294 lines
9.9 KiB
Diff
294 lines
9.9 KiB
Diff
From b2c677ed39f1aca3a1111691ba51b26f7fd414a4 Mon Sep 17 00:00:00 2001
|
|
From: Joey Hess <joey@kitenet.net>
|
|
Date: Wed, 8 May 2013 01:50:58 -0400
|
|
Subject: [PATCH] remove TH
|
|
|
|
---
|
|
Text/Hamlet.hs | 219 ++------------------------------------------------------
|
|
hamlet.cabal | 2 +-
|
|
2 files changed, 7 insertions(+), 214 deletions(-)
|
|
|
|
diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs
|
|
index 4ac870a..63b8555 100644
|
|
--- a/Text/Hamlet.hs
|
|
+++ b/Text/Hamlet.hs
|
|
@@ -11,35 +11,26 @@
|
|
module Text.Hamlet
|
|
( -- * Plain HTML
|
|
Html
|
|
- , shamlet
|
|
- , shamletFile
|
|
- , xshamlet
|
|
- , xshamletFile
|
|
-- * Hamlet
|
|
, HtmlUrl
|
|
- , hamlet
|
|
- , hamletFile
|
|
- , xhamlet
|
|
- , xhamletFile
|
|
-- * I18N Hamlet
|
|
, HtmlUrlI18n
|
|
- , ihamlet
|
|
- , ihamletFile
|
|
-- * Type classes
|
|
, ToAttributes (..)
|
|
-- * Internal, for making more
|
|
, HamletSettings (..)
|
|
, NewlineStyle (..)
|
|
- , hamletWithSettings
|
|
- , hamletFileWithSettings
|
|
, defaultHamletSettings
|
|
, xhtmlHamletSettings
|
|
, Env (..)
|
|
, HamletRules (..)
|
|
- , hamletRules
|
|
- , ihamletRules
|
|
- , htmlRules
|
|
, CloseStyle (..)
|
|
+ , condH
|
|
+ , maybeH
|
|
+
|
|
+ -- referred to in TH splices
|
|
+ , attrsToHtml
|
|
+ , asHtmlUrl
|
|
) where
|
|
|
|
import Text.Shakespeare.Base
|
|
@@ -90,14 +81,6 @@ 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
|
|
|
|
@@ -159,169 +142,9 @@ recordToFieldNames conStr = do
|
|
[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 scope d
|
|
- docs' <- docsToExp env hr scope docs
|
|
- return $ TupE [d', docs']
|
|
-docToExp env hr scope (DocCase deref cases) = do
|
|
- let exp_ = derefToExp scope deref
|
|
- matches <- mapM toMatch cases
|
|
- return $ CaseE exp_ matches
|
|
- where
|
|
- readMay s =
|
|
- case reads s of
|
|
- (x, ""):_ -> Just x
|
|
- _ -> Nothing
|
|
- toMatch (idents, inside) = do
|
|
- let pat = case map unIdent idents of
|
|
- ["_"] -> WildP
|
|
- [str]
|
|
- | Just i <- readMay str -> LitP $ IntegerL i
|
|
- strs -> let (constr:fields) = map mkName strs
|
|
- in ConP constr (map VarP fields)
|
|
- insideExp <- docsToExp env hr scope inside
|
|
- return $ Match pat (NormalB insideExp) []
|
|
-docToExp env hr v (DocContent c) = contentToExp env hr v c
|
|
-
|
|
-contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp
|
|
-contentToExp _ hr _ (ContentRaw s) = do
|
|
- os <- [|preEscapedText . pack|]
|
|
- let s' = LitE $ StringL s
|
|
- return $ hrFromHtml hr `AppE` (os `AppE` s')
|
|
-contentToExp _ hr scope (ContentVar d) = do
|
|
- str <- [|toHtml|]
|
|
- return $ hrFromHtml hr `AppE` (str `AppE` derefToExp scope d)
|
|
-contentToExp env hr scope (ContentUrl hasParams d) =
|
|
- case urlRender env of
|
|
- Nothing -> error "URL interpolation used, but no URL renderer provided"
|
|
- Just wrender -> wrender $ \render -> do
|
|
- let render' = return render
|
|
- ou <- if hasParams
|
|
- then [|\(u, p) -> $(render') u p|]
|
|
- else [|\u -> $(render') u []|]
|
|
- let d' = derefToExp scope d
|
|
- pet <- [|toHtml|]
|
|
- return $ hrFromHtml hr `AppE` (pet `AppE` (ou `AppE` d'))
|
|
-contentToExp env hr scope (ContentEmbed d) = hrEmbed hr env $ derefToExp scope d
|
|
-contentToExp env hr scope (ContentMsg d) =
|
|
- case msgRender env of
|
|
- Nothing -> error "Message interpolation used, but no message renderer provided"
|
|
- Just wrender -> wrender $ \render ->
|
|
- return $ hrFromHtml hr `AppE` (render `AppE` derefToExp scope d)
|
|
-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
|
|
@@ -333,36 +156,6 @@ data Env = Env
|
|
, msgRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
|
|
}
|
|
|
|
-hamletFromString :: Q HamletRules -> HamletSettings -> String -> Q Exp
|
|
-hamletFromString qhr set s = do
|
|
- hr <- qhr
|
|
- case parseDoc set s of
|
|
- Error s' -> error s'
|
|
- Ok (_mnl, d) -> hrWithEnv hr $ \env -> docsToExp env hr [] d
|
|
-
|
|
-hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp
|
|
-hamletFileWithSettings qhr set fp = do
|
|
-#ifdef GHC_7_4
|
|
- qAddDependentFile fp
|
|
-#endif
|
|
- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
|
|
- hamletFromString qhr set contents
|
|
-
|
|
-hamletFile :: FilePath -> Q Exp
|
|
-hamletFile = hamletFileWithSettings hamletRules defaultHamletSettings
|
|
-
|
|
-xhamletFile :: FilePath -> Q Exp
|
|
-xhamletFile = hamletFileWithSettings hamletRules xhtmlHamletSettings
|
|
-
|
|
-shamletFile :: FilePath -> Q Exp
|
|
-shamletFile = hamletFileWithSettings htmlRules defaultHamletSettings
|
|
-
|
|
-xshamletFile :: FilePath -> Q Exp
|
|
-xshamletFile = hamletFileWithSettings htmlRules xhtmlHamletSettings
|
|
-
|
|
-ihamletFile :: FilePath -> Q Exp
|
|
-ihamletFile = hamletFileWithSettings ihamletRules defaultHamletSettings
|
|
-
|
|
varName :: Scope -> String -> Exp
|
|
varName _ "" = error "Illegal empty varName"
|
|
varName scope v@(_:_) = fromMaybe (strToExp v) $ lookup (Ident v) scope
|
|
diff --git a/hamlet.cabal b/hamlet.cabal
|
|
index 73fa6a8..4348508 100644
|
|
--- a/hamlet.cabal
|
|
+++ b/hamlet.cabal
|
|
@@ -50,7 +50,7 @@ library
|
|
, text >= 0.7 && < 0.12
|
|
, containers >= 0.2
|
|
, blaze-builder >= 0.2 && < 0.4
|
|
- , process >= 1.0 && < 1.2
|
|
+ , process >= 1.0 && < 1.3
|
|
, blaze-html >= 0.5 && < 0.6
|
|
, blaze-markup >= 0.5.1 && < 0.6
|
|
|
|
--
|
|
1.7.10.4
|
|
|