    -- ------------------------------------------------------------

    {- |
       Module     : Text.XML.HXT.Parser.XmlDTDParser
       Copyright  : Copyright (C) 2005 Uwe Schmidt
       License    : MIT

       Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
       Stability  : experimental
       Portability: portable

       Parsec parser for DTD declarations for ELEMENT, ATTLIST, ENTITY and NOTATION declarations

    -}

    -- ------------------------------------------------------------

    module Text.XML.HXT.Parser.XmlDTDParser
        ( parseXmlDTDdecl
        , parseXmlDTDdeclPart
        , parseXmlDTDEntityValue
        , elementDecl
        , attlistDecl
        , entityDecl
        , notationDecl
        )
    where

    import Data.Maybe

    import Text.ParserCombinators.Parsec
    import Text.ParserCombinators.Parsec.Pos

    import Text.XML.HXT.DOM.Interface

    import Text.XML.HXT.DOM.ShowXml
        ( xshow
        )
    import Text.XML.HXT.DOM.XmlNode                        ( mkDTDElem'
                                                           , mkText'
                                                           , mkError'
                                                           , isText
                                                           , isDTD
                                                           , getText
                                                           , getDTDPart
                                                           , getDTDAttrl
                                                           , getChildren
                                                           , setChildren
                                                           )
    import qualified Text.XML.HXT.Parser.XmlTokenParser    as XT

    import           Text.XML.HXT.Parser.XmlCharParser     ( XParser
                                                           , XPState(..)
                                                           , withoutNormNewline
                                                           )

    import qualified Text.XML.HXT.Parser.XmlCharParser     as XC
                                                           ( xmlSpaceChar )

    import qualified Text.XML.HXT.Parser.XmlDTDTokenParser as XD
                                                           ( dtdToken )

    -----------------------------------------------------------
    --
    -- all parsers dealing with whitespace will be redefined
    -- to handle parameter entity substitution

    type LocalState = (Int, [(Int, String, SourcePos)])

    type SParser a  = XParser LocalState a

    initialState    :: SourcePos -> XPState LocalState
    initialState p  = withoutNormNewline (0, [(0, sourceName p, p)])

    updateLocalState :: (LocalState -> LocalState) -> SParser ()
    updateLocalState upd
                    = updateState $ \ xps -> xps { xps_userState = upd $ xps_userState xps }

    pushPar         :: String -> SParser ()
    pushPar n       = do
                      p <- getPosition
                      updateLocalState (\ (i, s) -> (i+1, (i+1, n, p) : s))
                      setPosition ( newPos (sourceName p ++ " (line " ++ show (sourceLine p) ++ ", column " ++ show (sourceColumn p) ++ ") in content of parameter entity ref %" ++ n ++ ";") 1 1)

    popPar          :: SParser ()
    popPar          = do
                      oldPos <- getPos
                      updateLocalState pop
                      setPosition oldPos
                    where
                    pop (i, [(_, s, p)]) = (i+1, [(i+1, s, p)])     -- if param entity substitution is correctly implemented, this case does not occur
                    pop (i, _t:s)        = (i, s)
                    pop (_i, [])         = undefined                -- stack is never empty

    getParNo        :: SParser Int
    getParNo        = do
                      s <- getState
                      let (_i, (top, _n, _p) : _s) = xps_userState s
                      return top

    getPos          :: SParser SourcePos
    getPos          = do
                      s <- getState
                      let (_i, (_top, _n, p) : _s) = xps_userState s
                      return p

    delPE   :: SParser ()
    delPE   = do
              _ <- char '\0'
              return ()

    startPE :: SParser ()
    startPE
        = do
          try ( do
                delPE
                n <- many1 (satisfy (/= '\0'))
                delPE
                pushPar n
              )

    endPE   :: SParser ()
    endPE
        = do
          try (do
               delPE
               delPE
               popPar
              )

    inSamePE        :: SParser a -> SParser a
    inSamePE p
        = do
          i <- getParNo
          r <- p
          j <- getParNo
          if (i == j)
             then return r
             else fail $ "parameter entity contents does not fit into the structure of a DTD declarations"

    -- ------------------------------------------------------------

    xmlSpaceChar    :: SParser ()
    xmlSpaceChar    = ( XC.xmlSpaceChar
                        >>
                        return ()
                      )
                      <|>
                      startPE
                      <|>
                      endPE
                      <?> "white space"

    skipS           :: SParser ()
    skipS
        = skipMany1 xmlSpaceChar
          >>
          return ()

    skipS0          :: SParser ()
    skipS0
        = skipMany xmlSpaceChar
          >>
          return ()

    name            :: SParser XmlTree
    name
        = do
          n <- XT.name
          return (mkDTDElem' NAME [(a_name, n)] [])

    nmtoken         :: SParser XmlTree
    nmtoken
        = do
          n <- XT.nmtoken
          return (mkDTDElem' NAME [(a_name, n)] [])

    -- ------------------------------------------------------------
    --
    -- Element Type Declarations (3.2)

    elementDecl     :: SParser XmlTrees
    elementDecl
        = between (try $ string "<!ELEMENT") (char '>') elementDeclBody

    elementDeclBody :: SParser XmlTrees
    elementDeclBody
        = do
          skipS
          n <- XT.name
          skipS
          (al, cl) <- contentspec
          skipS0
          return [mkDTDElem' ELEMENT ((a_name, n) : al) cl]

    contentspec     :: SParser (Attributes, XmlTrees)
    contentspec
        = simplespec k_empty v_empty
          <|>
          simplespec k_any v_any
          <|>
          inSamePE mixed
          <|>
          inSamePE children
          <?> "content specification"
        where
        simplespec kw v
            = do
              _ <- XT.keyword kw
              return ([(a_type, v)], [])

    -- ------------------------------------------------------------
    --
    -- Element Content (3.2.1)

    children        :: SParser (Attributes, XmlTrees)
    children
        = ( do
            (al, cl) <- choiceOrSeq
            modifier <- optOrRep
            return ([(a_type, v_children)], [mkDTDElem' CONTENT (modifier ++ al) cl])
          )
          <?> "element content"

    optOrRep        :: SParser Attributes
    optOrRep
        = do
          m <- option "" (XT.mkList (oneOf "?*+"))
          return [(a_modifier, m)]

    choiceOrSeq     :: SParser (Attributes, XmlTrees)
    choiceOrSeq
        = inSamePE $
          do
          cl <- try ( do
                      lpar
                      choiceOrSeqBody
                    )
          rpar
          return cl

    choiceOrSeqBody :: SParser (Attributes, XmlTrees)
    choiceOrSeqBody
        = do
          cp1 <- cp
          choiceOrSeq1 cp1
        where
        choiceOrSeq1        :: XmlTree -> SParser (Attributes, XmlTrees)
        choiceOrSeq1 c1
            = ( do
                bar
                c2 <- cp
                cl <- many ( do
                             bar
                             cp
                           )
                return ([(a_kind, v_choice)], (c1 : c2 : cl))
              )
              <|>
              ( do
                cl <- many ( do
                             comma
                             cp
                           )
                return ([(a_kind, v_seq)], (c1 : cl))
              )
              <?> "sequence or choice"

    cp              :: SParser XmlTree
    cp
        = ( do
            n <- name
            m <- optOrRep
            return ( case m of
                     [(_, "")] -> n
                     _         -> mkDTDElem' CONTENT (m ++ [(a_kind, v_seq)]) [n]
                   )
          )
          <|>
          ( do
            (al, cl) <- choiceOrSeq
            m <- optOrRep
            return (mkDTDElem' CONTENT (m ++ al) cl)
          )

    -- ------------------------------------------------------------
    --
    -- Mixed Content (3.2.2)

    mixed           :: SParser (Attributes, XmlTrees)
    mixed
        = ( do
            _ <- try ( do
                       lpar
                       string k_pcdata
                     )
            nl <- many ( do
                         bar
                         name
                       )
            rpar
            if null nl
              then do
                   _ <- option ' ' (char '*')               -- (#PCDATA) or (#PCDATA)* , both are legal
                   return ( [ (a_type, v_pcdata) ]
                          , []
                          )
              else do
                   _ <- char '*' <?> "closing parent for mixed content (\")*\")"
                   return ( [ (a_type, v_mixed) ]
                          , [ mkDTDElem' CONTENT [ (a_modifier, "*")
                                                 , (a_kind, v_choice)
                                                 ] nl
                            ]
                          )
          )
          <?> "mixed content"

    -- ------------------------------------------------------------
    --
    -- Attribute-List Declarations (3.3)

    attlistDecl             :: SParser XmlTrees
    attlistDecl
        = between (try $ string "<!ATTLIST") (char '>') attlistDeclBody

    attlistDeclBody         :: SParser XmlTrees
    attlistDeclBody
        = do
          skipS
          n <- XT.name
          al <- many attDef
          skipS0
          return (map (mkDTree n) al)
        where
        mkDTree n' (al, cl)
            = mkDTDElem' ATTLIST ((a_name, n') : al) cl

    attDef          :: SParser (Attributes, XmlTrees)
    attDef
        = do
          n <- try ( do
                     skipS
                     XT.name
                   ) <?> "attribute name"
          skipS
          (t, cl) <- attType
          skipS
          d <- defaultDecl
          return (((a_value, n) : d) ++ t, cl)

    attType :: SParser (Attributes, XmlTrees)
    attType
        = tokenizedOrStringType
          <|>
          enumeration
          <|>
          notationType
          <?> "attribute type"

    tokenizedOrStringType   :: SParser (Attributes, XmlTrees)
    tokenizedOrStringType
        = do
          n <- choice $ map XT.keyword typl
          return ([(a_type, n)], [])
          where
          typl      = [ k_cdata
                      , k_idrefs
                      , k_idref
                      , k_id
                      , k_entity
                      , k_entities
                      , k_nmtokens
                      , k_nmtoken
                      ]

    enumeration     :: SParser (Attributes, XmlTrees)
    enumeration
        = do
          nl <- inSamePE (between lpar rpar (sepBy1 nmtoken bar))
          return ([(a_type, k_enumeration)], nl)

    notationType    :: SParser (Attributes, XmlTrees)
    notationType
        = do
          _ <- XT.keyword k_notation
          skipS
          nl <- inSamePE (between lpar rpar ( sepBy1 name bar ))
          return ([(a_type, k_notation)], nl)

    defaultDecl     :: SParser Attributes
    defaultDecl
        = ( do
            str <- try $ string k_required
            return [(a_kind, str)]
          )
          <|>
          ( do
            str <- try $ string k_implied
            return [(a_kind, str)]
          )
          <|>
          ( do
            l <- fixed
            v <- XT.attrValueT
            return ((a_default, xshow v) : l)
          )
          <?> "default declaration"
        where
        fixed = option [(a_kind, k_default)]
                ( do
                  _ <- try $ string k_fixed
                  skipS
                  return [(a_kind, k_fixed)]
                )

    -- ------------------------------------------------------------
    --
    -- Entity Declarations (4.2)

    entityDecl              :: SParser XmlTrees
    entityDecl
        = between ( try $ string "<!ENTITY" ) (char '>') entityDeclBody

    entityDeclBody          :: SParser XmlTrees
    entityDeclBody
        = do
          skipS
          ( peDecl
            <|>
            geDecl
            <?> "entity declaration" )      -- don't move the ) to the next line

    geDecl                  :: SParser XmlTrees
    geDecl
        = do
          n <- XT.name
          skipS
          (al, cl) <- entityDef
          skipS0
          return [mkDTDElem' ENTITY ((a_name, n) : al) cl]

    entityDef               :: SParser (Attributes, XmlTrees)
    entityDef
        = entityValue
          <|>
          externalEntitySpec

    externalEntitySpec      :: SParser (Attributes, XmlTrees)
    externalEntitySpec
        = do
          al <- externalID
          nd <- option [] nDataDecl
          return ((al ++ nd), [])

    peDecl                  :: SParser XmlTrees
    peDecl
        = do
          _ <- char '%'
          skipS
          n <- XT.name
          skipS
          (al, cs) <- peDef
          skipS0
          return [mkDTDElem' PENTITY ((a_name, n) : al) cs]

    peDef                   :: SParser (Attributes, XmlTrees)
    peDef
        = entityValue
          <|>
          do
          al <- externalID
          return (al, [])

    entityValue     :: XParser s (Attributes, XmlTrees)
    entityValue
        = do
          v <- XT.entityValueT
          return ([], v)

    -- ------------------------------------------------------------
    --
    -- External Entities (4.2.2)

    externalID      :: SParser Attributes
    externalID
        = ( do
            _ <- XT.keyword k_system
            skipS
            lit <- XT.systemLiteral
            return [(k_system, lit)]
          )
          <|>
          ( do
            _ <- XT.keyword k_public
            skipS
            pl <- XT.pubidLiteral
            skipS
            sl <- XT.systemLiteral
            return [ (k_system, sl)
                   , (k_public, pl) ]
          )
          <?> "SYSTEM or PUBLIC declaration"

    nDataDecl       :: SParser Attributes
    nDataDecl
        = do
          _ <- try ( do
                     skipS
                     XT.keyword k_ndata
                   )
          skipS
          n <- XT.name
          return [(k_ndata, n)]

    -- ------------------------------------------------------------
    --
    -- Notation Declarations (4.7)

    notationDecl            :: SParser XmlTrees
    notationDecl
        = between (try $ string "<!NOTATION") (char '>' <?> "notation declaration") notationDeclBody

    notationDeclBody        :: SParser XmlTrees
    notationDeclBody
        = do
          skipS
          n <- XT.name
          skipS
          eid <- ( try externalID
                   <|>
                   publicID
                 )
          skipS0
          return [mkDTDElem' NOTATION ((a_name, n) : eid) []]

    publicID                :: SParser Attributes
    publicID
        = do
          _ <- XT.keyword k_public
          skipS
          l <- XT.pubidLiteral
          return [(k_public, l)]

    -- ------------------------------------------------------------

    condSectCondBody        :: SParser XmlTrees
    condSectCondBody
        = do
          skipS0
          n <- XT.name
          skipS0
          let n' = stringToUpper n
          if n' `elem` [k_include, k_ignore]
             then return [mkText'  n']
             else fail $ "INCLUDE or IGNORE expected in conditional section"

    -- ------------------------------------------------------------

    separator       :: Char -> SParser ()
    separator c
        = do
          _ <- try ( do
                     skipS0
                     char c
                   )
          skipS0
          <?> [c]

    bar, comma, lpar, rpar  :: SParser ()

    bar     = separator '|'
    comma   = separator ','

    lpar
        = do
          _ <- char '('
          skipS0

    rpar
        = do
          skipS0
          _ <- char ')'
          return ()

    -- ------------------------------------------------------------

    parseXmlDTDEntityValue  :: XmlTree -> XmlTrees
    parseXmlDTDEntityValue t        -- (NTree (XDTD PEREF al) cl)
        | isDTDPEref t
            = ( either
                ( (:[]) . mkError' c_err . (++ "\n") . show )
                ( \cl' -> if null cl'
                             then [mkText' ""]
                             else cl'
                )
                .
                runParser parser (withoutNormNewline ()) source
              ) input
        | otherwise
            = []
        where
        al     = fromMaybe [] . getDTDAttrl $ t
        cl     = getChildren t
        parser = XT.entityTokensT "%&"
        source = "value of parameter entity " ++ lookupDef "" a_peref al
        input  = xshow cl

    {-
    parseXmlDTDEntityValue n
        = error ("parseXmlDTDEntityValue: illegal argument: " ++ show n)
    -}
    -- ------------------------------------------------------------

    parseXmlDTDdeclPart     :: XmlTree -> XmlTrees
    parseXmlDTDdeclPart t           -- @(NTree (XDTD PEREF al) cl)
        | isDTDPEref t
            = ( (:[])
                .
                either
                   ( mkError' c_err . (++ "\n") . show )
                   ( flip setChildren $ t ) -- \ cl' -> setChildren cl' t)
                .
                runParser parser (withoutNormNewline ()) source
              ) input
        | otherwise
            = []
        where
        al     = fromMaybe [] . getDTDAttrl $ t
        cl     = getChildren t
        parser = many XD.dtdToken
        source = "value of parameter entity " ++ lookupDef "" a_peref al
        input  = xshow cl

    {-
    parseXmlDTDdeclPart n
        = error ("parseXmlDTDdeclPart: illegal argument: " ++ show n)
    -}
    -- ------------------------------------------------------------
    --
    -- the main entry point

    -- | parse a tokenized DTD declaration represented by a DTD tree.
    -- The content is represented by the children containing text and parameter entity reference nodes.
    -- The parameter entity reference nodes contain their value in the children list, consisting of text
    -- and possibly again parameter entity reference nodes. This structure is build by the parameter entity
    -- substitution.
    -- Output is again a DTD declaration node, but this time completely parsed and ready for further DTD processing

    parseXmlDTDdecl :: XmlTree -> XmlTrees
    parseXmlDTDdecl t       -- (NTree (XDTD dtdElem al) cl)
        | isDTD t
            = ( either ((:[]) . mkError' c_err . (++ "\n") . show) id
                .
                runParser parser (initialState pos) source
              ) input
        | otherwise
            = []
        where
        dtdElem = fromJust     . getDTDPart  $ t
        al      = fromMaybe [] . getDTDAttrl $ t
        cl      = getChildren t
        dtdParsers
            = [ (ELEMENT,  elementDeclBody)
              , (ATTLIST,  attlistDeclBody)
              , (ENTITY,   entityDeclBody)
              , (NOTATION, notationDeclBody)
              , (CONDSECT, condSectCondBody)
              ]
        source = lookupDef "DTD declaration" a_source al
        line   = lookupDef "1" a_line al
        column = lookupDef "1" a_column al
        pos    = newPos source (read line) (read column)
        parser = do
                 setPosition pos
                 res <- fromJust . lookup dtdElem $ dtdParsers
                 eof
                 return res
        input  = concatMap collectText cl
    {-
    parseXmlDTDdecl _
        = []
    -}

    -- | collect the tokens of a DTD declaration body and build
    -- a string ready for parsing. The structure of the parameter entity values
    -- is stll stored in this string for checking the scope of the parameter values

    collectText     :: XmlTree -> String

    collectText t
        | isText t
            = fromMaybe "" . getText $ t
        | isDTDPEref t
            = prefixPe ++ concatMap collectText (getChildren t) ++ suffixPe
        | otherwise
            = ""
        where
        al       = fromMaybe [] . getDTDAttrl $ t
        delPe    = "\0"
        prefixPe = delPe ++ lookupDef "???" a_peref al ++ delPe
        suffixPe = delPe ++ delPe

    {-

    collectText (NTree n _)
        | isXTextNode n
            = textOfXNode n

    collectText (NTree (XDTD PEREF al) cl)
        = prefixPe ++ concatMap collectText cl ++ suffixPe
          where
          delPe    = "\0"
          prefixPe = delPe ++ lookupDef "???" a_peref al ++ delPe
          suffixPe = delPe ++ delPe

    collectText _
        = ""
    -}

    isDTDPEref      :: XmlTree -> Bool
    isDTDPEref
        = maybe False (== PEREF) . getDTDPart

    -- ------------------------------------------------------------