From 38a22dae4f7f9726379fdaa3f85d78d75eee9d8e Mon Sep 17 00:00:00 2001 From: dummy Date: Thu, 16 Oct 2014 02:01:22 +0000 Subject: [PATCH] hack TH --- Text/Shakespeare.hs | 70 ++++++++---------------------------------------- Text/Shakespeare/Base.hs | 28 ------------------- 2 files changed, 11 insertions(+), 87 deletions(-) diff --git a/Text/Shakespeare.hs b/Text/Shakespeare.hs index 68e344f..97361a2 100644 --- a/Text/Shakespeare.hs +++ b/Text/Shakespeare.hs @@ -14,12 +14,12 @@ module Text.Shakespeare , WrapInsertion (..) , PreConversion (..) , defaultShakespeareSettings - , shakespeare - , shakespeareFile - , shakespeareFileReload + -- , shakespeare + -- , shakespeareFile + -- , shakespeareFileReload -- * low-level - , shakespeareFromString - , shakespeareUsedIdentifiers + -- , shakespeareFromString + -- , shakespeareUsedIdentifiers , RenderUrl , VarType (..) , Deref @@ -154,38 +154,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) @@ -349,6 +317,7 @@ pack' = TS.pack {-# NOINLINE pack' #-} #endif +{- contentsToShakespeare :: ShakespeareSettings -> [Content] -> Q Exp contentsToShakespeare rs a = do r <- newName "_render" @@ -400,16 +369,19 @@ shakespeareFile r fp = qAddDependentFile fp >> #endif readFileQ fp >>= shakespeareFromString r +-} data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin deriving (Show, Eq, Ord, Enum, Bounded, Typeable, Data, Generic) +{- 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 @@ -418,8 +390,10 @@ data VarExp url = EPlain Builder -- | 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 @@ -436,28 +410,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 a0e983c..23b4692 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 -- 2.1.1