xml-hamlet-0.4.1.1/Text/0000755000000000000000000000000012621142441013032 5ustar0000000000000000xml-hamlet-0.4.1.1/Text/Hamlet/0000755000000000000000000000000013037141244014246 5ustar0000000000000000xml-hamlet-0.4.1.1/test/0000755000000000000000000000000013037141244013067 5ustar0000000000000000xml-hamlet-0.4.1.1/Text/Hamlet/XML.hs0000644000000000000000000002137513037141244015252 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} module Text.Hamlet.XML ( xml , xmlFile , ToAttributes (..) ) where #if MIN_VERSION_template_haskell(2,9,0) import Language.Haskell.TH.Syntax hiding (Module) #else import Language.Haskell.TH.Syntax #endif import Language.Haskell.TH.Quote import Data.Char (isDigit) import qualified Data.Text.Lazy as TL import Control.Monad ((<=<)) import Text.Hamlet.XMLParse import Text.Shakespeare.Base (readUtf8File, derefToExp, Scope, Deref, Ident (Ident)) import Data.Text (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 import Control.Arrow (first, (***)) import Data.List (intercalate) -- | Convert some value to a list of attribute pairs. class ToAttributes a where toAttributes :: a -> Map.Map X.Name Text instance ToAttributes (X.Name, Text) where toAttributes (k, v) = Map.singleton k v instance ToAttributes (Text, Text) where toAttributes (k, v) = Map.singleton (fromString $ unpack k) v instance ToAttributes (String, String) where toAttributes (k, v) = Map.singleton (fromString k) (pack v) instance ToAttributes [(X.Name, Text)] where toAttributes = Map.fromList instance ToAttributes [(Text, Text)] where toAttributes = Map.fromList . map (first (fromString . unpack)) instance ToAttributes [(String, String)] where toAttributes = Map.fromList . map (fromString *** pack) instance ToAttributes (Map.Map X.Name Text) where toAttributes = id instance ToAttributes (Map.Map Text Text) where toAttributes = Map.mapKeys (fromString . unpack) instance ToAttributes (Map.Map String String) where toAttributes = Map.mapKeys fromString . Map.map pack docsToExp :: Scope -> [Doc] -> Q Exp docsToExp scope docs = [| concat $(fmap ListE $ mapM (docToExp scope) docs) |] unIdent :: Ident -> String unIdent (Ident s) = s bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)]) bindingPattern (BindAs i@(Ident s) b) = do name <- newName s (pattern, scope) <- bindingPattern b return (AsP name pattern, (i, VarE name):scope) bindingPattern (BindVar i@(Ident s)) | s == "_" = return (WildP, []) | all isDigit s = do return (LitP $ IntegerL $ read s, []) | otherwise = do name <- newName s return (VarP name, [(i, VarE name)]) bindingPattern (BindTuple is) = do (patterns, scopes) <- fmap unzip $ mapM bindingPattern is return (TupP patterns, concat scopes) bindingPattern (BindList is) = do (patterns, scopes) <- fmap unzip $ mapM bindingPattern is return (ListP patterns, concat scopes) bindingPattern (BindConstr con is) = do (patterns, scopes) <- fmap unzip $ mapM bindingPattern is return (ConP (mkConName con) patterns, concat scopes) bindingPattern (BindRecord con fields wild) = do let f (Ident field,b) = do (p,s) <- bindingPattern b return ((mkName field,p),s) (patterns, scopes) <- fmap unzip $ mapM f fields (patterns1, scopes1) <- if wild then bindWildFields con $ map fst fields else return ([],[]) return (RecP (mkConName con) (patterns++patterns1), concat scopes ++ scopes1) mkConName :: DataConstr -> Name mkConName = mkName . conToStr conToStr :: DataConstr -> String conToStr (DCUnqualified (Ident x)) = x conToStr (DCQualified (Module xs) (Ident x)) = intercalate "." $ xs ++ [x] -- Wildcards bind all of the unbound fields to variables whose name -- matches the field name. -- -- For example: data R = C { f1, f2 :: Int } -- C {..} is equivalent to C {f1=f1, f2=f2} -- C {f1 = a, ..} is equivalent to C {f1=a, f2=f2} -- C {f2 = a, ..} is equivalent to C {f1=f1, f2=a} bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)]) bindWildFields conName fields = do fieldNames <- recordToFieldNames conName let available n = nameBase n `notElem` map unIdent fields let remainingFields = filter available fieldNames let mkPat n = do e <- newName (nameBase n) return ((n,VarP e), (Ident (nameBase n), VarE e)) fmap unzip $ mapM mkPat remainingFields -- Important note! reify will fail if the record type is defined in the -- same module as the reify is used. This means quasi-quoted Hamlet -- literals will not be able to use wildcards to match record types -- defined in the same module. recordToFieldNames :: DataConstr -> Q [Name] recordToFieldNames conStr = do -- use 'lookupValueName' instead of just using 'mkName' so we reify the -- data constructor and not the type constructor if their names match. Just conName <- lookupValueName $ conToStr conStr #if MIN_VERSION_template_haskell(2,11,0) DataConI _ _ typeName <- reify conName TyConI (DataD _ _ _ _ cons _) <- reify typeName #else DataConI _ _ typeName _ <- reify conName TyConI (DataD _ _ _ cons _) <- reify typeName #endif [fields] <- return [fields | RecC name fields <- cons, name == conName] return [fieldName | (fieldName, _, _) <- fields] docToExp :: Scope -> Doc -> Q Exp docToExp scope (DocTag name attrs attrsD cs) = [| [ X.NodeElement (X.Element ($(liftName name)) $(mkAttrs scope attrs attrsD) $(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 list idents inside) = do let list' = derefToExp scope list (pat, extraScope) <- bindingPattern idents let scope' = extraScope ++ scope mh <- [|F.concatMap|] inside' <- docsToExp scope' inside let lam = LamE [pat] inside' return $ mh `AppE` lam `AppE` list' docToExp scope (DocWith [] inside) = docsToExp scope inside docToExp scope (DocWith ((deref, idents):dis) inside) = do let deref' = derefToExp scope deref (pat, extraScope) <- bindingPattern idents let scope' = extraScope ++ scope inside' <- docToExp scope' (DocWith dis inside) let lam = LamE [pat] inside' return $ lam `AppE` deref' docToExp scope (DocMaybe val idents inside mno) = do let val' = derefToExp scope val (pat, extraScope) <- bindingPattern idents let scope' = extraScope ++ scope inside' <- docsToExp scope' inside let inside'' = LamE [pat] inside' ninside' <- case mno of Nothing -> [| [] |] Just no -> docsToExp scope no [| maybe $(return ninside') $(return inside'') $(return val') |] docToExp scope (DocCond conds final) = do unit <- [| () |] otherwise' <- [|otherwise|] body <- fmap GuardedB $ mapM go $ map (first (derefToExp scope)) conds ++ [(otherwise', fromMaybe [] final)] return $ CaseE unit [Match (TupP []) body []] where go (deref, inside) = do inside' <- docsToExp scope inside return (NormalG deref, inside') docToExp scope (DocCase deref cases) = do let exp_ = derefToExp scope deref matches <- mapM toMatch cases return $ CaseE exp_ matches where toMatch :: (Binding, [Doc]) -> Q Match toMatch (idents, inside) = do (pat, extraScope) <- bindingPattern idents let scope' = extraScope ++ scope insideExp <- docsToExp scope' inside return $ Match pat (NormalB insideExp) [] mkAttrs :: Scope -> [(Maybe Deref, String, [Content])] -> [Deref] -> Q Exp mkAttrs _ [] [] = [| Map.empty |] mkAttrs scope [] (deref:rest) = do rest' <- mkAttrs scope [] rest [| Map.union (toAttributes $(return $ derefToExp scope deref)) $(return rest') |] mkAttrs scope ((mderef, name, value):rest) attrs = do rest' <- mkAttrs scope rest attrs 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 :: 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 xml-hamlet-0.4.1.1/Text/Hamlet/XMLParse.hs0000644000000000000000000003331413037141244016241 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} module Text.Hamlet.XMLParse ( Result (..) , Content (..) , Doc (..) , parseDoc , Binding (..) , DataConstr (..) , Module (..) ) where import Text.Shakespeare.Base import Control.Applicative ((<$>), Applicative (..)) import Control.Monad import Data.Char (isUpper) 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 Binding | LineIf Deref | LineElseIf Deref | LineElse | LineWith [(Deref, Binding)] | LineMaybe Deref Binding | LineNothing | LineCase Deref | LineOf Binding | LineTag { _lineTagName :: String , _lineAttr :: [(Maybe Deref, String, [Content])] , _lineContent :: [Content] , _lineAttrs :: [Deref] } | 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' >> fail "Tabs are not allowed in Hamlet indentation")) x <- comment <|> htmlComment <|> backslash <|> controlIf <|> controlElseIf <|> (try (string "$else") >> spaceTabs >> eol >> return LineElse) <|> controlMaybe <|> (try (string "$nothing") >> spaceTabs >> eol >> return LineNothing) <|> controlForall <|> controlWith <|> controlCase <|> controlOf <|> angle <|> invalidDollar <|> (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' invalidDollar = do _ <- char '$' fail "Received a command I did not understand. If you wanted a literal $, start the line with a backslash." 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 <- identPattern 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)]] controlCase = do _ <- try $ string "$case" spaces x <- parseDeref _ <- spaceTabs eol return $ LineCase x controlOf = do _ <- try $ string "$of" spaces x <- identPattern _ <- spaceTabs eol return $ LineOf x content cr = do x <- many $ content' cr case cr of InQuotes -> void $ char '"' 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 cr <|> contentCaret <|> contentReg cr contentHash cr = do x <- parseHash case x of Left "#" -> case cr of NotInQuotes -> fail "Expected hash at end of line, got Id" _ -> return $ ContentRaw "#" 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 d <- between (char ':') (char ':') parseDeref tagAttrib (Just d) tagAttrib cond = do s <- many1 $ noneOf " \t=\r\n><" v <- (char '=' >> tagAttribValue NotInQuotesAttr) <|> return [] return $ TagAttrib (cond, s, v) tagAttrs = do _ <- char '*' d <- between (char '{') (char '}') parseDeref return $ TagAttribs d tag' = foldr tag'' ("div", [], []) tag'' (TagName s) (_, y, as) = (s, y, as) tag'' (TagAttrib s) (x, y, as) = (x, s : y, as) tag'' (TagAttribs s) (x, y, as) = (x, y, s : as) ident :: Parser Ident ident = do i <- many1 (alphaNum <|> char '_' <|> char '\'') white return (Ident i) "identifier" parens = between (char '(' >> white) (char ')' >> white) brackets = between (char '[' >> white) (char ']' >> white) braces = between (char '{' >> white) (char '}' >> white) comma = char ',' >> white atsign = char '@' >> white equals = char '=' >> white white = skipMany $ char ' ' wildDots = string ".." >> white isVariable (Ident (x:_)) = not (isUpper x) isVariable (Ident []) = error "isVariable: bad identifier" isConstructor (Ident (x:_)) = isUpper x isConstructor (Ident []) = error "isConstructor: bad identifier" identPattern :: Parser Binding identPattern = gcon True <|> apat where apat = choice [ varpat , gcon False , parens tuplepat , brackets listpat ] varpat = do v <- try $ do v <- ident guard (isVariable v) return v option (BindVar v) $ do atsign b <- apat return (BindAs v b) "variable" gcon :: Bool -> Parser Binding gcon allowArgs = do c <- try $ do c <- dataConstr return c choice [ record c , fmap (BindConstr c) (guard allowArgs >> many apat) , return (BindConstr c []) ] "constructor" dataConstr = do p <- dcPiece ps <- many dcPieces return $ toDataConstr p ps dcPiece = do x@(Ident y) <- ident guard $ isConstructor x return y dcPieces = do _ <- char '.' dcPiece toDataConstr x [] = DCUnqualified $ Ident x toDataConstr x (y:ys) = go (x:) y ys where go front next [] = DCQualified (Module $ front []) (Ident next) go front next (rest:rests) = go (front . (next:)) rest rests record c = braces $ do (fields, wild) <- option ([], False) $ go return (BindRecord c fields wild) where go = (wildDots >> return ([], True)) <|> (do x <- recordField (xs,wild) <- option ([],False) (comma >> go) return (x:xs,wild)) recordField = do field <- ident p <- option (BindVar field) -- support punning (equals >> identPattern) return (field,p) tuplepat = do xs <- identPattern `sepBy` comma return $ case xs of [x] -> x _ -> BindTuple xs listpat = BindList <$> identPattern `sepBy` comma 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 <|> tagAttrs <|> tagAttrib Nothing)) _ <- many $ oneOf " \t\r\n" _ <- char '>' c <- content InContent let (tn, attr, attrsd) = tag' $ TagName name : xs return $ LineTag tn attr c attrsd data TagPiece = TagName String | TagAttrib (Maybe Deref, String, [Content]) | TagAttribs Deref 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 Binding [Doc] | DocWith [(Deref, Binding)] [Doc] | DocCond [(Deref, [Doc])] (Maybe [Doc]) | DocMaybe Deref Binding [Doc] (Maybe [Doc]) | DocCase Deref [(Binding, [Doc])] | DocTag String [(Maybe Deref, String, [Content])] [Deref] [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 (LineCase d) inside:rest) = do let getOf (Nest (LineOf x) insideC) = do insideC' <- nestToDoc insideC Ok (x, insideC') getOf _ = Error "Inside a $case there may only be $of. Use '$of _' for a wildcard." cases <- mapM getOf inside rest' <- nestToDoc rest Ok $ DocCase d cases : rest' nestToDoc (Nest (LineTag tn attrs content attrsD) inside:rest) = do inside' <- nestToDoc inside rest' <- nestToDoc rest Ok $ (DocTag tn attrs attrsD $ 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" nestToDoc (Nest (LineOf _) _:_) = Error "Unexpected 'of' (did you forget a $case?)" 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) data Binding = BindVar Ident | BindAs Ident Binding | BindConstr DataConstr [Binding] | BindTuple [Binding] | BindList [Binding] | BindRecord DataConstr [(Ident, Binding)] Bool deriving (Eq, Show, Read, Data, Typeable) data DataConstr = DCQualified Module Ident | DCUnqualified Ident deriving (Eq, Show, Read, Data, Typeable) newtype Module = Module [String] deriving (Eq, Show, Read, Data, Typeable) spaceTabs :: Parser String spaceTabs = many $ oneOf " \t" xml-hamlet-0.4.1.1/test/main.hs0000644000000000000000000001111313037141244014344 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.fromList (("true", "true") : attrs)) [] ] ] ] 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 "case on Maybe" $ let nothing = Nothing justTrue = Just True in [xml| $case nothing $of Just val $of Nothing $case justTrue $of Just val $if val $of Nothing $case (Just $ not False) $of Nothing $of Just val $if val $case Nothing $of Just val $of _ |] @?= [ X.NodeElement $ X.Element "one" Map.empty [] , X.NodeElement $ X.Element "two" Map.empty [] , X.NodeElement $ X.Element "three" Map.empty [] , X.NodeElement $ X.Element "four" 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||] it "Hash in attribute value" $ [xml||] @?= [xml||] where bin = "bin" nodes = [X.NodeInstruction $ X.Instruction "ifoo" "ibar"] true = "true" attrs = [("one","a"), ("two","b")] xs = ["foo", "bar", "baz"] comment = [X.NodeComment "somecomment"] five :: Int five = 5 xml-hamlet-0.4.1.1/LICENSE0000644000000000000000000000276712621142441013127 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.1.1/Setup.lhs0000755000000000000000000000021712621142441013721 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > import System.Cmd (system) > main :: IO () > main = defaultMain xml-hamlet-0.4.1.1/xml-hamlet.cabal0000644000000000000000000000275413162672521015162 0ustar0000000000000000Name: xml-hamlet Version: 0.4.1.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 ChangeLog.md README.md Cabal-version: >=1.8 Library Exposed-modules: Text.Hamlet.XML Other-modules: Text.Hamlet.XMLParse Build-depends: base >= 4 && < 5 , shakespeare >= 1.0 && < 2.2 , xml-conduit >= 1.0 , text >= 0.10 , 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.1.1/ChangeLog.md0000644000000000000000000000021013162672516014264 0ustar0000000000000000## 0.4.1.1 * Remove an upper bound ## 0.4.1 Add various hamlet features to xml-hamlet [#91](https://github.com/snoyberg/xml/pull/91) xml-hamlet-0.4.1.1/README.md0000644000000000000000000000003613037141530013364 0ustar0000000000000000## xml-hamlet Hamlet for XML