git-annex-5.20131221: standalone/no-th/haskell-patches/hamlet_remove-TH.patch
From f500a9e447912e68c12f011fe97b62e6a6c5c3ce Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Tue, 17 Dec 2013 16:16:32 +0000
Subject: [PATCH] remove TH
---
Text/Hamlet.hs | 310 ++++-----------------------------------------------------
1 file changed, 17 insertions(+), 293 deletions(-)
diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs
index 4f873f4..10d8ba6 100644
--- a/Text/Hamlet.hs
+++ b/Text/Hamlet.hs
@@ -11,34 +11,34 @@
module Text.Hamlet
( -- * Plain HTML
Html
- , shamlet
- , shamletFile
- , xshamlet
- , xshamletFile
+ --, shamlet
+ --, shamletFile
+ --, xshamlet
+ --, xshamletFile
-- * Hamlet
, HtmlUrl
- , hamlet
- , hamletFile
- , xhamlet
- , xhamletFile
+ --, hamlet
+ --, hamletFile
+ --, xhamlet
+ --, xhamletFile
-- * I18N Hamlet
, HtmlUrlI18n
- , ihamlet
- , ihamletFile
+ --, ihamlet
+ --, ihamletFile
-- * Type classes
, ToAttributes (..)
-- * Internal, for making more
, HamletSettings (..)
, NewlineStyle (..)
- , hamletWithSettings
- , hamletFileWithSettings
+ --, hamletWithSettings
+ --, hamletFileWithSettings
, defaultHamletSettings
, xhtmlHamletSettings
- , Env (..)
- , HamletRules (..)
- , hamletRules
- , ihamletRules
- , htmlRules
+ --, Env (..)
+ --, HamletRules (..)
+ --, hamletRules
+ --, ihamletRules
+ --, htmlRules
, CloseStyle (..)
-- * Used by generated code
, condH
@@ -100,47 +100,9 @@ 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
@@ -148,248 +110,10 @@ conToStr :: DataConstr -> String
conToStr (DCUnqualified (Ident x)) = x
conToStr (DCQualified (Module xs) (Ident x)) = intercalate "." $ xs ++ [x]
--- Wildcards bind all of the unbound fields to variables whose name
--- matches the field name.
---
--- For example: data R = C { f1, f2 :: Int }
--- C {..} is equivalent to C {f1=f1, f2=f2}
--- C {f1 = a, ..} is equivalent to C {f1=a, f2=f2}
--- C {f2 = a, ..} is equivalent to C {f1=f1, f2=a}
-bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)])
-bindWildFields conName fields = do
- fieldNames <- recordToFieldNames conName
- let available n = nameBase n `notElem` map unIdent fields
- let remainingFields = filter available fieldNames
- let mkPat n = do
- e <- newName (nameBase n)
- return ((n,VarP e), (Ident (nameBase n), VarE e))
- fmap unzip $ mapM mkPat remainingFields
-
--- Important note! reify will fail if the record type is defined in the
--- same module as the reify is used. This means quasi-quoted Hamlet
--- literals will not be able to use wildcards to match record types
--- defined in the same module.
-recordToFieldNames :: DataConstr -> Q [Name]
-recordToFieldNames conStr = do
- -- use 'lookupValueName' instead of just using 'mkName' so we reify the
- -- data constructor and not the type constructor if their names match.
- Just conName <- lookupValueName $ conToStr conStr
- DataConI _ _ typeName _ <- reify conName
- TyConI (DataD _ _ _ cons _) <- reify typeName
- [fields] <- return [fields | RecC name fields <- cons, name == conName]
- return [fieldName | (fieldName, _, _) <- fields]
-
-docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp
-docToExp env hr scope (DocForall list idents inside) = do
- let list' = derefToExp scope list
- (pat, extraScope) <- bindingPattern idents
- let scope' = extraScope ++ scope
- mh <- [|F.mapM_|]
- inside' <- docsToExp env hr scope' inside
- let lam = LamE [pat] inside'
- return $ mh `AppE` lam `AppE` list'
-docToExp env hr scope (DocWith [] inside) = do
- inside' <- docsToExp env hr scope inside
- return $ inside'
-docToExp env hr scope (DocWith ((deref, idents):dis) inside) = do
- let deref' = derefToExp scope deref
- (pat, extraScope) <- bindingPattern idents
- let scope' = extraScope ++ scope
- inside' <- docToExp env hr scope' (DocWith dis inside)
- let lam = LamE [pat] inside'
- return $ lam `AppE` deref'
-docToExp env hr scope (DocMaybe val idents inside mno) = do
- let val' = derefToExp scope val
- (pat, extraScope) <- bindingPattern idents
- let scope' = extraScope ++ scope
- inside' <- docsToExp env hr scope' inside
- let inside'' = LamE [pat] inside'
- ninside' <- case mno of
- Nothing -> [|Nothing|]
- Just no -> do
- no' <- docsToExp env hr scope no
- j <- [|Just|]
- return $ j `AppE` no'
- mh <- [|maybeH|]
- return $ mh `AppE` val' `AppE` inside'' `AppE` ninside'
-docToExp env hr scope (DocCond conds final) = do
- conds' <- mapM go conds
- final' <- case final of
- Nothing -> [|Nothing|]
- Just f -> do
- f' <- docsToExp env hr scope f
- j <- [|Just|]
- return $ j `AppE` f'
- ch <- [|condH|]
- return $ ch `AppE` ListE conds' `AppE` final'
- where
- go :: (Deref, [Doc]) -> Q Exp
- go (d, docs) = do
- let d' = derefToExp ((specialOrIdent, VarE 'or):scope) d
- docs' <- docsToExp env hr scope docs
- return $ TupE [d', docs']
-docToExp env hr scope (DocCase deref cases) = do
- let exp_ = derefToExp scope deref
- matches <- mapM toMatch cases
- return $ CaseE exp_ matches
- where
- readMay s =
- case reads s of
- (x, ""):_ -> Just x
- _ -> Nothing
- toMatch :: (Binding, [Doc]) -> Q Match
- toMatch (idents, inside) = do
- (pat, extraScope) <- bindingPattern idents
- let scope' = extraScope ++ scope
- insideExp <- docsToExp env hr scope' inside
- return $ Match pat (NormalB insideExp) []
-docToExp env hr v (DocContent c) = contentToExp env hr v c
-
-contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp
-contentToExp _ hr _ (ContentRaw s) = do
- os <- [|preEscapedText . pack|]
- let s' = LitE $ StringL s
- return $ hrFromHtml hr `AppE` (os `AppE` s')
-contentToExp _ hr scope (ContentVar d) = do
- str <- [|toHtml|]
- return $ hrFromHtml hr `AppE` (str `AppE` derefToExp scope d)
-contentToExp env hr scope (ContentUrl hasParams d) =
- case urlRender env of
- Nothing -> error "URL interpolation used, but no URL renderer provided"
- Just wrender -> wrender $ \render -> do
- let render' = return render
- ou <- if hasParams
- then [|\(u, p) -> $(render') u p|]
- else [|\u -> $(render') u []|]
- let d' = derefToExp scope d
- pet <- [|toHtml|]
- return $ hrFromHtml hr `AppE` (pet `AppE` (ou `AppE` d'))
-contentToExp env hr scope (ContentEmbed d) = hrEmbed hr env $ derefToExp scope d
-contentToExp env hr scope (ContentMsg d) =
- case msgRender env of
- Nothing -> error "Message interpolation used, but no message renderer provided"
- Just wrender -> wrender $ \render ->
- return $ hrFromHtml hr `AppE` (render `AppE` derefToExp scope d)
-contentToExp _ hr scope (ContentAttrs d) = do
- html <- [|attrsToHtml . toAttributes|]
- return $ hrFromHtml hr `AppE` (html `AppE` derefToExp scope d)
-
-shamlet :: QuasiQuoter
-shamlet = hamletWithSettings htmlRules defaultHamletSettings
-
-xshamlet :: QuasiQuoter
-xshamlet = hamletWithSettings htmlRules xhtmlHamletSettings
-
-htmlRules :: Q HamletRules
-htmlRules = do
- i <- [|id|]
- return $ HamletRules i ($ (Env Nothing Nothing)) (\_ b -> return b)
-
-hamlet :: QuasiQuoter
-hamlet = hamletWithSettings hamletRules defaultHamletSettings
-
-xhamlet :: QuasiQuoter
-xhamlet = hamletWithSettings hamletRules xhtmlHamletSettings
asHtmlUrl :: HtmlUrl url -> HtmlUrl url
asHtmlUrl = id
-hamletRules :: Q HamletRules
-hamletRules = do
- i <- [|id|]
- let ur f = do
- r <- newName "_render"
- let env = Env
- { urlRender = Just ($ (VarE r))
- , msgRender = Nothing
- }
- h <- f env
- return $ LamE [VarP r] h
- return $ HamletRules i ur em
- where
- em (Env (Just urender) Nothing) e = do
- asHtmlUrl' <- [|asHtmlUrl|]
- urender $ \ur' -> return ((asHtmlUrl' `AppE` e) `AppE` ur')
- em _ _ = error "bad Env"
-
-ihamlet :: QuasiQuoter
-ihamlet = hamletWithSettings ihamletRules defaultHamletSettings
-
-ihamletRules :: Q HamletRules
-ihamletRules = do
- i <- [|id|]
- let ur f = do
- u <- newName "_urender"
- m <- newName "_mrender"
- let env = Env
- { urlRender = Just ($ (VarE u))
- , msgRender = Just ($ (VarE m))
- }
- h <- f env
- return $ LamE [VarP m, VarP u] h
- return $ HamletRules i ur em
- where
- em (Env (Just urender) (Just mrender)) e =
- urender $ \ur' -> mrender $ \mr -> return (e `AppE` mr `AppE` ur')
- em _ _ = error "bad Env"
-
-hamletWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter
-hamletWithSettings hr set =
- QuasiQuoter
- { quoteExp = hamletFromString hr set
- }
-
-data HamletRules = HamletRules
- { hrFromHtml :: Exp
- , hrWithEnv :: (Env -> Q Exp) -> Q Exp
- , hrEmbed :: Env -> Exp -> Q Exp
- }
-
-data Env = Env
- { urlRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
- , msgRender :: Maybe ((Exp -> Q Exp) -> Q Exp)
- }
-
-hamletFromString :: Q HamletRules -> HamletSettings -> String -> Q Exp
-hamletFromString qhr set s = do
- hr <- qhr
- case parseDoc set s of
- Error s' -> error s'
- Ok (_mnl, d) -> hrWithEnv hr $ \env -> docsToExp env hr [] d
-
-hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp
-hamletFileWithSettings qhr set fp = do
-#ifdef GHC_7_4
- qAddDependentFile fp
-#endif
- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
- hamletFromString qhr set contents
-
-hamletFile :: FilePath -> Q Exp
-hamletFile = hamletFileWithSettings hamletRules defaultHamletSettings
-
-xhamletFile :: FilePath -> Q Exp
-xhamletFile = hamletFileWithSettings hamletRules xhtmlHamletSettings
-
-shamletFile :: FilePath -> Q Exp
-shamletFile = hamletFileWithSettings htmlRules defaultHamletSettings
-
-xshamletFile :: FilePath -> Q Exp
-xshamletFile = hamletFileWithSettings htmlRules xhtmlHamletSettings
-
-ihamletFile :: FilePath -> Q Exp
-ihamletFile = hamletFileWithSettings ihamletRules defaultHamletSettings
-
-varName :: Scope -> String -> Exp
-varName _ "" = error "Illegal empty varName"
-varName scope v@(_:_) = fromMaybe (strToExp v) $ lookup (Ident v) scope
-
-strToExp :: String -> Exp
-strToExp s@(c:_)
- | all isDigit s = LitE $ IntegerL $ read s
- | isUpper c = ConE $ mkName s
- | otherwise = VarE $ mkName s
-strToExp "" = error "strToExp on empty string"
-- | Checks for truth in the left value in each pair in the first argument. If
-- a true exists, then the corresponding right action is performed. Only the
--
1.8.5.1