hamlet-1.1.7.1/0000755000000000000000000000000012133022152011306 5ustar0000000000000000hamlet-1.1.7.1/LICENSE0000644000000000000000000000207512133022152012317 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 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: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 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. hamlet-1.1.7.1/test.hs0000644000000000000000000000011412133022152012615 0ustar0000000000000000import HamletTest (spec) import Test.Hspec main :: IO () main = hspec spec hamlet-1.1.7.1/Setup.lhs0000644000000000000000000000021712133022152013116 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > import System.Cmd (system) > main :: IO () > main = defaultMain hamlet-1.1.7.1/hamlet.cabal0000644000000000000000000000605112133022152013546 0ustar0000000000000000name: hamlet version: 1.1.7.1 license: MIT license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman synopsis: Haml-like template files that are compile-time checked 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 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 for a thorough description . > !!! > > > Hamlet Demo > <body> > <h1>Information on John Doe > <h2> > $if isMarried person > Married > $else > Not married category: Web, Yesod stability: Stable cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/book/shakespearean-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/HamletTestTypes.hs test/tmp.hs test.hs library build-depends: base >= 4 && < 5 , shakespeare >= 1.0.1 && < 1.1 , bytestring >= 0.9 , template-haskell , parsec >= 2 && < 4 , failure >= 0.1 && < 0.3 , text >= 0.7 , containers >= 0.2 , blaze-builder >= 0.2 && < 0.4 , process >= 1.0 , blaze-html >= 0.5 , blaze-markup >= 0.5.1 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 , base >= 4 && < 5 , parsec >= 2 && < 4 , containers >= 0.2 , text >= 0.7 && < 1 , HUnit , hspec >= 1.3 , blaze-html , blaze-markup source-repository head type: git location: git://github.com/yesodweb/shakespeare.git ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������hamlet-1.1.7.1/Text/��������������������������������������������������������������������������������0000755�0000000�0000000�00000000000�12133022152�012232� 5����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������hamlet-1.1.7.1/Text/Hamlet.hs�����������������������������������������������������������������������0000644�0000000�0000000�00000033206�12133022152�014004� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE PatternGuards #-} {-# 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 -- * Type classes , ToAttributes (..) -- * Internal, for making more , HamletSettings (..) , NewlineStyle (..) , hamletWithSettings , hamletFileWithSettings , defaultHamletSettings , xhtmlHamletSettings , Env (..) , HamletRules (..) , hamletRules , ihamletRules , htmlRules , CloseStyle (..) ) 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 (Html, toHtml) import Text.Blaze.Internal (preEscapedText) import qualified Data.Foldable as F import Control.Monad (mplus) import Data.Monoid (mempty, mappend) import Control.Arrow ((***)) import Data.List (intercalate) -- | Convert some value to a list of attribute pairs. class ToAttributes a where toAttributes :: a -> [(Text, Text)] instance ToAttributes (Text, Text) where toAttributes = return instance ToAttributes (String, String) where toAttributes (k, v) = [(pack k, pack v)] instance ToAttributes [(Text, Text)] where toAttributes = id instance ToAttributes [(String, String)] where toAttributes = map (pack *** pack) attrsToHtml :: [(Text, Text)] -> Html attrsToHtml = foldr go mempty where go (k, v) rest = toHtml " " `mappend` preEscapedText k `mappend` preEscapedText (pack "=\"") `mappend` toHtml v `mappend` preEscapedText (pack "\"") `mappend` rest 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 (BindAs i@(Ident s) b) = do name <- newName s (pattern, scope) <- bindingPattern b return (AsP name pattern, (i, VarE name):scope) bindingPattern (BindVar i@(Ident s)) | all isDigit s = do return (LitP $ IntegerL $ read s, []) | otherwise = do name <- newName s return (VarP name, [(i, VarE name)]) bindingPattern (BindTuple is) = do (patterns, scopes) <- fmap unzip $ mapM bindingPattern is return (TupP patterns, concat scopes) bindingPattern (BindList is) = do (patterns, scopes) <- fmap unzip $ mapM bindingPattern is return (ListP patterns, concat scopes) bindingPattern (BindConstr con is) = do (patterns, scopes) <- fmap unzip $ mapM bindingPattern is return (ConP (mkConName con) patterns, concat scopes) bindingPattern (BindRecord con fields wild) = do let f (Ident field,b) = do (p,s) <- bindingPattern b return ((mkName field,p),s) (patterns, scopes) <- fmap unzip $ mapM f fields (patterns1, scopes1) <- if wild then bindWildFields con $ map fst fields else return ([],[]) return (RecP (mkConName con) (patterns++patterns1), concat scopes ++ scopes1) mkConName :: DataConstr -> Name mkConName = mkName . conToStr conToStr :: DataConstr -> String conToStr (DCUnqualified (Ident x)) = x conToStr (DCQualified (Module xs) (Ident x)) = intercalate "." $ xs ++ [x] -- Wildcards bind all of the unbound fields to variables whose name -- matches the field name. -- -- For example: data R = C { f1, f2 :: Int } -- C {..} is equivalent to C {f1=f1, f2=f2} -- C {f1 = a, ..} is equivalent to C {f1=a, f2=f2} -- C {f2 = a, ..} is equivalent to C {f1=f1, f2=a} bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)]) bindWildFields conName fields = do fieldNames <- recordToFieldNames conName let available n = nameBase n `notElem` map unIdent fields let remainingFields = filter available fieldNames let mkPat n = do e <- newName (nameBase n) return ((n,VarP e), (Ident (nameBase n), VarE e)) fmap unzip $ mapM mkPat remainingFields -- Important note! reify will fail if the record type is defined in the -- same module as the reify is used. This means quasi-quoted Hamlet -- literals will not be able to use wildcards to match record types -- defined in the same module. recordToFieldNames :: DataConstr -> Q [Name] recordToFieldNames conStr = do -- use 'lookupValueName' instead of just using 'mkName' so we reify the -- data constructor and not the type constructor if their names match. Just conName <- lookupValueName $ conToStr conStr DataConI _ _ typeName _ <- reify conName TyConI (DataD _ _ _ cons _) <- reify typeName [fields] <- return [fields | RecC name fields <- cons, name == conName] return [fieldName | (fieldName, _, _) <- fields] 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 ((specialOrIdent, VarE 'or):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 readMay s = case reads s of (x, ""):_ -> Just x _ -> Nothing toMatch :: (Binding, [Doc]) -> Q Match toMatch (idents, inside) = do (pat, extraScope) <- bindingPattern idents let scope' = extraScope ++ scope 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) contentToExp _ hr scope (ContentAttrs d) = do html <- [|attrsToHtml . toAttributes|] return $ hrFromHtml hr `AppE` (html `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 asHtmlUrl :: HtmlUrl url -> HtmlUrl url asHtmlUrl = id 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 = do asHtmlUrl' <- [|asHtmlUrl|] urender $ \ur' -> return ((asHtmlUrl' `AppE` 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 (_mnl, 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 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������hamlet-1.1.7.1/Text/Hamlet/�������������������������������������������������������������������������0000755�0000000�0000000�00000000000�12133022152�013444� 5����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������hamlet-1.1.7.1/Text/Hamlet/RT.hs��������������������������������������������������������������������0000644�0000000�0000000�00000017222�12133022152�014331� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE CPP #-} {-# 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) #if MIN_VERSION_blaze_html(0,5,0) import Text.Blaze.Html (Html) import Text.Blaze.Internal (preEscapedString, preEscapedText) #else import Text.Blaze (preEscapedString, preEscapedText, Html) #endif 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 (BindAs _ _) docs) = error "Runtime Hamlet does not currently support 'as' patterns" 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 (BindAs _ _) jdocs ndocs) = error "Runtime Hamlet does not currently support 'as' 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 (DocContent ContentAttrs{}) = error "Runtime hamlet does not currently support attrs interpolation" convert x@(DocCond conds els) = do conds' <- mapM go conds els' <- maybe (return []) (mapM convert) els return $ SDCond conds' els' where -- | See the comments in Text.Hamlet.Parse.testIncludeClazzes. The conditional -- added there doesn't work for runtime Hamlet, so we remove it here. go (DerefBranch (DerefIdent x) _, docs') | x == specialOrIdent = do docs'' <- mapM convert docs' return (["True"], docs'') 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 | k == ["True"] -> return $ HDBool True 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-1.1.7.1/Text/Hamlet/Parse.hs�����������������������������������������������������������������0000644�0000000�0000000�00000061074�12133022152�015062� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} module Text.Hamlet.Parse ( Result (..) , Content (..) , Doc (..) , parseDoc , HamletSettings (..) , defaultHamletSettings , xhtmlHamletSettings , CloseStyle (..) , Binding (..) , NewlineStyle (..) , specialOrIdent , DataConstr (..) , Module (..) ) where import Text.Shakespeare.Base import Control.Applicative ((<$>), Applicative (..)) import Control.Monad import Control.Arrow import Data.Char (isUpper) import Data.Data import Text.ParserCombinators.Parsec hiding (Line) import Data.Set (Set) import qualified Data.Set as Set import Data.Maybe (mapMaybe, fromMaybe, isNothing) 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 | ContentAttrs 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 Binding | LineTag { _lineTagName :: String , _lineAttr :: [(Maybe Deref, String, Maybe [Content])] , _lineContent :: [Content] , _lineClasses :: [(Maybe Deref, [Content])] , _lineAttrs :: [Deref] , _lineNoNewline :: Bool } | LineContent [Content] Bool -- ^ True == avoid newlines deriving (Eq, Show, Read) parseLines :: HamletSettings -> String -> Result (Maybe NewlineStyle, HamletSettings, [(Int, Line)]) parseLines set s = case parse parser s s of Left e -> Error $ show e Right x -> Ok x where parser = do mnewline <- parseNewline let set' = case mnewline of Nothing -> case hamletNewlines set of DefaultNewlineStyle -> set { hamletNewlines = AlwaysNewlines } _ -> set Just n -> set { hamletNewlines = n } res <- many (parseLine set') return (mnewline, set', res) parseNewline = (try (many eol' >> spaceTabs >> string "$newline ") >> parseNewline' >>= \nl -> eol' >> return nl) <|> return Nothing parseNewline' = (try (string "always") >> return (Just AlwaysNewlines)) <|> (try (string "never") >> return (Just NoNewlines)) <|> (try (string "text") >> return (Just NewlinesText)) eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) 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 <|> ssiInclude <|> htmlComment <|> doctypeRaw <|> 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 [] True)) <|> (do (cs, avoidNewLines) <- content InContent isEof <- (eof >> return True) <|> return False if null cs && ss == 0 && isEof then fail "End of Hamlet template" else return $ LineContent cs avoidNewLines) return (ss, x) where eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) eol = eof <|> eol' doctype = do try $ string "!!!" >> eol return $ LineContent [ContentRaw $ hamletDoctype set ++ "\n"] True doctypeDollar = do _ <- try $ string "$doctype " name <- many $ noneOf "\r\n" eol case lookup name $ hamletDoctypeNames set of Nothing -> fail $ "Unknown doctype name: " ++ name Just val -> return $ LineContent [ContentRaw $ val ++ "\n"] True doctypeRaw = do x <- try $ string "<!" y <- many $ noneOf "\r\n" eol return $ LineContent [ContentRaw $ concat [x, y, "\n"]] True 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 [] True ssiInclude = do x <- try $ string "<!--#" y <- many $ noneOf "\r\n" eol return $ LineContent [ContentRaw $ x ++ y] False htmlComment = do _ <- try $ string "<!--" _ <- manyTill anyChar $ try $ string "-->" x <- many nonComments eol return $ LineContent [ContentRaw $ concat x] False {- FIXME -} -- 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"] True)) <|> (uncurry 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" spaces x <- identPattern _ <- spaceTabs eol return $ LineOf x content cr = do x <- many $ content' cr case cr of InQuotes -> char '"' >> return () NotInQuotes -> return () NotInQuotesAttr -> return () InContent -> eol return (cc $ map fst x, or $ map snd 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, null str) Right deref -> return (ContentVar deref, False) contentAt = do x <- parseAt return $ case x of Left str -> (ContentRaw str, null str) Right (s, y) -> (ContentUrl y s, False) contentCaret = do x <- parseCaret case x of Left str -> return (ContentRaw str, null str) Right deref -> return (ContentEmbed deref, False) contentUnder = do x <- parseUnder case x of Left str -> return (ContentRaw str, null str) Right deref -> return (ContentMsg deref, False) contentReg' x = (flip (,) False) <$> contentReg x 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 fst <$> content cr tagIdent = char '#' >> TagIdent <$> tagAttribValue NotInQuotes tagCond = do d <- between (char ':') (char ':') parseDeref tagClass (Just d) <|> tagAttrib (Just d) tagClass x = do clazz <- char '.' >> tagAttribValue NotInQuotes let hasHash (ContentRaw s) = any (== '#') s hasHash _ = False if any hasHash clazz then fail $ "Invalid class: " ++ show clazz ++ ". Did you want a space between a class and an ID?" else return (TagClass (x, clazz)) tagAttrib cond = do s <- many1 $ noneOf " \t=\r\n><" v <- (char '=' >> Just <$> tagAttribValue NotInQuotesAttr) <|> return Nothing return $ TagAttrib (cond, s, v) tagAttrs = do _ <- char '*' d <- between (char '{') (char '}') parseDeref return $ TagAttribs d tag' = foldr tag'' ("div", [], [], []) tag'' (TagName s) (_, y, z, as) = (s, y, z, as) tag'' (TagIdent s) (x, y, z, as) = (x, (Nothing, "id", Just s) : y, z, as) tag'' (TagClass s) (x, y, z, as) = (x, y, s : z, as) tag'' (TagAttrib s) (x, y, z, as) = (x, s : y, z, as) tag'' (TagAttribs s) (x, y, z, as) = (x, y, z, s : as) ident :: Parser Ident ident = do i <- many1 (alphaNum <|> char '_' <|> char '\'') white return (Ident i) <?> "identifier" parens = between (char '(' >> white) (char ')' >> white) brackets = between (char '[' >> white) (char ']' >> white) braces = between (char '{' >> white) (char '}' >> white) comma = char ',' >> white atsign = char '@' >> white equals = char '=' >> white white = skipMany $ char ' ' wildDots = string ".." >> white isVariable (Ident (x:_)) = not (isUpper x) isVariable (Ident []) = error "isVariable: bad identifier" isConstructor (Ident (x:_)) = isUpper x isConstructor (Ident []) = error "isConstructor: bad identifier" identPattern :: Parser Binding identPattern = gcon True <|> apat where apat = choice [ varpat , gcon False , parens tuplepat , brackets listpat ] varpat = do v <- try $ do v <- ident guard (isVariable v) return v option (BindVar v) $ do atsign b <- apat return (BindAs v b) <?> "variable" gcon :: Bool -> Parser Binding gcon allowArgs = do c <- try $ do c <- dataConstr return c choice [ record c , fmap (BindConstr c) (guard allowArgs >> many apat) , return (BindConstr c []) ] <?> "constructor" dataConstr = do p <- dcPiece ps <- many dcPieces return $ toDataConstr p ps dcPiece = do x@(Ident y) <- ident guard $ isConstructor x return y dcPieces = do _ <- char '.' dcPiece toDataConstr x [] = DCUnqualified $ Ident x toDataConstr x (y:ys) = go (x:) y ys where go front next [] = DCQualified (Module $ front []) (Ident next) go front next (rest:rests) = go (front . (next:)) rest rests record c = braces $ do (fields, wild) <- option ([], False) $ go return (BindRecord c fields wild) where go = (wildDots >> return ([], True)) <|> (do x <- recordField (xs,wild) <- option ([],False) (comma >> go) return (x:xs,wild)) recordField = do field <- ident p <- option (BindVar field) -- support punning (equals >> identPattern) return (field,p) tuplepat = do xs <- identPattern `sepBy` comma return $ case xs of [x] -> x _ -> BindTuple xs listpat = BindList <$> identPattern `sepBy` comma angle = do _ <- char '<' name' <- many $ noneOf " \t.#\r\n!>" let name = if null name' then "div" else name' xs <- many $ try ((many $ oneOf " \t\r\n") >> (tagIdent <|> tagCond <|> tagClass Nothing <|> tagAttrs <|> tagAttrib Nothing)) _ <- many $ oneOf " \t\r\n" _ <- char '>' (c, avoidNewLines) <- content InContent let (tn, attr, classes, attrsd) = 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 attrsd avoidNewLines data TagPiece = TagName String | TagIdent [Content] | TagClass (Maybe Deref, [Content]) | TagAttrib (Maybe Deref, String, Maybe [Content]) | TagAttribs Deref 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 [(Binding, [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 x) insideC) = do insideC' <- nestToDoc set insideC Ok (x, 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 attrsD avoidNewLine) inside:rest) = do let attrFix (x, y, z) = (x, y, [(Nothing, z)]) let takeClass (a, "class", b) = Just (a, fromMaybe [] 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 _ -> (testIncludeClazzes clazzes, "class", map (second Just) 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 $ case hamletNewlines set of { AlwaysNewlines | not avoidNewLine -> "\n"; _ -> "" } inside' <- nestToDoc set inside rest' <- nestToDoc set rest Ok $ start : attrs'' ++ map (DocContent . ContentAttrs) attrsD ++ seal : map DocContent content ++ inside' ++ end : newline' : rest' nestToDoc set (Nest (LineContent content avoidNewLine) inside:rest) = do inside' <- nestToDoc set inside rest' <- nestToDoc set rest let newline' = DocContent $ ContentRaw $ case hamletNewlines set of { NoNewlines -> ""; _ -> if nextIsContent && not avoidNewLine then "\n" else "" } nextIsContent = case (inside, rest) of ([], Nest LineContent{} _:_) -> True ([], Nest LineTag{} _:_) -> True _ -> False Ok $ map DocContent content ++ newline':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 (Maybe NewlineStyle, [Doc]) parseDoc set s = do (mnl, set', ls) <- parseLines set s let notEmpty (_, LineContent [] _) = False notEmpty _ = True let ns = nestLines $ filter notEmpty ls ds <- nestToDoc set' ns return (mnl, compressDoc ds) attrToContent :: (Maybe Deref, String, [(Maybe Deref, Maybe [Content])]) -> [Doc] attrToContent (Just cond, k, v) = [DocCond [(cond, attrToContent (Nothing, k, v))] Nothing] attrToContent (Nothing, k, []) = [DocContent $ ContentRaw $ ' ' : k] attrToContent (Nothing, k, [(Nothing, Nothing)]) = [DocContent $ ContentRaw $ ' ' : k] attrToContent (Nothing, k, [(Nothing, Just 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 (fromMaybe [] x) ++ [DocContent $ ContentRaw " "] go (Just b, x) = [ DocCond [(b, map DocContent (fromMaybe [] x) ++ [DocContent $ ContentRaw " "])] Nothing ] go' (Nothing, x) = maybe [] (map DocContent) x go' (Just b, x) = [ DocCond [(b, maybe [] (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 add newlines to the output, making it more human-readable? -- Useful for client-side debugging but may alter browser page layout. , hamletNewlines :: NewlineStyle -- | How a tag should be closed. Use this to switch between HTML, XHTML -- or even XML output. , hamletCloseStyle :: String -> CloseStyle -- | Mapping from short names in \"$doctype\" statements to full doctype. , hamletDoctypeNames :: [(String, String)] } data NewlineStyle = NoNewlines -- ^ never add newlines | NewlinesText -- ^ add newlines between consecutive text lines | AlwaysNewlines -- ^ add newlines everywhere | DefaultNewlineStyle deriving Show 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>" DefaultNewlineStyle htmlCloseStyle doctypeNames xhtmlHamletSettings :: HamletSettings xhtmlHamletSettings = HamletSettings doctype DefaultNewlineStyle xhtmlCloseStyle doctypeNames where doctype = "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" " ++ "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" 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 | BindAs Ident Binding | BindConstr DataConstr [Binding] | BindTuple [Binding] | BindList [Binding] | BindRecord DataConstr [(Ident, Binding)] Bool deriving (Eq, Show, Read, Data, Typeable) data DataConstr = DCQualified Module Ident | DCUnqualified Ident deriving (Eq, Show, Read, Data, Typeable) newtype Module = Module [String] deriving (Eq, Show, Read, Data, Typeable) spaceTabs :: Parser String spaceTabs = many $ oneOf " \t" -- | When using conditional classes, it will often be a single class, e.g.: -- -- > <div :isHome:.homepage> -- -- If isHome is False, we do not want any class attribute to be present. -- However, due to combining multiple classes together, the most obvious -- implementation would produce a class="". The purpose of this function is to -- work around that. It does so by checking if all the classes on this tag are -- optional. If so, it will only include the class attribute if at least one -- conditional is true. testIncludeClazzes :: [(Maybe Deref, [Content])] -> Maybe Deref testIncludeClazzes cs | any (isNothing . fst) cs = Nothing | otherwise = Just $ DerefBranch (DerefIdent specialOrIdent) $ DerefList $ mapMaybe fst cs -- | This funny hack is to allow us to refer to the 'or' function without -- requiring the user to have it in scope. See how this function is used in -- Text.Hamlet. specialOrIdent :: Ident specialOrIdent = Ident "__or__hamlet__special" ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������hamlet-1.1.7.1/test/��������������������������������������������������������������������������������0000755�0000000�0000000�00000000000�12133022152�012265� 5����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������hamlet-1.1.7.1/test/tmp.hs��������������������������������������������������������������������������0000644�0000000�0000000�00000001015�12133022152�013416� 0����������������������������������������������������������������������������������������������������ustar�00����������������������������������������������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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

