{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE Unsafe #-}
module Data.Bifunctor.TH.Internal where
import Control.Applicative
import Data.Bifunctor (Bifunctor(..))
import Data.Bifoldable (Bifoldable(..))
import Data.Bitraversable (Bitraversable(..))
import Data.Coerce (coerce)
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 Data.Monoid (Dual(..), Endo(..))
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
applySubstitutionKind :: Map Name Kind -> Type -> Type
applySubstitutionKind :: Map Name Kind -> Kind -> Kind
applySubstitutionKind = forall a. TypeSubstitution a => Map Name Kind -> a -> a
applySubstitution
substNameWithKind :: Name -> Kind -> Type -> Type
substNameWithKind :: Name -> Kind -> Kind -> Kind
substNameWithKind Name
n Kind
k = Map Name Kind -> Kind -> Kind
applySubstitutionKind (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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' (forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Kind -> Kind -> Kind
substNameWithKind Kind
starK) Kind
t [Name]
ns
bimapConst :: p b d -> (a -> b) -> (c -> d) -> p a c -> p b d
bimapConst :: forall (p :: * -> * -> *) b d a c.
p b d -> (a -> b) -> (c -> d) -> p a c -> p b d
bimapConst = forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const
{-# INLINE bimapConst #-}
bifoldrConst :: c -> (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c
bifoldrConst :: forall c a b (p :: * -> * -> *).
c -> (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c
bifoldrConst = forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const
{-# INLINE bifoldrConst #-}
bifoldMapConst :: m -> (a -> m) -> (b -> m) -> p a b -> m
bifoldMapConst :: forall m a b (p :: * -> * -> *).
m -> (a -> m) -> (b -> m) -> p a b -> m
bifoldMapConst = forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (f :: * -> *) (t :: * -> * -> *) c d a b.
f (t c d) -> (a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverseConst = forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const
{-# INLINE bitraverseConst #-}
data StarKindStatus = NotKindStar
| KindStar
| IsKindVar Name
deriving StarKindStatus -> StarKindStatus -> Bool
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
SigT Kind
_ (VarT Name
k) -> Name -> StarKindStatus
IsKindVar Name
k
Kind
_ -> StarKindStatus
NotKindStar
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName (IsKindVar Name
n) = forall a. a -> Maybe a
Just Name
n
starKindStatusToName StarKindStatus
_ = forall a. Maybe a
Nothing
catKindVarNames :: [StarKindStatus] -> [Name]
catKindVarNames :: [StarKindStatus] -> [Name]
catKindVarNames = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe StarKindStatus -> Maybe Name
starKindStatusToName
filterByList :: [Bool] -> [a] -> [a]
filterByList :: forall a. [Bool] -> [a] -> [a]
filterByList (Bool
True:[Bool]
bs) (a
x:[a]
xs) = a
x forall a. a -> [a] -> [a]
: forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
bs [a]
xs
filterByList (Bool
False:[Bool]
bs) (a
_:[a]
xs) = forall a. [Bool] -> [a] -> [a]
filterByList [Bool]
bs [a]
xs
filterByList [Bool]
_ [a]
_ = []
filterByLists :: [Bool] -> [a] -> [a] -> [a]
filterByLists :: forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists (Bool
True:[Bool]
bs) (a
x:[a]
xs) (a
_:[a]
ys) = a
x forall a. a -> [a] -> [a]
: forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists [Bool]
bs [a]
xs [a]
ys
filterByLists (Bool
False:[Bool]
bs) (a
_:[a]
xs) (a
y:[a]
ys) = a
y forall a. a -> [a] -> [a]
: forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists [Bool]
bs [a]
xs [a]
ys
filterByLists [Bool]
_ [a]
_ [a]
_ = []
partitionByList :: [Bool] -> [a] -> ([a], [a])
partitionByList :: forall a. [Bool] -> [a] -> ([a], [a])
partitionByList = forall {a}. [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
go [] []
where
go :: [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
go [a]
trues [a]
falses (Bool
True : [Bool]
bs) (a
x : [a]
xs) = [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
go (a
xforall a. a -> [a] -> [a]
:[a]
trues) [a]
falses [Bool]
bs [a]
xs
go [a]
trues [a]
falses (Bool
False : [Bool]
bs) (a
x : [a]
xs) = [a] -> [a] -> [Bool] -> [a] -> ([a], [a])
go [a]
trues (a
xforall a. a -> [a] -> [a]
:[a]
falses) [Bool]
bs [a]
xs
go [a]
trues [a]
falses [Bool]
_ [a]
_ = (forall a. [a] -> [a]
reverse [a]
trues, forall a. [a] -> [a]
reverse [a]
falses)
hasKindStar :: Type -> Bool
hasKindStar :: Kind -> Bool
hasKindStar VarT{} = Bool
True
hasKindStar (SigT Kind
_ Kind
StarT) = Bool
True
hasKindStar Kind
_ = Bool
False
isStarOrVar :: Kind -> Bool
isStarOrVar :: Kind -> Bool
isStarOrVar Kind
StarT = Bool
True
isStarOrVar VarT{} = Bool
True
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 (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
uk forall a. Num a => a -> a -> a
- Int
1 forall a. Eq a => a -> a -> Bool
== Int
kindArrows) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Kind -> Bool
isStarOrVar [Kind]
uk
then forall a. a -> Maybe a
Just (forall a. TypeSubstitution a => a -> [Name]
freeVariables [Kind]
uk)
else 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
thd3 :: (a, b, c) -> c
thd3 :: forall a b c. (a, b, c) -> c
thd3 (a
_, b
_, c
c) = c
c
unsnoc :: [a] -> Maybe ([a], a)
unsnoc :: forall a. [a] -> Maybe ([a], a)
unsnoc [] = forall a. Maybe a
Nothing
unsnoc (a
x:[a]
xs) = case forall a. [a] -> Maybe ([a], a)
unsnoc [a]
xs of
Maybe ([a], a)
Nothing -> forall a. a -> Maybe a
Just ([], a
x)
Just ([a]
a,a
b) -> forall a. a -> Maybe a
Just (a
xforall a. a -> [a] -> [a]
:[a]
a, a
b)
newNameList :: String -> Int -> Q [Name]
newNameList :: String -> Int -> Q [Name]
newNameList String
prefix Int
n = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). Quote m => String -> m Name
newName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
prefix forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) [Int
1..Int
n]
applyClass :: Name -> Name -> Pred
applyClass :: Name -> Name -> Kind
applyClass Name
con Name
t = Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
con) (Name -> Kind
VarT Name
t)
canEtaReduce :: [Type] -> [Type] -> Bool
canEtaReduce :: [Kind] -> [Kind] -> Bool
canEtaReduce [Kind]
remaining [Kind]
dropped =
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Kind -> Bool
isTyVar [Kind]
dropped
Bool -> Bool -> Bool
&& forall a. Ord a => [a] -> Bool
allDistinct [Name]
droppedNames
Bool -> Bool -> Bool
&& Bool -> Bool
not (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 = 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) = forall a. a -> Maybe a
Just Name
n
varTToName_maybe (SigT Kind
t Kind
_) = Kind -> Maybe Name
varTToName_maybe Kind
t
varTToName_maybe Kind
_ = forall a. Maybe a
Nothing
varTToName :: Type -> Name
varTToName :: Kind -> Name
varTToName = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"Not a type variable!") 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
_ -> 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
FamilyI (OpenTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndr ()]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_)) [Dec]
_
-> forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndr ()]
bndrs
FamilyI (ClosedTypeFamilyD (TypeFamilyHead Name
_ [TyVarBndr ()]
bndrs FamilyResultSig
_ Maybe InjectivityAnn
_) [TySynEqn]
_) [Dec]
_
-> forall a. [a] -> Q Bool
withinFirstArgs [TyVarBndr ()]
bndrs
Info
_ -> 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 = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
bndrs) [Kind]
tyArgs
argFVs :: [Name]
argFVs = forall a. TypeSubstitution a => a -> [Name]
freeVariables [Kind]
firstArgs
in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
argFVs) [Name]
names
allDistinct :: Ord a => [a] -> Bool
allDistinct :: forall a. Ord a => [a] -> Bool
allDistinct = forall a. Ord a => Set a -> [a] -> Bool
allDistinct' 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 forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
uniqs = Bool
False
| Bool
otherwise = forall a. Ord a => Set a -> [a] -> Bool
allDistinct' (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 Bool -> Bool -> Bool
|| Kind -> [Name] -> Bool
go Kind
k [Name]
names
go (VarT Name
n) [Name]
names = Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
names
go Kind
_ [Name]
_ = Bool
False
predMentionsName :: Pred -> [Name] -> Bool
predMentionsName :: Kind -> [Name] -> Bool
predMentionsName = Kind -> [Name] -> Bool
mentionsName
applyTy :: Type -> [Type] -> Type
applyTy :: Kind -> [Kind] -> Kind
applyTy = 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 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
ty2forall 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
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
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
t1forall 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 forall a. [a] -> [a] -> [a]
++ [Kind]
ctxt', [Kind]
tys)
uncurryTy Kind
t = ([], [Kind
t])
uncurryKind :: Kind -> [Kind]
uncurryKind :: Kind -> [Kind]
uncurryKind = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> ([Kind], [Kind])
uncurryTy
bimapConstValName :: Name
bimapConstValName :: Name
bimapConstValName = 'bimapConst
bifoldrConstValName :: Name
bifoldrConstValName :: Name
bifoldrConstValName = 'bifoldrConst
bifoldMapConstValName :: Name
bifoldMapConstValName :: Name
bifoldMapConstValName = 'bifoldMapConst
coerceValName :: Name
coerceValName :: Name
coerceValName = 'coerce
bitraverseConstValName :: Name
bitraverseConstValName :: Name
bitraverseConstValName = 'bitraverseConst
wrapMonadDataName :: Name
wrapMonadDataName :: Name
wrapMonadDataName = 'WrapMonad
functorTypeName :: Name
functorTypeName :: Name
functorTypeName = ''Functor
foldableTypeName :: Name
foldableTypeName :: Name
foldableTypeName = ''Foldable
traversableTypeName :: Name
traversableTypeName :: Name
traversableTypeName = ''Traversable
composeValName :: Name
composeValName :: Name
composeValName = '(.)
idValName :: Name
idValName :: Name
idValName = 'id
errorValName :: Name
errorValName :: Name
errorValName = 'error
flipValName :: Name
flipValName :: Name
flipValName = 'flip
fmapValName :: Name
fmapValName :: Name
fmapValName = 'fmap
foldrValName :: Name
foldrValName :: Name
foldrValName = 'foldr
foldMapValName :: Name
foldMapValName :: Name
foldMapValName = 'foldMap
seqValName :: Name
seqValName :: Name
seqValName = 'seq
traverseValName :: Name
traverseValName :: Name
traverseValName = 'traverse
unwrapMonadValName :: Name
unwrapMonadValName :: Name
unwrapMonadValName = 'unwrapMonad
bifunctorTypeName :: Name
bifunctorTypeName :: Name
bifunctorTypeName = ''Bifunctor
bimapValName :: Name
bimapValName :: Name
bimapValName = 'bimap
pureValName :: Name
pureValName :: Name
pureValName = 'pure
apValName :: Name
apValName :: Name
apValName = '(<*>)
liftA2ValName :: Name
liftA2ValName :: Name
liftA2ValName = 'liftA2
mappendValName :: Name
mappendValName :: Name
mappendValName = 'mappend
memptyValName :: Name
memptyValName :: Name
memptyValName = 'mempty
bifoldableTypeName :: Name
bifoldableTypeName :: Name
bifoldableTypeName = ''Bifoldable
bitraversableTypeName :: Name
bitraversableTypeName :: Name
bitraversableTypeName = ''Bitraversable
bifoldrValName :: Name
bifoldrValName :: Name
bifoldrValName = 'bifoldr
bifoldMapValName :: Name
bifoldMapValName :: Name
bifoldMapValName = 'bifoldMap
bitraverseValName :: Name
bitraverseValName :: Name
bitraverseValName = 'bitraverse
appEndoValName :: Name
appEndoValName :: Name
appEndoValName = 'appEndo
dualDataName :: Name
dualDataName :: Name
dualDataName = 'Dual
endoDataName :: Name
endoDataName :: Name
endoDataName = 'Endo
getDualValName :: Name
getDualValName :: Name
getDualValName = 'getDual