diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs --- a/Text/Hamlet.hs +++ b/Text/Hamlet.hs @@ -24,6 +24,8 @@ , HtmlUrlI18n , ihamlet , ihamletFile + -- * Type classes + , ToAttributes (..) -- * Internal, for making more , HamletSettings , hamletWithSettings @@ -45,7 +47,33 @@ import Text.Blaze (Html, preEscapedText, toHtml) import qualified Data.Foldable as F import Control.Monad (mplus) +import Data.Monoid (mempty, mappend) +import Control.Arrow ((***)) +-- | Convert some value to a list of attribute pairs. +class ToAttributes a where + toAttributes :: a -> [(Text, Text)] +instance ToAttributes (Text, Text) where + toAttributes = return +instance ToAttributes (String, String) where + toAttributes (k, v) = [(pack k, pack v)] +instance ToAttributes [(Text, Text)] where + toAttributes = id +instance ToAttributes [(String, String)] where + toAttributes = map (pack *** pack) + +attrsToHtml :: [(Text, Text)] -> Html +attrsToHtml = + foldr go mempty + where + go (k, v) rest = + toHtml " " + `mappend` preEscapedText k + `mappend` preEscapedText (pack "=\"") + `mappend` toHtml v + `mappend` preEscapedText (pack "\"") + `mappend` rest + type Render url = url -> [(Text, Text)] -> Text type Translate msg = msg -> Html @@ -165,6 +193,9 @@ Nothing -> error "Message interpolation used, but no message renderer provided" Just wrender -> wrender $ \render -> return $ hrFromHtml hr `AppE` (render `AppE` derefToExp scope d) +contentToExp _ hr scope (ContentAttrs d) = do + html <- [|attrsToHtml . toAttributes|] + return $ hrFromHtml hr `AppE` (html `AppE` derefToExp scope d) shamlet :: QuasiQuoter shamlet = hamletWithSettings htmlRules defaultHamletSettings diff --git a/Text/Hamlet/Parse.hs b/Text/Hamlet/Parse.hs --- a/Text/Hamlet/Parse.hs +++ b/Text/Hamlet/Parse.hs @@ -22,7 +22,7 @@ import Text.ParserCombinators.Parsec hiding (Line) import Data.Set (Set) import qualified Data.Set as Set -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, fromMaybe) data Result v = Error String | Ok v deriving (Show, Eq, Read, Data, Typeable) @@ -42,6 +42,7 @@ | ContentUrl Bool Deref -- ^ bool: does it include params? | ContentEmbed Deref | ContentMsg Deref + | ContentAttrs Deref deriving (Show, Eq, Read, Data, Typeable) data Line = LineForall Deref Binding @@ -55,9 +56,10 @@ | LineOf [Ident] | LineTag { _lineTagName :: String - , _lineAttr :: [(Maybe Deref, String, [Content])] + , _lineAttr :: [(Maybe Deref, String, Maybe [Content])] , _lineContent :: [Content] , _lineClasses :: [(Maybe Deref, [Content])] + , _lineAttrs :: [Deref] } | LineContent [Content] deriving (Eq, Show, Read) @@ -236,15 +238,22 @@ tagClass (Just d) <|> tagAttrib (Just d) tagClass x = char '.' >> (TagClass . (,) x) <$> tagAttribValue NotInQuotes tagAttrib cond = do - s <- many1 $ noneOf " \t=\r\n>" - v <- (char '=' >> tagAttribValue NotInQuotesAttr) <|> return [] + s <- many1 $ noneOf " \t=\r\n><" + v <- (char '=' >> Just <$> tagAttribValue NotInQuotesAttr) <|> return Nothing return $ TagAttrib (cond, s, v) - tag' = foldr tag'' ("div", [], []) - tag'' (TagName s) (_, y, z) = (s, y, z) - tag'' (TagIdent s) (x, y, z) = (x, (Nothing, "id", s) : y, z) - tag'' (TagClass s) (x, y, z) = (x, y, s : z) - tag'' (TagAttrib s) (x, y, z) = (x, s : y, z) + tagAttrs = do + _ <- char '*' + d <- between (char '{') (char '}') parseDeref + return $ TagAttribs d + + tag' = foldr tag'' ("div", [], [], []) + tag'' (TagName s) (_, y, z, as) = (s, y, z, as) + tag'' (TagIdent s) (x, y, z, as) = (x, (Nothing, "id", Just s) : y, z, as) + tag'' (TagClass s) (x, y, z, as) = (x, y, s : z, as) + tag'' (TagAttrib s) (x, y, z, as) = (x, s : y, z, as) + tag'' (TagAttribs s) (x, y, z, as) = (x, y, z, s : as) + ident :: Parser Ident ident = Ident <$> many1 (alphaNum <|> char '_' <|> char '\'') @@ -264,19 +273,21 @@ _ <- char '<' name' <- many $ noneOf " \t.#\r\n!>" let name = if null name' then "div" else name' - xs <- many $ try ((many $ oneOf " \t") >> - (tagIdent <|> tagCond <|> tagClass Nothing <|> tagAttrib Nothing)) - _ <- many $ oneOf " \t" - c <- (eol >> return []) <|> (char '>' >> content InContent) - let (tn, attr, classes) = tag' $ TagName name : xs + xs <- many $ try ((many $ oneOf " \t\r\n") >> + (tagIdent <|> tagCond <|> tagClass Nothing <|> tagAttrs <|> tagAttrib Nothing)) + _ <- many $ oneOf " \t\r\n" + _ <- char '>' + c <- content InContent + let (tn, attr, classes, attrsd) = tag' $ TagName name : xs if '/' `elem` tn then fail "A tag name may not contain a slash. Perhaps you have a closing tag in your HTML." - else return $ LineTag tn attr c classes + else return $ LineTag tn attr c classes attrsd data TagPiece = TagName String | TagIdent [Content] | TagClass (Maybe Deref, [Content]) - | TagAttrib (Maybe Deref, String, [Content]) + | TagAttrib (Maybe Deref, String, Maybe [Content]) + | TagAttribs Deref deriving Show data ContentRule = InQuotes | NotInQuotes | NotInQuotesAttr | InContent @@ -330,9 +341,9 @@ cases <- mapM getOf inside rest' <- nestToDoc set rest Ok $ DocCase d cases : rest' -nestToDoc set (Nest (LineTag tn attrs content classes) inside:rest) = do +nestToDoc set (Nest (LineTag tn attrs content classes attrsD) inside:rest) = do let attrFix (x, y, z) = (x, y, [(Nothing, z)]) - let takeClass (a, "class", b) = Just (a, b) + let takeClass (a, "class", b) = Just (a, fromMaybe [] b) takeClass _ = Nothing let clazzes = classes ++ mapMaybe takeClass attrs let notClass (_, x, _) = x /= "class" @@ -340,7 +351,7 @@ let attrs' = case clazzes of [] -> map attrFix noclass - _ -> (Nothing, "class", clazzes) + _ -> (Nothing, "class", map (second Just) clazzes) : map attrFix noclass let closeStyle = if not (null content) || not (null inside) @@ -361,6 +372,7 @@ rest' <- nestToDoc set rest Ok $ start : attrs'' + ++ map (DocContent . ContentAttrs) attrsD ++ seal : map DocContent content ++ inside' @@ -408,12 +420,12 @@ ds <- nestToDoc set ns return $ compressDoc ds -attrToContent :: (Maybe Deref, String, [(Maybe Deref, [Content])]) -> [Doc] +attrToContent :: (Maybe Deref, String, [(Maybe Deref, Maybe [Content])]) -> [Doc] attrToContent (Just cond, k, v) = [DocCond [(cond, attrToContent (Nothing, k, v))] Nothing] attrToContent (Nothing, k, []) = [DocContent $ ContentRaw $ ' ' : k] -attrToContent (Nothing, k, [(Nothing, [])]) = [DocContent $ ContentRaw $ ' ' : k] -attrToContent (Nothing, k, [(Nothing, v)]) = +attrToContent (Nothing, k, [(Nothing, Nothing)]) = [DocContent $ ContentRaw $ ' ' : k] +attrToContent (Nothing, k, [(Nothing, Just v)]) = DocContent (ContentRaw (' ' : k ++ "=\"")) : map DocContent v ++ [DocContent $ ContentRaw "\""] @@ -423,16 +435,16 @@ ++ go' (last v) ++ [DocContent $ ContentRaw "\""] where - go (Nothing, x) = map DocContent x ++ [DocContent $ ContentRaw " "] + go (Nothing, x) = map DocContent (fromMaybe [] x) ++ [DocContent $ ContentRaw " "] go (Just b, x) = [ DocCond - [(b, map DocContent x ++ [DocContent $ ContentRaw " "])] + [(b, map DocContent (fromMaybe [] x) ++ [DocContent $ ContentRaw " "])] Nothing ] - go' (Nothing, x) = map DocContent x + go' (Nothing, x) = maybe [] (map DocContent) x go' (Just b, x) = [ DocCond - [(b, map DocContent x)] + [(b, maybe [] (map DocContent) x)] Nothing ] diff --git a/Text/Hamlet/RT.hs b/Text/Hamlet/RT.hs --- a/Text/Hamlet/RT.hs +++ b/Text/Hamlet/RT.hs @@ -83,6 +83,9 @@ return $ SDTemplate y convert (DocContent ContentMsg{}) = error "Runtime hamlet does not currently support message interpolation" + convert (DocContent ContentAttrs{}) = + error "Runtime hamlet does not currently support attrs interpolation" + convert x@(DocCond conds els) = do conds' <- mapM go conds els' <- maybe (return []) (mapM convert) els diff --git a/hamlet.cabal b/hamlet.cabal --- a/hamlet.cabal +++ b/hamlet.cabal @@ -1,14 +1,14 @@ name: hamlet -version: 0.10.9.1 +version: 1.0.0 license: BSD3 license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman synopsis: Haml-like template files that are compile-time checked description: - Hamlet gives you a type-safe tool for generating HTML code. It works via Quasi-Quoting, and generating extremely efficient output code. The syntax is white-space sensitive, and it helps you avoid cross-site scripting issues and 404 errors. Please see the documentation at for more details. + Hamlet gives you a type-safe tool for generating HTML code. It works via Quasi-Quoting, and generating extremely efficient output code. The syntax is white-space sensitive, and it helps you avoid cross-site scripting issues and 404 errors. Please see the documentation at for more details. . - Here is a quick overview of hamlet html. Due to haddock escaping issues, we can't properly show variable insertion, but we are still going to show some conditionals. Please see for a thorough description + Here is a quick overview of hamlet html. Due to haddock escaping issues, we can't properly show variable insertion, but we are still going to show some conditionals. Please see for a thorough description . > !!! > @@ -25,7 +25,7 @@ stability: Stable cabal-version: >= 1.8 build-type: Simple -homepage: http://www.yesodweb.com/book/templates +homepage: http://www.yesodweb.com/book/shakespearean-templates extra-source-files: test/hamlets/double-foralls.hamlet test/hamlets/external-debug.hamlet @@ -41,14 +41,14 @@ library build-depends: base >= 4 && < 5 - , shakespeare >= 0.10.2 && < 0.12 + , shakespeare >= 1.0 && < 1.1 , bytestring >= 0.9 && < 0.10 , template-haskell , blaze-html >= 0.4 && < 0.5 , parsec >= 2 && < 4 , failure >= 0.1 && < 0.3 , text >= 0.7 && < 0.12 - , containers >= 0.2 && < 0.5 + , containers >= 0.2 , blaze-builder >= 0.2 && < 0.4 , process >= 1.0 && < 1.2 exposed-modules: Text.Hamlet @@ -64,7 +64,7 @@ type: exitcode-stdio-1.0 ghc-options: -Wall - build-depends: hamlet >= 0.10 && < 0.11 + build-depends: hamlet , base >= 4 && < 5 , parsec >= 2 && < 4 , containers >= 0.2 && < 0.5 diff --git a/test/HamletTest.hs b/test/HamletTest.hs --- a/test/HamletTest.hs +++ b/test/HamletTest.hs @@ -83,7 +83,7 @@ , it "ignores a blank line" $ do helper "

