-- | This is a parser for HTML documents.  Unlike for XML documents, it
--   must include a certain amount of error-correction to account for
--   HTML features like self-terminating tags, unterminated tags, and
--   incorrect nesting.  The input is tokenised by the
--   XML lexer (a separate lexer is not required for HTML).

-- It uses a slightly extended version of the Hutton/Meijer parser
-- combinators.

module Text.XML.HaXml.Html.Parse
  ( htmlParse
  , htmlParse'
  ) where

import Prelude hiding (either,maybe,sequence)
import qualified Prelude (either)
import Data.Maybe hiding (maybe)
import Data.Char (toLower, {-isSpace,-} isDigit, isHexDigit)
import Numeric (readDec,readHex)
import Control.Monad

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

--  #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
debug :: Monad m => String -> m ()
debug s = trace s (return ())
#else
debug :: Monad m => String -> m ()
debug :: forall (m :: * -> *). Monad m => String -> m ()
debug String
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif


-- | The first argument is the name of the file, the second is the string
--   contents of the file.  The result is the generic representation of
--   an XML document.  Any errors cause program failure with message to stderr.
htmlParse :: String -> String -> Document Posn
htmlParse :: String -> String -> Document Posn
htmlParse String
file = (String -> Document Posn)
-> (Document Posn -> Document Posn)
-> Either String (Document Posn)
-> Document Posn
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
Prelude.either String -> Document Posn
forall a. HasCallStack => String -> a
error Document Posn -> Document Posn
forall a. a -> a
id (Either String (Document Posn) -> Document Posn)
-> (String -> Either String (Document Posn))
-> String
-> Document Posn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Either String (Document Posn)
htmlParse' String
file

