diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,22 @@ +## 0.2 [2020.09.30] +* `genericLiftTyped` and `genericLiftTypedWithPkg` now return a `Code` instead + of a `TExp` to reflect the type of `liftTyped` changing in + `template-haskell-2.17.0.0`. New functions `genericLiftTypedTExp` and + `genericLiftTypedTExpWithPkg` have been added for those who wish to return + `TExp` specifically. In addition, the functions `genericLiftTypedCompat` and + `genericLiftTypedCompatWithPkg` have been introduced which return a `Code` + on `template-haskell-2.17.0.0` or later, but a `TExp` on older versions of + `template-haskell`. These functions are most useful for implementing + `liftTyped` in a `Lift` instance in a backwards-compatible way. + + The `th-compat` library is used to backport the `Code` data type back to + versions of `template-haskell` that do not define it. +* The functions in `Language.Haskell.TH.Lift.Generics` are now generalized to + work over any `Quote` instance instead of hardcoding `Q`. Again, the + `th-compat` library is used to backport `Quote` to old versions of + `template-haskell` that do not define it. +* Make `genericLift` work properly for empty data types. + ### 0.1.3 [2019.11.26] * Add `genericLiftTyped` and `genericLiftTypedWithPkg`. diff --git a/lift-generics.cabal b/lift-generics.cabal --- a/lift-generics.cabal +++ b/lift-generics.cabal @@ -1,5 +1,5 @@ name: lift-generics -version: 0.1.3 +version: 0.2 synopsis: GHC.Generics-based Language.Haskell.TH.Syntax.lift implementation description: This package provides a "GHC.Generics"-based @genericLiftWithPkg@ function (intended for GHC 7.10 and earlier), as well as a @@ -40,7 +40,7 @@ , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 - , GHC == 8.8.1 + , GHC == 8.8.3 , GHC == 8.10.1 extra-source-files: CHANGELOG.md, README.md cabal-version: >=1.10 @@ -55,6 +55,7 @@ , generic-deriving >= 1.9 && < 2 , ghc-prim , template-haskell >= 2.4 && < 2.17 + , th-compat >= 0.1 && < 0.2 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -70,7 +71,9 @@ , generic-deriving >= 1.9 && < 2 , hspec >= 2 && < 3 , lift-generics + , mtl >= 2.1 && < 2.3 , template-haskell >= 2.4 && < 2.17 + , th-compat >= 0.1 && < 0.2 build-tool-depends: hspec-discover:hspec-discover hs-source-dirs: tests default-language: Haskell2010 diff --git a/src/Language/Haskell/TH/Lift/Generics.hs b/src/Language/Haskell/TH/Lift/Generics.hs --- a/src/Language/Haskell/TH/Lift/Generics.hs +++ b/src/Language/Haskell/TH/Lift/Generics.hs @@ -22,10 +22,14 @@ genericLiftWithPkg #if MIN_VERSION_template_haskell(2,9,0) , genericLiftTypedWithPkg + , genericLiftTypedTExpWithPkg + , genericLiftTypedCompatWithPkg #endif #if __GLASGOW_HASKELL__ >= 711 , genericLift , genericLiftTyped + , genericLiftTypedTExp + , genericLiftTypedCompat #endif , GLift(..) , GLiftDatatype(..) @@ -34,19 +38,26 @@ , Lift(..) ) where -#if MIN_VERSION_template_haskell(2,8,0) -import Data.Char (ord) -import Data.Word (Word8) -#endif +import Data.Foldable (foldl') import Generics.Deriving import GHC.Base (unpackCString#) -import GHC.Exts +import GHC.Exts (Double(..), Float(..), Int(..), Word(..)) import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Syntax.Compat +#if MIN_VERSION_template_haskell(2,8,0) +import Data.Char (ord) +import Data.Word (Word8) +#endif + +#if MIN_VERSION_template_haskell(2,11,0) +import GHC.Exts (Char(..)) +#endif + #undef CURRENT_PACKAGE_KEY -- | "GHC.Generics"-based 'lift' implementation. -- @@ -104,13 +115,31 @@ -- foo :: Foo -- foo = $(lift (Foo 1 'a' "baz")) -- @ -genericLiftWithPkg :: (Generic a, GLift (Rep a)) => String -> a -> Q Exp +genericLiftWithPkg :: (Quote m, Generic a, GLift (Rep a)) => String -> a -> m Exp genericLiftWithPkg pkg = glift pkg . from #if MIN_VERSION_template_haskell(2,9,0) +-- | Like 'genericLiftWithPkg', but returns a 'Code' instead of an 'Exp'. +genericLiftTypedWithPkg :: (Quote m, Generic a, GLift (Rep a)) => String -> a -> Code m a +genericLiftTypedWithPkg pkg = unsafeCodeCoerce . genericLiftWithPkg pkg + -- | Like 'genericLiftWithPkg', but returns a 'TExp' instead of an 'Exp'. -genericLiftTypedWithPkg :: (Generic a, GLift (Rep a)) => String -> a -> Q (TExp a) -genericLiftTypedWithPkg pkg = unsafeTExpCoerce . genericLiftWithPkg pkg +genericLiftTypedTExpWithPkg :: (Quote m, Generic a, GLift (Rep a)) => String -> a -> m (TExp a) +genericLiftTypedTExpWithPkg pkg = unsafeTExpCoerceQuote . genericLiftWithPkg pkg + +-- | Lift 'genericLiftWithPkg', but returns: +-- +-- * A 'Code' (if using @template-haskell-2.17.0.0@ or later), or +-- * A 'TExp' (if using an older version of @template-haskell@) +-- +-- This function is ideal for implementing the 'liftTyped' method of 'Lift' +-- directly, as its type changed in @template-haskell-2.17.0.0@. +genericLiftTypedCompatWithPkg :: (Quote m, Generic a, GLift (Rep a)) => String -> a -> Splice m a +# if MIN_VERSION_template_haskell(2,17,0) +genericLiftTypedCompatWithPkg = genericLiftTypedWithPkg +# else +genericLiftTypedCompatWithPkg = genericLiftTypedTExpWithPkg +# endif #endif #if __GLASGOW_HASKELL__ >= 711 @@ -145,21 +174,40 @@ -- foo :: Foo -- foo = $(lift (Foo 1 'a' "baz")) -- @ -genericLift :: (Generic a, GLift (Rep a)) => a -> Q Exp +genericLift :: (Quote m, Generic a, GLift (Rep a)) => a -> m Exp genericLift = glift "" . from +-- | Like 'genericLift', but returns a 'Code' instead of an 'Exp'. +genericLiftTyped :: (Quote m, Generic a, GLift (Rep a)) => a -> Code m a +genericLiftTyped = unsafeCodeCoerce . genericLift + -- | Like 'genericLift', but returns a 'TExp' instead of an 'Exp'. -genericLiftTyped :: (Generic a, GLift (Rep a)) => a -> Q (TExp a) -genericLiftTyped = unsafeTExpCoerce . genericLift +genericLiftTypedTExp :: (Quote m, Generic a, GLift (Rep a)) => a -> m (TExp a) +genericLiftTypedTExp = unsafeTExpCoerceQuote . genericLift + +-- | Lift 'genericLift', but returns: +-- +-- * A 'Code' (if using @template-haskell-2.17.0.0@ or later), or +-- * A 'TExp' (if using an older version of @template-haskell@) +-- +-- This function is ideal for implementing the 'liftTyped' method of 'Lift' +-- directly, as its type changed in @template-haskell-2.17.0.0@. +genericLiftTypedCompat :: (Quote m, Generic a, GLift (Rep a)) => a -> Splice m a +# if MIN_VERSION_template_haskell(2,17,0) +genericLiftTypedCompat = genericLiftTyped +# else +genericLiftTypedCompat = genericLiftTypedTExp +# endif #endif -- | Class of generic representation types which can be converted to Template -- Haskell expressions. You shouldn't need to use this typeclass directly; it is -- only exported for educational purposes. class GLift f where - glift :: String -- ^ The package name (not used on GHC 8.0 and later) + glift :: Quote m + => String -- ^ The package name (not used on GHC 8.0 and later) -> f a -- ^ The generic value - -> Q Exp -- ^ The resulting Template Haskell expression + -> m Exp -- ^ The resulting Template Haskell expression instance (Datatype d, GLiftDatatype f) => GLift (D1 d f) where glift _pkg d@(M1 x) = gliftWith pName mName x @@ -176,14 +224,25 @@ -- Haskell expressions, given a package and module name. You shouldn't need to use -- this typeclass directly; it is only exported for educational purposes. class GLiftDatatype f where - gliftWith :: String -- ^ The package name + gliftWith :: Quote m + => String -- ^ The package name -> String -- ^ The module name -> f a -- ^ The generic value - -> Q Exp -- ^ The resulting Template Haskell expression + -> m Exp -- ^ The resulting Template Haskell expression +instance GLiftDatatype V1 where + gliftWith _ _ x = + return $ case x of +#if __GLASGOW_HASKELL__ >= 708 + {} +#else + !_ -> undefined +#endif + instance (Constructor c, GLiftArgs f) => GLiftDatatype (C1 c f) where - gliftWith pName mName c@(M1 x) = - appsE (conE (mkNameG_d pName mName cName) : gliftArgs x) + gliftWith pName mName c@(M1 x) = do + args <- sequence (gliftArgs x) + return $ foldl' AppE (ConE (mkNameG_d pName mName cName)) args where cName :: String cName = conName c @@ -197,22 +256,13 @@ -- shouldn't need to use this typeclass directly; it is only exported for educational -- purposes. class GLiftArgs f where - gliftArgs :: f a -> [Q Exp] - -instance GLiftArgs V1 where - gliftArgs x = - (:[]) $ return $ case x of -#if __GLASGOW_HASKELL__ >= 708 - {} -#else - !_ -> undefined -#endif + gliftArgs :: Quote m => f a -> [m Exp] instance GLiftArgs U1 where gliftArgs U1 = [] instance Lift c => GLiftArgs (K1 i c) where - gliftArgs (K1 x) = [lift x] + gliftArgs (K1 x) = [liftQuote x] instance GLiftArgs f => GLiftArgs (S1 s f) where gliftArgs (M1 x) = gliftArgs x @@ -221,7 +271,7 @@ gliftArgs (f :*: g) = gliftArgs f ++ gliftArgs g instance GLiftArgs UAddr where - gliftArgs (UAddr a) = [litE (stringPrimL (word8ify (unpackCString# a)))] + gliftArgs (UAddr a) = [return (LitE (StringPrimL (word8ify (unpackCString# a))))] where #if MIN_VERSION_template_haskell(2,8,0) word8ify :: String -> [Word8] @@ -233,17 +283,17 @@ #if MIN_VERSION_template_haskell(2,11,0) instance GLiftArgs UChar where - gliftArgs (UChar c) = [litE (charPrimL (C# c))] + gliftArgs (UChar c) = [return (LitE (CharPrimL (C# c)))] #endif instance GLiftArgs UDouble where - gliftArgs (UDouble d) = [litE (doublePrimL (toRational (D# d)))] + gliftArgs (UDouble d) = [return (LitE (DoublePrimL (toRational (D# d))))] instance GLiftArgs UFloat where - gliftArgs (UFloat f) = [litE (floatPrimL (toRational (F# f)))] + gliftArgs (UFloat f) = [return (LitE (floatPrimL (toRational (F# f))))] instance GLiftArgs UInt where - gliftArgs (UInt i) = [litE (intPrimL (toInteger (I# i)))] + gliftArgs (UInt i) = [return (LitE (IntPrimL (toInteger (I# i))))] instance GLiftArgs UWord where - gliftArgs (UWord w) = [litE (wordPrimL (toInteger (W# w)))] + gliftArgs (UWord w) = [return (LitE (WordPrimL (toInteger (W# w))))] diff --git a/tests/LiftGenericsSpec.hs b/tests/LiftGenericsSpec.hs --- a/tests/LiftGenericsSpec.hs +++ b/tests/LiftGenericsSpec.hs @@ -11,9 +11,10 @@ -} module LiftGenericsSpec (main, spec) where -import Language.Haskell.TH.Syntax (Lift(..)) -import Test.Hspec (Spec, hspec, describe, it, parallel, shouldBe) -import Types (Unit(..), p, s, u) +import Language.Haskell.TH.Syntax hiding (newName) +import Language.Haskell.TH.Syntax.Compat +import Test.Hspec +import Types main :: IO () main = hspec spec @@ -22,25 +23,34 @@ description = "should equal its lifted counterpart" spec :: Spec --- spec = return () spec = parallel $ do - describe "Unit" $ - it description $ - Unit `shouldBe` $(lift Unit) - describe "Product" $ - it description $ - p `shouldBe` $(lift p) - describe "Sum" $ - it description $ - s `shouldBe` $(lift s) - describe "Unboxed" $ - it description $ - u `shouldBe` $(lift u) + describe "genericLift" $ do + describe "Unit" $ + it description $ do + Unit `shouldBe` $(lift Unit) + ConE 'Unit `shouldBe` runPureQ (liftQuote Unit) + describe "Product" $ + it description $ + p `shouldBe` $(lift p) + describe "Sum" $ + it description $ + s `shouldBe` $(lift s) + describe "Unboxed" $ + it description $ + u `shouldBe` $(lift u) #if MIN_VERSION_template_haskell(2,16,0) - describe "genericLiftTyped" $ - it "should do what you expect" $ do - Unit `shouldBe` $$(liftTyped Unit) - p `shouldBe` $$(liftTyped p) - s `shouldBe` $$(liftTyped s) - u `shouldBe` $$(liftTyped u) + describe "genericLiftTyped" $ do + describe "Unit" $ + it description $ do + Unit `shouldBe` $$(liftTyped Unit) + ConE 'Unit `shouldBe` runPureQ (unTypeCode (liftTypedQuote Unit)) + describe "Product" $ + it description $ + p `shouldBe` $$(liftTyped p) + describe "Sum" $ + it description $ + s `shouldBe` $$(liftTyped s) + describe "Unboxed" $ + it description $ + u `shouldBe` $$(liftTyped u) #endif diff --git a/tests/Types.hs b/tests/Types.hs --- a/tests/Types.hs +++ b/tests/Types.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} #endif {-| @@ -15,22 +17,38 @@ Data types for testing `lift-generics`' capabilities. -} -module Types (Unit(..), Product(..), Sum(..), p, s, u) where +module Types ( + PureQ, runPureQ + , Unit(..), Product(..), Sum(..) + , p, s, u + ) where +import Control.Monad.State + import Generics.Deriving.TH (deriveAll) import GHC.Exts import Language.Haskell.TH.Lift.Generics ( genericLiftWithPkg #if MIN_VERSION_template_haskell(2,16,0) - , genericLiftTyped + , genericLiftTypedCompat #endif ) -import Language.Haskell.TH.Syntax (Lift(..)) +import Language.Haskell.TH.Syntax hiding (newName) +import Language.Haskell.TH.Syntax.Compat import Prelude () import Prelude.Compat +newtype PureQ a = MkPureQ (State Uniq a) + deriving (Functor, Applicative, Monad, MonadState Uniq) + +runPureQ :: PureQ a -> a +runPureQ m = case m of MkPureQ m' -> evalState m' 0 + +instance Quote PureQ where + newName s = state $ \i -> (mkNameU s i, i + 1) + data Unit = Unit deriving (Eq, Ord, Show) $(deriveAll ''Unit) @@ -77,23 +95,23 @@ instance Lift Unit where lift = genericLiftWithPkg pkgKey #if MIN_VERSION_template_haskell(2,16,0) - liftTyped = genericLiftTyped + liftTyped = genericLiftTypedCompat #endif instance (Lift a, Lift b, Lift c, Lift d) => Lift (Product a b c d) where lift = genericLiftWithPkg pkgKey #if MIN_VERSION_template_haskell(2,16,0) - liftTyped = genericLiftTyped + liftTyped = genericLiftTypedCompat #endif instance (Lift a, Lift b) => Lift (Sum a b) where lift = genericLiftWithPkg pkgKey #if MIN_VERSION_template_haskell(2,16,0) - liftTyped = genericLiftTyped + liftTyped = genericLiftTypedCompat #endif instance Lift a => Lift (Unboxed a) where lift = genericLiftWithPkg pkgKey #if MIN_VERSION_template_haskell(2,16,0) - liftTyped = genericLiftTyped + liftTyped = genericLiftTypedCompat #endif