Bravo (empty) → 0.1.0
raw patch · 10 files changed
+611/−0 lines, 10 filesdep +basedep +haskell-src-extsdep +haskell-src-metasetup-changed
Dependencies added: base, haskell-src-exts, haskell-src-meta, mtl, parsec, template-haskell
Files
- Bravo.cabal +41/−0
- LICENSE +25/−0
- Setup.hs +6/−0
- src/Examples/Example01.hs +23/−0
- src/Examples/Example01.tpl +35/−0
- src/Text/Bravo.hs +69/−0
- src/Text/Bravo/Parser.hs +156/−0
- src/Text/Bravo/Syntax.hs +29/−0
- src/Text/Bravo/Translate.hs +180/−0
- src/Text/Bravo/Util.hs +47/−0
+ Bravo.cabal view
@@ -0,0 +1,41 @@+Name: Bravo+Version: 0.1.0+Cabal-Version: >= 1.6+Build-Type: Simple+License: BSD3+License-File: LICENSE+Copyright: (C) 2010, Matthias Reisner+Author: Matthias Reisner+Maintainer: Matthias Reisner <matthias.reisner@googlemail.com>+Stability: experimental+Homepage: http://www.haskell.org/haskellwiki/Bravo+Synopsis: Static text template generation library+Description: Bravo is a text template library that provides parsing and generation of templates+ at compile time. Templates can be read from strings or files and for each+ a new record data type is created, allowing convenient access to all template+ variables in a type-safe manner. Since all templates are processed at compile time,+ no extra file access or error handling at runtime is necessary.+ .+ Additional features include the definition of multiple templates per file,+ conditional template evaluation, embeddeding of Haskell expressions and customized+ data type generation.+Category: Text+Tested-With: GHC == 6.10.4++Extra-Source-Files: src/Examples/Example01.hs,+ src/Examples/Example01.tpl++Library+ Build-Depends: base >= 3.0 && <5,+ mtl >= 1.1.0.2 && <1.2,+ haskell-src-exts >= 1.2 && <2,+ haskell-src-meta >= 0.0.6 && <0.1,+ template-haskell >= 2.3.0.1 && <2.4,+ parsec >= 2.1.0.1 && <3+ Exposed-Modules: Text.Bravo+ Other-Modules: Text.Bravo.Parser+ Text.Bravo.Syntax+ Text.Bravo.Translate+ Text.Bravo.Util+ HS-Source-Dirs: src+ GHC-Options: -O2 -Wall
+ LICENSE view
@@ -0,0 +1,25 @@+Copyright (C) 2010, Matthias Reisner+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted+provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright notice, this list of conditions+ and the following disclaimer.++ * Redistributions in binary form must reproduce the above copyright notice, this list of+ conditions and the following disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of the copyright holders nor the names of the contributors may be used to+ endorse or promote products derived from this software without specific prior written+ permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER+IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF+THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ src/Examples/Example01.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TemplateHaskell #-} +module Main (main) where + +import Text.Bravo + + +$(mkTemplatesFromFile "Example01.tpl") + +main :: IO () +main = do + let users = [ newUser "Peter" "Miller" 30 True, + newUser "Sandra" "Thompson" 24 False, + newUser "Linda" "Scott" 38 True ] + tpl = show TplMain { mainUsers = concatMap show users } + writeFile "Example01.html" tpl + +newUser :: String -> String -> Int -> Bool -> TplUser +newUser fname lname age married = TplUser { + userFirstName = fname, + userLastName = lname, + userAge = age, + userMarried = married + }
+ src/Examples/Example01.tpl view
@@ -0,0 +1,35 @@++ The main HTML template++{{tpl main}}+<html>+<head><title>Bravo template example 1</title></head>+<body>+ <h1>Employees list</h1>+ <table>+ <thead>+ <th>First name</th>+ <th>Last name</th>+ <th>Age</th>+ <th>Married</th>+ </thead>+ <tbody>+{{:$users}}+ </tbody>+ </table>+</body>+</html>+{{endtpl}}+++ HTML table row template for a single user++{{tpl user}}+ <tr>+ <td>{{:$firstName}}</td>+ <td>{{:$lastName}}</td>+ <td>{{:show $(age :: Int)}}</td>+ <td>{{if $(married :: Bool)}}Yes{{else}}No{{endif}}</td>+ </tr>+{{endtpl}}+
+ src/Text/Bravo.hs view
@@ -0,0 +1,69 @@+{- | + Module : Text.Bravo + Copyright : Matthias Reisner + License : BSD3 + + Maintainer : Matthias Reisner <matthias.reisner@googlemail.com> + Stability : experimental + Portability : unknown + + Bravo templates can be read from strings via the 'mkTemplates', or from files via the + 'mkTemplatesFromFile' Template Haskell functions, so you need to enable the TemplateHaskell + language extension when using Bravo in your Haskell application. Each read string or file can + contain multiple templates and additional comments. A single template is delimitated by an + opening splice @{{ tpl /name/ }}@ and a closing splice @{{ endtpl }}@ where /name/ is an + identifier starting with a lowercase letter. Characters before and after these splices are + considered to be template comments and therefore are ignored. Between these delimiters + multiple inner splices are allowed, which are: + + * Normal text, i.e. character sequences not including @{{@ or @}}@. + + * Comment splices @{\{\- /comment text/ \-\}}@. These splices are only for documentary purposes + and will not occur in the produced template text. + + * Expression splices @{{: /expression/ }}@. Here /expression/ can be an arbitrary Haskell + expression that does not require any language extensions to be parsed. The expression itself + is not evaluated at compile time but rather at runtime and the result of evaluation will be + included in the produced template text. Note that the evaluated expression must be of type + 'String', otherwise compile errors will occur in the produced declarations. Additionally, + template variables of the form @$/name/@ or @$(/name/)@ can be used within an expression. + + * Conditional splices @{{ if /condition_1/ }} ... [ {{ elseif /condition_2/ }} ... ]* + [ {{ else }} ... ] {{ endif }}@ where each @...@ stands for an arbitrary number of inner + splices. Multiple @elseif@ splices + and\/or a single @else@ splice are optional. /condition_n/ are Haskell expressions similar to + /expression/ in expression splices, except that they have to evaluate to a value of type + 'Bool'. All conditions will be evaluated in sequence and if one condition evaluates to + @True@, the subsequent template splices are added to the resulting template text; all + other inner splices are discarded. + + After successful parsing, a new record data type with a single data constructor and a + corresponding instance of class 'Show' is created for each template. Also each used template + variable is transformed to a new record field of the data constructor. When parsed with default + options, the simple template + +@ + {{tpl simple}}{{:$name}}'s favourite song is \"{{:$song}}\"{{endtpl}} +@ + + will be translated to the record data type + +@ + data TplSimple = TplSimple { + simpleName :: String, + simpleSong :: String + }. +@ + + To customize the created data types, the 'mkTemplatesWithOptions' or + 'mkTemplatesFromFileWithOptions' functions can be used. Finally, use the 'show' function on + a value of the created data type to convert it into a string. + +-} + +module Text.Bravo ( + module Text.Bravo.Translate + ) +where + +import Text.Bravo.Translate
+ src/Text/Bravo/Parser.hs view
@@ -0,0 +1,156 @@+--------------------------------------------------------------------------------------------------- +-- | +-- Module : Text.Bravo.Parser +-- Copyright : Matthias Reisner +-- License : BSD3 +-- +-- Maintainer : Matthias Reisner <matthias.reisner@googlemail.com> +-- Stability : experimental +-- Portability : unknown +-- +-- Bravo template parsers. +-- +--------------------------------------------------------------------------------------------------- + +module Text.Bravo.Parser ( + template, + templates + ) +where + + +import Control.Monad + +import Language.Haskell.Exts.Parser hiding (parse) +import Language.Haskell.Exts.Syntax +import Language.Haskell.Exts.Extension + +import Text.Bravo.Syntax +import Text.Bravo.Util +import Text.ParserCombinators.Parsec + + +{- + + tpl ::= tbegin tpls* tend + tpls ::= tcond | texpr | tcomm | ttext + + tbegin ::= '{{' spc* 'tpl' spc+ ident spc* '}}' + tend ::= '{{' spc* 'endtpl' spc* '}}' + tif ::= '{{' spc* 'if' spc+ cexpr spc* '}}' + telsif ::= '{{' spc* 'elseif' spc+ cexpr spc* '}}' + telse ::= '{{' spc* 'else' spc* '}}' + tendif ::= '{{' spc* 'endif' spc* '}}' + tcond ::= tif tpls* (telsif tpls*)* (telse tpls*)? tendif + + texpr ::= '{{' ':' spc* expr spc* '}}' + tcomm ::= '{{' '-' any* '-' '}}' + ttext ::= any+ + + expr ::= hs_expr :: String + cexpr ::= hs_expr :: Bool + + ident ::= lower alphaNum* + spc ::= ' ' | '\t' | '\n' | '\r' + +-} + + +keywords :: [String] +keywords = ["if", "elseif", "else", "endif", "tpl", "endtpl"] + +parseExts :: [Extension] +parseExts = [TemplateHaskell] + + +-- * CFG parsers + +-- | Parser for a single template. No comments or whitespace are allowed before the template. +template :: Parser Template +template = tpl + +-- | Parser for multiple templates with comments or whitespace before and after each template. +templates :: Parser [Template] +templates = option "" ttext' >> many (tpl << option "" ttext') + + +tpl :: Parser Template +tpl = liftM2 Template tbegin (many (try tpls) << tend) <?> "tpl" + +tpls :: Parser TemplateSplice +tpls = try texpr <|> try tcond <|> try tcomm <|> ttext <?> "tpls" + +tcond :: Parser TemplateSplice +tcond = do + i <- tif + ts <- many $ try tpls + eis <- many $ liftM2 (,) (try telsif) (many $ try tpls) + e <- option [] (try telse >> many (try tpls)) + tendif + return $ TConditions (((i, ts):eis) ++ [(Con $ UnQual $ Ident "True", e)]) + <?> "tcond" + +tbegin :: Parser String +tbegin = (string "{{" >> many spc >> string "tpl" >> many1 spc >> + ident << many spc << string "}}") <?> "tbegin" + +tend :: Parser () +tend = (skip $ string "{{" >> many spc >> string "endtpl" >> many spc >> string "}}") <?> "tend" + +tif :: Parser Exp +tif = (string "{{" >> many spc >> string "if" >> many1 spc >> + cexpr << many spc << string "}}") <?> "tif" + +telsif :: Parser Exp +telsif = (string "{{" >> many spc >> string "elseif" >> many1 spc >> + cexpr << many spc << string "}}") <?> "telseif" + +telse :: Parser () +telse = skip (string "{{" >> many spc >> string "else" >> many spc >> string "}}") <?> "telse" + +tendif :: Parser () +tendif = skip (string "{{" >> many spc >> string "endif" >> many spc >> string "}}") <?> "tendif" + +texpr :: Parser TemplateSplice +texpr = liftM TExpr (string "{{:" >> many spc >> expr << many spc << string "}}") <?> "texpr" + +tcomm :: Parser TemplateSplice +tcomm = (liftM TComment $ string "{{-" >> manyTill anyChar (try $ string "-}}")) <?> "tcomm" + +ttext :: Parser TemplateSplice +ttext = liftM TText ttext' <?> "ttext" + +ttext' :: Parser String +ttext' = manyNotMultiple '{' + +expr :: Parser Exp +expr = do + s <- manyNotMultiple '}' + case parseExpWithMode defaultParseMode { extensions = parseExts } s of + ParseFailed _ err -> fail $ "expr: " ++ err + ParseOk e -> return e + +cexpr :: Parser Exp +cexpr = expr + +-- * Token parsers + +ident :: Parser String +ident = do + s <- liftM2 (:) lower (many alphaNum) + if elem s keywords then unexpected "keyword" else return s + <?> "ident" + +spc :: Parser Char +spc = oneOf " \t\n\r" <?> "spc" + + +-- * Utility parsers + +notChar :: Char -> Parser Char +notChar = satisfy . (/=) + +manyNotMultiple :: Char -> Parser String +manyNotMultiple c = liftM2 (++) (many1 $ notChar c) + (option [] $ try $ liftM2 (:) (char c) (manyNotMultiple c)) +
+ src/Text/Bravo/Syntax.hs view
@@ -0,0 +1,29 @@+--------------------------------------------------------------------------------------------------- +-- | +-- Module : Text.Bravo.Syntax +-- Copyright : Matthias Reisner +-- License : BSD3 +-- +-- Maintainer : Matthias Reisner <matthias.reisner@googlemail.com> +-- Stability : experimental +-- Portability : unknown +-- +-- Bravo template syntax. +-- +--------------------------------------------------------------------------------------------------- + +module Text.Bravo.Syntax ( + Template (..), + TemplateSplice (..) + ) +where + +import Language.Haskell.Exts.Syntax + +data Template = Template String [TemplateSplice] deriving Show + +data TemplateSplice = TText String + | TComment String + | TExpr Exp + | TConditions [(Exp, [TemplateSplice])] + deriving Show
+ src/Text/Bravo/Translate.hs view
@@ -0,0 +1,180 @@+--------------------------------------------------------------------------------------------------- +-- | +-- Module : Text.Bravo.Translate +-- Copyright : Matthias Reisner +-- License : BSD3 +-- +-- Maintainer : Matthias Reisner <matthias.reisner@googlemail.com> +-- Stability : experimental +-- Portability : unknown +-- +-- Translation functions from Bravo templates to Haskell declarations. +-- +--------------------------------------------------------------------------------------------------- + +module Text.Bravo.Translate ( + mkTemplates, + mkTemplatesWithOptions, + mkTemplatesFromFile, + mkTemplatesFromFileWithOptions, + + TplOptions (..), + defaultTplOptions + ) +where + + +import Control.Monad.State + +import Data.Char +import Data.Generics +import Data.Maybe +import Data.Function + +import qualified Language.Haskell.Exts.Syntax as Hs +import Language.Haskell.Meta.Syntax.Translate +import Language.Haskell.TH + +import Text.Bravo.Syntax +import Text.Bravo.Util +import Text.Bravo.Parser +import Text.ParserCombinators.Parsec (parse, eof) + + + +-- | Transforms a string into a list of template declarations. +mkTemplates :: String -> Q [Dec] +mkTemplates = mkTemplates' defaultTplOptions "" + +-- | Transforms a string into a list of template declarations, using custom options for the +-- data type generation. +mkTemplatesWithOptions :: TplOptions -> String -> Q [Dec] +mkTemplatesWithOptions = flip mkTemplates' "" + +mkTemplates' :: TplOptions -> FilePath -> String -> Q [Dec] +mkTemplates' options path s = case parse (templates << eof) path s of + Left err -> report True ("Error while parsing templates:\n" ++ show err) >> return [] + Right tpl -> liftM join $ mapM (translateTpl options) tpl + + +-- | Reads a file and transforms the read file content into a list of template declarations. +mkTemplatesFromFile :: FilePath -> Q [Dec] +mkTemplatesFromFile = mkTemplatesFromFile' defaultTplOptions + +-- | Reads a file and transforms the read file content into a list of template declarations, using +-- custom options for the data type generation. +mkTemplatesFromFileWithOptions :: TplOptions -> FilePath -> Q [Dec] +mkTemplatesFromFileWithOptions = mkTemplatesFromFile' + +mkTemplatesFromFile' :: TplOptions -> FilePath -> Q [Dec] +mkTemplatesFromFile' options path = do + text <- runIO $ safeReadFile path + case text of + Nothing -> report True ("Error while reading file \"" ++ path ++ "\"") >> return [] + Just text' -> mkTemplates' options path text' + + +-- | A set of functions to change the style of the generated templates. +data TplOptions = TplOptions { + -- | Creates the data type and constructor name for a given template name. + tplMkName :: String -> String, + -- | Creates the record field name for a given template name and field name. + tplMkFieldName :: String -> String -> String, + -- | This function is applied to each template text splice, allowing e.g. the + -- removal of extra whitespace etc. + tplModifyText :: String -> String + } + +-- | The default template generation options used by 'mkTemplates' and 'mkTemplatesFromFile'. +-- An example: +-- +-- @ +-- tplMkName defaultTplOptions \"example\" == \"TplExample\" +-- tplMkFieldName defaultTplOptions \"example\" \"field\" == \"exampleField\" +-- tplModifyText defaultTplOptions == id +-- @ +defaultTplOptions :: TplOptions +defaultTplOptions = TplOptions { + tplMkName = defaultMkName, + tplMkFieldName = defaultMkFieldName, + tplModifyText = id + } + +defaultMkName :: String -> String +defaultMkName "" = error "*** bug: empty name in defaultMkName" +defaultMkName (c:cs) = "Tpl" ++ (toUpper c : cs) + +defaultMkFieldName :: String -> String -> String +defaultMkFieldName _ "" = error "*** bug: empty field name in defaultMkFieldName" +defaultMkFieldName name (c:cs) = name ++ (toUpper c : cs) + + +data TplState = TplState { + tplName :: String, + tplFields :: [(String, Maybe Type)], + tplOptions :: TplOptions + } + +type TplTrans a = State TplState a + +translateTpl :: TplOptions -> Template -> Q [Dec] +translateTpl options (Template name ts) = sequence decls + where + transFields cs = let parts = partition' ((==) `on` fst) cs in + zip (map (fst . head) parts) (map (listToMaybe . catMaybes . map snd) parts) + (decls, _) = runState trans TplState { tplName = name, tplFields = [], tplOptions = options} + trans = do + expr <- translateTplSplices ts + modify $ \st -> st { tplFields = transFields $ tplFields st } + recD <- mkRecDecl + showD <- mkShowInstance expr + return [recD, showD] + +mkRecDecl :: TplTrans DecQ +mkRecDecl = do + st <- get + let name' = mkName . tplMkName (tplOptions st) . tplName $ st + fDec (f, t) = return (mkName $ tplMkFieldName (tplOptions st) (tplName st) f, NotStrict, + fromMaybe (ConT $ mkName "String") t) + return $ dataD (cxt []) name' [] [recC name' . map fDec . tplFields $ st] [] + +mkShowInstance :: ExpQ -> TplTrans DecQ +mkShowInstance e = get >>= \st -> return $ instanceD (cxt []) + (appT (conT $ mkName "Show") (conT . mkName . tplMkName (tplOptions st) . tplName $ st)) + [funD (mkName "show") [clause [varP $ mkName "tpl"] (normalB e) []]] + +translateTplSplice :: TemplateSplice -> TplTrans (Maybe ExpQ) +translateTplSplice (TText s) = do + f <- gets $ (tplModifyText . tplOptions) + return . Just . litE . stringL . f $ s +translateTplSplice (TComment _) = return Nothing +translateTplSplice (TExpr e) = liftM Just $ translateExpr e +translateTplSplice (TConditions conds) = liftM2 + (\cs es -> Just $ (newName "cond") >>= + \name -> letE [valD (varP name) (guardedB $ fCond cs es) []] (varE name)) + (mapM (translateExpr . fst) conds) + (mapM (translateTplSplices . snd) conds) + where + fCond = zipWith (\c -> liftM2 (,) (normalG c)) + +translateTplSplices :: [TemplateSplice] -> TplTrans ExpQ +translateTplSplices = liftM ((\es -> appE (varE $ mkName "concat") (listE es)) . catMaybes) . + mapM translateTplSplice + +translateExpr :: Hs.Exp -> TplTrans ExpQ +translateExpr e = liftM (return . toExp) $ replaceVars e + +replaceVars :: Hs.Exp -> TplTrans Hs.Exp +replaceVars = everywhereM $ mkM f + where + f (Hs.SpliceExp (Hs.IdSplice field)) = rep Nothing field + f (Hs.SpliceExp (Hs.ParenSplice (Hs.Var (Hs.UnQual (Hs.Ident field))))) = rep Nothing field + f (Hs.SpliceExp (Hs.ParenSplice (Hs.ExpTypeSig _ + (Hs.Var (Hs.UnQual (Hs.Ident field))) t))) = rep (Just $ toType t) field + f e = return e + + rep t field = do + st <- get + modify $ \st' -> st' { tplFields = (field, t) : tplFields st'} + return $ Hs.App (var $ (tplMkFieldName . tplOptions) st (tplName st) field) (var "tpl") + var = Hs.Var . Hs.UnQual . Hs.Ident
+ src/Text/Bravo/Util.hs view
@@ -0,0 +1,47 @@+--------------------------------------------------------------------------------------------------- +-- | +-- Module : Text.Bravo.Util +-- Copyright : Matthias Reisner +-- License : BSD3 +-- +-- Maintainer : Matthias Reisner <matthias.reisner@googlemail.com> +-- Stability : experimental +-- Portability : unknown +-- +-- Bravo utility functions. +-- +--------------------------------------------------------------------------------------------------- + +module Text.Bravo.Util ( + (<<), + skip, + liftM', + partition', + safeReadFile + ) +where + + +import Control.Monad + +import Data.List + + +infixl 1 << + +(<<) :: Monad m => m a -> m b -> m a +(<<) = liftM2 const + +skip :: Monad m => m a -> m () +skip = liftM $ const () + +liftM' :: Monad m => (a -> m b) -> m a -> m b +liftM' = (=<<) + +partition' :: Eq a => (a -> a -> Bool) -> [a] -> [[a]] +partition' _ [] = [] +partition' p (c:cs) = (c : cs') : partition' p ncs + where (cs', ncs) = partition (p c) cs + +safeReadFile :: FilePath -> IO (Maybe String) +safeReadFile path = catch (liftM Just $ readFile path) (\_ -> return Nothing)