xml-hamlet 0.2.0 → 0.2.0.1
raw patch · 7 files changed
+596/−594 lines, 7 filessetup-changed
Files
- LICENSE +30/−30
- Setup.lhs +8/−8
- Text/Hamlet/Parse.hs +0/−282
- Text/Hamlet/XML.hs +97/−97
- Text/Hamlet/XMLParse.hs +282/−0
- test/main.hs +137/−135
- xml-hamlet.cabal +42/−42
LICENSE view
@@ -1,30 +1,30 @@-Copyright (c)2011, Michael Snoyman--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.-- * Neither the name of Michael Snoyman nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+Copyright (c)2011, Michael Snoyman + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Michael Snoyman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.lhs view
@@ -1,8 +1,8 @@-#!/usr/bin/env runhaskell--> module Main where-> import Distribution.Simple-> import System.Cmd (system)--> main :: IO ()-> main = defaultMain+#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple +> import System.Cmd (system) + +> main :: IO () +> main = defaultMain
− Text/Hamlet/Parse.hs
@@ -1,282 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE CPP #-}-module Text.Hamlet.Parse- ( Result (..)- , Content (..)- , Doc (..)- , parseDoc- )- where--import Text.Shakespeare.Base-import Control.Applicative ((<$>), Applicative (..))-import Control.Monad-import Data.Data-import Text.ParserCombinators.Parsec hiding (Line)--data Result v = Error String | Ok v- deriving (Show, Eq, Read, Data, Typeable)-instance Monad Result where- return = Ok- Error s >>= _ = Error s- Ok v >>= f = f v- fail = Error-instance Functor Result where- fmap = liftM-instance Applicative Result where- pure = return- (<*>) = ap--data Content = ContentRaw String- | ContentVar Deref- | ContentEmbed Deref- deriving (Show, Eq, Read, Data, Typeable)--data Line = LineForall Deref Ident- | LineIf Deref- | LineElseIf Deref- | LineElse- | LineWith [(Deref, Ident)]- | LineMaybe Deref Ident- | LineNothing- | LineTag- { _lineTagName :: String- , _lineAttr :: [(Maybe Deref, String, [Content])]- , _lineContent :: [Content]- }- | LineContent [Content]- deriving (Eq, Show, Read)--parseLines :: String -> Result [(Int, Line)]-parseLines s =- case parse (many parseLine) s s of- Left e -> Error $ show e- Right x -> Ok x--parseLine :: Parser (Int, Line)-parseLine = do- ss <- fmap sum $ many ((char ' ' >> return 1) <|>- (char '\t' >> return 4))- x <- comment <|>- htmlComment <|>- backslash <|>- controlIf <|>- controlElseIf <|>- (try (string "$else") >> spaceTabs >> eol >> return LineElse) <|>- controlMaybe <|>- (try (string "$nothing") >> spaceTabs >> eol >> return LineNothing) <|>- controlForall <|>- controlWith <|>- angle <|>- (eol' >> return (LineContent [])) <|>- (do- cs <- content InContent- isEof <- (eof >> return True) <|> return False- if null cs && ss == 0 && isEof- then fail "End of Hamlet template"- else return $ LineContent cs)- return (ss, x)- where- eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ())- eol = eof <|> eol'- spaceTabs = many $ oneOf " \t"- comment = do- _ <- try $ string "$#"- _ <- many $ noneOf "\r\n"- eol- return $ LineContent []- htmlComment = do- _ <- try $ string "<!--"- _ <- manyTill anyChar $ try $ string "-->"- x <- many nonComments- eol- return $ LineContent [ContentRaw $ concat x] -- FIXME handle variables?- nonComments = (many1 $ noneOf "\r\n<") <|> (do- _ <- char '<'- (do- _ <- try $ string "!--"- _ <- manyTill anyChar $ try $ string "-->"- return "") <|> return "<")- backslash = do- _ <- char '\\'- (eol >> return (LineContent [ContentRaw "\n"]))- <|> (LineContent <$> content InContent)- controlIf = do- _ <- try $ string "$if"- spaces- x <- parseDeref- _ <- spaceTabs- eol- return $ LineIf x- controlElseIf = do- _ <- try $ string "$elseif"- spaces- x <- parseDeref- _ <- spaceTabs- eol- return $ LineElseIf x- binding = do- y <- ident- spaces- _ <- string "<-"- spaces- x <- parseDeref- _ <- spaceTabs- return (x,y)- bindingSep = char ',' >> spaceTabs- controlMaybe = do- _ <- try $ string "$maybe"- spaces- (x,y) <- binding- eol- return $ LineMaybe x y- controlForall = do- _ <- try $ string "$forall"- spaces- (x,y) <- binding- eol- return $ LineForall x y- controlWith = do- _ <- try $ string "$with"- spaces- bindings <- (binding `sepBy` bindingSep) `endBy` eol- return $ LineWith $ concat bindings -- concat because endBy returns a [[(Deref,Ident)]]- content cr = do- x <- many $ content' cr- case cr of- InQuotes -> char '"' >> return ()- NotInQuotes -> return ()- NotInQuotesAttr -> return ()- InContent -> eol- return $ cc x- where- cc [] = []- cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c- cc (a:b) = a : cc b- content' cr = contentHash <|> contentCaret <|> contentReg cr- contentHash = do- x <- parseHash- case x of- Left str -> return $ ContentRaw str- Right deref -> return $ ContentVar deref- contentCaret = do- x <- parseCaret- case x of- Left str -> return $ ContentRaw str- Right deref -> return $ ContentEmbed deref- contentReg InContent = (ContentRaw . return) <$> noneOf "#@^\r\n"- contentReg NotInQuotes = (ContentRaw . return) <$> noneOf "@^#. \t\n\r>"- contentReg NotInQuotesAttr = (ContentRaw . return) <$> noneOf "@^ \t\n\r>"- contentReg InQuotes = (ContentRaw . return) <$> noneOf "#@^\\\"\n\r>"- tagAttribValue notInQuotes = do- cr <- (char '"' >> return InQuotes) <|> return notInQuotes- content cr- tagCond = do- _ <- char ':'- d <- parseDeref- _ <- char ':'- tagAttrib (Just d)- tagAttrib cond = do- s <- many1 $ noneOf " \t=\r\n>"- v <- (do- _ <- char '='- s' <- tagAttribValue NotInQuotesAttr- return s') <|> return []- return $ TagAttrib (cond, s, v)- tag' = foldr tag'' ("div", [])- tag'' (TagName s) (_, y) = (s, y)- tag'' (TagAttrib s) (x, y) = (x, s : y)- ident = Ident <$> many1 (alphaNum <|> char '_' <|> char '\'')- angle = do- _ <- char '<'- name' <- many $ noneOf " \t\r\n>"- let name = if null name' then "div" else name'- xs <- many $ try ((many $ oneOf " \t") >>- (tagCond <|> tagAttrib Nothing))- _ <- many $ oneOf " \t"- c <- (eol >> return []) <|> (do- _ <- char '>'- c <- content InContent- return c)- let (tn, attr) = tag' $ TagName name : xs- return $ LineTag tn attr c--data TagPiece = TagName String- | TagAttrib (Maybe Deref, String, [Content])- deriving Show--data ContentRule = InQuotes | NotInQuotes | NotInQuotesAttr | InContent--data Nest = Nest Line [Nest]--nestLines :: [(Int, Line)] -> [Nest]-nestLines [] = []-nestLines ((i, l):rest) =- let (deeper, rest') = span (\(i', _) -> i' > i) rest- in Nest l (nestLines deeper) : nestLines rest'--data Doc = DocForall Deref Ident [Doc]- | DocWith [(Deref,Ident)] [Doc]- | DocCond [(Deref, [Doc])] (Maybe [Doc])- | DocMaybe Deref Ident [Doc] (Maybe [Doc])- | DocTag String [(Maybe Deref, String, [Content])] [Doc]- | DocContent Content- -- FIXME PIs- deriving (Show, Eq, Read, Data, Typeable)--nestToDoc :: [Nest] -> Result [Doc]-nestToDoc [] = Ok []-nestToDoc (Nest (LineForall d i) inside:rest) = do- inside' <- nestToDoc inside- rest' <- nestToDoc rest- Ok $ DocForall d i inside' : rest'-nestToDoc (Nest (LineWith dis) inside:rest) = do- inside' <- nestToDoc inside- rest' <- nestToDoc rest- Ok $ DocWith dis inside' : rest'-nestToDoc (Nest (LineIf d) inside:rest) = do- inside' <- nestToDoc inside- (ifs, el, rest') <- parseConds ((:) (d, inside')) rest- rest'' <- nestToDoc rest'- Ok $ DocCond ifs el : rest''-nestToDoc (Nest (LineMaybe d i) inside:rest) = do- inside' <- nestToDoc inside- (nothing, rest') <-- case rest of- Nest LineNothing ninside:x -> do- ninside' <- nestToDoc ninside- return (Just ninside', x)- _ -> return (Nothing, rest)- rest'' <- nestToDoc rest'- Ok $ DocMaybe d i inside' nothing : rest''-nestToDoc (Nest (LineTag tn attrs content) inside:rest) = do- inside' <- nestToDoc inside- rest' <- nestToDoc rest- Ok $ (DocTag tn attrs $ map DocContent content ++ inside') : rest'-nestToDoc (Nest (LineContent content) inside:rest) = do- inside' <- nestToDoc inside- rest' <- nestToDoc rest- Ok $ map DocContent content ++ inside' ++ rest'-nestToDoc (Nest (LineElseIf _) _:_) = Error "Unexpected elseif"-nestToDoc (Nest LineElse _:_) = Error "Unexpected else"-nestToDoc (Nest LineNothing _:_) = Error "Unexpected nothing"--parseDoc :: String -> Result [Doc]-parseDoc s = do- ls <- parseLines s- let notEmpty (_, LineContent []) = False- notEmpty _ = True- let ns = nestLines $ filter notEmpty ls- ds <- nestToDoc ns- return ds--parseConds :: ([(Deref, [Doc])] -> [(Deref, [Doc])])- -> [Nest]- -> Result ([(Deref, [Doc])], Maybe [Doc], [Nest])-parseConds front (Nest LineElse inside:rest) = do- inside' <- nestToDoc inside- Ok $ (front [], Just inside', rest)-parseConds front (Nest (LineElseIf d) inside:rest) = do- inside' <- nestToDoc inside- parseConds (front . (:) (d, inside')) rest-parseConds front rest = Ok (front [], Nothing, rest)
Text/Hamlet/XML.hs view
@@ -1,97 +1,97 @@-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-}-module Text.Hamlet.XML- ( xml- , xmlFile- ) where--import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Quote-import qualified Data.Text.Lazy as TL-import Control.Monad ((<=<))-import Text.Hamlet.Parse-import Text.Shakespeare.Base (readUtf8File, derefToExp, Scope, Deref (DerefIdent), Ident (Ident))-import Data.Text (pack, unpack)-import qualified Data.Text as T-import qualified Text.XML as X-import Data.String (fromString)-import qualified Data.Foldable as F-import Data.Maybe (fromMaybe)--xml :: QuasiQuoter-xml = QuasiQuoter { quoteExp = strToExp }--xmlFile :: FilePath -> Q Exp-xmlFile = strToExp . TL.unpack <=< qRunIO . readUtf8File--strToExp :: String -> Q Exp-strToExp s =- case parseDoc s of- Error e -> error e- Ok x -> docsToExp [] x--docsToExp :: Scope -> [Doc] -> Q Exp-docsToExp scope docs = [| concat $(fmap ListE $ mapM (docToExp scope) docs) |]--docToExp :: Scope -> Doc -> Q Exp-docToExp scope (DocTag name attrs cs) =- [| [ X.NodeElement (X.Element ($(liftName name)) $(mkAttrs scope attrs) $(docsToExp scope cs))- ] |]-docToExp _ (DocContent (ContentRaw s)) = [| [ X.NodeContent (pack $(lift s)) ] |]-docToExp scope (DocContent (ContentVar d)) = [| [ X.NodeContent $(return $ derefToExp scope d) ] |]-docToExp scope (DocContent (ContentEmbed d)) = return $ derefToExp scope d-docToExp scope (DocForall deref ident@(Ident ident') inside) = do- let list' = derefToExp scope deref- name <- newName ident'- let scope' = (ident, VarE name) : scope- inside' <- docsToExp scope' inside- let lam = LamE [VarP name] inside'- [| F.concatMap $(return lam) $(return list') |]-docToExp scope (DocWith [] inside) = docsToExp scope inside-docToExp scope (DocWith ((deref, ident@(Ident name)):dis) inside) = do- let deref' = derefToExp scope deref- name' <- newName name- let scope' = (ident, VarE name') : scope- inside' <- docToExp scope' (DocWith dis inside)- let lam = LamE [VarP name'] inside'- return $ lam `AppE` deref'-docToExp scope (DocMaybe deref ident@(Ident name) just nothing) = do- let deref' = derefToExp scope deref- name' <- newName name- let scope' = (ident, VarE name') : scope- inside' <- docsToExp scope' just- let inside'' = LamE [VarP name'] inside'- nothing' <-- case nothing of- Nothing -> [| [] |]- Just n -> docsToExp scope n- [| maybe $(return nothing') $(return inside'') $(return deref') |]-docToExp scope (DocCond conds final) = do- unit <- [| () |]- body <- fmap GuardedB $ mapM go $ conds ++ [(DerefIdent $ Ident "otherwise", fromMaybe [] final)]- return $ CaseE unit [Match (TupP []) body []]- where- go (deref, inside) = do- inside' <- docsToExp scope inside- return (NormalG $ derefToExp scope deref, inside')--mkAttrs :: Scope -> [(Maybe Deref, String, [Content])] -> Q Exp-mkAttrs _ [] = [| [] |]-mkAttrs scope ((mderef, name, value):rest) = do- rest' <- mkAttrs scope rest- this <- [| ($(liftName name), T.concat $(fmap ListE $ mapM go value)) |]- let with = [| $(return this) : $(return rest') |]- case mderef of- Nothing -> with- Just deref -> [| if $(return $ derefToExp scope deref) then $(with) else $(return rest') |]- where- go (ContentRaw s) = [| pack $(lift s) |]- go (ContentVar d) = return $ derefToExp scope d- go ContentEmbed{} = error "Cannot use embed interpolation in attribute value"--liftName :: String -> Q Exp-liftName s = do- X.Name local mns _ <- return $ fromString s- case mns of- Nothing -> [| X.Name (pack $(lift $ unpack local)) Nothing Nothing |]- Just ns -> [| X.Name (pack $(lift $ unpack local)) (Just $ pack $(lift $ unpack ns)) Nothing |]+{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +module Text.Hamlet.XML + ( xml + , xmlFile + ) where + +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Quote +import qualified Data.Text.Lazy as TL +import Control.Monad ((<=<)) +import Text.Hamlet.XMLParse +import Text.Shakespeare.Base (readUtf8File, derefToExp, Scope, Deref (DerefIdent), Ident (Ident)) +import Data.Text (pack, unpack) +import qualified Data.Text as T +import qualified Text.XML as X +import Data.String (fromString) +import qualified Data.Foldable as F +import Data.Maybe (fromMaybe) + +xml :: QuasiQuoter +xml = QuasiQuoter { quoteExp = strToExp } + +xmlFile :: FilePath -> Q Exp +xmlFile = strToExp . TL.unpack <=< qRunIO . readUtf8File + +strToExp :: String -> Q Exp +strToExp s = + case parseDoc s of + Error e -> error e + Ok x -> docsToExp [] x + +docsToExp :: Scope -> [Doc] -> Q Exp +docsToExp scope docs = [| concat $(fmap ListE $ mapM (docToExp scope) docs) |] + +docToExp :: Scope -> Doc -> Q Exp +docToExp scope (DocTag name attrs cs) = + [| [ X.NodeElement (X.Element ($(liftName name)) $(mkAttrs scope attrs) $(docsToExp scope cs)) + ] |] +docToExp _ (DocContent (ContentRaw s)) = [| [ X.NodeContent (pack $(lift s)) ] |] +docToExp scope (DocContent (ContentVar d)) = [| [ X.NodeContent $(return $ derefToExp scope d) ] |] +docToExp scope (DocContent (ContentEmbed d)) = return $ derefToExp scope d +docToExp scope (DocForall deref ident@(Ident ident') inside) = do + let list' = derefToExp scope deref + name <- newName ident' + let scope' = (ident, VarE name) : scope + inside' <- docsToExp scope' inside + let lam = LamE [VarP name] inside' + [| F.concatMap $(return lam) $(return list') |] +docToExp scope (DocWith [] inside) = docsToExp scope inside +docToExp scope (DocWith ((deref, ident@(Ident name)):dis) inside) = do + let deref' = derefToExp scope deref + name' <- newName name + let scope' = (ident, VarE name') : scope + inside' <- docToExp scope' (DocWith dis inside) + let lam = LamE [VarP name'] inside' + return $ lam `AppE` deref' +docToExp scope (DocMaybe deref ident@(Ident name) just nothing) = do + let deref' = derefToExp scope deref + name' <- newName name + let scope' = (ident, VarE name') : scope + inside' <- docsToExp scope' just + let inside'' = LamE [VarP name'] inside' + nothing' <- + case nothing of + Nothing -> [| [] |] + Just n -> docsToExp scope n + [| maybe $(return nothing') $(return inside'') $(return deref') |] +docToExp scope (DocCond conds final) = do + unit <- [| () |] + body <- fmap GuardedB $ mapM go $ conds ++ [(DerefIdent $ Ident "otherwise", fromMaybe [] final)] + return $ CaseE unit [Match (TupP []) body []] + where + go (deref, inside) = do + inside' <- docsToExp scope inside + return (NormalG $ derefToExp scope deref, inside') + +mkAttrs :: Scope -> [(Maybe Deref, String, [Content])] -> Q Exp +mkAttrs _ [] = [| [] |] +mkAttrs scope ((mderef, name, value):rest) = do + rest' <- mkAttrs scope rest + this <- [| ($(liftName name), T.concat $(fmap ListE $ mapM go value)) |] + let with = [| $(return this) : $(return rest') |] + case mderef of + Nothing -> with + Just deref -> [| if $(return $ derefToExp scope deref) then $(with) else $(return rest') |] + where + go (ContentRaw s) = [| pack $(lift s) |] + go (ContentVar d) = return $ derefToExp scope d + go ContentEmbed{} = error "Cannot use embed interpolation in attribute value" + +liftName :: String -> Q Exp +liftName s = do + X.Name local mns _ <- return $ fromString s + case mns of + Nothing -> [| X.Name (pack $(lift $ unpack local)) Nothing Nothing |] + Just ns -> [| X.Name (pack $(lift $ unpack local)) (Just $ pack $(lift $ unpack ns)) Nothing |]
+ Text/Hamlet/XMLParse.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} +module Text.Hamlet.XMLParse + ( Result (..) + , Content (..) + , Doc (..) + , parseDoc + ) + where + +import Text.Shakespeare.Base +import Control.Applicative ((<$>), Applicative (..)) +import Control.Monad +import Data.Data +import Text.ParserCombinators.Parsec hiding (Line) + +data Result v = Error String | Ok v + deriving (Show, Eq, Read, Data, Typeable) +instance Monad Result where + return = Ok + Error s >>= _ = Error s + Ok v >>= f = f v + fail = Error +instance Functor Result where + fmap = liftM +instance Applicative Result where + pure = return + (<*>) = ap + +data Content = ContentRaw String + | ContentVar Deref + | ContentEmbed Deref + deriving (Show, Eq, Read, Data, Typeable) + +data Line = LineForall Deref Ident + | LineIf Deref + | LineElseIf Deref + | LineElse + | LineWith [(Deref, Ident)] + | LineMaybe Deref Ident + | LineNothing + | LineTag + { _lineTagName :: String + , _lineAttr :: [(Maybe Deref, String, [Content])] + , _lineContent :: [Content] + } + | LineContent [Content] + deriving (Eq, Show, Read) + +parseLines :: String -> Result [(Int, Line)] +parseLines s = + case parse (many parseLine) s s of + Left e -> Error $ show e + Right x -> Ok x + +parseLine :: Parser (Int, Line) +parseLine = do + ss <- fmap sum $ many ((char ' ' >> return 1) <|> + (char '\t' >> return 4)) + x <- comment <|> + htmlComment <|> + backslash <|> + controlIf <|> + controlElseIf <|> + (try (string "$else") >> spaceTabs >> eol >> return LineElse) <|> + controlMaybe <|> + (try (string "$nothing") >> spaceTabs >> eol >> return LineNothing) <|> + controlForall <|> + controlWith <|> + angle <|> + (eol' >> return (LineContent [])) <|> + (do + cs <- content InContent + isEof <- (eof >> return True) <|> return False + if null cs && ss == 0 && isEof + then fail "End of Hamlet template" + else return $ LineContent cs) + return (ss, x) + where + eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) + eol = eof <|> eol' + spaceTabs = many $ oneOf " \t" + comment = do + _ <- try $ string "$#" + _ <- many $ noneOf "\r\n" + eol + return $ LineContent [] + htmlComment = do + _ <- try $ string "<!--" + _ <- manyTill anyChar $ try $ string "-->" + x <- many nonComments + eol + return $ LineContent [ContentRaw $ concat x] -- FIXME handle variables? + nonComments = (many1 $ noneOf "\r\n<") <|> (do + _ <- char '<' + (do + _ <- try $ string "!--" + _ <- manyTill anyChar $ try $ string "-->" + return "") <|> return "<") + backslash = do + _ <- char '\\' + (eol >> return (LineContent [ContentRaw "\n"])) + <|> (LineContent <$> content InContent) + controlIf = do + _ <- try $ string "$if" + spaces + x <- parseDeref + _ <- spaceTabs + eol + return $ LineIf x + controlElseIf = do + _ <- try $ string "$elseif" + spaces + x <- parseDeref + _ <- spaceTabs + eol + return $ LineElseIf x + binding = do + y <- ident + spaces + _ <- string "<-" + spaces + x <- parseDeref + _ <- spaceTabs + return (x,y) + bindingSep = char ',' >> spaceTabs + controlMaybe = do + _ <- try $ string "$maybe" + spaces + (x,y) <- binding + eol + return $ LineMaybe x y + controlForall = do + _ <- try $ string "$forall" + spaces + (x,y) <- binding + eol + return $ LineForall x y + controlWith = do + _ <- try $ string "$with" + spaces + bindings <- (binding `sepBy` bindingSep) `endBy` eol + return $ LineWith $ concat bindings -- concat because endBy returns a [[(Deref,Ident)]] + content cr = do + x <- many $ content' cr + case cr of + InQuotes -> char '"' >> return () + NotInQuotes -> return () + NotInQuotesAttr -> return () + InContent -> eol + return $ cc x + where + cc [] = [] + cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c + cc (a:b) = a : cc b + content' cr = contentHash <|> contentCaret <|> contentReg cr + contentHash = do + x <- parseHash + case x of + Left str -> return $ ContentRaw str + Right deref -> return $ ContentVar deref + contentCaret = do + x <- parseCaret + case x of + Left str -> return $ ContentRaw str + Right deref -> return $ ContentEmbed deref + contentReg InContent = (ContentRaw . return) <$> noneOf "#@^\r\n" + contentReg NotInQuotes = (ContentRaw . return) <$> noneOf "@^#. \t\n\r>" + contentReg NotInQuotesAttr = (ContentRaw . return) <$> noneOf "@^ \t\n\r>" + contentReg InQuotes = (ContentRaw . return) <$> noneOf "#@^\\\"\n\r>" + tagAttribValue notInQuotes = do + cr <- (char '"' >> return InQuotes) <|> return notInQuotes + content cr + tagCond = do + _ <- char ':' + d <- parseDeref + _ <- char ':' + tagAttrib (Just d) + tagAttrib cond = do + s <- many1 $ noneOf " \t=\r\n>" + v <- (do + _ <- char '=' + s' <- tagAttribValue NotInQuotesAttr + return s') <|> return [] + return $ TagAttrib (cond, s, v) + tag' = foldr tag'' ("div", []) + tag'' (TagName s) (_, y) = (s, y) + tag'' (TagAttrib s) (x, y) = (x, s : y) + ident = Ident <$> many1 (alphaNum <|> char '_' <|> char '\'') + angle = do + _ <- char '<' + name' <- many $ noneOf " \t\r\n>" + let name = if null name' then "div" else name' + xs <- many $ try ((many $ oneOf " \t") >> + (tagCond <|> tagAttrib Nothing)) + _ <- many $ oneOf " \t" + c <- (eol >> return []) <|> (do + _ <- char '>' + c <- content InContent + return c) + let (tn, attr) = tag' $ TagName name : xs + return $ LineTag tn attr c + +data TagPiece = TagName String + | TagAttrib (Maybe Deref, String, [Content]) + deriving Show + +data ContentRule = InQuotes | NotInQuotes | NotInQuotesAttr | InContent + +data Nest = Nest Line [Nest] + +nestLines :: [(Int, Line)] -> [Nest] +nestLines [] = [] +nestLines ((i, l):rest) = + let (deeper, rest') = span (\(i', _) -> i' > i) rest + in Nest l (nestLines deeper) : nestLines rest' + +data Doc = DocForall Deref Ident [Doc] + | DocWith [(Deref,Ident)] [Doc] + | DocCond [(Deref, [Doc])] (Maybe [Doc]) + | DocMaybe Deref Ident [Doc] (Maybe [Doc]) + | DocTag String [(Maybe Deref, String, [Content])] [Doc] + | DocContent Content + -- FIXME PIs + deriving (Show, Eq, Read, Data, Typeable) + +nestToDoc :: [Nest] -> Result [Doc] +nestToDoc [] = Ok [] +nestToDoc (Nest (LineForall d i) inside:rest) = do + inside' <- nestToDoc inside + rest' <- nestToDoc rest + Ok $ DocForall d i inside' : rest' +nestToDoc (Nest (LineWith dis) inside:rest) = do + inside' <- nestToDoc inside + rest' <- nestToDoc rest + Ok $ DocWith dis inside' : rest' +nestToDoc (Nest (LineIf d) inside:rest) = do + inside' <- nestToDoc inside + (ifs, el, rest') <- parseConds ((:) (d, inside')) rest + rest'' <- nestToDoc rest' + Ok $ DocCond ifs el : rest'' +nestToDoc (Nest (LineMaybe d i) inside:rest) = do + inside' <- nestToDoc inside + (nothing, rest') <- + case rest of + Nest LineNothing ninside:x -> do + ninside' <- nestToDoc ninside + return (Just ninside', x) + _ -> return (Nothing, rest) + rest'' <- nestToDoc rest' + Ok $ DocMaybe d i inside' nothing : rest'' +nestToDoc (Nest (LineTag tn attrs content) inside:rest) = do + inside' <- nestToDoc inside + rest' <- nestToDoc rest + Ok $ (DocTag tn attrs $ map DocContent content ++ inside') : rest' +nestToDoc (Nest (LineContent content) inside:rest) = do + inside' <- nestToDoc inside + rest' <- nestToDoc rest + Ok $ map DocContent content ++ inside' ++ rest' +nestToDoc (Nest (LineElseIf _) _:_) = Error "Unexpected elseif" +nestToDoc (Nest LineElse _:_) = Error "Unexpected else" +nestToDoc (Nest LineNothing _:_) = Error "Unexpected nothing" + +parseDoc :: String -> Result [Doc] +parseDoc s = do + ls <- parseLines s + let notEmpty (_, LineContent []) = False + notEmpty _ = True + let ns = nestLines $ filter notEmpty ls + ds <- nestToDoc ns + return ds + +parseConds :: ([(Deref, [Doc])] -> [(Deref, [Doc])]) + -> [Nest] + -> Result ([(Deref, [Doc])], Maybe [Doc], [Nest]) +parseConds front (Nest LineElse inside:rest) = do + inside' <- nestToDoc inside + Ok $ (front [], Just inside', rest) +parseConds front (Nest (LineElseIf d) inside:rest) = do + inside' <- nestToDoc inside + parseConds (front . (:) (d, inside')) rest +parseConds front rest = Ok (front [], Nothing, rest)
test/main.hs view
@@ -1,135 +1,137 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE OverloadedStrings #-}-import Text.Hamlet.XML-import qualified Text.XML as X-import Test.HUnit-import Test.Hspec-import Test.Hspec.HUnit ()--main :: IO ()-main = hspecX $ describe "xml-hamlet"- [ it "handles plain tags" $ [xml|-<foo>- <baz-|] @?=- [ X.NodeElement $ X.Element "foo" []- [ X.NodeElement $ X.Element "baz" [] []- ]- ]- , it "handles raw text" $ [xml|-<foo>- <baz>bin-|] @?=- [ X.NodeElement $ X.Element "foo" []- [ X.NodeElement $ X.Element "baz" []- [ X.NodeContent "bin"- ]- ]- ]- , it "handles variables" $ [xml|-<foo>- <baz>#{bin}-|] @?=- [ X.NodeElement $ X.Element "foo" []- [ X.NodeElement $ X.Element "baz" []- [ X.NodeContent "bin"- ]- ]- ]- , it "handles embed" $ [xml|-<foo>- <baz>^{nodes}-|] @?=- [ X.NodeElement $ X.Element "foo" []- [ X.NodeElement $ X.Element "baz" [] nodes- ]- ]- , it "handles attributes" $ [xml|-<foo>- <bar here=there>- <baz-|] @?=- [ X.NodeElement $ X.Element "foo" []- [ X.NodeElement $ X.Element "bar" [("here", "there")]- [ X.NodeElement $ X.Element "baz" [] []- ]- ]- ]- , it "handles attributes" $ [xml|-<foo>- <bar here=there>- <baz :False:false=false :True:true=#{true}-|] @?=- [ X.NodeElement $ X.Element "foo" []- [ X.NodeElement $ X.Element "bar" [("here", "there")]- [ X.NodeElement $ X.Element "baz" [("true", "true")] []- ]- ]- ]- , it "handles forall" $ [xml|-$forall x <- xs- <word>#{x}- |] @?=- [ X.NodeElement $ X.Element "word" [] [X.NodeContent "foo"]- , X.NodeElement $ X.Element "word" [] [X.NodeContent "bar"]- , X.NodeElement $ X.Element "word" [] [X.NodeContent "baz"]- ]- , it "handles with" $ [xml|-$with ys <- xs- $forall x <- ys- <word>#{x}- |] @?=- [ X.NodeElement $ X.Element "word" [] [X.NodeContent "foo"]- , X.NodeElement $ X.Element "word" [] [X.NodeContent "bar"]- , X.NodeElement $ X.Element "word" [] [X.NodeContent "baz"]- ]- , it "handles maybe" $ [xml|-$maybe _x <- Just five- <one>-$nothing- <two>-$maybe _x <- Nothing- <three>-$nothing- <four>- |] @?=- [ X.NodeElement $ X.Element "one" [] []- , X.NodeElement $ X.Element "four" [] []- ]- , it "handles conditionals" $ [xml|-$if True- <one>-$else- <two>--$if False- <three>-$elseif True- <four>--$if False- <five>-$elseif False- <six>-$else- <seven>-|] @?=- [ X.NodeElement $ X.Element "one" [] []- , X.NodeElement $ X.Element "four" [] []- , X.NodeElement $ X.Element "seven" [] []- ]- , it "recognizes clark notation" $ [xml|-<{foo}bar {baz}bin="x"-|] @?= [X.NodeElement $ X.Element "{foo}bar" [("{baz}bin", "x")] []]- , it "recognizes clark with URLs" $ [xml|-<{http://www.example.com/foo/bar}baz>-|] @?= [X.NodeElement $ X.Element "{http://www.example.com/foo/bar}baz" [] []]- ]- where- bin = "bin"- nodes = [X.NodeInstruction $ X.Instruction "ifoo" "ibar"]- true = "true"- xs = ["foo", "bar", "baz"]--five :: Int-five = 5+{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +import Text.Hamlet.XML +import qualified Text.XML as X +import Test.HUnit +import Test.Hspec +import Test.Hspec.HUnit () + +main :: IO () +main = hspecX $ describe "xml-hamlet" + [ it "handles plain tags" $ [xml| +<foo> + <baz +|] @?= + [ X.NodeElement $ X.Element "foo" [] + [ X.NodeElement $ X.Element "baz" [] [] + ] + ] + , it "handles raw text" $ [xml| +<foo> + <baz>bin +|] @?= + [ X.NodeElement $ X.Element "foo" [] + [ X.NodeElement $ X.Element "baz" [] + [ X.NodeContent "bin" + ] + ] + ] + , it "handles variables" $ [xml| +<foo> + <baz>#{bin} +|] @?= + [ X.NodeElement $ X.Element "foo" [] + [ X.NodeElement $ X.Element "baz" [] + [ X.NodeContent "bin" + ] + ] + ] + , it "handles embed" $ [xml| +<foo> + <baz>^{nodes} +|] @?= + [ X.NodeElement $ X.Element "foo" [] + [ X.NodeElement $ X.Element "baz" [] nodes + ] + ] + , it "handles attributes" $ [xml| +<foo> + <bar here=there> + <baz +|] @?= + [ X.NodeElement $ X.Element "foo" [] + [ X.NodeElement $ X.Element "bar" [("here", "there")] + [ X.NodeElement $ X.Element "baz" [] [] + ] + ] + ] + , it "handles attributes" $ [xml| +<foo> + <bar here=there> + <baz :False:false=false :True:true=#{true} +|] @?= + [ X.NodeElement $ X.Element "foo" [] + [ X.NodeElement $ X.Element "bar" [("here", "there")] + [ X.NodeElement $ X.Element "baz" [("true", "true")] [] + ] + ] + ] + , it "handles forall" $ [xml| +$forall x <- xs + <word>#{x} + |] @?= + [ X.NodeElement $ X.Element "word" [] [X.NodeContent "foo"] + , X.NodeElement $ X.Element "word" [] [X.NodeContent "bar"] + , X.NodeElement $ X.Element "word" [] [X.NodeContent "baz"] + ] + , it "handles with" $ [xml| +$with ys <- xs + $forall x <- ys + <word>#{x} + |] @?= + [ X.NodeElement $ X.Element "word" [] [X.NodeContent "foo"] + , X.NodeElement $ X.Element "word" [] [X.NodeContent "bar"] + , X.NodeElement $ X.Element "word" [] [X.NodeContent "baz"] + ] + , it "handles maybe" $ [xml| +$maybe _x <- Just five + <one> +$nothing + <two> +$maybe _x <- Nothing + <three> +$nothing + <four> + |] @?= + [ X.NodeElement $ X.Element "one" [] [] + , X.NodeElement $ X.Element "four" [] [] + ] + , it "handles conditionals" $ [xml| +$if True + <one> +$else + <two> + +$if False + <three> +$elseif True + <four> + +$if False + <five> +$elseif False + <six> +$else + <seven> +|] @?= + [ X.NodeElement $ X.Element "one" [] [] + , X.NodeElement $ X.Element "four" [] [] + , X.NodeElement $ X.Element "seven" [] [] + ] + , it "recognizes clark notation" $ [xml| +<{foo}bar {baz}bin="x" +|] @?= [X.NodeElement $ X.Element "{foo}bar" [("{baz}bin", "x")] []] + , it "recognizes clark with URLs" $ [xml| +<{http://www.example.com/foo/bar}baz> +|] @?= [X.NodeElement $ X.Element "{http://www.example.com/foo/bar}baz" [] []] + , it "allow embedding comments" $[xml|^{comment}|] @?= comment + ] + where + bin = "bin" + nodes = [X.NodeInstruction $ X.Instruction "ifoo" "ibar"] + true = "true" + xs = ["foo", "bar", "baz"] + comment = [X.NodeComment "somecomment"] + +five :: Int +five = 5
xml-hamlet.cabal view
@@ -1,42 +1,42 @@-Name: xml-hamlet-Version: 0.2.0-Synopsis: Hamlet-style quasiquoter for XML content-Homepage: http://www.yesodweb.com/-License: BSD3-License-file: LICENSE-Author: Michael Snoyman-Maintainer: michael@snoyman.com-Category: Text-Build-type: Simple-Description: Hamlet-style quasiquoter for XML content-Extra-source-files: test/main.hs--Cabal-version: >=1.8--Library- Exposed-modules: Text.Hamlet.XML- Other-modules: Text.Hamlet.Parse- - Build-depends: base >= 4 && < 5- , shakespeare >= 0.10 && < 0.11- , xml-conduit >= 0.5 && < 0.6- , text >= 0.10 && < 1.0- , template-haskell- , parsec >= 2.0 && < 3.2-- Ghc-options: -Wall--test-suite test- main-is: main.hs- hs-source-dirs: test- type: exitcode-stdio-1.0- ghc-options: -Wall- build-depends: hspec- , HUnit >= 1.2 && < 1.3- , base >= 4 && < 5- , shakespeare >= 0.10 && < 0.11- , xml-conduit- , text >= 0.10 && < 1.0- , template-haskell- , parsec >= 2.0 && < 3.2- , xml-hamlet+Name: xml-hamlet +Version: 0.2.0.1 +Synopsis: Hamlet-style quasiquoter for XML content +Homepage: http://www.yesodweb.com/ +License: BSD3 +License-file: LICENSE +Author: Michael Snoyman +Maintainer: michael@snoyman.com +Category: Text +Build-type: Simple +Description: Hamlet-style quasiquoter for XML content +Extra-source-files: test/main.hs + +Cabal-version: >=1.8 + +Library + Exposed-modules: Text.Hamlet.XML + Other-modules: Text.Hamlet.XMLParse + + Build-depends: base >= 4 && < 5 + , shakespeare >= 0.10 && < 0.11 + , xml-conduit >= 0.5 && < 0.6 + , text >= 0.10 && < 1.0 + , template-haskell + , parsec >= 2.0 && < 3.2 + + Ghc-options: -Wall + +test-suite test + main-is: main.hs + hs-source-dirs: test + type: exitcode-stdio-1.0 + ghc-options: -Wall + build-depends: hspec + , HUnit >= 1.2 && < 1.3 + , base >= 4 && < 5 + , shakespeare >= 0.10 && < 0.11 + , xml-conduit + , text >= 0.10 && < 1.0 + , template-haskell + , parsec >= 2.0 && < 3.2 + , xml-hamlet