content: {- |
  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
  import Text.ParserCombinators.Parsec
  
  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 "{}[]")
  