{-# 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]
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
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)
(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
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"