diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs new file mode 100644 --- /dev/null +++ b/Text/Hamlet.hs @@ -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 diff --git a/Text/Hamlet/Monad.hs b/Text/Hamlet/Monad.hs new file mode 100644 --- /dev/null +++ b/Text/Hamlet/Monad.hs @@ -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 "" + ] + +-- | 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 diff --git a/Text/Hamlet/Parse.hs b/Text/Hamlet/Parse.hs new file mode 100644 --- /dev/null +++ b/Text/Hamlet/Parse.hs @@ -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 $ ""]] + _ -> [] + 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 "" 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 diff --git a/Text/Hamlet/Quasi.hs b/Text/Hamlet/Quasi.hs new file mode 100644 --- /dev/null +++ b/Text/Hamlet/Quasi.hs @@ -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 diff --git a/hamlet.cabal b/hamlet.cabal new file mode 100644 --- /dev/null +++ b/hamlet.cabal @@ -0,0 +1,43 @@ +name: hamlet +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman +maintainer: Michael Snoyman +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 diff --git a/runtests.hs b/runtests.hs new file mode 100644 --- /dev/null +++ b/runtests.hs @@ -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 "" + , mvar = return $ Unencoded $ pack "" + , 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 "

baz

" [$hamlet| +%p.foo + #bar baz|] + +caseVar :: Assertion +caseVar = helper "<var>" [$hamlet|$var$|] + +caseVarMonad :: Assertion +caseVarMonad = helper "<var>" [$hamlet|$*mvar$|] + +caseVarChain :: Assertion +caseVarChain = helper "<var>" [$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@ +|]