-- | The first argument is the name of the file, the second is the string
--   contents of the file.  The result is the generic representation of
--   an XML document.  Any parsing errors are returned in the @Either@ type.
htmlParse' :: String -> String -> Either String (Document Posn)
htmlParse' :: String -> String -> Either String (Document Posn)
htmlParse' String
file = (Document Posn -> Document Posn)
-> Either String (Document Posn) -> Either String (Document Posn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Document Posn -> Document Posn
forall i. Document i -> Document i
simplify (Either String (Document Posn) -> Either String (Document Posn))
-> (String -> Either String (Document Posn))
-> String
-> Either String (Document Posn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either String (Document Posn), [(Posn, TokenT)])
-> Either String (Document Posn)
forall a b. (a, b) -> a
fst
                  ((Either String (Document Posn), [(Posn, TokenT)])
 -> Either String (Document Posn))
-> (String -> (Either String (Document Posn), [(Posn, TokenT)]))
-> String
-> Either String (Document Posn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser (Posn, TokenT) (Document Posn)
-> [(Posn, TokenT)]
-> (Either String (Document Posn), [(Posn, TokenT)])
forall t a. Parser t a -> [t] -> (Either String a, [t])
runParser Parser (Posn, TokenT) (Document Posn)
document ([(Posn, TokenT)]
 -> (Either String (Document Posn), [(Posn, TokenT)]))
-> (String -> [(Posn, TokenT)])
-> String
-> (Either String (Document Posn), [(Posn, TokenT)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [(Posn, TokenT)]
xmlLex String
file

---- Document simplification ----

simplify :: Document i -> Document i
simplify :: forall i. Document i -> Document i
simplify (Document Prolog
p SymTab EntityDef
st (Elem QName
n [Attribute]
avs [Content i]
cs) [Misc]
ms) =
    Prolog -> SymTab EntityDef -> Element i -> [Misc] -> Document i
forall i.
Prolog -> SymTab EntityDef -> Element i -> [Misc] -> Document i
Document Prolog
p SymTab EntityDef
st (QName -> [Attribute] -> [Content i] -> Element i
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem QName
n [Attribute]
avs ((Content i -> Bool) -> [Content i] -> [Content i]
forall {i}. (Content i -> Bool) -> [Content i] -> [Content i]
deepfilter Content i -> Bool
forall {i}. Content i -> Bool
simp [Content i]
cs)) [Misc]
ms
  where
    simp :: Content i -> Bool
simp (CElem (Elem (N String
"null") [] []) i
_) = Bool
False
    simp (CElem (Elem QName
t [Attribute]
_ []) i
_)
        | QName -> String
localName QName
t String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"font",String
"p",String
"i",String
"b",String
"em",String
"tt",String
"big",String
"small"]
                                           = Bool
False
 -- simp (CString False s _) | all isSpace s = False
    simp Content i
_ = Bool
True
    deepfilter :: (Content i -> Bool) -> [Content i] -> [Content i]
deepfilter Content i -> Bool
f =
        (Content i -> Bool) -> [Content i] -> [Content i]
forall a. (a -> Bool) -> [a] -> [a]
filter Content i -> Bool
f ([Content i] -> [Content i])
-> ([Content i] -> [Content i]) -> [Content i] -> [Content i]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Content i -> Content i) -> [Content i] -> [Content i]
forall a b. (a -> b) -> [a] -> [b]
map (\Content i
c-> case Content i
c of
                          CElem (Elem QName
t [Attribute]
avs [Content i]
cs) i
i
                                  -> Element i -> i -> Content i
forall i. Element i -> i -> Content i
CElem (QName -> [Attribute] -> [Content i] -> Element i
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem QName
t [Attribute]
avs ((Content i -> Bool) -> [Content i] -> [Content i]
deepfilter Content i -> Bool
f [Content i]
cs)) i
i
                          Content i
_       -> Content i
c)

-- opening any of these, they close again immediately
selfclosingtags :: [String]
selfclosingtags :: [String]
selfclosingtags = [String
"img",String
"hr",String
"br",String
"meta",String
"col",String
"link",String
"base"
                  ,String
"param",String
"area",String
"frame",String
"input"]

-- closing this, implicitly closes any of those which are contained in it
closeInnerTags :: [(String,[String])]
closeInnerTags :: [(String, [String])]
closeInnerTags =
  [ (String
"ul",      [String
"li"])
  , (String
"ol",      [String
"li"])
  , (String
"dl",      [String
"dt",String
"dd"])
  , (String
"tr",      [String
"th",String
"td"])
  , (String
"div",     [String
"p"])
  , (String
"thead",   [String
"th",String
"tr",String
"td"])
  , (String
"tfoot",   [String
"th",String
"tr",String
"td"])
  , (String
"tbody",   [String
"th",String
"tr",String
"td"])
  , (String
"table",   [String
"th",String
"tr",String
"td",String
"thead",String
"tfoot",String
"tbody"])
  , (String
"caption", [String
"p"])
  , (String
"th",      [String
"p"])
  , (String
"td",      [String
"p"])
  , (String
"li",      [String
"p"])
  , (String
"dt",      [String
"p"])
  , (String
"dd",      [String
"p"])
  , (String
"object",  [String
"p"])
  , (String
"map",     [String
"p"])
  , (String
"body",    [String
"p"])
  ]

-- opening this, implicitly closes that
closes :: Name -> Name -> Bool
String
"a"     closes :: String -> String -> Bool
`closes` String
"a"      =  Bool
True
String
"li"    `closes` String
"li"     =  Bool
True
String
"th"    `closes`  String
t       | String
t String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"th",String
"td"]      =  Bool
True
String
"td"    `closes`  String
t       | String
t String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"th",String
"td"]      =  Bool
True
String
"tr"    `closes`  String
t       | String
t String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"th",String
"td",String
"tr"] =  Bool
True
String
"dt"    `closes`  String
t       | String
t String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"dt",String
"dd"]      =  Bool
True
String
"dd"    `closes`  String
t       | String
t String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"dt",String
"dd"]      =  Bool
True
String
"form"  `closes` String
"form"   = Bool
True
String
"label" `closes` String
"label"  = Bool
True
String
_       `closes` String
"option" = Bool
True
String
"thead" `closes` String
t        | String
t String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"colgroup"                = Bool
True
String
"tfoot" `closes` String
t        | String
t String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"thead",String
"colgroup"]  = Bool
True
String
"tbody" `closes` String
t        | String
t String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"tbody",String
"tfoot",String
"thead",String
"colgroup"] = Bool
True
String
"colgroup" `closes` String
"colgroup"  = Bool
True
String
t `closes` String
"p"
    | String
t String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"p",String
"h1",String
"h2",String
"h3",String
"h4",String
"h5",String
"h6"
               ,String
"hr",String
"div",String
"ul",String
"dl",String
"ol",String
"table"]  =  Bool
True
String
_ `closes` String
_ = Bool
False


