{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables, MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.TyCl (
tcTyAndClassDecls,
kcConDecls, tcConDecls, DataDeclInfo(..),
dataDeclChecks, checkValidTyCon,
tcFamTyPats, tcTyFamInstEqn,
tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,
unravelFamInstPats, addConsistencyConstraints,
wrongKindOfFamily
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Hs
import GHC.Tc.TyCl.Build
import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX
, reportUnsolvedEqualities )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Unify( unifyType, emitResidualTvConstraint )
import GHC.Tc.Types.Constraint( emptyWC )
import GHC.Tc.Validity
import GHC.Tc.Utils.Zonk
import GHC.Tc.TyCl.Utils
import GHC.Tc.TyCl.Class
import {-# SOURCE #-} GHC.Tc.TyCl.Instance( tcInstDecls1 )
import GHC.Tc.Deriv (DerivInfo(..))
import GHC.Tc.Gen.HsType
import GHC.Tc.Instance.Class( AssocInstInfo(..) )
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
import GHC.Tc.Instance.Family
import GHC.Tc.Types.Origin
import GHC.Builtin.Types (oneDataConTy, unitTy, makeRecoveryTyCon )
import GHC.Rename.Env( lookupConstructorFields )
import GHC.Core.Multiplicity
import GHC.Core.FamInstEnv
import GHC.Core.Coercion
import GHC.Core.Type
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr( pprTyVars )
import GHC.Core.Class
import GHC.Core.Coercion.Axiom
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.Unify
import GHC.Types.Id
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Types.SrcLoc
import GHC.Types.SourceFile
import GHC.Types.Unique
import GHC.Types.Basic
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Data.List.SetOps
import GHC.Unit
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import Control.Monad
import Data.Function ( on )
import Data.Functor.Identity
import Data.List (nubBy, partition)
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.Set as Set
import Data.Tuple( swap )
tcTyAndClassDecls :: [TyClGroup GhcRn]
-> TcM ( TcGblEnv
, [InstInfo GhcRn]
, [DerivInfo]
)
tcTyAndClassDecls :: [TyClGroup GhcRn] -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
tcTyAndClassDecls [TyClGroup GhcRn]
tyclds_s
= forall r. TcM r -> TcM r
checkNoErrs forall a b. (a -> b) -> a -> b
$ [InstInfo GhcRn]
-> [DerivInfo]
-> [TyClGroup GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
fold_env [] [] [TyClGroup GhcRn]
tyclds_s
where
fold_env :: [InstInfo GhcRn]
-> [DerivInfo]
-> [TyClGroup GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
fold_env :: [InstInfo GhcRn]
-> [DerivInfo]
-> [TyClGroup GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
fold_env [InstInfo GhcRn]
inst_info [DerivInfo]
deriv_info []
= do { TcGblEnv
gbl_env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
gbl_env, [InstInfo GhcRn]
inst_info, [DerivInfo]
deriv_info) }
fold_env [InstInfo GhcRn]
inst_info [DerivInfo]
deriv_info (TyClGroup GhcRn
tyclds:[TyClGroup GhcRn]
tyclds_s)
= do { (TcGblEnv
tcg_env, [InstInfo GhcRn]
inst_info', [DerivInfo]
deriv_info') <- TyClGroup GhcRn -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
tcTyClGroup TyClGroup GhcRn
tyclds
; forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env forall a b. (a -> b) -> a -> b
$
[InstInfo GhcRn]
-> [DerivInfo]
-> [TyClGroup GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
fold_env ([InstInfo GhcRn]
inst_info' forall a. [a] -> [a] -> [a]
++ [InstInfo GhcRn]
inst_info)
([DerivInfo]
deriv_info' forall a. [a] -> [a] -> [a]
++ [DerivInfo]
deriv_info)
[TyClGroup GhcRn]
tyclds_s }
tcTyClGroup :: TyClGroup GhcRn
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
tcTyClGroup :: TyClGroup GhcRn -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
tcTyClGroup (TyClGroup { group_tyclds :: forall pass. TyClGroup pass -> [LTyClDecl pass]
group_tyclds = [LTyClDecl GhcRn]
tyclds
, group_roles :: forall pass. TyClGroup pass -> [LRoleAnnotDecl pass]
group_roles = [LRoleAnnotDecl GhcRn]
roles
, group_kisigs :: forall pass. TyClGroup pass -> [LStandaloneKindSig pass]
group_kisigs = [LStandaloneKindSig GhcRn]
kisigs
, group_instds :: forall pass. TyClGroup pass -> [LInstDecl pass]
group_instds = [LInstDecl GhcRn]
instds })
= do { let role_annots :: RoleAnnotEnv
role_annots = [LRoleAnnotDecl GhcRn] -> RoleAnnotEnv
mkRoleAnnotEnv [LRoleAnnotDecl GhcRn]
roles
; String -> SDoc -> TcRn ()
traceTc String
"---- tcTyClGroup ---- {" SDoc
empty
; String -> SDoc -> TcRn ()
traceTc String
"Decls for" (forall a. Outputable a => a -> SDoc
ppr (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LTyClDecl GhcRn]
tyclds))
; ([TyCon]
tyclss, [DerivInfo]
data_deriv_info, NameSet
kindless) <-
forall r. TcTypeEnv -> TcM r -> TcM r
tcExtendKindEnv ([LTyClDecl GhcRn] -> TcTypeEnv
mkPromotionErrorEnv [LTyClDecl GhcRn]
tyclds) forall a b. (a -> b) -> a -> b
$
do { NameEnv Type
kisig_env <- forall a. [(Name, a)] -> NameEnv a
mkNameEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse LStandaloneKindSig GhcRn -> TcM (Name, Type)
tcStandaloneKindSig [LStandaloneKindSig GhcRn]
kisigs
; [LTyClDecl GhcRn]
-> NameEnv Type
-> RoleAnnotEnv
-> TcM ([TyCon], [DerivInfo], NameSet)
tcTyClDecls [LTyClDecl GhcRn]
tyclds NameEnv Type
kisig_env RoleAnnotEnv
role_annots }
; String -> SDoc -> TcRn ()
traceTc String
"Starting synonym cycle check" (forall a. Outputable a => a -> SDoc
ppr [TyCon]
tyclss)
; HomeUnit
home_unit <- HscEnv -> HomeUnit
hsc_home_unit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcRn ()
checkSynCycles (HomeUnit -> Unit
homeUnitAsUnit HomeUnit
home_unit) [TyCon]
tyclss [LTyClDecl GhcRn]
tyclds
; String -> SDoc -> TcRn ()
traceTc String
"Done synonym cycle check" (forall a. Outputable a => a -> SDoc
ppr [TyCon]
tyclss)
; String -> SDoc -> TcRn ()
traceTc String
"Starting validity check" (forall a. Outputable a => a -> SDoc
ppr [TyCon]
tyclss)
; [TyCon]
tyclss <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM TyCon -> TcM [TyCon]
checkValidTyCl [TyCon]
tyclss
; String -> SDoc -> TcRn ()
traceTc String
"Done validity check" (forall a. Outputable a => a -> SDoc
ppr [TyCon]
tyclss)
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall r. TcRn r -> TcRn r -> TcRn r
recoverM (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall b c a. (b -> c) -> (a -> b) -> a -> c
. RoleAnnotEnv -> TyCon -> TcRn ()
checkValidRoleAnnots RoleAnnotEnv
role_annots) [TyCon]
tyclss
; String -> SDoc -> TcRn ()
traceTc String
"---- end tcTyClGroup ---- }" SDoc
empty
; TcGblEnv
gbl_env <- [TyCon] -> TcM TcGblEnv
addTyConsToGblEnv [TyCon]
tyclss
; (TcGblEnv
gbl_env', [InstInfo GhcRn]
inst_info, [DerivInfo]
datafam_deriv_info) <-
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
gbl_env forall a b. (a -> b) -> a -> b
$
[LInstDecl GhcRn] -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
tcInstDecls1 [LInstDecl GhcRn]
instds
; let deriv_info :: [DerivInfo]
deriv_info = [DerivInfo]
datafam_deriv_info forall a. [a] -> [a] -> [a]
++ [DerivInfo]
data_deriv_info
; let gbl_env'' :: TcGblEnv
gbl_env'' = TcGblEnv
gbl_env'
{ tcg_ksigs :: NameSet
tcg_ksigs = TcGblEnv -> NameSet
tcg_ksigs TcGblEnv
gbl_env' NameSet -> NameSet -> NameSet
`unionNameSet` NameSet
kindless }
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
gbl_env'', [InstInfo GhcRn]
inst_info, [DerivInfo]
deriv_info) }
type KindSigEnv = NameEnv Kind
tcTyClDecls
:: [LTyClDecl GhcRn]
-> KindSigEnv
-> RoleAnnotEnv
-> TcM ([TyCon], [DerivInfo], NameSet)
tcTyClDecls :: [LTyClDecl GhcRn]
-> NameEnv Type
-> RoleAnnotEnv
-> TcM ([TyCon], [DerivInfo], NameSet)
tcTyClDecls [LTyClDecl GhcRn]
tyclds NameEnv Type
kisig_env RoleAnnotEnv
role_annots
= do {
([TyCon]
tc_tycons, NameSet
kindless) <- NameEnv Type -> [LTyClDecl GhcRn] -> TcM ([TyCon], NameSet)
kcTyClGroup NameEnv Type
kisig_env [LTyClDecl GhcRn]
tyclds
; String -> SDoc -> TcRn ()
traceTc String
"tcTyAndCl generalized kinds" ([SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map TyCon -> SDoc
ppr_tc_tycon [TyCon]
tc_tycons))
; forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM forall a b. (a -> b) -> a -> b
$ \ ~([TyCon]
rec_tyclss, [DerivInfo]
_, NameSet
_) -> do
{ TcGblEnv
tcg_env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let !src :: HscSource
src = TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env
roles :: Name -> [Role]
roles = HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role]
inferRoles HscSource
src RoleAnnotEnv
role_annots [TyCon]
rec_tyclss
; ([TyCon]
tycons, [[DerivInfo]]
data_deriv_infos) <-
forall r. [(Name, TyThing)] -> TcM r -> TcM r
tcExtendRecEnv ([TyCon] -> [TyCon] -> [(Name, TyThing)]
zipRecTyClss [TyCon]
tc_tycons [TyCon]
rec_tyclss) forall a b. (a -> b) -> a -> b
$
forall a. [TyCon] -> TcM a -> TcM a
tcExtendKindEnvWithTyCons [TyCon]
tc_tycons forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ((Name -> [Role]) -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo])
tcTyClDecl Name -> [Role]
roles) [LTyClDecl GhcRn]
tyclds
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TyCon]
tycons, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[DerivInfo]]
data_deriv_infos, NameSet
kindless)
} }
where
ppr_tc_tycon :: TyCon -> SDoc
ppr_tc_tycon TyCon
tc = SDoc -> SDoc
parens ([SDoc] -> SDoc
sep [ forall a. Outputable a => a -> SDoc
ppr (TyCon -> Name
tyConName TyCon
tc) SDoc -> SDoc -> SDoc
<> SDoc
comma
, forall a. Outputable a => a -> SDoc
ppr (TyCon -> [TyConBinder]
tyConBinders TyCon
tc) SDoc -> SDoc -> SDoc
<> SDoc
comma
, forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConResKind TyCon
tc)
, forall a. Outputable a => a -> SDoc
ppr (TyCon -> Bool
isTcTyCon TyCon
tc) ])
zipRecTyClss :: [TcTyCon]
-> [TyCon]
-> [(Name,TyThing)]
zipRecTyClss :: [TyCon] -> [TyCon] -> [(Name, TyThing)]
zipRecTyClss [TyCon]
tc_tycons [TyCon]
rec_tycons
= [ (Name
name, TyCon -> TyThing
ATyCon (Name -> TyCon
get Name
name)) | TyCon
tc_tycon <- [TyCon]
tc_tycons, let name :: Name
name = forall a. NamedThing a => a -> Name
getName TyCon
tc_tycon ]
where
rec_tc_env :: NameEnv TyCon
rec_tc_env :: NameEnv TyCon
rec_tc_env = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyCon -> NameEnv TyCon -> NameEnv TyCon
add_tc forall a. NameEnv a
emptyNameEnv [TyCon]
rec_tycons
add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
add_tc TyCon
tc NameEnv TyCon
env = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyCon -> NameEnv TyCon -> NameEnv TyCon
add_one_tc NameEnv TyCon
env (TyCon
tc forall a. a -> [a] -> [a]
: TyCon -> [TyCon]
tyConATs TyCon
tc)
add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
add_one_tc TyCon
tc NameEnv TyCon
env = forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv NameEnv TyCon
env (TyCon -> Name
tyConName TyCon
tc) TyCon
tc
get :: Name -> TyCon
get Name
name = case forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv TyCon
rec_tc_env Name
name of
Just TyCon
tc -> TyCon
tc
Maybe TyCon
other -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"zipRecTyClss" (forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Maybe TyCon
other)
kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([TcTyCon], NameSet)
kcTyClGroup :: NameEnv Type -> [LTyClDecl GhcRn] -> TcM ([TyCon], NameSet)
kcTyClGroup NameEnv Type
kisig_env [LTyClDecl GhcRn]
decls
= do { Module
mod <- forall (m :: * -> *). HasModule m => m Module
getModule
; String -> SDoc -> TcRn ()
traceTc String
"---- kcTyClGroup ---- {"
(String -> SDoc
text String
"module" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [LTyClDecl GhcRn]
decls))
; Bool
cusks_enabled <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.CUSKs forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<&&> forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PolyKinds
; let ([GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
kindless_decls, [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)]
kinded_decls) = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> Either
(GenLocated SrcSpanAnnA (TyClDecl GhcRn))
(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
get_kind [LTyClDecl GhcRn]
decls
kindless_names :: NameSet
kindless_names = [Name] -> NameSet
mkNameSet forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {p :: Pass} {l}.
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
GenLocated l (TyClDecl (GhcPass p)) -> IdGhcP p
get_name [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
kindless_decls
get_name :: GenLocated l (TyClDecl (GhcPass p)) -> IdP (GhcPass p)
get_name GenLocated l (TyClDecl (GhcPass p))
d = forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName (forall l e. GenLocated l e -> e
unLoc GenLocated l (TyClDecl (GhcPass p))
d)
get_kind :: GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> Either
(GenLocated SrcSpanAnnA (TyClDecl GhcRn))
(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
get_kind GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d
| Just Type
ki <- forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv Type
kisig_env (forall {p :: Pass} {l}.
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
GenLocated l (TyClDecl (GhcPass p)) -> IdGhcP p
get_name GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d)
= forall a b. b -> Either a b
Right (GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d, Type -> SAKS_or_CUSK
SAKS Type
ki)
| Bool
cusks_enabled Bool -> Bool -> Bool
&& TyClDecl GhcRn -> Bool
hsDeclHasCusk (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d)
= forall a b. b -> Either a b
Right (GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d, SAKS_or_CUSK
CUSK)
| Bool
otherwise = forall a b. a -> Either a b
Left GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d
; [TyCon]
checked_tcs <- forall r. TcM r -> TcM r
checkNoErrs forall a b. (a -> b) -> a -> b
$
[(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TyCon]
checkInitialKinds [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)]
kinded_decls
; [TyCon]
inferred_tcs
<- forall a. [TyCon] -> TcM a -> TcM a
tcExtendKindEnvWithTyCons [TyCon]
checked_tcs forall a b. (a -> b) -> a -> b
$
forall a. SkolemInfo -> [TyVar] -> TcM a -> TcM a
pushLevelAndSolveEqualities SkolemInfo
UnkSkol [] forall a b. (a -> b) -> a -> b
$
do {
[TyCon]
mono_tcs <- [LTyClDecl GhcRn] -> TcM [TyCon]
inferInitialKinds [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
kindless_decls
; String -> SDoc -> TcRn ()
traceTc String
"kcTyClGroup: initial kinds" forall a b. (a -> b) -> a -> b
$
[TyCon] -> SDoc
ppr_tc_kinds [TyCon]
mono_tcs
; forall r. TcM r -> TcM r
checkNoErrs forall a b. (a -> b) -> a -> b
$
forall a. [TyCon] -> TcM a -> TcM a
tcExtendKindEnvWithTyCons [TyCon]
mono_tcs forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ LTyClDecl GhcRn -> TcRn ()
kcLTyClDecl [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
kindless_decls
; forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon]
mono_tcs }
; let inferred_tc_env :: NameEnv TyCon
inferred_tc_env = forall a. [(Name, a)] -> NameEnv a
mkNameEnv forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (\TyCon
tc -> (TyCon -> Name
tyConName TyCon
tc, TyCon
tc)) [TyCon]
inferred_tcs
; [TyCon]
generalized_tcs <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (NameEnv TyCon -> LTyClDecl GhcRn -> TcM [TyCon]
generaliseTyClDecl NameEnv TyCon
inferred_tc_env)
[GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
kindless_decls
; let poly_tcs :: [TyCon]
poly_tcs = [TyCon]
checked_tcs forall a. [a] -> [a] -> [a]
++ [TyCon]
generalized_tcs
; String -> SDoc -> TcRn ()
traceTc String
"---- kcTyClGroup end ---- }" ([TyCon] -> SDoc
ppr_tc_kinds [TyCon]
poly_tcs)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TyCon]
poly_tcs, NameSet
kindless_names) }
where
ppr_tc_kinds :: [TyCon] -> SDoc
ppr_tc_kinds [TyCon]
tcs = [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map TyCon -> SDoc
pp_tc [TyCon]
tcs)
pp_tc :: TyCon -> SDoc
pp_tc TyCon
tc = forall a. Outputable a => a -> SDoc
ppr (TyCon -> Name
tyConName TyCon
tc) SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConKind TyCon
tc)
type ScopedPairs = [(Name, TcTyVar)]
generaliseTyClDecl :: NameEnv TcTyCon -> LTyClDecl GhcRn -> TcM [TcTyCon]
generaliseTyClDecl :: NameEnv TyCon -> LTyClDecl GhcRn -> TcM [TyCon]
generaliseTyClDecl NameEnv TyCon
inferred_tc_env (L SrcSpanAnnA
_ TyClDecl GhcRn
decl)
= do { let names_in_this_decl :: [Name]
names_in_this_decl :: [Name]
names_in_this_decl = TyClDecl GhcRn -> [Name]
tycld_names TyClDecl GhcRn
decl
; [(TyCon, [(Name, TyVar)])]
tc_with_tvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> TcM (TyCon, [(Name, TyVar)])
skolemise_tc_tycon [Name]
names_in_this_decl
; [(TyCon, [(Name, TyVar)], Type)]
tc_infos <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TyCon, [(Name, TyVar)]) -> TcM (TyCon, [(Name, TyVar)], Type)
zonk_tc_tycon [(TyCon, [(Name, TyVar)])]
tc_with_tvs
; [(TyCon, [(Name, TyVar)], Type)]
swizzled_infos <- forall a. TyClDecl GhcRn -> TcM a -> TcM a
tcAddDeclCtxt TyClDecl GhcRn
decl ([(TyCon, [(Name, TyVar)], Type)]
-> TcM [(TyCon, [(Name, TyVar)], Type)]
swizzleTcTyConBndrs [(TyCon, [(Name, TyVar)], Type)]
tc_infos)
; forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM (TyCon, [(Name, TyVar)], Type) -> TcM TyCon
generaliseTcTyCon [(TyCon, [(Name, TyVar)], Type)]
swizzled_infos }
where
tycld_names :: TyClDecl GhcRn -> [Name]
tycld_names :: TyClDecl GhcRn -> [Name]
tycld_names TyClDecl GhcRn
decl = forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
decl forall a. a -> [a] -> [a]
: TyClDecl GhcRn -> [Name]
at_names TyClDecl GhcRn
decl
at_names :: TyClDecl GhcRn -> [Name]
at_names :: TyClDecl GhcRn -> [Name]
at_names (ClassDecl { tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs = [LFamilyDecl GhcRn]
ats }) = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Pass). FamilyDecl (GhcPass p) -> IdP (GhcPass p)
familyDeclName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LFamilyDecl GhcRn]
ats
at_names TyClDecl GhcRn
_ = []
skolemise_tc_tycon :: Name -> TcM (TcTyCon, ScopedPairs)
skolemise_tc_tycon :: Name -> TcM (TyCon, [(Name, TyVar)])
skolemise_tc_tycon Name
tc_name
= do { let tc :: TyCon
tc = forall a. NameEnv a -> Name -> a
lookupNameEnv_NF NameEnv TyCon
inferred_tc_env Name
tc_name
; [(Name, TyVar)]
scoped_prs <- forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> [(a, b)] -> m [(a, c)]
mapSndM TyVar -> TcM TyVar
zonkAndSkolemise (TyCon -> [(Name, TyVar)]
tcTyConScopedTyVars TyCon
tc)
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
tc, [(Name, TyVar)]
scoped_prs) }
zonk_tc_tycon :: (TcTyCon, ScopedPairs) -> TcM (TcTyCon, ScopedPairs, TcKind)
zonk_tc_tycon :: (TyCon, [(Name, TyVar)]) -> TcM (TyCon, [(Name, TyVar)], Type)
zonk_tc_tycon (TyCon
tc, [(Name, TyVar)]
scoped_prs)
= do { [(Name, TyVar)]
scoped_prs <- forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> [(a, b)] -> m [(a, c)]
mapSndM HasDebugCallStack => TyVar -> TcM TyVar
zonkTcTyVarToTyVar [(Name, TyVar)]
scoped_prs
; Type
res_kind <- Type -> TcM Type
zonkTcType (TyCon -> Type
tyConResKind TyCon
tc)
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
tc, [(Name, TyVar)]
scoped_prs, Type
res_kind) }
swizzleTcTyConBndrs :: [(TcTyCon, ScopedPairs, TcKind)]
-> TcM [(TcTyCon, ScopedPairs, TcKind)]
swizzleTcTyConBndrs :: [(TyCon, [(Name, TyVar)], Type)]
-> TcM [(TyCon, [(Name, TyVar)], Type)]
swizzleTcTyConBndrs [(TyCon, [(Name, TyVar)], Type)]
tc_infos
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Name, TyVar) -> Bool
no_swizzle [(Name, TyVar)]
swizzle_prs
= do { String -> SDoc -> TcRn ()
traceTc String
"Skipping swizzleTcTyConBndrs for" (forall a. Outputable a => a -> SDoc
ppr (forall a b. (a -> b) -> [a] -> [b]
map forall a b c. (a, b, c) -> a
fstOf3 [(TyCon, [(Name, TyVar)], Type)]
tc_infos))
; forall (m :: * -> *) a. Monad m => a -> m a
return [(TyCon, [(Name, TyVar)], Type)]
tc_infos }
| Bool
otherwise
= do { TcRn ()
check_duplicate_tc_binders
; String -> SDoc -> TcRn ()
traceTc String
"swizzleTcTyConBndrs" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"before" SDoc -> SDoc -> SDoc
<+> forall {a} {a} {c}. Outputable a => [(a, [(a, TyVar)], c)] -> SDoc
ppr_infos [(TyCon, [(Name, TyVar)], Type)]
tc_infos
, String -> SDoc
text String
"swizzle_prs" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [(Name, TyVar)]
swizzle_prs
, String -> SDoc
text String
"after" SDoc -> SDoc -> SDoc
<+> forall {a} {a} {c}. Outputable a => [(a, [(a, TyVar)], c)] -> SDoc
ppr_infos [(TyCon, [(Name, TyVar)], Type)]
swizzled_infos ]
; forall (m :: * -> *) a. Monad m => a -> m a
return [(TyCon, [(Name, TyVar)], Type)]
swizzled_infos }
where
swizzled_infos :: [(TyCon, [(Name, TyVar)], Type)]
swizzled_infos = [ (TyCon
tc, forall b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd TyVar -> TyVar
swizzle_var [(Name, TyVar)]
scoped_prs, Type -> Type
swizzle_ty Type
kind)
| (TyCon
tc, [(Name, TyVar)]
scoped_prs, Type
kind) <- [(TyCon, [(Name, TyVar)], Type)]
tc_infos ]
swizzle_prs :: [(Name,TyVar)]
swizzle_prs :: [(Name, TyVar)]
swizzle_prs = [ (Name, TyVar)
pr | (TyCon
_, [(Name, TyVar)]
prs, Type
_) <- [(TyCon, [(Name, TyVar)], Type)]
tc_infos, (Name, TyVar)
pr <- [(Name, TyVar)]
prs ]
no_swizzle :: (Name,TyVar) -> Bool
no_swizzle :: (Name, TyVar) -> Bool
no_swizzle (Name
nm, TyVar
tv) = Name
nm forall a. Eq a => a -> a -> Bool
== TyVar -> Name
tyVarName TyVar
tv
ppr_infos :: [(a, [(a, TyVar)], c)] -> SDoc
ppr_infos [(a, [(a, TyVar)], c)]
infos = [SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr a
tc SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, TyVar)]
prs)
| (a
tc, [(a, TyVar)]
prs, c
_) <- [(a, [(a, TyVar)], c)]
infos ]
check_duplicate_tc_binders :: TcM ()
check_duplicate_tc_binders :: TcRn ()
check_duplicate_tc_binders = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, Name)]
err_prs) forall a b. (a -> b) -> a -> b
$
do { forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name, Name) -> TcRn ()
report_dup [(Name, Name)]
err_prs; forall env a. IOEnv env a
failM }
err_prs :: [(Name,Name)]
err_prs :: [(Name, Name)]
err_prs = [ (Name
n1,Name
n2)
| (Name, TyVar)
pr :| [(Name, TyVar)]
prs <- forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
findDupsEq (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> b
snd) [(Name, TyVar)]
swizzle_prs
, (Name
n1,TyVar
_):(Name
n2,TyVar
_):[(Name, TyVar)]
_ <- [forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) ((Name, TyVar)
prforall a. a -> [a] -> [a]
:[(Name, TyVar)]
prs)] ]
report_dup :: (Name,Name) -> TcM ()
report_dup :: (Name, Name) -> TcRn ()
report_dup (Name
n1,Name
n2)
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
n2) forall a b. (a -> b) -> a -> b
$ SDoc -> TcRn ()
addErrTc forall a b. (a -> b) -> a -> b
$
SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Different names for the same type variable:") Arity
2 SDoc
info
where
info :: SDoc
info | Name -> OccName
nameOccName Name
n1 forall a. Eq a => a -> a -> Bool
/= Name -> OccName
nameOccName Name
n2
= SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
n1) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"and" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
n2)
| Bool
otherwise
= [SDoc] -> SDoc
vcat [ SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
n1) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"bound at" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall a. NamedThing a => a -> SrcLoc
getSrcLoc Name
n1)
, SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
n2) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"bound at" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall a. NamedThing a => a -> SrcLoc
getSrcLoc Name
n2) ]
swizzle_env :: VarEnv Name
swizzle_env = forall a. [(TyVar, a)] -> VarEnv a
mkVarEnv (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> (b, a)
swap [(Name, TyVar)]
swizzle_prs)
swizzleMapper :: TyCoMapper () Identity
swizzleMapper :: TyCoMapper () Identity
swizzleMapper = TyCoMapper { tcm_tyvar :: () -> TyVar -> Identity Type
tcm_tyvar = forall {m :: * -> *} {p}. Monad m => p -> TyVar -> m Type
swizzle_tv
, tcm_covar :: () -> TyVar -> Identity Coercion
tcm_covar = forall {m :: * -> *} {p}. Monad m => p -> TyVar -> m Coercion
swizzle_cv
, tcm_hole :: () -> CoercionHole -> Identity Coercion
tcm_hole = forall {a} {p} {a}. Outputable a => p -> a -> a
swizzle_hole
, tcm_tycobinder :: () -> TyVar -> ArgFlag -> Identity ((), TyVar)
tcm_tycobinder = forall {m :: * -> *} {p} {p}.
Monad m =>
p -> TyVar -> p -> m ((), TyVar)
swizzle_bndr
, tcm_tycon :: TyCon -> Identity TyCon
tcm_tycon = forall {a} {a}. Outputable a => a -> a
swizzle_tycon }
swizzle_hole :: p -> a -> a
swizzle_hole p
_ a
hole = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"swizzle_hole" (forall a. Outputable a => a -> SDoc
ppr a
hole)
swizzle_tycon :: a -> a
swizzle_tycon a
tc = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"swizzle_tc" (forall a. Outputable a => a -> SDoc
ppr a
tc)
swizzle_tv :: p -> TyVar -> m Type
swizzle_tv p
_ TyVar
tv = forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Type
mkTyVarTy (TyVar -> TyVar
swizzle_var TyVar
tv))
swizzle_cv :: p -> TyVar -> m Coercion
swizzle_cv p
_ TyVar
cv = forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Coercion
mkCoVarCo (TyVar -> TyVar
swizzle_var TyVar
cv))
swizzle_bndr :: p -> TyVar -> p -> m ((), TyVar)
swizzle_bndr p
_ TyVar
tcv p
_
= forall (m :: * -> *) a. Monad m => a -> m a
return ((), TyVar -> TyVar
swizzle_var TyVar
tcv)
swizzle_var :: Var -> Var
swizzle_var :: TyVar -> TyVar
swizzle_var TyVar
v
| Just Name
nm <- forall a. VarEnv a -> TyVar -> Maybe a
lookupVarEnv VarEnv Name
swizzle_env TyVar
v
= (Type -> Type) -> TyVar -> TyVar
updateVarType Type -> Type
swizzle_ty (TyVar
v TyVar -> Name -> TyVar
`setVarName` Name
nm)
| Bool
otherwise
= (Type -> Type) -> TyVar -> TyVar
updateVarType Type -> Type
swizzle_ty TyVar
v
(Type -> Identity Type
map_type, [Type] -> Identity [Type]
_, Coercion -> Identity Coercion
_, [Coercion] -> Identity [Coercion]
_) = forall (m :: * -> *).
Monad m =>
TyCoMapper () m
-> (Type -> m Type, [Type] -> m [Type], Coercion -> m Coercion,
[Coercion] -> m [Coercion])
mapTyCo TyCoMapper () Identity
swizzleMapper
swizzle_ty :: Type -> Type
swizzle_ty Type
ty = forall a. Identity a -> a
runIdentity (Type -> Identity Type
map_type Type
ty)
generaliseTcTyCon :: (TcTyCon, ScopedPairs, TcKind) -> TcM TcTyCon
generaliseTcTyCon :: (TyCon, [(Name, TyVar)], Type) -> TcM TyCon
generaliseTcTyCon (TyCon
tc, [(Name, TyVar)]
scoped_prs, Type
tc_res_kind)
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyCon
tc) forall a b. (a -> b) -> a -> b
$
forall a. TyCon -> TcM a -> TcM a
addTyConCtxt TyCon
tc forall a b. (a -> b) -> a -> b
$
do {
; let spec_req_tvs :: [TyVar]
spec_req_tvs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, TyVar)]
scoped_prs
n_spec :: Arity
n_spec = forall (t :: * -> *) a. Foldable t => t a -> Arity
length [TyVar]
spec_req_tvs forall a. Num a => a -> a -> a
- TyCon -> Arity
tyConArity TyCon
tc
([TyVar]
spec_tvs, [TyVar]
req_tvs) = forall a. Arity -> [a] -> ([a], [a])
splitAt Arity
n_spec [TyVar]
spec_req_tvs
sorted_spec_tvs :: [TyVar]
sorted_spec_tvs = [TyVar] -> [TyVar]
scopedSort [TyVar]
spec_tvs
; CandidatesQTvs
dvs1 <- [Type] -> TcM CandidatesQTvs
candidateQTyVarsOfKinds forall a b. (a -> b) -> a -> b
$
(Type
tc_res_kind forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Type
tyVarKind [TyVar]
spec_req_tvs)
; let dvs2 :: CandidatesQTvs
dvs2 = CandidatesQTvs
dvs1 CandidatesQTvs -> [TyVar] -> CandidatesQTvs
`delCandidates` [TyVar]
spec_req_tvs
; [TyVar]
inferred <- CandidatesQTvs -> TcM [TyVar]
quantifyTyVars CandidatesQTvs
dvs2
; String -> SDoc -> TcRn ()
traceTc String
"generaliseTcTyCon: pre zonk"
([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"tycon =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyCon
tc
, String -> SDoc
text String
"spec_req_tvs =" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
spec_req_tvs
, String -> SDoc
text String
"tc_res_kind =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
tc_res_kind
, String -> SDoc
text String
"dvs1 =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr CandidatesQTvs
dvs1
, String -> SDoc
text String
"inferred =" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
inferred ])
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; (ZonkEnv
ze, [TyVar]
inferred) <- ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX ZonkEnv
ze [TyVar]
inferred
; (ZonkEnv
ze, [TyVar]
sorted_spec_tvs) <- ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX ZonkEnv
ze [TyVar]
sorted_spec_tvs
; (ZonkEnv
ze, [TyVar]
req_tvs) <- ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX ZonkEnv
ze [TyVar]
req_tvs
; Type
tc_res_kind <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
tc_res_kind
; String -> SDoc -> TcRn ()
traceTc String
"generaliseTcTyCon: post zonk" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"tycon =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyCon
tc
, String -> SDoc
text String
"inferred =" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
inferred
, String -> SDoc
text String
"spec_req_tvs =" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
spec_req_tvs
, String -> SDoc
text String
"sorted_spec_tvs =" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
sorted_spec_tvs
, String -> SDoc
text String
"req_tvs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyVar]
req_tvs
, String -> SDoc
text String
"zonk-env =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ZonkEnv
ze ]
; let dep_fv_set :: VarSet
dep_fv_set = CandidatesQTvs -> VarSet
candidateKindVars CandidatesQTvs
dvs1
inferred_tcbs :: [TyConBinder]
inferred_tcbs = ArgFlag -> [TyVar] -> [TyConBinder]
mkNamedTyConBinders ArgFlag
Inferred [TyVar]
inferred
specified_tcbs :: [TyConBinder]
specified_tcbs = ArgFlag -> [TyVar] -> [TyConBinder]
mkNamedTyConBinders ArgFlag
Specified [TyVar]
sorted_spec_tvs
required_tcbs :: [TyConBinder]
required_tcbs = forall a b. (a -> b) -> [a] -> [b]
map (VarSet -> TyVar -> TyConBinder
mkRequiredTyConBinder VarSet
dep_fv_set) [TyVar]
req_tvs
final_tcbs :: [TyConBinder]
final_tcbs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [TyConBinder]
inferred_tcbs
, [TyConBinder]
specified_tcbs
, [TyConBinder]
required_tcbs ]
tycon :: TyCon
tycon = Name
-> [TyConBinder]
-> Type
-> [(Name, TyVar)]
-> Bool
-> TyConFlavour
-> TyCon
mkTcTyCon (TyCon -> Name
tyConName TyCon
tc) [TyConBinder]
final_tcbs Type
tc_res_kind
([TyVar] -> [(Name, TyVar)]
mkTyVarNamePairs ([TyVar]
sorted_spec_tvs forall a. [a] -> [a] -> [a]
++ [TyVar]
req_tvs))
Bool
True
(TyCon -> TyConFlavour
tyConFlavour TyCon
tc)
; String -> SDoc -> TcRn ()
traceTc String
"generaliseTcTyCon done" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"tycon =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyCon
tc
, String -> SDoc
text String
"tc_res_kind =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
tc_res_kind
, String -> SDoc
text String
"dep_fv_set =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr VarSet
dep_fv_set
, String -> SDoc
text String
"inferred_tcbs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
inferred_tcbs
, String -> SDoc
text String
"specified_tcbs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
specified_tcbs
, String -> SDoc
text String
"required_tcbs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
required_tcbs
, String -> SDoc
text String
"final_tcbs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
final_tcbs ]
; TyCon -> TcRn ()
checkTyConTelescope TyCon
tycon
; forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tycon }
tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a
tcExtendKindEnvWithTyCons :: forall a. [TyCon] -> TcM a -> TcM a
tcExtendKindEnvWithTyCons [TyCon]
tcs
= forall r. [(Name, TcTyThing)] -> TcM r -> TcM r
tcExtendKindEnvList [ (TyCon -> Name
tyConName TyCon
tc, TyCon -> TcTyThing
ATcTyCon TyCon
tc) | TyCon
tc <- [TyCon]
tcs ]
mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv
mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv
mkPromotionErrorEnv [LTyClDecl GhcRn]
decls
= forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyClDecl GhcRn -> TcTypeEnv
mk_prom_err_env forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc)
forall a. NameEnv a
emptyNameEnv [LTyClDecl GhcRn]
decls
mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv
mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv
mk_prom_err_env (ClassDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
nm, tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs = [LFamilyDecl GhcRn]
ats })
= forall a. Name -> a -> NameEnv a
unitNameEnv Name
nm (PromotionErr -> TcTyThing
APromotionErr PromotionErr
ClassPE)
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv`
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (forall (p :: Pass). FamilyDecl (GhcPass p) -> IdP (GhcPass p)
familyDeclName FamilyDecl GhcRn
at, PromotionErr -> TcTyThing
APromotionErr PromotionErr
TyConPE)
| L SrcSpanAnnA
_ FamilyDecl GhcRn
at <- [LFamilyDecl GhcRn]
ats ]
mk_prom_err_env (DataDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
name
, tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn { dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons = [LConDecl GhcRn]
cons } })
= forall a. Name -> a -> NameEnv a
unitNameEnv Name
name (PromotionErr -> TcTyThing
APromotionErr PromotionErr
TyConPE)
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv`
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (Name
con, PromotionErr -> TcTyThing
APromotionErr PromotionErr
RecDataConPE)
| L SrcSpanAnnA
_ ConDecl GhcRn
con' <- [LConDecl GhcRn]
cons
, L SrcSpanAnnN
_ Name
con <- ConDecl GhcRn -> [GenLocated SrcSpanAnnN Name]
getConNames ConDecl GhcRn
con' ]
mk_prom_err_env TyClDecl GhcRn
decl
= forall a. Name -> a -> NameEnv a
unitNameEnv (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
decl) (PromotionErr -> TcTyThing
APromotionErr PromotionErr
TyConPE)
inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TyCon]
inferInitialKinds [LTyClDecl GhcRn]
decls
= do { String -> SDoc -> TcRn ()
traceTc String
"inferInitialKinds {" forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LTyClDecl GhcRn]
decls)
; [TyCon]
tcs <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM forall {ann}.
GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn) -> TcM [TyCon]
infer_initial_kind [LTyClDecl GhcRn]
decls
; String -> SDoc -> TcRn ()
traceTc String
"inferInitialKinds done }" SDoc
empty
; forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon]
tcs }
where
infer_initial_kind :: GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn) -> TcM [TyCon]
infer_initial_kind = forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA (InitialKindStrategy -> TyClDecl GhcRn -> TcM [TyCon]
getInitialKind InitialKindStrategy
InitialKindInfer)
checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon]
checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TyCon]
checkInitialKinds [(LTyClDecl GhcRn, SAKS_or_CUSK)]
decls
= do { String -> SDoc -> TcRn ()
traceTc String
"checkInitialKinds {" forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr (forall a c b. (a -> c) -> [(a, b)] -> [(c, b)]
mapFst (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [(LTyClDecl GhcRn, SAKS_or_CUSK)]
decls)
; [TyCon]
tcs <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM forall {ann}.
(GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn), SAKS_or_CUSK)
-> TcM [TyCon]
check_initial_kind [(LTyClDecl GhcRn, SAKS_or_CUSK)]
decls
; String -> SDoc -> TcRn ()
traceTc String
"checkInitialKinds done }" SDoc
empty
; forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon]
tcs }
where
check_initial_kind :: (GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn), SAKS_or_CUSK)
-> TcM [TyCon]
check_initial_kind (GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn)
ldecl, SAKS_or_CUSK
msig) =
forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA (InitialKindStrategy -> TyClDecl GhcRn -> TcM [TyCon]
getInitialKind (SAKS_or_CUSK -> InitialKindStrategy
InitialKindCheck SAKS_or_CUSK
msig)) GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn)
ldecl
getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon]
getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TyCon]
getInitialKind InitialKindStrategy
strategy
(ClassDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
name
, tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars = LHsQTyVars GhcRn
ktvs
, tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs = [LFamilyDecl GhcRn]
ats })
= do { TyCon
cls <- InitialKindStrategy
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM TyCon
kcDeclHeader InitialKindStrategy
strategy Name
name TyConFlavour
ClassFlavour LHsQTyVars GhcRn
ktvs forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> ContextKind
TheKind Type
constraintKind)
; let parent_tv_prs :: [(Name, TyVar)]
parent_tv_prs = TyCon -> [(Name, TyVar)]
tcTyConScopedTyVars TyCon
cls
; [TyCon]
inner_tcs <-
forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, TyVar)]
parent_tv_prs forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA (TyCon -> FamilyDecl GhcRn -> TcM TyCon
getAssocFamInitialKind TyCon
cls)) [LFamilyDecl GhcRn]
ats
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
cls forall a. a -> [a] -> [a]
: [TyCon]
inner_tcs) }
where
getAssocFamInitialKind :: TyCon -> FamilyDecl GhcRn -> TcM TyCon
getAssocFamInitialKind TyCon
cls =
case InitialKindStrategy
strategy of
InitialKindStrategy
InitialKindInfer -> Maybe TyCon -> FamilyDecl GhcRn -> TcM TyCon
get_fam_decl_initial_kind (forall a. a -> Maybe a
Just TyCon
cls)
InitialKindCheck SAKS_or_CUSK
_ -> TyCon -> FamilyDecl GhcRn -> TcM TyCon
check_initial_kind_assoc_fam TyCon
cls
getInitialKind InitialKindStrategy
strategy
(DataDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
name
, tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars = LHsQTyVars GhcRn
ktvs
, tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn { dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (LHsKind GhcRn)
m_sig
, dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_ND = NewOrData
new_or_data } })
= do { let flav :: TyConFlavour
flav = NewOrData -> TyConFlavour
newOrDataToFlavour NewOrData
new_or_data
ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
DataKindCtxt Name
name
; TyCon
tc <- InitialKindStrategy
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM TyCon
kcDeclHeader InitialKindStrategy
strategy Name
name TyConFlavour
flav LHsQTyVars GhcRn
ktvs forall a b. (a -> b) -> a -> b
$
case Maybe (LHsKind GhcRn)
m_sig of
Just LHsKind GhcRn
ksig -> Type -> ContextKind
TheKind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserTypeCtxt -> LHsKind GhcRn -> TcM Type
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
ksig
Maybe (LHsKind GhcRn)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ InitialKindStrategy -> NewOrData -> ContextKind
dataDeclDefaultResultKind InitialKindStrategy
strategy NewOrData
new_or_data
; forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon
tc] }
getInitialKind InitialKindStrategy
InitialKindInfer (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl GhcRn
decl })
= do { TyCon
tc <- Maybe TyCon -> FamilyDecl GhcRn -> TcM TyCon
get_fam_decl_initial_kind forall a. Maybe a
Nothing FamilyDecl GhcRn
decl
; forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon
tc] }
getInitialKind (InitialKindCheck SAKS_or_CUSK
msig) (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam =
FamilyDecl { fdLName :: forall pass. FamilyDecl pass -> LIdP pass
fdLName = forall l e. GenLocated l e -> e
unLoc -> Name
name
, fdTyVars :: forall pass. FamilyDecl pass -> LHsQTyVars pass
fdTyVars = LHsQTyVars GhcRn
ktvs
, fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdResultSig = forall l e. GenLocated l e -> e
unLoc -> FamilyResultSig GhcRn
resultSig
, fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcRn
info } } )
= do { let flav :: TyConFlavour
flav = forall pass. Maybe TyCon -> FamilyInfo pass -> TyConFlavour
getFamFlav forall a. Maybe a
Nothing FamilyInfo GhcRn
info
ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
TyFamResKindCtxt Name
name
; TyCon
tc <- InitialKindStrategy
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM TyCon
kcDeclHeader (SAKS_or_CUSK -> InitialKindStrategy
InitialKindCheck SAKS_or_CUSK
msig) Name
name TyConFlavour
flav LHsQTyVars GhcRn
ktvs forall a b. (a -> b) -> a -> b
$
case forall (p :: Pass).
FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p))
famResultKindSignature FamilyResultSig GhcRn
resultSig of
Just LHsKind GhcRn
ksig -> Type -> ContextKind
TheKind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserTypeCtxt -> LHsKind GhcRn -> TcM Type
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
ksig
Maybe (LHsKind GhcRn)
Nothing ->
case SAKS_or_CUSK
msig of
SAKS_or_CUSK
CUSK -> forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> ContextKind
TheKind Type
liftedTypeKind)
SAKS Type
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ContextKind
AnyKind
; forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon
tc] }
getInitialKind InitialKindStrategy
strategy
(SynDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
name
, tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars = LHsQTyVars GhcRn
ktvs
, tcdRhs :: forall pass. TyClDecl pass -> LHsType pass
tcdRhs = LHsKind GhcRn
rhs })
= do { let ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
TySynKindCtxt Name
name
; TyCon
tc <- InitialKindStrategy
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM TyCon
kcDeclHeader InitialKindStrategy
strategy Name
name TyConFlavour
TypeSynonymFlavour LHsQTyVars GhcRn
ktvs forall a b. (a -> b) -> a -> b
$
case forall (p :: Pass).
LHsType (GhcPass p) -> Maybe (LHsType (GhcPass p))
hsTyKindSig LHsKind GhcRn
rhs of
Just LHsKind GhcRn
rhs_sig -> Type -> ContextKind
TheKind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserTypeCtxt -> LHsKind GhcRn -> TcM Type
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
rhs_sig
Maybe (LHsKind GhcRn)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ContextKind
AnyKind
; forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon
tc] }
get_fam_decl_initial_kind
:: Maybe TcTyCon
-> FamilyDecl GhcRn
-> TcM TcTyCon
get_fam_decl_initial_kind :: Maybe TyCon -> FamilyDecl GhcRn -> TcM TyCon
get_fam_decl_initial_kind Maybe TyCon
mb_parent_tycon
FamilyDecl { fdLName :: forall pass. FamilyDecl pass -> LIdP pass
fdLName = L SrcSpanAnnN
_ Name
name
, fdTyVars :: forall pass. FamilyDecl pass -> LHsQTyVars pass
fdTyVars = LHsQTyVars GhcRn
ktvs
, fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdResultSig = L SrcSpan
_ FamilyResultSig GhcRn
resultSig
, fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcRn
info }
= InitialKindStrategy
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM TyCon
kcDeclHeader InitialKindStrategy
InitialKindInfer Name
name TyConFlavour
flav LHsQTyVars GhcRn
ktvs forall a b. (a -> b) -> a -> b
$
case FamilyResultSig GhcRn
resultSig of
KindSig XCKindSig GhcRn
_ LHsKind GhcRn
ki -> Type -> ContextKind
TheKind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserTypeCtxt -> LHsKind GhcRn -> TcM Type
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
ki
TyVarSig XTyVarSig GhcRn
_ (L SrcSpanAnnA
_ (KindedTyVar XKindedTyVar GhcRn
_ ()
_ LIdP GhcRn
_ LHsKind GhcRn
ki)) -> Type -> ContextKind
TheKind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserTypeCtxt -> LHsKind GhcRn -> TcM Type
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
ki
FamilyResultSig GhcRn
_
| TyConFlavour -> Bool
tcFlavourIsOpen TyConFlavour
flav -> forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> ContextKind
TheKind Type
liftedTypeKind)
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ContextKind
AnyKind
where
flav :: TyConFlavour
flav = forall pass. Maybe TyCon -> FamilyInfo pass -> TyConFlavour
getFamFlav Maybe TyCon
mb_parent_tycon FamilyInfo GhcRn
info
ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
TyFamResKindCtxt Name
name
check_initial_kind_assoc_fam
:: TcTyCon
-> FamilyDecl GhcRn
-> TcM TcTyCon
check_initial_kind_assoc_fam :: TyCon -> FamilyDecl GhcRn -> TcM TyCon
check_initial_kind_assoc_fam TyCon
cls
FamilyDecl
{ fdLName :: forall pass. FamilyDecl pass -> LIdP pass
fdLName = forall l e. GenLocated l e -> e
unLoc -> Name
name
, fdTyVars :: forall pass. FamilyDecl pass -> LHsQTyVars pass
fdTyVars = LHsQTyVars GhcRn
ktvs
, fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdResultSig = forall l e. GenLocated l e -> e
unLoc -> FamilyResultSig GhcRn
resultSig
, fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcRn
info }
= InitialKindStrategy
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM TyCon
kcDeclHeader (SAKS_or_CUSK -> InitialKindStrategy
InitialKindCheck SAKS_or_CUSK
CUSK) Name
name TyConFlavour
flav LHsQTyVars GhcRn
ktvs forall a b. (a -> b) -> a -> b
$
case forall (p :: Pass).
FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p))
famResultKindSignature FamilyResultSig GhcRn
resultSig of
Just LHsKind GhcRn
ksig -> Type -> ContextKind
TheKind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserTypeCtxt -> LHsKind GhcRn -> TcM Type
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
ksig
Maybe (LHsKind GhcRn)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> ContextKind
TheKind Type
liftedTypeKind)
where
ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
TyFamResKindCtxt Name
name
flav :: TyConFlavour
flav = forall pass. Maybe TyCon -> FamilyInfo pass -> TyConFlavour
getFamFlav (forall a. a -> Maybe a
Just TyCon
cls) FamilyInfo GhcRn
info
dataDeclDefaultResultKind :: InitialKindStrategy -> NewOrData -> ContextKind
dataDeclDefaultResultKind :: InitialKindStrategy -> NewOrData -> ContextKind
dataDeclDefaultResultKind InitialKindStrategy
strategy NewOrData
new_or_data
| NewOrData
NewType <- NewOrData
new_or_data
= ContextKind
OpenKind
| NewOrData
DataType <- NewOrData
new_or_data
, InitialKindCheck (SAKS Type
_) <- InitialKindStrategy
strategy
= ContextKind
OpenKind
| Bool
otherwise
= Type -> ContextKind
TheKind Type
liftedTypeKind
getFamFlav
:: Maybe TcTyCon
-> FamilyInfo pass
-> TyConFlavour
getFamFlav :: forall pass. Maybe TyCon -> FamilyInfo pass -> TyConFlavour
getFamFlav Maybe TyCon
mb_parent_tycon FamilyInfo pass
info =
case FamilyInfo pass
info of
FamilyInfo pass
DataFamily -> Maybe TyCon -> TyConFlavour
DataFamilyFlavour Maybe TyCon
mb_parent_tycon
FamilyInfo pass
OpenTypeFamily -> Maybe TyCon -> TyConFlavour
OpenTypeFamilyFlavour Maybe TyCon
mb_parent_tycon
ClosedTypeFamily Maybe [LTyFamInstEqn pass]
_ -> ASSERT( isNothing mb_parent_tycon )
TyConFlavour
ClosedTypeFamilyFlavour
kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()
kcLTyClDecl :: LTyClDecl GhcRn -> TcRn ()
kcLTyClDecl (L SrcSpanAnnA
loc TyClDecl GhcRn
decl)
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
do { TyCon
tycon <- HasDebugCallStack => Name -> TcM TyCon
tcLookupTcTyCon IdP GhcRn
tc_name
; String -> SDoc -> TcRn ()
traceTc String
"kcTyClDecl {" (forall a. Outputable a => a -> SDoc
ppr IdP GhcRn
tc_name)
; forall a. TyCon -> TcM a -> TcM a
addVDQNote TyCon
tycon forall a b. (a -> b) -> a -> b
$
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (TyClDecl GhcRn -> SDoc
tcMkDeclCtxt TyClDecl GhcRn
decl) forall a b. (a -> b) -> a -> b
$
TyClDecl GhcRn -> TyCon -> TcRn ()
kcTyClDecl TyClDecl GhcRn
decl TyCon
tycon
; String -> SDoc -> TcRn ()
traceTc String
"kcTyClDecl done }" (forall a. Outputable a => a -> SDoc
ppr IdP GhcRn
tc_name) }
where
tc_name :: IdP GhcRn
tc_name = forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
decl
kcTyClDecl :: TyClDecl GhcRn -> TcTyCon -> TcM ()
kcTyClDecl :: TyClDecl GhcRn -> TyCon -> TcRn ()
kcTyClDecl (DataDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = (L SrcSpanAnnN
_ Name
name), tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn GhcRn
defn }) TyCon
tycon
| HsDataDefn { dd_ctxt :: forall pass. HsDataDefn pass -> Maybe (LHsContext pass)
dd_ctxt = Maybe (LHsContext GhcRn)
ctxt, dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons = [LConDecl GhcRn]
cons, dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_ND = NewOrData
new_or_data } <- HsDataDefn GhcRn
defn
= forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
name forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
_ Type
_ ->
do { String -> SDoc -> TcRn ()
traceTc String
"kcTyClDecl" (forall a. Outputable a => a -> SDoc
ppr TyCon
tycon SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr (TyCon -> [TyVar]
tyConTyVars TyCon
tycon) SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConResKind TyCon
tycon))
; [Type]
_ <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
ctxt
; NewOrData -> Type -> [LConDecl GhcRn] -> TcRn ()
kcConDecls NewOrData
new_or_data (TyCon -> Type
tyConResKind TyCon
tycon) [LConDecl GhcRn]
cons
}
kcTyClDecl (SynDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
name, tcdRhs :: forall pass. TyClDecl pass -> LHsType pass
tcdRhs = LHsKind GhcRn
rhs }) TyCon
_tycon
= forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
name forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
_ Type
res_kind ->
forall a. TcM a -> TcRn ()
discardResult forall a b. (a -> b) -> a -> b
$ LHsKind GhcRn -> ContextKind -> TcM Type
tcCheckLHsType LHsKind GhcRn
rhs (Type -> ContextKind
TheKind Type
res_kind)
kcTyClDecl (ClassDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
name
, tcdCtxt :: forall pass. TyClDecl pass -> Maybe (LHsContext pass)
tcdCtxt = Maybe (LHsContext GhcRn)
ctxt, tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
tcdSigs = [LSig GhcRn]
sigs }) TyCon
_tycon
= forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
name forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
_ Type
_ ->
do { [Type]
_ <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
ctxt
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. (a -> TcRn ()) -> LocatedA a -> TcRn ()
wrapLocMA_ Sig GhcRn -> TcRn ()
kc_sig) [LSig GhcRn]
sigs }
where
kc_sig :: Sig GhcRn -> TcRn ()
kc_sig (ClassOpSig XClassOpSig GhcRn
_ Bool
_ [LIdP GhcRn]
nms LHsSigType GhcRn
op_ty) = [GenLocated SrcSpanAnnN Name] -> LHsSigType GhcRn -> TcRn ()
kcClassSigType [LIdP GhcRn]
nms LHsSigType GhcRn
op_ty
kc_sig Sig GhcRn
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
kcTyClDecl (FamDecl XFamDecl GhcRn
_ (FamilyDecl { fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcRn
fd_info })) TyCon
fam_tc
= case FamilyInfo GhcRn
fd_info of
ClosedTypeFamily (Just [LTyFamInstEqn GhcRn]
eqns) -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TyCon -> LTyFamInstEqn GhcRn -> TcRn ()
kcTyFamInstEqn TyCon
fam_tc) [LTyFamInstEqn GhcRn]
eqns
FamilyInfo GhcRn
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
kcConArgTys :: NewOrData -> Kind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM ()
kcConArgTys :: NewOrData -> Type -> [HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ()
kcConArgTys NewOrData
new_or_data Type
res_kind [HsScaled GhcRn (LHsKind GhcRn)]
arg_tys = do
{ let exp_kind :: ContextKind
exp_kind = NewOrData -> Type -> ContextKind
getArgExpKind NewOrData
new_or_data Type
res_kind
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [HsScaled GhcRn (LHsKind GhcRn)]
arg_tys (\(HsScaled HsArrow GhcRn
mult GenLocated SrcSpanAnnA (HsType GhcRn)
ty) -> do Type
_ <- LHsKind GhcRn -> ContextKind -> TcM Type
tcCheckLHsType (forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p)
getBangType GenLocated SrcSpanAnnA (HsType GhcRn)
ty) ContextKind
exp_kind
HsArrow GhcRn -> TcM Type
tcMult HsArrow GhcRn
mult)
}
kcConH98Args :: NewOrData -> Kind -> HsConDeclH98Details GhcRn -> TcM ()
kcConH98Args :: NewOrData -> Type -> HsConDeclH98Details GhcRn -> TcRn ()
kcConH98Args NewOrData
new_or_data Type
res_kind HsConDeclH98Details GhcRn
con_args = case HsConDeclH98Details GhcRn
con_args of
PrefixCon [Void]
_ [HsScaled GhcRn (LHsKind GhcRn)]
tys -> NewOrData -> Type -> [HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ()
kcConArgTys NewOrData
new_or_data Type
res_kind [HsScaled GhcRn (LHsKind GhcRn)]
tys
InfixCon HsScaled GhcRn (LHsKind GhcRn)
ty1 HsScaled GhcRn (LHsKind GhcRn)
ty2 -> NewOrData -> Type -> [HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ()
kcConArgTys NewOrData
new_or_data Type
res_kind [HsScaled GhcRn (LHsKind GhcRn)
ty1, HsScaled GhcRn (LHsKind GhcRn)
ty2]
RecCon (L SrcSpanAnnL
_ [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
flds) -> NewOrData -> Type -> [HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ()
kcConArgTys NewOrData
new_or_data Type
res_kind forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (forall a pass. a -> HsScaled pass a
hsLinear forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. ConDeclField pass -> LBangType pass
cd_fld_type forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
flds
kcConGADTArgs :: NewOrData -> Kind -> HsConDeclGADTDetails GhcRn -> TcM ()
kcConGADTArgs :: NewOrData -> Type -> HsConDeclGADTDetails GhcRn -> TcRn ()
kcConGADTArgs NewOrData
new_or_data Type
res_kind HsConDeclGADTDetails GhcRn
con_args = case HsConDeclGADTDetails GhcRn
con_args of
PrefixConGADT [HsScaled GhcRn (LHsKind GhcRn)]
tys -> NewOrData -> Type -> [HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ()
kcConArgTys NewOrData
new_or_data Type
res_kind [HsScaled GhcRn (LHsKind GhcRn)]
tys
RecConGADT (L SrcSpanAnnL
_ [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
flds) -> NewOrData -> Type -> [HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ()
kcConArgTys NewOrData
new_or_data Type
res_kind forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (forall a pass. a -> HsScaled pass a
hsLinear forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. ConDeclField pass -> LBangType pass
cd_fld_type forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
flds
kcConDecls :: NewOrData
-> Kind
-> [LConDecl GhcRn]
-> TcM ()
kcConDecls :: NewOrData -> Type -> [LConDecl GhcRn] -> TcRn ()
kcConDecls NewOrData
new_or_data Type
tc_res_kind [LConDecl GhcRn]
cons
= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. (a -> TcRn ()) -> LocatedA a -> TcRn ()
wrapLocMA_ (NewOrData -> Type -> ConDecl GhcRn -> TcRn ()
kcConDecl NewOrData
new_or_data Type
tc_res_kind)) [LConDecl GhcRn]
cons
kcConDecl :: NewOrData
-> Kind
-> ConDecl GhcRn
-> TcM ()
kcConDecl :: NewOrData -> Type -> ConDecl GhcRn -> TcRn ()
kcConDecl NewOrData
new_or_data Type
tc_res_kind (ConDeclH98
{ con_name :: forall pass. ConDecl pass -> LIdP pass
con_name = LIdP GhcRn
name, con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_ex_tvs = [LHsTyVarBndr Specificity GhcRn]
ex_tvs
, con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcRn)
ex_ctxt, con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_args = HsConDeclH98Details GhcRn
args })
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([GenLocated SrcSpanAnnN Name] -> SDoc
dataConCtxt [LIdP GhcRn
name]) forall a b. (a -> b) -> a -> b
$
forall a. TcM a -> TcRn ()
discardResult forall a b. (a -> b) -> a -> b
$
forall flag a.
OutputableBndrFlag flag 'Renamed =>
[LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrs_Tv [LHsTyVarBndr Specificity GhcRn]
ex_tvs forall a b. (a -> b) -> a -> b
$
do { [Type]
_ <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
ex_ctxt
; NewOrData -> Type -> HsConDeclH98Details GhcRn -> TcRn ()
kcConH98Args NewOrData
new_or_data Type
tc_res_kind HsConDeclH98Details GhcRn
args
}
kcConDecl NewOrData
new_or_data
Type
_tc_res_kind
(ConDeclGADT
{ con_names :: forall pass. ConDecl pass -> [LIdP pass]
con_names = [LIdP GhcRn]
names, con_bndrs :: forall pass. ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)
con_bndrs = L SrcSpanAnnA
_ HsOuterSigTyVarBndrs GhcRn
outer_bndrs, con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcRn)
cxt
, con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_g_args = HsConDeclGADTDetails GhcRn
args, con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_res_ty = LHsKind GhcRn
res_ty })
=
forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([GenLocated SrcSpanAnnN Name] -> SDoc
dataConCtxt [LIdP GhcRn]
names) forall a b. (a -> b) -> a -> b
$
forall a. TcM a -> TcRn ()
discardResult forall a b. (a -> b) -> a -> b
$
forall a.
HsOuterSigTyVarBndrs GhcRn
-> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)
bindOuterSigTKBndrs_Tv HsOuterSigTyVarBndrs GhcRn
outer_bndrs forall a b. (a -> b) -> a -> b
$
do { [Type]
_ <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
cxt
; String -> SDoc -> TcRn ()
traceTc String
"kcConDecl:GADT {" (forall a. Outputable a => a -> SDoc
ppr [LIdP GhcRn]
names SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr LHsKind GhcRn
res_ty)
; Type
con_res_kind <- TcM Type
newOpenTypeKind
; Type
_ <- LHsKind GhcRn -> ContextKind -> TcM Type
tcCheckLHsType LHsKind GhcRn
res_ty (Type -> ContextKind
TheKind Type
con_res_kind)
; NewOrData -> Type -> HsConDeclGADTDetails GhcRn -> TcRn ()
kcConGADTArgs NewOrData
new_or_data Type
con_res_kind HsConDeclGADTDetails GhcRn
args
; String -> SDoc -> TcRn ()
traceTc String
"kcConDecl:GADT }" (forall a. Outputable a => a -> SDoc
ppr [LIdP GhcRn]
names SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Type
con_res_kind)
; forall (m :: * -> *) a. Monad m => a -> m a
return () }
tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo])
tcTyClDecl :: (Name -> [Role]) -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo])
tcTyClDecl Name -> [Role]
roles_info (L SrcSpanAnnA
loc TyClDecl GhcRn
decl)
| Just TyThing
thing <- Name -> Maybe TyThing
wiredInNameTyThing_maybe (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
decl)
= case TyThing
thing of
ATyCon TyCon
tc -> forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
tc, TyCon -> TyClDecl GhcRn -> [DerivInfo]
wiredInDerivInfo TyCon
tc TyClDecl GhcRn
decl)
TyThing
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcTyClDecl" (forall a. Outputable a => a -> SDoc
ppr TyThing
thing)
| Bool
otherwise
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ forall a. TyClDecl GhcRn -> TcM a -> TcM a
tcAddDeclCtxt TyClDecl GhcRn
decl forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"---- tcTyClDecl ---- {" (forall a. Outputable a => a -> SDoc
ppr TyClDecl GhcRn
decl)
; (TyCon
tc, [DerivInfo]
deriv_infos) <- Maybe Class
-> (Name -> [Role]) -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo])
tcTyClDecl1 forall a. Maybe a
Nothing Name -> [Role]
roles_info TyClDecl GhcRn
decl
; String -> SDoc -> TcRn ()
traceTc String
"---- tcTyClDecl end ---- }" (forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
tc, [DerivInfo]
deriv_infos) }
noDerivInfos :: a -> (a, [DerivInfo])
noDerivInfos :: forall a. a -> (a, [DerivInfo])
noDerivInfos a
a = (a
a, [])
wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo]
wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo]
wiredInDerivInfo TyCon
tycon TyClDecl GhcRn
decl
| DataDecl { tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn GhcRn
dataDefn } <- TyClDecl GhcRn
decl
, HsDataDefn { dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs = HsDeriving GhcRn
derivs } <- HsDataDefn GhcRn
dataDefn
= [ DerivInfo { di_rep_tc :: TyCon
di_rep_tc = TyCon
tycon
, di_scoped_tvs :: [(Name, TyVar)]
di_scoped_tvs =
if TyCon -> Bool
isFunTyCon TyCon
tycon Bool -> Bool -> Bool
|| TyCon -> Bool
isPrimTyCon TyCon
tycon
then []
else [TyVar] -> [(Name, TyVar)]
mkTyVarNamePairs (TyCon -> [TyVar]
tyConTyVars TyCon
tycon)
, di_clauses :: HsDeriving GhcRn
di_clauses = HsDeriving GhcRn
derivs
, di_ctxt :: SDoc
di_ctxt = TyClDecl GhcRn -> SDoc
tcMkDeclCtxt TyClDecl GhcRn
decl } ]
wiredInDerivInfo TyCon
_ TyClDecl GhcRn
_ = []
tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo])
tcTyClDecl1 :: Maybe Class
-> (Name -> [Role]) -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo])
tcTyClDecl1 Maybe Class
parent Name -> [Role]
_roles_info (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl GhcRn
fd })
= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> (a, [DerivInfo])
noDerivInfos forall a b. (a -> b) -> a -> b
$
Maybe Class -> FamilyDecl GhcRn -> TcM TyCon
tcFamDecl1 Maybe Class
parent FamilyDecl GhcRn
fd
tcTyClDecl1 Maybe Class
_parent Name -> [Role]
roles_info
(SynDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
tc_name
, tcdRhs :: forall pass. TyClDecl pass -> LHsType pass
tcdRhs = LHsKind GhcRn
rhs })
= ASSERT( isNothing _parent )
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> (a, [DerivInfo])
noDerivInfos forall a b. (a -> b) -> a -> b
$
(Name -> [Role]) -> Name -> LHsKind GhcRn -> TcM TyCon
tcTySynRhs Name -> [Role]
roles_info Name
tc_name LHsKind GhcRn
rhs
tcTyClDecl1 Maybe Class
_parent Name -> [Role]
roles_info
decl :: TyClDecl GhcRn
decl@(DataDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
tc_name
, tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn GhcRn
defn })
= ASSERT( isNothing _parent )
SDoc
-> (Name -> [Role])
-> Name
-> HsDataDefn GhcRn
-> TcM (TyCon, [DerivInfo])
tcDataDefn (TyClDecl GhcRn -> SDoc
tcMkDeclCtxt TyClDecl GhcRn
decl) Name -> [Role]
roles_info Name
tc_name HsDataDefn GhcRn
defn
tcTyClDecl1 Maybe Class
_parent Name -> [Role]
roles_info
(ClassDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
class_name
, tcdCtxt :: forall pass. TyClDecl pass -> Maybe (LHsContext pass)
tcdCtxt = Maybe (LHsContext GhcRn)
hs_ctxt
, tcdMeths :: forall pass. TyClDecl pass -> LHsBinds pass
tcdMeths = LHsBinds GhcRn
meths
, tcdFDs :: forall pass. TyClDecl pass -> [LHsFunDep pass]
tcdFDs = [LHsFunDep GhcRn]
fundeps
, tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
tcdSigs = [LSig GhcRn]
sigs
, tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs = [LFamilyDecl GhcRn]
ats
, tcdATDefs :: forall pass. TyClDecl pass -> [LTyFamDefltDecl pass]
tcdATDefs = [LTyFamDefltDecl GhcRn]
at_defs })
= ASSERT( isNothing _parent )
do { Class
clas <- (Name -> [Role])
-> Name
-> Maybe (LHsContext GhcRn)
-> LHsBinds GhcRn
-> [LHsFunDep GhcRn]
-> [LSig GhcRn]
-> [LFamilyDecl GhcRn]
-> [LTyFamDefltDecl GhcRn]
-> TcM Class
tcClassDecl1 Name -> [Role]
roles_info Name
class_name Maybe (LHsContext GhcRn)
hs_ctxt
LHsBinds GhcRn
meths [LHsFunDep GhcRn]
fundeps [LSig GhcRn]
sigs [LFamilyDecl GhcRn]
ats [LTyFamDefltDecl GhcRn]
at_defs
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> (a, [DerivInfo])
noDerivInfos (Class -> TyCon
classTyCon Class
clas)) }
tcClassDecl1 :: RolesInfo -> Name -> Maybe (LHsContext GhcRn)
-> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn]
-> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn]
-> TcM Class
tcClassDecl1 :: (Name -> [Role])
-> Name
-> Maybe (LHsContext GhcRn)
-> LHsBinds GhcRn
-> [LHsFunDep GhcRn]
-> [LSig GhcRn]
-> [LFamilyDecl GhcRn]
-> [LTyFamDefltDecl GhcRn]
-> TcM Class
tcClassDecl1 Name -> [Role]
roles_info Name
class_name Maybe (LHsContext GhcRn)
hs_ctxt LHsBinds GhcRn
meths [LHsFunDep GhcRn]
fundeps [LSig GhcRn]
sigs [LFamilyDecl GhcRn]
ats [LTyFamDefltDecl GhcRn]
at_defs
= forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM forall a b. (a -> b) -> a -> b
$ \ Class
clas ->
forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
class_name forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
binders Type
res_kind ->
do { Type -> TcRn ()
checkClassKindSig Type
res_kind
; String -> SDoc -> TcRn ()
traceTc String
"tcClassDecl 1" (forall a. Outputable a => a -> SDoc
ppr Name
class_name SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
binders)
; let tycon_name :: Name
tycon_name = Name
class_name
roles :: [Role]
roles = Name -> [Role]
roles_info Name
tycon_name
; ([Type]
ctxt, [([TyVar], [TyVar])]
fds, [TcMethInfo]
sig_stuff, [ClassATItem]
at_stuff)
<- forall a. SkolemInfo -> [TyVar] -> TcM a -> TcM a
pushLevelAndSolveEqualities SkolemInfo
skol_info (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
binders) forall a b. (a -> b) -> a -> b
$
do { [Type]
ctxt <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
hs_ctxt
; [([TyVar], [TyVar])]
fds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA FunDep GhcRn -> TcM ([TyVar], [TyVar])
tc_fundep) [LHsFunDep GhcRn]
fundeps
; [TcMethInfo]
sig_stuff <- Name -> [LSig GhcRn] -> LHsBinds GhcRn -> TcM [TcMethInfo]
tcClassSigs Name
class_name [LSig GhcRn]
sigs LHsBinds GhcRn
meths
; [ClassATItem]
at_stuff <- Name
-> Class
-> [LFamilyDecl GhcRn]
-> [LTyFamDefltDecl GhcRn]
-> TcM [ClassATItem]
tcClassATs Name
class_name Class
clas [LFamilyDecl GhcRn]
ats [LTyFamDefltDecl GhcRn]
at_defs
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
ctxt, [([TyVar], [TyVar])]
fds, [TcMethInfo]
sig_stuff, [ClassATItem]
at_stuff) }
; CandidatesQTvs
dvs <- [Type] -> TcM CandidatesQTvs
candidateQTyVarsOfTypes [Type]
ctxt
; let mk_doc :: TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
mk_doc TidyEnv
tidy_env = do { (TidyEnv
tidy_env2, [Type]
ctxt) <- TidyEnv -> [Type] -> TcM (TidyEnv, [Type])
zonkTidyTcTypes TidyEnv
tidy_env [Type]
ctxt
; forall (m :: * -> *) a. Monad m => a -> m a
return ( TidyEnv
tidy_env2
, [SDoc] -> SDoc
sep [ String -> SDoc
text String
"the class context:"
, [Type] -> SDoc
pprTheta [Type]
ctxt ] ) }
; CandidatesQTvs
-> (TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc))
-> TcRn ()
doNotQuantifyTyVars CandidatesQTvs
dvs TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
mk_doc
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; [Type]
ctxt <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
ctxt
; [TcMethInfo]
sig_stuff <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> TcMethInfo -> TcM TcMethInfo
zonkTcMethInfoToMethInfoX ZonkEnv
ze) [TcMethInfo]
sig_stuff
; ClassMinimalDef
mindef <- Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef
tcClassMinimalDef Name
class_name [LSig GhcRn]
sigs [TcMethInfo]
sig_stuff
; Bool
is_boot <- IOEnv (Env TcGblEnv TcLclEnv) Bool
tcIsHsBootOrSig
; let body :: Maybe ([Type], [ClassATItem], [TcMethInfo], ClassMinimalDef)
body | Bool
is_boot, forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
ctxt, forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClassATItem]
at_stuff, forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcMethInfo]
sig_stuff
= forall a. Maybe a
Nothing
| Bool
otherwise
= forall a. a -> Maybe a
Just ([Type]
ctxt, [ClassATItem]
at_stuff, [TcMethInfo]
sig_stuff, ClassMinimalDef
mindef)
; Class
clas <- forall m n.
Name
-> [TyConBinder]
-> [Role]
-> [([TyVar], [TyVar])]
-> Maybe ([Type], [ClassATItem], [TcMethInfo], ClassMinimalDef)
-> TcRnIf m n Class
buildClass Name
class_name [TyConBinder]
binders [Role]
roles [([TyVar], [TyVar])]
fds Maybe ([Type], [ClassATItem], [TcMethInfo], ClassMinimalDef)
body
; String -> SDoc -> TcRn ()
traceTc String
"tcClassDecl" (forall a. Outputable a => a -> SDoc
ppr [LHsFunDep GhcRn]
fundeps SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
binders SDoc -> SDoc -> SDoc
$$
forall a. Outputable a => a -> SDoc
ppr [([TyVar], [TyVar])]
fds)
; forall (m :: * -> *) a. Monad m => a -> m a
return Class
clas }
where
skol_info :: SkolemInfo
skol_info = TyConFlavour -> Name -> SkolemInfo
TyConSkol TyConFlavour
ClassFlavour Name
class_name
tc_fundep :: GHC.Hs.FunDep GhcRn -> TcM ([Var],[Var])
tc_fundep :: FunDep GhcRn -> TcM ([TyVar], [TyVar])
tc_fundep (FunDep XCFunDep GhcRn
_ [LIdP GhcRn]
tvs1 [LIdP GhcRn]
tvs2)
= do { [TyVar]
tvs1' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> TcM TyVar
tcLookupTyVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LIdP GhcRn]
tvs1 ;
; [TyVar]
tvs2' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> TcM TyVar
tcLookupTyVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LIdP GhcRn]
tvs2 ;
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
tvs1',[TyVar]
tvs2') }
tcClassATs :: Name
-> Class
-> [LFamilyDecl GhcRn]
-> [LTyFamDefltDecl GhcRn]
-> TcM [ClassATItem]
tcClassATs :: Name
-> Class
-> [LFamilyDecl GhcRn]
-> [LTyFamDefltDecl GhcRn]
-> TcM [ClassATItem]
tcClassATs Name
class_name Class
cls [LFamilyDecl GhcRn]
ats [LTyFamDefltDecl GhcRn]
at_defs
= do {
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ forall a. SDoc -> TcM a
failWithTc (Name -> Name -> SDoc
badATErr Name
class_name Name
n)
| Name
n <- forall a b. (a -> b) -> [a] -> [b]
map LTyFamDefltDecl GhcRn -> Name
at_def_tycon [LTyFamDefltDecl GhcRn]
at_defs
, Bool -> Bool
not (Name
n Name -> NameSet -> Bool
`elemNameSet` NameSet
at_names) ]
; forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) ClassATItem
tc_at [LFamilyDecl GhcRn]
ats }
where
at_def_tycon :: LTyFamDefltDecl GhcRn -> Name
at_def_tycon :: LTyFamDefltDecl GhcRn -> Name
at_def_tycon = forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)
tyFamInstDeclName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc
at_fam_name :: LFamilyDecl GhcRn -> Name
at_fam_name :: LFamilyDecl GhcRn -> Name
at_fam_name = forall (p :: Pass). FamilyDecl (GhcPass p) -> IdP (GhcPass p)
familyDeclName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc
at_names :: NameSet
at_names = [Name] -> NameSet
mkNameSet (forall a b. (a -> b) -> [a] -> [b]
map LFamilyDecl GhcRn -> Name
at_fam_name [LFamilyDecl GhcRn]
ats)
at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn]
at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn]
at_defs_map = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
at_def NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
nenv -> forall a. (a -> a -> a) -> NameEnv a -> Name -> a -> NameEnv a
extendNameEnv_C forall a. [a] -> [a] -> [a]
(++) NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
nenv
(LTyFamDefltDecl GhcRn -> Name
at_def_tycon GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
at_def) [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
at_def])
forall a. NameEnv a
emptyNameEnv [LTyFamDefltDecl GhcRn]
at_defs
tc_at :: GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) ClassATItem
tc_at GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
at = do { TyCon
fam_tc <- forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA (Maybe Class -> FamilyDecl GhcRn -> TcM TyCon
tcFamDecl1 (forall a. a -> Maybe a
Just Class
cls)) GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
at
; let at_defs :: [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
at_defs = forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv [LTyFamDefltDecl GhcRn]
at_defs_map (LFamilyDecl GhcRn -> Name
at_fam_name GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
at)
forall a. Maybe a -> a -> a
`orElse` []
; Maybe (Type, ATValidityInfo)
atd <- TyCon
-> [LTyFamDefltDecl GhcRn] -> TcM (Maybe (Type, ATValidityInfo))
tcDefaultAssocDecl TyCon
fam_tc [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
at_defs
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> Maybe (Type, ATValidityInfo) -> ClassATItem
ATI TyCon
fam_tc Maybe (Type, ATValidityInfo)
atd) }
tcDefaultAssocDecl ::
TyCon
-> [LTyFamDefltDecl GhcRn]
-> TcM (Maybe (KnotTied Type, ATValidityInfo))
tcDefaultAssocDecl :: TyCon
-> [LTyFamDefltDecl GhcRn] -> TcM (Maybe (Type, ATValidityInfo))
tcDefaultAssocDecl TyCon
_ []
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
tcDefaultAssocDecl TyCon
_ (LTyFamDefltDecl GhcRn
d1:LTyFamDefltDecl GhcRn
_:[LTyFamDefltDecl GhcRn]
_)
= forall a. SDoc -> TcM a
failWithTc (String -> SDoc
text String
"More than one default declaration for"
SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)
tyFamInstDeclName (forall l e. GenLocated l e -> e
unLoc LTyFamDefltDecl GhcRn
d1)))
tcDefaultAssocDecl TyCon
fam_tc
[L SrcSpanAnnA
loc (TyFamInstDecl { tfid_eqn :: forall pass. TyFamInstDecl pass -> TyFamInstEqn pass
tfid_eqn =
FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = L SrcSpanAnnN
_ Name
tc_name
, feqn_bndrs :: forall pass rhs. FamEqn pass rhs -> HsOuterFamEqnTyVarBndrs pass
feqn_bndrs = HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs
, feqn_pats :: forall pass rhs. FamEqn pass rhs -> HsTyPats pass
feqn_pats = HsTyPats GhcRn
hs_pats
, feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = LHsKind GhcRn
hs_rhs_ty }})]
=
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
forall a. SDoc -> Name -> TcM a -> TcM a
tcAddFamInstCtxt (String -> SDoc
text String
"default type instance") Name
tc_name forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcDefaultAssocDecl 1" (forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
; let fam_tc_name :: Name
fam_tc_name = TyCon -> Name
tyConName TyCon
fam_tc
vis_arity :: Arity
vis_arity = forall (t :: * -> *) a. Foldable t => t a -> Arity
length (TyCon -> [TyVar]
tyConVisibleTyVars TyCon
fam_tc)
vis_pats :: Arity
vis_pats = forall tm ty. [HsArg tm ty] -> Arity
numVisibleArgs HsTyPats GhcRn
hs_pats
; ASSERT( fam_tc_name == tc_name )
Bool -> SDoc -> TcRn ()
checkTc (TyCon -> Bool
isTypeFamilyTyCon TyCon
fam_tc) (TyCon -> SDoc
wrongKindOfFamily TyCon
fam_tc)
; Bool -> SDoc -> TcRn ()
checkTc (Arity
vis_pats forall a. Eq a => a -> a -> Bool
== Arity
vis_arity)
(Arity -> SDoc
wrongNumberOfParmsErr Arity
vis_arity)
; ([TyVar]
qtvs, [Type]
pats, Type
rhs_ty) <- TyCon
-> AssocInstInfo
-> HsOuterFamEqnTyVarBndrs GhcRn
-> HsTyPats GhcRn
-> LHsKind GhcRn
-> TcM ([TyVar], [Type], Type)
tcTyFamInstEqnGuts TyCon
fam_tc AssocInstInfo
NotAssociated
HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs HsTyPats GhcRn
hs_pats LHsKind GhcRn
hs_rhs_ty
; let fam_tvs :: [TyVar]
fam_tvs = TyCon -> [TyVar]
tyConTyVars TyCon
fam_tc
; String -> SDoc -> TcRn ()
traceTc String
"tcDefaultAssocDecl 2" ([SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"hs_pats" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr HsTyPats GhcRn
hs_pats
, String -> SDoc
text String
"hs_rhs_ty" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr LHsKind GhcRn
hs_rhs_ty
, String -> SDoc
text String
"fam_tvs" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyVar]
fam_tvs
, String -> SDoc
text String
"qtvs" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyVar]
qtvs
])
; let subst :: TCvSubst
subst = case forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Maybe TyVar
getTyVar_maybe [Type]
pats of
Just [TyVar]
cpt_tvs -> HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst
zipTvSubst [TyVar]
cpt_tvs ([TyVar] -> [Type]
mkTyVarTys [TyVar]
fam_tvs)
Maybe [TyVar]
Nothing -> TCvSubst
emptyTCvSubst
; forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (TCvSubst -> Type -> Type
substTyUnchecked TCvSubst
subst Type
rhs_ty, SrcSpan -> [Type] -> ATValidityInfo
ATVI (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) [Type]
pats)
}
tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon
tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon
tcFamDecl1 Maybe Class
parent (FamilyDecl { fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcRn
fam_info
, fdLName :: forall pass. FamilyDecl pass -> LIdP pass
fdLName = tc_lname :: LIdP GhcRn
tc_lname@(L SrcSpanAnnN
_ Name
tc_name)
, fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdResultSig = L SrcSpan
_ FamilyResultSig GhcRn
sig
, fdInjectivityAnn :: forall pass. FamilyDecl pass -> Maybe (LInjectivityAnn pass)
fdInjectivityAnn = Maybe (LInjectivityAnn GhcRn)
inj })
| FamilyInfo GhcRn
DataFamily <- FamilyInfo GhcRn
fam_info
= forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tc_name forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
binders Type
res_kind -> do
{ String -> SDoc -> TcRn ()
traceTc String
"data family:" (forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
; Name -> TcRn ()
checkFamFlag Name
tc_name
; DataSort -> Type -> TcRn ()
checkDataKindSig DataSort
DataFamilySort Type
res_kind
; Name
tc_rep_name <- forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
tc_name
; let inj :: Injectivity
inj = [Bool] -> Injectivity
Injective forall a b. (a -> b) -> a -> b
$ forall a. Arity -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Arity
length [TyConBinder]
binders) Bool
True
tycon :: TyCon
tycon = Name
-> [TyConBinder]
-> Type
-> Maybe Name
-> FamTyConFlav
-> Maybe Class
-> Injectivity
-> TyCon
mkFamilyTyCon Name
tc_name [TyConBinder]
binders
Type
res_kind
(forall (a :: Pass).
FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
resultVariableName FamilyResultSig GhcRn
sig)
(Name -> FamTyConFlav
DataFamilyTyCon Name
tc_rep_name)
Maybe Class
parent Injectivity
inj
; forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tycon }
| FamilyInfo GhcRn
OpenTypeFamily <- FamilyInfo GhcRn
fam_info
= forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tc_name forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
binders Type
res_kind -> do
{ String -> SDoc -> TcRn ()
traceTc String
"open type family:" (forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
; Name -> TcRn ()
checkFamFlag Name
tc_name
; Injectivity
inj' <- [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) -> TcM Injectivity
tcInjectivity [TyConBinder]
binders Maybe (LInjectivityAnn GhcRn)
inj
; Name -> FamilyResultSig GhcRn -> TcRn ()
checkResultSigFlag Name
tc_name FamilyResultSig GhcRn
sig
; let tycon :: TyCon
tycon = Name
-> [TyConBinder]
-> Type
-> Maybe Name
-> FamTyConFlav
-> Maybe Class
-> Injectivity
-> TyCon
mkFamilyTyCon Name
tc_name [TyConBinder]
binders Type
res_kind
(forall (a :: Pass).
FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
resultVariableName FamilyResultSig GhcRn
sig) FamTyConFlav
OpenSynFamilyTyCon
Maybe Class
parent Injectivity
inj'
; forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tycon }
| ClosedTypeFamily Maybe [LTyFamInstEqn GhcRn]
mb_eqns <- FamilyInfo GhcRn
fam_info
=
do { String -> SDoc -> TcRn ()
traceTc String
"Closed type family:" (forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
; (Injectivity
inj', [TyConBinder]
binders, Type
res_kind)
<- forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tc_name forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
binders Type
res_kind ->
do { Injectivity
inj' <- [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) -> TcM Injectivity
tcInjectivity [TyConBinder]
binders Maybe (LInjectivityAnn GhcRn)
inj
; forall (m :: * -> *) a. Monad m => a -> m a
return (Injectivity
inj', [TyConBinder]
binders, Type
res_kind) }
; Name -> TcRn ()
checkFamFlag Name
tc_name
; Name -> FamilyResultSig GhcRn -> TcRn ()
checkResultSigFlag Name
tc_name FamilyResultSig GhcRn
sig
; case Maybe [LTyFamInstEqn GhcRn]
mb_eqns of
Maybe [LTyFamInstEqn GhcRn]
Nothing ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name
-> [TyConBinder]
-> Type
-> Maybe Name
-> FamTyConFlav
-> Maybe Class
-> Injectivity
-> TyCon
mkFamilyTyCon Name
tc_name [TyConBinder]
binders Type
res_kind
(forall (a :: Pass).
FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
resultVariableName FamilyResultSig GhcRn
sig)
FamTyConFlav
AbstractClosedSynFamilyTyCon Maybe Class
parent
Injectivity
inj'
Just [LTyFamInstEqn GhcRn]
eqns -> do {
; let tc_fam_tc :: TyCon
tc_fam_tc = Name
-> [TyConBinder]
-> Type
-> [(Name, TyVar)]
-> Bool
-> TyConFlavour
-> TyCon
mkTcTyCon Name
tc_name [TyConBinder]
binders Type
res_kind
[(Name, TyVar)]
noTcTyConScopedTyVars
Bool
False
TyConFlavour
ClosedTypeFamilyFlavour
; [KnotTied CoAxBranch]
branches <- forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM (TyCon
-> AssocInstInfo
-> LTyFamInstEqn GhcRn
-> TcM (KnotTied CoAxBranch)
tcTyFamInstEqn TyCon
tc_fam_tc AssocInstInfo
NotAssociated) [LTyFamInstEqn GhcRn]
eqns
; Name
co_ax_name <- GenLocated SrcSpanAnnN Name -> [[Type]] -> TcM Name
newFamInstAxiomName LIdP GhcRn
tc_lname []
; let mb_co_ax :: Maybe (CoAxiom Branched)
mb_co_ax
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LTyFamInstEqn GhcRn]
eqns = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just (Name -> TyCon -> [KnotTied CoAxBranch] -> CoAxiom Branched
mkBranchedCoAxiom Name
co_ax_name TyCon
fam_tc [KnotTied CoAxBranch]
branches)
fam_tc :: TyCon
fam_tc = Name
-> [TyConBinder]
-> Type
-> Maybe Name
-> FamTyConFlav
-> Maybe Class
-> Injectivity
-> TyCon
mkFamilyTyCon Name
tc_name [TyConBinder]
binders Type
res_kind (forall (a :: Pass).
FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
resultVariableName FamilyResultSig GhcRn
sig)
(Maybe (CoAxiom Branched) -> FamTyConFlav
ClosedSynFamilyTyCon Maybe (CoAxiom Branched)
mb_co_ax) Maybe Class
parent Injectivity
inj'
; forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
fam_tc } }
#if __GLASGOW_HASKELL__ <= 810
| otherwise = panic "tcFamInst1"
#endif
tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn)
-> TcM Injectivity
tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) -> TcM Injectivity
tcInjectivity [TyConBinder]
_ Maybe (LInjectivityAnn GhcRn)
Nothing
= forall (m :: * -> *) a. Monad m => a -> m a
return Injectivity
NotInjective
tcInjectivity [TyConBinder]
tcbs (Just (L SrcSpan
loc (InjectivityAnn XCInjectivityAnn GhcRn
_ LIdP GhcRn
_ [LIdP GhcRn]
lInjNames)))
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$
do { let tvs :: [TyVar]
tvs = forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tcbs
; DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Bool -> SDoc -> TcRn ()
checkTc (Extension -> DynFlags -> Bool
xopt Extension
LangExt.TypeFamilyDependencies DynFlags
dflags)
(String -> SDoc
text String
"Illegal injectivity annotation" SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"Use TypeFamilyDependencies to allow this")
; [TyVar]
inj_tvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> TcM TyVar
tcLookupTyVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LIdP GhcRn]
lInjNames
; [TyVar]
inj_tvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasDebugCallStack => TyVar -> TcM TyVar
zonkTcTyVarToTyVar [TyVar]
inj_tvs
; let inj_ktvs :: VarSet
inj_ktvs = (TyVar -> Bool) -> VarSet -> VarSet
filterVarSet TyVar -> Bool
isTyVar forall a b. (a -> b) -> a -> b
$
VarSet -> VarSet
closeOverKinds ([TyVar] -> VarSet
mkVarSet [TyVar]
inj_tvs)
; let inj_bools :: [Bool]
inj_bools = forall a b. (a -> b) -> [a] -> [b]
map (TyVar -> VarSet -> Bool
`elemVarSet` VarSet
inj_ktvs) [TyVar]
tvs
; String -> SDoc -> TcRn ()
traceTc String
"tcInjectivity" ([SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs, forall a. Outputable a => a -> SDoc
ppr [LIdP GhcRn]
lInjNames, forall a. Outputable a => a -> SDoc
ppr [TyVar]
inj_tvs
, forall a. Outputable a => a -> SDoc
ppr VarSet
inj_ktvs, forall a. Outputable a => a -> SDoc
ppr [Bool]
inj_bools ])
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Bool] -> Injectivity
Injective [Bool]
inj_bools }
tcTySynRhs :: RolesInfo -> Name
-> LHsType GhcRn -> TcM TyCon
tcTySynRhs :: (Name -> [Role]) -> Name -> LHsKind GhcRn -> TcM TyCon
tcTySynRhs Name -> [Role]
roles_info Name
tc_name LHsKind GhcRn
hs_ty
= forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tc_name forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
binders Type
res_kind ->
do { TcLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; String -> SDoc -> TcRn ()
traceTc String
"tc-syn" (forall a. Outputable a => a -> SDoc
ppr Name
tc_name SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr (TcLclEnv -> TcTypeEnv
tcl_env TcLclEnv
env))
; Type
rhs_ty <- forall a. SkolemInfo -> [TyVar] -> TcM a -> TcM a
pushLevelAndSolveEqualities SkolemInfo
skol_info (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
binders) forall a b. (a -> b) -> a -> b
$
LHsKind GhcRn -> ContextKind -> TcM Type
tcCheckLHsType LHsKind GhcRn
hs_ty (Type -> ContextKind
TheKind Type
res_kind)
; CandidatesQTvs
dvs <- Type -> TcM CandidatesQTvs
candidateQTyVarsOfType Type
rhs_ty
; let mk_doc :: TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
mk_doc TidyEnv
tidy_env = do { (TidyEnv
tidy_env2, Type
rhs_ty) <- TidyEnv -> Type -> TcM (TidyEnv, Type)
zonkTidyTcType TidyEnv
tidy_env Type
rhs_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return ( TidyEnv
tidy_env2
, [SDoc] -> SDoc
sep [ String -> SDoc
text String
"the type synonym right-hand side:"
, forall a. Outputable a => a -> SDoc
ppr Type
rhs_ty ] ) }
; CandidatesQTvs
-> (TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc))
-> TcRn ()
doNotQuantifyTyVars CandidatesQTvs
dvs TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
mk_doc
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; Type
rhs_ty <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
rhs_ty
; let roles :: [Role]
roles = Name -> [Role]
roles_info Name
tc_name
; forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [TyConBinder] -> Type -> [Role] -> Type -> TyCon
buildSynTyCon Name
tc_name [TyConBinder]
binders Type
res_kind [Role]
roles Type
rhs_ty) }
where
skol_info :: SkolemInfo
skol_info = TyConFlavour -> Name -> SkolemInfo
TyConSkol TyConFlavour
TypeSynonymFlavour Name
tc_name
tcDataDefn :: SDoc -> RolesInfo -> Name
-> HsDataDefn GhcRn -> TcM (TyCon, [DerivInfo])
tcDataDefn :: SDoc
-> (Name -> [Role])
-> Name
-> HsDataDefn GhcRn
-> TcM (TyCon, [DerivInfo])
tcDataDefn SDoc
err_ctxt Name -> [Role]
roles_info Name
tc_name
(HsDataDefn { dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_ND = NewOrData
new_or_data, dd_cType :: forall pass. HsDataDefn pass -> Maybe (XRec pass CType)
dd_cType = Maybe (XRec GhcRn CType)
cType
, dd_ctxt :: forall pass. HsDataDefn pass -> Maybe (LHsContext pass)
dd_ctxt = Maybe (LHsContext GhcRn)
ctxt
, dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (LHsKind GhcRn)
mb_ksig
, dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons = [LConDecl GhcRn]
cons
, dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs = HsDeriving GhcRn
derivs })
= forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tc_name forall a b. (a -> b) -> a -> b
$ \ TyCon
tctc [TyConBinder]
tycon_binders Type
res_kind ->
do { Bool
gadt_syntax <- Name
-> NewOrData
-> Maybe (LHsContext GhcRn)
-> [LConDecl GhcRn]
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
dataDeclChecks Name
tc_name NewOrData
new_or_data Maybe (LHsContext GhcRn)
ctxt [LConDecl GhcRn]
cons
; ([TyConBinder]
extra_bndrs, Type
final_res_kind) <- [TyConBinder] -> Type -> TcM ([TyConBinder], Type)
etaExpandAlgTyCon [TyConBinder]
tycon_binders Type
res_kind
; TcGblEnv
tcg_env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let hsc_src :: HscSource
hsc_src = TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall {a}. HscSource -> [a] -> Bool
mk_permissive_kind HscSource
hsc_src [LConDecl GhcRn]
cons) forall a b. (a -> b) -> a -> b
$
DataSort -> Type -> TcRn ()
checkDataKindSig (NewOrData -> DataSort
DataDeclSort NewOrData
new_or_data) Type
final_res_kind
; let skol_tvs :: [TyVar]
skol_tvs = forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tycon_binders
; [Type]
stupid_tc_theta <- forall a. SkolemInfo -> [TyVar] -> TcM a -> TcM a
pushLevelAndSolveEqualities SkolemInfo
skol_info [TyVar]
skol_tvs forall a b. (a -> b) -> a -> b
$
Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
ctxt
; CandidatesQTvs
dvs <- [Type] -> TcM CandidatesQTvs
candidateQTyVarsOfTypes [Type]
stupid_tc_theta
; let mk_doc :: TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
mk_doc TidyEnv
tidy_env
= do { (TidyEnv
tidy_env2, [Type]
theta) <- TidyEnv -> [Type] -> TcM (TidyEnv, [Type])
zonkTidyTcTypes TidyEnv
tidy_env [Type]
stupid_tc_theta
; forall (m :: * -> *) a. Monad m => a -> m a
return ( TidyEnv
tidy_env2
, [SDoc] -> SDoc
sep [ String -> SDoc
text String
"the datatype context:"
, [Type] -> SDoc
pprTheta [Type]
theta ] ) }
; CandidatesQTvs
-> (TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc))
-> TcRn ()
doNotQuantifyTyVars CandidatesQTvs
dvs TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
mk_doc
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; [Type]
stupid_theta <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
stupid_tc_theta
; Bool
kind_signatures <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.KindSignatures
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe (LHsKind GhcRn)
mb_ksig) forall a b. (a -> b) -> a -> b
$
Bool -> SDoc -> TcRn ()
checkTc (Bool
kind_signatures) (Name -> SDoc
badSigTyDecl Name
tc_name)
; TyCon
tycon <- forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM forall a b. (a -> b) -> a -> b
$ \ TyCon
rec_tycon -> do
{ let final_bndrs :: [TyConBinder]
final_bndrs = [TyConBinder]
tycon_binders forall a. [a] -> [a] -> [a]
`chkAppend` [TyConBinder]
extra_bndrs
roles :: [Role]
roles = Name -> [Role]
roles_info Name
tc_name
; [DataCon]
data_cons <- NewOrData
-> DataDeclInfo
-> TyCon
-> [TyConBinder]
-> Type
-> [LConDecl GhcRn]
-> TcM [DataCon]
tcConDecls
NewOrData
new_or_data DataDeclInfo
DDataType
TyCon
rec_tycon [TyConBinder]
final_bndrs Type
final_res_kind
[LConDecl GhcRn]
cons
; AlgTyConRhs
tc_rhs <- HscSource
-> TyCon -> [DataCon] -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
mk_tc_rhs HscSource
hsc_src TyCon
rec_tycon [DataCon]
data_cons
; Name
tc_rep_nm <- forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
tc_name
; forall (m :: * -> *) a. Monad m => a -> m a
return (Name
-> [TyConBinder]
-> Type
-> [Role]
-> Maybe CType
-> [Type]
-> AlgTyConRhs
-> AlgTyConFlav
-> Bool
-> TyCon
mkAlgTyCon Name
tc_name
[TyConBinder]
final_bndrs
Type
final_res_kind
[Role]
roles
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l e. GenLocated l e -> e
unLoc Maybe (XRec GhcRn CType)
cType)
[Type]
stupid_theta AlgTyConRhs
tc_rhs
(Name -> AlgTyConFlav
VanillaAlgTyCon Name
tc_rep_nm)
Bool
gadt_syntax) }
; let deriv_info :: DerivInfo
deriv_info = DerivInfo { di_rep_tc :: TyCon
di_rep_tc = TyCon
tycon
, di_scoped_tvs :: [(Name, TyVar)]
di_scoped_tvs = TyCon -> [(Name, TyVar)]
tcTyConScopedTyVars TyCon
tctc
, di_clauses :: HsDeriving GhcRn
di_clauses = HsDeriving GhcRn
derivs
, di_ctxt :: SDoc
di_ctxt = SDoc
err_ctxt }
; String -> SDoc -> TcRn ()
traceTc String
"tcDataDefn" (forall a. Outputable a => a -> SDoc
ppr Name
tc_name SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
tycon_binders SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
extra_bndrs)
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
tycon, [DerivInfo
deriv_info]) }
where
skol_info :: SkolemInfo
skol_info = TyConFlavour -> Name -> SkolemInfo
TyConSkol TyConFlavour
flav Name
tc_name
flav :: TyConFlavour
flav = NewOrData -> TyConFlavour
newOrDataToFlavour NewOrData
new_or_data
mk_permissive_kind :: HscSource -> [a] -> Bool
mk_permissive_kind HscSource
HsigFile [] = Bool
True
mk_permissive_kind HscSource
_ [a]
_ = Bool
False
mk_tc_rhs :: HscSource
-> TyCon -> [DataCon] -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
mk_tc_rhs HscSource
HsBootFile TyCon
_ []
= forall (m :: * -> *) a. Monad m => a -> m a
return AlgTyConRhs
AbstractTyCon
mk_tc_rhs HscSource
HsigFile TyCon
_ []
= forall (m :: * -> *) a. Monad m => a -> m a
return AlgTyConRhs
AbstractTyCon
mk_tc_rhs HscSource
_ TyCon
tycon [DataCon]
data_cons
= case NewOrData
new_or_data of
NewOrData
DataType -> forall (m :: * -> *) a. Monad m => a -> m a
return ([DataCon] -> AlgTyConRhs
mkDataTyConRhs [DataCon]
data_cons)
NewOrData
NewType -> ASSERT( not (null data_cons) )
forall m n. Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
mkNewTyConRhs Name
tc_name TyCon
tycon (forall a. [a] -> a
head [DataCon]
data_cons)
kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM ()
kcTyFamInstEqn :: TyCon -> LTyFamInstEqn GhcRn -> TcRn ()
kcTyFamInstEqn TyCon
tc_fam_tc
(L SrcSpanAnnA
loc (FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = L SrcSpanAnnN
_ Name
eqn_tc_name
, feqn_bndrs :: forall pass rhs. FamEqn pass rhs -> HsOuterFamEqnTyVarBndrs pass
feqn_bndrs = HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs
, feqn_pats :: forall pass rhs. FamEqn pass rhs -> HsTyPats pass
feqn_pats = HsTyPats GhcRn
hs_pats
, feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = GenLocated SrcSpanAnnA (HsType GhcRn)
hs_rhs_ty }))
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"kcTyFamInstEqn" ([SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"tc_name =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
eqn_tc_name
, String -> SDoc
text String
"fam_tc =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyCon
tc_fam_tc SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConKind TyCon
tc_fam_tc)
, String -> SDoc
text String
"feqn_bndrs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs
, String -> SDoc
text String
"feqn_pats =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr HsTyPats GhcRn
hs_pats ])
; forall tm ty. TyCon -> Name -> [HsArg tm ty] -> TcRn ()
checkTyFamInstEqn TyCon
tc_fam_tc Name
eqn_tc_name HsTyPats GhcRn
hs_pats
; forall a. TcM a -> TcRn ()
discardResult forall a b. (a -> b) -> a -> b
$
forall a.
HsOuterFamEqnTyVarBndrs GhcRn -> TcM a -> TcM ([TyVar], a)
bindOuterFamEqnTKBndrs_Q_Tv HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs forall a b. (a -> b) -> a -> b
$
do { (Type
_fam_app, Type
res_kind) <- TyCon -> HsTyPats GhcRn -> TcM (Type, Type)
tcFamTyPats TyCon
tc_fam_tc HsTyPats GhcRn
hs_pats
; LHsKind GhcRn -> ContextKind -> TcM Type
tcCheckLHsType GenLocated SrcSpanAnnA (HsType GhcRn)
hs_rhs_ty (Type -> ContextKind
TheKind Type
res_kind) }
}
tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn
-> TcM (KnotTied CoAxBranch)
tcTyFamInstEqn :: TyCon
-> AssocInstInfo
-> LTyFamInstEqn GhcRn
-> TcM (KnotTied CoAxBranch)
tcTyFamInstEqn TyCon
fam_tc AssocInstInfo
mb_clsinfo
(L SrcSpanAnnA
loc (FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = L SrcSpanAnnN
_ Name
eqn_tc_name
, feqn_bndrs :: forall pass rhs. FamEqn pass rhs -> HsOuterFamEqnTyVarBndrs pass
feqn_bndrs = HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs
, feqn_pats :: forall pass rhs. FamEqn pass rhs -> HsTyPats pass
feqn_pats = HsTyPats GhcRn
hs_pats
, feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = GenLocated SrcSpanAnnA (HsType GhcRn)
hs_rhs_ty }))
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcTyFamInstEqn" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr SrcSpanAnnA
loc, forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr HsTyPats GhcRn
hs_pats
, String -> SDoc
text String
"fam tc bndrs" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars (TyCon -> [TyVar]
tyConTyVars TyCon
fam_tc)
, case AssocInstInfo
mb_clsinfo of
NotAssociated {} -> SDoc
empty
InClsInst { ai_class :: AssocInstInfo -> Class
ai_class = Class
cls } -> String -> SDoc
text String
"class" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Class
cls SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars (Class -> [TyVar]
classTyVars Class
cls) ]
; forall tm ty. TyCon -> Name -> [HsArg tm ty] -> TcRn ()
checkTyFamInstEqn TyCon
fam_tc Name
eqn_tc_name HsTyPats GhcRn
hs_pats
; ([TyVar]
qtvs, [Type]
pats, Type
rhs_ty) <- TyCon
-> AssocInstInfo
-> HsOuterFamEqnTyVarBndrs GhcRn
-> HsTyPats GhcRn
-> LHsKind GhcRn
-> TcM ([TyVar], [Type], Type)
tcTyFamInstEqnGuts TyCon
fam_tc AssocInstInfo
mb_clsinfo
HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs HsTyPats GhcRn
hs_pats GenLocated SrcSpanAnnA (HsType GhcRn)
hs_rhs_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
-> [TyVar]
-> [TyVar]
-> [Type]
-> Type
-> [Role]
-> SrcSpan
-> KnotTied CoAxBranch
mkCoAxBranch [TyVar]
qtvs [] [] [Type]
pats Type
rhs_ty
(forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Role
Nominal) [TyVar]
qtvs)
(forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)) }
checkTyFamInstEqn :: TcTyCon -> Name -> [HsArg tm ty] -> TcM ()
checkTyFamInstEqn :: forall tm ty. TyCon -> Name -> [HsArg tm ty] -> TcRn ()
checkTyFamInstEqn TyCon
tc_fam_tc Name
eqn_tc_name [HsArg tm ty]
hs_pats =
do {
let tc_fam_tc_name :: Name
tc_fam_tc_name = forall a. NamedThing a => a -> Name
getName TyCon
tc_fam_tc
; Bool -> SDoc -> TcRn ()
checkTc (Name
tc_fam_tc_name forall a. Eq a => a -> a -> Bool
== Name
eqn_tc_name) forall a b. (a -> b) -> a -> b
$
Name -> Name -> SDoc
wrongTyFamName Name
tc_fam_tc_name Name
eqn_tc_name
; let vis_arity :: Arity
vis_arity = forall (t :: * -> *) a. Foldable t => t a -> Arity
length (TyCon -> [TyVar]
tyConVisibleTyVars TyCon
tc_fam_tc)
vis_pats :: Arity
vis_pats = forall tm ty. [HsArg tm ty] -> Arity
numVisibleArgs [HsArg tm ty]
hs_pats
; Bool -> SDoc -> TcRn ()
checkTc (Arity
vis_pats forall a. Eq a => a -> a -> Bool
== Arity
vis_arity) forall a b. (a -> b) -> a -> b
$
Arity -> SDoc
wrongNumberOfParmsErr Arity
vis_arity
}
tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo
-> HsOuterFamEqnTyVarBndrs GhcRn
-> HsTyPats GhcRn
-> LHsType GhcRn
-> TcM ([TyVar], [TcType], TcType)
tcTyFamInstEqnGuts :: TyCon
-> AssocInstInfo
-> HsOuterFamEqnTyVarBndrs GhcRn
-> HsTyPats GhcRn
-> LHsKind GhcRn
-> TcM ([TyVar], [Type], Type)
tcTyFamInstEqnGuts TyCon
fam_tc AssocInstInfo
mb_clsinfo HsOuterFamEqnTyVarBndrs GhcRn
outer_hs_bndrs HsTyPats GhcRn
hs_pats LHsKind GhcRn
hs_rhs_ty
= do { String -> SDoc -> TcRn ()
traceTc String
"tcTyFamInstEqnGuts {" (forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc)
; (TcLevel
tclvl, WantedConstraints
wanted, ([TyVar]
outer_tvs, (Type
lhs_ty, Type
rhs_ty)))
<- forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tcTyFamInstEqnGuts" forall a b. (a -> b) -> a -> b
$
forall a.
HsOuterFamEqnTyVarBndrs GhcRn -> TcM a -> TcM ([TyVar], a)
bindOuterFamEqnTKBndrs HsOuterFamEqnTyVarBndrs GhcRn
outer_hs_bndrs forall a b. (a -> b) -> a -> b
$
do { (Type
lhs_ty, Type
rhs_kind) <- TyCon -> HsTyPats GhcRn -> TcM (Type, Type)
tcFamTyPats TyCon
fam_tc HsTyPats GhcRn
hs_pats
; AssocInstInfo -> Type -> TcRn ()
addConsistencyConstraints AssocInstInfo
mb_clsinfo Type
lhs_ty
; Type
rhs_ty <- LHsKind GhcRn -> ContextKind -> TcM Type
tcCheckLHsType LHsKind GhcRn
hs_rhs_ty (Type -> ContextKind
TheKind Type
rhs_kind)
; forall (m :: * -> *) a. Monad m => a -> m a
return (Type
lhs_ty, Type
rhs_ty) }
; CandidatesQTvs
dvs <- [Type] -> TcM CandidatesQTvs
candidateQTyVarsOfTypes (Type
lhs_ty forall a. a -> [a] -> [a]
: [TyVar] -> [Type]
mkTyVarTys [TyVar]
outer_tvs)
; [TyVar]
qtvs <- CandidatesQTvs -> TcM [TyVar]
quantifyTyVars CandidatesQTvs
dvs
; SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcRn ()
reportUnsolvedEqualities SkolemInfo
FamInstSkol [TyVar]
qtvs TcLevel
tclvl WantedConstraints
wanted
; TcLevel -> HsOuterFamEqnTyVarBndrs GhcRn -> [TyVar] -> TcRn ()
checkFamTelescope TcLevel
tclvl HsOuterFamEqnTyVarBndrs GhcRn
outer_hs_bndrs [TyVar]
outer_tvs
; String -> SDoc -> TcRn ()
traceTc String
"tcTyFamInstEqnGuts 2" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc
, String -> SDoc
text String
"lhs_ty" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
lhs_ty
, String -> SDoc
text String
"qtvs" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
qtvs ]
; CandidatesQTvs
dvs_rhs <- Type -> TcM CandidatesQTvs
candidateQTyVarsOfType Type
rhs_ty
; let mk_doc :: TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
mk_doc TidyEnv
tidy_env
= do { (TidyEnv
tidy_env2, Type
rhs_ty) <- TidyEnv -> Type -> TcM (TidyEnv, Type)
zonkTidyTcType TidyEnv
tidy_env Type
rhs_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return ( TidyEnv
tidy_env2
, [SDoc] -> SDoc
sep [ String -> SDoc
text String
"type family equation right-hand side:"
, forall a. Outputable a => a -> SDoc
ppr Type
rhs_ty ] ) }
; CandidatesQTvs
-> (TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc))
-> TcRn ()
doNotQuantifyTyVars CandidatesQTvs
dvs_rhs TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
mk_doc
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; (ZonkEnv
ze, [TyVar]
qtvs) <- ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX ZonkEnv
ze [TyVar]
qtvs
; Type
lhs_ty <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
lhs_ty
; Type
rhs_ty <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
rhs_ty
; let pats :: [Type]
pats = Type -> [Type]
unravelFamInstPats Type
lhs_ty
; String -> SDoc -> TcRn ()
traceTc String
"tcTyFamInstEqnGuts }" (forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
qtvs)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
qtvs, [Type]
pats, Type
rhs_ty) }
checkFamTelescope :: TcLevel -> HsOuterFamEqnTyVarBndrs GhcRn
-> [TcTyVar] -> TcM ()
checkFamTelescope :: TcLevel -> HsOuterFamEqnTyVarBndrs GhcRn -> [TyVar] -> TcRn ()
checkFamTelescope TcLevel
tclvl HsOuterFamEqnTyVarBndrs GhcRn
hs_outer_bndrs [TyVar]
outer_tvs
| HsOuterExplicit { hso_bndrs :: forall flag pass.
HsOuterTyVarBndrs flag pass -> [LHsTyVarBndr flag (NoGhcTc pass)]
hso_bndrs = [LHsTyVarBndr () (NoGhcTc GhcRn)]
bndrs } <- HsOuterFamEqnTyVarBndrs GhcRn
hs_outer_bndrs
, (LHsTyVarBndr () (NoGhcTc GhcRn)
b_first : [LHsTyVarBndr () (NoGhcTc GhcRn)]
_) <- [LHsTyVarBndr () (NoGhcTc GhcRn)]
bndrs
, let b_last :: GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
b_last = forall a. [a] -> a
last [LHsTyVarBndr () (NoGhcTc GhcRn)]
bndrs
skol_info :: SkolemInfo
skol_info = SDoc -> SkolemInfo
ForAllSkol ([SDoc] -> SDoc
fsep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr () (NoGhcTc GhcRn)]
bndrs))
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsTyVarBndr () (NoGhcTc GhcRn)
b_first) (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
b_last)) forall a b. (a -> b) -> a -> b
$
SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcRn ()
emitResidualTvConstraint SkolemInfo
skol_info [TyVar]
outer_tvs TcLevel
tclvl WantedConstraints
emptyWC
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
unravelFamInstPats :: TcType -> [TcType]
unravelFamInstPats :: Type -> [Type]
unravelFamInstPats Type
fam_app
= case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
fam_app of
Just (TyCon
_, [Type]
pats) -> [Type]
pats
Maybe (TyCon, [Type])
Nothing -> forall a. String -> a
panic String
"unravelFamInstPats: Ill-typed LHS of family instance"
addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM ()
addConsistencyConstraints :: AssocInstInfo -> Type -> TcRn ()
addConsistencyConstraints AssocInstInfo
mb_clsinfo Type
fam_app
| InClsInst { ai_inst_env :: AssocInstInfo -> VarEnv Type
ai_inst_env = VarEnv Type
inst_env } <- AssocInstInfo
mb_clsinfo
, Just (TyCon
fam_tc, [Type]
pats) <- HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
fam_app
= do { let eqs :: [(Type, Type)]
eqs = [ (Type
cls_ty, Type
pat)
| (TyVar
fam_tc_tv, Type
pat) <- TyCon -> [TyVar]
tyConTyVars TyCon
fam_tc forall a b. [a] -> [b] -> [(a, b)]
`zip` [Type]
pats
, Just Type
cls_ty <- [forall a. VarEnv a -> TyVar -> Maybe a
lookupVarEnv VarEnv Type
inst_env TyVar
fam_tc_tv] ]
; String -> SDoc -> TcRn ()
traceTc String
"addConsistencyConstraints" (forall a. Outputable a => a -> SDoc
ppr [(Type, Type)]
eqs)
; CtOrigin -> [(Type, Type)] -> TcRn ()
emitDerivedEqs CtOrigin
AssocFamPatOrigin [(Type, Type)]
eqs }
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
dataDeclChecks :: Name -> NewOrData
-> Maybe (LHsContext GhcRn) -> [LConDecl GhcRn]
-> TcM Bool
dataDeclChecks :: Name
-> NewOrData
-> Maybe (LHsContext GhcRn)
-> [LConDecl GhcRn]
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
dataDeclChecks Name
tc_name NewOrData
new_or_data Maybe (LHsContext GhcRn)
mctxt [LConDecl GhcRn]
cons
= do { let stupid_theta :: HsContext GhcRn
stupid_theta = forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext Maybe (LHsContext GhcRn)
mctxt
; Bool
gadtSyntax_ok <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.GADTSyntax
; let gadt_syntax :: Bool
gadt_syntax = [LConDecl GhcRn] -> Bool
consUseGadtSyntax [LConDecl GhcRn]
cons
; Bool -> SDoc -> TcRn ()
checkTc (Bool
gadtSyntax_ok Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
gadt_syntax) (Name -> SDoc
badGadtDecl Name
tc_name)
; Bool -> SDoc -> TcRn ()
checkTc (forall (t :: * -> *) a. Foldable t => t a -> Bool
null HsContext GhcRn
stupid_theta Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
gadt_syntax) (Name -> SDoc
badStupidTheta Name
tc_name)
; Bool -> SDoc -> TcRn ()
checkTc (NewOrData
new_or_data forall a. Eq a => a -> a -> Bool
== NewOrData
DataType Bool -> Bool -> Bool
|| forall a. [a] -> Bool
isSingleton [LConDecl GhcRn]
cons)
(Name -> Arity -> SDoc
newtypeConError Name
tc_name (forall (t :: * -> *) a. Foldable t => t a -> Arity
length [LConDecl GhcRn]
cons))
; Bool
empty_data_decls <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.EmptyDataDecls
; Bool
is_boot <- IOEnv (Env TcGblEnv TcLclEnv) Bool
tcIsHsBootOrSig
; Bool -> SDoc -> TcRn ()
checkTc (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LConDecl GhcRn]
cons) Bool -> Bool -> Bool
|| Bool
empty_data_decls Bool -> Bool -> Bool
|| Bool
is_boot)
(Name -> SDoc
emptyConDeclsErr Name
tc_name)
; forall (m :: * -> *) a. Monad m => a -> m a
return Bool
gadt_syntax }
consUseGadtSyntax :: [LConDecl GhcRn] -> Bool
consUseGadtSyntax :: [LConDecl GhcRn] -> Bool
consUseGadtSyntax (L SrcSpanAnnA
_ (ConDeclGADT {}) : [LConDecl GhcRn]
_) = Bool
True
consUseGadtSyntax [LConDecl GhcRn]
_ = Bool
False
data DataDeclInfo
= DDataType
| DDataInstance
Type
mkDDHeaderTy :: DataDeclInfo -> TyCon -> [TyConBinder] -> Type
DataDeclInfo
dd_info TyCon
rep_tycon [TyConBinder]
tc_bndrs
= case DataDeclInfo
dd_info of
DataDeclInfo
DDataType -> TyCon -> [Type] -> Type
mkTyConApp TyCon
rep_tycon forall a b. (a -> b) -> a -> b
$
[TyVar] -> [Type]
mkTyVarTys (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tc_bndrs)
DDataInstance Type
header_ty -> Type
header_ty
tcConDecls :: NewOrData
-> DataDeclInfo
-> KnotTied TyCon
-> [TyConBinder]
-> TcKind
-> [LConDecl GhcRn] -> TcM [DataCon]
tcConDecls :: NewOrData
-> DataDeclInfo
-> TyCon
-> [TyConBinder]
-> Type
-> [LConDecl GhcRn]
-> TcM [DataCon]
tcConDecls NewOrData
new_or_data DataDeclInfo
dd_info TyCon
rep_tycon [TyConBinder]
tmpl_bndrs Type
res_kind
= forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM forall a b. (a -> b) -> a -> b
$ forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA forall a b. (a -> b) -> a -> b
$
NewOrData
-> DataDeclInfo
-> TyCon
-> [TyConBinder]
-> Type
-> NameEnv Arity
-> ConDecl GhcRn
-> TcM [DataCon]
tcConDecl NewOrData
new_or_data DataDeclInfo
dd_info TyCon
rep_tycon [TyConBinder]
tmpl_bndrs Type
res_kind
(TyCon -> NameEnv Arity
mkTyConTagMap TyCon
rep_tycon)
tcConDecl :: NewOrData
-> DataDeclInfo
-> KnotTied TyCon
-> [TyConBinder]
-> TcKind
-> NameEnv ConTag
-> ConDecl GhcRn
-> TcM [DataCon]
tcConDecl :: NewOrData
-> DataDeclInfo
-> TyCon
-> [TyConBinder]
-> Type
-> NameEnv Arity
-> ConDecl GhcRn
-> TcM [DataCon]
tcConDecl NewOrData
new_or_data DataDeclInfo
dd_info TyCon
rep_tycon [TyConBinder]
tc_bndrs Type
res_kind NameEnv Arity
tag_map
(ConDeclH98 { con_name :: forall pass. ConDecl pass -> LIdP pass
con_name = lname :: LIdP GhcRn
lname@(L SrcSpanAnnN
_ Name
name)
, con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_ex_tvs = [LHsTyVarBndr Specificity GhcRn]
explicit_tkv_nms
, con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcRn)
hs_ctxt
, con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_args = HsConDeclH98Details GhcRn
hs_args })
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([GenLocated SrcSpanAnnN Name] -> SDoc
dataConCtxt [LIdP GhcRn
lname]) forall a b. (a -> b) -> a -> b
$
do {
; String -> SDoc -> TcRn ()
traceTc String
"tcConDecl 1" ([SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr Name
name, forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr Specificity GhcRn]
explicit_tkv_nms ])
; (TcLevel
tclvl, WantedConstraints
wanted, ([VarBndr TyVar Specificity]
exp_tvbndrs, ([Type]
ctxt, [Scaled Type]
arg_tys, [FieldLabel]
field_lbls, [HsSrcBang]
stricts)))
<- forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tcConDecl:H98" forall a b. (a -> b) -> a -> b
$
forall flag a.
OutputableBndrFlag flag 'Renamed =>
[LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a)
tcExplicitTKBndrs [LHsTyVarBndr Specificity GhcRn]
explicit_tkv_nms forall a b. (a -> b) -> a -> b
$
do { [Type]
ctxt <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
hs_ctxt
; let exp_kind :: ContextKind
exp_kind = NewOrData -> Type -> ContextKind
getArgExpKind NewOrData
new_or_data Type
res_kind
; [(Scaled Type, HsSrcBang)]
btys <- ContextKind
-> HsConDeclH98Details GhcRn -> TcM [(Scaled Type, HsSrcBang)]
tcConH98Args ContextKind
exp_kind HsConDeclH98Details GhcRn
hs_args
; [FieldLabel]
field_lbls <- Name -> RnM [FieldLabel]
lookupConstructorFields Name
name
; let ([Scaled Type]
arg_tys, [HsSrcBang]
stricts) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Scaled Type, HsSrcBang)]
btys
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
ctxt, [Scaled Type]
arg_tys, [FieldLabel]
field_lbls, [HsSrcBang]
stricts)
}
; let tc_tvs :: [TyVar]
tc_tvs = forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tc_bndrs
fake_ty :: Type
fake_ty = [TyVar] -> Type -> Type
mkSpecForAllTys [TyVar]
tc_tvs forall a b. (a -> b) -> a -> b
$
[VarBndr TyVar Specificity] -> Type -> Type
mkInvisForAllTys [VarBndr TyVar Specificity]
exp_tvbndrs forall a b. (a -> b) -> a -> b
$
[Type] -> Type -> Type
mkPhiTy [Type]
ctxt forall a b. (a -> b) -> a -> b
$
[Scaled Type] -> Type -> Type
mkVisFunTys [Scaled Type]
arg_tys forall a b. (a -> b) -> a -> b
$
Type
unitTy
; [TyVar]
kvs <- Type -> TcM [TyVar]
kindGeneralizeAll Type
fake_ty
; let skol_tvs :: [TyVar]
skol_tvs = [TyVar]
tc_tvs forall a. [a] -> [a] -> [a]
++ [TyVar]
kvs forall a. [a] -> [a] -> [a]
++ forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TyVar Specificity]
exp_tvbndrs
; SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcRn ()
reportUnsolvedEqualities SkolemInfo
skol_info [TyVar]
skol_tvs TcLevel
tclvl WantedConstraints
wanted
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; (ZonkEnv
ze, [TyVar]
qkvs) <- ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX ZonkEnv
ze [TyVar]
kvs
; (ZonkEnv
ze, [VarBndr TyVar Specificity]
user_qtvbndrs) <- forall vis.
ZonkEnv
-> [VarBndr TyVar vis] -> TcM (ZonkEnv, [VarBndr TyVar vis])
zonkTyVarBindersX ZonkEnv
ze [VarBndr TyVar Specificity]
exp_tvbndrs
; [Scaled Type]
arg_tys <- ZonkEnv -> [Scaled Type] -> TcM [Scaled Type]
zonkScaledTcTypesToTypesX ZonkEnv
ze [Scaled Type]
arg_tys
; [Type]
ctxt <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
ctxt
; String -> SDoc -> TcRn ()