{- |
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 (StringKind -> StringKind -> Bool
(StringKind -> StringKind -> Bool)
-> (StringKind -> StringKind -> Bool) -> Eq StringKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StringKind -> StringKind -> Bool
$c/= :: StringKind -> StringKind -> Bool
== :: StringKind -> StringKind -> Bool
$c== :: StringKind -> StringKind -> Bool
Eq, Int -> StringKind -> ShowS
[StringKind] -> ShowS
StringKind -> String
(Int -> StringKind -> ShowS)
-> (StringKind -> String)
-> ([StringKind] -> ShowS)
-> Show StringKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StringKind] -> ShowS
$cshowList :: [StringKind] -> ShowS
show :: StringKind -> String
$cshow :: StringKind -> String
showsPrec :: Int -> StringKind -> ShowS
$cshowsPrec :: Int -> StringKind -> ShowS
Show)

data ListOfList = Literal StringKind String | List [RangedLL]
     deriving Int -> ListOfList -> ShowS
[ListOfList] -> ShowS
ListOfList -> String
(Int -> ListOfList -> ShowS)
-> (ListOfList -> String)
-> ([ListOfList] -> ShowS)
-> Show ListOfList
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ListOfList] -> ShowS
$cshowList :: [ListOfList] -> ShowS
show :: ListOfList -> String
$cshow :: ListOfList -> String
showsPrec :: Int -> ListOfList -> ShowS
$cshowsPrec :: Int -> ListOfList -> ShowS
Show

data RangedLL = RangedLL SourcePos ListOfList SourcePos deriving Int -> RangedLL -> ShowS
[RangedLL] -> ShowS
RangedLL -> String
(Int -> RangedLL -> ShowS)
-> (RangedLL -> String) -> ([RangedLL] -> ShowS) -> Show RangedLL
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RangedLL] -> ShowS
$cshowList :: [RangedLL] -> ShowS
show :: RangedLL -> String
$cshow :: RangedLL -> String
showsPrec :: Int -> RangedLL -> ShowS
$cshowsPrec :: Int -> RangedLL -> ShowS
Show

-- | skip white spaces and comments for the lexer

dq :: Char
dq :: Char
dq = '"'

scanString :: CharParser st String
scanString :: CharParser st String
scanString = CharParser st String
-> ParsecT String st Identity Char -> CharParser st String
forall (m :: * -> *) a. Monad m => m [a] -> m a -> m [a]
enclosedBy
  (ParsecT String st Identity [String] -> CharParser st String
forall (m :: * -> *) a. Monad m => m [[a]] -> m [a]
flat (ParsecT String st Identity [String] -> CharParser st String)
-> ParsecT String st Identity [String] -> CharParser st String
forall a b. (a -> b) -> a -> b
$ CharParser st String -> ParsecT String st Identity [String]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (CharParser st String -> ParsecT String st Identity [String])
-> CharParser st String -> ParsecT String st Identity [String]
forall a b. (a -> b) -> a -> b
$ (Char -> String)
-> ParsecT String st Identity Char -> CharParser st String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char -> ShowS
forall a. a -> [a] -> [a]
: []) ((Char -> Bool) -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
dq)) CharParser st String
-> CharParser st String -> CharParser st String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> CharParser st String
forall st. String -> CharParser st String
tryString "\\\"")
  (ParsecT String st Identity Char -> CharParser st String)
-> ParsecT String st Identity Char -> CharParser st String
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
dq

isKTokenChar :: Char -> Bool
isKTokenChar :: Char -> Bool
isKTokenChar c :: Char
c = Char -> Bool
isPrint Char
c Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c "()\";" Bool -> Bool -> Bool
|| Char -> Bool
isSpace Char
c)

scanLiteral :: CharParser st ListOfList
scanLiteral :: CharParser st ListOfList
scanLiteral = do
  s :: String
s@(c :: Char
c : _) <- ParsecT String st Identity Char
-> ParsecT String st Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ((Char -> Bool) -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isKTokenChar)
  ListOfList -> CharParser st ListOfList
forall (m :: * -> *) a. Monad m => a -> m a
return (ListOfList -> CharParser st ListOfList)
-> ListOfList -> CharParser st ListOfList
forall a b. (a -> b) -> a -> b
$ StringKind -> String -> ListOfList
Literal (if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '?' then StringKind
QWord else
                        if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '@' then StringKind
AtWord else StringKind
KToken) String
s

eolOrEof :: GenParser Char st ()
eolOrEof :: GenParser Char st ()
eolOrEof = ParsecT String st Identity Char -> GenParser Char st ()
forall (m :: * -> *) a. Monad m => m a -> m ()
forget (String -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf "\n\r") GenParser Char st ()
-> GenParser Char st () -> GenParser Char st ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> GenParser Char st ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof

commentOut :: CharParser st ()
commentOut :: CharParser st ()
commentOut = ParsecT String st Identity String -> CharParser st ()
forall (m :: * -> *) a. Monad m => m a -> m ()
forget (ParsecT String st Identity String -> CharParser st ())
-> ParsecT String st Identity String -> CharParser st ()
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char ';' ParsecT String st Identity Char
-> ParsecT String st Identity String
-> ParsecT String st Identity String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String st Identity Char
-> CharParser st () -> ParsecT String st Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar CharParser st ()
forall st. GenParser Char st ()
eolOrEof