---- Auxiliary Parsing Functions ----

type HParser a = Parser (Posn,TokenT) a

tok :: TokenT -> HParser TokenT
tok :: TokenT -> HParser TokenT
tok TokenT
t = do (Posn
p,TokenT
t') <- Parser (Posn, TokenT) (Posn, TokenT)
forall t. Parser t t
next
           case TokenT
t' of TokError String
_    -> (String -> HParser TokenT)
-> String -> Posn -> TokenT -> HParser TokenT
forall a.
(String -> HParser a) -> String -> Posn -> TokenT -> HParser a
report String -> HParser 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 -> HParser TokenT
forall (m :: * -> *) a. Monad m => a -> m a
return TokenT
t
                        | Bool
otherwise -> (String -> HParser TokenT)
-> String -> Posn -> TokenT -> HParser TokenT
forall a.
(String -> HParser a) -> String -> Posn -> TokenT -> HParser a
report String -> HParser TokenT
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (TokenT -> String
forall a. Show a => a -> String
show TokenT
t) Posn
p TokenT
t'

qname :: HParser QName
qname :: HParser QName
qname = (String -> QName) -> Parser (Posn, TokenT) String -> HParser QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> QName
N Parser (Posn, TokenT) String
name

name :: HParser Name
--name = do {(p,TokName s) <- next; return s}
name :: Parser (Posn, TokenT) String
name = do (Posn
p,TokenT
tok) <- Parser (Posn, TokenT) (Posn, TokenT)
forall t. Parser t t
next
          case TokenT
tok of
            TokName String
s  -> String -> Parser (Posn, TokenT) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
s
            TokError String
_ -> (String -> Parser (Posn, TokenT) String)
-> String -> Posn -> TokenT -> Parser (Posn, TokenT) String
forall a.
(String -> HParser a) -> String -> Posn -> TokenT -> HParser a
report String -> Parser (Posn, TokenT) String
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad String
"a name" Posn
p TokenT
tok
            TokenT
_          -> (String -> Parser (Posn, TokenT) String)
-> String -> Posn -> TokenT -> Parser (Posn, TokenT) String
forall a.
(String -> HParser a) -> String -> Posn -> TokenT -> HParser a
report String -> Parser (Posn, TokenT) String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"a name" Posn
p TokenT
tok

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

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

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

word :: String -> HParser ()
word :: String -> HParser ()
word String
s = do { (Posn, TokenT)
x <- Parser (Posn, TokenT) (Posn, TokenT)
forall t. Parser t t
next
            ; case (Posn, TokenT)
x of
                (Posn
_p,TokName String
n)     | String
sString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
n -> () -> HParser ()
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 -> () -> HParser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                ( Posn
p,t :: TokenT
t@(TokError String
_)) -> (String -> HParser ()) -> String -> Posn -> TokenT -> HParser ()
forall a.
(String -> HParser a) -> String -> Posn -> TokenT -> HParser a
report String -> HParser ()
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 -> HParser ()) -> String -> Posn -> TokenT -> HParser ()
forall a.
(String -> HParser a) -> String -> Posn -> TokenT -> HParser a
report String -> HParser ()
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 :: HParser Posn
posn :: HParser Posn
posn = do { x :: (Posn, TokenT)
x@(Posn
p,TokenT
_) <- Parser (Posn, TokenT) (Posn, TokenT)
forall t. Parser t t
next
          ; [(Posn, TokenT)] -> HParser ()
forall t. [t] -> Parser t ()
reparse [(Posn, TokenT)
x]
          ; Posn -> HParser Posn
forall (m :: * -> *) a. Monad m => a -> m a
return Posn
p
          } HParser Posn -> HParser Posn -> HParser Posn
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` Posn -> HParser Posn
forall (m :: * -> *) a. Monad m => a -> m a
return Posn
noPos

nmtoken :: HParser NmToken
nmtoken :: Parser (Posn, TokenT) String
nmtoken = Parser (Posn, TokenT) String
string Parser (Posn, TokenT) String
-> Parser (Posn, TokenT) String -> Parser (Posn, TokenT) String
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` Parser (Posn, TokenT) String
freetext

failP, failBadP :: String -> HParser a
failP :: forall a. String -> HParser a
failP String
msg    = do { Posn
p <- HParser Posn
posn; String -> HParser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
msgString -> 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) }
failBadP :: forall a. String -> HParser a
failBadP String
msg = do { Posn
p <- HParser Posn
posn; String -> HParser a
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad (String
msgString -> 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) }

