-- | A non-validating XML parser.  For the input grammar, see
--   <http://www.w3.org/TR/REC-xml>.
module Text.XML.HaXml.ParseLazy
  (
  -- * Parse a whole document
    xmlParse  -- , xmlParse'
  -- * Parse just a DTD
  , dtdParse  -- , dtdParse'
  -- * Parse a partial document
  , xmlParseWith
  -- * Individual parsers for use with /xmlParseWith/ and module SAX
  , document, element, content
  , comment, chardata
  , reference, doctypedecl
  , processinginstruction
  , elemtag, qname, name, tok
  , elemOpenTag, elemCloseTag
  , emptySTs, XParser
  -- * These general utility functions don't belong here
  , fst3, snd3, thd3
  ) where

-- An XML parser, written using a slightly extended version of the
-- Hutton/Meijer parser combinators.  The input is tokenised internally
-- by the lexer xmlLex.  Whilst parsing, we gather a symbol
-- table of entity references.  PERefs must be defined before use, so we
-- expand their uses as we encounter them, forcing the remainder of the
-- input to be re-lexed and re-parsed.  GERefs are simply stored for
-- later retrieval.

import Prelude hiding (either,maybe,sequence,catch)
import qualified Prelude (either)
import Data.Maybe hiding (maybe)
import Data.List (intercalate)
import Data.Char (isSpace,isDigit,isHexDigit)
import Control.Monad hiding (sequence)
import Numeric (readDec,readHex)
--import Control.Exception (catch)

import Text.XML.HaXml.Types
import Text.XML.HaXml.Namespaces
import Text.XML.HaXml.Posn
import Text.XML.HaXml.Lex
import Text.ParserCombinators.Poly.StateLazy

import System.FilePath (combine, dropFileName)


#if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
    ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
import System.IO.Unsafe (unsafePerformIO)
#elif defined(__GLASGOW_HASKELL__)
import IOExts (unsafePerformIO)
#elif defined(__NHC__)
import IOExtras (unsafePerformIO)
#elif defined(__HBC__)
import UnsafePerformIO
#endif

--  #define DEBUG

#if defined(DEBUG)
#  if ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 502 ) || \
      ( defined(__NHC__) && __NHC__ > 114 ) || defined(__HUGS__)
import Debug.Trace(trace)
#  elif defined(__GLASGOW_HASKELL__)
import IOExts(trace)
#  elif defined(__NHC__) || defined(__HBC__)
import NonStdTrace
#  endif
v `debug` s = trace s v
#else
a
v debug :: forall a. a -> String -> a
`debug` String
_ = a
v
#endif
debug :: a -> String -> a


-- | To parse a whole document, @xmlParse file content@ takes a filename
--   (for generating error reports) and the string content of that file.
--   A parse error causes program failure, with message to stderr.
xmlParse :: String -> String -> Document Posn

{-
-- | To parse a whole document, @xmlParse' file content@ takes a filename
--   (for generating error reports) and the string content of that file.
--   Any parse error message is passed back to the caller through the
--   @Either@ type.
xmlParse' :: String -> String -> Either String (Document Posn)
-}

-- | To parse just a DTD, @dtdParse file content@ takes a filename
--   (for generating error reports) and the string content of that
--   file.  If no DTD was found, you get @Nothing@ rather than an error.
--   However, if a DTD is found but contains errors, the program crashes.
dtdParse  :: String -> String -> Maybe DocTypeDecl

{-
-- | To parse just a DTD, @dtdParse' file content@ takes a filename
--   (for generating error reports) and the string content of that
--   file.  If no DTD was found, you get @Right Nothing@.
--   If a DTD was found but contains errors, you get a @Left message@.
dtdParse' :: String -> String -> Either String (Maybe DocTypeDecl)

xmlParse' name inp = xmlParse name inp `catch` (Left . show)
dtdParse' name inp = dtdParse name inp `catch` (Left . show)
-}

