{-# LANGUAGE CPP #-}

#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Unsafe #-}
#endif

{-|
Module:      Data.Bifunctor.TH.Internal
Copyright:   (C) 2008-2016 Edward Kmett, (C) 2015-2016 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Edward Kmett
Portability: Template Haskell

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

import           Data.Foldable (foldr')
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

-- Ensure, beyond a shadow of a doubt, that the instances are in-scope
import           Data.Bifunctor ()
import           Data.Bifoldable ()
import           Data.Bitraversable ()

#ifndef CURRENT_PACKAGE_KEY
import           Data.Version (showVersion)
import           Paths_bifunctors (version)
#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 n :: Name
n k :: 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 ns :: [Name]
ns t :: 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

-------------------------------------------------------------------------------
-- Type-specialized const functions
-------------------------------------------------------------------------------

bimapConst :: p b d -> (a -> b) -> (c -> d) -> p a c -> p b d
bimapConst :: p b d -> (a -> b) -> (c -> d) -> p a c -> p b d
bimapConst = ((c -> d) -> p a c -> p b d)
-> (a -> b) -> (c -> d) -> p a c -> p b d
forall a b. a -> b -> a
const (((c -> d) -> p a c -> p b d)
 -> (a -> b) -> (c -> d) -> p a c -> p b d)
-> (p b d -> (c -> d) -> p a c -> p b d)
-> p b d
-> (a -> b)
-> (c -> d)
-> p a c
-> p b d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (p a c -> p b d) -> (c -> d) -> p a c -> p b d
forall a b. a -> b -> a
const ((p a c -> p b d) -> (c -> d) -> p a c -> p b d)
-> (p b d -> p a c -> p b d) -> p b d -> (c -> d) -> p a c -> p b d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p b d -> p a c -> p b d
forall a b. a -> b -> a
const
{-# INLINE bimapConst #-}

bifoldrConst :: c -> (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c
bifoldrConst :: c -> (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c
bifoldrConst = ((b -> c -> c) -> c -> p a b -> c)
-> (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c
forall a b. a -> b -> a
const (((b -> c -> c) -> c -> p a b -> c)
 -> (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c)
-> (c -> (b -> c -> c) -> c -> p a b -> c)
-> c
-> (a -> c -> c)
-> (b -> c -> c)
-> c
-> p a b
-> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c -> p a b -> c) -> (b -> c -> c) -> c -> p a b -> c
forall a b. a -> b -> a
const ((c -> p a b -> c) -> (b -> c -> c) -> c -> p a b -> c)
-> (c -> c -> p a b -> c) -> c -> (b -> c -> c) -> c -> p a b -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (p a b -> c) -> c -> p a b -> c
forall a b. a -> b -> a
const ((p a b -> c) -> c -> p a b -> c)
-> (c -> p a b -> c) -> c -> c -> p a b -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> p a b -> c
forall a b. a -> b -> a
const
{-# INLINE bifoldrConst #-}

bifoldMapConst :: m -> (a -> m) -> (b -> m) -> p a b -> m
bifoldMapConst :: m -> (a -> m) -> (b -> m) -> p a b -> m
bifoldMapConst = ((b -> m) -> p a b -> m) -> (a -> m) -> (b -> m) -> p a b -> m
forall a b. a -> b -> a
const (((b -> m) -> p a b -> m) -> (a -> m) -> (b -> m) -> p a b -> m)
-> (m -> (b -> m) -> p a b -> m)
-> m
-> (a -> m)
-> (b -> m)
-> p a b
-> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (p a b -> m) -> (b -> m) -> p a b -> m
forall a b. a -> b -> a
const ((p a b -> m) -> (b -> m) -> p a b -> m)
-> (m -> p a b -> m) -> m -> (b -> m) -> p a b -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m -> p a b -> m
forall a b. a -> b -> a
const
{-# INLINE bifoldMapConst #-}

bitraverseConst :: f (t c d) -> (a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverseConst :: f (t c d) -> (a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverseConst = ((b -> f d) -> t a b -> f (t c d))
-> (a -> f c) -> (b -> f d) -> t a b -> f (t c d)
forall a b. a -> b -> a
const (((b -> f d) -> t a b -> f (t c d))
 -> (a -> f c) -> (b -> f d) -> t a b -> f (t c d))
-> (f (t c d) -> (b -> f d) -> t a b -> f (t c d))
-> f (t c d)
-> (a -> f c)
-> (b -> f d)
-> t a b
-> f (t c d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t a b -> f (t c d)) -> (b -> f d) -> t a b -> f (t c d)
forall a b. a -> b -> a
const ((t a b -> f (t c d)) -> (b -> f d) -> t a b -> f (t c d))
-> (f (t c d) -> t a b -> f (t c d))
-> f (t c d)
-> (b -> f d)
-> t a b
-> f (t c d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (t c d) -> t a b -> f (t c d)
forall a b. a -> b -> a
const
{-# INLINE bitraverseConst #-}

-------------------------------------------------------------------------------
-- 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
/= :: StarKindStatus -> StarKindStatus -> Bool
$c/= :: StarKindStatus -> StarKindStatus -> Bool
== :: StarKindStatus -> StarKindStatus -> Bool
$c== :: StarKindStatus -> StarKindStatus -> Bool
Eq

-- | Does a Type have kind * or k (for some kind variable k)?
canRealizeKindStar :: Type -> StarKindStatus
canRealizeKindStar :: Kind -> StarKindStatus
canRealizeKindStar t :: Kind
t
  | Kind -> Bool
hasKindStar Kind
t = StarKindStatus
KindStar
  | Bool
otherwise = case Kind
t of
#if MIN_VERSION_template_haskell(2,8,0)
                     SigT _ (VarT k :: Name
k) -> Name -> StarKindStatus
IsKindVar Name
k
#endif
                     _               -> 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 n :: Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
starKindStatusToName _             = 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
-------------------------------------------------------------------------------

-- filterByList, filterByLists, and partitionByList taken from GHC (BSD3-licensed)

-- | 'filterByList' takes a list of Bools and a list of some elements and
-- filters out these elements for which the corresponding value in the list of
-- Bools is False. This function does not check whether the lists have equal
-- length.
filterByList :: [Bool] -> [a] -> [a]
filterByList :: [Bool] -> [a] -> [a]
filterByList (True:bs :: [Bool]
bs)  (x :: a
x:xs :: [a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [Bool] -> [a] -> [a]
forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
bs [a]
xs
filterByList (False:bs :: [Bool]
bs) (_:xs :: [a]
xs) =     [Bool] -> [a] -> [a]
forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
bs [a]
xs
filterByList _          _      = []

-- | 'filterByLists' takes a list of Bools and two lists as input, and
-- outputs a new list consisting of elements from the last two input lists. For
-- each Bool in the list, if it is 'True', then it takes an element from the
-- former list. If it is 'False', it takes an element from the latter list.
-- The elements taken correspond to the index of the Bool in its list.
-- For example:
--
-- @
-- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\"
-- @
--
-- This function does not check whether the lists have equal length.
filterByLists :: [Bool] -> [a] -> [a] -> [a]
filterByLists :: [Bool] -> [a] -> [a] -> [a]
filterByLists (True:bs :: [Bool]
bs)  (x :: a
x:xs :: [a]
xs) (_:ys :: [a]
ys) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [Bool] -> [a] -> [a] -> [a]
forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists [Bool]
bs [a]
xs [a]
ys
filterByLists (False:bs :: [Bool]
bs) (_:xs :: [a]
xs) (y :: a
y:ys :: [a]
ys) = a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [Bool] -> [a] -> [a] -> [a]
forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists [Bool]
bs [a]
xs [a]
ys
filterByLists _          _      _      = []

-- | 'partitionByList' takes a list of Bools and a list of some elements and
-- partitions the list according to the list of Bools. Elements corresponding
-- to 'True' go to the left; elements corresponding to 'False' go to the right.
-- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@
-- This function does not check whether the lists have equal
-- length.
partitionByList :: [Bool] -> [a] -> ([a], [a])
partitionByList :: [Bool] -> [a] -> ([a], [a])
partitionByList = [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
forall a. [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
go [] []
  where
    go :: [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
go trues :: [a]
trues falses :: [a]
falses (True  : bs :: [Bool]
bs) (x :: a
x : xs :: [a]
xs) = [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
go (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
trues) [a]
falses [Bool]
bs [a]
xs
    go trues :: [a]
trues falses :: [a]
falses (False : bs :: [Bool]
bs) (x :: a
x : xs :: [a]
xs) = [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
go [a]
trues (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
falses) [Bool]
bs [a]
xs
    go trues :: [a]
trues falses :: [a]
falses _ _ = ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
trues, [a] -> [a]
forall a. [a] -> [a]
reverse [a]
falses)

-- | 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 _ StarT) = Bool
True
#else
hasKindStar (SigT _ StarK) = True
#endif
hasKindStar _              = 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 StarT  = Bool
True
isStarOrVar VarT{} = Bool
True
#else
isStarOrVar StarK  = True
#endif
isStarOrVar _      = 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 kindArrows :: Int
kindArrows t :: 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
- 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 _ k :: Kind
k) = Kind
k
tyKind _          = Kind
starK

-- | A mapping of type variable Names to their map function Names. For example, in a
-- Bifunctor declaration, a TyVarMap might look like (a ~> f, b ~> g), where
-- a and b are the last two type variables of the datatype, and f and g are the two
-- functions which map their respective type variables.
type TyVarMap = Map Name Name

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

unsnoc :: [a] -> Maybe ([a], a)
unsnoc :: [a] -> Maybe ([a], a)
unsnoc []     = Maybe ([a], a)
forall a. Maybe a
Nothing
unsnoc (x :: a
x:xs :: [a]
xs) = case [a] -> Maybe ([a], a)
forall a. [a] -> Maybe ([a], a)
unsnoc [a]
xs of
                  Nothing    -> ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just ([], a
x)
                  Just (a :: [a]
a,b :: a
b) -> ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
a, a
b)

-- | Generate a list of fresh names with a common prefix, and numbered suffixes.
newNameList :: String -> Int -> Q [Name]
newNameList :: String -> Int -> Q [Name]
newNameList prefix :: String
prefix n :: 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 (String -> Q Name
newName (String -> Q Name) -> (Int -> String) -> Int -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [1..Int
n]

-- | Applies a typeclass constraint to a type.
applyClass :: Name -> Name -> Pred
#if MIN_VERSION_template_haskell(2,10,0)
applyClass :: Name -> Name -> Kind
applyClass con :: Name
con t :: 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 remaining :: [Kind]
remaining dropped :: [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 n :: Name
n)   = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
varTToName_maybe (SigT t :: Kind
t _) = Kind -> Maybe Name
varTToName_maybe Kind
t
varTToName_maybe _          = 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 (String -> Name
forall a. HasCallStack => String -> a
error "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 t :: Kind
t _) = Kind
t
unSigT t :: Kind
t          = Kind
t

-- | Is the given type a variable?
isTyVar :: Type -> Bool
isTyVar :: Kind -> Bool
isTyVar (VarT _)   = Bool
True
isTyVar (SigT t :: Kind
t _) = Kind -> Bool
isTyVar Kind
t
isTyVar _          = 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 names :: [Name]
names tyFun :: Kind
tyFun tyArgs :: [Kind]
tyArgs =
  case Kind
tyFun of
    ConT tcName :: Name
tcName -> Name -> Q Bool
go Name
tcName
    _           -> Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where
    go :: Name -> Q Bool
    go :: Name -> Q Bool
go tcName :: 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 _ bndrs :: [TyVarBndr]
bndrs _ _)) _
          -> [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 _ bndrs :: [TyVarBndr]
bndrs _ _) _) _
          -> [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

        _ -> Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      where
        withinFirstArgs :: [a] -> Q Bool
        withinFirstArgs :: [a] -> Q Bool
withinFirstArgs bndrs :: [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

-- | 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 :: [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' uniqs :: Set a
uniqs (x :: a
x:xs :: [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' _ _           = 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 t1 :: Kind
t1 t2 :: Kind
t2) names :: [Name]
names = Kind -> [Name] -> Bool
go Kind
t1 [Name]
names Bool -> Bool -> Bool
|| Kind -> [Name] -> Bool
go Kind
t2 [Name]
names
    go (SigT t :: Kind
t _k :: Kind
_k)  names :: [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 n :: Name
n)     names :: [Name]
names = Name
n Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
names
    go _            _     = 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 (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 ty :: 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 _      (AppT ty1 :: Kind
ty1 ty2 :: Kind
ty2)     args :: [Kind]
args = Kind -> Kind -> [Kind] -> (Kind, [Kind])
go Kind
ty1 Kind
ty1 (Kind
ty2Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
:[Kind]
args)
    go origTy :: Kind
origTy (SigT ty' :: Kind
ty' _)       args :: [Kind]
args = Kind -> Kind -> [Kind] -> (Kind, [Kind])
go Kind
origTy Kind
ty' [Kind]
args
#if MIN_VERSION_template_haskell(2,11,0)
    go origTy :: Kind
origTy (InfixT ty1 :: Kind
ty1 n :: Name
n ty2 :: Kind
ty2) args :: [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 origTy :: Kind
origTy (ParensT ty' :: Kind
ty')      args :: [Kind]
args = Kind -> Kind -> [Kind] -> (Kind, [Kind])
go Kind
origTy Kind
ty' [Kind]
args
#endif
    go origTy :: Kind
origTy _                  args :: [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 ArrowT t1 :: Kind
t1) t2 :: Kind
t2) =
  let (ctxt :: [Kind]
ctxt, tys :: [Kind]
tys) = Kind -> ([Kind], [Kind])
uncurryTy Kind
t2
  in ([Kind]
ctxt, Kind
t1Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
:[Kind]
tys)
uncurryTy (SigT t :: Kind
t _) = Kind -> ([Kind], [Kind])
uncurryTy Kind
t
uncurryTy (ForallT _ ctxt :: [Kind]
ctxt t :: Kind
t) =
  let (ctxt' :: [Kind]
ctxt', tys :: [Kind]
tys) = Kind -> ([Kind], [Kind])
uncurryTy Kind
t
  in ([Kind]
ctxt [Kind] -> [Kind] -> [Kind]
forall a. [a] -> [a] -> [a]
++ [Kind]
ctxt', [Kind]
tys)
uncurryTy t :: 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

-------------------------------------------------------------------------------
-- Manually quoted names
-------------------------------------------------------------------------------

-- By manually generating these names we avoid needing to use the
-- TemplateHaskell language extension when compiling the bifunctors library.
-- This allows the library to be used in stage1 cross-compilers.

bifunctorsPackageKey :: String
#ifdef CURRENT_PACKAGE_KEY
bifunctorsPackageKey :: String
bifunctorsPackageKey = CURRENT_PACKAGE_KEY
#else
bifunctorsPackageKey = "bifunctors-" ++ showVersion version
#endif

mkBifunctorsName_tc :: String -> String -> Name
mkBifunctorsName_tc :: String -> String -> Name
mkBifunctorsName_tc = String -> String -> String -> Name
mkNameG_tc String
bifunctorsPackageKey

mkBifunctorsName_v :: String -> String -> Name
mkBifunctorsName_v :: String -> String -> Name
mkBifunctorsName_v = String -> String -> String -> Name
mkNameG_v String
bifunctorsPackageKey

bimapConstValName :: Name
bimapConstValName :: Name
bimapConstValName = String -> String -> Name
mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bimapConst"

bifoldrConstValName :: Name
bifoldrConstValName :: Name
bifoldrConstValName = String -> String -> Name
mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldrConst"

bifoldMapConstValName :: Name
bifoldMapConstValName :: Name
bifoldMapConstValName = String -> String -> Name
mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldMapConst"

coerceValName :: Name
coerceValName :: Name
coerceValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "coerce"

bitraverseConstValName :: Name
bitraverseConstValName :: Name
bitraverseConstValName = String -> String -> Name
mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bitraverseConst"

wrapMonadDataName :: Name
wrapMonadDataName :: Name
wrapMonadDataName = String -> String -> String -> Name
mkNameG_d "base" "Control.Applicative" "WrapMonad"

functorTypeName :: Name
functorTypeName :: Name
functorTypeName = String -> String -> String -> Name
mkNameG_tc "base" "GHC.Base" "Functor"

foldableTypeName :: Name
foldableTypeName :: Name
foldableTypeName = String -> String -> String -> Name
mkNameG_tc "base" "Data.Foldable" "Foldable"

traversableTypeName :: Name
traversableTypeName :: Name
traversableTypeName = String -> String -> String -> Name
mkNameG_tc "base" "Data.Traversable" "Traversable"

composeValName :: Name
composeValName :: Name
composeValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "."

idValName :: Name
idValName :: Name
idValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "id"

errorValName :: Name
errorValName :: Name
errorValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Err" "error"

flipValName :: Name
flipValName :: Name
flipValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "flip"

fmapValName :: Name
fmapValName :: Name
fmapValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "fmap"

foldrValName :: Name
foldrValName :: Name
foldrValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Foldable" "foldr"

foldMapValName :: Name
foldMapValName :: Name
foldMapValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Foldable" "foldMap"

seqValName :: Name
seqValName :: Name
seqValName = String -> String -> String -> Name
mkNameG_v "ghc-prim" "GHC.Prim" "seq"

traverseValName :: Name
traverseValName :: Name
traverseValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Traversable" "traverse"

unwrapMonadValName :: Name
unwrapMonadValName :: Name
unwrapMonadValName = String -> String -> String -> Name
mkNameG_v "base" "Control.Applicative" "unwrapMonad"

#if MIN_VERSION_base(4,8,0)
bifunctorTypeName :: Name
bifunctorTypeName :: Name
bifunctorTypeName = String -> String -> String -> Name
mkNameG_tc "base" "Data.Bifunctor" "Bifunctor"

bimapValName :: Name
bimapValName :: Name
bimapValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Bifunctor" "bimap"

pureValName :: Name
pureValName :: Name
pureValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "pure"

apValName :: Name
apValName :: Name
apValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "<*>"

liftA2ValName :: Name
liftA2ValName :: Name
liftA2ValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "liftA2"

mappendValName :: Name
mappendValName :: Name
mappendValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "mappend"

memptyValName :: Name
memptyValName :: Name
memptyValName = String -> String -> String -> Name
mkNameG_v "base" "GHC.Base" "mempty"
#else
bifunctorTypeName :: Name
bifunctorTypeName = mkBifunctorsName_tc "Data.Bifunctor" "Bifunctor"

bimapValName :: Name
bimapValName = mkBifunctorsName_v "Data.Bifunctor" "bimap"

pureValName :: Name
pureValName = mkNameG_v "base" "Control.Applicative" "pure"

apValName :: Name
apValName = mkNameG_v "base" "Control.Applicative" "<*>"

liftA2ValName :: Name
liftA2ValName = mkNameG_v "base" "Control.Applicative" "liftA2"

mappendValName :: Name
mappendValName = mkNameG_v "base" "Data.Monoid" "mappend"

memptyValName :: Name
memptyValName = mkNameG_v "base" "Data.Monoid" "mempty"
#endif

#if MIN_VERSION_base(4,10,0)
bifoldableTypeName :: Name
bifoldableTypeName :: Name
bifoldableTypeName = String -> String -> String -> Name
mkNameG_tc "base" "Data.Bifoldable" "Bifoldable"

bitraversableTypeName :: Name
bitraversableTypeName :: Name
bitraversableTypeName = String -> String -> String -> Name
mkNameG_tc "base" "Data.Bitraversable" "Bitraversable"

bifoldrValName :: Name
bifoldrValName :: Name
bifoldrValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Bifoldable" "bifoldr"

bifoldMapValName :: Name
bifoldMapValName :: Name
bifoldMapValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Bifoldable" "bifoldMap"

bitraverseValName :: Name
bitraverseValName :: Name
bitraverseValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Bitraversable" "bitraverse"
#else
bifoldableTypeName :: Name
bifoldableTypeName = mkBifunctorsName_tc "Data.Bifoldable" "Bifoldable"

bitraversableTypeName :: Name
bitraversableTypeName = mkBifunctorsName_tc "Data.Bitraversable" "Bitraversable"

bifoldrValName :: Name
bifoldrValName = mkBifunctorsName_v "Data.Bifoldable" "bifoldr"

bifoldMapValName :: Name
bifoldMapValName = mkBifunctorsName_v "Data.Bifoldable" "bifoldMap"

bitraverseValName :: Name
bitraverseValName = mkBifunctorsName_v "Data.Bitraversable" "bitraverse"
#endif

#if MIN_VERSION_base(4,11,0)
appEndoValName :: Name
appEndoValName :: Name
appEndoValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Semigroup.Internal" "appEndo"

dualDataName :: Name
dualDataName :: Name
dualDataName = String -> String -> String -> Name
mkNameG_d "base" "Data.Semigroup.Internal" "Dual"

endoDataName :: Name
endoDataName :: Name
endoDataName = String -> String -> String -> Name
mkNameG_d "base" "Data.Semigroup.Internal" "Endo"

getDualValName :: Name
getDualValName :: Name
getDualValName = String -> String -> String -> Name
mkNameG_v "base" "Data.Semigroup.Internal" "getDual"
#else
appEndoValName :: Name
appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo"

dualDataName :: Name
dualDataName = mkNameG_d "base" "Data.Monoid" "Dual"

endoDataName :: Name
endoDataName = mkNameG_d "base" "Data.Monoid" "Endo"

getDualValName :: Name
getDualValName = mkNameG_v "base" "Data.Monoid" "getDual"
#endif