th-lift 0.6.1 → 0.7
raw patch · 4 files changed
+140/−68 lines, 4 filesdep +th-liftdep ~template-haskell
Dependencies added: th-lift
Dependency ranges changed: template-haskell
Files
- Changelog +18/−4
- src/Language/Haskell/TH/Lift.hs +89/−52
- t/Foo.hs +6/−0
- th-lift.cabal +27/−12
Changelog view
@@ -1,15 +1,29 @@-2010-09-19 Mathieu Boespflug <mboes@tweag.net>+2014-12-07 Mathieu Boespflug <mboes@tweag.net> + * Support GHC 7.9 and hopefully 7.10, thanks to Richard Eisenberg.+ * On versions of GHC that support role inference, don't constrain+ phantom type variables.+ * Get rid of some orphan instances when using GHC >= 7.9.++2013-12-09 Mathieu Boespflug <mboes@tweag.net>++ * Support GHC 7.8, thanks to Michael Snoyberg.+ * Support existentially quantified type variables in datatype+ declarations.+ * Handle exotic kinds properly.++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>+2010-08-05 Mathieu Boespflug <mboes@tweag.net> * Support for contexts in datatypes, thanks to Ben Millwood. * deriveLiftWith becomes deriveLift' and takes an Info structure rather than a custom reification function. * Add deriveLiftMany to derive many Lift instances in one go. -2010-08-02 Mathieu Boespflug <mboes@tweag.net>+2010-08-02 Mathieu Boespflug <mboes@tweag.net> * Add support for newtypes and records syntax, thanks to a patch by Ben Millwood.@@ -18,7 +32,7 @@ * New deriveLiftWith function with custom reification, following a feature request by Jonas Duregård. -2010-03-24 Mathieu Boespflug <mboes@tweag.net>+2010-03-24 Mathieu Boespflug <mboes@tweag.net> * Port to Template Haskell 2.4. * Maintainer is now Mathieu Boespflug.
src/Language/Haskell/TH/Lift.hs view
@@ -1,20 +1,32 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module Language.Haskell.TH.Lift (deriveLift, deriveLiftMany, deriveLift', deriveLiftMany', Lift(..)) where +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+#if !(MIN_VERSION_template_haskell(2,10,0))+import GHC.Exts (Int(..))+#endif /* !(MIN_VERSION_template_haskell(2,10,0)) */ import Language.Haskell.TH import Language.Haskell.TH.Syntax import Control.Monad ((<=<))+#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"@@ -37,53 +49,71 @@ 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 (map fst vs))- [funD 'lift cases]- typ n = foldl appT (conT n) . map varT- ctxt dcx = fmap (dcx ++) . cxt . concatMap liftPred- -- Only consider *-kinded type variables, because Lift instances cannot- -- meaningfully be given to types of other kinds.-#if MIN_VERSION_template_haskell(2,8,0)- unTyVarBndr (PlainTV v) = (v, StarT)- unTyVarBndr (KindedTV v k) = (v, k)- liftPred (v, StarT) = [classP ''Lift [varT v]]- liftPred (_, _) = []+ case i of+ TyConI (DataD dcx n vsk cons _) ->+ liftInstance dcx n (map unTyVarBndr vsk) cons+ TyConI (NewtypeD dcx n vsk con _) ->+ liftInstance dcx n (map unTyVarBndr vsk) [con]+ _ -> error (modName ++ ".deriveLift: unhandled: " ++ pprint i)+ where+ liftInstance dcx n vs cons = do+#if MIN_VERSION_template_haskell(2,9,0)+ roles <- qReifyRoles n+ -- Compute the set of phantom variables.+ let phvars = catMaybes $+ zipWith (\v role -> if role == PhantomR then Just v else Nothing)+ vs+ roles+#else /* MIN_VERSION_template_haskell(2,9,0) */+ let phvars = []+#endif+ instanceD (ctxt dcx phvars vs)+ (conT ''Lift `appT` typ n (map fst vs))+ [funD 'lift (map doCons cons)]+ typ n = foldl appT (conT n) . map varT+ -- 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)+#if MIN_VERSION_template_haskell(2,10,0)+ unTyVarBndr (PlainTV v) = (v, StarT)+ unTyVarBndr (KindedTV v k) = (v, k)+ liftPred (v, StarT) = [conT ''Lift `appT` varT v]+ liftPred (_, _) = []+#elif MIN_VERSION_template_haskell(2,8,0)+ unTyVarBndr (PlainTV v) = (v, StarT)+ unTyVarBndr (KindedTV v k) = (v, k)+ liftPred (v, StarT) = [classP ''Lift [varT v]]+ liftPred (_, _) = [] #elif MIN_VERSION_template_haskell(2,4,0)- unTyVarBndr (PlainTV v) = (v, StarK)- unTyVarBndr (KindedTV v k) = (v, k)- liftPred (v, StarK) = [classP ''Lift [varT v]]- liftPred (_, _) = []+ unTyVarBndr (PlainTV v) = (v, StarK)+ unTyVarBndr (KindedTV v k) = (v, k)+ liftPred (v, StarK) = [classP ''Lift [varT v]]+ liftPred (_, _) = [] #else /* template-haskell < 2.4.0 */- unTyVarBndr v = v- liftPred n = conT ''Lift `appT` varT n+ unTyVarBndr v = v+ liftPred n = conT ''Lift `appT` varT n #endif doCons :: Con -> Q Clause doCons (NormalC c sts) = do- let ns = zipWith (\_ i -> "x" ++ show (i :: Int)) 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) []+ let ns = zipWith (\_ i -> "x" ++ show (i :: Int)) 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 (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 (ForallC _ _ c) = doCons c instance Lift Name where- lift (Name occName nameFlavour) = [| Name occName nameFlavour |]+ lift (Name occName nameFlavour) = [| Name occName nameFlavour |] #if MIN_VERSION_template_haskell(2,4,0) instance Lift OccName where@@ -101,20 +131,26 @@ #endif /* MIN_VERSION_template_haskell(2,4,0) */ instance Lift NameFlavour where- lift NameS = [| NameS |]- lift (NameQ modnam) = [| NameQ modnam |]- 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 modnam)- = [| NameG nameSpace pkgName modnam |]+ lift NameS = [| NameS |]+ lift (NameQ modnam) = [| NameQ modnam |]+#if MIN_VERSION_template_haskell(2,10,0)+ lift (NameU i) = [| NameU i |]+ lift (NameL i) = [| NameL i |]+#else /* MIN_VERSION_template_haskell(2,10,0) */+ lift (NameU i) = [| case $( lift (I# i) ) of+ I# i' -> NameU i' |]+ lift (NameL i) = [| case $( lift (I# i) ) of+ I# i' -> NameL i' |]+#endif /* MIN_VERSION_template_haskell(2,10,0) */+ lift (NameG nameSpace pkgName modnam)+ = [| NameG nameSpace pkgName modnam |] instance Lift NameSpace where- lift VarName = [| VarName |]- lift DataName = [| DataName |]- lift TcClsName = [| TcClsName |]+ lift VarName = [| VarName |]+ lift DataName = [| DataName |]+ lift TcClsName = [| TcClsName |] +#if !(MIN_VERSION_template_haskell(2,10,0)) -- These instances should really go in the template-haskell package. instance Lift () where@@ -122,3 +158,4 @@ instance Lift Rational where lift x = return (LitE (RationalL x))+#endif
t/Foo.hs view
@@ -1,9 +1,15 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Foo where import Language.Haskell.TH.Lift +-- Phantom type parameters can't be dealt with poperly on GHC < 7.8.+#if MIN_VERSION_template_haskell(2,9,0)+data (Eq a) => Foo a b = Foo a Char | Bar a+#else data (Eq a) => Foo a = Foo a Char | Bar a+#endif deriving Show newtype Rec a = Rec { field :: a }
th-lift.cabal view
@@ -1,19 +1,24 @@ Name: th-lift-Version: 0.6.1-Cabal-Version: >= 1.6-License: OtherLicense-License-File: COPYING-Copyright: Ian Lynagh, 2006+Version: 0.7+Cabal-Version: >= 1.8+License: BSD3+License-Files: COPYING, BSD3, GPL-2+Copyright: © 2006 Ian Lynagh, © 2010-2014 Mathieu Boespflugg Author: Ian Lynagh Maintainer: Mathieu Boespflug <mboes@tweag.net>+Homepage: http://github.com/mboes/th-lift Synopsis: Derive Template Haskell's Lift class for datatypes. Description:- Derive Template Haskell's Lift class for datatypes.+ Derive Template Haskell's Lift class for datatypes. Category: Language-Tested-With: GHC==6.12, GHC==7.0.1, GHC==7.2+Tested-With: GHC==7.4, GHC==7.6, GHC==7.8 build-type: Simple-Extra-source-files: BSD3, GPL-2, Changelog, t/Foo.hs, t/Test.hs+Extra-source-files: Changelog +source-repository head+ type: git+ location: git://github.com/mboes/th-lift+ Library Exposed-modules: Language.Haskell.TH.Lift Extensions: CPP, TemplateHaskell, MagicHash, TypeSynonymInstances, FlexibleInstances@@ -25,8 +30,18 @@ Build-Depends: packedstring == 0.1.*, template-haskell >= 2.2 && < 2.4 else- Build-Depends: template-haskell >= 2.4 && < 2.10+ Build-Depends: template-haskell >= 2.4 && < 2.11 -source-repository head- type: git- location: git://github.com/mboes/th-lift+Test-Suite test+ Type: exitcode-stdio-1.0+ Main-Is: Test.hs+ Hs-Source-Dirs: t+ other-modules: Foo+ ghc-options: -Wall+ Build-Depends: base >= 3 && < 5,+ th-lift+ if impl(ghc < 6.12)+ Build-Depends: packedstring == 0.1.*,+ template-haskell >= 2.2 && < 2.4+ else+ Build-Depends: template-haskell >= 2.4 && < 2.11