{-# 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 = IgnoreKinds -> DType -> q DType
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 (DForallTelescope -> DType -> DType)
-> q DForallTelescope -> q (DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IgnoreKinds -> DForallTelescope -> q DForallTelescope
forall (q :: * -> *).
DsMonad q =>
IgnoreKinds -> DForallTelescope -> q DForallTelescope
expand_tele IgnoreKinds
ign DForallTelescope
tele
q (DType -> DType) -> q DType -> q DType
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
ty
go [DTypeArg]
_ (DForallT {}) =
String -> q DType
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 (DCxt -> DType -> DType) -> q DCxt -> q (DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DType -> q DType) -> DCxt -> q DCxt
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 (IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign) DCxt
cxt
q (DType -> DType) -> q DType -> q DType
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
ty
go [DTypeArg]
_ (DConstrainedT {}) =
String -> q DType
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' <- IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
t2
[DTypeArg] -> DType -> q DType
go (DType -> DTypeArg
DTANormal DType
t2' DTypeArg -> [DTypeArg] -> [DTypeArg]
forall a. a -> [a] -> [a]
: [DTypeArg]
args) DType
t1
go [DTypeArg]
args (DAppKindT DType
p DType
k) = do
DType
k' <- IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
k
[DTypeArg] -> DType -> q DType
go (DType -> DTypeArg
DTyArg DType
k' DTypeArg -> [DTypeArg] -> [DTypeArg]
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) = IgnoreKinds -> Name -> [DTypeArg] -> q DType
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 = DType -> q DType
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
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 ([DTyVarBndrUnit] -> DForallTelescope)
-> q [DTyVarBndrUnit] -> q DForallTelescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DTyVarBndrUnit -> q DTyVarBndrUnit)
-> [DTyVarBndrUnit] -> q [DTyVarBndrUnit]
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 (IgnoreKinds -> DTyVarBndrUnit -> q DTyVarBndrUnit
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 ([DTyVarBndrSpec] -> DForallTelescope)
-> q [DTyVarBndrSpec] -> q DForallTelescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DTyVarBndrSpec -> q DTyVarBndrSpec)
-> [DTyVarBndrSpec] -> q [DTyVarBndrSpec]
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 (IgnoreKinds -> DTyVarBndrSpec -> q DTyVarBndrSpec
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{} = DTyVarBndr flag -> q (DTyVarBndr flag)
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DTyVarBndr flag
tvb
expand_tvb IgnoreKinds
ign (DKindedTV Name
n flag
flag DType
k) = Name -> flag -> DType -> DTyVarBndr flag
forall flag. Name -> flag -> DType -> DTyVarBndr flag
DKindedTV Name
n flag
flag (DType -> DTyVarBndr flag) -> q DType -> q (DTyVarBndr flag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IgnoreKinds -> DType -> q DType
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 <- Name -> q Info
forall (q :: * -> *). DsMonad q => Name -> q Info
reifyWithLocals Name
n
case Info
info of
TyConI (TySynD Name
_ [TyVarBndr ()]
_ Type
StarT)
-> DType -> q DType
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
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 <- Info -> q 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]
_
| DCxt -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length DCxt
normal_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [DTyVarBndrUnit] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DTyVarBndrUnit]
tvbs
-> do
let (DCxt
syn_args, DCxt
rest_args) = [DTyVarBndrUnit] -> DCxt -> (DCxt, DCxt)
forall a b. [a] -> [b] -> ([b], [b])
splitAtList [DTyVarBndrUnit]
tvbs DCxt
normal_args
DType
ty <- DSubst -> DType -> q DType
forall (q :: * -> *). Quasi q => DSubst -> DType -> q DType
substTy ([(Name, DType)] -> DSubst
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, DType)] -> DSubst) -> [(Name, DType)] -> DSubst
forall a b. (a -> b) -> a -> b
$ [Name] -> DCxt -> [(Name, DType)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((DTyVarBndrUnit -> Name) -> [DTyVarBndrUnit] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrUnit -> Name
forall flag. DTyVarBndr flag -> Name
dtvbName [DTyVarBndrUnit]
tvbs) DCxt
syn_args) DType
rhs
DType
ty' <- IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
ty
DType -> q DType
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ DType -> [DTypeArg] -> DType
applyDType DType
ty' ([DTypeArg] -> DType) -> [DTypeArg] -> DType
forall a b. (a -> b) -> a -> b
$ (DType -> DTypeArg) -> DCxt -> [DTypeArg]
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]
_
| DCxt -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length DCxt
normal_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [DTyVarBndrUnit] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DTyVarBndrUnit]
tvbs
-> do
let (DCxt
syn_args, DCxt
rest_args) = [DTyVarBndrUnit] -> DCxt -> (DCxt, DCxt)
forall a b. [a] -> [b] -> ([b], [b])
splitAtList [DTyVarBndrUnit]
tvbs DCxt
normal_args
[Dec]
insts <- q [Dec] -> q [Dec] -> q [Dec]
forall a. q a -> q a -> q a
forall (m :: * -> *) a. Quasi m => m a -> m a -> m a
qRecover ([Dec] -> q [Dec]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return []) (q [Dec] -> q [Dec]) -> q [Dec] -> q [Dec]
forall a b. (a -> b) -> a -> b
$
Name -> [Type] -> q [Dec]
forall (m :: * -> *). Quasi m => Name -> [Type] -> m [Dec]
qReifyInstances Name
n ((DType -> Type) -> DCxt -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map DType -> Type
typeToTH DCxt
syn_args)
[DDec]
dinsts <- [Dec] -> q [DDec]
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 ([Maybe DSubst] -> Maybe DSubst) -> [Maybe DSubst] -> Maybe DSubst
forall a b. (a -> b) -> a -> b
$ (DType -> DType -> Maybe DSubst) -> DCxt -> DCxt -> [Maybe DSubst]
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 <- DSubst -> DType -> q DType
forall (q :: * -> *). Quasi q => DSubst -> DType -> q DType
substTy DSubst
subst DType
rhs
DType
ty' <- IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
ty
DType -> q DType
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ DType -> [DTypeArg] -> DType
applyDType DType
ty' ([DTypeArg] -> DType) -> [DTypeArg] -> DType
forall a b. (a -> b) -> a -> b
$ (DType -> DTypeArg) -> DCxt -> [DTypeArg]
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]
_
| DCxt -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length DCxt
normal_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [DTyVarBndrUnit] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DTyVarBndrUnit]
tvbs
-> do
let (DCxt
syn_args, DCxt
rest_args) = [DTyVarBndrUnit] -> DCxt -> (DCxt, DCxt)
forall a b. [a] -> [b] -> ([b], [b])
splitAtList [DTyVarBndrUnit]
tvbs DCxt
normal_args
DCxt
rhss <- (DTySynEqn -> q (Maybe DType)) -> [DTySynEqn] -> q DCxt
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' <- IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
rhs
DType -> q DType
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ DType -> [DTypeArg] -> DType
applyDType DType
rhs' ([DTypeArg] -> DType) -> [DTypeArg] -> DType
forall a b. (a -> b) -> a -> b
$ (DType -> DTypeArg) -> DCxt -> [DTypeArg]
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 ([Maybe DSubst] -> Maybe DSubst) -> [Maybe DSubst] -> Maybe DSubst
forall a b. (a -> b) -> a -> b
$ (DType -> DType -> Maybe DSubst) -> DCxt -> DCxt -> [Maybe DSubst]
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
(DSubst -> q DType) -> Maybe DSubst -> q (Maybe DType)
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) -> Maybe a -> m (Maybe b)
T.mapM ((DSubst -> DType -> q DType) -> DType -> DSubst -> q DType
forall a b c. (a -> b -> c) -> b -> a -> c
flip DSubst -> DType -> q DType
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 = DType -> q DType
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
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 = IgnoreKinds -> a -> q a
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 = IgnoreKinds -> a -> q a
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 = GenericM q -> GenericM q
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM ((DType -> q DType) -> a -> q a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM (IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign))