diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 0.2.1 +* Add `Foldable` and `Traversable` instances for `WrappedFunctor` +* Fixed build on GHC HEAD + # 0.2 * Support deriving `Invariant` and `Invariant2` instances with Template Haskell * Added `invmapFunctor`, `invmapContravariant`, `invmap2Bifunctor`, and diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,18 @@ -# `invariant` [![Hackage version](https://img.shields.io/hackage/v/invariant.svg?style=flat)](http://hackage.haskell.org/package/invariant) [![Build Status](https://img.shields.io/travis/nfrisby/invariant-functors.svg?style=flat)](https://travis-ci.org/nfrisby/invariant-functors) +# `invariant` +[![Hackage](https://img.shields.io/hackage/v/invariant.svg)][Hackage: invariant] +[![Hackage Dependencies](https://img.shields.io/hackage-deps/v/invariant.svg)](http://packdeps.haskellers.com/reverse/invariant) +[![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] +[![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] +[![Build](https://img.shields.io/travis/nfrisby/invariant-functors.svg)](https://travis-ci.org/nfrisby/invariant-functors) + +[Hackage: invariant]: + http://hackage.haskell.org/package/invariant + "invariant package on Hackage" +[Haskell.org]: + http://www.haskell.org + "The Haskell Programming Language" +[tl;dr Legal: BSD3]: + https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 + "BSD 3-Clause License (Revised)" Haskell98 invariant functors diff --git a/invariant.cabal b/invariant.cabal --- a/invariant.cabal +++ b/invariant.cabal @@ -1,5 +1,5 @@ name: invariant -version: 0.2 +version: 0.2.1 synopsis: Haskell 98 invariant functors description: Haskell 98 invariant functors category: Control, Data @@ -34,7 +34,7 @@ , semigroups >= 0.16.2 && < 1 , stm >= 2.2 && < 3 , tagged >= 0.7.3 && < 1 - , template-haskell >= 2.4 && < 2.11 + , template-haskell >= 2.4 && < 2.12 , transformers >= 0.2 && < 0.5 , transformers-compat >= 0.3 && < 1 , unordered-containers >= 0.2.4 && < 0.3 diff --git a/src/Data/Functor/Invariant.hs b/src/Data/Functor/Invariant.hs --- a/src/Data/Functor/Invariant.hs +++ b/src/Data/Functor/Invariant.hs @@ -41,9 +41,10 @@ import Control.Arrow import Control.Applicative as App import Control.Exception (Handler(..)) -import Control.Monad (MonadPlus(..)) +import Control.Monad (MonadPlus(..), liftM) import qualified Control.Monad.ST as Strict (ST) import qualified Control.Monad.ST.Lazy as Lazy (ST) +import qualified Data.Foldable as F (Foldable(..)) import Data.Functor.Identity (Identity) #if __GLASGOW_HASKELL__ < 711 import Data.Ix (Ix) @@ -54,6 +55,7 @@ #endif import Data.Monoid (Dual(..), Endo(..)) import Data.Proxy (Proxy(..)) +import qualified Data.Traversable as T (Traversable(..)) #if GHC_GENERICS_OK import GHC.Generics #endif @@ -475,6 +477,34 @@ instance MonadPlus m => MonadPlus (WrappedFunctor m) where mzero = WrapFunctor mzero WrapFunctor x `mplus` WrapFunctor y = WrapFunctor $ x `mplus` y + +instance F.Foldable f => F.Foldable (WrappedFunctor f) where + fold = F.fold . unwrapFunctor + foldMap f = F.foldMap f . unwrapFunctor + foldr f z = F.foldr f z . unwrapFunctor + foldl f q = F.foldl f q . unwrapFunctor + foldr1 f = F.foldr1 f . unwrapFunctor + foldl1 f = F.foldl1 f . unwrapFunctor +#if MIN_VERSION_base(4,6,0) + foldr' f z = F.foldr' f z . unwrapFunctor + foldl' f q = F.foldl' f q . unwrapFunctor +#endif +#if MIN_VERSION_base(4,8,0) + toList = F.toList . unwrapFunctor + null = F.null . unwrapFunctor + length = F.length . unwrapFunctor + elem x = F.elem x . unwrapFunctor + maximum = F.maximum . unwrapFunctor + minimum = F.minimum . unwrapFunctor + sum = F.sum . unwrapFunctor + product = F.product . unwrapFunctor +#endif + +instance T.Traversable f => T.Traversable (WrappedFunctor f) where + traverse f = fmap WrapFunctor . T.traverse f . unwrapFunctor + sequenceA = fmap WrapFunctor . T.sequenceA . unwrapFunctor + mapM f = liftM WrapFunctor . T.mapM f . unwrapFunctor + sequence = liftM WrapFunctor . T.sequence . unwrapFunctor ------------------------------------------------------------------------------- -- WrappedContravariant diff --git a/src/Data/Functor/Invariant/TH.hs b/src/Data/Functor/Invariant/TH.hs --- a/src/Data/Functor/Invariant/TH.hs +++ b/src/Data/Functor/Invariant/TH.hs @@ -232,61 +232,16 @@ -- | Derive an Invariant(2) instance declaration (depending on the InvariantClass -- argument's value). deriveInvariantClass :: InvariantClass -> Name -> Q [Dec] -deriveInvariantClass iClass tyConName = do - info <- reify tyConName - case info of - TyConI{} -> deriveInvariantPlainTy iClass tyConName -#if MIN_VERSION_template_haskell(2,7,0) - DataConI{} -> deriveInvariantDataFamInst iClass tyConName - FamilyI (FamilyD DataFam _ _ _) _ -> - error $ ns ++ "Cannot use a data family name. Use a data family instance constructor instead." - FamilyI (FamilyD TypeFam _ _ _) _ -> - error $ ns ++ "Cannot use a type family name." - _ -> error $ ns ++ "The name must be of a plain type constructor or data family instance constructor." -#else - DataConI{} -> dataConIError - _ -> error $ ns ++ "The name must be of a plain type constructor." -#endif - where - ns :: String - ns = "Data.Functor.Invariant.TH.deriveInvariant: " - --- | Generates an Invariant(2) instance declaration for a plain type constructor. -deriveInvariantPlainTy :: InvariantClass -> Name -> Q [Dec] -deriveInvariantPlainTy iClass tyConName = - withTyCon tyConName fromCons - where - className :: Name - className = invariantClassNameTable iClass - - fromCons :: Cxt -> [TyVarBndr] -> [Con] -> Q [Dec] - fromCons ctxt tvbs cons = (:[]) `fmap` - instanceD (return instanceCxt) - (return $ AppT (ConT className) instanceType) - (invmapDecs droppedNbs cons) - where - (instanceCxt, instanceType, droppedNbs) = - cxtAndTypePlainTy iClass tyConName ctxt tvbs - -#if MIN_VERSION_template_haskell(2,7,0) --- | Generates an Invariant(2) instance declaration for a data family instance --- constructor. -deriveInvariantDataFamInst :: InvariantClass -> Name -> Q [Dec] -deriveInvariantDataFamInst iClass dataFamInstName = - withDataFamInstCon dataFamInstName fromDec +deriveInvariantClass iClass name = withType name fromCons where - className :: Name - className = invariantClassNameTable iClass - - fromDec :: [TyVarBndr] -> Cxt -> Name -> [Type] -> [Con] -> Q [Dec] - fromDec famTvbs ctxt parentName instTys cons = (:[]) `fmap` + fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] + fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` instanceD (return instanceCxt) - (return $ AppT (ConT className) instanceType) + (return instanceType) (invmapDecs droppedNbs cons) where (instanceCxt, instanceType, droppedNbs) = - cxtAndTypeDataFamInstCon iClass parentName ctxt famTvbs instTys -#endif + buildTypeInstance iClass name' ctxt tvbs mbTys -- | Generates a declaration defining the primary function corresponding to a -- particular class (invmap for Invariant and invmap2 for Invariant2). @@ -300,33 +255,17 @@ ] where classFuncName :: Name - classFuncName = invmapNameTable . toEnum $ length nbs + classFuncName = invmapName . toEnum $ length nbs -- | Generates a lambda expression which behaves like invmap (for Invariant), -- or invmap2 (for Invariant2). makeInvmapClass :: InvariantClass -> Name -> Q Exp -makeInvmapClass iClass tyConName = do - info <- reify tyConName - case info of - TyConI{} -> withTyCon tyConName $ \ctxt tvbs decs -> - let nbs = thd3 $ cxtAndTypePlainTy iClass tyConName ctxt tvbs - in nbs `seq` makeInvmapForCons nbs decs -#if MIN_VERSION_template_haskell(2,7,0) - DataConI{} -> withDataFamInstCon tyConName $ \famTvbs ctxt parentName instTys cons -> - let nbs = thd3 $ cxtAndTypeDataFamInstCon iClass parentName ctxt famTvbs instTys - in nbs `seq` makeInvmapForCons nbs cons - FamilyI (FamilyD DataFam _ _ _) _ -> - error $ ns ++ "Cannot use a data family name. Use a data family instance constructor instead." - FamilyI (FamilyD TypeFam _ _ _) _ -> - error $ ns ++ "Cannot use a type family name." - _ -> error $ ns ++ "The name must be of a plain type constructor or data family instance constructor." -#else - DataConI{} -> dataConIError - _ -> error $ ns ++ "The name must be of a plain type constructor." -#endif +makeInvmapClass iClass name = withType name fromCons where - ns :: String - ns = "Data.Functor.Invariant.TH.makeInvmap: " + fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp + fromCons name' ctxt tvbs cons mbTys = + let nbs = thd3 $ buildTypeInstance iClass name' ctxt tvbs mbTys + in nbs `seq` makeInvmapForCons nbs cons -- | Generates a lambda expression for invmap(2) for the given constructors. -- All constructors must be from the same type. @@ -343,10 +282,10 @@ argNames = concat (transpose [covMaps, contraMaps]) ++ [value] lamE (map varP argNames) . appsE - $ [ varE $ invmapConstNameTable iClass + $ [ varE $ invmapConstName iClass , if null cons then appE (varE errorValName) - (stringE $ "Void " ++ nameBase (invmapNameTable iClass)) + (stringE $ "Void " ++ nameBase (invmapName iClass)) else caseE (varE value) (map (makeInvmapForCon iClass tvis) cons) ] ++ map varE argNames @@ -471,7 +410,7 @@ then outOfPlaceTyVarError conName tyVarNameBases else if any (`mentionsNameBase` tyVarNameBases) rhsArgs then appsE $ - ( varE (invmapNameTable (toEnum numLastArgs)) + ( varE (invmapName (toEnum numLastArgs)) : doubleMap (makeInvmapForType iClass conName tvis) rhsArgs ) else do x <- newName "x" @@ -482,76 +421,84 @@ ------------------------------------------------------------------------------- -- | Extracts a plain type constructor's information. -withTyCon :: Name -- ^ Name of the plain type constructor - -> (Cxt -> [TyVarBndr] -> [Con] -> Q a) - -> Q a -withTyCon name f = do - info <- reify name - case info of - TyConI dec -> - case dec of - DataD ctxt _ tvbs cons _ -> f ctxt tvbs cons - NewtypeD ctxt _ tvbs con _ -> f ctxt tvbs [con] - other -> error $ ns ++ "Unsupported type " ++ show other ++ ". Must be a data type or newtype." - _ -> error $ ns ++ "The name must be of a plain type constructor." - where - ns :: String - ns = "Data.Functor.Invariant.TH.withTyCon: " - +-- | 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 cons _ -> f name ctxt tvbs cons Nothing + NewtypeD ctxt _ tvbs con _ -> f name ctxt tvbs [con] Nothing + _ -> error $ ns ++ "Unsupported type: " ++ show dec #if MIN_VERSION_template_haskell(2,7,0) --- | Extracts a data family name's information. -withDataFam :: Name -- ^ Name of the data family - -> ([TyVarBndr] -> [Dec] -> Q a) - -> Q a -withDataFam name f = do - info <- reify name - case info of - FamilyI (FamilyD DataFam _ tvbs _) decs -> f tvbs decs - FamilyI (FamilyD TypeFam _ _ _) _ -> - error $ ns ++ "Cannot use a type family name." - other -> error $ ns ++ "Unsupported type " ++ show other ++ ". Must be a data family name." - where - ns :: String - ns = "Data.Functor.Invariant.TH.withDataFam: " - --- | Extracts a data family instance constructor's information. -withDataFamInstCon :: Name -- ^ Name of the data family instance constructor - -> ([TyVarBndr] -> Cxt -> Name -> [Type] -> [Con] -> Q a) - -> Q a -withDataFamInstCon dficName f = do - dficInfo <- reify dficName - case dficInfo of - DataConI _ _ parentName _ -> do - parentInfo <- reify parentName - case parentInfo of - FamilyI (FamilyD DataFam _ _ _) _ -> withDataFam parentName $ \famTvbs decs -> - let sameDefDec = flip find decs $ \dec -> - case dec of - DataInstD _ _ _ cons' _ -> any ((dficName ==) . constructorName) cons' - NewtypeInstD _ _ _ con _ -> dficName == constructorName con - _ -> error $ ns ++ "Must be a data or newtype instance." - - (ctxt, instTys, cons) = case sameDefDec of - Just (DataInstD ctxt' _ instTys' cons' _) -> (ctxt', instTys', cons') - Just (NewtypeInstD ctxt' _ instTys' con _) -> (ctxt', instTys', [con]) - _ -> error $ ns ++ "Could not find data or newtype instance constructor." - - in f famTvbs ctxt parentName instTys cons - _ -> error $ ns ++ "Data constructor " ++ show dficName ++ " is not from a data family instance." - other -> error $ ns ++ "Unsupported type " ++ show other ++ ". Must be a data family instance constructor." +# 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 _ _ _ cons _ -> any ((name ==) . constructorName) cons + NewtypeInstD _ _ _ con _ -> name == constructorName con + _ -> error $ ns ++ "Must be a data or newtype instance." + in case instDec of + Just (DataInstD ctxt _ instTys cons _) + -> f parentName ctxt tvbs cons $ Just instTys + Just (NewtypeInstD ctxt _ instTys con _) + -> f parentName ctxt tvbs [con] $ Just instTys + _ -> error $ ns ++ + "Could not find data or newtype instance constructor." + _ -> error $ 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 + error $ ns ++ + "Cannot use a data family name. Use a data family instance constructor instead." + _ -> error $ ns ++ "The name must be of a plain data type constructor, " + ++ "or a data family instance constructor." +#else + DataConI{} -> dataConIError + _ -> error $ ns ++ "The name must be of a plain type constructor." +#endif where ns :: String - ns = "Data.Functor.Invariant.TH.withDataFamInstCon: " -#endif + ns = "Data.Functor.Invariant.TH.withType: " --- | Deduces the Invariant(2) instance context, instance head, and eta-reduced --- type variables for a plain data type constructor. -cxtAndTypePlainTy :: InvariantClass -- Invariant or Invariant2 - -> Name -- The datatype's name - -> Cxt -- The datatype context - -> [TyVarBndr] -- The type variables +-- | Deduces the instance context, instance head, and eta-reduced type variables +-- for an instance. +buildTypeInstance :: InvariantClass + -- ^ Invariant or Invariant2 + -> 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 -> (Cxt, Type, [NameBase]) -cxtAndTypePlainTy iClass tyConName dataCxt tvbs = +-- Plain data type/newtype case +buildTypeInstance iClass tyConName dataCxt tvbs Nothing = if remainingLength < 0 || not (wellKinded droppedKinds) -- If we have enough well-kinded type variables then derivingKindError iClass tyConName else if any (`predMentionsNameBase` droppedNbs) dataCxt -- If the last type variable(s) are mentioned in a datatype context @@ -563,7 +510,9 @@ $ filter (needsConstraint iClass . tvbKind) remaining instanceType :: Type - instanceType = applyTyCon tyConName $ map (VarT . tvbName) remaining + instanceType = AppT (ConT $ invariantClassName iClass) + . applyTyCon tyConName + $ map (VarT . tvbName) remaining remainingLength :: Int remainingLength = length tvbs - fromEnum iClass @@ -576,17 +525,8 @@ droppedNbs :: [NameBase] droppedNbs = map (NameBase . tvbName) dropped - -#if MIN_VERSION_template_haskell(2,7,0) --- | Deduces the Invariant(2) instance context, instance head, and eta-reduced --- type variables for a data family instnce constructor. -cxtAndTypeDataFamInstCon :: InvariantClass -- Invariant or Invariant2 - -> Name -- The data family name - -> Cxt -- The datatype context - -> [TyVarBndr] -- The data family declaration's type variables - -> [Type] -- The data family instance types - -> (Cxt, Type, [NameBase]) -cxtAndTypeDataFamInstCon iClass parentName dataCxt famTvbs instTysAndKinds = +-- Data family instance case +buildTypeInstance iClass parentName dataCxt tvbs (Just instTysAndKinds) = if remainingLength < 0 || not (wellKinded droppedKinds) -- If we have enough well-kinded type variables then derivingKindError iClass parentName else if any (`predMentionsNameBase` droppedNbs) dataCxt -- If the last type variable(s) are mentioned in a datatype context @@ -608,17 +548,18 @@ -- -- To do this, we remove every kind ascription (i.e., strip off every 'SigT'). instanceType :: Type - instanceType = applyTyCon parentName + instanceType = AppT (ConT $ invariantClassName iClass) + . applyTyCon parentName $ map unSigT remaining remainingLength :: Int - remainingLength = length famTvbs - fromEnum iClass + remainingLength = length tvbs - fromEnum iClass remaining, dropped :: [Type] (remaining, dropped) = splitAt remainingLength rhsTypes droppedKinds :: [Kind] - droppedKinds = map tvbKind . snd $ splitAt remainingLength famTvbs + droppedKinds = map tvbKind . snd $ splitAt remainingLength tvbs droppedNbs :: [NameBase] droppedNbs = map varTToNameBase dropped @@ -636,18 +577,18 @@ -- then dropping that number of entries from @instTysAndKinds@. instTypes :: [Type] instTypes = -# if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0)) +#if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0)) instTysAndKinds -# else - drop (Set.size . Set.unions $ map (distinctKindVars . tvbKind) famTvbs) +#else + drop (Set.size . Set.unions $ map (distinctKindVars . tvbKind) tvbs) instTysAndKinds -# endif +#endif lhsTvbs :: [TyVarBndr] lhsTvbs = map (uncurry replaceTyVarName) . filter (isTyVar . snd) . take remainingLength - $ zip famTvbs rhsTypes + $ zip tvbs rhsTypes -- In GHC 7.8, only the @Type@s up to the rightmost non-eta-reduced type variable -- in @instTypes@ are provided (as a result of this extremely annoying bug: @@ -679,23 +620,22 @@ -- Thankfully, other versions of GHC don't seem to have this bug. rhsTypes :: [Type] rhsTypes = -# if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 +#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 instTypes ++ map tvbToType (drop (length instTypes) - famTvbs) -# else + tvbs) +#else instTypes -# endif #endif -- | Given a TyVarBndr, apply an Invariant(2) constraint to it, depending -- on its kind. applyInvariantConstraint :: TyVarBndr -> Pred -applyInvariantConstraint (PlainTV _) = error "Cannot constrain type of kind *" +applyInvariantConstraint PlainTV{} = error "Cannot constrain type of kind *" applyInvariantConstraint (KindedTV name kind) = applyClass className name where className :: Name - className = invariantClassNameTable . toEnum $ numKindArrows kind + className = invariantClassName . toEnum $ numKindArrows kind -- | Can a kind signature inhabit an Invariant constraint? -- @@ -732,7 +672,7 @@ $ "" where className :: String - className = nameBase $ invariantClassNameTable iClass + className = nameBase $ invariantClassName iClass -- | The data type has a DatatypeContext which mentions one of the eta-reduced -- type variables. @@ -765,14 +705,14 @@ . showString " only in the last argument(s) of a data type" $ "" -#if MIN_VERSION_template_haskell(2,7,0) -- | One of the last type variables cannot be eta-reduced (see the canEtaReduce -- function for the criteria it would have to meet). etaReductionError :: Type -> a etaReductionError instanceType = error $ "Cannot eta-reduce to an instance of form \n\tinstance (...) => " ++ pprint instanceType -#else + +#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 Invariant instance -- to work. diff --git a/src/Data/Functor/Invariant/TH/Internal.hs b/src/Data/Functor/Invariant/TH/Internal.hs --- a/src/Data/Functor/Invariant/TH/Internal.hs +++ b/src/Data/Functor/Invariant/TH/Internal.hs @@ -90,17 +90,17 @@ toEnum 2 = Invariant2 toEnum i = error $ "No Invariant class for number " ++ show i -invmapConstNameTable :: InvariantClass -> Name -invmapConstNameTable Invariant = invmapConstValName -invmapConstNameTable Invariant2 = invmap2ConstValName +invmapConstName :: InvariantClass -> Name +invmapConstName Invariant = invmapConstValName +invmapConstName Invariant2 = invmap2ConstValName -invariantClassNameTable :: InvariantClass -> Name -invariantClassNameTable Invariant = invariantTypeName -invariantClassNameTable Invariant2 = invariant2TypeName +invariantClassName :: InvariantClass -> Name +invariantClassName Invariant = invariantTypeName +invariantClassName Invariant2 = invariant2TypeName -invmapNameTable :: InvariantClass -> Name -invmapNameTable Invariant = invmapValName -invmapNameTable Invariant2 = invmap2ValName +invmapName :: InvariantClass -> Name +invmapName Invariant = invmapValName +invmapName Invariant2 = invmap2ValName -- | A type-restricted version of 'const'. This constrains the map functions -- that are autogenerated by Template Haskell to be the correct type, even @@ -252,10 +252,15 @@ isTyFamily (ConT n) = do info <- reify n return $ case info of -#if MIN_VERSION_template_haskell(2,7,0) +#if MIN_VERSION_template_haskell(2,11,0) + FamilyI OpenTypeFamilyD{} _ -> True +#elif MIN_VERSION_template_haskell(2,7,0) FamilyI (FamilyD TypeFam _ _ _) _ -> True #else TyConI (FamilyD TypeFam _ _ _) -> True +#endif +#if MIN_VERSION_template_haskell(2,9,0) + FamilyI ClosedTypeFamilyD{} _ -> True #endif _ -> False isTyFamily _ = return False diff --git a/test/THSpec.hs b/test/THSpec.hs --- a/test/THSpec.hs +++ b/test/THSpec.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} @@ -20,6 +22,8 @@ -- 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 @@ -38,7 +42,7 @@ newtype Compose f g a b = Compose (f (g a b)) deriving (Arbitrary, Eq, Show) -data ComplexConstraint f a b = ComplexContraint (f Int Int (f Bool Bool a,a,b)) +data ComplexConstraint f a b = ComplexConstraint (f Int Int (f Bool Bool a,a,b)) data Universal a = Universal (forall b. (b,[a])) @@ -54,8 +58,53 @@ type IntFun a b = b -> a data IntFunD a b = IntFunD (IntFun a b) +-- Data families + +data family StrangeFam a b c +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 + | T6Fam (b -> c) -- function types + | T7Fam (b -> (c,a)) -- functions and tuples + | T8Fam ((c -> b) -> a) -- continuation + +data family NotPrimitivelyRecursiveFam a b +data instance NotPrimitivelyRecursiveFam a b + = S1Fam (NotPrimitivelyRecursive (a,a) (b, a)) + | S2Fam a + | S3Fam b + +data family ComposeFam (f :: * -> *) (g :: * -> * -> *) a b +newtype instance ComposeFam f g a b = ComposeFam (f (g a b)) + deriving (Arbitrary, Eq, Show) + +data family ComplexConstraintFam (f :: * -> * -> * -> *) a b +data instance ComplexConstraintFam f a b = + ComplexConstraintFam (f Int Int (f Bool Bool a,a,b)) + +data family UniversalFam a +data instance UniversalFam a + = UniversalFam (forall b. (b,[a])) + | Universal2Fam (forall f. Invariant f => (f a)) + | Universal3Fam (forall a. a -> Int) -- reuse a + | NotReallyUniversalFam (forall b. a) + +data family ExistentialFam b +data instance ExistentialFam b + = forall a. ExistentialListFam [a] + | forall f. Invariant f => ExistentialFunctorFam (f b) + | forall b. SneakyUseSameNameFam (b -> Bool) + +data family IntFunDFam a b +data instance IntFunDFam a b = IntFunDFam (IntFun a b) + ------------------------------------------------------------------------------- +-- Plain data types + $(deriveInvariant ''Strange) $(deriveInvariant2 ''Strange) @@ -81,6 +130,35 @@ $(deriveInvariant ''IntFunD) $(deriveInvariant2 ''IntFunD) +#if MIN_VERSION_template_haskell(2,7,0) +-- Data Families + +$(deriveInvariant 'T1Fam) +$(deriveInvariant2 'T2Fam) + +$(deriveInvariant 'S1Fam) +$(deriveInvariant2 'S2Fam) + +instance (Invariant f, Invariant (g a)) => + Invariant (ComposeFam f g a) where + invmap = $(makeInvmap 'ComposeFam) +$(deriveInvariant2 'ComposeFam) + +instance Invariant (f Int Int) => + Invariant (ComplexConstraintFam f a) where + invmap = $(makeInvmap 'ComplexConstraintFam) +instance (Invariant2 (f Bool), Invariant2 (f Int)) => + Invariant2 (ComplexConstraintFam f) where + invmap2 = $(makeInvmap2 'ComplexConstraintFam) + +$(deriveInvariant 'UniversalFam) + +$(deriveInvariant 'ExistentialListFam) + +$(deriveInvariant 'IntFunDFam) +$(deriveInvariant2 'IntFunDFam) +#endif + ------------------------------------------------------------------------------- -- | Verifies that @invmap id id = id@ (the other 'invmap' law follows @@ -100,6 +178,11 @@ spec :: Spec spec = do - describe "Compose Maybe Either Int Int" $ do - prop "satisfies the invmap laws" (prop_invmapLaws :: Compose Maybe Either Int Int -> Bool) - prop "satisfies the invmap2 laws" (prop_invmap2Laws :: Compose Maybe Either Int Int -> Bool) + describe "Compose Maybe Either Int Int" $ do + prop "satisfies the invmap laws" (prop_invmapLaws :: Compose Maybe Either Int Int -> Bool) + prop "satisfies the invmap2 laws" (prop_invmap2Laws :: Compose Maybe Either Int Int -> Bool) +#if MIN_VERSION_template_haskell(2,7,0) + describe "ComposeFam Maybe Either Int Int" $ do + prop "satisfies the invmap laws" (prop_invmapLaws :: ComposeFam Maybe Either Int Int -> Bool) + prop "satisfies the invmap2 laws" (prop_invmap2Laws :: ComposeFam Maybe Either Int Int -> Bool) +#endif