invariant 0.5.6 → 0.6.5
raw patch · 6 files changed
Files
- CHANGELOG.md +30/−0
- invariant.cabal +14/−17
- src/Data/Functor/Invariant.hs +41/−54
- src/Data/Functor/Invariant/TH.hs +22/−43
- src/Data/Functor/Invariant/TH/Internal.hs +14/−82
- test/THSpec.hs +5/−15
CHANGELOG.md view
@@ -1,3 +1,33 @@+# 0.6.5 [2026.01.10]+* Remove unused `ghc-prim` and `transformers-compat` dependencies.+* Allow building with `template-haskell-2.24.*` (GHC 9.14).++# 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).++# 0.6.2 [2023.08.06]+* The Template Haskell machinery now uses `TemplateHaskellQuotes` when+ building with GHC 8.0+ instead of manually constructing each Template Haskell+ `Name`. A consequence of this is that `invariant` will now build with GHC+ 9.8, as `TemplateHaskellQuotes` abstracts over some internal Template Haskell+ changes introduced in 9.8.++# 0.6.1 [2023.02.27]+* Support `th-abstraction-0.5.*`.++# 0.6 [2022.07.03]+* Loosen the `Monad` constraint in the `Invariant(2)` instances for+ `Kleisli` to an `Invariant` constraint.+* Loosen the `Comonad` constraint in the `Invariant2` instance for `Cokleisli`+ to an `Invariant` constraint.+* Add `Invariant` instances for `PastroSum`, `CopastroSum`, `Environment`,+ `FreeMapping`, `Pastro`, and `FreeTraversing` from the `profunctors` library.+* Add `Invariant(2)` instances for `Copastro` and `Coyoneda` from the+ `profunctors` library.+ # 0.5.6 [2022.05.07] * Add `InvariantProfunctor` and `InvariantArrow` newtypes that admit implementations of `invmap` that only require `Profunctor` or `Arrow`
invariant.cabal view
@@ -1,5 +1,5 @@ name: invariant-version: 0.5.6+version: 0.6.5 synopsis: Haskell98 invariant functors description: Haskell98 invariant functors (also known as exponential functors). .@@ -16,20 +16,20 @@ 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 , GHC == 8.8.4 , GHC == 8.10.7- , GHC == 9.0.1- , GHC == 9.2.1+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.7+ , GHC == 9.8.4+ , GHC == 9.10.3+ , GHC == 9.12.2+ , GHC == 9.14.1 extra-source-files: CHANGELOG.md, README.md source-repository head@@ -44,20 +44,18 @@ 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.7+ , containers >= 0.1 && < 0.9 , contravariant >= 0.5 && < 2- , ghc-prim , profunctors >= 5.2.1 && < 6 , StateVar >= 1.1 && < 2 , stm >= 2.2 && < 3 , tagged >= 0.7.3 && < 1- , template-haskell >= 2.4 && < 2.19- , th-abstraction >= 0.4 && < 0.5+ , template-haskell >= 2.11 && < 2.25+ , th-abstraction >= 0.5 && < 0.8 , transformers >= 0.2 && < 0.7- , transformers-compat >= 0.3 && < 1 , unordered-containers >= 0.2.4 && < 0.3 ghc-options: -Wall @@ -75,7 +73,6 @@ , hspec >= 1.8 , invariant , QuickCheck >= 2.11 && < 3- , template-haskell >= 2.4 && < 2.19 build-tool-depends: hspec-discover:hspec-discover ghc-options: -Wall if impl(ghc >= 8.6)
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)@@ -112,7 +94,7 @@ import Data.Bifunctor.Wrapped -- comonad-import Control.Comonad (Comonad(..), Cokleisli(..), liftW)+import Control.Comonad (Cokleisli(..)) -- containers import Data.IntMap (IntMap)@@ -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,27 +218,19 @@ 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 Monad m => Invariant (Kleisli m a) where- invmap = invmap2 id id+instance Invariant m => Invariant (Kleisli m a) where+ invmap f g (Kleisli m) = Kleisli (invmap f g . m) -- | from "Control.Exception" 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@@ -436,6 +402,9 @@ instance Invariant2 p => Invariant (Closure p a) where invmap = invmap2 id id -- | from the @profunctors@ package+instance Invariant (Environment p a) where+ invmap = invmap2 id id+-- | from the @profunctors@ package instance Invariant2 p => Invariant (Codensity p a) where invmap = invmap2 id id -- | from the @profunctors@ package@@ -457,9 +426,27 @@ instance Invariant2 p => Invariant (Tambara p a) where invmap = invmap2 id id -- | from the @profunctors@ package+instance Invariant (PastroSum p a) where+ invmap = invmap2 id id+-- | from the @profunctors@ package+instance Invariant (FreeMapping p a) where+ invmap = invmap2 id id+-- | from the @profunctors@ package+instance Invariant (FreeTraversing p a) where+ invmap = invmap2 id id+-- | from the @profunctors@ package+instance Invariant (Pastro p a) where+ invmap = invmap2 id id+-- | from the @profunctors@ package instance Invariant (Cotambara p a) where invmap = invmapFunctor -- | from the @profunctors@ package+instance Invariant (Copastro p a) where+ invmap = invmap2 id id+-- | from the @profunctors@ package+instance Invariant (CopastroSum p a) where+ invmap = invmap2 id id+-- | from the @profunctors@ package instance Invariant (CotambaraSum p a) where invmap = invmapFunctor -- | from the @profunctors@ package@@ -468,6 +455,9 @@ -- | from the @profunctors@ package instance Invariant (Yoneda p a) where invmap = invmapFunctor+-- | from the @profunctors@ package+instance Invariant (Coyoneda p a) where+ invmap = invmap2 id id -- | from the @StateVar@ package instance Invariant StateVar where@@ -604,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@@ -617,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@@ -702,8 +688,8 @@ invmap2 _ f' g _ (App.WrapArrow x) = App.WrapArrow $ arr g Cat.. x Cat.. arr f' -- | from "Control.Arrow"-instance Monad m => Invariant2 (Kleisli m) where- invmap2 _ f' g _ (Kleisli m) = Kleisli $ liftM g . m . f'+instance Invariant m => Invariant2 (Kleisli m) where+ invmap2 _ f' g g' (Kleisli m) = Kleisli $ invmap g g' . m . f' -- | from "Data.Semigroup" instance Invariant2 Arg where@@ -739,9 +725,8 @@ invmap2 = invmap2Bifunctor -- | from the @comonad@ package-instance Comonad w => Invariant2 (Cokleisli w) where- invmap2 _ f' g _ (Cokleisli w) = Cokleisli $ g . w . liftW f'-+instance Invariant w => Invariant2 (Cokleisli w) where+ invmap2 f f' g _ (Cokleisli w) = Cokleisli $ g . w . invmap f' f -- | from the @contravariant@ package instance Invariant2 Op where invmap2 f f' g g' (Op x) = Op $ invmap2 g g' f f' x@@ -810,6 +795,9 @@ instance Invariant2 (Cotambara p) where invmap2 = invmap2Profunctor -- | from the @profunctors@ package+instance Invariant2 (Copastro p) where+ invmap2 = invmap2Profunctor+-- | from the @profunctors@ package instance Invariant2 (CopastroSum p) where invmap2 = invmap2Profunctor -- | from the @profunctors@ package@@ -822,6 +810,9 @@ -- | from the @profunctors@ package instance Invariant2 (Yoneda p) where invmap2 = invmap2Profunctor+-- | from the @profunctors@ package+instance Invariant2 (Coyoneda p) where+ invmap2 = invmap2Profunctor -- | from the @tagged@ package instance Invariant2 Tagged where@@ -915,7 +906,6 @@ proextract = unwrapProfunctor produplicate = WrapProfunctor -#if GHC_GENERICS_OK ------------------------------------------------------------------------------- -- GHC Generics -------------------------------------------------------------------------------@@ -947,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@@ -971,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@@ -997,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
@@ -40,7 +40,7 @@ import qualified Data.Map as Map ((!), fromList, keys, lookup, member, size) import Data.Maybe -import Language.Haskell.TH.Datatype+import Language.Haskell.TH.Datatype as Datatype import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr@@ -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@@ -510,14 +497,15 @@ map (substNamesWithKindStar (List.union droppedKindVarNames kvNames')) $ take remainingLength varTysOrig - isDataFamily :: Bool- isDataFamily = case variant of- Datatype -> False- Newtype -> False- DataInstance -> True- NewtypeInstance -> True+ isDataFamily <-+ case variant of+ Datatype -> return False+ Newtype -> return False+ DataInstance -> return True+ NewtypeInstance -> return True+ Datatype.TypeData -> typeDataError tyConName - remainingTysOrigSubst' :: [Type]+ let remainingTysOrigSubst' :: [Type] -- See Note [Kind signatures in derived instances] for an explanation -- of the isDataFamily check. remainingTysOrigSubst' =@@ -700,6 +688,15 @@ "Cannot eta-reduce to an instance of form \n\tinstance (...) => " ++ pprint instanceType +-- | We cannot implement class methods at the term level for @type data@+-- declarations, which only exist at the type level.+typeDataError :: Name -> Q a+typeDataError dataName = fail+ . showString "Cannot derive instance for ‘"+ . showString (nameBase dataName)+ . showString "‘, which is a ‘type data‘ declaration"+ $ ""+ ------------------------------------------------------------------------------- -- Generic traversal for functor-like deriving -------------------------------------------------------------------------------@@ -788,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@@ -803,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@@ -820,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) @@ -850,8 +834,7 @@ mkSimpleLam :: (Exp -> Q Exp) -> Q Exp mkSimpleLam lam = do n <- newName "n"- body <- lam (VarE n)- return $ LamE [VarP n] body+ lamE [varP n] (lam (VarE n)) -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" --@@ -879,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)@@ -889,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,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskellQuotes #-} {-| Module: Data.Functor.Invariant.TH.Internal@@ -11,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)@@ -24,21 +26,12 @@ import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax -#ifndef CURRENT_PACKAGE_KEY-import Data.Version (showVersion)-import Paths_invariant (version)-#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)@@ -105,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.@@ -128,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@@ -196,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:@@ -261,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@@ -306,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@@ -347,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:@@ -376,57 +330,35 @@ -- | 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 ---------------------------------------------------------------------------------- Manually quoted names+-- Quoted names ------------------------------------------------------------------------------- --- 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"+invariantTypeName = ''Invariant invariant2TypeName :: Name-invariant2TypeName = mkInvariantName_tc "Data.Functor.Invariant" "Invariant2"+invariant2TypeName = ''Invariant2 invmapValName :: Name-invmapValName = mkInvariantName_v "Data.Functor.Invariant" "invmap"+invmapValName = 'invmap invmap2ValName :: Name-invmap2ValName = mkInvariantName_v "Data.Functor.Invariant" "invmap2"+invmap2ValName = 'invmap2 invmapConstValName :: Name-invmapConstValName = mkInvariantName_v "Data.Functor.Invariant.TH.Internal" "invmapConst"+invmapConstValName = 'invmapConst invmap2ConstValName :: Name-invmap2ConstValName = mkInvariantName_v "Data.Functor.Invariant.TH.Internal" "invmap2Const"+invmap2ConstValName = 'invmap2Const coerceValName :: Name-coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce"+coerceValName = 'coerce errorValName :: Name-errorValName = mkNameG_v "base" "GHC.Err" "error"+errorValName = 'error seqValName :: Name-seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq"+seqValName = 'seq
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