{- |
Module : ./Taxonomy/OntoParser.hs
Copyright : (c) DFKI GmbH, Uni Bremen 2004-2009
License : GPLv2 or higher, see LICENSE.txt
Maintainer : Christian.Maeder@dfki.de
Stability : provisional
Portability : non-portable (imports Taxonomy.MMiSSOntology)
a function that takes a filename as argument and parses that file for
mmisslatex ontology commands. If it succeeds gives back the whole ontology
structure along with a list of warnings (if class, object or relation
declarations are missing).
-}
module Taxonomy.OntoParser
( parseMMiSSOntologyFile
, ClassDecl (..)
, ObjectDecl (..)
, RelationDecl (..)
, BaseRelationDecl (..)
, RelationTypeDecl (..)
, ObjectLink (..)
, Frag (..)
) where
import Control.Monad
import Data.Maybe
import Taxonomy.MMiSSOntology
data ClassDecl = ClassDecl {
className :: String,
classText :: String,
super :: Maybe String
} deriving Show
data ObjectDecl = ObjectDecl {
objName :: String,
objectText :: String,
instanceOf :: String
} deriving Show
data RelationDecl = RelationDecl {
multiplicities :: Maybe String,
relName :: String,
relationText :: String,
source :: String,
target :: String
} deriving Show
data BaseRelationDecl = BaseRelationDecl {
baseMultiplicities :: Maybe String,
baseRelName :: String,
baseRelationText :: String,
superRel :: Maybe String
} deriving Show
data RelationTypeDecl = RelationTypeDecl {
nameOfRel :: String,
nameOfSource :: String,
nameOfTarget :: String
} deriving Show
data ObjectLink = ObjectLink {
sourceObj :: String,
targetObj :: String,
linkRelation :: String
} deriving Show
data Frag =
ClassDeclFrag ClassDecl
| ObjectDeclFrag ObjectDecl
| RelationDeclFrag RelationDecl
| BaseRelationDeclFrag BaseRelationDecl
| RelationTypeDeclFrag RelationTypeDecl
| ObjectLinkFrag ObjectLink
deriving Show
parseMMiSSOntologyFile :: SourceName -> IO (WithError MMiSSOntology)
parseMMiSSOntologyFile s =
do peFs <- parseFromFile ontoDoc s
return $ case peFs of
Right fs -> generateOntology (emptyMMiSSOntology "Test" AutoInsert) fs
Left err -> hasError (show err)
-- | main function that collects fragments
ontoDoc :: GenParser Char st [Frag]
ontoDoc = do
skip
fs <- many (frag <?> "Fragment")
eof
return $ catMaybes fs
generateOntology :: MMiSSOntology -> [Frag] -> WithError MMiSSOntology
generateOntology onto frs = case frs of
[] -> hasValue onto
f : fs -> let
weOnto = case f of
ClassDeclFrag (ClassDecl name deflTxt sup) ->
insertClass onto name deflTxt (maybeToList sup) Nothing
ObjectDeclFrag (ObjectDecl name deflTxt instOf) ->
insertObject onto name deflTxt instOf
RelationDeclFrag (RelationDecl cardValue name deflTxt srcCl tgtCl) ->
let wOnto = insertBaseRelation onto name deflTxt Nothing cardValue
in weither (const wOnto)
( \ o -> insertRelationType o name srcCl tgtCl)
wOnto
BaseRelationDeclFrag (BaseRelationDecl cardValue name deflTxt supRel) ->
insertBaseRelation onto name deflTxt supRel cardValue
RelationTypeDeclFrag (RelationTypeDecl name src tgt) ->
insertRelationType onto name src tgt
ObjectLinkFrag (ObjectLink src tgt name) ->
insertLink onto src tgt name
in weither (const weOnto) (`generateOntology` fs) weOnto
-- | parse fragments
frag :: GenParser Char st (Maybe Frag)
frag = do
char '\\'
f <- fmap Just ontologyElement <|> (anyChar >> return Nothing)
skip
return f
skip :: GenParser Char st String
skip = many $ comment <|> noneOf "\\%"
comment :: GenParser Char st Char
comment = char '%' >> manyTill anyChar newline >> return '%'
braced :: GenParser Char st a -> GenParser Char st a
braced p = do
b <- between (char '{') (char '}') p
spaces
return b
-- | maybe empty
value :: GenParser Char st String
value = fmap concat $ many
$ many1 (noneOf "{}\\")
<|> fmap (\ v -> '{' : v ++ "}") (braced value)
<|> liftM2 (\ c1 c2 -> [c1, c2]) (char '\\') anyChar
ontologyElement :: GenParser Char st Frag
ontologyElement = declClassP <|> declObjectP <|> relationNameP
<|> declRelationP <|> declBaseRelationP <|> declRelTypeP <|> objRelationP
nameDefl :: GenParser Char st (String, String)
nameDefl = do
s1 <- braced idParser
s2 <- braced value
return (s1, s2)
cardP :: GenParser Char st (Maybe String)
cardP = do
s <- braced idParser
return $ if null s then Nothing else Just s
nameDeflOpt :: GenParser Char st (String, String, Maybe String)
nameDeflOpt = do
(s1, s2) <- nameDefl
s3 <- option "" $ braced idParser
return (s1, s2, if null s3 then Nothing else Just s3)
nameSrcTgt :: GenParser Char st (String, String, String)
nameSrcTgt = do
s1 <- braced idParser
s2 <- braced idParser
s3 <- braced idParser
return (s1, s2, s3)
keyWord :: String -> GenParser Char st ()
keyWord s = do
try (string s >> notFollowedBy alphaNum)
spaces
declClassP :: GenParser Char st Frag
declClassP = do
keyWord "DeclClass" <|> keyWord "Class"
(name, deflTxt, supClassVal) <- nameDeflOpt
return $ ClassDeclFrag $ ClassDecl name deflTxt supClassVal
declObjectP :: GenParser Char st Frag
declObjectP = do
keyWord "DeclObject" <|> keyWord "Object"
(name, deflTxt) <- nameDefl
instOf <- braced idParser
return $ ObjectDeclFrag $ ObjectDecl name deflTxt instOf
declRelationP :: GenParser Char st Frag
declRelationP = do
keyWord "DeclRelation"
cardVal <- cardP
name <- braced idParser
(deflTxt, srcCl, tgtCl) <- nameSrcTgt
return $ RelationDeclFrag $ RelationDecl cardVal name deflTxt srcCl tgtCl
declBaseRelationP :: GenParser Char st Frag
declBaseRelationP = do
keyWord "DeclRel" <|> keyWord "Relation"
optional $ between (char '[') (char ']') idParser
cardVal <- cardP
(name, deflTxt, supRel) <- nameDeflOpt
return $ BaseRelationDeclFrag $ BaseRelationDecl cardVal name deflTxt supRel
relationNameP :: GenParser Char st Frag
relationNameP = do
keyWord "RelationName"
name <- braced idParser
deflTxt <- braced idParser
return $ BaseRelationDeclFrag $ BaseRelationDecl Nothing name deflTxt Nothing
declRelTypeP :: GenParser Char st Frag
declRelTypeP = do
keyWord "RelType"
(name, src, tgt) <- nameSrcTgt
return $ RelationTypeDeclFrag $ RelationTypeDecl name src tgt
objRelationP :: GenParser Char st Frag
objRelationP = do
keyWord "Relate"
(name, src, tgt) <- nameSrcTgt
return $ ObjectLinkFrag $ ObjectLink src tgt name
idParser :: GenParser Char st String
idParser = many (noneOf "{}[]")