diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs deleted file mode 100644 --- a/Text/Hamlet.hs +++ /dev/null @@ -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" diff --git a/Text/Hamlet/Parse.hs b/Text/Hamlet/Parse.hs deleted file mode 100644 --- a/Text/Hamlet/Parse.hs +++ /dev/null @@ -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 "" - 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 $ "" - _ -> 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 "" DefaultNewlineStyle htmlCloseStyle doctypeNames - -xhtmlHamletSettings :: HamletSettings -xhtmlHamletSettings = - HamletSettings doctype DefaultNewlineStyle xhtmlCloseStyle doctypeNames - where - doctype = - "" - -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", "") - , ("html", "") - , ("1.1", "") - , ("strict", "") - ] - -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.: --- --- >
--- --- 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" diff --git a/Text/Hamlet/RT.hs b/Text/Hamlet/RT.hs deleted file mode 100644 --- a/Text/Hamlet/RT.hs +++ /dev/null @@ -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 diff --git a/hamlet.cabal b/hamlet.cabal --- a/hamlet.cabal +++ b/hamlet.cabal @@ -1,10 +1,10 @@ name: hamlet -version: 1.1.9.2 +version: 1.2.0 license: MIT license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman -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 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 diff --git a/test.hs b/test.hs deleted file mode 100644 --- a/test.hs +++ /dev/null @@ -1,5 +0,0 @@ -import HamletTest (spec) -import Test.Hspec - -main :: IO () -main = hspec spec diff --git a/test/HamletTest.hs b/test/HamletTest.hs deleted file mode 100644 --- a/test/HamletTest.hs +++ /dev/null @@ -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 "

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") - helper "

HELLO WORLD

\n" $(hamletFileReload "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") - helper "

url

\n" $(hamletFileReload "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") - ihelper "

Hola

\n" $(ihamletFileReload "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 -