report :: (String->HParser a) -> String -> Posn -> TokenT -> HParser a
report :: forall a.
(String -> HParser a) -> String -> Posn -> TokenT -> HParser a
report String -> HParser a
fail String
expect Posn
p TokenT
t = String -> HParser a
fail (String
"Expected "String -> String -> String
forall a. [a] -> [a] -> [a]
++String -> String
forall a. Show a => a -> String
show 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  at "String -> String -> String
forall a. [a] -> [a] -> [a]
++Posn -> String
forall a. Show a => a -> String
show Posn
p)

adjustErrP :: HParser a -> (String->String) -> HParser a
HParser a
p adjustErrP :: forall a. HParser a -> (String -> String) -> HParser a
`adjustErrP` String -> String
f = HParser a
p HParser a -> HParser a -> HParser a
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` do Posn
pn <- HParser Posn
posn
                                 (HParser a
p HParser a -> (String -> String) -> HParser a
forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` String -> String
f) HParser a -> (String -> String) -> HParser a
forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` (String -> String -> String
forall a. [a] -> [a] -> [a]
++Posn -> String
forall a. Show a => a -> String
show Posn
pn)

---- XML Parsing Functions ----

document :: HParser (Document Posn)
document :: Parser (Posn, TokenT) (Document Posn)
document = do
    Prolog
p     <- HParser Prolog
prolog HParser Prolog -> (String -> String) -> HParser Prolog
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]
++)
    [(Stack, Element Posn)]
ht    <- Parser (Posn, TokenT) (Stack, Element Posn)
-> Parser (Posn, TokenT) [(Stack, Element Posn)]
forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1 (String -> Parser (Posn, TokenT) (Stack, Element Posn)
element String
"HTML document")
    [Misc]
ms    <- Parser (Posn, TokenT) Misc -> Parser (Posn, TokenT) [Misc]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser (Posn, TokenT) Misc
misc
    Document Posn -> Parser (Posn, TokenT) (Document Posn)
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 Prolog
p SymTab EntityDef
forall a. SymTab a
emptyST (case ((Stack, Element Posn) -> Element Posn)
-> [(Stack, Element Posn)] -> [Element Posn]
forall a b. (a -> b) -> [a] -> [b]
map (Stack, Element Posn) -> Element Posn
forall a b. (a, b) -> b
snd [(Stack, Element Posn)]
ht of
                                  [Element Posn
e] -> Element Posn
e
                                  [Element Posn]
es  -> QName -> [Attribute] -> [Content Posn] -> Element Posn
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (String -> QName
N String
"html") [] ((Element Posn -> Content Posn) -> [Element Posn] -> [Content Posn]
forall a b. (a -> b) -> [a] -> [b]
map Element Posn -> Content Posn
mkCElem [Element Posn]
es))
                               [Misc]
ms)
  where mkCElem :: Element Posn -> Content Posn
mkCElem Element Posn
e = Element Posn -> Posn -> Content Posn
forall i. Element i -> i -> Content i
CElem Element Posn
e Posn
noPos

comment :: HParser Comment
comment :: Parser (Posn, TokenT) String
comment = do
    HParser TokenT
-> HParser TokenT
-> Parser (Posn, TokenT) String
-> Parser (Posn, TokenT) String
forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket (TokenT -> HParser TokenT
tok TokenT
TokCommentOpen) (TokenT -> HParser TokenT
tok TokenT
TokCommentClose) Parser (Posn, TokenT) String
freetext

processinginstruction :: HParser ProcessingInstruction
processinginstruction :: HParser ProcessingInstruction
processinginstruction = do
    TokenT -> HParser TokenT
tok TokenT
TokPIOpen
    HParser ProcessingInstruction -> HParser ProcessingInstruction
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (HParser ProcessingInstruction -> HParser ProcessingInstruction)
-> HParser ProcessingInstruction -> HParser ProcessingInstruction
forall a b. (a -> b) -> a -> b
$ do
      String
n <- Parser (Posn, TokenT) String
string  Parser (Posn, TokenT) String
-> Parser (Posn, TokenT) String -> Parser (Posn, TokenT) String
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` String -> Parser (Posn, TokenT) String
forall a. String -> HParser a
failP String
"processing instruction has no target"
      String
