Hello community, here is the log from the commit of package ghc-xml-hamlet for openSUSE:Factory checked in at 2017-02-21 13:38:25 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-xml-hamlet (Old) and /work/SRC/openSUSE:Factory/.ghc-xml-hamlet.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-xml-hamlet" Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-xml-hamlet/ghc-xml-hamlet.changes 2016-10-23 12:51:01.000000000 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-xml-hamlet.new/ghc-xml-hamlet.changes 2017-02-21 13:38:26.245117652 +0100 @@ -1,0 +2,5 @@ +Thu Jan 26 16:20:20 UTC 2017 - [email protected] + +- Update to version 0.4.1 with cabal2obs. + +------------------------------------------------------------------- Old: ---- xml-hamlet-0.4.0.12.tar.gz New: ---- xml-hamlet-0.4.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-xml-hamlet.spec ++++++ --- /var/tmp/diff_new_pack.js8FnT/_old 2017-02-21 13:38:26.629063488 +0100 +++ /var/tmp/diff_new_pack.js8FnT/_new 2017-02-21 13:38:26.633062924 +0100 @@ -1,7 +1,7 @@ # # spec file for package ghc-xml-hamlet # -# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,7 +19,7 @@ %global pkg_name xml-hamlet %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.4.0.12 +Version: 0.4.1 Release: 0 Summary: Hamlet-style quasiquoter for XML content License: BSD-3-Clause @@ -78,5 +78,6 @@ %files devel -f %{name}-devel.files %defattr(-,root,root,-) +%doc ChangeLog.md README.md %changelog ++++++ xml-hamlet-0.4.0.12.tar.gz -> xml-hamlet-0.4.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-hamlet-0.4.0.12/ChangeLog.md new/xml-hamlet-0.4.1/ChangeLog.md --- old/xml-hamlet-0.4.0.12/ChangeLog.md 1970-01-01 01:00:00.000000000 +0100 +++ new/xml-hamlet-0.4.1/ChangeLog.md 2017-01-16 16:34:29.000000000 +0100 @@ -0,0 +1,3 @@ +## 0.4.1 + +Add various hamlet features to xml-hamlet [#91](https://github.com/snoyberg/xml/pull/91) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-hamlet-0.4.0.12/README.md new/xml-hamlet-0.4.1/README.md --- old/xml-hamlet-0.4.0.12/README.md 1970-01-01 01:00:00.000000000 +0100 +++ new/xml-hamlet-0.4.1/README.md 2017-01-16 16:34:29.000000000 +0100 @@ -0,0 +1,3 @@ +## xml-hamlet + +Hamlet for XML diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-hamlet-0.4.0.12/Text/Hamlet/XML.hs new/xml-hamlet-0.4.1/Text/Hamlet/XML.hs --- old/xml-hamlet-0.4.0.12/Text/Hamlet/XML.hs 2016-09-23 10:34:26.000000000 +0200 +++ new/xml-hamlet-0.4.1/Text/Hamlet/XML.hs 2017-01-16 16:34:29.000000000 +0100 @@ -1,73 +1,169 @@ {-# 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 (pack, unpack) +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 Control.Arrow (first, (***)) +import Data.List (intercalate) -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 +-- | 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 cs) = - [| [ X.NodeElement (X.Element ($(liftName name)) $(mkAttrs scope attrs) $(docsToExp scope cs)) +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 deref ident@(Ident ident') inside) = do - let list' = derefToExp scope deref - name <- newName ident' - let scope' = (ident, VarE name) : scope +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 [VarP name] inside' - [| F.concatMap $(return lam) $(return list') |] + let lam = LamE [pat] inside' + return $ mh `AppE` lam `AppE` list' docToExp scope (DocWith [] inside) = docsToExp scope inside -docToExp scope (DocWith ((deref, ident@(Ident name)):dis) inside) = do +docToExp scope (DocWith ((deref, idents):dis) inside) = do let deref' = derefToExp scope deref - name' <- newName name - let scope' = (ident, VarE name') : scope + (pat, extraScope) <- bindingPattern idents + let scope' = extraScope ++ scope inside' <- docToExp scope' (DocWith dis inside) - let lam = LamE [VarP name'] inside' + let lam = LamE [pat] 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 (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|] @@ -77,11 +173,25 @@ go (deref, inside) = do inside' <- docsToExp scope inside return (NormalG deref, inside') - -mkAttrs :: Scope -> [(Maybe Deref, String, [Content])] -> Q Exp -mkAttrs _ [] = [| Map.empty |] -mkAttrs scope ((mderef, name, value):rest) = do - rest' <- mkAttrs scope rest +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 @@ -98,3 +208,16 @@ 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 + diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-hamlet-0.4.0.12/Text/Hamlet/XMLParse.hs new/xml-hamlet-0.4.1/Text/Hamlet/XMLParse.hs --- old/xml-hamlet-0.4.0.12/Text/Hamlet/XMLParse.hs 2016-09-23 10:34:26.000000000 +0200 +++ new/xml-hamlet-0.4.1/Text/Hamlet/XMLParse.hs 2017-01-16 16:34:29.000000000 +0100 @@ -6,12 +6,16 @@ , 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) @@ -33,17 +37,20 @@ | ContentEmbed Deref deriving (Show, Eq, Read, Data, Typeable) -data Line = LineForall Deref Ident +data Line = LineForall Deref Binding | LineIf Deref | LineElseIf Deref | LineElse - | LineWith [(Deref, Ident)] - | LineMaybe Deref Ident + | 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) @@ -57,7 +64,7 @@ parseLine :: Parser (Int, Line) parseLine = do ss <- fmap sum $ many ((char ' ' >> return 1) <|> - (char '\t' >> return 4)) + (char '\t' >> fail "Tabs are not allowed in Hamlet indentation")) x <- comment <|> htmlComment <|> backslash <|> @@ -68,7 +75,10 @@ (try (string "$nothing") >> spaceTabs >> eol >> return LineNothing) <|> controlForall <|> controlWith <|> + controlCase <|> + controlOf <|> angle <|> + invalidDollar <|> (eol' >> return (LineContent [])) <|> (do cs <- content InContent @@ -80,7 +90,9 @@ where eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) eol = eof <|> eol' - spaceTabs = many $ oneOf " \t" + 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" @@ -117,7 +129,7 @@ eol return $ LineElseIf x binding = do - y <- ident + y <- identPattern spaces _ <- string "<-" spaces @@ -142,10 +154,24 @@ 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 -> char '"' >> return () + InQuotes -> void $ char '"' NotInQuotes -> return () NotInQuotesAttr -> return () InContent -> eol @@ -154,10 +180,15 @@ 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 + 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 @@ -168,40 +199,147 @@ 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>" + contentReg InQuotes = (ContentRaw . return) <$> noneOf "#@^\"\n\r" tagAttribValue notInQuotes = do cr <- (char '"' >> return InQuotes) <|> return notInQuotes content cr tagCond = do - _ <- char ':' - d <- parseDeref - _ <- char ':' + d <- between (char ':') (char ':') parseDeref tagAttrib (Just d) tagAttrib cond = do s <- many1 $ noneOf " \t=\r\n><" - v <- (do - _ <- char '=' - s' <- tagAttribValue NotInQuotesAttr - return s') <|> return [] + v <- (char '=' >> tagAttribValue NotInQuotesAttr) <|> 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 '\'') + + 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 <|> tagAttrib Nothing)) - _ <- many $ oneOf " \t" + (tagCond <|> tagAttrs <|> tagAttrib Nothing)) + _ <- many $ oneOf " \t\r\n" _ <- char '>' c <- content InContent - let (tn, attr) = tag' $ TagName name : xs - return $ LineTag tn attr c + 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 @@ -214,11 +352,12 @@ 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] +data Doc = DocForall Deref Binding [Doc] + | DocWith [(Deref, Binding)] [Doc] | DocCond [(Deref, [Doc])] (Maybe [Doc]) - | DocMaybe Deref Ident [Doc] (Maybe [Doc]) - | DocTag String [(Maybe Deref, String, [Content])] [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) @@ -248,10 +387,18 @@ _ -> return (Nothing, rest) rest'' <- nestToDoc rest' Ok $ DocMaybe d i inside' nothing : rest'' -nestToDoc (Nest (LineTag tn attrs content) inside:rest) = do +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 $ map DocContent content ++ inside') : rest' + Ok $ (DocTag tn attrs attrsD $ map DocContent content ++ inside') : rest' nestToDoc (Nest (LineContent content) inside:rest) = do inside' <- nestToDoc inside rest' <- nestToDoc rest @@ -259,6 +406,7 @@ 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 @@ -279,3 +427,21 @@ 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" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-hamlet-0.4.0.12/test/main.hs new/xml-hamlet-0.4.1/test/main.hs --- old/xml-hamlet-0.4.0.12/test/main.hs 2016-09-23 10:34:26.000000000 +0200 +++ new/xml-hamlet-0.4.1/test/main.hs 2017-01-16 16:34:29.000000000 +0100 @@ -59,11 +59,11 @@ it "handles attributes" $ [xml| <foo> <bar here=there> - <baz :False:false=false :True:true=#{true}> + <baz :False:false=false :True:true=#{true} *{attrs}> |] @?= [ 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") [] + [ X.NodeElement $ X.Element "baz" (Map.fromList (("true", "true") : attrs)) [] ] ] ] @@ -119,6 +119,34 @@ , 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 + <one> +$case justTrue + $of Just val + $if val + <two> + $of Nothing +$case (Just $ not False) + $of Nothing + $of Just val + $if val + <three> +$case Nothing + $of Just val + $of _ + <four> +|] @?= + [ 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") []] @@ -131,10 +159,12 @@ bin=bin>content |] @?= [xml|<foo bar=baz bin=bin>content|] it "short circuiting of attributes" $ [xml|<foo :False:x=#{undefined}>|] @?= [xml|<foo>|] + it "Hash in attribute value" $ [xml|<a href=#>|] @?= [xml|<a href="#">|] 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"] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/xml-hamlet-0.4.0.12/xml-hamlet.cabal new/xml-hamlet-0.4.1/xml-hamlet.cabal --- old/xml-hamlet-0.4.0.12/xml-hamlet.cabal 2016-09-23 10:34:26.000000000 +0200 +++ new/xml-hamlet-0.4.1/xml-hamlet.cabal 2017-01-16 16:34:29.000000000 +0100 @@ -1,5 +1,5 @@ Name: xml-hamlet -Version: 0.4.0.12 +Version: 0.4.1 Synopsis: Hamlet-style quasiquoter for XML content Homepage: http://www.yesodweb.com/ License: BSD3 @@ -9,7 +9,7 @@ Category: Text Build-type: Simple Description: Hamlet-style quasiquoter for XML content -Extra-source-files: test/main.hs +Extra-source-files: test/main.hs ChangeLog.md README.md Cabal-version: >=1.8
