hamlet 0.10.9.1 → 1.2.0
raw patch · 16 files changed
Files
- LICENSE +17/−22
- Text/Hamlet.hs +0/−292
- Text/Hamlet/Parse.hs +0/−520
- Text/Hamlet/RT.hs +0/−179
- hamlet.cabal +7/−49
- test.hs +0/−5
- test/HamletTest.hs +0/−831
- test/hamlets/double-foralls.hamlet +0/−3
- test/hamlets/external-debug.hamlet +0/−1
- test/hamlets/external-debug2.hamlet +0/−29
- test/hamlets/external-debug3.hamlet +0/−4
- test/hamlets/external.hamlet +0/−2
- test/hamlets/nonpolyhamlet.hamlet +0/−1
- test/hamlets/nonpolyhtml.hamlet +0/−1
- test/hamlets/nonpolyihamlet.hamlet +0/−1
- test/tmp.hs +0/−17
LICENSE view
@@ -1,25 +1,20 @@-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:+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ -* Redistributions of source code must retain the above copyright notice, this- list of conditions and the following disclaimer.+Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions: -* 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.+The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software. -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.+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
− Text/Hamlet.hs
@@ -1,292 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-}-module Text.Hamlet- ( -- * Plain HTML- Html- , shamlet- , shamletFile- , xshamlet- , xshamletFile- -- * Hamlet- , HtmlUrl- , hamlet- , hamletFile- , xhamlet- , xhamletFile- -- * I18N Hamlet- , HtmlUrlI18n- , ihamlet- , ihamletFile- -- * Internal, for making more- , HamletSettings- , hamletWithSettings- , hamletFileWithSettings- , defaultHamletSettings- , xhtmlHamletSettings- , Env (..)- , HamletRules (..)- ) where--import Text.Shakespeare.Base-import Text.Hamlet.Parse-import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Quote-import Data.Char (isUpper, isDigit)-import Data.Maybe (fromMaybe)-import Data.Text (Text, pack)-import qualified Data.Text.Lazy as TL-import Text.Blaze (Html, preEscapedText, toHtml)-import qualified Data.Foldable as F-import Control.Monad (mplus)--type Render url = url -> [(Text, Text)] -> Text-type Translate msg = msg -> Html---- | A function generating an 'Html' given a URL-rendering function.-type HtmlUrl url = Render url -> Html---- | A function generating an 'Html' given a message translator and a URL rendering function.-type HtmlUrlI18n msg url = Translate msg -> Render url -> Html--docsToExp :: Env -> HamletRules -> Scope -> [Doc] -> Q Exp-docsToExp env hr scope docs = do- exps <- mapM (docToExp env hr scope) docs- case exps of- [] -> [|return ()|]- [x] -> return x- _ -> return $ DoE $ map NoBindS exps--unIdent :: Ident -> String-unIdent (Ident s) = s--bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)])-bindingPattern (BindVar i@(Ident s)) = do- name <- newName s- return (VarP name, [(i, VarE name)])-bindingPattern (BindTuple is) = do- names <- mapM (newName . unIdent) is- return (TupP $ map VarP names, zip is $ map VarE names)-bindingPattern (BindConstr (Ident con) is) = do- names <- mapM (newName . unIdent) is- return (ConP (mkName con) (map VarP names), zip is $ map VarE names)--docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp-docToExp env hr scope (DocForall list idents inside) = do- let list' = derefToExp scope list- (pat, extraScope) <- bindingPattern idents- let scope' = extraScope ++ scope- mh <- [|F.mapM_|]- inside' <- docsToExp env hr scope' inside- let lam = LamE [pat] inside'- return $ mh `AppE` lam `AppE` list'-docToExp env hr scope (DocWith [] inside) = do- inside' <- docsToExp env hr scope inside- return $ inside'-docToExp env hr scope (DocWith ((deref, idents):dis) inside) = do- let deref' = derefToExp scope deref- (pat, extraScope) <- bindingPattern idents- let scope' = extraScope ++ scope- inside' <- docToExp env hr scope' (DocWith dis inside)- let lam = LamE [pat] inside'- return $ lam `AppE` deref'-docToExp env hr scope (DocMaybe val idents inside mno) = do- let val' = derefToExp scope val- (pat, extraScope) <- bindingPattern idents- let scope' = extraScope ++ scope- inside' <- docsToExp env hr scope' inside- let inside'' = LamE [pat] inside'- ninside' <- case mno of- Nothing -> [|Nothing|]- Just no -> do- no' <- docsToExp env hr scope no- j <- [|Just|]- return $ j `AppE` no'- mh <- [|maybeH|]- return $ mh `AppE` val' `AppE` inside'' `AppE` ninside'-docToExp env hr scope (DocCond conds final) = do- conds' <- mapM go conds- final' <- case final of- Nothing -> [|Nothing|]- Just f -> do- f' <- docsToExp env hr scope f- j <- [|Just|]- return $ j `AppE` f'- ch <- [|condH|]- return $ ch `AppE` ListE conds' `AppE` final'- where- go :: (Deref, [Doc]) -> Q Exp- go (d, docs) = do- let d' = derefToExp scope d- docs' <- docsToExp env hr scope docs- return $ TupE [d', docs']-docToExp env hr scope (DocCase deref cases) = do- let exp_ = derefToExp scope deref- matches <- mapM toMatch cases- return $ CaseE exp_ matches- where- toMatch (idents, inside) = do- let pat = case map unIdent idents of- ["_"] -> WildP- strs -> let (constr:fields) = map mkName strs- in ConP constr (map VarP fields)- insideExp <- docsToExp env hr scope inside- return $ Match pat (NormalB insideExp) []-docToExp env hr v (DocContent c) = contentToExp env hr v c--contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp-contentToExp _ hr _ (ContentRaw s) = do- os <- [|preEscapedText . pack|]- let s' = LitE $ StringL s- return $ hrFromHtml hr `AppE` (os `AppE` s')-contentToExp _ hr scope (ContentVar d) = do- str <- [|toHtml|]- return $ hrFromHtml hr `AppE` (str `AppE` derefToExp scope d)-contentToExp env hr scope (ContentUrl hasParams d) =- case urlRender env of- Nothing -> error "URL interpolation used, but no URL renderer provided"- Just wrender -> wrender $ \render -> do- let render' = return render- ou <- if hasParams- then [|\(u, p) -> $(render') u p|]- else [|\u -> $(render') u []|]- let d' = derefToExp scope d- pet <- [|toHtml|]- return $ hrFromHtml hr `AppE` (pet `AppE` (ou `AppE` d'))-contentToExp env hr scope (ContentEmbed d) = hrEmbed hr env $ derefToExp scope d-contentToExp env hr scope (ContentMsg d) =- case msgRender env of- Nothing -> error "Message interpolation used, but no message renderer provided"- Just wrender -> wrender $ \render ->- return $ hrFromHtml hr `AppE` (render `AppE` derefToExp scope d)--shamlet :: QuasiQuoter-shamlet = hamletWithSettings htmlRules defaultHamletSettings--xshamlet :: QuasiQuoter-xshamlet = hamletWithSettings htmlRules xhtmlHamletSettings--htmlRules :: Q HamletRules-htmlRules = do- i <- [|id|]- return $ HamletRules i ($ (Env Nothing Nothing)) (\_ b -> return b)--hamlet :: QuasiQuoter-hamlet = hamletWithSettings hamletRules defaultHamletSettings--xhamlet :: QuasiQuoter-xhamlet = hamletWithSettings hamletRules xhtmlHamletSettings--hamletRules :: Q HamletRules-hamletRules = do- i <- [|id|]- let ur f = do- r <- newName "_render"- let env = Env- { urlRender = Just ($ (VarE r))- , msgRender = Nothing- }- h <- f env- return $ LamE [VarP r] h- return $ HamletRules i ur em- where- em (Env (Just urender) Nothing) e =- urender $ \ur' -> return (e `AppE` ur')- em _ _ = error "bad Env"--ihamlet :: QuasiQuoter-ihamlet = hamletWithSettings ihamletRules defaultHamletSettings--ihamletRules :: Q HamletRules-ihamletRules = do- i <- [|id|]- let ur f = do- u <- newName "_urender"- m <- newName "_mrender"- let env = Env- { urlRender = Just ($ (VarE u))- , msgRender = Just ($ (VarE m))- }- h <- f env- return $ LamE [VarP m, VarP u] h- return $ HamletRules i ur em- where- em (Env (Just urender) (Just mrender)) e =- urender $ \ur' -> mrender $ \mr -> return (e `AppE` mr `AppE` ur')- em _ _ = error "bad Env"--hamletWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter-hamletWithSettings hr set =- QuasiQuoter- { quoteExp = hamletFromString hr set- }--data HamletRules = HamletRules- { hrFromHtml :: Exp- , hrWithEnv :: (Env -> Q Exp) -> Q Exp- , hrEmbed :: Env -> Exp -> Q Exp- }--data Env = Env- { urlRender :: Maybe ((Exp -> Q Exp) -> Q Exp)- , msgRender :: Maybe ((Exp -> Q Exp) -> Q Exp)- }--hamletFromString :: Q HamletRules -> HamletSettings -> String -> Q Exp-hamletFromString qhr set s = do- hr <- qhr- case parseDoc set s of- Error s' -> error s'- Ok d -> hrWithEnv hr $ \env -> docsToExp env hr [] d--hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp-hamletFileWithSettings qhr set fp = do-#ifdef GHC_7_4- qAddDependentFile fp-#endif- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp- hamletFromString qhr set contents--hamletFile :: FilePath -> Q Exp-hamletFile = hamletFileWithSettings hamletRules defaultHamletSettings--xhamletFile :: FilePath -> Q Exp-xhamletFile = hamletFileWithSettings hamletRules xhtmlHamletSettings--shamletFile :: FilePath -> Q Exp-shamletFile = hamletFileWithSettings htmlRules defaultHamletSettings--xshamletFile :: FilePath -> Q Exp-xshamletFile = hamletFileWithSettings htmlRules xhtmlHamletSettings--ihamletFile :: FilePath -> Q Exp-ihamletFile = hamletFileWithSettings ihamletRules defaultHamletSettings--varName :: Scope -> String -> Exp-varName _ "" = error "Illegal empty varName"-varName scope v@(_:_) = fromMaybe (strToExp v) $ lookup (Ident v) scope--strToExp :: String -> Exp-strToExp s@(c:_)- | all isDigit s = LitE $ IntegerL $ read s- | isUpper c = ConE $ mkName s- | otherwise = VarE $ mkName s-strToExp "" = error "strToExp on empty string"---- | 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 => [(Bool, m ())] -> Maybe (m ()) -> m ()-condH bms mm = fromMaybe (return ()) $ lookup True bms `mplus` mm---- | 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 -> m ()) -> Maybe (m ()) -> m ()-maybeH mv f mm = fromMaybe (return ()) $ fmap f mv `mplus` mm
− Text/Hamlet/Parse.hs
@@ -1,520 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE CPP #-}-module Text.Hamlet.Parse- ( Result (..)- , Content (..)- , Doc (..)- , parseDoc- , HamletSettings (..)- , defaultHamletSettings- , xhtmlHamletSettings- , debugHamletSettings- , CloseStyle (..)- , Binding (..)- )- where--import Text.Shakespeare.Base-import Control.Applicative ((<$>), Applicative (..))-import Control.Monad-import Control.Arrow-import Data.Data-import Text.ParserCombinators.Parsec hiding (Line)-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Maybe (mapMaybe)--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--data Content = ContentRaw String- | ContentVar Deref- | ContentUrl Bool Deref -- ^ bool: does it include params?- | ContentEmbed Deref- | ContentMsg Deref- deriving (Show, Eq, Read, Data, Typeable)--data Line = LineForall Deref Binding- | LineIf Deref- | LineElseIf Deref- | LineElse- | LineWith [(Deref, Binding)]- | LineMaybe Deref Binding- | LineNothing- | LineCase Deref- | LineOf [Ident]- | LineTag- { _lineTagName :: String- , _lineAttr :: [(Maybe Deref, String, [Content])]- , _lineContent :: [Content]- , _lineClasses :: [(Maybe Deref, [Content])]- }- | LineContent [Content]- deriving (Eq, Show, Read)--parseLines :: HamletSettings -> String -> Result [(Int, Line)]-parseLines set s =- case parse (many $ parseLine set) s s of- Left e -> Error $ show e- Right x -> Ok x--parseLine :: HamletSettings -> Parser (Int, Line)-parseLine set = do- ss <- fmap sum $ many ((char ' ' >> return 1) <|>- (char '\t' >> fail "Tabs are not allowed in Hamlet indentation"))- x <- doctype <|>- doctypeDollar <|>- comment <|>- htmlComment <|>- backslash <|>- controlIf <|>- controlElseIf <|>- (try (string "$else") >> spaceTabs >> eol >> return LineElse) <|>- controlMaybe <|>- (try (string "$nothing") >> spaceTabs >> eol >> return LineNothing) <|>- controlForall <|>- controlWith <|>- controlCase <|>- controlOf <|>- angle <|>- invalidDollar <|>- (eol' >> return (LineContent [])) <|>- (do- cs <- content InContent- isEof <- (eof >> return True) <|> return False- if null cs && ss == 0 && isEof- then fail "End of Hamlet template"- else return $ LineContent cs)- return (ss, x)- where- eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ())- eol = eof <|> eol'- spaceTabs = many $ oneOf " \t"- doctype = do- try $ string "!!!" >> eol- return $ LineContent [ContentRaw $ hamletDoctype set ++ "\n"]- doctypeDollar = do- _ <- try $ string "$doctype "- name <- many $ noneOf "\r\n"- eol- case lookup name doctypeNames of- Nothing -> fail $ "Unknown doctype name: " ++ name- Just val -> return $ LineContent [ContentRaw $ val ++ "\n"]-- invalidDollar = do- _ <- char '$'- fail "Received a command I did not understand. If you wanted a literal $, start the line with a backslash."- comment = do- _ <- try $ string "$#"- _ <- many $ noneOf "\r\n"- eol- return $ LineContent []- htmlComment = do- _ <- try $ string "<!--"- _ <- manyTill anyChar $ try $ string "-->"- x <- many nonComments- eol- return $ LineContent [ContentRaw $ concat x] -- FIXME handle variables?- nonComments = (many1 $ noneOf "\r\n<") <|> (do- _ <- char '<'- (do- _ <- try $ string "!--"- _ <- manyTill anyChar $ try $ string "-->"- return "") <|> return "<")- backslash = do- _ <- char '\\'- (eol >> return (LineContent [ContentRaw "\n"]))- <|> (LineContent <$> content InContent)- controlIf = do- _ <- try $ string "$if"- spaces- x <- parseDeref- _ <- spaceTabs- eol- return $ LineIf x- controlElseIf = do- _ <- try $ string "$elseif"- spaces- x <- parseDeref- _ <- spaceTabs- eol- return $ LineElseIf x- binding = do- y <- identPattern- spaces- _ <- string "<-"- spaces- x <- parseDeref- _ <- spaceTabs- return (x,y)- bindingSep = char ',' >> spaceTabs- controlMaybe = do- _ <- try $ string "$maybe"- spaces- (x,y) <- binding- eol- return $ LineMaybe x y- controlForall = do- _ <- try $ string "$forall"- spaces- (x,y) <- binding- eol- return $ LineForall x y- controlWith = do- _ <- try $ string "$with"- spaces- bindings <- (binding `sepBy` bindingSep) `endBy` eol- return $ LineWith $ concat bindings -- concat because endBy returns a [[(Deref,Ident)]]- controlCase = do- _ <- try $ string "$case"- spaces- x <- parseDeref- _ <- spaceTabs- eol- return $ LineCase x- controlOf = do- _ <- try $ string "$of"- pat <- many1 $ try $ spaces >> ident- _ <- spaceTabs- eol- return $ LineOf pat- content cr = do- x <- many $ content' cr- case cr of- InQuotes -> char '"' >> return ()- NotInQuotes -> return ()- NotInQuotesAttr -> return ()- InContent -> eol- return $ cc x- where- cc [] = []- cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c- cc (a:b) = a : cc b- content' cr = contentHash <|> contentAt <|> contentCaret- <|> contentUnder- <|> contentReg cr- contentHash = do- x <- parseHash- case x of- Left str -> return $ ContentRaw str- Right deref -> return $ ContentVar deref- contentAt = do- x <- parseAt- return $ case x of- Left str -> ContentRaw str- Right (s, y) -> ContentUrl y s- contentCaret = do- x <- parseCaret- case x of- Left str -> return $ ContentRaw str- Right deref -> return $ ContentEmbed deref- contentUnder = do- x <- parseUnder- case x of- Left str -> return $ ContentRaw str- Right deref -> return $ ContentMsg deref- contentReg InContent = (ContentRaw . return) <$> noneOf "#@^\r\n"- contentReg NotInQuotes = (ContentRaw . return) <$> noneOf "@^#. \t\n\r>"- contentReg NotInQuotesAttr = (ContentRaw . return) <$> noneOf "@^ \t\n\r>"- contentReg InQuotes = (ContentRaw . return) <$> noneOf "#@^\\\"\n\r>"- tagAttribValue notInQuotes = do- cr <- (char '"' >> return InQuotes) <|> return notInQuotes- content cr- tagIdent = char '#' >> TagIdent <$> tagAttribValue NotInQuotes- tagCond = do- d <- between (char ':') (char ':') parseDeref- tagClass (Just d) <|> tagAttrib (Just d)- tagClass x = char '.' >> (TagClass . (,) x) <$> tagAttribValue NotInQuotes- tagAttrib cond = do- s <- many1 $ noneOf " \t=\r\n>"- v <- (char '=' >> tagAttribValue NotInQuotesAttr) <|> return []- return $ TagAttrib (cond, s, v)- tag' = foldr tag'' ("div", [], [])- tag'' (TagName s) (_, y, z) = (s, y, z)- tag'' (TagIdent s) (x, y, z) = (x, (Nothing, "id", s) : y, z)- tag'' (TagClass s) (x, y, z) = (x, y, s : z)- tag'' (TagAttrib s) (x, y, z) = (x, s : y, z)-- ident :: Parser Ident- ident = Ident <$> many1 (alphaNum <|> char '_' <|> char '\'')-- identPattern :: Parser Binding- identPattern = (between- (char '(' >> spaces)- (spaces >> char ')' >> spaces)- (BindTuple <$> sepBy1 ident (spaces >> char ',' >> spaces))- ) <|> (do- i <- ident- is <- many $ try $ (many $ char ' ') >> ident- if null is- then return $ BindVar i- else return $ BindConstr i is- )- angle = do- _ <- char '<'- name' <- many $ noneOf " \t.#\r\n!>"- let name = if null name' then "div" else name'- xs <- many $ try ((many $ oneOf " \t") >>- (tagIdent <|> tagCond <|> tagClass Nothing <|> tagAttrib Nothing))- _ <- many $ oneOf " \t"- c <- (eol >> return []) <|> (char '>' >> content InContent)- let (tn, attr, classes) = tag' $ TagName name : xs- if '/' `elem` tn- then fail "A tag name may not contain a slash. Perhaps you have a closing tag in your HTML."- else return $ LineTag tn attr c classes--data TagPiece = TagName String- | TagIdent [Content]- | TagClass (Maybe Deref, [Content])- | TagAttrib (Maybe Deref, String, [Content])- deriving Show--data ContentRule = InQuotes | NotInQuotes | NotInQuotesAttr | InContent--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 Binding [Doc]- | DocWith [(Deref, Binding)] [Doc]- | DocCond [(Deref, [Doc])] (Maybe [Doc])- | DocMaybe Deref Binding [Doc] (Maybe [Doc])- | DocCase Deref [([Ident], [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 (LineWith dis) inside:rest) = do- inside' <- nestToDoc set inside- rest' <- nestToDoc set rest- Ok $ DocWith dis 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 (LineMaybe d i) inside:rest) = do- inside' <- nestToDoc set inside- (nothing, rest') <-- case rest of- Nest LineNothing ninside:x -> do- ninside' <- nestToDoc set ninside- return (Just ninside', x)- _ -> return (Nothing, rest)- rest'' <- nestToDoc set rest'- Ok $ DocMaybe d i inside' nothing : rest''-nestToDoc set (Nest (LineCase d) inside:rest) = do- let getOf (Nest (LineOf pat) insideC) = do- insideC' <- nestToDoc set insideC- Ok (pat, insideC')- getOf _ = Error "Inside a $case there may only be $of. Use '$of _' for a wildcard."- cases <- mapM getOf inside- rest' <- nestToDoc set rest- Ok $ DocCase d cases : rest'-nestToDoc set (Nest (LineTag tn attrs content classes) inside:rest) = do- let attrFix (x, y, z) = (x, y, [(Nothing, z)])- let takeClass (a, "class", b) = Just (a, b)- takeClass _ = Nothing- let clazzes = classes ++ mapMaybe takeClass attrs- let notClass (_, x, _) = x /= "class"- let noclass = filter notClass attrs- let attrs' =- case clazzes of- [] -> map attrFix noclass- _ -> (Nothing, "class", clazzes)- : map attrFix noclass- let closeStyle =- if not (null content) || not (null inside)- then CloseSeparate- else hamletCloseStyle set tn- let end = case closeStyle of- CloseSeparate ->- DocContent $ ContentRaw $ "</" ++ tn ++ ">"- _ -> DocContent $ ContentRaw ""- seal = case closeStyle of- CloseInside -> DocContent $ ContentRaw "/>"- _ -> DocContent $ ContentRaw ">"- start = DocContent $ ContentRaw $ "<" ++ tn- attrs'' = concatMap attrToContent attrs'- newline' = DocContent $ ContentRaw- $ if hamletCloseNewline set then "\n" else ""- inside' <- nestToDoc set inside- rest' <- nestToDoc set rest- Ok $ start- : attrs''- ++ seal- : map DocContent content- ++ inside'- ++ end- : newline'- : rest'-nestToDoc set (Nest (LineContent content) inside:rest) = do- inside' <- nestToDoc set inside- rest' <- nestToDoc set 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"-nestToDoc _set (Nest (LineOf _) _:_) = Error "Unexpected 'of' (did you forget a $case?)"--compressDoc :: [Doc] -> [Doc]-compressDoc [] = []-compressDoc (DocForall d i doc:rest) =- DocForall d i (compressDoc doc) : compressDoc rest-compressDoc (DocWith dis doc:rest) =- DocWith dis (compressDoc doc) : compressDoc rest-compressDoc (DocMaybe d i doc mnothing:rest) =- DocMaybe d i (compressDoc doc) (fmap compressDoc mnothing)- : compressDoc rest-compressDoc (DocCond [(a, x)] Nothing:DocCond [(b, y)] Nothing:rest)- | a == b = compressDoc $ DocCond [(a, x ++ y)] Nothing : rest-compressDoc (DocCond x y:rest) =- DocCond (map (second compressDoc) x) (compressDoc `fmap` y)- : compressDoc rest-compressDoc (DocCase d cs:rest) =- DocCase d (map (second compressDoc) cs) : compressDoc 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- ls <- parseLines set s- let notEmpty (_, LineContent []) = False- notEmpty _ = True- let ns = nestLines $ filter notEmpty ls- ds <- nestToDoc set ns- return $ compressDoc ds--attrToContent :: (Maybe Deref, String, [(Maybe Deref, [Content])]) -> [Doc]-attrToContent (Just cond, k, v) =- [DocCond [(cond, attrToContent (Nothing, k, v))] Nothing]-attrToContent (Nothing, k, []) = [DocContent $ ContentRaw $ ' ' : k]-attrToContent (Nothing, k, [(Nothing, [])]) = [DocContent $ ContentRaw $ ' ' : k]-attrToContent (Nothing, k, [(Nothing, v)]) =- DocContent (ContentRaw (' ' : k ++ "=\""))- : map DocContent v- ++ [DocContent $ ContentRaw "\""]-attrToContent (Nothing, k, v) = -- only for class- DocContent (ContentRaw (' ' : k ++ "=\""))- : concatMap go (init v)- ++ go' (last v)- ++ [DocContent $ ContentRaw "\""]- where- go (Nothing, x) = map DocContent x ++ [DocContent $ ContentRaw " "]- go (Just b, x) =- [ DocCond- [(b, map DocContent x ++ [DocContent $ ContentRaw " "])]- Nothing- ]- go' (Nothing, x) = map DocContent x- go' (Just b, x) =- [ DocCond- [(b, map DocContent x)]- Nothing- ]---- | Settings for parsing of a hamlet document.-data HamletSettings = HamletSettings- {- -- | The value to replace a \"!!!\" with. Do not include the trailing- -- newline.- hamletDoctype :: String- -- | Should we put a newline after closing a tag? Mostly useful for debug- -- output.- , hamletCloseNewline :: Bool- -- | How a tag should be closed. Use this to switch between HTML, XHTML- -- or even XML output.- , hamletCloseStyle :: String -> CloseStyle- }--htmlEmptyTags :: Set String-htmlEmptyTags = Set.fromAscList- [ "area"- , "base"- , "basefont"- , "br"- , "col"- , "frame"- , "hr"- , "img"- , "input"- , "isindex"- , "link"- , "meta"- , "param"- ]---- | Defaults settings: HTML5 doctype and HTML-style empty tags.-defaultHamletSettings :: HamletSettings-defaultHamletSettings = HamletSettings "<!DOCTYPE html>" False htmlCloseStyle--xhtmlHamletSettings :: HamletSettings-xhtmlHamletSettings =- HamletSettings doctype False xhtmlCloseStyle- where- doctype =- "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" " ++- "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"--debugHamletSettings :: HamletSettings-debugHamletSettings = HamletSettings "<!DOCTYPE html>" True htmlCloseStyle--htmlCloseStyle :: String -> CloseStyle-htmlCloseStyle s =- if Set.member s htmlEmptyTags- then NoClose- else CloseSeparate--xhtmlCloseStyle :: String -> CloseStyle-xhtmlCloseStyle s =- if Set.member s htmlEmptyTags- then CloseInside- else CloseSeparate--data CloseStyle = NoClose | CloseInside | CloseSeparate--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)--doctypeNames :: [(String, String)]-doctypeNames =- [ ("5", "<!DOCTYPE html>")- , ("html", "<!DOCTYPE html>")- , ("1.1", "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">")- , ("strict", "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")- ]--data Binding = BindVar Ident | BindConstr Ident [Ident] | BindTuple [Ident]- deriving (Eq, Show, Read, Data, Typeable)
− Text/Hamlet/RT.hs
@@ -1,179 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DeriveDataTypeable #-}--- | Most everything exported here is exported also by "Text.Hamlet". The--- exceptions to that rule should not be necessary for normal usage.-module Text.Hamlet.RT- ( -- * Public API- HamletRT (..)- , HamletData (..)- , HamletMap- , HamletException (..)- , parseHamletRT- , renderHamletRT- , renderHamletRT'- , SimpleDoc (..)- ) where--import Text.Shakespeare.Base-import Data.Monoid (mconcat)-import Control.Monad (liftM, forM)-import Control.Exception (Exception)-import Data.Typeable (Typeable)-import Control.Failure-import Text.Hamlet.Parse-import Data.List (intercalate)-import Text.Blaze (preEscapedString, preEscapedText, Html)-import Data.Text (Text)--type HamletMap url = [([String], HamletData url)]--data HamletData url- = HDHtml Html- | HDUrl url- | HDUrlParams url [(Text, Text)]- | HDTemplate HamletRT- | HDBool Bool- | HDMaybe (Maybe (HamletMap url))- | HDList [HamletMap url]---- FIXME switch to Text?-data SimpleDoc = SDRaw String- | SDVar [String]- | SDUrl Bool [String]- | SDTemplate [String]- | SDForall [String] String [SimpleDoc]- | SDMaybe [String] String [SimpleDoc] [SimpleDoc]- | SDCond [([String], [SimpleDoc])] [SimpleDoc]--newtype HamletRT = HamletRT [SimpleDoc]--data HamletException = HamletParseException String- | HamletUnsupportedDocException Doc- | HamletRenderException String- deriving (Show, Typeable)-instance Exception HamletException--parseHamletRT :: Failure HamletException m- => HamletSettings -> String -> m HamletRT-parseHamletRT set s =- case parseDoc set s of- Error s' -> failure $ HamletParseException s'- Ok x -> liftM HamletRT $ mapM convert x- where- convert x@(DocForall deref (BindVar (Ident ident)) docs) = do- deref' <- flattenDeref' x deref- docs' <- mapM convert docs- return $ SDForall deref' ident docs'- convert DocForall{} = error "Runtime Hamlet does not currently support tuple patterns"- convert x@(DocMaybe deref (BindVar (Ident ident)) jdocs ndocs) = do- deref' <- flattenDeref' x deref- jdocs' <- mapM convert jdocs- ndocs' <- maybe (return []) (mapM convert) ndocs- return $ SDMaybe deref' ident jdocs' ndocs'- convert DocMaybe{} = error "Runtime Hamlet does not currently support tuple patterns"- convert (DocContent (ContentRaw s')) = return $ SDRaw s'- convert x@(DocContent (ContentVar deref)) = do- y <- flattenDeref' x deref- return $ SDVar y- convert x@(DocContent (ContentUrl p deref)) = do- y <- flattenDeref' x deref- return $ SDUrl p y- convert x@(DocContent (ContentEmbed deref)) = do- y <- flattenDeref' x deref- return $ SDTemplate y- convert (DocContent ContentMsg{}) =- error "Runtime hamlet does not currently support message interpolation"- convert x@(DocCond conds els) = do- conds' <- mapM go conds- els' <- maybe (return []) (mapM convert) els- return $ SDCond conds' els'- where- go (deref, docs') = do- deref' <- flattenDeref' x deref- docs'' <- mapM convert docs'- return (deref', docs'')- convert DocWith{} = error "Runtime hamlet does not currently support $with"- convert DocCase{} = error "Runtime hamlet does not currently support $case"--renderHamletRT :: Failure HamletException m- => HamletRT- -> HamletMap url- -> (url -> [(Text, Text)] -> Text)- -> m Html-renderHamletRT = renderHamletRT' False--renderHamletRT' :: Failure HamletException m- => Bool- -> HamletRT- -> HamletMap url- -> (url -> [(Text, Text)] -> Text)- -> m Html-renderHamletRT' tempAsHtml (HamletRT docs) scope0 renderUrl =- liftM mconcat $ mapM (go scope0) docs- where- go _ (SDRaw s) = return $ preEscapedString s- go scope (SDVar n) = do- v <- lookup' n n scope- case v of- HDHtml h -> return h- _ -> fa $ showName n ++ ": expected HDHtml"- go scope (SDUrl p n) = do- v <- lookup' n n scope- case (p, v) of- (False, HDUrl u) -> return $ preEscapedText $ renderUrl u []- (True, HDUrlParams u q) ->- return $ preEscapedText $ renderUrl u q- (False, _) -> fa $ showName n ++ ": expected HDUrl"- (True, _) -> fa $ showName n ++ ": expected HDUrlParams"- go scope (SDTemplate n) = do- v <- lookup' n n scope- case (tempAsHtml, v) of- (False, HDTemplate h) -> renderHamletRT' tempAsHtml h scope renderUrl- (False, _) -> fa $ showName n ++ ": expected HDTemplate"- (True, HDHtml h) -> return h- (True, _) -> fa $ showName n ++ ": expected HDHtml"- go scope (SDForall n ident docs') = do- v <- lookup' n n scope- case v of- HDList os ->- liftM mconcat $ forM os $ \o -> do- let scope' = map (\(x, y) -> (ident : x, y)) o ++ scope- renderHamletRT' tempAsHtml (HamletRT docs') scope' renderUrl- _ -> fa $ showName n ++ ": expected HDList"- go scope (SDMaybe n ident jdocs ndocs) = do- v <- lookup' n n scope- (scope', docs') <-- case v of- HDMaybe Nothing -> return (scope, ndocs)- HDMaybe (Just o) -> do- let scope' = map (\(x, y) -> (ident : x, y)) o ++ scope- return (scope', jdocs)- _ -> fa $ showName n ++ ": expected HDMaybe"- renderHamletRT' tempAsHtml (HamletRT docs') scope' renderUrl- go scope (SDCond [] docs') =- renderHamletRT' tempAsHtml (HamletRT docs') scope renderUrl- go scope (SDCond ((b, docs'):cs) els) = do- v <- lookup' b b scope- case v of- HDBool True ->- renderHamletRT' tempAsHtml (HamletRT docs') scope renderUrl- HDBool False -> go scope (SDCond cs els)- _ -> fa $ showName b ++ ": expected HDBool"- lookup' :: Failure HamletException m- => [String] -> [String] -> HamletMap url -> m (HamletData url)- lookup' orig k m =- case lookup k m of- Nothing -> fa $ showName orig ++ ": not found"- Just x -> return x--fa :: Failure HamletException m => String -> m a-fa = failure . HamletRenderException--showName :: [String] -> String-showName = intercalate "." . reverse--flattenDeref' :: Failure HamletException f => Doc -> Deref -> f [String]-flattenDeref' orig deref =- case flattenDeref deref of- Nothing -> failure $ HamletUnsupportedDocException orig- Just x -> return x
hamlet.cabal view
@@ -1,14 +1,14 @@ name: hamlet-version: 0.10.9.1-license: BSD3+version: 1.2.0+license: MIT 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+synopsis: Haml-like template files that are compile-time checked (deprecated) description:- Hamlet gives you a type-safe tool for generating HTML code. It works via Quasi-Quoting, and generating extremely efficient output code. The syntax is white-space sensitive, and it helps you avoid cross-site scripting issues and 404 errors. Please see the documentation at <http://docs.yesodweb.com/book/hamlet/> for more details.+ Hamlet gives you a type-safe tool for generating HTML code. It works via Quasi-Quoting, and generating extremely efficient output code. The syntax is white-space sensitive, and it helps you avoid cross-site scripting issues and 404 errors. Please see the documentation at <http://www.yesodweb.com/book/shakespearean-templates> for more details. .- Here is a quick overview of hamlet html. Due to haddock escaping issues, we can't properly show variable insertion, but we are still going to show some conditionals. Please see <http://www.yesodweb.com/book/templates> for a thorough description+ Here is a quick overview of hamlet html. Due to haddock escaping issues, we can't properly show variable insertion, but we are still going to show some conditionals. Please see <http://www.yesodweb.com/book/shakespearean-templates> for a thorough description . > !!! > <html>@@ -25,53 +25,11 @@ stability: Stable cabal-version: >= 1.8 build-type: Simple-homepage: http://www.yesodweb.com/book/templates-extra-source-files:- test/hamlets/double-foralls.hamlet- test/hamlets/external-debug.hamlet- test/hamlets/external-debug2.hamlet- test/hamlets/external-debug3.hamlet- test/hamlets/external.hamlet- test/hamlets/nonpolyhamlet.hamlet- test/hamlets/nonpolyhtml.hamlet- test/hamlets/nonpolyihamlet.hamlet- test/HamletTest.hs- test/tmp.hs- test.hs+homepage: http://www.yesodweb.com/book/shakespearean-templates library build-depends: base >= 4 && < 5- , shakespeare >= 0.10.2 && < 0.12- , bytestring >= 0.9 && < 0.10- , template-haskell- , blaze-html >= 0.4 && < 0.5- , parsec >= 2 && < 4- , failure >= 0.1 && < 0.3- , text >= 0.7 && < 0.12- , containers >= 0.2 && < 0.5- , blaze-builder >= 0.2 && < 0.4- , process >= 1.0 && < 1.2- exposed-modules: Text.Hamlet- Text.Hamlet.RT- other-modules: Text.Hamlet.Parse- ghc-options: -Wall- if impl(ghc >= 7.4)- cpp-options: -DGHC_7_4--test-suite test- hs-source-dirs: test- main-is: ../test.hs- type: exitcode-stdio-1.0-- ghc-options: -Wall- build-depends: hamlet >= 0.10 && < 0.11- , base >= 4 && < 5- , parsec >= 2 && < 4- , containers >= 0.2 && < 0.5- , text >= 0.7 && < 1- , HUnit- , hspec >= 0.8 && < 0.10- , blaze-html >= 0.4 && < 0.5+ , shakespeare >= 2.0 source-repository head
− test.hs
@@ -1,5 +0,0 @@-import HamletTest (specs)-import Test.Hspec--main :: IO ()-main = hspecX $ descriptions [specs]
− test/HamletTest.hs
@@ -1,831 +0,0 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -module HamletTest (specs) where - -import Test.HUnit hiding (Test) -import Test.Hspec -import Test.Hspec.HUnit - -import Prelude hiding (reverse) -import Text.Hamlet -import Data.List (intercalate) -import qualified Data.Text.Lazy as T -import qualified Data.List -import qualified Data.List as L -import qualified Data.Map as Map -import Data.Text (Text, pack, unpack) -import Data.Monoid (mappend) -import qualified Data.Set as Set -import qualified Text.Blaze.Renderer.Text -import Text.Blaze (toHtml, preEscapedString) - -specs = describe "hamlet" - [ it "empty" caseEmpty - , it "static" caseStatic - , it "tag" caseTag - , it "var" caseVar - , it "var chain " caseVarChain - , it "url" caseUrl - , it "url chain " caseUrlChain - , it "embed" caseEmbed - , it "embed chain " caseEmbedChain - , it "if" caseIf - , it "if chain " caseIfChain - , it "else" caseElse - , it "else chain " caseElseChain - , it "elseif" caseElseIf - , it "elseif chain " caseElseIfChain - , it "list" caseList - , it "list chain" caseListChain - , it "with" caseWith - , it "with multi" caseWithMulti - , it "with chain" caseWithChain - , it "with comma string" caseWithCommaString - , it "with multi scope" caseWithMultiBindingScope - , it "script not empty" caseScriptNotEmpty - , it "meta empty" caseMetaEmpty - , it "input empty" caseInputEmpty - , it "multiple classes" caseMultiClass - , it "attrib order" caseAttribOrder - , it "nothing" caseNothing - , it "nothing chain " caseNothingChain - , it "just" caseJust - , it "just chain " caseJustChain - , it "constructor" caseConstructor - , it "url + params" caseUrlParams - , it "escape" caseEscape - , it "empty statement list" caseEmptyStatementList - , it "attribute conditionals" caseAttribCond - , it "non-ascii" caseNonAscii - , it "maybe function" caseMaybeFunction - , it "trailing dollar sign" caseTrailingDollarSign - , it "non leading percent sign" caseNonLeadingPercent - , it "quoted attributes" caseQuotedAttribs - , it "spaced derefs" caseSpacedDerefs - , it "attrib vars" caseAttribVars - , it "strings and html" caseStringsAndHtml - , it "nesting" caseNesting - , it "trailing space" caseTrailingSpace - , it "currency symbols" caseCurrency - , it "external" caseExternal - , it "parens" caseParens - , it "hamlet literals" caseHamletLiterals - , it "hamlet' and xhamlet'" caseHamlet' - - - - , it "comments" $ do - -- FIXME reconsider Hamlet comment syntax? - helper "" [hamlet|$# this is a comment -$# another comment -$#a third one|] - - - , it "ignores a blank line" $ do - helper "<p>foo</p>" [hamlet| -<p - - foo - - -|] - - - - - , it "hamlet angle bracket syntax" $ - helper "<p class=\"foo\" height=\"100\"><span id=\"bar\" width=\"50\">HELLO</span></p>" - [hamlet| -<p.foo height="100" - <span #bar width=50>HELLO -|] - - - - , it "hamlet module names" $ - let foo = "foo" in - helper "oof oof 3.14 -5" - [hamlet|#{Data.List.reverse foo} # -#{L.reverse foo} # -#{show 3.14} #{show -5}|] - - - - - - , it "single dollar at and caret" $ do - helper "$@^" [hamlet|\$@^|] - - helper "#{@{^{" [hamlet|#\{@\{^\{|] - - - , it "dollar operator" $ do - let val = (1, (2, 3)) - helper "2" [hamlet|#{ show $ fst $ snd val }|] - helper "2" [hamlet|#{ show $ fst $ snd $ val}|] - - - , it "in a row" $ do - helper "1" [hamlet|#{ show $ const 1 2 }|] - - - , it "embedded slash" $ do - helper "///" [hamlet|///|] - -{- compile-time error - , it "tag with slash" $ do - helper "" [hamlet| -<p> - Text -</p> -|] --} - - , it "string literals" $ do - helper "string" [hamlet|#{"string"}|] - helper "string" [hamlet|#{id "string"}|] - helper "gnirts" [hamlet|#{L.reverse $ id "string"}|] - helper "str"ing" [hamlet|#{"str\"ing"}|] - helper "str<ing" [hamlet|#{"str<ing"}|] - - - , it "interpolated operators" $ do - helper "3" [hamlet|#{show $ (+) 1 2}|] - helper "6" [hamlet|#{show $ sum $ (:) 1 ((:) 2 $ return 3)}|] - - - , it "HTML comments" $ do - helper "<p>1</p><p>2 not ignored</p>" [hamlet| -<p>1 -<!-- ignored comment --> -<p - 2 - <!-- ignored --> not ignored<!-- ignored --> -|] - - - - , it "nested maybes" $ do - let muser = Just "User" :: Maybe String - mprof = Nothing :: Maybe Int - m3 = Nothing :: Maybe String - helper "justnothing" [hamlet| -$maybe user <- muser - $maybe profile <- mprof - First two are Just - $maybe desc <- m3 - \ and left us a description: - <p>#{desc} - $nothing - and has left us no description. - $nothing - justnothing -$nothing - <h1>No such Person exists. - |] - - - - - - - - , it "conditional class" $ do - helper "<p class=\"current\"></p>" - [hamlet|<p :False:.ignored :True:.current|] - - helper "<p class=\"1 3 2 4\"></p>" - [hamlet|<p :True:.1 :True:class=2 :False:.a :False:class=b .3 class=4|] - - helper "<p class=\"foo bar baz\"></p>" - [hamlet|<p class=foo class=bar class=baz|] - - - - - , it "forall on Foldable" $ do - let set = Set.fromList [1..5 :: Int] - helper "12345" [hamlet| -$forall x <- set - #{x} -|] - - - - , it "non-poly HTML" $ do - helperHtml "<h1>HELLO WORLD</h1>" [shamlet| - <h1>HELLO WORLD - |] - helperHtml "<h1>HELLO WORLD</h1>" $(shamletFile "test/hamlets/nonpolyhtml.hamlet") - - - , it "non-poly Hamlet" $ do - let embed = [hamlet|<p>EMBEDDED|] - helper "<h1>url</h1><p>EMBEDDED</p>" [hamlet| - <h1>@{Home} - ^{embed} - |] - helper "<h1>url</h1>" $(hamletFile "test/hamlets/nonpolyhamlet.hamlet") - - , it "non-poly IHamlet" $ do - let embed = [ihamlet|<p>EMBEDDED|] - ihelper "<h1>Adios</h1><p>EMBEDDED</p>" [ihamlet| - <h1>_{Goodbye} - ^{embed} - |] - ihelper "<h1>Hola</h1>" $(ihamletFile "test/hamlets/nonpolyihamlet.hamlet") - - , it "pattern-match tuples: forall" $ do - let people = [("Michael", 26), ("Miriam", 25)] - helper "<dl><dt>Michael</dt><dd>26</dd><dt>Miriam</dt><dd>25</dd></dl>" [hamlet| -<dl> - $forall (name, age) <- people - <dt>#{name} - <dd>#{show age} -|] - , it "pattern-match tuples: maybe" $ do - let people = Just ("Michael", 26) - helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet| -<dl> - $maybe (name, age) <- people - <dt>#{name} - <dd>#{show age} -|] - , it "pattern-match tuples: with" $ do - let people = ("Michael", 26) - helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet| -<dl> - $with (name, age) <- people - <dt>#{name} - <dd>#{show age} -|] - , it "list syntax for interpolation" $ do - helper "<ul><li>1</li><li>2</li><li>3</li></ul>" [hamlet| -<ul> - $forall num <- [1, 2, 3] - <li>#{show num} -|] - , it "infix operators" $ - helper "5" [hamlet|#{show $ (4 + 5) - (2 + 2)}|] - , it "infix operators with parens" $ - helper "5" [hamlet|#{show (2 + 3)}|] - , it "doctypes" $ helper "<!DOCTYPE html>\n<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n" [hamlet| -$doctype 5 -$doctype strict -|] - - , it "case on Maybe" $ - let nothing = Nothing - justTrue = Just True - in helper "<br><br><br><br>" [hamlet| -$case nothing - $of Just val - $of Nothing - <br> -$case justTrue - $of Just val - $if val - <br> - $of Nothing -$case (Just $ not False) - $of Nothing - $of Just val - $if val - <br> -$case Nothing - $of Just val - $of _ - <br> -|] - - , it "case on Url" $ - let url1 = Home - url2 = Sub SubUrl - in helper "<br><br>" [hamlet| -$case url1 - $of Home - <br> - $of _ -$case url2 - $of Sub sub - $case sub - $of SubUrl - <br> - $of Home -|] - - , it "pattern-match constructors: forall" $ do - let people = [Pair "Michael" 26, Pair "Miriam" 25] - helper "<dl><dt>Michael</dt><dd>26</dd><dt>Miriam</dt><dd>25</dd></dl>" [hamlet| -<dl> - $forall Pair name age <- people - <dt>#{name} - <dd>#{show age} -|] - , it "pattern-match constructors: maybe" $ do - let people = Just $ Pair "Michael" 26 - helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet| -<dl> - $maybe Pair name age <- people - <dt>#{name} - <dd>#{show age} -|] - , it "pattern-match constructors: with" $ do - let people = Pair "Michael" 26 - helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet| -<dl> - $with Pair name age <- people - <dt>#{name} - <dd>#{show age} -|] - ] - -data Pair = Pair String Int - -data Url = Home | Sub SubUrl -data SubUrl = SubUrl -render :: Url -> [(Text, Text)] -> Text -render Home qs = pack "url" `mappend` showParams qs -render (Sub SubUrl) qs = pack "suburl" `mappend` showParams qs - -showParams :: [(Text, Text)] -> Text -showParams [] = pack "" -showParams z = - pack $ '?' : intercalate "&" (map go z) - where - go (x, y) = go' x ++ '=' : go' y - go' = concatMap encodeUrlChar . unpack - --- | 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] - -data Arg url = Arg - { getArg :: Arg url - , var :: Html - , url :: Url - , embed :: HtmlUrl url - , true :: Bool - , false :: Bool - , list :: [Arg url] - , nothing :: Maybe String - , just :: Maybe String - , urlParams :: (Url, [(Text, Text)]) - } - -theArg :: Arg url -theArg = Arg - { getArg = theArg - , var = toHtml "<var>" - , url = Home - , embed = [hamlet|embed|] - , true = True - , false = False - , list = [theArg, theArg, theArg] - , nothing = Nothing - , just = Just "just" - , urlParams = (Home, [(pack "foo", pack "bar"), (pack "foo1", pack "bar1")]) - } - -helperHtml :: String -> Html -> Assertion -helperHtml res h = do - let x = Text.Blaze.Renderer.Text.renderHtml h - T.pack res @=? x - -helper :: String -> HtmlUrl Url -> Assertion -helper res h = do - let x = Text.Blaze.Renderer.Text.renderHtml $ h render - T.pack res @=? x - -caseEmpty :: Assertion -caseEmpty = helper "" [hamlet||] - -caseStatic :: Assertion -caseStatic = helper "some static content" [hamlet|some static content|] - -caseTag :: Assertion -caseTag = do - helper "<p class=\"foo\"><div id=\"bar\">baz</div></p>" [hamlet| -<p .foo - <#bar>baz -|] - helper "<p class=\"foo.bar\"><div id=\"bar\">baz</div></p>" [hamlet| -<p class=foo.bar - <#bar>baz -|] - -caseVar :: Assertion -caseVar = do - helper "<var>" [hamlet|#{var theArg}|] - -caseVarChain :: Assertion -caseVarChain = do - helper "<var>" [hamlet|#{var (getArg (getArg (getArg theArg)))}|] - -caseUrl :: Assertion -caseUrl = do - helper (unpack $ render Home []) [hamlet|@{url theArg}|] - -caseUrlChain :: Assertion -caseUrlChain = do - helper (unpack $ render Home []) [hamlet|@{url (getArg (getArg (getArg theArg)))}|] - -caseEmbed :: Assertion -caseEmbed = do - helper "embed" [hamlet|^{embed theArg}|] - -caseEmbedChain :: Assertion -caseEmbedChain = do - helper "embed" [hamlet|^{embed (getArg (getArg (getArg theArg)))}|] - -caseIf :: Assertion -caseIf = do - helper "if" [hamlet| -$if true theArg - if -|] - -caseIfChain :: Assertion -caseIfChain = do - helper "if" [hamlet| -$if true (getArg (getArg (getArg theArg))) - if -|] - -caseElse :: Assertion -caseElse = helper "else" [hamlet| -$if false theArg - if -$else - else -|] - -caseElseChain :: Assertion -caseElseChain = helper "else" [hamlet| -$if false (getArg (getArg (getArg theArg))) - if -$else - else -|] - -caseElseIf :: Assertion -caseElseIf = helper "elseif" [hamlet| -$if false theArg - if -$elseif true theArg - elseif -$else - else -|] - -caseElseIfChain :: Assertion -caseElseIfChain = helper "elseif" [hamlet| -$if false(getArg(getArg(getArg theArg))) - if -$elseif true(getArg(getArg(getArg theArg))) - elseif -$else - else -|] - -caseList :: Assertion -caseList = do - helper "xxx" [hamlet| -$forall _x <- (list theArg) - x -|] - -caseListChain :: Assertion -caseListChain = do - helper "urlurlurl" [hamlet| -$forall x <- list(getArg(getArg(getArg(getArg(getArg (theArg)))))) - @{url x} -|] - -caseWith :: Assertion -caseWith = do - helper "it's embedded" [hamlet| -$with n <- embed theArg - it's ^{n}ded -|] - -caseWithMulti :: Assertion -caseWithMulti = do - helper "it's embedded" [hamlet| -$with n <- embed theArg, m <- true theArg - $if m - it's ^{n}ded -|] - -caseWithChain :: Assertion -caseWithChain = do - helper "it's true" [hamlet| -$with n <- true(getArg(getArg(getArg(getArg theArg)))) - $if n - it's true -|] - --- in multi-with binding, make sure that a comma in a string doesn't confuse the parser. -caseWithCommaString :: Assertion -caseWithCommaString = do - helper "it's , something" [hamlet| -$with n <- " , something" - it's #{n} -|] - -caseWithMultiBindingScope :: Assertion -caseWithMultiBindingScope = do - helper "it's , something" [hamlet| -$with n <- " , something", y <- n - it's #{y} -|] - -caseScriptNotEmpty :: Assertion -caseScriptNotEmpty = helper "<script></script>" [hamlet|<script|] - -caseMetaEmpty :: Assertion -caseMetaEmpty = do - helper "<meta>" [hamlet|<meta|] - helper "<meta/>" [xhamlet|<meta|] - helper "<meta>" [hamlet|<meta>|] - helper "<meta/>" [xhamlet|<meta>|] - -caseInputEmpty :: Assertion -caseInputEmpty = do - helper "<input>" [hamlet|<input|] - helper "<input/>" [xhamlet|<input|] - helper "<input>" [hamlet|<input>|] - helper "<input/>" [xhamlet|<input>|] - -caseMultiClass :: Assertion -caseMultiClass = do - helper "<div class=\"foo bar\"></div>" [hamlet|<.foo.bar|] - helper "<div class=\"foo bar\"></div>" [hamlet|<.foo.bar>|] - -caseAttribOrder :: Assertion -caseAttribOrder = do - helper "<meta 1 2 3>" [hamlet|<meta 1 2 3|] - helper "<meta 1 2 3>" [hamlet|<meta 1 2 3>|] - -caseNothing :: Assertion -caseNothing = do - helper "" [hamlet| -$maybe _n <- nothing theArg - nothing -|] - helper "nothing" [hamlet| -$maybe _n <- nothing theArg - something -$nothing - nothing -|] - -caseNothingChain :: Assertion -caseNothingChain = helper "" [hamlet| -$maybe n <- nothing(getArg(getArg(getArg theArg))) - nothing #{n} -|] - -caseJust :: Assertion -caseJust = helper "it's just" [hamlet| -$maybe n <- just theArg - it's #{n} -|] - -caseJustChain :: Assertion -caseJustChain = helper "it's just" [hamlet| -$maybe n <- just(getArg(getArg(getArg theArg))) - it's #{n} -|] - -caseConstructor :: Assertion -caseConstructor = do - helper "url" [hamlet|@{Home}|] - helper "suburl" [hamlet|@{Sub SubUrl}|] - let text = "<raw text>" - helper "<raw text>" [hamlet|#{preEscapedString text}|] - -caseUrlParams :: Assertion -caseUrlParams = do - helper "url?foo=bar&foo1=bar1" [hamlet|@?{urlParams theArg}|] - -caseEscape :: Assertion -caseEscape = do - helper "#this is raw\n " [hamlet| -\#this is raw -\ -\ -|] - helper "$@^" [hamlet|\$@^|] - -caseEmptyStatementList :: Assertion -caseEmptyStatementList = do - helper "" [hamlet|$if True|] - helper "" [hamlet|$maybe _x <- Nothing|] - let emptyList = [] - helper "" [hamlet|$forall _x <- emptyList|] - -caseAttribCond :: Assertion -caseAttribCond = do - helper "<select></select>" [hamlet|<select :False:selected|] - helper "<select selected></select>" [hamlet|<select :True:selected|] - helper "<meta var=\"foo:bar\">" [hamlet|<meta var=foo:bar|] - helper "<select selected></select>" - [hamlet|<select :true theArg:selected|] - - helper "<select></select>" [hamlet|<select :False:selected>|] - helper "<select selected></select>" [hamlet|<select :True:selected>|] - helper "<meta var=\"foo:bar\">" [hamlet|<meta var=foo:bar>|] - helper "<select selected></select>" - [hamlet|<select :true theArg:selected>|] - -caseNonAscii :: Assertion -caseNonAscii = do - helper "עִבְרִי" [hamlet|עִבְרִי|] - -caseMaybeFunction :: Assertion -caseMaybeFunction = do - helper "url?foo=bar&foo1=bar1" [hamlet| -$maybe x <- Just urlParams - @?{x theArg} -|] - -caseTrailingDollarSign :: Assertion -caseTrailingDollarSign = - helper "trailing space \ndollar sign #" [hamlet|trailing space # -\ -dollar sign #\ -|] - -caseNonLeadingPercent :: Assertion -caseNonLeadingPercent = - helper "<span style=\"height:100%\">foo</span>" [hamlet| -<span style=height:100%>foo -|] - -caseQuotedAttribs :: Assertion -caseQuotedAttribs = - helper "<input type=\"submit\" value=\"Submit response\">" [hamlet| -<input type=submit value="Submit response" -|] - -caseSpacedDerefs :: Assertion -caseSpacedDerefs = do - helper "<var>" [hamlet|#{var theArg}|] - helper "<div class=\"<var>\"></div>" [hamlet|<.#{var theArg}|] - -caseAttribVars :: Assertion -caseAttribVars = do - helper "<div id=\"<var>\"></div>" [hamlet|<##{var theArg}|] - helper "<div class=\"<var>\"></div>" [hamlet|<.#{var theArg}|] - helper "<div f=\"<var>\"></div>" [hamlet|< f=#{var theArg}|] - - helper "<div id=\"<var>\"></div>" [hamlet|<##{var theArg}>|] - helper "<div class=\"<var>\"></div>" [hamlet|<.#{var theArg}>|] - helper "<div f=\"<var>\"></div>" [hamlet|< f=#{var theArg}>|] - -caseStringsAndHtml :: Assertion -caseStringsAndHtml = do - let str = "<string>" - let html = preEscapedString "<html>" - helper "<string> <html>" [hamlet|#{str} #{html}|] - -caseNesting :: Assertion -caseNesting = do - helper - "<table><tbody><tr><td>1</td></tr><tr><td>2</td></tr></tbody></table>" - [hamlet| -<table - <tbody - $forall user <- users - <tr - <td>#{user} -|] - helper - (concat - [ "<select id=\"foo\" name=\"foo\"><option selected></option>" - , "<option value=\"true\">Yes</option>" - , "<option value=\"false\">No</option>" - , "</select>" - ]) - [hamlet| -<select #"#{name}" name=#{name} - <option :isBoolBlank val:selected - <option value=true :isBoolTrue val:selected>Yes - <option value=false :isBoolFalse val:selected>No -|] - where - users = ["1", "2"] - name = "foo" - val = 5 :: Int - isBoolBlank _ = True - isBoolTrue _ = False - isBoolFalse _ = False - -caseTrailingSpace :: Assertion -caseTrailingSpace = - helper "" [hamlet| |] - -caseCurrency :: Assertion -caseCurrency = - helper foo [hamlet|#{foo}|] - where - foo = "eg: 5, $6, €7.01, £75" - -caseExternal :: Assertion -caseExternal = do - helper "foo<br>" $(hamletFile "test/hamlets/external.hamlet") - helper "foo<br/>" $(xhamletFile "test/hamlets/external.hamlet") - where - foo = "foo" - -caseParens :: Assertion -caseParens = do - let plus = (++) - x = "x" - y = "y" - helper "xy" [hamlet|#{(plus x) y}|] - helper "xxy" [hamlet|#{plus (plus x x) y}|] - let alist = ["1", "2", "3"] - helper "123" [hamlet| -$forall x <- (id id id id alist) - #{x} -|] - -caseHamletLiterals :: Assertion -caseHamletLiterals = do - helper "123" [hamlet|#{show 123}|] - helper "123.456" [hamlet|#{show 123.456}|] - helper "-123" [hamlet|#{show -123}|] - helper "-123.456" [hamlet|#{show -123.456}|] - -helper' :: String -> Html -> Assertion -helper' res h = T.pack res @=? Text.Blaze.Renderer.Text.renderHtml h - -caseHamlet' :: Assertion -caseHamlet' = do - helper' "foo" [shamlet|foo|] - helper' "foo" [xshamlet|foo|] - helper "<br>" $ const $ [shamlet|<br|] - helper "<br/>" $ const $ [xshamlet|<br|] - - -- new with generalized stuff - helper' "foo" [shamlet|foo|] - helper' "foo" [xshamlet|foo|] - helper "<br>" $ const $ [shamlet|<br|] - helper "<br/>" $ const $ [xshamlet|<br|] - - -instance Show Url where - show _ = "FIXME remove this instance show Url" - -caseDiffBindNames :: Assertion -caseDiffBindNames = do - let list = words "1 2 3" - -- FIXME helper "123123" $(hamletFileReload "test/hamlets/external-debug3.hamlet") - error "test has been disabled" - - -caseTrailingSpaces :: Assertion -caseTrailingSpaces = helper "" [hamlet| -$if True -$elseif False -$else -$maybe x <- Nothing -$nothing -$forall x <- empty -|] - where - empty = [] - - - - -data Msg = Hello | Goodbye - -ihelper :: String -> HtmlUrlI18n Msg Url -> Assertion -ihelper res h = do - let x = Text.Blaze.Renderer.Text.renderHtml $ h showMsg render - T.pack res @=? x - where - showMsg Hello = preEscapedString "Hola" - showMsg Goodbye = preEscapedString "Adios"
− test/hamlets/double-foralls.hamlet
@@ -1,3 +0,0 @@-$forall _ <- list-$forall l <- list- #{l}
− test/hamlets/external-debug.hamlet
@@ -1,1 +0,0 @@-#{foo} 1
− test/hamlets/external-debug2.hamlet
@@ -1,29 +0,0 @@-#{var}-#{id var}-@{url}-@{Home}-@{Sub SubUrl}-@?{urlp}-^{template}-$if id true- true- #{id $ id $ id (id $ id extra)}-$if not true-$else- not true- #{id $ id $ id (id extra)}-$if not true-$elseif true- elseif true- #{id $ id(id extra)}-$maybe j <- just- #{j}- #{id j}- #{id (id extra)}-$maybe _ <- nothing-$nothing- nothing- #{id extra}-$forall l <- list- #{id $ id l}- #{extra}
− test/hamlets/external-debug3.hamlet
@@ -1,4 +0,0 @@-$forall list a- $a$-$forall list b- $b$
− test/hamlets/external.hamlet
@@ -1,2 +0,0 @@-#{foo}-<br
− test/hamlets/nonpolyhamlet.hamlet
@@ -1,1 +0,0 @@-<h1>@{Home}
− test/hamlets/nonpolyhtml.hamlet
@@ -1,1 +0,0 @@-<h1>HELLO WORLD
− test/hamlets/nonpolyihamlet.hamlet
@@ -1,1 +0,0 @@-<h1>_{Hello}
− test/tmp.hs
@@ -1,17 +0,0 @@-data Url = Home | Img-renderUrl' Home = "http://localhost/"-renderUrl' Img = "http://localhost/image.png"--data Obj = Obj- { foo :: Url- , bar :: IO String- }--main = myTemp renderUrl' $ Obj Img (return "some bar value")--myTemp renderUrl obj = do- putStr "<html><head><title>Foo Bar Baz</title></head><body><h1>Hello World</h1><div id=\"content\"><div class=\"foo\">Bar Baz</div>Plain Content<img src=\""- putStr $ renderUrl $ foo obj- putStr "\">"- bar obj >>= putStr- putStr "</div></body></html>"