lift-generics 0.2 → 0.2.1

raw patch · 7 files changed

+645/−81 lines, 7 filesdep +containersdep +taggeddep +th-lift-instancesdep ~mtldep ~template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: containers, tagged, th-lift-instances

Dependency ranges changed: mtl, template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−0
• README.md +1/−1
• lift-generics.cabal +29/−17
• src/Language/Haskell/TH/Lift/Generics.hs +285/−53
• src/Language/Haskell/TH/Lift/Generics/Internal/OuterTypeable.hs +71/−0
• tests/LiftGenericsSpec.hs +65/−2
• tests/Types.hs +178/−8

@@ -1,3 +1,19 @@+## 0.2.1 [2021.09.16]+* The lifting functions have been modified to reduce splice+  time for constructors with many fields from quadratic to+  linear. This probably only has a modest impact on total+  compilation time.++* `genericLift`, `genericLiftTyped`, `genericLiftTypedExp`, and+  `genericLiftTypedCompat` functions now work for GHC 7.4 and above+  for types that derive `Typeable`.++* `genericLiftWithPkgFallback`, `genericLiftTypedWithPkgFallback`,+  `genericLiftTypedExpWithPkgFallback`, and+  `genericLiftTypedCompatWithPkgFallback` functions have been added that take+  advantage of `Typeable` instances for GHC 7.4 and above but also take a+  user-provided package name for earlier versions.+ ## 0.2 [2020.09.30] * `genericLiftTyped` and `genericLiftTypedWithPkg` now return a `Code` instead   of a `TExp` to reflect the type of `liftTyped` changing in

