hamlet 0.2.3.1 → 0.3.0

raw patch · 6 files changed

+255/−650 lines, 6 filesdep +blaze-htmldep +bytestringdep +utf8-stringdep −textPVP ok

version bump matches the API change (PVP)

Dependencies added: blaze-html, bytestring, utf8-string

Dependencies removed: text

API changes (from Hackage documentation)

Files

• Text/Hamlet.hs +32/−7
• Text/Hamlet/Monad.hs +0/−260
• Text/Hamlet/Parse.hs +41/−51
• Text/Hamlet/Quasi.hs +134/−196
• hamlet.cabal +6/−5
• runtests.hs +42/−131

@@ -1,16 +1,41 @@ module Text.Hamlet-    ( hamlet+    ( -- * Basic quasiquoters+      hamlet     , xhamlet+      -- * Build customized quasiquoters     , hamletWithSettings     , HamletSettings (..)     , defaultHamletSettings-    , Hamlet (..)-    , HtmlContent (..)-    , printHamlet-    , Enumerator (..)-    , fromList+      -- * Datatypes+    , Html+    , Hamlet+      -- * Construction/rendering+    , renderHamlet+    , renderHtml+    , preEscapedString+    , string+    , unsafeByteString+    , cdata     ) where -import Text.Hamlet.Monad import Text.Hamlet.Parse import Text.Hamlet.Quasi+import Text.Blaze+import qualified Data.ByteString.Lazy as L+import Data.Monoid (mappend)++-- | An function generating an 'Html' given a URL-rendering function.+type Hamlet url = (url -> String) -> Html ()++-- | Converts a 'Hamlet' to lazy bytestring.+renderHamlet :: (url -> String) -> Hamlet url -> L.ByteString+renderHamlet render h = renderHtml $ h render++-- | Wrap an 'Html' for embedding in an XML file.+cdata :: Html () -> Html ()+cdata h =+    preEscapedString "<![CDATA["+    `mappend`+    h+    `mappend`+    preEscapedString "]]>"

@@ -1,260 +0,0 @@-{-# LANGUAGE RankNTypes #-}-module Text.Hamlet.Monad-    ( -- * Generalized enumerator-      Iteratee-    , Enumerator (..)-    , fromList-      -- * Datatypes-    , Hamlet (..)-    , HtmlContent (..)-      -- * Output-    , output-    , outputHtml-    , outputString-    , outputUrl-    , outputUrlParams-    , outputEmbed-      -- * Utility functions-    , htmlContentToText-    , showUrl-    , liftHamlet-    , mapH-    , condH-    , maybeH-    , maybeH'-    , printHamlet-    , hamletToText-    , cdata-    ) where--import Data.Text (Text, pack)-import qualified Data.Text as S-import qualified Data.Text.Lazy as L-import qualified Data.Text.IO as T-import Control.Applicative-import Control.Monad-import Data.Monoid-import Data.List---- | Something to be run for each val. Returns 'Left' when enumeration should--- terminate immediately, 'Right' when it can receive more input.-type Iteratee val seed m = seed -> val -> m (Either seed seed)---- | Generates a stream of values to be passed to an 'Iteratee'.-newtype Enumerator val m = Enumerator-    { runEnumerator :: forall seed.-        Iteratee val seed m -> seed-     -> m (Either seed seed)-    }---- | Convert a list into an 'Enumerator'.-fromList :: Monad m => [a] -> Enumerator a m-fromList x = Enumerator $ go x where-    go [] _ seed = return $ Right seed-    go (l:ls) iter seed = do-        ea <- iter seed l-        case ea of-            Left seed' -> return $ Left seed'-            Right seed' -> go ls iter seed'---- | 'Hamlet' is a monad that has two features:------ * It passes along a function to convert a URL to a 'String'.------ * It keeps an 'Iteratee' and a seed value so that it can output values.--- Output is all done through a strict 'Text' value.------ The URL to String function makes it very convenient to write templates--- without knowing the absolute URLs for all referenced resources. For more--- information on this approach, please see the web-routes package.------ For efficiency, the 'Hamlet' monad halts execution as soon as the underlying--- 'Iteratee' returns a 'Left' value. This is normally what you want; this--- might cause a problem if you are relying on the side effects of a 'Hamlet'--- action. However, it is not recommended to rely on side-effects. Though a--- 'Hamlet' monad may perform IO actions, this should only be used for--- read-only behavior for efficiency.-newtype Hamlet url m a = Hamlet-    { runHamlet :: forall seed.-       (url -> String)-    -> seed-    -> Iteratee Text seed m-    -> m (Either seed (a, seed))-    }--instance Monad m => Monad (Hamlet url m) where-    return x = Hamlet $ \_ seed _ -> return (Right (x, seed))-    (Hamlet f) >>= g = Hamlet go where-        go a c d = f a c d >>= go' a d-        go' _ _ (Left seed) = return $ Left seed-        go' a d (Right (v, seed)) = runHamlet (g v) a seed d-instance Monad m => Functor (Hamlet url m) where-    fmap = liftM-instance Monad m => Applicative (Hamlet url m) where-    pure = return-    (<*>) = ap---- | Directly output strict 'Text' without any escaping.-output :: Monad m => Text -> Hamlet url m ()-output bs = Hamlet go where-    go _ seed iter = do-        ea <- iter seed bs-        case ea of-            Left seed' -> return $ Left seed'-            Right seed' -> return $ Right ((), seed')---- | Content for an HTML document. 'Encoded' content should not be entity--- escaped; 'Unencoded' should be.-data HtmlContent = Encoded Text | Unencoded Text-    deriving (Eq, Show, Read)-instance Monoid HtmlContent where-    mempty = Encoded mempty-    mappend x y = Encoded $ mappend (htmlContentToText x)-                                    (htmlContentToText y)---- | Wrap some 'HtmlContent' for embedding in an XML file.-cdata :: HtmlContent -> HtmlContent-cdata h = mconcat-    [ Encoded $ pack "<![CDATA["-    , h-    , Encoded $ pack "]]>"-    ]---- | Outputs the given 'HtmlContent', entity encoding any 'Unencoded' data.-outputHtml :: Monad m => HtmlContent -> Hamlet url m ()-outputHtml = output . htmlContentToText---- | 'pack' a 'String' and call 'output'; this will not perform any escaping.-outputString :: Monad m => String -> Hamlet url m ()-outputString = output . pack---- | Uses the URL rendering function to convert the given URL to a 'String' and--- then calls 'outputString'.-outputUrl :: Monad m => url -> Hamlet url m ()-outputUrl u = showUrl u >>= outputString---- | Same as 'outputUrl', but appends a query-string with given keys and--- values.-outputUrlParams :: Monad m => (url, [(String, String)]) -> Hamlet url m ()-outputUrlParams (u, []) = outputUrl u-outputUrlParams (u, params) = do-    outputUrl u-    outputString $ showParams params-  where-    showParams x = '?' : intercalate "&" (map go x)-    go (x, y) = go' x ++ '=' : go' y-    go' = concatMap encodeUrlChar---- | Taken straight from web-encodings; reimplemented here to avoid extra--- dependencies.-encodeUrlChar :: Char -> String-encodeUrlChar c-    -- List of unreserved characters per RFC 3986-    -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding-    | 'A' <= c && c <= 'Z' = [c]-    | 'a' <= c && c <= 'z' = [c]-    | '0' <= c && c <= '9' = [c]-encodeUrlChar c@'-' = [c]-encodeUrlChar c@'_' = [c]-encodeUrlChar c@'.' = [c]-encodeUrlChar c@'~' = [c]-encodeUrlChar ' ' = "+"-encodeUrlChar y =-    let (a, c) = fromEnum y `divMod` 16-        b = a `mod` 16-        showHex' x -- FIXME just use Numeric version?-            | x < 10 = toEnum $ x + (fromEnum '0')-            | x < 16 = toEnum $ x - 10 + (fromEnum 'A')-            | otherwise = error $ "Invalid argument to showHex: " ++ show x-     in ['%', showHex' b, showHex' c]---- | Only really used to ensure that the argument has the right type.-outputEmbed :: Monad m => Hamlet url m () -> Hamlet url m ()-outputEmbed = id---- | Use the URL to 'String' rendering function to convert a URL to a 'String'.-showUrl :: Monad m => url -> Hamlet url m String-showUrl url = Hamlet $ \s seed _ -> return (Right (s url, seed))---- | Lift a monadic action into the 'Hamlet' monad.-liftHamlet :: Monad m => m a -> Hamlet url m a-liftHamlet m = Hamlet $ \_ c _ -> m >>= \m' -> return (Right (m', c))---- | Perform the given 'Hamlet' action for all values generated by the given--- 'Enumerator'.-mapH :: Monad m-     => (val -> Hamlet url m ())-     -> Enumerator val m-     -> Hamlet url m ()-mapH each (Enumerator e) = Hamlet go where-    go surl seed iter = do-        res <- e (iter' surl iter) seed-        case res of-            Left seed' -> return $ Left seed'-            Right seed' -> return $ Right ((), seed')-    iter' surl iter seed val = do-        res <- runHamlet (each val) surl seed iter-        case res of-            Left seed' -> return $ Left seed'-            Right ((), seed') -> return $ Right seed'---- | Checks for truth in the left value in each pair in the first argument. If--- a true exists, then the corresponding right action is performed. Only the--- first is performed. In there are no true values, then the second argument is--- performed, if supplied.-condH :: Monad m-      => [(m Bool, Hamlet url m ())]-      -> Maybe (Hamlet url m ())-      -> Hamlet url m ()-condH [] Nothing = return ()-condH [] (Just x) = x-condH ((x, y):rest) z = do-    x' <- liftHamlet x-    if x' then y else condH rest z---- | Runs the second argument with the value in the first, if available.-maybeH :: Monad m-       => Maybe v-       -> (v -> Hamlet url m ())-       -> Hamlet url m ()-maybeH Nothing _ = return ()-maybeH (Just v) f = f v---- | Runs the second argument with the value in the first, if available.--- Otherwise, runs the third argument, if available.-maybeH' :: Monad m-        => Maybe v-        -> (v -> Hamlet url m ())-        -> Maybe (Hamlet url m ())-        -> Hamlet url m ()-maybeH' Nothing _ Nothing = return ()-maybeH' Nothing _ (Just x) = x-maybeH' (Just v) f _ = f v---- | Prints a Hamlet to standard out. Good for debugging.-printHamlet :: (url -> String) -> Hamlet url IO () -> IO ()-printHamlet render h = runHamlet h render () iter >> return () where-    iter () text = do-        T.putStr text-        return $ Right ()---- | Converts a 'Hamlet' to lazy text, using strict I/O.-hamletToText :: Monad m => (url -> String) -> Hamlet url m () -> m L.Text-hamletToText render h = do-    Right ((), front) <- runHamlet h render id iter-    return $ L.fromChunks $ front []-  where-    iter front text = return $ Right $ front . (:) text---- | Returns HTML-ready text (ie, all entities are escaped properly).-htmlContentToText :: HtmlContent -> Text-htmlContentToText (Encoded t) = t-htmlContentToText (Unencoded t) = S.concatMap (pack . encodeHtmlChar) t--encodeHtmlChar :: Char -> String-encodeHtmlChar '<' = "&lt;"-encodeHtmlChar '>' = "&gt;"-encodeHtmlChar '&' = "&amp;"-encodeHtmlChar '"' = "&quot;"-encodeHtmlChar '\'' = "&#39;"-encodeHtmlChar c = [c]

@@ -40,7 +40,7 @@     pure = return     (<*>) = ap -newtype Deref = Deref [(Bool, Ident)] -- ^ is monadic, ident+newtype Deref = Deref [Ident] -- ^ is monadic, ident     deriving (Show, Eq, Read, Data, Typeable) newtype Ident = Ident String     deriving (Show, Eq, Read, Data, Typeable)@@ -89,7 +89,7 @@     case words rest of         [x, y] -> do             x' <- parseDeref x-            (False, y') <- parseIdent' False y+            y' <- parseIdent y             return $ LineForall x' y'         _ -> Error $ "Invalid forall: " ++ rest parseLine _ ('$':'i':'f':' ':rest) = LineIf <$> parseDeref rest@@ -100,7 +100,7 @@     case words rest of         [x, y] -> do             x' <- parseDeref x-            (False, y') <- parseIdent' False y+            y' <- parseIdent y             return $ LineMaybe x' y'         _ -> Error $ "Invalid maybe: " ++ rest parseLine _ "$nothing" = Ok LineNothing@@ -114,7 +114,7 @@  #if TEST fooBar :: Deref-fooBar = Deref [(False, Ident "bar"), (False, Ident "foo")]+fooBar = Deref [Ident "bar", Ident "foo"]  caseParseLine :: Assertion caseParseLine = do@@ -141,7 +141,7 @@         @?= Ok (LineContent [ContentRaw "\n"])     parseLine' "%img!:baz:src=@foo.bar@"         @?= Ok (LineTag "img"-                [(Just $ Deref [(False, Ident "baz")],+                [(Just $ Deref [Ident "baz"],                   "src",                   [ContentUrl False fooBar])] [] []) #endif@@ -180,21 +180,21 @@     parseContent "" @?= Ok []     parseContent "foo" @?= Ok [ContentRaw "foo"]     parseContent "foo $bar$ baz" @?= Ok [ ContentRaw "foo "-                                        , ContentVar $ Deref [(False, Ident "bar")]+                                        , ContentVar $ Deref [Ident "bar"]                                         , ContentRaw " baz"                                         ]     parseContent "foo @bar@ baz" @?=         Ok [ ContentRaw "foo "-           , ContentUrl False (Deref [(False, Ident "bar")])+           , ContentUrl False (Deref [Ident "bar"])            , ContentRaw " baz"            ]     parseContent "foo @?bar@ baz" @?=         Ok [ ContentRaw "foo "-           , ContentUrl True (Deref [(False, Ident "bar")])+           , ContentUrl True (Deref [Ident "bar"])            , ContentRaw " baz"            ]     parseContent "foo ^bar^ baz" @?= Ok [ ContentRaw "foo "-                                        , ContentEmbed $ Deref [(False, Ident "bar")]+                                        , ContentEmbed $ Deref [Ident "bar"]                                         , ContentRaw " baz"                                         ]     parseContent "@@" @?= Ok [ContentRaw "@"]@@ -215,28 +215,22 @@ #if TEST caseParseDeref :: Assertion caseParseDeref = do-    parseDeref "baz.*bar.foo" @?=-        Ok (Deref [ (False, Ident "foo")-                  , (True, Ident "bar")-                  , (False, Ident "baz")])+    parseDeref "baz.bar.foo" @?=+        Ok (Deref [ Ident "foo"+                  , Ident "bar"+                  , Ident "baz"]) #endif -parseIdent :: String -> Result (Bool, Ident)-parseIdent ('*':s) = parseIdent' True s-parseIdent s = parseIdent' False s--parseIdent' :: Bool -> String -> Result (Bool, Ident)-parseIdent' _ "" = Error "Invalid empty ident"-parseIdent' b s+parseIdent :: String -> Result Ident+parseIdent "" = Error "Invalid empty ident"+parseIdent s     | all (flip elem (['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'")) s-        = Ok (b, Ident s)+        = Ok $ Ident s     | otherwise = Error $ "Invalid identifier: " ++ s  #if TEST caseParseIdent :: Assertion-caseParseIdent = do-    parseIdent "foo" @?= Ok (False, Ident "foo")-    parseIdent "*foo" @?= Ok (True, Ident "foo")+caseParseIdent = parseIdent "foo" @?= Ok (Ident "foo") #endif  parseTag :: String -> Result@@ -301,7 +295,7 @@ data Doc = DocForall Deref Ident [Doc]          | DocCond [(Deref, [Doc])] (Maybe [Doc])          | DocMaybe Deref Ident [Doc] (Maybe [Doc])-         | DocContent [Content]+         | DocContent Content     deriving (Show, Eq, Read, Data, Typeable)  nestToDoc :: HamletSettings -> [Nest] -> Result [Doc]@@ -337,26 +331,26 @@                 else closeTag set tn     let end = case closeStyle of                 CloseSeparate ->-                    DocContent [ContentRaw $ "</" ++ tn ++ ">"]-                _ -> DocContent []+                    DocContent $ ContentRaw $ "</" ++ tn ++ ">"+                _ -> DocContent $ ContentRaw ""         seal = case closeStyle of-                 CloseInside -> DocContent [ContentRaw "/>"]-                 _ -> DocContent [ContentRaw ">"]-        start = DocContent [ContentRaw $ "<" ++ tn]-        attrs'' = map attrToContent attrs'+                 CloseInside -> DocContent $ ContentRaw "/>"+                 _ -> DocContent $ ContentRaw ">"+        start = DocContent $ ContentRaw $ "<" ++ tn+        attrs'' = concatMap attrToContent attrs'     inside' <- nestToDoc set inside     rest' <- nestToDoc set rest     Ok $ start        : attrs''       ++ seal-       : DocContent content-       : inside'+       : map DocContent content+      ++ inside'       ++ end        : rest' nestToDoc set (Nest (LineContent content) inside:rest) = do     inside' <- nestToDoc set inside     rest' <- nestToDoc set rest-    Ok $ DocContent content : inside' ++ rest'+    Ok $ map DocContent content ++ inside' ++ rest' nestToDoc _set (Nest (LineElseIf _) _:_) = Error "Unexpected elseif" nestToDoc _set (Nest LineElse _:_) = Error "Unexpected else" nestToDoc _set (Nest LineNothing _:_) = Error "Unexpected nothing"@@ -373,17 +367,12 @@ compressDoc (DocCond x y:rest) =     DocCond (map (second compressDoc) x) (compressDoc `fmap` y)     : compressDoc rest-compressDoc (DocContent x:DocContent y:rest) =-    compressDoc $ DocContent (x ++ y) : rest-compressDoc (DocContent x:rest) =-    DocContent (compressContent x) : compressDoc rest--compressContent :: [Content] -> [Content]-compressContent [] = []-compressContent (ContentRaw "":rest) = compressContent rest-compressContent (ContentRaw x:ContentRaw y:rest) =-    compressContent $ ContentRaw (x ++ y) : rest-compressContent (x:rest) = x : compressContent rest+compressDoc (DocContent (ContentRaw ""):rest) = compressDoc rest+compressDoc ( DocContent (ContentRaw x)+            : DocContent (ContentRaw y)+            : rest+            ) = compressDoc $ (DocContent $ ContentRaw $ x ++ y) : rest+compressDoc (DocContent x:rest) = DocContent x : compressDoc rest  parseDoc :: HamletSettings -> String -> Result [Doc] parseDoc set s = do@@ -392,13 +381,14 @@     ds <- nestToDoc set ns     return $ compressDoc ds -attrToContent :: (Maybe Deref, String, [Content]) -> Doc+attrToContent :: (Maybe Deref, String, [Content]) -> [Doc] attrToContent (Just cond, k, v) =-    DocCond [(cond, [attrToContent (Nothing, k, v)])] Nothing-attrToContent (Nothing, k, []) = DocContent [ContentRaw $ ' ' : k]-attrToContent (Nothing, k, v) = DocContent $-    ContentRaw (' ' : k ++ "=\"")-  : v ++ [ContentRaw "\""]+    [DocCond [(cond, attrToContent (Nothing, k, v))] Nothing]+attrToContent (Nothing, k, []) = [DocContent $ ContentRaw $ ' ' : k]+attrToContent (Nothing, k, v) =+    DocContent (ContentRaw (' ' : k ++ "=\""))+  : map DocContent v+  ++ [DocContent $ ContentRaw "\""]  -- | Settings for parsing of a hamlet document. data HamletSettings = HamletSettings

