{-# LANGUAGE CPP #-}
module Data.Functor.Invariant.TH.Internal where
import Data.Foldable (foldr')
import Data.Functor.Invariant ()
import qualified Data.List as List
import qualified Data.Map as Map (singleton)
import Data.Map (Map)
import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Set as Set
import Data.Set (Set)
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
#ifndef CURRENT_PACKAGE_KEY
import Data.Version (showVersion)
import Paths_invariant (version)
#endif
applySubstitutionKind :: Map Name Kind -> Type -> Type
#if MIN_VERSION_template_haskell(2,8,0)
applySubstitutionKind :: Map Name Kind -> Kind -> Kind
applySubstitutionKind = Map Name Kind -> Kind -> Kind
forall a. TypeSubstitution a => Map Name Kind -> a -> a
applySubstitution
#else
applySubstitutionKind _ t = t
#endif
substNameWithKind :: Name -> Kind -> Type -> Type
substNameWithKind :: Name -> Kind -> Kind -> Kind
substNameWithKind Name
n Kind
k = Map Name Kind -> Kind -> Kind
applySubstitutionKind (Name -> Kind -> Map Name Kind
forall k a. k -> a -> Map k a
Map.singleton Name
n Kind
k)
substNamesWithKindStar :: [Name] -> Type -> Type
substNamesWithKindStar :: [Name] -> Kind -> Kind
substNamesWithKindStar [Name]
ns Kind
t = (Name -> Kind -> Kind) -> Kind -> [Name] -> Kind
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' ((Name -> Kind -> Kind -> Kind) -> Kind -> Name -> Kind -> Kind
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Kind -> Kind -> Kind
substNameWithKind Kind
starK) Kind
t [Name]
ns
data InvariantClass = Invariant | Invariant2
deriving (InvariantClass -> InvariantClass -> Bool
(InvariantClass -> InvariantClass -> Bool)
-> (InvariantClass -> InvariantClass -> Bool) -> Eq InvariantClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InvariantClass -> InvariantClass -> Bool
$c/= :: InvariantClass -> InvariantClass -> Bool
== :: InvariantClass -> InvariantClass -> Bool
$c== :: InvariantClass -> InvariantClass -> Bool
Eq, Eq InvariantClass
Eq InvariantClass
-> (InvariantClass -> InvariantClass -> Ordering)
-> (InvariantClass -> InvariantClass -> Bool)
-> (InvariantClass -> InvariantClass -> Bool)
-> (InvariantClass -> InvariantClass -> Bool)
-> (InvariantClass -> InvariantClass -> Bool)
-> (InvariantClass -> InvariantClass -> InvariantClass)
-> (InvariantClass -> InvariantClass -> InvariantClass)
-> Ord InvariantClass
InvariantClass -> InvariantClass -> Bool
InvariantClass -> InvariantClass -> Ordering
InvariantClass -> InvariantClass -> InvariantClass
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: InvariantClass -> InvariantClass -> InvariantClass
$cmin :: InvariantClass -> InvariantClass -> InvariantClass
max :: InvariantClass -> InvariantClass -> InvariantClass
$cmax :: InvariantClass -> InvariantClass -> InvariantClass
>= :: InvariantClass -> InvariantClass -> Bool
$c>= :: InvariantClass -> InvariantClass -> Bool
> :: InvariantClass -> InvariantClass -> Bool
$c> :: InvariantClass -> InvariantClass -> Bool
<= :: InvariantClass -> InvariantClass -> Bool
$c<= :: InvariantClass -> InvariantClass -> Bool
< :: InvariantClass -> InvariantClass -> Bool
$c< :: InvariantClass -> InvariantClass -> Bool
compare :: InvariantClass -> InvariantClass -> Ordering
$ccompare :: InvariantClass -> InvariantClass -> Ordering
$cp1Ord :: Eq InvariantClass
Ord)
instance Enum InvariantClass where
fromEnum :: InvariantClass -> Int
fromEnum InvariantClass
Invariant = Int
1
fromEnum InvariantClass
Invariant2 = Int
2
toEnum :: Int -> InvariantClass
toEnum Int
1 = InvariantClass
Invariant
toEnum Int
2 = InvariantClass
Invariant2
toEnum Int
i = [Char] -> InvariantClass
forall a. HasCallStack => [Char] -> a
error ([Char] -> InvariantClass) -> [Char] -> InvariantClass
forall a b. (a -> b) -> a -> b
$ [Char]
"No Invariant class for number " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i
invmapConstName :: InvariantClass -> Name
invmapConstName :: InvariantClass -> Name
invmapConstName InvariantClass
Invariant = Name
invmapConstValName
invmapConstName InvariantClass
Invariant2 = Name
invmap2ConstValName
invariantClassName :: InvariantClass -> Name
invariantClassName :: InvariantClass -> Name
invariantClassName InvariantClass
Invariant = Name
invariantTypeName
invariantClassName InvariantClass
Invariant2 = Name
invariant2TypeName
invmapName :: InvariantClass -> Name
invmapName :: InvariantClass -> Name
invmapName InvariantClass
Invariant = Name
invmapValName
invmapName InvariantClass
Invariant2 = Name
invmap2ValName
invmapConst :: f b -> (a -> b) -> (b -> a) -> f a -> f b
invmapConst :: f b -> (a -> b) -> (b -> a) -> f a -> f b
invmapConst = ((b -> a) -> f a -> f b) -> (a -> b) -> (b -> a) -> f a -> f b
forall a b. a -> b -> a
const (((b -> a) -> f a -> f b) -> (a -> b) -> (b -> a) -> f a -> f b)
-> (f b -> (b -> a) -> f a -> f b)
-> f b
-> (a -> b)
-> (b -> a)
-> f a
-> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f a -> f b) -> (b -> a) -> f a -> f b
forall a b. a -> b -> a
const ((f a -> f b) -> (b -> a) -> f a -> f b)
-> (f b -> f a -> f b) -> f b -> (b -> a) -> f a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f b -> f a -> f b
forall a b. a -> b -> a
const
{-# INLINE invmapConst #-}
invmap2Const :: f c d
-> (a -> c) -> (c -> a)
-> (b -> d) -> (d -> b)
-> f a b -> f c d
invmap2Const :: f c d
-> (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> f a b -> f c d
invmap2Const = ((c -> a) -> (b -> d) -> (d -> b) -> f a b -> f c d)
-> (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> f a b -> f c d
forall a b. a -> b -> a
const (((c -> a) -> (b -> d) -> (d -> b) -> f a b -> f c d)
-> (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> f a b -> f c d)
-> (f c d -> (c -> a) -> (b -> d) -> (d -> b) -> f a b -> f c d)
-> f c d
-> (a -> c)
-> (c -> a)
-> (b -> d)
-> (d -> b)
-> f a b
-> f c d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b -> d) -> (d -> b) -> f a b -> f c d)
-> (c -> a) -> (b -> d) -> (d -> b) -> f a b -> f c d
forall a b. a -> b -> a
const (((b -> d) -> (d -> b) -> f a b -> f c d)
-> (c -> a) -> (b -> d) -> (d -> b) -> f a b -> f c d)
-> (f c d -> (b -> d) -> (d -> b) -> f a b -> f c d)
-> f c d
-> (c -> a)
-> (b -> d)
-> (d -> b)
-> f a b
-> f c d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((d -> b) -> f a b -> f c d)
-> (b -> d) -> (d -> b) -> f a b -> f c d
forall a b. a -> b -> a
const (((d -> b) -> f a b -> f c d)
-> (b -> d) -> (d -> b) -> f a b -> f c d)
-> (f c d -> (d -> b) -> f a b -> f c d)
-> f c d
-> (b -> d)
-> (d -> b)
-> f a b
-> f c d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f a b -> f c d) -> (d -> b) -> f a b -> f c d
forall a b. a -> b -> a
const ((f a b -> f c d) -> (d -> b) -> f a b -> f c d)
-> (f c d -> f a b -> f c d) -> f c d -> (d -> b) -> f a b -> f c d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f c d -> f a b -> f c d
forall a b. a -> b -> a
const
{-# INLINE invmap2Const #-}
data StarKindStatus = NotKindStar
| KindStar
| IsKindVar Name
deriving StarKindStatus -> StarKindStatus -> Bool
(StarKindStatus -> StarKindStatus -> Bool)
-> (StarKindStatus -> StarKindStatus -> Bool) -> Eq StarKindStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StarKindStatus -> StarKindStatus -> Bool
$c/= :: StarKindStatus -> StarKindStatus -> Bool
== :: StarKindStatus -> StarKindStatus -> Bool
$c== :: StarKindStatus -> StarKindStatus -> Bool
Eq
canRealizeKindStar :: Type -> StarKindStatus
canRealizeKindStar :: Kind -> StarKindStatus
canRealizeKindStar Kind
t
| Kind -> Bool
hasKindStar Kind
t = StarKindStatus
KindStar
| Bool
otherwise = case Kind
t of
#if MIN_VERSION_template_haskell(2,8,0)
SigT Kind
_ (VarT Name
k) -> Name -> StarKindStatus
IsKindVar Name
k
#endif
Kind
_ -> StarKindStatus
NotKindStar
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName (IsKindVar Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
starKindStatusToName StarKindStatus
_ = Maybe Name
forall a. Maybe a
Nothing
catKindVarNames :: [StarKindStatus] -> [Name]
catKindVarNames :: [StarKindStatus] -> [Name]
catKindVarNames = (StarKindStatus -> Maybe Name) -> [StarKindStatus] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe StarKindStatus -> Maybe Name
starKindStatusToName
hasKindStar :: Type -> Bool
hasKindStar :: Kind -> Bool
hasKindStar VarT{} = Bool
True
#if MIN_VERSION_template_haskell(2,8,0)
hasKindStar (SigT Kind
_ Kind
StarT) = Bool
True
#else
hasKindStar (SigT _ StarK) = True
#endif
hasKindStar Kind
_ = Bool
False
isStarOrVar :: Kind -> Bool
#if MIN_VERSION_template_haskell(2,8,0)
isStarOrVar :: Kind -> Bool
isStarOrVar Kind
StarT = Bool
True
isStarOrVar VarT{} = Bool
True
#else
isStarOrVar StarK = True
#endif
isStarOrVar Kind
_ = Bool
False
hasKindVarChain :: Int -> Type -> Maybe [Name]
hasKindVarChain :: Int -> Kind -> Maybe [Name]
hasKindVarChain Int
kindArrows Kind
t =
let uk :: [Kind]
uk = Kind -> [Kind]
uncurryKind (Kind -> Kind
tyKind Kind
t)
in if ([Kind] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
uk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
kindArrows) Bool -> Bool -> Bool
&& (Kind -> Bool) -> [Kind] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Kind -> Bool
isStarOrVar [Kind]
uk
then [Name] -> Maybe [Name]
forall a. a -> Maybe a
Just ([Kind] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Kind]
uk)
else Maybe [Name]
forall a. Maybe a
Nothing
tyKind :: Type -> Kind
tyKind :: Kind -> Kind
tyKind (SigT Kind
_ Kind
k) = Kind
k
tyKind Kind
_ = Kind
starK
type TyVarMap = Map Name (Name, Name)
fst3 :: (a, b, c) -> a
fst3 :: (a, b, c) -> a
fst3 (a
a, b
_, c
_) = a
a
thd3 :: (a, b, c) -> c
thd3 :: (a, b, c) -> c
thd3 (a
_, b
_, c
c) = c
c
lookup2 :: Eq a => a -> [(a, b, c)] -> Maybe (b, c)
lookup2 :: a -> [(a, b, c)] -> Maybe (b, c)
lookup2 a
_ [] = Maybe (b, c)
forall a. Maybe a
Nothing
lookup2 a
key ((a
x,b
y,c
z):[(a, b, c)]
xyzs)
| a
key a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x = (b, c) -> Maybe (b, c)
forall a. a -> Maybe a
Just (b
y, c
z)
| Bool
otherwise = a -> [(a, b, c)] -> Maybe (b, c)
forall a b c. Eq a => a -> [(a, b, c)] -> Maybe (b, c)
lookup2 a
key [(a, b, c)]
xyzs
newNameList :: String -> Int -> Q [Name]
newNameList :: [Char] -> Int -> Q [Name]
newNameList [Char]
prefix Int
n = (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Char] -> Q Name
newName ([Char] -> Q Name) -> (Int -> [Char]) -> Int -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
prefix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> (Int -> [Char]) -> Int -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show) [Int
1..Int
n]
createKindChain :: Int -> Kind
createKindChain :: Int -> Kind
createKindChain = Kind -> Int -> Kind
go Kind
starK
where
go :: Kind -> Int -> Kind
go :: Kind -> Int -> Kind
go Kind
k Int
0 = Kind
k
go Kind
k Int
n = Int
n Int -> Kind -> Kind
`seq` Kind -> Int -> Kind
go (Kind -> Kind -> Kind
arrowKCompat Kind
starK Kind
k) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
applyClass :: Name -> Name -> Pred
#if MIN_VERSION_template_haskell(2,10,0)
applyClass :: Name -> Name -> Kind
applyClass Name
con Name
t = Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
con) (Name -> Kind
VarT Name
t)
#else
applyClass con t = ClassP con [VarT t]
#endif
canEtaReduce :: [Type] -> [Type] -> Bool
canEtaReduce :: [Kind] -> [Kind] -> Bool
canEtaReduce [Kind]
remaining [Kind]
dropped =
(Kind -> Bool) -> [Kind] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Kind -> Bool
isTyVar [Kind]
dropped
Bool -> Bool -> Bool
&& [Name] -> Bool
forall a. Ord a => [a] -> Bool
allDistinct [Name]
droppedNames
Bool -> Bool -> Bool
&& Bool -> Bool
not ((Kind -> Bool) -> [Kind] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Kind -> [Name] -> Bool
`mentionsName` [Name]
droppedNames) [Kind]
remaining)
where
droppedNames :: [Name]
droppedNames :: [Name]
droppedNames = (Kind -> Name) -> [Kind] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> Name
varTToName [Kind]
dropped
varTToName_maybe :: Type -> Maybe Name
varTToName_maybe :: Kind -> Maybe Name
varTToName_maybe (VarT Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
varTToName_maybe (SigT Kind
t Kind
_) = Kind -> Maybe Name
varTToName_maybe Kind
t
varTToName_maybe Kind
_ = Maybe Name
forall a. Maybe a
Nothing
varTToName :: Type -> Name
varTToName :: Kind -> Name
varTToName = Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Name
forall a. HasCallStack => [Char] -> a
error [Char]
"Not a type variable!") (Maybe Name -> Name) -> (Kind -> Maybe Name) -> Kind -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Maybe Name
varTToName_maybe
unSigT :: Type -> Type
unSigT :: Kind -> Kind
unSigT (SigT Kind
t Kind
_) = Kind
t
unSigT Kind
t = Kind
t
isTyVar :: Type -> Bool
isTyVar :: Kind -> Bool
isTyVar (VarT Name
_) = Bool
True
isTyVar (SigT Kind
t Kind
_) = Kind -> Bool
isTyVar Kind
t
isTyVar Kind
_ = Bool
False
isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool
isInTypeFamilyApp :: [Name] -> Kind -> [Kind] -> Q Bool
isInTypeFamilyApp [Name]
names Kind
tyFun [Kind]
tyArgs =
case Kind
tyFun of
ConT Name
tcName -> Name -> Q Bool
go Name
tcName
Kind
_ -> Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
where
go :: Name -> Q Bool
go :: Name -> Q Bool
go Name
tcName = do
Info
info <- Name -> Q Info
reify Name
tcName
case Info
info of
#if MIN_VERSION_template_haskell(2,11,0)
FamilyI (OpenTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndr]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_)) [Dec]
_
-> [TyVarBndr] -> Q Bool
forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndr]
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 Name
_ [TyVarBndr]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) [Dec]
_
-> [TyVarBndr] -> Q Bool
forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndr]
bndrs
#elif MIN_VERSION_template_haskell(2,9,0)
FamilyI (ClosedTypeFamilyD _ bndrs _ _) _
-> withinFirstArgs bndrs
#endif
Info
_ -> Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
where
withinFirstArgs :: [a] -> Q Bool
withinFirstArgs :: [a] -> Q Bool
withinFirstArgs [a]
bndrs =
let firstArgs :: [Kind]
firstArgs = Int -> [Kind] -> [Kind]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
bndrs) [Kind]
tyArgs
argFVs :: [Name]
argFVs = [Kind] -> [Name]
forall a. TypeSubstitution a => a -> [Name]
freeVariables [Kind]
firstArgs
in Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Q Bool) -> Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
argFVs) [Name]
names
allDistinct :: Ord a => [a] -> Bool
allDistinct :: [a] -> Bool
allDistinct = Set a -> [a] -> Bool
forall a. Ord a => Set a -> [a] -> Bool
allDistinct' Set a
forall a. Set a
Set.empty
where
allDistinct' :: Ord a => Set a -> [a] -> Bool
allDistinct' :: Set a -> [a] -> Bool
allDistinct' Set a
uniqs (a
x:[a]
xs)
| a
x a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
uniqs = Bool
False
| Bool
otherwise = Set a -> [a] -> Bool
forall a. Ord a => Set a -> [a] -> Bool
allDistinct' (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
uniqs) [a]
xs
allDistinct' Set a
_ [a]
_ = Bool
True
mentionsName :: Type -> [Name] -> Bool
mentionsName :: Kind -> [Name] -> Bool
mentionsName = Kind -> [Name] -> Bool
go
where
go :: Type -> [Name] -> Bool
go :: Kind -> [Name] -> Bool
go (AppT Kind
t1 Kind
t2) [Name]
names = Kind -> [Name] -> Bool
go Kind
t1 [Name]
names Bool -> Bool -> Bool
|| Kind -> [Name] -> Bool
go Kind
t2 [Name]
names
go (SigT Kind
t Kind
_k) [Name]
names = Kind -> [Name] -> Bool
go Kind
t [Name]
names
#if MIN_VERSION_template_haskell(2,8,0)
Bool -> Bool -> Bool
|| Kind -> [Name] -> Bool
go Kind
_k [Name]
names
#endif
go (VarT Name
n) [Name]
names = Name
n Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
names
go Kind
_ [Name]
_ = Bool
False
predMentionsName :: Pred -> [Name] -> Bool
#if MIN_VERSION_template_haskell(2,10,0)
predMentionsName :: Kind -> [Name] -> Bool
predMentionsName = Kind -> [Name] -> Bool
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
applyTy :: Type -> [Type] -> Type
applyTy :: Kind -> [Kind] -> Kind
applyTy = (Kind -> Kind -> Kind) -> Kind -> [Kind] -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Kind -> Kind -> Kind
AppT
applyTyCon :: Name -> [Type] -> Type
applyTyCon :: Name -> [Kind] -> Kind
applyTyCon = Kind -> [Kind] -> Kind
applyTy (Kind -> [Kind] -> Kind)
-> (Name -> Kind) -> Name -> [Kind] -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Kind
ConT
unapplyTy :: Type -> (Type, [Type])
unapplyTy :: Kind -> (Kind, [Kind])
unapplyTy Kind
ty = Kind -> Kind -> [Kind] -> (Kind, [Kind])
go Kind
ty Kind
ty []
where
go :: Type -> Type -> [Type] -> (Type, [Type])
go :: Kind -> Kind -> [Kind] -> (Kind, [Kind])
go Kind
_ (AppT Kind
ty1 Kind
ty2) [Kind]
args = Kind -> Kind -> [Kind] -> (Kind, [Kind])
go Kind
ty1 Kind
ty1 (Kind
ty2Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
:[Kind]
args)
go Kind
origTy (SigT Kind
ty' Kind
_) [Kind]
args = Kind -> Kind -> [Kind] -> (Kind, [Kind])
go Kind
origTy Kind
ty' [Kind]
args
#if MIN_VERSION_template_haskell(2,11,0)
go Kind
origTy (InfixT Kind
ty1 Name
n Kind
ty2) [Kind]
args = Kind -> Kind -> [Kind] -> (Kind, [Kind])
go Kind
origTy (Name -> Kind
ConT Name
n Kind -> Kind -> Kind
`AppT` Kind
ty1 Kind -> Kind -> Kind
`AppT` Kind
ty2) [Kind]
args
go Kind
origTy (ParensT Kind
ty') [Kind]
args = Kind -> Kind -> [Kind] -> (Kind, [Kind])
go Kind
origTy Kind
ty' [Kind]
args
#endif
go Kind
origTy Kind
_ [Kind]
args = (Kind
origTy, [Kind]
args)
uncurryTy :: Type -> (Cxt, [Type])
uncurryTy :: Kind -> ([Kind], [Kind])
uncurryTy (AppT (AppT Kind
ArrowT Kind
t1) Kind
t2) =
let ([Kind]
ctxt, [Kind]
tys) = Kind -> ([Kind], [Kind])
uncurryTy Kind
t2
in ([Kind]
ctxt, Kind
t1Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
:[Kind]
tys)
uncurryTy (SigT Kind
t Kind
_) = Kind -> ([Kind], [Kind])
uncurryTy Kind
t
uncurryTy (ForallT [TyVarBndr]
_ [Kind]
ctxt Kind
t) =
let ([Kind]
ctxt', [Kind]
tys) = Kind -> ([Kind], [Kind])
uncurryTy Kind
t
in ([Kind]
ctxt [Kind] -> [Kind] -> [Kind]
forall a. [a] -> [a] -> [a]
++ [Kind]
ctxt', [Kind]
tys)
uncurryTy Kind
t = ([], [Kind
t])
uncurryKind :: Kind -> [Kind]
#if MIN_VERSION_template_haskell(2,8,0)
uncurryKind :: Kind -> [Kind]
uncurryKind = ([Kind], [Kind]) -> [Kind]
forall a b. (a, b) -> b
snd (([Kind], [Kind]) -> [Kind])
-> (Kind -> ([Kind], [Kind])) -> Kind -> [Kind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> ([Kind], [Kind])
uncurryTy
#else
uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2
uncurryKind k = [k]
#endif
invariantPackageKey :: String
#ifdef CURRENT_PACKAGE_KEY
invariantPackageKey :: [Char]
invariantPackageKey = CURRENT_PACKAGE_KEY
#else
invariantPackageKey = "invariant-" ++ showVersion version
#endif
mkInvariantName_tc :: String -> String -> Name
mkInvariantName_tc :: [Char] -> [Char] -> Name
mkInvariantName_tc = [Char] -> [Char] -> [Char] -> Name
mkNameG_tc [Char]
invariantPackageKey
mkInvariantName_v :: String -> String -> Name
mkInvariantName_v :: [Char] -> [Char] -> Name
mkInvariantName_v = [Char] -> [Char] -> [Char] -> Name
mkNameG_v [Char]
invariantPackageKey
invariantTypeName :: Name
invariantTypeName :: Name
invariantTypeName = [Char] -> [Char] -> Name
mkInvariantName_tc [Char]
"Data.Functor.Invariant" [Char]
"Invariant"
invariant2TypeName :: Name
invariant2TypeName :: Name
invariant2TypeName = [Char] -> [Char] -> Name
mkInvariantName_tc [Char]
"Data.Functor.Invariant" [Char]
"Invariant2"
invmapValName :: Name
invmapValName :: Name
invmapValName = [Char] -> [Char] -> Name
mkInvariantName_v [Char]
"Data.Functor.Invariant" [Char]
"invmap"
invmap2ValName :: Name
invmap2ValName :: Name
invmap2ValName = [Char] -> [Char] -> Name
mkInvariantName_v [Char]
"Data.Functor.Invariant" [Char]
"invmap2"
invmapConstValName :: Name
invmapConstValName :: Name
invmapConstValName = [Char] -> [Char] -> Name
mkInvariantName_v [Char]
"Data.Functor.Invariant.TH.Internal" [Char]
"invmapConst"
invmap2ConstValName :: Name
invmap2ConstValName :: Name
invmap2ConstValName = [Char] -> [Char] -> Name
mkInvariantName_v [Char]
"Data.Functor.Invariant.TH.Internal" [Char]
"invmap2Const"
coerceValName :: Name
coerceValName :: Name
coerceValName = [Char] -> [Char] -> [Char] -> Name
mkNameG_v [Char]
"ghc-prim" [Char]
"GHC.Prim" [Char]
"coerce"
errorValName :: Name
errorValName :: Name
errorValName = [Char] -> [Char] -> [Char] -> Name
mkNameG_v [Char]
"base" [Char]
"GHC.Err" [Char]
"error"
seqValName :: Name
seqValName :: Name
seqValName = [Char] -> [Char] -> [Char] -> Name
mkNameG_v [Char]
"ghc-prim" [Char]
"GHC.Prim" [Char]
"seq"