diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/lift-generics.cabal b/lift-generics.cabal --- a/lift-generics.cabal +++ b/lift-generics.cabal @@ -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 . . - 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 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 @@ -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 + +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: -- -- @ --- {-# LANGUAGE CPP, DeriveGeneric #-} +-- {-# LANGUAGE CPP, DeriveGeneric, DeriveDataTypeable #-} -- -- part of package foobar -- module Foo where -- -- import GHC.Generics +-- import Data.Typeable -- import Language.Haskell.Lift.Generics -- -- #ifndef CURRENT_PACKAGE_KEY @@ -91,10 +200,13 @@ -- #endif -- -- data Foo = Foo Int Char String --- deriving Generic +-- deriving (Generic, Typeable) -- -- instance Lift Foo where --- lift = genericLiftWithPkg pkgName +-- lift = genericLiftWithPkgFallback pkgName +-- #if MIN_VERSION_template_haskell(2,9,0) +-- liftTyped = genericLiftTypedCompatWithPkgFallback pkgName +-- #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: +-- -- @ -- {-# LANGUAGE DeriveGeneric #-} -- module Foo where @@ -160,6 +354,9 @@ -- -- instance Lift Foo where -- lift = genericLift +-- #if MIN_VERSION_template_haskell(2,9,0) +-- liftTyped = genericLiftTypedCompat +-- #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)))) diff --git a/src/Language/Haskell/TH/Lift/Generics/Internal/OuterTypeable.hs b/src/Language/Haskell/TH/Lift/Generics/Internal/OuterTypeable.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/Lift/Generics/Internal/OuterTypeable.hs @@ -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 diff --git a/tests/LiftGenericsSpec.hs b/tests/LiftGenericsSpec.hs --- a/tests/LiftGenericsSpec.hs +++ b/tests/LiftGenericsSpec.hs @@ -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 diff --git a/tests/Types.hs b/tests/Types.hs --- a/tests/Types.hs +++ b/tests/Types.hs @@ -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