hako-0.3.0: Text/Hako/Parsing.hs

{-# LANGUAGE TemplateHaskell, FlexibleContexts, RankNTypes #-}
module Text.Hako.Parsing
( parseTemplateFromString
) where

import Text.Parsec
import Language.Haskell.TH
import Language.Haskell.Meta.Parse
import Text.Parsec.String
import Text.Hako.Html

type HakoParser a = Stream s m Char => ParsecT s u m a

-- | Hako's main parser, suitable as a quoteExpr.
parseTemplateFromString :: String -> ExpQ
parseTemplateFromString s = either (error . show) return $ parse template [] s

data Template = Template [Dec] [Exp]

tjoin :: Template -> Template -> Template
tjoin (Template dl el) (Template dr er) =
    Template (dl ++ dr) (el ++ er)

tpack :: Template -> Exp
tpack (Template defs exps) =
    let body = if null exps
                then emptyLiteralExp
                else foldl1 expJoin exps
    in if null defs
        then body
        else LetE defs body

template :: HakoParser Exp
template = do
    tfs <- many templateFragment
    return $ tpack $ foldl1 tjoin tfs

templateFragment :: HakoParser Template
templateFragment = try templateDefFragment
                 <|> try templateForFragment
                 <|> templateExpFragment
                 <|> templateLitFragment
                 <?> "template fragment"

templateDefFragment :: HakoParser Template
templateDefFragment = do
    defs <- blockDef
    return $ Template defs []

templateExpFragment :: HakoParser Template
templateExpFragment = do
    exp <- haskellExpr
    return $ Template [] [exp]

templateForFragment :: HakoParser Template
templateForFragment = do
    exp <- forExpr
    return $ Template [] [exp]

templateLitFragment :: HakoParser Template
templateLitFragment = do
    exp <- literalText
    return $ Template [] [exp]

emptyLiteralExp :: Exp
emptyLiteralExp = AppE (ConE . mkName $ "Html") $ LitE $ StringL ""

expJoin :: Exp -> Exp -> Exp
expJoin a b = AppE (AppE (VarE . mkName $ "<++>") a) b

expWrap :: Exp -> Exp
expWrap a = AppE (VarE . mkName $ "toHtml") a

blockDef :: HakoParser [Dec]
blockDef = do
    string "{def"
    space
    leader <- manyTill anyChar $ char '=' 
    inner <- template
    string "}"
    let decs = parseDecs $ leader ++ " = " ++ pprint inner
    case decs of
        Right d -> return d
        Left err -> error err

forExpr :: HakoParser Exp
forExpr = do
    string "{for"
    space
    iteree <- manyTill (try anyChar) $ char '-'
    string ">"
    space
    iter <- manyTill (try anyChar) $ char ':'
    inner <- template
    string "}"
    let expr = parseExp $ "foldl (<++>) (Html \"\") (map (\\" ++ iter ++ " -> " ++ pprint inner ++ ") (" ++ iteree ++ "))"
    case expr of
        Right e -> return e
        Left err -> error err

literalText :: HakoParser Exp
literalText = do
    str <- many1 $ noneOf "{}"
    return $ AppE (ConE . mkName $ "Html") $ LitE $ StringL str

haskellExpr :: HakoParser Exp
haskellExpr = do
    e <- haskellExpr'
    return $ expWrap e

haskellExpr' :: HakoParser Exp
haskellExpr' = do
    _ <- char '{'
    src <- haskellText
    _ <- char '}'
    either fail return $ parseExp src

haskellText :: HakoParser String
haskellText = do
    parts <- many1 haskellPart
    return $ concat parts

bracedText :: HakoParser String
bracedText = do
    char '{'
    inner <- haskellText
    char '}'
    return $ "{" ++ inner ++ "}"

haskellPart :: HakoParser String
haskellPart = quotedChar
            <|> quotedEscapedChar
            <|> quotedString
            <|> bracedText
            <|> haskellOther

haskellOther :: HakoParser String
haskellOther = many1 $ noneOf "\"'{}"

quotedChar :: HakoParser String
quotedChar = do
    char '\''
    c <- noneOf "\\"
    char '\''
    return ['\'', c, '\'']

quotedEscapedChar :: HakoParser String
quotedEscapedChar = do
    char '\''
    char '\\'
    c <- anyChar
    char '\''
    return ['\'', '\\', c, '\'']

quotedString :: HakoParser String
quotedString = do
    char '"'
    strs <- many quotedStringPart
    char '"'
    let str = concat strs
    return $ "\"" ++ str ++ "\""
    where quotedStringPart = singleChar <|> escapedChar
          singleChar = do { c <- noneOf "\"\\"; return [c] }
          escapedChar = do { char '\\'; c <- anyChar; return ['\\',c] }