diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs --- a/Text/Hamlet.hs +++ b/Text/Hamlet.hs @@ -2,6 +2,9 @@ ( -- * Basic quasiquoters hamlet , xhamlet + , hamlet' + , xhamlet' + , hamletDebug -- * Load from external file , hamletFile , xhamletFile @@ -10,6 +13,7 @@ , hamletFileWithSettings , HamletSettings (..) , defaultHamletSettings + , xhtmlHamletSettings -- * Datatypes , Html , Hamlet @@ -20,10 +24,17 @@ , string , unsafeByteString , cdata + -- * Runtime Hamlet + , HamletRT + , HamletData (..) + , HamletException (..) + , parseHamletRT + , renderHamletRT ) where import Text.Hamlet.Parse import Text.Hamlet.Quasi +import Text.Hamlet.RT import Text.Blaze import qualified Data.ByteString.Lazy as L import Data.Monoid (mappend) diff --git a/Text/Hamlet/Parse.hs b/Text/Hamlet/Parse.hs --- a/Text/Hamlet/Parse.hs +++ b/Text/Hamlet/Parse.hs @@ -8,6 +8,8 @@ , parseDoc , HamletSettings (..) , defaultHamletSettings + , xhtmlHamletSettings + , debugHamletSettings ) where @@ -265,6 +267,8 @@ _ -> DocContent $ ContentRaw ">" start = DocContent $ ContentRaw $ "<" ++ tn attrs'' = concatMap attrToContent attrs' + newline' = DocContent $ ContentRaw + $ if hamletCloseNewline set then "\n" else "" inside' <- nestToDoc set inside rest' <- nestToDoc set rest Ok $ start @@ -273,6 +277,7 @@ : map DocContent content ++ inside' ++ end + : newline' : rest' nestToDoc set (Nest (LineContent content) inside:rest) = do inside' <- nestToDoc set inside @@ -326,11 +331,24 @@ -- | 'True' means to close empty tags (eg, img) with a trailing slash, ie -- XML-style empty tags. 'False' uses HTML-style. , hamletCloseEmpties :: Bool + -- | Should we put a newline after closing a tag? + , hamletCloseNewline :: Bool } -- | Defaults settings: HTML5 doctype and HTML-style empty tags. defaultHamletSettings :: HamletSettings -defaultHamletSettings = HamletSettings "" False +defaultHamletSettings = HamletSettings "" False False + +xhtmlHamletSettings :: HamletSettings +xhtmlHamletSettings = + HamletSettings doctype True False + where + doctype = + "" + +debugHamletSettings :: HamletSettings +debugHamletSettings = HamletSettings "" False True data CloseStyle = NoClose | CloseInside | CloseSeparate diff --git a/Text/Hamlet/Quasi.hs b/Text/Hamlet/Quasi.hs --- a/Text/Hamlet/Quasi.hs +++ b/Text/Hamlet/Quasi.hs @@ -4,10 +4,15 @@ module Text.Hamlet.Quasi ( hamlet , xhamlet + , hamlet' + , xhamlet' + , hamletDebug , hamletWithSettings + , hamletWithSettings' , hamletFile , xhamletFile , hamletFileWithSettings + , showParams ) where import Text.Hamlet.Parse @@ -101,16 +106,25 @@ let d' = deref scope d return (d' `AppE` render) +-- | Calls 'hamletWithSettings'' with 'defaultHamletSettings'. +hamlet' :: QuasiQuoter +hamlet' = hamletWithSettings' defaultHamletSettings + +-- | Calls 'hamletWithSettings'' using XHTML 1.0 Strict settings. +xhamlet' :: QuasiQuoter +xhamlet' = hamletWithSettings' xhtmlHamletSettings + -- | Calls 'hamletWithSettings' with 'defaultHamletSettings'. hamlet :: QuasiQuoter hamlet = hamletWithSettings defaultHamletSettings +-- | Calls 'hamletWithSettings' with 'debugHamletSettings'. +hamletDebug :: QuasiQuoter +hamletDebug = hamletWithSettings debugHamletSettings + -- | Calls 'hamletWithSettings' using XHTML 1.0 Strict settings. xhamlet :: QuasiQuoter -xhamlet = hamletWithSettings $ HamletSettings doctype True where - doctype = - "" +xhamlet = hamletWithSettings xhtmlHamletSettings -- | A quasi-quoter that converts Hamlet syntax into a function of form: -- @@ -122,6 +136,17 @@ QuasiQuoter (hamletFromString set) $ error "Cannot quasi-quote Hamlet to patterns" +-- | A quasi-quoter that converts Hamlet syntax into a 'Html' (). +-- +-- Please see accompanying documentation for a description of Hamlet syntax. +hamletWithSettings' :: HamletSettings -> QuasiQuoter +hamletWithSettings' set = + QuasiQuoter (\s -> do + x <- hamletFromString set s + id' <- [|id|] + return $ x `AppE` id') + $ error "Cannot quasi-quote Hamlet to patterns" + hamletFromString :: HamletSettings -> String -> Q Exp hamletFromString set s = do case parseDoc set s of @@ -142,12 +167,7 @@ -- | Calls 'hamletFileWithSettings' using XHTML 1.0 Strict settings. xhamletFile :: FilePath -> Q Exp -xhamletFile = - hamletFileWithSettings $ HamletSettings doctype True - where - doctype = - "" +xhamletFile = hamletFileWithSettings xhtmlHamletSettings deref :: Scope -> Deref -> Exp deref scope (DerefBranch x y) = @@ -197,8 +217,11 @@ outputUrlParams render (u, params) = mappend (outputUrl render u) (string $ showParams params) + +showParams :: [(String, String)] -> String +showParams z = + '?' : intercalate "&" (map go z) where - showParams x = '?' : intercalate "&" (map go x) go (x, y) = go' x ++ '=' : go' y go' = concatMap encodeUrlChar diff --git a/Text/Hamlet/RT.hs b/Text/Hamlet/RT.hs new file mode 100644 --- /dev/null +++ b/Text/Hamlet/RT.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- | Most everything exported here is exported also by "Text.Hamlet". The +-- exceptions to that rule should not be necessary for normal usage. +module Text.Hamlet.RT + ( -- * Public API + HamletRT (..) + , HamletData (..) + , HamletException (..) + , parseHamletRT + , renderHamletRT + , SimpleDoc (..) + ) where + +import Data.Monoid (mconcat) +import Control.Monad (liftM, forM) +import Control.Exception (Exception) +import Data.Typeable (Typeable) +import Control.Failure +import Text.Blaze +import Text.Hamlet.Parse +import Text.Hamlet.Quasi (showParams) +import Data.List (intercalate) + +data HamletData url = HDHtml (Html ()) + | HDUrl url + | HDUrlParams url [(String, String)] + | HDTemplate HamletRT + | HDBool Bool + | HDMaybe (Maybe (HamletData url)) + | HDList [HamletData url] + | HDMap [(String, HamletData url)] + +data SimpleDoc = SDRaw String + | SDVar [String] + | SDUrl Bool [String] + | SDTemplate [String] + | SDForall [String] String [SimpleDoc] + | SDMaybe [String] String [SimpleDoc] [SimpleDoc] + | SDCond [([String], [SimpleDoc])] [SimpleDoc] + +newtype HamletRT = HamletRT [SimpleDoc] + +data HamletException = HamletParseException String + | HamletUnsupportedDocException Doc + | HamletRenderException String + deriving (Show, Typeable) +instance Exception HamletException + +parseHamletRT :: Failure HamletException m + => HamletSettings -> String -> m HamletRT +parseHamletRT set s = + case parseDoc set s of + Error s' -> failure $ HamletParseException s' + Ok x -> liftM HamletRT $ mapM convert x + where + convert x@(DocForall deref (Ident ident) docs) = do + deref' <- flattenDeref x deref + docs' <- mapM convert docs + return $ SDForall deref' ident docs' + convert x@(DocMaybe deref (Ident ident) jdocs ndocs) = do + deref' <- flattenDeref x deref + jdocs' <- mapM convert jdocs + ndocs' <- maybe (return []) (mapM convert) ndocs + return $ SDMaybe deref' ident jdocs' ndocs' + convert (DocContent (ContentRaw s')) = return $ SDRaw s' + convert x@(DocContent (ContentVar deref)) = do + y <- flattenDeref x deref + return $ SDVar y + convert x@(DocContent (ContentUrl p deref)) = do + y <- flattenDeref x deref + return $ SDUrl p y + convert x@(DocContent (ContentEmbed deref)) = do + y <- flattenDeref x deref + return $ SDTemplate y + convert x@(DocCond conds els) = do + conds' <- mapM go conds + els' <- maybe (return []) (mapM convert) els + return $ SDCond conds' els' + where + go (deref, docs') = do + deref' <- flattenDeref x deref + docs'' <- mapM convert docs' + return (deref', docs'') + flattenDeref _ (DerefLeaf (Ident x)) = return [x] + flattenDeref orig (DerefBranch (DerefLeaf (Ident x)) y) = do + y' <- flattenDeref orig y + return $ x : y' + flattenDeref orig _ = failure $ HamletUnsupportedDocException orig + +renderHamletRT :: Failure HamletException m + => HamletRT + -> HamletData url + -> (url -> String) + -> m (Html ()) +renderHamletRT (HamletRT docs) (HDMap scope0) renderUrl = + liftM mconcat $ mapM (go scope0) docs + where + go _ (SDRaw s) = return $ preEscapedString s + go scope (SDVar n) = do + v <- lookup' n n $ HDMap scope + case v of + HDHtml h -> return h + _ -> fa $ intercalate "." n ++ ": expected HDHtml" + go scope (SDUrl p n) = do + v <- lookup' n n $ HDMap scope + case (p, v) of + (False, HDUrl u) -> return $ preEscapedString $ renderUrl u + (True, HDUrlParams u q) -> + return $ preEscapedString $ renderUrl u ++ showParams q + (False, _) -> fa $ intercalate "." n ++ ": expected HDUrl" + (True, _) -> fa $ intercalate "." n ++ ": expected HDUrlParams" + go scope (SDTemplate n) = do + v <- lookup' n n $ HDMap scope + case v of + HDTemplate h -> renderHamletRT h (HDMap scope) renderUrl + _ -> fa $ intercalate "." n ++ ": expected HDTemplate" + go scope (SDForall n ident docs') = do + v <- lookup' n n $ HDMap scope + case v of + HDList os -> do + liftM mconcat $ forM os $ \o -> do + let scope' = HDMap $ (ident, o) : scope + renderHamletRT (HamletRT docs') scope' renderUrl + _ -> fa $ intercalate "." n ++ ": expected HDList" + go scope (SDMaybe n ident jdocs ndocs) = do + v <- lookup' n n $ HDMap scope + (scope', docs') <- + case v of + HDMaybe Nothing -> return (scope, ndocs) + HDMaybe (Just o) -> return ((ident, o) : scope, jdocs) + _ -> fa $ intercalate "." n ++ ": expected HDMaybe" + renderHamletRT (HamletRT docs') (HDMap scope') renderUrl + go scope (SDCond [] docs') = + renderHamletRT (HamletRT docs') (HDMap scope) renderUrl + go scope (SDCond ((b, docs'):cs) els) = do + v <- lookup' b b $ HDMap scope + case v of + HDBool True -> + renderHamletRT (HamletRT docs') (HDMap scope) renderUrl + HDBool False -> go scope (SDCond cs els) + _ -> fa $ intercalate "." b ++ ": expected HDBool" + lookup' _ [] x = return x + lookup' orig (n:ns) (HDMap m) = + case lookup n m of + Nothing -> fa $ intercalate "." orig ++ " not found" + Just o -> lookup' orig ns o + lookup' orig _ _ = fa $ intercalate "." orig ++ ": unexpected type" + fa = failure . HamletRenderException +renderHamletRT _ _ _ = + failure $ HamletRenderException "renderHamletRT must be given a HDMap" diff --git a/hamlet.cabal b/hamlet.cabal --- a/hamlet.cabal +++ b/hamlet.cabal @@ -1,5 +1,5 @@ name: hamlet -version: 0.4.1 +version: 0.4.2 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -44,8 +44,10 @@ utf8-string >= 0.3.4 && < 0.4, template-haskell, blaze-html >= 0.1.1 && < 0.2, - parsec >= 2 && < 4 + parsec >= 2 && < 4, + failure >= 0.1.0 && < 0.2 exposed-modules: Text.Hamlet + Text.Hamlet.RT other-modules: Text.Hamlet.Parse Text.Hamlet.Quasi ghc-options: -Wall diff --git a/runtests.hs b/runtests.hs --- a/runtests.hs +++ b/runtests.hs @@ -56,6 +56,9 @@ , testCase "currency symbols" caseCurrency , testCase "external" caseExternal , testCase "parens" caseParens + , testCase "hamlet' and xhamlet'" caseHamlet' + , testCase "hamletDebug" caseHamletDebug + , testCase "hamlet runtime" caseHamletRT ] data Url = Home | Sub SubUrl @@ -354,7 +357,7 @@ where users = ["1", "2"] name = "foo" - val = 5 + val = 5 :: Int isBoolBlank _ = True isBoolTrue _ = False isBoolFalse _ = False @@ -384,8 +387,74 @@ helper "xy" [$hamlet|$(plus x) y$|] helper "xy" [$hamlet|$(plus.x).y$|] helper "xxy" [$hamlet|$(plus (plus x).x).y$|] - let list = ["1", "2", "3"] + let alist = ["1", "2", "3"] helper "123" [$hamlet| -$forall (id id.id id.list) x +$forall (id id.id id.alist) x $x$ |] + +helper' :: String -> Html ()-> Assertion +helper' res h = do + let x = renderHtml h + res @=? toString x + +caseHamlet' :: Assertion +caseHamlet' = do + helper' "foo" [$hamlet'|foo|] + helper' "foo" [$xhamlet'|foo|] + +caseHamletDebug :: Assertion +caseHamletDebug = do + helper "

foo

\n

bar

\n" [$hamletDebug| +%p foo +%p bar +|] + +caseHamletRT :: Assertion +caseHamletRT = do + temp <- parseHamletRT defaultHamletSettings "$var$" + rt <- parseHamletRT defaultHamletSettings $ + unlines + [ "$foo.bar.baz$ bin $" + , "$forall list l" + , " $l$" + , "$maybe just j" + , " $j$" + , "$maybe nothing n" + , "$nothing" + , " nothing" + , "^template^" + , "@url@" + , "$if false" + , "$elseif false" + , "$elseif true" + , " a" + , "$if false" + , "$else" + , " b" + , "@?urlp@" + ] + let scope = + HDMap + [ ("foo", HDMap + [ ("bar", HDMap + [ ("baz", HDHtml $ preEscapedString "foobaz") + ]) + ]) + , ("list", HDList + [ HDHtml $ string "1" + , HDHtml $ string "2" + , HDHtml $ string "3" + ]) + , ("just", HDMaybe $ Just $ HDHtml $ string "just") + , ("nothing", HDMaybe Nothing) + , ("template", HDTemplate temp) + , ("var", HDHtml $ string "var") + , ("url", HDUrl Home) + , ("urlp", HDUrlParams Home [("foo", "bar")]) + , ("true", HDBool True) + , ("false", HDBool False) + ] + rend <- renderHamletRT rt scope render + toString (renderHtml rend) @?= + "foobaz bin 123justnothingvarurlaburl?foo=bar"