heterocephalus 1.0.2.0 → 1.0.2.3
raw patch · 3 files changed
+281/−186 lines, 3 filesPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
API changes (from Hackage documentation)
+ Text.Heterocephalus: instance GHC.Base.Monoid (Text.Heterocephalus.ScopeM ())
Files
- heterocephalus.cabal +1/−1
- src/Text/Heterocephalus.hs +138/−132
- src/Text/Heterocephalus/Parse.hs +142/−53
heterocephalus.cabal view
@@ -1,5 +1,5 @@ name: heterocephalus-version: 1.0.2.0+version: 1.0.2.3 synopsis: A type-safe template engine for working with popular front end development tools description: Recent front end development tools and languages are growing fast and have
src/Text/Heterocephalus.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-}@@ -50,7 +51,7 @@ #if MIN_VERSION_base(4,9,0) #else import Control.Applicative ((<$>), (<*>), Applicative(..))-import Data.Monoid (mempty)+import Data.Monoid (Monoid, mempty, mappend) #endif import Control.Monad (forM) import Data.Char (isDigit)@@ -63,19 +64,26 @@ import qualified Data.Text.Lazy as TL import Language.Haskell.TH.Lib (ExpQ, varE) import Language.Haskell.TH.Quote+ (QuasiQuoter(QuasiQuoter), quoteExp, quoteDec, quotePat, quoteType) #if MIN_VERSION_template_haskell(2,9,0)-import Language.Haskell.TH.Syntax hiding (Module)+import Language.Haskell.TH.Syntax+ (Con(..), Dec(..), Exp(..), Info(..), Lit(..), Name(..), Pat(..),+ Q, Stmt(..), lookupValueName, mkName, nameBase, newName,+ qAddDependentFile, qRunIO, reify) #else import Language.Haskell.TH.Syntax #endif import Text.Blaze (preEscapedToMarkup) import Text.Blaze.Html (toHtml) import Text.Blaze.Internal (preEscapedText)-import Text.Hamlet+import Text.Hamlet (Html, HtmlUrl, HtmlUrlI18n, condH) import Text.Hamlet.Parse+ (Binding(..), DataConstr(..), Module(Module), specialOrIdent) import Text.Shakespeare.Base+ (Deref, Ident(..), Scope, derefToExp, readUtf8File) -import Text.Heterocephalus.Parse (Doc(..), Content(..), parseDoc)+import Text.Heterocephalus.Parse+ (Doc(..), Content(..), docFromString) {- $setup >>> :set -XTemplateHaskell -XQuasiQuotes@@ -98,73 +106,73 @@ Values declared by 'overwrite' overwrites same name variables. Values declared by 'setDefault' are overwritten by same name variables. - >>> :set -XOverloadedStrings- >>> :{- >>> putStr $ renderMarkup (- >>> let as = ["<a>", "b"]- >>> in $(compileTextFileWith "templates/sample.txt" $ do- >>> setDefault "as" [| ["foo", "bar"] |]- >>> )- >>> )- >>> :}- sample- key: <a>,- key: b,+>>> :set -XOverloadedStrings+>>> :{+putStr $ renderMarkup (+ let as = ["<a>", "b"]+ in $(compileTextFileWith "templates/sample.txt" $ do+ setDefault "as" [| ["foo", "bar"] |]+ )+)+:}+sample+key: <a>,+key: b, - >>> :{- >>> putStr $ renderMarkup (- >>> let as = ["<a>", "b"]- >>> in $(compileTextFileWith "templates/sample.txt" $ do- >>> overwrite "as" [| ["foo", "bar"] |]- >>> )- >>> )- >>> :}- sample- key: foo,- key: bar,+>>> :{+putStr $ renderMarkup (+ let as = ["<a>", "b"]+ in $(compileTextFileWith "templates/sample.txt" $ do+ overwrite "as" [| ["foo", "bar"] |]+ )+)+:}+sample+key: foo,+key: bar, - >>> :{- >>> putStr $ renderMarkup (- >>> let as = ["<a>", "b"]- >>> in $(compileTextFileWith "templates/sample.txt" $ do- >>> overwrite "as" [| ["bazbaz", "barbar"] |]- >>> setDefault "as" [| ["foo", "bar"] |]- >>> overwrite "as" [| ["baz", "foobar"] |]- >>> )- >>> )- >>> :}- sample- key: baz,- key: foobar,+>>> :{+putStr $ renderMarkup (+ let as = ["<a>", "b"]+ in $(compileTextFileWith "templates/sample.txt" $ do+ overwrite "as" [| ["bazbaz", "barbar"] |]+ setDefault "as" [| ["foo", "bar"] |]+ overwrite "as" [| ["baz", "foobar"] |]+ )+)+:}+sample+key: baz,+key: foobar, -} compileTextFileWith :: FilePath -> ScopeM () -> Q Exp compileTextFileWith fp scopeM = compileFileWith scopeM textSetting fp {-| Same as 'compileText' but allows the user to specify default values for template parameters. - >>> :set -XOverloadedStrings- >>> :{- >>> putStr $ renderMarkup (- >>> let as = ["<a>", "b"]- >>> in $(compileTextFileWithDefault "templates/sample.txt"- >>> [("as", [| ["foo", "bar"] |])]- >>> )- >>> )- >>> :}- sample- key: <a>,- key: b,+>>> :set -XOverloadedStrings+>>> :{+putStr $ renderMarkup (+ let as = ["<a>", "b"]+ in $(compileTextFileWithDefault "templates/sample.txt"+ [("as", [| ["foo", "bar"] |])]+ )+)+:}+sample+key: <a>,+key: b, - >>> :{- >>> putStr $ renderMarkup (- >>> $(compileTextFileWithDefault "templates/sample.txt"- >>> [("as", [| ["foo", "bar"] |])]- >>> )- >>> )- >>> :}- sample- key: foo,- key: bar,+>>> :{+putStr $ renderMarkup (+ $(compileTextFileWithDefault "templates/sample.txt"+ [("as", [| ["foo", "bar"] |])]+ )+)+:}+sample+key: foo,+key: bar, -} compileTextFileWithDefault :: FilePath -> DefaultScope -> Q Exp compileTextFileWithDefault fp scope = compileFileWithDefault scope textSetting fp@@ -183,73 +191,73 @@ Values declared by 'overwrite' overwrites same name variables. Values declared by 'setDefault' are overwritten by same name variables. - >>> :set -XOverloadedStrings- >>> :{- >>> putStr $ renderMarkup (- >>> let as = ["<a>", "b"]- >>> in $(compileHtmlFileWith "templates/sample.txt" $ do- >>> setDefault "as" [| ["foo", "bar"] |]- >>> )- >>> )- >>> :}- sample- key: <a>,- key: b,+>>> :set -XOverloadedStrings+>>> :{+putStr $ renderMarkup (+ let as = ["<a>", "b"]+ in $(compileHtmlFileWith "templates/sample.txt" $ do+ setDefault "as" [| ["foo", "bar"] |]+ )+)+:}+sample+key: <a>,+key: b, - >>> :{- >>> putStr $ renderMarkup (- >>> let as = ["<a>", "b"]- >>> in $(compileHtmlFileWith "templates/sample.txt" $ do- >>> overwrite "as" [| ["foo", "bar"] |]- >>> )- >>> )- >>> :}- sample- key: foo,- key: bar,+>>> :{+putStr $ renderMarkup (+ let as = ["<a>", "b"]+ in $(compileHtmlFileWith "templates/sample.txt" $ do+ overwrite "as" [| ["foo", "bar"] |]+ )+)+:}+sample+key: foo,+key: bar, - >>> :{- >>> putStr $ renderMarkup (- >>> let as = ["<a>", "b"]- >>> in $(compileHtmlFileWith "templates/sample.txt" $ do- >>> overwrite "as" [| ["bazbaz", "barbar"] |]- >>> setDefault "as" [| ["foo", "bar"] |]- >>> overwrite "as" [| ["baz", "foobar"] |]- >>> )- >>> )- >>> :}- sample- key: baz,- key: foobar,+>>> :{+putStr $ renderMarkup (+ let as = ["<a>", "b"]+ in $(compileHtmlFileWith "templates/sample.txt" $ do+ overwrite "as" [| ["bazbaz", "barbar"] |]+ setDefault "as" [| ["foo", "bar"] |]+ overwrite "as" [| ["baz", "foobar"] |]+ )+)+:}+sample+key: baz,+key: foobar, -} compileHtmlFileWith :: FilePath -> ScopeM () -> Q Exp compileHtmlFileWith fp scopeM = compileFileWith scopeM htmlSetting fp {-| Same as 'compileHtmlFile' but allows the user to specify default values for template parameters. - >>> :set -XOverloadedStrings- >>> :{- >>> putStr $ renderMarkup (- >>> let as = ["<a>", "b"]- >>> in $(compileHtmlFileWithDefault "templates/sample.txt"- >>> [("as", [| ["foo", "bar"] |])]- >>> )- >>> )- >>> :}- sample- key: <a>,- key: b,+>>> :set -XOverloadedStrings+:{+putStr $ renderMarkup (+ let as = ["<a>", "b"]+ in $(compileHtmlFileWithDefault "templates/sample.txt"+ [("as", [| ["foo", "bar"] |])]+ )+)+:}+sample+key: <a>,+key: b, - >>> :{- >>> putStr $ renderMarkup (- >>> $(compileHtmlFileWithDefault "templates/sample.txt"- >>> [("as", [| ["foo", "bar"] |])]- >>> )- >>> )- >>> :}- sample- key: foo,- key: bar,+>>> :{+putStr $ renderMarkup (+ $(compileHtmlFileWithDefault "templates/sample.txt"+ [("as", [| ["foo", "bar"] |])]+ )+)+:}+sample+key: foo,+key: bar, -} compileHtmlFileWithDefault :: FilePath -> DefaultScope -> Q Exp compileHtmlFileWithDefault fp scope = compileFileWithDefault scope htmlSetting fp@@ -350,12 +358,6 @@ Just x -> varE x Nothing -> qexp -docFromString :: String -> [Doc]-docFromString s =- case parseDoc s of- Error s' -> error s'- Ok d -> d- data HeterocephalusSetting = HeterocephalusSetting { escapeExp :: Q Exp }@@ -380,8 +382,8 @@ type OverwriteDList = DList (Ident, Q Exp) {- | A type to handle extra scopes.- - This is opaque type, so use 'setDefault' and 'overwrite'- - to construct new 'ScopeM'.+ This is opaque type, so use 'setDefault' and 'overwrite'+ to construct new 'ScopeM'. -} data ScopeM a = SetDefault Ident ExpQ (ScopeM a)@@ -400,6 +402,10 @@ runScopeM (PureScopeM _) = (mempty, mempty) +instance Monoid (ScopeM ()) where+ mempty = pure ()+ mappend a b = a >> b+ instance Functor ScopeM where fmap f (SetDefault ident qexp next) = SetDefault ident qexp $ fmap f next@@ -426,15 +432,15 @@ PureScopeM a >>= f = f a {-| Constructor for 'ScopeM'.- - Values declared by this function are overwritten- - by same name variables exits in scope of render function.+ Values declared by this function are overwritten+ by same name variables exits in scope of render function. -} setDefault :: Ident -> Q Exp -> ScopeM () setDefault ident qexp = SetDefault ident qexp $ pure () {-| Constructor for 'ScopeM'.- - Values declared by this function overwrites- - same name variables exits in scope of render function.+ Values declared by this function overwrites+ same name variables exits in scope of render function. -} overwrite :: Ident -> Q Exp -> ScopeM () overwrite ident qexp = Overwrite ident qexp $ pure ()
src/Text/Heterocephalus/Parse.hs view
@@ -10,12 +10,16 @@ #else import Control.Applicative ((<$>)) #endif-import Control.Monad+import Control.Monad (guard, void) import Data.Char (isUpper)-import Data.Data-import Text.Parsec.Prim (Parsec)-import Text.ParserCombinators.Parsec hiding (Line)+import Data.Data (Data)+import Data.Typeable (Typeable)+import Text.Parsec+ (Parsec, (<?>), (<|>), alphaNum, between, char, choice, eof, many,+ many1, manyTill, noneOf, oneOf, option, optional, parse, sepBy,+ skipMany, spaces, string, try) import Text.Shakespeare.Base+ (Ident(Ident), Deref, parseDeref, parseHash) import Text.Hamlet.Parse @@ -37,7 +41,7 @@ | ContentVar Deref deriving (Show, Eq, Read, Data, Typeable) -type UserParser a = Parsec String a+type UserParser = Parsec String () docFromString :: String -> [Doc] docFromString s =@@ -62,54 +66,76 @@ controlsToDocs (NoControl c:cs) = DocContent c : controlsToDocs cs controlsToDocs cs = error $ "Parse error: " ++ show cs --- TODO parse elseif-parseConds :: Int -> [Control] -> ([Control], Maybe [Control], [Control])+-- | Parse conditional 'Control' statements (@if@, @else@, @endif@) into a+-- three-tuple.+--+-- TODO: parse elseif+parseConds+ :: Int+ -- ^ Current recursive depth of parsing conditional statements.+ -> [Control]+ -- ^ Input 'Control' statements. This should be every statement AFTER the+ -- initial 'ControlIf' statement.+ -> ([Control], Maybe [Control], [Control])+ -- ^ Tuple with three different sets of 'Control' statements. The first+ -- @['Control']@ is all of the statements under the @if@ block. The second+ -- @'Maybe' ['Control']@ is all the control statements under the @else@+ -- block. The third @['Control']@ is the rest of the 'Control' statements+ -- after this conditional block. parseConds _ [] = error "No endif found"-parseConds depth (x:xs')+parseConds depth (x:xs) | depth < 0 = error "A `endif` keyword without any corresponding `if` was found."- | depth == 0 && isEndIf x = ([], Nothing, xs')+ | depth == 0 && isEndIf x = ([], Nothing, xs) | depth == 0 && isElse x =- let (ys, may, zs) = parseConds depth xs'+ let (ys, may, zs) = parseConds depth xs in case may of Nothing -> ([], Just ys, zs) Just _ -> error "A `if` clause can not have more than one `else` keyword." | isEndIf x =- let (ys, may, zs) = parseConds (depth - 1) xs'+ let (ys, may, zs) = parseConds (depth - 1) xs in (x : ys, may, zs) | isIf x =- let (ys, may, zs) = parseConds (depth + 1) xs'+ let (ys, may, zs) = parseConds (depth + 1) xs in (x : ys, may, zs) | otherwise =- let (ys, may, zs) = parseConds depth xs'+ let (ys, may, zs) = parseConds depth xs in (x : ys, may, zs) where+ isIf :: Control -> Bool isIf (ControlIf _) = True isIf _ = False++ isEndIf :: Control -> Bool isEndIf ControlEndIf = True isEndIf _ = False++ isElse :: Control -> Bool isElse ControlElse = True isElse _ = False parseReps :: Int -> [Control] -> ([Control], [Control]) parseReps _ [] = error "No endforall found"-parseReps depth (x:xs')+parseReps depth (x:xs) | depth < 0 = error "A `endforall` keyword without any corresponding `for` was found."- | depth == 0 && isEndForall x = ([], xs')+ | depth == 0 && isEndForall x = ([], xs) | isEndForall x =- let (ys, zs) = parseReps (depth - 1) xs'+ let (ys, zs) = parseReps (depth - 1) xs in (x : ys, zs) | isForall x =- let (ys, zs) = parseReps (depth + 1) xs'+ let (ys, zs) = parseReps (depth + 1) xs in (x : ys, zs) | otherwise =- let (ys, zs) = parseReps depth xs'+ let (ys, zs) = parseReps depth xs in (x : ys, zs) where+ isEndForall :: Control -> Bool isEndForall ControlEndForall = True isEndForall _ = False++ isForall :: Control -> Bool isForall (ControlForall _ _) = True isForall _ = False @@ -119,34 +145,40 @@ Left e -> Error $ show e Right x -> Ok x -lineControl :: UserParser () [Control]+lineControl :: UserParser [Control] lineControl = manyTill control $ try eof >> return () -control :: UserParser () Control+control :: UserParser Control control = controlHash <|> controlPercent <|> controlReg where+ controlPercent :: UserParser Control controlPercent = do x <- parsePercent case x of Left str -> return (NoControl $ ContentRaw str) Right ctrl -> return ctrl++ controlHash :: UserParser Control controlHash = do x <- parseHash return . NoControl $ case x of Left str -> ContentRaw str Right deref -> ContentVar deref++ controlReg :: UserParser Control controlReg = (NoControl . ContentRaw) <$> many (noneOf "#%") -parsePercent :: UserParser () (Either String Control)+parsePercent :: UserParser (Either String Control) parsePercent = do a <- parseControl '%' optional eol return a where- eol = (char '\n' >> return ()) <|> (string "\r\n" >> return ())+ eol :: UserParser ()+ eol = void (char '\n') <|> void (string "\r\n") -parseControl :: Char -> UserParser () (Either String Control)+parseControl :: Char -> UserParser (Either String Control) parseControl c = do _ <- char c (char '\\' >> return (Left [c])) <|>@@ -160,30 +192,41 @@ return (Left [c]) -parseControl' :: UserParser () Control+parseControl' :: UserParser Control parseControl' = try parseForall <|> try parseEndForall <|> try parseIf <|> try parseElse <|> try parseEndIf where+ parseForall :: UserParser Control parseForall = do _ <- try $ string "forall" spaces (x, y) <- binding return $ ControlForall x y++ parseEndForall :: UserParser Control parseEndForall = do _ <- try $ string "endforall" return $ ControlEndForall++ parseIf :: UserParser Control parseIf = do _ <- try $ string "if" spaces x <- parseDeref return $ ControlIf x++ parseElse :: UserParser Control parseElse = do _ <- try $ string "else" return $ ControlElse++ parseEndIf :: UserParser Control parseEndIf = do _ <- try $ string "endif" return $ ControlEndIf++ binding :: UserParser (Deref, Binding) binding = do y <- identPattern spaces@@ -192,76 +235,118 @@ x <- parseDeref _ <- spaceTabs return (x, y)- spaceTabs :: Parser String++ spaceTabs :: UserParser String spaceTabs = many $ oneOf " \t"- ident :: Parser Ident- ident =- do i <- many1 (alphaNum <|> char '_' <|> char '\'')- white- return (Ident i) <?> "identifier"++ ident :: UserParser Ident+ ident = do+ i <- many1 (alphaNum <|> char '_' <|> char '\'')+ white+ return (Ident i) <?> "identifier"++ parens :: UserParser a -> UserParser a parens = between (char '(' >> white) (char ')' >> white)++ brackets :: UserParser a -> UserParser a brackets = between (char '[' >> white) (char ']' >> white)++ braces :: UserParser a -> UserParser a braces = between (char '{' >> white) (char '}' >> white)++ comma :: UserParser () comma = char ',' >> white++ atsign :: UserParser () atsign = char '@' >> white++ equals :: UserParser () equals = char '=' >> white++ white :: UserParser () white = skipMany $ char ' '++ wildDots :: UserParser () wildDots = string ".." >> white++ isVariable :: Ident -> Bool isVariable (Ident (x:_)) = not (isUpper x) isVariable (Ident []) = error "isVariable: bad identifier"++ isConstructor :: Ident -> Bool isConstructor (Ident (x:_)) = isUpper x isConstructor (Ident []) = error "isConstructor: bad identifier"- identPattern :: Parser Binding++ identPattern :: UserParser Binding identPattern = gcon True <|> apat where+ apat :: UserParser Binding apat = choice [varpat, gcon False, parens tuplepat, brackets listpat]- varpat =- do v <-- try $ do- v <- ident- guard (isVariable v)- return v- option (BindVar v) $ do- atsign- b <- apat- return (BindAs v b) <?> "variable"- gcon :: Bool -> Parser Binding- gcon allowArgs =- do c <-- try $ do- c <- dataConstr- return c- choice- [ record c- , fmap (BindConstr c) (guard allowArgs >> many apat)- , return (BindConstr c [])- ] <?> "constructor"++ varpat :: UserParser Binding+ varpat = do+ v <-+ try $ do+ v <- ident+ guard (isVariable v)+ return v+ option (BindVar v) $ do+ atsign+ b <- apat+ return (BindAs v b) <?> "variable"++ gcon :: Bool -> UserParser Binding+ gcon allowArgs = do+ c <-+ try $ do+ c <- dataConstr+ return c+ choice+ [ record c+ , fmap (BindConstr c) (guard allowArgs >> many apat)+ , return (BindConstr c [])+ ] <?>+ "constructor"++ dataConstr :: UserParser DataConstr dataConstr = do p <- dcPiece ps <- many dcPieces return $ toDataConstr p ps++ dcPiece :: UserParser String dcPiece = do x@(Ident y) <- ident guard $ isConstructor x return y++ dcPieces :: UserParser String dcPieces = do _ <- char '.' dcPiece++ toDataConstr :: String -> [String] -> DataConstr toDataConstr x [] = DCUnqualified $ Ident x toDataConstr x (y:ys) = go (x :) y ys where+ go :: ([String] -> [String]) -> String -> [String] -> DataConstr go front next [] = DCQualified (Module $ front []) (Ident next) go front next (rest:rests) = go (front . (next :)) rest rests++ record :: DataConstr -> UserParser Binding record c = braces $ do- (fields, wild) <- option ([], False) $ go+ (fields, wild) <- option ([], False) go return (BindRecord c fields wild) where+ go :: UserParser ([(Ident, Binding)], Bool) go = (wildDots >> return ([], True)) <|> (do x <- recordField (xs, wild) <- option ([], False) (comma >> go) return (x : xs, wild))++ recordField :: UserParser (Ident, Binding) recordField = do field <- ident p <-@@ -269,10 +354,14 @@ (BindVar field) -- support punning (equals >> identPattern) return (field, p)++ tuplepat :: UserParser Binding tuplepat = do xs <- identPattern `sepBy` comma return $ case xs of [x] -> x _ -> BindTuple xs++ listpat :: UserParser Binding listpat = BindList <$> identPattern `sepBy` comma