xmlParse :: String -> String -> Document Posn
xmlParse  String
name  = (Document Posn, SymTabs, [(Posn, TokenT)]) -> Document Posn
forall a b c. (a, b, c) -> a
fst3 ((Document Posn, SymTabs, [(Posn, TokenT)]) -> Document Posn)
-> (String -> (Document Posn, SymTabs, [(Posn, TokenT)]))
-> String
-> Document Posn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser SymTabs (Posn, TokenT) (Document Posn)
-> SymTabs
-> [(Posn, TokenT)]
-> (Document Posn, SymTabs, [(Posn, TokenT)])
forall s t a. Parser s t a -> s -> [t] -> (a, s, [t])
runParser (Parser SymTabs (Posn, TokenT) (Document Posn)
-> Parser SymTabs (Posn, TokenT) (Document Posn)
forall a. XParser a -> XParser a
toEOF Parser SymTabs (Posn, TokenT) (Document Posn)
document) SymTabs
emptySTs ([(Posn, TokenT)] -> (Document Posn, SymTabs, [(Posn, TokenT)]))
-> (String -> [(Posn, TokenT)])
-> String
-> (Document Posn, SymTabs, [(Posn, TokenT)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [(Posn, TokenT)]
xmlLex String
name
dtdParse :: String -> String -> Maybe DocTypeDecl
dtdParse  String
name  = (Maybe DocTypeDecl, SymTabs, [(Posn, TokenT)]) -> Maybe DocTypeDecl
forall a b c. (a, b, c) -> a
fst3 ((Maybe DocTypeDecl, SymTabs, [(Posn, TokenT)])
 -> Maybe DocTypeDecl)
-> (String -> (Maybe DocTypeDecl, SymTabs, [(Posn, TokenT)]))
-> String
-> Maybe DocTypeDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser SymTabs (Posn, TokenT) (Maybe DocTypeDecl)
-> SymTabs
-> [(Posn, TokenT)]
-> (Maybe DocTypeDecl, SymTabs, [(Posn, TokenT)])
forall s t a. Parser s t a -> s -> [t] -> (a, s, [t])
runParser Parser SymTabs (Posn, TokenT) (Maybe DocTypeDecl)
justDTD  SymTabs
emptySTs ([(Posn, TokenT)]
 -> (Maybe DocTypeDecl, SymTabs, [(Posn, TokenT)]))
-> (String -> [(Posn, TokenT)])
-> String
-> (Maybe DocTypeDecl, SymTabs, [(Posn, TokenT)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [(Posn, TokenT)]
xmlLex String
name

toEOF :: XParser a -> XParser a
toEOF :: forall a. XParser a -> XParser a
toEOF = XParser a -> XParser a
forall a. a -> a
id      -- there are other possible implementations...

-- | To parse a partial document, e.g. from an XML-based stream protocol,
--   where you may later want to get more document elements from the same
--   stream.  Arguments are: a parser for the item you want, and the
--   already-lexed input to parse from.  Returns the item you wanted
--   (or an error message), plus the remainder of the input.
xmlParseWith :: XParser a -> [(Posn,TokenT)]
                -> (Either String a, [(Posn,TokenT)])
xmlParseWith :: forall a.
XParser a
-> [(Posn, TokenT)] -> (Either String a, [(Posn, TokenT)])
xmlParseWith XParser a
p = (\(a
v,SymTabs
_,[(Posn, TokenT)]
s)->(a -> Either String a
forall a b. b -> Either a b
Right a
v,[(Posn, TokenT)]
s)) ((a, SymTabs, [(Posn, TokenT)])
 -> (Either String a, [(Posn, TokenT)]))
-> ([(Posn, TokenT)] -> (a, SymTabs, [(Posn, TokenT)]))
-> [(Posn, TokenT)]
-> (Either String a, [(Posn, TokenT)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XParser a
-> SymTabs -> [(Posn, TokenT)] -> (a, SymTabs, [(Posn, TokenT)])
forall s t a. Parser s t a -> s -> [t] -> (a, s, [t])
runParser XParser a
p SymTabs
emptySTs


---- Symbol table stuff ----

type SymTabs = (SymTab PEDef, SymTab EntityDef)

-- | Some empty symbol tables for GE and PE references.
emptySTs :: SymTabs
emptySTs :: SymTabs
emptySTs = (SymTab PEDef
forall a. SymTab a
emptyST, SymTab EntityDef
forall a. SymTab a
emptyST)

addPE :: String -> PEDef -> SymTabs -> SymTabs
addPE :: String -> PEDef -> SymTabs -> SymTabs
addPE String
n PEDef
v (SymTab PEDef
pe,SymTab EntityDef
ge) = (String -> PEDef -> SymTab PEDef -> SymTab PEDef
forall a. String -> a -> SymTab a -> SymTab a
addST String
n PEDef
v SymTab PEDef
pe, SymTab EntityDef
ge)

addGE :: String -> EntityDef -> SymTabs -> SymTabs
addGE :: String -> EntityDef -> SymTabs -> SymTabs
addGE String
n EntityDef
v (SymTab PEDef
pe,SymTab EntityDef
ge) = let newge :: SymTab EntityDef
newge = String -> EntityDef -> SymTab EntityDef -> SymTab EntityDef
forall a. String -> a -> SymTab a -> SymTab a
addST String
n EntityDef
v SymTab EntityDef
ge in SymTab EntityDef
newge SymTab EntityDef -> SymTabs -> SymTabs
forall a b. a -> b -> b
`seq` (SymTab PEDef
pe, SymTab EntityDef
newge)

lookupPE :: String -> SymTabs -> Maybe PEDef
lookupPE :: String -> SymTabs -> Maybe PEDef
lookupPE String
s (SymTab PEDef
pe,SymTab EntityDef
_ge) = String -> SymTab PEDef -> Maybe PEDef
forall a. String -> SymTab a -> Maybe a
lookupST String
s SymTab PEDef
pe

flattenEV :: EntityValue -> String
flattenEV :: EntityValue -> String
flattenEV (EntityValue [EV]
evs) = (EV -> String) -> [EV] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap EV -> String
flatten [EV]
evs
  where
    flatten :: EV -> String
flatten (EVString String
s)          = String
s
    flatten (EVRef (RefEntity String
r)) = String
"&" String -> String -> String
forall a. [a] -> [a] -> [a]
++String
rString -> String -> String
forall a. [a] -> [a] -> [a]
++String
";"
    flatten (EVRef (RefChar CharRef
r))   = String
"&#"String -> String -> String
forall a. [a] -> [a] -> [a]
++CharRef -> String
forall a. Show a => a -> String
show CharRef
rString -> String -> String
forall a. [a] -> [a] -> [a]
++String
";"
 -- flatten (EVPERef n)           = "%" ++n++";"


---- Misc ----
fst3 :: (a,b,c) -> a
snd3 :: (a,b,c) -> b
thd3 :: (a,b,c) -> c

fst3 :: forall a b c. (a, b, c) -> a
fst3 (a
a,b
_,c
_) = a
a
snd3 :: forall a b c. (a, b, c) -> b
snd3 (a
_,b
a,c
_) = b
a
thd3 :: forall a b c. (a, b, c) -> c
thd3 (a
_,b
_,c
a) = c
a


---- Auxiliary Parsing Functions ----

-- | XParser is just a specialisation of the PolyStateLazy parser.
type XParser a = Parser SymTabs (Posn,TokenT) a

-- | Return the next token from the input only if it matches the given token.
tok :: TokenT -> XParser TokenT
tok :: TokenT -> XParser TokenT
tok TokenT
t = do (p,t') <- Parser SymTabs (Posn, TokenT) (Posn, TokenT)
forall s t. Parser s t t
next
           case t' of TokError String
_    -> (String -> XParser TokenT)
-> String -> Posn -> TokenT -> XParser TokenT
forall a.
(String -> XParser a) -> String -> Posn -> TokenT -> XParser a
report String -> XParser TokenT
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad (TokenT -> String
forall a. Show a => a -> String
show TokenT
t) Posn
p TokenT
t'
                      TokenT
_ | TokenT
t'TokenT -> TokenT -> Bool
forall a. Eq a => a -> a -> Bool
==TokenT
t     -> TokenT -> XParser TokenT
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return TokenT
t
                        | Bool
otherwise -> (String -> XParser TokenT)
-> String -> Posn -> TokenT -> XParser TokenT
forall a.
(String -> XParser a) -> String -> Posn -> TokenT -> XParser a
report String -> XParser TokenT
forall a. String -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (TokenT -> String
forall a. Show a => a -> String
show TokenT
t) Posn
p TokenT
t'
nottok :: [TokenT] -> XParser TokenT
nottok :: [TokenT] -> XParser TokenT
nottok [TokenT]
ts = do (p,t) <- Parser SymTabs (Posn, TokenT) (Posn, TokenT)
forall s t. Parser s t t
next
               if t`elem`ts then report fail ("no "++show t) p t
                            else return t

-- | Return a qualified name (although the namespace qualification is not
--   processed here; this is merely to get the correct type).
qname :: XParser QName
qname :: XParser QName
qname = do
    (p,tok) <- Parser SymTabs (Posn, TokenT) (Posn, TokenT)
forall s t. Parser s t t
next
    case tok of
        TokName String
s  -> case Char -> String -> [String]
split Char
':' String
s of
            [String
one] -> QName -> XParser QName
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> XParser QName) -> QName -> XParser QName
forall a b. (a -> b) -> a -> b
$ String -> QName
N String
s
            [String
ns,String
elem_name] -> QName -> XParser QName
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> XParser QName) -> QName -> XParser QName
forall a b. (a -> b) -> a -> b
$ Namespace -> String -> QName
QN (String -> String -> Namespace
Namespace String
ns String
"") String
elem_name
            [String]
_ -> (String -> XParser QName)
-> String -> Posn -> TokenT -> XParser QName
forall a.
(String -> XParser a) -> String -> Posn -> TokenT -> XParser a
report String -> XParser QName
forall a. String -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"a name" Posn
p TokenT
tok
        TokError String
_ -> (String -> XParser QName)
-> String -> Posn -> TokenT -> XParser QName
forall a.
(String -> XParser a) -> String -> Posn -> TokenT -> XParser a
report String -> XParser QName
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad String
"a name" Posn
p TokenT
tok
        TokenT
_          -> (String -> XParser QName)
-> String -> Posn -> TokenT -> XParser QName
forall a.
(String -> XParser a) -> String -> Posn -> TokenT -> XParser a
report String -> XParser QName
forall a. String -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"a name" Posn
p TokenT
tok
    where
    split :: Char -> String -> [String]
    split :: Char -> String -> [String]
split Char
c String
xs = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
c) String
xs of
        (String
ls, String
"") -> [String
ls]
        (String
ls, Char
x:String
rs) -> String
ls String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Char -> String -> [String]
split Char
c String
rs

-- | Return just a name, e.g. element name, attribute name.
name :: XParser Name
name :: XParser String
name = do (p,tok) <- Parser SymTabs (Posn, TokenT) (Posn, TokenT)
forall s t. Parser s t t
next
          case tok of
            TokName String
s  -> String -> XParser String
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return String
s
            TokError String
_ -> (String -> XParser String)
-> String -> Posn -> TokenT -> XParser String
forall a.
(String -> XParser a) -> String -> Posn -> TokenT -> XParser a
report String -> XParser String
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad String
"a name" Posn
p TokenT
tok
            TokenT
_          -> (String -> XParser String)
-> String -> Posn -> TokenT -> XParser String
forall a.
(String -> XParser a) -> String -> Posn -> TokenT -> XParser a
report String -> XParser String
forall a. String -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"a name" Posn
p TokenT
tok

string, freetext :: XParser String
string :: XParser String
string   = do (p,t) <- Parser SymTabs (Posn, TokenT) (Posn, TokenT)
forall s t. Parser s t t
next
              case t of TokName String
s -> String -> XParser String
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return String
s
                        TokenT
_         -> (String -> XParser String)
-> String -> Posn -> TokenT -> XParser String
forall a.
(String -> XParser a) -> String -> Posn -> TokenT -> XParser a
report String -> XParser String
forall a. String -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"text" Posn
p TokenT
t
freetext :: XParser String
freetext = do (p,t) <- Parser SymTabs (Posn, TokenT) (Posn, TokenT)
forall s t. Parser s t t
next
              case t of TokFreeText String
s -> String -> XParser String
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return String
s
                        TokenT
_             -> (String -> XParser String)
-> String -> Posn -> TokenT -> XParser String
forall a.
(String -> XParser a) -> String -> Posn -> TokenT -> XParser a
report String -> XParser String
forall a. String -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"text" Posn
p TokenT
t

maybe :: XParser a -> XParser (Maybe a)
maybe :: forall a. XParser a -> XParser (Maybe a)
maybe XParser a
p =
    (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a)
-> XParser a -> Parser SymTabs (Posn, TokenT) (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XParser a
p) Parser SymTabs (Posn, TokenT) (Maybe a)
-> Parser SymTabs (Posn, TokenT) (Maybe a)
-> Parser SymTabs (Posn, TokenT) (Maybe a)
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail`
    Maybe a -> Parser SymTabs (Posn, TokenT) (Maybe a)
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

either :: XParser a -> XParser b -> XParser (Either a b)
either :: forall a b. XParser a -> XParser b -> XParser (Either a b)
either XParser a
p XParser b
q =
    (a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b)
-> XParser a -> Parser SymTabs (Posn, TokenT) (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XParser a
p) Parser SymTabs (Posn, TokenT) (Either a b)
-> Parser SymTabs (Posn, TokenT) (Either a b)
-> Parser SymTabs (Posn, TokenT) (Either a b)
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail`
    (b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b)
-> XParser b -> Parser SymTabs (Posn, TokenT) (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XParser b
q)

word :: String -> XParser ()
word :: String -> XParser ()
word String
s = do { x <- Parser SymTabs (Posn, TokenT) (Posn, TokenT)
forall s t. Parser s t t
next
            ; case x of
                (Posn
_p,TokName String
n)     | String
sString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
n -> () -> XParser ()
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                (Posn
_p,TokFreeText String
n) | String
sString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
n -> () -> XParser ()
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                ( Posn
p,t :: TokenT
t@(TokError String
_)) -> (String -> XParser ()) -> String -> Posn -> TokenT -> XParser ()
forall a.
(String -> XParser a) -> String -> Posn -> TokenT -> XParser a
report String -> XParser ()
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad (String -> String
forall a. Show a => a -> String
show String
s) Posn
p TokenT
t
                ( Posn
p,TokenT
t) -> (String -> XParser ()) -> String -> Posn -> TokenT -> XParser ()
forall a.
(String -> XParser a) -> String -> Posn -> TokenT -> XParser a
report String -> XParser ()
forall a. String -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> String
forall a. Show a => a -> String
show String
s) Posn
p TokenT
t
            }

posn :: XParser Posn
posn :: XParser Posn
posn = do { x@(p,_) <- Parser SymTabs (Posn, TokenT) (Posn, TokenT)
forall s t. Parser s t t
next
          ; reparse [x]
          ; return p
          }

nmtoken :: XParser NmToken
nmtoken :: XParser String
nmtoken = XParser String
string XParser String -> XParser String -> XParser String
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail` XParser String
freetext

failP, failBadP :: String -> XParser a
failP :: forall a. String -> Parser SymTabs (Posn, TokenT) a
failP String
msg = do { p <- XParser Posn
posn; fail (msg++"\n    at "++show p) }
failBadP :: forall a. String -> Parser SymTabs (Posn, TokenT) a
failBadP String
msg = do { p <- XParser Posn
posn; failBad (msg++"\n    at "++show p) }

report :: (String->XParser a) -> String -> Posn -> TokenT -> XParser a
report :: forall a.
(String -> XParser a) -> String -> Posn -> TokenT -> XParser a
report String -> XParser a
fail String
expect Posn
p TokenT
t = String -> XParser a
fail (String
"Expected "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
expectString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" but found "String -> String -> String
forall a. [a] -> [a] -> [a]
++TokenT -> String
forall a. Show a => a -> String
show TokenT
t
                               String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n  in "String -> String -> String
forall a. [a] -> [a] -> [a]
++Posn -> String
forall a. Show a => a -> String
show Posn
p)

adjustErrP :: XParser a -> (String->String) -> XParser a
XParser a
p adjustErrP :: forall a. XParser a -> (String -> String) -> XParser a
`adjustErrP` String -> String
f = XParser a
p XParser a -> XParser a -> XParser a
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail` do pn <- XParser Posn
posn
                                 (p `adjustErr` f) `adjustErr` (++show pn)

peRef :: XParser a -> XParser a
peRef :: forall a. XParser a -> XParser a
peRef XParser a
p =
    XParser a
p XParser a -> XParser a -> XParser a
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail`
    do pn <- XParser Posn
posn
       n <- pereference
       tr <- stQuery (lookupPE n) `debug` ("Looking up %"++n)
       case tr of
           Just (PEDefEntityValue EntityValue
ev) ->
                      do [(Posn, TokenT)] -> XParser ()
forall t s. [t] -> Parser s t ()
reparse (Posn -> String -> [(Posn, TokenT)]
xmlReLex (String -> Maybe Posn -> Posn
posInNewCxt (String
"macro %"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nString -> String -> String
forall a. [a] -> [a] -> [a]
++String
";")
                                                        (Posn -> Maybe Posn
forall a. a -> Maybe a
Just Posn
pn))
                                           (EntityValue -> String
flattenEV EntityValue
ev))
                               XParser () -> String -> XParser ()
forall a. a -> String -> a
`debug` (String
"  defn:  "String -> String -> String
forall a. [a] -> [a] -> [a]
++EntityValue -> String
flattenEV EntityValue
ev)
                         XParser a -> XParser a
forall a. XParser a -> XParser a
peRef XParser a
p
           Just (PEDefExternalID (PUBLIC PubidLiteral
_ (SystemLiteral String
f))) ->
                      do let f' :: String
f' = String -> String -> String
combine (String -> String
dropFileName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Posn -> String
posnFilename Posn
pn) String
f
                             val :: String
val = IO String -> String
forall a. IO a -> a
unsafePerformIO (String -> IO String
readFile String
f')
                         [(Posn, TokenT)] -> XParser ()
forall t s. [t] -> Parser s t ()
reparse (Posn -> String -> [(Posn, TokenT)]
xmlReLex (String -> Maybe Posn -> Posn
posInNewCxt String
f'
                                                        (Posn -> Maybe Posn
forall a. a -> Maybe a
Just Posn
pn)) String
val)
                               XParser () -> String -> XParser ()
forall a. a -> String -> a
`debug` (String
"  reading from file "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
f')
                         XParser a -> XParser a
forall a. XParser a -> XParser a
peRef XParser a
p
           Just (PEDefExternalID (SYSTEM (SystemLiteral String
f))) ->
                      do let f' :: String
f' = String -> String -> String
combine (String -> String
dropFileName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Posn -> String
posnFilename Posn
pn) String
f
                             val :: String
val = IO String -> String
forall a. IO a -> a
unsafePerformIO (String -> IO String
readFile String
f')
                         [(Posn, TokenT)] -> XParser ()
forall t s. [t] -> Parser s t ()
reparse (Posn -> String -> [(Posn, TokenT)]
xmlReLex (String -> Maybe Posn -> Posn
posInNewCxt String
f'
                                                        (Posn -> Maybe Posn
forall a. a -> Maybe a
Just Posn
pn)) String
val)
                               XParser () -> String -> XParser ()
forall a. a -> String -> a
`debug` (String
"  reading from file "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
f')
                         XParser a -> XParser a
forall a. XParser a -> XParser a
peRef XParser a
p
           Maybe PEDef
Nothing -> String -> XParser a
forall a. String -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"PEReference use before definition: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"%"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nString -> String -> String
forall a. [a] -> [a] -> [a]
++String
";"
                           String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n    at "String -> String -> String
forall a. [a] -> [a] -> [a]
++Posn -> String
forall a. Show a => a -> String
show Posn
pn)

blank :: XParser a -> XParser a
blank :: forall a. XParser a -> XParser a
blank XParser a
p =
    XParser a
p XParser a -> XParser a -> XParser a
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail`
    do n <- XParser String
pereference
       tr <- stQuery (lookupPE n) `debug` ("Looking up %"++n++" (is blank?)")
       case tr of
           Just (PEDefEntityValue EntityValue
ev)
                    | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace (EntityValue -> String
flattenEV EntityValue
ev)  ->
                            do XParser a -> XParser a
forall a. XParser a -> XParser a
blank XParser a
p XParser a -> String -> XParser a
forall a. a -> String -> a
`debug` String
"Empty macro definition"
           Just PEDef
_  -> String -> XParser a
forall a. String -> Parser SymTabs (Posn, TokenT) a
failP (String
"expected a blank PERef macro: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"%"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nString -> String -> String
forall a. [a] -> [a] -> [a]
++String
";")
           Maybe PEDef
Nothing -> String -> XParser a
forall a. String -> Parser SymTabs (Posn, TokenT) a
failP (String
"PEReference use before definition: "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"%"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nString -> String -> String
forall a. [a] -> [a] -> [a]
++String
";")



---- XML Parsing Functions ----

justDTD :: XParser (Maybe DocTypeDecl)
justDTD :: Parser SymTabs (Posn, TokenT) (Maybe DocTypeDecl)
justDTD =
  do (ExtSubset _ ds) <- XParser ExtSubset
extsubset XParser ExtSubset -> String -> XParser ExtSubset
forall a. a -> String -> a
`debug` String
"Trying external subset"
     if null ds then fail "empty"
         else return (Just (DTD (N "extsubset") Nothing (concatMap extract ds)))
  Parser SymTabs (Posn, TokenT) (Maybe DocTypeDecl)
-> Parser SymTabs (Posn, TokenT) (Maybe DocTypeDecl)
-> Parser SymTabs (Posn, TokenT) (Maybe DocTypeDecl)
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail`
  do (Prolog _ _ dtd _) <- XParser Prolog
prolog
     return dtd
 where extract :: ExtSubsetDecl -> [MarkupDecl]
extract (ExtMarkupDecl MarkupDecl
m) = [MarkupDecl
m]
       extract (ExtConditionalSect (IncludeSect [ExtSubsetDecl]
i)) = (ExtSubsetDecl -> [MarkupDecl]) -> [ExtSubsetDecl] -> [MarkupDecl]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ExtSubsetDecl -> [MarkupDecl]
extract [ExtSubsetDecl]
i
       extract (ExtConditionalSect (IgnoreSect IgnoreSect
_)) = []

-- | Return an entire XML document including prolog and trailing junk.
document :: XParser (Document Posn)
document :: Parser SymTabs (Posn, TokenT) (Document Posn)
document = do
 -- p <- prolog `adjustErr` ("unrecognisable XML prolog\n"++)
 -- e <- element
 -- ms <- many misc
 -- (_,ge) <- stGet
 -- return (Document p ge e ms)
    (Prolog
 -> SymTab EntityDef -> Element Posn -> [Misc] -> Document Posn)
-> Parser
     SymTabs
     (Posn, TokenT)
     (Prolog
      -> SymTab EntityDef -> Element Posn -> [Misc] -> Document Posn)
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return Prolog
-> SymTab EntityDef -> Element Posn -> [Misc] -> Document Posn
forall i.
Prolog -> SymTab EntityDef -> Element i -> [Misc] -> Document i
Document Parser
  SymTabs
  (Posn, TokenT)
  (Prolog
   -> SymTab EntityDef -> Element Posn -> [Misc] -> Document Posn)
-> XParser Prolog
-> Parser
     SymTabs
     (Posn, TokenT)
     (SymTab EntityDef -> Element Posn -> [Misc] -> Document Posn)
forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (XParser Prolog
prolog XParser Prolog -> (String -> String) -> XParser Prolog
forall a. XParser a -> (String -> String) -> XParser a
forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr`
                                    (String
"unrecognisable XML prolog\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++))
                    Parser
  SymTabs
  (Posn, TokenT)
  (SymTab EntityDef -> Element Posn -> [Misc] -> Document Posn)
-> Parser SymTabs (Posn, TokenT) (SymTab EntityDef)
-> Parser
     SymTabs (Posn, TokenT) (Element Posn -> [Misc] -> Document Posn)
forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (SymTabs -> SymTab EntityDef)
-> Parser SymTabs (Posn, TokenT) SymTabs
-> Parser SymTabs (Posn, TokenT) (SymTab EntityDef)
forall a b.
(a -> b)
-> Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SymTabs -> SymTab EntityDef
forall a b. (a, b) -> b
snd Parser SymTabs (Posn, TokenT) SymTabs
forall s t. Parser s t s
stGet
                    Parser
  SymTabs (Posn, TokenT) (Element Posn -> [Misc] -> Document Posn)
-> Parser SymTabs (Posn, TokenT) (Element Posn)
-> Parser SymTabs (Posn, TokenT) ([Misc] -> Document Posn)
forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` Parser SymTabs (Posn, TokenT) (Element Posn)
element
                    Parser SymTabs (Posn, TokenT) ([Misc] -> Document Posn)
-> Parser SymTabs (Posn, TokenT) [Misc]
-> Parser SymTabs (Posn, TokenT) (Document Posn)
forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` Parser SymTabs (Posn, TokenT) Misc
-> Parser SymTabs (Posn, TokenT) [Misc]
forall a.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser SymTabs (Posn, TokenT) Misc
misc

-- | Return an XML comment.
comment :: XParser Comment
comment :: XParser String
comment = do
    XParser TokenT
-> XParser TokenT -> XParser String -> XParser String
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket (TokenT -> XParser TokenT
tok TokenT
TokCommentOpen) (TokenT -> XParser TokenT
tok TokenT
TokCommentClose) XParser String
freetext
--  tok TokCommentOpen
--  commit $ do
--    c <- freetext
--    tok TokCommentClose
--    return c

-- | Parse a processing instruction.
processinginstruction :: XParser ProcessingInstruction
processinginstruction :: XParser (String, String)
processinginstruction = do
    TokenT -> XParser TokenT
tok TokenT
TokPIOpen
    XParser (String, String) -> XParser (String, String)
forall a. XParser a -> XParser a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (XParser (String, String) -> XParser (String, String))
-> XParser (String, String) -> XParser (String, String)
forall a b. (a -> b) -> a -> b
$ do
      n <- XParser String
string  XParser String -> XParser String -> XParser String
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail` String -> XParser String
forall a. String -> Parser SymTabs (Posn, TokenT) a
failP String
"processing instruction has no target"
      f <- freetext
      tok TokPIClose `onFail` failP ("missing ?> in <?"++n)
      return (n, f)

cdsect :: XParser CDSect
cdsect :: XParser String
cdsect = do
    TokenT -> XParser TokenT
tok TokenT
TokSectionOpen
    XParser TokenT
-> XParser TokenT -> XParser String -> XParser String
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket (TokenT -> XParser TokenT
tok (Section -> TokenT
TokSection Section
CDATAx)) (XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (XParser TokenT -> XParser TokenT)
-> XParser TokenT -> XParser TokenT
forall a b. (a -> b) -> a -> b
$ TokenT -> XParser TokenT
tok TokenT
TokSectionClose) XParser String
chardata

prolog :: XParser Prolog
prolog :: XParser Prolog
prolog = do
    x   <- XParser XMLDecl -> XParser (Maybe XMLDecl)
forall a. XParser a -> XParser (Maybe a)
maybe XParser XMLDecl
xmldecl
    m1  <- many misc
    dtd <- maybe doctypedecl
    m2  <- many misc
    return (Prolog x m1 dtd m2)

xmldecl :: XParser XMLDecl
xmldecl :: XParser XMLDecl
xmldecl = do
    TokenT -> XParser TokenT
tok TokenT
TokPIOpen
    String -> XParser ()
word String
"xml" XParser () -> XParser () -> XParser ()
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail` String -> XParser ()
word String
"XML"
    p <- XParser Posn
posn
    s <- freetext
    tok TokPIClose `onFail` failBadP "missing ?> in <?xml ...?>"
 -- raise ((runParser aux emptySTs . xmlReLex p) s)
    return (fst3 ((runParser aux emptySTs . xmlReLex p) s))
  where
    aux :: XParser XMLDecl
aux = do
        v <- XParser String
versioninfo  XParser String -> XParser String -> XParser String
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail` String -> XParser String
forall a. String -> Parser SymTabs (Posn, TokenT) a
failP String
"missing XML version info"
        e <- maybe encodingdecl
        s <- maybe sddecl
        return (XMLDecl v e s)
 -- raise (Left err, _, _) = failP err
 -- raise (Right ok, _, _) = return ok

versioninfo :: XParser VersionInfo
versioninfo :: XParser String
versioninfo = do
    String -> XParser ()
word String
"version" XParser () -> XParser () -> XParser ()
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail` String -> XParser ()
word String
"VERSION"
    TokenT -> XParser TokenT
tok TokenT
TokEqual
    XParser TokenT
-> XParser TokenT -> XParser String -> XParser String
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket (TokenT -> XParser TokenT
tok TokenT
TokQuote) (XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (XParser TokenT -> XParser TokenT)
-> XParser TokenT -> XParser TokenT
forall a b. (a -> b) -> a -> b
$ TokenT -> XParser TokenT
tok TokenT
TokQuote) XParser String
freetext

misc :: XParser Misc
misc :: Parser SymTabs (Posn, TokenT) Misc
misc =
    [(String, Parser SymTabs (Posn, TokenT) Misc)]
-> Parser SymTabs (Posn, TokenT) Misc
forall a.
[(String, Parser SymTabs (Posn, TokenT) a)]
-> Parser SymTabs (Posn, TokenT) a
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
oneOf' [ (String
"<!--comment-->",  String -> Misc
Comment (String -> Misc)
-> XParser String -> Parser SymTabs (Posn, TokenT) Misc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XParser String
comment)
           , (String
"<?PI?>",          (String, String) -> Misc
PI ((String, String) -> Misc)
-> XParser (String, String) -> Parser SymTabs (Posn, TokenT) Misc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XParser (String, String)
processinginstruction)
           ]

-- | Return a DOCTYPE decl, indicating a DTD.
doctypedecl :: XParser DocTypeDecl
doctypedecl :: XParser DocTypeDecl
doctypedecl = do
    TokenT -> XParser TokenT
tok TokenT
TokSpecialOpen
    TokenT -> XParser TokenT
tok (Special -> TokenT
TokSpecial Special
DOCTYPEx)
    XParser DocTypeDecl -> XParser DocTypeDecl
forall a. XParser a -> XParser a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (XParser DocTypeDecl -> XParser DocTypeDecl)
-> XParser DocTypeDecl -> XParser DocTypeDecl
forall a b. (a -> b) -> a -> b
$ do
      n   <- XParser QName
qname
      eid <- maybe externalid
      es  <- maybe (bracket (tok TokSqOpen) (commit $ tok TokSqClose)
                            (many (peRef markupdecl)))
      blank (tok TokAnyClose)  `onFail` failP "missing > in DOCTYPE decl"
      return (DTD n eid (fromMaybe [] es))

-- | Return a DTD markup decl, e.g. ELEMENT, ATTLIST, etc
markupdecl :: XParser MarkupDecl
markupdecl :: Parser SymTabs (Posn, TokenT) MarkupDecl
markupdecl =
  [(String, Parser SymTabs (Posn, TokenT) MarkupDecl)]
-> Parser SymTabs (Posn, TokenT) MarkupDecl
forall a.
[(String, Parser SymTabs (Posn, TokenT) a)]
-> Parser SymTabs (Posn, TokenT) a
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
oneOf' [ (String
"ELEMENT",  ElementDecl -> MarkupDecl
Element (ElementDecl -> MarkupDecl)
-> Parser SymTabs (Posn, TokenT) ElementDecl
-> Parser SymTabs (Posn, TokenT) MarkupDecl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) ElementDecl
elementdecl)
         , (String
"ATTLIST",  AttListDecl -> MarkupDecl
AttList (AttListDecl -> MarkupDecl)
-> Parser SymTabs (Posn, TokenT) AttListDecl
-> Parser SymTabs (Posn, TokenT) MarkupDecl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) AttListDecl
attlistdecl)
         , (String
"ENTITY",   EntityDecl -> MarkupDecl
Entity (EntityDecl -> MarkupDecl)
-> Parser SymTabs (Posn, TokenT) EntityDecl
-> Parser SymTabs (Posn, TokenT) MarkupDecl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) EntityDecl
entitydecl)
         , (String
"NOTATION", NotationDecl -> MarkupDecl
Notation (NotationDecl -> MarkupDecl)
-> Parser SymTabs (Posn, TokenT) NotationDecl
-> Parser SymTabs (Posn, TokenT) MarkupDecl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) NotationDecl
notationdecl)
         , (String
"misc",     Misc -> MarkupDecl
MarkupMisc (Misc -> MarkupDecl)
-> Parser SymTabs (Posn, TokenT) Misc
-> Parser SymTabs (Posn, TokenT) MarkupDecl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) Misc
misc)
         ]
    Parser SymTabs (Posn, TokenT) MarkupDecl
