content: {-# OPTIONS_GHC -O2 #-}
  
  module Text.HTML.TagSoup.Parser2(
      parseTags, parseTagsOptions,
      ParseOptions(..), parseOptions
      ) where
  
  import Text.ParserCombinators.LazyParse
  import Data.Char
  import Control.Monad
  import Control.Arrow
  import Text.HTML.TagSoup.Type
  import Text.HTML.TagSoup.Options
  import qualified Text.StringLike as Str(concat)
  import Text.StringLike hiding(concat)
  import Debug.Trace
  
  
  ---------------------------------------------------------------------
  -- MAIN RUN FUNCTION
  
  parseTags :: StringLike str => str -> [Tag str]
  parseTags = parseTagsOptions parseOptions
  
  
  parseTagsOptions :: StringLike str => ParseOptions str -> str -> [Tag str]
  parseTagsOptions opts x = mergeTexts $ runParser tags $ S x nullPosition [] opts
  
  
  -- | Combine adjacent text nodes.
  --
  --   If two text nodes are separated only a position node, delete the position.
  --   If two text nodes are separated only by a warning, move the warning afterwards.
  --   If a position immediately proceeds a warning, count that into the warning.
  --
  --   Note: this function leaks stack on Hugs.
  mergeTexts :: StringLike str => [Tag str] -> [Tag str]
  mergeTexts (TagText x:xs) = TagText (Str.concat $ x:texts) : warns ++ mergeTexts rest
      where
          (texts,warns,rest) = f xs
  
          f (TagText x:xs) = (x:a,b,c)
              where (a,b,c) = f xs
          f (TagPosition _ _:TagText x:xs) = (x:a,b,c)
              where (a,b,c) = f xs
  
          f (p@TagPosition{}:TagWarning y:xs) = (a,p:TagWarning y:b,c)
              where (a,b,c) = f xs
          f (TagWarning x:xs) = (a,TagWarning x:b,c)
              where (a,b,c) = f xs
  
          f xs = ([],[],xs)
  
  mergeTexts (x:xs) = x : mergeTexts xs
  mergeTexts [] = []
  
  
  
  ---------------------------------------------------------------------
  -- PARAMETERISATION
  
  data S str = S {string :: str, pos :: !Position, warn :: [(Position,str)], opts :: ParseOptions str}
  
  instance StringLike s => StringLike (S s) where
      uncons s = case uncons (string s) of
          Nothing -> Nothing
          Just (x,xs) -> Just (x, s{string=xs, pos=positionChar (pos s) x})
  
  
  addWarn :: str -> Parser (S str) ()
  addWarn msg = modify $ \s ->
      if optTagWarning (opts s) then s{warn=(pos s,msg):warn s} else s
  
  outWarn :: Parser (S str) [Tag str] -> Parser (S str) [Tag str]
  outWarn p = do
      s <- get
      put s{warn=[]}
      res <- p
      return $ concat [position s{pos=p} [TagWarning w] | (p,w) <- warn s] ++ res
  
  position :: S str -> [Tag str] -> [Tag str]
  position s xs | optTagPosition $ opts s = tagPosition (pos s) : xs
                | otherwise = xs
  
  tagPosWarnFix :: ParseOptions str -> [Tag str] -> [Tag str]
  tagPosWarnFix opts = if optTagWarning opts then id else filter (not . isTagWarning)
  
  debug p = do
      s <- get
      trace (take 50 $ string s) p
  
  ---------------------------------------------------------------------
  -- USEFUL UTILITIES
  
  isNameChar x = not $ isSpace x || x `elem` "><&'\"="
  
  
  nowLit :: StringLike str => String -> Parser (S str) ()
  nowLit s = do
      r <- lit s
      when (r == "") $ addWarn $ fromString $ "Expected but not found: " ++ s
  
  
  name :: StringLike str => Parser (S str) str
  name = many isNameChar
  
  nowName :: StringLike str => Parser (S str) str
  nowName = do
      r <- name
      when (isEmpty r) $ addWarn $ fromString $ "Expected but not found: a name"
      return r
  
  spaces :: StringLike str => Parser (S str) ()
  spaces = do
      x <- many isSpace
      let _ = x :: String
      return ()
  
  
  ---------------------------------------------------------------------
  -- THE PARSER
  
  tags, tag, comment, entity, close, open, text, cdata :: StringLike str => Parser (S str) [Tag str]
  
  tags = do
      s <- get
      outWarn $ choice $ do
          eof ==> return []
          def ==> do x<-tag ; xs<-tags ; return $ position s $ x ++ xs
  
  tag = choice $ do
      "<!--" ==> comment
      "&" ==> entity
      "<![CDATA[" ==> cdata
      "</" ==> close
      "<" ==> open
      def ==> text
  
  comment = do res <- takesUntil "-->" ; nowLit "-->" ; return [TagComment res]
  
  entity = do
      res <- choice $ do
          "#x" ==> many isHexDigit >>= entityName "#x"
          "#" ==> many isDigit >>= entityName "#"
          def ==> many isAlphaNum >>= entityName ""
      nowLit ";"
      return res
      where
          entityName prefix x = do
              s <- get
              return $ tagPosWarnFix (opts s) $ optLookupEntity (opts s) $
                  fromString prefix `append` x
  
  close = do spaces ; res<-nowName ; spaces ; nowLit ">" ; return [TagClose res]
  
  text = do res <- many (`notElem` "<&") ; return [TagText res]
  
  open = do spaces ; x<-nowName ; spaces ; xs<-atts x; return $ TagOpen x (fst xs) : snd xs
  
  cdata = do res <- takesUntil "]]>" ; return [TagCData res]
  
  
  ---------------------------------------------------------------------
  -- PARSING ATTRIBUTES
  
  atts :: StringLike str => str -> Parser (S str) ([(str,str)],[Tag str])
  atts param = choice $ do
      "/>" ==> return ([],[TagClose param])
      ">"  ==> return ([],[])
      "\"" ==> do y<-str "\"" ; spaces ; res<-atts param ; return $ first ((empty,y):) res
      "\'" ==> do y<-str "\'" ; spaces ; res<-atts param ; return $ first ((empty,y):) res
      def ==> do
          x<-name
          if isEmpty x
              then do nowLit ">" ; return ([],[])
              else do spaces ; y<-attEq ; spaces ; res<-atts param; return $ first ((x,y):) res
  
  -- ="bar"
  attEq :: StringLike str => Parser (S str) str
  attEq = choice $ do
      "=" ==> do spaces ; attQuote
      def ==> do spaces ; return empty
  
  -- "bar"
  attQuote :: StringLike str => Parser (S str) str
  attQuote = choice $ do
      "\"" ==> str "\""
      "'"  ==> str "'"
      def ==> name
  
  -- bar"
  str :: StringLike str => String -> Parser (S str) str
  str param = choice $ do
      eof ==> do nowLit param ; return empty
      param ==> return empty
      "&" ==> do x<-entity ; xs<-str param ; return $ innerText x `append` xs
      def ==> do x <- many (`notElem` ("&"++param)) ; xs<-str param ; return $ x `append` xs
  