lift-generics 0.1.3 → 0.2

raw patch · 5 files changed

+170/−70 lines, 5 filesdep +mtldep +th-compatdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, th-compat

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +19/−0
• lift-generics.cabal +5/−2
• src/Language/Haskell/TH/Lift/Generics.hs +84/−34
• tests/LiftGenericsSpec.hs +32/−22
• tests/Types.hs +30/−12

@@ -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`. 

@@ -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

@@ -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))))]

@@ -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

@@ -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