f <- Parser (Posn, TokenT) String
freetext
      (TokenT -> HParser TokenT
tok TokenT
TokPIClose HParser TokenT -> HParser TokenT -> HParser TokenT
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` TokenT -> HParser TokenT
tok TokenT
TokAnyClose) HParser TokenT -> HParser TokenT -> HParser TokenT
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` String -> HParser TokenT
forall a. String -> HParser a
failP String
"missing ?> or >"
      ProcessingInstruction -> HParser ProcessingInstruction
forall (m :: * -> *) a. Monad m => a -> m a
return (String
n, String
f)

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

prolog :: HParser Prolog
prolog :: HParser Prolog
prolog = do
    Maybe XMLDecl
x <- HParser XMLDecl -> HParser (Maybe XMLDecl)
forall a. HParser a -> HParser (Maybe a)
maybe HParser XMLDecl
xmldecl
    [Misc]
m1 <- Parser (Posn, TokenT) Misc -> Parser (Posn, TokenT) [Misc]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser (Posn, TokenT) Misc
misc
    Maybe DocTypeDecl
dtd <- HParser DocTypeDecl -> HParser (Maybe DocTypeDecl)
forall a. HParser a -> HParser (Maybe a)
maybe HParser DocTypeDecl
doctypedecl
    [Misc]
m2 <- Parser (Posn, TokenT) Misc -> Parser (Posn, TokenT) [Misc]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser (Posn, TokenT) Misc
misc
    Prolog -> HParser Prolog
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe XMLDecl -> [Misc] -> Maybe DocTypeDecl -> [Misc] -> Prolog
Prolog Maybe XMLDecl
x [Misc]
m1 Maybe DocTypeDecl
dtd [Misc]
m2)

xmldecl :: HParser XMLDecl
xmldecl :: HParser XMLDecl
xmldecl = do
    TokenT -> HParser TokenT
tok TokenT
TokPIOpen
    String -> HParser ()
word String
"xml" HParser () -> HParser () -> HParser ()
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` String -> HParser ()
word String
"XML"
    Posn
p <- HParser Posn
posn
    String
s <- Parser (Posn, TokenT) String
freetext
    TokenT -> HParser TokenT
tok TokenT
TokPIClose HParser TokenT -> HParser TokenT -> HParser TokenT
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` String -> HParser TokenT
forall a. String -> HParser a
failBadP String
"missing ?> in <?xml ...?>"
    ((String -> HParser XMLDecl)
-> (XMLDecl -> HParser XMLDecl)
-> Either String XMLDecl
-> HParser XMLDecl
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
Prelude.either String -> HParser XMLDecl
forall a. String -> HParser a
failP XMLDecl -> HParser XMLDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String XMLDecl -> HParser XMLDecl)
-> (String -> Either String XMLDecl) -> String -> HParser XMLDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either String XMLDecl, [(Posn, TokenT)]) -> Either String XMLDecl
forall a b. (a, b) -> a
fst ((Either String XMLDecl, [(Posn, TokenT)])
 -> Either String XMLDecl)
