diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,123 @@ +# Change Log + +All notable changes to this project will be documented in this file. + +## [0.8.7] - 2026.01.03 + +* Support building with `template-haskell-2.24.*`. +* Remove unnecessary `ghc-prim` dependency. + +## [0.8.6] - 2024.12.05 + +* Support building with `template-haskell-2.23.0`. + +## [0.8.5] - 2024.10.22 + +* Support building with `template-haskell-2.22.1`. +* Drop support for pre-8.0 versions of GHC. + +## [0.8.4] - 2023.08.01 + +* Add support for the `FldName` `NameSpace`, which was introduced in + `template-haskell-2.21.0.0` (GHC 9.8). + +## [0.8.3] - 2023.02.27 + +* Support building with `th-abstraction-0.5.*`. +* Require `th-abstraction-0.3.0.0` or later. + +## [0.8.2] - 2020-09-29 + +* Allow building with `template-haskell-2.17.0.0` (GHC 9.0). +* Make `deriveLift` work for unlifted newtypes. + +## [0.8.1] - 2019-12-06 + +* Support GHC 8.10/`template-haskell-2.16`. +* Derive implementations of `liftTyped` (in addition to `lift`) when using + `template-haskell-2.16` or later. +* Fix a bug in which derived `Lift` instances for data types containing + `Addr#` would fail to typecheck. + +## [0.8.0.1] - 2019-05-09 + +* Support GHC 8.8/`template-haskell-2.15`. + +## [0.8] - 2019-04-26 + +* Remove `Lift ()`, `Ratio`, `Identity` and `Const ()` instances. + These are now provided in [`th-lift-instances` package](http://hackage.haskell.org/package/th-lift-instances) +- Use `TemplateHaskellQuotes` where available + +## [0.7.11] - 2018-08-27 + +* Support for GHC 8.6. + +## [0.7.10] - 2018-02-01 + +* Add support for data families + +## [0.7.9] - 2018-02-01 + +* `Lift` instances for `Identity` and `Const`. + +## [0.7.8] - 2018-02-01 + +* GHC 8.4 compatibility. + +## [0.7.7] - 2015-04-19 + +* GHC 8.2 compatibility. + +## [0.7.6] - 2015-01-18 + +* GHC 8.1 compatibility. + +## [0.7.5] - 2015-11-19 + +* Added `makeLift`, for cases when it's necessary to write the + instance manually. (Thanks to Ryan Scott). +* Support empty datatypes and unboxed types. + +## [0.7] - 2014-12-07 + +* 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. + +## [0.6] - 2013-12-09 + +* Support GHC 7.8, thanks to Michael Snoyberg. +* Support existentially quantified type variables in datatype + declarations. +* Handle exotic kinds properly. + +## [0.5.2] - 2010-09-19 + +* Support older GHCs and Cabal, thanks to Ben Millwood. + +## [0.5] - 2010-08-05 + +* 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. + +## [0.4] - 2010-08-02 + +* Add support for newtypes and records syntax, thanks to a patch by + Ben Millwood. +* Add support for infix constructors. +* `deriveLift` returns a list of declarations. +* New `deriveLiftWith` function with custom reification, following + a feature request by Jonas Duregård. + +## [0.3] - 2010-03-24 + +* Port to Template Haskell 2.4. +* Maintainer is now Mathieu Boespflug. + +## [0.2] - 2006-09-06 + +Initial release by Ian Lynagh. diff --git a/COPYING b/COPYING --- a/COPYING +++ b/COPYING @@ -1,5 +1,6 @@ -Copyright (c) Ian Lynagh, 2006. +Copyright (c) Ian Lynagh, 2006; Mathieu Boespflug, 2010-2019; Ryan Scott +2019. This package can be used under either the GPL v2, as in ./GPL-2, or the 3-clause BSD, as in ./BSD3, license. diff --git a/Changelog b/Changelog deleted file mode 100644 --- a/Changelog +++ /dev/null @@ -1,28 +0,0 @@ -2010-09-19 Mathieu Boespflug - - * Support older GHCs and Cabal, thanks to Ben Millwood. - -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 - - * Add support for newtypes and records syntax, thanks to a patch - by Ben Millwood. - * Add support for infix constructors. - * deriveLift returns a list of declarations. - * New deriveLiftWith function with custom reification, following a - feature request by Jonas Duregård. - -2010-03-24 Mathieu Boespflug - - * Port to Template Haskell 2.4. - * Maintainer is now Mathieu Boespflug. - -2006-09-06 Ian Lynagh - - * Initial release. 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,124 +1,261 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Language.Haskell.TH.Lift (deriveLift, deriveLiftMany, deriveLift', deriveLiftMany', Lift(..)) where +{-# OPTIONS_GHC -Wno-orphans #-} -#if !(MIN_VERSION_template_haskell(2,4,0)) -import Data.PackedString (PackedString, packString, unpackPS) -#endif /* MIN_VERSION_template_haskell(2,4,0) */ +module Language.Haskell.TH.Lift + ( deriveLift + , deriveLiftMany + , deriveLift' + , deriveLiftMany' + , makeLift + , makeLift' + , Lift(..) + ) where -import GHC.Exts +import Control.Monad ((<=<), zipWithM) + +import Data.Char (ord) +import Data.Maybe (catMaybes) + +import GHC.Base (unpackCString#) +import GHC.Exts (Addr#, Char(..), Char#, Double(..), Double#, Float(..), + Float#, Int(..), Int#, Word(..), Word#) + import Language.Haskell.TH +import Language.Haskell.TH.Datatype as Datatype +import qualified Language.Haskell.TH.Lib as Lib (starK) +import Language.Haskell.TH.Lift.Internal import Language.Haskell.TH.Syntax -import Control.Monad ((<=<)) -modName :: String -modName = "Language.Haskell.TH.Lift" - --- | Derive Lift instances for the given datatype. +-- | Derive a 'Lift' instance for the given datatype. +-- +-- Note that 'deriveLift' uses a very simple technique for inferring the +-- instance context: it simply takes all visible type variables from the data +-- type declaration and adds a 'Lift' constraint for each one. For instance, +-- in the following example: +-- +-- @ +-- data Foo a b = ... +-- $(deriveLift ''Foo) +-- @ +-- +-- The following instance would be generated: +-- +-- @ +-- instance (Lift a, Lift b) => Lift (Foo a b) where ... +-- @ +-- +-- This will not work in all situations, however. For instance, there could +-- conceivably be type variables that are not of the appropriate kind. For +-- these other situations, the 'makeLift' function can provide a more +-- fine-grained approach that allows specifying the instance context precisely. deriveLift :: Name -> Q [Dec] -deriveLift = deriveLift' <=< reify +deriveLift name = do + roles <- reifyDatatypeRoles name + info <- reifyDatatype name + fmap (:[]) $ deriveLiftOne roles info --- | Derive Lift instances for many datatypes. +-- | Derive 'Lift' instances for many datatypes. deriveLiftMany :: [Name] -> Q [Dec] -deriveLiftMany = deriveLiftMany' <=< mapM reify +deriveLiftMany names = do + roles <- mapM reifyDatatypeRoles names + infos <- mapM reifyDatatype names + mapM (uncurry deriveLiftOne) $ zip roles infos --- | Obtain Info values through a custom reification function. This is useful +-- | 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 +deriveLift' :: [Role] -> Info -> Q [Dec] +deriveLift' roles = fmap (:[]) . deriveLiftOne roles <=< normalizeInfo -deriveLiftMany' :: [Info] -> Q [Dec] -deriveLiftMany' = mapM deriveLiftOne +deriveLiftMany' :: [([Role], Info)] -> Q [Dec] +deriveLiftMany' = mapM (\(rs, i) -> deriveLiftOne rs =<< normalizeInfo i) -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 (_, _) = [] -#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 (_, _) = [] -#else /* template-haskell < 2.4.0 */ - unTyVarBndr v = v - liftPred n = conT ''Lift `appT` varT n +-- | Generates a lambda expresson which behaves like 'lift' (without requiring +-- a 'Lift' instance). Example: +-- +-- @ +-- newtype Fix f = In { out :: f (Fix f) } +-- +-- instance Lift (f (Fix f)) => Lift (Fix f) where +-- lift = $(makeLift ''Fix) +-- @ +-- +-- This can be useful when 'deriveLift' is not clever enough to infer the +-- correct instance context, such as in the example above. +makeLift :: Name -> Q Exp +makeLift = makeLiftInternal <=< reifyDatatype + +-- | Like 'makeLift', but using a custom reification function. +makeLift' :: Info -> Q Exp +makeLift' = makeLiftInternal <=< normalizeInfo + +makeLiftInternal :: DatatypeInfo -> Q Exp +makeLiftInternal i = withInfo i $ \_ n _ cons -> makeLiftOne n cons + +deriveLiftOne :: [Role] -> DatatypeInfo -> Q Dec +deriveLiftOne roles i = withInfo i liftInstance + where + liftInstance dcx n tys cons = do + -- roles <- reifyDatatypeRoles n + -- Compute the set of phantom variables. + let phtys = catMaybes $ + zipWith (\t role -> if role == PhantomR then Just t else Nothing) + tys + roles + _x <- newName "x" + instanceD (ctxt dcx phtys tys) + (conT ''Lift `appT` typ n tys) + [ funD 'lift [clause [] (normalB (makeLiftOne n cons)) []] +#if MIN_VERSION_template_haskell(2,16,0) + , let rhs = varE 'unsafeSpliceCoerce `appE` + (varE 'lift `appE` varE _x) in + funD 'liftTyped [clause [varP _x] (normalB rhs) []] #endif + ] + typ n = foldl appT (conT n) . map unKind + -- Only consider *-kinded type variables for now. Furthermore, filter out + -- type variables that are obviously phantom. + 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 + mkLift ty = [conT ''Lift `appT` (return ty)] + unKind (SigT t k) + | k == Lib.starK = return t + unKind t = return t -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) [] -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 (ForallC _ _ c) = doCons c +makeLiftOne :: Name -> [ConstructorInfo] -> Q Exp +makeLiftOne n cons = do + e <- newName "e" + lam1E (varP e) $ caseE (varE e) $ consMatches n cons +consMatches :: Name -> [ConstructorInfo] -> [Q Match] +consMatches n [] = [match wildP (normalB e) []] + where + e = varE 'errorQuoteExp `appE` + (stringE $ "Can't lift value of empty datatype " ++ nameBase n) +consMatches _ cons = concatMap doCons cons + +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 |] + case (variant, ns, ts) of + (InfixConstructor, [x0, x1], [t0, t1]) -> + let e = varE 'infixApp `appE` liftVar x0 t0 `appE` con `appE` liftVar x1 t1 + in match (infixP (varP x0) c (varP x1)) (normalB e) [] + (_, _, _) -> + let e = foldl (\e1 e2 -> varE 'appE `appE` e1 `appE` e2) con $ zipWith liftVar ns ts + in match (conP c (map varP ns)) (normalB e) [] + +-- 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 + +liftVar :: Name -> Type -> Q Exp +liftVar varName (ConT tyName) + | tyName == ''Addr# = apps + [ varE 'litE, varE 'stringPrimL + , varE 'map `appE` + infixApp (varE 'fromIntegral) (varE '(.)) (varE 'ord) + , varE 'unpackCString# ] + | tyName == ''Char# = apps [ varE 'litE, varE 'charPrimL, conE 'C# ] + | tyName == ''Double# = apps [ varE 'litE, varE 'doublePrimL, varE 'toRational, conE 'D# ] + | tyName == ''Float# = apps [ varE 'litE, varE 'floatPrimL, varE 'toRational, conE 'F# ] + | tyName == ''Int# = apps [ varE 'litE, varE 'intPrimL, varE 'toInteger, conE 'I# ] + | tyName == ''Word# = apps [ varE 'litE, varE 'wordPrimL, varE 'toInteger, conE 'W# ] + + where + apps = foldr appE var + + var :: Q Exp + var = varE varName + +liftVar varName _ = varE 'lift `appE` varE varName + +withInfo :: DatatypeInfo + -> (Cxt -> Name -> [Type] -> [ConstructorInfo] -> Q a) + -> Q a +withInfo i f = case i of + DatatypeInfo { datatypeContext = dcx + , datatypeName = n + , datatypeInstTypes = vs + , datatypeCons = cons + , datatypeVariant = variant + } -> do + case variant of + Datatype.TypeData -> typeDataError n + _ -> return () + f dcx n vs cons + +-- | We cannot define implementations for @lift@ at the term level for +-- @type data@ declarations, which only exist at the type level. +typeDataError :: Name -> Q a +typeDataError dataName = fail + . showString "Cannot derive instance for ‘" + . showString (nameBase dataName) + . showString "‘, which is a ‘type data‘ declaration" + $ "" + +#if !MIN_VERSION_template_haskell(2,23,0) instance Lift Name where - lift (Name occName nameFlavour) = [| Name occName nameFlavour |] + lift (Name occName nameFlavour) = [| Name occName nameFlavour |] +# if MIN_VERSION_template_haskell(2,16,0) + liftTyped = unsafeSpliceCoerce . lift +# endif -#if MIN_VERSION_template_haskell(2,4,0) instance Lift OccName where - lift n = [| mkOccName $(lift $ occString n) |] + lift n = [| mkOccName |] `appE` lift (occString n) +# if MIN_VERSION_template_haskell(2,16,0) + liftTyped = unsafeSpliceCoerce . lift +# endif instance Lift PkgName where - lift n = [| mkPkgName $(lift $ pkgString n) |] + lift n = [| mkPkgName |] `appE` lift (pkgString n) +# if MIN_VERSION_template_haskell(2,16,0) + liftTyped = unsafeSpliceCoerce . lift +# endif 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) |] + lift n = [| mkModName |] `appE` lift (modString n) +# if MIN_VERSION_template_haskell(2,16,0) + liftTyped = unsafeSpliceCoerce . lift +# endif -#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 |] + lift (NameU i) = [| NameU i |] + lift (NameL i) = [| NameL i |] + lift (NameG nameSpace' pkgName modnam) + = [| NameG nameSpace' pkgName modnam |] +# if MIN_VERSION_template_haskell(2,16,0) + liftTyped = unsafeSpliceCoerce . lift +# endif 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)) + lift VarName = [| VarName |] + lift DataName = [| DataName |] + lift TcClsName = [| TcClsName |] +# if MIN_VERSION_template_haskell(2,21,0) + lift (FldName parent) = [| FldName parent |] +# endif +# if MIN_VERSION_template_haskell(2,16,0) + liftTyped = unsafeSpliceCoerce . lift +# endif +#endif diff --git a/src/Language/Haskell/TH/Lift/Internal.hs b/src/Language/Haskell/TH/Lift/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/Lift/Internal.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Helper functions used in code that "Language.Haskell.TH.Lift" generates. +-- +-- Note: this is an internal module, and as such, the API presented here is not +-- guaranteed to be stable, even between minor releases of this library. +module Language.Haskell.TH.Lift.Internal where + +#if MIN_VERSION_template_haskell(2,16,0) +import GHC.Exts (RuntimeRep, TYPE) +#endif + +import Language.Haskell.TH.Syntax + +-- | A type-restricted version of 'error' that ensures 'makeLift' always +-- returns a value of type @q 'Exp'@ (where @q@ is an instance of 'Quote'), +-- even when used on an empty datatype. +#if MIN_VERSION_template_haskell(2,17,0) +errorQuoteExp :: Quote q => String -> q Exp +#else +errorQuoteExp :: String -> Q Exp +#endif +errorQuoteExp = error + +-- | This is a cargo-culted version of @unsafeSpliceCoerce@ from the +-- @th-compat@ library, which has been copied here to avoid incurring a library +-- dependency. +#if MIN_VERSION_template_haskell(2,17,0) +unsafeSpliceCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m. Quote m => m Exp -> Code m a +unsafeSpliceCoerce = unsafeCodeCoerce +#elif MIN_VERSION_template_haskell(2,16,0) +unsafeSpliceCoerce :: forall (r :: RuntimeRep) (a :: TYPE r). Q Exp -> Q (TExp a) +unsafeSpliceCoerce = unsafeTExpCoerce +#else +unsafeSpliceCoerce :: forall a. Q Exp -> Q (TExp a) +unsafeSpliceCoerce = unsafeTExpCoerce +#endif diff --git a/t/Foo.hs b/t/Foo.hs --- a/t/Foo.hs +++ b/t/Foo.hs @@ -1,13 +1,100 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if __GLASGOW_HASKELL__ >= 810 +{-# LANGUAGE UnliftedNewtypes #-} +#endif module Foo where +import GHC.Exts (Char#, Double#, Float#, Int#, Word#) + import Language.Haskell.TH.Lift +#if MIN_VERSION_template_haskell(2,16,0) +import Language.Haskell.TH.Lift.Internal (unsafeSpliceCoerce) +#endif -data (Eq a) => Foo a = Foo a Char | Bar a +data (Eq a) => Foo a b = Foo a Char | Bar a deriving Show newtype Rec a = Rec { field :: a } deriving Show +data Empty a + +data Unboxed = Unboxed { + primChar :: Char#, + primDouble :: Double#, + primFloat :: Float#, + primInt :: Int#, + primWord :: Word# + } deriving Show + +newtype Fix f = In { out :: f (Fix f) } +deriving instance Show (f (Fix f)) => Show (Fix f) + +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 + $(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,16,0) + liftTyped = unsafeSpliceCoerce . lift +#endif + +$(deriveLift 'FamPrefix1) +instance (Eq a, Lift a) => Lift (Fam a Bool Bool) where + lift = $(makeLift 'FamInstBool) +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = unsafeSpliceCoerce . lift +#endif + +#if MIN_VERSION_template_haskell(2,16,0) +-- One can also implement Lift instances (on template-haskell-2.16+) by only +-- defining liftTyped and using the default definition of lift in terms of +-- liftTyped. +newtype Fix2 f = In2 { out2 :: f (Fix2 f) } +deriving instance Show (f (Fix2 f)) => Show (Fix2 f) + +data family Fam2 a b c +data instance Fam2 a Int Char + = Fam2Prefix1 a Char + | Fam2Prefix2 a + | Fam2Rec { fam2Field :: a } + | a :%%%: a + deriving Show +data instance Fam2 a Bool Bool = Fam2InstBool a Bool + deriving Show + +$(pure []) + +instance Lift (f (Fix2 f)) => Lift (Fix2 f) where + liftTyped = unsafeSpliceCoerce . $(makeLift ''Fix2) +instance Lift a => Lift (Fam2 a Int Char) where + liftTyped = unsafeSpliceCoerce . $(makeLift 'Fam2Prefix1) +instance (Eq a, Lift a) => Lift (Fam2 a Bool Bool) where + liftTyped = unsafeSpliceCoerce . $(makeLift 'Fam2InstBool) +#endif + +#if __GLASGOW_HASKELL__ >= 810 +-- Regression test for #43 +newtype T43 = MkT43 Int# +$(deriveLift ''T43) +#endif diff --git a/t/Test.hs b/t/Test.hs --- a/t/Test.hs +++ b/t/Test.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-} module Main (main) where @@ -8,3 +9,9 @@ main = do print $( lift (Foo "str1" 'c') ) print $( lift (Bar "str2") ) print $( lift (Rec {field = 'a'}) ) + print $( lift (Unboxed 'a'# 1.0## 1.0# 1# 1##) ) + print $( lift (In { out = Nothing }) ) + print $( lift (FamPrefix1 "str1" 'c') ) + print $( lift (FamPrefix2 "str2") ) + print $( lift (FamRec {famField = 'a'}) ) + print $( lift ('a' :%%: 'b') ) diff --git a/th-lift.cabal b/th-lift.cabal --- a/th-lift.cabal +++ b/th-lift.cabal @@ -1,32 +1,60 @@ Name: th-lift -Version: 0.6.1 -Cabal-Version: >= 1.6 -License: OtherLicense -License-File: COPYING -Copyright: Ian Lynagh, 2006 +Version: 0.8.7 +Cabal-Version: 1.12 +License: BSD3 +License-Files: COPYING, BSD3, GPL-2 +Copyright: © 2006 Ian Lynagh, © 2010-2019 Mathieu Boespflug, © 2019 Ryan Scott Author: Ian Lynagh -Maintainer: Mathieu Boespflug +Maintainer: Ryan Scott +Homepage: http://github.com/RyanGlScott/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 using @TemplateHaskell@. + The functionality in this package has largely been subsumed by the + @DeriveLift@ language extension, which is available in GHC 8.0 and later + versions. As such, this package is only useful as a way to backport bugfixes + to @DeriveLift@ in later GHC versions back to older GHCs. + . + The following libraries are related: + . + * The package + provides instances for @template-haskell@ syntax types. + . + * The + package provides @Lift@ instances for types in @base@, @text@, + @bytestring@, @vector@, etc. Some of these instances are only provided for + old versions of their respective libraries, as the same @Lift@ instances + are also present upstream on newer versions. Category: Language -Tested-With: GHC==6.12, GHC==7.0.1, GHC==7.2 +Tested-With: GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, GHC==9.2.8, GHC==9.4.8, GHC==9.6.6, GHC==9.8.4, GHC==9.10.3, GHC==9.12.2, GHC==9.14.1 build-type: Simple -Extra-source-files: BSD3, GPL-2, Changelog, t/Foo.hs, t/Test.hs +Extra-source-files: CHANGELOG.md +source-repository head + type: git + location: https://github.com/RyanGlScott/th-lift + Library - Exposed-modules: Language.Haskell.TH.Lift - Extensions: CPP, TemplateHaskell, MagicHash, TypeSynonymInstances, FlexibleInstances - Hs-Source-Dirs: src - Build-Depends: base >= 3 && < 5 + Default-Language: Haskell2010 + Exposed-modules: Language.Haskell.TH.Lift + Language.Haskell.TH.Lift.Internal + Other-Extensions: CPP, MagicHash, TypeSynonymInstances, FlexibleInstances, TemplateHaskellQuotes + Hs-Source-Dirs: src + Build-Depends: base >= 4.9 && < 5, + th-abstraction >= 0.5 && < 0.8, + template-haskell >= 2.11 && < 2.25 + ghc-options: -Wall - ghc-options: -Wall - if impl(ghc < 6.12) - Build-Depends: packedstring == 0.1.*, - template-haskell >= 2.2 && < 2.4 - else - Build-Depends: template-haskell >= 2.4 && < 2.10 +Test-Suite test + Default-Language: Haskell2010 + Type: exitcode-stdio-1.0 + Main-Is: Test.hs + Hs-Source-Dirs: t + other-modules: Foo + ghc-options: -Wall + if impl(ghc >= 9.0) + ghc-options: -fenable-th-splice-warnings + Build-Depends: base, + th-lift, + template-haskell -source-repository head - type: git - location: git://github.com/mboes/th-lift