invariant 0.2 → 0.2.1
raw patch · 7 files changed
+264/−187 lines, 7 filesdep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: template-haskell
API changes (from Hackage documentation)
+ Data.Functor.Invariant: instance Foldable f => Foldable (WrappedFunctor f)
+ Data.Functor.Invariant: instance Traversable f => Traversable (WrappedFunctor f)
Files
- CHANGELOG.md +4/−0
- README.md +16/−1
- invariant.cabal +2/−2
- src/Data/Functor/Invariant.hs +31/−1
- src/Data/Functor/Invariant/TH.hs +109/−169
- src/Data/Functor/Invariant/TH/Internal.hs +15/−10
- test/THSpec.hs +87/−4
CHANGELOG.md view
@@ -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
README.md view
@@ -1,3 +1,18 @@-# `invariant` [](http://hackage.haskell.org/package/invariant) [](https://travis-ci.org/nfrisby/invariant-functors)+# `invariant`+[][Hackage: invariant]+[](http://packdeps.haskellers.com/reverse/invariant)+[][Haskell.org]+[][tl;dr Legal: BSD3]+[](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
invariant.cabal view
@@ -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
src/Data/Functor/Invariant.hs view
@@ -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
src/Data/Functor/Invariant/TH.hs view
@@ -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.
src/Data/Functor/Invariant/TH/Internal.hs view
@@ -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
test/THSpec.hs view
@@ -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