xml-hamlet-0.4.0.4/0000755000000000000000000000000012110322736012110 5ustar0000000000000000xml-hamlet-0.4.0.4/LICENSE0000644000000000000000000000276712110322736013131 0ustar0000000000000000Copyright (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. xml-hamlet-0.4.0.4/Setup.lhs0000644000000000000000000000021712110322736013720 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > import System.Cmd (system) > main :: IO () > main = defaultMain xml-hamlet-0.4.0.4/xml-hamlet.cabal0000644000000000000000000000276012110322736015151 0ustar0000000000000000Name: xml-hamlet Version: 0.4.0.4 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 >= 1.0 && < 1.1 , xml-conduit >= 1.0 && < 1.2 , text >= 0.10 && < 1.0 , template-haskell , parsec >= 2.0 && < 3.2 , containers 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 >= 1.3 , HUnit , base >= 4 && < 5 , shakespeare , xml-conduit , text , template-haskell , parsec , xml-hamlet , containers xml-hamlet-0.4.0.4/Text/0000755000000000000000000000000012110322736013034 5ustar0000000000000000xml-hamlet-0.4.0.4/Text/Hamlet/0000755000000000000000000000000012110322736014246 5ustar0000000000000000xml-hamlet-0.4.0.4/Text/Hamlet/XMLParse.hs0000644000000000000000000002165512110322736016246 0ustar0000000000000000{-# 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 "" 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\r\n") >> (tagCond <|> tagAttrib Nothing)) _ <- many $ oneOf " \t" _ <- char '>' c <- content InContent 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) xml-hamlet-0.4.0.4/Text/Hamlet/XML.hs0000644000000000000000000000742412110322736015251 0ustar0000000000000000{-# 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) import qualified Data.Map as Map 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 _ [] = [| Map.empty |] mkAttrs scope ((mderef, name, value):rest) = do rest' <- mkAttrs scope rest this <- [| Map.insert $(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 |] xml-hamlet-0.4.0.4/test/0000755000000000000000000000000012110322736013067 5ustar0000000000000000xml-hamlet-0.4.0.4/test/main.hs0000644000000000000000000000751112110322736014353 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} import Text.Hamlet.XML import qualified Text.XML as X import Test.HUnit import Test.Hspec import qualified Data.Map as Map main :: IO () main = hspec $ do describe "xml-hamlet" $ do it "handles plain tags" $ [xml| |] @?= [ X.NodeElement $ X.Element "foo" Map.empty [ X.NodeElement $ X.Element "baz" Map.empty [] ] ] it "handles raw text" $ [xml| bin |] @?= [ X.NodeElement $ X.Element "foo" Map.empty [ X.NodeElement $ X.Element "baz" Map.empty [ X.NodeContent "bin" ] ] ] it "handles variables" $ [xml| #{bin} |] @?= [ X.NodeElement $ X.Element "foo" Map.empty [ X.NodeElement $ X.Element "baz" Map.empty [ X.NodeContent "bin" ] ] ] it "handles embed" $ [xml| ^{nodes} |] @?= [ X.NodeElement $ X.Element "foo" Map.empty [ X.NodeElement $ X.Element "baz" Map.empty nodes ] ] it "handles attributes" $ [xml| |] @?= [ X.NodeElement $ X.Element "foo" Map.empty [ X.NodeElement $ X.Element "bar" (Map.singleton "here" "there") [ X.NodeElement $ X.Element "baz" Map.empty [] ] ] ] it "handles attributes" $ [xml| |] @?= [ X.NodeElement $ X.Element "foo" Map.empty [ X.NodeElement $ X.Element "bar" (Map.singleton "here" "there") [ X.NodeElement $ X.Element "baz" (Map.singleton "true" "true") [] ] ] ] it "handles forall" $ [xml| $forall x <- xs #{x} |] @?= [ X.NodeElement $ X.Element "word" Map.empty [X.NodeContent "foo"] , X.NodeElement $ X.Element "word" Map.empty [X.NodeContent "bar"] , X.NodeElement $ X.Element "word" Map.empty [X.NodeContent "baz"] ] it "handles with" $ [xml| $with ys <- xs $forall x <- ys #{x} |] @?= [ X.NodeElement $ X.Element "word" Map.empty [X.NodeContent "foo"] , X.NodeElement $ X.Element "word" Map.empty [X.NodeContent "bar"] , X.NodeElement $ X.Element "word" Map.empty [X.NodeContent "baz"] ] it "handles maybe" $ [xml| $maybe _x <- Just five $nothing $maybe _x <- Nothing $nothing |] @?= [ X.NodeElement $ X.Element "one" Map.empty [] , X.NodeElement $ X.Element "four" Map.empty [] ] it "handles conditionals" $ [xml| $if True $else $if False $elseif True $if False $elseif False $else |] @?= [ X.NodeElement $ X.Element "one" Map.empty [] , X.NodeElement $ X.Element "four" Map.empty [] , X.NodeElement $ X.Element "seven" Map.empty [] ] it "recognizes clark notation" $ [xml| <{foo}bar {baz}bin="x"> |] @?= [X.NodeElement $ X.Element "{foo}bar" (Map.singleton "{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" Map.empty []] it "allow embedding comments" $[xml|^{comment}|] @?= comment it "multiline tags" $ [xml| content |] @?= [xml|content|] it "short circuiting of attributes" $ [xml||] @?= [xml||] where bin = "bin" nodes = [X.NodeInstruction $ X.Instruction "ifoo" "ibar"] true = "true" xs = ["foo", "bar", "baz"] comment = [X.NodeComment "somecomment"] five :: Int five = 5