hako 0.3.0 → 1.0.0
raw patch · 4 files changed
+70/−57 lines, 4 filesdep +textdep +transformers
Dependencies added: text, transformers
Files
- LICENSE +1/−1
- Text/Hako/Html.hs +10/−6
- Text/Hako/Parsing.hs +56/−49
- hako.cabal +3/−1
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c)2012, Tobias Dammers+Copyright (c)2012, Tobias Dammers and contributors All rights reserved.
Text/Hako/Html.hs view
@@ -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)
Text/Hako/Parsing.hs view
@@ -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: <a>{x}</a>} 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
hako.cabal view
@@ -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: