{-# LANGUAGE CPP #-}

#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#endif

{-|
Module:      Data.Functor.Invariant.TH.Internal
Copyright:   (C) 2012-2017 Nicolas Frisby, (C) 2015-2017 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Portability: Template Haskell

Template Haskell-related utilities.
-}
module Data.Functor.Invariant.TH.Internal where

import           Data.Foldable (foldr')
import           Data.Functor.Invariant () -- To import the instances
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

#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 :: 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 a b. (a -> b -> b) -> b -> [a] -> b
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

-------------------------------------------------------------------------------
-- Class-specific constants
-------------------------------------------------------------------------------

-- | A representation of which @Invariant@ is being used.
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
$c== :: InvariantClass -> InvariantClass -> Bool
== :: InvariantClass -> InvariantClass -> Bool
$c/= :: InvariantClass -> InvariantClass -> Bool
/= :: 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
$ccompare :: InvariantClass -> InvariantClass -> Ordering
compare :: InvariantClass -> InvariantClass -> Ordering
$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
>= :: InvariantClass -> InvariantClass -> Bool
$cmax :: InvariantClass -> InvariantClass -> InvariantClass
max :: InvariantClass -> InvariantClass -> InvariantClass
$cmin :: InvariantClass -> InvariantClass -> InvariantClass
min :: InvariantClass -> InvariantClass -> 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

-- | A type-restricted version of 'const'. This constrains the map functions
-- that are autogenerated by Template Haskell to be the correct type, even
-- if they aren't actually used in an invmap(2) expression. This is useful
-- in makeInvmap(2), since a map function might have its type inferred as
-- @a@ instead of @a -> b@ (which is clearly wrong).
invmapConst :: f b -> (a -> b) -> (b -> a) -> f a -> f b
invmapConst :: forall (f :: * -> *) b a. 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 :: forall (f :: * -> * -> *) c d a b.
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 #-}

-------------------------------------------------------------------------------
-- StarKindStatus
-------------------------------------------------------------------------------

-- | Whether a type is not of kind *, is of kind *, or is a kind variable.
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
$c== :: StarKindStatus -> StarKindStatus -> Bool
== :: StarKindStatus -> StarKindStatus -> Bool
$c/= :: StarKindStatus -> StarKindStatus -> Bool
/= :: StarKindStatus -> StarKindStatus -> Bool
Eq

-- | Does a Type have kind * or k (for some kind variable k)?
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

-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.
-- Otherwise, returns 'Nothing'.
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

-- | Concat together all of the StarKindStatuses that are IsKindVar and extract
-- the kind variables' Names out.
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

-------------------------------------------------------------------------------
-- Assorted utilities
-------------------------------------------------------------------------------

-- | Returns True if a Type has kind *.
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

-- 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 :: Kind -> Bool
isStarOrVar Kind
StarT  = Bool
True
isStarOrVar VarT{} = Bool
True
#else
isStarOrVar StarK  = True
#endif
isStarOrVar Kind
_      = Bool
False

-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form
-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or
-- kind variables.
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 a. [a] -> 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

-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.
tyKind :: Type -> Kind
tyKind :: Kind -> Kind
tyKind (SigT Kind
_ Kind
k) = Kind
k
tyKind Kind
_          = Kind
starK

-- | A mapping of type variable Names to their map function Names. For example, in a
-- Invariant declaration, a TyVarMap might look like:
--
--   (a ~> (covA, contraA), b ~> (covB, contraB))
--
-- where a and b are the last two type variables of the datatype, and covA and covB
-- are the two map functions for a and b in covariant positions, and contraA and
-- contraB are the two map functions for a and b in contravariant positions.
type TyVarMap = Map Name (Name, Name)

fst3 :: (a, b, c) -> a
fst3 :: forall a b c. (a, b, c) -> a
fst3 (a
a, b
_, c
_) = a
a

thd3 :: (a, b, c) -> c
thd3 :: forall a b c. (a, b, c) -> c
thd3 (a
_, b
_, c
c) = c
c

-- Like 'lookup', but for lists of triples.
lookup2 :: Eq a => a -> [(a, b, c)] -> Maybe (b, c)
lookup2 :: forall a b c. Eq a => 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

-- | Generate a list of fresh names with a common prefix, and numbered suffixes.
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m 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
forall a b. a -> b -> b
`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)

-- | Applies a typeclass constraint to a type.
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

-- | 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:
--
-- (1) All of the dropped types are type variables
-- (2) All of the dropped types are distinct
-- (3) None of the remaining types mention any of the dropped types
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 -- Make sure not to pass something of type [Type], since Type
                                -- didn't have an Ord instance until template-haskell-2.10.0.0
    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

-- | Extract Just the Name from a type variable. If the argument Type is not a
-- type variable, return Nothing.
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

-- | Extract the Name from a type variable. If the argument Type is not a
-- type variable, throw an error.
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

-- | Peel off a kind signature from a Type (if it has one).
unSigT :: Type -> Type
unSigT :: Kind -> Kind
unSigT (SigT Kind
t Kind
_) = Kind
t
unSigT Kind
t          = Kind
t

-- | Is the given type a variable?
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

-- | Detect if a Name in a list of provided Names occurs as an argument to some
-- type family. This makes an effort to exclude /oversaturated/ arguments to
-- type families. For instance, if one declared the following type family:
--
-- @
-- type family F a :: Type -> Type
-- @
--
-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@,
-- but not @b@.
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 a. a -> Q a
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 a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      where
        withinFirstArgs :: [a] -> Q Bool
        withinFirstArgs :: forall a. [a] -> Q Bool
withinFirstArgs [a]
bndrs =
          let firstArgs :: [Kind]
firstArgs = Int -> [Kind] -> [Kind]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall a. [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 a. a -> Q a
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 a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
argFVs) [Name]
names

-- | Are all of the items in a list (which have an ordering) distinct?
--
-- This uses Set (as opposed to nub) for better asymptotic time complexity.
allDistinct :: Ord a => [a] -> Bool
allDistinct :: forall a. Ord a => [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' :: forall a. Ord a => 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

-- | Does the given type mention any of the Names in the list?
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 a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
names
    go Kind
_            [Name]
_     = Bool
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 :: 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

-- | Construct a type via curried application.
applyTy :: Type -> [Type] -> Type
applyTy :: Kind -> [Kind] -> Kind
applyTy = (Kind -> Kind -> Kind) -> Kind -> [Kind] -> Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Kind -> Kind -> Kind
AppT

-- | Fully applies a type constructor to its type variables.
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

-- | Split an applied type into its individual components. For example, this:
--
-- @
-- Either Int Char
-- @
--
-- would split to this:
--
-- @
-- [Either, Int, Char]
-- @
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)

-- | Split a type signature by the arrows on its spine. For example, this:
--
-- @
-- forall a b. (a ~ b) => (a -> b) -> Char -> ()
-- @
--
-- would split to this:
--
-- @
-- (a ~ b, [a -> b, Char, ()])
-- @
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 Specificity]
_ [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])

-- | Like uncurryType, except on a kind level.
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

-------------------------------------------------------------------------------
-- 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 :: Name
invariantTypeName = ''Invariant

invariant2TypeName :: Name
invariant2TypeName :: Name
invariant2TypeName = ''Invariant2

invmapValName :: Name
invmapValName :: Name
invmapValName = 'invmap

invmap2ValName :: Name
invmap2ValName :: Name
invmap2ValName = 'invmap2

invmapConstValName :: Name
invmapConstValName :: Name
invmapConstValName = 'invmapConst

invmap2ConstValName :: Name
invmap2ConstValName :: Name
invmap2ConstValName = 'invmap2Const

coerceValName :: Name
coerceValName :: Name
coerceValName = 'coerce

errorValName :: Name
errorValName :: Name
errorValName = 'error

seqValName :: Name
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