@@ -4,7 +4,7 @@ [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/lift-generics.svg)](http://packdeps.haskellers.com/reverse/lift-generics) [![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] [![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3]-[![Build](https://img.shields.io/travis/RyanGlScott/lift-generics.svg)](https://travis-ci.org/RyanGlScott/lift-generics)+[![Build Status](https://github.com/RyanGlScott/lift-generics/workflows/Haskell-CI/badge.svg)](https://github.com/RyanGlScott/lift-generics/actions?query=workflow%3AHaskell-CI)  [Hackage: lift-generics]:   http://hackage.haskell.org/package/lift-generics

@@ -1,24 +1,29 @@ name:                lift-generics-version:             0.2+version:             0.2.1 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-                     @genericLift@ function (only available on GHC 8.0 and later),-                     both of which can be used for providing a+description:         This package provides a "GHC.Generics"-based @genericLift@+                     function (only available on GHC 7.4 and later), as well as+                     a @genericLiftWithPkgFallback@ function (for code that+                     must support GHC 7.2 and earlier) and a+                     @genericLiftWithPkg@ function (for use when neither of the+                     above will work), all of which can be used for providing a                      @Language.Haskell.TH.Syntax.lift@ implementation. See the-                     documentation in the "Language.Haskell.TH.Lift.Generics" module-                     to get started.+                     documentation in the "Language.Haskell.TH.Lift.Generics"+                     module to get started.                      .                      Credit goes to Matthew Pickering for                      <https://ghc.haskell.org/trac/ghc/ticket/1830#comment:12 suggesting this idea>.                      .-                     Note that due to API limitations, "GHC.Generics" wasn't powerful-                     enough to come up with the entirety of a `lift` implementation prior-                     to GHC 8.0. For this reason, @genericLiftWithPkg@ requires you to-                     produce the package name yourself, which proves to be no small feat-                     (see the documentation for more info).+                     Note that due to API limitations, "GHC.Generics" wasn't+                     powerful enough to come up with the entirety of a `lift`+                     implementation prior to GHC 8.0. For GHC 7.4 and later, we+                     can pluck this information out of `Typeable`. For earlier+                     versions, and where `Typeable` isn't available,+                     @genericLiftWithPkg@ requires you to produce the package+                     name yourself, which proves to be no small feat (see the+                     documentation for more info).                      .-                     Luckily, you don't have to jump through as many hoops on GHC 8.0 and+                     Luckily, you don't have to jump through as many hoops on GHC 7.4 and                      later: simply use the @genericLift@ function, and life is good. homepage:            https://github.com/RyanGlScott/lift-generics bug-reports:         https://github.com/RyanGlScott/lift-generics/issues@@ -40,8 +45,9 @@                    , GHC == 8.2.2                    , GHC == 8.4.4                    , GHC == 8.6.5-                   , GHC == 8.8.3-                   , GHC == 8.10.1+                   , GHC == 8.8.4+                   , GHC == 8.10.4+                   , GHC == 9.0.1 extra-source-files:  CHANGELOG.md, README.md cabal-version:       >=1.10 @@ -51,11 +57,15 @@  library   exposed-modules:     Language.Haskell.TH.Lift.Generics+  if (impl(ghc >= 7.4) && impl(ghc < 8.0))+    other-modules:       Language.Haskell.TH.Lift.Generics.Internal.OuterTypeable   build-depends:       base             >= 4.3 && < 5                      , generic-deriving >= 1.9 && < 2                      , ghc-prim-                     , template-haskell >= 2.4 && < 2.17+                     , template-haskell >= 2.4 && < 2.18                      , th-compat        >= 0.1 && < 0.2+  if (impl(ghc >= 7.4) && impl(ghc < 7.8))+    build-depends:     tagged >= 0.5 && < 0.9   hs-source-dirs:      src   default-language:    Haskell2010   ghc-options:         -Wall@@ -68,11 +78,13 @@                        Paths_lift_generics   build-depends:       base             >= 4.3   && < 5                      , base-compat      >= 0.8.2 && < 1+                     , containers       >= 0.1 && < 0.7+                     , th-lift-instances >= 0.1 && < 0.2                      , generic-deriving >= 1.9   && < 2                      , hspec            >= 2     && < 3                      , lift-generics                      , mtl              >= 2.1   && < 2.3-                     , template-haskell >= 2.4   && < 2.17+                     , template-haskell >= 2.4   && < 2.18                      , th-compat        >= 0.1   && < 0.2   build-tool-depends:  hspec-discover:hspec-discover   hs-source-dirs:      tests

@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE MagicHash            #-}+{-# LANGUAGE ScopedTypeVariables  #-} {-# LANGUAGE TypeOperators        #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -16,21 +17,103 @@ License:     BSD-style (see the file LICENSE) Maintainer:  Ryan Scott -"GHC.Generics"-based approach to implementing `lift`.+"GHC.Generics"-based approach to implementing `lift`. Different sets of+functions are available for use with different GHC and @template-haskell@+versions.++=== General recommendations++* If you only need to support GHC 8.0 (@base@ 4.9.0) and later, then you may+either use the \"friendly\" functions here or skip this package entirely and use+the built-in `DeriveLift` mechanism, which has the advantage of working for+GADTs and existential types.++* If you only need to support GHC 7.4 (@base@ 4.5) and later, and you have+'Typeable' instances for the relevant type constructors (or can derive them),+then you should use the \"friendly\" functions here.++* If you must support GHC versions before 7.4 (@base@ 4.5), or types in other+packages without 'Typeable' instances, then you should seriously consider using+the+<https://hackage.haskell.org/package/th-lift th-lift>+package to derive 'Lift' instances. If you choose to continue with this package:++    * If you have 'Typeable' instances, then you should use the \"less friendly\"+    functions here. These take an argument for the package name, but they ignore it+    (acting just like the friendly ones) for GHC 7.4 (@base@ 4.5) and later.++    * If you lack a 'Typeable' instance for a type constructor, then you'll+    need to use the \"unfriendly\" functions. These rely solely on the+    user-provided package name. On GHC 7.10, it is extremely difficult to+    obtain the correct package name for an external package.++=== A note on 'Typeable' constraints++For relevant versions, the \"friendly\" and \"less friendly\" functions require+the type to satisfy an @OuterTypeable@ constraint.  A type is @OuterTypable@ if+its /type constructor/ (applied to any /kind/ arguments) is 'Typeable'. For+example, @'Maybe' a@ is only 'Typeable' if @a@ is 'Typeable', but it is always+@OuterTypeable@. For @'Control.Applicative.Const' a b@ to be 'OuterTypeable',+the /kinds/ of @a@ and @b@ must be 'Typeable'.++Before GHC 7.8, 'Typeable' can only be derived for types with seven+or fewer parameters, all of kind @*@. Types with more parameters that+manually instantiate the now-defunct @Typeable7@ class should work,+but there may be some loss of polymorphism in the first arguments.+Types whose 'Typeable' instances can't be derived because of kind issues+will not work with these GHC versions. -} module Language.Haskell.TH.Lift.Generics (-      genericLiftWithPkg+#if MIN_VERSION_base(4,5,0)+    -- * Friendly "GHC.Generics"-based 'lift' implementations+    --+    -- $friendlyFunctions+      genericLift+# if MIN_VERSION_template_haskell(2,9,0)+    , genericLiftTyped+    , genericLiftTypedTExp+    , genericLiftTypedCompat+# endif+    ,+#endif++    -- * Less friendly and unfriendly "GHC.Generics"-based 'lift'+    -- implementations+    --+    -- $lessFriendlyFunctions++    -- ** Less friendly implementations+    --+    -- | These implementations should be used when support for versions+    -- before GHC 7.4 (@base@ 4.5) is required, but a 'Data.Typeable.Typeable'+    -- instance is available. The 'Data.Typeable.Typeable' instance will be used+    -- to get the package name for GHC 7.4 and later.+      genericLiftWithPkgFallback #if MIN_VERSION_template_haskell(2,9,0)+    , genericLiftTypedWithPkgFallback+    , genericLiftTypedTExpWithPkgFallback+    , genericLiftTypedCompatWithPkgFallback+#endif++    -- ** Unfriendly implementations+    --+    -- | These implementations should be used when support for versions+    -- before GHC 8.0 (@base@ 4.9) is required and a 'Data.Typeable.Typeable' instance+    -- is /not/ available. These functions are termed "unfriendly" because+    -- they're extremely hard to use under GHC 7.10 when working with types+    -- defined in other packages. The only way to do so is to use a 'Typeable'+    -- type in the same package to get the \"package name\", which will be a+    -- hash value.+    , genericLiftWithPkg+#if MIN_VERSION_template_haskell(2,9,0)     , genericLiftTypedWithPkg     , genericLiftTypedTExpWithPkg     , genericLiftTypedCompatWithPkg #endif-#if __GLASGOW_HASKELL__ >= 711-    , genericLift-    , genericLiftTyped-    , genericLiftTypedTExp-    , genericLiftTypedCompat-#endif+    -- * 'Generic' classes+    --+    -- | You shouldn't need to use any of these+    -- classes directly; they are only exported for educational purposes.     , GLift(..)     , GLiftDatatype(..)     , GLiftArgs(..)@@ -38,12 +121,19 @@     , Lift(..)     ) where -import Data.Foldable (foldl')+#if MIN_VERSION_base(4,5,0) && !MIN_VERSION_base(4,9,0)+import Language.Haskell.TH.Lift.Generics.Internal.OuterTypeable+#endif +import Control.Monad (liftM, (>=>))+ import Generics.Deriving  import GHC.Base (unpackCString#) import GHC.Exts (Double(..), Float(..), Int(..), Word(..))+#if __GLASGOW_HASKELL__ < 708+import GHC.Conc (pseq)+#endif  import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax@@ -58,24 +148,43 @@ import GHC.Exts (Char(..)) #endif +#if MIN_VERSION_base(4,5,0) && !MIN_VERSION_base(4,9,0)+import qualified Data.Typeable as T+#endif++#if MIN_VERSION_base(4,5,0) && !MIN_VERSION_base(4,9,0)+import Data.Proxy (Proxy (..))+#endif++-- We don't want to expand this in the Haddocks! #undef CURRENT_PACKAGE_KEY--- | "GHC.Generics"-based 'lift' implementation.++-- $lessFriendlyFunctions ----- API limitations of early versions of GHC (7.10 and earlier) require the user--- to produce the package name themselves. This isn't as easy to come up with as--- it sounds, because GHC 7.10 uses a hashed package ID for a name. To make things--- worse, if you produce the wrong package name, you might get bizarre compilation--- errors!+-- API limitations of early versions of GHC (7.2 and earlier) require the user+-- to produce the package name themselves. This is also occasionally necessary+-- for later versions of GHC when dealing with types from other packages that+-- lack 'Data.Typeable.Typeable' instances. The package name isn't always as easy to come+-- up with as it sounds, especially because GHC 7.10 uses a hashed package ID+-- for that name. To make things worse, if you produce the wrong package name,+-- you might get bizarre compilation errors! ----- There's no need to fear, though—the code sample below shows an example of how to--- properly use 'genericLiftWithPkg' without shooting yourself in the foot:+-- There's no need to fear, though—in most cases it's possible to obtain the+-- correct package name anyway, at least for types defined /in the current package/.+-- When compiling a library with @Cabal@, the current package+-- name is obtained using the CPP macro @CURRENT_PACKAGE_KEY@. When compiling+-- an application, or compiling without Cabal, it takes a bit more work to get+-- the name. The code sample below shows an example of how to+-- properly use 'genericLiftWithPkgFallback' or 'genericLiftWithPkg' without+-- shooting yourself in the foot: -- -- @--- &#123;-&#35; LANGUAGE CPP, DeriveGeneric &#35;-&#125;+-- &#123;-&#35; LANGUAGE CPP, DeriveGeneric, DeriveDataTypeable &#35;-&#125; -- -- part of package foobar -- module Foo where -- -- import GHC.Generics+-- import Data.Typeable -- import Language.Haskell.Lift.Generics -- -- &#35;ifndef CURRENT_PACKAGE_KEY@@ -91,10 +200,13 @@ -- &#35;endif -- -- data Foo = Foo Int Char String---   deriving Generic+--   deriving (Generic, Typeable) -- -- instance Lift Foo where---   lift = genericLiftWithPkg pkgName+--   lift = genericLiftWithPkgFallback pkgName+-- &#35;if MIN&#95;VERSION&#95;template_haskell(2,9,0)+--   liftTyped = genericLiftTypedCompatWithPkgFallback pkgName+-- &#35;endif -- @ -- -- As you can see, this trick only works if (1) the current package key is known@@ -113,8 +225,84 @@ -- import Language.Haskell.TH.Syntax -- -- foo :: Foo--- foo = $(lift (Foo 1 'a' "baz"))+-- foo = $(lift (Foo 1 \'a\' \"baz\")) -- @++-- | Generically produce an implementation of 'lift', given a user-provided+-- (but correct!) package name. The provided package name is ignored for+-- GHC 7.4 (@base@ 4.5) and later.+--+-- === Note+--+-- A @'Data.Typeable.Typeable' a@ instance is required for 7.4 <= GHC < 8.0 (4.5 <= @base@ < 4.9).+--+-- @since 0.2.1+#if MIN_VERSION_base (4,9,0) || !MIN_VERSION_base (4,5,0)+genericLiftWithPkgFallback :: (Quote m, Generic a, GLift (Rep a)) => String -> a -> m Exp+#else+genericLiftWithPkgFallback :: (Quote m, Generic a, GLift (Rep a), OuterTypeable a) => String -> a -> m Exp+#endif+#if MIN_VERSION_base(4,5,0)+genericLiftWithPkgFallback _pkg = genericLift+#else+genericLiftWithPkgFallback = genericLiftWithPkg+#endif++#if MIN_VERSION_template_haskell(2,9,0)+-- | Like 'genericLiftWithPkgFallback', but returns a 'Code' instead of an 'Exp'.+--+-- @since 0.2.1+# if MIN_VERSION_base (4,9,0) || !MIN_VERSION_base (4,5,0)+genericLiftTypedWithPkgFallback :: (Quote m, Generic a, GLift (Rep a)) => String -> a -> Code m a+# else+genericLiftTypedWithPkgFallback :: (Quote m, Generic a, GLift (Rep a), OuterTypeable a) => String -> a -> Code m a+# endif+# if MIN_VERSION_base(4,5,0)+genericLiftTypedWithPkgFallback _pkg = genericLiftTyped+# else+genericLiftTypedWithPkgFallback = genericLiftTypedWithPkg+# endif++-- | Like 'genericLiftWithPkgFallback', but returns a 'TExp' instead of an 'Exp'.+--+-- @since 0.2.1+# if MIN_VERSION_base (4,9,0) || !MIN_VERSION_base (4,5,0)+genericLiftTypedTExpWithPkgFallback :: (Quote m, Generic a, GLift (Rep a)) => String -> a -> m (TExp a)+# else+genericLiftTypedTExpWithPkgFallback :: (Quote m, Generic a, GLift (Rep a), OuterTypeable a) => String -> a -> m (TExp a)+# endif+# if MIN_VERSION_base(4,5,0)+genericLiftTypedTExpWithPkgFallback _pkg = genericLiftTypedTExp+# else+genericLiftTypedTExpWithPkgFallback = genericLiftTypedTExpWithPkg+# endif++-- | Like '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@.+--+-- @since 0.2.1+# if MIN_VERSION_base (4,9,0) || !MIN_VERSION_base (4,5,0)+genericLiftTypedCompatWithPkgFallback :: (Quote m, Generic a, GLift (Rep a)) => String -> a -> Splice m a+# else+genericLiftTypedCompatWithPkgFallback :: (Quote m, Generic a, GLift (Rep a), OuterTypeable a) => String -> a -> Splice m a+# endif+# if MIN_VERSION_template_haskell(2,17,0)+genericLiftTypedCompatWithPkgFallback = genericLiftTypedWithPkgFallback+# else+genericLiftTypedCompatWithPkgFallback = genericLiftTypedTExpWithPkgFallback+# endif+#endif++-- ---++-- | Generically produce an implementation of 'lift', given a user-provided+-- (but correct!) package name. The provided package name is ignored for+-- GHC 8.0 (@base@ 4.9) and later. genericLiftWithPkg :: (Quote m, Generic a, GLift (Rep a)) => String -> a -> m Exp genericLiftWithPkg pkg = glift pkg . from @@ -127,7 +315,7 @@ genericLiftTypedTExpWithPkg :: (Quote m, Generic a, GLift (Rep a)) => String -> a -> m (TExp a) genericLiftTypedTExpWithPkg pkg = unsafeTExpCoerceQuote . genericLiftWithPkg pkg --- | Lift 'genericLiftWithPkg', but returns:+-- | Like '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@)@@ -142,12 +330,18 @@ # endif #endif -#if __GLASGOW_HASKELL__ >= 711--- | "GHC.Generics"-based 'lift' implementation. Only available on GHC 8.0 and later--- due to API limitations of earlier GHC versions.+#if MIN_VERSION_base (4,5,0)+-- $friendlyFunctions ----- Unlike 'genericLiftWithPkg', this function does all of the work for you:+-- The functions in this section are nice and simple, but are only available on+-- GHC 7.4.1 (@base@ 4.5) and later due to API limitations of earlier GHC+-- versions. The types of these functions depend slightly on the GHC version.+-- In particular, before GHC 8.0 (@base@ 4.9), these functions have+-- 'Data.Typeable.Typeable' constraints in addition to 'GHC.Generic.Generic'+-- ones. --+-- These functions do all of the work for you:+-- -- @ -- &#123;-&#35; LANGUAGE DeriveGeneric &#35;-&#125; -- module Foo where@@ -160,6 +354,9 @@ -- -- instance Lift Foo where --   lift = genericLift+-- &#35;if MIN&#95;VERSION&#95;template_haskell(2,9,0)+--   liftTyped = genericLiftTypedCompat+-- &#35;endif -- @ -- -- Now you can splice @Foo@ values directly into Haskell source code:@@ -172,17 +369,39 @@ -- import Language.Haskell.TH.Syntax -- -- foo :: Foo--- foo = $(lift (Foo 1 'a' "baz"))+-- foo = $(lift (Foo 1 \'a\' \"baz\")) -- @++-- | Produce a generic definition of 'lift'.+--+-- === Note+--+-- A @'Data.Typeable.Typeable' a@ instance is required for GHC < 8.0 (@base@ < 4.9).+# if MIN_VERSION_base (4,9,0) genericLift :: (Quote m, Generic a, GLift (Rep a)) => a -> m Exp genericLift = glift "" . from+# else+genericLift :: forall m a. (Quote m, Generic a, GLift (Rep a), OuterTypeable a) => a -> m Exp+genericLift =+  glift (T.tyConPackage (T.typeRepTyCon (getConTR (Proxy :: Proxy a))))+    . from+# endif +# if MIN_VERSION_template_haskell(2,9,0) -- | Like 'genericLift', but returns a 'Code' instead of an 'Exp'.+#  if MIN_VERSION_base (4,9,0) genericLiftTyped :: (Quote m, Generic a, GLift (Rep a)) => a -> Code m a+#  else+genericLiftTyped :: (Quote m, Generic a, GLift (Rep a), OuterTypeable a) => a -> Code m a+#  endif genericLiftTyped = unsafeCodeCoerce . genericLift  -- | Like 'genericLift', but returns a 'TExp' instead of an 'Exp'.+#  if MIN_VERSION_base (4,9,0) genericLiftTypedTExp :: (Quote m, Generic a, GLift (Rep a)) => a -> m (TExp a)+#  else+genericLiftTypedTExp :: (Quote m, Generic a, GLift (Rep a), OuterTypeable a) => a -> m (TExp a)+#  endif genericLiftTypedTExp = unsafeTExpCoerceQuote . genericLift  -- | Lift 'genericLift', but returns:@@ -192,17 +411,21 @@ -- -- This function is ideal for implementing the 'liftTyped' method of 'Lift' -- directly, as its type changed in @template-haskell-2.17.0.0@.+#  if MIN_VERSION_base (4,9,0) genericLiftTypedCompat :: (Quote m, Generic a, GLift (Rep a)) => a -> Splice m a-# if MIN_VERSION_template_haskell(2,17,0)+#  else+genericLiftTypedCompat :: (Quote m, Generic a, GLift (Rep a), OuterTypeable a) => a -> Splice m a+#  endif+#  if MIN_VERSION_template_haskell(2,17,0) genericLiftTypedCompat = genericLiftTyped-# else+#  else genericLiftTypedCompat = genericLiftTypedTExp+#  endif # 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.+-- Haskell expressions. class GLift f where     glift :: Quote m           => String -- ^ The package name (not used on GHC 8.0 and later)@@ -221,8 +444,7 @@         mName = moduleName d  -- | Class of generic representation types which can be converted to Template--- Haskell expressions, given a package and module name. You shouldn't need to use--- this typeclass directly; it is only exported for educational purposes.+-- Haskell expressions, given a package and module name. class GLiftDatatype f where     gliftWith :: Quote m               => String -- ^ The package name@@ -231,18 +453,24 @@               -> m Exp  -- ^ The resulting Template Haskell expression  instance GLiftDatatype V1 where+    -- While many instances for void types produce the laziest possible result+    -- (here, something like pure undefined), we choose to be stricter. There+    -- seems little if any benefit to delaying exceptions in this context.     gliftWith _ _ x =-      return $ case x of+      case x of #if __GLASGOW_HASKELL__ >= 708-                 {}+        {} #else-                 !_ -> undefined+        -- pseq ensures that we'll get the exception/non-termination+        -- of v, rather than allowing GHC to "optimize" the function+        -- to gliftWith _ _ _ = undefined, which it would be permitted+        -- to do if we used seq or a bang pattern.+        v -> v `pseq` undefined #endif  instance (Constructor c, GLiftArgs f) => GLiftDatatype (C1 c f) where-    gliftWith pName mName c@(M1 x) = do-      args <- sequence (gliftArgs x)-      return $ foldl' AppE (ConE (mkNameG_d pName mName cName)) args+    gliftWith pName mName c@(M1 x) =+      gliftArgs x (ConE (mkNameG_d pName mName cName))       where         cName :: String         cName = conName c@@ -251,27 +479,31 @@     gliftWith pName mName (L1 l) = gliftWith pName mName l     gliftWith pName mName (R1 r) = gliftWith pName mName r --- | Class of generic representation types which can be converted to a list of--- Template Haskell expressions (which represent a constructors' arguments). You--- shouldn't need to use this typeclass directly; it is only exported for educational--- purposes.+-- | Class of generic representation types which can conceptually be converted+-- to a list of Template Haskell expressions (which represent a constructors'+-- arguments). class GLiftArgs f where-    gliftArgs :: Quote m => f a -> [m Exp]+    -- | @gliftArgs e f@ applies @f@ to the zero or more arguments represented+    -- by @e@.+    gliftArgs :: Quote m => f a -> Exp -> m Exp  instance GLiftArgs U1 where-    gliftArgs U1 = []+    -- This pattern match must be strict, because+    -- lift undefined really shouldn't just happen+    -- to work for unit types.+    gliftArgs U1 = return  instance Lift c => GLiftArgs (K1 i c) where-    gliftArgs (K1 x) = [liftQuote x]+    gliftArgs (K1 x) h = AppE h `liftM` liftQuote x  instance GLiftArgs f => GLiftArgs (S1 s f) where     gliftArgs (M1 x) = gliftArgs x  instance (GLiftArgs f, GLiftArgs g) => GLiftArgs (f :*: g) where-    gliftArgs (f :*: g) = gliftArgs f ++ gliftArgs g+    gliftArgs (f :*: g) = gliftArgs f >=> gliftArgs g  instance GLiftArgs UAddr where-    gliftArgs (UAddr a) = [return (LitE (StringPrimL (word8ify (unpackCString# a))))]+    gliftArgs (UAddr a) h = return $ AppE h (LitE (StringPrimL (word8ify (unpackCString# a))))       where #if MIN_VERSION_template_haskell(2,8,0)         word8ify :: String -> [Word8]@@ -283,17 +515,17 @@  #if MIN_VERSION_template_haskell(2,11,0) instance GLiftArgs UChar where-    gliftArgs (UChar c) = [return (LitE (CharPrimL (C# c)))]+    gliftArgs (UChar c) h = return $ AppE h (LitE (CharPrimL (C# c))) #endif  instance GLiftArgs UDouble where-    gliftArgs (UDouble d) = [return (LitE (DoublePrimL (toRational (D# d))))]+    gliftArgs (UDouble d) h = return $ AppE h (LitE (DoublePrimL (toRational (D# d))))  instance GLiftArgs UFloat where-    gliftArgs (UFloat f) = [return (LitE (floatPrimL (toRational (F# f))))]+    gliftArgs (UFloat f) h = return $ AppE h (LitE (floatPrimL (toRational (F# f))))  instance GLiftArgs UInt where-    gliftArgs (UInt i) = [return (LitE (IntPrimL (toInteger (I# i))))]+    gliftArgs (UInt i) h = return $ AppE h (LitE (IntPrimL (toInteger (I# i))))  instance GLiftArgs UWord where-    gliftArgs (UWord w) = [return (LitE (WordPrimL (toInteger (W# w))))]+    gliftArgs (UWord w) h = return $ AppE h (LitE (WordPrimL (toInteger (W# w))))

@@ -0,0 +1,71 @@+{-# language CPP #-}+{-# language FlexibleInstances #-}+{-# language UndecidableInstances #-}+{-# language ScopedTypeVariables #-}+#if __GLASGOW_HASKELL__ >= 708+{-# language PolyKinds #-}+#endif++#if __GLASGOW_HASKELL__ < 710+{-# language OverlappingInstances #-}+#endif++module Language.Haskell.TH.Lift.Generics.Internal.OuterTypeable+  ( OuterTypeable (..)+  ) where+import Data.Typeable++-- | A type is @OuterTypable@ if its /type constructor/ (applied to any kind+-- arguments) is 'Typeable'. For example, @'Maybe' a@ is only 'Typeable' if @a@+-- is 'Typeable', but it is always @OuterTypeable@.+class OuterTypeable a where+  -- | Get the 'TypeRep' corresponding to the outermost constructor+  -- of a type.+  getConTR :: proxy a -> TypeRep++#if __GLASGOW_HASKELL__ >= 708++# if __GLASGOW_HASKELL__ >= 710+instance {-# OVERLAPPING #-} OuterTypeable f => OuterTypeable (f a) where+# else+instance                     OuterTypeable f => OuterTypeable (f a) where+# endif+  getConTR _ = getConTR (Proxy :: Proxy f)++instance Typeable a => OuterTypeable a where+  getConTR = typeRep++-- Why do we need overlapping instances above? Couldn't we use+-- the type family instance selection trick? No, we couldn't. We'd+-- like to be able to write+--+-- type family IsApp (a :: k) :: Bool where+--   IsApp (f a) = 'True+--   IsApp a = 'False+--+-- and switch on that. Unfortunately, that type family wasn't allowed+-- until TypeInType came out in GHC 8.0, which is precisely when we+-- stop needing this module at all.++#else++-- Before GHC 7.8, we didn't have polykinded Typeable, so things were+-- rather less pleasant.++instance Typeable a => OuterTypeable a where+  getConTR _ = typeOf (undefined :: a)+instance Typeable1 p => OuterTypeable (p a) where+  getConTR _ = typeOf1 (undefined :: p a)+instance Typeable2 p => OuterTypeable (p a b) where+  getConTR _ = typeOf2 (undefined :: p a b)+instance Typeable3 p => OuterTypeable (p a b c) where+  getConTR _ = typeOf3 (undefined :: p a b c)+instance Typeable4 p => OuterTypeable (p a b c d) where+  getConTR _ = typeOf4 (undefined :: p a b c d)+instance Typeable5 p => OuterTypeable (p a b c d e) where+  getConTR _ = typeOf5 (undefined :: p a b c d e)+instance Typeable6 p => OuterTypeable (p a b c d e f) where+  getConTR _ = typeOf6 (undefined :: p a b c d e f)+instance Typeable7 p => OuterTypeable (p a b c d e f g) where+  getConTR _ = typeOf7 (undefined :: p a b c d e f g)+#endif

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-}  {-|@@ -11,10 +12,19 @@ -} module LiftGenericsSpec (main, spec) where +import Instances.TH.Lift () import Language.Haskell.TH.Syntax hiding (newName) import Language.Haskell.TH.Syntax.Compat+#if MIN_VERSION_base(4,5,0)+import Language.Haskell.TH.Lift.Generics (genericLift)+# if MIN_VERSION_template_haskell(2,16,0)+import Language.Haskell.TH.Lift.Generics (genericLiftTypedCompat)+# endif+#endif import Test.Hspec import Types+import Control.Exception (Exception, throw, evaluate)+import Data.Typeable (Typeable)  main :: IO () main = hspec spec@@ -22,13 +32,18 @@ description :: String description = "should equal its lifted counterpart" +data Exc = Exc deriving (Show, Typeable, Eq)+instance Exception Exc+ spec :: Spec spec = parallel $ do     describe "genericLift" $ do-        describe "Unit" $+        describe "Unit" $ do             it description $ do                 Unit `shouldBe` $(lift Unit)                 ConE 'Unit `shouldBe` runPureQ (liftQuote Unit)+            it "should throw an exception on undefined" $+                evaluate (runPureQ $ liftQuote (throw Exc :: Unit)) `shouldThrow` (== Exc)         describe "Product" $             it description $                 p `shouldBe` $(lift p)@@ -38,7 +53,45 @@         describe "Unboxed" $             it description $                 u `shouldBe` $(lift u)-#if MIN_VERSION_template_haskell(2,16,0)+        describe "Const" $+            it description $+                c `shouldBe` $(lift c)+        describe "Ap" $+            it description $+                z `shouldBe` $(lift z)+#if MIN_VERSION_base(4,5,0)+        -- We use Tree to check that things work for types imported+        -- from external packages without special distinguished names.+        -- It proved rather tricky to find a good choice. This one's+        -- not really ideal (I'd rather have a non-recursive type), but+        -- it'll do for now.+        describe "Tree" $+            it description $+                w `shouldBe` $(genericLift w)+        describe "Unit'" $ do+            it description $ do+                Unit' `shouldBe` $(lift Unit')+                ConE 'Unit' `shouldBe` runPureQ (liftQuote Unit')+            it "should throw an exception on undefined" $+                evaluate (runPureQ $ liftQuote (throw Exc :: Unit')) `shouldThrow` (== Exc)+        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 "Const'" $+            it description $+                c' `shouldBe` $(lift c')+# if __GLASGOW_HASKELL__ >= 708+        describe "Ap'" $+            it description $+                z' `shouldBe` $(lift z')+#endif+# if MIN_VERSION_template_haskell(2,16,0)     describe "genericLiftTyped" $ do         describe "Unit" $             it description $ do@@ -53,4 +106,14 @@         describe "Unboxed" $             it description $                 u `shouldBe` $$(liftTyped u)+        describe "Const" $+            it description $+                c `shouldBe` $$(liftTyped c)+        describe "Ap" $+            it description $+                z `shouldBe` $$(liftTyped z)+        describe "Tree" $+            it description $+                w `shouldBe` $$(genericLiftTypedCompat w)+# endif #endif

@@ -1,4 +1,6 @@ {-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash                  #-} {-# LANGUAGE StandaloneDeriving         #-}@@ -9,6 +11,10 @@ {-# LANGUAGE DataKinds                  #-} #endif +#if !MIN_VERSION_containers(0,5,8)+{-# OPTIONS_GHC -fno-warn-orphans #-}+#endif+ {-| Module:      Types Copyright:   (C) 2015-2017 Ryan Scott@@ -19,21 +25,43 @@ -} module Types (     PureQ, runPureQ-  , Unit(..), Product(..), Sum(..)-  , p, s, u+  , Unit(..)+  , Product(..)+  , Sum(..)+  , Const(..)+  , Ap(..)+  , p, s, u, c, z, w+#if MIN_VERSION_base(4,5,0)+  , Unit'(..)+  , Product'(..)+  , Sum'(..)+  , Const'(..)+  , Ap'(..)+  , p', s', u', c', z'+#endif   ) where +import Data.Tree (Tree (..))+#if MIN_VERSION_base(4,5,0)+import Data.Typeable (Typeable)+#endif+ import Control.Monad.State  import Generics.Deriving.TH (deriveAll)  import GHC.Exts -import Language.Haskell.TH.Lift.Generics ( genericLiftWithPkg+import Language.Haskell.TH.Lift.Generics+  ( genericLiftWithPkg+#if MIN_VERSION_base(4,5,0)+  , genericLift+#endif #if MIN_VERSION_template_haskell(2,16,0)-                                         , genericLiftTypedCompat+  , genericLiftTypedCompatWithPkg+  , genericLiftTypedCompat #endif-                                         )+  ) import Language.Haskell.TH.Syntax hiding (newName) import Language.Haskell.TH.Syntax.Compat @@ -49,6 +77,10 @@ instance Quote PureQ where   newName s = state $ \i -> (mkNameU s i, i + 1) +#if !MIN_VERSION_containers(0,5,8)+$(deriveAll ''Tree)+#endif+ data Unit = Unit   deriving (Eq, Ord, Show) $(deriveAll ''Unit)@@ -61,6 +93,14 @@   deriving (Eq, Ord, Show) $(deriveAll ''Sum) +newtype Const a b = Const a+  deriving (Eq, Ord, Show)+$(deriveAll ''Const)++newtype Ap f a = Ap (f a)+  deriving (Eq, Ord, Show)+$(deriveAll ''Ap)+ data Unboxed a    = Unboxed a #if MIN_VERSION_template_haskell(2,11,0)@@ -89,29 +129,159 @@             1#             1## +c :: Const Int a+c = Const 1++z :: Ap Maybe Int+z = Ap (Just 3)++w :: Tree Int+w = Node 3 [Node 4 [], Node 5 []]++#if MIN_VERSION_base(4,5,0)++-- The types below are essentially the same as the ones above.  However, we+-- give them genericLift-based instances rather than genericLiftWithPkg ones,+-- to ensure that the former work too.++data Unit' = Unit'+  deriving (Eq, Ord, Show, Typeable)+$(deriveAll ''Unit')++data Product' a b c d = Product' a b c d+  deriving (Eq, Ord, Show, Typeable)+$(deriveAll ''Product')++data Sum' a b = Inl' a | Inr' b+  deriving (Eq, Ord, Show, Typeable)+$(deriveAll ''Sum')++newtype Const' a b = Const' a+  deriving (Eq, Ord, Show, Typeable)+$(deriveAll ''Const')++newtype Ap' f a = Ap' (f a)+  deriving (Eq, Ord, Show)+#if __GLASGOW_HASKELL__ >= 708+deriving instance Typeable Ap'+#endif+$(deriveAll ''Ap')++data Unboxed' a+   = Unboxed' a+# if MIN_VERSION_template_haskell(2,11,0)+             Char#+# endif+             Double#+             Float#+             Int#+             Word#+  deriving (Eq, Ord, Show, Typeable)+$(deriveAll ''Unboxed')++p' :: Product' Char Int Bool String+p' = Product' 'a' 1 True "b"++s' :: Sum Char Int+s' = Inl 'c'++u' :: Unboxed' Int+u' = Unboxed' 1+# if MIN_VERSION_template_haskell(2,11,0)+            '1'#+# endif+            1.0##+            1.0#+            1#+            1##++c' :: Const' Int a+c' = Const' 1++z' :: Ap' Maybe Int+z' = Ap' (Just 3)+#endif+ pkgKey :: String pkgKey = "main"  instance Lift Unit where     lift = genericLiftWithPkg pkgKey #if MIN_VERSION_template_haskell(2,16,0)-    liftTyped = genericLiftTypedCompat+    liftTyped = genericLiftTypedCompatWithPkg pkgKey #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 = genericLiftTypedCompat+    liftTyped = genericLiftTypedCompatWithPkg pkgKey #endif  instance (Lift a, Lift b) => Lift (Sum a b) where     lift = genericLiftWithPkg pkgKey #if MIN_VERSION_template_haskell(2,16,0)-    liftTyped = genericLiftTypedCompat+    liftTyped = genericLiftTypedCompatWithPkg pkgKey #endif  instance Lift a => Lift (Unboxed a) where     lift = genericLiftWithPkg pkgKey #if MIN_VERSION_template_haskell(2,16,0)+    liftTyped = genericLiftTypedCompatWithPkg pkgKey+#endif++instance Lift a => Lift (Const a b) where+    lift = genericLiftWithPkg pkgKey+#if MIN_VERSION_template_haskell(2,16,0)+    liftTyped = genericLiftTypedCompatWithPkg pkgKey+#endif++instance Lift (f a) => Lift (Ap f a) where+    lift = genericLiftWithPkg pkgKey+#if MIN_VERSION_template_haskell(2,16,0)+    liftTyped = genericLiftTypedCompatWithPkg pkgKey+#endif++#if MIN_VERSION_base(4,5,0)++instance Lift Unit' where+    lift = genericLift+# if MIN_VERSION_template_haskell(2,16,0)     liftTyped = genericLiftTypedCompat+# endif++instance (Lift a, Lift b, Lift c, Lift d) => Lift (Product' a b c d) where+    lift = genericLift+# if MIN_VERSION_template_haskell(2,16,0)+    liftTyped = genericLiftTypedCompat+# endif++instance (Lift a, Lift b) => Lift (Sum' a b) where+    lift = genericLift+# if MIN_VERSION_template_haskell(2,16,0)+    liftTyped = genericLiftTypedCompat+# endif++instance Lift a => Lift (Unboxed' a) where+    lift = genericLift+# if MIN_VERSION_template_haskell(2,16,0)+    liftTyped = genericLiftTypedCompat+# endif++-- This instance shows that we can have parametric polymorphism—we don't need+-- Typeable instances for @a@ or @b@.+instance Lift a => Lift (Const' a b) where+    lift = genericLift+# if MIN_VERSION_template_haskell(2,16,0)+    liftTyped = genericLiftTypedCompat+# endif++# if __GLASGOW_HASKELL__ >= 708+-- This instance demonstrates some polykindedness—the arguments to Ap' aren't+-- all of kind Type. This only works for GHC 7.8 and later.+instance Lift (f a) => Lift (Ap' f a) where+    lift = genericLift+#  if MIN_VERSION_template_haskell(2,16,0)+    liftTyped = genericLiftTypedCompat+#  endif+# endif #endif