press (empty) → 0.1.0
raw patch · 8 files changed
+594/−0 lines, 8 filesdep +basedep +containersdep +jsonsetup-changed
Dependencies added: base, containers, json, mtl, parsec
Files
- LICENSE +1/−0
- Setup.hs +4/−0
- Text/Press/Parser.hs +144/−0
- Text/Press/Render.hs +94/−0
- Text/Press/Run.hs +80/−0
- Text/Press/Tags.hs +163/−0
- Text/Press/Types.hs +92/−0
- press.cabal +16/−0
+ LICENSE view
@@ -0,0 +1,1 @@+GPL Version 3 or Later
+ Setup.hs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell+import Distribution.Simple (defaultMain)++main = defaultMain
+ Text/Press/Parser.hs view
@@ -0,0 +1,144 @@++module Text.Press.Parser where+import Data.Char (isSpace)+import Data.Either (Either(..))+import Data.Map (fromList, Map, lookup, insert)+import Data.Maybe (catMaybes, listToMaybe)+import Prelude hiding (lookup)++import qualified Text.Parsec as Parsec+import qualified Text.Parsec.Error as Parsec.Error+import Text.Parsec.Char (string, anyChar, space, alphaNum, letter, oneOf)+import Text.Parsec.String (parseFromFile)+import Text.Parsec.Combinator (manyTill, many1, notFollowedBy, choice, eof, lookAhead, optional, sepEndBy)+import Text.Parsec.Pos (SourcePos, sourceName)+import Text.Parsec.Prim ((<|>), try, Parsec, getPosition, getState)+import qualified Text.Parsec.Prim as Parsec.Prim++import Text.Press.Types+import Text.Press.Render ++skipMany p = scan+ where scan = (p >> scan) <|> return ()++intermediateParser = manyTill intermediate eof + +intermediate = choice [try parseTag, try parseVar, someText]++someText = withPos $ fmap PText someText' + where someText' = (choice [check $ string "{{", check $ string "{%", check eof]) <|> succ+ check p = (lookAhead $ try p) >> return []+ succ = do + c <- anyChar+ xs <- someText'+ return $ c : xs++between left right = string left >> manyTill anyChar (string right)++withPos action = do + p <- getPosition+ result <- action+ return (result, p)++parseTag = withPos $ do+ string "{%"+ skipMany space+ name <- identifier+ skipMany space+ rest <- manyTill anyChar (string "%}")+ return $ PTag name rest + where ++identifier = do + l <- choice [letter, oneOf "_"]+ s <- Parsec.Prim.many (choice [alphaNum, oneOf "_"])+ return (l:s)++parseVar = withPos $ fmap PVar $ between "{{" "}}"++parseFile :: Parser -> String -> IO (Either Parsec.ParseError Template)+parseFile parser filename = do+ eitherTokens <- parseFromFile intermediateParser filename + return $ case eitherTokens of+ Left err -> Left err+ Right tokens -> Parsec.Prim.runParser tokensToTemplate (parser, newTemplate) filename tokens++parseString :: Parser -> String -> Either Parsec.ParseError Template+parseString parser string = do+ case Parsec.Prim.runParser intermediateParser () "" string of+ Left err -> Left err+ Right tokens -> Parsec.Prim.runParser tokensToTemplate (parser, newTemplate) "" tokens+++tokensToTemplate :: Parsec [(Token, SourcePos)] ParserState Template +tokensToTemplate = do + nodes <- fmap catMaybes $ Parsec.Prim.many pNode + (p, t) <- getState+ return $ t {tmplNodes=nodes}++pNode = choice [pVar, pTag, pText]++pVar = do+ (PVar x, pos) <- var + return $ Just $ Var $ strip x++pText = do+ (PText x, pos) <- text+ return $ Just $ Text x ++pTag = do + ((PTag name rest), pos) <- tag+ (parser, _) <- getState+ case lookup name (parserTagTypes parser) of + Nothing -> fail ("unknown tag: " ++ show name)+ Just (TagType t) -> t name rest++token' x = Parsec.Prim.token (show . fst) (snd) x+var = token' $ toMaybe $ isVar . fst+text = token' $ toMaybe $ isText . fst+tag = token' $ toMaybe $ isTag . fst+tagNamed name = token' $ toMaybe $ (isTagNamed name) . fst+tagNamedOneOf name = token' $ toMaybe $ (isTagNamedOneOf name) . fst++toMaybe f tokpos = if (f tokpos) then Just tokpos else Nothing++isVar (PVar _) = True+isVar otherwise = False++isTag (PTag _ _) = True+isTag otherwise = False++isTagNamed aname tag = isTagNamedOneOf [aname] tag++isTagNamedOneOf names (PTag name _) = name `elem` names+isTagNamedOneOf names otherwise = False++isText (PText _) = True+isText otherwise = False++strip = f . f+ where f = reverse . dropWhile isSpace++handleParsecError e = error (show e)++failWithParseError :: (Parsec.Prim.Stream s m t) => Parsec.Error.ParseError -> Parsec.Prim.ParsecT s u m a+failWithParseError parseError = Parsec.Prim.ParsecT $ + \s -> return $ Parsec.Prim.Empty $ return $ Parsec.Prim.Error parseError++runSubParser parser state input = do+ name <- fmap sourceName getPosition+ case Parsec.Prim.runParser parser state name input of+ Left parseError -> failWithParseError parseError+ Right tokens -> return tokens++spaces = many1 space++runParseTagExpressions input = runSubParser parseTagExpressions () input+ where parseTagExpressions = do + optional spaces+ exprs <- (choice [try pStr, try pVar]) `sepEndBy` spaces+ return exprs + pStr = fmap ExprStr $ between "\"" "\""+ pVar = fmap ExprVar $ identifier++
+ Text/Press/Render.hs view
@@ -0,0 +1,94 @@+module Text.Press.Render where++import Control.Monad.State+import Control.Monad.Writer.Lazy+import Control.Monad.Error.Class (throwError)++import Data.Map (Map, lookup, fromList, insert)+import Data.Maybe (listToMaybe, catMaybes)+import Prelude hiding (lookup)+import Data.List hiding (lookup)++import Text.JSON.Types +import Text.JSON++import Text.Press.Types++emit s = tell [s]++instance Render Node where + render (Text s) = emit s+ render (Var var) = do+ context <- getRenderState+ case lookupVar var context of+ Nothing -> emit ""+ Just jsval -> render jsval+ render (Tag _ f) = render f ++instance Render TagFunc where+ render (TagFunc f) = f ++instance Render JSValue where + render JSNull = emit ""+ render (JSString x) = emit $ fromJSString x+ render other = emit $ (showJSValue other) ""++lookupVarM name = do + st <- getRenderState + return $ lookupVar name st++lookupVar name (RenderState {renderStateValues = vals}) = + listToMaybe . catMaybes $ map (getf name) vals++split :: String -> String -> [String]+split tok splitme = unfoldr (sp1 tok) splitme+ where sp1 _ "" = Nothing+ sp1 t s = case find (t `isSuffixOf`) (inits s) of+ Nothing -> Just (s, "")+ Just p -> Just (take ((length p) - (length t)) p,+ drop (length p) s)++getf name a = getf' names (Just a)+ where + names = split "." name + getf' [] y = y+ getf' x Nothing = Nothing+ getf' (x : xs) obj@(Just (JSObject a)) = getf' xs $ get_field a x+ getf' x y = Nothing ++-- Show a block+showBlock :: String -> RenderT_ +showBlock blockName = do+ templates <- templateStack+ let maybeNodes = lookupFirst blockName $ map tmplBlocks $ templates+ case maybeNodes of+ Just nodes -> mapM_ render nodes+ Nothing -> tell [""]++lookupFirst :: Ord k => k -> [Map k a] -> Maybe a+lookupFirst name maps = listToMaybe . catMaybes $ map (lookup name) maps ++getTemplate = fmap renderStateTemplate getRenderState++templateStack = getTemplate >>= templateStack' + where+ templateStack' t@(Template {tmplExtends=Nothing}) = return [t]+ templateStack' t@(Template {tmplExtends=Just name}) = do+ cache <- fmap (parserTemplateCache . renderStateParser) get+ case lookup name cache of+ Just template -> do+ templates <- templateStack' template+ return $ t : (template : templates)+ Nothing -> throwError $ PressError $ "expecting a template in the cache named: " ++ (show name)++doRender = do + bodyNodes <- fmap (tmplNodes . last) templateStack+ mapM render bodyNodes++coerceJSToBool :: JSValue -> Bool+coerceJSToBool JSNull = False +coerceJSToBool (JSBool bool) = bool+coerceJSToBool (JSRational sign r) = (not sign) && (r > 0)+coerceJSToBool (JSString x) = length (fromJSString x) > 0+coerceJSToBool (JSArray vals) = length vals > 0+coerceJSToBool (JSObject obj) = length (fromJSObject obj) > 0
+ Text/Press/Run.hs view
@@ -0,0 +1,80 @@+module Text.Press.Run where++import Control.Monad.State+import Control.Monad.Error (runErrorT, ErrorT)+import Control.Monad.Error.Class (throwError)+import Control.Monad.Writer.Lazy+import Prelude hiding (lookup)++import Data.Map (insert, lookup)+import Text.JSON (JSValue, decodeStrict, JSValue(..))++import Text.Press.Types+import Text.Press.Parser+import Text.Press.Render+import Text.Press.Tags++type Result = Either PressError [String]++runJSValuesWithPath datas templateName = runErrorT $ evalStateT (runJSValuesWithPathStTErrT datas templateName) defaultParser++runJSValuesWithPathStTErrT :: [JSValue] -> String -> StateT Parser (ErrorT PressError IO) [String]+runJSValuesWithPathStTErrT datas templateName = do+ addToTemplateCache templateName+ parser <- get+ template <- fmap head $ lookupTemplates templateName+ let st = RenderState {+ renderStateParser = parser,+ renderStateTemplate = template,+ renderStateValues = datas+ }+ lift $ evalStateT (execWriterT doRender) st++runJSValuesWithBody :: [JSValue] -> String -> IO Result+runJSValuesWithBody jsvalues body = do + case parseString defaultParser body of+ Left parsecError -> return $ Left $ ParseError parsecError+ Right template -> runErrorT $ evalStateT (runJSValuesWithTemplateStTErrT jsvalues template) defaultParser++runJSValuesWithTemplate :: [JSValue] -> Template -> Parser -> IO Result+runJSValuesWithTemplate jsvalues template parser = runErrorT $ evalStateT (runJSValuesWithTemplateStTErrT jsvalues template) parser++runJSValuesWithTemplateStTErrT :: [JSValue] -> Template -> StateT Parser (ErrorT PressError IO) [String]+runJSValuesWithTemplateStTErrT jsvalues template = do+ case tmplExtends template of + Just s -> addToTemplateCache s+ Nothing -> return ()+ parser <- get+ lift $ evalStateT (execWriterT doRender) RenderState {+ renderStateParser = parser,+ renderStateTemplate = template,+ renderStateValues = jsvalues+ }++lookupTemplates templateName = do+ parser <- get+ case lookup templateName (parserTemplateCache parser) of+ Just template -> case tmplExtends template of + Nothing -> return [template]+ Just s -> do + xs <- lookupTemplates s+ return $ template : xs+ Nothing -> throwError $ PressError $ "unexpected uncached template: " ++ (show templateName)++addToTemplateCache template = do+ parser <- get+ let mapping = parserTemplateCache parser+ case lookup template mapping of + Just tmpl -> return ()+ Nothing -> do+ eitherTemplateError <- liftIO $ parseFile parser template+ case eitherTemplateError of+ Left err -> liftIO $ error . show $ err+ Right tmpl -> do + let mapping' = insert template tmpl mapping + put $ parser {parserTemplateCache = mapping'}+ case tmplExtends tmpl of+ Nothing -> return ()+ Just s -> addToTemplateCache s++defaultParser = newParser { parserTagTypes = defaultTagTypes }
+ Text/Press/Tags.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Text.Press.Tags where+import Text.JSON.Types++import Data.Map (fromList, insert)+import Data.Maybe (catMaybes)+import qualified Text.Parsec.Prim as Parsec.Prim+import Text.Parsec.Combinator (manyTill, choice)+import Control.Monad.Trans (lift, liftIO)+import Control.Monad (forM_)++import Text.Press.Parser+import Control.Monad.Trans (lift, liftIO)++import Text.Press.Parser+import Text.Press.Render+import Text.Press.Types++extendsTag name rest = do+ exprs <- runParseTagExpressions rest+ include <- case exprs of+ (ExprStr s : xs) -> return s+ otherwise -> fail "expecting a string"+ let rest' = Just . strip $ include+ Parsec.Prim.modifyState $ \(parser, tmpl) -> (parser, tmpl {tmplExtends = rest'})+ return $ Nothing++blockTag name rest = do+ exprs <- runParseTagExpressions rest+ blockName <- case exprs of+ (ExprVar var : xs) -> return var+ otherwise -> Parsec.Prim.unexpected (show otherwise)+ nodes <- fmap catMaybes $ manyTill pNode (tagNamed "endblock")+ Parsec.Prim.modifyState $ \(parser, tmpl) -> (parser,+ tmpl {tmplBlocks = insert blockName nodes (tmplBlocks tmpl)})+ return $ Just $ Tag "block" $ TagFunc $ showBlock blockName++-- This is mapping of all of the default tag types. +defaultTagTypes = (fromList [+ ("extends", TagType extendsTag),+ ("block", TagType blockTag),+ ("if", TagType ifTag),+ ("for", TagType forTag),+ ("comment", TagType commentTag)+ ])++-- Comment Tag+commentTag name rest = do + manyTill pNode (tagNamed "endcomment")+ return Nothing++-- If tag+ifTag name rest = do+ expr <- parseIfExpr rest+ scan [] expr+ where+ scan ifs e = do+ (maybeNodes, tokenPos) <- manyTill' pNode (tagNamedOneOf ["else", "endif", "elif"])+ let nodes = catMaybes maybeNodes+ let token = fst tokenPos+ let ifs' = ifs ++ [(e, nodes)]+ case token of+ (PTag "endif" rest) -> do+ return $ Just $ Tag "if" $ TagFunc $ showIfElse ifs' []+ (PTag "elif" rest) -> do+ e' <- parseIfExpr rest+ scan ifs' e'+ (PTag "else" rest) -> do+ nodes <- fmap catMaybes $ manyTill pNode (tagNamed "endif")+ return $ Just $ Tag "if" $ TagFunc $ showIfElse ifs' nodes+ otherwise -> Parsec.Prim.unexpected "unexpected tag"+ parseIfExpr s = do+ exprs <- runParseTagExpressions s+ case exprs of+ [] -> Parsec.Prim.unexpected "empty if"+ (x : []) -> return x+ (x : xs) -> Parsec.Prim.unexpected $ show . head $ xs++-- Version of manyTill that returns the terminating token+manyTill' p1 p2 = scan+ where scan = (Parsec.Prim.try p2') Parsec.Prim.<|> p1'+ p1' = do x <- p1+ (xs, y) <- scan+ return (x : xs, y)+ p2' = do y <- p2+ return ([], y)++-- Evaluate an expression to a boolean suitable for an If clase+exprToBool :: Expr -> RenderT Bool+exprToBool expr = do+ case expr of+ ExprStr s -> return $ length s > 0+ ExprNum num -> return $ num > 0+ ExprVar var -> do+ maybeVal <- lookupVarM var+ case maybeVal of+ Nothing -> return False+ Just val -> return $ coerceJSToBool val++showIfElse :: [(Expr, [Node])] -> [Node] -> RenderT_+showIfElse [] right = mapM_ render right+showIfElse ((expr, left) : xs) right = do+ succ <- exprToBool expr+ if succ+ then mapM_ render left+ else showIfElse xs right++forTag name rest = do+ (target, sourceExpr) <- parseFor rest+ (maybeNodes, (token, pos)) <- manyTill' pNode (tagNamedOneOf ["endfor", "else"])+ let forNodes = catMaybes maybeNodes+ case token of+ PTag "else" _ -> do+ elseNodes <- fmap catMaybes $ manyTill pNode (tagNamed "endfor")+ return $ Just $ Tag "for" $ TagFunc $ showFor target sourceExpr forNodes elseNodes+ PTag "endfor" _ -> do+ return $ Just $ Tag "for" $ TagFunc $ showFor target sourceExpr forNodes []++ where+ parseFor s = do+ exprs <- runParseTagExpressions s+ if length exprs == 3+ then do+ target <- case head exprs of+ ExprVar x -> return x+ otherwise -> fail "unexpected for target"+ case head $ tail exprs of+ ExprVar "in" -> return ()+ otherwise -> fail "expecting 'in'"+ return $ (target, head $ tail $ tail exprs)+ else Parsec.Prim.unexpected "number of arguments"++showFor :: String -> Expr -> [Node] -> [Node] -> RenderT_+showFor target sourceExpr forNodes elseNodes = do+ sourceValues <- fmap toList $ toJS sourceExpr+ runFor sourceValues+ where+ runFor [] = mapM_ render elseNodes+ runFor vals = forM_ vals $ \x -> do+ pushValues [(target, x)]+ mapM_ render forNodes+ popValues++ toList (Just (JSArray vals)) = vals+ toList otherwise = []++ toJS (ExprVar x) = lookupVarM x+ toJS otherwise = return Nothing++ pushValues kvpairs = do+ st <- getRenderState+ setRenderState $ st {+ renderStateValues = values' : renderStateValues st+ }+ where values' = JSObject $ toJSObject kvpairs++ popValues = do+ st <- getRenderState+ setRenderState $ st {+ renderStateValues = tail $ renderStateValues st+ }+
+ Text/Press/Types.hs view
@@ -0,0 +1,92 @@+module Text.Press.Types where ++import Control.Monad.Error (ErrorT, Error)+import Control.Monad.Error.Class +import Control.Monad.State (StateT, get, put)+import Control.Monad.Trans (lift)+import Control.Monad.Writer.Lazy (WriterT)+import Data.Map (Map, lookup, fromList)++import qualified Text.Parsec.Prim as Prim+import qualified Text.Parsec.Error+import Text.Parsec.Pos (SourcePos)+import Text.JSON (JSValue)++data RenderState = RenderState {+ renderStateParser :: Parser,+ renderStateTemplate :: Template,+ renderStateValues :: [JSValue]+}++data PressError = PressError String+ | ParseError Text.Parsec.Error.ParseError+ | RenderError String+ deriving (Show)++instance Error PressError where+ noMsg = PressError "Some rendering error"+ strMsg s = PressError s++type RenderT a = WriterT [String] (StateT RenderState (ErrorT PressError IO)) a+type RenderT_ = RenderT ()++getRenderState :: RenderT RenderState+--getRenderState = lift $ lift $ get+getRenderState = get++setRenderState :: RenderState -> RenderT ()+setRenderState = put++data TagFunc = TagFunc RenderT_++data Node = Var String+ | Tag TagName TagFunc+ | Text String+ deriving (Show)++instance Show TagFunc where+ show s = "TagFunc ?"++type TemplatePath = String++data Template = Template {+ tmplExtends :: Maybe TemplatePath,+ tmplBlocks :: Map String [Node],+ tmplNodes :: [Node],+ tmplFilename :: String+} deriving (Show) ++newTemplate = Template Nothing (fromList []) [] "" ++type TagName = String+type TemplateParser a = Prim.Parsec [(Token, SourcePos)] ParserState a+type NodeParser = TemplateParser (Maybe Node)+data TagType = TagType (TagName -> String -> NodeParser)+data Expr = ExprStr String+ | ExprVar String+ | ExprNum Double+ -- | ExprBinary Op Expr Expr + -- | ExprUnary Op Expr+ deriving (Ord, Eq, Show)++type ParserState = (Parser, Template)++instance Show TagType where+ show s = "TagType ?"++data Token = PText String + | PTag TagName String+ | PVar String+ deriving (Ord, Show, Eq)++data Parser = Parser {+ parserTagTypes :: Map TagName TagType,+ parserSearchPaths :: [String],+ parserTemplateCache :: Map TemplatePath Template +} deriving (Show)++class Render a where+ render :: a -> RenderT_++newParser = Parser (fromList []) [] (fromList [])+
+ press.cabal view
@@ -0,0 +1,16 @@+Name: press+Version: 0.1.0+Synopsis: Text templating language+Description: A text templating language similar to Jinja & Django Templates+Category: Text, Web+License: GPL+License-File: LICENSE+Author: Brandon Bickford <bickfordb@gmail.com>+Maintainer: bickfordb@gmail.com+Homepage: http://github.com/bickfordb/text-press+Build-Type: Simple+Cabal-Version: >= 1.2++Library+ Build-Depends: base <4, containers, mtl, parsec >= 3.0.0, json+ Exposed-Modules: Text.Press.Render, Text.Press.Parser, Text.Press.Tags, Text.Press.Run, Text.Press.Types