StrappedTemplates 0.1.1.0 → 0.2.0.0
raw patch · 7 files changed
+346/−175 lines, 7 filesdep ~StrappedTemplates
Dependency ranges changed: StrappedTemplates
Files
- StrappedTemplates.cabal +6/−6
- src/Text/Strapped.hs +2/−0
- src/Text/Strapped/Parser.hs +76/−54
- src/Text/Strapped/Render.hs +144/−75
- src/Text/Strapped/Types.hs +96/−22
- src/Text/Strapped/Utils.hs +14/−7
- tests/StrappedTest.hs +8/−11
StrappedTemplates.cabal view
@@ -1,5 +1,5 @@ name: StrappedTemplates-version: 0.1.1.0+version: 0.2.0.0 synopsis: General purpose templates in haskell homepage: https://github.com/hansonkd/StrappedTemplates license: BSD3@@ -14,21 +14,21 @@ . > import Control.Monad.IO.Class > import qualified Blaze.ByteString.Builder as B- > import qualified Data.Text.Lazy as T+ > import qualified Data.Text as T > import Data.Time > > import Text.Strapped > > makeBucket :: Integer -> InputBucket IO > makeBucket i = bucketFromList - > [ ("is", List $ map (LitVal . LitInteger) [1..i])- > , ("is_truthy", LitVal $ LitInteger i)+ > [ ("is", lit $ map (LitInteger) [1..i])+ > , ("is_truthy", lit i) > , ("ioTime", Func (\_ -> (liftIO $ getCurrentTime) >>= (\c -> return $ LitText $ T.pack $ show c))) > ] > > main :: IO () > main = do- > tmpls <- templateStoreFromDirectory "examples/templates" ".strp"+ > tmpls <- templateStoreFromDirectory defaultConfig "examples/templates" ".strp" > case tmpls of > Left err -> print err > Right store -> do@@ -78,7 +78,7 @@ test-suite Main type: exitcode-stdio-1.0- build-depends: StrappedTemplates >= 0.1 && < 0.2,+ build-depends: StrappedTemplates >= 0.2 && < 0.3, base >= 4.7 && < 4.8, hspec >= 1.11 && < 1.12, text >= 1.0 && < 1.2,
src/Text/Strapped.hs view
@@ -9,6 +9,8 @@ , bucketLookup , bucketFromList , emptyBucket+ , lit+ , dyn -- * Parsing , parseTemplate -- * TemplateLoading
src/Text/Strapped/Parser.hs view
@@ -1,11 +1,23 @@ module Text.Strapped.Parser ( parseTemplate+ -- * Building custom template parsers+ , parseExpression+ , parseContent+ , tagStart+ , tagEnd+ , peekTag+ , tryTag+ , tag+ , wordString+ , pathString+ , peekChar ) where import Control.Applicative ((<*>)) import Control.Monad import Data.Monoid-import qualified Data.Text.Lazy as T+import qualified Data.Map.Strict as M+import qualified Data.Text as T import Blaze.ByteString.Builder as B import Blaze.ByteString.Builder.Char.Utf8 as B import Text.Parsec@@ -13,94 +25,98 @@ import qualified Text.Parsec.Token as P import Text.Parsec.Language (emptyDef) import Text.Strapped.Types-+import Text.Strapped.Render hiding (getState) -tagStart :: GenParser Char st String+-- | Parse the beginning of a tag+tagStart :: ParserM String tagStart = string "{$" -tagEnd :: GenParser Char st String+-- | Parse the end of a tag.+tagEnd :: ParserM String tagEnd = string "$}" -wordString :: GenParser Char st String+-- | Parse alpha-numeric characters and '_'+wordString :: ParserM String wordString = many1 $ oneOf "_" <|> alphaNum -pathString :: GenParser Char st String+-- | Parse alpha-numeric characters and '_./'+pathString :: ParserM String pathString = many1 $ oneOf "_./" <|> alphaNum -peekChar :: Char -> GenParser Char st ()+-- | Look at a character but don't consume+peekChar :: Char -> ParserM () peekChar = void . try . lookAhead . char +-- | Look at a tag but don't consume+peekTag :: ParserM a -> ParserM () peekTag = void . try . lookAhead . tag -tryTag :: GenParser Char st a -> GenParser Char st ()+-- | Try a tag and consume if it matches+tryTag :: ParserM a -> ParserM () tryTag = void . try . tag -tag :: GenParser Char st a -> GenParser Char st a+-- | Parse content between `tagStart` and `tagEnd`+tag :: ParserM a -> ParserM a tag p = between (tagStart >> spaces) (spaces >> tagEnd) p <?> "Tag" -parseFloat :: GenParser Char st Double+parseFloat :: ParserM Double parseFloat = do sign <- option 1 (do s <- oneOf "+-" return $ if s == '-' then-1.0 else 1.0) x <- P.float $ P.makeTokenParser emptyDef return $ sign * x -parseInt :: GenParser Char st Integer+parseInt :: ParserM Integer parseInt = do sign <- option 1 (do s <- oneOf "+-" return $ if s == '-' then-1 else 1) x <- P.integer $ P.makeTokenParser emptyDef return $ sign * x -parseContent :: GenParser Char st a -> GenParser Char st [ParsedPiece]+parseContent :: ParserM a -> ParserM [ParsedPiece] parseContent end = do- decls <- many (try $ spaces >> parseDecl)+ decls <- many (try $ spaces >> parseWithPos parseDecl) spaces extends <- optionMaybe (try $ spaces >> parseInherits) case (extends) of Just (e, epos) -> do includes <- manyTill parseIsIgnoreSpace end- return $ (decls) ++ [ParsedPiece (Inherits e includes) epos]+ return $ (decls) ++ [ParsedPiece (Inherits e (M.fromList includes)) epos] _ -> do ps <- manyTill parsePiece end return $ decls ++ ps where parseIsIgnoreSpace = do {spaces; b <- parseIsBlock; spaces; return b} -parseBlock :: GenParser Char st ParsedPiece+parseBlock :: ParserM Piece parseBlock = do- pos <- getPosition blockName <- tag (string "block" >> spaces >> wordString) <?> "Block tag" blockContent <- parseContent (tryTag $ string "endblock") - return $ ParsedPiece (BlockPiece blockName blockContent) pos+ return $ (BlockPiece blockName blockContent) -parseRaw :: GenParser Char st ParsedPiece+parseRaw :: ParserM Piece parseRaw = do- pos <- getPosition tag (string "raw") <?> "Raw tag" c <- anyChar s <- manyTill anyChar (tryTag (string "endraw"))- return $ ParsedPiece (StaticPiece (B.fromString $ c:s)) pos+ return $ StaticPiece (B.fromString $ c:s) -parseComment :: GenParser Char st ParsedPiece+parseComment :: ParserM Piece parseComment = do- pos <- getPosition tag (string "comment") <?> "Comment tag" c <- anyChar s <- manyTill anyChar (tryTag (string "endcomment"))- return $ ParsedPiece (StaticPiece mempty) pos+ return $ StaticPiece mempty -parseIf :: GenParser Char st ParsedPiece+parseIf :: ParserM Piece parseIf = do- pos <- getPosition exp <- (tagStart >> spaces >> string "if" >> spaces >> parseExpression (try $ spaces >> tagEnd)) <?> "If tag" positive <- parseContent ((peekTag $ string "endif") <|> (tryTag $ string "else")) negative <- parseContent (tryTag $ string "endif")- return $ ParsedPiece (IfPiece exp positive negative) pos+ return $ IfPiece exp positive negative -parseFor :: GenParser Char st ParsedPiece+parseFor :: ParserM Piece parseFor = do- pos <- getPosition (newVarName, exp) <- (tagStart >> spaces >> string "for" >> argParser) <?> "For tag" blockContent <- parseContent (tryTag $ string "endfor") - return $ ParsedPiece (ForPiece newVarName exp blockContent) pos+ return $ ForPiece newVarName exp blockContent where argParser = do spaces v <- wordString@@ -108,42 +124,41 @@ func <- parseExpression (try $ spaces >> tagEnd) return (v, func) -parseDecl :: GenParser Char st ParsedPiece+parseDecl :: ParserM Piece parseDecl = do {spaces; decl <- parserDecl; spaces; return decl} <?> "Let tag" where parserDecl = do- pos <- getPosition tagStart >> spaces string "let" >> spaces varName <- wordString spaces >> string "=" >> spaces func <- parseExpression (try $ spaces >> tagEnd)- return $ ParsedPiece (Decl varName func) pos+ return $ Decl varName func parseIsBlock = do blockName <- tag (string "isblock" >> spaces >> wordString) <?> "Isblock tag" blockContent <- parseContent (tryTag $ string "endisblock") return (blockName, blockContent) -parseInclude :: GenParser Char st ParsedPiece+parseInclude :: ParserM Piece parseInclude = do- pos <- getPosition- tag (parserInclude pos) <?> "Include tag"- where parserInclude pos = do+ tag parserInclude <?> "Include tag"+ where parserInclude = do string "include" >> spaces includeName <- pathString- return $ ParsedPiece (Include includeName) pos+ return $ Include includeName parseInherits = do {pos <- getPosition; mtag <- tag (string "inherits" >> spaces >> pathString); return (mtag, pos)} <?> "Inherits tag" -parseFunc :: GenParser Char st ParsedPiece+parseFunc :: ParserM Piece parseFunc = parserFunc <?> "Call tag" where parserFunc = do pos <- getPosition string "${" >> spaces exp <- parseExpression (try $ spaces >> string "}")- return $ ParsedPiece (FuncPiece exp) pos+ return $ FuncPiece exp -parseExpression :: GenParser Char st a -> GenParser Char st ParsedExpression+-- | Parse an expression that produces a `Literal`+parseExpression :: ParserM a -> ParserM ParsedExpression parseExpression end = manyPart <?> "Expression" where parseGroup = try parens <|> parseAtomic parseAtomic = do@@ -169,7 +184,7 @@ parseBool = (try $ string "True" >> return True) <|> (try $ string "False" >> return False) literal = wordString >>= (return . LookupExpression) -parseStringContents :: Char -> GenParser Char st String+parseStringContents :: Char -> ParserM String parseStringContents esc = between (char esc) (char esc) (many chars) where chars = (try escaped) <|> noneOf [esc] escaped = char '\\' >> choice (zipWith escapedChar codes replacements)@@ -177,14 +192,13 @@ codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '\'', '/'] replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '\'', '/'] -parseStatic :: GenParser Char st ParsedPiece+parseStatic :: ParserM Piece parseStatic = do- pos <- getPosition c <- anyChar s <- manyTill anyChar (peekChar '{' <|> peekChar '$' <|> eof)- return $ ParsedPiece (StaticPiece (B.fromString $ c:s)) pos+ return $ StaticPiece (B.fromString $ c:s) -parseNonStatic :: GenParser Char st ParsedPiece+parseNonStatic :: ParserM Piece parseNonStatic = try parseComment <|> try parseRaw <|> try parseBlock@@ -192,18 +206,26 @@ <|> try parseFor <|> try parseInclude <|> parseFunc- -parsePiece :: GenParser Char st ParsedPiece-parsePiece = (try parseNonStatic <|> parseStatic) -parsePieces :: GenParser Char st [ParsedPiece]+parsePiece :: ParserM ParsedPiece+parsePiece = do+ parsers <- liftM customParsers getState + foldr (\(BlockParser p) acc -> try (parseWithPos p) <|> acc) base_parser parsers+ where base_parser = parseWithPos (try parseNonStatic <|> parseStatic)++parseWithPos :: (Block a) => ParserM a -> ParserM ParsedPiece+parseWithPos p = do+ pos <- getPosition+ v <- p+ return $ ParsedPiece v pos++parsePieces :: ParserM [ParsedPiece] parsePieces = parseContent eof -parseToTemplate :: GenParser Char st Template+parseToTemplate :: ParserM Template parseToTemplate = (parseContent eof) >>= (return . Template) --- | Take a template body and a template name and return either an error or a+-- | Take config, a template body and a template name and return either an error or a -- renderable template.--parseTemplate :: String -> String -> Either ParseError Template-parseTemplate s tmplN = parse parseToTemplate tmplN s+parseTemplate :: StrappedConfig -> String -> String -> Either ParseError Template+parseTemplate config s tmplN = runParser parseToTemplate config tmplN s
src/Text/Strapped/Render.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE BangPatterns #-}+ module Text.Strapped.Render ( combineBuckets , varBucket@@ -6,29 +9,41 @@ , emptyBucket , render , defaultConfig+ -- * Building Custom Tags+ , reduceExpression+ , putBucket+ , getBucket+ , getConfig+ , getState+ , putState ) where import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Char.Utf8+import Blaze.ByteString.Builder.Int import Control.Monad-import qualified Data.Map as M+import qualified Data.Map.Strict as M+import Data.Foldable (foldlM) import Data.List (intersperse) import Data.Monoid ((<>), mempty, mconcat) import Control.Monad.Except+import Control.Monad.State.Strict+import Control.Monad.Writer import Control.Monad.IO.Class import Data.Maybe (catMaybes)-import qualified Data.Text.Lazy as T+import qualified Data.Text as T import Text.Strapped.Types import Text.Parsec.Pos +import Debug.Trace instance Renderable Builder where renderOutput _ = id instance Renderable Literal where- renderOutput (RenderConfig _ ef) (LitText s) = fromLazyText $ ef s- renderOutput _ (LitSafe s) = fromLazyText s- renderOutput rc (LitInteger i) = fromShow i+ renderOutput (StrappedConfig _ _ ef) (LitText s) = fromText $ ef s+ renderOutput _ (LitSafe s) = fromText s+ renderOutput _ (LitInteger i) = fromShow i renderOutput rc (LitDouble i) = fromShow i renderOutput rc (LitBool i) = fromShow i renderOutput _ (LitBuilder b) = b@@ -36,101 +51,155 @@ (mconcat $ intersperse (fromChar ',') (map (renderOutput rc) l)) <> (fromChar ']') renderOutput rc (LitDyn r) = renderOutput rc r+ {-# INLINE renderOutput #-} -- | Default render configuration. No text escaping.-defaultConfig :: RenderConfig-defaultConfig = RenderConfig (\_ -> return Nothing) id---- | If the first bucket fails, try the second.-combineBuckets :: InputBucket m -> InputBucket m -> InputBucket m-combineBuckets = (++) +defaultConfig :: StrappedConfig+defaultConfig = StrappedConfig [] (\_ -> return Nothing) id -- | Basic bucket. Matches on string and return input. Returns Nothing for -- everything else. varBucket :: String -> Input m -> InputBucket m-varBucket varName o = [M.fromList [(varName, o)]]+varBucket varName o = bucketFromList [(varName, o)]+{-# INLINE varBucket #-} +-- | If the first bucket fails, try the second.+combineBuckets :: InputBucket m -> InputBucket m -> InputBucket m+combineBuckets (InputBucket a) (InputBucket b) = InputBucket (a ++ b) +{-# INLINE combineBuckets #-} + emptyBucket :: InputBucket m-emptyBucket = []+emptyBucket = InputBucket [] bucketLookup :: String -> InputBucket m -> Maybe (Input m)-bucketLookup v [] = Nothing-bucketLookup v (m:ms) = maybe (bucketLookup v ms) Just (M.lookup v m)+bucketLookup v (InputBucket []) = Nothing+bucketLookup v (InputBucket (m:ms)) = maybe (bucketLookup v (InputBucket ms)) Just (M.lookup v m)+{-# INLINE bucketLookup #-} bucketFromList :: [(String, Input m)] -> InputBucket m-bucketFromList l = [M.fromList l]+bucketFromList l = InputBucket [M.fromList l]+{-# INLINE bucketFromList #-} -getOrThrow v getter pos = maybe (throwError $ InputNotFound v pos) return (bucketLookup v getter)+getOrThrow :: (Monad m) => String -> RenderT m (Input m)+getOrThrow v = do+ getter <- getBucket+ maybe (throwError $ InputNotFound v) return (bucketLookup v getter) -reduceExpression :: Monad m => RenderConfig -> ParsedExpression -> InputBucket m -> ExceptT StrapError m Literal-reduceExpression c (ParsedExpression exp pos) getter = convert exp- where convertMore exp = reduceExpression c exp getter- convert (LiteralExpression i) = return $ i+{-# INLINE getOrThrow #-}++reduceExpression :: (Monad m) => ParsedExpression -> RenderT m Literal+reduceExpression (ParsedExpression exp pos) = convert exp+ where convert (LiteralExpression i) = return $ i convert (Multipart []) = return $ LitEmpty- convert (Multipart (f:[])) = convertMore f+ convert (Multipart (f:[])) = reduceExpression f convert (Multipart ((ParsedExpression (LookupExpression func) ipos):args)) = do- val <- getOrThrow func getter pos+ val <- getOrThrow func case val of (Func f) -> convert (Multipart args) >>= f- _ -> throwError $ StrapError ("`" ++ func ++ "` is not a function but has args: " ++ (show args)) ipos- convert (Multipart v) = throwError $ StrapError ("`" ++ (show v) ++ "` cannot be reduced.") pos- convert (ListExpression args) = mapM convertMore args >>= (return . LitList) + _ -> throwParser $ "`" ++ func ++ "` is not a function but has args: " ++ (show args)+ convert (Multipart v) = throwParser $ "`" ++ (show v) ++ "` cannot be reduced."+ convert (ListExpression args) = mapM reduceExpression args >>= (return . LitList) convert (LookupExpression f) = do- val <- getOrThrow f getter pos+ val <- getOrThrow f inputToLiteral val inputToLiteral inp = case inp of- (List args) -> mapM inputToLiteral args >>= (return . LitList)- (RenderVal r) -> return $ LitBuilder (renderOutput c r) (Func f) -> f LitEmpty (LitVal v) -> return v --- | Using a 'TemplateStore' and an 'InputBucket' render the template name.-render :: MonadIO m => RenderConfig -> InputBucket m -> String -> m (Either StrapError Output)-render renderConfig getter' tmplName = do+{-# INLINE reduceExpression #-}++ +putPos :: Monad m => SourcePos -> RenderT m ()+putPos a = RenderT $ modify (\i -> i { position=a })++putBucket :: Monad m => (InputBucket m) -> RenderT m ()+putBucket a = RenderT $ modify (\i -> i { bucket=a })++getPos :: Monad m => RenderT m SourcePos+getPos = liftM position getState++getBucket :: Monad m => RenderT m (InputBucket m)+getBucket = liftM bucket getState+{-# INLINE getBucket #-}++getConfig :: Monad m => RenderT m StrappedConfig+getConfig = liftM renderConfig getState+{-# INLINE getConfig #-} ++getBlocks :: Monad m => RenderT m BlockMap+getBlocks = liftM blocks getState++putBlocks :: Monad m => BlockMap -> RenderT m ()+putBlocks a = RenderT $ lift $ modify (\i -> i { blocks=a })++getState :: Monad m => RenderT m (RenderState m)+getState = RenderT $ get++putState :: Monad m => RenderState m -> RenderT m ()+putState = RenderT . put++throwParser :: (Monad m) => String -> RenderT m b+throwParser s = throwError $ StrapError s ++instance Block Piece where+ process (StaticPiece s) = return s+ process (BlockPiece n default_content) = do+ blks <- getBlocks+ maybe (buildContent default_content) (buildContent) (M.lookup n blks)+ process (ForPiece n exp c) = do+ var <- reduceExpression exp+ curState <- getState+ curBucket <- getBucket+ ret <- case var of + LitList l -> foldlM (\acc obj -> putBucket (combineBuckets (varBucket n $ LitVal obj) curBucket) >> + buildContent c >>= return . (<>) acc) mempty l+ _ -> throwParser $ "`" ++ show exp ++ "` is not a LitList"+ putBucket curBucket+ return ret+ process (IfPiece exp p n) = do+ var <- reduceExpression exp+ c <- case (toBool var) of+ True -> buildContent p+ False -> buildContent n+ return c+ process (Inherits n b) = do+ tmplStore <- liftM templateStore getConfig+ mtmpl <- liftIO (tmplStore n)+ maybe (throwError (TemplateNotFound n))+ (\(Template c) -> do + curBlocks <- getBlocks+ putBlocks $ M.union b curBlocks+ r <- buildContent c+ putBlocks curBlocks+ return r)+ mtmpl+ process (Include n) = do+ tmplStore <- liftM templateStore getConfig+ mtmpl <- liftIO (tmplStore n)+ maybe (throwError (TemplateNotFound n))+ (\(Template c) -> buildContent c)+ mtmpl+ process (Decl n exp) = do+ val <- (reduceExpression exp)+ bucket <- getBucket+ putBucket $ combineBuckets (varBucket n (LitVal val)) bucket+ return mempty+ process (FuncPiece exp) = do+ config <- getConfig+ val <- reduceExpression exp+ return $ renderOutput config val+ +-- buildContent pieces accum = forM_ pieces (\(ParsedPiece piece pos) -> putPos pos >> process piece accum)+buildContent pieces = foldlM (\acc (ParsedPiece piece pos) -> (process piece) `catchError` (\e -> throwError $ PositionedError e pos) >>= return . (<>) acc ) mempty pieces++render :: (MonadIO m) => StrappedConfig -> InputBucket m -> String -> m (Either StrapError Output)+render renderConfig !getter' tmplName = do tmpl <- liftIO $ tmplStore tmplName- maybe (return $ Left $ TemplateNotFound tmplName (initialPos tmplName)) - (\(Template c) -> runExceptT $ loop mempty mempty getter' c) + maybe (return $ Left $ TemplateNotFound tmplName) + (\(Template c) -> (flip evalStateT startState $ runExceptT $ runRenderT $ buildContent c)) tmpl+ where tmplStore = templateStore renderConfig- loop accum _ _ [] = return accum- loop accum blks getter ((ParsedPiece (StaticPiece s) pos):ps) =- loop (accum <> s) blks getter ps- loop accum blks getter ((ParsedPiece (BlockPiece n def) pos):ps) = - (maybe (loop accum blks getter def) - (\content -> loop accum blks getter content)- (lookup n blks)- ) >>= (\a -> loop a blks getter ps)- loop accum blks getter ((ParsedPiece (ForPiece n exp c) pos):ps) = do- var <- reduceExpression renderConfig exp getter- case var of - LitList l -> (processFor getter n c accum blks l) >>= (\a -> loop a blks getter ps)- _ -> throwError $ StrapError ("`" ++ show exp ++ "` is not a LitList") pos- loop accum blks getter ((ParsedPiece (IfPiece exp p n) pos):ps) = do- var <- reduceExpression renderConfig exp getter- case (toBool var) of- True -> (loop accum blks getter p) >>= (\a -> loop a blks getter ps)- False -> (loop accum blks getter n) >>= (\a -> loop a blks getter ps)- loop accum blks getter ((ParsedPiece (Inherits n b) pos):ps) =- liftIO (tmplStore n) >>=- maybe (throwError (TemplateNotFound n pos))- (\(Template c) -> (loop accum (b ++ blks) getter c) >>= - (\a -> loop a blks getter ps))- loop accum blks getter ((ParsedPiece (Include n) pos):ps) =- liftIO (tmplStore n) >>=- maybe (throwError (TemplateNotFound n pos)) - (\(Template c) -> (loop accum blks getter c) >>=- (\a -> loop a blks getter ps))- loop accum blks getter ((ParsedPiece (Decl n exp) pos):ps) = - (reduceExpression renderConfig exp getter) >>=- (\v -> loop accum blks (combineBuckets (varBucket n (LitVal v)) getter) ps)-- loop accum blks getter ((ParsedPiece (FuncPiece exp) pos):ps) = - (reduceExpression renderConfig exp getter) >>= - (\r -> loop (accum <> (renderOutput renderConfig r)) blks getter ps) + startState = RenderState (initialPos tmplName) renderConfig M.empty getter' - processFor getter varName content accum blks objs = loopFor accum objs- where loopGetter o = combineBuckets (varBucket varName (LitVal o)) getter- loopFor accum [] = return accum- loopFor accum (o:os) = do- s <- loop accum blks (loopGetter o) content- loopFor s os+
src/Text/Strapped/Types.hs view
@@ -1,17 +1,54 @@ {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+ module Text.Strapped.Types where import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Char8 hiding (fromString)+import Control.Applicative import Control.Monad.Except import qualified Data.ByteString.Lazy.Char8 as BS import Data.List as L (intersperse, null)-import qualified Data.Map as M+import qualified Data.Map.Strict as M+import Control.Monad.State.Strict+import Control.Monad.Writer import Data.Monoid (mconcat)-import Data.Text.Lazy as T (Text, null, unpack)+import Data.Text as T (Text, pack, null, unpack) import Data.Typeable+import Data.String import Text.Parsec.Pos +import Text.Parsec+import Text.Parsec.String++-- | RenderT m+--+-- * m -> Monad we are transforming+newtype RenderT m a = RenderT + { runRenderT :: ExceptT StrapError (StateT (RenderState m) m) a + } deriving ( Functor, Applicative, Monad, MonadIO )++instance MonadTrans RenderT where+ lift = RenderT . lift . lift+ +data RenderState m = RenderState+ { position :: SourcePos+ , renderConfig :: StrappedConfig+ , blocks :: BlockMap+ , bucket :: InputBucket m+ }++instance (Monad m) => MonadError StrapError (RenderT m) where+ throwError = RenderT . throwError+ catchError (RenderT m) f = RenderT (catchError m (runRenderT . f))+ type Output = Builder+type BlockMap = M.Map String [ParsedPiece] instance Show Builder where show = show . toByteString@@ -40,30 +77,61 @@ | FuncPiece ParsedExpression | Decl String ParsedExpression | Include String- | Inherits String [(String, [ParsedPiece])]+ | Inherits String BlockMap deriving (Show) -data ParsedPiece = ParsedPiece Piece SourcePos- deriving (Show)+data ParsedPiece = forall a . (Block a) => ParsedPiece a SourcePos++instance Show ParsedPiece where+ show (ParsedPiece a b) = show b class Renderable a where- renderOutput :: RenderConfig -> a -> Output+ renderOutput :: StrappedConfig -> a -> Output+ -data Input m = forall a . (Renderable a) => RenderVal a- | List [Input m]- | Func (Literal -> ExceptT StrapError m Literal)+data Input m = Func (Literal -> RenderT m Literal) | LitVal Literal -data Literal = forall a . (Typeable a, Renderable a) => LitDyn a- | LitText Text- | LitSafe Text- | LitInteger Integer- | LitDouble Double- | LitBuilder Builder+data Literal = forall a . (Typeable a, Renderable a) => LitDyn !a+ | LitText !Text+ | LitSafe !Text+ | LitInteger !Integer+ | LitDouble !Double+ | LitBuilder !Builder | LitList ![Literal]- | LitBool Bool+ | LitBool !Bool | LitEmpty +class ToLiteral a where+ toLiteral :: a -> Literal++instance ToLiteral Text where+ toLiteral = LitText++instance ToLiteral Integer where+ toLiteral = LitInteger++instance ToLiteral Double where+ toLiteral = LitDouble++instance ToLiteral Builder where+ toLiteral = LitBuilder++instance ToLiteral [Literal] where+ toLiteral = LitList++instance ToLiteral Bool where+ toLiteral = LitBool++instance ToLiteral String where+ toLiteral = LitText . T.pack++instance IsString Literal where+ fromString = toLiteral++class Block a where+ process :: (MonadIO m) => a -> RenderT m Output+ class Booly a where toBool :: a -> Bool @@ -90,19 +158,25 @@ show LitEmpty = "" -data StrapError = StrapError String SourcePos - | InputNotFound String SourcePos - | TemplateNotFound String SourcePos+data StrapError = StrapError String+ | InputNotFound String+ | TemplateNotFound String+ | PositionedError StrapError SourcePos deriving (Show, Eq) -type InputBucket m = [M.Map String (Input m)]+data InputBucket m = InputBucket [(M.Map String (Input m))] type TemplateStore = String -> IO (Maybe Template) data Template = Template [ParsedPiece] deriving Show -data RenderConfig = RenderConfig - { templateStore :: TemplateStore+type ParserM = GenParser Char StrappedConfig++data BlockParser = forall a . (Block a) => BlockParser (ParserM a)++data StrappedConfig = StrappedConfig+ { customParsers :: [BlockParser]+ , templateStore :: TemplateStore , escapeFunc :: Text -> Text }
src/Text/Strapped/Utils.hs view
@@ -6,28 +6,35 @@ import Data.List hiding (find) import Text.Strapped.Types import Text.Strapped.Parser+import Data.Typeable import System.FilePath.Find import System.FilePath.Posix (addTrailingPathSeparator) import Text.ParserCombinators.Parsec -templateStoreFromList :: [(String, String)] -> Either ParseError TemplateStore-templateStoreFromList tmpls = do- templateTups <- forM tmpls (\(tn, t) -> fmap ((,) tn) $ parseTemplate t tn)+templateStoreFromList :: StrappedConfig -> [(String, String)] -> Either ParseError TemplateStore+templateStoreFromList config tmpls = do+ templateTups <- forM tmpls (\(tn, t) -> fmap ((,) tn) $ parseTemplate config t tn) return (\n -> return $ lookup n templateTups) -- | Given a file path and extension, load all templates in a directory, recursively.-templateStoreFromDirectory :: FilePath -> String -> IO (Either ParseError TemplateStore)-templateStoreFromDirectory dir ext = do+templateStoreFromDirectory :: StrappedConfig -> FilePath -> String -> IO (Either ParseError TemplateStore)+templateStoreFromDirectory config dir ext = do files <- find always (extension ==? ext) dirPath tmpls <- forM files (\fn -> let fname = maybe [] id $ stripPrefix dirPath fn in print fname >> readFile fn >>= (return . (,) fname))- return $ templateStoreFromList tmpls+ return $! templateStoreFromList config tmpls where dirPath = addTrailingPathSeparator dir -putStore :: TemplateStore -> RenderConfig -> RenderConfig+putStore :: TemplateStore -> StrappedConfig -> StrappedConfig putStore ts rc = rc { templateStore = ts } showToBuilder :: Show a => a -> Builder showToBuilder = fromShow++lit :: ToLiteral a => a -> Input m+lit = LitVal . toLiteral++dyn :: (Renderable a, Typeable a) => a -> Input m+dyn = LitVal . LitDyn
tests/StrappedTest.hs view
@@ -1,23 +1,24 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} import Test.Hspec import qualified Blaze.ByteString.Builder as B-import qualified Data.Text.Lazy as T+import qualified Data.Text as T import qualified Data.ByteString as BS+import Data.Typeable import Text.Strapped import System.Exit data Custom = Custom- deriving (Show)+ deriving (Show, Typeable) instance Renderable Custom where renderOutput _ c = showToBuilder c mainBucket :: InputBucket IO mainBucket = bucketFromList [- ("custom", RenderVal Custom),- ("is", List $ map (LitVal . LitInteger) [1..3]),+ ("custom", LitVal $ LitDyn Custom),+ ("is", lit $ map (LitInteger) [1..3]), ("addNumbers", Func add) ] where add (LitList ((LitInteger a):(LitInteger b):[])) = return $ LitInteger $ a + b@@ -27,16 +28,12 @@ renderShouldBe :: IO (Either StrapError Output) -> Either StrapError BS.ByteString -> Expectation renderShouldBe f c = f >>= (\e -> (fmap B.toByteString e) `shouldBe` c) -spec :: RenderConfig -> Spec+spec :: StrappedConfig -> Spec spec ts = do describe "for loop" $ it "Should loop through stuff" $ do (render ts mainBucket "for_loop") `renderShouldBe` (Right "1, 2, 3, ") - describe "RenderVal" $- it "class RenderVal" $ do- (render ts mainBucket "custom") `renderShouldBe` (Right "Custom")- describe "Comment" $ it "Check comments" $ do (render ts mainBucket "comment") `renderShouldBe` (Right "")@@ -66,7 +63,7 @@ (render ts mainBucket "if") `renderShouldBe` (Right "show me") main = do- let ets = templateStoreFromList + let ets = templateStoreFromList defaultConfig [ ("for_loop", "{$ for i in is $}${ i }, {$ endfor $}") , ("custom", "${ custom }") , ("comment", "{$ comment $}${ custom }{$ endcomment $}")