diff --git a/Changelog b/Changelog --- a/Changelog +++ b/Changelog @@ -1,15 +1,29 @@ -2010-09-19 Mathieu Boespflug +2014-12-07 Mathieu Boespflug + * 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 + + * 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 + * Support older GHCs and Cabal, thanks to Ben Millwood. -2010-08-05 Mathieu Boespflug +2010-08-05 Mathieu Boespflug * 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 +2010-08-02 Mathieu Boespflug * 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 +2010-03-24 Mathieu Boespflug * Port to Template Haskell 2.4. * Maintainer is now Mathieu Boespflug. diff --git a/src/Language/Haskell/TH/Lift.hs b/src/Language/Haskell/TH/Lift.hs --- a/src/Language/Haskell/TH/Lift.hs +++ b/src/Language/Haskell/TH/Lift.hs @@ -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 diff --git a/t/Foo.hs b/t/Foo.hs --- a/t/Foo.hs +++ b/t/Foo.hs @@ -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 } diff --git a/th-lift.cabal b/th-lift.cabal --- a/th-lift.cabal +++ b/th-lift.cabal @@ -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 +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