content: {- |
  Module      :  ./CASL/Kif.hs
  Description :  Parsing lists of lists with SUMO .kif files
  Copyright   :  (c) T.Mossakowski, C.Maeder and Uni Bremen 2006
  License     :  GPLv2 or higher, see LICENSE.txt
  
  Maintainer  :  Christian.Maeder@dfki.de
  Stability   :  provisional
  Portability :  portable
  
  Parsing lists of lists with SUMO (suggested upper merged ontology) .kif files
  -}
  
  module CASL.Kif where
  
  import Common.Parsec
  import Text.ParserCombinators.Parsec
  import qualified Text.PrettyPrint.HughesPJ as Doc
  import Data.Char
  
  data StringKind = Quoted | KToken | QWord | AtWord deriving (Eq, Show)
  
  data ListOfList = Literal StringKind String | List [RangedLL]
       deriving Show
  
  data RangedLL = RangedLL SourcePos ListOfList SourcePos deriving Show
  
  -- | skip white spaces and comments for the lexer
  
  dq :: Char
  dq = '"'
  
  scanString :: CharParser st String
  scanString = enclosedBy
    (flat $ many $ fmap (: []) (satisfy (/= dq)) <|> tryString "\\\"")
    $ char dq
  
  isKTokenChar :: Char -> Bool
  isKTokenChar c = isPrint c && not (elem c "()\";" || isSpace c)
  
  scanLiteral :: CharParser st ListOfList
  scanLiteral = do
    s@(c : _) <- many1 (satisfy isKTokenChar)
    return $ Literal (if c == '?' then QWord else
                          if c == '@' then AtWord else KToken) s
  
  eolOrEof :: GenParser Char st ()
  eolOrEof = forget (oneOf "\n\r") <|> eof
  
  commentOut :: CharParser st ()
  commentOut = forget $ char ';' >> manyTill anyChar eolOrEof
  
  skip :: CharParser st [()]
  skip = many $ forget (satisfy isSpace) <|> commentOut
  
  lexem :: CharParser st a -> CharParser st a
  lexem = (<< skip)
  
  rangedLL :: CharParser st RangedLL
  rangedLL = do
    p <- getPosition
    l <- nestedList
    q <- getPosition
    skip
    return $ RangedLL p l q
  
  nestedList :: CharParser st ListOfList
  nestedList = do
      lexem $ char '('
      l <- many rangedLL
      char ')'
      return $ List l
   <|> fmap (Literal Quoted) scanString
   <|> scanLiteral
  
  kifProg :: CharParser st [RangedLL]
  kifProg = kifBasic << eof
  
  kifBasic :: CharParser st [RangedLL]
  kifBasic = skip >> many1 rangedLL
  
  ppRangedLL :: RangedLL -> Doc.Doc
  ppRangedLL (RangedLL _ l _) = ppListOfList l
  
  ppListOfList :: ListOfList -> Doc.Doc
  ppListOfList e = case e of
      Literal _ s -> Doc.text s
      List l -> Doc.parens $ Doc.fsep $ map ppRangedLL l
  
  kifParse :: String -> IO ()
  kifParse s = do
    e <- parseFromFile kifProg s
    case e of
      Left err -> print err
      Right l -> print $ Doc.vcat $ map ppRangedLL l
  