-> (String -> String) -> Parser SymTabs (Posn, TokenT) MarkupDecl
forall a. XParser a -> (String -> String) -> XParser a
`adjustErrP`
          (String
"when looking for a markup decl,\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++)
 --       (\  (ELEMENT, ATTLIST, ENTITY, NOTATION, <!--comment-->, or <?PI?>")

extsubset :: XParser ExtSubset
extsubset :: XParser ExtSubset
extsubset = do
    td <- XParser TextDecl -> XParser (Maybe TextDecl)
forall a. XParser a -> XParser (Maybe a)
maybe XParser TextDecl
textdecl
    ds <- many (peRef extsubsetdecl)
    return (ExtSubset td ds)

extsubsetdecl :: XParser ExtSubsetDecl
extsubsetdecl :: Parser SymTabs (Posn, TokenT) ExtSubsetDecl
extsubsetdecl =
    (MarkupDecl -> ExtSubsetDecl
ExtMarkupDecl (MarkupDecl -> ExtSubsetDecl)
-> Parser SymTabs (Posn, TokenT) MarkupDecl
-> Parser SymTabs (Posn, TokenT) ExtSubsetDecl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) MarkupDecl
markupdecl) Parser SymTabs (Posn, TokenT) ExtSubsetDecl
-> Parser SymTabs (Posn, TokenT) ExtSubsetDecl
-> Parser SymTabs (Posn, TokenT) ExtSubsetDecl
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail`
    (ConditionalSect -> ExtSubsetDecl
ExtConditionalSect (ConditionalSect -> ExtSubsetDecl)
-> Parser SymTabs (Posn, TokenT) ConditionalSect
-> Parser SymTabs (Posn, TokenT) ExtSubsetDecl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) ConditionalSect
conditionalsect)

sddecl :: XParser SDDecl
sddecl :: XParser Bool
sddecl = do
    String -> XParser ()
word String
"standalone" XParser () -> XParser () -> XParser ()
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail` String -> XParser ()
word String
"STANDALONE"
    XParser Bool -> XParser Bool
forall a. XParser a -> XParser a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (XParser Bool -> XParser Bool) -> XParser Bool -> XParser Bool
forall a b. (a -> b) -> a -> b
$ do
      TokenT -> XParser TokenT
tok TokenT
TokEqual XParser TokenT -> XParser TokenT -> XParser TokenT
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail` String -> XParser TokenT
forall a. String -> Parser SymTabs (Posn, TokenT) a
failP String
"missing = in 'standalone' decl"
      XParser TokenT -> XParser TokenT -> XParser Bool -> XParser Bool
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket (TokenT -> XParser TokenT
tok TokenT
TokQuote) (XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (XParser TokenT -> XParser TokenT)
-> XParser TokenT -> XParser TokenT
forall a b. (a -> b) -> a -> b
$ TokenT -> XParser TokenT
tok TokenT
TokQuote)
              ( (String -> XParser ()
word String
"yes" XParser () -> XParser Bool -> XParser Bool
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XParser Bool
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) XParser Bool -> XParser Bool -> XParser Bool
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail`
                (String -> XParser ()
word String
"no" XParser () -> XParser Bool -> XParser Bool
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XParser Bool
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) XParser Bool -> XParser Bool -> XParser Bool
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail`
                String -> XParser Bool
forall a. String -> Parser SymTabs (Posn, TokenT) a
failP String
"'standalone' decl requires 'yes' or 'no' value" )

{-
element :: XParser (Element Posn)
element = do
    tok TokAnyOpen
    (ElemTag n as) <- elemtag
    oneOf' [ ("self-closing tag <"++n++"/>"
             ,  do tok TokEndClose
                   return (Elem n as []))
           , ("after open tag <"++n++">"
             ,  do tok TokAnyClose
                   cs <- many content
                   p  <- posn
                   m  <- bracket (tok TokEndOpen) (commit $ tok TokAnyClose) qname
                   checkmatch p n m
                   return (Elem n as cs))
           ] `adjustErr` (("in element tag "++n++",\n")++)
-}

-- | Return a complete element including all its inner content.
element :: XParser (Element Posn)
element :: Parser SymTabs (Posn, TokenT) (Element Posn)
element = do
    TokenT -> XParser TokenT
tok TokenT
TokAnyOpen
    (ElemTag n as) <- XParser ElemTag
elemtag
    return (Elem n as) `apply`
        ( do tok TokEndClose
             return []
          `onFail`
          do tok TokAnyClose
             commit $ manyFinally content
                                  (do p <- posn
                                      m <- bracket (tok TokEndOpen)
                                                   (commit $ tok TokAnyClose) qname
                                      checkmatch p n m)
          ) `adjustErrBad` (("in element tag "++printableName n++",\n")++)

checkmatch :: Posn -> QName -> QName -> XParser ()
checkmatch :: Posn -> QName -> QName -> XParser ()
checkmatch Posn
p QName
n QName
m =
  if QName
n QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
m then () -> XParser ()
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  else String -> XParser ()
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad (String
"tag <"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
printableName QName
nString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"> terminated by </"String -> String -> String
forall a. [a] -> [a] -> [a]
++QName -> String
printableName QName
m
                String -> String -> String
forall a. [a] -> [a] -> [a]
++String
">\n  at "String -> String -> String
forall a. [a] -> [a] -> [a]
++Posn -> String
forall a. Show a => a -> String
show Posn
p)

-- | Parse only the parts between angle brackets in an element tag.
elemtag :: XParser ElemTag
elemtag :: XParser ElemTag
elemtag = do
    n  <- XParser QName
qname XParser QName -> (String -> String) -> XParser QName
forall (p :: * -> *) a.
PolyParse p =>
p a -> (String -> String) -> p a
`adjustErrBad` (String
"malformed element tag\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++)
    as <- many attribute
    return (ElemTag n as)

-- | For use with stream parsers - returns the complete opening element tag.
elemOpenTag :: XParser ElemTag
elemOpenTag :: XParser ElemTag
elemOpenTag = do
    TokenT -> XParser TokenT
tok TokenT
TokAnyOpen
    e <- XParser ElemTag
elemtag
    tok TokAnyClose
    return e

-- | For use with stream parsers - accepts a closing tag, provided it
--   matches the given element name.
elemCloseTag :: QName -> XParser ()
elemCloseTag :: QName -> XParser ()
elemCloseTag QName
n = do
    TokenT -> XParser TokenT
tok TokenT
TokEndOpen
    p <- XParser Posn
posn
    m <- qname
    tok TokAnyClose
    checkmatch p n m

attribute :: XParser Attribute
attribute :: Parser SymTabs (Posn, TokenT) Attribute
attribute = do
    n <- XParser QName
qname XParser QName -> (String -> String) -> XParser QName
forall a. XParser a -> (String -> String) -> XParser a
forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` (String
"malformed attribute name\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++)
    tok TokEqual `onFail` failBadP "missing = in attribute"
    v <- attvalue `onFail` failBadP "missing attvalue"
    return (n,v)

-- | Return a content particle, e.g. text, element, reference, etc
content :: XParser (Content Posn)
content :: Parser SymTabs (Posn, TokenT) (Content Posn)
content =
  do { p  <- XParser Posn
posn
     ; c' <- content'
     ; return (c' p)
     }
  where
     content' :: XParser (Posn -> Content Posn)
content' = [(String, XParser (Posn -> Content Posn))]
-> XParser (Posn -> Content Posn)
forall a.
[(String, Parser SymTabs (Posn, TokenT) a)]
-> Parser SymTabs (Posn, TokenT) a
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
oneOf' [ (String
"element",   Element Posn -> Posn -> Content Posn
forall i. Element i -> i -> Content i
CElem (Element Posn -> Posn -> Content Posn)
-> Parser SymTabs (Posn, TokenT) (Element Posn)
-> XParser (Posn -> Content Posn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) (Element Posn)
element)
                       , (String
"chardata",  Bool -> String -> Posn -> Content Posn
forall i. Bool -> String -> i -> Content i
CString Bool
False (String -> Posn -> Content Posn)
-> XParser String -> XParser (Posn -> Content Posn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XParser String
chardata)
                       , (String
"reference", Reference -> Posn -> Content Posn
forall i. Reference -> i -> Content i
CRef (Reference -> Posn -> Content Posn)
-> Parser SymTabs (Posn, TokenT) Reference
-> XParser (Posn -> Content Posn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) Reference
reference)
                       , (String
"CDATA",     Bool -> String -> Posn -> Content Posn
forall i. Bool -> String -> i -> Content i
CString Bool
True (String -> Posn -> Content Posn)
-> XParser String -> XParser (Posn -> Content Posn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XParser String
cdsect)
                       , (String
"misc",      Misc -> Posn -> Content Posn
forall i. Misc -> i -> Content i
CMisc (Misc -> Posn -> Content Posn)
-> Parser SymTabs (Posn, TokenT) Misc
-> XParser (Posn -> Content Posn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) Misc
misc)
                       ]
                  XParser (Posn -> Content Posn)
-> (String -> String) -> XParser (Posn -> Content Posn)
forall a. XParser a -> (String -> String) -> XParser a
`adjustErrP` (String
"when looking for a content item,\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++)
-- (\    (element, text, reference, CDATA section, <!--comment-->, or <?PI?>")

elementdecl :: XParser ElementDecl
elementdecl :: Parser SymTabs (Posn, TokenT) ElementDecl
elementdecl = do
    TokenT -> XParser TokenT
tok TokenT
TokSpecialOpen
    TokenT -> XParser TokenT
tok (Special -> TokenT
TokSpecial Special
ELEMENTx)
    n <- XParser QName -> XParser QName
forall a. XParser a -> XParser a
peRef XParser QName
qname XParser QName -> (String -> String) -> XParser QName
forall (p :: * -> *) a.
PolyParse p =>
p a -> (String -> String) -> p a
`adjustErrBad` (String
"expecting identifier in ELEMENT decl\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++)
    c <- peRef contentspec
             `adjustErrBad` (("in content spec of ELEMENT decl: "
                             ++printableName n++"\n")++)
    blank (tok TokAnyClose) `onFail` failBadP
       ("expected > terminating ELEMENT decl"
       ++"\n    element name was "++show (printableName n)
       ++"\n    contentspec was "++(\ (ContentSpec CP
p)-> CP -> String
debugShowCP CP
p) c)
    return (ElementDecl n c)

contentspec :: XParser ContentSpec
contentspec :: XParser ContentSpec
contentspec =
    [(String, XParser ContentSpec)] -> XParser ContentSpec
forall a.
[(String, Parser SymTabs (Posn, TokenT) a)]
-> Parser SymTabs (Posn, TokenT) a
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
oneOf' [ (String
"EMPTY",  XParser () -> XParser ()
forall a. XParser a -> XParser a
peRef (String -> XParser ()
word String
"EMPTY") XParser () -> XParser ContentSpec -> XParser ContentSpec
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ContentSpec -> XParser ContentSpec
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return ContentSpec
EMPTY)
           , (String
"ANY",    XParser () -> XParser ()
forall a. XParser a -> XParser a
peRef (String -> XParser ()
word String
"ANY") XParser () -> XParser ContentSpec -> XParser ContentSpec
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ContentSpec -> XParser ContentSpec
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return ContentSpec
ANY)
           , (String
"mixed",  Mixed -> ContentSpec
Mixed (Mixed -> ContentSpec)
-> Parser SymTabs (Posn, TokenT) Mixed -> XParser ContentSpec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) Mixed
-> Parser SymTabs (Posn, TokenT) Mixed
forall a. XParser a -> XParser a
peRef Parser SymTabs (Posn, TokenT) Mixed
mixed)
           , (String
"simple", CP -> ContentSpec
ContentSpec (CP -> ContentSpec)
-> Parser SymTabs (Posn, TokenT) CP -> XParser ContentSpec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) CP
-> Parser SymTabs (Posn, TokenT) CP
forall a. XParser a -> XParser a
peRef Parser SymTabs (Posn, TokenT) CP
cp)
           ]
 --   `adjustErr` ("when looking for content spec,\n"++)
 --   `adjustErr` (++"\nLooking for content spec (EMPTY, ANY, mixed, etc)")

choice :: XParser [CP]
choice :: XParser [CP]
choice = do
    XParser TokenT -> XParser TokenT -> XParser [CP] -> XParser [CP]
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket (TokenT -> XParser TokenT
tok TokenT
TokBraOpen XParser TokenT -> String -> XParser TokenT
forall a. a -> String -> a
`debug` String
"Trying choice")
            (XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
blank (TokenT -> XParser TokenT
tok TokenT
TokBraClose XParser TokenT -> String -> XParser TokenT
forall a. a -> String -> a
`debug` String
"Succeeded with choice"))
            (Parser SymTabs (Posn, TokenT) CP
-> Parser SymTabs (Posn, TokenT) CP
forall a. XParser a -> XParser a
peRef Parser SymTabs (Posn, TokenT) CP
cp Parser SymTabs (Posn, TokenT) CP -> XParser TokenT -> XParser [CP]
forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
`sepBy1` XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
blank (TokenT -> XParser TokenT
tok TokenT
TokPipe))

sequence :: XParser [CP]
sequence :: XParser [CP]
sequence = do
    XParser TokenT -> XParser TokenT -> XParser [CP] -> XParser [CP]
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket (TokenT -> XParser TokenT
tok TokenT
TokBraOpen XParser TokenT -> String -> XParser TokenT
forall a. a -> String -> a
`debug` String
"Trying sequence")
            (XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
blank (TokenT -> XParser TokenT
tok TokenT
TokBraClose XParser TokenT -> String -> XParser TokenT
forall a. a -> String -> a
`debug` String
"Succeeded with sequence"))
            (Parser SymTabs (Posn, TokenT) CP
-> Parser SymTabs (Posn, TokenT) CP
forall a. XParser a -> XParser a
peRef Parser SymTabs (Posn, TokenT) CP
cp Parser SymTabs (Posn, TokenT) CP -> XParser TokenT -> XParser [CP]
forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
`sepBy1` XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
blank (TokenT -> XParser TokenT
tok TokenT
TokComma))

cp :: XParser CP
cp :: Parser SymTabs (Posn, TokenT) CP
cp = [Parser SymTabs (Posn, TokenT) CP]
-> Parser SymTabs (Posn, TokenT) CP
forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ do n <- XParser QName
qname
                m <- modifier
                let c = QName -> Modifier -> CP
TagName QName
n Modifier
m
                return c `debug` ("ContentSpec: name "++debugShowCP c)
           , do ss <- XParser [CP]
sequence
                m <- modifier
                let c = [CP] -> Modifier -> CP
Seq [CP]
ss Modifier
m
                return c `debug` ("ContentSpec: sequence "++debugShowCP c)
           , do cs <- XParser [CP]
choice
                m <- modifier
                let c = [CP] -> Modifier -> CP
Choice [CP]
cs Modifier
m
                return c `debug` ("ContentSpec: choice "++debugShowCP c)
           ] Parser SymTabs (Posn, TokenT) CP
-> (String -> String) -> Parser SymTabs (Posn, TokenT) CP
forall a. XParser a -> (String -> String) -> XParser a
forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` (String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\nwhen looking for a content particle")

modifier :: XParser Modifier
modifier :: XParser Modifier
modifier = [XParser Modifier] -> XParser Modifier
forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ TokenT -> XParser TokenT
tok TokenT
TokStar XParser TokenT -> XParser Modifier -> XParser Modifier
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Modifier -> XParser Modifier
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return Modifier
Star
                 , TokenT -> XParser TokenT
tok TokenT
TokQuery XParser TokenT -> XParser Modifier -> XParser Modifier
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Modifier -> XParser Modifier
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return Modifier
Query
                 , TokenT -> XParser TokenT
tok TokenT
TokPlus XParser TokenT -> XParser Modifier -> XParser Modifier
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Modifier -> XParser Modifier
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return Modifier
Plus
                 , Modifier -> XParser Modifier
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return Modifier
None
                 ]

-- just for debugging
debugShowCP :: CP -> String
debugShowCP :: CP -> String
debugShowCP CP
cp = case CP
cp of
    TagName QName
n Modifier
m  -> QName -> String
printableName QName
nString -> String -> String
forall a. [a] -> [a] -> [a]
++Modifier -> String
debugShowModifier Modifier
m
    Choice [CP]
cps Modifier
m -> Char
'('Char -> String -> String
forall a. a -> [a] -> [a]
: String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"|" ((CP -> String) -> [CP] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CP -> String
debugShowCP [CP]
cps)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
")"String -> String -> String
forall a. [a] -> [a] -> [a]
++Modifier -> String
debugShowModifier Modifier
m
    Seq [CP]
cps Modifier
m    -> Char
'('Char -> String -> String
forall a. a -> [a] -> [a]
: String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((CP -> String) -> [CP] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CP -> String
debugShowCP [CP]
cps)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
")"String -> String -> String
forall a. [a] -> [a] -> [a]
++Modifier -> String
debugShowModifier Modifier
m
debugShowModifier :: Modifier -> String
debugShowModifier :: Modifier -> String
debugShowModifier Modifier
modifier = case Modifier
modifier of
    Modifier
None  -> String
""
    Modifier
Query -> String
"?"
    Modifier
Star  -> String
"*"
    Modifier
Plus  -> String
"+"
----

mixed :: XParser Mixed
mixed :: Parser SymTabs (Posn, TokenT) Mixed
mixed = do
    TokenT -> XParser TokenT
tok TokenT
TokBraOpen
    XParser () -> XParser ()
forall a. XParser a -> XParser a
peRef (do TokenT -> XParser TokenT
tok TokenT
TokHash
              String -> XParser ()
word String
"PCDATA")
    Parser SymTabs (Posn, TokenT) Mixed
-> Parser SymTabs (Posn, TokenT) Mixed
forall a. XParser a -> XParser a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (Parser SymTabs (Posn, TokenT) Mixed
 -> Parser SymTabs (Posn, TokenT) Mixed)
-> Parser SymTabs (Posn, TokenT) Mixed
-> Parser SymTabs (Posn, TokenT) Mixed
forall a b. (a -> b) -> a -> b
$
      [Parser SymTabs (Posn, TokenT) Mixed]
-> Parser SymTabs (Posn, TokenT) Mixed
forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ do cs <- XParser QName -> Parser SymTabs (Posn, TokenT) [QName]
forall a.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (XParser QName -> XParser QName
forall a. XParser a -> XParser a
peRef (do TokenT -> XParser TokenT
tok TokenT
TokPipe
                                       XParser QName -> XParser QName
forall a. XParser a -> XParser a
peRef XParser QName
qname))
                 blank (tok TokBraClose >> tok TokStar)
                 return (PCDATAplus cs)
            , XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
blank (TokenT -> XParser TokenT
tok TokenT
TokBraClose XParser TokenT -> XParser TokenT -> XParser TokenT
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TokenT -> XParser TokenT
tok TokenT
TokStar) XParser TokenT
-> Parser SymTabs (Posn, TokenT) Mixed
-> Parser SymTabs (Posn, TokenT) Mixed
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Mixed -> Parser SymTabs (Posn, TokenT) Mixed
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return Mixed
PCDATA
            , XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
blank (TokenT -> XParser TokenT
tok TokenT
TokBraClose) XParser TokenT
-> Parser SymTabs (Posn, TokenT) Mixed
-> Parser SymTabs (Posn, TokenT) Mixed
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Mixed -> Parser SymTabs (Posn, TokenT) Mixed
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return Mixed
PCDATA
            ]
        Parser SymTabs (Posn, TokenT) Mixed
-> (String -> String) -> Parser SymTabs (Posn, TokenT) Mixed
forall a. XParser a -> (String -> String) -> XParser a
`adjustErrP` (String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\nLooking for mixed content spec (#PCDATA | ...)*\n")

attlistdecl :: XParser AttListDecl
attlistdecl :: Parser SymTabs (Posn, TokenT) AttListDecl
attlistdecl = do
    TokenT -> XParser TokenT
tok TokenT
TokSpecialOpen
    TokenT -> XParser TokenT
tok (Special -> TokenT
TokSpecial Special
ATTLISTx)
    n <- XParser QName -> XParser QName
forall a. XParser a -> XParser a
peRef XParser QName
qname XParser QName -> (String -> String) -> XParser QName
forall (p :: * -> *) a.
PolyParse p =>
p a -> (String -> String) -> p a
`adjustErrBad` (String
"expecting identifier in ATTLIST\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++)
    ds <- peRef (many1 (peRef attdef))
    blank (tok TokAnyClose) `onFail` failBadP "missing > terminating ATTLIST"
    return (AttListDecl n ds)

attdef :: XParser AttDef
attdef :: Parser SymTabs (Posn, TokenT) AttDef
attdef =
  do n <- XParser QName -> XParser QName
forall a. XParser a -> XParser a
peRef XParser QName
qname XParser QName -> (String -> String) -> XParser QName
forall a. XParser a -> (String -> String) -> XParser a
forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` (String
"expecting attribute name\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++)
     t <- peRef atttype `adjustErr` (("within attlist defn: "
                                      ++printableName n++",\n")++)
     d <- peRef defaultdecl `adjustErr` (("in attlist defn: "
                                          ++printableName n++",\n")++)
     return (AttDef n t d)

atttype :: XParser AttType
atttype :: XParser AttType
atttype =
    [(String, XParser AttType)] -> XParser AttType
forall a.
[(String, Parser SymTabs (Posn, TokenT) a)]
-> Parser SymTabs (Posn, TokenT) a
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
oneOf' [ (String
"CDATA",      String -> XParser ()
word String
"CDATA" XParser () -> XParser AttType -> XParser AttType
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AttType -> XParser AttType
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return AttType
StringType)
           , (String
"tokenized",  TokenizedType -> AttType
TokenizedType (TokenizedType -> AttType)
-> Parser SymTabs (Posn, TokenT) TokenizedType -> XParser AttType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) TokenizedType
tokenizedtype)
           , (String
"enumerated", EnumeratedType -> AttType
EnumeratedType (EnumeratedType -> AttType)
-> Parser SymTabs (Posn, TokenT) EnumeratedType -> XParser AttType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) EnumeratedType
enumeratedtype)
           ]
      XParser AttType -> (String -> String) -> XParser AttType
