{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables #-}
module Language.Haskell.TH.Desugar.Expand (
expand, expandType,
expandUnsoundly
) where
import qualified Data.Map as M
import Language.Haskell.TH hiding (cxt)
import Language.Haskell.TH.Syntax ( Quasi(..) )
import Data.Data
import Data.Generics
import qualified Data.Traversable as T
import Language.Haskell.TH.Desugar.AST
import Language.Haskell.TH.Desugar.Core
import Language.Haskell.TH.Desugar.Util
import Language.Haskell.TH.Desugar.Sweeten
import Language.Haskell.TH.Desugar.Reify
import Language.Haskell.TH.Desugar.Subst
expandType :: DsMonad q => DType -> q DType
expandType :: forall (q :: * -> *). DsMonad q => DType -> q DType
expandType = forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
NoIgnore
expand_type :: forall q. DsMonad q => IgnoreKinds -> DType -> q DType
expand_type :: forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign = [DTypeArg] -> DType -> q DType
go []
where
go :: [DTypeArg] -> DType -> q DType
go :: [DTypeArg] -> DType -> q DType
go [] (DForallT DForallTelescope
tele DType
ty) =
DForallTelescope -> DType -> DType
DForallT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *).
DsMonad q =>
IgnoreKinds -> DForallTelescope -> q DForallTelescope
expand_tele IgnoreKinds
ign DForallTelescope
tele
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
ty
go [DTypeArg]
_ (DForallT {}) =
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"A forall type is applied to another type."
go [] (DConstrainedT DCxt
cxt DType
ty) =
DCxt -> DType -> DType
DConstrainedT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign) DCxt
cxt
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
ty
go [DTypeArg]
_ (DConstrainedT {}) =
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"A constrained type is applied to another type."
go [DTypeArg]
args (DAppT DType
t1 DType
t2) = do
DType
t2' <- forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
t2
[DTypeArg] -> DType -> q DType
go (DType -> DTypeArg
DTANormal DType
t2' forall a. a -> [a] -> [a]
: [DTypeArg]
args) DType
t1
go [DTypeArg]
args (DAppKindT DType
p DType
k) = do
DType
k' <- forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
k
[DTypeArg] -> DType -> q DType
go (DType -> DTypeArg
DTyArg DType
k' forall a. a -> [a] -> [a]
: [DTypeArg]
args) DType
p
go [DTypeArg]
args (DSigT DType
ty DType
ki) = do
DType
ty' <- [DTypeArg] -> DType -> q DType
go [] DType
ty
DType
ki' <- [DTypeArg] -> DType -> q DType
go [] DType
ki
DType -> [DTypeArg] -> q DType
finish (DType -> DType -> DType
DSigT DType
ty' DType
ki') [DTypeArg]
args
go [DTypeArg]
args (DConT Name
n) = forall (q :: * -> *).
DsMonad q =>
IgnoreKinds -> Name -> [DTypeArg] -> q DType
expand_con IgnoreKinds
ign Name
n [DTypeArg]
args
go [DTypeArg]
args ty :: DType
ty@(DVarT Name
_) = DType -> [DTypeArg] -> q DType
finish DType
ty [DTypeArg]
args
go [DTypeArg]
args ty :: DType
ty@DType
DArrowT = DType -> [DTypeArg] -> q DType
finish DType
ty [DTypeArg]
args
go [DTypeArg]
args ty :: DType
ty@(DLitT TyLit
_) = DType -> [DTypeArg] -> q DType
finish DType
ty [DTypeArg]
args
go [DTypeArg]
args ty :: DType
ty@DType
DWildCardT = DType -> [DTypeArg] -> q DType
finish DType
ty [DTypeArg]
args
finish :: DType -> [DTypeArg] -> q DType
finish :: DType -> [DTypeArg] -> q DType
finish DType
ty [DTypeArg]
args = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DType -> [DTypeArg] -> DType
applyDType DType
ty [DTypeArg]
args
expand_tele :: DsMonad q => IgnoreKinds -> DForallTelescope -> q DForallTelescope
expand_tele :: forall (q :: * -> *).
DsMonad q =>
IgnoreKinds -> DForallTelescope -> q DForallTelescope
expand_tele IgnoreKinds
ign (DForallVis [DTyVarBndrUnit]
tvbs) = [DTyVarBndrUnit] -> DForallTelescope
DForallVis forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (q :: * -> *) flag.
DsMonad q =>
IgnoreKinds -> DTyVarBndr flag -> q (DTyVarBndr flag)
expand_tvb IgnoreKinds
ign) [DTyVarBndrUnit]
tvbs
expand_tele IgnoreKinds
ign (DForallInvis [DTyVarBndrSpec]
tvbs) = [DTyVarBndrSpec] -> DForallTelescope
DForallInvis forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (q :: * -> *) flag.
DsMonad q =>
IgnoreKinds -> DTyVarBndr flag -> q (DTyVarBndr flag)
expand_tvb IgnoreKinds
ign) [DTyVarBndrSpec]
tvbs
expand_tvb :: DsMonad q => IgnoreKinds -> DTyVarBndr flag -> q (DTyVarBndr flag)
expand_tvb :: forall (q :: * -> *) flag.
DsMonad q =>
IgnoreKinds -> DTyVarBndr flag -> q (DTyVarBndr flag)
expand_tvb IgnoreKinds
_ tvb :: DTyVarBndr flag
tvb@DPlainTV{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure DTyVarBndr flag
tvb
expand_tvb IgnoreKinds
ign (DKindedTV Name
n flag
flag DType
k) = forall flag. Name -> flag -> DType -> DTyVarBndr flag
DKindedTV Name
n flag
flag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
k
expand_con :: forall q.
DsMonad q
=> IgnoreKinds
-> Name
-> [DTypeArg]
-> q DType
expand_con :: forall (q :: * -> *).
DsMonad q =>
IgnoreKinds -> Name -> [DTypeArg] -> q DType
expand_con IgnoreKinds
ign Name
n [DTypeArg]
args = do
Info
info <- forall (q :: * -> *). DsMonad q => Name -> q Info
reifyWithLocals Name
n
case Info
info of
TyConI (TySynD Name
_ [TyVarBndr ()]
_ Type
StarT)
-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DType -> [DTypeArg] -> DType
applyDType (Name -> DType
DConT Name
typeKindName) [DTypeArg]
args
Info
_ -> Info -> q DType
go Info
info
where
normal_args :: [DType]
normal_args :: DCxt
normal_args = [DTypeArg] -> DCxt
filterDTANormals [DTypeArg]
args
go :: Info -> q DType
go :: Info -> q DType
go Info
info = do
DInfo
dinfo <- forall (q :: * -> *). DsMonad q => Info -> q DInfo
dsInfo Info
info
case DInfo
dinfo of
DTyConI (DTySynD Name
_n [DTyVarBndrUnit]
tvbs DType
rhs) Maybe [DDec]
_
| forall (t :: * -> *) a. Foldable t => t a -> Int
length DCxt
normal_args forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length [DTyVarBndrUnit]
tvbs
-> do
let (DCxt
syn_args, DCxt
rest_args) = forall a b. [a] -> [b] -> ([b], [b])
splitAtList [DTyVarBndrUnit]
tvbs DCxt
normal_args
DType
ty <- forall (q :: * -> *). Quasi q => DSubst -> DType -> q DType
substTy (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall flag. DTyVarBndr flag -> Name
dtvbName [DTyVarBndrUnit]
tvbs) DCxt
syn_args) DType
rhs
DType
ty' <- forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
ty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DType -> [DTypeArg] -> DType
applyDType DType
ty' forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map DType -> DTypeArg
DTANormal DCxt
rest_args
DTyConI (DOpenTypeFamilyD (DTypeFamilyHead Name
_n [DTyVarBndrUnit]
tvbs DFamilyResultSig
_frs Maybe InjectivityAnn
_ann)) Maybe [DDec]
_
| forall (t :: * -> *) a. Foldable t => t a -> Int
length DCxt
normal_args forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length [DTyVarBndrUnit]
tvbs
-> do
let (DCxt
syn_args, DCxt
rest_args) = forall a b. [a] -> [b] -> ([b], [b])
splitAtList [DTyVarBndrUnit]
tvbs DCxt
normal_args
[Dec]
insts <- forall (m :: * -> *) a. Quasi m => m a -> m a -> m a
qRecover (forall (m :: * -> *) a. Monad m => a -> m a
return []) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Quasi m => Name -> [Type] -> m [Dec]
qReifyInstances Name
n (forall a b. (a -> b) -> [a] -> [b]
map DType -> Type
typeToTH DCxt
syn_args)
[DDec]
dinsts <- forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
insts
case [DDec]
dinsts of
[DTySynInstD (DTySynEqn Maybe [DTyVarBndrUnit]
_ DType
lhs DType
rhs)]
| (DType
_, [DTypeArg]
lhs_args) <- DType -> (DType, [DTypeArg])
unfoldDType DType
lhs
, let lhs_normal_args :: DCxt
lhs_normal_args = [DTypeArg] -> DCxt
filterDTANormals [DTypeArg]
lhs_args
, Just DSubst
subst <-
[Maybe DSubst] -> Maybe DSubst
unionMaybeSubsts forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (IgnoreKinds -> DType -> DType -> Maybe DSubst
matchTy IgnoreKinds
ign) DCxt
lhs_normal_args DCxt
syn_args
-> do DType
ty <- forall (q :: * -> *). Quasi q => DSubst -> DType -> q DType
substTy DSubst
subst DType
rhs
DType
ty' <- forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
ty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DType -> [DTypeArg] -> DType
applyDType DType
ty' forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map DType -> DTypeArg
DTANormal DCxt
rest_args
[DDec]
_ -> q DType
give_up
DTyConI (DClosedTypeFamilyD (DTypeFamilyHead Name
_n [DTyVarBndrUnit]
tvbs DFamilyResultSig
_frs Maybe InjectivityAnn
_ann) [DTySynEqn]
eqns) Maybe [DDec]
_
| forall (t :: * -> *) a. Foldable t => t a -> Int
length DCxt
normal_args forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length [DTyVarBndrUnit]
tvbs
-> do
let (DCxt
syn_args, DCxt
rest_args) = forall a b. [a] -> [b] -> ([b], [b])
splitAtList [DTyVarBndrUnit]
tvbs DCxt
normal_args
DCxt
rhss <- forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (DCxt -> DTySynEqn -> q (Maybe DType)
check_eqn DCxt
syn_args) [DTySynEqn]
eqns
case DCxt
rhss of
(DType
rhs : DCxt
_) -> do
DType
rhs' <- forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
rhs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DType -> [DTypeArg] -> DType
applyDType DType
rhs' forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map DType -> DTypeArg
DTANormal DCxt
rest_args
[] -> q DType
give_up
where
check_eqn :: [DType] -> DTySynEqn -> q (Maybe DType)
check_eqn :: DCxt -> DTySynEqn -> q (Maybe DType)
check_eqn DCxt
arg_tys (DTySynEqn Maybe [DTyVarBndrUnit]
_ DType
lhs DType
rhs) = do
let (DType
_, [DTypeArg]
lhs_args) = DType -> (DType, [DTypeArg])
unfoldDType DType
lhs
normal_lhs_args :: DCxt
normal_lhs_args = [DTypeArg] -> DCxt
filterDTANormals [DTypeArg]
lhs_args
m_subst :: Maybe DSubst
m_subst = [Maybe DSubst] -> Maybe DSubst
unionMaybeSubsts forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (IgnoreKinds -> DType -> DType -> Maybe DSubst
matchTy IgnoreKinds
ign) DCxt
normal_lhs_args DCxt
arg_tys
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (q :: * -> *). Quasi q => DSubst -> DType -> q DType
substTy DType
rhs) Maybe DSubst
m_subst
DInfo
_ -> q DType
give_up
give_up :: q DType
give_up :: q DType
give_up = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DType -> [DTypeArg] -> DType
applyDType (Name -> DType
DConT Name
n) [DTypeArg]
args
expand :: (DsMonad q, Data a) => a -> q a
expand :: forall (q :: * -> *) a. (DsMonad q, Data a) => a -> q a
expand = forall (q :: * -> *) a.
(DsMonad q, Data a) =>
IgnoreKinds -> a -> q a
expand_ IgnoreKinds
NoIgnore
expandUnsoundly :: (DsMonad q, Data a) => a -> q a
expandUnsoundly :: forall (q :: * -> *) a. (DsMonad q, Data a) => a -> q a
expandUnsoundly = forall (q :: * -> *) a.
(DsMonad q, Data a) =>
IgnoreKinds -> a -> q a
expand_ IgnoreKinds
YesIgnore
expand_ :: (DsMonad q, Data a) => IgnoreKinds -> a -> q a
expand_ :: forall (q :: * -> *) a.
(DsMonad q, Data a) =>
IgnoreKinds -> a -> q a
expand_ IgnoreKinds
ign = forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM (forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM (forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign))