diff --git a/StrappedTemplates.cabal b/StrappedTemplates.cabal --- a/StrappedTemplates.cabal +++ b/StrappedTemplates.cabal @@ -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, diff --git a/src/Text/Strapped.hs b/src/Text/Strapped.hs --- a/src/Text/Strapped.hs +++ b/src/Text/Strapped.hs @@ -9,6 +9,8 @@ , bucketLookup , bucketFromList , emptyBucket + , lit + , dyn -- * Parsing , parseTemplate -- * TemplateLoading diff --git a/src/Text/Strapped/Parser.hs b/src/Text/Strapped/Parser.hs --- a/src/Text/Strapped/Parser.hs +++ b/src/Text/Strapped/Parser.hs @@ -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 diff --git a/src/Text/Strapped/Render.hs b/src/Text/Strapped/Render.hs --- a/src/Text/Strapped/Render.hs +++ b/src/Text/Strapped/Render.hs @@ -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 + diff --git a/src/Text/Strapped/Types.hs b/src/Text/Strapped/Types.hs --- a/src/Text/Strapped/Types.hs +++ b/src/Text/Strapped/Types.hs @@ -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 } diff --git a/src/Text/Strapped/Utils.hs b/src/Text/Strapped/Utils.hs --- a/src/Text/Strapped/Utils.hs +++ b/src/Text/Strapped/Utils.hs @@ -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 diff --git a/tests/StrappedTest.hs b/tests/StrappedTest.hs --- a/tests/StrappedTest.hs +++ b/tests/StrappedTest.hs @@ -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 $}")