xml-hamlet 0.2.0.1 → 0.2.0.2
raw patch · 6 files changed
+596/−596 lines, 6 filesdep ~shakespearesetup-changed
Dependency ranges changed: shakespeare
Files
- LICENSE +30/−30
- Setup.lhs +8/−8
- Text/Hamlet/XML.hs +97/−97
- Text/Hamlet/XMLParse.hs +282/−282
- test/main.hs +137/−137
- 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/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.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 |] +{-# 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
@@ -1,282 +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) +{-# 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,137 +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" [] []] - , 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 +{-# 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.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 +Name: xml-hamlet+Version: 0.2.0.2+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.12+ , 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