content: {-# LANGUAGE DeriveDataTypeable #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE CPP #-}
  module Text.Hamlet.XMLParse
      ( Result (..)
      , Content (..)
      , Doc (..)
      , parseDoc
      , Binding (..)
      , DataConstr (..)
      , Module (..)
      )
      where
  
  import Text.Shakespeare.Base
  import Control.Applicative ((<$>), Applicative (..))
  import Control.Monad
  import Data.Char (isUpper)
  import Data.Data
  import Text.ParserCombinators.Parsec hiding (Line)
  
  data Result v = Error String | Ok v
      deriving (Show, Eq, Read, Data, Typeable)
  instance Monad Result where
      return = Ok
      Error s >>= _ = Error s
      Ok v >>= f = f v
  #if MIN_VERSION_base(4,13,0)
  instance MonadFail Result where
  #endif
      fail = Error
  instance Functor Result where
      fmap = liftM
  instance Applicative Result where
      pure = return
      (<*>) = ap
  
  data Content = ContentRaw String
               | ContentVar Deref
               | ContentEmbed Deref
      deriving (Show, Eq, Read, Data, Typeable)
  
  data Line = LineForall Deref Binding
            | LineIf Deref
            | LineElseIf Deref
            | LineElse
            | LineWith [(Deref, Binding)]
            | LineMaybe Deref Binding
            | LineNothing
            | LineCase Deref
            | LineOf Binding
            | LineTag
              { _lineTagName :: String
              , _lineAttr :: [(Maybe Deref, String, [Content])]
              , _lineContent :: [Content]
              , _lineAttrs :: [Deref]
              }
            | LineContent [Content]
      deriving (Eq, Show, Read)
  
  parseLines :: String -> Result [(Int, Line)]
  parseLines s =
      case parse (many parseLine) s s of
          Left e -> Error $ show e
          Right x -> Ok x
  
  parseLine :: Parser (Int, Line)
  parseLine = do
      ss <- fmap sum $ many ((char ' ' >> return 1) <|>
                             (char '\t' >> fail "Tabs are not allowed in Hamlet indentation"))
      x <- comment <|>
           htmlComment <|>
           backslash <|>
           controlIf <|>
           controlElseIf <|>
           (try (string "$else") >> spaceTabs >> eol >> return LineElse) <|>
           controlMaybe <|>
           (try (string "$nothing") >> spaceTabs >> eol >> return LineNothing) <|>
           controlForall <|>
           controlWith <|>
           controlCase <|>
           controlOf <|>
           angle <|>
           invalidDollar <|>
           (eol' >> return (LineContent [])) <|>
           (do
              cs <- content InContent
              isEof <- (eof >> return True) <|> return False
              if null cs && ss == 0 && isEof
                  then fail "End of Hamlet template"
                  else return $ LineContent cs)
      return (ss, x)
    where
      eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ())
      eol = eof <|> eol'
      invalidDollar = do
          _ <- char '$'
          fail "Received a command I did not understand. If you wanted a literal $, start the line with a backslash."
      comment = do
          _ <- try $ string "$#"
          _ <- many $ noneOf "\r\n"
          eol
          return $ LineContent []
      htmlComment = do
          _ <- try $ string "<!--"
          _ <- manyTill anyChar $ try $ string "-->"
          x <- many nonComments
          eol
          return $ LineContent [ContentRaw $ concat x] -- FIXME handle variables?
      nonComments = (many1 $ noneOf "\r\n<") <|> (do
          _ <- char '<'
          (do
              _ <- try $ string "!--"
              _ <- manyTill anyChar $ try $ string "-->"
              return "") <|> return "<")
      backslash = do
          _ <- char '\\'
          (eol >> return (LineContent [ContentRaw "\n"]))
              <|> (LineContent <$> content InContent)
      controlIf = do
          _ <- try $ string "$if"
          spaces
          x <- parseDeref
          _ <- spaceTabs
          eol
          return $ LineIf x
      controlElseIf = do
          _ <- try $ string "$elseif"
          spaces
          x <- parseDeref
          _ <- spaceTabs
          eol
          return $ LineElseIf x
      binding = do
          y <- identPattern
          spaces
          _ <- string "<-"
          spaces
          x <- parseDeref
          _ <- spaceTabs
          return (x,y)
      bindingSep = char ',' >> spaceTabs
      controlMaybe = do
          _ <- try $ string "$maybe"
          spaces
          (x,y) <- binding
          eol
          return $ LineMaybe x y
      controlForall = do
          _ <- try $ string "$forall"
          spaces
          (x,y) <- binding
          eol
          return $ LineForall x y
      controlWith = do
          _ <- try $ string "$with"
          spaces
          bindings <- (binding `sepBy` bindingSep) `endBy` eol
          return $ LineWith $ concat bindings -- concat because endBy returns a [[(Deref,Ident)]]
      controlCase = do
          _ <- try $ string "$case"
          spaces
          x <- parseDeref
          _ <- spaceTabs
          eol
          return $ LineCase x
      controlOf = do
          _   <- try $ string "$of"
          spaces
          x <- identPattern
          _   <- spaceTabs
          eol
          return $ LineOf x
      content cr = do
          x <- many $ content' cr
          case cr of
              InQuotes -> void $ char '"'
              NotInQuotes -> return ()
              NotInQuotesAttr -> return ()
              InContent -> eol
          return $ cc x
        where
          cc [] = []
          cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c
          cc (a:b) = a : cc b
      content' cr =     contentHash cr
                    <|> contentCaret
                    <|> contentReg cr
      contentHash cr = do
          x <- parseHash
          case x of
              Left "#" -> case cr of
                            NotInQuotes -> fail "Expected hash at end of line, got Id"
                            _ -> return $ ContentRaw "#"
              Left str -> return $ ContentRaw str
              Right deref -> return $ ContentVar deref
      contentCaret = do
          x <- parseCaret
          case x of
              Left str -> return $ ContentRaw str
              Right deref -> return $ ContentEmbed deref
      contentReg InContent = (ContentRaw . return) <$> noneOf "#@^\r\n"
      contentReg NotInQuotes = (ContentRaw . return) <$> noneOf "@^#. \t\n\r>"
      contentReg NotInQuotesAttr = (ContentRaw . return) <$> noneOf "@^ \t\n\r>"
      contentReg InQuotes = (ContentRaw . return) <$> noneOf "#@^\"\n\r"
      tagAttribValue notInQuotes = do
          cr <- (char '"' >> return InQuotes) <|> return notInQuotes
          content cr
      tagCond = do
          d <- between (char ':') (char ':') parseDeref
          tagAttrib (Just d)
      tagAttrib cond = do
          s <- many1 $ noneOf " \t=\r\n><"
          v <- (char '=' >> tagAttribValue NotInQuotesAttr) <|> return []
          return $ TagAttrib (cond, s, v)
  
      tagAttrs = do
          _ <- char '*'
          d <- between (char '{') (char '}') parseDeref
          return $ TagAttribs d
  
      tag' = foldr tag'' ("div", [], [])
      tag'' (TagName s) (_, y, as) = (s, y, as)
      tag'' (TagAttrib s) (x, y, as) = (x, s : y, as)
      tag'' (TagAttribs s) (x, y, as) = (x, y, s : as)
  
      ident :: Parser Ident
      ident = do
        i <- many1 (alphaNum <|> char '_' <|> char '\'')
        white
        return (Ident i)
       <?> "identifier"
  
      parens = between (char '(' >> white) (char ')' >> white)
  
      brackets = between (char '[' >> white) (char ']' >> white)
  
      braces = between (char '{' >> white) (char '}' >> white)
  
      comma = char ',' >> white
  
      atsign = char '@' >> white
  
      equals = char '=' >> white
  
      white = skipMany $ char ' '
  
      wildDots = string ".." >> white
  
      isVariable (Ident (x:_)) = not (isUpper x)
      isVariable (Ident []) = error "isVariable: bad identifier"
  
      isConstructor (Ident (x:_)) = isUpper x
      isConstructor (Ident []) = error "isConstructor: bad identifier"
  
      identPattern :: Parser Binding
      identPattern = gcon True <|> apat
        where
        apat = choice
          [ varpat
          , gcon False
          , parens tuplepat
          , brackets listpat
          ]
  
        varpat = do
          v <- try $ do v <- ident
                        guard (isVariable v)
                        return v
          option (BindVar v) $ do
            atsign
            b <- apat
            return (BindAs v b)
         <?> "variable"
  
        gcon :: Bool -> Parser Binding
        gcon allowArgs = do
          c <- try $ do c <- dataConstr
                        return c
          choice
            [ record c
            , fmap (BindConstr c) (guard allowArgs >> many apat)
            , return (BindConstr c [])
            ]
         <?> "constructor"
  
        dataConstr = do
          p <- dcPiece
          ps <- many dcPieces
          return $ toDataConstr p ps
  
        dcPiece = do
          x@(Ident y) <- ident
          guard $ isConstructor x
          return y
  
        dcPieces = do
          _ <- char '.'
          dcPiece
  
        toDataConstr x [] = DCUnqualified $ Ident x
        toDataConstr x (y:ys) =
            go (x:) y ys
          where
            go front next [] = DCQualified (Module $ front []) (Ident next)
            go front next (rest:rests) = go (front . (next:)) rest rests
  
        record c = braces $ do
          (fields, wild) <- option ([], False) $ go
          return (BindRecord c fields wild)
          where
          go = (wildDots >> return ([], True))
             <|> (do x         <- recordField
                     (xs,wild) <- option ([],False) (comma >> go)
                     return (x:xs,wild))
  
        recordField = do
          field <- ident
          p <- option (BindVar field) -- support punning
                      (equals >> identPattern)
          return (field,p)
  
        tuplepat = do
          xs <- identPattern `sepBy` comma
          return $ case xs of
            [x] -> x
            _   -> BindTuple xs
  
        listpat = BindList <$> identPattern `sepBy` comma
  
      angle = do
          _ <- char '<'
          name' <- many  $ noneOf " \t\r\n>"
          let name = if null name' then "div" else name'
          xs <- many $ try ((many $ oneOf " \t\r\n") >>
                (tagCond <|> tagAttrs <|> tagAttrib Nothing))
          _ <- many $ oneOf " \t\r\n"
          _ <- char '>'
          c <- content InContent
          let (tn, attr, attrsd) = tag' $ TagName name : xs
          return $ LineTag tn attr c attrsd
  
  data TagPiece = TagName String
                | TagAttrib (Maybe Deref, String, [Content])
                | TagAttribs Deref
      deriving Show
  
  data ContentRule = InQuotes | NotInQuotes | NotInQuotesAttr | InContent
  
  data Nest = Nest Line [Nest]
  
  nestLines :: [(Int, Line)] -> [Nest]
  nestLines [] = []
  nestLines ((i, l):rest) =
      let (deeper, rest') = span (\(i', _) -> i' > i) rest
       in Nest l (nestLines deeper) : nestLines rest'
  
  data Doc = DocForall Deref Binding [Doc]
           | DocWith [(Deref, Binding)] [Doc]
           | DocCond [(Deref, [Doc])] (Maybe [Doc])
           | DocMaybe Deref Binding [Doc] (Maybe [Doc])
           | DocCase Deref [(Binding, [Doc])]
           | DocTag String [(Maybe Deref, String, [Content])] [Deref] [Doc]
           | DocContent Content
           -- FIXME PIs
      deriving (Show, Eq, Read, Data, Typeable)
  
  nestToDoc :: [Nest] -> Result [Doc]
  nestToDoc [] = Ok []
  nestToDoc (Nest (LineForall d i) inside:rest) = do
      inside' <- nestToDoc inside
      rest' <- nestToDoc rest
      Ok $ DocForall d i inside' : rest'
  nestToDoc (Nest (LineWith dis) inside:rest) = do
      inside' <- nestToDoc inside
      rest' <- nestToDoc rest
      Ok $ DocWith dis inside' : rest'
  nestToDoc (Nest (LineIf d) inside:rest) = do
      inside' <- nestToDoc inside
      (ifs, el, rest') <- parseConds ((:) (d, inside')) rest
      rest'' <- nestToDoc rest'
      Ok $ DocCond ifs el : rest''
  nestToDoc (Nest (LineMaybe d i) inside:rest) = do
      inside' <- nestToDoc inside
      (nothing, rest') <-
          case rest of
              Nest LineNothing ninside:x -> do
                  ninside' <- nestToDoc ninside
                  return (Just ninside', x)
              _ -> return (Nothing, rest)
      rest'' <- nestToDoc rest'
      Ok $ DocMaybe d i inside' nothing : rest''
  nestToDoc (Nest (LineCase d) inside:rest) = do
      let getOf (Nest (LineOf x) insideC) = do
              insideC' <- nestToDoc insideC
              Ok (x, insideC')
          getOf _ = Error "Inside a $case there may only be $of.  Use '$of _' for a wildcard."
      cases <- mapM getOf inside
      rest' <- nestToDoc rest
      Ok $ DocCase d cases : rest'
  nestToDoc (Nest (LineTag tn attrs content attrsD) inside:rest) = do
      inside' <- nestToDoc inside
      rest' <- nestToDoc rest
      Ok $ (DocTag tn attrs attrsD $ map DocContent content ++ inside') : rest'
  nestToDoc (Nest (LineContent content) inside:rest) = do
      inside' <- nestToDoc inside
      rest' <- nestToDoc rest
      Ok $ map DocContent content ++ inside' ++ rest'
  nestToDoc (Nest (LineElseIf _) _:_) = Error "Unexpected elseif"
  nestToDoc (Nest LineElse _:_) = Error "Unexpected else"
  nestToDoc (Nest LineNothing _:_) = Error "Unexpected nothing"
  nestToDoc (Nest (LineOf _) _:_) = Error "Unexpected 'of' (did you forget a $case?)"
  
  parseDoc :: String -> Result [Doc]
  parseDoc s = do
      ls <- parseLines s
      let notEmpty (_, LineContent []) = False
          notEmpty _ = True
      let ns = nestLines $ filter notEmpty ls
      ds <- nestToDoc ns
      return ds
  
  parseConds :: ([(Deref, [Doc])] -> [(Deref, [Doc])])
             -> [Nest]
             -> Result ([(Deref, [Doc])], Maybe [Doc], [Nest])
  parseConds front (Nest LineElse inside:rest) = do
      inside' <- nestToDoc inside
      Ok $ (front [], Just inside', rest)
  parseConds front (Nest (LineElseIf d) inside:rest) = do
      inside' <- nestToDoc inside
      parseConds (front . (:) (d, inside')) rest
  parseConds front rest = Ok (front [], Nothing, rest)
  
  data Binding = BindVar Ident
               | BindAs Ident Binding
               | BindConstr DataConstr [Binding]
               | BindTuple [Binding]
               | BindList [Binding]
               | BindRecord DataConstr [(Ident, Binding)] Bool
      deriving (Eq, Show, Read, Data, Typeable)
  
  data DataConstr = DCQualified Module Ident
                  | DCUnqualified Ident
      deriving (Eq, Show, Read, Data, Typeable)
  
  newtype Module = Module [String]
      deriving (Eq, Show, Read, Data, Typeable)
  
  spaceTabs :: Parser String
  spaceTabs = many $ oneOf " \t"
  