hamlet 1.1.9.2 → 1.2.0
raw patch · 17 files changed
+3/−2705 lines, 17 filesdep −HUnitdep −blaze-builderdep −blaze-htmldep ~shakespeare
Dependencies removed: HUnit, blaze-builder, blaze-html, blaze-markup, bytestring, containers, failure, hamlet, hspec, parsec, process, system-fileio, system-filepath, template-haskell, text, time
Dependency ranges changed: shakespeare
Files
- Text/Hamlet.hs +0/−587
- Text/Hamlet/Parse.hs +0/−732
- Text/Hamlet/RT.hs +0/−201
- hamlet.cabal +3/−45
- test.hs +0/−5
- test/HamletTest.hs +0/−1068
- test/HamletTestTypes.hs +0/−7
- test/hamlets/double-foralls.hamlet +0/−3
- test/hamlets/embed.hamlet +0/−1
- 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
− Text/Hamlet.hs
@@ -1,587 +0,0 @@-{-# 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- , hamletFileReload- , ihamletFileReload- , 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 (..)- -- * Used by generated code- , condH- , maybeH- , asHtmlUrl- , attrsToHtml- ) where--import Text.Shakespeare.Base-import Text.Hamlet.Parse-#if MIN_VERSION_template_haskell(2,9,0)-import Language.Haskell.TH.Syntax hiding (Module)-#else-import Language.Haskell.TH.Syntax-#endif-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, mconcat)-import Control.Arrow ((***))-import Data.List (intercalate)--import Data.IORef-import qualified Data.Map as M-import System.IO.Unsafe (unsafePerformIO)-import Filesystem (getModified)-import Data.Time (UTCTime)-import Filesystem.Path.CurrentOS (decodeString)-import Text.Blaze.Html (preEscapedToHtml)---- | 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- 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- hrWithEnv hr $ \env -> docsToExp env hr [] $ docFromString set s--docFromString :: HamletSettings -> String -> [Doc]-docFromString set s =- case parseDoc set s of- Error s' -> error s'- Ok (_, d) -> 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--hamletFileReload :: FilePath -> Q Exp-hamletFileReload = hamletFileReloadWithSettings runtimeRules defaultHamletSettings- where runtimeRules = HamletRuntimeRules { hrrI18n = False }--ihamletFileReload :: FilePath -> Q Exp-ihamletFileReload = hamletFileReloadWithSettings runtimeRules defaultHamletSettings- where runtimeRules = HamletRuntimeRules { hrrI18n = True }--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---type MTime = UTCTime-data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin | VTMsg | VTAttrs--type QueryParameters = [(Text, Text)]-type RenderUrl url = (url -> QueryParameters -> Text)-type Shakespeare url = RenderUrl url -> Html-data VarExp msg url = EPlain Html- | EUrl url- | EUrlParam (url, QueryParameters)- | EMixin (HtmlUrl url)- | EMixinI18n (HtmlUrlI18n msg url)- | EMsg msg--getVars :: Content -> [(Deref, VarType)]-getVars ContentRaw{} = []-getVars (ContentVar d) = [(d, VTPlain)]-getVars (ContentUrl False d) = [(d, VTUrl)]-getVars (ContentUrl True d) = [(d, VTUrlParam)]-getVars (ContentEmbed d) = [(d, VTMixin)]-getVars (ContentMsg d) = [(d, VTMsg)]-getVars (ContentAttrs d) = [(d, VTAttrs)]--hamletUsedIdentifiers :: HamletSettings -> String -> [(Deref, VarType)]-hamletUsedIdentifiers settings =- concatMap getVars . contentFromString settings---data HamletRuntimeRules = HamletRuntimeRules {- hrrI18n :: Bool- }--hamletFileReloadWithSettings :: HamletRuntimeRules- -> HamletSettings -> FilePath -> Q Exp-hamletFileReloadWithSettings hrr settings fp = do- s <- readFileQ fp- let b = hamletUsedIdentifiers settings s- c <- mapM vtToExp b- rt <- if hrrI18n hrr- then [|hamletRuntimeMsg settings fp|]- else [|hamletRuntime settings fp|]- return $ rt `AppE` ListE c- where- vtToExp :: (Deref, VarType) -> Q Exp- vtToExp (d, vt) = do- d' <- lift d- c' <- toExp vt- return $ TupE [d', c' `AppE` derefToExp [] d]- where- toExp = c- where- c :: VarType -> Q Exp- c VTAttrs = [|EPlain . attrsToHtml . toAttributes|]- c VTPlain = [|EPlain . toHtml|]- c VTUrl = [|EUrl|]- c VTUrlParam = [|EUrlParam|]- c VTMixin = [|\r -> EMixin $ \c -> r c|]- c VTMsg = [|EMsg|]---- move to Shakespeare.Base?-readFileUtf8 :: FilePath -> IO String-readFileUtf8 fp = fmap TL.unpack $ readUtf8File fp---- move to Shakespeare.Base?-readFileQ :: FilePath -> Q String-readFileQ fp = qRunIO $ readFileUtf8 fp--{-# NOINLINE reloadMapRef #-}-reloadMapRef :: IORef (M.Map FilePath (MTime, [Content]))-reloadMapRef = unsafePerformIO $ newIORef M.empty--lookupReloadMap :: FilePath -> IO (Maybe (MTime, [Content]))-lookupReloadMap fp = do- reloads <- readIORef reloadMapRef- return $ M.lookup fp reloads--insertReloadMap :: FilePath -> (MTime, [Content]) -> IO [Content]-insertReloadMap fp (mt, content) = atomicModifyIORef reloadMapRef- (\reloadMap -> (M.insert fp (mt, content) reloadMap, content))--contentFromString :: HamletSettings -> String -> [Content]-contentFromString set = map justContent . docFromString set- where- unsupported msg = error $ "hamletFileReload does not support " ++ msg-- justContent :: Doc -> Content- justContent (DocContent c) = c- justContent DocForall{} = unsupported "$forall"- justContent DocWith{} = unsupported "$with"- justContent DocMaybe{} = unsupported "$maybe"- justContent DocCase{} = unsupported "$case"- justContent DocCond{} = unsupported "attribute conditionals"---hamletRuntime :: HamletSettings- -> FilePath- -> [(Deref, VarExp msg url)]- -> Shakespeare url-hamletRuntime settings fp cd render = unsafePerformIO $ do- mtime <- qRunIO $ getModified $ decodeString fp- mdata <- lookupReloadMap fp- case mdata of- Just (lastMtime, lastContents) ->- if mtime == lastMtime then return $ go' lastContents- else fmap go' $ newContent mtime- Nothing -> fmap go' $ newContent mtime- where- newContent mtime = do- s <- readFileUtf8 fp- insertReloadMap fp (mtime, contentFromString settings s)-- go' = mconcat . map (runtimeContentToHtml cd render (error "I18n embed IMPOSSIBLE") handleMsgEx)- handleMsgEx _ = error "i18n _{} encountered, but did not use ihamlet"--type RuntimeVars msg url = [(Deref, VarExp msg url)]-hamletRuntimeMsg :: HamletSettings- -> FilePath- -> RuntimeVars msg url- -> HtmlUrlI18n msg url-hamletRuntimeMsg settings fp cd i18nRender render = unsafePerformIO $ do- mtime <- qRunIO $ getModified $ decodeString fp- mdata <- lookupReloadMap fp- case mdata of- Just (lastMtime, lastContents) ->- if mtime == lastMtime then return $ go' lastContents- else fmap go' $ newContent mtime- Nothing -> fmap go' $ newContent mtime- where- newContent mtime = do- s <- readFileUtf8 fp- insertReloadMap fp (mtime, contentFromString settings s)-- go' = mconcat . map (runtimeContentToHtml cd render i18nRender handleMsg)- handleMsg d = case lookup d cd of- Just (EMsg s) -> i18nRender s- _ -> error $ show d ++ ": expected EMsg for ContentMsg"--runtimeContentToHtml :: RuntimeVars msg url -> Render url -> Translate msg -> (Deref -> Html) -> Content -> Html-runtimeContentToHtml cd render i18nRender handleMsg = go- where- go :: Content -> Html- go (ContentMsg d) = handleMsg d- go (ContentRaw s) = preEscapedToHtml s- go (ContentAttrs d) =- case lookup d cd of- Just (EPlain s) -> s- _ -> error $ show d ++ ": expected EPlain for ContentAttrs"- go (ContentVar d) =- case lookup d cd of- Just (EPlain s) -> s- _ -> error $ show d ++ ": expected EPlain for ContentVar"- go (ContentUrl False d) =- case lookup d cd of- Just (EUrl u) -> toHtml $ render u []- _ -> error $ show d ++ ": expected EUrl"- go (ContentUrl True d) =- case lookup d cd of- Just (EUrlParam (u, p)) ->- toHtml $ render u p- _ -> error $ show d ++ ": expected EUrlParam"- go (ContentEmbed d) = case lookup d cd of- Just (EMixin m) -> m render- Just (EMixinI18n m) -> m i18nRender render- _ -> error $ show d ++ ": expected EMixin"
− Text/Hamlet/Parse.hs
@@ -1,732 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-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)-import Language.Haskell.TH.Syntax (Lift (..))--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 -> void $ char '"'- NotInQuotes -> return ()- NotInQuotesAttr -> return ()- InContent -> eol- return (cc $ map fst x, any 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--instance Lift NewlineStyle where- lift NoNewlines = [|NoNewlines|]- lift NewlinesText = [|NewlinesText|]- lift AlwaysNewlines = [|AlwaysNewlines|]- lift DefaultNewlineStyle = [|DefaultNewlineStyle|]--instance Lift (String -> CloseStyle) where- lift _ = [|\s -> htmlCloseStyle s|]--instance Lift HamletSettings where- lift (HamletSettings a b c d) = [|HamletSettings $(lift a) $(lift b) $(lift c) $(lift d)|]---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"
− Text/Hamlet/RT.hs
@@ -1,201 +0,0 @@-{-# 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)]-type UrlRenderer url = (url -> [(Text, Text)] -> Text)--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- -> UrlRenderer url- -> 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.cabal view
@@ -1,10 +1,10 @@ name: hamlet-version: 1.1.9.2+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://www.yesodweb.com/book/shakespearean-templates> for more details. .@@ -26,52 +26,10 @@ cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/book/shakespearean-templates-extra-source-files:- test/hamlets/*.hamlet- test/HamletTest.hs- test/HamletTestTypes.hs- test/tmp.hs- test.hs library build-depends: base >= 4 && < 5- , shakespeare >= 1.2.0.4 && < 1.3- , 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- , system-filepath >= 0.4- , system-fileio >= 0.3- , time >= 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- , HUnit- , hspec >= 1.3- , blaze-html- , blaze-markup+ , shakespeare >= 2.0 source-repository head
− test.hs
@@ -1,5 +0,0 @@-import HamletTest (spec)-import Test.Hspec--main :: IO ()-main = hspec spec
− test/HamletTest.hs
@@ -1,1068 +0,0 @@-{-# 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 Text.Hamlet.RT -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 "<p>foo</p>\n" [hamlet| -<p> - - foo - - -|] - - - - - it "angle bracket syntax" $ - helper "<p class=\"foo\" height=\"100\"><span id=\"bar\" width=\"50\">HELLO</span></p>" - [hamlet| -$newline never -<p.foo height="100"> - <span #bar width=50>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| -<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| -$newline never -<p>1 -<!-- ignored comment --> -<p> - 2 - <!-- ignored --> not ignored<!-- ignored --> -|] - - it "Keeps SSI includes" $ - helper "<!--# SSI -->" [hamlet|<!--# SSI -->|] - - - - 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 "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 "<p class=\"current\"></p>\n" - [hamlet|<p :False:.ignored :True:.current>|] - - helper "<p class=\"1 3 2 4\"></p>\n" - [hamlet|<p :True:.1 :True:class=2 :False:.a :False:class=b .3 class=4>|] - - helper "<p class=\"foo bar baz\"></p>\n" - [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>\n" [shamlet| - <h1>HELLO WORLD - |] - helperHtml "<h1>HELLO WORLD</h1>\n" $(shamletFile "test/hamlets/nonpolyhtml.hamlet") - helper "<h1>HELLO WORLD</h1>\n" $(hamletFileReload "test/hamlets/nonpolyhtml.hamlet") - - - it "non-poly Hamlet" $ do - let embed = [hamlet|<p>EMBEDDED|] - helper "<h1>url</h1>\n<p>EMBEDDED</p>\n" [hamlet| - <h1>@{Home} - ^{embed} - |] - helper "<h1>url</h1>\n" $(hamletFile "test/hamlets/nonpolyhamlet.hamlet") - helper "<h1>url</h1>\n" $(hamletFileReload "test/hamlets/nonpolyhamlet.hamlet") - - it "non-poly IHamlet" $ do - let embed = [ihamlet|<p>EMBEDDED|] - ihelper "<h1>Adios</h1>\n<p>EMBEDDED</p>\n" [ihamlet| - <h1>_{Goodbye} - ^{embed} - |] - ihelper "<h1>Hola</h1>\n" $(ihamletFile "test/hamlets/nonpolyihamlet.hamlet") - ihelper "<h1>Hola</h1>\n" $(ihamletFileReload "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| -$newline never -<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| -$newline never -<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| -$newline never -<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| -$newline never -<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 ((+) 1 1 + 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| -$newline never -$doctype 5 -$doctype strict -|] - - it "case on Maybe" $ - let nothing = Nothing - justTrue = Just True - in helper "<br><br><br><br>" [hamlet| -$newline never -$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>\n<br>\n" [hamlet| -$newline always -$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| -$newline text -<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| -$newline text -<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| -$newline text -<dl> - $with Pair name age <- people - <dt>#{name} - <dd>#{show age} -|] - - it "multiline tags" $ helper - "<foo bar=\"baz\" bin=\"bin\">content</foo>\n" [hamlet| -<foo bar=baz - bin=bin>content -|] - it "*{...} attributes" $ - let attrs = [("bar", "baz"), ("bin", "<>\"&")] in helper - "<foo bar=\"baz\" bin=\"<>"&\">content</foo>\n" [hamlet| -<foo *{attrs}>content -|] - it "blank attr values" $ helper - "<foo bar=\"\" baz bin=\"\"></foo>\n" - [hamlet|<foo bar="" baz bin=>|] - it "greater than in attr" $ helper - "<button data-bind=\"enable: someFunction() > 5\">hello</button>\n" - [hamlet|<button data-bind="enable: someFunction() > 5">hello|] - it "normal doctype" $ helper - "<!DOCTYPE html>\n" - [hamlet|<!DOCTYPE html>|] - it "newline style" $ helper - "<p>foo</p>\n<pre>bar\nbaz\nbin</pre>\n" - [hamlet| -$newline always -<p>foo -<pre> - bar - baz - bin -|] - it "avoid newlines" $ helper - "<p>foo</p><pre>barbazbin</pre>" - [hamlet| -$newline always -<p>foo# -<pre># - bar# - baz# - bin# -|] - it "manual linebreaks" $ helper - "<p>foo</p><pre>bar\nbaz\nbin</pre>" - [hamlet| -$newline never -<p>foo -<pre> - bar - \ - baz - \ - bin -|] - it "indented newline" $ helper - "<p>foo</p><pre>bar\nbaz\nbin</pre>" - [hamlet| - $newline never - <p>foo - <pre> - bar - \ - baz - \ - bin -|] - it "case underscore" $ - let num = 3 - in helper "<p>Many</p>\n" [hamlet| -$case num - $of 1 - <p>1 - $of 2 - <p>2 - $of _ - <p>Many -|] - it "optional and missing classes" $ - helper "<i>foo</i>\n" [hamlet|<i :False:.not-present>foo|] - it "multiple optional and missing classes" $ - helper "<i>foo</i>\n" [hamlet|<i :False:.not-present :False:.also-not-here>foo|] - it "optional and present classes" $ - helper "<i class=\"present\">foo</i>\n" [hamlet|<i :False:.not-present :True:.present>foo|] - it "punctuation operators #115" $ - helper "foo" - [hamlet| - $if True && True - foo - $else - bar - |] - - it "list syntax" $ - helper "123" - [hamlet| - $forall x <- [] - ignored - $forall x <- [1, 2, 3] - #{show x} - |] - - it "list in attribute" $ - let myShow :: [Int] -> String - myShow = show - in helper "<a href=\"[]\">foo</a>\n<a href=\"[1,2]\">bar</a>\n" - [hamlet| - <a href=#{myShow []}>foo - <a href=#{myShow [1, 2]}>bar - |] - - it "AngularJS attribute values #122" $ - helper "<li ng-repeat=\"addr in msgForm.new.split(/\\\\s/)\">{{addr}}</li>\n" - [hamlet|<li ng-repeat="addr in msgForm.new.split(/\\s/)">{{addr}}|] - - it "runtime Hamlet with caret interpolation" $ do - let toInclude render = render (5, [("hello", "world")]) - let renderer x y = pack $ show (x :: Int, y :: [(Text, Text)]) - template1 = "@?{url}" - template2 = "foo^{toInclude}bar" - toInclude <- parseHamletRT defaultHamletSettings template1 - hamletRT <- parseHamletRT defaultHamletSettings template2 - res <- renderHamletRT hamletRT - [ (["toInclude"], HDTemplate toInclude) - , (["url"], HDUrlParams 5 [(pack "hello", pack "world")]) - ] renderer - helperHtml "foo(5,[(\"hello\",\"world\")])bar" res - -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.Html.Renderer.Text.renderHtml h - T.pack res @=? x - -helper :: String -> HtmlUrl Url -> Assertion -helper res h = do - let x = Text.Blaze.Html.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| -$newline text -<p .foo> - <#bar>baz -|] - helper "<p class=\"foo.bar\"><div id=\"bar\">baz</div></p>" [hamlet| -$newline text -<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}|] - helper "embed" $(hamletFileReload "test/hamlets/embed.hamlet") - ihelper "embed" $(ihamletFileReload "test/hamlets/embed.hamlet") - -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>\n" [hamlet|<script>|] - -caseMetaEmpty :: Assertion -caseMetaEmpty = do - helper "<meta>\n" [hamlet|<meta>|] - helper "<meta/>\n" [xhamlet|<meta>|] - -caseInputEmpty :: Assertion -caseInputEmpty = do - helper "<input>\n" [hamlet|<input>|] - helper "<input/>\n" [xhamlet|<input>|] - -caseMultiClass :: Assertion -caseMultiClass = helper "<div class=\"foo bar\"></div>\n" [hamlet|<.foo.bar>|] - -caseAttribOrder :: Assertion -caseAttribOrder = - helper "<meta 1 2 3>\n" [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| -$newline never -\#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>\n" [hamlet|<select :False:selected>|] - helper "<select selected></select>\n" [hamlet|<select :True:selected>|] - helper "<meta var=\"foo:bar\">\n" [hamlet|<meta var=foo:bar>|] - helper "<select selected></select>\n" - [hamlet|<select :true theArg:selected>|] - - helper "<select></select>\n" [hamlet|<select :False:selected>|] - helper "<select selected></select>\n" [hamlet|<select :True:selected>|] - helper "<meta var=\"foo:bar\">\n" [hamlet|<meta var=foo:bar>|] - helper "<select selected></select>\n" - [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| -$newline never -trailing space # -\ -dollar sign #\ -|] - -caseNonLeadingPercent :: Assertion -caseNonLeadingPercent = - helper "<span style=\"height:100%\">foo</span>" [hamlet| -$newline never -<span style=height:100%>foo -|] - -caseQuotedAttribs :: Assertion -caseQuotedAttribs = - helper "<input type=\"submit\" value=\"Submit response\">" [hamlet| -$newline never -<input type=submit value="Submit response"> -|] - -caseSpacedDerefs :: Assertion -caseSpacedDerefs = do - helper "<var>" [hamlet|#{var theArg}|] - helper "<div class=\"<var>\"></div>\n" [hamlet|<.#{var theArg}>|] - -caseAttribVars :: Assertion -caseAttribVars = do - helper "<div id=\"<var>\"></div>\n" [hamlet|<##{var theArg}>|] - helper "<div class=\"<var>\"></div>\n" [hamlet|<.#{var theArg}>|] - helper "<div f=\"<var>\"></div>\n" [hamlet|< f=#{var theArg}>|] - - helper "<div id=\"<var>\"></div>\n" [hamlet|<##{var theArg}>|] - helper "<div class=\"<var>\"></div>\n" [hamlet|<.#{var theArg}>|] - helper "<div f=\"<var>\"></div>\n" [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| -$newline never -<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| -$newline never -<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\n<br>\n" $(hamletFile "test/hamlets/external.hamlet") - helper "foo\n<br/>\n" $(xhamletFile "test/hamlets/external.hamlet") - helper "foo\n<br>\n" $(hamletFileReload "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.Html.Renderer.Text.renderHtml h - -caseHamlet' :: Assertion -caseHamlet' = do - helper' "foo" [shamlet|foo|] - helper' "foo" [xshamlet|foo|] - helper "<br>\n" $ const $ [shamlet|<br>|] - helper "<br/>\n" $ const $ [xshamlet|<br>|] - - -- new with generalized stuff - helper' "foo" [shamlet|foo|] - helper' "foo" [xshamlet|foo|] - helper "<br>\n" $ const $ [shamlet|<br>|] - helper "<br/>\n" $ 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 = [] - - - -caseTuple :: Assertion -caseTuple = do - helper "(1,1)" [hamlet| #{("1","1")}|] - helper "foo" [hamlet| - $with (a,b) <- ("foo","bar") - #{a} - |] - helper "url" [hamlet| - $with (a,b) <- (Home,Home) - @{a} - |] - helper "url" [hamlet| - $with p <- (Home,[]) - @?{p} - |] - - - -caseComplex :: Assertion -caseComplex = do - let z :: ((Int,Int),Maybe Int,(),Bool,[[Int]]) - z = ((1,2),Just 3,(),True,[[4],[5,6]]) - helper "1 2 3 4 5 61 2 3 4 5 6" [hamlet| - $with ((a,b),Just c, () ,True,d@[[e],[f,g]]) <- z - $forall h <- d - #{a} #{b} #{c} #{e} #{f} #{g} - |] - -caseRecord :: Assertion -caseRecord = do - let z = ARecord 10 True - helper "10" [hamlet| - $with ARecord { field1, field2 = True } <- z - #{field1} - |] - -caseRecordWildCard :: Assertion -caseRecordWildCard = do - let z = ARecord 10 True - helper "10 True" [hamlet| - $with ARecord {..} <- z - #{field1} #{field2} - |] - -caseRecordWildCard1 :: Assertion -caseRecordWildCard1 = do - let z = ARecord 10 True - helper "10" [hamlet| - $with ARecord {field2 = True, ..} <- z - #{field1} - |] - -caseCaseRecord :: Assertion -caseCaseRecord = do - let z = ARecord 10 True - helper "10\nTrue" [hamlet| - $case z - $of ARecord { field1, field2 = x } - #{field1} - #{x} - |] - -data Msg = Hello | Goodbye - -ihelper :: String -> HtmlUrlI18n Msg Url -> Assertion -ihelper res h = do - let x = Text.Blaze.Html.Renderer.Text.renderHtml $ h showMsg render - T.pack res @=? x - where - showMsg Hello = preEscapedString "Hola" - showMsg Goodbye = preEscapedString "Adios" - -instance (ToMarkup a, ToMarkup b) => ToMarkup (a,b) where - toMarkup (a,b) = do - toMarkup "(" - toMarkup a - toMarkup "," - toMarkup b - toMarkup ")"
− test/HamletTestTypes.hs
@@ -1,7 +0,0 @@-module HamletTestTypes where---- This record is defined outside of the HamletTest module--- because record wildcards use 'reify' and reify doesn't--- see types defined in the local module.--data ARecord = ARecord { field1 :: Int, field2 :: Bool }
− test/hamlets/double-foralls.hamlet
@@ -1,3 +0,0 @@-$forall _ <- list-$forall l <- list- #{l}
− test/hamlets/embed.hamlet
@@ -1,1 +0,0 @@-^{embed theArg}
− 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>"