packages feed

hamlet (empty) → 0.0.0

raw patch · 8 files changed

+1068/−0 lines, 8 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, template-haskell, test-framework, test-framework-hunit, text, web-encodings

Files

+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2009, 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.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/Hamlet.hs view
@@ -0,0 +1,15 @@+module Text.Hamlet+    ( hamlet+    , hamletWithSettings+    , HamletSettings (..)+    , defaultHamletSettings+    , Hamlet (..)+    , HtmlContent (..)+    , printHamlet+    , Enumerator (..)+    , fromList+    ) where++import Text.Hamlet.Monad+import Text.Hamlet.Parse+import Text.Hamlet.Quasi
+ Text/Hamlet/Monad.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE RankNTypes #-}+module Text.Hamlet.Monad+    ( -- * Generalized enumerator+      Iteratee+    , Enumerator (..)+    , fromList+      -- * Datatypes+    , Hamlet (..)+    , HtmlContent (..)+      -- * Output+    , output+    , outputHtml+    , outputString+    , outputUrl+    , outputEmbed+      -- * Utility functions+    , showUrl+    , liftHamlet+    , mapH+    , condH+    , printHamlet+    , hamletToText+    , cdata+    ) where++import Data.Text (Text, pack)+import qualified Data.Text.Lazy as L+import qualified Data.Text.IO as T+import Control.Applicative+import Control.Monad+import Web.Encodings+import Data.Monoid++-- | 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 (Encoded x)   (Encoded y)   = Encoded   $ mappend x y+    mappend (Unencoded x) (Unencoded y) = Unencoded $ mappend x y+    mappend (Encoded x)   (Unencoded y) = Encoded   $ mappend x+                                                    $ encodeHtml y+    mappend (Unencoded x) (Encoded y)   = Encoded   $ mappend+                                                      (encodeHtml x) 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 (Encoded t) = output t+outputHtml (Unencoded t) = output $ encodeHtml t++-- | '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++-- | 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++-- | 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
+ Text/Hamlet/Parse.hs view
@@ -0,0 +1,368 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Text.Hamlet.Parse+    ( Result (..)+    , Deref (..)+    , Ident (..)+    , Content (..)+    , Doc (..)+    , parseDoc+    , HamletSettings (..)+    , defaultHamletSettings+#if TEST+    , testSuite+#endif+    )+    where++import Control.Applicative+import Control.Monad+import Control.Arrow+import Data.Data++#if TEST+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)+#endif++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++newtype Deref = Deref [(Bool, Ident)]+    deriving (Show, Eq, Read, Data, Typeable)+newtype Ident = Ident String+    deriving (Show, Eq, Read, Data, Typeable)++data Content = ContentRaw String+             | ContentVar Deref+             | ContentUrl Deref+             | ContentEmbed Deref+    deriving (Show, Eq, Read, Data, Typeable)++data Line = LineForall Deref Ident+          | LineIf Deref+          | LineElseIf Deref+          | LineElse+          | LineTag+            { _lineTagName :: String+            , _lineAttr :: [(String, [Content])]+            , _lineContent :: [Content]+            }+          | LineContent [Content]+    deriving (Eq, Show, Read)++parseLines :: HamletSettings -> String -> Result [(Int, Line)]+parseLines set = mapM go . lines where+    go s = do+        let (spaces, s') = countSpaces 0 s+        l <- parseLine set s'+        Ok (spaces, l)+    countSpaces i (' ':rest) = countSpaces (i + 1) rest+    countSpaces i ('\t':rest) = countSpaces (i + 4) rest+    countSpaces i x = (i, x)++parseLine :: HamletSettings -> String -> Result Line+parseLine set "!!!" =+    Ok $ LineContent [ContentRaw $ hamletDoctype set ++ "\n"]+parseLine _ ('$':'f':'o':'r':'a':'l':'l':' ':rest) =+    case words rest of+        [x, y] -> do+            x' <- parseDeref x+            (False, y') <- parseIdent' False y+            return $ LineForall x' y'+        _ -> Error $ "Invalid forall: " ++ rest+parseLine _ ('$':'i':'f':' ':rest) = LineIf <$> parseDeref rest+parseLine _ ('$':'e':'l':'s':'e':'i':'f':' ':rest) =+    LineElseIf <$> parseDeref rest+parseLine _ "$else" = Ok LineElse+parseLine _ x@(c:_) | c `elem` "%#." = do+    let (begin, rest) = break (== ' ') x+        rest' = dropWhile (== ' ') rest+    (tn, attr) <- parseTag begin+    con <- parseContent rest'+    return $ LineTag tn attr con+parseLine _ s = LineContent <$> parseContent s++#if TEST+fooBar :: Deref+fooBar = Deref [(False, Ident "foo"), (False, Ident "bar")]++caseParseLine :: Assertion+caseParseLine = do+    let parseLine' = parseLine defaultHamletSettings+    parseLine' "$if foo.bar" @?= Ok (LineIf fooBar)+    parseLine' "$elseif foo.bar" @?= Ok (LineElseIf fooBar)+    parseLine' "$else" @?= Ok LineElse+    parseLine' "%img!src=@foo.bar@"+        @?= Ok (LineTag "img" [("src", [ContentUrl fooBar])] [])+    parseLine' ".$foo.bar$"+        @?= Ok (LineTag "div" [("class", [ContentVar fooBar])] [])+    parseLine' "%span#foo.bar!baz=bin"+        @?= Ok (LineTag "span" [ ("baz", [ContentRaw "bin"])+                               , ("class", [ContentRaw "bar"])+                               , ("id", [ContentRaw "foo"])+                               ] [])+#endif++parseContent :: String -> Result [Content]+parseContent "" = Ok []+parseContent s =+    case break (flip elem "@$^") s of+        (_, "") -> Ok [ContentRaw s]+        (a, delim:a') -> do+            b <-+                case break (== delim) a' of+                    ("", _:rest) -> do+                        rest' <- parseContent rest+                        return $ ContentRaw [delim] : rest'+                    (deref, _:rest) -> do+                        deref' <- parseDeref deref+                        let x = case delim of+                                    '$' -> ContentVar+                                    '@' -> ContentUrl+                                    '^' -> ContentEmbed+                                    _ -> error $ "Invalid delim in parseContent: " ++ [delim]+                        rest' <- parseContent rest+                        return $ x deref' : rest'+                    _ -> error "Invalid branch in parseContent"+            case a of+                "" -> return b+                _ -> return $ ContentRaw a : b++#if TEST+caseParseContent :: Assertion+caseParseContent = do+    parseContent "" @?= Ok []+    parseContent "foo" @?= Ok [ContentRaw "foo"]+    parseContent "foo $bar$ baz" @?= Ok [ ContentRaw "foo "+                                        , ContentVar $ Deref [(False, Ident "bar")]+                                        , ContentRaw " baz"+                                        ]+    parseContent "foo @bar@ baz" @?= Ok [ ContentRaw "foo "+                                        , ContentUrl $ Deref [(False, Ident "bar")]+                                        , ContentRaw " baz"+                                        ]+    parseContent "foo ^bar^ baz" @?= Ok [ ContentRaw "foo "+                                        , ContentEmbed $ Deref [(False, Ident "bar")]+                                        , ContentRaw " baz"+                                        ]+    parseContent "@@" @?= Ok [ContentRaw "@"]+    parseContent "^^" @?= Ok [ContentRaw "^"]+#endif++parseDeref :: String -> Result Deref+parseDeref "" = Error "Invalid empty deref"+parseDeref s = Deref <$> go s where+    go "" = return []+    go a = case break (== '.') a of+                (x, '.':y) -> do+                    x' <- parseIdent x+                    y' <- go y+                    return $ x' : y'+                (x, "") -> return <$> parseIdent x+                _ -> error "Invalid branch in Text.Hamlet.Parse.parseDef"++#if TEST+caseParseDeref :: Assertion+caseParseDeref = do+    parseDeref "foo.*bar.baz" @?=+        Ok (Deref [ (False, Ident "foo")+                  , (True, Ident "bar")+                  , (False, 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' b s+    | all (flip elem (['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_'")) s+        = Ok (b, 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")+#endif++parseTag :: String -> Result (String, [(String, [Content])])+parseTag s = do+    pieces <- takePieces s+    foldM go ("div", []) pieces+  where+    go (_, attrs) ('%':tn) = Ok (tn, attrs)+    go (tn, attrs) ('.':cl) = do+        con <- parseContent cl+        Ok (tn, ("class", con) : attrs)+    go (tn, attrs) ('#':cl) = do+        con <- parseContent cl+        Ok (tn, ("id", con) : attrs)+    go (tn, attrs) ('!':rest) = do+        let (name, val) = break (== '=') rest+        val' <-+            case val of+                ('=':rest') -> parseContent rest'+                _ -> Ok []+        Ok (tn, (name, val') : attrs)+    go _ _ = error "Invalid branch in Text.Hamlet.Parse.parseTag"++takePieces :: String -> Result [String]+takePieces "" = Ok []+takePieces (a:s) = do+    (x, y) <- takePiece ((:) a) False False False s+    y' <- takePieces y+    return $ x : y'+  where+    takePiece front False False False "" = Ok (front "", "")+    takePiece _ _ _ _ "" = Error $ "Unterminated URL, var or embed: " ++ s+    takePiece front False False False (c:rest)+        | c `elem` "#.%!" = Ok (front "", c:rest)+    takePiece front x y z (c:rest)+        | c == '$' = takePiece (front . (:) c) (not x) y z rest+        | c == '@' = takePiece (front . (:) c) x (not y) z rest+        | c == '^' = takePiece (front . (:) c) x y (not z) rest+        | otherwise = takePiece (front . (:) c) x y z rest++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 Ident [Doc]+         | DocCond [(Deref, [Doc])] (Maybe [Doc])+         | DocContent [Content]+    deriving (Show, Eq, Read, Data, Typeable)++nestToDoc :: HamletSettings -> [Nest] -> Result [Doc]+nestToDoc _set [] = Ok []+nestToDoc set (Nest (LineForall d i) inside:rest) = do+    inside' <- nestToDoc set inside+    rest' <- nestToDoc set rest+    Ok $ DocForall d i inside' : rest'+nestToDoc set (Nest (LineIf d) inside:rest) = do+    inside' <- nestToDoc set inside+    (ifs, el, rest') <- parseConds set ((:) (d, inside')) rest+    rest'' <- nestToDoc set rest'+    Ok $ DocCond ifs el : rest''+nestToDoc set (Nest (LineTag tn attrs content) inside:rest) = do+    let closeStyle =+            if not (null content) || not (null inside)+                then CloseSeparate+                else closeTag set tn+    let end = case closeStyle of+                CloseSeparate -> [DocContent [ContentRaw $ "</" ++ tn ++ ">"]]+                _ -> []+        seal = case closeStyle of+                 CloseInside -> ContentRaw "/>"+                 _ -> ContentRaw ">"+        start = ContentRaw $ "<" ++ tn+        attrs' = concatMap attrToContent attrs+    inside' <- nestToDoc set inside+    rest' <- nestToDoc set rest+    Ok $ DocContent (start : attrs' ++ seal : 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'+nestToDoc _set (Nest (LineElseIf _) _:_) = Error "Unexpected elseif"+nestToDoc _set (Nest LineElse _:_) = Error "Unexpected else"++compressDoc :: [Doc] -> [Doc]+compressDoc [] = []+compressDoc (DocForall d i doc:rest) =+    DocForall d i (compressDoc doc) : compressDoc rest+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 (ContentRaw "":rest) = compressContent rest+compressContent (ContentRaw x:ContentRaw y:rest) = compressContent $ ContentRaw (x ++ y) : rest+compressContent (x:rest) = x : compressContent rest+compressContent [] = []++parseDoc :: HamletSettings -> String -> Result [Doc]+parseDoc set s = do+    ls <- parseLines set s+    let ns = nestLines ls+    ds <- nestToDoc set ns+    return $ compressDoc ds++attrToContent :: (String, [Content]) -> [Content]+attrToContent (k, []) = [ContentRaw $ ' ' : k]+attrToContent (k, v) = (ContentRaw $ ' ' : k ++ "=\"") : v ++ [ContentRaw "\""]++-- | Settings for parsing of a hamlet document.+data HamletSettings = HamletSettings+    {+      -- | The value to replace a \"!!!\" with. Do not include the trailing+      -- newline.+      hamletDoctype :: String+      -- | 'True' means to close empty tags (eg, img) with a trailing slash, ie+      -- XML-style empty tags. 'False' uses HTML-style.+    , hamletCloseEmpties :: Bool+    }++-- | Defaults settings: HTML5 doctype and HTML-style empty tags.+defaultHamletSettings :: HamletSettings+defaultHamletSettings = HamletSettings "<!DOCTYPE html>" False++data CloseStyle = NoClose | CloseInside | CloseSeparate++closeTag :: HamletSettings -> String -> CloseStyle+closeTag h s =+    if canBeEmpty s+        then (if hamletCloseEmpties h then CloseInside else NoClose)+        else CloseSeparate+  where+    canBeEmpty "img" = False+    canBeEmpty "link" = False+    canBeEmpty "meta" = False+    canBeEmpty "br" = False+    canBeEmpty "hr" = False+    canBeEmpty _ = True++parseConds :: HamletSettings+           -> ([(Deref, [Doc])] -> [(Deref, [Doc])])+           -> [Nest]+           -> Result ([(Deref, [Doc])], Maybe [Doc], [Nest])+parseConds set front (Nest LineElse inside:rest) = do+    inside' <- nestToDoc set inside+    Ok $ (front [], Just inside', rest)+parseConds set front (Nest (LineElseIf d) inside:rest) = do+    inside' <- nestToDoc set inside+    parseConds set (front . (:) (d, inside')) rest+parseConds _ front rest = Ok (front [], Nothing, rest)++#if TEST+---- Testing+testSuite :: Test+testSuite = testGroup "Text.Hamlet.Parse"+    [ testCase "parseLine" caseParseLine+    , testCase "parseContent" caseParseContent+    , testCase "parseDeref" caseParseDeref+    , testCase "parseIdent" caseParseIdent+    ]+#endif
+ Text/Hamlet/Quasi.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE TemplateHaskell #-}+module Text.Hamlet.Quasi+    ( hamlet+    , hamletWithSettings+    ) 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)++type Vars = (Scope, Exp, [Stmt] -> [Stmt])++type Scope = [([Ident], Exp)]++docsToExp :: [Doc] -> Q Exp+docsToExp docs = do+    arg <- newName "_arg"+    (_, _, stmts) <- foldM docToStmt ([], VarE arg, id) docs+    stmts' <- case stmts [] of+                    [] -> do+                        ret <- [|return ()|]+                        return [NoBindS ret]+                    x -> return x+    return $ LamE [VarP arg] $ DoE stmts'++docToStmt :: Vars -> Doc -> Q Vars+docToStmt (vars, arg, 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+                let i' = VarE (mkName i) `AppE` arg+                return (vars, i', id, x)+            _ -> do+                let front = Deref $ init idents+                    (x, Ident i) = last idents+                (vars', base, stmts') <- bindDeref vars arg 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'', arg, id) inside+    let dos = LamE [VarP ident'] $ DoE $ inside' []+    let stmt = NoBindS $ mh `AppE` dos `AppE` deref''+    return (vars', arg, stmts . stmts' . (:) stmt)+docToStmt (vars, arg, stmts) (DocCond conds final) = do+    conds' <- liftConds vars arg conds id+    final' <- case final of+                Nothing -> [|Nothing|]+                Just f -> do+                    (_, _, f') <- foldM docToStmt (vars, arg, id) f+                    j <- [|Just|]+                    return $ j `AppE` (DoE $ f' [])+    ch <- [|condH|]+    let stmt = NoBindS $ ch `AppE` conds' `AppE` final'+    return (vars, arg, stmts . (:) stmt)+docToStmt v (DocContent c) = foldM contentToStmt v c++contentToStmt :: Vars -> Content -> Q Vars+contentToStmt (a, b, c) (ContentRaw s) = do+    os <- [|outputString|]+    s' <- lift s+    let stmt = NoBindS $ os `AppE` s'+    return (a, b, c . (:) stmt)+contentToStmt (vars, arg, stmts) (ContentVar d) = do+    (vars', d', stmts') <- bindDeref vars arg d+    oh <- [|outputHtml|]+    let stmt = NoBindS $ oh `AppE` d'+    return (vars', arg, stmts . stmts' . (:) stmt)+contentToStmt (vars, arg, stmts) (ContentUrl d) = do+    (vars', d', stmts') <- bindDeref vars arg d+    ou <- [|outputUrl|]+    let stmt = NoBindS $ ou `AppE` d'+    return (vars', arg, stmts . stmts' . (:) stmt)+contentToStmt (vars, arg, stmts) (ContentEmbed d) = do+    (vars', d', stmts') <- bindDeref vars arg d+    oe <- [|outputEmbed|]+    let stmt = NoBindS $ oe `AppE` d'+    return (vars', arg, stmts . stmts' . (:) stmt)++liftConds :: Scope+          -> Exp+          -> [(Deref, [Doc])]+          -> (Exp -> Exp)+          -> Q Exp+liftConds _vars _arg [] front = do+    nil <- [|[]|]+    return $ front nil+liftConds vars arg ((bool, doc):conds) front = do+    let (base, rest) = shortestPath vars arg bool+    bool' <- identsToVal False (Deref rest) base+    (_, _, doc') <- foldM docToStmt (vars, arg, id) doc+    let pair = TupE [bool', DoE $ doc' []]+    cons <- [|(:)|]+    let front' rest' = front (cons `AppE` pair `AppE` rest')+    liftConds vars arg conds front'++-- | Calls 'hamletWithSettings' with 'defaultHamletSettings'.+hamlet :: QuasiQuoter+hamlet = hamletWithSettings defaultHamletSettings++-- | A quasi-quoter that converts Hamlet syntax into a function of form:+--+-- argument -> Hamlet url m ()+--+-- 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"+  where+    go s = do+      case parseDoc set s of+        Error s' -> error s'+        Ok d -> docsToExp d++-- deref helper funcs+shortestPath :: Scope+             -> Exp -- ^ original argument+             -> Deref -- ^ path sought+             -> (Exp, [(Bool, Ident)]) -- ^ (base, path from base)+shortestPath vars e (Deref is) = findMatch' svars is e+  where+    svars = sortBy (\(x, _) (y, _)+                  -> compare (length y) (length x)) vars+    findMatch' [] is' e' = (e', is')+    findMatch' (x:xs) is' e' =+        case checkMatch x is' of+            Just y -> y+            Nothing -> findMatch' xs is' e'+    checkMatch :: ([Ident], Exp)+               -> [(Bool, Ident)]+               -> Maybe (Exp, [(Bool, Ident)])+    checkMatch (a, e') b+        | a `isPrefixOf` map snd b = Just (e', drop (length a) b)+        | otherwise = Nothing++-- | 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'++-- | Add a new binding for a 'Deref'+bindDeref :: Scope+          -> Exp -- ^ argument+          -> Deref+          -> Q (Scope, Exp, [Stmt] -> [Stmt])+bindDeref vars arg (Deref []) = return (vars, arg, id)+bindDeref vars arg deref@(Deref idents) =+    case lookup (map snd idents) vars of+        Just e -> return (vars, e, id)+        Nothing -> do+            let front = init idents+                (isMonad, Ident final) = last idents+            (vars', base, stmts) <- bindDeref vars arg $ Deref front+            lh <- [|liftHamlet|]+            let rhs = VarE (mkName final) `AppE` base+            var <- newName $ derefToName deref+            let stmt =+                  if isMonad+                      then BindS (VarP var) $ lh `AppE` rhs+                      else LetS [FunD var+                                  [ Clause [] (NormalB rhs) []+                                  ]]+            let vars'' = (map snd idents, VarE var) : vars'+            return (vars'', VarE var, stmts . (:) stmt)++derefToName :: Deref -> String+derefToName (Deref is') = go is' where+    go [] = ""+    go [(_, Ident i)] = i+    go ((_, Ident i):is) = i ++ "__" ++ go is
+ hamlet.cabal view
@@ -0,0 +1,43 @@+name:            hamlet+version:         0.0.0+license:         BSD3+license-file:    LICENSE+author:          Michael Snoyman <michael@snoyman.com>+maintainer:      Michael Snoyman <michael@snoyman.com>+synopsis:        Haml-like template files that are compile-time checked+category:        Web+stability:       unstable+cabal-version:   >= 1.6+build-type:      Simple+homepage:        http://docs.yesodweb.com/hamlet/++flag buildtests+  description: Build the executable to run unit tests+  default: False++library+    build-depends:   base >= 4 && < 5,+                     web-encodings >= 0.2.4 && < 0.3,+                     text >= 0.5 && < 0.8,+                     template-haskell+    exposed-modules: Text.Hamlet+                     Text.Hamlet.Monad+                     Text.Hamlet.Parse+                     Text.Hamlet.Quasi+    ghc-options:     -Wall++executable             runtests+    if flag(buildtests)+        Buildable: True+        cpp-options:   -DTEST+        build-depends: QuickCheck >= 2 && < 3,+                       HUnit,+                       test-framework-hunit,+                       test-framework+    else+        Buildable: False+    main-is:         runtests.hs++source-repository head+  type:     git+  location: git://github.com/snoyberg/hamlet.git
+ runtests.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE QuasiQuotes #-}+import Test.Framework (defaultMain, testGroup, Test)+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)++import qualified Text.Hamlet.Parse+import Text.Hamlet+import Text.Hamlet.Monad (hamletToText)+import Data.Text (pack)+import Data.Text.Lazy (unpack)++main :: IO ()+main = defaultMain+    [ Text.Hamlet.Parse.testSuite+    , testSuite+    ]++testSuite :: Test+testSuite = testGroup "Text.Hamlet"+    [ testCase "empty" caseEmpty+    , 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+    ]++data Url = Home+render :: Url -> String+render Home = "url"++data Arg m url = Arg+    { getArg :: Arg m url+    , getArgM :: m (Arg m url)+    , var :: HtmlContent+    , mvar :: m HtmlContent+    , url :: Url+    , murl :: m Url+    , embed :: Hamlet url m ()+    , membed :: m (Hamlet url m ())+    , true :: Bool+    , mtrue :: m Bool+    , false :: Bool+    , mfalse :: m Bool+    , list :: [Arg m url]+    , enum :: Enumerator (Arg m url) m+    }++arg :: Monad m => Arg m url+arg = Arg+    { getArg = arg+    , getArgM = return arg+    , var = Unencoded $ pack "<var>"+    , mvar = return $ Unencoded $ pack "<var>"+    , url = Home+    , murl = return Home+    , embed = [$hamlet|embed|] ()+    , membed = return $ [$hamlet|embed|] ()+    , true = True+    , mtrue = return True+    , false = False+    , mfalse = return False+    , list = [arg, arg, arg]+    , enum = fromList $ list arg+    }++helper :: String -> (Arg IO Url -> Hamlet Url IO ()) -> Assertion+helper res h = do+    x <- hamletToText render $ h arg+    res @=? unpack x++caseEmpty :: Assertion+caseEmpty = helper "" [$hamlet||]++caseStatic :: Assertion+caseStatic = helper "some static content" [$hamlet|some static content|]++caseTag :: Assertion+caseTag = helper "<p class=\"foo\"><div id=\"bar\">baz</div></p>" [$hamlet|+%p.foo+ #bar baz|]++caseVar :: Assertion+caseVar = helper "&lt;var&gt;" [$hamlet|$var$|]++caseVarMonad :: Assertion+caseVarMonad = helper "&lt;var&gt;" [$hamlet|$*mvar$|]++caseVarChain :: Assertion+caseVarChain = helper "&lt;var&gt;" [$hamlet|$getArg.*getArgM.getArg.var$|]++caseUrl :: Assertion+caseUrl = helper (render Home) [$hamlet|@url@|]++caseUrlMonad :: Assertion+caseUrlMonad = helper (render Home) [$hamlet|@*murl@|]++caseUrlChain :: Assertion+caseUrlChain = helper (render Home) [$hamlet|@getArg.*getArgM.getArg.url@|]++caseEmbed :: Assertion+caseEmbed = helper "embed" [$hamlet|^embed^|]++caseEmbedMonad :: Assertion+caseEmbedMonad = helper "embed" [$hamlet|^*membed^|]++caseEmbedChain :: Assertion+caseEmbedChain = helper "embed" [$hamlet|^getArg.*getArgM.getArg.embed^|]++caseIf :: Assertion+caseIf = helper "if" [$hamlet|+$if true+    if+|]++caseIfMonad :: Assertion+caseIfMonad = helper "if" [$hamlet|+$if *mtrue+    if+|]++caseIfChain :: Assertion+caseIfChain = helper "if" [$hamlet|+$if getArg.*getArgM.getArg.*mtrue+    if+|]++caseElse :: Assertion+caseElse = helper "else" [$hamlet|+$if false+    if+$else+    else+|]++caseElseMonad :: Assertion+caseElseMonad = helper "else" [$hamlet|+$if *mfalse+    if+$else+    else+|]++caseElseChain :: Assertion+caseElseChain = helper "else" [$hamlet|+$if getArg.*getArgM.getArg.*mfalse+    if+$else+    else+|]++caseElseIf :: Assertion+caseElseIf = helper "elseif" [$hamlet|+$if false+    if+$elseif true+    elseif+$else+    else+|]++caseElseIfMonad :: Assertion+caseElseIfMonad = helper "elseif" [$hamlet|+$if *mfalse+    if+$elseif *mtrue+    elseif+$else+    else+|]++caseElseIfChain :: Assertion+caseElseIfChain = helper "elseif" [$hamlet|+$if getArg.*getArgM.getArg.*mfalse+    if+$elseif getArg.*getArgM.getArg.*mtrue+    elseif+$else+    else+|]++caseList :: Assertion+caseList = helper "xxx" [$hamlet|+$forall list x+    x+|]++caseListChain :: Assertion+caseListChain = helper "urlurlurl" [$hamlet|+$forall getArg.*getArgM.getArg.getArg.*getArgM.list x+    @x.*murl@+|]++caseEnum :: Assertion+caseEnum = helper "xxx" [$hamlet|+$forall *enum x+    x+|]++caseEnumChain :: Assertion+caseEnumChain = helper "urlurlurl" [$hamlet|+$forall getArg.*getArgM.getArg.getArg.*getArgM.*enum x+    @x.*murl@+|]