th-lift 0.5 → 0.5.1
raw patch · 4 files changed
+122/−94 lines, 4 filesdep +packedstringdep ~basedep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependencies added: packedstring
Dependency ranges changed: base, template-haskell
API changes (from Hackage documentation)
Files
- Changelog +4/−0
- Language/Haskell/TH/Lift.hs +0/−91
- src/Language/Haskell/TH/Lift.hs +108/−0
- th-lift.cabal +10/−3
Changelog view
@@ -1,3 +1,7 @@+2010-09-19 Mathieu Boespflug <mboes@tweag.net>++ * Support older GHCs and Cabal, thanks to Ben Millwood.+ 2010-08-05 Mathieu Boespflug <mboes@tweag.net> * Support for contexts in datatypes, thanks to Ben Millwood.
− Language/Haskell/TH/Lift.hs
@@ -1,91 +0,0 @@-module Language.Haskell.TH.Lift (deriveLift, deriveLiftMany, deriveLift', deriveLiftMany', Lift(..)) where--import GHC.Exts-import Language.Haskell.TH-import Language.Haskell.TH.Syntax-import Control.Monad ((<=<))--modName :: String-modName = "Language.Haskell.TH.Lift"---- | Derive Lift instances for the given datatype.-deriveLift :: Name -> Q [Dec]-deriveLift = deriveLift' <=< reify---- | Derive Lift instances for many datatypes.-deriveLiftMany :: [Name] -> Q [Dec]-deriveLiftMany = deriveLiftMany' <=< mapM reify---- | Obtain Info values through a custom reification function. This is useful--- when generating instances for datatypes that have not yet been declared.-deriveLift' :: Info -> Q [Dec]-deriveLift' = fmap (:[]) . deriveLiftOne--deriveLiftMany' :: [Info] -> Q [Dec]-deriveLiftMany' = mapM deriveLiftOne--deriveLiftOne :: Info -> Q Dec-deriveLiftOne i =- case i of- TyConI (DataD dcx n vsk cons _) ->- liftInstance dcx n (map unTyVarBndr vsk) (map doCons cons)- TyConI (NewtypeD dcx n vsk con _) ->- liftInstance dcx n (map unTyVarBndr vsk) [doCons con]- _ -> error (modName ++ ".deriveLift: unhandled: " ++ pprint i)- where liftInstance dcx n vs cases =- instanceD (ctxt dcx vs) (conT ''Lift `appT` typ n vs) [funD 'lift cases]- unTyVarBndr (PlainTV v) = v- unTyVarBndr (KindedTV v _) = v- ctxt dcx = fmap (dcx ++) . cxt . map (\n -> classP ''Lift [varT n])- typ n = foldl appT (conT n) . map varT--doCons :: Con -> Q Clause-doCons (NormalC c sts) = do- let ns = zipWith (\_ i -> "x" ++ show i) sts [0..]- con = [| conE c |]- args = [ [| lift $(varE (mkName n)) |] | n <- ns ]- e = foldl (\e1 e2 -> [| appE $e1 $e2 |]) con args- clause [conP c (map (varP . mkName) ns)] (normalB e) []-doCons (RecC c sts) = doCons $ NormalC c [(s, t) | (_, s, t) <- sts]-doCons (InfixC sty1 c sty2) = do- let con = [| conE c |]- left = [| lift $(varE (mkName "x0")) |]- right = [| lift $(varE (mkName "x1")) |]- e = [| infixApp $left $con $right |]- clause [infixP (varP (mkName "x0")) c (varP (mkName "x1"))] (normalB e) []-doCons c = error (modName ++ ".doCons: Unhandled constructor: " ++ pprint c)--instance Lift Name where- lift (Name occName nameFlavour) = [| Name occName nameFlavour |]--instance Lift OccName where- lift n = [| mkOccName $(lift $ occString n) |]--instance Lift PkgName where- lift n = [| mkPkgName $(lift $ pkgString n) |]--instance Lift ModName where- lift n = [| mkModName $(lift $ modString n) |]--instance Lift NameFlavour where- lift NameS = [| NameS |]- lift (NameQ modName) = [| NameQ modName |]- lift (NameU i) = [| case $( lift (I# i) ) of- I# i' -> NameU i' |]- lift (NameL i) = [| case $( lift (I# i) ) of- I# i' -> NameL i' |]- lift (NameG nameSpace pkgName modName)- = [| NameG nameSpace pkgName modName |]--instance Lift NameSpace where- lift VarName = [| VarName |]- lift DataName = [| DataName |]- lift TcClsName = [| TcClsName |]---- These instances should really go in the template-haskell package.--instance Lift () where- lift _ = [| () |]--instance Lift Rational where- lift x = return (LitE (RationalL x))
+ src/Language/Haskell/TH/Lift.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE CPP, TemplateHaskell, MagicHash, TypeSynonymInstances #-}+module Language.Haskell.TH.Lift (deriveLift, deriveLiftMany, deriveLift', deriveLiftMany', Lift(..)) where++#if !MIN_VERSION_template_haskell(2,4,0)+import Data.PackedString (PackedString, packString, unpackPS)+#endif /* MIN_VERSION_template_haskell(2,4,0) */++import GHC.Exts+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Control.Monad ((<=<))++modName :: String+modName = "Language.Haskell.TH.Lift"++-- | Derive Lift instances for the given datatype.+deriveLift :: Name -> Q [Dec]+deriveLift = deriveLift' <=< reify++-- | Derive Lift instances for many datatypes.+deriveLiftMany :: [Name] -> Q [Dec]+deriveLiftMany = deriveLiftMany' <=< mapM reify++-- | Obtain Info values through a custom reification function. This is useful+-- when generating instances for datatypes that have not yet been declared.+deriveLift' :: Info -> Q [Dec]+deriveLift' = fmap (:[]) . deriveLiftOne++deriveLiftMany' :: [Info] -> Q [Dec]+deriveLiftMany' = mapM deriveLiftOne++deriveLiftOne :: Info -> Q Dec+deriveLiftOne i =+ case i of+ TyConI (DataD dcx n vsk cons _) ->+ liftInstance dcx n (map unTyVarBndr vsk) (map doCons cons)+ TyConI (NewtypeD dcx n vsk con _) ->+ liftInstance dcx n (map unTyVarBndr vsk) [doCons con]+ _ -> error (modName ++ ".deriveLift: unhandled: " ++ pprint i)+ where liftInstance dcx n vs cases =+ instanceD (ctxt dcx vs) (conT ''Lift `appT` typ n vs) [funD 'lift cases]+ typ n = foldl appT (conT n) . map varT+ ctxt dcx = fmap (dcx ++) . cxt . map liftPred+#if MIN_VERSION_template_haskell(2,4,0)+ unTyVarBndr (PlainTV v) = v+ unTyVarBndr (KindedTV v _) = v+ liftPred n = classP ''Lift [varT n]+#else /* MIN_VERSION_template_haskell(2,4,0) */+ unTyVarBndr v = v+ liftPred n = conT ''Lift `appT` varT n+#endif /* MIN_VERSION_template_haskell(2,4,0) */++doCons :: Con -> Q Clause+doCons (NormalC c sts) = do+ let ns = zipWith (\_ i -> "x" ++ show i) sts [0..]+ con = [| conE c |]+ args = [ [| lift $(varE (mkName n)) |] | n <- ns ]+ e = foldl (\e1 e2 -> [| appE $e1 $e2 |]) con args+ clause [conP c (map (varP . mkName) ns)] (normalB e) []+doCons (RecC c sts) = doCons $ NormalC c [(s, t) | (_, s, t) <- sts]+doCons (InfixC sty1 c sty2) = do+ let con = [| conE c |]+ left = [| lift $(varE (mkName "x0")) |]+ right = [| lift $(varE (mkName "x1")) |]+ e = [| infixApp $left $con $right |]+ clause [infixP (varP (mkName "x0")) c (varP (mkName "x1"))] (normalB e) []+doCons c = error (modName ++ ".doCons: Unhandled constructor: " ++ pprint c)++instance Lift Name where+ lift (Name occName nameFlavour) = [| Name occName nameFlavour |]++#if MIN_VERSION_template_haskell(2,4,0)+instance Lift OccName where+ lift n = [| mkOccName $(lift $ occString n) |]++instance Lift PkgName where+ lift n = [| mkPkgName $(lift $ pkgString n) |]++instance Lift ModName where+ lift n = [| mkModName $(lift $ modString n) |]++#else /* MIN_VERSION_template_haskell(2,4,0) */+instance Lift PackedString where+ lift ps = [| packString $(lift $ unpackPS ps) |]++#endif /* MIN_VERSION_template_haskell(2,4,0) */+instance Lift NameFlavour where+ lift NameS = [| NameS |]+ lift (NameQ modName) = [| NameQ modName |]+ lift (NameU i) = [| case $( lift (I# i) ) of+ I# i' -> NameU i' |]+ lift (NameL i) = [| case $( lift (I# i) ) of+ I# i' -> NameL i' |]+ lift (NameG nameSpace pkgName modName)+ = [| NameG nameSpace pkgName modName |]++instance Lift NameSpace where+ lift VarName = [| VarName |]+ lift DataName = [| DataName |]+ lift TcClsName = [| TcClsName |]++-- These instances should really go in the template-haskell package.++instance Lift () where+ lift _ = [| () |]++instance Lift Rational where+ lift x = return (LitE (RationalL x))
th-lift.cabal view
@@ -1,5 +1,5 @@ Name: th-lift-Version: 0.5+Version: 0.5.1 Cabal-Version: >= 1.6 License: OtherLicense License-File: COPYING@@ -15,9 +15,16 @@ Extra-source-files: BSD3, GPL-2, Changelog, t/Foo.hs, t/Test.hs Library- Build-Depends: base >= 4 && < 5, template-haskell >= 2.4 && < 2.5 Exposed-modules: Language.Haskell.TH.Lift- Extensions: TemplateHaskell, MagicHash, TypeSynonymInstances+ Extensions: CPP, TemplateHaskell, MagicHash, TypeSynonymInstances+ Hs-Source-Dirs: src+ Build-Depends: base >= 3 && < 5++ if impl(ghc < 6.12)+ Build-Depends: packedstring == 0.1.*,+ template-haskell >= 2.2 && < 2.4+ else+ Build-Depends: template-haskell == 2.4.* source-repository head type: git