From 2e6721d571148cb77fb8c906042f6fa61e660999 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 28 Feb 2013 23:35:41 -0400 Subject: [PATCH] remove TH --- Text/Shakespeare.hs | 109 ---------------------------------------------- Text/Shakespeare/Base.hs | 28 ------------ 2 files changed, 137 deletions(-) diff --git a/Text/Shakespeare.hs b/Text/Shakespeare.hs index e774e65..d300951 100644 --- a/Text/Shakespeare.hs +++ b/Text/Shakespeare.hs @@ -12,11 +12,7 @@ module Text.Shakespeare , WrapInsertion (..) , PreConversion (..) , defaultShakespeareSettings - , shakespeare - , shakespeareFile - , shakespeareFileReload -- * low-level - , shakespeareFromString , shakespeareUsedIdentifiers , RenderUrl , VarType @@ -133,39 +129,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 ab ac) = - [|WrapInsertion $(lift indent) $(lift sb) $(lift sep) $(lift sc) $(lift e) $(lift ab) $(lift ac)|] - -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) type Shakespeare url = RenderUrl url -> Builder @@ -300,54 +263,6 @@ 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 $ wrap rs `AppE` (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 r 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)] @@ -367,30 +282,6 @@ data VarExp url = EPlain Builder shakespeareUsedIdentifiers :: ShakespeareSettings -> String -> [(Deref, VarType)] shakespeareUsedIdentifiers settings = concatMap getVars . contentFromString settings -shakespeareFileReload :: ShakespeareSettings -> FilePath -> Q Exp -shakespeareFileReload rs fp = do - str <- readFileQ fp - s <- qRunIO $ preFilter rs str - let b = shakespeareUsedIdentifiers rs s - c <- mapM vtToExp b - rt <- [|shakespeareRuntime|] - wrap' <- [|\x -> $(return $ wrap rs) . x|] - r' <- lift rs - return $ wrap' `AppE` (rt `AppE` r' `AppE` (LitE $ StringL fp) `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 $ toBuilder rs)|] - c VTUrl = [|EUrl|] - c VTUrlParam = [|EUrlParam|] - c VTMixin = [|\x -> EMixin $ \r -> $(return $ unwrap rs) $ x r|] - - shakespeareRuntime :: ShakespeareSettings -> FilePath -> [(Deref, VarExp url)] -> Shakespeare url shakespeareRuntime rs fp cd render' = unsafePerformIO $ do str <- readFileUtf8 fp diff --git a/Text/Shakespeare/Base.hs b/Text/Shakespeare/Base.hs index 7c96898..ef769b1 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.7.10.4