diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs --- a/Text/Hamlet.hs +++ b/Text/Hamlet.hs @@ -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 "" diff --git a/Text/Hamlet/Monad.hs b/Text/Hamlet/Monad.hs deleted file mode 100644 --- a/Text/Hamlet/Monad.hs +++ /dev/null @@ -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 "" - ] - --- | 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 '<' = "<" -encodeHtmlChar '>' = ">" -encodeHtmlChar '&' = "&" -encodeHtmlChar '"' = """ -encodeHtmlChar '\'' = "'" -encodeHtmlChar c = [c] diff --git a/Text/Hamlet/Parse.hs b/Text/Hamlet/Parse.hs --- a/Text/Hamlet/Parse.hs +++ b/Text/Hamlet/Parse.hs @@ -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 $ ""] - _ -> DocContent [] + DocContent $ ContentRaw $ "" + _ -> 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 diff --git a/Text/Hamlet/Quasi.hs b/Text/Hamlet/Quasi.hs --- a/Text/Hamlet/Quasi.hs +++ b/Text/Hamlet/Quasi.hs @@ -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] diff --git a/hamlet.cabal b/hamlet.cabal --- a/hamlet.cabal +++ b/hamlet.cabal @@ -1,5 +1,5 @@ name: hamlet -version: 0.2.3.1 +version: 0.3.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -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 diff --git a/runtests.hs b/runtests.hs --- a/runtests.hs +++ b/runtests.hs @@ -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 "" - , mvar = return $ Unencoded $ pack "" + , var = string "" , 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 "<var>" [$hamlet|$var.theArg$|] -caseVarMonad :: Assertion -caseVarMonad = do - helper "<var>" [$hamlet|$*mvar.theArg$|] - caseVarChain :: Assertion caseVarChain = do - helper "<var>" [$hamlet|$var.getArg.*getArgM.getArg.theArg$|] + helper "<var>" [$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 "" - helper "" [$hamlet|$Encoded.text$|] + let text = "" + helper "" [$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&foo1=bar1" [$hamlet|@?urlParams.theArg@|] caseEscape :: Assertion caseEscape = do @@ -372,3 +272,14 @@ helper "" [$hamlet|%meta!var=foo:bar|] helper "" [$hamlet|%select!:true.theArg:selected|] + +caseNonAscii :: Assertion +caseNonAscii = do + helper "עִבְרִי" [$hamlet|עִבְרִי|] + +caseMaybeFunction :: Assertion +caseMaybeFunction = do + helper "url?foo=bar&foo1=bar1" [$hamlet| +$maybe Just.urlParams x + @?x.theArg@ +|]