skip :: CharParser st [()]
skip :: CharParser st [()]
skip = ParsecT String st Identity () -> CharParser st [()]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String st Identity () -> CharParser st [()])
-> ParsecT String st Identity () -> CharParser st [()]
forall a b. (a -> b) -> a -> b
$ ParsecT String st Identity Char -> ParsecT String st Identity ()
forall (m :: * -> *) a. Monad m => m a -> m ()
forget ((Char -> Bool) -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isSpace) ParsecT String st Identity ()
-> ParsecT String st Identity () -> ParsecT String st Identity ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String st Identity ()
forall st. GenParser Char st ()
commentOut

lexem :: CharParser st a -> CharParser st a
lexem :: CharParser st a -> CharParser st a
lexem = (CharParser st a
-> ParsecT String st Identity [()] -> CharParser st a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m a
<< ParsecT String st Identity [()]
forall st. CharParser st [()]
skip)

rangedLL :: CharParser st RangedLL
rangedLL :: CharParser st RangedLL
rangedLL = do
  SourcePos
p <- ParsecT String st Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
  ListOfList
l <- CharParser st ListOfList
forall st. CharParser st ListOfList
nestedList
  SourcePos
q <- ParsecT String st Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
  CharParser st [()]
forall st. CharParser st [()]
skip
  RangedLL -> CharParser st RangedLL
forall (m :: * -> *) a. Monad m => a -> m a
return (RangedLL -> CharParser st RangedLL)
-> RangedLL -> CharParser st RangedLL
forall a b. (a -> b) -> a -> b
$ SourcePos -> ListOfList -> SourcePos -> RangedLL
RangedLL SourcePos
p ListOfList
l SourcePos
q

nestedList :: CharParser st ListOfList
nestedList :: CharParser st ListOfList
nestedList = do
    CharParser st Char -> CharParser st Char
forall st a. CharParser st a -> CharParser st a
lexem (CharParser st Char -> CharParser st Char)
-> CharParser st Char -> CharParser st Char
forall a b. (a -> b) -> a -> b
$ Char -> CharParser st Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '('
    [RangedLL]
l <- ParsecT String st Identity RangedLL
-> ParsecT String st Identity [RangedLL]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String st Identity RangedLL
forall st. CharParser st RangedLL
rangedLL
    Char -> CharParser st Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char ')'
    ListOfList -> CharParser st ListOfList
forall (m :: * -> *) a. Monad m => a -> m a
return (ListOfList -> CharParser st ListOfList)
-> ListOfList -> CharParser st ListOfList
forall a b. (a -> b) -> a -> b
$ [RangedLL] -> ListOfList
List [RangedLL]
l
 CharParser st ListOfList
-> CharParser st ListOfList -> CharParser st ListOfList
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (String -> ListOfList)
-> ParsecT String st Identity String -> CharParser st ListOfList
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (StringKind -> String -> ListOfList
Literal StringKind
Quoted) ParsecT String st Identity String
forall st. CharParser st String
scanString
 CharParser st ListOfList
-> CharParser st ListOfList -> CharParser st ListOfList
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> CharParser st ListOfList
forall st. CharParser st ListOfList
scanLiteral

kifProg :: CharParser st [RangedLL]
kifProg :: CharParser st [RangedLL]
kifProg = CharParser st [RangedLL]
forall st. CharParser st [RangedLL]
kifBasic CharParser st [RangedLL]
-> ParsecT String st Identity () -> CharParser st [RangedLL]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m a
<< ParsecT String st Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof

kifBasic :: CharParser st [RangedLL]
kifBasic :: CharParser st [RangedLL]
kifBasic = CharParser st [()]
forall st. CharParser st [()]
skip CharParser st [()]
-> CharParser st [RangedLL] -> CharParser st [RangedLL]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String st Identity RangedLL -> CharParser st [RangedLL]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String st Identity RangedLL
forall st. CharParser st RangedLL
rangedLL

ppRangedLL :: RangedLL -> Doc.Doc
ppRangedLL :: RangedLL -> Doc
ppRangedLL (RangedLL _ l :: ListOfList
l _) = ListOfList -> Doc
ppListOfList ListOfList
l

ppListOfList :: ListOfList -> Doc.Doc
ppListOfList :: ListOfList -> Doc
ppListOfList e :: ListOfList
e = case ListOfList
e of
    Literal _ s :: String
s -> String -> Doc
Doc.text String
s
    List l :: [RangedLL]
l -> Doc -> Doc
Doc.parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
Doc.fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (RangedLL -> Doc) -> [RangedLL] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map RangedLL -> Doc
ppRangedLL [RangedLL]
l

kifParse :: String -> IO ()
kifParse :: String -> IO ()
kifParse s :: String
s = do
  Either ParseError [RangedLL]
e <- Parser [RangedLL] -> String -> IO (Either ParseError [RangedLL])
forall a. Parser a -> String -> IO (Either ParseError a)
parseFromFile Parser [RangedLL]
forall st. CharParser st [RangedLL]
kifProg String
s
  case Either ParseError [RangedLL]
e of
    Left err :: ParseError
err -> ParseError -> IO ()
forall a. Show a => a -> IO ()
print ParseError
err
    Right l :: [RangedLL]
l -> Doc -> IO ()
forall a. Show a => a -> IO ()
print (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
Doc.vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (RangedLL -> Doc) -> [RangedLL] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map RangedLL -> Doc
ppRangedLL [RangedLL]
l