forall a. XParser a -> (String -> String) -> XParser a
forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` (String
"looking for ATTTYPE,\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++)
 --   `adjustErr` (++"\nLooking for ATTTYPE (CDATA, tokenized, or enumerated")

tokenizedtype :: XParser TokenizedType
tokenizedtype :: Parser SymTabs (Posn, TokenT) TokenizedType
tokenizedtype =
    [Parser SymTabs (Posn, TokenT) TokenizedType]
-> Parser SymTabs (Posn, TokenT) TokenizedType
forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [ String -> XParser ()
word String
"ID" XParser ()
-> Parser SymTabs (Posn, TokenT) TokenizedType
-> Parser SymTabs (Posn, TokenT) TokenizedType
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TokenizedType -> Parser SymTabs (Posn, TokenT) TokenizedType
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return TokenizedType
ID
          , String -> XParser ()
word String
"IDREF" XParser ()
-> Parser SymTabs (Posn, TokenT) TokenizedType
-> Parser SymTabs (Posn, TokenT) TokenizedType
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TokenizedType -> Parser SymTabs (Posn, TokenT) TokenizedType
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return TokenizedType
IDREF
          , String -> XParser ()
word String
"IDREFS" XParser ()
-> Parser SymTabs (Posn, TokenT) TokenizedType
-> Parser SymTabs (Posn, TokenT) TokenizedType
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TokenizedType -> Parser SymTabs (Posn, TokenT) TokenizedType
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return TokenizedType
IDREFS
          , String -> XParser ()
word String
"ENTITY" XParser ()
-> Parser SymTabs (Posn, TokenT) TokenizedType
-> Parser SymTabs (Posn, TokenT) TokenizedType
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TokenizedType -> Parser SymTabs (Posn, TokenT) TokenizedType
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return TokenizedType
ENTITY
          , String -> XParser ()
word String
"ENTITIES" XParser ()
-> Parser SymTabs (Posn, TokenT) TokenizedType
-> Parser SymTabs (Posn, TokenT) TokenizedType
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TokenizedType -> Parser SymTabs (Posn, TokenT) TokenizedType
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return TokenizedType
ENTITIES
          , String -> XParser ()
word String
"NMTOKEN" XParser ()
-> Parser SymTabs (Posn, TokenT) TokenizedType
-> Parser SymTabs (Posn, TokenT) TokenizedType
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TokenizedType -> Parser SymTabs (Posn, TokenT) TokenizedType
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return TokenizedType
NMTOKEN
          , String -> XParser ()
word String
"NMTOKENS" XParser ()
-> Parser SymTabs (Posn, TokenT) TokenizedType
-> Parser SymTabs (Posn, TokenT) TokenizedType
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TokenizedType -> Parser SymTabs (Posn, TokenT) TokenizedType
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return TokenizedType
NMTOKENS
          ] Parser SymTabs (Posn, TokenT) TokenizedType
-> Parser SymTabs (Posn, TokenT) TokenizedType
-> Parser SymTabs (Posn, TokenT) TokenizedType
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail`
    do { t <- Parser SymTabs (Posn, TokenT) (Posn, TokenT)
forall s t. Parser s t t
next
       ; failP ("Expected one of"
               ++" (ID, IDREF, IDREFS, ENTITY, ENTITIES, NMTOKEN, NMTOKENS)"
               ++"\nbut got "++show t)
       }

enumeratedtype :: XParser EnumeratedType
enumeratedtype :: Parser SymTabs (Posn, TokenT) EnumeratedType
enumeratedtype =
    [(String, Parser SymTabs (Posn, TokenT) EnumeratedType)]
-> Parser SymTabs (Posn, TokenT) EnumeratedType
forall a.
[(String, Parser SymTabs (Posn, TokenT) a)]
-> Parser SymTabs (Posn, TokenT) a
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
oneOf' [ (String
"NOTATION",   [String] -> EnumeratedType
NotationType ([String] -> EnumeratedType)
-> Parser SymTabs (Posn, TokenT) [String]
-> Parser SymTabs (Posn, TokenT) EnumeratedType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) [String]
notationtype)
           , (String
"enumerated", [String] -> EnumeratedType
Enumeration ([String] -> EnumeratedType)
-> Parser SymTabs (Posn, TokenT) [String]
-> Parser SymTabs (Posn, TokenT) EnumeratedType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) [String]
enumeration)
           ]
      Parser SymTabs (Posn, TokenT) EnumeratedType
-> (String -> String)
-> Parser SymTabs (Posn, TokenT) EnumeratedType
forall a. XParser a -> (String -> String) -> XParser a
forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` (String
"looking for an enumerated or NOTATION type,\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++)

notationtype :: XParser NotationType
notationtype :: Parser SymTabs (Posn, TokenT) [String]
notationtype = do
    String -> XParser ()
word String
"NOTATION"
    XParser TokenT
-> XParser TokenT
-> Parser SymTabs (Posn, TokenT) [String]
-> Parser SymTabs (Posn, TokenT) [String]
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket (TokenT -> XParser TokenT
tok TokenT
TokBraOpen) (XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (XParser TokenT -> XParser TokenT)
-> XParser TokenT -> XParser TokenT
forall a b. (a -> b) -> a -> b
$ XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
blank (XParser TokenT -> XParser TokenT)
-> XParser TokenT -> XParser TokenT
forall a b. (a -> b) -> a -> b
$ TokenT -> XParser TokenT
tok TokenT
TokBraClose)
            (XParser String -> XParser String
forall a. XParser a -> XParser a
peRef XParser String
name XParser String
-> XParser TokenT -> Parser SymTabs (Posn, TokenT) [String]
forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
`sepBy1` XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
peRef (TokenT -> XParser TokenT
tok TokenT
TokPipe))

enumeration :: XParser Enumeration
enumeration :: Parser SymTabs (Posn, TokenT) [String]
enumeration =
    XParser TokenT
-> XParser TokenT
-> Parser SymTabs (Posn, TokenT) [String]
-> Parser SymTabs (Posn, TokenT) [String]
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket (TokenT -> XParser TokenT
tok TokenT
TokBraOpen) (XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (XParser TokenT -> XParser TokenT)
-> XParser TokenT -> XParser TokenT
forall a b. (a -> b) -> a -> b
$ XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
blank (XParser TokenT -> XParser TokenT)
-> XParser TokenT -> XParser TokenT
forall a b. (a -> b) -> a -> b
$ TokenT -> XParser TokenT
tok TokenT
TokBraClose)
            (XParser String -> XParser String
forall a. XParser a -> XParser a
peRef XParser String
nmtoken XParser String
-> XParser TokenT -> Parser SymTabs (Posn, TokenT) [String]
forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
`sepBy1` XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
blank (XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
peRef (TokenT -> XParser TokenT
tok TokenT
TokPipe)))

defaultdecl :: XParser DefaultDecl
defaultdecl :: XParser DefaultDecl
defaultdecl =
    [(String, XParser DefaultDecl)] -> XParser DefaultDecl
forall a.
[(String, Parser SymTabs (Posn, TokenT) a)]
-> Parser SymTabs (Posn, TokenT) a
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
oneOf' [ (String
"REQUIRED",  TokenT -> XParser TokenT
tok TokenT
TokHash XParser TokenT -> XParser () -> XParser ()
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> XParser ()
word String
"REQUIRED" XParser () -> XParser DefaultDecl -> XParser DefaultDecl
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DefaultDecl -> XParser DefaultDecl
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return DefaultDecl
REQUIRED)
           , (String
"IMPLIED",   TokenT -> XParser TokenT
tok TokenT
TokHash XParser TokenT -> XParser () -> XParser ()
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> XParser ()
word String
"IMPLIED" XParser () -> XParser DefaultDecl -> XParser DefaultDecl
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DefaultDecl -> XParser DefaultDecl
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return DefaultDecl
IMPLIED)
           , (String
"FIXED",     do f <- XParser FIXED -> XParser (Maybe FIXED)
forall a. XParser a -> XParser (Maybe a)
maybe (TokenT -> XParser TokenT
tok TokenT
TokHash XParser TokenT -> XParser () -> XParser ()
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> XParser ()
word String
"FIXED"
                                                      XParser () -> XParser FIXED -> XParser FIXED
forall a b.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) b
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FIXED -> XParser FIXED
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return FIXED
FIXED)
                              a <- peRef attvalue
                              return (DefaultTo a f) )
           ]
        XParser DefaultDecl -> (String -> String) -> XParser DefaultDecl
forall a. XParser a -> (String -> String) -> XParser a
forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` (String
"looking for an attribute default decl,\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++)

conditionalsect :: XParser ConditionalSect
conditionalsect :: Parser SymTabs (Posn, TokenT) ConditionalSect
conditionalsect = [(String, Parser SymTabs (Posn, TokenT) ConditionalSect)]
-> Parser SymTabs (Posn, TokenT) ConditionalSect
forall a.
[(String, Parser SymTabs (Posn, TokenT) a)]
-> Parser SymTabs (Posn, TokenT) a
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
oneOf'
    [ ( String
"INCLUDE"
      , do TokenT -> XParser TokenT
tok TokenT
TokSectionOpen
           XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
peRef (TokenT -> XParser TokenT
tok (Section -> TokenT
TokSection Section
INCLUDEx))
           p <- XParser Posn
posn
           tok TokSqOpen `onFail` failBadP "missing [ after INCLUDE"
           i <- many (peRef extsubsetdecl)
           tok TokSectionClose
                   `onFail` failBadP ("missing ]]> for INCLUDE section"
                                     ++"\n    begun at "++show p)
           return (IncludeSect i))
    , ( String
"IGNORE"
      , do TokenT -> XParser TokenT
tok TokenT
TokSectionOpen
           XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
peRef (TokenT -> XParser TokenT
tok (Section -> TokenT
TokSection Section
IGNOREx))
           p <- XParser Posn
posn
           tok TokSqOpen `onFail` failBadP "missing [ after IGNORE"
           i <- many newIgnore  -- many ignoresectcontents
           tok TokSectionClose
                   `onFail` failBadP ("missing ]]> for IGNORE section"
                                     ++"\n    begun at "++show p)
           return (IgnoreSect []))
    ] Parser SymTabs (Posn, TokenT) ConditionalSect
-> (String -> String)
-> Parser SymTabs (Posn, TokenT) ConditionalSect
forall a. XParser a -> (String -> String) -> XParser a
forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` (String
"in a conditional section,\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++)

newIgnore :: XParser Ignore
newIgnore :: Parser SymTabs (Posn, TokenT) Ignore
newIgnore =
    ( do TokenT -> XParser TokenT
tok TokenT
TokSectionOpen
         Parser SymTabs (Posn, TokenT) Ignore
-> Parser SymTabs (Posn, TokenT) [Ignore]
forall a.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser SymTabs (Posn, TokenT) Ignore
newIgnore Parser SymTabs (Posn, TokenT) [Ignore]
-> String -> Parser SymTabs (Posn, TokenT) [Ignore]
forall a. a -> String -> a
`debug` String
"IGNORING conditional section"
         TokenT -> XParser TokenT
tok TokenT
TokSectionClose
         Ignore -> Parser SymTabs (Posn, TokenT) Ignore
forall a. a -> Parser SymTabs (Posn, TokenT) a
forall (m :: * -> *) a. Monad m => a -> m a
return Ignore
Ignore Parser SymTabs (Posn, TokenT) Ignore
-> String -> Parser SymTabs (Posn, TokenT) Ignore
forall a. a -> String -> a
`debug` String
"end of IGNORED conditional section") Parser SymTabs (Posn, TokenT) Ignore
-> Parser SymTabs (Posn, TokenT) Ignore
-> Parser SymTabs (Posn, TokenT) Ignore
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail`
    ( do t <- [TokenT] -> XParser TokenT
nottok [TokenT
TokSectionOpen,TokenT
TokSectionClose]
         return Ignore  `debug` ("ignoring: "++show t))

--- obsolete?
--ignoresectcontents :: XParser IgnoreSectContents
--ignoresectcontents = do
--    i <- ignore
--    is <- many (do tok TokSectionOpen
--                   ic <- ignoresectcontents
--                   tok TokSectionClose
--                   ig <- ignore
--                   return (ic,ig))
--    return (IgnoreSectContents i is)
--
--ignore :: XParser Ignore
--ignore = do
--  is <- many1 (nottok [TokSectionOpen,TokSectionClose])
--  return Ignore  `debug` ("ignored all of: "++show is)
----

-- | Return either a general entity reference, or a character reference.
reference :: XParser Reference
reference :: Parser SymTabs (Posn, TokenT) Reference
reference = do
    XParser TokenT
-> XParser TokenT
-> Parser SymTabs (Posn, TokenT) Reference
-> Parser SymTabs (Posn, TokenT) Reference
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket (TokenT -> XParser TokenT
tok TokenT
TokAmp) (XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (XParser TokenT -> XParser TokenT)
-> XParser TokenT -> XParser TokenT
forall a b. (a -> b) -> a -> b
$ TokenT -> XParser TokenT
tok TokenT
TokSemi) (XParser String
freetext XParser String
-> (String -> Parser SymTabs (Posn, TokenT) Reference)
-> Parser SymTabs (Posn, TokenT) Reference
forall a b.
Parser SymTabs (Posn, TokenT) a
-> (a -> Parser SymTabs (Posn, TokenT) b)
-> Parser SymTabs (Posn, TokenT) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Parser SymTabs (Posn, TokenT) Reference
forall {m :: * -> *}. Monad m => String -> m Reference
val)
  where
    val :: String -> m Reference
val (Char
'#':Char
'x':String
i) | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isHexDigit String
i
                    = Reference -> m Reference
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reference -> m Reference)
-> (String -> Reference) -> String -> m Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharRef -> Reference
RefChar (CharRef -> Reference)
-> (String -> CharRef) -> String -> Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CharRef, String) -> CharRef
forall a b. (a, b) -> a
fst ((CharRef, String) -> CharRef)
-> (String -> (CharRef, String)) -> String -> CharRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CharRef, String)] -> (CharRef, String)
forall a. HasCallStack => [a] -> a
head ([(CharRef, String)] -> (CharRef, String))
-> (String -> [(CharRef, String)]) -> String -> (CharRef, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(CharRef, String)]
forall a. (Eq a, Num a) => ReadS a
readHex (String -> m Reference) -> String -> m Reference
forall a b. (a -> b) -> a -> b
$ String
i
    val (Char
'#':String
i)     | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
i
                    = Reference -> m Reference
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reference -> m Reference)
-> (String -> Reference) -> String -> m Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharRef -> Reference
RefChar (CharRef -> Reference)
-> (String -> CharRef) -> String -> Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CharRef, String) -> CharRef
forall a b. (a, b) -> a
fst ((CharRef, String) -> CharRef)
-> (String -> (CharRef, String)) -> String -> CharRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CharRef, String)] -> (CharRef, String)
forall a. HasCallStack => [a] -> a
head ([(CharRef, String)] -> (CharRef, String))
-> (String -> [(CharRef, String)]) -> String -> (CharRef, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(CharRef, String)]
forall a. (Eq a, Num a) => ReadS a
readDec (String -> m Reference) -> String -> m Reference
forall a b. (a -> b) -> a -> b
$ String
i
    val String