-> (String -> (Either String XMLDecl, [(Posn, TokenT)]))
-> String
-> Either String XMLDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HParser XMLDecl
-> [(Posn, TokenT)] -> (Either String XMLDecl, [(Posn, TokenT)])
forall t a. Parser t a -> [t] -> (Either String a, [t])
runParser HParser XMLDecl
aux ([(Posn, TokenT)] -> (Either String XMLDecl, [(Posn, TokenT)]))
-> (String -> [(Posn, TokenT)])
-> String
-> (Either String XMLDecl, [(Posn, TokenT)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Posn -> String -> [(Posn, TokenT)]
xmlReLex Posn
p) String
s
  where
    aux :: HParser XMLDecl
aux = do
      String
v <- Parser (Posn, TokenT) String
versioninfo  Parser (Posn, TokenT) String
-> Parser (Posn, TokenT) String -> Parser (Posn, TokenT) String
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` String -> Parser (Posn, TokenT) String
forall a. String -> HParser a
failP String
"missing XML version info"
      Maybe EncodingDecl
e <- HParser EncodingDecl -> HParser (Maybe EncodingDecl)
forall a. HParser a -> HParser (Maybe a)
maybe HParser EncodingDecl
encodingdecl
      Maybe Bool
s <- HParser Bool -> HParser (Maybe Bool)
forall a. HParser a -> HParser (Maybe a)
maybe HParser Bool
sddecl
      XMLDecl -> HParser XMLDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe EncodingDecl -> Maybe Bool -> XMLDecl
XMLDecl String
v Maybe EncodingDecl
e Maybe Bool
s)

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

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


-- Question: for HTML, should we disallow in-line DTDs, allowing only externals?
-- Answer: I think so.

doctypedecl :: HParser DocTypeDecl
doctypedecl :: HParser DocTypeDecl
doctypedecl = do
    TokenT -> HParser TokenT
tok TokenT
TokSpecialOpen
    TokenT -> HParser TokenT
tok (Special -> TokenT
TokSpecial Special
DOCTYPEx)
    HParser DocTypeDecl -> HParser DocTypeDecl
forall (p :: * -> *) a. Commitment p => p a -> p a
commit (HParser DocTypeDecl -> HParser DocTypeDecl)
-> HParser DocTypeDecl -> HParser DocTypeDecl
forall a b. (a -> b) -> a -> b
$ do
      QName
n <- HParser QName
qname
      Maybe ExternalID
eid <- HParser ExternalID -> HParser (Maybe ExternalID)
forall a. HParser a -> HParser (Maybe a)
maybe HParser ExternalID
externalid
--    es <- maybe (bracket (tok TokSqOpen) (commit $ tok TokSqClose)) (many markupdecl)
      TokenT -> HParser TokenT
tok TokenT
TokAnyClose  HParser TokenT -> HParser TokenT -> HParser TokenT
forall t a. Parser t a -> Parser t a -> Parser t a
`onFail` String -> HParser TokenT
forall a. String -> HParser a
failP String
"missing > in DOCTYPE decl"
--    return (DTD n eid (case es of { Nothing -> []; Just e -> e }))
      DocTypeDecl -> HParser DocTypeDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> Maybe ExternalID -> [MarkupDecl] -> DocTypeDecl
DTD QName
n Maybe ExternalID
eid [])

--markupdecl :: HParser MarkupDecl
--markupdecl =
--    (Element <$> elementdecl) `onFail`
--    (AttList <$> attlistdecl) `onFail`
--    (Entity <$> entitydecl) `onFail`
--    (Notation <$> notationdecl) `onFail`
--    (MarkupMisc <$> misc) `onFail`
--    PEREF(MarkupPE,markupdecl)
--
--extsubset :: HParser ExtSubset
--extsubset = do
--    td <- maybe textdecl
--    ds <- many extsubsetdecl
--    return (ExtSubset td ds)
--
--extsubsetdecl :: HParser ExtSubsetDecl
--extsubsetdecl =
--    (ExtMarkupDecl <$> markupdecl) `onFail`
--    (ExtConditionalSect <$> conditionalsect) `onFail`
--    PEREF(ExtPEReference,extsubsetdecl)

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




----
-- VERY IMPORTANT NOTE: The stack returned here contains those tags which
-- have been closed implicitly and need to be reopened again at the
-- earliest opportunity.
type Stack = [(Name,[Attribute])]

element :: Name -> HParser (Stack,Element Posn)
element :: String -> Parser (Posn, TokenT) (Stack, Element Posn)
element String
ctx =
  do
    TokenT -> HParser TokenT
tok TokenT
TokAnyOpen
    (ElemTag (N String
e) [Attribute]
avs) <- HParser ElemTag
elemtag
    ( if String
e String -> String -> Bool
`closes` String
ctx then
         -- insert the missing close-tag, fail forward, and reparse.
         ( do String -> HParser ()
forall (m :: * -> *). Monad m => String -> m ()
debug String
"/"
              [TokenT] -> HParser ()
unparse ([TokenT
TokEndOpen, String -> TokenT
TokName String
ctx, TokenT
TokAnyClose,
                        TokenT
TokAnyOpen, String -> TokenT
TokName String
e] [TokenT] -> [TokenT] -> [TokenT]
forall a. [a] -> [a] -> [a]
++ [Attribute] -> [TokenT]
reformatAttrs [Attribute]
avs)
              (Stack, Element Posn)
-> Parser (Posn, TokenT) (Stack, Element Posn)
forall (m :: * -> *) a. Monad m => a -> m a
return ([],