foo

" [hamlet| -

foo @@ -96,7 +96,7 @@ , it "hamlet angle bracket syntax" $ helper "

HELLO

" [hamlet| - HELLO |] @@ -158,7 +158,7 @@ helper "

1

2 not ignored

" [hamlet|

1 -

2 not ignored |] @@ -192,13 +192,13 @@ , it "conditional class" $ do helper "

" - [hamlet|

|] helper "

" - [hamlet|

|] helper "

" - [hamlet|

|] @@ -265,10 +265,12 @@ $forall num <- [1, 2, 3]

  • #{show num} |] +{- , it "infix operators" $ helper "5" [hamlet|#{show $ (4 + 5) - (2 + 2)}|] , it "infix operators with parens" $ helper "5" [hamlet|#{show (2 + 3)}|] + -} , it "doctypes" $ helper "\n\n" [hamlet| $doctype 5 $doctype strict @@ -338,6 +340,20 @@
    #{name}
    #{show age} |] + + , it "multiline tags" $ helper + "content" [hamlet| +content +|] + , let attrs = [("bar", "baz"), ("bin", "<>\"&")] + in it "*{...} attributes" $ helper + "content" [hamlet| +content +|] + , it "blank attr values" $ helper + "" + [hamlet||] ] data Pair = Pair String Int @@ -425,11 +441,11 @@ caseTag :: Assertion caseTag = do helper "

    baz

    " [hamlet| -

    <#bar>baz |] helper "

    baz

    " [hamlet| -

    <#bar>baz |] @@ -560,30 +576,23 @@ |] caseScriptNotEmpty :: Assertion -caseScriptNotEmpty = helper "" [hamlet|" [hamlet|