name        = Reference -> m Reference
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reference -> m Reference)
-> (String -> Reference) -> String -> m Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Reference
RefEntity (String -> m Reference) -> String -> m Reference
forall a b. (a -> b) -> a -> b
$ String
name

{- -- following is incorrect
reference =
    ( RefChar <$> charref) `onFail`
    ( RefEntity <$> entityref)

entityref :: XParser EntityRef
entityref = do
    bracket (tok TokAmp) (commit $ tok TokSemi) name

charref :: XParser CharRef
charref = do
    bracket (tok TokAmp) (commit $ tok TokSemi) (freetext >>= readCharVal)
  where
    readCharVal ('#':'x':i) = return . fst . head . readHex $ i
    readCharVal ('#':i)     = return . fst . head . readDec $ i
    readCharVal _           = mzero
-}

pereference :: XParser PEReference
pereference :: XParser String
pereference = do
    XParser TokenT
-> XParser TokenT -> XParser String -> XParser String
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket (TokenT -> XParser TokenT
tok TokenT
TokPercent) (TokenT -> XParser TokenT
tok TokenT
TokSemi) XParser String
nmtoken

entitydecl :: XParser EntityDecl
entitydecl :: Parser SymTabs (Posn, TokenT) EntityDecl
entitydecl =
    ( GEDecl -> EntityDecl
EntityGEDecl (GEDecl -> EntityDecl)
-> Parser SymTabs (Posn, TokenT) GEDecl
-> Parser SymTabs (Posn, TokenT) EntityDecl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) GEDecl
gedecl) Parser SymTabs (Posn, TokenT) EntityDecl
-> Parser SymTabs (Posn, TokenT) EntityDecl
-> Parser SymTabs (Posn, TokenT) EntityDecl
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail`
    ( PEDecl -> EntityDecl
EntityPEDecl (PEDecl -> EntityDecl)
-> Parser SymTabs (Posn, TokenT) PEDecl
-> Parser SymTabs (Posn, TokenT) EntityDecl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) PEDecl
pedecl)

gedecl :: XParser GEDecl
gedecl :: Parser SymTabs (Posn, TokenT) GEDecl
gedecl = do
    TokenT -> XParser TokenT
tok TokenT
TokSpecialOpen
    TokenT -> XParser TokenT
tok (Special -> TokenT
TokSpecial Special
ENTITYx)
    n <- XParser String
name
    e <- entitydef `adjustErrBad` (("in general entity defn "++n++",\n")++)
    tok TokAnyClose `onFail` failBadP ("expected > terminating G ENTITY decl "++n)
    stUpdate (addGE n e) `debug` ("added GE defn &"++n++";")
    return (GEDecl n e)

pedecl :: XParser PEDecl
pedecl :: Parser SymTabs (Posn, TokenT) PEDecl
pedecl = do
    TokenT -> XParser TokenT
tok TokenT
TokSpecialOpen
    TokenT -> XParser TokenT
tok (Special -> TokenT
TokSpecial Special
ENTITYx)
    TokenT -> XParser TokenT
tok TokenT
TokPercent
    n <- XParser String
name
    e <- pedef `adjustErrBad` (("in parameter entity defn "++n++",\n")++)
    tok TokAnyClose `onFail` failBadP ("expected > terminating P ENTITY decl "++n)
    stUpdate (addPE n e) `debug` ("added PE defn %"++n++";\n"++show e)
    return (PEDecl n e)

entitydef :: XParser EntityDef
entitydef :: XParser EntityDef
entitydef =
    [(String, XParser EntityDef)] -> XParser EntityDef
forall a.
[(String, Parser SymTabs (Posn, TokenT) a)]
-> Parser SymTabs (Posn, TokenT) a
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
oneOf' [ (String
"entityvalue", EntityValue -> EntityDef
DefEntityValue (EntityValue -> EntityDef)
-> Parser SymTabs (Posn, TokenT) EntityValue -> XParser EntityDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) EntityValue
entityvalue)
           , (String
"external",    do eid <- XParser ExternalID
externalid
                                ndd <- maybe ndatadecl
                                return (DefExternalID eid ndd))
           ]

pedef :: XParser PEDef
pedef :: XParser PEDef
pedef =
    [(String, XParser PEDef)] -> XParser PEDef
forall a.
[(String, Parser SymTabs (Posn, TokenT) a)]
-> Parser SymTabs (Posn, TokenT) a
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
oneOf' [ (String
"entityvalue", EntityValue -> PEDef
PEDefEntityValue (EntityValue -> PEDef)
-> Parser SymTabs (Posn, TokenT) EntityValue -> XParser PEDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) EntityValue
entityvalue)
           , (String
"externalid",  ExternalID -> PEDef
PEDefExternalID (ExternalID -> PEDef) -> XParser ExternalID -> XParser PEDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XParser ExternalID
externalid )
           ]

externalid :: XParser ExternalID
externalid :: XParser ExternalID
externalid =
    [(String, XParser ExternalID)] -> XParser ExternalID
forall a.
[(String, Parser SymTabs (Posn, TokenT) a)]
-> Parser SymTabs (Posn, TokenT) a
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
oneOf' [ (String
"SYSTEM", do String -> XParser ()
word String
"SYSTEM"
                           SystemLiteral -> ExternalID
SYSTEM (SystemLiteral -> ExternalID)
-> Parser SymTabs (Posn, TokenT) SystemLiteral
-> XParser ExternalID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) SystemLiteral
systemliteral)
           , (String
"PUBLIC", do String -> XParser ()
word String
"PUBLIC"
                           p <- XParser PubidLiteral
pubidliteral
                           PUBLIC p <$> systemliteral)
           ]
      XParser ExternalID -> (String -> String) -> XParser ExternalID
forall a. XParser a -> (String -> String) -> XParser a
forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` (String
"looking for an external id,\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++)

ndatadecl :: XParser NDataDecl
ndatadecl :: XParser NDataDecl
ndatadecl = do
    String -> XParser ()
word String
"NDATA"
    String -> NDataDecl
NDATA (String -> NDataDecl) -> XParser String -> XParser NDataDecl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XParser String
name

textdecl :: XParser TextDecl
textdecl :: XParser TextDecl
textdecl = do
    TokenT -> XParser TokenT
tok TokenT
TokPIOpen
    String -> XParser ()
word String
"xml" XParser () -> XParser () -> XParser ()
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail` String -> XParser ()
word String
"XML"
    v <- XParser String -> XParser (Maybe String)
forall a. XParser a -> XParser (Maybe a)
maybe XParser String
versioninfo
    e <- encodingdecl
    tok TokPIClose `onFail` failP "expected ?> terminating text decl"
    return (TextDecl v e)

--extparsedent :: XParser (ExtParsedEnt Posn)
--extparsedent = do
--    t <- maybe textdecl
--    c <- content
--    return (ExtParsedEnt t c)
--
--extpe :: XParser ExtPE
--extpe = do
--    t <- maybe textdecl
--    e <- many (peRef extsubsetdecl)
--    return (ExtPE t e)

encodingdecl :: XParser EncodingDecl
encodingdecl :: XParser EncodingDecl
encodingdecl = do
    String -> XParser ()
word String
"encoding" XParser () -> XParser () -> XParser ()
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail` String -> XParser ()
word String
"ENCODING"
    TokenT -> XParser TokenT
tok TokenT
TokEqual XParser TokenT -> XParser TokenT -> XParser TokenT
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail` String -> XParser TokenT
forall a. String -> Parser SymTabs (Posn, TokenT) a
failBadP String
"expected = in 'encoding' decl"
    f <- XParser TokenT
-> XParser TokenT -> XParser String -> XParser String
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket (TokenT -> XParser TokenT
tok TokenT
TokQuote) (XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (XParser TokenT -> XParser TokenT)
-> XParser TokenT -> XParser TokenT
forall a b. (a -> b) -> a -> b
$ TokenT -> XParser TokenT
tok TokenT
TokQuote) XParser String
freetext
    return (EncodingDecl f)

notationdecl :: XParser NotationDecl
notationdecl :: Parser SymTabs (Posn, TokenT) NotationDecl
notationdecl = do
    TokenT -> XParser TokenT
tok TokenT
TokSpecialOpen
    TokenT -> XParser TokenT
tok (Special -> TokenT
TokSpecial Special
NOTATIONx)
    n <- XParser String
name
    e <- either externalid publicid
    tok TokAnyClose `onFail` failBadP ("expected > terminating NOTATION decl "++n)
    return (NOTATION n e)

publicid :: XParser PublicID
publicid :: XParser PublicID
publicid = do
    String -> XParser ()
word String
"PUBLIC"
    PubidLiteral -> PublicID
PUBLICID (PubidLiteral -> PublicID)
-> XParser PubidLiteral -> XParser PublicID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XParser PubidLiteral
pubidliteral

entityvalue :: XParser EntityValue
entityvalue :: Parser SymTabs (Posn, TokenT) EntityValue
entityvalue = do
 -- evs <- bracket (tok TokQuote) (commit $ tok TokQuote) (many (peRef ev))
    TokenT -> XParser TokenT
tok TokenT
TokQuote
    pn <- XParser Posn
posn
    evs <- many ev
    tok TokQuote `onFail` failBadP "expected quote to terminate entityvalue"
    -- quoted text must be rescanned for possible PERefs
    st <- stGet
 -- Prelude.either failBad (return . EntityValue) . fst3 $
    return . EntityValue . fst3 $
                runParser (many ev) st
                         (reLexEntityValue (\String
s-> Maybe PEDef -> Maybe String
stringify (String -> SymTabs -> Maybe PEDef
lookupPE String
s SymTabs
st))
                                           pn
                                           (flattenEV (EntityValue evs)))
  where
    stringify :: Maybe PEDef -> Maybe String
stringify (Just (PEDefEntityValue EntityValue
ev)) = String -> Maybe String
forall a. a -> Maybe a
Just (EntityValue -> String
flattenEV EntityValue
ev)
    stringify Maybe PEDef
_ = Maybe String
forall a. Maybe a
Nothing

ev :: XParser EV
ev :: Parser SymTabs (Posn, TokenT) EV
ev =
    [(String, Parser SymTabs (Posn, TokenT) EV)]
-> Parser SymTabs (Posn, TokenT) EV
forall a.
[(String, Parser SymTabs (Posn, TokenT) a)]
-> Parser SymTabs (Posn, TokenT) a
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
oneOf' [ (String
"string",    String -> EV
EVString (String -> EV)
-> XParser String -> Parser SymTabs (Posn, TokenT) EV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (XParser String
stringXParser String -> XParser String -> XParser String
forall s t a. Parser s t a -> Parser s t a -> Parser s t a
`onFail`XParser String
freetext))
           , (String
"reference", Reference -> EV
EVRef (Reference -> EV)
-> Parser SymTabs (Posn, TokenT) Reference
-> Parser SymTabs (Posn, TokenT) EV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SymTabs (Posn, TokenT) Reference
reference)
           ]
      Parser SymTabs (Posn, TokenT) EV
-> (String -> String) -> Parser SymTabs (Posn, TokenT) EV
forall a. XParser a -> (String -> String) -> XParser a
forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` (String
"looking for entity value,\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++)

attvalue :: XParser AttValue
attvalue :: XParser AttValue
attvalue = do
    avs <- XParser TokenT
-> XParser TokenT
-> Parser SymTabs (Posn, TokenT) [Either String Reference]
-> Parser SymTabs (Posn, TokenT) [Either String Reference]
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket (TokenT -> XParser TokenT
tok TokenT
TokQuote) (XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (XParser TokenT -> XParser TokenT)
-> XParser TokenT -> XParser TokenT
forall a b. (a -> b) -> a -> b
$ TokenT -> XParser TokenT
tok TokenT
TokQuote)
                   (Parser SymTabs (Posn, TokenT) (Either String Reference)
-> Parser SymTabs (Posn, TokenT) [Either String Reference]
forall a.
Parser SymTabs (Posn, TokenT) a
-> Parser SymTabs (Posn, TokenT) [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (XParser String
-> Parser SymTabs (Posn, TokenT) Reference
-> Parser SymTabs (Posn, TokenT) (Either String Reference)
forall a b. XParser a -> XParser b -> XParser (Either a b)
either XParser String
freetext Parser SymTabs (Posn, TokenT) Reference
reference))
    return (AttValue avs)

systemliteral :: XParser SystemLiteral
systemliteral :: Parser SymTabs (Posn, TokenT) SystemLiteral
systemliteral = do
    s <- XParser TokenT
-> XParser TokenT -> XParser String -> XParser String
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket (TokenT -> XParser TokenT
tok TokenT
TokQuote) (XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (XParser TokenT -> XParser TokenT)
-> XParser TokenT -> XParser TokenT
forall a b. (a -> b) -> a -> b
$ TokenT -> XParser TokenT
tok TokenT
TokQuote) XParser String
freetext
    return (SystemLiteral s)            -- note: refs &...; not permitted

pubidliteral :: XParser PubidLiteral
pubidliteral :: XParser PubidLiteral
pubidliteral = do
    s <- XParser TokenT
-> XParser TokenT -> XParser String -> XParser String
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket (TokenT -> XParser TokenT
tok TokenT
TokQuote) (XParser TokenT -> XParser TokenT
forall a. XParser a -> XParser a
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (XParser TokenT -> XParser TokenT)
-> XParser TokenT -> XParser TokenT
forall a b. (a -> b) -> a -> b
$ TokenT -> XParser TokenT
tok TokenT
TokQuote) XParser String
freetext
    return (PubidLiteral s)             -- note: freetext is too liberal here

-- | Return parsed freetext (i.e. until the next markup)
chardata :: XParser CharData
chardata :: XParser String
chardata = XParser String
freetext