diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c)2012, Tobias Dammers +Copyright (c)2012, Tobias Dammers and contributors All rights reserved. diff --git a/Text/Hako/Html.hs b/Text/Hako/Html.hs --- a/Text/Hako/Html.hs +++ b/Text/Hako/Html.hs @@ -8,9 +8,11 @@ , ToHtml , toHtml , fromHtml -, (<++>) ) where +import Data.Monoid +import qualified Data.Text as T + -- | Basic HTML-encoding: converts all special HTML characters into the -- corresponding entities. htmlEncode :: String -> Html @@ -53,6 +55,9 @@ instance ToHtml [Char] where toHtml = htmlEncode +instance ToHtml T.Text where + toHtml = htmlEncode . T.unpack + -- | Implement an instance for 'Maybe', so that 'Nothing' is leniently -- converted to an empty string, and 'Just's are unpacked. instance ToHtml a => ToHtml (Maybe a) where @@ -68,14 +73,13 @@ -- | Lists are automatically folded using straightforward concatenation. instance ToHtml a => ToHtml [a] where toHtml [] = Html "" - toHtml xs = foldl1 (<++>) $ map toHtml xs + toHtml xs = foldl1 (<>) $ map toHtml xs -- | All other types in 'Show' default to HTML-encoding their 'show' -- representation. instance Show a => ToHtml a where toHtml = htmlEncode . show --- | Concatenate two 'Html's together. --- The 'Html' equivalent to list concatenation (@++@) -(<++>) :: Html -> Html -> Html -(Html a) <++> (Html b) = Html (a ++ b) +instance Monoid Html where + mempty = Html "" + mappend (Html a) (Html b) = Html (a ++ b) diff --git a/Text/Hako/Parsing.hs b/Text/Hako/Parsing.hs --- a/Text/Hako/Parsing.hs +++ b/Text/Hako/Parsing.hs @@ -1,19 +1,21 @@ -{-# LANGUAGE TemplateHaskell, FlexibleContexts, RankNTypes #-} +{-# LANGUAGE TemplateHaskell, FlexibleContexts #-} module Text.Hako.Parsing ( parseTemplateFromString ) where -import Text.Parsec +import Control.Monad.Trans.Class +import Data.Monoid import Language.Haskell.TH import Language.Haskell.Meta.Parse +import Text.Parsec 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 +parseTemplateFromString :: String -> Q Exp +parseTemplateFromString s = do + exp <- runParserT template () "Hako" s + return $ either (error . show) id exp data Template = Template [Dec] [Exp] @@ -30,121 +32,126 @@ then body else LetE defs body -template :: HakoParser Exp +template :: ParsecT String () Q Exp template = do tfs <- many templateFragment return $ tpack $ foldl1 tjoin tfs -templateFragment :: HakoParser Template +templateFragment :: ParsecT String () Q Template templateFragment = try templateDefFragment - <|> try templateForFragment + <|> try templateLoopFragment <|> templateExpFragment <|> templateLitFragment "template fragment" -templateDefFragment :: HakoParser Template +templateDefFragment :: ParsecT String () Q Template templateDefFragment = do - defs <- blockDef - return $ Template defs [] + def <- blockDef + return $ Template [def] [] -templateExpFragment :: HakoParser Template -templateExpFragment = do - exp <- haskellExpr +templateLoopFragment :: ParsecT String () Q Template +templateLoopFragment = do + exp <- forLoop return $ Template [] [exp] -templateForFragment :: HakoParser Template -templateForFragment = do - exp <- forExpr +templateExpFragment :: ParsecT String () Q Template +templateExpFragment = do + exp <- haskellExpr return $ Template [] [exp] -templateLitFragment :: HakoParser Template +templateLitFragment :: ParsecT String () Q Template templateLitFragment = do exp <- literalText return $ Template [] [exp] emptyLiteralExp :: Exp -emptyLiteralExp = AppE (ConE . mkName $ "Html") $ LitE $ StringL "" +emptyLiteralExp = AppE (ConE 'Html) $ LitE $ StringL "" expJoin :: Exp -> Exp -> Exp -expJoin a b = AppE (AppE (VarE . mkName $ "<++>") a) b +expJoin a b = AppE (AppE (VarE '(<>)) a) b expWrap :: Exp -> Exp -expWrap a = AppE (VarE . mkName $ "toHtml") a +expWrap a = AppE (VarE 'toHtml) a -blockDef :: HakoParser [Dec] +-- We might have a {def const = some fixed template} +-- Or we might have {def f x y = some dynamic template using {x} and {y}} +-- We could also have patterns {def f (x:_) = first {x}} +blockDef :: ParsecT String () Q Dec blockDef = do string "{def" space - leader <- manyTill anyChar $ char '=' + leader <- manyTill anyChar $ char '=' inner <- template string "}" - let decs = parseDecs $ leader ++ " = " ++ pprint inner - case decs of - Right d -> return d - Left err -> error err + case parseExp ("let " ++ leader ++ " = 42 in 42") of + Right (LetE [ValD p _ _] _) -> return $ ValD p (NormalB inner) [] + Right (LetE [FunD n [Clause ps _ _]] _) -> return $ FunD n [Clause ps (NormalB inner) []] + Right _ -> error "the definition leader did not parse into one of the expected constructs" + Left err -> error err -forExpr :: HakoParser Exp -forExpr = do +-- Turn {for x in list: {x}} into: mconcat . map (\x -> TEMPLATE_EXPR) list +forLoop :: ParsecT String () Q Exp +forLoop = do string "{for" space - iteree <- manyTill (try anyChar) $ char '-' - string ">" - space - iter <- manyTill (try anyChar) $ char ':' + var <- manyTill anyChar $ string " in " + lst <- manyTill 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 + let varPat = either error id $ parsePat var + funExpr = LamE [varPat] inner + lstExpr = parseExp lst + case lstExpr of + Right e -> return $ VarE 'mconcat `AppE` (VarE 'map `AppE` funExpr `AppE` e) + Left err -> error err -literalText :: HakoParser Exp +literalText :: ParsecT String () Q Exp literalText = do str <- many1 $ noneOf "{}" - return $ AppE (ConE . mkName $ "Html") $ LitE $ StringL str + return $ AppE (ConE 'Html) $ LitE $ StringL str -haskellExpr :: HakoParser Exp +haskellExpr :: ParsecT String () Q Exp haskellExpr = do e <- haskellExpr' return $ expWrap e -haskellExpr' :: HakoParser Exp +haskellExpr' :: ParsecT String () Q Exp haskellExpr' = do _ <- char '{' src <- haskellText _ <- char '}' either fail return $ parseExp src -haskellText :: HakoParser String +haskellText :: ParsecT String () Q String haskellText = do parts <- many1 haskellPart return $ concat parts -bracedText :: HakoParser String +bracedText :: ParsecT String () Q String bracedText = do char '{' inner <- haskellText char '}' return $ "{" ++ inner ++ "}" -haskellPart :: HakoParser String +haskellPart :: ParsecT String () Q String haskellPart = quotedChar <|> quotedEscapedChar <|> quotedString <|> bracedText <|> haskellOther -haskellOther :: HakoParser String +haskellOther :: ParsecT String () Q String haskellOther = many1 $ noneOf "\"'{}" -quotedChar :: HakoParser String +quotedChar :: ParsecT String () Q String quotedChar = do char '\'' c <- noneOf "\\" char '\'' return ['\'', c, '\''] -quotedEscapedChar :: HakoParser String +quotedEscapedChar :: ParsecT String () Q String quotedEscapedChar = do char '\'' char '\\' @@ -152,7 +159,7 @@ char '\'' return ['\'', '\\', c, '\''] -quotedString :: HakoParser String +quotedString :: ParsecT String () Q String quotedString = do char '"' strs <- many quotedStringPart diff --git a/hako.cabal b/hako.cabal --- a/hako.cabal +++ b/hako.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.3.0 +Version: 1.0.0 -- A short (one-line) description of the package. Synopsis: A mako-like quasi-quoter template library @@ -62,6 +62,8 @@ , base >= 3.0 && < 5.0 , template-haskell >= 2.5 && < 3.0 , haskell-src-meta >= 0.5 && < 0.6 + , transformers + , text -- Modules not exported by this package. -- Other-modules: