From b66f160fea86d8839572620892181eb4ada2ad29 Mon Sep 17 00:00:00 2001 From: Joey Hess 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