ccef06da41
Was able to reuse many of the android patches, but several had to be re-done. On Android, ghc is a stage2 build, so can compile, but not run TH code. But debian's ghc on armel cannot even compile TH code, so it has to be patched out. Some haskell packages have been updated to new versions, including yesod and DAV, and their patches had to be redone. The Makefile now has 2 new targets. The first is run on a companion x86 system to do the build and get TH splices. Then the second target is run the same source tree on the arm system to build without needing TH. This commit was sponsored by Svenne Krap.
365 lines
13 KiB
Diff
365 lines
13 KiB
Diff
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
|
|
|