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.
223 lines
8.2 KiB
Diff
223 lines
8.2 KiB
Diff
From b66f160fea86d8839572620892181eb4ada2ad29 Mon Sep 17 00:00:00 2001
|
|
From: Joey Hess <joey@kitenet.net>
|
|
Date: Tue, 17 Dec 2013 06:17:26 +0000
|
|
Subject: [PATCH 2/2] remove TH
|
|
|
|
---
|
|
Text/Shakespeare.hs | 131 +++--------------------------------------------
|
|
Text/Shakespeare/Base.hs | 28 ----------
|
|
2 files changed, 6 insertions(+), 153 deletions(-)
|
|
|
|
diff --git a/Text/Shakespeare.hs b/Text/Shakespeare.hs
|
|
index f908ff4..55cd1d1 100644
|
|
--- a/Text/Shakespeare.hs
|
|
+++ b/Text/Shakespeare.hs
|
|
@@ -12,14 +12,14 @@ module Text.Shakespeare
|
|
, WrapInsertion (..)
|
|
, PreConversion (..)
|
|
, defaultShakespeareSettings
|
|
- , shakespeare
|
|
- , shakespeareFile
|
|
- , shakespeareFileReload
|
|
+ --, shakespeare
|
|
+ --, shakespeareFile
|
|
+ -- , shakespeareFileReload
|
|
-- * low-level
|
|
- , shakespeareFromString
|
|
- , shakespeareUsedIdentifiers
|
|
+ -- , shakespeareFromString
|
|
+ --, shakespeareUsedIdentifiers
|
|
, RenderUrl
|
|
- , VarType
|
|
+ --, VarType
|
|
, Deref
|
|
, Parser
|
|
|
|
@@ -151,38 +151,6 @@ defaultShakespeareSettings = ShakespeareSettings {
|
|
, modifyFinalValue = Nothing
|
|
}
|
|
|
|
-instance Lift PreConvert where
|
|
- lift (PreConvert convert ignore comment wrapInsertion) =
|
|
- [|PreConvert $(lift convert) $(lift ignore) $(lift comment) $(lift wrapInsertion)|]
|
|
-
|
|
-instance Lift WrapInsertion where
|
|
- lift (WrapInsertion indent sb sep sc e wp) =
|
|
- [|WrapInsertion $(lift indent) $(lift sb) $(lift sep) $(lift sc) $(lift e) $(lift wp)|]
|
|
-
|
|
-instance Lift PreConversion where
|
|
- lift (ReadProcess command args) =
|
|
- [|ReadProcess $(lift command) $(lift args)|]
|
|
- lift Id = [|Id|]
|
|
-
|
|
-instance Lift ShakespeareSettings where
|
|
- lift (ShakespeareSettings x1 x2 x3 x4 x5 x6 x7 x8 x9) =
|
|
- [|ShakespeareSettings
|
|
- $(lift x1) $(lift x2) $(lift x3)
|
|
- $(liftExp x4) $(liftExp x5) $(liftExp x6) $(lift x7) $(lift x8) $(liftMExp x9)|]
|
|
- where
|
|
- liftExp (VarE n) = [|VarE $(liftName n)|]
|
|
- liftExp (ConE n) = [|ConE $(liftName n)|]
|
|
- liftExp _ = error "liftExp only supports VarE and ConE"
|
|
- liftMExp Nothing = [|Nothing|]
|
|
- liftMExp (Just e) = [|Just|] `appE` liftExp e
|
|
- liftName (Name (OccName a) b) = [|Name (OccName $(lift a)) $(liftFlavour b)|]
|
|
- liftFlavour NameS = [|NameS|]
|
|
- liftFlavour (NameQ (ModName a)) = [|NameQ (ModName $(lift a))|]
|
|
- liftFlavour (NameU _) = error "liftFlavour NameU" -- [|NameU $(lift $ fromIntegral a)|]
|
|
- liftFlavour (NameL _) = error "liftFlavour NameL" -- [|NameU $(lift $ fromIntegral a)|]
|
|
- liftFlavour (NameG ns (PkgName p) (ModName m)) = [|NameG $(liftNS ns) (PkgName $(lift p)) (ModName $(lift m))|]
|
|
- liftNS VarName = [|VarName|]
|
|
- liftNS DataName = [|DataName|]
|
|
|
|
type QueryParameters = [(TS.Text, TS.Text)]
|
|
type RenderUrl url = (url -> QueryParameters -> TS.Text)
|
|
@@ -346,77 +314,12 @@ pack' = TS.pack
|
|
{-# NOINLINE pack' #-}
|
|
#endif
|
|
|
|
-contentsToShakespeare :: ShakespeareSettings -> [Content] -> Q Exp
|
|
-contentsToShakespeare rs a = do
|
|
- r <- newName "_render"
|
|
- c <- mapM (contentToBuilder r) a
|
|
- compiledTemplate <- case c of
|
|
- -- Make sure we convert this mempty using toBuilder to pin down the
|
|
- -- type appropriately
|
|
- [] -> fmap (AppE $ wrap rs) [|mempty|]
|
|
- [x] -> return x
|
|
- _ -> do
|
|
- mc <- [|mconcat|]
|
|
- return $ mc `AppE` ListE c
|
|
- fmap (maybe id AppE $ modifyFinalValue rs) $
|
|
- if justVarInterpolation rs
|
|
- then return compiledTemplate
|
|
- else return $ LamE [VarP r] compiledTemplate
|
|
- where
|
|
- contentToBuilder :: Name -> Content -> Q Exp
|
|
- contentToBuilder _ (ContentRaw s') = do
|
|
- ts <- [|fromText . pack'|]
|
|
- return $ wrap rs `AppE` (ts `AppE` LitE (StringL s'))
|
|
- contentToBuilder _ (ContentVar d) =
|
|
- return $ (toBuilder rs `AppE` derefToExp [] d)
|
|
- contentToBuilder r (ContentUrl d) = do
|
|
- ts <- [|fromText|]
|
|
- return $ wrap rs `AppE` (ts `AppE` (VarE r `AppE` derefToExp [] d `AppE` ListE []))
|
|
- contentToBuilder r (ContentUrlParam d) = do
|
|
- ts <- [|fromText|]
|
|
- up <- [|\r' (u, p) -> r' u p|]
|
|
- return $ wrap rs `AppE` (ts `AppE` (up `AppE` VarE r `AppE` derefToExp [] d))
|
|
- contentToBuilder r (ContentMix d) =
|
|
- return $ derefToExp [] d `AppE` VarE r
|
|
-
|
|
-shakespeare :: ShakespeareSettings -> QuasiQuoter
|
|
-shakespeare r = QuasiQuoter { quoteExp = shakespeareFromString r }
|
|
-
|
|
-shakespeareFromString :: ShakespeareSettings -> String -> Q Exp
|
|
-shakespeareFromString r str = do
|
|
- s <- qRunIO $ preFilter Nothing r $
|
|
-#ifdef WINDOWS
|
|
- filter (/='\r')
|
|
-#endif
|
|
- str
|
|
- contentsToShakespeare r $ contentFromString r s
|
|
-
|
|
-shakespeareFile :: ShakespeareSettings -> FilePath -> Q Exp
|
|
-shakespeareFile r fp = do
|
|
-#ifdef GHC_7_4
|
|
- qAddDependentFile fp
|
|
-#endif
|
|
- readFileQ fp >>= shakespeareFromString r
|
|
-
|
|
-data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin
|
|
-
|
|
-getVars :: Content -> [(Deref, VarType)]
|
|
-getVars ContentRaw{} = []
|
|
-getVars (ContentVar d) = [(d, VTPlain)]
|
|
-getVars (ContentUrl d) = [(d, VTUrl)]
|
|
-getVars (ContentUrlParam d) = [(d, VTUrlParam)]
|
|
-getVars (ContentMix d) = [(d, VTMixin)]
|
|
|
|
data VarExp url = EPlain Builder
|
|
| EUrl url
|
|
| EUrlParam (url, [(TS.Text, TS.Text)])
|
|
| EMixin (Shakespeare url)
|
|
|
|
--- | Determine which identifiers are used by the given template, useful for
|
|
--- creating systems like yesod devel.
|
|
-shakespeareUsedIdentifiers :: ShakespeareSettings -> String -> [(Deref, VarType)]
|
|
-shakespeareUsedIdentifiers settings = concatMap getVars . contentFromString settings
|
|
-
|
|
type MTime = UTCTime
|
|
|
|
{-# NOINLINE reloadMapRef #-}
|
|
@@ -432,28 +335,6 @@ insertReloadMap :: FilePath -> (MTime, [Content]) -> IO [Content]
|
|
insertReloadMap fp (mt, content) = atomicModifyIORef reloadMapRef
|
|
(\reloadMap -> (M.insert fp (mt, content) reloadMap, content))
|
|
|
|
-shakespeareFileReload :: ShakespeareSettings -> FilePath -> Q Exp
|
|
-shakespeareFileReload settings fp = do
|
|
- str <- readFileQ fp
|
|
- s <- qRunIO $ preFilter (Just fp) settings str
|
|
- let b = shakespeareUsedIdentifiers settings s
|
|
- c <- mapM vtToExp b
|
|
- rt <- [|shakespeareRuntime settings fp|]
|
|
- wrap' <- [|\x -> $(return $ wrap settings) . x|]
|
|
- return $ wrap' `AppE` (rt `AppE` ListE c)
|
|
- where
|
|
- vtToExp :: (Deref, VarType) -> Q Exp
|
|
- vtToExp (d, vt) = do
|
|
- d' <- lift d
|
|
- c' <- c vt
|
|
- return $ TupE [d', c' `AppE` derefToExp [] d]
|
|
- where
|
|
- c :: VarType -> Q Exp
|
|
- c VTPlain = [|EPlain . $(return $
|
|
- InfixE (Just $ unwrap settings) (VarE '(.)) (Just $ toBuilder settings))|]
|
|
- c VTUrl = [|EUrl|]
|
|
- c VTUrlParam = [|EUrlParam|]
|
|
- c VTMixin = [|\x -> EMixin $ \r -> $(return $ unwrap settings) $ x r|]
|
|
|
|
|
|
|
|
diff --git a/Text/Shakespeare/Base.hs b/Text/Shakespeare/Base.hs
|
|
index 9573533..49f1995 100644
|
|
--- a/Text/Shakespeare/Base.hs
|
|
+++ b/Text/Shakespeare/Base.hs
|
|
@@ -52,34 +52,6 @@ data Deref = DerefModulesIdent [String] Ident
|
|
| DerefTuple [Deref]
|
|
deriving (Show, Eq, Read, Data, Typeable, Ord)
|
|
|
|
-instance Lift Ident where
|
|
- lift (Ident s) = [|Ident|] `appE` lift s
|
|
-instance Lift Deref where
|
|
- lift (DerefModulesIdent v s) = do
|
|
- dl <- [|DerefModulesIdent|]
|
|
- v' <- lift v
|
|
- s' <- lift s
|
|
- return $ dl `AppE` v' `AppE` s'
|
|
- lift (DerefIdent s) = do
|
|
- dl <- [|DerefIdent|]
|
|
- s' <- lift s
|
|
- return $ dl `AppE` s'
|
|
- lift (DerefBranch x y) = do
|
|
- x' <- lift x
|
|
- y' <- lift y
|
|
- db <- [|DerefBranch|]
|
|
- return $ db `AppE` x' `AppE` y'
|
|
- lift (DerefIntegral i) = [|DerefIntegral|] `appE` lift i
|
|
- lift (DerefRational r) = do
|
|
- n <- lift $ numerator r
|
|
- d <- lift $ denominator r
|
|
- per <- [|(%) :: Int -> Int -> Ratio Int|]
|
|
- dr <- [|DerefRational|]
|
|
- return $ dr `AppE` InfixE (Just n) per (Just d)
|
|
- lift (DerefString s) = [|DerefString|] `appE` lift s
|
|
- lift (DerefList x) = [|DerefList $(lift x)|]
|
|
- lift (DerefTuple x) = [|DerefTuple $(lift x)|]
|
|
-
|
|
derefParens, derefCurlyBrackets :: UserParser a Deref
|
|
derefParens = between (char '(') (char ')') parseDeref
|
|
derefCurlyBrackets = between (char '{') (char '}') parseDeref
|
|
--
|
|
1.8.5.1
|
|
|