Hello World

Bar Baz
Plain Content" bar obj >>= putStr putStr "
" hamlet-1.1.7.1/test/HamletTest.hs0000644000000000000000000006305412133022152014703 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module HamletTest (spec) where import HamletTestTypes (ARecord(..)) import Test.HUnit hiding (Test) import Test.Hspec 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,mconcat) import qualified Data.Set as Set import qualified Text.Blaze.Html.Renderer.Text import Text.Blaze.Html (toHtml) import Text.Blaze.Internal (preEscapedString) import Text.Blaze spec = do describe "hamlet" $ do 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 "hamlet tuple" caseTuple it "complex pattern" caseComplex it "record pattern" caseRecord it "record wildcard pattern #1" caseRecordWildCard it "record wildcard pattern #2" caseRecordWildCard1 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 "

foo

\n" [hamlet|

foo |] it "angle bracket syntax" $ helper "

HELLO

" [hamlet| $newline never HELLO |] it "hamlet module names" $ do let foo = "foo" helper "oof oof 3.14 -5" [hamlet| $newline never #{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|

Text

|] -} 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|#{"str1

2 not ignored

" [hamlet| $newline never

1

2 not ignored |] it "Keeps SSI includes" $ helper "" [hamlet||] 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:

#{desc} $nothing and has left us no description. $nothing justnothing $nothing

