content: {- |
  Module      :  ./OWL2/Parse.hs
  Description :  Manchester syntax parser for OWL 2
  Copyright   :  (c) DFKI GmbH, Uni Bremen 2007-2010
  License     :  GPLv2 or higher, see LICENSE.txt
  
  Maintainer  :  Christian.Maeder@dfki.de
  Stability   :  provisional
  Portability :  portable
  
  Contains    :  Parser for the Manchester Syntax into Abstract Syntax of OWL 2
  
  References  :  <http://www.w3.org/TR/2009/NOTE-owl2-manchester-syntax-20091027/>
  -}
  
  module OWL2.Parse where
  
  import OWL2.AS
  import OWL2.Symbols
  import OWL2.Keywords
  import OWL2.ColonKeywords
  
  import Common.Keywords
  import Common.IRI
  import Common.Lexer
  import Common.Parsec
  import Common.AnnoParser (commentLine)
  import Common.Token (criticalKeywords)
  import Common.Utils (nubOrd)
  import qualified Common.IRI as IRI
  import qualified Common.GlobalAnnotations as GA (PrefixMap)
  
  import Text.ParserCombinators.Parsec
  import Control.Monad (liftM2)
  import Data.Char
  import qualified Data.Map as Map
  import Data.Maybe (isJust)
  
  characters :: [Character]
  characters = [minBound .. maxBound]
  
  -- | OWL and CASL structured keywords including 'andS' and 'notS'
  owlKeywords :: [String]
  owlKeywords = notS : stringS : map show entityTypes
    ++ map show characters ++ keywords ++ criticalKeywords
  
  ncNameStart :: Char -> Bool
  ncNameStart c = isAlpha c || c == '_'
  
  -- | rfc3987 plus '+' from scheme (scheme does not allow the dots)
  ncNameChar :: Char -> Bool
  ncNameChar c = isAlphaNum c || elem c ".+-_\183"
  
  prefix :: CharParser st String
  prefix = satisfy ncNameStart <:> many (satisfy ncNameChar)
  
  iunreserved :: Char -> Bool
  iunreserved c = isAlphaNum c || elem c "-._~" || ord c >= 160 && ord c <= 55295
  
  -- maybe lower case hex-digits should be illegal
  pctEncoded :: CharParser st String
  pctEncoded = char '%' <:> hexDigit <:> single hexDigit
  
  {- comma and parens are removed here
     but would cause no problems for full IRIs within angle brackets -}
  subDelims :: Char -> Bool
  subDelims c = elem c "!$&'*+;="
  
  iunreservedSubDelims :: String -> CharParser st Char
  iunreservedSubDelims cs =
      satisfy $ \ c -> iunreserved c || subDelims c || elem c cs
  
  iunreservedPctEncodedSubDelims :: String -> CharParser st String
  iunreservedPctEncodedSubDelims cs =
      single (iunreservedSubDelims cs) <|> pctEncoded
  
  ipChar :: CharParser st String
  ipChar = iunreservedPctEncodedSubDelims ":@"
  
  ifragment :: CharParser st String
  ifragment = flat $ many (ipChar <|> single (char '/' <|> char '?'))
  
  iquery :: CharParser st String
  iquery = ifragment -- ignore iprivate
  
  iregName :: CharParser st String
  iregName = flat $ many $ iunreservedPctEncodedSubDelims ""
  
  iuserinfo :: CharParser st String
  iuserinfo = flat $ many $ iunreservedPctEncodedSubDelims ":"
  
  -- | parse zero or at most n consecutive arguments
  atMost :: Int -> GenParser tok st a -> GenParser tok st [a]
  atMost n p = if n <= 0 then return [] else
       p <:> atMost (n - 1) p <|> return []
  
  -- | parse at least one but at most n conse
  atMost1 :: Int -> GenParser tok st a -> GenParser tok st [a]
  atMost1 n p = p <:> atMost (n - 1) p
  
  decOctet :: CharParser st String
  decOctet = atMost 3 digit
    `checkWith` \ s -> let v = value 10 s in v <= 255 &&
                               (if v == 0 then s == "0" else take 1 s /= "0")
  
  iPv4Adress :: CharParser st String
  iPv4Adress = decOctet <++> string "."
    <++> decOctet <++> string "."
    <++> decOctet <++> string "."
    <++> decOctet
  
  ihost :: CharParser st String
  ihost = iregName <|> iPv4Adress -- or ipLiteral
  
  port :: CharParser st String
  port = many digit
  
  iauthority :: CharParser st String
  iauthority = optionL (try $ iuserinfo <++> string "@") <++> ihost
      <++> optionL (char ':' <:> port)
  
  isegment :: CharParser st String
  isegment = flat $ many ipChar
  
  isegmentNz :: CharParser st String
  isegmentNz = flat $ many1 ipChar
  
  ipathAbempty :: CharParser st String
  ipathAbempty = flat $ many (char '/' <:> isegment)
  
  ipathAbsolute :: CharParser st String
  ipathAbsolute = char '/' <:> optionL (isegmentNz <++> ipathAbempty)
  
  {- within abbreviated IRIs only ipath-noscheme should be used
     that excludes colons via isegment-nz-nc -}
  ipathRootless :: CharParser st String
  ipathRootless = isegmentNz <++> ipathAbempty
  
  iauthorityWithPath :: CharParser st String
  iauthorityWithPath = tryString "//" <++> iauthority <++> ipathAbempty
  
  optQueryOrFrag :: CharParser st String
  optQueryOrFrag = optionL (char '?' <:> iquery)
    <++> optionL (char '#' <:> ifragment)
  
  -- | covers irelative-part (therefore we omit curie)
  ihierPart :: CharParser st String
  ihierPart =
    iauthorityWithPath <|> ipathAbsolute <|> ipathRootless
  
  hierPartWithOpts :: CharParser st String
  hierPartWithOpts = (char '#' <:> ifragment) <|> ihierPart <++> optQueryOrFrag
  
  skips :: CharParser st a -> CharParser st a
  skips = (<< skipMany
          (forget space <|> forget commentLine <|> nestCommentOut <?> ""))
  
  
  uriQ :: CharParser st IRI
  -- uriQ = fullIri <|> abbrIri
  uriQ = Common.IRI.compoundIriCurie
  
  fullIri :: CharParser st IRI
  fullIri = angles iriParser
  
  uriP :: CharParser st IRI
  uriP = skips $ try $ do
    colonM <- optionMaybe . try . lookAhead $ char ':'
    checkWithUsing (\i -> "keyword \"" ++ showIRI i ++ "\"") uriQ $ \ q -> let p = prefixName q in
      if not (isAbbrev q) || isJust colonM then True
      else if null p then notElem (iFragment q) owlKeywords
      else notElem p $ map (takeWhile (/= ':'))
          $ colonKeywords
          ++ [ show d ++ e | d <- equivOrDisjointL, e <- [classesC, propertiesC]]
  
  extEntity :: CharParser st ExtEntityType
  extEntity =
      fmap EntityType entityType
     <|> option AnyEntity (pkeyword "Prefix" >> return PrefixO)
  
  symbItem :: GenParser Char st SymbItems
  symbItem = do
      ext <- extEntity
      i <- uriP
      return $ SymbItems ext [i]
  
  symbItems :: GenParser Char st SymbItems
  symbItems = do
      ext <- extEntity
      iris <- symbs
      return $ SymbItems ext iris
  
  -- | parse a comma separated list of uris
  symbs :: GenParser Char st [IRI]
  symbs = uriP >>= \ u -> do
      commaP `followedWith` uriP
      us <- symbs
      return $ u : us
    <|> return [u]
  
  -- | parse a possibly kinded list of comma separated symbol pairs
  symbMapItems :: GenParser Char st SymbMapItems
  symbMapItems = do
    ext <- extEntity
    iris <- symbPairs
    return $ SymbMapItems ext iris
  
  -- | parse a comma separated list of uri pairs
  symbPairs :: GenParser Char st [(IRI, Maybe IRI)]
  symbPairs = uriPair >>= \ u -> do
      commaP `followedWith` uriP
      us <- symbPairs
      return $ u : us
    <|> return [u]
  
  uriPair :: GenParser Char st (IRI, Maybe IRI)
  uriPair = uriP >>= \ u -> do
      pToken $ toKey mapsTo
      u2 <- uriP
      return (u, Just u2)
    <|> return (u, Nothing)
  
  datatypeUri :: CharParser st IRI
  datatypeUri = fmap mkIRI (choice $ map keyword datatypeKeys) <|> uriP
  
  optSign :: CharParser st Bool
  optSign = option False $ fmap (== '-') (oneOf "+-")
  
  postDecimal :: CharParser st NNInt
  postDecimal = char '.' >> option zeroNNInt getNNInt
  
  getNNInt :: CharParser st NNInt
  getNNInt = fmap (NNInt . map digitToInt) getNumber
  
  intLit :: CharParser st IntLit
  intLit = do
    b <- optSign
    n <- getNNInt
    return $ negNNInt b n
  
  decimalLit :: CharParser st DecLit
  decimalLit = liftM2 DecLit intLit $ option zeroNNInt postDecimal
  
  floatDecimal :: CharParser st DecLit
  floatDecimal = do
      n <- getNNInt
      f <- option zeroNNInt postDecimal
      return $ DecLit (negNNInt False n) f
     <|> do
      n <- postDecimal
      return $ DecLit zeroInt n
  
  floatingPointLit :: CharParser st FloatLit
  floatingPointLit = do
     b <- optSign
     d <- floatDecimal
     i <- option zeroInt (oneOf "eE" >> intLit)
     optionMaybe $ oneOf "fF"
     return $ FloatLit (negDec b d) i
  
  languageTag :: CharParser st String
  languageTag = atMost1 4 letter
    <++> flat (many $ char '-' <:> atMost1 8 alphaNum)
  
  rmQuotes :: String -> String
  rmQuotes s = case s of
    _ : tl@(_ : _) -> init tl
    _ -> error "rmQuotes"
  
  stringLiteral :: CharParser st Literal
  stringLiteral = do
    s <- fmap rmQuotes stringLit
    do
        string cTypeS
        d <- datatypeUri
        return $ Literal s $ Typed d
      <|> do
          string asP
          t <- skips $ optionMaybe languageTag
          return $ Literal s $ Untyped t
      <|> skips (return $ Literal s $ Typed $ (mkIRI stringS) {prefixName = "xsd"} )
  
  literal :: CharParser st Literal
  literal = do
      f <- skips $ try floatingPointLit
           <|> fmap decToFloat decimalLit
      return $ NumberLit f
    <|> stringLiteral
  
  -- * description
  
  owlClassUri :: CharParser st IRI
  owlClassUri = uriP
  
  individualUri :: CharParser st IRI
  individualUri = uriP
  
  individual :: CharParser st Individual
  individual = do
      i <- individualUri
      return $ if prefixName i == "_" then i {isBlankNode = True}
                                      else i
  
  skipChar :: Char -> CharParser st ()
  skipChar = forget . skips . char
  
  parensP :: CharParser st a -> CharParser st a
  parensP = between (skipChar '(') (skipChar ')')
  
  bracesP :: CharParser st a -> CharParser st a
  bracesP = between (skipChar '{') (skipChar '}')
  
  bracketsP :: CharParser st a -> CharParser st a
  bracketsP = between (skipChar '[') (skipChar ']')
  
  commaP :: CharParser st ()
  commaP = forget $ skipChar ','
  
  sepByComma :: CharParser st a -> CharParser st [a]
  sepByComma p = sepBy1 p commaP
  
  -- | plain string parser with skip
  pkeyword :: String -> CharParser st ()
  pkeyword s = forget . keywordNotFollowedBy s $ alphaNum <|> char '/'
  
  keywordNotFollowedBy :: String -> CharParser st Char -> CharParser st String
  keywordNotFollowedBy s c = skips $ try $ string s << notFollowedBy c
  
  -- | keyword not followed by any alphanum
  keyword :: String -> CharParser st String
  keyword s = keywordNotFollowedBy s (alphaNum <|> char '_')
  
  -- base OWLClass excluded
  atomic :: CharParser st ClassExpression
  atomic = parensP description
    <|> fmap ObjectOneOf (bracesP $ sepByComma individual)
  
  objectPropertyExpr :: CharParser st ObjectPropertyExpression
  objectPropertyExpr = do
      keyword inverseS
      fmap ObjectInverseOf objectPropertyExpr
    <|> fmap ObjectProp uriP
  
  -- creating the facet-value pairs
  facetValuePair :: CharParser st (ConstrainingFacet, RestrictionValue)
  facetValuePair = do
    df <- choice $ map (\ f -> keyword (showFacet f) >> return f)
        [ LENGTH
        , MINLENGTH
        , MAXLENGTH
        , PATTERN
        , TOTALDIGITS
        , FRACTIONDIGITS ] ++ map
        (\ f -> keywordNotFollowedBy (showFacet f) (oneOf "<>=")
                >> return f)
        [ MININCLUSIVE
        , MINEXCLUSIVE
        , MAXINCLUSIVE
        , MAXEXCLUSIVE ]
    rv <- literal
    return (facetToIRI df, rv)
  
  -- it returns DataType Datatype or DatatypeRestriction Datatype [facetValuePair]
  dataRangeRestriction :: CharParser st DataRange
  dataRangeRestriction = do
    e <- datatypeUri
    option (DataType e []) $ fmap (DataType e) $ bracketsP
      $ sepByComma facetValuePair
  
  dataConjunct :: CharParser st DataRange
  dataConjunct = fmap (mkDataJunction IntersectionOf)
        $ sepBy1 dataPrimary $ keyword andS
  
  dataRange :: CharParser st DataRange
  dataRange = fmap (mkDataJunction UnionOf)
        $ sepBy1 dataConjunct $ keyword orS
  
  dataPrimary :: CharParser st DataRange
  dataPrimary = do
      keyword notS
      fmap DataComplementOf dataPrimary
     <|> fmap DataOneOf (bracesP $ sepByComma literal)
     <|> dataRangeRestriction
  
  mkDataJunction :: JunctionType -> [DataRange] -> DataRange
  mkDataJunction ty ds = case nubOrd ds of
    [] -> error "mkDataJunction"
    [x] -> x
    ns -> DataJunction ty ns
  
  -- parses "some" or "only"
  someOrOnly :: CharParser st QuantifierType
  someOrOnly = choice
    $ map (\ f -> keyword (showQuantifierType f) >> return f)
      [AllValuesFrom, SomeValuesFrom]
  
  -- locates the keywords "min" "max" "exact" and their argument
  card :: CharParser st (CardinalityType, Int)
  card = do
    c <- choice $ map (\ f -> keywordNotFollowedBy (showCardinalityType f) letter
                              >> return f)
               [MinCardinality, MaxCardinality, ExactCardinality]
    n <- skips getNumber
    return (c, value 10 n)
  
  -- tries to parse either a IRI or a literal
  individualOrConstant :: CharParser st (Either Individual Literal)
  individualOrConstant = fmap Right literal <|> fmap Left individual
  
  {- | applies the previous one to a list separated by commas
      (the list needs to be all of the same type, of course) -}
  individualOrConstantList :: CharParser st (Either [Individual] [Literal])
  individualOrConstantList = do
      ioc <- individualOrConstant
      case ioc of
        Left u -> fmap (Left . (u :)) $ optionL
          $ commaP >> sepByComma individual
        Right c -> fmap (Right . (c :)) $ optionL
          $ commaP >> sepByComma literal
  
  primaryOrDataRange :: CharParser st (Either ClassExpression DataRange)
  primaryOrDataRange = do
    ns <- many $ keyword notS  -- allows multiple not before primary
    ed <- do
        u <- datatypeUri
        fmap Left (restrictionAny $ ObjectProp u)
          <|> fmap (Right . DataType u)
              (bracketsP $ sepByComma facetValuePair)
          <|> return (if isDatatypeKey u
                then Right $ DataType u []
                else Left $ Expression u) -- could still be a datatypeUri
      <|> do
        e <- bracesP individualOrConstantList
        return $ case e of
          Left us -> Left $ ObjectOneOf us
          Right cs -> Right $ DataOneOf cs
      <|> fmap Left restrictionOrAtomic
    return $ if even (length ns) then ed else
      case ed of
        Left d -> Left $ ObjectComplementOf d
        Right d -> Right $ DataComplementOf d
  
  mkObjectJunction :: JunctionType -> [ClassExpression] -> ClassExpression
  mkObjectJunction ty ds = case nubOrd ds of
    [] -> error "mkObjectJunction"
    [x] -> x
    ns -> ObjectJunction ty ns
  
  restrictionAny :: ObjectPropertyExpression -> CharParser st ClassExpression
  restrictionAny opExpr = do
        keyword valueS
        e <- individualOrConstant
        case e of
          Left u -> return $ ObjectHasValue opExpr u
          Right c -> case opExpr of
            ObjectProp dpExpr -> return $ DataHasValue dpExpr c
            _ -> unexpected "literal"
      <|> do
        keyword selfS
        return $ ObjectHasSelf opExpr
      <|> do -- sugar
        keyword onlysomeS
        ds <- bracketsP $ sepByComma description
        let as = map (ObjectValuesFrom SomeValuesFrom opExpr) ds
            o = ObjectValuesFrom AllValuesFrom opExpr
                $ mkObjectJunction UnionOf ds
        return $ mkObjectJunction IntersectionOf $ o : as
      <|> do -- sugar
        keyword hasS
        iu <- individual
        return $ ObjectValuesFrom SomeValuesFrom opExpr $ ObjectOneOf [iu]
      <|> do
        v <- someOrOnly
        pr <- primaryOrDataRange
        case pr of
          Left p -> return $ ObjectValuesFrom v opExpr p
          Right r -> case opExpr of
            ObjectProp dpExpr -> return $ DataValuesFrom v [dpExpr] r
            _ -> unexpected $ "dataRange after " ++ showQuantifierType v
      <|> do
        (c, n) <- card
        mp <- optionMaybe primaryOrDataRange
        case mp of
           Nothing -> return $ ObjectCardinality $ Cardinality c n opExpr Nothing
           Just pr -> case pr of
             Left p ->
               return $ ObjectCardinality $ Cardinality c n opExpr $ Just p
             Right r -> case opExpr of
               ObjectProp dpExpr ->
                 return $ DataCardinality $ Cardinality c n dpExpr $ Just r
               _ -> unexpected $ "dataRange after " ++ showCardinalityType c
  
  restriction :: CharParser st ClassExpression
  restriction = objectPropertyExpr >>= restrictionAny
  
  restrictionOrAtomic :: CharParser st ClassExpression
  restrictionOrAtomic = do
      opExpr <- objectPropertyExpr
      restrictionAny opExpr <|> case opExpr of
         ObjectProp euri -> return $ Expression euri
         _ -> unexpected "inverse object property"
    <|> atomic
  
  optNot :: (a -> a) -> CharParser st a -> CharParser st a
  optNot f p = (keyword notS >> fmap f p) <|> p
  
  primary :: CharParser st ClassExpression
  primary = optNot ObjectComplementOf restrictionOrAtomic
  
  conjunction :: CharParser st ClassExpression
  conjunction = do
      curi <- fmap Expression $ try (owlClassUri << keyword thatS)
      rs <- sepBy1 (optNot ObjectComplementOf restriction) $ keyword andS
      return $ mkObjectJunction IntersectionOf $ curi : rs
    <|> fmap (mkObjectJunction IntersectionOf)
        (sepBy1 primary $ keyword andS)
  
  description :: CharParser st ClassExpression
  description =
    fmap (mkObjectJunction UnionOf) $ sepBy1 conjunction $ keyword orS
  
  entityType :: CharParser st EntityType
  entityType = choice $ map (\ f -> keyword (show f) >> return f)
    entityTypes
  
  {- | same as annotation Target in Manchester Syntax,
        named annotation Value in Abstract Syntax -}
  annotationValue :: CharParser st AnnotationValue
  annotationValue = do
      l <- literal
      return $ AnnValLit l
    <|> do
      i <- individual
      return $ AnnValue i
  
  equivOrDisjointL :: [EquivOrDisjoint]
  equivOrDisjointL = [Equivalent, Disjoint]
  
  equivOrDisjoint :: CharParser st EquivOrDisjoint
  equivOrDisjoint = choice
    $ map (\ f -> pkeyword (showEquivOrDisjoint f) >> return f)
    equivOrDisjointL
  
  subPropertyKey :: CharParser st ()
  subPropertyKey = pkeyword subPropertyOfC
  
  characterKey :: CharParser st ()
  characterKey = pkeyword characteristicsC
  
  sameOrDifferent :: CharParser st SameOrDifferent
  sameOrDifferent = choice
    $ map (\ f -> pkeyword (showSameOrDifferent f) >> return f)
    [Same, Different]
  
  sameOrDifferentIndu :: CharParser st SameOrDifferent
  sameOrDifferentIndu = (pkeyword sameIndividualC >> return Same)
      <|> (pkeyword differentIndividualsC >> return Different)
  
  equivOrDisjointKeyword :: String -> CharParser st EquivOrDisjoint
  equivOrDisjointKeyword ext = choice
    $ map (\ f -> pkeyword (show f ++ ext) >> return f)
    equivOrDisjointL
  
  objectPropertyCharacter :: CharParser st Character
  objectPropertyCharacter =
    choice $ map (\ f -> keyword (show f) >> return f) characters
  
  domainOrRange :: CharParser st DomainOrRange
  domainOrRange = choice
    $ map (\ f -> pkeyword (showDomainOrRange f) >> return f)
    [ADomain, ARange]
  
  nsEntry :: CharParser st (String, IRI)
  nsEntry = do
      pkeyword prefixC
      p <- skips (option "" prefix << char ':')
      i <- skips fullIri
      return (p, i)
    <|> do
      pkeyword namespaceC
      p <- skips prefix
      i <- skips fullIri
      return (p, i)
  
  importEntry :: CharParser st IRI
  importEntry = pkeyword importC >> uriP
  
  convertPrefixMap :: GA.PrefixMap -> Map.Map String String
  convertPrefixMap = Map.map $ IRI.iriToStringUnsecure . IRI.setAngles False
  