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

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

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

       This parser tries to interprete everything as HTML
       no errors are emitted during parsing. If something looks
       weired, warning messages are inserted in the document tree.

       All filter are pure XmlFilter,
       errror handling and IO is done in 'Text.XML.HXT.Parser.HtmlParser'
       or other modules

    -}

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

    module Text.XML.HXT.Parser.HtmlParsec
        ( parseHtmlText
        , parseHtmlDocument
        , parseHtmlContent
        , isEmptyHtmlTag
        , isInnerHtmlTagOf
        , closesHtmlTag
        , emptyHtmlTags
        )

    where

    import Control.Applicative                      ( (<$>) )

    import Data.Char                                ( toLower
                                                    , toUpper
                                                    )
    import Data.Char.Properties.XMLCharProps        ( isXmlChar
                                                    )
    import Data.Maybe                               ( fromMaybe
                                                    , fromJust
                                                    )
    import qualified Data.Map                       as M

    import Text.ParserCombinators.Parsec            ( SourcePos
                                                    , anyChar
                                                    , between
                                                    -- , char
                                                    , eof
                                                    , getPosition
                                                    , many
                                                    , many1
                                                    , noneOf
                                                    , option
                                                    , runParser
                                                    , satisfy
                                                    , string
                                                    , try
                                                    , (<|>)
                                                    )

    import Text.XML.HXT.DOM.Interface
    import Text.XML.HXT.DOM.XmlNode                 ( mkText'
                                                    , mkError'
                                                    , mkCdata'
                                                    , mkCmt'
                                                    , mkCharRef'
                                                    , mkElement'
                                                    , mkAttr'
                                                    , mkDTDElem'
                                                    , mkPi'
                                                    , isEntityRef
                                                    , getEntityRef
                                                    )
    import Text.XML.HXT.Parser.XmlTokenParser       ( allBut
                                                    , amp
                                                    , dq
                                                    , eq
                                                    , gt
                                                    , lt
                                                    , name
                                                    , pubidLiteral
                                                    , skipS
                                                    , skipS0
                                                    , sPace
                                                    , sq
                                                    , systemLiteral
                                                    , checkString
                                                    , singleCharsT
                                                    , referenceT
                                                    , mergeTextNodes
                                                    )
    import Text.XML.HXT.Parser.XmlParsec            ( misc
                                                    , parseXmlText
                                                    , xMLDecl'
                                                    )
    import Text.XML.HXT.Parser.XmlCharParser        ( xmlChar
                                                    , SimpleXParser
                                                    , withNormNewline
                                                    )
    import Text.XML.HXT.Parser.XhtmlEntities        ( xhtmlEntities
                                                    )

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

    parseHtmlText           :: String -> XmlTree -> XmlTrees
    parseHtmlText loc t     = parseXmlText htmlDocument (withNormNewline ()) loc $ t

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

    parseHtmlFromString     :: SimpleXParser XmlTrees -> String -> String -> XmlTrees
    parseHtmlFromString parser loc
        = either ((:[]) . mkError' c_err . (++ "\n") . show) id . runParser parser (withNormNewline ()) loc

    parseHtmlDocument       :: String -> String -> XmlTrees
    parseHtmlDocument       = parseHtmlFromString htmlDocument

    parseHtmlContent        :: String -> XmlTrees
    parseHtmlContent        = parseHtmlFromString htmlContent "string"

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

    type Context    = (XmlTreeFl, OpenTags)

    type XmlTreeFl  = XmlTrees -> XmlTrees

    type OpenTags   = [(String, XmlTrees, XmlTreeFl)]

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

    htmlDocument    :: SimpleXParser XmlTrees
    htmlDocument
        = do
          pl <- htmlProlog
          el <- htmlContent
          eof
          return (pl ++ el)

    htmlProlog      :: SimpleXParser XmlTrees
    htmlProlog
        = do
          xml <- option []
                 ( try xMLDecl'
                   <|>
                   ( do
                     pos <- getPosition
                     checkString "<?"
                     return $ [mkError' c_warn (show pos ++ " wrong XML declaration")]
                   )
                 )
          misc1   <- many misc
          dtdPart <- option []
                     ( try doctypedecl
                       <|>
                       ( do
                         pos <- getPosition
                         upperCaseString "<!DOCTYPE"
                         return $ [mkError' c_warn (show pos ++ " HTML DOCTYPE declaration ignored")]
                       )
                     )
          return (xml ++ misc1 ++ dtdPart)

    doctypedecl     :: SimpleXParser XmlTrees
    doctypedecl
        = between (upperCaseString "<!DOCTYPE") gt
          ( do
            skipS
            n <- name
            exId <- ( do
                      skipS
                      option [] externalID
                    )
            skipS0
            return [mkDTDElem' DOCTYPE ((a_name, n) : exId) []]
          )

    externalID      :: SimpleXParser Attributes
    externalID
        = do
          upperCaseString k_public
          skipS
          pl <- pubidLiteral
          sl <- option "" $ try ( do
                                  skipS
                                  systemLiteral
                                )
          return $ (k_public, pl) : if null sl then [] else [(k_system, sl)]

    htmlContent     :: SimpleXParser XmlTrees
    htmlContent
        = mergeTextNodes <$> htmlContent'

    htmlContent'    :: SimpleXParser XmlTrees
    htmlContent'
        = option []
          ( do
            context <- hContent (id, [])
            pos     <- getPosition
            return $ closeTags pos context
          )
          where
          closeTags _pos (body, [])
              = body []
          closeTags pos' (body, ((tn, al, body1) : restOpen))
              = closeTags pos'
                          ( addHtmlWarn (show pos' ++ ": no closing tag found for \"<" ++ tn ++ " ...>\"")
                            .
                            addHtmlTag tn al body
                            $
                            (body1, restOpen)
                          )

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

    hElement        :: Context -> SimpleXParser Context
    hElement context
        = ( do
            t <- hSimpleData
            return (addHtmlElem t context)
          )
          <|>
          hCloseTag context
          <|>
          hOpenTag context
          <|>
          ( do                      -- wrong tag, take it as text
            pos <- getPosition
            c   <- xmlChar
            return ( addHtmlWarn (show pos ++ " markup char " ++ show c ++ " not allowed in this context")
                     .
                     addHtmlElem (mkText' [c])
                     $
                     context
                   )
          )
          <|>
          ( do
            pos <- getPosition
            c <- anyChar
            return ( addHtmlWarn ( show pos
                                   ++ " illegal data in input or illegal XML char "
                                   ++ show c
                                   ++ " found and ignored, possibly wrong encoding scheme used")
                     $
                     context
                   )
          )

    hSimpleData     :: SimpleXParser XmlTree
    hSimpleData
        = charData''
          <|>
          hReference'
          <|>
          hComment
          <|>
          hpI
          <|>
          hcDSect
        where
        charData''
            = do
              t <- many1 (satisfy (\ x -> isXmlChar x && not (x == '<' || x == '&')))
              return (mkText' t)

    hCloseTag       :: Context -> SimpleXParser Context
    hCloseTag context
        = do
          checkString "</"
          n <- lowerCaseName
          skipS0
          pos <- getPosition
          checkSymbol gt ("closing > in tag \"</" ++ n ++ "\" expected") (closeTag pos n context)

    hOpenTag        :: Context -> SimpleXParser Context
    hOpenTag context
        = ( do
            e   <- hOpenTagStart
            hOpenTagRest e context
          )

    hOpenTagStart   :: SimpleXParser ((SourcePos, String), XmlTrees)
    hOpenTagStart
        = do
          np <- try ( do
                      lt
                      pos <- getPosition
                      n <- lowerCaseName
                      return (pos, n)
                    )
          skipS0
          as <- hAttrList
          return (np, as)

    hOpenTagRest    :: ((SourcePos, String), XmlTrees) -> Context -> SimpleXParser Context
    hOpenTagRest ((pos, tn), al) context
        = ( do
            checkString "/>"
            return (addHtmlTag tn al id context)
          )
          <|>
          ( do
            context1 <- checkSymbol gt ("closing > in tag \"<" ++ tn ++ "...\" expected") context
            return ( let context2 = closePrevTag pos tn context1
                     in
                     ( if isEmptyHtmlTag tn
                       then addHtmlTag tn al id
                       else openTag tn al
                     ) context2
                   )
          )

    hAttrList       :: SimpleXParser XmlTrees
    hAttrList
        = many (try hAttribute)
          where
          hAttribute
              = do
                n <- lowerCaseName
                v <- hAttrValue
                skipS0
                return $ mkAttr' (mkName n) v

    hAttrValue      :: SimpleXParser XmlTrees
    hAttrValue
        = option []
          ( eq >> hAttrValue' )

    hAttrValue'     :: SimpleXParser XmlTrees
    hAttrValue'
        = try ( between dq dq (hAttrValue'' "&\"") )
          <|>
          try ( between sq sq (hAttrValue'' "&\'") )
          <|>
          ( do                      -- HTML allows unquoted attribute values
            cs <- many (noneOf " \r\t\n>\"\'")
            return [mkText' cs]
          )

    hAttrValue''    :: String -> SimpleXParser XmlTrees
    hAttrValue'' notAllowed
        = many ( hReference' <|> singleCharsT notAllowed)

    hReference'     :: SimpleXParser XmlTree
    hReference'
        = try hReferenceT
          <|>
          ( do
            amp
            return (mkText' "&")
          )

    hReferenceT     :: SimpleXParser XmlTree
    hReferenceT
        = do
          r <- referenceT
          return ( if isEntityRef r
                   then substRef  r
                   else r
                 )
        where
        -- optimization: HTML entity refs are substituted by char refs, so a later entity ref substituion isn't required
        substRef r
            = case (lookup en xhtmlEntities) of
              Just i        -> mkCharRef' i
              Nothing       -> r                            -- not found: the entity ref remains as it is
                                                            -- this is also done in the XML parser
    {- alternative def
              Nothing       -> mkText' ("&" ++ en ++ ";")   -- not found: the entity ref is taken as text
    -}
            where
            en = fromJust . getEntityRef $ r

    hContent        :: Context -> SimpleXParser Context
    hContent context
        = option context
          ( hElement context
            >>=
            hContent
          )

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

    -- hComment allows "--" in comments
    -- comment from XML spec does not

    hComment                :: SimpleXParser XmlTree
    hComment
        = do
          checkString "<!--"
          pos <- getPosition
          c <- allBut many "-->"
          closeCmt pos c
        where
        closeCmt pos c
            = ( do
                checkString "-->"
                return (mkCmt' c)
              )
              <|>
              ( return $
                mkError' c_warn (show pos ++ " no closing comment sequence \"-->\" found")
              )

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

    hpI             :: SimpleXParser XmlTree
    hpI = checkString "<?"
          >>
          ( try ( do
                  n <- name
                  p <- sPace >> allBut many "?>"
                  string "?>" >>
                         return (mkPi' (mkName n) [mkAttr' (mkName a_value) [mkText' p]])
                )
            <|>
            ( do
              pos <- getPosition
              return $
                mkError' c_warn (show pos ++ " illegal PI found")
            )
          )

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

    hcDSect        :: SimpleXParser XmlTree
    hcDSect
        = do
          checkString "<![CDATA["
          pos <- getPosition
          t <- allBut many "]]>"
          closeCD pos t
        where
        closeCD pos t
            = ( do
                checkString "]]>"
                return (mkCdata' t)
              )
              <|>
              ( return $
                mkError' c_warn (show pos ++ " no closing CDATA sequence \"]]>\" found")
              )

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

    checkSymbol     :: SimpleXParser () -> String -> Context -> SimpleXParser Context
    checkSymbol p msg context
        = ( p
            >>
            return context
          )
          <|>
          ( do
            pos <- getPosition
            return $ addHtmlWarn (show pos ++ " " ++ msg) context
          )

    lowerCaseName   :: SimpleXParser String
    lowerCaseName
        = do
          n <- name
          return (map toLower n)

    upperCaseString :: String -> SimpleXParser ()
    upperCaseString s
        = try (sequence (map (\ c -> satisfy (( == c) . toUpper)) s)) >> return ()

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

    addHtmlTag      :: String -> XmlTrees -> XmlTreeFl -> Context -> Context
    addHtmlTag tn al body context
        = e `seq`
          addHtmlElem e context
        where
        e = mkElement' (mkName tn) al (body [])

    addHtmlWarn     :: String -> Context -> Context
    addHtmlWarn msg
        = addHtmlElem (mkError' c_warn msg)

    addHtmlElem    :: XmlTree -> Context -> Context
    addHtmlElem elem' (body, openTags)
        = (body . (elem' :), openTags)

    openTag         :: String -> XmlTrees -> Context -> Context
    openTag tn al (body, openTags)
        = (id, (tn, al, body) : openTags)

    closeTag        :: SourcePos -> String -> Context -> Context
    closeTag pos n context
        | n `elem` (map ( \ (n1, _, _) -> n1) $ snd context)
            = closeTag' n context
        | otherwise
            = addHtmlWarn (show pos ++ " no opening tag found for </" ++ n ++ ">")
              .
              addHtmlTag n [] id
              $
              context
        where
        closeTag' n' (body', (n1, al1, body1) : restOpen)
            = close context1
              where
              context1
                  = addHtmlTag n1 al1 body' (body1, restOpen)
              close
                  | n' == n1
                    = id
                  | n1 `isInnerHtmlTagOf` n'
                      = closeTag pos n'
                  | otherwise
                    = addHtmlWarn (show pos ++ " no closing tag found for \"<" ++ n1 ++ " ...>\"")
                      .
                      closeTag' n'
        closeTag' _ _
            = error "illegal argument for closeTag'"

    closePrevTag    :: SourcePos -> String -> Context -> Context
    closePrevTag _pos _n context@(_body, [])
        = context
    closePrevTag pos n context@(body, (n1, al1, body1) : restOpen)
        | n `closesHtmlTag` n1
            = closePrevTag pos n
              ( addHtmlWarn (show pos ++ " tag \"<" ++ n1 ++ " ...>\" implicitly closed by opening tag \"<" ++ n ++ " ...>\"")
                .
                addHtmlTag n1 al1 body
                $
                (body1, restOpen)
              )
        | otherwise
            = context

    -- ------------------------------------------------------------
    --
    -- taken from HaXml and extended

    isEmptyHtmlTag  :: String -> Bool
    isEmptyHtmlTag n
        = n `elem`
          emptyHtmlTags

    emptyHtmlTags   :: [String]
    emptyHtmlTags
        = [ "area"
          , "base"
          , "br"
          , "col"
          , "frame"
          , "hr"
          , "img"
          , "input"
          , "link"
          , "meta"
          , "param"
          ]
    {-# INLINE emptyHtmlTags #-}

    isInnerHtmlTagOf        :: String -> String -> Bool
    n `isInnerHtmlTagOf` tn
        = n `elem`
          ( fromMaybe [] . lookup tn
          $ [ ("body",    ["p"])
            , ("caption", ["p"])
            , ("dd",      ["p"])
            , ("div",     ["p"])
            , ("dl",      ["dt","dd"])
            , ("dt",      ["p"])
            , ("li",      ["p"])
            , ("map",     ["p"])
            , ("object",  ["p"])
            , ("ol",      ["li"])
            , ("table",   ["th","tr","td","thead","tfoot","tbody"])
            , ("tbody",   ["th","tr","td"])
            , ("td",      ["p"])
            , ("tfoot",   ["th","tr","td"])
            , ("th",      ["p"])
            , ("thead",   ["th","tr","td"])
            , ("tr",      ["th","td"])
            , ("ul",      ["li"])
            ]
          )

    -- a bit more efficient implementation of closes

    closesHtmlTag   :: String -> String -> Bool
    closesHtmlTag t t2
        = fromMaybe False . fmap ($ t) . M.lookup t2 $ closedByTable
    {-# INLINE closesHtmlTag #-}

    closedByTable   :: M.Map String (String -> Bool)
    closedByTable
        = M.fromList $
          [ ("a",   (== "a"))
          , ("li",  (== "li" ))
          , ("th",  (`elem` ["th", "td", "tr"] ))
          , ("td",  (`elem` ["th", "td", "tr"] ))
          , ("tr",  (== "tr"))
          , ("dt",  (`elem` ["dt", "dd"] ))
          , ("dd",  (`elem` ["dt", "dd"] ))
          , ("p",   (`elem` ["hr"
                            , "h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))
          , ("colgroup",    (`elem` ["colgroup", "thead", "tfoot", "tbody"] ))
          , ("form",        (`elem` ["form"] ))
          , ("label",       (`elem` ["label"] ))
          , ("map",         (`elem` ["map"] ))
          , ("option",      const True)
          , ("script",      const True)
          , ("style",       const True)
          , ("textarea",    const True)
          , ("title",       const True)
          , ("select",      ( /= "option"))
          , ("thead",       (`elem` ["tfoot","tbody"] ))
          , ("tbody",       (== "tbody" ))
          , ("tfoot",       (== "tbody" ))
          , ("h1",  (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))
          , ("h2",  (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))
          , ("h3",  (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))
          , ("h4",  (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))
          , ("h5",  (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))
          , ("h6",  (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] ))
          ]

    {-
    closesHtmlTag :: String -> String -> Bool
    closesHtmlTag   = closes

    closes :: String -> String -> Bool

    "a"     `closes` "a"                                    = True
    "li"    `closes` "li"                                   = True
    "th"    `closes`  t    | t `elem` ["th","td"]           = True
    "td"    `closes`  t    | t `elem` ["th","td"]           = True
    "tr"    `closes`  t    | t `elem` ["th","td","tr"]      = True
    "dt"    `closes`  t    | t `elem` ["dt","dd"]           = True
    "dd"    `closes`  t    | t `elem` ["dt","dd"]           = True
    "hr"    `closes`  "p"                                   = True
    "colgroup"
            `closes` "colgroup"                             = True
    "form"  `closes` "form"                                 = True
    "label" `closes` "label"                                = True
    "map"   `closes` "map"                                  = True
    "object"
            `closes` "object"                               = True
    _       `closes` t  | t `elem` ["option"
                                   ,"script"
                                   ,"style"
                                   ,"textarea"
                                   ,"title"
                                   ]                        = True
    t       `closes` "select" | t /= "option"               = True
    "thead" `closes` t  | t `elem` ["colgroup"]             = True
    "tfoot" `closes` t  | t `elem` ["thead"
                                   ,"colgroup"]             = True
    "tbody" `closes` t  | t `elem` ["tbody"
                                   ,"tfoot"
                                   ,"thead"
                                   ,"colgroup"]             = True
    t       `closes` t2 | t `elem` ["h1","h2","h3"
                                   ,"h4","h5","h6"
                                   ,"dl","ol","ul"
                                   ,"table"
                                   ,"div","p"
                                   ]
                          &&
                          t2 `elem` ["h1","h2","h3"
                                    ,"h4","h5","h6"
                                    ,"p"                    -- not "div"
                                    ]                       = True
    _       `closes` _                                      = False
    -}

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