No such Person exists. |] it "maybe with qualified constructor" $ do helper "5" [hamlet| $maybe HamletTestTypes.ARecord x y <- Just $ ARecord 5 True \#{x} |] it "record with qualified constructor" $ do helper "5" [hamlet| $maybe HamletTestTypes.ARecord {..} <- Just $ ARecord 5 True \#{field1} |] it "conditional class" $ do helper "

\n" [hamlet|

|] helper "

\n" [hamlet|

|] helper "

\n" [hamlet|

|] 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 "

HELLO WORLD

\n" [shamlet|

HELLO WORLD |] helperHtml "

HELLO WORLD

\n" $(shamletFile "test/hamlets/nonpolyhtml.hamlet") it "non-poly Hamlet" $ do let embed = [hamlet|

EMBEDDED|] helper "

url

\n

EMBEDDED

\n" [hamlet|

@{Home} ^{embed} |] helper "

url

\n" $(hamletFile "test/hamlets/nonpolyhamlet.hamlet") it "non-poly IHamlet" $ do let embed = [ihamlet|

EMBEDDED|] ihelper "

Adios

\n

EMBEDDED

\n" [ihamlet|

_{Goodbye} ^{embed} |] ihelper "

Hola

\n" $(ihamletFile "test/hamlets/nonpolyihamlet.hamlet") it "pattern-match tuples: forall" $ do let people = [("Michael", 26), ("Miriam", 25)] helper "
Michael
26
Miriam
25
" [hamlet| $newline never
$forall (name, age) <- people
#{name}
#{show age} |] it "pattern-match tuples: maybe" $ do let people = Just ("Michael", 26) helper "
Michael
26
" [hamlet| $newline never
$maybe (name, age) <- people
#{name}
#{show age} |] it "pattern-match tuples: with" $ do let people = ("Michael", 26) helper "
Michael
26
" [hamlet| $newline never
$with (name, age) <- people
#{name}
#{show age} |] it "list syntax for interpolation" $ do helper "
  • 1
  • 2
  • 3
