template-hsml 0.1.0.0 → 0.2.0.1
raw patch · 10 files changed
+810/−397 lines, 10 filesdep +QuickCheckdep +template-hsmldep +test-framework
Dependencies added: QuickCheck, template-hsml, test-framework, test-framework-quickcheck2
Files
- src/Template/HSML.hs +150/−7
- src/Template/HSML/Internal/Parser.hs +72/−33
- src/Template/HSML/Internal/Parser/Raw.hs +0/−213
- src/Template/HSML/Internal/Parser/Syntax.hs +207/−0
- src/Template/HSML/Internal/TH.hs +185/−64
- src/Template/HSML/Internal/Types.hs +79/−70
- src/Template/HSML/Internal/Types/Syntax.hs +30/−0
- template-hsml.cabal +44/−10
- tests/Main.hs +15/−0
- tests/Parser/Syntax.hs +28/−0
src/Template/HSML.hs view
@@ -1,14 +1,157 @@+-- | `HSML` is simple templating system with syntax similar to XML that+-- lets you embed Haskell expressions and declarations inside your+-- templates. Apart from that, it also lets you specify argumets for your+-- templates, thanks to that, templates can be mostly self-contained.+--+-- This is the syntax, with some of the details left out:+--+-- > syntax = { argument }, { chunk } ;+-- > chunk = text | text_raw | element_node | element_leaf | haskell ;+-- > argument = "{a|" ? argument name ?, [ "::" ? type ? ] "|}" ;+-- >+-- > text = ? all characters except \'<\' and \'{\' which have to be escaped ? ;+-- > text_raw = "{r|" ? all characters, the sequence can not contain \"|}\" substring ? "|}" ;+-- > element_node = "<" element_name { attribute } ">" { chunk } "</" element_name ">" ;+-- > element_leaf = "<" element_name { attribute } "/>" ;+-- > haskell = "{h|" expression | declaration "|}" ;+-- >+-- > attribute = attribute_name "=" attribute_value ;+-- > attribute_name = ? classic attribute name ? | "{h|" expression "|}" ;+-- > attribute_value = ? classic attribute value ? | "{h| expression "|}" ;+-- >+-- > expression = ? Haskell expression not containing \"|}\" as a substring ? ;+-- > declaration = ? Haskell declaration not containing \"|}\" as a substring ? ;+--+-- Example (Main.hs):+--+-- > {-# LANGUAGE TemplateHaskell #-}+-- > {-# LANGUAGE QuasiQuotes #-}+-- > {-# LANGUAGE RecordWildCards #-}+-- > +-- > ------------------------------------------------------------------------------+-- > import Data.Monoid ((<>))+-- > ------------------------------------------------------------------------------+-- > import Control.Monad+-- > ------------------------------------------------------------------------------+-- > import qualified Text.Blaze.Html5 as B+-- > ------------------------------------------------------------------------------+-- > import Template.HSML+-- > ------------------------------------------------------------------------------+-- > +-- > data User = User+-- > { userID :: Int+-- > , userName :: String+-- > , userAge :: Int+-- > }+-- > +-- > $(hsmlFileWith (defaultOptions "Default") "default_layout.hsml")+-- > +-- > homeTemplate :: [User] -> B.Markup+-- > homeTemplate users = renderTemplate Default+-- > { defaultTitle = "Home page"+-- > , defaultSectionMiddle = middle+-- > , defaultSectionFooter = [m| <p>Generated by HSML</p> |]+-- > }+-- > where+-- > middle = [m|+-- > <ul class="users">+-- > {h| forM_ users wrap |}+-- > </ul> |]+-- > wrap u = [m|<li> {h| userTemplate u |} </li>|]+-- > +-- > userTemplate :: User -> B.Markup+-- > userTemplate User{..} = [m|+-- > <ul class={h| "user-" <> show userID |}>+-- > <li>Name: {h|userName|}</li>+-- > <li>Age: {h|userAge|}</li>+-- > </ul> |]+--+-- Example (default_layout.hsml):+--+-- > {a| title :: String |}+-- > {a| sectionMiddle :: B.Markup |}+-- > {a| sectionFooter :: B.Markup |}+-- > +-- > {h| B.docType |}+-- > +-- > <html lang="en">+-- > <head>+-- > <meta charset="utf-8"/>+-- > <title>{h|title|}</title>+-- > </head>+-- > +-- > <body>+-- > <div class="section middle">+-- > {h|sectionMiddle|}+-- > </div>+-- > +-- > <footer>+-- > {h|sectionFooter|}+-- > </footer>+-- > </body>+-- > </html>+--+-- Result of @renderMarkup . homeTemplate [User 1 "Jon Doe" 16, User+-- 2 "Jane Roe" 17]@:+--+-- > <!DOCTYPE HTML>+-- > <html lang="en">+-- > <head>+-- > <meta charset="utf-8">+-- > <title>Home page</title>+-- > </head>+-- > +-- > <body>+-- > <div class="section middle">+-- > <ul class="users">+-- > <li>+-- > <ul class="user-1">+-- > <li>Name: Jon Doe</li>+-- > <li>Age: 16</li>+-- > </ul>+-- > </li>+-- > <li>+-- > <ul class="user-2">+-- > <li>Name: Jane Roe</li>+-- > <li>Age: 17</li>+-- > </ul>+-- > </li>+-- > </ul>+-- > </div>+-- > +-- > <footer>+-- > <p>Generated by HSML</p>+-- > </footer>+-- > </body>+-- > </html> module Template.HSML-( module Export+(+ -- * Quasi Quoters+ hsml+, m++ -- * HSML+, hsmlStringWith+, hsmlString+, hsmlFileWith+, hsmlFile++ -- * Simplified HSML+, shsmlStringWith+, shsmlString+, shsmlFileWith+, shsmlFile++ -- * Types+, IsTemplate(..)+, Options(..)+, defaultOptions+, defaultOptionsS ) where -------------------------------------------------------------------------------import Template.HSML.Internal.TH as Export-import Template.HSML.Internal.Types as Export ( HSMLTemplate(..)- , Options(..)- , defaultHSML- , defaultSHSML- )+import Template.HSML.Internal.TH +import Template.HSML.Internal.Types ------------------------------------------------------------------------------
src/Template/HSML/Internal/Parser.hs view
@@ -1,27 +1,34 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} module Template.HSML.Internal.Parser+#ifdef TESTING+where+#else ( hsmlParser , shsmlParser , hsmlTemplate , shsmlTemplate ) where+#endif ------------------------------------------------------------------------------ import qualified Language.Haskell.Exts.Parser as HE--- import qualified Language.Haskell.Exts.Extension as HE--- import qualified Language.Haskell.Exts.Syntax as HE+import qualified Language.Haskell.Exts.Extension as HE ------------------------------------------------------------------------------ import Control.Applicative+import Control.Monad+import Control.Arrow ------------------------------------------------------------------------------ import Data.Monoid ((<>)) ------------------------------------------------------------------------------ import qualified Text.Parsec.String as P import qualified Text.Parsec.Prim as P -------------------------------------------------------------------------------import qualified Template.HSML.Internal.Types as I-import qualified Template.HSML.Internal.Parser.Raw as I+import qualified Template.HSML.Internal.Types as I+import qualified Template.HSML.Internal.Types.Syntax as IS+import qualified Template.HSML.Internal.Parser.Syntax as IS ------------------------------------------------------------------------------ hsmlTemplate :: String -> Either String I.Template@@ -31,7 +38,7 @@ Left err -> Left $ show err hsmlParser :: P.Parser I.Template-hsmlParser = I.hsmlParser >>= transform+hsmlParser = IS.hsmlSyntax >>= transform shsmlTemplate :: String -> Either String I.Template shsmlTemplate str =@@ -40,15 +47,14 @@ Left err -> Left $ show err shsmlParser :: P.Parser I.Template-shsmlParser = I.shsmlParser >>= transform+shsmlParser = IS.shsmlSyntax >>= transform ------------------------------------------------------------------------------ -transform :: I.RTemplate -> P.Parser I.Template-transform I.Template{..} = do- args <- mapM transformArg templateArgs- decs <- mapM transformDec templateDecs- sections <- mapM transformSection templateSections+transform :: IS.Syntax -> P.Parser I.Template+transform IS.Syntax{..} = do+ args <- mapM transformArg syntaxArgs+ (decs, sections) <- transformChunks syntaxChunks return I.Template { I.templateArgs = args , I.templateDecs = decs@@ -59,34 +65,41 @@ transformArg (I.RArg name mtype) = case mtype of Just stype ->- case HE.parseType stype of- HE.ParseOk t -> return . I.Arg name $ Just t- HE.ParseFailed _ r -> fail $ "Could not parse type \"" <> stype <> "\", reason: " <> r+ case parseType stype of+ Right t -> return . I.Arg name $ Just t+ Left r -> fail $ "Could not parse type \"" <> stype <> "\", reason: " <> r Nothing -> return $ I.Arg name Nothing -transformDec :: I.RDec -> P.Parser I.Dec-transformDec (I.RDec sdec) = - case HE.parseDecl sdec of- HE.ParseOk d -> return $ I.Dec d- HE.ParseFailed _ r -> fail $ "Could not parse declaration \"" <> sdec <> "\", reason: " <> r- transformExp :: I.RExp -> P.Parser I.Exp-transformExp (I.RExp sexp) =- case HE.parseExp sexp of- HE.ParseOk e -> return $ I.Exp e - HE.ParseFailed _ r -> fail $ "Could not parse expression \"" <> sexp <> "\", reason: " <> r+transformExp sexp =+ case parseExp sexp of+ Right e -> return e + Left r -> fail $ "Could not parse expression \"" <> sexp <> "\", reason: " <> r -transformSection :: I.RSection -> P.Parser I.Section-transformSection (I.ElementNode name rattributes rsections) = do+transformChunks :: [IS.Chunk] -> P.Parser ([I.Dec], [I.Section])+transformChunks chunks = (reverse *** reverse) <$> foldM transformChunk ([], []) chunks++transformChunk :: ([I.Dec], [I.Section]) -> IS.Chunk -> P.Parser ([I.Dec], [I.Section])+transformChunk (ds, ss) (IS.ElementNode name rattributes chunks) = do attributes <- mapM transformAttribute rattributes- sections <- mapM transformSection rsections- return $ I.ElementNode name attributes sections-transformSection (I.ElementLeaf name rattributes) = do+ (decs, sections) <- transformChunks chunks+ return (ds, I.ElementNode name attributes sections decs : ss)+transformChunk (ds, ss) (IS.ElementLeaf name rattributes) = do attributes <- mapM transformAttribute rattributes- return $ I.ElementLeaf name attributes-transformSection (I.Text text) = return $ I.Text text-transformSection (I.TextRaw text) = return $ I.TextRaw text-transformSection (I.Expression rexp) = I.Expression <$> transformExp rexp+ return (ds, I.ElementLeaf name attributes : ss)+transformChunk (ds, ss) (IS.Text text) = return (ds, I.Text text : ss)+transformChunk (ds, ss) (IS.TextRaw text) = return (ds, I.TextRaw text : ss)+transformChunk (ds, ss) (IS.Haskell rhs) = + case parseExp rhs of+ Right e -> return (ds, I.Expression e : ss)+ Left er -> + case parseDec rhs of+ Right d -> return (d : ds, ss)+ Left dr -> fail $ concat + [ "Could not parse haskell \"", rhs+ , "\", as expression, because: ", er+ , "; as declaration, because: ", dr+ ] transformAttribute :: I.RAttribute -> P.Parser I.Attribute transformAttribute (I.Attribute rname rvalue) =@@ -97,4 +110,30 @@ transformValue (I.AttributeValueExp rexp) = I.AttributeValueExp <$> transformExp rexp transformValue (I.AttributeValueText text) = return $ I.AttributeValueText text++parseType :: String -> Either String I.Type+parseType = toEither . HE.parseTypeWithMode parseMode+{-# INLINE parseType #-}++parseExp :: String -> Either String I.Exp+parseExp = toEither . HE.parseExpWithMode parseMode+{-# INLINE parseExp #-}++parseDec :: String -> Either String I.Dec+parseDec = toEither . HE.parseDeclWithMode parseMode+{-# INLINE parseDec #-}++toEither :: HE.ParseResult a -> Either String a+toEither pr =+ case pr of+ HE.ParseOk x -> Right x+ HE.ParseFailed _ e -> Left e+{-# INLINE toEither #-} ++parseMode :: HE.ParseMode+parseMode = HE.defaultParseMode+ { HE.extensions = HE.TemplateHaskell : HE.QuasiQuotes : HE.haskell2010+ }+{-# INLINE parseMode #-}+
− src/Template/HSML/Internal/Parser/Raw.hs
@@ -1,213 +0,0 @@-module Template.HSML.Internal.Parser.Raw-( hsmlParser-, shsmlParser-) where---------------------------------------------------------------------------------import Control.Applicative-import Control.Monad--------------------------------------------------------------------------------import Data.Char--------------------------------------------------------------------------------import qualified Text.Parsec.String as P-import qualified Text.Parsec.Combinator as P-import qualified Text.Parsec.Char as P-import qualified Text.Parsec.Prim as P--------------------------------------------------------------------------------import qualified Template.HSML.Internal.Types as I----------------------------------------------------------------------------------- | .HSML parser.-hsmlParser:: P.Parser I.RTemplate-hsmlParser = do- spaces - args <- P.try $ sepEndBy argument spaces- chus <- P.try $ sepEndBy1 chunk spaces- P.eof- return . templateFromSyntax $ Syntax args chus---- | Simple .HSML parser (argument are not allowed).-shsmlParser :: P.Parser I.RTemplate-shsmlParser = do- spaces- chus <- P.try $ sepEndBy1 chunk spaces - P.eof- return . templateFromSyntax $ Syntax [] chus------------------------------------------------------------------------------------templateFromSyntax :: Syntax -> I.RTemplate-templateFromSyntax (Syntax args chunks) =- I.Template args decs secs- where- (decs, secs) = foldr go ([], []) chunks- go (Dec d) (ds, ss) = (d : ds, ss)- go (Sec s) (ds, ss) = (ds, s : ss) ------------------------------------------------------------------------------------chunk :: P.Parser Chunk-chunk = Dec <$> declaration <|>- Sec <$> section------------------------------------------------------------------------------------- | Declaration---- | Raw declaration conforms to the following:--- "{a|" <spaces> <funIdent> [ <spaces> "::" <spaces> <typeIdent> ] <spaces> "|}"-argument :: P.Parser I.RArg-argument = do- P.string "{a|" >> spaces- aname <- funIdent- atype <- maybeParser $ P.spaces >> P.string "::" >> spaces >> typeIdent - spaces >> P.string "|}" >> spaces- return $ I.RArg aname atype------------------------------------------------------------------------------------- | Declaration---- | Raw declaration conforms to the following:--- "{d|" <string without "|}" substring> "|}"-declaration :: P.Parser I.RDec-declaration = I.RDec <$> wrappedText 'd' P.anyChar ------------------------------------------------------------------------------------- | Section--section :: P.Parser I.RSection-section = P.try ( elementNode <|>- elementLeaf <|>- expression <|>- textRaw <|>- text - )------------------------------------------------------------------------------------- | Elements--elementNode :: P.Parser I.RSection-elementNode = P.try $ do- (name, attributes) <- tagOpening <* P.string ">"- body <- many section - tagClosing name - return $ I.ElementNode name attributes body--elementLeaf :: P.Parser I.RSection-elementLeaf = P.try $ do- (name, attributes) <- tagOpening <* P.string "/>"- return $ I.ElementLeaf name attributes--attribute :: P.Parser I.RAttribute-attribute = do- n <- attributeName- spaces >> P.char '=' >> spaces- v <- attributeValue- return $ I.Attribute n v--attributeName :: P.Parser I.RAttributeName-attributeName = P.try $- P.try (I.AttributeNameText <$> attributeIdent) <|>- (I.AttributeNameExp . I.RExp <$> expressionText) --attributeValue :: P.Parser I.RAttributeValue-attributeValue = P.try $- P.try (P.char '\"' *> (I.AttributeValueText <$> attributeIdent) <* P.char '\"') <|>- (I.AttributeValueExp . I.RExp <$> expressionText)--attributeIdent :: P.Parser String-attributeIdent = P.many1 $ P.satisfy ((||) <$> isAlphaNum <*> (`elem` " -_"))------------------------------------------------------------------------------------- | Text --text :: P.Parser I.RSection-text = P.try $ I.Text <$> P.many1 (textChar '\\' (`elem` "<{"))--textRaw :: P.Parser I.RSection-textRaw = I.TextRaw <$> wrappedText 'r' (textChar '\\' (`elem` "<{")) --textChar :: Char -> (Char -> Bool) -> P.Parser Char-textChar esc needEsc = escapedChar <|> P.satisfy (\c -> not (needEsc c || c == esc))- where - escapedChar = P.try $ P.char esc >> P.anyChar ------------------------------------------------------------------------------------- | Expression---- | Raw expression conforms to the following:--- "{e|" <string without "|}" substring> "|}"-expression :: P.Parser I.RSection-expression = I.Expression . I.RExp <$> expressionText------------------------------------------------------------------------------------tagOpening :: P.Parser (String, [I.RAttribute]) -tagOpening = P.try $ do- P.char '<' >> spaces- name <- tagIdentifier- spaces- attributes <- sepEndBy attribute spaces- return (name, attributes)--tagClosing :: String -> P.Parser ()-tagClosing tagName = P.try . void $ do- P.string "</"- spaces- P.string tagName- spaces- P.char '>'--tagIdentifier :: P.Parser String-tagIdentifier = P.try $ P.many1 P.alphaNum------------------------------------------------------------------------------------expressionText :: P.Parser String-expressionText = wrappedText 'e' P.anyChar--wrappedText :: Char -> P.Parser Char -> P.Parser String-wrappedText m p = P.try $- P.string ['{', m, '|'] *> many1Until p (P.string "|}") <* P.string "|}"--funIdent :: P.Parser String-funIdent = (:) <$> P.lower <*> P.many P.alphaNum--typeIdent :: P.Parser String-typeIdent = (:) <$> P.upper <*> P.many (P.satisfy (/= ' '))------------------------------------------------------------------------------------data Syntax = Syntax [I.RArg] [Chunk]--data Chunk = Dec I.RDec- | Sec I.RSection------------------------------------------------------------------------------------- CONVENIENCE FUNCTIONS--maybeParser :: P.Parser a -> P.Parser (Maybe a)-maybeParser p = (Just <$> P.try p) <|> return Nothing--spaces :: P.Parser ()-spaces = void $ P.many P.space---- spaces1 :: P.Parser ()--- spaces1 = void $ P.many1 P.space--sepEndBy1 :: P.Parser a -> P.Parser b -> P.Parser [a]-sepEndBy1 p sep = P.try $ do- x <- p- P.try ((x:) <$> (sep >> sepEndBy p sep)) <|> return [x]--sepEndBy :: P.Parser a -> P.Parser b -> P.Parser [a]-sepEndBy p sep = P.try (sepEndBy1 p sep) <|> return []--manyUntil :: P.Parser a -> P.Parser b -> P.Parser [a]-manyUntil p stop = P.try $ P.manyTill p (P.lookAhead $ void (P.try stop) <|> void P.eof)--many1Until :: P.Parser a -> P.Parser b -> P.Parser [a]-many1Until p stop = P.try $ do- x <- p- xs <- manyUntil p stop- return $ x : xs-
+ src/Template/HSML/Internal/Parser/Syntax.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE CPP #-}++module Template.HSML.Internal.Parser.Syntax+#ifdef TESTING+where+#else+( hsmlSyntax+, shsmlSyntax+) where+#endif++------------------------------------------------------------------------------+import Control.Applicative+import Control.Monad+------------------------------------------------------------------------------+import Data.Char+------------------------------------------------------------------------------+import qualified Text.Parsec.String as P+import qualified Text.Parsec.Combinator as P+import qualified Text.Parsec.Char as P+import qualified Text.Parsec.Prim as P+------------------------------------------------------------------------------+import qualified Template.HSML.Internal.Types.Syntax as I+------------------------------------------------------------------------------++------------------------------------------------------------------------------+-- | Syntax++shsmlSyntax :: P.Parser I.Syntax+shsmlSyntax = do+ spaces+ chus <- P.try $ sepEndBy1 chunk spaces+ P.eof+ return $ I.Syntax [] chus++hsmlSyntax :: P.Parser I.Syntax+hsmlSyntax = do+ spaces+ args <- P.try $ sepEndBy argument spaces+ spaces+ chus <- P.try $ sepEndBy1 chunk spaces+ P.eof+ return $ I.Syntax args chus++--------------------------------------------------------------------------------+-- | Chunk+chunk :: P.Parser I.Chunk+chunk = P.try ( P.try elementNode <|>+ P.try elementLeaf <|>+ P.try haskell <|>+ P.try textRaw <|>+ text + )++--------------------------------------------------------------------------------+-- | Argument+argument :: P.Parser I.RArg+argument = P.try $ do+ P.string "{a|" >> spaces+ aname <- argName+ atype <- maybeParser $ P.spaces >> P.string "::" >> spaces >> typeName + spaces >> P.string "|}" >> spaces+ return $ I.RArg aname atype++argName :: P.Parser String+argName = (:) <$> P.lower <*> P.many P.alphaNum++typeName :: P.Parser String+typeName = (:) <$> P.upper <*> P.many (P.satisfy (/= ' '))++--------------------------------------------------------------------------------+-- | Element Node+elementNode :: P.Parser I.Chunk+elementNode = P.try $ do+ (name, attributes) <- tagOpening <* P.string ">"+ body <- many chunk + tagClosing name + return $ I.ElementNode name attributes body++--------------------------------------------------------------------------------+-- | Element Leaf+elementLeaf :: P.Parser I.Chunk+elementLeaf = P.try $ do+ (name, attributes) <- tagOpening <* P.string "/>"+ return $ I.ElementLeaf name attributes++tagOpening :: P.Parser (String, [I.RAttribute]) +tagOpening = P.try $ do+ P.char '<' >> spaces+ name <- tagName+ spaces+ attributes <- sepEndBy attribute spaces+ return (name, attributes)++tagClosing :: String -> P.Parser ()+tagClosing name = P.try . void $ + P.string "</" *> spaces *> P.string name <* spaces <* P.string ">"++tagName :: P.Parser String+tagName = P.try $ P.many1 P.alphaNum++--------------------------------------------------------------------------------+-- | Attribute+attribute :: P.Parser I.RAttribute+attribute = do+ n <- attributeName+ spaces >> P.char '=' >> spaces+ v <- attributeValue+ return $ I.Attribute n v++attributeValue :: P.Parser I.RAttributeValue+attributeValue = P.try $+ P.try attributeValueText <|>+ attributeValueExp++attributeValueText :: P.Parser I.RAttributeValue+attributeValueText =+ P.char '\"'+ *> (I.AttributeValueText <$> P.many1 valueChar) <*+ P.char '\"'+ where+ valueChar = P.satisfy (\c -> isAlphaNum c || c `elem` " -_")++attributeValueExp :: P.Parser I.RAttributeValue+attributeValueExp = I.AttributeValueExp <$> haskellBody++attributeName :: P.Parser I.RAttributeName+attributeName = P.try $+ P.try attributeNameText <|>+ attributeNameExp ++attributeNameText :: P.Parser I.RAttributeName+attributeNameText = I.AttributeNameText <$> P.many1 nameChar + where+ nameChar = P.satisfy (\c -> isAlphaNum c || c `elem` "-_")++attributeNameExp :: P.Parser I.RAttributeName+attributeNameExp = I.AttributeNameExp <$> haskellBody++--------------------------------------------------------------------------------+-- | Text +text :: P.Parser I.Chunk+text = P.try $ I.Text <$> P.many1 myChar+ where+ myChar = escapedChar <|> P.satisfy (\c -> c `notElem` "<{" && c /= '\\')+ {-# INLINE myChar #-}++--------------------------------------------------------------------------------+-- | Text Raw+textRaw :: P.Parser I.Chunk+textRaw = P.try $+ P.string "{r|"+ *> (I.TextRaw <$> manyUntil myChar (P.string "|}")) <*+ P.string "|}"+ where+ myChar = escapedChar <|> P.anyChar+ {-# INLINE myChar #-}++--------------------------------------------------------------------------------+-- | Haskell+haskell :: P.Parser I.Chunk+haskell = I.Haskell <$> haskellBody++haskellBody :: P.Parser String+haskellBody = P.try (P.string "{h|" *> manyUntil myChar (P.string "|}") <* P.string "|}")+ where+ myChar = P.anyChar+ {-# INLINE myChar #-}++--------------------------------------------------------------------------------+-- CONVENIENCE FUNCTIONS++escapedChar :: P.Parser Char+escapedChar = P.try $ P.char '\\' >> P.anyChar +{-# INLINE escapedChar #-} ++maybeParser :: P.Parser a -> P.Parser (Maybe a)+maybeParser p = (Just <$> P.try p) <|> return Nothing++spaces :: P.Parser ()+spaces = void $ P.many P.space++-- spaces1 :: P.Parser ()+-- spaces1 = void $ P.many1 P.space++sepEndBy1 :: P.Parser a -> P.Parser b -> P.Parser [a]+sepEndBy1 p sep = P.try $ do+ x <- p+ P.try ((x:) <$> (sep >> sepEndBy p sep)) <|> return [x]++sepEndBy :: P.Parser a -> P.Parser b -> P.Parser [a]+sepEndBy p sep = P.try (sepEndBy1 p sep) <|> return []++manyUntil :: P.Parser a -> P.Parser b -> P.Parser [a]+manyUntil p stop = P.try $ P.manyTill p (P.lookAhead $ void (P.try stop) <|> void P.eof)++{-+many1Until :: P.Parser a -> P.Parser b -> P.Parser [a]+many1Until p stop = P.try $ do+ x <- p+ xs <- manyUntil p stop+ return $ x : xs++peekChar :: P.Parser (Maybe Char)+peekChar = P.try (Just <$> P.lookAhead P.anyChar) <|> return Nothing+-}+
src/Template/HSML/Internal/TH.hs view
@@ -1,114 +1,206 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} module Template.HSML.Internal.TH-( hsmlWith-, hsml+#ifdef TESTING+where+#else+( -- * Quasi Quoters for Simplified HSML+ hsml , m , hsmlStringWith+, hsmlString , hsmlFileWith+, hsmlFile , shsmlStringWith , shsmlString , shsmlFileWith , shsmlFile ) where+#endif -------------------------------------------------------------------------------- import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH import qualified Language.Haskell.TH.Syntax as TH--- import qualified Language.Haskell.Exts.Syntax as HE import qualified Language.Haskell.Meta.Syntax.Translate as HE -------------------------------------------------------------------------------- import qualified Text.Blaze as B import qualified Text.Blaze.Internal as B ----------------------------------------------------------------------------------- import Control.Applicative+import Control.Applicative+import Control.Arrow import Control.Monad ----------------------------------------------------------------------------------- import Data.Char import Data.String import Data.Monoid--- import qualified Data.Generics as G -------------------------------------------------------------------------------- import qualified Template.HSML.Internal.Types as I import qualified Template.HSML.Internal.Parser as I -------------------------------------------------------------------------------- -hsmlWith :: I.Options -> TH.QuasiQuoter-hsmlWith opts = TH.QuasiQuoter- { TH.quoteExp = shsmlStringWith opts - , TH.quoteDec = hsmlStringWith opts- , TH.quotePat = const $ fail "You can not use the .HSML QuasiQuoter as a pattern."- , TH.quoteType = const $ fail "You can not use the .HSML QuasiQuoter as a type."- }-{-# INLINE hsmlWith #-}-+-- | QuasiQuoter for Simplified HSML expressions with default options. See+-- `Template.HSML.Internal.Types.defaulOptionsS` for details. +--+-- Example:+--+-- > example :: Blaze.Text.Markup+-- > example = [hsml|+-- > <h1>Page Title</h1>+-- > <p>+-- > Some interesting paragraph.+-- > </p>+-- > |] hsml :: TH.QuasiQuoter hsml = TH.QuasiQuoter { TH.quoteExp = shsmlString - , TH.quoteDec = const $ fail "You can not use the .HSML QuasiQuoter as a declaration."- , TH.quotePat = const $ fail "You can not use the .HSML QuasiQuoter as a pattern."- , TH.quoteType = const $ fail "You can not use the .HSML QuasiQuoter as a type."+ , TH.quoteDec = const $ fail "You can not use the HSML QuasiQuoter as a declaration."+ , TH.quotePat = const $ fail "You can not use the HSML QuasiQuoter as a pattern."+ , TH.quoteType = const $ fail "You can not use the HSML QuasiQuoter as a type." } {-# INLINE hsml #-} +-- | The same as `Templahe.HSML.Internal.TH.hsml`.+--+-- Example:+--+-- > example :: Blaze.Text.Markup+-- > example = [m|+-- > <h1>Page Title</h1>+-- > <p>+-- > Some interesting paragraph.+-- > </p>+-- > |] m :: TH.QuasiQuoter m = hsml {-# INLINE m #-} ----------------------------------------------------------------------------------- | .HSML+-- HSML -hsmlFileWith :: I.Options -> FilePath -> TH.Q [TH.Dec]+-- These functions parse the given file or string as a HSML document.+-- If possible, splicing these generates a record field type and its instance of+-- `Template.HSML.Internal.Types.IsTemplate`.++-- | Parses HSML document from file with the given options. Results in+-- record type and its `Template.HSML.Internal.Types.IsTemplate` instance.+--+-- Example:+--+-- > $(hsmlFileWith (defaultOptions "MyTemplate") "my_template.hsml")+hsmlFileWith :: I.Options -- ^ HSML options.+ -> FilePath -- ^ Name of input file.+ -> TH.Q [TH.Dec] -- ^ Resulting type declaration and type-class instance. hsmlFileWith opts path = TH.runIO (readFile path) >>= hsmlStringWith opts {-# INLINE hsmlFileWith #-} -hsmlFile :: String -> FilePath -> TH.Q [TH.Dec]-hsmlFile = hsmlFileWith . I.defaultHSML+-- | Parses HSML document from file with default options. Results in+-- record type and its `Template.HSML.Internal.Types.IsTemplate` instance.+--+-- Example:+--+-- > $(hsmlFile "MyTemplate" "my_template.hsml")+hsmlFile :: String -- ^ Name of the record type (passed to `Template.HSML.Internal.Types.defaultOptions`).+ -> FilePath -- ^ Name of input file.+ -> TH.Q [TH.Dec] -- ^ Resulting type declaration and type-class instance.+hsmlFile = hsmlFileWith . I.defaultOptions {-# INLINE hsmlFile #-} -hsmlStringWith :: I.Options -> String -> TH.Q [TH.Dec]+-- | Parses HSML document string with the given options. Results in+-- record type and its `Template.HSML.Internal.Types.IsTemplate` instance.+--+-- Example:+--+-- > $(hsmlStringWith (defaultOptions "MyTemplate") "<p>Paragraph</p>")+hsmlStringWith :: I.Options -- ^ HSML options.+ -> String -- ^ Input string.+ -> TH.Q [TH.Dec] -- ^ Resulting type declaration and type-class instance. hsmlStringWith opts str = case I.hsmlTemplate str of Right tpl -> makeDec opts tpl Left err -> fail err {-# INLINE hsmlStringWith #-} -hsmlString :: String -> String -> TH.Q [TH.Dec]-hsmlString = hsmlStringWith . I.defaultHSML+-- | Parses HSML document from string with default options. Results in+-- record type and its `Template.HSML.Internal.Types.IsTemplate` instance.+--+-- Example:+--+-- > $(hsmlString "MyTemplate" "<p>Paragraph</p>")+hsmlString :: String -- ^ Name of the record type (passed to `Template.HSML.Internal.Types.defaultOptions`). + -> String -- ^ Input string.+ -> TH.Q [TH.Dec] -- ^ Resulting type declaration and type-class instance.+hsmlString = hsmlStringWith . I.defaultOptions {-# INLINE hsmlString #-} ----------------------------------------------------------------------------------- | Simple .HSML (without arguments)+-- Simplified HSML (without arguments) -shsmlFileWith :: I.Options -> FilePath -> TH.ExpQ+-- These functions parse the given file or string as a Simplified HSML document.+-- If possible, splicing these results in an expression of the type+-- `Text.Blaze.Markup`.++-- | Parses Simplified HSML document from file with the given options. Results in+-- expression of type `Text.Blaze.Markup`.+--+-- Example:+--+-- > example :: Text.Blaze.Markup+-- > example = $(shsmlFileWith defaultOptionsS "my_template.hsml")+shsmlFileWith :: I.Options -- ^ HSML Options.+ -> FilePath -- ^ Name of input file.+ -> TH.ExpQ -- ^ Resulting expression. shsmlFileWith opts path = TH.runIO (readFile path) >>= shsmlStringWith opts {-# INLINE shsmlFileWith #-} -shsmlFile :: FilePath -> TH.ExpQ-shsmlFile = shsmlFileWith I.defaultSHSML+-- | Parses Simplified HSML document from file with default options. Results in+-- expression of type `Text.Blaze.Markup`.+--+-- Example:+--+-- > example :: Text.Blaze.Markup+-- > example = $(shsmlFile "my_template.hsml")+shsmlFile :: FilePath -- ^ Name of input file.+ -> TH.ExpQ -- ^ Resulting expression.+shsmlFile = shsmlFileWith I.defaultOptionsS {-# INLINE shsmlFile #-} -shsmlStringWith :: I.Options -> String -> TH.ExpQ+-- | Parses Simplified HSML document from string with the given options. Results in+-- expression of type `Text.Blaze.Markup`.+--+-- Example:+--+-- > example :: Text.Blaze.Markup+-- > example = $(shsmlStringWith defaultOptionsS "<p>Paragraph</p>")+shsmlStringWith :: I.Options -- ^ HSML options+ -> String -- ^ Input string.+ -> TH.ExpQ -- ^ Resulting expression. shsmlStringWith opts str = case I.shsmlTemplate str of Right I.Template{..} -> makeExp opts templateDecs templateSections Left err -> fail err {-# INLINE shsmlStringWith #-} -shsmlString :: String -> TH.ExpQ-shsmlString = shsmlStringWith I.defaultSHSML+-- | Parses Simplified HSML document from string with default options. Results in+-- expression of type `Text.Blaze.Markup`.+--+-- Example:+--+-- > example :: Text.Blaze.Markup+-- > example = $(shsmlString "<p>Paragraph</p>")+shsmlString :: String -- ^ Input string.+ -> TH.ExpQ -- ^ Resulting expression.+shsmlString = shsmlStringWith I.defaultOptionsS {-# INLINE shsmlString #-} -------------------------------------------------------------------------------- --- | This function take options @ template and generates the record type and--- instance of .HSMLTemplate for that record type.+-- | Generates a record type and its instance of `IsTemplate`. makeDec :: I.Options -> I.Template -> TH.Q [TH.Dec]-makeDec opts@(I.Options _ tname fname) (I.Template args decs sections) = do+makeDec opts@(I.Options _ _ tname fname) (I.Template args decs sections) = do (vars, fields) <- makeVarsAndFields tdata <- makeData vars fields tinst <- makeInstance vars@@ -119,7 +211,7 @@ -- | This function generates the type variable names and fields. makeVarsAndFields :: TH.Q ([TH.Name], [TH.VarStrictType])- makeVarsAndFields = foldM go ([], []) args+ makeVarsAndFields = (reverse *** reverse) <$> foldM go ([], []) args where go (vs, fs) (I.Arg an (Just at)) = return (vs, (HE.toName $ fname an, TH.NotStrict, HE.toType at) : fs)@@ -127,24 +219,23 @@ v <- TH.newName "a" return (v : vs, (HE.toName $ fname an, TH.NotStrict, TH.VarT v) : fs) - -- | This function generates the instance in .HSMLTemplate.+ -- | This function generates the instance of IsTemplate. makeInstance :: [TH.Name] -> TH.DecQ makeInstance vars =- -- instance .HSMLTemplate (<dataName> <vars>) where- -- renderTemplate <tpl>@(<dataName>{ <binds> }) = + -- instance .IsTemplate (<dataName> <vars>) where+ -- renderTemplate (<dataName>{ <binds> }) = -- <expression generated by makeExp> TH.instanceD (return [])- (TH.conT ''I.HSMLTemplate `TH.appT` contyp)+ (TH.conT ''I.IsTemplate `TH.appT` contyp) [TH.funD 'I.renderTemplate [clause]] where -- This is the data type applied to all the type variables. contyp = foldl (\acc n -> acc `TH.appT` TH.varT n) (TH.conT dataName) vars -- This is the clause for renderTemplate. - clause = do - arg <- TH.newName "tpl"- TH.clause [TH.asP arg $ TH.recP dataName binds]+ clause = + TH.clause [TH.recP dataName binds] (TH.normalB $ makeExp opts decs sections) [] -- This is the { <fieldName1> = <argName1>, ... } pattern. binds = map (\(I.Arg n _) -> return (HE.toName $ fname n, TH.VarP $ HE.toName n)) args@@ -155,18 +246,13 @@ -- data <dataName> <vars> = <dataName> { <fields> } TH.DataD [] dataName (map TH.PlainTV vars) [TH.RecC dataName fields] [] +-- | Generates an expression of the type `Text.Blaze.Markup` makeExp :: I.Options -> [I.Dec] -> [I.Section] -> TH.ExpQ makeExp opts decs sections =- TH.letE (declarationsToDecs decs)- (sectionsToExp opts sections)+ TH.letE (map (return . HE.toDec) decs) $ sectionsToExp opts sections -------------------------------------------------------------------------------- -declarationsToDecs :: [I.Dec] -> [TH.DecQ]-declarationsToDecs = map declarationToDec- where declarationToDec (I.Dec dec) = return $ HE.toDec dec-- sectionsToExp :: I.Options -> [I.Section] -> TH.ExpQ sectionsToExp opts sections = [e| mconcat $(TH.listE $ map (sectionToExp opts) sections) :: B.Markup |]@@ -174,36 +260,71 @@ sectionToExp :: I.Options -> I.Section -> TH.ExpQ sectionToExp opts@I.Options{..} section = case section of- (I.ElementNode name atts sections) ->- [e| applyAttributes $(TH.listE $ map attributeToExp atts) $+ (I.ElementNode name atts sections decs) ->+ [e| applyAttributes $(TH.listE $ map (attributeToExp opts) atts) $ B.Parent (fromString name) (fromString $ "<" <> name) (fromString $ "</" <> name <> ">")- $(sectionsToExp opts sections) |]+ $(makeExp opts decs sections) |] (I.ElementLeaf name atts) -> - [e| applyAttributes $(TH.listE $ map attributeToExp atts) $+ [e| applyAttributes $(TH.listE $ map (attributeToExp opts) atts) $ B.Leaf (fromString name) (fromString $ "<" <> name) (fromString ">") |] (I.Text str) -> [e| B.string str |] (I.TextRaw str) -> [e| B.preEscapedString str |]- (I.Expression (I.Exp e)) ->- if optSectionsToMarkup- then [e| B.toMarkup $(return $ HE.toExp e) |]- else return $ HE.toExp e+ (I.Expression e) ->+ if optExpToMarkup+ then [e| B.toMarkup $(toExp e) |]+ else toExp e applyAttributes :: [B.Attribute] -> B.MarkupM a -> B.MarkupM a applyAttributes attributes markup = foldl (B.!) markup attributes -attributeToExp :: I.Attribute -> TH.ExpQ-attributeToExp (I.Attribute aname avalue) =+attributeToExp :: I.Options -> I.Attribute -> TH.ExpQ+attributeToExp I.Options{..} (I.Attribute aname avalue) = [e| B.attribute (fromString $(attributeNameToExp aname)) (fromString (" " <> $(attributeNameToExp aname) <> "=\""))- (fromString $(attributeValueToExp avalue)) |]+ $(attributeValueToExp avalue) |] where- attributeNameToExp (I.AttributeNameExp (I.Exp e)) = return $ HE.toExp e attributeNameToExp (I.AttributeNameText str) = [e| str |]+ attributeNameToExp (I.AttributeNameExp e) = toExp e - attributeValueToExp (I.AttributeValueExp (I.Exp e)) = return $ HE.toExp e- attributeValueToExp (I.AttributeValueText str) = [e| str |] + attributeValueToExp (I.AttributeValueText str) = [e| B.toValue str |] + attributeValueToExp (I.AttributeValueExp e) =+ if optExpToValue+ then [e| B.toValue $(toExp e) |]+ else toExp e ++toExp :: HE.ToExp a => a -> TH.ExpQ+toExp = return . HE.toExp++{-+toExp :: HE.Exp -> TH.ExpQ+toExp (HE.Var n) = return $ TH.VarE (HE.toName n)+toExp (HE.Con n) = return $ TH.ConE (HE.toName n)+toExp (HE.Lit l) = return $ TH.LitE (HE.toLit l)+toExp (HE.InfixApp e o f) = TH.uInfixE (toExp e) (return $ HE.toExp o) (toExp f)+toExp (HE.LeftSection e o) = TH.infixE (Just $ toExp e) (return $ HE.toExp o) Nothing+toExp (HE.RightSection o f) = TH.infixE Nothing (return $ HE.toExp o) (Just $ toExp f)+toExp (HE.App e f) = TH.appE (toExp e) (toExp f)+toExp (HE.NegApp e) = TH.appE (TH.varE 'negate) (toExp e)+toExp (HE.Lambda _ ps e) = TH.lamE (fmap (return . HE.toPat) ps) (toExp e)+toExp (HE.Let bs e) = TH.letE (map return $ HE.hsBindsToDecs bs) (toExp e)+toExp (HE.If a b c) = TH.condE (toExp a) (toExp b) (toExp c)+toExp (HE.Do ss) = TH.doE (map (return . HE.toStmt) ss)+toExp (HE.Tuple xs) = TH.tupE (fmap toExp xs)+toExp (HE.List xs) = TH.listE (fmap toExp xs)+toExp (HE.Paren e) = TH.parensE (toExp e)+toExp (HE.RecConstr n xs) = TH.recConE (HE.toName n) (map (return . HE.toFieldExp) xs)+toExp (HE.RecUpdate e xs) = TH.recUpdE (toExp e) (map (return . HE.toFieldExp) xs)+toExp (HE.EnumFrom e) = TH.arithSeqE $ TH.fromR (toExp e)+toExp (HE.EnumFromTo e f) = TH.arithSeqE $ TH.fromToR (toExp e) (toExp f)+toExp (HE.EnumFromThen e f) = TH.arithSeqE $ TH.fromThenR (toExp e) (toExp f)+toExp (HE.EnumFromThenTo e f g) = TH.arithSeqE $ TH.fromThenToR (toExp e) (toExp f) (toExp g)+toExp (HE.ExpTypeSig _ e t) = TH.sigE (toExp e) (return $ HE.toType t)+toExp (HE.Case e alts) = TH.caseE (toExp e) (map (return . HE.toMatch) alts)+toExp (HE.QuasiQuote n string) = TH.parensE ([e|TH.quoteExp|] `TH.appE` TH.varE (HE.toName n)) `TH.appE` TH.litE (TH.stringL string)+toExp _ = error "Failed toExp"+-}
src/Template/HSML/Internal/Types.hs view
@@ -2,36 +2,33 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Template.HSML.Internal.Types-( HSMLTemplate(..)+( IsTemplate(..) , Options(..)-, defaultHSML-, defaultSHSML+, defaultOptions+, defaultOptionsS -, PTemplate(..)-, PSection(..)+, Template(..)+, Section(..) , PAttribute(..) , PAttributeName(..) , PAttributeValue(..) -, Template-, Section , Attribute , AttributeName , AttributeValue -, RTemplate-, RSection , RAttribute , RAttributeName , RAttributeValue , Arg(..)-, Dec(..)-, Exp(..)+, Dec+, Exp+, Type , RArg(..)-, RDec(..)-, RExp(..)+, RDec+, RExp ) where --------------------------------------------------------------------------------@@ -43,12 +40,29 @@ import qualified Text.Blaze as B (Markup) -------------------------------------------------------------------------------- -class HSMLTemplate a where- renderTemplate :: a -> B.Markup+-- | Template type-class.+class IsTemplate a where+ renderTemplate :: a -> B.Markup -- ^ Renders the template. -defaultHSML :: String -> Options-defaultHSML name = Options- { optSectionsToMarkup = True++-- | Default settings for HSML generators.+--+-- > defaultOptions name = Options+-- > { optExpToMarkup = True+-- > , optExpToValue = True+-- > , optTemplateName = firstUpper name+-- > , optTemplateFieldName = \a -> firstLower name <> firstUpper a+-- > }+-- > where+-- > firstUpper "" = ""+-- > firstUpper (c:cs) = toUpper c : cs+-- > +-- > firstLower "" = ""+-- > firstLower (c:cs) = toLower c : cs+defaultOptions :: String -> Options+defaultOptions name = Options+ { optExpToMarkup = True+ , optExpToValue = True , optTemplateName = firstUpper name , optTemplateFieldName = \a -> firstLower name <> firstUpper a }@@ -59,40 +73,51 @@ firstLower "" = "" firstLower (c:cs) = toLower c : cs -defaultSHSML :: Options-defaultSHSML = Options- { optSectionsToMarkup = True +-- | Default settings for Simplified HSML generators.+--+-- > defaultOptionsS = Options+-- > { optExpToMarkup = True +-- > , optExpToValue = True+-- > , optTemplateName = undefined+-- > , optTemplateFieldName = undefined +-- > }+defaultOptionsS :: Options+defaultOptionsS = Options+ { optExpToMarkup = True + , optExpToValue = True , optTemplateName = undefined , optTemplateFieldName = undefined } --- | This type let's you customize some behaviour of the templating system.+-- | This type lets you customize some behaviour of HSML templates. data Options = Options {- -- ^ If (and only if) set to True, applies `Blaze.Text.toMarkup` to- -- section expression- optSectionsToMarkup :: Bool+ -- | If and only if set to True, applies `Text.Blaze.toMarkup` on+ -- section expressions in your HSML templates.+ optExpToMarkup :: Bool - -- ^ The name of the generated record.- -- NOTE: Has no effect on s.HSML templates.+ -- | If and only if set to True, applies `Text.Blaze.toValue` on+ -- attribute value expressions in your HSML templates.+ , optExpToValue :: Bool++ -- | The name of the generated record.+ --+ -- NOTE: Has no effect on Simplified HSML templates. , optTemplateName :: String - -- ^ The name of the fields of the genrated record.- -- NOTE: Has no effect on sHTML templates.+ -- | The name of the fields of the genrated record.+ --+ -- NOTE: Has no effect on Simplified HTML templates. , optTemplateFieldName :: String -> String } -------------------------------------------------------------------------------- -- | Handy synonyms -type Template = PTemplate Arg Dec Exp-type Section = PSection Exp type Attribute = PAttribute Exp type AttributeName = PAttributeName Exp type AttributeValue = PAttributeValue Exp -type RTemplate = PTemplate RArg RDec RExp-type RSection = PSection RExp type RAttribute = PAttribute RExp type RAttributeName = PAttributeName RExp type RAttributeValue = PAttributeValue RExp@@ -100,39 +125,22 @@ -------------------------------------------------------------------------------- -- | The Template. This includes arguments, declarations and sections -data PTemplate arg dec exp = Template- { templateArgs :: [arg]- , templateDecs :: [dec]- , templateSections :: [PSection exp]+data Template = Template+ { templateArgs :: [Arg]+ , templateDecs :: [Dec]+ , templateSections :: [Section] } -instance Show e => Show (PTemplate a d e) where- show tpl = unlines . map show $ templateSections tpl--data PSection exp = ElementNode String [PAttribute exp] [PSection exp]- | ElementLeaf String [PAttribute exp]- | Text String- | TextRaw String- | Expression exp--instance Show e => Show (PSection e) where- show (ElementNode name _ sections) = concat [ "<" <> name <> ">\n"- , unlines (map show sections)- , "</" <> name <> ">\n"- ]- show (ElementLeaf name _) = "<" <> name <> "/>"- show (Text str) = hsmlEscape str- show (TextRaw str) = str- show (Expression e) = show e--hsmlEscape :: String -> String-hsmlEscape "" = ""-hsmlEscape (c:rest) =- if shouldEscape c- then '\\' : c : hsmlEscape rest- else c : hsmlEscape rest- where- shouldEscape = (`elem` "<{") +data Section = ElementNode+ { nodeName :: String+ , noteAttributes :: [Attribute]+ , nodeBody :: [Section]+ , nodeDecs :: [Dec]+ }+ | ElementLeaf String [Attribute]+ | Text String+ | TextRaw String+ | Expression Exp data PAttribute exp = Attribute (PAttributeName exp) (PAttributeValue exp) @@ -142,11 +150,12 @@ data PAttributeValue exp = AttributeValueText String | AttributeValueExp exp -data Arg = Arg String (Maybe HE.Type)-newtype Dec = Dec HE.Decl-newtype Exp = Exp HE.Exp+data Arg = Arg String (Maybe Type)+type Dec = HE.Decl+type Exp = HE.Exp+type Type = HE.Type -data RArg = RArg String (Maybe String) deriving Show-newtype RDec = RDec String deriving Show-newtype RExp = RExp String deriving Show+data RArg = RArg String (Maybe String)+type RDec = String+type RExp = String
+ src/Template/HSML/Internal/Types/Syntax.hs view
@@ -0,0 +1,30 @@+module Template.HSML.Internal.Types.Syntax+( Syntax(..)+, Chunk(..)++, I.RArg(..)+, I.RExp+, I.RDec+, I.PAttribute(..)+, I.RAttribute+, I.PAttributeName(..)+, I.RAttributeName+, I.PAttributeValue(..)+, I.RAttributeValue+) where++------------------------------------------------------------------------------+import qualified Template.HSML.Internal.Types as I+------------------------------------------------------------------------------++data Syntax = Syntax+ { syntaxArgs :: [I.RArg]+ , syntaxChunks :: [Chunk]+ }++data Chunk = ElementNode String [I.RAttribute] [Chunk]+ | ElementLeaf String [I.RAttribute]+ | Text String+ | TextRaw String+ | Haskell String+
template-hsml.cabal view
@@ -1,11 +1,11 @@ name: template-hsml-version: 0.1.0.0+version: 0.2.0.1 synopsis: Haskell's Simple Markup Language description: HSML syntax is very similar to that of XML, but there are less rules.- The main advantage over plain HTML is that it allows you to embed Haskell declarations+ The main advantage over plain XML or HTML is that it allows you to embed Haskell declarations and expression directly into your template. - The main dvantage over something like Blaze is thatit saves+ The main advantage over something like Blaze is that it saves you the overhead of using Blaze's combinators. It's also relatively easy to port your existing plain HTML templates into HSML (most of the times, cut & paste will suffice). @@ -20,17 +20,22 @@ cabal-version: >=1.8 stability: Experimental +flag testing+ description: Are we building for testing?+ default: False + library hs-source-dirs: src- + exposed-modules:- Template.HSML - + Template.HSML + other-modules: - Template.HSML.Internal.TH- , Template.HSML.Internal.Types- , Template.HSML.Internal.Parser- , Template.HSML.Internal.Parser.Raw+ Template.HSML.Internal.TH+ , Template.HSML.Internal.Types+ , Template.HSML.Internal.Types.Syntax+ , Template.HSML.Internal.Parser+ , Template.HSML.Internal.Parser.Syntax build-depends: base == 4.5.*@@ -40,3 +45,32 @@ , haskell-src-meta == 0.5.* , parsec == 3.1.* , template-haskell == 2.7.*++ extensions: CPP++ ghc-options: -O2 -Wall+ + if flag(testing) + cpp-options: -DTESTING+++test-suite template-hsml-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Main.hs+ + other-modules:+ Parser.Syntax+ ++ build-depends:+ base == 4.5.*+ , template-hsml+ , parsec == 3.1.*+ , QuickCheck == 2.4.*+ , test-framework == 0.6.*+ , test-framework-quickcheck2 == 0.2.*++ ghc-options: -Wall+ cpp-options: -DTESTING+
+ tests/Main.hs view
@@ -0,0 +1,15 @@+module Main+( main+) where+ +------------------------------------------------------------------------------+import Test.Framework (defaultMain, testGroup)+------------------------------------------------------------------------------+import qualified Parser.Syntax +------------------------------------------------------------------------------++main :: IO ()+main = defaultMain+ [ testGroup "Parser.Syntax" Parser.Syntax.tests+ ]+
+ tests/Parser/Syntax.hs view
@@ -0,0 +1,28 @@+module Parser.Syntax+( tests+) where++------------------------------------------------------------------------------+-- import Data.Maybe+------------------------------------------------------------------------------+-- import qualified Text.Parsec.String as P+-- import qualified Text.Parsec as P+------------------------------------------------------------------------------+import Test.Framework+-- import Test.Framework.Providers.QuickCheck2+-- import Test.QuickCheck+------------------------------------------------------------------------------+-- import qualified Template.HSML.Internal.Types.Syntax as I+-- import qualified Template.HSML.Internal.Parser.Syntax as I+------------------------------------------------------------------------------++tests :: [Test]+tests = []++{-+parse :: P.Parser a -> String -> Maybe a+parse p str = case P.parse p "" str of+ Right x -> Just x+ _ -> Nothing+-}+