{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} module Text.Hamlet ( -- * Plain HTML Html , shamlet , shamletFile , xshamlet , xshamletFile -- * Hamlet , HtmlUrl , Render , hamlet , hamletFile , hamletFileReload , xhamlet , xhamletFile -- * I18N Hamlet , HtmlUrlI18n , Translate , ihamlet , ihamletFile , ihamletFileReload -- * 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 -- * low-level , hamletFromString ) 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 System.Directory (getModificationTime) import Data.Time (UTCTime) 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)) | s == "_" = return (WildP, []) | 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 #if MIN_VERSION_template_haskell(2,11,0) DataConI _ _ typeName <- reify conName TyConI (DataD _ _ _ _ cons _) <- reify typeName #else DataConI _ _ typeName _ <- reify conName TyConI (DataD _ _ _ cons _) <- reify typeName #endif [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) -- | "Simple Hamlet" quasi-quoter. May only be used to generate expressions. -- -- Generated expressions have type 'Html'. -- -- @ -- >>> 'putStrLn' ('Text.Blaze.Html.Renderer.renderHtml' ['shamlet'|\