diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,6 @@ +### 0.2.1 +* Added `Text.Show.Deriving`, which allows deriving `Show`, `Show1`, and `Show2` with TH. + ## 0.2 * Added support for GHC 8.0 * Added `Data.Functor.Deriving` and `Data.Traversable.Deriving`, which allow deriving `Functor` and `Traversable` with TH. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -25,6 +25,7 @@ * In GHC 8.0, `DeriveFoldable` was changed to allow folding over data types with existential constraints. * In GHC 8.0, `DeriveFoldable` and `DeriveTraversable` were changed so as not to generate superfluous `mempty` or `pure` expressions in generated code. As a result, this allows deriving `Traversable` instances for datatypes with unlifted argument types. +* In GHC 8.0, deriving `Show` was changed so that constructor fields with unlifted types are no longer shown with parentheses, and the output of showing an unlifted type is suffixed with the same number of hash signs as the corresponding primitive literals. Note that some recent GHC extensions are not covered by this package: diff --git a/deriving-compat.cabal b/deriving-compat.cabal --- a/deriving-compat.cabal +++ b/deriving-compat.cabal @@ -1,5 +1,5 @@ name: deriving-compat -version: 0.2 +version: 0.2.1 synopsis: Backports of GHC deriving extensions description: Provides Template Haskell functions that mimic deriving extensions that were introduced or modified in recent versions @@ -22,6 +22,11 @@ deriving @Traversable@ instances for datatypes with unlifted argument types. . + * In GHC 8.0, deriving @Show@ was changed so that constructor fields + with unlifted types are no longer shown with parentheses, and + the output of showing an unlifted type is suffixed with the same + number of hash signs as the corresponding primitive literals. + . Note that some recent GHC extensions are not covered by this package: . * @DeriveGeneric@, which was introducted in GHC 7.2 for deriving @@ -58,19 +63,46 @@ type: git location: https://github.com/haskell-compat/deriving-compat +flag base-49 + description: Use base-4.9 or later. + default: True + +flag new-functor-classes + description: Use a version of transformers or transformers-compat with a + modern-style Data.Functor.Classes module. This flag cannot be + used when building with transformers-0.4, since it comes with + a different version of Data.Functor.Classes. + default: True + library exposed-modules: Data.Deriving Data.Foldable.Deriving Data.Functor.Deriving Data.Traversable.Deriving + Text.Show.Deriving other-modules: Data.Deriving.Internal Data.Functor.Deriving.Internal + Text.Show.Deriving.Internal Paths_deriving_compat - build-depends: base >= 4.3 && < 5 - , containers >= 0.1 && < 0.6 + build-depends: containers >= 0.1 && < 0.6 , ghc-prim - , template-haskell >= 2.5 && < 2.12 + , template-haskell >= 2.5 && < 2.12 + + if flag(base-49) + build-depends: base >= 4.9 && < 5 + , ghc-boot-th + cpp-options: "-DNEW_FUNCTOR_CLASSES" + else + build-depends: base >= 4.3 && < 4.9 + + if flag(new-functor-classes) + build-depends: transformers (>= 0.2 && < 0.4) || >= 0.5 + , transformers-compat >= 0.5 + cpp-options: "-DNEW_FUNCTOR_CLASSES" + else + build-depends: transformers == 0.4.* + hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -78,15 +110,27 @@ test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs - other-modules: DerivingSpec - build-depends: base >= 4.3 && < 5 - , base-compat >= 0.8.1 && < 1 + other-modules: FunctorSpec + ShowSpec + build-depends: base-compat >= 0.8.1 && < 1 , base-orphans >= 0.5 && < 1 - , deriving-compat == 0.2 + , deriving-compat == 0.2.1 , hspec >= 1.8 , QuickCheck >= 2 && < 3 - , transformers >= 0.2 - , transformers-compat >= 0.3 + + if flag(base-49) + build-depends: base >= 4.9 && < 5 + cpp-options: "-DNEW_FUNCTOR_CLASSES" + else + build-depends: base >= 4.3 && < 4.9 + + if flag(new-functor-classes) + build-depends: transformers (>= 0.2 && < 0.4) || >= 0.5 + , transformers-compat >= 0.5 + cpp-options: "-DNEW_FUNCTOR_CLASSES" + else + build-depends: transformers == 0.4.* + hs-source-dirs: tests default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Data/Deriving.hs b/src/Data/Deriving.hs --- a/src/Data/Deriving.hs +++ b/src/Data/Deriving.hs @@ -22,6 +22,7 @@ import Data.Foldable.Deriving as Exports import Data.Functor.Deriving as Exports import Data.Traversable.Deriving as Exports +import Text.Show.Deriving as Exports {- $derive diff --git a/src/Data/Deriving/Internal.hs b/src/Data/Deriving/Internal.hs --- a/src/Data/Deriving/Internal.hs +++ b/src/Data/Deriving/Internal.hs @@ -1,5 +1,15 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +#if !(MIN_VERSION_base(4,9,0)) +# if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TemplateHaskellQuotes #-} +# else +{-# LANGUAGE TemplateHaskell #-} +# endif +#endif + {-| Module: Data.Deriving.Internal Copyright: (C) 2015-2016 Ryan Scott @@ -11,17 +21,25 @@ -} module Data.Deriving.Internal where -import Control.Monad (liftM) +import Control.Monad (liftM, when, unless) import Data.Foldable (foldr') +#if !(MIN_VERSION_base(4,9,0)) +# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +import Data.Functor.Classes (Show1(..), Show2(..)) +# else +import Data.Functor.Classes (Show1(..)) +# endif +#endif import Data.List -import qualified Data.Map as Map (fromList, findWithDefault, singleton) +import qualified Data.Map as Map import Data.Map (Map) -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe import qualified Data.Set as Set import Data.Set (Set) import Language.Haskell.TH.Lib +import Language.Haskell.TH.Ppr (pprint) import Language.Haskell.TH.Syntax #ifndef CURRENT_PACKAGE_KEY @@ -109,21 +127,44 @@ ------------------------------------------------------------------------------- fmapConst :: f b -> (a -> b) -> f a -> f b -fmapConst = const . const +fmapConst x _ _ = x {-# INLINE fmapConst #-} foldrConst :: b -> (a -> b -> b) -> b -> t a -> b -foldrConst = const . const . const +foldrConst x _ _ _ = x {-# INLINE foldrConst #-} foldMapConst :: m -> (a -> m) -> t a -> m -foldMapConst = const . const +foldMapConst x _ _ = x {-# INLINE foldMapConst #-} traverseConst :: f (t b) -> (a -> f b) -> t a -> f (t b) -traverseConst = const . const +traverseConst x _ _ = x {-# INLINE traverseConst #-} +showsPrecConst :: ShowS + -> Int -> a -> ShowS +showsPrecConst x _ _ = x +{-# INLINE showsPrecConst #-} + +showsPrec1Const :: ShowS + -> Int -> f a -> ShowS +showsPrec1Const x _ _ = x +{-# INLINE showsPrec1Const #-} + +liftShowsPrecConst :: ShowS + -> (Int -> a -> ShowS) -> ([a] -> ShowS) + -> Int -> f a -> ShowS +liftShowsPrecConst x _ _ _ _ = x +{-# INLINE liftShowsPrecConst #-} + +liftShowsPrec2Const :: ShowS + -> (Int -> a -> ShowS) -> ([a] -> ShowS) + -> (Int -> b -> ShowS) -> ([b] -> ShowS) + -> Int -> f a b -> ShowS +liftShowsPrec2Const x _ _ _ _ _ _ = x +{-# INLINE liftShowsPrec2Const #-} + ------------------------------------------------------------------------------- -- StarKindStatus ------------------------------------------------------------------------------- @@ -156,9 +197,654 @@ catKindVarNames = mapMaybe starKindStatusToName ------------------------------------------------------------------------------- +-- ClassRep +------------------------------------------------------------------------------- + +class ClassRep a where + arity :: a -> Int + allowExQuant :: a -> Bool + fullClassName :: a -> Name + classConstraint :: a -> Int -> Maybe Name + +------------------------------------------------------------------------------- +-- Template Haskell reifying and AST manipulation +------------------------------------------------------------------------------- + +-- | Boilerplate for top level splices. +-- +-- The given Name must meet one of two criteria: +-- +-- 1. It must be the name of a type constructor of a plain data type or newtype. +-- 2. It must be the name of a data family instance or newtype instance constructor. +-- +-- Any other value will result in an exception. +withType :: Name + -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a) + -> Q a +withType name f = do + info <- reify name + case info of + TyConI dec -> + case dec of + DataD ctxt _ tvbs +#if MIN_VERSION_template_haskell(2,11,0) + _ +#endif + cons _ -> f name ctxt tvbs cons Nothing + NewtypeD ctxt _ tvbs +#if MIN_VERSION_template_haskell(2,11,0) + _ +#endif + con _ -> f name ctxt tvbs [con] Nothing + _ -> fail $ ns ++ "Unsupported type: " ++ show dec +#if MIN_VERSION_template_haskell(2,7,0) +# if MIN_VERSION_template_haskell(2,11,0) + DataConI _ _ parentName -> do +# else + DataConI _ _ parentName _ -> do +# endif + parentInfo <- reify parentName + case parentInfo of +# if MIN_VERSION_template_haskell(2,11,0) + FamilyI (DataFamilyD _ tvbs _) decs -> +# else + FamilyI (FamilyD DataFam _ tvbs _) decs -> +# endif + let instDec = flip find decs $ \dec -> case dec of + DataInstD _ _ _ +# if MIN_VERSION_template_haskell(2,11,0) + _ +# endif + cons _ -> any ((name ==) . constructorName) cons + NewtypeInstD _ _ _ +# if MIN_VERSION_template_haskell(2,11,0) + _ +# endif + con _ -> name == constructorName con + _ -> error $ ns ++ "Must be a data or newtype instance." + in case instDec of + Just (DataInstD ctxt _ instTys +# if MIN_VERSION_template_haskell(2,11,0) + _ +# endif + cons _) + -> f parentName ctxt tvbs cons $ Just instTys + Just (NewtypeInstD ctxt _ instTys +# if MIN_VERSION_template_haskell(2,11,0) + _ +# endif + con _) + -> f parentName ctxt tvbs [con] $ Just instTys + _ -> fail $ ns ++ + "Could not find data or newtype instance constructor." + _ -> fail $ ns ++ "Data constructor " ++ show name ++ + " is not from a data family instance constructor." +# if MIN_VERSION_template_haskell(2,11,0) + FamilyI DataFamilyD{} _ -> +# else + FamilyI (FamilyD DataFam _ _ _) _ -> +# endif + fail $ ns ++ + "Cannot use a data family name. Use a data family instance constructor instead." + _ -> fail $ ns ++ "The name must be of a plain data type constructor, " + ++ "or a data family instance constructor." +#else + DataConI{} -> dataConIError + _ -> fail $ ns ++ "The name must be of a plain type constructor." +#endif + where + ns :: String + ns = "Data.Deriving.Internal.withType: " + +-- | Deduces the instance context and head for an instance. +buildTypeInstance :: ClassRep a + => a + -- ^ The typeclass for which an instance should be derived + -> Name + -- ^ The type constructor or data family name + -> Cxt + -- ^ The datatype context + -> [TyVarBndr] + -- ^ The type variables from the data type/data family declaration + -> Maybe [Type] + -- ^ 'Just' the types used to instantiate a data family instance, + -- or 'Nothing' if it's a plain data type + -> Q (Cxt, Type) +-- Plain data type/newtype case +buildTypeInstance cRep tyConName dataCxt tvbs Nothing = + let varTys :: [Type] + varTys = map tvbToType tvbs + in buildTypeInstanceFromTys cRep tyConName dataCxt varTys False +-- Data family instance case +-- +-- The CPP is present to work around a couple of annoying old GHC bugs. +-- See Note [Polykinded data families in Template Haskell] +buildTypeInstance cRep parentName dataCxt tvbs (Just instTysAndKinds) = do +#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0) + let instTys :: [Type] + instTys = zipWith stealKindForType tvbs instTysAndKinds +#else + let kindVarNames :: [Name] + kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs + + numKindVars :: Int + numKindVars = length kindVarNames + + givenKinds, givenKinds' :: [Kind] + givenTys :: [Type] + (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds + givenKinds' = map sanitizeStars givenKinds + + -- A GHC 7.6-specific bug requires us to replace all occurrences of + -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it. + -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot. + sanitizeStars :: Kind -> Kind + sanitizeStars = go + where + go :: Kind -> Kind + go (AppT t1 t2) = AppT (go t1) (go t2) + go (SigT t k) = SigT (go t) (go k) + go (ConT n) | n == starKindName = StarT + go t = t + + -- If we run this code with GHC 7.8, we might have to generate extra type + -- variables to compensate for any type variables that Template Haskell + -- eta-reduced away. + -- See Note [Polykinded data families in Template Haskell] + xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys) + + let xTys :: [Type] + xTys = map VarT xTypeNames + -- ^ Because these type variables were eta-reduced away, we can only + -- determine their kind by using stealKindForType. Therefore, we mark + -- them as VarT to ensure they will be given an explicit kind annotation + -- (and so the kind inference machinery has the right information). + + substNamesWithKinds :: [(Name, Kind)] -> Type -> Type + substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks + + -- The types from the data family instance might not have explicit kind + -- annotations, which the kind machinery needs to work correctly. To + -- compensate, we use stealKindForType to explicitly annotate any + -- types without kind annotations. + instTys :: [Type] + instTys = map (substNamesWithKinds (zip kindVarNames givenKinds')) + -- Note that due to a GHC 7.8-specific bug + -- (see Note [Polykinded data families in Template Haskell]), + -- there may be more kind variable names than there are kinds + -- to substitute. But this is OK! If a kind is eta-reduced, it + -- means that is was not instantiated to something more specific, + -- so we need not substitute it. Using stealKindForType will + -- grab the correct kind. + $ zipWith stealKindForType tvbs (givenTys ++ xTys) +#endif + buildTypeInstanceFromTys cRep parentName dataCxt instTys True + +-- For the given Types, generate an instance context and head. Coming up with +-- the instance type isn't as simple as dropping the last types, as you need to +-- be wary of kinds being instantiated with *. +-- See Note [Type inference in derived instances] +buildTypeInstanceFromTys :: ClassRep a + => a + -- ^ The typeclass for which an instance should be derived + -> Name + -- ^ The type constructor or data family name + -> Cxt + -- ^ The datatype context + -> [Type] + -- ^ The types to instantiate the instance with + -> Bool + -- ^ True if it's a data family, False otherwise + -> Q (Cxt, Type) +buildTypeInstanceFromTys cRep tyConName dataCxt varTysOrig isDataFamily = do + -- Make sure to expand through type/kind synonyms! Otherwise, the + -- eta-reduction check might get tripped up over type variables in a + -- synonym that are actually dropped. + -- (See GHC Trac #11416 for a scenario where this actually happened.) + varTysExp <- mapM expandSyn varTysOrig + + let remainingLength :: Int + remainingLength = length varTysOrig - arity cRep + + droppedTysExp :: [Type] + droppedTysExp = drop remainingLength varTysExp + + droppedStarKindStati :: [StarKindStatus] + droppedStarKindStati = map canRealizeKindStar droppedTysExp + + -- Check there are enough types to drop and that all of them are either of + -- kind * or kind k (for some kind variable k). If not, throw an error. + when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $ + derivingKindError cRep tyConName + + let droppedKindVarNames :: [Name] + droppedKindVarNames = catKindVarNames droppedStarKindStati + + -- Substitute kind * for any dropped kind variables + varTysExpSubst :: [Type] + varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp + + remainingTysExpSubst, droppedTysExpSubst :: [Type] + (remainingTysExpSubst, droppedTysExpSubst) = + splitAt remainingLength varTysExpSubst + + -- All of the type variables mentioned in the dropped types + -- (post-synonym expansion) + droppedTyVarNames :: [Name] + droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst + + -- If any of the dropped types were polykinded, ensure that they are of kind * + -- after substituting * for the dropped kind variables. If not, throw an error. + unless (all hasKindStar droppedTysExpSubst) $ + derivingKindError cRep tyConName + + let preds :: [Maybe Pred] + kvNames :: [[Name]] + kvNames' :: [Name] + -- Derive instance constraints (and any kind variables which are specialized + -- to * in those constraints) + (preds, kvNames) = unzip $ map (deriveConstraint cRep) remainingTysExpSubst + kvNames' = concat kvNames + + -- Substitute the kind variables specialized in the constraints with * + remainingTysExpSubst' :: [Type] + remainingTysExpSubst' = + map (substNamesWithKindStar kvNames') remainingTysExpSubst + + -- We now substitute all of the specialized-to-* kind variable names with + -- *, but in the original types, not the synonym-expanded types. The reason + -- we do this is a superficial one: we want the derived instance to resemble + -- the datatype written in source code as closely as possible. For example, + -- for the following data family instance: + -- + -- data family Fam a + -- newtype instance Fam String = Fam String + -- + -- We'd want to generate the instance: + -- + -- instance C (Fam String) + -- + -- Not: + -- + -- instance C (Fam [Char]) + remainingTysOrigSubst :: [Type] + remainingTysOrigSubst = + map (substNamesWithKindStar (union droppedKindVarNames kvNames')) + $ take remainingLength varTysOrig + + remainingTysOrigSubst' :: [Type] + -- See Note [Kind signatures in derived instances] for an explanation + -- of the isDataFamily check. + remainingTysOrigSubst' = + if isDataFamily + then remainingTysOrigSubst + else map unSigT remainingTysOrigSubst + + instanceCxt :: Cxt + instanceCxt = catMaybes preds + + instanceType :: Type + instanceType = AppT (ConT (fullClassName cRep)) + $ applyTyCon tyConName remainingTysOrigSubst' + + -- If the datatype context mentions any of the dropped type variables, + -- we can't derive an instance, so throw an error. + when (any (`predMentionsName` droppedTyVarNames) dataCxt) $ + datatypeContextError tyConName instanceType + -- Also ensure the dropped types can be safely eta-reduced. Otherwise, + -- throw an error. + unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $ + etaReductionError instanceType + return (instanceCxt, instanceType) + +-- | Attempt to derive a constraint on a Type. If successful, return +-- Just the constraint and any kind variable names constrained to *. +-- Otherwise, return Nothing and the empty list. +-- +-- See Note [Type inference in derived instances] for the heuristics used to +-- come up with constraints. +deriveConstraint :: ClassRep a => a -> Type -> (Maybe Pred, [Name]) +deriveConstraint cRep t + | not (isTyVar t) = (Nothing, []) + | hasKindStar t = ((`applyClass` tName) `fmap` classConstraint cRep 0, []) + | otherwise = case hasKindVarChain 1 t of + Just ns | cRepArity >= 1 + -> ((`applyClass` tName) `fmap` classConstraint cRep 1, ns) + _ -> case hasKindVarChain 2 t of + Just ns | cRepArity == 2 + -> ((`applyClass` tName) `fmap` classConstraint cRep 2, ns) + _ -> (Nothing, []) + where + tName :: Name + tName = varTToName t + + cRepArity :: Int + cRepArity = arity cRep + +{- +Note [Polykinded data families in Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In order to come up with the correct instance context and head for an instance, e.g., + + instance C a => C (Data a) where ... + +We need to know the exact types and kinds used to instantiate the instance. For +plain old datatypes, this is simple: every type must be a type variable, and +Template Haskell reliably tells us the type variables and their kinds. + +Doing the same for data families proves to be much harder for three reasons: + +1. On any version of Template Haskell, it may not tell you what an instantiated + type's kind is. For instance, in the following data family instance: + + data family Fam (f :: * -> *) (a :: *) + data instance Fam f a + + Then if we use TH's reify function, it would tell us the TyVarBndrs of the + data family declaration are: + + [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT] + + and the instantiated types of the data family instance are: + + [VarT f1,VarT a1] + + We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we + have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the + kind is in case an instantiated type isn't a SigT, so we use the stealKindForType + function to ensure all of the instantiated types are SigTs before passing them + to buildTypeInstanceFromTys. +2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of + the specified kinds of a data family instance efore any of the instantiated + types. Fortunately, this is easy to deal with: you simply count the number of + distinct kind variables in the data family declaration, take that many elements + from the front of the Types list of the data family instance, substitute the + kind variables with their respective instantiated kinds (which you took earlier), + and proceed as normal. +3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template + Haskell might not even list all of the Types of a data family instance, since + they are eta-reduced away! And yes, kinds can be eta-reduced too. + + The simplest workaround is to count how many instantiated types are missing from + the list and generate extra type variables to use in their place. Luckily, we + needn't worry much if its kind was eta-reduced away, since using stealKindForType + will get it back. + +Note [Kind signatures in derived instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It is possible to put explicit kind signatures into the derived instances, e.g., + + instance C a => C (Data (f :: * -> *)) where ... + +But it is preferable to avoid this if possible. If we come up with an incorrect +kind signature (which is entirely possible, since our type inferencer is pretty +unsophisticated - see Note [Type inference in derived instances]), then GHC will +flat-out reject the instance, which is quite unfortunate. + +Plain old datatypes have the advantage that you can avoid using any kind signatures +at all in their instances. This is because a datatype declaration uses all type +variables, so the types that we use in a derived instance uniquely determine their +kinds. As long as we plug in the right types, the kind inferencer can do the rest +of the work. For this reason, we use unSigT to remove all kind signatures before +splicing in the instance context and head. + +Data family instances are trickier, since a data family can have two instances that +are distinguished by kind alone, e.g., + + data family Fam (a :: k) + data instance Fam (a :: * -> *) + data instance Fam (a :: *) + +If we dropped the kind signatures for C (Fam a), then GHC will have no way of +knowing which instance we are talking about. To avoid this scenario, we always +include explicit kind signatures in data family instances. There is a chance that +the inferred kind signatures will be incorrect, but if so, we can always fall back +on the make- functions. + +Note [Type inference in derived instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Type inference is can be tricky to get right, and we want to avoid recreating the +entirety of GHC's type inferencer in Template Haskell. For this reason, we will +probably never come up with derived instance contexts that are as accurate as +GHC's. But that doesn't mean we can't do anything! There are a couple of simple +things we can do to make instance contexts that work for 80% of use cases: + +1. If one of the last type parameters is polykinded, then its kind will be + specialized to * in the derived instance. We note what kind variable the type + parameter had and substitute it with * in the other types as well. For example, + imagine you had + + data Data (a :: k) (b :: k) + + Then you'd want to derived instance to be: + + instance C (Data (a :: *)) + + Not: + + instance C (Data (a :: k)) + +2. We naïvely come up with instance constraints using the following criteria, using + Show(1)(2) as the example typeclasses: + + (i) If there's a type parameter n of kind *, generate a Show n constraint. + (ii) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind + variables), then generate a Show1 n constraint, and if k1/k2 are kind + variables, then substitute k1/k2 with * elsewhere in the types. We must + consider the case where they are kind variables because you might have a + scenario like this: + + newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) + = Compose (f (g a)) + + Which would have a derived Show1 instance of: + + instance (Show1 f, Show1 g) => Show1 (Compose f g) where ... + (iii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are + * or kind variables), then generate a Show2 constraint and perform + kind substitution as in the other cases. +-} + +-- Determines the types of a constructor's arguments as well as the last type +-- parameters (mapped to their auxiliary functions), expanding through any type synonyms. +-- The type parameters are determined on a constructor-by-constructor basis since +-- they may be refined to be particular types in a GADT. +reifyConTys :: ClassRep a + => a + -> [OneOrTwoNames b] + -> Name + -> Q ([Type], TyVarMap b) +reifyConTys cRep auxs conName = do + info <- reify conName + (ctxt, uncTy) <- case info of + DataConI _ ty _ +#if !(MIN_VERSION_template_haskell(2,11,0)) + _ +#endif + -> fmap uncurryTy (expandSyn ty) + _ -> error "Must be a data constructor" + let (argTys, [resTy]) = splitAt (length uncTy - 1) uncTy + unapResTy = unapplyTy resTy + cRepArity = arity cRep + -- If one of the last type variables is refined to a particular type + -- (i.e., not truly polymorphic), we mark it with Nothing and filter + -- it out later, since we only apply auxiliary functions to arguments of + -- a type that it (1) one of the last type variables, and (2) + -- of a truly polymorphic type. + mbTvNames = map varTToName_maybe $ + drop (length unapResTy - cRepArity) unapResTy + -- We use Map.fromList to ensure that if there are any duplicate type + -- variables (as can happen in a GADT), the rightmost type variable gets + -- associated with the auxiliary function. + -- + -- See Note [Matching functions with GADT type variables] + tvMap = Map.fromList + . catMaybes -- Drop refined types + $ zipWith (\mbTvName aux -> + fmap (\tvName -> (tvName, aux)) mbTvName) + mbTvNames auxs + if (any (`predMentionsName` Map.keys tvMap) ctxt + || Map.size tvMap < cRepArity) + && not (allowExQuant cRep) + then existentialContextError conName + else return (argTys, tvMap) + +reifyConTys1 :: ClassRep a + => a + -> [Name] + -> Name + -> Q ([Type], TyVarMap1) +reifyConTys1 cRep auxs = reifyConTys cRep (map OneName auxs) + +reifyConTys2 :: ClassRep a + => a + -> [(Name, Name)] + -> Name + -> Q ([Type], TyVarMap2) +reifyConTys2 cRep auxs = reifyConTys cRep (map (\(x, y) -> TwoNames x y) auxs) + +{- +Note [Matching functions with GADT type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When deriving category-2 classes like Show2, there is a tricky corner case to consider: + + data Both a b where + BothCon :: x -> x -> Both x x + +Which show functions should be applied to which arguments of BothCon? We have a +choice, since both the function of type (Int -> a -> ShowS) and of type +(Int -> b -> ShowS) can be applied to either argument. In such a scenario, the +second show function takes precedence over the first show function, so the +derived Show2 instance would be: + + instance Show2 Both where + liftShowsPrec2 sp1 sp2 p (BothCon x1 x2) = + showsParen (p > appPrec) $ + showString "BothCon " . sp2 appPrec1 x1 . showSpace . sp2 appPrec1 x2 + +This is not an arbitrary choice, as this definition ensures that +liftShowsPrec2 showsPrec = liftShowsPrec for a derived Show1 instance for +Both. +-} + +------------------------------------------------------------------------------- +-- Error messages +------------------------------------------------------------------------------- + +-- | Either the given data type doesn't have enough type variables, or one of +-- the type variables to be eta-reduced cannot realize kind *. +derivingKindError :: ClassRep a => a -> Name -> Q b +derivingKindError cRep tyConName = fail + . showString "Cannot derive well-kinded instance of form ‘" + . showString className + . showChar ' ' + . showParen True + ( showString (nameBase tyConName) + . showString " ..." + ) + . showString "‘\n\tClass " + . showString className + . showString " expects an argument of kind " + . showString (pprint . createKindChain $ arity cRep) + $ "" + where + className :: String + className = nameBase $ fullClassName cRep + +-- | The last type variable appeared in a contravariant position +-- when deriving Functor. +contravarianceError :: Name -> Q a +contravarianceError conName = fail + . showString "Constructor ‘" + . showString (nameBase conName) + . showString "‘ must not use the last type variable in a function argument" + $ "" + +-- | A constructor has a function argument in a derived Foldable or Traversable +-- instance. +noFunctionsError :: Name -> Q a +noFunctionsError conName = fail + . showString "Constructor ‘" + . showString (nameBase conName) + . showString "‘ must not contain function types" + $ "" + +-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce +-- function for the criteria it would have to meet). +etaReductionError :: Type -> Q a +etaReductionError instanceType = fail $ + "Cannot eta-reduce to an instance of form \n\tinstance (...) => " + ++ pprint instanceType + +-- | The data type has a DatatypeContext which mentions one of the eta-reduced +-- type variables. +datatypeContextError :: Name -> Type -> Q a +datatypeContextError dataName instanceType = fail + . showString "Can't make a derived instance of ‘" + . showString (pprint instanceType) + . showString "‘:\n\tData type ‘" + . showString (nameBase dataName) + . showString "‘ must not have a class context involving the last type argument(s)" + $ "" + +-- | The data type has an existential constraint which mentions one of the +-- eta-reduced type variables. +existentialContextError :: Name -> Q a +existentialContextError conName = fail + . showString "Constructor ‘" + . showString (nameBase conName) + . showString "‘ must be truly polymorphic in the last argument(s) of the data type" + $ "" + +-- | The data type mentions one of the n eta-reduced type variables in a place other +-- than the last nth positions of a data type in a constructor's field. +outOfPlaceTyVarError :: ClassRep a => a -> Name -> Q b +outOfPlaceTyVarError cRep conName = fail + . showString "Constructor ‘" + . showString (nameBase conName) + . showString "‘ must only use its last " + . shows n + . showString " type variable(s) within the last " + . shows n + . showString " argument(s) of a data type" + $ "" + where + n :: Int + n = arity cRep + +-- | Template Haskell didn't list all of a data family's instances upon reification +-- until template-haskell-2.7.0.0, which is necessary for a derived instance to work. +dataConIError :: Q a +dataConIError = fail + . showString "Cannot use a data constructor." + . showString "\n\t(Note: if you are trying to derive for a data family instance," + . showString "\n\tuse GHC >= 7.4 instead.)" + $ "" + +------------------------------------------------------------------------------- -- Assorted utilities ------------------------------------------------------------------------------- +-- | A mapping of type variable Names to their auxiliary function Names. +type TyVarMap a = Map Name (OneOrTwoNames a) +type TyVarMap1 = TyVarMap One +type TyVarMap2 = TyVarMap Two + +data OneOrTwoNames a where + OneName :: Name -> OneOrTwoNames One + TwoNames :: Name -> Name -> OneOrTwoNames Two + +data One +data Two + +interleave :: [a] -> [a] -> [a] +interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s +interleave _ _ = [] + -- isRight and fromEither taken from the extra package (BSD3-licensed) -- | Test if an 'Either' value is the 'Right' constructor. @@ -289,12 +975,6 @@ concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM f xs = liftM concat (mapM f xs) --- | A mapping of type variable Names to their map function Names. For example, in a --- Functor declaration, a TyVarMap might look like (a ~> f), where --- a is the last type variable of the datatype, and f is the function which maps --- over a. -type TyVarMap = Map Name Name - thd3 :: (a, b, c) -> c thd3 (_, _, c) = c @@ -331,6 +1011,17 @@ applyClass con t = ClassP con [VarT t] #endif +createKindChain :: Int -> Kind +createKindChain = go starK + where + go :: Kind -> Int -> Kind + go k !0 = k +#if MIN_VERSION_template_haskell(2,8,0) + go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1) +#else + go k !n = go (ArrowK StarK k) (n - 1) +#endif + -- | Checks to see if the last types in a data family instance can be safely eta- -- reduced (i.e., dropped), given the other types. This checks for three conditions: -- @@ -496,39 +1187,84 @@ derivingCompatPackageKey = "deriving-compat-" ++ showVersion version #endif -mkDerivingCompatName_v :: String -> String -> Name -mkDerivingCompatName_v = mkNameG_v derivingCompatPackageKey +mkDerivingCompatName_v :: String -> Name +mkDerivingCompatName_v = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" fmapConstValName :: Name -fmapConstValName = mkDerivingCompatName_v "Data.Deriving.Internal" "fmapConst" +fmapConstValName = mkDerivingCompatName_v "fmapConst" foldrConstValName :: Name -foldrConstValName = mkDerivingCompatName_v "Data.Deriving.Internal" "foldrConst" +foldrConstValName = mkDerivingCompatName_v "foldrConst" foldMapConstValName :: Name -foldMapConstValName = mkDerivingCompatName_v "Data.Deriving.Internal" "foldMapConst" +foldMapConstValName = mkDerivingCompatName_v "foldMapConst" traverseConstValName :: Name -traverseConstValName = mkDerivingCompatName_v "Data.Deriving.Internal" "traverseConst" +traverseConstValName = mkDerivingCompatName_v "traverseConst" +showsPrecConstValName :: Name +showsPrecConstValName = mkDerivingCompatName_v "showsPrecConst" + +showsPrec1ConstValName :: Name +showsPrec1ConstValName = mkDerivingCompatName_v "showsPrec1Const" + +liftShowsPrecConstValName :: Name +liftShowsPrecConstValName = mkDerivingCompatName_v "liftShowsPrecConst" + +liftShowsPrec2ConstValName :: Name +liftShowsPrec2ConstValName = mkDerivingCompatName_v "liftShowsPrec2Const" + +cHashDataName :: Name +cHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "C#" + +dHashDataName :: Name +dHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "D#" + dualDataName :: Name dualDataName = mkNameG_d "base" "Data.Monoid" "Dual" endoDataName :: Name endoDataName = mkNameG_d "base" "Data.Monoid" "Endo" +fHashDataName :: Name +fHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "F#" + +iHashDataName :: Name +iHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "I#" + wrapMonadDataName :: Name wrapMonadDataName = mkNameG_d "base" "Control.Applicative" "WrapMonad" -functorTypeName :: Name -functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor" +-- addrHashTypeName :: Name +-- addrHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Addr#" +charHashTypeName :: Name +charHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Char#" + +doubleHashTypeName :: Name +doubleHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Double#" + +floatHashTypeName :: Name +floatHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Float#" + foldableTypeName :: Name foldableTypeName = mkNameG_tc "base" "Data.Foldable" "Foldable" +functorTypeName :: Name +functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor" + +intHashTypeName :: Name +intHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int#" + +showTypeName :: Name +showTypeName = mkNameG_tc "base" "GHC.Show" "Show" + traversableTypeName :: Name traversableTypeName = mkNameG_tc "base" "Data.Traversable" "Traversable" +wordHashTypeName :: Name +wordHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word#" + appEndoValName :: Name appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo" @@ -556,12 +1292,49 @@ idValName :: Name idValName = mkNameG_v "base" "GHC.Base" "id" +showCharValName :: Name +showCharValName = mkNameG_v "base" "GHC.Show" "showChar" + +showListValName :: Name +showListValName = mkNameG_v "base" "GHC.Show" "showList" + +showListWithValName :: Name +showListWithValName = mkNameG_v "base" "Text.Show" "showListWith" + +showParenValName :: Name +showParenValName = mkNameG_v "base" "GHC.Show" "showParen" + +showsPrecValName :: Name +showsPrecValName = mkNameG_v "base" "GHC.Show" "showsPrec" + +showSpaceValName :: Name +showSpaceValName = mkNameG_v "base" "GHC.Show" "showSpace" + +showStringValName :: Name +showStringValName = mkNameG_v "base" "GHC.Show" "showString" + traverseValName :: Name traverseValName = mkNameG_v "base" "Data.Traversable" "traverse" unwrapMonadValName :: Name unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "unwrapMonad" +#if MIN_VERSION_base(4,5,0) +ltValName :: Name +ltValName = mkNameG_v "ghc-prim" "GHC.Classes" ">" +#else +ltValName :: Name +ltValName = mkNameG_v "base" "GHC.Classes" ">" +#endif + +#if MIN_VERSION_base(4,6,0) +wHashDataName :: Name +wHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "W#" +#else +wHashDataName :: Name +wHashDataName = mkNameG_d "base" "GHC.Word" "W#" +#endif + #if MIN_VERSION_base(4,6,0) && !(MIN_VERSION_base(4,9,0)) starKindName :: Name starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*" @@ -591,4 +1364,60 @@ memptyValName :: Name memptyValName = mkNameG_v "base" "Data.Monoid" "mempty" +#endif + +#if MIN_VERSION_base(4,9,0) +show1TypeName :: Name +show1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Show1" + +show2TypeName :: Name +show2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Show2" + +liftShowListValName :: Name +liftShowListValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowList" + +liftShowsPrecValName :: Name +liftShowsPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowsPrec" + +liftShowList2ValName :: Name +liftShowList2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowList2" + +liftShowsPrec2ValName :: Name +liftShowsPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowsPrec2" +#else +-- If Data.Functor.Classes isn't located in base, then sadly we can't refer to +-- Names from that module without using -XTemplateHaskell. +# if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) +show1TypeName :: Name +show1TypeName = ''Show1 + +show2TypeName :: Name +show2TypeName = ''Show2 + +liftShowListValName :: Name +liftShowListValName = 'liftShowList + +liftShowsPrecValName :: Name +liftShowsPrecValName = 'liftShowsPrec + +liftShowList2ValName :: Name +liftShowList2ValName = 'liftShowList2 + +liftShowsPrec2ValName :: Name +liftShowsPrec2ValName = 'liftShowsPrec2 +# else +show1TypeName :: Name +show1TypeName = ''Show1 + +showsPrec1ValName :: Name +showsPrec1ValName = 'showsPrec1 + +newtype Apply f a = Apply { unApply :: f a } + +instance (Show1 f, Show a) => Show (Apply f a) where + showsPrec p (Apply x) = showsPrec1 p x + +applyDataName :: Name +applyDataName = mkNameG_d derivingCompatPackageKey "Data.Deriving.Internal" "Apply" +# endif #endif diff --git a/src/Data/Foldable/Deriving.hs b/src/Data/Foldable/Deriving.hs --- a/src/Data/Foldable/Deriving.hs +++ b/src/Data/Foldable/Deriving.hs @@ -28,13 +28,14 @@ . -} module Data.Foldable.Deriving ( - -- * 'deriveFoldable' limitations - -- $constraints + -- * 'Foldable' deriveFoldable , makeFoldMap , makeFoldr , makeFold , makeFoldl + -- * 'deriveFoldable' limitations + -- $constraints ) where import Data.Functor.Deriving.Internal @@ -47,6 +48,7 @@ existential constraint cannot mention the last type variable. For example, @data Illegal a = forall a. Show a => Illegal a@ cannot have a derived 'Functor' instance. + * Type variables of kind @* -> *@ are assumed to have 'Foldable' constraints. - If this is not desirable, use @makeFoldr@ or @makeFoldMap@. + If this is not desirable, use 'makeFoldr' or 'makeFoldMap'. -} diff --git a/src/Data/Functor/Deriving.hs b/src/Data/Functor/Deriving.hs --- a/src/Data/Functor/Deriving.hs +++ b/src/Data/Functor/Deriving.hs @@ -11,10 +11,11 @@ . -} module Data.Functor.Deriving ( - -- * 'deriveFunctor' limitations - -- $constraints + -- * 'Functor' deriveFunctor , makeFmap + -- * 'deriveFunctor' limitations + -- $constraints ) where import Data.Functor.Deriving.Internal @@ -24,5 +25,5 @@ Be aware of the following potential gotchas: * Type variables of kind @* -> *@ are assumed to have 'Functor' constraints. - If this is not desirable, use @makeFmap@'. + If this is not desirable, use 'makeFmap'. -} diff --git a/src/Data/Functor/Deriving/Internal.hs b/src/Data/Functor/Deriving/Internal.hs --- a/src/Data/Functor/Deriving/Internal.hs +++ b/src/Data/Functor/Deriving/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-| Module: Data.Functor.Deriving.Internal Copyright: (C) 2015-2016 Ryan Scott @@ -29,19 +29,15 @@ , makeSequence ) where -import Control.Monad (guard, unless, when, zipWithM) +import Control.Monad (guard, zipWithM) import Data.Deriving.Internal import Data.Either (rights) -#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0)) -import Data.Foldable (foldr') -#endif import Data.List -import qualified Data.Map as Map (fromList, keys, lookup, size) +import qualified Data.Map as Map (keys, lookup) import Data.Maybe import Language.Haskell.TH.Lib -import Language.Haskell.TH.Ppr import Language.Haskell.TH.Syntax -- | Generates a 'Foldable' instance declaration for the given data type or data @@ -195,14 +191,14 @@ makeFunctorFunForCon :: FunctorFun -> Name -> Name -> Con -> Q Match makeFunctorFunForCon ff z mapFun con = do let conName = constructorName con - (ts, tvMap) <- reifyConTys ff conName mapFun + (ts, tvMap) <- reifyConTys1 (functorFunToClass ff) [mapFun] conName argNames <- newNameList "_arg" $ length ts makeFunctorFunForArgs ff z tvMap conName ts argNames -- | Generates a lambda expression for a single constructor's arguments. makeFunctorFunForArgs :: FunctorFun -> Name - -> TyVarMap + -> TyVarMap1 -> Name -> [Type] -> [Name] @@ -219,7 +215,7 @@ -- The returned value is 'Right' if its type mentions the last type -- parameter. Otherwise, it is 'Left'. makeFunctorFunForArg :: FunctorFun - -> TyVarMap + -> TyVarMap1 -> Name -> Type -> Name @@ -231,17 +227,17 @@ -- 'Right' if its type mentions the last type parameter. Otherwise, -- it is 'Left'. makeFunctorFunForType :: FunctorFun - -> TyVarMap + -> TyVarMap1 -> Name -> Bool -> Type -> Q (Either Exp Exp) makeFunctorFunForType ff tvMap conName covariant (VarT tyName) = case Map.lookup tyName tvMap of - Just mapName -> fmap Right $ - if covariant - then varE mapName - else contravarianceError conName + Just (OneName mapName) -> + fmap Right $ if covariant + then varE mapName + else contravarianceError conName -- Invariant: this should only happen when deriving fmap Nothing -> fmap Left $ functorFunTriv ff makeFunctorFunForType ff tvMap conName covariant (SigT ty _) = @@ -270,9 +266,12 @@ makeFunctorFunForType ff tvMap conName covariant fieldTy `appEitherE` varE fieldName + fc :: FunctorClass + fc = functorFunToClass ff + in case tyCon of ArrowT - | not (allowFunTys (functorFunToClass ff)) -> noFunctionsError conName + | not (allowFunTys fc) -> noFunctionsError conName | mentionsTyArgs, [argTy, resTy] <- tyArgs -> do x <- newName "x" b <- newName "b" @@ -304,7 +303,7 @@ _ -> do itf <- isTyFamily tyCon if any (`mentionsName` tyVarNames) lhsArgs || (itf && mentionsTyArgs) - then outOfPlaceTyVarError conName + then outOfPlaceTyVarError fc conName else if any (`mentionsName` tyVarNames) rhsArgs then fmap Right . functorFunApp ff . appsE $ ( varE (functorFunName ff) @@ -314,564 +313,24 @@ else fmap Left $ functorFunTriv ff ------------------------------------------------------------------------------- --- Template Haskell reifying and AST manipulation -------------------------------------------------------------------------------- - --- | Boilerplate for top level splices. --- --- The given Name must meet one of two criteria: --- --- 1. It must be the name of a type constructor of a plain data type or newtype. --- 2. It must be the name of a data family instance or newtype instance constructor. --- --- Any other value will result in an exception. -withType :: Name - -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a) - -> Q a -withType name f = do - info <- reify name - case info of - TyConI dec -> - case dec of - DataD ctxt _ tvbs -#if MIN_VERSION_template_haskell(2,11,0) - _ -#endif - cons _ -> f name ctxt tvbs cons Nothing - NewtypeD ctxt _ tvbs -#if MIN_VERSION_template_haskell(2,11,0) - _ -#endif - con _ -> f name ctxt tvbs [con] Nothing - _ -> fail $ ns ++ "Unsupported type: " ++ show dec -#if MIN_VERSION_template_haskell(2,7,0) -# if MIN_VERSION_template_haskell(2,11,0) - DataConI _ _ parentName -> do -# else - DataConI _ _ parentName _ -> do -# endif - parentInfo <- reify parentName - case parentInfo of -# if MIN_VERSION_template_haskell(2,11,0) - FamilyI (DataFamilyD _ tvbs _) decs -> -# else - FamilyI (FamilyD DataFam _ tvbs _) decs -> -# endif - let instDec = flip find decs $ \dec -> case dec of - DataInstD _ _ _ -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - cons _ -> any ((name ==) . constructorName) cons - NewtypeInstD _ _ _ -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - con _ -> name == constructorName con - _ -> error $ ns ++ "Must be a data or newtype instance." - in case instDec of - Just (DataInstD ctxt _ instTys -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - cons _) - -> f parentName ctxt tvbs cons $ Just instTys - Just (NewtypeInstD ctxt _ instTys -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - con _) - -> f parentName ctxt tvbs [con] $ Just instTys - _ -> fail $ ns ++ - "Could not find data or newtype instance constructor." - _ -> fail $ ns ++ "Data constructor " ++ show name ++ - " is not from a data family instance constructor." -# if MIN_VERSION_template_haskell(2,11,0) - FamilyI DataFamilyD{} _ -> -# else - FamilyI (FamilyD DataFam _ _ _) _ -> -# endif - fail $ ns ++ - "Cannot use a data family name. Use a data family instance constructor instead." - _ -> fail $ ns ++ "The name must be of a plain data type constructor, " - ++ "or a data family instance constructor." -#else - DataConI{} -> dataConIError - _ -> fail $ ns ++ "The name must be of a plain type constructor." -#endif - where - ns :: String - ns = "Data.Functor.Deriving.Internal.withType: " - --- | Deduces the instance context and head for an instance. -buildTypeInstance :: FunctorClass - -- ^ Functor, Foldable, or Traversable - -> Name - -- ^ The type constructor or data family name - -> Cxt - -- ^ The datatype context - -> [TyVarBndr] - -- ^ The type variables from the data type/data family declaration - -> Maybe [Type] - -- ^ 'Just' the types used to instantiate a data family instance, - -- or 'Nothing' if it's a plain data type - -> Q (Cxt, Type) --- Plain data type/newtype case -buildTypeInstance fc tyConName dataCxt tvbs Nothing = - let varTys :: [Type] - varTys = map tvbToType tvbs - in buildTypeInstanceFromTys fc tyConName dataCxt varTys False --- Data family instance case --- --- The CPP is present to work around a couple of annoying old GHC bugs. --- See Note [Polykinded data families in Template Haskell] -buildTypeInstance fc parentName dataCxt tvbs (Just instTysAndKinds) = do -#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0) - let instTys :: [Type] - instTys = zipWith stealKindForType tvbs instTysAndKinds -#else - let kindVarNames :: [Name] - kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs - - numKindVars :: Int - numKindVars = length kindVarNames - - givenKinds, givenKinds' :: [Kind] - givenTys :: [Type] - (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds - givenKinds' = map sanitizeStars givenKinds - - -- A GHC 7.6-specific bug requires us to replace all occurrences of - -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it. - -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot. - sanitizeStars :: Kind -> Kind - sanitizeStars = go - where - go :: Kind -> Kind - go (AppT t1 t2) = AppT (go t1) (go t2) - go (SigT t k) = SigT (go t) (go k) - go (ConT n) | n == starKindName = StarT - go t = t - - -- If we run this code with GHC 7.8, we might have to generate extra type - -- variables to compensate for any type variables that Template Haskell - -- eta-reduced away. - -- See Note [Polykinded data families in Template Haskell] - xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys) - - let xTys :: [Type] - xTys = map VarT xTypeNames - -- ^ Because these type variables were eta-reduced away, we can only - -- determine their kind by using stealKindForType. Therefore, we mark - -- them as VarT to ensure they will be given an explicit kind annotation - -- (and so the kind inference machinery has the right information). - - substNamesWithKinds :: [(Name, Kind)] -> Type -> Type - substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks - - -- The types from the data family instance might not have explicit kind - -- annotations, which the kind machinery needs to work correctly. To - -- compensate, we use stealKindForType to explicitly annotate any - -- types without kind annotations. - instTys :: [Type] - instTys = map (substNamesWithKinds (zip kindVarNames givenKinds')) - -- ^ Note that due to a GHC 7.8-specific bug - -- (see Note [Polykinded data families in Template Haskell]), - -- there may be more kind variable names than there are kinds - -- to substitute. But this is OK! If a kind is eta-reduced, it - -- means that is was not instantiated to something more specific, - -- so we need not substitute it. Using stealKindForType will - -- grab the correct kind. - $ zipWith stealKindForType tvbs (givenTys ++ xTys) -#endif - buildTypeInstanceFromTys fc parentName dataCxt instTys True - --- For the given Types, generate an instance context and head. Coming up with --- the instance type isn't as simple as dropping the last type, as you need to --- be wary of kinds being instantiated with *. --- See Note [Type inference in derived instances] -buildTypeInstanceFromTys :: FunctorClass - -- ^ Functor, Foldable, or Traversable - -> Name - -- ^ The type constructor or data family name - -> Cxt - -- ^ The datatype context - -> [Type] - -- ^ The types to instantiate the instance with - -> Bool - -- ^ True if it's a data family, False otherwise - -> Q (Cxt, Type) -buildTypeInstanceFromTys fc tyConName dataCxt varTysOrig isDataFamily = do - -- Make sure to expand through type/kind synonyms! Otherwise, the - -- eta-reduction check might get tripped up over type variables in a - -- synonym that are actually dropped. - -- (See GHC Trac #11416 for a scenario where this actually happened.) - varTysExp <- mapM expandSyn varTysOrig - - let remainingLength :: Int - remainingLength = length varTysOrig - 1 - - droppedTysExp :: [Type] - droppedTysExp = drop remainingLength varTysExp - - droppedStarKindStati :: [StarKindStatus] - droppedStarKindStati = map canRealizeKindStar droppedTysExp - - -- Check there are enough types to drop and that all of them are either of - -- kind * or kind k (for some kind variable k). If not, throw an error. - when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $ - derivingKindError fc tyConName - - let droppedKindVarNames :: [Name] - droppedKindVarNames = catKindVarNames droppedStarKindStati - - -- Substitute kind * for any dropped kind variables - varTysExpSubst :: [Type] - varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp - - remainingTysExpSubst, droppedTysExpSubst :: [Type] - (remainingTysExpSubst, droppedTysExpSubst) = - splitAt remainingLength varTysExpSubst - - -- All of the type variables mentioned in the dropped types - -- (post-synonym expansion) - droppedTyVarNames :: [Name] - droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst - - -- If any of the dropped types were polykinded, ensure that they are of kind * - -- after substituting * for the dropped kind variables. If not, throw an error. - unless (all hasKindStar droppedTysExpSubst) $ - derivingKindError fc tyConName - - let preds :: [Maybe Pred] - kvNames :: [[Name]] - kvNames' :: [Name] - -- Derive instance constraints (and any kind variables which are specialized - -- to * in those constraints) - (preds, kvNames) = unzip $ map (deriveConstraint fc) remainingTysExpSubst - kvNames' = concat kvNames - - -- Substitute the kind variables specialized in the constraints with * - remainingTysExpSubst' :: [Type] - remainingTysExpSubst' = - map (substNamesWithKindStar kvNames') remainingTysExpSubst - - -- We now substitute all of the specialized-to-* kind variable names with - -- *, but in the original types, not the synonym-expanded types. The reason - -- we do this is a superficial one: we want the derived instance to resemble - -- the datatype written in source code as closely as possible. For example, - -- for the following data family instance: - -- - -- data family Fam a - -- newtype instance Fam String = Fam String - -- - -- We'd want to generate the instance: - -- - -- instance C (Fam String) - -- - -- Not: - -- - -- instance C (Fam [Char]) - remainingTysOrigSubst :: [Type] - remainingTysOrigSubst = - map (substNamesWithKindStar (union droppedKindVarNames kvNames')) - $ take remainingLength varTysOrig - - remainingTysOrigSubst' :: [Type] - -- See Note [Kind signatures in derived instances] for an explanation - -- of the isDataFamily check. - remainingTysOrigSubst' = - if isDataFamily - then remainingTysOrigSubst - else map unSigT remainingTysOrigSubst - - instanceCxt :: Cxt - instanceCxt = catMaybes preds - - instanceType :: Type - instanceType = AppT (ConT $ functorClassName fc) - $ applyTyCon tyConName remainingTysOrigSubst' - - -- If the datatype context mentions any of the dropped type variables, - -- we can't derive an instance, so throw an error. - when (any (`predMentionsName` droppedTyVarNames) dataCxt) $ - datatypeContextError tyConName instanceType - -- Also ensure the dropped types can be safely eta-reduced. Otherwise, - -- throw an error. - unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $ - etaReductionError instanceType - return (instanceCxt, instanceType) - --- | Attempt to derive a constraint on a Type. If successful, return --- Just the constraint and any kind variable names constrained to *. --- Otherwise, return Nothing and the empty list. --- --- See Note [Type inference in derived instances] for the heuristics used to --- come up with constraints. -deriveConstraint :: FunctorClass -> Type -> (Maybe Pred, [Name]) -deriveConstraint fc t - | not (isTyVar t) = (Nothing, []) - | otherwise = case hasKindVarChain 1 t of - Just ns -> (Just (applyClass (functorClassName fc) tName), ns) - Nothing -> (Nothing, []) - where - tName :: Name - tName = varTToName t - -{- -Note [Polykinded data families in Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In order to come up with the correct instance context and head for an instance, e.g., - - instance C a => C (Data a) where ... - -We need to know the exact types and kinds used to instantiate the instance. For -plain old datatypes, this is simple: every type must be a type variable, and -Template Haskell reliably tells us the type variables and their kinds. - -Doing the same for data families proves to be much harder for three reasons: - -1. On any version of Template Haskell, it may not tell you what an instantiated - type's kind is. For instance, in the following data family instance: - - data family Fam (f :: * -> *) (a :: *) - data instance Fam f a - - Then if we use TH's reify function, it would tell us the TyVarBndrs of the - data family declaration are: - - [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT] - - and the instantiated types of the data family instance are: - - [VarT f1,VarT a1] - - We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we - have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the - kind is in case an instantiated type isn't a SigT, so we use the stealKindForType - function to ensure all of the instantiated types are SigTs before passing them - to buildTypeInstanceFromTys. -2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of - the specified kinds of a data family instance efore any of the instantiated - types. Fortunately, this is easy to deal with: you simply count the number of - distinct kind variables in the data family declaration, take that many elements - from the front of the Types list of the data family instance, substitute the - kind variables with their respective instantiated kinds (which you took earlier), - and proceed as normal. -3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template - Haskell might not even list all of the Types of a data family instance, since - they are eta-reduced away! And yes, kinds can be eta-reduced too. - - The simplest workaround is to count how many instantiated types are missing from - the list and generate extra type variables to use in their place. Luckily, we - needn't worry much if its kind was eta-reduced away, since using stealKindForType - will get it back. - -Note [Kind signatures in derived instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -It is possible to put explicit kind signatures into the derived instances, e.g., - - instance C a => C (Data (f :: * -> *)) where ... - -But it is preferable to avoid this if possible. If we come up with an incorrect -kind signature (which is entirely possible, since our type inferencer is pretty -unsophisticated - see Note [Type inference in derived instances]), then GHC will -flat-out reject the instance, which is quite unfortunate. - -Plain old datatypes have the advantage that you can avoid using any kind signatures -at all in their instances. This is because a datatype declaration uses all type -variables, so the types that we use in a derived instance uniquely determine their -kinds. As long as we plug in the right types, the kind inferencer can do the rest -of the work. For this reason, we use unSigT to remove all kind signatures before -splicing in the instance context and head. - -Data family instances are trickier, since a data family can have two instances that -are distinguished by kind alone, e.g., - - data family Fam (a :: k) - data instance Fam (a :: * -> *) - data instance Fam (a :: *) - -If we dropped the kind signatures for C (Fam a), then GHC will have no way of -knowing which instance we are talking about. To avoid this scenario, we always -include explicit kind signatures in data family instances. There is a chance that -the inferred kind signatures will be incorrect, but if so, we can always fall back -on the make- functions. - -Note [Type inference in derived instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Type inference is can be tricky to get right, and we want to avoid recreating the -entirety of GHC's type inferencer in Template Haskell. For this reason, we will -probably never come up with derived instance contexts that are as accurate as -GHC's. But that doesn't mean we can't do anything! There are a couple of simple -things we can do to make instance contexts that work for 80% of use cases: - -1. If one of the last type parameters is polykinded, then its kind will be - specialized to * in the derived instance. We note what kind variable the type - parameter had and substitute it with * in the other types as well. For example, - imagine you had - - data Data (a :: k) (b :: k) (c :: k) - - Then you'd want to derived instance to be: - - instance C (Data (a :: *)) - - Not: - - instance C (Data (a :: k)) - -2. We naïvely come up with instance constraints using the following criterion: - - (i) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind - variables), then generate a Functor n constraint, and if k1/k2 are kind - variables, then substitute k1/k2 with * elsewhere in the types. We must - consider the case where they are kind variables because you might have a - scenario like this: - - newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) - = Compose (f (g a)) - - Which would have a derived Functor instance of: - - instance (Functor f, Functor g) => Functor (Compose f g) where ... --} - --- Determines the types of a constructor's arguments as well as the last type --- parameters (along with their map functions), expanding through any type synonyms. --- The type parameters are determined on a constructor-by-constructor basis since --- they may be refined to be particular types in a GADT. -reifyConTys :: FunctorFun - -> Name - -> Name - -> Q ([Type], TyVarMap) -reifyConTys ff conName mapFun = do - info <- reify conName - (ctxt, uncTy) <- case info of - DataConI _ ty _ -#if !(MIN_VERSION_template_haskell(2,11,0)) - _ -#endif - -> fmap uncurryTy (expandSyn ty) - _ -> fail "Must be a data constructor" - let (argTys, [resTy]) = splitAt (length uncTy - 1) uncTy - unapResTy = unapplyTy resTy - -- If one of the last type variables is refined to a particular type - -- (i.e., not truly polymorphic), we mark it with Nothing and filter - -- it out later, since we only apply map functions to arguments of - -- a type that it (1) one of the last type variables, and (2) - -- of a truly polymorphic type. - mbTvNames = map varTToName_maybe $ - drop (length unapResTy - 1) unapResTy - tvMap = Map.fromList - . catMaybes -- Drop refined types - $ zipWith (\mbTvName sp -> - fmap (\tvName -> (tvName, sp)) mbTvName) - mbTvNames [mapFun] - if (any (`predMentionsName` Map.keys tvMap) ctxt - || Map.size tvMap < 1) - && not (allowExQuant (functorFunToClass ff)) - then existentialContextError conName - else return (argTys, tvMap) - -------------------------------------------------------------------------------- --- Error messages +-- Class-specific constants ------------------------------------------------------------------------------- --- | Either the given data type doesn't have enough type variables, or one of --- the type variables to be eta-reduced cannot realize kind *. -derivingKindError :: FunctorClass -> Name -> Q a -derivingKindError fc tyConName = fail - . showString "Cannot derive well-kinded instance of form ‘" - . showString className - . showChar ' ' - . showParen True - ( showString (nameBase tyConName) - . showString " ..." - ) - . showString "‘\n\tClass " - . showString className - . showString " expects an argument of kind * -> *" - $ "" - where - className :: String - className = nameBase $ functorClassName fc - --- | The last type variable appeared in a contravariant position --- when deriving Functor. -contravarianceError :: Name -> Q a -contravarianceError conName = fail - . showString "Constructor ‘" - . showString (nameBase conName) - . showString "‘ must not use the last type variable in a function argument" - $ "" - --- | A constructor has a function argument in a derived Foldable or Traversable --- instance. -noFunctionsError :: Name -> Q a -noFunctionsError conName = fail - . showString "Constructor ‘" - . showString (nameBase conName) - . showString "‘ must not contain function types" - $ "" - --- | The data type has a DatatypeContext which mentions one of the eta-reduced --- type variables. -datatypeContextError :: Name -> Type -> Q a -datatypeContextError dataName instanceType = fail - . showString "Can't make a derived instance of ‘" - . showString (pprint instanceType) - . showString "‘:\n\tData type ‘" - . showString (nameBase dataName) - . showString "‘ must not have a class context involving the last type argument(s)" - $ "" - --- | The data type has an existential constraint which mentions one of the --- eta-reduced type variables. -existentialContextError :: Name -> Q a -existentialContextError conName = fail - . showString "Constructor ‘" - . showString (nameBase conName) - . showString "‘ must be truly polymorphic in the last argument(s) of the data type" - $ "" - --- | The data type mentions one of the n eta-reduced type variables in a place other --- than the last nth positions of a data type in a constructor's field. -outOfPlaceTyVarError :: Name -> Q a -outOfPlaceTyVarError conName = fail - . showString "Constructor ‘" - . showString (nameBase conName) - . showString "‘ must only use its last two type variable(s) within" - . showString " the last two argument(s) of a data type" - $ "" +-- | A representation of which class is being derived. +data FunctorClass = Functor | Foldable | Traversable --- | One of the last type variables cannot be eta-reduced (see the canEtaReduce --- function for the criteria it would have to meet). -etaReductionError :: Type -> Q a -etaReductionError instanceType = fail $ - "Cannot eta-reduce to an instance of form \n\tinstance (...) => " - ++ pprint instanceType +instance ClassRep FunctorClass where + arity _ = 1 -#if !(MIN_VERSION_template_haskell(2,7,0)) --- | Template Haskell didn't list all of a data family's instances upon reification --- until template-haskell-2.7.0.0, which is necessary for a derived instance to work. -dataConIError :: Q a -dataConIError = fail - . showString "Cannot use a data constructor." - . showString "\n\t(Note: if you are trying to derive for a data family instance," - . showString "\n\tuse GHC >= 7.4 instead.)" - $ "" -#endif + allowExQuant Foldable = True + allowExQuant _ = False -------------------------------------------------------------------------------- --- Class-specific constants -------------------------------------------------------------------------------- + fullClassName Functor = functorTypeName + fullClassName Foldable = foldableTypeName + fullClassName Traversable = traversableTypeName --- | A representation of which class is being derived. -data FunctorClass = Functor | Foldable | Traversable + classConstraint fClass 1 = Just $ fullClassName fClass + classConstraint _ _ = Nothing -- | A representation of which function is being generated. data FunctorFun = Fmap | Foldr | FoldMap | Traverse @@ -889,11 +348,6 @@ functorFunConstName FoldMap = foldMapConstValName functorFunConstName Traverse = traverseConstValName -functorClassName :: FunctorClass -> Name -functorClassName Functor = functorTypeName -functorClassName Foldable = foldableTypeName -functorClassName Traversable = traversableTypeName - functorFunName :: FunctorFun -> Name functorFunName Fmap = fmapValName functorFunName Foldr = foldrValName @@ -914,10 +368,6 @@ allowFunTys :: FunctorClass -> Bool allowFunTys Functor = True allowFunTys _ = False - -allowExQuant :: FunctorClass -> Bool -allowExQuant Foldable = True -allowExQuant _ = False -- See Trac #7436 for why explicit lambdas are used functorFunTriv :: FunctorFun -> Q Exp diff --git a/src/Data/Traversable/Deriving.hs b/src/Data/Traversable/Deriving.hs --- a/src/Data/Traversable/Deriving.hs +++ b/src/Data/Traversable/Deriving.hs @@ -27,13 +27,14 @@ . -} module Data.Traversable.Deriving ( - -- * 'deriveTraversable' limitations - -- $constraints + -- * 'Traversable' deriveTraversable , makeTraverse , makeSequenceA , makeMapM , makeSequence + -- * 'deriveTraversable' limitations + -- $constraints ) where import Data.Functor.Deriving.Internal @@ -46,6 +47,7 @@ existential constraint cannot mention the last type variable. For example, @data Illegal a = forall a. Show a => Illegal a@ cannot have a derived 'Traversable' instance. + * Type variables of kind @* -> *@ are assumed to have 'Traversable' constraints. - If this is not desirable, use @makeTraverse@. + If this is not desirable, use 'makeTraverse'. -} diff --git a/src/Text/Show/Deriving.hs b/src/Text/Show/Deriving.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Deriving.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE CPP #-} +{-| +Module: Text.Show.Deriving +Copyright: (C) 2015-2016 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Show', 'Show1', and 'Show2' instances. +-} +module Text.Show.Deriving ( + -- * 'Show' + deriveShow + , deriveShowOptions + , makeShowsPrec + , makeShowsPrecOptions + , makeShow + , makeShowOptions + , makeShowList + , makeShowListOptions + -- * 'Show1' + , deriveShow1 + , deriveShow1Options +#if defined(NEW_FUNCTOR_CLASSES) + , makeLiftShowsPrec + , makeLiftShowsPrecOptions + , makeLiftShowList + , makeLiftShowListOptions +#endif + , makeShowsPrec1 + , makeShowsPrec1Options +#if defined(NEW_FUNCTOR_CLASSES) + -- * 'Show2' + , deriveShow2 + , deriveShow2Options + , makeLiftShowsPrec2 + , makeLiftShowsPrec2Options + , makeLiftShowList2 + , makeLiftShowList2Options + , makeShowsPrec2 + , makeShowsPrec2Options +#endif + -- * 'Options' + , Options(..) + , defaultOptions + , legacyOptions + -- * 'deriveShow' limitations + -- $constraints + ) where + +import Text.Show.Deriving.Internal + +{- $constraints + +Be aware of the following potential gotchas: + +* Type variables of kind @*@ are assumed to have 'Show' constraints. + Type variables of kind @* -> *@ are assumed to have 'Show1' constraints. + Type variables of kind @* -> * -> *@ are assumed to have 'Show2' constraints. + If this is not desirable, use 'makeShowsPrec' or one of its cousins. + +* The 'Show1' class had a different definition in @transformers-0.4@, and as a result, + 'deriveShow1' implements different instances for the @transformers-0.4@ 'Show1' than + it otherwise does. Also, 'makeLiftShowsPrec' and 'makeLiftShowList' are not available + when this library is built against @transformers-0.4@, only 'makeShowsPrec1. + +* The 'Show2' class is not available in @transformers-0.4@, and as a + result, neither are Template Haskell functions that deal with 'Show2' when this + library is built against @transformers-0.4@. +-} diff --git a/src/Text/Show/Deriving/Internal.hs b/src/Text/Show/Deriving/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Text/Show/Deriving/Internal.hs @@ -0,0 +1,699 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-| +Module: Text.Show.Deriving.Internal +Copyright: (C) 2015-2016 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +Exports functions to mechanically derive 'Show', 'Show1', and 'Show2' instances. +-} +module Text.Show.Deriving.Internal ( + -- * 'Show' + deriveShow + , deriveShowOptions + , makeShowsPrec + , makeShowsPrecOptions + , makeShow + , makeShowOptions + , makeShowList + , makeShowListOptions + -- * 'Show1' + , deriveShow1 + , deriveShow1Options +#if defined(NEW_FUNCTOR_CLASSES) + , makeLiftShowsPrec + , makeLiftShowsPrecOptions + , makeLiftShowList + , makeLiftShowListOptions +#endif + , makeShowsPrec1 + , makeShowsPrec1Options +#if defined(NEW_FUNCTOR_CLASSES) + -- * 'Show2' + , deriveShow2 + , deriveShow2Options + , makeLiftShowsPrec2 + , makeLiftShowsPrec2Options + , makeLiftShowList2 + , makeLiftShowList2Options + , makeShowsPrec2 + , makeShowsPrec2Options +#endif + -- * 'Options' + , Options(..) + , defaultOptions + , legacyOptions + ) where + +#if MIN_VERSION_template_haskell(2,11,0) +import Control.Monad ((<=<)) +import Data.Maybe (fromMaybe, isJust) +#endif + +import Data.Deriving.Internal +import Data.List +import qualified Data.Map as Map + +#if __GLASGOW_HASKELL__ >= 800 +import GHC.Lexeme (startsConSym) +#endif +import GHC.Show (appPrec, appPrec1) + +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax + +-- | Options that further configure how the functions in "Text.Show.Deriving" +-- should behave. +newtype Options = Options + { ghc8ShowBehavior :: Bool + -- ^ If 'True', the derived 'Show', 'Show1', or 'Show2' instance will not + -- surround the output of showing fields of unlifted types with parentheses, + -- and the output will be suffixed with hash signs (@#@). + } deriving (Eq, Ord, Read, Show) + +-- | Options that match the behavior of the most recent GHC release. +defaultOptions :: Options +defaultOptions = Options { ghc8ShowBehavior = True } + +-- | Options that match the behavior of the installed version of GHC. +legacyOptions :: Options +legacyOptions = Options + { ghc8ShowBehavior = +#if __GLASGOW_HASKELL__ >= 711 + True +#else + False +#endif + } + +-- | Generates a 'Show' instance declaration for the given data type or data +-- family instance. +deriveShow :: Name -> Q [Dec] +deriveShow = deriveShowOptions defaultOptions + +-- | Like 'deriveShow', but takes an 'Options' argument. +deriveShowOptions :: Options -> Name -> Q [Dec] +deriveShowOptions = deriveShowClass Show + +-- | Generates a lambda expression which behaves like 'show' (without +-- requiring a 'Show' instance). +makeShow :: Name -> Q Exp +makeShow = makeShowOptions defaultOptions + +-- | Like 'makeShow', but takes an 'Options' argument. +makeShowOptions :: Options -> Name -> Q Exp +makeShowOptions opts name = do + x <- newName "x" + lam1E (varP x) $ makeShowsPrecOptions opts name + `appE` litE (integerL 0) + `appE` varE x + `appE` stringE "" + +-- | Generates a lambda expression which behaves like 'showsPrec' (without +-- requiring a 'Show' instance). +makeShowsPrec :: Name -> Q Exp +makeShowsPrec = makeShowsPrecOptions defaultOptions + +-- | Like 'makeShowsPrec', but takes an 'Options' argument. +makeShowsPrecOptions :: Options -> Name -> Q Exp +makeShowsPrecOptions = makeShowsPrecClass Show + +-- | Generates a lambda expression which behaves like 'showList' (without +-- requiring a 'Show' instance). +makeShowList :: Name -> Q Exp +makeShowList = makeShowListOptions defaultOptions + +-- | Like 'makeShowList', but takes an 'Options' argument. +makeShowListOptions :: Options -> Name -> Q Exp +makeShowListOptions opts name = + varE showListWithValName `appE` (makeShowsPrecOptions opts name `appE` litE (integerL 0)) + +-- | Generates a 'Show1' instance declaration for the given data type or data +-- family instance. +deriveShow1 :: Name -> Q [Dec] +deriveShow1 = deriveShow1Options defaultOptions + +-- | Like 'deriveShow1', but takes an 'Options' argument. +deriveShow1Options :: Options -> Name -> Q [Dec] +deriveShow1Options = deriveShowClass Show1 + +-- | Generates a lambda expression which behaves like 'showsPrec1' (without +-- requiring a 'Show1' instance). +makeShowsPrec1 :: Name -> Q Exp +makeShowsPrec1 = makeShowsPrec1Options defaultOptions + +#if defined(NEW_FUNCTOR_CLASSES) +-- | Generates a lambda expression which behaves like 'liftShowsPrec' (without +-- requiring a 'Show1' instance). +-- +-- This function is not available with @transformers-0.4@. +makeLiftShowsPrec :: Name -> Q Exp +makeLiftShowsPrec = makeLiftShowsPrecOptions defaultOptions + +-- | Like 'makeLiftShowsPrec', but takes an 'Options' argument. +-- +-- This function is not available with @transformers-0.4@. +makeLiftShowsPrecOptions :: Options -> Name -> Q Exp +makeLiftShowsPrecOptions = makeShowsPrecClass Show1 + +-- | Generates a lambda expression which behaves like 'liftShowList' (without +-- requiring a 'Show' instance). +-- +-- This function is not available with @transformers-0.4@. +makeLiftShowList :: Name -> Q Exp +makeLiftShowList = makeLiftShowListOptions defaultOptions + +-- | Like 'makeLiftShowList', but takes an 'Options' argument. +-- +-- This function is not available with @transformers-0.4@. +makeLiftShowListOptions :: Options -> Name -> Q Exp +makeLiftShowListOptions opts name = do + sp' <- newName "sp'" + sl' <- newName "sl'" + lamE [varP sp', varP sl'] $ varE showListWithValName `appE` + (makeLiftShowsPrecOptions opts name `appE` varE sp' `appE` varE sl' + `appE` litE (integerL 0)) + +-- | Like 'makeShowsPrec1', but takes an 'Options' argument. +makeShowsPrec1Options :: Options -> Name -> Q Exp +makeShowsPrec1Options opts name = makeLiftShowsPrecOptions opts name + `appE` varE showsPrecValName + `appE` varE showListValName +#else +-- | Like 'makeShowsPrec1', but takes an 'Options' argument. +makeShowsPrec1Options :: Options -> Name -> Q Exp +makeShowsPrec1Options = makeShowsPrecClass Show1 +#endif + +#if defined(NEW_FUNCTOR_CLASSES) +-- | Generates a 'Show2' instance declaration for the given data type or data +-- family instance. +-- +-- This function is not available with @transformers-0.4@. +deriveShow2 :: Name -> Q [Dec] +deriveShow2 = deriveShow2Options defaultOptions + +-- | Like 'deriveShow2', but takes an 'Options' argument. +-- +-- This function is not available with @transformers-0.4@. +deriveShow2Options :: Options -> Name -> Q [Dec] +deriveShow2Options = deriveShowClass Show2 + +-- | Generates a lambda expression which behaves like 'liftShowsPrec2' (without +-- requiring a 'Show2' instance). +-- +-- This function is not available with @transformers-0.4@. +makeLiftShowsPrec2 :: Name -> Q Exp +makeLiftShowsPrec2 = makeLiftShowsPrec2Options defaultOptions + +-- | Like 'makeLiftShowsPrec2', but takes an 'Options' argument. +-- +-- This function is not available with @transformers-0.4@. +makeLiftShowsPrec2Options :: Options -> Name -> Q Exp +makeLiftShowsPrec2Options = makeShowsPrecClass Show2 + +-- | Generates a lambda expression which behaves like 'liftShowList2' (without +-- requiring a 'Show' instance). +-- +-- This function is not available with @transformers-0.4@. +makeLiftShowList2 :: Name -> Q Exp +makeLiftShowList2 = makeLiftShowList2Options defaultOptions + +-- | Like 'makeLiftShowList2', but takes an 'Options' argument. +-- +-- This function is not available with @transformers-0.4@. +makeLiftShowList2Options :: Options -> Name -> Q Exp +makeLiftShowList2Options opts name = do + sp1' <- newName "sp1'" + sl1' <- newName "sl1'" + sp2' <- newName "sp2'" + sl2' <- newName "sl2'" + lamE [varP sp1', varP sl1', varP sp2', varP sl2'] $ + varE showListWithValName `appE` + (makeLiftShowsPrec2Options opts name `appE` varE sp1' `appE` varE sl1' + `appE` varE sp2' `appE` varE sl2' + `appE` litE (integerL 0)) + +-- | Generates a lambda expression which behaves like 'showsPrec2' (without +-- requiring a 'Show2' instance). +-- +-- This function is not available with @transformers-0.4@. +makeShowsPrec2 :: Name -> Q Exp +makeShowsPrec2 = makeShowsPrec2Options defaultOptions + +-- | Like 'makeShowsPrec2', but takes an 'Options' argument. +-- +-- This function is not available with @transformers-0.4@. +makeShowsPrec2Options :: Options -> Name -> Q Exp +makeShowsPrec2Options opts name = makeLiftShowsPrec2Options opts name + `appE` varE showsPrecValName + `appE` varE showListValName + `appE` varE showsPrecValName + `appE` varE showListValName +#endif + +------------------------------------------------------------------------------- +-- Code generation +------------------------------------------------------------------------------- + +-- | Derive a Show(1)(2) instance declaration (depending on the ShowClass +-- argument's value). +deriveShowClass :: ShowClass -> Options -> Name -> Q [Dec] +deriveShowClass sClass opts name = withType name fromCons + where + fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] + fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do + (instanceCxt, instanceType) + <- buildTypeInstance sClass name' ctxt tvbs mbTys + instanceD (return instanceCxt) + (return instanceType) + (showsPrecDecs sClass opts cons) + +-- | Generates a declaration defining the primary function corresponding to a +-- particular class (showsPrec for Show, liftShowsPrec for Show1, and +-- liftShowsPrec2 for Show2). +showsPrecDecs :: ShowClass -> Options -> [Con] -> [Q Dec] +showsPrecDecs sClass opts cons = + [ funD (showsPrecName sClass) + [ clause [] + (normalB $ makeShowForCons sClass opts cons) + [] + ] + ] + +-- | Generates a lambda expression which behaves like showsPrec (for Show), +-- liftShowsPrec (for Show1), or liftShowsPrec2 (for Show2). +makeShowsPrecClass :: ShowClass -> Options -> Name -> Q Exp +makeShowsPrecClass sClass opts name = withType name fromCons + where + fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp + fromCons name' ctxt tvbs cons mbTys = + -- We force buildTypeInstance here since it performs some checks for whether + -- or not the provided datatype can actually have showsPrec/liftShowsPrec/etc. + -- implemented for it, and produces errors if it can't. + buildTypeInstance sClass name' ctxt tvbs mbTys + `seq` makeShowForCons sClass opts cons + +-- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for the +-- given constructors. All constructors must be from the same type. +makeShowForCons :: ShowClass -> Options -> [Con] -> Q Exp +makeShowForCons _ _ [] = error "Must have at least one data constructor" +makeShowForCons sClass opts cons = do + p <- newName "p" + value <- newName "value" + sps <- newNameList "sp" $ arity sClass + sls <- newNameList "sl" $ arity sClass + let spls = zip sps sls + _spsAndSls = interleave sps sls + matches <- concatMapM (makeShowForCon p sClass opts spls) cons + lamE (map varP $ +#if defined(NEW_FUNCTOR_CLASSES) + _spsAndSls ++ +#endif + [p, value]) + . appsE + $ [ varE $ showsPrecConstName sClass + , caseE (varE value) (map return matches) + ] +#if defined(NEW_FUNCTOR_CLASSES) + ++ map varE _spsAndSls +#endif + ++ [varE p, varE value] + +-- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for a +-- single constructor. +makeShowForCon :: Name -> ShowClass -> Options -> [(Name, Name)] -> Con -> Q [Match] +makeShowForCon _ sClass _ spls (NormalC conName []) = do + ([], _) <- reifyConTys2 sClass spls conName + m <- match + (conP conName []) + (normalB $ varE showStringValName `appE` stringE (parenInfixConName conName "")) + [] + return [m] +makeShowForCon p sClass opts spls (NormalC conName [_]) = do + ([argTy], tvMap) <- reifyConTys2 sClass spls conName + arg <- newName "arg" + + let showArg = makeShowForArg appPrec1 sClass opts conName tvMap argTy arg + namedArg = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " ")) + (varE composeValName) + showArg + + m <- match + (conP conName [varP arg]) + (normalB $ varE showParenValName + `appE` infixApp (varE p) + (varE ltValName) + (litE . integerL $ fromIntegral appPrec) + `appE` namedArg) + [] + return [m] +makeShowForCon p sClass opts spls (NormalC conName _) = do + (argTys, tvMap) <- reifyConTys2 sClass spls conName + args <- newNameList "arg" $ length argTys + + m <- if isNonUnitTuple conName + then do + let showArgs = zipWith (makeShowForArg 0 sClass opts conName tvMap) argTys args + parenCommaArgs = (varE showCharValName `appE` litE (charL '(')) + : intersperse (varE showCharValName `appE` litE (charL ',')) showArgs + mappendArgs = foldr (`infixApp` varE composeValName) + (varE showCharValName `appE` litE (charL ')')) + parenCommaArgs + + match (conP conName $ map varP args) + (normalB mappendArgs) + [] + else do + let showArgs = zipWith (makeShowForArg appPrec1 sClass opts conName tvMap) argTys args + mappendArgs = foldr1 (\v q -> infixApp v (varE composeValName) + (infixApp (varE showSpaceValName) + (varE composeValName) + q)) showArgs + namedArgs = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " ")) + (varE composeValName) + mappendArgs + + match (conP conName $ map varP args) + (normalB $ varE showParenValName + `appE` infixApp (varE p) + (varE ltValName) + (litE . integerL $ fromIntegral appPrec) + `appE` namedArgs) + [] + return [m] +makeShowForCon p sClass opts spls (RecC conName []) = + makeShowForCon p sClass opts spls $ NormalC conName [] +makeShowForCon p sClass opts spls (RecC conName ts) = do + (argTys, tvMap) <- reifyConTys2 sClass spls conName + args <- newNameList "arg" $ length argTys + + let showArgs = concatMap (\((argName, _, _), argTy, arg) + -> [ varE showStringValName `appE` stringE (nameBase argName ++ " = ") + , makeShowForArg 0 sClass opts conName tvMap argTy arg + , varE showStringValName `appE` stringE ", " + ] + ) + (zip3 ts argTys args) + braceCommaArgs = (varE showCharValName `appE` litE (charL '{')) : take (length showArgs - 1) showArgs + mappendArgs = foldr (`infixApp` varE composeValName) + (varE showCharValName `appE` litE (charL '}')) + braceCommaArgs + namedArgs = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " ")) + (varE composeValName) + mappendArgs + + m <- match + (conP conName $ map varP args) + (normalB $ varE showParenValName + `appE` infixApp (varE p) + (varE ltValName) + (litE . integerL $ fromIntegral appPrec) + `appE` namedArgs) + [] + return [m] +makeShowForCon p sClass opts spls (InfixC _ conName _) = do + ([alTy, arTy], tvMap) <- reifyConTys2 sClass spls conName + al <- newName "argL" + ar <- newName "argR" + info <- reify conName + +#if __GLASGOW_HASKELL__ >= 711 + conPrec <- case info of + DataConI{} -> do + fi <- fromMaybe defaultFixity <$> reifyFixity conName + case fi of + Fixity prec _ -> return prec +#else + let conPrec = case info of + DataConI _ _ _ (Fixity prec _) -> prec +#endif + _ -> error $ "Text.Show.Deriving.Internal.makeShowForCon: Unsupported type: " ++ show info + + let opName = nameBase conName + infixOpE = appE (varE showStringValName) . stringE $ + if isInfixTypeCon opName + then " " ++ opName ++ " " + else " `" ++ opName ++ "` " + + m <- match + (infixP (varP al) conName (varP ar)) + (normalB $ (varE showParenValName `appE` infixApp (varE p) + (varE ltValName) + (litE . integerL $ fromIntegral conPrec)) + `appE` (infixApp (makeShowForArg (conPrec + 1) sClass opts conName tvMap alTy al) + (varE composeValName) + (infixApp infixOpE + (varE composeValName) + (makeShowForArg (conPrec + 1) sClass opts conName tvMap arTy ar))) + ) + [] + return [m] +makeShowForCon p sClass opts spls (ForallC _ _ con) = + makeShowForCon p sClass opts spls con +#if MIN_VERSION_template_haskell(2,11,0) +makeShowForCon p sClass opts spls (GadtC conNames ts _) = + let con :: Name -> Q Con + con conName = do + mbFi <- reifyFixity conName + return $ if startsConSym (head $ nameBase conName) + && length ts == 2 + && isJust mbFi + then let [t1, t2] = ts in InfixC t1 conName t2 + else NormalC conName ts + + in concatMapM (makeShowForCon p sClass opts spls <=< con) conNames +makeShowForCon p sClass opts spls (RecGadtC conNames ts _) = + concatMapM (makeShowForCon p sClass opts spls . flip RecC ts) conNames +#endif + +-- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for an +-- argument of a constructor. +makeShowForArg :: Int + -> ShowClass + -> Options + -> Name + -> TyVarMap2 + -> Type + -> Name + -> Q Exp +makeShowForArg p _ opts _ _ (ConT tyName) tyExpName = + showE + where + tyVarE :: Q Exp + tyVarE = varE tyExpName + + showE :: Q Exp + showE | tyName == charHashTypeName = showPrimE cHashDataName oneHashE + | tyName == doubleHashTypeName = showPrimE dHashDataName twoHashE + | tyName == floatHashTypeName = showPrimE fHashDataName oneHashE + | tyName == intHashTypeName = showPrimE iHashDataName oneHashE + | tyName == wordHashTypeName = showPrimE wHashDataName twoHashE + | otherwise = varE showsPrecValName + `appE` litE (integerL $ fromIntegral p) + `appE` tyVarE + + -- Starting with GHC 7.10, data types containing unlifted types with derived Show + -- instances show hashed literals with actual hash signs, and negative hashed + -- literals are not surrounded with parentheses. + showPrimE :: Name -> Q Exp -> Q Exp + showPrimE con hashE + | ghc8ShowBehavior opts + = infixApp (varE showsPrecValName + `appE` litE (integerL 0) + `appE` (conE con `appE` tyVarE)) + (varE composeValName) + hashE + | otherwise = varE showsPrecValName + `appE` litE (integerL $ fromIntegral p) + `appE` tyVarE + + oneHashE, twoHashE :: Q Exp + oneHashE = varE showCharValName `appE` litE (charL '#') + twoHashE = varE showStringValName `appE` stringE "##" +makeShowForArg p sClass _ conName tvMap ty tyExpName = + makeShowForType sClass conName tvMap False ty + `appE` litE (integerL $ fromIntegral p) + `appE` varE tyExpName + +-- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for a +-- specific type. The generated expression depends on the number of type variables. +-- +-- 1. If the type is of kind * (T), apply showsPrec. +-- 2. If the type is of kind * -> * (T a), apply liftShowsPrec $(makeShowForType a) +-- 3. If the type is of kind * -> * -> * (T a b), apply +-- liftShowsPrec2 $(makeShowForType a) $(makeShowForType b) +makeShowForType :: ShowClass + -> Name + -> TyVarMap2 + -> Bool -- ^ True if we are using the function of type ([a] -> ShowS), + -- False if we are using the function of type (Int -> a -> ShowS). + -> Type + -> Q Exp +#if defined(NEW_FUNCTOR_CLASSES) +makeShowForType _ _ tvMap sl (VarT tyName) = + varE $ case Map.lookup tyName tvMap of + Just (TwoNames spExp slExp) -> if sl then slExp else spExp + Nothing -> if sl then showListValName else showsPrecValName +#else +makeShowForType _ _ _ _ VarT{} = varE showsPrecValName +#endif +makeShowForType sClass conName tvMap sl (SigT ty _) = makeShowForType sClass conName tvMap sl ty +makeShowForType sClass conName tvMap sl (ForallT _ _ ty) = makeShowForType sClass conName tvMap sl ty +#if defined(NEW_FUNCTOR_CLASSES) +makeShowForType sClass conName tvMap sl ty = do + let tyCon :: Type + tyArgs :: [Type] + tyCon:tyArgs = unapplyTy ty + + numLastArgs :: Int + numLastArgs = min (arity sClass) (length tyArgs) + + lhsArgs, rhsArgs :: [Type] + (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs + + tyVarNames :: [Name] + tyVarNames = Map.keys tvMap + + itf <- isTyFamily tyCon + if any (`mentionsName` tyVarNames) lhsArgs + || itf && any (`mentionsName` tyVarNames) tyArgs + then outOfPlaceTyVarError sClass conName + else appsE $ [ varE . showsPrecOrListName sl $ toEnum numLastArgs] + ++ zipWith (makeShowForType sClass conName tvMap) + (cycle [False,True]) + (interleave rhsArgs rhsArgs) +#else +makeShowForType sClass conName tvMap _ ty = do + let varNames = Map.keys tvMap + + p' <- newName "p'" + value' <- newName "value'" + case varNames of + [] -> varE showsPrecValName + varName:_ -> + if mentionsName ty varNames + then lamE [varP p', varP value'] $ varE showsPrec1ValName + `appE` varE p' + `appE` (makeFmapApply sClass conName ty varName `appE` varE value') + else varE showsPrecValName +#endif + +#if !defined(NEW_FUNCTOR_CLASSES) +makeFmapApply :: ShowClass -> Name -> Type -> Name -> Q Exp +makeFmapApply sClass conName (SigT ty _) name = makeFmapApply sClass conName ty name +makeFmapApply sClass conName t name = do + let tyCon :: Type + tyArgs :: [Type] + tyCon:tyArgs = unapplyTy t + + numLastArgs :: Int + numLastArgs = min (arity sClass) (length tyArgs) + + lhsArgs, rhsArgs :: [Type] + (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs + + inspectTy :: Type -> Q Exp + inspectTy (SigT ty _) = inspectTy ty + inspectTy (VarT a) | a == name = varE idValName + inspectTy beta = varE fmapValName `appE` + infixApp (conE applyDataName) + (varE composeValName) + (makeFmapApply sClass conName beta name) + + itf <- isTyFamily tyCon + if any (`mentionsName` [name]) lhsArgs + || itf && any (`mentionsName` [name]) tyArgs + then outOfPlaceTyVarError sClass conName + else inspectTy (head rhsArgs) +#endif + +------------------------------------------------------------------------------- +-- Class-specific constants +------------------------------------------------------------------------------- + +-- | A representation of which @Show@ variant is being derived. +data ShowClass = Show + | Show1 +#if defined(NEW_FUNCTOR_CLASSES) + | Show2 +#endif + deriving (Bounded, Enum) + +instance ClassRep ShowClass where + arity = fromEnum + + allowExQuant _ = True + + fullClassName Show = showTypeName + fullClassName Show1 = show1TypeName +#if defined(NEW_FUNCTOR_CLASSES) + fullClassName Show2 = show2TypeName +#endif + + classConstraint sClass i + | sMin <= i && i <= sMax = Just $ fullClassName (toEnum i :: ShowClass) + | otherwise = Nothing + where + sMin, sMax :: Int + sMin = fromEnum (minBound :: ShowClass) + sMax = fromEnum sClass + +showsPrecConstName :: ShowClass -> Name +showsPrecConstName Show = showsPrecConstValName +#if defined(NEW_FUNCTOR_CLASSES) +showsPrecConstName Show1 = liftShowsPrecConstValName +showsPrecConstName Show2 = liftShowsPrec2ConstValName +#else +showsPrecConstName Show1 = showsPrec1ConstValName +#endif + +showsPrecName :: ShowClass -> Name +showsPrecName Show = showsPrecValName +#if defined(NEW_FUNCTOR_CLASSES) +showsPrecName Show1 = liftShowsPrecValName +showsPrecName Show2 = liftShowsPrec2ValName +#else +showsPrecName Show1 = showsPrec1ValName +#endif + +#if defined(NEW_FUNCTOR_CLASSES) +showListName :: ShowClass -> Name +showListName Show = showListValName +showListName Show1 = liftShowListValName +showListName Show2 = liftShowList2ValName + +showsPrecOrListName :: Bool -- ^ showListName if True, showsPrecName if False + -> ShowClass + -> Name +showsPrecOrListName False = showsPrecName +showsPrecOrListName True = showListName +#endif + +------------------------------------------------------------------------------- +-- Assorted utilities +------------------------------------------------------------------------------- + +-- | Checks if a 'Name' represents a tuple type constructor (other than '()') +isNonUnitTuple :: Name -> Bool +isNonUnitTuple = isTupleString . nameBase + +-- | Parenthesize an infix constructor name if it is being applied as a prefix +-- function (e.g., data Amp a = (:&) a a) +parenInfixConName :: Name -> ShowS +parenInfixConName conName = + let conNameBase = nameBase conName + in showParen (isInfixTypeCon conNameBase) $ showString conNameBase + +-- | Checks if a 'String' names a valid Haskell infix type constructor (i.e., does +-- it begin with a colon?). +isInfixTypeCon :: String -> Bool +isInfixTypeCon (':':_) = True +isInfixTypeCon _ = False + +-- | Checks if a 'String' represents a tuple (other than '()') +isTupleString :: String -> Bool +isTupleString ('(':',':_) = True +isTupleString _ = False diff --git a/tests/DerivingSpec.hs b/tests/DerivingSpec.hs deleted file mode 100644 --- a/tests/DerivingSpec.hs +++ /dev/null @@ -1,318 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-unused-matches #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -Wno-unused-foralls #-} -#endif - -{-| -Module: DerivingSpec -Copyright: (C) 2015-2016 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Portability: Template Haskell - -@hspec@ tests for @deriving-compat@. --} -module DerivingSpec where - -import Data.Char (chr) -import Data.Deriving -import Data.Foldable (fold) -import Data.Functor.Classes (Eq1) -import Data.Functor.Compose (Compose(..)) -import Data.Functor.Identity (Identity(..)) -import Data.Monoid -import Data.Orphans () - -import GHC.Exts (Int#) - -import Prelude () -import Prelude.Compat - -import Test.Hspec -import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck (Arbitrary) - -------------------------------------------------------------------------------- - --- Adapted from the test cases from --- https://ghc.haskell.org/trac/ghc/attachment/ticket/2953/deriving-functor-tests.patch - --- Plain data types - -data Strange a b c - = T1 a b c - | T2 [a] [b] [c] -- lists - | T3 [[a]] [[b]] [[c]] -- nested lists - | T4 (c,(b,b),(c,c)) -- tuples - | T5 ([c],Strange a b c) -- tycons - -type IntFun a b = (b -> Int) -> a -data StrangeFunctions a b c - = T6 (a -> c) -- function types - | T7 (a -> (c,a)) -- functions and tuples - | T8 ((b -> a) -> c) -- continuation - | T9 (IntFun b c) -- type synonyms - -data StrangeGADT a b where - T10 :: Ord d => d -> StrangeGADT c d - T11 :: Int -> StrangeGADT e Int - T12 :: c ~ Int => c -> StrangeGADT f Int - T13 :: i ~ Int => Int -> StrangeGADT h i - T14 :: k ~ Int => k -> StrangeGADT j k - T15 :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADT m n - -data NotPrimitivelyRecursive a b - = S1 (NotPrimitivelyRecursive (a,a) (b, a)) - | S2 a - | S3 b - -newtype OneTwoCompose f g a b = OneTwoCompose (Either (f (g a)) (f (g b))) - deriving (Arbitrary, Eq, Show) - -newtype ComplexConstraint f g a b = ComplexConstraint (f Int Int (g a,a,b)) - -data Universal a b - = Universal (forall b. (b,[a])) - | Universal2 (forall f. Functor (f a) => f a b) - | Universal3 (forall a. Maybe a) -- reuse a - | NotReallyUniversal (forall b. a) - -data Existential a b - = forall a. ExistentialList [a] - | forall f. Traversable (f a) => ExistentialFunctor (f a b) - | forall b. SneakyUseSameName (Maybe b) - -data IntHash a b - = IntHash Int# Int# - | IntHashTuple Int# a b (a, b, Int, IntHash Int (a, b, Int)) - -data IntHashFun a b - = IntHashFun ((((a -> Int#) -> b) -> Int#) -> a) - --- Data families - -data family StrangeFam x y z -data instance StrangeFam a b c - = T1Fam a b c - | T2Fam [a] [b] [c] -- lists - | T3Fam [[a]] [[b]] [[c]] -- nested lists - | T4Fam (c,(b,b),(c,c)) -- tuples - | T5Fam ([c],Strange a b c) -- tycons - -data family StrangeFunctionsFam x y z -data instance StrangeFunctionsFam a b c - = T6Fam (a -> c) -- function types - | T7Fam (a -> (c,a)) -- functions and tuples - | T8Fam ((b -> a) -> c) -- continuation - | T9Fam (IntFun b c) -- type synonyms - -data family StrangeGADTFam x y -data instance StrangeGADTFam a b where - T10Fam :: Ord d => d -> StrangeGADTFam c d - T11Fam :: Int -> StrangeGADTFam e Int - T12Fam :: c ~ Int => c -> StrangeGADTFam f Int - T13Fam :: i ~ Int => Int -> StrangeGADTFam h i - T14Fam :: k ~ Int => k -> StrangeGADTFam j k - T15Fam :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADTFam m n - -data family NotPrimitivelyRecursiveFam x y -data instance NotPrimitivelyRecursiveFam a b - = S1Fam (NotPrimitivelyRecursive (a,a) (b, a)) - | S2Fam a - | S3Fam b - -data family OneTwoComposeFam (j :: * -> *) (k :: * -> *) x y -newtype instance OneTwoComposeFam f g a b = - OneTwoComposeFam (Either (f (g a)) (f (g b))) - deriving (Arbitrary, Eq, Show) - -data family ComplexConstraintFam (j :: * -> * -> * -> *) (k :: * -> *) x y -newtype instance ComplexConstraintFam f g a b = ComplexConstraintFam (f Int Int (g a,a,b)) - -data family UniversalFam x y -data instance UniversalFam a b - = UniversalFam (forall b. (b,[a])) - | Universal2Fam (forall f. Functor (f a) => f a b) - | Universal3Fam (forall a. Maybe a) -- reuse a - | NotReallyUniversalFam (forall b. a) - -data family ExistentialFam x y -data instance ExistentialFam a b - = forall a. ExistentialListFam [a] - | forall f. Traversable (f a) => ExistentialFunctorFam (f a b) - | forall b. SneakyUseSameNameFam (Maybe b) - -data family IntHashFam x y -data instance IntHashFam a b - = IntHashFam Int# Int# - | IntHashTupleFam Int# a b (a, b, Int, IntHashFam Int (a, b, Int)) - -data family IntHashFunFam x y -data instance IntHashFunFam a b - = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a) - -------------------------------------------------------------------------------- - --- Plain data types - -$(deriveFunctor ''Strange) -$(deriveFoldable ''Strange) -$(deriveTraversable ''Strange) - -$(deriveFunctor ''StrangeFunctions) -$(deriveFoldable ''StrangeGADT) - -$(deriveFunctor ''NotPrimitivelyRecursive) -$(deriveFoldable ''NotPrimitivelyRecursive) -$(deriveTraversable ''NotPrimitivelyRecursive) - -$(deriveFunctor ''OneTwoCompose) -$(deriveFoldable ''OneTwoCompose) -$(deriveTraversable ''OneTwoCompose) - -instance Functor (f Int Int) => Functor (ComplexConstraint f g a) where - fmap = $(makeFmap ''ComplexConstraint) -instance Foldable (f Int Int) => Foldable (ComplexConstraint f g a) where - foldr = $(makeFoldr ''ComplexConstraint) - foldMap = $(makeFoldMap ''ComplexConstraint) -instance Traversable (f Int Int) => Traversable (ComplexConstraint f g a) where - traverse = $(makeTraverse ''ComplexConstraint) - -$(deriveFunctor ''Universal) - -$(deriveFunctor ''Existential) -$(deriveFoldable ''Existential) -$(deriveTraversable ''Existential) - -$(deriveFunctor ''IntHash) -$(deriveFoldable ''IntHash) -$(deriveTraversable ''IntHash) - -$(deriveFunctor ''IntHashFun) - -#if MIN_VERSION_template_haskell(2,7,0) --- Data families - -$(deriveFunctor 'T1Fam) -$(deriveFoldable 'T2Fam) -$(deriveTraversable 'T3Fam) - -$(deriveFunctor 'T6Fam) -$(deriveFoldable 'T10Fam) - -$(deriveFunctor 'S1Fam) -$(deriveFoldable 'S2Fam) -$(deriveTraversable 'S3Fam) - -$(deriveFunctor 'OneTwoComposeFam) -$(deriveFoldable 'OneTwoComposeFam) -$(deriveTraversable 'OneTwoComposeFam) - -instance Functor (f Int Int) => Functor (ComplexConstraintFam f g a) where - fmap = $(makeFmap 'ComplexConstraintFam) -instance Foldable (f Int Int) => Foldable (ComplexConstraintFam f g a) where - foldr = $(makeFoldr 'ComplexConstraintFam) - foldMap = $(makeFoldMap 'ComplexConstraintFam) -instance Traversable (f Int Int) => Traversable (ComplexConstraintFam f g a) where - traverse = $(makeTraverse 'ComplexConstraintFam) - -$(deriveFunctor 'UniversalFam) - -$(deriveFunctor 'ExistentialListFam) -$(deriveFoldable 'ExistentialFunctorFam) -$(deriveTraversable 'SneakyUseSameNameFam) - -$(deriveFunctor 'IntHashFam) -$(deriveFoldable 'IntHashTupleFam) -$(deriveTraversable 'IntHashFam) - -$(deriveFunctor 'IntHashFunFam) -#endif - -------------------------------------------------------------------------------- - -prop_FunctorLaws :: (Functor f, Eq (f a), Eq (f c)) - => (b -> c) -> (a -> b) -> f a -> Bool -prop_FunctorLaws f g x = - fmap id x == x - && fmap (f . g) x == (fmap f . fmap g) x - -prop_FunctorEx :: (Functor f, Eq (f [Int])) => f [Int] -> Bool -prop_FunctorEx = prop_FunctorLaws reverse (++ [42]) - -prop_FoldableLaws :: (Eq a, Eq b, Eq z, Monoid a, Monoid b, Foldable f) - => (a -> b) -> (a -> z -> z) -> z -> f a -> Bool -prop_FoldableLaws f h z x = - fold x == foldMap id x - && foldMap f x == foldr (mappend . f) mempty x - && foldr h z x == appEndo (foldMap (Endo . h) x) z - -prop_FoldableEx :: Foldable f => f [Int] -> Bool -prop_FoldableEx = prop_FoldableLaws reverse ((+) . length) 0 - -prop_TraversableLaws :: forall t f g a b c. - (Applicative f, Applicative g, Traversable t, - Eq (t (f a)), Eq (g (t a)), Eq (g (t b)), - Eq (t a), Eq (t c), Eq1 f, Eq1 g) - => (a -> f b) -> (b -> f c) - -> (forall x. f x -> g x) -> t a -> Bool -prop_TraversableLaws f g t x = - (t . traverse f) x == traverse (t . f) x - && traverse Identity x == Identity x - && traverse (Compose . fmap g . f) x - == (Compose . fmap (traverse g) . traverse f) x - - && (t . sequenceA) y == (sequenceA . fmap t) y - && (sequenceA . fmap Identity) y == Identity y - && (sequenceA . fmap Compose) z - == (Compose . fmap sequenceA . sequenceA) z - where - y :: t (f a) - y = fmap pure x - - z :: t (f (g a)) - z = fmap (fmap pure) y - -prop_TraversableEx :: (Traversable t, Eq (t [[Int]]), - Eq (t [Int]), Eq (t String), Eq (t Char)) - => t [Int] -> Bool -prop_TraversableEx = prop_TraversableLaws - (replicate 2 . map (chr . abs)) - (++ "Hello") - reverse - -------------------------------------------------------------------------------- - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "OneTwoCompose Maybe ((,) Bool) [Int] [Int]" $ do - prop "satisfies the Functor laws" - (prop_FunctorEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool) - prop "satisfies the Foldable laws" - (prop_FoldableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool) - prop "satisfies the Traversable laws" - (prop_TraversableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool) -#if MIN_VERSION_template_haskell(2,7,0) - describe "OneTwoComposeFam Maybe ((,) Bool) [Int] [Int]" $ do - prop "satisfies the Functor laws" - (prop_FunctorEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool) - prop "satisfies the Foldable laws" - (prop_FoldableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool) - prop "satisfies the Traversable laws" - (prop_TraversableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool) -#endif diff --git a/tests/FunctorSpec.hs b/tests/FunctorSpec.hs new file mode 100644 --- /dev/null +++ b/tests/FunctorSpec.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-unused-foralls #-} +#endif + +{-| +Module: FunctorSpec +Copyright: (C) 2015-2016 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +@hspec@ tests for derived 'Functor', 'Foldable', and 'Traversable' instances. +-} +module FunctorSpec where + +import Data.Char (chr) +import Data.Deriving +import Data.Foldable (fold) +import Data.Functor.Classes (Eq1) +import Data.Functor.Compose (Compose(..)) +import Data.Functor.Identity (Identity(..)) +import Data.Monoid +import Data.Orphans () + +import GHC.Exts (Int#) + +import Prelude () +import Prelude.Compat + +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Arbitrary) + +------------------------------------------------------------------------------- + +-- Adapted from the test cases from +-- https://ghc.haskell.org/trac/ghc/attachment/ticket/2953/deriving-functor-tests.patch + +-- Plain data types + +data Strange a b c + = T1 a b c + | T2 [a] [b] [c] -- lists + | T3 [[a]] [[b]] [[c]] -- nested lists + | T4 (c,(b,b),(c,c)) -- tuples + | T5 ([c],Strange a b c) -- tycons + +type IntFun a b = (b -> Int) -> a +data StrangeFunctions a b c + = T6 (a -> c) -- function types + | T7 (a -> (c,a)) -- functions and tuples + | T8 ((b -> a) -> c) -- continuation + | T9 (IntFun b c) -- type synonyms + +data StrangeGADT a b where + T10 :: Ord d => d -> StrangeGADT c d + T11 :: Int -> StrangeGADT e Int + T12 :: c ~ Int => c -> StrangeGADT f Int + T13 :: i ~ Int => Int -> StrangeGADT h i + T14 :: k ~ Int => k -> StrangeGADT j k + T15 :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADT m n + +data NotPrimitivelyRecursive a b + = S1 (NotPrimitivelyRecursive (a,a) (b, a)) + | S2 a + | S3 b + +newtype OneTwoCompose f g a b = OneTwoCompose (Either (f (g a)) (f (g b))) + deriving (Arbitrary, Eq, Show) + +newtype ComplexConstraint f g a b = ComplexConstraint (f Int Int (g a,a,b)) + +data Universal a b + = Universal (forall b. (b,[a])) + | Universal2 (forall f. Functor (f a) => f a b) + | Universal3 (forall a. Maybe a) -- reuse a + | NotReallyUniversal (forall b. a) + +data Existential a b + = forall a. ExistentialList [a] + | forall f. Traversable (f a) => ExistentialFunctor (f a b) + | forall b. SneakyUseSameName (Maybe b) + +data IntHash a b + = IntHash Int# Int# + | IntHashTuple Int# a b (a, b, Int, IntHash Int (a, b, Int)) + +data IntHashFun a b + = IntHashFun ((((a -> Int#) -> b) -> Int#) -> a) + +-- Data families + +data family StrangeFam x y z +data instance StrangeFam a b c + = T1Fam a b c + | T2Fam [a] [b] [c] -- lists + | T3Fam [[a]] [[b]] [[c]] -- nested lists + | T4Fam (c,(b,b),(c,c)) -- tuples + | T5Fam ([c],Strange a b c) -- tycons + +data family StrangeFunctionsFam x y z +data instance StrangeFunctionsFam a b c + = T6Fam (a -> c) -- function types + | T7Fam (a -> (c,a)) -- functions and tuples + | T8Fam ((b -> a) -> c) -- continuation + | T9Fam (IntFun b c) -- type synonyms + +data family StrangeGADTFam x y +data instance StrangeGADTFam a b where + T10Fam :: Ord d => d -> StrangeGADTFam c d + T11Fam :: Int -> StrangeGADTFam e Int + T12Fam :: c ~ Int => c -> StrangeGADTFam f Int + T13Fam :: i ~ Int => Int -> StrangeGADTFam h i + T14Fam :: k ~ Int => k -> StrangeGADTFam j k + T15Fam :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADTFam m n + +data family NotPrimitivelyRecursiveFam x y +data instance NotPrimitivelyRecursiveFam a b + = S1Fam (NotPrimitivelyRecursive (a,a) (b, a)) + | S2Fam a + | S3Fam b + +data family OneTwoComposeFam (j :: * -> *) (k :: * -> *) x y +newtype instance OneTwoComposeFam f g a b = + OneTwoComposeFam (Either (f (g a)) (f (g b))) + deriving (Arbitrary, Eq, Show) + +data family ComplexConstraintFam (j :: * -> * -> * -> *) (k :: * -> *) x y +newtype instance ComplexConstraintFam f g a b = ComplexConstraintFam (f Int Int (g a,a,b)) + +data family UniversalFam x y +data instance UniversalFam a b + = UniversalFam (forall b. (b,[a])) + | Universal2Fam (forall f. Functor (f a) => f a b) + | Universal3Fam (forall a. Maybe a) -- reuse a + | NotReallyUniversalFam (forall b. a) + +data family ExistentialFam x y +data instance ExistentialFam a b + = forall a. ExistentialListFam [a] + | forall f. Traversable (f a) => ExistentialFunctorFam (f a b) + | forall b. SneakyUseSameNameFam (Maybe b) + +data family IntHashFam x y +data instance IntHashFam a b + = IntHashFam Int# Int# + | IntHashTupleFam Int# a b (a, b, Int, IntHashFam Int (a, b, Int)) + +data family IntHashFunFam x y +data instance IntHashFunFam a b + = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a) + +------------------------------------------------------------------------------- + +-- Plain data types + +$(deriveFunctor ''Strange) +$(deriveFoldable ''Strange) +$(deriveTraversable ''Strange) + +$(deriveFunctor ''StrangeFunctions) +$(deriveFoldable ''StrangeGADT) + +$(deriveFunctor ''NotPrimitivelyRecursive) +$(deriveFoldable ''NotPrimitivelyRecursive) +$(deriveTraversable ''NotPrimitivelyRecursive) + +$(deriveFunctor ''OneTwoCompose) +$(deriveFoldable ''OneTwoCompose) +$(deriveTraversable ''OneTwoCompose) + +instance Functor (f Int Int) => Functor (ComplexConstraint f g a) where + fmap = $(makeFmap ''ComplexConstraint) +instance Foldable (f Int Int) => Foldable (ComplexConstraint f g a) where + foldr = $(makeFoldr ''ComplexConstraint) + foldMap = $(makeFoldMap ''ComplexConstraint) +instance Traversable (f Int Int) => Traversable (ComplexConstraint f g a) where + traverse = $(makeTraverse ''ComplexConstraint) + +$(deriveFunctor ''Universal) + +$(deriveFunctor ''Existential) +$(deriveFoldable ''Existential) +$(deriveTraversable ''Existential) + +$(deriveFunctor ''IntHash) +$(deriveFoldable ''IntHash) +$(deriveTraversable ''IntHash) + +$(deriveFunctor ''IntHashFun) + +#if MIN_VERSION_template_haskell(2,7,0) +-- Data families + +$(deriveFunctor 'T1Fam) +$(deriveFoldable 'T2Fam) +$(deriveTraversable 'T3Fam) + +$(deriveFunctor 'T6Fam) +$(deriveFoldable 'T10Fam) + +$(deriveFunctor 'S1Fam) +$(deriveFoldable 'S2Fam) +$(deriveTraversable 'S3Fam) + +$(deriveFunctor 'OneTwoComposeFam) +$(deriveFoldable 'OneTwoComposeFam) +$(deriveTraversable 'OneTwoComposeFam) + +instance Functor (f Int Int) => Functor (ComplexConstraintFam f g a) where + fmap = $(makeFmap 'ComplexConstraintFam) +instance Foldable (f Int Int) => Foldable (ComplexConstraintFam f g a) where + foldr = $(makeFoldr 'ComplexConstraintFam) + foldMap = $(makeFoldMap 'ComplexConstraintFam) +instance Traversable (f Int Int) => Traversable (ComplexConstraintFam f g a) where + traverse = $(makeTraverse 'ComplexConstraintFam) + +$(deriveFunctor 'UniversalFam) + +$(deriveFunctor 'ExistentialListFam) +$(deriveFoldable 'ExistentialFunctorFam) +$(deriveTraversable 'SneakyUseSameNameFam) + +$(deriveFunctor 'IntHashFam) +$(deriveFoldable 'IntHashTupleFam) +$(deriveTraversable 'IntHashFam) + +$(deriveFunctor 'IntHashFunFam) +#endif + +------------------------------------------------------------------------------- + +prop_FunctorLaws :: (Functor f, Eq (f a), Eq (f c)) + => (b -> c) -> (a -> b) -> f a -> Bool +prop_FunctorLaws f g x = + fmap id x == x + && fmap (f . g) x == (fmap f . fmap g) x + +prop_FunctorEx :: (Functor f, Eq (f [Int])) => f [Int] -> Bool +prop_FunctorEx = prop_FunctorLaws reverse (++ [42]) + +prop_FoldableLaws :: (Eq a, Eq b, Eq z, Monoid a, Monoid b, Foldable f) + => (a -> b) -> (a -> z -> z) -> z -> f a -> Bool +prop_FoldableLaws f h z x = + fold x == foldMap id x + && foldMap f x == foldr (mappend . f) mempty x + && foldr h z x == appEndo (foldMap (Endo . h) x) z + +prop_FoldableEx :: Foldable f => f [Int] -> Bool +prop_FoldableEx = prop_FoldableLaws reverse ((+) . length) 0 + +prop_TraversableLaws :: forall t f g a b c. + (Applicative f, Applicative g, Traversable t, + Eq (t (f a)), Eq (g (t a)), Eq (g (t b)), + Eq (t a), Eq (t c), Eq1 f, Eq1 g) + => (a -> f b) -> (b -> f c) + -> (forall x. f x -> g x) -> t a -> Bool +prop_TraversableLaws f g t x = + (t . traverse f) x == traverse (t . f) x + && traverse Identity x == Identity x + && traverse (Compose . fmap g . f) x + == (Compose . fmap (traverse g) . traverse f) x + + && (t . sequenceA) y == (sequenceA . fmap t) y + && (sequenceA . fmap Identity) y == Identity y + && (sequenceA . fmap Compose) z + == (Compose . fmap sequenceA . sequenceA) z + where + y :: t (f a) + y = fmap pure x + + z :: t (f (g a)) + z = fmap (fmap pure) y + +prop_TraversableEx :: (Traversable t, Eq (t [[Int]]), + Eq (t [Int]), Eq (t String), Eq (t Char)) + => t [Int] -> Bool +prop_TraversableEx = prop_TraversableLaws + (replicate 2 . map (chr . abs)) + (++ "Hello") + reverse + +------------------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "OneTwoCompose Maybe ((,) Bool) [Int] [Int]" $ do + prop "satisfies the Functor laws" + (prop_FunctorEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool) + prop "satisfies the Foldable laws" + (prop_FoldableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool) + prop "satisfies the Traversable laws" + (prop_TraversableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool) +#if MIN_VERSION_template_haskell(2,7,0) + describe "OneTwoComposeFam Maybe ((,) Bool) [Int] [Int]" $ do + prop "satisfies the Functor laws" + (prop_FunctorEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool) + prop "satisfies the Foldable laws" + (prop_FoldableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool) + prop "satisfies the Traversable laws" + (prop_TraversableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool) +#endif diff --git a/tests/ShowSpec.hs b/tests/ShowSpec.hs new file mode 100644 --- /dev/null +++ b/tests/ShowSpec.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module: ShowSpec +Copyright: (C) 2015-2016 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +@hspec@ tests for derived 'Show', 'Show1', and 'Show2' instances. +-} +module ShowSpec where + +#if !defined(NEW_FUNCTOR_CLASSES) +import Data.Functor.Classes (Show1(..)) +#endif +import Data.Deriving + +import GHC.Exts (Char#, Double#, Float#, Int#, Word#) + +import Prelude () +import Prelude.Compat + +import Test.Hspec + +------------------------------------------------------------------------------- + +-- Plain data types + +infixl 4 :@: +data TyCon1 a b = TyConPrefix { tc1 :: a, tc2 :: b } + | (:@:) { tc3 :: b, tc4 :: a } + +infixl 3 :!!: +infix 4 :@@: +infixr 5 `TyConPlain` +infixr 6 `TyConFakeInfix` +data TyConPlain a b = (:!!:) a b + | a :@@: b + | a `TyConPlain` b + | TyConFakeInfix a b + +data TyConGADT a b where + (:.) :: c -> d -> TyConGADT c d + (:..) :: e -> f -> TyConGADT e f + (:...) :: g -> h -> Int -> TyConGADT g h + (:....) :: { tcg1 :: i, tcg2 :: j } -> TyConGADT i j + +data TyCon# a b = TyCon# { + tcA :: a + , tcB :: b + , tcInt# :: Int# + , tcFloat# :: Float# + , tcDouble# :: Double# + , tcChar# :: Char# + , tcWord# :: Word# +} + +data TyCon2 a b c d where + TyConClassConstraints :: (Ord m, Ord n, Ord o, Ord p) + => m -> n -> o -> p + -> TyCon2 m n o p + + TyConEqualityConstraints :: (e ~ g, f ~ h, e ~ f) + => e -> f -> g -> h + -> TyCon2 e f g h + + TyConTypeRefinement1, + TyConTypeRefinement2 :: Int -> z + -> TyCon2 Int Int z z + + TyConForalls :: forall p q r s t u. + (Show p, Show q) + => p -> q -> u -> t + -> TyCon2 r s t u + +data TyConWrap f g h a = TyConWrap1 (f a) + | TyConWrap2 (f (g a)) + | TyConWrap3 (f (g (h a))) + +-- Data families + +data family TyFamily1 y z :: * + +infixl 4 :!: +data instance TyFamily1 a b = TyFamilyPrefix { tf1 :: a, tf2 :: b } + | (:!:) { tf3 :: b, tf4 :: a } + +data family TyFamilyPlain y z :: * + +infixl 3 :#: +infix 4 :$: +infixr 5 `TyFamilyPlain` +infixr 6 `TyFamilyFakeInfix` +data instance TyFamilyPlain a b = (:#:) a b + | a :$: b + | a `TyFamilyPlain` b + | TyFamilyFakeInfix a b + + +data family TyFamilyGADT y z :: * + +infixr 1 :*, :***, :**** +data instance TyFamilyGADT a b where + (:*) :: c -> d -> TyFamilyGADT c d + (:**) :: e -> f -> TyFamilyGADT e f + (:***) :: g -> h -> Int -> TyFamilyGADT g h + (:****) :: { tfg1 :: i, tfg2 :: j } -> TyFamilyGADT i j + +data family TyFamily# y z :: * + +data instance TyFamily# a b = TyFamily# { + tfA :: a + , tfB :: b + , tfInt# :: Int# + , tfFloat# :: Float# + , tfDouble# :: Double# + , tfChar# :: Char# + , tfWord# :: Word# +} + +data family TyFamily2 w x y z :: * + +data instance TyFamily2 a b c d where + TyFamilyClassConstraints :: (Ord m, Ord n, Ord o, Ord p) + => m -> n -> o -> p + -> TyFamily2 m n o p + + TyFamilyEqualityConstraints :: (e ~ g, f ~ h, e ~ f) + => e -> f -> g -> h + -> TyFamily2 e f g h + + TyFamilyTypeRefinement1, + TyFamilyTypeRefinement2 :: Int -> z + -> TyFamily2 Int Int z z + + TyFamilyForalls :: forall p q r s t u. + (Show p, Show q) + => p -> q -> u -> t + -> TyFamily2 r s t u + +data family TyFamilyWrap (w :: * -> *) (x :: * -> *) (y :: * -> *) z :: * + +data instance TyFamilyWrap f g h a = TyFamilyWrap1 (f a) + | TyFamilyWrap2 (f (g a)) + | TyFamilyWrap3 (f (g (h a))) + +------------------------------------------------------------------------------- + +-- Plain data types + +$(deriveShow ''TyCon1) +$(deriveShow ''TyConPlain) +$(deriveShow ''TyConGADT) +$(deriveShow ''TyCon#) +$(deriveShow ''TyCon2) +instance (Show (f a), Show (f (g a)), Show (f (g (h a)))) + => Show (TyConWrap f g h a) where + showsPrec = $(makeShowsPrec ''TyConWrap) + +$(deriveShow1 ''TyCon1) +$(deriveShow1 ''TyConPlain) +$(deriveShow1 ''TyConGADT) +$(deriveShow1 ''TyCon#) +$(deriveShow1 ''TyCon2) +#if defined(NEW_FUNCTOR_CLASSES) +$(deriveShow1 ''TyConWrap) +#else +instance (Show1 f, Functor f, Show1 g, Functor g, Show1 h) + => Show1 (TyConWrap f g h) where + showsPrec1 = $(makeShowsPrec1 ''TyConWrap) +#endif + +#if defined(NEW_FUNCTOR_CLASSES) +$(deriveShow2 ''TyCon1) +$(deriveShow2 ''TyConPlain) +$(deriveShow2 ''TyConGADT) +$(deriveShow2 ''TyCon#) +$(deriveShow2 ''TyCon2) +#endif + +#if MIN_VERSION_template_haskell(2,7,0) +-- Data families + +$(deriveShow 'TyFamilyPrefix) +$(deriveShow '(:#:)) +$(deriveShow '(:*)) +$(deriveShow 'TyFamily#) +$(deriveShow 'TyFamilyClassConstraints) +instance (Show (f a), Show (f (g a)), Show (f (g (h a)))) + => Show (TyFamilyWrap f g h a) where + showsPrec = $(makeShowsPrec 'TyFamilyWrap1) + +$(deriveShow1 '(:!:)) +$(deriveShow1 '(:$:)) +$(deriveShow1 '(:**)) +$(deriveShow1 'TyFamily#) +$(deriveShow1 'TyFamilyEqualityConstraints) +# if defined(NEW_FUNCTOR_CLASSES) +$(deriveShow1 'TyFamilyWrap2) +# else +instance (Show1 f, Functor f, Show1 g, Functor g, Show1 h) + => Show1 (TyFamilyWrap f g h) where + showsPrec1 = $(makeShowsPrec1 'TyFamilyWrap3) +# endif + +# if defined(NEW_FUNCTOR_CLASSES) +$(deriveShow2 'TyFamilyPrefix) +$(deriveShow2 'TyFamilyPlain) +$(deriveShow2 '(:***)) +$(deriveShow2 'TyFamily#) +$(deriveShow2 'TyFamilyTypeRefinement1) +# endif +#endif + +------------------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = pure ()