" [hamlet| $newline never
    $forall num <- [1, 2, 3]
  • #{show num} |] it "infix operators" $ helper "5" [hamlet|#{show $ (4 + 5) - (2 + 2)}|] it "infix operators with parens" $ helper "5" [hamlet|#{show ((+) 1 1 + 3)}|] it "doctypes" $ helper "\n\n" [hamlet| $newline never $doctype 5 $doctype strict |] it "case on Maybe" $ let nothing = Nothing justTrue = Just True in helper "



    " [hamlet| $newline never $case nothing $of Just val $of Nothing
    $case justTrue $of Just val $if val
    $of Nothing $case (Just $ not False) $of Nothing $of Just val $if val
    $case Nothing $of Just val $of _
    |] it "case on Url" $ let url1 = Home url2 = Sub SubUrl in helper "
    \n
    \n" [hamlet| $newline always $case url1 $of Home
    $of _ $case url2 $of Sub sub $case sub $of SubUrl
    $of Home |] it "pattern-match constructors: forall" $ do let people = [Pair "Michael" 26, Pair "Miriam" 25] helper "
    Michael
    26
    Miriam
    25
    " [hamlet| $newline text
    $forall Pair name age <- people
    #{name}
    #{show age} |] it "pattern-match constructors: maybe" $ do let people = Just $ Pair "Michael" 26 helper "
    Michael
    26
    " [hamlet| $newline text
    $maybe Pair name age <- people
    #{name}
    #{show age} |] it "pattern-match constructors: with" $ do let people = Pair "Michael" 26 helper "
    Michael
    26
    " [hamlet| $newline text
    $with Pair name age <- people
    #{name}
    #{show age} |] it "multiline tags" $ helper "content\n" [hamlet| content |] it "*{...} attributes" $ let attrs = [("bar", "baz"), ("bin", "<>\"&")] in helper "content\n" [hamlet| content |] it "blank attr values" $ helper "\n" [hamlet||] it "greater than in attr" $ helper "\n" [hamlet|