@@ -6,115 +6,80 @@     ) where  import Text.Hamlet.Parse-import Text.Hamlet.Monad import Language.Haskell.TH.Syntax import Language.Haskell.TH.Quote-import Control.Monad-import Data.List (sortBy, isPrefixOf) import Data.Char (isUpper)-import Control.Applicative ((<$>))--type Vars = (Scope, [Stmt] -> [Stmt])--type Scope = [([Ident], Exp)]+import qualified Data.ByteString.UTF8 as BSU+import qualified Data.ByteString.Char8 as S8+import Data.Monoid (mconcat, mappend, mempty)+import Text.Blaze (unsafeByteString, Html, string)+import Data.List (intercalate) -docsToExp :: [Doc] -> Q Exp-docsToExp docs = do-    (_, stmts) <- foldM docToStmt ([], id) docs-    safeDoE $ stmts []+type Scope = [(Ident, Exp)] -safeDoE :: [Stmt] -> Q Exp-safeDoE [] = [|return ()|]-safeDoE x = return $ DoE x+docsToExp :: Exp -> Scope -> [Doc] -> Q Exp+docsToExp render scope docs = do+    exps <- mapM (docToExp render scope) docs+    ma <- [|mappend|]+    me <- [|mempty|]+    return $ if null exps then me else foldr1 (go ma) exps+  where+    go ma x y = ma `AppE` x `AppE` y -docToStmt :: Vars -> Doc -> Q Vars-docToStmt (vars, stmts) (DocForall (Deref idents) ident@(Ident name) inside) = do-    (vars', deref', stmts', isEnum) <--        case idents of-            [] -> error $ "Invalid forall deref: " ++ show idents-            [(x, Ident i)] -> do-                return (vars, getBase vars $ Ident i, id, x)-            _ -> do-                let front = Deref $ init idents-                    (x, Ident i) = last idents-                (vars', base, stmts') <- bindDeref vars front-                return (vars', VarE (mkName i) `AppE` base, stmts', x)-    fl <- [|fromList|]-    let deref'' = if isEnum then deref' else fl `AppE` deref'-    mh <- [|mapH|]-    ident' <- newName name-    let vars'' = ([ident], VarE ident') : vars'-    (_, inside') <- foldM docToStmt (vars'', id) inside-    dos <- LamE [VarP ident'] <$> (safeDoE $ inside' [])-    let stmt = NoBindS $ mh `AppE` dos `AppE` deref''-    return (vars', stmts . stmts' . (:) stmt)-docToStmt (vars, stmts) (DocMaybe deref ident@(Ident name) inside mno) = do-    (vars', base, stmts') <- bindDeref vars deref-    ident' <- newName name-    let vars'' = ([ident], VarE ident') : vars'-    (_, inside') <- foldM docToStmt (vars'', id) inside-    dos <- LamE [VarP ident'] <$> (safeDoE $ inside' [])-    ninside <- case mno of-                Nothing -> [|Nothing|]-                Just no -> do-                    (_, ninside') <- foldM docToStmt (vars'', id) no-                    j <- [|Just|]-                    x <- safeDoE $ ninside' []-                    return $ j `AppE` x-    mh <- [|maybeH'|]-    let stmt = NoBindS $ mh `AppE` base `AppE` dos `AppE` ninside-    return (vars', stmts . stmts' . (:) stmt)-docToStmt (vars, stmts) (DocCond conds final) = do-    conds' <- liftConds vars conds id+docToExp :: Exp -> Scope -> Doc -> Q Exp+docToExp render scope (DocForall list ident@(Ident name) inside) = do+    let list' = deref scope list+    name' <- newName name+    let scope' = (ident, VarE name') : scope+    mh <- [|\a -> mconcat . map a|]+    inside' <- docsToExp render scope' inside+    let lam = LamE [VarP name'] inside'+    return $ mh `AppE` lam `AppE` list'+docToExp render scope (DocMaybe val ident@(Ident name) inside mno) = do+    let val' = deref scope val+    name' <- newName name+    let scope' = (ident, VarE name') : scope+    inside' <- docsToExp render scope' inside+    let inside'' = LamE [VarP name'] inside'+    ninside' <- case mno of+                    Nothing -> [|Nothing|]+                    Just no -> do+                        no' <- docsToExp render scope no+                        j <- [|Just|]+                        return $ j `AppE` no'+    mh <- [|maybeH|]+    return $ mh `AppE` val' `AppE` inside'' `AppE` ninside'+docToExp render scope (DocCond conds final) = do+    conds' <- mapM go conds     final' <- case final of                 Nothing -> [|Nothing|]                 Just f -> do-                    (_, f') <- foldM docToStmt (vars, id) f+                    f' <- docsToExp render scope f                     j <- [|Just|]-                    AppE j <$> (safeDoE $ f' [])+                    return $ j `AppE` f'     ch <- [|condH|]-    let stmt = NoBindS $ ch `AppE` conds' `AppE` final'-    return (vars, stmts . (:) stmt)-docToStmt v (DocContent c) = foldM contentToStmt v c+    return $ ch `AppE` ListE conds' `AppE` final'+  where+    go :: (Deref, [Doc]) -> Q Exp+    go (d, docs) = do+        let d' = deref scope d+        docs' <- docsToExp render scope docs+        return $ TupE [d', docs']+docToExp render v (DocContent c) = contentToExp render v c -contentToStmt :: Vars -> Content -> Q Vars-contentToStmt (a, b) (ContentRaw s) = do-    os <- [|outputString|]-    s' <- lift s-    let stmt = NoBindS $ os `AppE` s'-    return (a, b . (:) stmt)-contentToStmt (vars, stmts) (ContentVar d) = do-    (vars', d', stmts') <- bindDeref vars d-    oh <- [|outputHtml|]-    let stmt = NoBindS $ oh `AppE` d'-    return (vars', stmts . stmts' . (:) stmt)-contentToStmt (vars, stmts) (ContentUrl hasParams d) = do-    (vars', d', stmts') <- bindDeref vars d+contentToExp :: Exp -> Scope -> Content -> Q Exp+contentToExp _ _ (ContentRaw s) = do+    os <- [|unsafeByteString . S8.pack|]+    let s' = LitE $ StringL $ S8.unpack $ BSU.fromString s+    return $ os `AppE` s'+contentToExp _ scope (ContentVar d) = return $ deref scope d+contentToExp render scope (ContentUrl hasParams d) = do     ou <- if hasParams then [|outputUrlParams|] else [|outputUrl|]-    let stmt = NoBindS $ ou `AppE` d'-    return (vars', stmts . stmts' . (:) stmt)-contentToStmt (vars, stmts) (ContentEmbed d) = do-    (vars', d', stmts') <- bindDeref vars d-    oe <- [|outputEmbed|]-    let stmt = NoBindS $ oe `AppE` d'-    return (vars', stmts . stmts' . (:) stmt)--liftConds :: Scope-          -> [(Deref, [Doc])]-          -> (Exp -> Exp)-          -> Q Exp-liftConds _vars [] front = do-    nil <- [|[]|]-    return $ front nil-liftConds vars ((bool, doc):conds) front = do-    let (base, rest) = shortestPath vars bool-    bool' <- identsToVal False (Deref rest) base-    (_, doc') <- foldM docToStmt (vars, id) doc-    doe <- safeDoE $ doc' []-    let pair = TupE [bool', doe]-    cons <- [|(:)|]-    let front' rest' = front (cons `AppE` pair `AppE` rest')-    liftConds vars conds front'+    let d' = deref scope d+    return $ ou `AppE` render `AppE` d'+contentToExp render scope (ContentEmbed d) = do+    let d' = deref scope d+    return (d' `AppE` render)  -- | Calls 'hamletWithSettings' with 'defaultHamletSettings'. hamlet :: QuasiQuoter@@ -129,12 +94,9 @@  -- | A quasi-quoter that converts Hamlet syntax into a function of form: ----- argument -> Hamlet url m ()+-- > (url -> String) -> Html -- -- Please see accompanying documentation for a description of Hamlet syntax.--- You must ensure that the type of m, url and argument all work properly with--- the functions referred to in the template. Of course, worst case scenario is--- the compiler will catch your mistakes. hamletWithSettings :: HamletSettings -> QuasiQuoter hamletWithSettings set =     QuasiQuoter go $ error "Cannot quasi-quote Hamlet to patterns"@@ -142,106 +104,82 @@     go s = do       case parseDoc set s of         Error s' -> error s'-        Ok d -> docsToExp d+        Ok d -> do+            render <- newName "_render"+            func <- docsToExp (VarE render) [] d+            return $ LamE [VarP render] func --- deref helper funcs-shortestPath :: Scope-             -> Deref -- ^ path sought-             -> (Exp, [(Bool, Ident)]) -- ^ (base, path from base)-shortestPath scope (Deref is) = findMatch' svars+deref :: Scope -> Deref -> Exp+deref _ (Deref []) = error "Invalid empty deref"+deref scope (Deref (z@(Ident zName):y)) =+    let z' = case lookup z scope of+                Nothing -> varName zName+                Just zExp -> zExp+     in foldr go z' $ reverse y   where-    svars = sortBy (\(x, _) (y, _)-                  -> compare (length y) (length x)) scope-    findMatch' [] =-        case is of-            ((False, top):rest) -> (getBase scope top, rest)-            ((True, _):_) -> error "shortestPath: first segment is monadic"-            [] -> error "shortestPath called with null deref"-    findMatch' (x:xs) =-        case checkMatch x of-            Just y -> y-            Nothing -> findMatch' xs-    checkMatch :: ([Ident], Exp)-               -> Maybe (Exp, [(Bool, Ident)])-    checkMatch (a, e')-        | a `isPrefixOf` map snd is = Just (e', drop (length a) is)-        | otherwise = Nothing+    varName "" = error "Illegal empty varName"+    varName v@(s:_) =+        case lookup (Ident v) scope of+            Just e -> e+            Nothing ->+                if isUpper s+                    then ConE $ mkName v+                    else VarE $ mkName v+    go (Ident func) z' = varName func `AppE` z' --- | Converts a chain of idents and initial 'Exp' to a monadic value.-identsToVal :: Bool -- ^ is initial monadic?-            -> Deref-            -> Exp-            -> Q Exp-identsToVal isMonad (Deref []) e =-    if isMonad-        then return e-        else do-            ret <- [|return|]-            return $ ret `AppE` e-identsToVal isInitMonad (Deref ((isMonad, Ident i):is)) e = do-    case (isInitMonad, isMonad) of-        (False, _) -> do-            let e' = VarE (mkName i) `AppE` e-            identsToVal isMonad (Deref is) e'-        (True, True) -> do-            bind <- [|(>>=)|]-            let e' = InfixE (Just e) bind $ Just $ VarE $ mkName i-            identsToVal True (Deref is) e'-        (True, False) -> do-            fm <- [|fmap|]-            let e' = fm `AppE` (VarE $ mkName i) `AppE` e-            identsToVal True (Deref is) e'+-- | Checks for truth in the left value in each pair in the first argument. If+-- a true exists, then the corresponding right action is performed. Only the+-- first is performed. In there are no true values, then the second argument is+-- performed, if supplied.+condH :: [(Bool, Html ())] -> Maybe (Html ()) -> Html ()+condH [] Nothing = mempty+condH [] (Just x) = x+condH ((True, y):_) _ = y+condH ((False, _):rest) z = condH rest z -getBase :: Scope-        -> Ident-        -> Exp-getBase _ (Ident "") = error "Invalid empty ident"-getBase _ (Ident name@(x:_))-    | isUpper x = ConE $ mkName name-getBase scope (Ident top) =-    case lookup [Ident top] scope of-        Nothing -> VarE $ mkName top-        Just e -> e+-- | Runs the second argument with the value in the first, if available.+-- Otherwise, runs the third argument, if available.+maybeH :: Maybe v -> (v -> Html ()) -> Maybe (Html ()) -> Html ()+maybeH Nothing _ Nothing = mempty+maybeH Nothing _ (Just x) = x+maybeH (Just v) f _ = f v -bindMonadicVar :: String -> Exp -> Q (Exp, [Stmt] -> [Stmt])-bindMonadicVar name e = do-    lh <- [|liftHamlet|]-    name' <- newName name-    let stmt = BindS (VarP name') $ lh `AppE` e-    return (VarE name', (:) stmt)+-- | Uses the URL rendering function to convert the given URL to a 'String' and+-- then calls 'outputString'.+outputUrl :: (url -> String) -> url -> Html ()+outputUrl render u = string $ render u --- | Add a new binding for a 'Deref'-bindDeref :: Scope-          -> Deref-          -> Q (Scope, Exp, [Stmt] -> [Stmt])-bindDeref _ (Deref []) = error "bindDeref with null deref"-bindDeref scopeFirst (Deref ((isMonadFirst, Ident base):rest)) = do-    let base' = getBase scopeFirst $ Ident base-    (base'', stmts) <--        if isMonadFirst-            then bindMonadicVar base base'-            else return (base', id)-    (x, y, z, _) <- foldM go (scopeFirst, base'', stmts, [Ident base]) rest-    return (x, y, z)+-- | Same as 'outputUrl', but appends a query-string with given keys and+-- values.+outputUrlParams :: (url -> String) -> (url, [(String, String)]) -> Html ()+outputUrlParams render (u, []) = outputUrl render u+outputUrlParams render (u, params) = mappend+    (outputUrl render u)+    (string $ showParams params)   where-    go :: (Scope, Exp, [Stmt] -> [Stmt], [Ident])-       -> (Bool, Ident)-       -> Q (Scope, Exp, [Stmt] -> [Stmt], [Ident])-    go (scope, base', stmts, front) (isMonad, Ident func) = do-        let (x, func') =-                if not (null func) && isUpper (head func)-                    then (ConE, "var" ++ func)-                    else (VarE, func)-        let rhs = x (mkName func) `AppE` base'-        name <- newName func'-        stmt <--            if isMonad-                then do-                    lh <- [|liftHamlet|]-                    return $ BindS (VarP name) $ lh `AppE` rhs-                else return $ LetS [FunD name-                                    [ Clause [] (NormalB rhs) []-                                    ]]-        let front' = front ++ [Ident func]-        return ((front', VarE name) : scope, VarE name,-                stmts . (:) stmt, front')+    showParams x = '?' : intercalate "&" (map go x)+    go (x, y) = go' x ++ '=' : go' y+    go' = concatMap encodeUrlChar++-- | Taken straight from web-encodings; reimplemented here to avoid extra+-- dependencies.+encodeUrlChar :: Char -> String+encodeUrlChar c+    -- List of unreserved characters per RFC 3986+    -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding+    | 'A' <= c && c <= 'Z' = [c]+    | 'a' <= c && c <= 'z' = [c]+    | '0' <= c && c <= '9' = [c]+encodeUrlChar c@'-' = [c]+encodeUrlChar c@'_' = [c]+encodeUrlChar c@'.' = [c]+encodeUrlChar c@'~' = [c]+encodeUrlChar ' ' = "+"+encodeUrlChar y =+    let (a, c) = fromEnum y `divMod` 16+        b = a `mod` 16+        showHex' x+            | x < 10 = toEnum $ x + (fromEnum '0')+            | x < 16 = toEnum $ x - 10 + (fromEnum 'A')+            | otherwise = error $ "Invalid argument to showHex: " ++ show x+     in ['%', showHex' b, showHex' c]

@@ -1,5 +1,5 @@ name:            hamlet-version:         0.2.3.1+version:         0.3.0 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -40,11 +40,12 @@  library     build-depends:   base >= 4 && < 5,-                     text >= 0.5 && < 0.8,-                     template-haskell+                     bytestring >= 0.9 && < 0.10,+                     utf8-string >= 0.3.4 && < 0.4,+                     template-haskell,+                     blaze-html >= 0.1 && < 0.2     exposed-modules: Text.Hamlet-                     Text.Hamlet.Monad-                     Text.Hamlet.Parse+    other-modules:   Text.Hamlet.Parse                      Text.Hamlet.Quasi     ghc-options:     -Wall 

@@ -5,9 +5,8 @@  import qualified Text.Hamlet.Parse import Text.Hamlet-import Text.Hamlet.Monad (hamletToText)-import Data.Text (pack)-import Data.Text.Lazy (unpack)+import Data.ByteString.UTF8 (fromString)+import Data.ByteString.Lazy.UTF8 (toString)  main :: IO () main = defaultMain@@ -21,44 +20,35 @@     , testCase "static" caseStatic     , testCase "tag" caseTag     , testCase "var" caseVar-    , testCase "var monad" caseVarMonad     , testCase "var chain " caseVarChain     , testCase "url" caseUrl-    , testCase "url monad" caseUrlMonad     , testCase "url chain " caseUrlChain     , testCase "embed" caseEmbed-    , testCase "embed monad" caseEmbedMonad     , testCase "embed chain " caseEmbedChain     , testCase "if" caseIf-    , testCase "if monad" caseIfMonad     , testCase "if chain " caseIfChain     , testCase "else" caseElse-    , testCase "else monad" caseElseMonad     , testCase "else chain " caseElseChain     , testCase "elseif" caseElseIf-    , testCase "elseif monad" caseElseIfMonad     , testCase "elseif chain " caseElseIfChain     , testCase "list" caseList-    , testCase "enum" caseEnum     , testCase "list chain" caseListChain-    , testCase "enum chain" caseEnumChain     , testCase "script not empty" caseScriptNotEmpty     , testCase "meta empty" caseMetaEmpty     , testCase "input empty" caseInputEmpty     , testCase "multiple classes" caseMultiClass     , testCase "attrib order" caseAttribOrder     , testCase "nothing" caseNothing-    , testCase "nothing monad" caseNothingMonad     , testCase "nothing chain " caseNothingChain     , testCase "just" caseJust-    , testCase "just monad" caseJustMonad     , testCase "just chain " caseJustChain     , testCase "constructor" caseConstructor     , testCase "url + params" caseUrlParams-    , testCase "url + params monad" caseUrlParamsMonad     , testCase "escape" caseEscape     , testCase "empty statement list" caseEmptyStatementList     , testCase "attribute conditionals" caseAttribCond+    , testCase "non-ascii" caseNonAscii+    , testCase "maybe function" caseMaybeFunction     ]  data Url = Home | Sub SubUrl@@ -67,57 +57,37 @@ render Home = "url" render (Sub SubUrl) = "suburl" -data Arg m url = Arg-    { getArg :: Arg m url-    , getArgM :: m (Arg m url)-    , var :: HtmlContent-    , mvar :: m HtmlContent+data Arg url = Arg+    { getArg :: Arg url+    , var :: Html ()     , url :: Url-    , murl :: m Url-    , embed :: Hamlet url m ()-    , membed :: m (Hamlet url m ())+    , embed :: Hamlet url     , true :: Bool-    , mtrue :: m Bool     , false :: Bool-    , mfalse :: m Bool-    , list :: [Arg m url]-    , enum :: Enumerator (Arg m url) m-    , nothing :: Maybe HtmlContent-    , mnothing :: m (Maybe HtmlContent)-    , just :: Maybe HtmlContent-    , mjust :: m (Maybe HtmlContent)+    , list :: [Arg url]+    , nothing :: Maybe (Html ())+    , just :: Maybe (Html ())     , urlParams :: (Url, [(String, String)])-    , murlParams :: m (Url, [(String, String)])     } -theArg :: Arg IO url+theArg :: Arg url theArg = Arg     { getArg = theArg-    , getArgM = return theArg-    , var = Unencoded $ pack "<var>"-    , mvar = return $ Unencoded $ pack "<var>"+    , var = string "<var>"     , url = Home-    , murl = return Home     , embed = [$hamlet|embed|]-    , membed = return [$hamlet|embed|]     , true = True-    , mtrue = return True     , false = False-    , mfalse = return False     , list = [theArg, theArg, theArg]-    , enum = fromList $ list theArg     , nothing = Nothing-    , mnothing = return Nothing-    , just = Just $ Unencoded $ pack "just"-    , mjust = return $ Just $ Unencoded $ pack "just"+    , just = Just $ string "just"     , urlParams = (Home, [("foo", "bar"), ("foo1", "bar1")])-    , murlParams = return $ urlParams theArg     } -helper :: String -> Hamlet Url IO () -> Assertion+helper :: String -> Hamlet Url -> Assertion helper res h = do-    x <- hamletToText render h-    res @=? unpack x+    let x = renderHamlet render h+    res @=? toString x  caseEmpty :: Assertion caseEmpty = helper "" [$hamlet||]@@ -134,37 +104,25 @@ caseVar = do     helper "&lt;var&gt;" [$hamlet|$var.theArg$|] -caseVarMonad :: Assertion-caseVarMonad = do-    helper "&lt;var&gt;" [$hamlet|$*mvar.theArg$|]- caseVarChain :: Assertion caseVarChain = do-    helper "&lt;var&gt;" [$hamlet|$var.getArg.*getArgM.getArg.theArg$|]+    helper "&lt;var&gt;" [$hamlet|$var.getArg.getArg.getArg.theArg$|]  caseUrl :: Assertion caseUrl = do     helper (render Home) [$hamlet|@url.theArg@|] -caseUrlMonad :: Assertion-caseUrlMonad = do-    helper (render Home) [$hamlet|@*murl.theArg@|]- caseUrlChain :: Assertion caseUrlChain = do-    helper (render Home) [$hamlet|@url.getArg.*getArgM.getArg.theArg@|]+    helper (render Home) [$hamlet|@url.getArg.getArg.getArg.theArg@|]  caseEmbed :: Assertion caseEmbed = do     helper "embed" [$hamlet|^embed.theArg^|] -caseEmbedMonad :: Assertion-caseEmbedMonad = do-    helper "embed" [$hamlet|^*membed.theArg^|]- caseEmbedChain :: Assertion caseEmbedChain = do-    helper "embed" [$hamlet|^embed.getArg.*getArgM.getArg.theArg^|]+    helper "embed" [$hamlet|^embed.getArg.getArg.getArg.theArg^|]  caseIf :: Assertion caseIf = do@@ -173,17 +131,10 @@     if |] -caseIfMonad :: Assertion-caseIfMonad = do-    helper "if" [$hamlet|-$if *mtrue.theArg-    if-|]- caseIfChain :: Assertion caseIfChain = do     helper "if" [$hamlet|-$if *mtrue.getArg.*getArgM.getArg.theArg+$if true.getArg.getArg.getArg.theArg     if |] @@ -195,17 +146,9 @@     else |] -caseElseMonad :: Assertion-caseElseMonad = helper "else" [$hamlet|-$if *mfalse.theArg-    if-$else-    else-|]- caseElseChain :: Assertion caseElseChain = helper "else" [$hamlet|-$if *mfalse.getArg.*getArgM.getArg.theArg+$if false.getArg.getArg.getArg.theArg     if $else     else@@ -221,21 +164,11 @@     else |] -caseElseIfMonad :: Assertion-caseElseIfMonad = helper "elseif" [$hamlet|-$if *mfalse.theArg-    if-$elseif *mtrue.theArg-    elseif-$else-    else-|]- caseElseIfChain :: Assertion caseElseIfChain = helper "elseif" [$hamlet|-$if *mfalse.getArg.*getArgM.getArg.theArg+$if false.getArg.getArg.getArg.theArg     if-$elseif *mtrue.getArg.*getArgM.getArg.theArg+$elseif true.getArg.getArg.getArg.theArg     elseif $else     else@@ -251,25 +184,8 @@ caseListChain :: Assertion caseListChain = do     helper "urlurlurl" [$hamlet|-$forall list.*getArgM.getArg.getArg.*getArgM.getArg.theArg x-    @*murl.x@-|]--caseEnum :: Assertion-caseEnum = do-    helper "xxx" [$hamlet|-$forall *enum.theArg x-    x-|]-    helper "xxx" [$hamlet|-$forall *enum.theArg x-    x-|]--caseEnumChain :: Assertion-caseEnumChain = helper "urlurlurl" [$hamlet|-$forall *enum.*getArgM.getArg.getArg.*getArgM.getArg.theArg x-    @*murl.x@+$forall list.getArg.getArg.getArg.getArg.getArg.theArg x+    @url.x@ |]  caseScriptNotEmpty :: Assertion@@ -305,15 +221,9 @@     nothing |] -caseNothingMonad :: Assertion-caseNothingMonad = helper "" [$hamlet|-$maybe *mnothing.theArg n-    nothing $n$-|]- caseNothingChain :: Assertion caseNothingChain = helper "" [$hamlet|-$maybe *mnothing.getArg.*getArgM.getArg.theArg n+$maybe nothing.getArg.getArg.getArg.theArg n     nothing $n$ |] @@ -323,15 +233,9 @@     it's $n$ |] -caseJustMonad :: Assertion-caseJustMonad = helper "it's just" [$hamlet|-$maybe *mjust.theArg n-    it's $n$-|]- caseJustChain :: Assertion caseJustChain = helper "it's just" [$hamlet|-$maybe *mjust.getArg.*getArgM.getArg.theArg n+$maybe just.getArg.getArg.getArg.theArg n     it's $n$ |] @@ -339,16 +243,12 @@ caseConstructor = do     helper "url" [$hamlet|@Home@|]     helper "suburl" [$hamlet|@Sub.SubUrl@|]-    let text = pack "<raw text>"-    helper "<raw text>" [$hamlet|$Encoded.text$|]+    let text = "<raw text>"+    helper "<raw text>" [$hamlet|$preEscapedString.text$|]  caseUrlParams :: Assertion caseUrlParams = do-    helper "url?foo=bar&foo1=bar1" [$hamlet|@?urlParams.theArg@|]--caseUrlParamsMonad :: Assertion-caseUrlParamsMonad = do-    helper "url?foo=bar&foo1=bar1" [$hamlet|@?*murlParams.theArg@|]+    helper "url?foo=bar&amp;foo1=bar1" [$hamlet|@?urlParams.theArg@|]  caseEscape :: Assertion caseEscape = do@@ -372,3 +272,14 @@     helper "<meta var=\"foo:bar\">" [$hamlet|%meta!var=foo:bar|]     helper "<select selected></select>"         [$hamlet|%select!:true.theArg:selected|]++caseNonAscii :: Assertion+caseNonAscii = do+    helper "עִבְרִי" [$hamlet|עִבְרִי|]++caseMaybeFunction :: Assertion+caseMaybeFunction = do+    helper "url?foo=bar&amp;foo1=bar1" [$hamlet|+$maybe Just.urlParams x+    @?x.theArg@+|]