th-lift 0.7.9 → 0.7.10
raw patch · 4 files changed
+108/−106 lines, 4 filesdep +th-abstractionPVP ok
version bump matches the API change (PVP)
Dependencies added: th-abstraction
API changes (from Hackage documentation)
Files
- src/Language/Haskell/TH/Lift.hs +78/−103
- t/Foo.hs +20/−0
- t/Test.hs +6/−0
- th-lift.cabal +4/−3
src/Language/Haskell/TH/Lift.hs view
@@ -39,51 +39,50 @@ import Data.Ratio (Ratio) #endif /* !(MIN_VERSION_template_haskell(2,10,0)) */ import Language.Haskell.TH+import Language.Haskell.TH.Datatype+import qualified Language.Haskell.TH.Lib as Lib (starK) import Language.Haskell.TH.Syntax import Control.Monad ((<=<), zipWithM) #if MIN_VERSION_template_haskell(2,9,0) import Data.Maybe (catMaybes) #endif /* MIN_VERSION_template_haskell(2,9,0) */ -modName :: String-modName = "Language.Haskell.TH.Lift"- -- | Derive Lift instances for the given datatype. deriveLift :: Name -> Q [Dec] #if MIN_VERSION_template_haskell(2,9,0) deriveLift name = do- roles <- qReifyRoles name- info <- reify name- deriveLift' roles info+ roles <- reifyDatatypeRoles name+ info <- reifyDatatype name+ fmap (:[]) $ deriveLiftOne roles info #else-deriveLift = deriveLift' <=< reify+deriveLift = fmap (:[]) . deriveLiftOne <=< reifyDatatype #endif -- | Derive Lift instances for many datatypes. deriveLiftMany :: [Name] -> Q [Dec] #if MIN_VERSION_template_haskell(2,9,0) deriveLiftMany names = do- roles <- mapM qReifyRoles names- infos <- mapM reify names- deriveLiftMany' (zip roles infos)+ roles <- mapM reifyDatatypeRoles names+ infos <- mapM reifyDatatype names+ mapM (uncurry deriveLiftOne) $ zip roles infos #else-deriveLiftMany = deriveLiftMany' <=< mapM reify+deriveLiftMany = mapM deriveLiftOne <=< mapM reifyDatatype #endif -- | Obtain Info values through a custom reification function. This is useful -- when generating instances for datatypes that have not yet been declared. #if MIN_VERSION_template_haskell(2,9,0) deriveLift' :: [Role] -> Info -> Q [Dec]-deriveLift' roles = fmap (:[]) . deriveLiftOne roles+deriveLift' roles = fmap (:[]) . deriveLiftOne roles <=< normalizeInfo deriveLiftMany' :: [([Role], Info)] -> Q [Dec]-deriveLiftMany' = mapM (uncurry deriveLiftOne)+deriveLiftMany' = mapM (\(rs, i) -> deriveLiftOne rs =<< normalizeInfo i) #else deriveLift' :: Info -> Q [Dec]-deriveLift' = fmap (:[]) . deriveLiftOne+deriveLift' = fmap (:[]) . deriveLiftOne <=< normalizeInfo deriveLiftMany' :: [Info] -> Q [Dec]-deriveLiftMany' = mapM deriveLiftOne+deriveLiftMany' = mapM (deriveLiftOne <=< normalizeInfo) #endif -- | Generates a lambda expresson which behaves like 'lift' (without requiring@@ -96,95 +95,92 @@ -- lift = $(makeLift ''Fix) -- @ makeLift :: Name -> Q Exp-makeLift = makeLift' <=< reify+makeLift = makeLiftInternal <=< reifyDatatype -- | Like 'makeLift', but using a custom reification function. makeLift' :: Info -> Q Exp-makeLift' i = withInfo i $ \_ n _ cons -> makeLiftOne n cons+makeLift' = makeLiftInternal <=< normalizeInfo +makeLiftInternal :: DatatypeInfo -> Q Exp+makeLiftInternal i = withInfo i $ \_ n _ cons -> makeLiftOne n cons+ #if MIN_VERSION_template_haskell(2,9,0)-deriveLiftOne :: [Role] -> Info -> Q Dec+deriveLiftOne :: [Role] -> DatatypeInfo -> Q Dec deriveLiftOne roles i = withInfo i liftInstance #else-deriveLiftOne :: Info -> Q Dec+deriveLiftOne :: DatatypeInfo -> Q Dec deriveLiftOne i = withInfo i liftInstance #endif where- liftInstance dcx n vs cons = do+ liftInstance dcx n tys cons = do #if MIN_VERSION_template_haskell(2,9,0)- -- roles <- qReifyRoles n+ -- roles <- reifyDatatypeRoles n -- Compute the set of phantom variables.- let phvars = catMaybes $- zipWith (\v role -> if role == PhantomR then Just v else Nothing)- vs+ let phtys = catMaybes $+ zipWith (\t role -> if role == PhantomR then Just t else Nothing)+ tys roles #else /* MIN_VERSION_template_haskell(2,9,0) */- let phvars = []+ let phtys = [] #endif- instanceD (ctxt dcx phvars vs)- (conT ''Lift `appT` typ n (map fst vs))+ instanceD (ctxt dcx phtys tys)+ (conT ''Lift `appT` typ n tys) [funD 'lift [clause [] (normalB (makeLiftOne n cons)) []]]- typ n = foldl appT (conT n) . map varT+ typ n = foldl appT (conT n) . map unKind -- Only consider *-kinded type variables, because Lift instances cannot -- meaningfully be given to types of other kinds. Further, filter out type -- variables that are obviously phantom.- ctxt dcx phvars =- fmap (dcx ++) . cxt . concatMap liftPred . filter (`notElem` phvars)+ ctxt dcx phtys =+ fmap (dcx ++) . cxt . concatMap liftPred . filter (`notElem` phtys)+ liftPred ty =+ case ty of+ SigT t k+ | k == Lib.starK -> mkLift t+ | otherwise -> []+ _ -> mkLift ty #if MIN_VERSION_template_haskell(2,10,0)- liftPred (v, StarT) = [conT ''Lift `appT` varT v]- liftPred (_, _) = []-#elif MIN_VERSION_template_haskell(2,8,0)- liftPred (v, StarT) = [classP ''Lift [varT v]]- liftPred (_, _) = []-#elif MIN_VERSION_template_haskell(2,4,0)- liftPred (v, StarK) = [classP ''Lift [varT v]]- liftPred (_, _) = []-#else /* !(MIN_VERSION_template_haskell(2,4,0)) */- liftPred n = conT ''Lift `appT` varT n+ mkLift ty = [conT ''Lift `appT` (return ty)]+#else+ mkLift ty = [classP ''Lift [return ty]] #endif+ unKind (SigT t k)+ | k == Lib.starK = return t+ unKind t = return t -makeLiftOne :: Name -> [Con] -> Q Exp+makeLiftOne :: Name -> [ConstructorInfo] -> Q Exp makeLiftOne n cons = do e <- newName "e" lam1E (varP e) $ caseE (varE e) $ consMatches n cons -consMatches :: Name -> [Con] -> [Q Match]+consMatches :: Name -> [ConstructorInfo] -> [Q Match] consMatches n [] = [match wildP (normalB e) []] where e = [| errorQExp $(stringE ("Can't lift value of empty datatype " ++ nameBase n)) |] consMatches _ cons = concatMap doCons cons -doCons :: Con -> [Q Match]-doCons (NormalC c sts) = (:[]) $ do- ns <- zipWithM (\_ i -> newName ('x':show (i :: Int))) sts [0..]- let con = [| conE c |]- args = [ liftVar n t | (n, (_, t)) <- zip ns sts ]- e = foldl (\e1 e2 -> [| appE $e1 $e2 |]) con args- match (conP c (map varP ns)) (normalB e) []-doCons (RecC c sts) = doCons $ NormalC c [(s, t) | (_, s, t) <- sts]-doCons (InfixC sty1 c sty2) = (:[]) $ do- x0 <- newName "x0"- x1 <- newName "x1"- let con = [| conE c |]- left = liftVar x0 (snd sty1)- right = liftVar x1 (snd sty2)- e = [| infixApp $left $con $right |]- match (infixP (varP x0) c (varP x1)) (normalB e) []-doCons (ForallC _ _ c) = doCons c-#if MIN_VERSION_template_haskell(2,11,0)--- GADTs can have multiple constructor names, when they are written like:------ data T where--- MkT1, MkT2 :: T-doCons (GadtC cs sts _) = map (\c -> do- ns <- zipWithM (\_ i -> newName ('x':show (i :: Int))) sts [0..]+doCons :: ConstructorInfo -> [Q Match]+doCons (ConstructorInfo { constructorName = c+ , constructorFields = ts+ , constructorVariant = variant+ }) = (:[]) $ do+ ns <- zipWithM (\_ i -> newName ('x':show (i :: Int))) ts [0..] let con = [| conE c |]- args = [ liftVar n t | (n, (_, t)) <- zip ns sts ]- e = foldl (\e1 e2 -> [| appE $e1 $e2 |]) con args- match (conP c (map varP ns)) (normalB e) []- ) cs-doCons (RecGadtC cs sts _) =- concatMap (\c -> doCons $ NormalC c [(s,t) | (_, s, t) <- sts]) cs+ case (variant, ns, ts) of+ (InfixConstructor, [x0, x1], [t0, t1]) ->+ let e = [| infixApp $(liftVar x0 t0) $con $(liftVar x1 t1) |]+ in match (infixP (varP x0) c (varP x1)) (normalB e) []+ (_, _, _) ->+ let e = foldl (\e1 e2 -> [| appE $e1 $e2 |]) con $ zipWith liftVar ns ts+ in match (conP c (map varP ns)) (normalB e) []++#if MIN_VERSION_template_haskell(2,9,0)+-- Reify the roles of a data type. Note that the argument Name may correspond+-- to that of a data family instance constructor, so we need to go through+-- reifyDatatype to determine what the parent data family Name is.+reifyDatatypeRoles :: Name -> Q [Role]+reifyDatatypeRoles n = do+ DatatypeInfo { datatypeName = dn } <- reifyDatatype n+ qReifyRoles dn #endif liftVar :: Name -> Type -> Q Exp@@ -207,37 +203,16 @@ var = varE varName liftVar varName _ = [| lift $(varE varName) |] -withInfo :: Info-#if MIN_VERSION_template_haskell(2,4,0)- -> (Cxt -> Name -> [(Name, Kind)] -> [Con] -> Q a)-#else /* !(MIN_VERSION_template_haskell(2,4,0)) */- -> (Cxt -> Name -> [Name] -> [Con] -> Q a)-#endif+withInfo :: DatatypeInfo+ -> (Cxt -> Name -> [Type] -> [ConstructorInfo] -> Q a) -> Q a withInfo i f = case i of-#if MIN_VERSION_template_haskell(2,11,0)- TyConI (DataD dcx n vsk _ cons _) ->- f dcx n (map unTyVarBndr vsk) cons- TyConI (NewtypeD dcx n vsk _ con _) ->- f dcx n (map unTyVarBndr vsk) [con]-#else- TyConI (DataD dcx n vsk cons _) ->- f dcx n (map unTyVarBndr vsk) cons- TyConI (NewtypeD dcx n vsk con _) ->- f dcx n (map unTyVarBndr vsk) [con]-#endif- _ -> error (modName ++ ".deriveLift: unhandled: " ++ pprint i)- where-#if MIN_VERSION_template_haskell(2,8,0)- unTyVarBndr (PlainTV v) = (v, StarT)- unTyVarBndr (KindedTV v k) = (v, k)-#elif MIN_VERSION_template_haskell(2,4,0)- unTyVarBndr (PlainTV v) = (v, StarK)- unTyVarBndr (KindedTV v k) = (v, k)-#else /* !(MIN_VERSION_template_haskell(2,4,0)) */- unTyVarBndr :: Name -> Name- unTyVarBndr v = v-#endif+ DatatypeInfo { datatypeContext = dcx+ , datatypeName = n+ , datatypeVars = vs+ , datatypeCons = cons+ } ->+ f dcx n vs cons -- A type-restricted version of error that ensures makeLift always returns a -- value of type Q Exp, even when used on an empty datatype.@@ -275,8 +250,8 @@ lift (NameL i) = [| case $( lift (I# i) ) of I# i' -> NameL i' |] #endif /* __GLASGOW_HASKELL__ < 710 */- lift (NameG nameSpace pkgName modnam)- = [| NameG nameSpace pkgName modnam |]+ lift (NameG nameSpace' pkgName modnam)+ = [| NameG nameSpace' pkgName modnam |] instance Lift NameSpace where lift VarName = [| VarName |]
t/Foo.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Foo where @@ -41,9 +43,27 @@ newtype Fix f = In { out :: f (Fix f) } deriving instance Show (f (Fix f)) => Show (Fix f) +#if MIN_VERSION_template_haskell(2,7,0)+data family Fam a b c+data instance Fam a Int Char+ = FamPrefix1 a Char+ | FamPrefix2 a+ | FamRec { famField :: a }+ | a :%%: a+ deriving Show+data instance Fam a Bool Bool = FamInstBool a Bool+ deriving Show+#endif+ $(deriveLift ''Foo) $(deriveLift ''Rec) $(deriveLift ''Empty) $(deriveLift ''Unboxed) instance Lift (f (Fix f)) => Lift (Fix f) where lift = $(makeLift ''Fix)++#if MIN_VERSION_template_haskell(2,7,0)+$(deriveLift 'FamPrefix1)+instance (Eq a, Lift a) => Lift (Fam a Bool Bool) where+ lift = $(makeLift 'FamInstBool)+#endif
t/Test.hs view
@@ -16,3 +16,9 @@ #endif 1.0## 1.0# 1# 1##) ) print $( lift (In { out = Nothing }) )+#if MIN_VERSION_template_haskell(2,7,0)+ print $( lift (FamPrefix1 "str1" 'c') )+ print $( lift (FamPrefix2 "str2") )+ print $( lift (FamRec {famField = 'a'}) )+ print $( lift ('a' :%%: 'b') )+#endif
th-lift.cabal view
@@ -1,9 +1,9 @@ Name: th-lift-Version: 0.7.9+Version: 0.7.10 Cabal-Version: >= 1.8 License: BSD3 License-Files: COPYING, BSD3, GPL-2-Copyright: © 2006 Ian Lynagh, © 2010-2014 Mathieu Boespflug+Copyright: © 2006 Ian Lynagh, © 2010-2018 Mathieu Boespflug Author: Ian Lynagh Maintainer: Mathieu Boespflug <mboes@tweag.net> Homepage: http://github.com/mboes/th-lift@@ -24,7 +24,8 @@ Extensions: CPP, TemplateHaskell, MagicHash, TypeSynonymInstances, FlexibleInstances Hs-Source-Dirs: src Build-Depends: base >= 3 && < 5,- ghc-prim+ ghc-prim,+ th-abstraction >= 0.2.3 ghc-options: -Wall if impl(ghc < 6.12)