invariant 0.6.3 → 0.6.4
raw patch · 6 files changed
+30/−229 lines, 6 filesdep ~basedep ~containersdep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, containers, template-haskell, th-abstraction
API changes (from Hackage documentation)
Files
- CHANGELOG.md +3/−0
- invariant.cabal +8/−13
- src/Data/Functor/Invariant.hs +4/−46
- src/Data/Functor/Invariant/TH.hs +7/−41
- src/Data/Functor/Invariant/TH/Internal.hs +3/−114
- test/THSpec.hs +5/−15
CHANGELOG.md view
@@ -1,3 +1,6 @@+# 0.6.4 [2024.12.05]+* Drop support for pre-8.0 versions of GHC.+ # 0.6.3 [2024.03.19] * Support building with `template-haskell-2.22.*` (GHC 9.10).
invariant.cabal view
@@ -1,5 +1,5 @@ name: invariant-version: 0.6.3+version: 0.6.4 synopsis: Haskell98 invariant functors description: Haskell98 invariant functors (also known as exponential functors). .@@ -16,13 +16,7 @@ Ryan Scott <ryan.gl.scott@gmail.com> build-type: Simple cabal-version: >= 1.10-tested-with: GHC == 7.0.4- , GHC == 7.2.2- , GHC == 7.4.2- , GHC == 7.6.3- , GHC == 7.8.4- , GHC == 7.10.3- , GHC == 8.0.2+tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5@@ -31,9 +25,10 @@ , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.8- , GHC == 9.6.4- , GHC == 9.8.2+ , GHC == 9.6.6+ , GHC == 9.8.4 , GHC == 9.10.1+ , GHC == 9.12.1 extra-source-files: CHANGELOG.md, README.md source-repository head@@ -48,7 +43,7 @@ hs-source-dirs: src default-language: Haskell2010 build-depends: array >= 0.3 && < 0.6- , base >= 4 && < 5+ , base >= 4.9 && < 5 , bifunctors >= 5.2 && < 6 , comonad >= 5 && < 6 , containers >= 0.1 && < 0.8@@ -58,8 +53,8 @@ , StateVar >= 1.1 && < 2 , stm >= 2.2 && < 3 , tagged >= 0.7.3 && < 1- , template-haskell >= 2.4 && < 2.23- , th-abstraction >= 0.4 && < 0.8+ , template-haskell >= 2.11 && < 2.24+ , th-abstraction >= 0.5 && < 0.8 , transformers >= 0.2 && < 0.7 , transformers-compat >= 0.3 && < 1 , unordered-containers >= 0.2.4 && < 0.3
src/Data/Functor/Invariant.hs view
@@ -1,21 +1,14 @@ {-# LANGUAGE CPP #-} #if !(MIN_VERSION_base(4,16,0)) || !(MIN_VERSION_transformers(0,6,0))-{-# OPTIONS_GHC -fno-warn-deprecations #-}+{-# OPTIONS_GHC -Wno-deprecations #-} #endif -#define GHC_GENERICS_OK __GLASGOW_HASKELL__ >= 702--#if GHC_GENERICS_OK {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-#endif--#if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-}-#endif+{-# LANGUAGE TypeFamilies #-} {-| Module: Data.Functor.Invariant@@ -35,11 +28,9 @@ ( -- * @Invariant@ Invariant(..) , invmapFunctor-#if GHC_GENERICS_OK -- ** @GHC.Generics@ -- $ghcgenerics , genericInvmap-#endif , WrappedFunctor(..) , invmapContravariant , invmapProfunctor@@ -64,22 +55,15 @@ import Control.Monad (MonadPlus(..), liftM) import qualified Control.Monad.ST as Strict (ST) import qualified Control.Monad.ST.Lazy as Lazy (ST)-#if MIN_VERSION_base(4,4,0) import Data.Complex (Complex(..))-#endif import qualified Data.Foldable as F (Foldable(..)) import qualified Data.Functor.Compose as Functor (Compose(..)) import Data.Functor.Identity (Identity) import Data.Functor.Product as Functor (Product(..)) import Data.Functor.Sum as Functor (Sum(..))-#if __GLASGOW_HASKELL__ < 711-import Data.Ix (Ix)-#endif import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Monoid as Monoid (First(..), Last(..), Product(..), Sum(..))-#if MIN_VERSION_base(4,8,0) import Data.Monoid (Alt(..))-#endif import Data.Monoid (Dual(..), Endo(..)) import Data.Proxy (Proxy(..)) import qualified Data.Semigroup as Semigroup (First(..), Last(..))@@ -88,9 +72,7 @@ #endif import Data.Semigroup (Min(..), Max(..), Arg(..)) import qualified Data.Traversable as T (Traversable(..))-#if GHC_GENERICS_OK import GHC.Generics-#endif import System.Console.GetOpt as GetOpt import Text.ParserCombinators.ReadP (ReadP) import Text.ParserCombinators.ReadPrec (ReadPrec)@@ -186,10 +168,8 @@ -- > invmap f2 f2' . invmap f1 f1' = invmap (f2 . f1) (f1' . f2') class Invariant f where invmap :: (a -> b) -> (b -> a) -> f a -> f b-#if GHC_GENERICS_OK default invmap :: (Generic1 f, Invariant (Rep1 f)) => (a -> b) -> (b -> a) -> f a -> f b invmap = genericInvmap-#endif -- | Every 'Functor' is also an 'Invariant' functor. invmapFunctor :: Functor f => (a -> b) -> (b -> a) -> f a -> f b@@ -238,13 +218,7 @@ invmap f _ (App.WrapArrow x) = App.WrapArrow $ ((arr f) Cat.. x) -- | from "Control.Arrow"-instance-#if MIN_VERSION_base(4,4,0)- Arrow a-#else- ArrowApply a-#endif- => Invariant (ArrowMonad a) where+instance Arrow a => Invariant (ArrowMonad a) where invmap f _ (ArrowMonad m) = ArrowMonad (m >>> arr f) -- | from "Control.Arrow" instance Invariant m => Invariant (Kleisli m a) where@@ -254,11 +228,9 @@ instance Invariant Handler where invmap f _ (Handler h) = Handler (fmap f . h) -#if MIN_VERSION_base(4,4,0) -- | from "Data.Complex" instance Invariant Complex where invmap f _ (r :+ i) = f r :+ f i-#endif -- | from "Data.Functor.Compose" instance (Invariant f, Invariant g) => Invariant (Functor.Compose f g) where@@ -300,11 +272,9 @@ -- | from "Data.Monoid" instance Invariant Monoid.Sum where invmap f _ (Monoid.Sum x) = Monoid.Sum (f x)-#if MIN_VERSION_base(4,8,0) -- | from "Data.Monoid" instance Invariant f => Invariant (Alt f) where invmap f g (Alt x) = Alt (invmap f g x)-#endif -- | from "Data.Proxy" instance Invariant Proxy where@@ -346,11 +316,7 @@ invmap f g (GetOpt.Option a b argDescr c) = GetOpt.Option a b (invmap f g argDescr) c -- | from the @array@ package-instance-#if __GLASGOW_HASKELL__ < 711- Ix i =>-#endif- Invariant (Array i) where+instance Invariant (Array i) where invmap = invmapFunctor -- | from the @bifunctors@ package@@ -628,11 +594,8 @@ 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@@ -641,7 +604,6 @@ minimum = F.minimum . unwrapFunctor sum = F.sum . unwrapFunctor product = F.product . unwrapFunctor-#endif #if MIN_VERSION_base(4,13,0) foldMap' f = F.foldMap' f . unwrapFunctor #endif@@ -944,7 +906,6 @@ proextract = unwrapProfunctor produplicate = WrapProfunctor -#if GHC_GENERICS_OK ------------------------------------------------------------------------------- -- GHC Generics -------------------------------------------------------------------------------@@ -976,7 +937,6 @@ instance (Invariant f, Invariant g) => Invariant ((:.:) f g) where invmap f g (Comp1 fgp) = Comp1 $ invmap (invmap f g) (invmap g f) fgp -# if __GLASGOW_HASKELL__ >= 800 -- | from "GHC.Generics" instance Invariant UAddr where invmap _ _ (UAddr a) = UAddr a@@ -1000,7 +960,6 @@ -- | from "GHC.Generics" instance Invariant UWord where invmap _ _ (UWord w) = UWord w-# endif {- $ghcgenerics With GHC 7.2 or later, 'Invariant' instances can be defined easily using GHC@@ -1026,7 +985,6 @@ -- | A generic implementation of 'invmap'. genericInvmap :: (Generic1 f, Invariant (Rep1 f)) => (a -> b) -> (b -> a) -> f a -> f b genericInvmap f g = to1 . invmap f g . from1-#endif ------------------------------------------------------------------------------- -- Wrappers
src/Data/Functor/Invariant/TH.hs view
@@ -337,20 +337,14 @@ makeFun :: Name -> TyVarMap -> Q Exp makeFun value tvMap = do-#if MIN_VERSION_template_haskell(2,9,0) roles <- reifyRoles _parentName let rroles = roles-#endif case () of- _--#if MIN_VERSION_template_haskell(2,9,0)- | (length rroles >= numNbs) &&+ _ | (length rroles >= numNbs) && (all (== PhantomR) (drop (length rroles - numNbs) rroles)) -> varE coerceValName `appE` varE value-#endif - | null cons && emptyCaseBehavior opts && ghc7'8OrLater+ | null cons && emptyCaseBehavior opts -> caseE (varE value) [] | null cons@@ -362,13 +356,6 @@ -> caseE (varE value) (map (makeInvmapForCon iClass tvMap) cons) - ghc7'8OrLater :: Bool-#if __GLASGOW_HASKELL__ >= 708- ghc7'8OrLater = True-#else- ghc7'8OrLater = False-#endif- -- | Generates a match for invmap(2) for a single constructor. makeInvmapForCon :: InvariantClass -> TyVarMap -> ConstructorInfo -> Q Match makeInvmapForCon iClass tvMap@@ -512,13 +499,11 @@ isDataFamily <- case variant of- Datatype -> return False- Newtype -> return False- DataInstance -> return True- NewtypeInstance -> return True-#if MIN_VERSION_th_abstraction(0,5,0)+ Datatype -> return False+ Newtype -> return False+ DataInstance -> return True+ NewtypeInstance -> return True Datatype.TypeData -> typeDataError tyConName-#endif let remainingTysOrigSubst' :: [Type] -- See Note [Kind signatures in derived instances] for an explanation@@ -703,7 +688,6 @@ "Cannot eta-reduce to an instance of form \n\tinstance (...) => " ++ pprint instanceType -#if MIN_VERSION_th_abstraction(0,5,0) -- | We cannot implement class methods at the term level for @type data@ -- declarations, which only exist at the type level. typeDataError :: Name -> Q a@@ -712,7 +696,6 @@ . showString (nameBase dataName) . showString "‘, which is a ‘type data‘ declaration" $ ""-#endif ------------------------------------------------------------------------------- -- Generic traversal for functor-like deriving@@ -802,10 +785,8 @@ -- and at least one xr is True | TupleT len <- f -> tuple $ Boxed len-#if MIN_VERSION_template_haskell(2,6,0) | UnboxedTupleT len <- f -> tuple $ Unboxed len-#endif | fc || or (take numFirstArgs xcs) -> wrongArg -- T (..var..) ty_1 ... ty_n | otherwise -- T (..no var..) ty_1 ... ty_n@@ -817,7 +798,7 @@ $ zip3 args xrs contraXrs , True ) go co (SigT t k) = do- (_, kc) <- go_kind co k+ (_, kc) <- go co k if kc then return (caseWrongArg, True) else go co t@@ -834,17 +815,6 @@ else return (caseForAll tvbs tr, True) go _ _ = trivial - {-- go_kind :: Bool- -> Kind- -> Q (a, Bool)- -}-#if MIN_VERSION_template_haskell(2,9,0)- go_kind = go-#else- go_kind _ _ = trivial-#endif- -- trivial :: Q (a, Bool) trivial = return (caseTrivial, False) @@ -892,9 +862,7 @@ -- corresponds to @Unboxed 3@. data TupleSort = Boxed Int-#if MIN_VERSION_template_haskell(2,6,0) | Unboxed Int-#endif -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" mkSimpleTupleCase :: (Name -> [a] -> Q Match)@@ -902,8 +870,6 @@ mkSimpleTupleCase matchForCon tupSort insides x = do let tupDataName = case tupSort of Boxed len -> tupleDataName len-#if MIN_VERSION_template_haskell(2,6,0) Unboxed len -> unboxedTupleDataName len-#endif m <- matchForCon tupDataName insides return $ CaseE x [m]
src/Data/Functor/Invariant/TH/Internal.hs view
@@ -1,8 +1,5 @@ {-# LANGUAGE CPP #-}--#if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TemplateHaskellQuotes #-}-#endif {-| Module: Data.Functor.Invariant.TH.Internal@@ -15,8 +12,9 @@ -} module Data.Functor.Invariant.TH.Internal where +import Data.Coerce (coerce) import Data.Foldable (foldr')-import Data.Functor.Invariant () -- To import the instances+import Data.Functor.Invariant (Invariant(..), Invariant2(..)) import qualified Data.List as List import qualified Data.Map as Map (singleton) import Data.Map (Map)@@ -28,26 +26,12 @@ import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax -#if __GLASGOW_HASKELL__ >= 800-import Data.Coerce (coerce)-import Data.Functor.Invariant (Invariant(..), Invariant2(..))-#else-# ifndef CURRENT_PACKAGE_KEY-import Data.Version (showVersion)-import Paths_invariant (version)-# endif-#endif- ------------------------------------------------------------------------------- -- Expanding type synonyms ------------------------------------------------------------------------------- applySubstitutionKind :: Map Name Kind -> Type -> Type-#if MIN_VERSION_template_haskell(2,8,0) applySubstitutionKind = applySubstitution-#else-applySubstitutionKind _ t = t-#endif substNameWithKind :: Name -> Kind -> Type -> Type substNameWithKind n k = applySubstitutionKind (Map.singleton n k)@@ -114,9 +98,7 @@ canRealizeKindStar t | hasKindStar t = KindStar | otherwise = case t of-#if MIN_VERSION_template_haskell(2,8,0) SigT _ (VarT k) -> IsKindVar k-#endif _ -> NotKindStar -- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.@@ -137,21 +119,13 @@ -- | Returns True if a Type has kind *. hasKindStar :: Type -> Bool hasKindStar VarT{} = True-#if MIN_VERSION_template_haskell(2,8,0) hasKindStar (SigT _ StarT) = True-#else-hasKindStar (SigT _ StarK) = True-#endif hasKindStar _ = False -- Returns True is a kind is equal to *, or if it is a kind variable. isStarOrVar :: Kind -> Bool-#if MIN_VERSION_template_haskell(2,8,0) isStarOrVar StarT = True isStarOrVar VarT{} = True-#else-isStarOrVar StarK = True-#endif isStarOrVar _ = False -- | @hasKindVarChain n kind@ Checks if @kind@ is of the form@@ -205,11 +179,7 @@ -- | Applies a typeclass constraint to a type. applyClass :: Name -> Name -> Pred-#if MIN_VERSION_template_haskell(2,10,0) applyClass con t = AppT (ConT con) (VarT t)-#else-applyClass con t = ClassP con [VarT t]-#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:@@ -270,25 +240,10 @@ go tcName = do info <- reify tcName case info of-#if MIN_VERSION_template_haskell(2,11,0) FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _ -> withinFirstArgs bndrs-#elif MIN_VERSION_template_haskell(2,7,0)- FamilyI (FamilyD TypeFam _ bndrs _) _- -> withinFirstArgs bndrs-#else- TyConI (FamilyD TypeFam _ bndrs _)- -> withinFirstArgs bndrs-#endif--#if MIN_VERSION_template_haskell(2,11,0) FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _ -> withinFirstArgs bndrs-#elif MIN_VERSION_template_haskell(2,9,0)- FamilyI (ClosedTypeFamilyD _ bndrs _ _) _- -> withinFirstArgs bndrs-#endif- _ -> return False where withinFirstArgs :: [a] -> Q Bool@@ -315,21 +270,13 @@ where go :: Type -> [Name] -> Bool go (AppT t1 t2) names = go t1 names || go t2 names- go (SigT t _k) names = go t names-#if MIN_VERSION_template_haskell(2,8,0)- || go _k names-#endif+ go (SigT t k) names = go t names || go k names go (VarT n) names = n `elem` names go _ _ = False -- | Does an instance predicate mention any of the Names in the list? predMentionsName :: Pred -> [Name] -> Bool-#if MIN_VERSION_template_haskell(2,10,0) predMentionsName = mentionsName-#else-predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys-predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names-#endif -- | Construct a type via curried application. applyTy :: Type -> [Type] -> Type@@ -356,10 +303,8 @@ go :: Type -> Type -> [Type] -> (Type, [Type]) go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args) go origTy (SigT ty' _) args = go origTy ty' args-#if MIN_VERSION_template_haskell(2,11,0) go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args go origTy (ParensT ty') args = go origTy ty' args-#endif go origTy _ args = (origTy, args) -- | Split a type signature by the arrows on its spine. For example, this:@@ -385,21 +330,12 @@ -- | Like uncurryType, except on a kind level. uncurryKind :: Kind -> [Kind]-#if MIN_VERSION_template_haskell(2,8,0) uncurryKind = snd . uncurryTy-#else-uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2-uncurryKind k = [k]-#endif ------------------------------------------------------------------------------- -- Quoted names ------------------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 800--- With GHC 8.0 or later, we can simply use TemplateHaskellQuotes to quote each--- name. Life is good.- invariantTypeName :: Name invariantTypeName = ''Invariant @@ -426,50 +362,3 @@ seqValName :: Name seqValName = 'seq-#else--- On pre-8.0 GHCs, we do not have access to the TemplateHaskellQuotes--- extension, so we construct the Template Haskell names by hand.--- By manually generating these names we avoid needing to use the--- TemplateHaskell language extension when compiling the invariant library.--- This allows the library to be used in stage1 cross-compilers.--invariantPackageKey :: String-# ifdef CURRENT_PACKAGE_KEY-invariantPackageKey = CURRENT_PACKAGE_KEY-# else-invariantPackageKey = "invariant-" ++ showVersion version-# endif--mkInvariantName_tc :: String -> String -> Name-mkInvariantName_tc = mkNameG_tc invariantPackageKey--mkInvariantName_v :: String -> String -> Name-mkInvariantName_v = mkNameG_v invariantPackageKey--invariantTypeName :: Name-invariantTypeName = mkInvariantName_tc "Data.Functor.Invariant" "Invariant"--invariant2TypeName :: Name-invariant2TypeName = mkInvariantName_tc "Data.Functor.Invariant" "Invariant2"--invmapValName :: Name-invmapValName = mkInvariantName_v "Data.Functor.Invariant" "invmap"--invmap2ValName :: Name-invmap2ValName = mkInvariantName_v "Data.Functor.Invariant" "invmap2"--invmapConstValName :: Name-invmapConstValName = mkInvariantName_v "Data.Functor.Invariant.TH.Internal" "invmapConst"--invmap2ConstValName :: Name-invmap2ConstValName = mkInvariantName_v "Data.Functor.Invariant.TH.Internal" "invmap2Const"--coerceValName :: Name-coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce"--errorValName :: Name-errorValName = mkNameG_v "base" "GHC.Err" "error"--seqValName :: Name-seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq"-#endif
test/THSpec.hs view
@@ -1,22 +1,18 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE RoleAnnotations #-}-#endif -{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# OPTIONS_GHC -fno-warn-unused-matches #-}-#if __GLASGOW_HASKELL__ >= 800-{-# OPTIONS_GHC -fno-warn-unused-foralls #-}-#endif+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_GHC -Wno-unused-matches #-}+{-# OPTIONS_GHC -Wno-unused-foralls #-} module THSpec (main, spec) where import Data.Functor.Invariant@@ -69,9 +65,7 @@ data Empty1 a b data Empty2 a b-#if __GLASGOW_HASKELL__ >= 708 type role Empty2 nominal nominal-#endif data TyCon18 a b c = TyCon18 c (TyCon18 a a c) @@ -183,7 +177,6 @@ $(deriveInvariant ''TyCon20) $(deriveInvariant2 ''TyCon20) -#if MIN_VERSION_template_haskell(2,7,0) -- Data Families $(deriveInvariant 'T1Fam)@@ -219,7 +212,6 @@ $(deriveInvariant 'TyFamily20) $(deriveInvariant2 'TyFamily20)-#endif ------------------------------------------------------------------------------- @@ -243,8 +235,6 @@ describe "Compose Maybe Either Int Int" $ do prop "satisfies the invmap laws" (prop_invmapLaws :: Compose Maybe Either Int Int -> Expectation) prop "satisfies the invmap2 laws" (prop_invmap2Laws :: Compose Maybe Either Int Int -> Expectation)-#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 -> Expectation) prop "satisfies the invmap2 laws" (prop_invmap2Laws :: ComposeFam Maybe Either Int Int -> Expectation)-#endif