{-# LANGUAGE CPP #-}
{-# LANGUAGE 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,
checkFamTelescope
) where
import GHC.Prelude
import GHC.Driver.Env
import GHC.Driver.DynFlags
import GHC.Driver.Config.HsToCore
import GHC.Hs
import GHC.Tc.Errors.Types
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.Zonk.Type
import GHC.Tc.Zonk.TcType
import GHC.Tc.TyCl.Utils
import GHC.Tc.TyCl.Class
import {-# SOURCE #-} GHC.Tc.TyCl.Instance( tcInstDecls1 )
import {-# SOURCE #-} GHC.Tc.Module( checkBootDeclM )
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.Tc.Types.LclEnv
import GHC.Builtin.Types (oneDataConTy, unitTy, makeRecoveryTyCon )
import GHC.Rename.Env( lookupConstructorFields )
import GHC.Core.Multiplicity
import GHC.Core.FamInstEnv ( mkBranchedCoAxiom, mkCoAxBranch )
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.Error
import GHC.Types.Id
import GHC.Types.Id.Make
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.TypeEnv
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( minusList, equivClasses )
import GHC.Unit
import GHC.Unit.Module.ModDetails
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import Control.Monad
import Data.Foldable ( toList, traverse_ )
import Data.Functor.Identity
import Data.List ( partition)
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import Data.Traversable ( for )
import Data.Tuple( swap )
tcTyAndClassDecls :: [TyClGroup GhcRn]
-> TcM ( TcGblEnv
, [InstInfo GhcRn]
, [DerivInfo]
, ThBindEnv
)
tcTyAndClassDecls :: [TyClGroup GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
tcTyAndClassDecls [TyClGroup GhcRn]
tyclds_s
= TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
forall r. TcM r -> TcM r
checkNoErrs (TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv))
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
forall a b. (a -> b) -> a -> b
$ [InstInfo GhcRn]
-> [DerivInfo]
-> ThBindEnv
-> [TyClGroup GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
fold_env [] [] ThBindEnv
forall a. NameEnv a
emptyNameEnv [TyClGroup GhcRn]
tyclds_s
where
fold_env :: [InstInfo GhcRn]
-> [DerivInfo]
-> ThBindEnv
-> [TyClGroup GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
fold_env :: [InstInfo GhcRn]
-> [DerivInfo]
-> ThBindEnv
-> [TyClGroup GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
fold_env [InstInfo GhcRn]
inst_info [DerivInfo]
deriv_info ThBindEnv
th_bndrs []
= do { gbl_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; return (gbl_env, inst_info, deriv_info, th_bndrs) }
fold_env [InstInfo GhcRn]
inst_info [DerivInfo]
deriv_info ThBindEnv
th_bndrs (TyClGroup GhcRn
tyclds:[TyClGroup GhcRn]
tyclds_s)
= do { (tcg_env, inst_info', deriv_info', th_bndrs')
<- TyClGroup GhcRn
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
tcTyClGroup TyClGroup GhcRn
tyclds
; setGblEnv tcg_env $
fold_env (inst_info' ++ inst_info)
(deriv_info' ++ deriv_info)
(th_bndrs' `plusNameEnv` th_bndrs)
tyclds_s }
tcTyClGroup :: TyClGroup GhcRn
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
tcTyClGroup :: TyClGroup GhcRn
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
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
forall doc. IsOutput doc => doc
empty
; String -> SDoc -> TcRn ()
traceTc String
"Decls for" ([IdGhcP 'Renamed] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> IdGhcP 'Renamed)
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)] -> [IdGhcP 'Renamed]
forall a b. (a -> b) -> [a] -> [b]
map (TyClDecl GhcRn -> IdP GhcRn
TyClDecl GhcRn -> IdGhcP 'Renamed
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName (TyClDecl GhcRn -> IdGhcP 'Renamed)
-> (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn)
-> GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> IdGhcP 'Renamed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) [LTyClDecl GhcRn]
[GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
tyclds))
; (tyclss_with_validity_infos, data_deriv_info, kindless) <-
NameEnv TcTyThing
-> TcM ([(TyCon, [TyFamEqnValidityInfo])], [DerivInfo], NameSet)
-> TcM ([(TyCon, [TyFamEqnValidityInfo])], [DerivInfo], NameSet)
forall r. NameEnv TcTyThing -> TcM r -> TcM r
tcExtendKindEnv ([LTyClDecl GhcRn] -> NameEnv TcTyThing
mkPromotionErrorEnv [LTyClDecl GhcRn]
tyclds) (TcM ([(TyCon, [TyFamEqnValidityInfo])], [DerivInfo], NameSet)
-> TcM ([(TyCon, [TyFamEqnValidityInfo])], [DerivInfo], NameSet))
-> TcM ([(TyCon, [TyFamEqnValidityInfo])], [DerivInfo], NameSet)
-> TcM ([(TyCon, [TyFamEqnValidityInfo])], [DerivInfo], NameSet)
forall a b. (a -> b) -> a -> b
$
do { kisig_env <- [(Name, Type)] -> NameEnv Type
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ([(Name, Type)] -> NameEnv Type)
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, Type)]
-> IOEnv (Env TcGblEnv TcLclEnv) (NameEnv Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Name, Type))
-> [GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, Type)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse LStandaloneKindSig GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Name, Type)
GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Name, Type)
tcStandaloneKindSig [LStandaloneKindSig GhcRn]
[GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn)]
kisigs
; tcTyClDecls tyclds kisig_env role_annots }
; let tyclss = ((TyCon, [TyFamEqnValidityInfo]) -> TyCon)
-> [(TyCon, [TyFamEqnValidityInfo])] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map (TyCon, [TyFamEqnValidityInfo]) -> TyCon
forall a b. (a, b) -> a
fst [(TyCon, [TyFamEqnValidityInfo])]
tyclss_with_validity_infos
; traceTc "Starting synonym cycle check" (ppr tyclss)
; home_unit <- hsc_home_unit <$> getTopEnv
; checkSynCycles (homeUnitAsUnit home_unit) tyclss tyclds
; traceTc "Done synonym cycle check" (ppr tyclss)
; traceTc "Starting validity check" (ppr tyclss)
; tyclss <- tcExtendTyConEnv tyclss $
fmap concat . for tyclss_with_validity_infos $ \ (TyCon
tycls, [TyFamEqnValidityInfo]
ax_validity_infos) ->
do { SDoc -> Name -> TcRn () -> TcRn ()
forall a. SDoc -> Name -> TcM a -> TcM a
tcAddFamInstCtxt (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"type family") (TyCon -> Name
tyConName TyCon
tycls) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TyCon -> TcRn () -> TcRn ()
forall a. TyCon -> TcM a -> TcM a
tcAddClosedTypeFamilyDeclCtxt TyCon
tycls (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
(TyFamEqnValidityInfo -> TcRn ())
-> [TyFamEqnValidityInfo] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TyCon -> TyFamEqnValidityInfo -> TcRn ()
checkTyFamEqnValidityInfo TyCon
tycls) [TyFamEqnValidityInfo]
ax_validity_infos
; TyCon -> TcM [TyCon]
checkValidTyCl TyCon
tycls }
; traceTc "Done validity check" (ppr tyclss)
; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss
; traceTc "---- end tcTyClGroup ---- }" empty
; (gbl_env, th_bndrs) <- addTyConsToGblEnv tyclss
; (gbl_env', inst_info, datafam_deriv_info, th_bndrs') <-
setGblEnv gbl_env $
tcInstDecls1 instds
; let deriv_info = [DerivInfo]
datafam_deriv_info [DerivInfo] -> [DerivInfo] -> [DerivInfo]
forall a. [a] -> [a] -> [a]
++ [DerivInfo]
data_deriv_info
; let gbl_env'' = TcGblEnv
gbl_env'
{ tcg_ksigs = tcg_ksigs gbl_env' `unionNameSet` kindless }
; return (gbl_env'', inst_info, deriv_info,
th_bndrs' `plusNameEnv` th_bndrs) }
type KindSigEnv = NameEnv Kind
tcTyClDecls
:: [LTyClDecl GhcRn]
-> KindSigEnv
-> RoleAnnotEnv
-> TcM ([(TyCon, [TyFamEqnValidityInfo])], [DerivInfo], NameSet)
tcTyClDecls :: [LTyClDecl GhcRn]
-> NameEnv Type
-> RoleAnnotEnv
-> TcM ([(TyCon, [TyFamEqnValidityInfo])], [DerivInfo], NameSet)
tcTyClDecls [LTyClDecl GhcRn]
tyclds NameEnv Type
kisig_env RoleAnnotEnv
role_annots
= do {
(tc_tycons, kindless) <- TcM ([TyCon], NameSet) -> TcM ([TyCon], NameSet)
forall r. TcM r -> TcM r
checkNoErrs (TcM ([TyCon], NameSet) -> TcM ([TyCon], NameSet))
-> TcM ([TyCon], NameSet) -> TcM ([TyCon], NameSet)
forall a b. (a -> b) -> a -> b
$
NameEnv Type -> [LTyClDecl GhcRn] -> TcM ([TyCon], NameSet)
kcTyClGroup NameEnv Type
kisig_env [LTyClDecl GhcRn]
tyclds
; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons))
; fixM $ \ ~([(TyCon, [TyFamEqnValidityInfo])]
rec_tyclss_with_validity_infos, [DerivInfo]
_, NameSet
_) -> do
{ tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let !src = TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env
rec_tyclss = ((TyCon, [TyFamEqnValidityInfo]) -> TyCon)
-> [(TyCon, [TyFamEqnValidityInfo])] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map (TyCon, [TyFamEqnValidityInfo]) -> TyCon
forall a b. (a, b) -> a
fst [(TyCon, [TyFamEqnValidityInfo])]
rec_tyclss_with_validity_infos
roles = HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role]
inferRoles HscSource
src RoleAnnotEnv
role_annots [TyCon]
rec_tyclss
; (tycons, data_deriv_infos) <-
tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $
tcExtendKindEnvWithTyCons tc_tycons $
mapAndUnzipM (tcTyClDecl roles) tyclds
; return (tycons, concat data_deriv_infos, kindless)
} }
where
ppr_tc_tycon :: TyCon -> SDoc
ppr_tc_tycon TyCon
tc = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Name
tyConName TyCon
tc) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
, [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [TyConBinder]
tyConBinders TyCon
tc) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConResKind TyCon
tc)
, Bool -> SDoc
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 = TyCon -> 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 = (TyCon -> NameEnv TyCon -> NameEnv TyCon)
-> NameEnv TyCon -> [TyCon] -> NameEnv TyCon
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyCon -> NameEnv TyCon -> NameEnv TyCon
add_tc NameEnv TyCon
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 = (TyCon -> NameEnv TyCon -> NameEnv TyCon)
-> NameEnv TyCon -> [TyCon] -> NameEnv TyCon
forall a b. (a -> b -> b) -> b -> [a] -> b
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 TyCon -> [TyCon] -> [TyCon]
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 = NameEnv TyCon -> Name -> TyCon -> NameEnv TyCon
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 NameEnv TyCon -> Name -> Maybe TyCon
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv TyCon
rec_tc_env Name
name of
Just TyCon
tc -> TyCon
tc
Maybe TyCon
other -> String -> SDoc -> TyCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"zipRecTyClss" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe TyCon
other)
kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([PolyTcTyCon], NameSet)
kcTyClGroup :: NameEnv Type -> [LTyClDecl GhcRn] -> TcM ([TyCon], NameSet)
kcTyClGroup NameEnv Type
kisig_env [LTyClDecl GhcRn]
decls
= do { mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; traceTc "---- kcTyClGroup ---- {"
(text "module" <+> ppr mod $$ vcat (map ppr decls))
; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds
; let (kindless_decls, kinded_decls) = partitionWith get_kind decls
kindless_names = [Name] -> NameSet
mkNameSet ([Name] -> NameSet) -> [Name] -> NameSet
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> Name)
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> Name
GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> IdGhcP 'Renamed
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))
d = TyClDecl (GhcPass p) -> IdP (GhcPass p)
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName (GenLocated l (TyClDecl (GhcPass p)) -> TyClDecl (GhcPass p)
forall l e. GenLocated l e -> e
unLoc GenLocated l (TyClDecl (GhcPass p))
d)
get_kind GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d
| Just Type
ki <- NameEnv Type -> Name -> Maybe Type
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv Type
kisig_env (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> IdGhcP 'Renamed
forall {p :: Pass} {l}.
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
GenLocated l (TyClDecl (GhcPass p)) -> IdGhcP p
get_name GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d)
= (GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
-> Either
(GenLocated SrcSpanAnnA (TyClDecl GhcRn))
(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
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 (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d)
= (GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
-> Either
(GenLocated SrcSpanAnnA (TyClDecl GhcRn))
(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
forall a b. b -> Either a b
Right (GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d, SAKS_or_CUSK
CUSK)
| Bool
otherwise = GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> Either
(GenLocated SrcSpanAnnA (TyClDecl GhcRn))
(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
forall a b. a -> Either a b
Left GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d
; checked_tcs <- checkNoErrs $
checkInitialKinds kinded_decls
; inferred_tcs
<- tcExtendKindEnvWithTyCons checked_tcs $
pushLevelAndSolveEqualities unkSkolAnon [] $
do {
mono_tcs <- inferInitialKinds kindless_decls
; traceTc "kcTyClGroup: initial kinds" $
ppr_tc_kinds mono_tcs
; checkNoErrs $
tcExtendKindEnvWithTyCons mono_tcs $
mapM_ kcLTyClDecl kindless_decls
; return mono_tcs }
; let inferred_tc_env = [(Name, TyCon)] -> NameEnv TyCon
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ([(Name, TyCon)] -> NameEnv TyCon)
-> [(Name, TyCon)] -> NameEnv TyCon
forall a b. (a -> b) -> a -> b
$
(TyCon -> (Name, TyCon)) -> [TyCon] -> [(Name, TyCon)]
forall a b. (a -> b) -> [a] -> [b]
map (\TyCon
tc -> (TyCon -> Name
tyConName TyCon
tc, TyCon
tc)) [TyCon]
inferred_tcs
; generalized_tcs <- concatMapM (generaliseTyClDecl inferred_tc_env)
kindless_decls
; let poly_tcs = [TyCon]
checked_tcs [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ [TyCon]
generalized_tcs
; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs)
; return (poly_tcs, kindless_names) }
where
ppr_tc_kinds :: [TyCon] -> SDoc
ppr_tc_kinds [TyCon]
tcs = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((TyCon -> SDoc) -> [TyCon] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map TyCon -> SDoc
pp_tc [TyCon]
tcs)
pp_tc :: TyCon -> SDoc
pp_tc TyCon
tc = Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Name
tyConName TyCon
tc) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConKind TyCon
tc)
type ScopedPairs = [(Name, TcTyVar)]
generaliseTyClDecl :: NameEnv MonoTcTyCon -> LTyClDecl GhcRn -> TcM [PolyTcTyCon]
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
; tc_infos <- ZonkM [(TyCon, SkolemInfo, [(Name, Var)], Type)]
-> TcM [(TyCon, SkolemInfo, [(Name, Var)], Type)]
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM [(TyCon, SkolemInfo, [(Name, Var)], Type)]
-> TcM [(TyCon, SkolemInfo, [(Name, Var)], Type)])
-> ZonkM [(TyCon, SkolemInfo, [(Name, Var)], Type)]
-> TcM [(TyCon, SkolemInfo, [(Name, Var)], Type)]
forall a b. (a -> b) -> a -> b
$
do {
; tc_with_tvs <- (Name -> ZonkM (TyCon, SkolemInfo, [(Name, Var)]))
-> [Name] -> ZonkM [(TyCon, SkolemInfo, [(Name, Var)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> ZonkM (TyCon, SkolemInfo, [(Name, Var)])
skolemise_tc_tycon [Name]
names_in_this_decl
; mapM zonk_tc_tycon tc_with_tvs }
; swizzled_infos <- tcAddDeclCtxt decl (swizzleTcTyConBndrs tc_infos)
; mapAndReportM generaliseTcTyCon swizzled_infos }
where
tycld_names :: TyClDecl GhcRn -> [Name]
tycld_names :: TyClDecl GhcRn -> [Name]
tycld_names TyClDecl GhcRn
decl = TyClDecl GhcRn -> IdP GhcRn
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
decl Name -> [Name] -> [Name]
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 }) = (GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> Name)
-> [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (FamilyDecl GhcRn -> IdP GhcRn
FamilyDecl GhcRn -> Name
forall (p :: Pass). FamilyDecl (GhcPass p) -> IdP (GhcPass p)
familyDeclName (FamilyDecl GhcRn -> Name)
-> (GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> FamilyDecl GhcRn)
-> GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> FamilyDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) [LFamilyDecl GhcRn]
[GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
ats
at_names TyClDecl GhcRn
_ = []
skolemise_tc_tycon :: Name -> ZonkM (TcTyCon, SkolemInfo, ScopedPairs)
skolemise_tc_tycon :: Name -> ZonkM (TyCon, SkolemInfo, [(Name, Var)])
skolemise_tc_tycon Name
tc_name
= do { let tc :: TyCon
tc = NameEnv TyCon -> Name -> TyCon
forall a. NameEnv a -> Name -> a
lookupNameEnv_NF NameEnv TyCon
inferred_tc_env Name
tc_name
; skol_info <- SkolemInfoAnon -> ZonkM SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (TyConFlavour TyCon -> Name -> SkolemInfoAnon
TyConSkol (TyCon -> TyConFlavour TyCon
tyConFlavour TyCon
tc) Name
tc_name )
; scoped_prs <- mapSndM (zonkAndSkolemise skol_info) (tcTyConScopedTyVars tc)
; return (tc, skol_info, scoped_prs) }
zonk_tc_tycon :: (TcTyCon, SkolemInfo, ScopedPairs)
-> ZonkM (TcTyCon, SkolemInfo, ScopedPairs, TcKind)
zonk_tc_tycon :: (TyCon, SkolemInfo, [(Name, Var)])
-> ZonkM (TyCon, SkolemInfo, [(Name, Var)], Type)
zonk_tc_tycon (TyCon
tc, SkolemInfo
skol_info, [(Name, Var)]
scoped_prs)
= do { scoped_prs <- (Var -> ZonkM Var) -> [(Name, Var)] -> ZonkM [(Name, Var)]
forall (m :: * -> *) (f :: * -> *) b c a.
(Applicative m, Traversable f) =>
(b -> m c) -> f (a, b) -> m (f (a, c))
mapSndM HasDebugCallStack => Var -> ZonkM Var
Var -> ZonkM Var
zonkTcTyVarToTcTyVar [(Name, Var)]
scoped_prs
; res_kind <- zonkTcType (tyConResKind tc)
; return (tc, skol_info, scoped_prs, res_kind) }
swizzleTcTyConBndrs :: [(TcTyCon, SkolemInfo, ScopedPairs, TcKind)]
-> TcM [(TcTyCon, SkolemInfo, ScopedPairs, TcKind)]
swizzleTcTyConBndrs :: [(TyCon, SkolemInfo, [(Name, Var)], Type)]
-> TcM [(TyCon, SkolemInfo, [(Name, Var)], Type)]
swizzleTcTyConBndrs [(TyCon, SkolemInfo, [(Name, Var)], Type)]
tc_infos
| ((Name, Var) -> Bool) -> [(Name, Var)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Name, Var) -> Bool
no_swizzle [(Name, Var)]
swizzle_prs
= do { String -> SDoc -> TcRn ()
traceTc String
"Skipping swizzleTcTyConBndrs for" ([(TyCon, SkolemInfo, [(Name, Var)], Type)] -> SDoc
forall {a} {b} {a} {d}.
Outputable a =>
[(a, b, [(a, Var)], d)] -> SDoc
ppr_infos [(TyCon, SkolemInfo, [(Name, Var)], Type)]
tc_infos)
; [(TyCon, SkolemInfo, [(Name, Var)], Type)]
-> TcM [(TyCon, SkolemInfo, [(Name, Var)], Type)]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [(TyCon, SkolemInfo, [(Name, Var)], Type)]
tc_infos }
| Bool
otherwise
= do { [(Name, Var)] -> TcRn ()
checkForDuplicateScopedTyVars [(Name, Var)]
swizzle_prs
; String -> SDoc -> TcRn ()
traceTc String
"swizzleTcTyConBndrs" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"before" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [(TyCon, SkolemInfo, [(Name, Var)], Type)] -> SDoc
forall {a} {b} {a} {d}.
Outputable a =>
[(a, b, [(a, Var)], d)] -> SDoc
ppr_infos [(TyCon, SkolemInfo, [(Name, Var)], Type)]
tc_infos
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"swizzle_prs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [(Name, Var)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, Var)]
swizzle_prs
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"after" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [(TyCon, SkolemInfo, [(Name, Var)], Type)] -> SDoc
forall {a} {b} {a} {d}.
Outputable a =>
[(a, b, [(a, Var)], d)] -> SDoc
ppr_infos [(TyCon, SkolemInfo, [(Name, Var)], Type)]
swizzled_infos ]
; [(TyCon, SkolemInfo, [(Name, Var)], Type)]
-> TcM [(TyCon, SkolemInfo, [(Name, Var)], Type)]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [(TyCon, SkolemInfo, [(Name, Var)], Type)]
swizzled_infos }
where
swizzled_infos :: [(TyCon, SkolemInfo, [(Name, Var)], Type)]
swizzled_infos = [ (TyCon
tc, SkolemInfo
skol_info, (Var -> Var) -> [(Name, Var)] -> [(Name, Var)]
forall (f :: * -> *) b c a.
Functor f =>
(b -> c) -> f (a, b) -> f (a, c)
mapSnd Var -> Var
swizzle_var [(Name, Var)]
scoped_prs, Type -> Type
swizzle_ty Type
kind)
| (TyCon
tc, SkolemInfo
skol_info, [(Name, Var)]
scoped_prs, Type
kind) <- [(TyCon, SkolemInfo, [(Name, Var)], Type)]
tc_infos ]
swizzle_prs :: [(Name,TyVar)]
swizzle_prs :: [(Name, Var)]
swizzle_prs = [ (Name, Var)
pr | (TyCon
_, SkolemInfo
_, [(Name, Var)]
prs, Type
_) <- [(TyCon, SkolemInfo, [(Name, Var)], Type)]
tc_infos, (Name, Var)
pr <- [(Name, Var)]
prs ]
no_swizzle :: (Name,TyVar) -> Bool
no_swizzle :: (Name, Var) -> Bool
no_swizzle (Name
nm, Var
tv) = Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Var -> Name
tyVarName Var
tv
ppr_infos :: [(a, b, [(a, Var)], d)] -> SDoc
ppr_infos [(a, b, [(a, Var)], d)]
infos = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
tc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Var] -> SDoc
pprTyVars (((a, Var) -> Var) -> [(a, Var)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (a, Var) -> Var
forall a b. (a, b) -> b
snd [(a, Var)]
prs)
| (a
tc, b
_, [(a, Var)]
prs, d
_) <- [(a, b, [(a, Var)], d)]
infos ]
swizzle_env :: VarEnv Name
swizzle_env = [(Var, Name)] -> VarEnv Name
forall a. [(Var, a)] -> VarEnv a
mkVarEnv (((Name, Var) -> (Var, Name)) -> [(Name, Var)] -> [(Var, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Var) -> (Var, Name)
forall a b. (a, b) -> (b, a)
swap [(Name, Var)]
swizzle_prs)
swizzleMapper :: TyCoMapper () Identity
swizzleMapper :: TyCoMapper () Identity
swizzleMapper = TyCoMapper { tcm_tyvar :: () -> Var -> Identity Type
tcm_tyvar = () -> Var -> Identity Type
forall {m :: * -> *} {p}. Monad m => p -> Var -> m Type
swizzle_tv
, tcm_covar :: () -> Var -> Identity Coercion
tcm_covar = () -> Var -> Identity Coercion
forall {m :: * -> *} {p}. Monad m => p -> Var -> m Coercion
swizzle_cv
, tcm_hole :: () -> CoercionHole -> Identity Coercion
tcm_hole = () -> CoercionHole -> Identity Coercion
forall {a} {p} {a}. Outputable a => p -> a -> a
swizzle_hole
, tcm_tycobinder :: forall r.
()
-> Var -> ForAllTyFlag -> (() -> Var -> Identity r) -> Identity r
tcm_tycobinder = ()
-> Var -> ForAllTyFlag -> (() -> Var -> Identity r) -> Identity r
forall r.
()
-> Var -> ForAllTyFlag -> (() -> Var -> Identity r) -> Identity r
swizzle_bndr
, tcm_tycon :: TyCon -> Identity TyCon
tcm_tycon = TyCon -> Identity TyCon
forall {a} {a}. Outputable a => a -> a
swizzle_tycon }
swizzle_hole :: p -> a -> a
swizzle_hole p
_ a
hole = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"swizzle_hole" (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
hole)
swizzle_tycon :: a -> a
swizzle_tycon a
tc = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"swizzle_tc" (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
tc)
swizzle_tv :: p -> Var -> m Type
swizzle_tv p
_ Var
tv = Type -> m Type
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> Type
mkTyVarTy (Var -> Var
swizzle_var Var
tv))
swizzle_cv :: p -> Var -> m Coercion
swizzle_cv p
_ Var
cv = Coercion -> m Coercion
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> Coercion
mkCoVarCo (Var -> Var
swizzle_var Var
cv))
swizzle_bndr :: ()
-> TyCoVar
-> ForAllTyFlag
-> (() -> TyCoVar -> Identity r)
-> Identity r
swizzle_bndr :: forall r.
()
-> Var -> ForAllTyFlag -> (() -> Var -> Identity r) -> Identity r
swizzle_bndr ()
_ Var
tcv ForAllTyFlag
_ () -> Var -> Identity r
k
= () -> Var -> Identity r
k () (Var -> Var
swizzle_var Var
tcv)
swizzle_var :: Var -> Var
swizzle_var :: Var -> Var
swizzle_var Var
v
| Just Name
nm <- VarEnv Name -> Var -> Maybe Name
forall a. VarEnv a -> Var -> Maybe a
lookupVarEnv VarEnv Name
swizzle_env Var
v
= (Type -> Type) -> Var -> Var
updateVarType Type -> Type
swizzle_ty (Var
v Var -> Name -> Var
`setVarName` Name
nm)
| Bool
otherwise
= (Type -> Type) -> Var -> Var
updateVarType Type -> Type
swizzle_ty Var
v
(Type -> Identity Type
map_type, ThetaType -> Identity ThetaType
_, Coercion -> Identity Coercion
_, [Coercion] -> Identity [Coercion]
_) = TyCoMapper () Identity
-> (Type -> Identity Type, ThetaType -> Identity ThetaType,
Coercion -> Identity Coercion, [Coercion] -> Identity [Coercion])
forall (m :: * -> *).
Monad m =>
TyCoMapper () m
-> (Type -> m Type, ThetaType -> m ThetaType,
Coercion -> m Coercion, [Coercion] -> m [Coercion])
mapTyCo TyCoMapper () Identity
swizzleMapper
swizzle_ty :: Type -> Type
swizzle_ty Type
ty = Identity Type -> Type
forall a. Identity a -> a
runIdentity (Type -> Identity Type
map_type Type
ty)
generaliseTcTyCon :: (MonoTcTyCon, SkolemInfo, ScopedPairs, TcKind) -> TcM PolyTcTyCon
generaliseTcTyCon :: (TyCon, SkolemInfo, [(Name, Var)], Type) -> TcRn TyCon
generaliseTcTyCon (TyCon
tc, SkolemInfo
skol_info, [(Name, Var)]
scoped_prs, Type
tc_res_kind)
= SrcSpan -> TcRn TyCon -> TcRn TyCon
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (TyCon -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyCon
tc) (TcRn TyCon -> TcRn TyCon) -> TcRn TyCon -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$
TyCon -> TcRn TyCon -> TcRn TyCon
forall a. TyCon -> TcM a -> TcM a
addTyConCtxt TyCon
tc (TcRn TyCon -> TcRn TyCon) -> TcRn TyCon -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$
do {
; let spec_req_tvs :: [Var]
spec_req_tvs = ((Name, Var) -> Var) -> [(Name, Var)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Var) -> Var
forall a b. (a, b) -> b
snd [(Name, Var)]
scoped_prs
n_spec :: Int
n_spec = [Var] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Var]
spec_req_tvs Int -> Int -> Int
forall a. Num a => a -> a -> a
- TyCon -> Int
tyConArity TyCon
tc
([Var]
spec_tvs, [Var]
req_tvs) = Int -> [Var] -> ([Var], [Var])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n_spec [Var]
spec_req_tvs
sorted_spec_tvs :: [Var]
sorted_spec_tvs = [Var] -> [Var]
scopedSort [Var]
spec_tvs
; dvs1 <- ThetaType -> TcM CandidatesQTvs
candidateQTyVarsOfKinds (ThetaType -> TcM CandidatesQTvs)
-> ThetaType -> TcM CandidatesQTvs
forall a b. (a -> b) -> a -> b
$
(Type
tc_res_kind Type -> ThetaType -> ThetaType
forall a. a -> [a] -> [a]
: (Var -> Type) -> [Var] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map Var -> Type
tyVarKind [Var]
spec_req_tvs)
; let dvs2 = CandidatesQTvs
dvs1 CandidatesQTvs -> [Var] -> CandidatesQTvs
`delCandidates` [Var]
spec_req_tvs
; inferred <- quantifyTyVars skol_info DefaultNonStandardTyVars dvs2
; traceTc "generaliseTcTyCon: pre zonk"
(vcat [ text "tycon =" <+> ppr tc
, text "spec_req_tvs =" <+> pprTyVars spec_req_tvs
, text "tc_res_kind =" <+> ppr tc_res_kind
, text "dvs1 =" <+> ppr dvs1
, text "inferred =" <+> pprTyVars inferred ])
; (inferred, sorted_spec_tvs,req_tvs,tc_res_kind) <- liftZonkM $
do { inferred <- zonkTcTyVarsToTcTyVars inferred
; sorted_spec_tvs <- zonkTcTyVarsToTcTyVars sorted_spec_tvs
; req_tvs <- zonkTcTyVarsToTcTyVars req_tvs
; tc_res_kind <- zonkTcType tc_res_kind
; return (inferred, sorted_spec_tvs, req_tvs, tc_res_kind) }
; traceTc "generaliseTcTyCon: post zonk" $
vcat [ text "tycon =" <+> ppr tc
, text "inferred =" <+> pprTyVars inferred
, text "spec_req_tvs =" <+> pprTyVars spec_req_tvs
, text "sorted_spec_tvs =" <+> pprTyVars sorted_spec_tvs
, text "req_tvs =" <+> ppr req_tvs ]
; let dep_fv_set = CandidatesQTvs -> VarSet
candidateKindVars CandidatesQTvs
dvs1
inferred_tcbs = ForAllTyFlag -> [Var] -> [TyConBinder]
mkNamedTyConBinders ForAllTyFlag
Inferred [Var]
inferred
specified_tcbs = ForAllTyFlag -> [Var] -> [TyConBinder]
mkNamedTyConBinders ForAllTyFlag
Specified [Var]
sorted_spec_tvs
required_tcbs = (Var -> TyConBinder) -> [Var] -> [TyConBinder]
forall a b. (a -> b) -> [a] -> [b]
map (VarSet -> Var -> TyConBinder
mkRequiredTyConBinder VarSet
dep_fv_set) [Var]
req_tvs
all_tcbs = [[TyConBinder]] -> [TyConBinder]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [TyConBinder]
inferred_tcbs
, [TyConBinder]
specified_tcbs
, [TyConBinder]
required_tcbs ]
flav = TyCon -> TyConFlavour TyCon
tyConFlavour TyCon
tc
; (eta_tcbs, tc_res_kind) <- etaExpandAlgTyCon flav skol_info all_tcbs tc_res_kind
; let final_tcbs = [TyConBinder]
all_tcbs [TyConBinder] -> [TyConBinder] -> [TyConBinder]
forall a. [a] -> [a] -> [a]
`chkAppend` [TyConBinder]
eta_tcbs
tycon = Name
-> [TyConBinder]
-> Type
-> [(Name, Var)]
-> Bool
-> TyConFlavour TyCon
-> TyCon
mkTcTyCon (TyCon -> Name
tyConName TyCon
tc)
[TyConBinder]
final_tcbs Type
tc_res_kind
([Var] -> [(Name, Var)]
mkTyVarNamePairs ([Var]
sorted_spec_tvs [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
req_tvs))
Bool
True
TyConFlavour TyCon
flav
; traceTc "generaliseTcTyCon done" $
vcat [ text "tycon =" <+> ppr tc
, text "tc_res_kind =" <+> ppr tc_res_kind
, text "dep_fv_set =" <+> ppr dep_fv_set
, text "inferred_tcbs =" <+> ppr inferred_tcbs
, text "specified_tcbs =" <+> ppr specified_tcbs
, text "required_tcbs =" <+> ppr required_tcbs
, text "final_tcbs =" <+> ppr final_tcbs ]
; checkTyConTelescope tycon
; return tycon }
tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a
tcExtendKindEnvWithTyCons :: forall r. [TyCon] -> TcM r -> TcM r
tcExtendKindEnvWithTyCons [TyCon]
tcs
= [(Name, TcTyThing)] -> TcM a -> TcM a
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] -> NameEnv TcTyThing
mkPromotionErrorEnv [LTyClDecl GhcRn]
decls
= (GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> NameEnv TcTyThing -> NameEnv TcTyThing)
-> NameEnv TcTyThing
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
-> NameEnv TcTyThing
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NameEnv TcTyThing -> NameEnv TcTyThing -> NameEnv TcTyThing
forall a. NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv (NameEnv TcTyThing -> NameEnv TcTyThing -> NameEnv TcTyThing)
-> (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> NameEnv TcTyThing)
-> GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> NameEnv TcTyThing
-> NameEnv TcTyThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyClDecl GhcRn -> NameEnv TcTyThing
mk_prom_err_env (TyClDecl GhcRn -> NameEnv TcTyThing)
-> (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn)
-> GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> NameEnv TcTyThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn
forall l e. GenLocated l e -> e
unLoc)
NameEnv TcTyThing
forall a. NameEnv a
emptyNameEnv [LTyClDecl GhcRn]
[GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
decls
mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv
mk_prom_err_env :: TyClDecl GhcRn -> NameEnv TcTyThing
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 })
= Name -> TcTyThing -> NameEnv TcTyThing
forall a. Name -> a -> NameEnv a
unitNameEnv Name
nm (PromotionErr -> TcTyThing
APromotionErr PromotionErr
ClassPE)
NameEnv TcTyThing -> NameEnv TcTyThing -> NameEnv TcTyThing
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv`
[(Name, TcTyThing)] -> NameEnv TcTyThing
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (FamilyDecl GhcRn -> IdP GhcRn
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]
[GenLocated SrcSpanAnnA (FamilyDecl 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 -> DataDefnCons (LConDecl pass)
dd_cons = DataDefnCons (LConDecl GhcRn)
cons } })
= Name -> TcTyThing -> NameEnv TcTyThing
forall a. Name -> a -> NameEnv a
unitNameEnv Name
name (PromotionErr -> TcTyThing
APromotionErr PromotionErr
TyConPE)
NameEnv TcTyThing -> NameEnv TcTyThing -> NameEnv TcTyThing
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv`
[(Name, TcTyThing)] -> NameEnv TcTyThing
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (Name
con, PromotionErr -> TcTyThing
APromotionErr PromotionErr
conPE)
| L SrcSpanAnnA
_ ConDecl GhcRn
con' <- DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
-> [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
forall a. DataDefnCons a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList DataDefnCons (LConDecl GhcRn)
DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
cons
, L SrcSpanAnnN
_ Name
con <- ConDecl GhcRn -> [LocatedN Name]
getConNames ConDecl GhcRn
con' ]
where
conPE :: PromotionErr
conPE
| DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)) -> Bool
forall a. DataDefnCons a -> Bool
isTypeDataDefnCons DataDefnCons (LConDecl GhcRn)
DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
cons = PromotionErr
TyConPE
| Bool
otherwise = PromotionErr
RecDataConPE
mk_prom_err_env TyClDecl GhcRn
decl
= Name -> TcTyThing -> NameEnv TcTyThing
forall a. Name -> a -> NameEnv a
unitNameEnv (TyClDecl GhcRn -> IdP GhcRn
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 [MonoTcTyCon]
inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TyCon]
inferInitialKinds [LTyClDecl GhcRn]
decls
= do { String -> SDoc -> TcRn ()
traceTc String
"inferInitialKinds {" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [IdGhcP 'Renamed] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> IdGhcP 'Renamed)
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)] -> [IdGhcP 'Renamed]
forall a b. (a -> b) -> [a] -> [b]
map (TyClDecl GhcRn -> IdP GhcRn
TyClDecl GhcRn -> IdGhcP 'Renamed
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName (TyClDecl GhcRn -> IdGhcP 'Renamed)
-> (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn)
-> GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> IdGhcP 'Renamed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) [LTyClDecl GhcRn]
[GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
decls)
; tcs <- (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TcM [TyCon])
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)] -> TcM [TyCon]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TcM [TyCon]
infer_initial_kind [LTyClDecl GhcRn]
[GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
decls
; traceTc "inferInitialKinds done }" empty
; return tcs }
where
infer_initial_kind :: GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TcM [TyCon]
infer_initial_kind = (TyClDecl GhcRn -> TcM [TyCon])
-> GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TcM [TyCon]
forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM (InitialKindStrategy -> TyClDecl GhcRn -> TcM [TyCon]
getInitialKind InitialKindStrategy
InitialKindInfer)
checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [PolyTcTyCon]
checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TyCon]
checkInitialKinds [(LTyClDecl GhcRn, SAKS_or_CUSK)]
decls
= do { String -> SDoc -> TcRn ()
traceTc String
"checkInitialKinds {" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [(IdGhcP 'Renamed, SAKS_or_CUSK)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> IdGhcP 'Renamed)
-> [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)]
-> [(IdGhcP 'Renamed, SAKS_or_CUSK)]
forall (f :: * -> *) a c b.
Functor f =>
(a -> c) -> f (a, b) -> f (c, b)
mapFst (TyClDecl GhcRn -> IdP GhcRn
TyClDecl GhcRn -> IdGhcP 'Renamed
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName (TyClDecl GhcRn -> IdGhcP 'Renamed)
-> (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn)
-> GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> IdGhcP 'Renamed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) [(LTyClDecl GhcRn, SAKS_or_CUSK)]
[(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)]
decls)
; tcs <- ((GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
-> TcM [TyCon])
-> [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)]
-> TcM [TyCon]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM (GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
-> TcM [TyCon]
forall {t}.
HasLoc t =>
(GenLocated t (TyClDecl GhcRn), SAKS_or_CUSK) -> TcM [TyCon]
check_initial_kind [(LTyClDecl GhcRn, SAKS_or_CUSK)]
[(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)]
decls
; traceTc "checkInitialKinds done }" empty
; return tcs }
where
check_initial_kind :: (GenLocated t (TyClDecl GhcRn), SAKS_or_CUSK) -> TcM [TyCon]
check_initial_kind (GenLocated t (TyClDecl GhcRn)
ldecl, SAKS_or_CUSK
msig) =
(TyClDecl GhcRn -> TcM [TyCon])
-> GenLocated t (TyClDecl GhcRn) -> TcM [TyCon]
forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM (InitialKindStrategy -> TyClDecl GhcRn -> TcM [TyCon]
getInitialKind (SAKS_or_CUSK -> InitialKindStrategy
InitialKindCheck SAKS_or_CUSK
msig)) GenLocated t (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 { cls_tc <- InitialKindStrategy
-> Name
-> TyConFlavour TyCon
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcRn TyCon
kcDeclHeader InitialKindStrategy
strategy Name
name TyConFlavour TyCon
forall tc. TyConFlavour tc
ClassFlavour LHsQTyVars GhcRn
ktvs (TcM ContextKind -> TcRn TyCon) -> TcM ContextKind -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$
ContextKind -> TcM ContextKind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> ContextKind
TheKind Type
constraintKind)
; at_tcs <- tcExtendTyVarEnv (tyConTyVars cls_tc) $
mapM (addLocM (getAssocFamInitialKind cls_tc)) ats
; return (cls_tc : at_tcs) }
where
getAssocFamInitialKind :: TyCon -> FamilyDecl GhcRn -> TcRn TyCon
getAssocFamInitialKind TyCon
cls =
case InitialKindStrategy
strategy of
InitialKindStrategy
InitialKindInfer -> Maybe TyCon -> FamilyDecl GhcRn -> TcRn TyCon
get_fam_decl_initial_kind (TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
cls)
InitialKindCheck SAKS_or_CUSK
_ -> TyCon -> FamilyDecl GhcRn -> TcRn 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_cons :: forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_cons = DataDefnCons (LConDecl GhcRn)
cons } })
= do { let flav :: TyConFlavour TyCon
flav = NewOrData -> TyConFlavour TyCon
forall tc. NewOrData -> TyConFlavour tc
newOrDataToFlavour (DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)) -> NewOrData
forall a. DataDefnCons a -> NewOrData
dataDefnConsNewOrData DataDefnCons (LConDecl GhcRn)
DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
cons)
ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
DataKindCtxt Name
name
; tc <- InitialKindStrategy
-> Name
-> TyConFlavour TyCon
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcRn TyCon
kcDeclHeader InitialKindStrategy
strategy Name
name TyConFlavour TyCon
flav LHsQTyVars GhcRn
ktvs (TcM ContextKind -> TcRn TyCon) -> TcM ContextKind -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$
case Maybe (LHsKind GhcRn)
m_sig of
Just LHsKind GhcRn
ksig -> Type -> ContextKind
TheKind (Type -> ContextKind)
-> IOEnv (Env TcGblEnv TcLclEnv) Type -> TcM ContextKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserTypeCtxt -> LHsKind GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Type
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
ksig
Maybe (LHsKind GhcRn)
Nothing -> ContextKind -> TcM ContextKind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ContextKind -> TcM ContextKind) -> ContextKind -> TcM ContextKind
forall a b. (a -> b) -> a -> b
$ InitialKindStrategy -> NewOrData -> ContextKind
dataDeclDefaultResultKind InitialKindStrategy
strategy (DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)) -> NewOrData
forall a. DataDefnCons a -> NewOrData
dataDefnConsNewOrData DataDefnCons (LConDecl GhcRn)
DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
cons)
; return [tc] }
getInitialKind InitialKindStrategy
InitialKindInfer (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl GhcRn
decl })
= do { tc <- Maybe TyCon -> FamilyDecl GhcRn -> TcRn TyCon
get_fam_decl_initial_kind Maybe TyCon
forall a. Maybe a
Nothing FamilyDecl GhcRn
decl
; return [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 = LIdP GhcRn -> Name
LocatedN Name -> Name
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 = LFamilyResultSig GhcRn -> FamilyResultSig GhcRn
GenLocated EpAnnCO (FamilyResultSig GhcRn) -> FamilyResultSig GhcRn
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 TyCon
flav = Maybe TyCon -> FamilyInfo GhcRn -> TyConFlavour TyCon
forall tc pass. Maybe tc -> FamilyInfo pass -> TyConFlavour tc
familyInfoTyConFlavour Maybe TyCon
forall a. Maybe a
Nothing FamilyInfo GhcRn
info
ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
TyFamResKindCtxt Name
name
; tc <- InitialKindStrategy
-> Name
-> TyConFlavour TyCon
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcRn TyCon
kcDeclHeader (SAKS_or_CUSK -> InitialKindStrategy
InitialKindCheck SAKS_or_CUSK
msig) Name
name TyConFlavour TyCon
flav LHsQTyVars GhcRn
ktvs (TcM ContextKind -> TcRn TyCon) -> TcM ContextKind -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$
case FamilyResultSig GhcRn -> Maybe (LHsKind GhcRn)
forall (p :: Pass).
FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p))
famResultKindSignature FamilyResultSig GhcRn
resultSig of
Just LHsKind GhcRn
ksig -> Type -> ContextKind
TheKind (Type -> ContextKind)
-> IOEnv (Env TcGblEnv TcLclEnv) Type -> TcM ContextKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserTypeCtxt -> LHsKind GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Type
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
ksig
Maybe (LHsKind GhcRn)
Nothing ->
case SAKS_or_CUSK
msig of
SAKS_or_CUSK
CUSK -> ContextKind -> TcM ContextKind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> ContextKind
TheKind Type
liftedTypeKind)
SAKS Type
_ -> ContextKind -> TcM ContextKind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ContextKind
AnyKind
; return [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
; tc <- InitialKindStrategy
-> Name
-> TyConFlavour TyCon
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcRn TyCon
kcDeclHeader InitialKindStrategy
strategy Name
name TyConFlavour TyCon
forall tc. TyConFlavour tc
TypeSynonymFlavour LHsQTyVars GhcRn
ktvs (TcM ContextKind -> TcRn TyCon) -> TcM ContextKind -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$
case LHsKind GhcRn -> Maybe (LHsKind GhcRn)
forall (p :: Pass).
LHsType (GhcPass p) -> Maybe (LHsType (GhcPass p))
hsTyKindSig LHsKind GhcRn
rhs of
Just LHsKind GhcRn
rhs_sig -> Type -> ContextKind
TheKind (Type -> ContextKind)
-> IOEnv (Env TcGblEnv TcLclEnv) Type -> TcM ContextKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserTypeCtxt -> LHsKind GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Type
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
rhs_sig
Maybe (LHsKind GhcRn)
Nothing -> ContextKind -> TcM ContextKind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ContextKind
AnyKind
; return [tc] }
get_fam_decl_initial_kind
:: Maybe TcTyCon
-> FamilyDecl GhcRn
-> TcM TcTyCon
get_fam_decl_initial_kind :: Maybe TyCon -> FamilyDecl GhcRn -> TcRn 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 EpAnnCO
_ FamilyResultSig GhcRn
resultSig
, fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcRn
info }
= InitialKindStrategy
-> Name
-> TyConFlavour TyCon
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcRn TyCon
kcDeclHeader InitialKindStrategy
InitialKindInfer Name
name TyConFlavour TyCon
flav LHsQTyVars GhcRn
ktvs (TcM ContextKind -> TcRn TyCon) -> TcM ContextKind -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$
case FamilyResultSig GhcRn
resultSig of
KindSig XCKindSig GhcRn
_ LHsKind GhcRn
ki -> Type -> ContextKind
TheKind (Type -> ContextKind)
-> IOEnv (Env TcGblEnv TcLclEnv) Type -> TcM ContextKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserTypeCtxt -> LHsKind GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Type
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
ki
TyVarSig XTyVarSig GhcRn
_ (L SrcSpanAnnA
_ HsTyVarBndr () GhcRn
tvb) | HsTvb { tvb_kind :: forall flag pass. HsTyVarBndr flag pass -> HsBndrKind pass
tvb_kind = HsBndrKind XBndrKind GhcRn
_ LHsKind GhcRn
ki } <- HsTyVarBndr () GhcRn
tvb
-> Type -> ContextKind
TheKind (Type -> ContextKind)
-> IOEnv (Env TcGblEnv TcLclEnv) Type -> TcM ContextKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserTypeCtxt -> LHsKind GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Type
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
ki
FamilyResultSig GhcRn
_
| TyConFlavour TyCon -> Bool
forall tc. TyConFlavour tc -> Bool
tcFlavourIsOpen TyConFlavour TyCon
flav -> ContextKind -> TcM ContextKind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> ContextKind
TheKind Type
liftedTypeKind)
| Bool
otherwise -> ContextKind -> TcM ContextKind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ContextKind
AnyKind
where
flav :: TyConFlavour TyCon
flav = Maybe TyCon -> FamilyInfo GhcRn -> TyConFlavour TyCon
forall tc pass. Maybe tc -> FamilyInfo pass -> TyConFlavour tc
familyInfoTyConFlavour 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 -> TcRn TyCon
check_initial_kind_assoc_fam TyCon
cls
FamilyDecl
{ fdLName :: forall pass. FamilyDecl pass -> LIdP pass
fdLName = LIdP GhcRn -> Name
LocatedN Name -> Name
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 = LFamilyResultSig GhcRn -> FamilyResultSig GhcRn
GenLocated EpAnnCO (FamilyResultSig GhcRn) -> FamilyResultSig GhcRn
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 TyCon
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcRn TyCon
kcDeclHeader (SAKS_or_CUSK -> InitialKindStrategy
InitialKindCheck SAKS_or_CUSK
CUSK) Name
name TyConFlavour TyCon
flav LHsQTyVars GhcRn
ktvs (TcM ContextKind -> TcRn TyCon) -> TcM ContextKind -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$
case FamilyResultSig GhcRn -> Maybe (LHsKind GhcRn)
forall (p :: Pass).
FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p))
famResultKindSignature FamilyResultSig GhcRn
resultSig of
Just LHsKind GhcRn
ksig -> Type -> ContextKind
TheKind (Type -> ContextKind)
-> IOEnv (Env TcGblEnv TcLclEnv) Type -> TcM ContextKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserTypeCtxt -> LHsKind GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Type
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
ksig
Maybe (LHsKind GhcRn)
Nothing -> ContextKind -> TcM ContextKind
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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 TyCon
flav = Maybe TyCon -> FamilyInfo GhcRn -> TyConFlavour TyCon
forall tc pass. Maybe tc -> FamilyInfo pass -> TyConFlavour tc
familyInfoTyConFlavour (TyCon -> Maybe TyCon
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
kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()
kcLTyClDecl :: LTyClDecl GhcRn -> TcRn ()
kcLTyClDecl (L SrcSpanAnnA
loc TyClDecl GhcRn
decl)
= SrcSpanAnnA -> TcRn () -> TcRn ()
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do { tycon <- HasDebugCallStack => Name -> TcRn TyCon
Name -> TcRn TyCon
tcLookupTcTyCon IdP GhcRn
Name
tc_name
; traceTc "kcTyClDecl {" (ppr tc_name)
; addVDQNote tycon $
addErrCtxt (tcMkDeclCtxt decl) $
kcTyClDecl decl tycon
; traceTc "kcTyClDecl done }" (ppr tc_name) }
where
tc_name :: IdP GhcRn
tc_name = TyClDecl GhcRn -> IdP GhcRn
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
decl
kcTyClDecl :: TyClDecl GhcRn -> MonoTcTyCon -> 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 { dd_ctxt :: forall pass. HsDataDefn pass -> Maybe (LHsContext pass)
dd_ctxt = Maybe (LHsContext GhcRn)
ctxt, dd_cons :: forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_cons = DataDefnCons (LConDecl GhcRn)
cons } }) TyCon
tycon
= [(Name, Var)] -> TcRn () -> TcRn ()
forall r. [(Name, Var)] -> TcM r -> TcM r
tcExtendNameTyVarEnv (TyCon -> [(Name, Var)]
tcTyConScopedTyVars TyCon
tycon) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"kcTyClDecl" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tycon SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [Var]
tyConTyVars TyCon
tycon) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConResKind TyCon
tycon))
; _ <- Maybe (LHsContext GhcRn) -> TcM ThetaType
tcHsContext Maybe (LHsContext GhcRn)
ctxt
; kcConDecls (dataDefnConsNewOrData cons) (tyConResKind tycon) 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
= [(Name, Var)] -> TcRn () -> TcRn ()
forall r. [(Name, Var)] -> TcM r -> TcM r
tcExtendNameTyVarEnv (TyCon -> [(Name, Var)]
tcTyConScopedTyVars TyCon
tycon) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
let res_kind :: Type
res_kind = TyCon -> Type
tyConResKind TyCon
tycon
in IOEnv (Env TcGblEnv TcLclEnv) Type -> TcRn ()
forall a. TcM a -> TcRn ()
discardResult (IOEnv (Env TcGblEnv TcLclEnv) Type -> TcRn ())
-> IOEnv (Env TcGblEnv TcLclEnv) Type -> TcRn ()
forall a b. (a -> b) -> a -> b
$ LHsKind GhcRn -> ContextKind -> IOEnv (Env TcGblEnv TcLclEnv) Type
tcCheckLHsTypeInContext 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
= [(Name, Var)] -> TcRn () -> TcRn ()
forall r. [(Name, Var)] -> TcM r -> TcM r
tcExtendNameTyVarEnv (TyCon -> [(Name, Var)]
tcTyConScopedTyVars TyCon
tycon) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do { _ <- Maybe (LHsContext GhcRn) -> TcM ThetaType
tcHsContext Maybe (LHsContext GhcRn)
ctxt
; mapM_ (wrapLocMA_ kc_sig) sigs }
where
kc_sig :: Sig GhcRn -> TcRn ()
kc_sig (ClassOpSig XClassOpSig GhcRn
_ Bool
_ [LIdP GhcRn]
nms LHsSigType GhcRn
op_ty) = [LocatedN Name] -> LHsSigType GhcRn -> TcRn ()
kcClassSigType [LIdP GhcRn]
[LocatedN Name]
nms LHsSigType GhcRn
op_ty
kc_sig Sig GhcRn
_ = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
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) -> (GenLocated
SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> TcRn ())
-> [GenLocated
SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
-> TcRn ()
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]
[GenLocated
SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
eqns
FamilyInfo GhcRn
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
kcConArgTys :: NewOrData -> TcKind -> [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
; [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
-> (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) Type)
-> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [HsScaled GhcRn (LHsKind GhcRn)]
[HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
arg_tys (\(HsScaled HsArrow GhcRn
mult GenLocated SrcSpanAnnA (HsType GhcRn)
ty) -> do _ <- LHsKind GhcRn -> ContextKind -> IOEnv (Env TcGblEnv TcLclEnv) Type
tcCheckLHsTypeInContext (LHsKind GhcRn -> LHsKind GhcRn
forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p)
getBangType LHsKind GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty) ContextKind
exp_kind
tcMult mult)
}
kcConH98Args :: NewOrData -> TcKind -> 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 ([HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ())
-> [HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ()
forall a b. (a -> b) -> a -> b
$
(GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> HsScaled GhcRn (LHsKind GhcRn))
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> [HsScaled GhcRn (LHsKind GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall (p :: Pass) a. IsPass p => a -> HsScaled (GhcPass p) a
hsLinear (GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConDeclField GhcRn -> LHsKind GhcRn
ConDeclField GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall pass. ConDeclField pass -> LBangType pass
cd_fld_type (ConDeclField GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDeclField GhcRn) -> ConDeclField GhcRn
forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
flds
kcConGADTArgs :: NewOrData -> TcKind -> 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 XPrefixConGADT GhcRn
_ [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 XRecConGADT GhcRn
_ (L SrcSpanAnnL
_ [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
flds) -> NewOrData -> Type -> [HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ()
kcConArgTys NewOrData
new_or_data Type
res_kind ([HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ())
-> [HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ()
forall a b. (a -> b) -> a -> b
$
(GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> HsScaled GhcRn (LHsKind GhcRn))
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> [HsScaled GhcRn (LHsKind GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall (p :: Pass) a. IsPass p => a -> HsScaled (GhcPass p) a
hsLinear (GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConDeclField GhcRn -> LHsKind GhcRn
ConDeclField GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall pass. ConDeclField pass -> LBangType pass
cd_fld_type (ConDeclField GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDeclField GhcRn) -> ConDeclField GhcRn
forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
flds
kcConDecls :: Foldable f
=> NewOrData
-> TcKind
-> f (LConDecl GhcRn)
-> TcM ()
kcConDecls :: forall (f :: * -> *).
Foldable f =>
NewOrData -> Type -> f (LConDecl GhcRn) -> TcRn ()
kcConDecls NewOrData
new_or_data Type
tc_res_kind = (GenLocated SrcSpanAnnA (ConDecl GhcRn) -> TcRn ())
-> f (GenLocated SrcSpanAnnA (ConDecl GhcRn)) -> TcRn ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((ConDecl GhcRn -> TcRn ())
-> GenLocated SrcSpanAnnA (ConDecl GhcRn) -> TcRn ()
forall a. (a -> TcRn ()) -> LocatedA a -> TcRn ()
wrapLocMA_ (NewOrData -> Type -> ConDecl GhcRn -> TcRn ()
kcConDecl NewOrData
new_or_data Type
tc_res_kind))
kcConDecl :: NewOrData
-> TcKind
-> 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 })
= SDoc -> TcRn () -> TcRn ()
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (NonEmpty (LocatedN Name) -> SDoc
dataConCtxt (LocatedN Name -> NonEmpty (LocatedN Name)
forall a. a -> NonEmpty a
NE.singleton LIdP GhcRn
LocatedN Name
name)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcM ([VarBndr Var Specificity], ()) -> TcRn ()
forall a. TcM a -> TcRn ()
discardResult (TcM ([VarBndr Var Specificity], ()) -> TcRn ())
-> TcM ([VarBndr Var Specificity], ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[LHsTyVarBndr Specificity GhcRn]
-> TcRn () -> TcM ([VarBndr Var Specificity], ())
forall flag a.
OutputableBndrFlag flag 'Renamed =>
[LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr Var flag], a)
bindExplicitTKBndrs_Tv [LHsTyVarBndr Specificity GhcRn]
ex_tvs (TcRn () -> TcM ([VarBndr Var Specificity], ()))
-> TcRn () -> TcM ([VarBndr Var Specificity], ())
forall a b. (a -> b) -> a -> b
$
do { _ <- Maybe (LHsContext GhcRn) -> TcM ThetaType
tcHsContext Maybe (LHsContext GhcRn)
ex_ctxt
; kcConH98Args new_or_data tc_res_kind args
}
kcConDecl NewOrData
new_or_data
Type
_tc_res_kind
(ConDeclGADT
{ con_names :: forall pass. ConDecl pass -> NonEmpty (LIdP pass)
con_names = NonEmpty (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 })
=
SDoc -> TcRn () -> TcRn ()
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (NonEmpty (LocatedN Name) -> SDoc
dataConCtxt NonEmpty (LIdP GhcRn)
NonEmpty (LocatedN Name)
names) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcM (HsOuterSigTyVarBndrs GhcTc, ()) -> TcRn ()
forall a. TcM a -> TcRn ()
discardResult (TcM (HsOuterSigTyVarBndrs GhcTc, ()) -> TcRn ())
-> TcM (HsOuterSigTyVarBndrs GhcTc, ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$
HsOuterSigTyVarBndrs GhcRn
-> TcRn () -> TcM (HsOuterSigTyVarBndrs GhcTc, ())
forall a.
HsOuterSigTyVarBndrs GhcRn
-> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)
bindOuterSigTKBndrs_Tv HsOuterSigTyVarBndrs GhcRn
outer_bndrs (TcRn () -> TcM (HsOuterSigTyVarBndrs GhcTc, ()))
-> TcRn () -> TcM (HsOuterSigTyVarBndrs GhcTc, ())
forall a b. (a -> b) -> a -> b
$
do { _ <- Maybe (LHsContext GhcRn) -> TcM ThetaType
tcHsContext Maybe (LHsContext GhcRn)
cxt
; traceTc "kcConDecl:GADT {" (ppr names $$ ppr res_ty)
; con_res_kind <- newOpenTypeKind
; _ <- tcCheckLHsTypeInContext res_ty (TheKind con_res_kind)
; kcConGADTArgs new_or_data con_res_kind args
; traceTc "kcConDecl:GADT }" (ppr names $$ ppr con_res_kind)
; return () }
tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
tcTyClDecl :: (Name -> [Role])
-> LTyClDecl GhcRn
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
tcTyClDecl Name -> [Role]
roles_info (L SrcSpanAnnA
loc TyClDecl GhcRn
decl)
| Just TyThing
thing <- Name -> Maybe TyThing
wiredInNameTyThing_maybe (TyClDecl GhcRn -> IdP GhcRn
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
decl)
= case TyThing
thing of
ATyCon TyCon
tc -> ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TyCon
tc, []), TyCon -> TyClDecl GhcRn -> [DerivInfo]
wiredInDerivInfo TyCon
tc TyClDecl GhcRn
decl)
TyThing
_ -> String
-> SDoc
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcTyClDecl" (TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
thing)
| Bool
otherwise
= SrcSpanAnnA
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall a b. (a -> b) -> a -> b
$ TyClDecl GhcRn
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall a. TyClDecl GhcRn -> TcM a -> TcM a
tcAddDeclCtxt TyClDecl GhcRn
decl (IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"---- tcTyClDecl ---- {" (TyClDecl GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyClDecl GhcRn
decl)
; (tc_vi@(tc, _), deriv_infos) <- Maybe Class
-> (Name -> [Role])
-> TyClDecl GhcRn
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
tcTyClDecl1 Maybe Class
forall a. Maybe a
Nothing Name -> [Role]
roles_info TyClDecl GhcRn
decl
; traceTc "---- tcTyClDecl end ---- }" (ppr tc)
; return (tc_vi, deriv_infos) }
noDerivInfos :: a -> (a, [DerivInfo])
noDerivInfos :: forall a. a -> (a, [DerivInfo])
noDerivInfos a
a = (a
a, [])
noEqnValidityInfos :: a -> (a, [TyFamEqnValidityInfo])
noEqnValidityInfos :: forall a. a -> (a, [TyFamEqnValidityInfo])
noEqnValidityInfos 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, Var)]
di_scoped_tvs =
if TyCon -> Bool
isPrimTyCon TyCon
tycon
then []
else [Var] -> [(Name, Var)]
mkTyVarNamePairs (TyCon -> [Var]
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, [TyFamEqnValidityInfo]), [DerivInfo])
tcTyClDecl1 :: Maybe Class
-> (Name -> [Role])
-> TyClDecl GhcRn
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
tcTyClDecl1 Maybe Class
parent Name -> [Role]
_roles_info (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl GhcRn
fd })
= ((TyCon, [TyFamEqnValidityInfo])
-> ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TyCon, [TyFamEqnValidityInfo])
-> ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall a. a -> (a, [DerivInfo])
noDerivInfos (IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall a b. (a -> b) -> a -> b
$
Maybe Class
-> FamilyDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo])
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 })
= Bool
-> ((TyCon -> ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]))
-> TcRn TyCon
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]))
-> (TyCon -> ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]))
-> TcRn TyCon
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall a. HasCallStack => Bool -> a -> a
assert (Maybe Class -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Class
_parent )
(TyCon -> ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]))
-> TcRn TyCon
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ( (TyCon, [TyFamEqnValidityInfo])
-> ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall a. a -> (a, [DerivInfo])
noDerivInfos ((TyCon, [TyFamEqnValidityInfo])
-> ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]))
-> (TyCon -> (TyCon, [TyFamEqnValidityInfo]))
-> TyCon
-> ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> (TyCon, [TyFamEqnValidityInfo])
forall a. a -> (a, [TyFamEqnValidityInfo])
noEqnValidityInfos ) (TcRn TyCon
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]))
-> TcRn TyCon
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall a b. (a -> b) -> a -> b
$
(Name -> [Role]) -> Name -> LHsKind GhcRn -> TcRn 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 })
= Bool
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall a. HasCallStack => Bool -> a -> a
assert (Maybe Class -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Class
_parent) (IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall a b. (a -> b) -> a -> b
$
((TyCon, [DerivInfo])
-> ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(TyCon
tc, [DerivInfo]
deriv_info) -> ((TyCon
tc, []), [DerivInfo]
deriv_info)) (IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall a b. (a -> b) -> a -> b
$
SDoc
-> (Name -> [Role])
-> Name
-> HsDataDefn GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (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 })
= Bool
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall a. HasCallStack => Bool -> a -> a
assert (Maybe Class -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Class
_parent) (IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
-> IOEnv
(Env TcGblEnv TcLclEnv)
((TyCon, [TyFamEqnValidityInfo]), [DerivInfo])
forall a b. (a -> b) -> a -> b
$
do { 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
; return (noDerivInfos $ noEqnValidityInfos (classTyCon 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
= (Class -> TcM Class) -> TcM Class
forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM ((Class -> TcM Class) -> TcM Class)
-> (Class -> TcM Class) -> TcM Class
forall a b. (a -> b) -> a -> b
$ \ Class
clas ->
Name -> ([TyConBinder] -> Type -> TcM Class) -> TcM Class
forall a. Name -> ([TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
class_name (([TyConBinder] -> Type -> TcM Class) -> TcM Class)
-> ([TyConBinder] -> Type -> TcM Class) -> TcM Class
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
tc_bndrs Type
res_kind ->
do { Type -> TcRn ()
checkClassKindSig Type
res_kind
; String -> SDoc -> TcRn ()
traceTc String
"tcClassDecl 1" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
class_name SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
tc_bndrs)
; let tycon_name :: Name
tycon_name = Name
class_name
roles :: [Role]
roles = Name -> [Role]
roles_info Name
tycon_name
; (ctxt, fds, sig_stuff, at_stuff)
<- SkolemInfoAnon
-> [TyConBinder]
-> TcM (ThetaType, [([Var], [Var])], [TcMethInfo], [ClassATItem])
-> TcM (ThetaType, [([Var], [Var])], [TcMethInfo], [ClassATItem])
forall a. SkolemInfoAnon -> [TyConBinder] -> TcM a -> TcM a
pushLevelAndSolveEqualities SkolemInfoAnon
skol_info [TyConBinder]
tc_bndrs (TcM (ThetaType, [([Var], [Var])], [TcMethInfo], [ClassATItem])
-> TcM (ThetaType, [([Var], [Var])], [TcMethInfo], [ClassATItem]))
-> TcM (ThetaType, [([Var], [Var])], [TcMethInfo], [ClassATItem])
-> TcM (ThetaType, [([Var], [Var])], [TcMethInfo], [ClassATItem])
forall a b. (a -> b) -> a -> b
$
do { ctxt <- Maybe (LHsContext GhcRn) -> TcM ThetaType
tcHsContext Maybe (LHsContext GhcRn)
hs_ctxt
; fds <- mapM (addLocM tc_fundep) fundeps
; sig_stuff <- tcClassSigs class_name sigs meths
; at_stuff <- tcClassATs class_name clas ats at_defs
; return (ctxt, fds, sig_stuff, at_stuff) }
; dvs <- candidateQTyVarsOfTypes ctxt
; let err_ctx TidyEnv
tidy_env = do { (tidy_env2, ctxt) <- TidyEnv -> ThetaType -> ZonkM (TidyEnv, ThetaType)
zonkTidyTcTypes TidyEnv
tidy_env ThetaType
ctxt
; return (tidy_env2, UninfTyCtx_ClassContext ctxt) }
; doNotQuantifyTyVars dvs err_ctx
; (bndrs, ctxt, sig_stuff) <- initZonkEnv NoFlexi $
runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ [TyConBinder]
bndrs ->
do { ctxt <- ThetaType -> ZonkTcM ThetaType
zonkTcTypesToTypesX ThetaType
ctxt
; sig_stuff <- mapM zonkTcMethInfoToMethInfoX sig_stuff
; return (bndrs, ctxt, sig_stuff) }
; mindef <- tcClassMinimalDef class_name sigs sig_stuff
; is_boot <- tcIsHsBootOrSig
; let body | Bool
is_boot, Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
-> Bool
forall a. Maybe a -> Bool
isNothing Maybe (LHsContext GhcRn)
Maybe
(GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)])
hs_ctxt, [ClassATItem] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClassATItem]
at_stuff, [TcMethInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcMethInfo]
sig_stuff
= Maybe (ThetaType, [ClassATItem], [TcMethInfo], ClassMinimalDef)
forall a. Maybe a
Nothing
| Bool
otherwise
= (ThetaType, [ClassATItem], [TcMethInfo], ClassMinimalDef)
-> Maybe (ThetaType, [ClassATItem], [TcMethInfo], ClassMinimalDef)
forall a. a -> Maybe a
Just (ThetaType
ctxt, [ClassATItem]
at_stuff, [TcMethInfo]
sig_stuff, ClassMinimalDef
mindef)
; clas <- buildClass class_name bndrs roles fds body
; traceTc "tcClassDecl" (ppr fundeps $$ ppr bndrs $$
ppr fds)
; return clas }
where
skol_info :: SkolemInfoAnon
skol_info = TyConFlavour TyCon -> Name -> SkolemInfoAnon
TyConSkol TyConFlavour TyCon
forall tc. TyConFlavour tc
ClassFlavour Name
class_name
tc_fundep :: GHC.Hs.FunDep GhcRn -> TcM ([Var],[Var])
tc_fundep :: FunDep GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) ([Var], [Var])
tc_fundep (FunDep XCFunDep GhcRn
_ [LIdP GhcRn]
tvs1 [LIdP GhcRn]
tvs2)
= do { tvs1' <- (LocatedN Name -> IOEnv (Env TcGblEnv TcLclEnv) Var)
-> [LocatedN Name] -> TcM [Var]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name -> IOEnv (Env TcGblEnv TcLclEnv) Var
tcLookupTyVar (Name -> IOEnv (Env TcGblEnv TcLclEnv) Var)
-> (LocatedN Name -> Name)
-> LocatedN Name
-> IOEnv (Env TcGblEnv TcLclEnv) Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc) [LIdP GhcRn]
[LocatedN Name]
tvs1 ;
; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ;
; return (tvs1',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 {
[IOEnv (Env TcGblEnv TcLclEnv) (ZonkAny 0)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) (ZonkAny 0)
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) (ZonkAny 0))
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) (ZonkAny 0)
forall a b. (a -> b) -> a -> b
$ IllegalInstanceReason -> TcRnMessage
TcRnIllegalInstance
(IllegalInstanceReason -> TcRnMessage)
-> IllegalInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ IllegalFamilyInstanceReason -> IllegalInstanceReason
IllegalFamilyInstance (IllegalFamilyInstanceReason -> IllegalInstanceReason)
-> IllegalFamilyInstanceReason -> IllegalInstanceReason
forall a b. (a -> b) -> a -> b
$ InvalidAssoc -> IllegalFamilyInstanceReason
InvalidAssoc
(InvalidAssoc -> IllegalFamilyInstanceReason)
-> InvalidAssoc -> IllegalFamilyInstanceReason
forall a b. (a -> b) -> a -> b
$ InvalidAssocDefault -> InvalidAssoc
InvalidAssocDefault
(InvalidAssocDefault -> InvalidAssoc)
-> InvalidAssocDefault -> InvalidAssoc
forall a b. (a -> b) -> a -> b
$ Name -> Name -> InvalidAssocDefault
AssocDefaultNotAssoc Name
class_name Name
n
| Name
n <- (GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn) -> Name)
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LTyFamDefltDecl GhcRn -> Name
GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn) -> Name
at_def_tycon [LTyFamDefltDecl GhcRn]
[GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
at_defs
, Bool -> Bool
not (Name
n Name -> NameSet -> Bool
`elemNameSet` NameSet
at_names) ]
; (GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) ClassATItem)
-> [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)] -> TcM [ClassATItem]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) ClassATItem
tc_at [LFamilyDecl GhcRn]
[GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
ats }
where
at_def_tycon :: LTyFamDefltDecl GhcRn -> Name
at_def_tycon :: LTyFamDefltDecl GhcRn -> Name
at_def_tycon = TyFamInstDecl GhcRn -> IdP GhcRn
TyFamInstDecl GhcRn -> Name
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)
tyFamInstDeclName (TyFamInstDecl GhcRn -> Name)
-> (GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
-> TyFamInstDecl GhcRn)
-> GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn) -> TyFamInstDecl GhcRn
forall l e. GenLocated l e -> e
unLoc
at_fam_name :: LFamilyDecl GhcRn -> Name
at_fam_name :: LFamilyDecl GhcRn -> Name
at_fam_name = FamilyDecl GhcRn -> IdP GhcRn
FamilyDecl GhcRn -> Name
forall (p :: Pass). FamilyDecl (GhcPass p) -> IdP (GhcPass p)
familyDeclName (FamilyDecl GhcRn -> Name)
-> (GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> FamilyDecl GhcRn)
-> GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> FamilyDecl GhcRn
forall l e. GenLocated l e -> e
unLoc
at_names :: NameSet
at_names = [Name] -> NameSet
mkNameSet ((GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> Name)
-> [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LFamilyDecl GhcRn -> Name
GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> Name
at_fam_name [LFamilyDecl GhcRn]
[GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
ats)
at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn]
at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn]
at_defs_map = (GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
-> NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)])
-> NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
forall a b. (a -> b -> b) -> b -> [a] -> b
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 -> ([GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)])
-> NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> Name
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
forall a. (a -> a -> a) -> NameEnv a -> Name -> a -> NameEnv a
extendNameEnv_C [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
forall a. [a] -> [a] -> [a]
(++) NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
nenv
(LTyFamDefltDecl GhcRn -> Name
at_def_tycon LTyFamDefltDecl GhcRn
GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
at_def) [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
at_def])
NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
forall a. NameEnv a
emptyNameEnv [LTyFamDefltDecl GhcRn]
[GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
at_defs
tc_at :: GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) ClassATItem
tc_at GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
at = do { (fam_tc, val_infos) <- (FamilyDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo]))
-> GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo])
forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM (Maybe Class
-> FamilyDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo])
tcFamDecl1 (Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls)) GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
at
; mapM_ (checkTyFamEqnValidityInfo fam_tc) val_infos
; let at_defs = NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> Name -> Maybe [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv [LTyFamDefltDecl GhcRn]
NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
at_defs_map (LFamilyDecl GhcRn -> Name
at_fam_name LFamilyDecl GhcRn
GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
at)
Maybe [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
forall a. Maybe a -> a -> a
`orElse` []
; atd <- tcDefaultAssocDecl fam_tc at_defs
; return (ATI fam_tc atd) }
tcDefaultAssocDecl ::
TyCon
-> [LTyFamDefltDecl GhcRn]
-> TcM (Maybe (KnotTied Type, TyFamEqnValidityInfo))
tcDefaultAssocDecl :: TyCon
-> [LTyFamDefltDecl GhcRn]
-> TcM (Maybe (Type, TyFamEqnValidityInfo))
tcDefaultAssocDecl TyCon
_ []
= Maybe (Type, TyFamEqnValidityInfo)
-> TcM (Maybe (Type, TyFamEqnValidityInfo))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Type, TyFamEqnValidityInfo)
forall a. Maybe a
Nothing
tcDefaultAssocDecl TyCon
_ (LTyFamDefltDecl GhcRn
d1:LTyFamDefltDecl GhcRn
_:[LTyFamDefltDecl GhcRn]
_)
= TcRnMessage -> TcM (Maybe (Type, TyFamEqnValidityInfo))
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM (Maybe (Type, TyFamEqnValidityInfo)))
-> TcRnMessage -> TcM (Maybe (Type, TyFamEqnValidityInfo))
forall a b. (a -> b) -> a -> b
$ IllegalInstanceReason -> TcRnMessage
TcRnIllegalInstance (IllegalInstanceReason -> TcRnMessage)
-> IllegalInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ IllegalFamilyInstanceReason -> IllegalInstanceReason
IllegalFamilyInstance
(IllegalFamilyInstanceReason -> IllegalInstanceReason)
-> IllegalFamilyInstanceReason -> IllegalInstanceReason
forall a b. (a -> b) -> a -> b
$ InvalidAssoc -> IllegalFamilyInstanceReason
InvalidAssoc (InvalidAssoc -> IllegalFamilyInstanceReason)
-> InvalidAssoc -> IllegalFamilyInstanceReason
forall a b. (a -> b) -> a -> b
$ InvalidAssocDefault -> InvalidAssoc
InvalidAssocDefault (InvalidAssocDefault -> InvalidAssoc)
-> InvalidAssocDefault -> InvalidAssoc
forall a b. (a -> b) -> a -> b
$
Name -> InvalidAssocDefault
AssocMultipleDefaults (TyFamInstDecl GhcRn -> IdP GhcRn
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)
tyFamInstDeclName (GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn) -> TyFamInstDecl GhcRn
forall l e. GenLocated l e -> e
unLoc LTyFamDefltDecl GhcRn
GenLocated SrcSpanAnnA (TyFamInstDecl 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 -> HsFamEqnPats pass
feqn_pats = HsFamEqnPats GhcRn
hs_pats
, feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = LHsKind GhcRn
hs_rhs_ty }})]
=
SrcSpanAnnA
-> TcM (Maybe (Type, TyFamEqnValidityInfo))
-> TcM (Maybe (Type, TyFamEqnValidityInfo))
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (Maybe (Type, TyFamEqnValidityInfo))
-> TcM (Maybe (Type, TyFamEqnValidityInfo)))
-> TcM (Maybe (Type, TyFamEqnValidityInfo))
-> TcM (Maybe (Type, TyFamEqnValidityInfo))
forall a b. (a -> b) -> a -> b
$
SDoc
-> Name
-> TcM (Maybe (Type, TyFamEqnValidityInfo))
-> TcM (Maybe (Type, TyFamEqnValidityInfo))
forall a. SDoc -> Name -> TcM a -> TcM a
tcAddFamInstCtxt (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"default type instance") Name
tc_name (TcM (Maybe (Type, TyFamEqnValidityInfo))
-> TcM (Maybe (Type, TyFamEqnValidityInfo)))
-> TcM (Maybe (Type, TyFamEqnValidityInfo))
-> TcM (Maybe (Type, TyFamEqnValidityInfo))
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcDefaultAssocDecl 1" (Name -> SDoc
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 :: Int
vis_arity = [Var] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TyCon -> [Var]
tyConVisibleTyVars TyCon
fam_tc)
vis_pats :: Int
vis_pats = [HsArg
GhcRn
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> Int
forall p tm ty. [HsArg p tm ty] -> Int
numVisibleArgs HsFamEqnPats GhcRn
[HsArg
GhcRn
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
hs_pats
; Bool -> TcRn () -> TcRn ()
forall a. HasCallStack => Bool -> a -> a
assert (Name
fam_tc_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
tc_name) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Bool -> TcRnMessage -> TcRn ()
checkTc (TyCon -> Bool
isTypeFamilyTyCon TyCon
fam_tc) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
IllegalInstanceReason -> TcRnMessage
TcRnIllegalInstance (IllegalInstanceReason -> TcRnMessage)
-> IllegalInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ IllegalFamilyInstanceReason -> IllegalInstanceReason
IllegalFamilyInstance (IllegalFamilyInstanceReason -> IllegalInstanceReason)
-> IllegalFamilyInstanceReason -> IllegalInstanceReason
forall a b. (a -> b) -> a -> b
$
TyCon -> IllegalFamilyInstanceReason
FamilyCategoryMismatch TyCon
fam_tc
; Bool -> TcRnMessage -> TcRn ()
checkTc (Int
vis_pats Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
vis_arity) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
IllegalInstanceReason -> TcRnMessage
TcRnIllegalInstance (IllegalInstanceReason -> TcRnMessage)
-> IllegalInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ IllegalFamilyInstanceReason -> IllegalInstanceReason
IllegalFamilyInstance (IllegalFamilyInstanceReason -> IllegalInstanceReason)
-> IllegalFamilyInstanceReason -> IllegalInstanceReason
forall a b. (a -> b) -> a -> b
$
TyCon -> Int -> IllegalFamilyInstanceReason
FamilyArityMismatch TyCon
fam_tc Int
vis_arity
; (qtvs, non_user_tvs, pats, rhs_ty)
<- TyCon
-> AssocInstInfo
-> HsOuterFamEqnTyVarBndrs GhcRn
-> HsFamEqnPats GhcRn
-> LHsKind GhcRn
-> TcM ([Var], VarSet, ThetaType, Type)
tcTyFamInstEqnGuts TyCon
fam_tc AssocInstInfo
NotAssociated
HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs HsFamEqnPats GhcRn
hs_pats LHsKind GhcRn
hs_rhs_ty
; let fam_tvs = TyCon -> [Var]
tyConTyVars TyCon
fam_tc
; traceTc "tcDefaultAssocDecl 2" (vcat
[ text "hs_pats" <+> ppr hs_pats
, text "hs_rhs_ty" <+> ppr hs_rhs_ty
, text "fam_tvs" <+> ppr fam_tvs
, text "qtvs" <+> ppr qtvs
])
; let subst = case (Type -> Maybe Var) -> ThetaType -> Maybe [Var]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type -> Maybe Var
getTyVar_maybe ThetaType
pats of
Just [Var]
cpt_tvs -> [Var] -> ThetaType -> Subst
HasDebugCallStack => [Var] -> ThetaType -> Subst
zipTvSubst [Var]
cpt_tvs ([Var] -> ThetaType
mkTyVarTys [Var]
fam_tvs)
Maybe [Var]
Nothing -> Subst
emptySubst
; pure $ Just ( substTyUnchecked subst rhs_ty
, VI { vi_loc = locA loc
, vi_qtvs = qtvs
, vi_non_user_tvs = non_user_tvs
, vi_pats = pats
, vi_rhs = rhs_ty } )
}
tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM (TyCon, [TyFamEqnValidityInfo])
tcFamDecl1 :: Maybe Class
-> FamilyDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo])
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 EpAnnCO
_ FamilyResultSig GhcRn
sig
, fdInjectivityAnn :: forall pass. FamilyDecl pass -> Maybe (LInjectivityAnn pass)
fdInjectivityAnn = Maybe (LInjectivityAnn GhcRn)
inj })
| FamilyInfo GhcRn
DataFamily <- FamilyInfo GhcRn
fam_info
= Name
-> ([TyConBinder]
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo])
forall a. Name -> ([TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVarsAndZonk Name
tc_name (([TyConBinder]
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo]))
-> ([TyConBinder]
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo])
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
tc_bndrs Type
res_kind -> do
{ String -> SDoc -> TcRn ()
traceTc String
"tcFamDecl1 data family:" (Name -> SDoc
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
; tc_rep_name <- Name -> TcRnIf TcGblEnv TcLclEnv Name
forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
tc_name
; let inj = [Bool] -> Injectivity
Injective ([Bool] -> Injectivity) -> [Bool] -> Injectivity
forall a b. (a -> b) -> a -> b
$ Int -> Bool -> [Bool]
forall a. Int -> a -> [a]
replicate ([TyConBinder] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TyConBinder]
tc_bndrs) Bool
True
tycon = Name
-> [TyConBinder]
-> Type
-> Maybe Name
-> FamTyConFlav
-> Maybe Class
-> Injectivity
-> TyCon
mkFamilyTyCon Name
tc_name [TyConBinder]
tc_bndrs
Type
res_kind
(FamilyResultSig GhcRn -> Maybe (IdP GhcRn)
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
; return (tycon, []) }
| FamilyInfo GhcRn
OpenTypeFamily <- FamilyInfo GhcRn
fam_info
= Name
-> ([TyConBinder]
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo])
forall a. Name -> ([TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVarsAndZonk Name
tc_name (([TyConBinder]
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo]))
-> ([TyConBinder]
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo])
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
tc_bndrs Type
res_kind -> do
{ String -> SDoc -> TcRn ()
traceTc String
"tcFamDecl1 open type family:" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
; Name -> TcRn ()
checkFamFlag Name
tc_name
; inj' <- [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) -> TcM Injectivity
tcInjectivity [TyConBinder]
tc_bndrs Maybe (LInjectivityAnn GhcRn)
inj
; checkResultSigFlag tc_name sig
; let tycon = Name
-> [TyConBinder]
-> Type
-> Maybe Name
-> FamTyConFlav
-> Maybe Class
-> Injectivity
-> TyCon
mkFamilyTyCon Name
tc_name [TyConBinder]
tc_bndrs Type
res_kind
(FamilyResultSig GhcRn -> Maybe (IdP GhcRn)
forall (a :: Pass).
FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
resultVariableName FamilyResultSig GhcRn
sig) FamTyConFlav
OpenSynFamilyTyCon
Maybe Class
parent Injectivity
inj'
; return (tycon, []) }
| ClosedTypeFamily Maybe [LTyFamInstEqn GhcRn]
mb_eqns <- FamilyInfo GhcRn
fam_info
=
do { String -> SDoc -> TcRn ()
traceTc String
"tcFamDecl1 Closed type family:" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
; (inj', tc_bndrs, res_kind)
<- Name
-> ([TyConBinder]
-> Type -> TcM (Injectivity, [TyConBinder], Type))
-> TcM (Injectivity, [TyConBinder], Type)
forall a. Name -> ([TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVarsAndZonk Name
tc_name (([TyConBinder] -> Type -> TcM (Injectivity, [TyConBinder], Type))
-> TcM (Injectivity, [TyConBinder], Type))
-> ([TyConBinder]
-> Type -> TcM (Injectivity, [TyConBinder], Type))
-> TcM (Injectivity, [TyConBinder], Type)
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
tc_bndrs Type
res_kind ->
do { inj' <- [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) -> TcM Injectivity
tcInjectivity [TyConBinder]
tc_bndrs Maybe (LInjectivityAnn GhcRn)
inj
; return (inj', tc_bndrs, res_kind) }
; checkFamFlag tc_name
; checkResultSigFlag tc_name sig
; case mb_eqns of
Maybe [LTyFamInstEqn GhcRn]
Nothing ->
let tc :: TyCon
tc = Name
-> [TyConBinder]
-> Type
-> Maybe Name
-> FamTyConFlav
-> Maybe Class
-> Injectivity
-> TyCon
mkFamilyTyCon Name
tc_name [TyConBinder]
tc_bndrs Type
res_kind
(FamilyResultSig GhcRn -> Maybe (IdP GhcRn)
forall (a :: Pass).
FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
resultVariableName FamilyResultSig GhcRn
sig)
FamTyConFlav
AbstractClosedSynFamilyTyCon Maybe Class
parent
Injectivity
inj'
in (TyCon, [TyFamEqnValidityInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [TyFamEqnValidityInfo])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
tc, [])
Just [LTyFamInstEqn GhcRn]
eqns -> do {
; let tc_fam_tc :: TyCon
tc_fam_tc = Name
-> [TyConBinder]
-> Type
-> [(Name, Var)]
-> Bool
-> TyConFlavour TyCon
-> TyCon
mkTcTyCon Name
tc_name [TyConBinder]
tc_bndrs Type
res_kind
[(Name, Var)]
noTcTyConScopedTyVars
Bool
False
TyConFlavour TyCon
forall tc. TyConFlavour tc
ClosedTypeFamilyFlavour
; (branches, axiom_validity_infos) <-
[(KnotTied CoAxBranch, TyFamEqnValidityInfo)]
-> ([KnotTied CoAxBranch], [TyFamEqnValidityInfo])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(KnotTied CoAxBranch, TyFamEqnValidityInfo)]
-> ([KnotTied CoAxBranch], [TyFamEqnValidityInfo]))
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(KnotTied CoAxBranch, TyFamEqnValidityInfo)]
-> IOEnv
(Env TcGblEnv TcLclEnv)
([KnotTied CoAxBranch], [TyFamEqnValidityInfo])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenLocated
SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> TcRn (KnotTied CoAxBranch, TyFamEqnValidityInfo))
-> [GenLocated
SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[(KnotTied CoAxBranch, TyFamEqnValidityInfo)]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM (TyCon
-> AssocInstInfo
-> LTyFamInstEqn GhcRn
-> TcRn (KnotTied CoAxBranch, TyFamEqnValidityInfo)
tcTyFamInstEqn TyCon
tc_fam_tc AssocInstInfo
NotAssociated) [LTyFamInstEqn GhcRn]
[GenLocated
SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
eqns
; co_ax_name <- newFamInstAxiomName tc_lname []
; let mb_co_ax
| [GenLocated
SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LTyFamInstEqn GhcRn]
[GenLocated
SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
eqns = Maybe (CoAxiom Branched)
forall a. Maybe a
Nothing
| Bool
otherwise = CoAxiom Branched -> Maybe (CoAxiom Branched)
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 = Name
-> [TyConBinder]
-> Type
-> Maybe Name
-> FamTyConFlav
-> Maybe Class
-> Injectivity
-> TyCon
mkFamilyTyCon Name
tc_name [TyConBinder]
tc_bndrs Type
res_kind (FamilyResultSig GhcRn -> Maybe (IdP GhcRn)
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'
; return (fam_tc, axiom_validity_infos) } }
tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn)
-> TcM Injectivity
tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) -> TcM Injectivity
tcInjectivity [TyConBinder]
_ Maybe (LInjectivityAnn GhcRn)
Nothing
= Injectivity -> TcM Injectivity
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Injectivity
NotInjective
tcInjectivity [TyConBinder]
tcbs (Just (L EpAnnCO
loc (InjectivityAnn XCInjectivityAnn GhcRn
_ LIdP GhcRn
_ [LIdP GhcRn]
lInjNames)))
= EpAnnCO -> TcM Injectivity -> TcM Injectivity
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA EpAnnCO
loc (TcM Injectivity -> TcM Injectivity)
-> TcM Injectivity -> TcM Injectivity
forall a b. (a -> b) -> a -> b
$
do { let tvs :: [Var]
tvs = [TyConBinder] -> [Var]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tcbs
; dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; checkTc (xopt LangExt.TypeFamilyDependencies dflags)
TcRnTyFamDepsDisabled
; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames
; inj_tvs <- liftZonkM $ zonkTcTyVarsToTcTyVars inj_tvs
; let inj_ktvs = (Var -> Bool) -> VarSet -> VarSet
filterVarSet Var -> Bool
isTyVar (VarSet -> VarSet) -> VarSet -> VarSet
forall a b. (a -> b) -> a -> b
$
VarSet -> VarSet
closeOverKinds ([Var] -> VarSet
mkVarSet [Var]
inj_tvs)
; let inj_bools = (Var -> Bool) -> [Var] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Var -> VarSet -> Bool
`elemVarSet` VarSet
inj_ktvs) [Var]
tvs
; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs
, ppr inj_ktvs, ppr inj_bools ])
; return $ Injective inj_bools }
tcTySynRhs :: RolesInfo -> Name
-> LHsType GhcRn -> TcM TyCon
tcTySynRhs :: (Name -> [Role]) -> Name -> LHsKind GhcRn -> TcRn TyCon
tcTySynRhs Name -> [Role]
roles_info Name
tc_name LHsKind GhcRn
hs_ty
= Name -> ([TyConBinder] -> Type -> TcRn TyCon) -> TcRn TyCon
forall a. Name -> ([TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tc_name (([TyConBinder] -> Type -> TcRn TyCon) -> TcRn TyCon)
-> ([TyConBinder] -> Type -> TcRn TyCon) -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
tc_bndrs Type
res_kind ->
do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; traceTc "tc-syn" (ppr tc_name $$ ppr (getLclEnvRdrEnv env))
; rhs_ty <- pushLevelAndSolveEqualities skol_info tc_bndrs $
tcCheckLHsTypeInContext hs_ty (TheKind res_kind)
; dvs <- candidateQTyVarsOfType rhs_ty
; let err_ctx TidyEnv
tidy_env = do { (tidy_env2, rhs_ty) <- TidyEnv -> Type -> ZonkM (TidyEnv, Type)
zonkTidyTcType TidyEnv
tidy_env Type
rhs_ty
; return (tidy_env2, UninfTyCtx_TySynRhs rhs_ty) }
; doNotQuantifyTyVars dvs err_ctx
; (bndrs, rhs_ty) <- initZonkEnv NoFlexi $
runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ [TyConBinder]
bndrs ->
do { rhs_ty <- Type -> ZonkTcM Type
zonkTcTypeToTypeX Type
rhs_ty
; return (bndrs, rhs_ty) }
; let roles = Name -> [Role]
roles_info Name
tc_name
; return (buildSynTyCon tc_name bndrs res_kind roles rhs_ty) }
where
skol_info :: SkolemInfoAnon
skol_info = TyConFlavour TyCon -> Name -> SkolemInfoAnon
TyConSkol TyConFlavour TyCon
forall tc. TyConFlavour tc
TypeSynonymFlavour Name
tc_name
tcDataDefn :: SDoc -> RolesInfo -> Name
-> HsDataDefn GhcRn -> TcM (TyCon, [DerivInfo])
tcDataDefn :: SDoc
-> (Name -> [Role])
-> Name
-> HsDataDefn GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
tcDataDefn SDoc
err_ctxt Name -> [Role]
roles_info Name
tc_name
(HsDataDefn { 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 -> DataDefnCons (LConDecl pass)
dd_cons = DataDefnCons (LConDecl GhcRn)
cons
, dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs = HsDeriving GhcRn
derivs })
= Name
-> ([TyConBinder]
-> Type -> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
forall a. Name -> ([TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tc_name (([TyConBinder]
-> Type -> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo]))
-> ([TyConBinder]
-> Type -> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
tc_bndrs Type
res_kind ->
do { gadt_syntax <- Name
-> Maybe (LHsContext GhcRn)
-> DataDefnCons (LConDecl GhcRn)
-> TcRnIf TcGblEnv TcLclEnv Bool
dataDeclChecks Name
tc_name Maybe (LHsContext GhcRn)
ctxt DataDefnCons (LConDecl GhcRn)
cons
; tcg_env <- getGblEnv
; let hsc_src = TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env
; unless (mk_permissive_kind hsc_src cons) $
checkDataKindSig (DataDeclSort (dataDefnConsNewOrData cons)) res_kind
; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info tc_bndrs $
tcHsContext ctxt
; dvs <- candidateQTyVarsOfTypes stupid_tc_theta
; let err_ctx TidyEnv
tidy_env
= do { (tidy_env2, theta) <- TidyEnv -> ThetaType -> ZonkM (TidyEnv, ThetaType)
zonkTidyTcTypes TidyEnv
tidy_env ThetaType
stupid_tc_theta
; return (tidy_env2, UninfTyCtx_DataContext theta) }
; doNotQuantifyTyVars dvs err_ctx
; kind_signatures <- xoptM LangExt.KindSignatures
; case mb_ksig of
Just (L SrcSpanAnnA
_ HsType GhcRn
ksig)
| Bool -> Bool
not Bool
kind_signatures
-> TcRnMessage -> TcRn ()
addErrTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Either (HsType GhcPs) (Name, HsType GhcRn) -> TcRnMessage
TcRnKindSignaturesDisabled ((Name, HsType GhcRn) -> Either (HsType GhcPs) (Name, HsType GhcRn)
forall a b. b -> Either a b
Right (Name
tc_name, HsType GhcRn
ksig))
Maybe (LHsKind GhcRn)
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; (bndrs, stupid_theta, res_kind) <- initZonkEnv NoFlexi $
runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ [TyConBinder]
bndrs ->
do { stupid_theta <- ThetaType -> ZonkTcM ThetaType
zonkTcTypesToTypesX ThetaType
stupid_tc_theta
; res_kind <- zonkTcTypeToTypeX res_kind
; return (bndrs, stupid_theta, res_kind) }
; tycon <- fixM $ \ TyCon
rec_tycon -> do
{ data_cons <- DataDeclInfo
-> TyCon
-> [TyConBinder]
-> Type
-> DataDefnCons (LConDecl GhcRn)
-> TcM (DataDefnCons DataCon)
tcConDecls DataDeclInfo
DDataType TyCon
rec_tycon [TyConBinder]
tc_bndrs Type
res_kind DataDefnCons (LConDecl GhcRn)
cons
; tc_rhs <- mk_tc_rhs hsc_src rec_tycon data_cons
; tc_rep_nm <- newTyConRepName tc_name
; return (mkAlgTyCon tc_name
bndrs
res_kind
(roles_info tc_name)
(fmap unLoc cType)
stupid_theta tc_rhs
(VanillaAlgTyCon tc_rep_nm)
gadt_syntax)
}
; let scoped_tvs = [Var] -> [(Name, Var)]
mkTyVarNamePairs ([TyConBinder] -> [Var]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tc_bndrs)
deriv_info = DerivInfo { di_rep_tc :: TyCon
di_rep_tc = TyCon
tycon
, di_scoped_tvs :: [(Name, Var)]
di_scoped_tvs = [(Name, Var)]
scoped_tvs
, di_clauses :: HsDeriving GhcRn
di_clauses = HsDeriving GhcRn
derivs
, di_ctxt :: SDoc
di_ctxt = SDoc
err_ctxt }
; traceTc "tcDataDefn" (ppr tc_name $$ ppr tc_bndrs)
; return (tycon, [deriv_info]) }
where
skol_info :: SkolemInfoAnon
skol_info = TyConFlavour TyCon -> Name -> SkolemInfoAnon
TyConSkol TyConFlavour TyCon
flav Name
tc_name
flav :: TyConFlavour TyCon
flav = NewOrData -> TyConFlavour TyCon
forall tc. NewOrData -> TyConFlavour tc
newOrDataToFlavour (DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)) -> NewOrData
forall a. DataDefnCons a -> NewOrData
dataDefnConsNewOrData DataDefnCons (LConDecl GhcRn)
DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
cons)
mk_permissive_kind :: HscSource -> DataDefnCons a -> Bool
mk_permissive_kind HscSource
HsigFile (DataTypeCons Bool
_ []) = Bool
True
mk_permissive_kind HscSource
_ DataDefnCons a
_ = Bool
False
mk_tc_rhs :: HscSource
-> TyCon
-> DataDefnCons DataCon
-> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
mk_tc_rhs (HscSource -> Bool
isHsBootOrSig -> Bool
True) TyCon
_ (DataTypeCons Bool
_ [])
= AlgTyConRhs -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return AlgTyConRhs
AbstractTyCon
mk_tc_rhs HscSource
_ TyCon
tycon DataDefnCons DataCon
data_cons = case DataDefnCons DataCon
data_cons of
DataTypeCons Bool
is_type_data [DataCon]
data_cons -> AlgTyConRhs -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (AlgTyConRhs -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs)
-> AlgTyConRhs -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
forall a b. (a -> b) -> a -> b
$
Bool -> Bool -> [DataCon] -> AlgTyConRhs
mkLevPolyDataTyConRhs
(HasDebugCallStack => Type -> Bool
Type -> Bool
isFixedRuntimeRepKind (TyCon -> Type
tyConResKind TyCon
tycon))
Bool
is_type_data
[DataCon]
data_cons
NewTypeCon DataCon
data_con -> Name
-> TyCon -> DataCon -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
forall m n. Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
mkNewTyConRhs Name
tc_name TyCon
tycon DataCon
data_con
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 -> HsFamEqnPats pass
feqn_pats = HsFamEqnPats GhcRn
hs_pats
, feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = GenLocated SrcSpanAnnA (HsType GhcRn)
hs_rhs_ty }))
= SrcSpanAnnA -> TcRn () -> TcRn ()
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"kcTyFamInstEqn" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tc_name =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
eqn_tc_name
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fam_tc =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc_fam_tc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConKind TyCon
tc_fam_tc)
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"feqn_bndrs =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsOuterFamEqnTyVarBndrs GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"feqn_pats =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [HsArg
GhcRn
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> SDoc
forall a. Outputable a => a -> SDoc
ppr HsFamEqnPats GhcRn
[HsArg
GhcRn
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
hs_pats ])
; TyCon
-> Name
-> [HsArg
GhcRn
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> TcRn ()
forall p tm ty. TyCon -> Name -> [HsArg p tm ty] -> TcRn ()
checkTyFamInstEqn TyCon
tc_fam_tc Name
eqn_tc_name HsFamEqnPats GhcRn
[HsArg
GhcRn
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
hs_pats
; TcM (HsOuterFamEqnTyVarBndrs GhcTc, Type) -> TcRn ()
forall a. TcM a -> TcRn ()
discardResult (TcM (HsOuterFamEqnTyVarBndrs GhcTc, Type) -> TcRn ())
-> TcM (HsOuterFamEqnTyVarBndrs GhcTc, Type) -> TcRn ()
forall a b. (a -> b) -> a -> b
$
HsOuterFamEqnTyVarBndrs GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) Type
-> TcM (HsOuterFamEqnTyVarBndrs GhcTc, Type)
forall a.
HsOuterFamEqnTyVarBndrs GhcRn
-> TcM a -> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a)
bindOuterFamEqnTKBndrs_Q_Tv HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs (IOEnv (Env TcGblEnv TcLclEnv) Type
-> TcM (HsOuterFamEqnTyVarBndrs GhcTc, Type))
-> IOEnv (Env TcGblEnv TcLclEnv) Type
-> TcM (HsOuterFamEqnTyVarBndrs GhcTc, Type)
forall a b. (a -> b) -> a -> b
$
do { (_fam_app, res_kind) <- TyCon -> HsFamEqnPats GhcRn -> TcM (Type, Type)
tcFamTyPats TyCon
tc_fam_tc HsFamEqnPats GhcRn
hs_pats
; tcCheckLHsTypeInContext hs_rhs_ty (TheKind res_kind) }
}
tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn
-> TcM (KnotTied CoAxBranch, TyFamEqnValidityInfo)
tcTyFamInstEqn :: TyCon
-> AssocInstInfo
-> LTyFamInstEqn GhcRn
-> TcRn (KnotTied CoAxBranch, TyFamEqnValidityInfo)
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 -> HsFamEqnPats pass
feqn_pats = HsFamEqnPats GhcRn
hs_pats
, feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = GenLocated SrcSpanAnnA (HsType GhcRn)
hs_rhs_ty }))
= SrcSpanAnnA
-> TcRn (KnotTied CoAxBranch, TyFamEqnValidityInfo)
-> TcRn (KnotTied CoAxBranch, TyFamEqnValidityInfo)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn (KnotTied CoAxBranch, TyFamEqnValidityInfo)
-> TcRn (KnotTied CoAxBranch, TyFamEqnValidityInfo))
-> TcRn (KnotTied CoAxBranch, TyFamEqnValidityInfo)
-> TcRn (KnotTied CoAxBranch, TyFamEqnValidityInfo)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcTyFamInstEqn" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SrcSpanAnnA -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanAnnA
loc, TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [HsArg
GhcRn
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> SDoc
forall a. Outputable a => a -> SDoc
ppr HsFamEqnPats GhcRn
[HsArg
GhcRn
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
hs_pats
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fam tc bndrs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Var] -> SDoc
pprTyVars (TyCon -> [Var]
tyConTyVars TyCon
fam_tc)
, case AssocInstInfo
mb_clsinfo of
NotAssociated {} -> SDoc
forall doc. IsOutput doc => doc
empty
InClsInst { ai_class :: AssocInstInfo -> Class
ai_class = Class
cls } -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"class" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Var] -> SDoc
pprTyVars (Class -> [Var]
classTyVars Class
cls) ]
; TyCon
-> Name
-> [HsArg
GhcRn
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> TcRn ()
forall p tm ty. TyCon -> Name -> [HsArg p tm ty] -> TcRn ()
checkTyFamInstEqn TyCon
fam_tc Name
eqn_tc_name HsFamEqnPats GhcRn
[HsArg
GhcRn
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
hs_pats
; (qtvs, non_user_tvs, pats, rhs_ty)
<- TyCon
-> AssocInstInfo
-> HsOuterFamEqnTyVarBndrs GhcRn
-> HsFamEqnPats GhcRn
-> LHsKind GhcRn
-> TcM ([Var], VarSet, ThetaType, Type)
tcTyFamInstEqnGuts TyCon
fam_tc AssocInstInfo
mb_clsinfo
HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs HsFamEqnPats GhcRn
hs_pats LHsKind GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
hs_rhs_ty
; let ax = [Var]
-> [Var]
-> [Var]
-> ThetaType
-> Type
-> [Role]
-> SrcSpan
-> KnotTied CoAxBranch
mkCoAxBranch [Var]
qtvs [] [] ThetaType
pats Type
rhs_ty
((Var -> Role) -> [Var] -> [Role]
forall a b. (a -> b) -> [a] -> [b]
map (Role -> Var -> Role
forall a b. a -> b -> a
const Role
Nominal) [Var]
qtvs)
(SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc)
vi = VI { vi_loc :: SrcSpan
vi_loc = SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc
, vi_qtvs :: [Var]
vi_qtvs = [Var]
qtvs
, vi_non_user_tvs :: VarSet
vi_non_user_tvs = VarSet
non_user_tvs
, vi_pats :: ThetaType
vi_pats = ThetaType
pats
, vi_rhs :: Type
vi_rhs = Type
rhs_ty }
; return (ax, vi) }
checkTyFamInstEqn :: TcTyCon -> Name -> [HsArg p tm ty] -> TcM ()
checkTyFamInstEqn :: forall p tm ty. TyCon -> Name -> [HsArg p tm ty] -> TcRn ()
checkTyFamInstEqn TyCon
tc_fam_tc Name
eqn_tc_name [HsArg p tm ty]
hs_pats =
do {
let tc_fam_tc_name :: Name
tc_fam_tc_name = TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc_fam_tc
; Bool -> TcRnMessage -> TcRn ()
checkTc (Name
tc_fam_tc_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
eqn_tc_name) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
IllegalInstanceReason -> TcRnMessage
TcRnIllegalInstance (IllegalInstanceReason -> TcRnMessage)
-> IllegalInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ IllegalFamilyInstanceReason -> IllegalInstanceReason
IllegalFamilyInstance (IllegalFamilyInstanceReason -> IllegalInstanceReason)
-> IllegalFamilyInstanceReason -> IllegalInstanceReason
forall a b. (a -> b) -> a -> b
$
Name -> Name -> IllegalFamilyInstanceReason
TyFamNameMismatch Name
tc_fam_tc_name Name
eqn_tc_name
; let vis_arity :: Int
vis_arity = [Var] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TyCon -> [Var]
tyConVisibleTyVars TyCon
tc_fam_tc)
vis_pats :: Int
vis_pats = [HsArg p tm ty] -> Int
forall p tm ty. [HsArg p tm ty] -> Int
numVisibleArgs [HsArg p tm ty]
hs_pats
; Bool -> TcRnMessage -> TcRn ()
checkTc (Int
vis_pats Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
vis_arity) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
IllegalInstanceReason -> TcRnMessage
TcRnIllegalInstance (IllegalInstanceReason -> TcRnMessage)
-> IllegalInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ IllegalFamilyInstanceReason -> IllegalInstanceReason
IllegalFamilyInstance (IllegalFamilyInstanceReason -> IllegalInstanceReason)
-> IllegalFamilyInstanceReason -> IllegalInstanceReason
forall a b. (a -> b) -> a -> b
$
TyCon -> Int -> IllegalFamilyInstanceReason
FamilyArityMismatch TyCon
tc_fam_tc Int
vis_arity
}
tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo
-> HsOuterFamEqnTyVarBndrs GhcRn
-> HsFamEqnPats GhcRn
-> LHsType GhcRn
-> TcM ([TyVar], TyVarSet, [TcType], TcType)
tcTyFamInstEqnGuts :: TyCon
-> AssocInstInfo
-> HsOuterFamEqnTyVarBndrs GhcRn
-> HsFamEqnPats GhcRn
-> LHsKind GhcRn
-> TcM ([Var], VarSet, ThetaType, Type)
tcTyFamInstEqnGuts TyCon
fam_tc AssocInstInfo
mb_clsinfo HsOuterFamEqnTyVarBndrs GhcRn
outer_hs_bndrs HsFamEqnPats GhcRn
hs_pats LHsKind GhcRn
hs_rhs_ty
= do { String -> SDoc -> TcRn ()
traceTc String
"tcTyFamInstEqnGuts {" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ HsOuterFamEqnTyVarBndrs GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsOuterFamEqnTyVarBndrs GhcRn
outer_hs_bndrs SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [HsArg
GhcRn
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> SDoc
forall a. Outputable a => a -> SDoc
ppr HsFamEqnPats GhcRn
[HsArg
GhcRn
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
hs_pats)
; skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo SkolemInfoAnon
FamInstSkol
; (tclvl, wanted, (outer_bndrs, (lhs_ty, rhs_ty)))
<- pushLevelAndSolveEqualitiesX "tcTyFamInstEqnGuts" $
bindOuterFamEqnTKBndrs skol_info outer_hs_bndrs $
do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats
; addConsistencyConstraints mb_clsinfo lhs_ty
; rhs_ty <- tcCheckLHsTypeInContext hs_rhs_ty (TheKind rhs_kind)
; return (lhs_ty, rhs_ty) }
; outer_bndrs <- scopedSortOuter outer_bndrs
; let outer_tvs = HsOuterFamEqnTyVarBndrs GhcTc -> [Var]
forall flag. HsOuterTyVarBndrs flag GhcTc -> [Var]
outerTyVars HsOuterFamEqnTyVarBndrs GhcTc
outer_bndrs
; checkFamTelescope tclvl outer_hs_bndrs outer_tvs
; traceTc "tcTyFamInstEqnGuts 1" (pprTyVars outer_tvs $$ ppr skol_info)
; dvs <- candidateQTyVarsWithBinders outer_tvs lhs_ty
; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs
; let final_tvs = [Var] -> [Var]
scopedSort ([Var]
qtvs [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
outer_tvs)
; reportUnsolvedEqualities skol_info final_tvs tclvl wanted
; traceTc "tcTyFamInstEqnGuts 2" $
vcat [ ppr fam_tc
, text "lhs_ty:" <+> ppr lhs_ty
, text "final_tvs:" <+> pprTyVars final_tvs ]
; dvs_rhs <- candidateQTyVarsOfType rhs_ty
; let err_ctx TidyEnv
tidy_env
= do { (tidy_env2, rhs_ty) <- TidyEnv -> Type -> ZonkM (TidyEnv, Type)
zonkTidyTcType TidyEnv
tidy_env Type
rhs_ty
; return (tidy_env2, UninfTyCtx_TyFamRhs rhs_ty) }
; doNotQuantifyTyVars dvs_rhs err_ctx
; (final_tvs, non_user_tvs, lhs_ty, rhs_ty) <- initZonkEnv NoFlexi $
runZonkBndrT (zonkTyBndrsX final_tvs) $ \ [Var]
final_tvs ->
do { lhs_ty <- Type -> ZonkTcM Type
zonkTcTypeToTypeX Type
lhs_ty
; rhs_ty <- zonkTcTypeToTypeX rhs_ty
; non_user_tvs <- traverse lookupTyVarX qtvs
; return (final_tvs, non_user_tvs, lhs_ty, rhs_ty) }
; let pats = Type -> ThetaType
unravelFamInstPats Type
lhs_ty
; traceTc "tcTyFamInstEqnGuts }" (vcat [ ppr fam_tc, pprTyVars final_tvs ])
; return (final_tvs, mkVarSet non_user_tvs, pats, rhs_ty) }
checkFamTelescope :: TcLevel
-> HsOuterFamEqnTyVarBndrs GhcRn
-> [TcTyVar] -> TcM ()
checkFamTelescope :: TcLevel -> HsOuterFamEqnTyVarBndrs GhcRn -> [Var] -> TcRn ()
checkFamTelescope TcLevel
tclvl HsOuterFamEqnTyVarBndrs GhcRn
hs_outer_bndrs [Var]
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 = [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
forall a. HasCallStack => [a] -> a
last [LHsTyVarBndr () (NoGhcTc GhcRn)]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
bndrs
= do { skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (TyVarBndrs -> SkolemInfoAnon
ForAllSkol (TyVarBndrs -> SkolemInfoAnon) -> TyVarBndrs -> SkolemInfoAnon
forall a b. (a -> b) -> a -> b
$ [HsTyVarBndr () GhcRn] -> TyVarBndrs
forall flag.
OutputableBndrFlag flag 'Renamed =>
[HsTyVarBndr flag GhcRn] -> TyVarBndrs
HsTyVarBndrsRn ((GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
-> HsTyVarBndr () GhcRn)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
-> [HsTyVarBndr () GhcRn]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
-> HsTyVarBndr () GhcRn
forall l e. GenLocated l e -> e
unLoc [LHsTyVarBndr () (NoGhcTc GhcRn)]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
bndrs))
; setSrcSpan (combineSrcSpans (getLocA b_first) (getLocA b_last)) $ do
emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC }
| Bool
otherwise
= () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
unravelFamInstPats :: TcType -> [TcType]
unravelFamInstPats :: Type -> ThetaType
unravelFamInstPats Type
fam_app
= case HasDebugCallStack => Type -> Maybe (TyCon, ThetaType)
Type -> Maybe (TyCon, ThetaType)
tcSplitTyConApp_maybe Type
fam_app of
Just (TyCon
_, ThetaType
pats) -> ThetaType
pats
Maybe (TyCon, ThetaType)
Nothing -> String -> ThetaType
forall a. HasCallStack => 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, ThetaType
pats) <- HasDebugCallStack => Type -> Maybe (TyCon, ThetaType)
Type -> Maybe (TyCon, ThetaType)
tcSplitTyConApp_maybe Type
fam_app
= do { let eqs :: [(Type, Type)]
eqs = [ (Type
cls_ty, Type
pat)
| (Var
fam_tc_tv, Type
pat) <- TyCon -> [Var]
tyConTyVars TyCon
fam_tc [Var] -> ThetaType -> [(Var, Type)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` ThetaType
pats
, Just Type
cls_ty <- [VarEnv Type -> Var -> Maybe Type
forall a. VarEnv a -> Var -> Maybe a
lookupVarEnv VarEnv Type
inst_env Var
fam_tc_tv] ]
; String -> SDoc -> TcRn ()
traceTc String
"addConsistencyConstraints" ([(Type, Type)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Type, Type)]
eqs)
; CtOrigin -> [(Type, Type)] -> TcRn ()
emitWantedEqs CtOrigin
AssocFamPatOrigin [(Type, Type)]
eqs }
| Bool
otherwise
= () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
dataDeclChecks :: Name
-> Maybe (LHsContext GhcRn) -> DataDefnCons (LConDecl GhcRn)
-> TcM Bool
dataDeclChecks :: Name
-> Maybe (LHsContext GhcRn)
-> DataDefnCons (LConDecl GhcRn)
-> TcRnIf TcGblEnv TcLclEnv Bool
dataDeclChecks Name
tc_name Maybe (LHsContext GhcRn)
mctxt DataDefnCons (LConDecl GhcRn)
cons
= do { let stupid_theta :: HsContext GhcRn
stupid_theta = Maybe (LHsContext GhcRn) -> HsContext GhcRn
forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext Maybe (LHsContext GhcRn)
mctxt
; gadtSyntax_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.GADTSyntax
; let gadt_syntax = DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn)) -> Bool
forall (f :: * -> *) l pass.
Foldable f =>
f (GenLocated l (ConDecl pass)) -> Bool
anyLConIsGadt DataDefnCons (LConDecl GhcRn)
DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
cons
; unless (gadtSyntax_ok || not gadt_syntax) $
addErrTc (TcRnGADTsDisabled tc_name)
; checkTc (null stupid_theta || not gadt_syntax) (TcRnGADTDataContext tc_name)
; empty_data_decls <- xoptM LangExt.EmptyDataDecls
; is_boot <- tcIsHsBootOrSig
; unless (not (null cons) || empty_data_decls || is_boot) $
addErrTc (TcRnEmptyDataDeclsDisabled tc_name)
; return gadt_syntax }
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 -> ThetaType -> Type
mkTyConApp TyCon
rep_tycon (ThetaType -> Type) -> ThetaType -> Type
forall a b. (a -> b) -> a -> b
$
[Var] -> ThetaType
mkTyVarTys ([TyConBinder] -> [Var]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tc_bndrs)
DDataInstance Type
header_ty -> Type
header_ty
tcConDecls :: DataDeclInfo
-> KnotTied TyCon
-> [TcTyConBinder]
-> TcKind
-> DataDefnCons (LConDecl GhcRn) -> TcM (DataDefnCons DataCon)
tcConDecls :: DataDeclInfo
-> TyCon
-> [TyConBinder]
-> Type
-> DataDefnCons (LConDecl GhcRn)
-> TcM (DataDefnCons DataCon)
tcConDecls DataDeclInfo
dd_info TyCon
rep_tycon [TyConBinder]
tmpl_bndrs Type
res_kind
= Name
-> (NewOrData -> LConDecl GhcRn -> TcM (NonEmpty DataCon))
-> DataDefnCons (LConDecl GhcRn)
-> TcM (DataDefnCons DataCon)
forall a b.
Name
-> (NewOrData -> a -> TcM (NonEmpty b))
-> DataDefnCons a
-> TcM (DataDefnCons b)
concatMapDataDefnConsTcM (TyCon -> Name
tyConName TyCon
rep_tycon) ((NewOrData -> LConDecl GhcRn -> TcM (NonEmpty DataCon))
-> DataDefnCons (LConDecl GhcRn) -> TcM (DataDefnCons DataCon))
-> (NewOrData -> LConDecl GhcRn -> TcM (NonEmpty DataCon))
-> DataDefnCons (LConDecl GhcRn)
-> TcM (DataDefnCons DataCon)
forall a b. (a -> b) -> a -> b
$ \ NewOrData
new_or_data ->
(ConDecl GhcRn -> TcM (NonEmpty DataCon))
-> GenLocated SrcSpanAnnA (ConDecl GhcRn) -> TcM (NonEmpty DataCon)
forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM ((ConDecl GhcRn -> TcM (NonEmpty DataCon))
-> GenLocated SrcSpanAnnA (ConDecl GhcRn)
-> TcM (NonEmpty DataCon))
-> (ConDecl GhcRn -> TcM (NonEmpty DataCon))
-> GenLocated SrcSpanAnnA (ConDecl GhcRn)
-> TcM (NonEmpty DataCon)
forall a b. (a -> b) -> a -> b
$ NewOrData
-> DataDeclInfo
-> TyCon
-> [TyConBinder]
-> Type
-> NameEnv Int
-> ConDecl GhcRn
-> TcM (NonEmpty DataCon)
tcConDecl NewOrData
new_or_data DataDeclInfo
dd_info TyCon
rep_tycon [TyConBinder]
tmpl_bndrs Type
res_kind (TyCon -> NameEnv Int
mkTyConTagMap TyCon
rep_tycon)
concatMapDataDefnConsTcM :: Name -> (NewOrData -> a -> TcM (NonEmpty b)) -> DataDefnCons a -> TcM (DataDefnCons b)
concatMapDataDefnConsTcM :: forall a b.
Name
-> (NewOrData -> a -> TcM (NonEmpty b))
-> DataDefnCons a
-> TcM (DataDefnCons b)
concatMapDataDefnConsTcM Name
name NewOrData -> a -> TcM (NonEmpty b)
f = \ case
NewTypeCon a
a -> NewOrData -> a -> TcM (NonEmpty b)
f NewOrData
NewType a
a TcM (NonEmpty b)
-> (NonEmpty b -> TcM (DataDefnCons b)) -> TcM (DataDefnCons b)
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> (a -> IOEnv (Env TcGblEnv TcLclEnv) b)
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
b
b:|[] -> DataDefnCons b -> TcM (DataDefnCons b)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> DataDefnCons b
forall a. a -> DataDefnCons a
NewTypeCon b
b)
NonEmpty b
bs -> TcRnMessage -> TcM (DataDefnCons b)
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM (DataDefnCons b))
-> TcRnMessage -> TcM (DataDefnCons b)
forall a b. (a -> b) -> a -> b
$ Name -> Int -> TcRnMessage
TcRnMultipleConForNewtype Name
name (NonEmpty b -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty b
bs)
DataTypeCons Bool
is_type_data [a]
as -> Bool -> [b] -> DataDefnCons b
forall a. Bool -> [a] -> DataDefnCons a
DataTypeCons Bool
is_type_data ([b] -> DataDefnCons b)
-> IOEnv (Env TcGblEnv TcLclEnv) [b] -> TcM (DataDefnCons b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> IOEnv (Env TcGblEnv TcLclEnv) [b])
-> [a] -> IOEnv (Env TcGblEnv TcLclEnv) [b]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM ((NonEmpty b -> [b])
-> TcM (NonEmpty b) -> IOEnv (Env TcGblEnv TcLclEnv) [b]
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty b -> [b]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (TcM (NonEmpty b) -> IOEnv (Env TcGblEnv TcLclEnv) [b])
-> (a -> TcM (NonEmpty b))
-> a
-> IOEnv (Env TcGblEnv TcLclEnv) [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewOrData -> a -> TcM (NonEmpty b)
f NewOrData
DataType) [a]
as
tcConDecl :: NewOrData
-> DataDeclInfo
-> KnotTied TyCon
-> [TcTyConBinder]
-> TcKind
-> NameEnv ConTag
-> ConDecl GhcRn
-> TcM (NonEmpty DataCon)
tcConDecl :: NewOrData
-> DataDeclInfo
-> TyCon
-> [TyConBinder]
-> Type
-> NameEnv Int
-> ConDecl GhcRn
-> TcM (NonEmpty DataCon)
tcConDecl NewOrData
new_or_data DataDeclInfo
dd_info TyCon
rep_tycon [TyConBinder]
tc_bndrs Type
res_kind NameEnv Int
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 })
= SDoc -> TcM (NonEmpty DataCon) -> TcM (NonEmpty DataCon)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (NonEmpty (LocatedN Name) -> SDoc
dataConCtxt (LocatedN Name -> NonEmpty (LocatedN Name)
forall a. a -> NonEmpty a
NE.singleton LIdP GhcRn
LocatedN Name
lname)) (TcM (NonEmpty DataCon) -> TcM (NonEmpty DataCon))
-> TcM (NonEmpty DataCon) -> TcM (NonEmpty DataCon)
forall a b. (a -> b) -> a -> b
$
do {
; String -> SDoc -> TcRn ()
traceTc String
"tcConDecl 1" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"explicit_tkv_nms" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr Specificity GhcRn]
[GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)]
explicit_tkv_nms
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tc_bndrs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
tc_bndrs ])
; skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (TyVarBndrs -> SkolemInfoAnon
ForAllSkol ([HsTyVarBndr Specificity GhcRn] -> TyVarBndrs
forall flag.
OutputableBndrFlag flag 'Renamed =>
[HsTyVarBndr flag GhcRn] -> TyVarBndrs
HsTyVarBndrsRn (GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)
-> HsTyVarBndr Specificity GhcRn
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)
-> HsTyVarBndr Specificity GhcRn)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)]
-> [HsTyVarBndr Specificity GhcRn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsTyVarBndr Specificity GhcRn]
[GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)]
explicit_tkv_nms)))
; (tclvl, wanted, (exp_tvbndrs, (ctxt, arg_tys, field_lbls, stricts)))
<- pushLevelAndSolveEqualitiesX "tcConDecl:H98" $
tcExplicitTKBndrs skol_info explicit_tkv_nms $
do { ctxt <- tcHsContext hs_ctxt
; let exp_kind = NewOrData -> Type -> ContextKind
getArgExpKind NewOrData
new_or_data Type
res_kind
; btys <- tcConH98Args exp_kind hs_args
; field_lbls <- lookupConstructorFields name
; let (arg_tys, stricts) = unzip btys
; return (ctxt, arg_tys, field_lbls, stricts)
}
; let tc_tvs = [TyConBinder] -> [Var]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tc_bndrs
fake_ty = [Var] -> Type -> Type
mkSpecForAllTys [Var]
tc_tvs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[VarBndr Var Specificity] -> Type -> Type
mkInvisForAllTys [VarBndr Var Specificity]
exp_tvbndrs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
ThetaType -> Type -> Type
HasDebugCallStack => ThetaType -> Type -> Type
tcMkPhiTy ThetaType
ctxt (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Scaled Type] -> Type -> Type
tcMkScaledFunTys [Scaled Type]
arg_tys (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type
unitTy
; kvs <- kindGeneralizeAll skol_info fake_ty
; let all_skol_tvs = [Var]
tc_tvs [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
kvs
; reportUnsolvedEqualities skol_info all_skol_tvs tclvl wanted
; (tc_bndrs, kvs, exp_tvbndrs, arg_tys, ctxt) <- initZonkEnv NoFlexi $
runZonkBndrT (zonkTyVarBindersX tc_bndrs ) $ \ [TyConBinder]
tc_bndrs ->
ZonkBndrT (IOEnv (Env TcGblEnv TcLclEnv)) [Var]
-> forall r.
([Var] -> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) r)
-> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ([Var] -> ZonkBndrT (IOEnv (Env TcGblEnv TcLclEnv)) [Var]
zonkTyBndrsX [Var]
kvs ) (([Var]
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([TyConBinder], [Var], [VarBndr Var Specificity], [Scaled Type],
ThetaType))
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([TyConBinder], [Var], [VarBndr Var Specificity], [Scaled Type],
ThetaType))
-> ([Var]
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([TyConBinder], [Var], [VarBndr Var Specificity], [Scaled Type],
ThetaType))
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([TyConBinder], [Var], [VarBndr Var Specificity], [Scaled Type],
ThetaType)
forall a b. (a -> b) -> a -> b
$ \ [Var]
kvs ->
ZonkBndrT (IOEnv (Env TcGblEnv TcLclEnv)) [VarBndr Var Specificity]
-> forall r.
([VarBndr Var Specificity]
-> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) r)
-> ZonkT (IOEnv (Env TcGblEnv TcLclEnv)) r
forall (m :: * -> *) a.
ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r
runZonkBndrT ([VarBndr Var Specificity]
-> ZonkBndrT
(IOEnv (Env TcGblEnv TcLclEnv)) [VarBndr Var Specificity]
forall vis. [VarBndr Var vis] -> ZonkBndrTcM [VarBndr Var vis]
zonkTyVarBindersX [VarBndr Var Specificity]
exp_tvbndrs) (([VarBndr Var Specificity]
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([TyConBinder], [Var], [VarBndr Var Specificity], [Scaled Type],
ThetaType))
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([TyConBinder], [Var], [VarBndr Var Specificity], [Scaled Type],
ThetaType))
-> ([VarBndr Var Specificity]
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([TyConBinder], [Var], [VarBndr Var Specificity], [Scaled Type],
ThetaType))
-> ZonkT
(IOEnv (Env TcGblEnv TcLclEnv))
([TyConBinder], [Var], [VarBndr Var Specificity], [Scaled Type],
ThetaType)
forall a b. (a -> b) -> a -> b
$ \ [VarBndr Var Specificity]
exp_tvbndrs ->
do { arg_tys <- [Scaled Type] -> ZonkTcM [Scaled Type]
zonkScaledTcTypesToTypesX [Scaled Type]
arg_tys
; ctxt <- zonkTcTypesToTypesX ctxt
; return (tc_bndrs, kvs, exp_tvbndrs, arg_tys, ctxt) }
; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls)
; let univ_tvbs = [TyConBinder] -> [VarBndr Var Specificity]
tyConInvisTVBinders [TyConBinder]
tc_bndrs
ex_tvbs = Specificity -> [Var] -> [VarBndr Var Specificity]
forall vis. vis -> [Var] -> [VarBndr Var vis]
mkTyVarBinders Specificity
InferredSpec [Var]
kvs [VarBndr Var Specificity]
-> [VarBndr Var Specificity] -> [VarBndr Var Specificity]
forall a. [a] -> [a] -> [a]
++ [VarBndr Var Specificity]
exp_tvbndrs
ex_tvs = [VarBndr Var Specificity] -> [Var]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Var Specificity]
ex_tvbs
user_tvbs = [VarBndr Var Specificity]
univ_tvbs [VarBndr Var Specificity]
-> [VarBndr Var Specificity] -> [VarBndr Var Specificity]
forall a. [a] -> [a] -> [a]
++ [VarBndr Var Specificity]
ex_tvbs
user_res_ty = DataDeclInfo -> TyCon -> [TyConBinder] -> Type
mkDDHeaderTy DataDeclInfo
dd_info TyCon
rep_tycon [TyConBinder]
tc_bndrs
; traceTc "tcConDecl 2" (ppr name)
; is_infix <- tcConIsInfixH98 name hs_args
; rep_nm <- newTyConRepName name
; fam_envs <- tcGetFamInstEnvs
; dflags <- getDynFlags
; let bang_opts = BangOpts -> DataConBangOpts
SrcBangOpts (DynFlags -> BangOpts
initBangOpts DynFlags
dflags)
; dc <- buildDataCon fam_envs bang_opts name is_infix rep_nm
stricts field_lbls
tc_tvs ex_tvs user_tvbs
[] ctxt arg_tys
user_res_ty rep_tycon tag_map
; return (NE.singleton dc) }
tcConDecl NewOrData
new_or_data DataDeclInfo
dd_info TyCon
rep_tycon [TyConBinder]
tc_bndrs Type
_res_kind NameEnv Int
tag_map
(ConDeclGADT { con_names :: forall pass. ConDecl pass -> NonEmpty (LIdP pass)
con_names = NonEmpty (LIdP GhcRn)
names
, con_bndrs :: forall pass. ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)
con_bndrs = L SrcSpanAnnA
_ HsOuterSigTyVarBndrs GhcRn
outer_hs_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
hs_args
, con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_res_ty = LHsKind GhcRn
hs_res_ty })
= SDoc -> TcM (NonEmpty DataCon) -> TcM (NonEmpty DataCon)
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (NonEmpty (LocatedN Name) -> SDoc
dataConCtxt NonEmpty (LIdP GhcRn)
NonEmpty (LocatedN Name)
names) (TcM (NonEmpty DataCon) -> TcM (NonEmpty DataCon))
-> TcM (NonEmpty DataCon) -> TcM (NonEmpty DataCon)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcConDecl 1 gadt" (NonEmpty (LocatedN Name) -> SDoc
forall a. Outputable a => a -> SDoc
ppr NonEmpty (LIdP GhcRn)
NonEmpty (LocatedN Name)
names)
; let L SrcSpanAnnN
_ Name
name :| [LIdP GhcRn]
_ = NonEmpty (LIdP GhcRn)
names
; skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (Name -> SkolemInfoAnon
DataConSkol Name
name)
; (tclvl, wanted, (outer_bndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts)))
<- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $
tcOuterTKBndrs skol_info outer_hs_bndrs $
do { ctxt <- tcHsContext cxt
; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty
; case dd_info of
DataDeclInfo
DDataType -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
DDataInstance Type
hdr_ty ->
do { (subst, _meta_tvs) <- [Var] -> TcM (Subst, [Var])
newMetaTyVars ([TyConBinder] -> [Var]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tc_bndrs)
; let head_shape = HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
subst Type
hdr_ty
; discardResult $
popErrCtxt $
addErrCtxt (dataConResCtxt names) $
unifyType Nothing res_ty head_shape }
; let exp_kind = NewOrData -> Type -> ContextKind
getArgExpKind NewOrData
new_or_data Type
res_kind
; btys <- tcConGADTArgs exp_kind hs_args
; let (arg_tys, stricts) = unzip btys
; field_lbls <- lookupConstructorFields name
; return (ctxt, arg_tys, res_ty, field_lbls, stricts)
}
; outer_bndrs <- scopedSortOuter outer_bndrs
; let outer_tv_bndrs = HsOuterSigTyVarBndrs GhcTc -> [VarBndr Var Specificity]
outerTyVarBndrs HsOuterSigTyVarBndrs GhcTc
outer_bndrs
; tkvs <- kindGeneralizeAll skol_info
(mkInvisForAllTys outer_tv_bndrs $
tcMkPhiTy ctxt $
tcMkScaledFunTys arg_tys $
res_ty)
; traceTc "tcConDecl:GADT" (ppr names $$ ppr res_ty $$ ppr tkvs)
; reportUnsolvedEqualities skol_info tkvs tclvl wanted
; let tvbndrs = Specificity -> [Var] -> [VarBndr Var Specificity]
forall vis. vis -> [Var] -> [VarBndr Var vis]
mkTyVarBinders Specificity
InferredSpec [Var]
tkvs [VarBndr Var Specificity]
-> [VarBndr Var Specificity] -> [VarBndr Var Specificity]
forall a. [a] -> [a] -> [a]
++ [VarBndr Var Specificity]
outer_tv_bndrs
; (tvbndrs, arg_tys, ctxt, res_ty) <- initZonkEnv NoFlexi $
runZonkBndrT (zonkTyVarBindersX tvbndrs) $ \ [VarBndr Var Specificity]
tvbndrs ->
do { arg_tys <- [Scaled Type] -> ZonkTcM [Scaled Type]
zonkScaledTcTypesToTypesX [Scaled Type]
arg_tys
; ctxt <- zonkTcTypesToTypesX ctxt
; res_ty <- zonkTcTypeToTypeX res_ty
; return (tvbndrs, arg_tys, ctxt, res_ty) }
; let res_tmpl = DataDeclInfo -> TyCon -> [TyConBinder] -> Type
mkDDHeaderTy DataDeclInfo
dd_info TyCon
rep_tycon [TyConBinder]
tc_bndrs
(univ_tvs, ex_tvs, tvbndrs', eq_preds, arg_subst)
= rejigConRes tc_bndrs res_tmpl tvbndrs res_ty
ctxt' = HasDebugCallStack => Subst -> ThetaType -> ThetaType
Subst -> ThetaType -> ThetaType
substTys Subst
arg_subst ThetaType
ctxt
arg_tys' = HasDebugCallStack => Subst -> [Scaled Type] -> [Scaled Type]
Subst -> [Scaled Type] -> [Scaled Type]
substScaledTys Subst
arg_subst [Scaled Type]
arg_tys
res_ty' = HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
arg_subst Type
res_ty
; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)
; fam_envs <- tcGetFamInstEnvs
; dflags <- getDynFlags
; let
buildOneDataCon (L SrcSpanAnnN
_ Name
name) = do
{ is_infix <- Name -> HsConDeclGADTDetails GhcRn -> TcRnIf TcGblEnv TcLclEnv Bool
tcConIsInfixGADT Name
name HsConDeclGADTDetails GhcRn
hs_args
; rep_nm <- newTyConRepName name
; let bang_opts = BangOpts -> DataConBangOpts
SrcBangOpts (DynFlags -> BangOpts
initBangOpts DynFlags
dflags)
; buildDataCon fam_envs bang_opts name is_infix
rep_nm stricts field_lbls
univ_tvs ex_tvs tvbndrs' eq_preds
ctxt' arg_tys' res_ty' rep_tycon tag_map
}
; mapM buildOneDataCon names }
getArgExpKind :: NewOrData -> TcKind -> ContextKind
getArgExpKind :: NewOrData -> Type -> ContextKind
getArgExpKind NewOrData
NewType Type
res_ki = Type -> ContextKind
TheKind Type
res_ki
getArgExpKind NewOrData
DataType Type
_ = ContextKind
OpenKind
tcConIsInfixH98 :: Name
-> HsConDeclH98Details GhcRn
-> TcM Bool
tcConIsInfixH98 :: Name -> HsConDeclH98Details GhcRn -> TcRnIf TcGblEnv TcLclEnv Bool
tcConIsInfixH98 Name
_ HsConDeclH98Details GhcRn
details
= case HsConDeclH98Details GhcRn
details of
InfixCon{} -> Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
RecCon{} -> Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
PrefixCon{} -> Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
tcConIsInfixGADT :: Name
-> HsConDeclGADTDetails GhcRn
-> TcM Bool
tcConIsInfixGADT :: Name -> HsConDeclGADTDetails GhcRn -> TcRnIf TcGblEnv TcLclEnv Bool
tcConIsInfixGADT Name
con HsConDeclGADTDetails GhcRn
details
= case HsConDeclGADTDetails GhcRn
details of
RecConGADT{} -> Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
PrefixConGADT XPrefixConGADT GhcRn
_ [HsScaled GhcRn (LHsKind GhcRn)]
arg_tys
| OccName -> Bool
isSymOcc (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
con)
, [GenLocated SrcSpanAnnA (HsType GhcRn)
_ty1,GenLocated SrcSpanAnnA (HsType GhcRn)
_ty2] <- (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall pass a. HsScaled pass a -> a
hsScaledThing [HsScaled GhcRn (LHsKind GhcRn)]
[HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
arg_tys
-> do { fix_env <- TcRn FixityEnv
getFixityEnv
; return (con `elemNameEnv` fix_env) }
| Bool
otherwise -> Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
tcConH98Args :: ContextKind
-> HsConDeclH98Details GhcRn
-> TcM [(Scaled TcType, HsSrcBang)]
tcConH98Args :: ContextKind
-> HsConDeclH98Details GhcRn -> TcM [(Scaled Type, HsSrcBang)]
tcConH98Args ContextKind
exp_kind (PrefixCon [Void]
_ [HsScaled GhcRn (LHsKind GhcRn)]
btys)
= (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Type, HsSrcBang))
-> [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
-> TcM [(Scaled Type, HsSrcBang)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ContextKind
-> HsScaled GhcRn (LHsKind GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Type, HsSrcBang)
tcConArg ContextKind
exp_kind) [HsScaled GhcRn (LHsKind GhcRn)]
[HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
btys
tcConH98Args ContextKind
exp_kind (InfixCon HsScaled GhcRn (LHsKind GhcRn)
bty1 HsScaled GhcRn (LHsKind GhcRn)
bty2)
= do { bty1' <- ContextKind
-> HsScaled GhcRn (LHsKind GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Type, HsSrcBang)
tcConArg ContextKind
exp_kind HsScaled GhcRn (LHsKind GhcRn)
bty1
; bty2' <- tcConArg exp_kind bty2
; return [bty1', bty2'] }
tcConH98Args ContextKind
exp_kind (RecCon XRec GhcRn [LConDeclField GhcRn]
fields)
= ContextKind
-> LocatedL [LConDeclField GhcRn] -> TcM [(Scaled Type, HsSrcBang)]
tcRecConDeclFields ContextKind
exp_kind XRec GhcRn [LConDeclField GhcRn]
LocatedL [LConDeclField GhcRn]
fields
tcConGADTArgs :: ContextKind
-> HsConDeclGADTDetails GhcRn
-> TcM [(Scaled TcType, HsSrcBang)]
tcConGADTArgs :: ContextKind
-> HsConDeclGADTDetails GhcRn -> TcM [(Scaled Type, HsSrcBang)]
tcConGADTArgs ContextKind
exp_kind (PrefixConGADT XPrefixConGADT GhcRn
_ [HsScaled GhcRn (LHsKind GhcRn)]
btys)
= (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Type, HsSrcBang))
-> [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
-> TcM [(Scaled Type, HsSrcBang)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ContextKind
-> HsScaled GhcRn (LHsKind GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Type, HsSrcBang)
tcConArg ContextKind
exp_kind) [HsScaled GhcRn (LHsKind GhcRn)]
[HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
btys
tcConGADTArgs ContextKind
exp_kind (RecConGADT XRecConGADT GhcRn
_ XRec GhcRn [LConDeclField GhcRn]
fields)
= ContextKind
-> LocatedL [LConDeclField GhcRn] -> TcM [(Scaled Type, HsSrcBang)]
tcRecConDeclFields ContextKind
exp_kind XRec GhcRn [LConDeclField GhcRn]
LocatedL [LConDeclField GhcRn]
fields
tcConArg :: ContextKind
-> HsScaled GhcRn (LHsType GhcRn) -> TcM (Scaled TcType, HsSrcBang)
tcConArg :: ContextKind
-> HsScaled GhcRn (LHsKind GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Type, HsSrcBang)
tcConArg ContextKind
exp_kind (HsScaled HsArrow GhcRn
w LHsKind GhcRn
bty)
= do { String -> SDoc -> TcRn ()
traceTc String
"tcConArg 1" (GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsKind GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
bty)
; arg_ty <- LHsKind GhcRn -> ContextKind -> IOEnv (Env TcGblEnv TcLclEnv) Type
tcCheckLHsTypeInContext (LHsKind GhcRn -> LHsKind GhcRn
forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p)
getBangType LHsKind GhcRn
bty) ContextKind
exp_kind
; w' <- tcDataConMult w
; traceTc "tcConArg 2" (ppr bty)
; return (Scaled w' arg_ty, getBangStrictness bty) }
tcRecConDeclFields :: ContextKind
-> LocatedL [LConDeclField GhcRn]
-> TcM [(Scaled TcType, HsSrcBang)]
tcRecConDeclFields :: ContextKind
-> LocatedL [LConDeclField GhcRn] -> TcM [(Scaled Type, HsSrcBang)]
tcRecConDeclFields ContextKind
exp_kind LocatedL [LConDeclField GhcRn]
fields
= (HsScaled GhcRn (LHsKind GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Type, HsSrcBang))
-> [HsScaled GhcRn (LHsKind GhcRn)]
-> TcM [(Scaled Type, HsSrcBang)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ContextKind
-> HsScaled GhcRn (LHsKind GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Type, HsSrcBang)
tcConArg ContextKind
exp_kind) [HsScaled GhcRn (LHsKind GhcRn)]
btys
where
combined :: [([XRec GhcRn (FieldOcc GhcRn)], HsScaled GhcRn (LHsKind GhcRn))]
combined = (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> ([XRec GhcRn (FieldOcc GhcRn)], HsScaled GhcRn (LHsKind GhcRn)))
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> [([XRec GhcRn (FieldOcc GhcRn)],
HsScaled GhcRn (LHsKind GhcRn))]
forall a b. (a -> b) -> [a] -> [b]
map (\(L SrcSpanAnnA
_ ConDeclField GhcRn
f) -> (ConDeclField GhcRn -> [XRec GhcRn (FieldOcc GhcRn)]
forall pass. ConDeclField pass -> [LFieldOcc pass]
cd_fld_names ConDeclField GhcRn
f,LHsKind GhcRn -> HsScaled GhcRn (LHsKind GhcRn)
forall (p :: Pass) a. IsPass p => a -> HsScaled (GhcPass p) a
hsLinear (ConDeclField GhcRn -> LHsKind GhcRn
forall pass. ConDeclField pass -> LBangType pass
cd_fld_type ConDeclField GhcRn
f)))
(GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
forall l e. GenLocated l e -> e
unLoc LocatedL [LConDeclField GhcRn]
GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
fields)
explode :: ([a], b) -> [(a, b)]
explode ([a]
ns,b
ty) = [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
ns (b -> [b]
forall a. a -> [a]
repeat b
ty)
exploded :: [(XRec GhcRn (FieldOcc GhcRn), HsScaled GhcRn (LHsKind GhcRn))]
exploded = (([XRec GhcRn (FieldOcc GhcRn)], HsScaled GhcRn (LHsKind GhcRn))
-> [(XRec GhcRn (FieldOcc GhcRn), HsScaled GhcRn (LHsKind GhcRn))])
-> [([XRec GhcRn (FieldOcc GhcRn)],
HsScaled GhcRn (LHsKind GhcRn))]
-> [(XRec GhcRn (FieldOcc GhcRn), HsScaled GhcRn (LHsKind GhcRn))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([XRec GhcRn (FieldOcc GhcRn)], HsScaled GhcRn (LHsKind GhcRn))
-> [(XRec GhcRn (FieldOcc GhcRn), HsScaled GhcRn (LHsKind GhcRn))]
forall {a} {b}. ([a], b) -> [(a, b)]
explode [([XRec GhcRn (FieldOcc GhcRn)], HsScaled GhcRn (LHsKind GhcRn))]
combined
([XRec GhcRn (FieldOcc GhcRn)]
_,[HsScaled GhcRn (LHsKind GhcRn)]
btys) = [(XRec GhcRn (FieldOcc GhcRn), HsScaled GhcRn (LHsKind GhcRn))]
-> ([XRec GhcRn (FieldOcc GhcRn)],
[HsScaled GhcRn (LHsKind GhcRn)])
forall a b. [(a, b)] -> ([a], [b])
unzip [(XRec GhcRn (FieldOcc GhcRn), HsScaled GhcRn (LHsKind GhcRn))]
exploded
tcDataConMult :: HsArrow GhcRn -> TcM Mult
tcDataConMult :: HsArrow GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Type
tcDataConMult arr :: HsArrow GhcRn
arr@(HsUnrestrictedArrow XUnrestrictedArrow (LHsKind GhcRn) GhcRn
_) = do
linearEnabled <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.LinearTypes
if linearEnabled then tcMult arr else return oneDataConTy
tcDataConMult HsArrow GhcRn
arr = HsArrow GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Type
tcMult HsArrow GhcRn
arr
rejigConRes :: [KnotTied TyConBinder]
-> KnotTied Type
-> [InvisTVBinder]
-> KnotTied Type
-> ([TyVar],
[TyVar],
[InvisTVBinder],
[EqSpec],
Subst)
rejigConRes :: [TyConBinder]
-> Type
-> [VarBndr Var Specificity]
-> Type
-> ([Var], [Var], [VarBndr Var Specificity], [EqSpec], Subst)
rejigConRes [TyConBinder]
tc_tvbndrs Type
res_tmpl [VarBndr Var Specificity]
dc_tvbndrs Type
res_ty
| Just Subst
subst <- Type -> Type -> Maybe Subst
tcMatchTy Type
res_tmpl Type
res_ty
= let ([Var]
univ_tvs, [(Var, Type)]
raw_eqs, Subst
kind_subst) = [Var] -> [Var] -> Subst -> ([Var], [(Var, Type)], Subst)
mkGADTVars [Var]
tc_tvs [Var]
dc_tvs Subst
subst
raw_ex_tvs :: [Var]
raw_ex_tvs = [Var]
dc_tvs [Var] -> [Var] -> [Var]
forall a. Ord a => [a] -> [a] -> [a]
`minusList` [Var]
univ_tvs
(Subst
arg_subst, [Var]
substed_ex_tvs) = HasDebugCallStack => Subst -> [Var] -> (Subst, [Var])
Subst -> [Var] -> (Subst, [Var])
substTyVarBndrs Subst
kind_subst [Var]
raw_ex_tvs
subst_user_tvs :: [VarBndr Var Specificity] -> [VarBndr Var Specificity]
subst_user_tvs = (Var -> Var)
-> [VarBndr Var Specificity] -> [VarBndr Var Specificity]
forall var var' flag.
(var -> var') -> [VarBndr var flag] -> [VarBndr var' flag]
mapVarBndrs (HasDebugCallStack => Subst -> Var -> Var
Subst -> Var -> Var
substTyVarToTyVar Subst
arg_subst)
substed_tvbndrs :: [VarBndr Var Specificity]
substed_tvbndrs = [VarBndr Var Specificity] -> [VarBndr Var Specificity]
subst_user_tvs [VarBndr Var Specificity]
dc_tvbndrs
substed_eqs :: [EqSpec]
substed_eqs = [ Var -> Type -> EqSpec
mkEqSpec (HasDebugCallStack => Subst -> Var -> Var
Subst -> Var -> Var
substTyVarToTyVar Subst
arg_subst Var
tv)
(HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
arg_subst Type
ty)
| (Var
tv,Type
ty) <- [(Var, Type)]
raw_eqs ]
in
([Var]
univ_tvs, [Var]
substed_ex_tvs, [VarBndr Var Specificity]
substed_tvbndrs, [EqSpec]
substed_eqs, Subst
arg_subst)
| Bool
otherwise
= ([Var]
tc_tvs, [Var]
dc_tvs [Var] -> [Var] -> [Var]
forall a. Ord a => [a] -> [a] -> [a]
`minusList` [Var]
tc_tvs, [VarBndr Var Specificity]
dc_tvbndrs, [], Subst
emptySubst)
where
dc_tvs :: [Var]
dc_tvs = [VarBndr Var Specificity] -> [Var]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr Var Specificity]
dc_tvbndrs
tc_tvs :: [Var]
tc_tvs = [TyConBinder] -> [Var]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tc_tvbndrs
mkGADTVars :: [TyVar]
-> [TyVar]
-> Subst
-> ( [TyVar]
, [(TyVar,Type)]
, Subst )
mkGADTVars :: [Var] -> [Var] -> Subst -> ([Var], [(Var, Type)], Subst)
mkGADTVars [Var]
tmpl_tvs [Var]
dc_tvs Subst
subst
= [Var]
-> [(Var, Type)]
-> Subst
-> Subst
-> [Var]
-> ([Var], [(Var, Type)], Subst)
choose [] [] Subst
empty_subst Subst
empty_subst [Var]
tmpl_tvs
where
in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet ([Var] -> VarSet
mkVarSet [Var]
tmpl_tvs VarSet -> VarSet -> VarSet
`unionVarSet` [Var] -> VarSet
mkVarSet [Var]
dc_tvs)
InScopeSet -> InScopeSet -> InScopeSet
`unionInScope` Subst -> InScopeSet
getSubstInScope Subst
subst
empty_subst :: Subst
empty_subst = InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope
choose :: [TyVar]
-> [(TyVar,Type)]
-> Subst
-> Subst
-> [TyVar]
-> ( [TyVar]
, [(TyVar,Type)]
, Subst )
choose :: [Var]
-> [(Var, Type)]
-> Subst
-> Subst
-> [Var]
-> ([Var], [(Var, Type)], Subst)
choose [Var]
univs [(Var, Type)]
eqs Subst
_t_sub Subst
r_sub []
= ([Var] -> [Var]
forall a. [a] -> [a]
reverse [Var]
univs, [(Var, Type)] -> [(Var, Type)]
forall a. [a] -> [a]
reverse [(Var, Type)]
eqs, Subst
r_sub)
choose [Var]
univs [(Var, Type)]
eqs Subst
t_sub Subst
r_sub (Var
t_tv:[Var]
t_tvs)
| Just Type
r_ty <- Subst -> Var -> Maybe Type
lookupTyVar Subst
subst Var
t_tv
= case Type -> Maybe Var
getTyVar_maybe Type
r_ty of
Just Var
r_tv
| Bool -> Bool
not (Var
r_tv Var -> [Var] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Var]
univs)
, Var -> Type
tyVarKind Var
r_tv HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
t_sub (Var -> Type
tyVarKind Var
t_tv))
->
[Var]
-> [(Var, Type)]
-> Subst
-> Subst
-> [Var]
-> ([Var], [(Var, Type)], Subst)
choose (Var
r_tvVar -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
univs) [(Var, Type)]
eqs
(Subst -> Var -> Type -> Subst
extendTvSubst Subst
t_sub Var
t_tv Type
r_ty')
(Subst -> Var -> Type -> Subst
extendTvSubst Subst
r_sub Var
r_tv Type
r_ty')
[Var]
t_tvs
where
r_tv1 :: Var
r_tv1 = Var -> Name -> Var
setTyVarName Var
r_tv (Var -> Var -> Name
choose_tv_name Var
r_tv Var
t_tv)
r_ty' :: Type
r_ty' = Var -> Type
mkTyVarTy Var
r_tv1
Maybe Var
_ -> [Var]
-> [(Var, Type)]
-> Subst
-> Subst
-> [Var]
-> ([Var], [(Var, Type)], Subst)
choose (Var
t_tv'Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
univs) [(Var, Type)]
eqs'
(Subst -> Var -> Type -> Subst
extendTvSubst Subst
t_sub Var
t_tv (Var -> Type
mkTyVarTy Var
t_tv'))
Subst
r_sub [Var]
t_tvs
where
tv_kind :: Type
tv_kind = Var -> Type
tyVarKind Var
t_tv
tv_kind' :: Type
tv_kind' = HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
t_sub Type
tv_kind
t_tv' :: Var
t_tv' = Var -> Type -> Var
setTyVarKind Var
t_tv Type
tv_kind'
eqs' :: [(Var, Type)]
eqs' = (Var
t_tv', Type
r_ty) (Var, Type) -> [(Var, Type)] -> [(Var, Type)]
forall a. a -> [a] -> [a]
: [(Var, Type)]
eqs
| Bool
otherwise
= [Var]
-> [(Var, Type)]
-> Subst
-> Subst
-> [Var]
-> ([Var], [(Var, Type)], Subst)
choose (Var
t_tvVar -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
univs) [(Var, Type)]
eqs Subst
t_sub Subst
r_sub [Var]
t_tvs
choose_tv_name :: TyVar -> TyVar -> Name
choose_tv_name :: Var -> Var -> Name
choose_tv_name Var
r_tv Var
t_tv
| Name -> Bool
isSystemName Name
r_tv_name
= Name -> Unique -> Name
setNameUnique Name
t_tv_name (Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique Name
r_tv_name)
| Bool
otherwise
= Name
r_tv_name
where
r_tv_name :: Name
r_tv_name = Var -> Name
forall a. NamedThing a => a -> Name
getName Var
r_tv
t_tv_name :: Name
t_tv_name = Var -> Name
forall a. NamedThing a => a -> Name
getName Var
t_tv
checkValidTyCl :: TyCon -> TcM [TyCon]
checkValidTyCl :: TyCon -> TcM [TyCon]
checkValidTyCl TyCon
tc
= SrcSpan -> TcM [TyCon] -> TcM [TyCon]
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (TyCon -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyCon
tc) (TcM [TyCon] -> TcM [TyCon]) -> TcM [TyCon] -> TcM [TyCon]
forall a b. (a -> b) -> a -> b
$
TyCon -> TcM [TyCon] -> TcM [TyCon]
forall a. TyCon -> TcM a -> TcM a
addTyConCtxt TyCon
tc (TcM [TyCon] -> TcM [TyCon]) -> TcM [TyCon] -> TcM [TyCon]
forall a b. (a -> b) -> a -> b
$
TcM [TyCon] -> TcM [TyCon] -> TcM [TyCon]
forall r. TcRn r -> TcRn r -> TcRn r
recoverM TcM [TyCon]
recovery_code (TcM [TyCon] -> TcM [TyCon]) -> TcM [TyCon] -> TcM [TyCon]
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"Starting validity for tycon" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; TyCon -> TcRn ()
checkValidTyCon TyCon
tc
; TyCon -> TcRn ()
checkTyConConsistentWithBoot TyCon
tc
; String -> SDoc -> TcRn ()
traceTc String
"Done validity for tycon" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; [TyCon] -> TcM [TyCon]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon
tc] }
where
recovery_code :: TcM [TyCon]
recovery_code
= do { String -> SDoc -> TcRn ()
traceTc String
"Aborted validity for tycon" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; [TyCon] -> TcM [TyCon]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TyCon -> TyCon) -> [TyCon] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map TyCon -> TyCon
mk_fake_tc ([TyCon] -> [TyCon]) -> [TyCon] -> [TyCon]
forall a b. (a -> b) -> a -> b
$
TyCon
tc TyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
: TyCon -> [TyCon]
child_tycons TyCon
tc) }
mk_fake_tc :: TyCon -> TyCon
mk_fake_tc TyCon
tc
| TyCon -> Bool
isClassTyCon TyCon
tc = TyCon
tc
| Bool
otherwise = TyCon -> TyCon
makeRecoveryTyCon TyCon
tc
child_tycons :: TyCon -> [TyCon]
child_tycons TyCon
tc = TyCon -> [TyCon]
tyConATs TyCon
tc [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ (DataCon -> TyCon) -> [DataCon] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> TyCon
promoteDataCon (TyCon -> [DataCon]
tyConDataCons TyCon
tc)
checkTyConConsistentWithBoot :: TyCon -> TcM ()
checkTyConConsistentWithBoot :: TyCon -> TcRn ()
checkTyConConsistentWithBoot TyCon
tc =
do { gbl_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let name = TyCon -> Name
tyConName TyCon
tc
real_thing = TyCon -> TyThing
ATyCon TyCon
tc
boot_info = TcGblEnv -> SelfBootInfo
tcg_self_boot TcGblEnv
gbl_env
boot_type_env = case SelfBootInfo
boot_info of
SelfBootInfo
NoSelfBoot -> TypeEnv
emptyTypeEnv
SelfBoot ModDetails
boot_details -> ModDetails -> TypeEnv
md_types ModDetails
boot_details
m_boot_info = TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv TypeEnv
boot_type_env Name
name
; case m_boot_info of
Maybe TyThing
Nothing -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just TyThing
boot_thing -> HsBootOrSig -> TyThing -> TyThing -> TcRn ()
checkBootDeclM HsBootOrSig
HsBoot TyThing
boot_thing TyThing
real_thing
}
checkValidTyCon :: TyCon -> TcM ()
checkValidTyCon :: TyCon -> TcRn ()
checkValidTyCon TyCon
tc
| TyCon -> Bool
isPrimTyCon TyCon
tc
= () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| TyCon -> Bool
forall thing. NamedThing thing => thing -> Bool
isWiredIn TyCon
tc
= String -> SDoc -> TcRn ()
traceTc String
"Skipping validity check for wired-in" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
| Bool
otherwise
= do { String -> SDoc -> TcRn ()
traceTc String
"checkValidTyCon" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Maybe Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Maybe Class
tyConClass_maybe TyCon
tc))
; if | Just Class
cl <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc
-> Class -> TcRn ()
checkValidClass Class
cl
| Just Type
syn_rhs <- TyCon -> Maybe Type
synTyConRhs_maybe TyCon
tc
-> do { UserTypeCtxt -> Type -> TcRn ()
checkValidType UserTypeCtxt
syn_ctxt Type
syn_rhs
; UserTypeCtxt -> Type -> TcRn ()
checkTySynRhs UserTypeCtxt
syn_ctxt Type
syn_rhs }
| Just FamTyConFlav
fam_flav <- TyCon -> Maybe FamTyConFlav
famTyConFlav_maybe TyCon
tc
-> case FamTyConFlav
fam_flav of
{ ClosedSynFamilyTyCon (Just CoAxiom Branched
ax)
-> TyCon -> TcRn () -> TcRn ()
forall a. TyCon -> TcM a -> TcM a
tcAddClosedTypeFamilyDeclCtxt TyCon
tc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
CoAxiom Branched -> TcRn ()
checkValidCoAxiom CoAxiom Branched
ax
; ClosedSynFamilyTyCon Maybe (CoAxiom Branched)
Nothing -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; FamTyConFlav
AbstractClosedSynFamilyTyCon ->
do { hsBoot <- TcRnIf TcGblEnv TcLclEnv Bool
tcIsHsBootOrSig
; checkTc hsBoot $ TcRnAbstractClosedTyFamDecl }
; DataFamilyTyCon {} -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; FamTyConFlav
OpenSynFamilyTyCon -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; BuiltInSynFamTyCon BuiltInSynFamily
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return () }
| Bool
otherwise -> do
{
String -> SDoc -> TcRn ()
traceTc String
"cvtc1" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; UserTypeCtxt -> ThetaType -> TcRn ()
checkValidTheta (Name -> UserTypeCtxt
DataTyCtxt Name
name) (TyCon -> ThetaType
tyConStupidTheta TyCon
tc)
; String -> SDoc -> TcRn ()
traceTc String
"cvtc2" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; existential_ok <- xoptM LangExt.ExistentialQuantification
; gadt_ok <- xoptM LangExt.GADTs
; let ex_ok = Bool
existential_ok Bool -> Bool -> Bool
|| Bool
gadt_ok
; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons
; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc)
; mapM_ check_fields groups }}
where
syn_ctxt :: UserTypeCtxt
syn_ctxt = Name -> UserTypeCtxt
TySynCtxt Name
name
name :: Name
name = TyCon -> Name
tyConName TyCon
tc
data_cons :: [DataCon]
data_cons = TyCon -> [DataCon]
tyConDataCons TyCon
tc
groups :: [NonEmpty (FieldLabel, DataCon)]
groups = ((FieldLabel, DataCon) -> (FieldLabel, DataCon) -> Ordering)
-> [(FieldLabel, DataCon)] -> [NonEmpty (FieldLabel, DataCon)]
forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a]
equivClasses (FieldLabel, DataCon) -> (FieldLabel, DataCon) -> Ordering
forall {b} {b}. (FieldLabel, b) -> (FieldLabel, b) -> Ordering
cmp_fld ((DataCon -> [(FieldLabel, DataCon)])
-> [DataCon] -> [(FieldLabel, DataCon)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DataCon -> [(FieldLabel, DataCon)]
get_fields [DataCon]
data_cons)
cmp_fld :: (FieldLabel, b) -> (FieldLabel, b) -> Ordering
cmp_fld (FieldLabel
f1,b
_) (FieldLabel
f2,b
_) = FieldLabelString -> FastString
field_label (FieldLabel -> FieldLabelString
flLabel FieldLabel
f1) FastString -> FastString -> Ordering
`uniqCompareFS` FieldLabelString -> FastString
field_label (FieldLabel -> FieldLabelString
flLabel FieldLabel
f2)
get_fields :: DataCon -> [(FieldLabel, DataCon)]
get_fields DataCon
con = DataCon -> [FieldLabel]
dataConFieldLabels DataCon
con [FieldLabel] -> [DataCon] -> [(FieldLabel, DataCon)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` DataCon -> [DataCon]
forall a. a -> [a]
repeat DataCon
con
check_fields :: NonEmpty (FieldLabel, DataCon) -> TcRn ()
check_fields ((FieldLabel
label, DataCon
con1) :| [(FieldLabel, DataCon)]
other_fields)
= TcRn () -> TcRn () -> TcRn ()
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (() -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ ((FieldLabel, DataCon) -> TcRn ())
-> [(FieldLabel, DataCon)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FieldLabel, DataCon) -> TcRn ()
checkOne [(FieldLabel, DataCon)]
other_fields
where
res1 :: Type
res1 = DataCon -> Type
dataConOrigResTy DataCon
con1
fty1 :: Type
fty1 = DataCon -> FieldLabelString -> Type
dataConFieldType DataCon
con1 FieldLabelString
lbl
lbl :: FieldLabelString
lbl = FieldLabel -> FieldLabelString
flLabel FieldLabel
label
checkOne :: (FieldLabel, DataCon) -> TcRn ()
checkOne (FieldLabel
_, DataCon
con2)
= do { FieldLabelString
-> DataCon -> DataCon -> Type -> Type -> Type -> Type -> TcRn ()
checkFieldCompat FieldLabelString
lbl DataCon
con1 DataCon
con2 Type
res1 Type
res2 Type
fty1 Type
fty2
; FieldLabelString
-> DataCon -> DataCon -> Type -> Type -> Type -> Type -> TcRn ()
checkFieldCompat FieldLabelString
lbl DataCon
con2 DataCon
con1 Type
res2 Type
res1 Type
fty2 Type
fty1 }
where
res2 :: Type
res2 = DataCon -> Type
dataConOrigResTy DataCon
con2
fty2 :: Type
fty2 = DataCon -> FieldLabelString -> Type
dataConFieldType DataCon
con2 FieldLabelString
lbl
checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM ()
checkPartialRecordField :: [DataCon] -> FieldLabel -> TcRn ()
checkPartialRecordField [DataCon]
all_cons FieldLabel
fld
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Bool -> TcRnMessage -> TcRn ()
warnIf (Bool -> Bool
not Bool
is_exhaustive Bool -> Bool -> Bool
&& Bool -> Bool
not (OccName -> Bool
startsWithUnderscore OccName
occ_name))
(FieldLabel -> TcRnMessage
TcRnPartialFieldSelector FieldLabel
fld)
where
sel :: Name
sel = FieldLabel -> Name
flSelector FieldLabel
fld
loc :: SrcSpan
loc = Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
sel
occ_name :: OccName
occ_name = Name -> OccName
nameOccName Name
sel
([DataCon]
cons_with_field, [DataCon]
cons_without_field) = (DataCon -> Bool) -> [DataCon] -> ([DataCon], [DataCon])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition DataCon -> Bool
has_field [DataCon]
all_cons
has_field :: DataCon -> Bool
has_field DataCon
con = FieldLabel
fld FieldLabel -> [FieldLabel] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (DataCon -> [FieldLabel]
dataConFieldLabels DataCon
con)
is_exhaustive :: Bool
is_exhaustive = (DataCon -> Bool) -> [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ThetaType -> DataCon -> Bool
dataConCannotMatch ThetaType
inst_tys) [DataCon]
cons_without_field
con1 :: DataCon
con1 = Bool -> DataCon -> DataCon
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([DataCon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
cons_with_field)) (DataCon -> DataCon) -> DataCon -> DataCon
forall a b. (a -> b) -> a -> b
$ [DataCon] -> DataCon
forall a. HasCallStack => [a] -> a
head [DataCon]
cons_with_field
inst_tys :: ThetaType
inst_tys = DataCon -> ThetaType
dataConResRepTyArgs DataCon
con1
checkFieldCompat :: FieldLabelString -> DataCon -> DataCon
-> Type -> Type -> Type -> Type -> TcM ()
checkFieldCompat :: FieldLabelString
-> DataCon -> DataCon -> Type -> Type -> Type -> Type -> TcRn ()
checkFieldCompat FieldLabelString
fld DataCon
con1 DataCon
con2 Type
res1 Type
res2 Type
fty1 Type
fty2
= do { Bool -> TcRnMessage -> TcRn ()
checkTc (Maybe Subst -> Bool
forall a. Maybe a -> Bool
isJust Maybe Subst
mb_subst1) (DataCon -> DataCon -> FieldLabelString -> TcRnMessage
TcRnCommonFieldResultTypeMismatch DataCon
con1 DataCon
con2 FieldLabelString
fld)
; Bool -> TcRnMessage -> TcRn ()
checkTc (Maybe Subst -> Bool
forall a. Maybe a -> Bool
isJust Maybe Subst
mb_subst2) (DataCon -> DataCon -> FieldLabelString -> TcRnMessage
TcRnCommonFieldTypeMismatch DataCon
con1 DataCon
con2 FieldLabelString
fld) }
where
mb_subst1 :: Maybe Subst
mb_subst1 = Type -> Type -> Maybe Subst
tcMatchTy Type
res1 Type
res2
mb_subst2 :: Maybe Subst
mb_subst2 = Subst -> Type -> Type -> Maybe Subst
tcMatchTyX (String -> Maybe Subst -> Subst
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"checkFieldCompat" Maybe Subst
mb_subst1) Type
fty1 Type
fty2
checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM ()
checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcRn ()
checkValidDataCon DynFlags
dflags Bool
existential_ok TyCon
tc DataCon
con
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
con_loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn () -> TcRn ()
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (NonEmpty (LocatedN Name) -> SDoc
dataConCtxt (LocatedN Name -> NonEmpty (LocatedN Name)
forall a. a -> NonEmpty a
NE.singleton (SrcSpanAnnN -> Name -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
con_loc) Name
con_name))) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do { let tc_tvs :: [Var]
tc_tvs = TyCon -> [Var]
tyConTyVars TyCon
tc
res_ty_tmpl :: Type
res_ty_tmpl = TyCon -> ThetaType -> Type
mkFamilyTyConApp TyCon
tc ([Var] -> ThetaType
mkTyVarTys [Var]
tc_tvs)
arg_tys :: [Scaled Type]
arg_tys = DataCon -> [Scaled Type]
dataConOrigArgTys DataCon
con
orig_res_ty :: Type
orig_res_ty = DataCon -> Type
dataConOrigResTy DataCon
con
; String -> SDoc -> TcRn ()
traceTc String
"checkValidDataCon" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con, TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc, [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
tc_tvs
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
res_ty_tmpl SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
res_ty_tmpl)
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
orig_res_ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
orig_res_ty)])
; Bool -> TcRnMessage -> TcRn ()
checkTc (Maybe Subst -> Bool
forall a. Maybe a -> Bool
isJust (Type -> Type -> Maybe Subst
tcMatchTyKi Type
res_ty_tmpl Type
orig_res_ty))
(DataCon -> Type -> TcRnMessage
TcRnDataConParentTypeMismatch DataCon
con Type
res_ty_tmpl)
; String -> SDoc -> TcRn ()
traceTc String
"checkValidDataCon 2" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
data_con_display_type)
; Type -> TcRn ()
checkValidMonoType Type
orig_res_ty
; Type -> TcRn ()
checkEscapingKind (DataCon -> Type
dataConWrapperType DataCon
con)
; let check_rr :: Type -> TcRn ()
check_rr = FixedRuntimeRepProvenance -> Type -> TcRn ()
checkTypeHasFixedRuntimeRep FixedRuntimeRepProvenance
FixedRuntimeRepDataConField
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TyCon -> Bool
isNewTyCon TyCon
tc) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRn () -> TcRn ()
forall r. TcM r -> TcM r
checkNoErrs (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
(Scaled Type -> TcRn ()) -> [Scaled Type] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Type -> TcRn ()
check_rr (Type -> TcRn ())
-> (Scaled Type -> Type) -> Scaled Type -> TcRn ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scaled Type -> Type
forall a. Scaled a -> a
scaledThing) [Scaled Type]
arg_tys
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyCon -> Bool
isNewTyCon TyCon
tc) (DataCon -> TcRn ()
checkNewDataCon DataCon
con)
; UserTypeCtxt -> Type -> TcRn ()
checkValidType UserTypeCtxt
ctxt Type
data_con_display_type
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
existential_ok Bool -> Bool -> Bool
|| DataCon -> Bool
isVanillaDataCon DataCon
con) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcRn ()
addErrTc (DataCon -> TcRnMessage
TcRnExistentialQuantificationDisabled DataCon
con)
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DataCon -> Bool
isTypeDataCon DataCon
con) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Bool -> TcRnMessage -> TcRn ()
checkTc ((Type -> Bool) -> ThetaType -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isEqClassPred (DataCon -> ThetaType
dataConOtherTheta DataCon
con))
(Type -> TcRnMessage
TcRnConstraintInKind (DataCon -> Type
dataConRepType DataCon
con))
; hsc_env <- IOEnv (Env TcGblEnv TcLclEnv) HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; let check_bang :: Type -> HsSrcBang -> HsImplBang -> Int -> TcM ()
check_bang Type
orig_arg_ty HsSrcBang
bang HsImplBang
rep_bang Int
n
| HsSrcBang SourceText
_ (HsBang SrcUnpackedness
_ SrcStrictness
SrcLazy) <- HsSrcBang
bang
, Bool -> Bool
not (BangOpts -> Bool
bang_opt_strict_data BangOpts
bang_opts)
= TcRnMessage -> TcRn ()
addErrTc (Int -> BadFieldAnnotationReason -> TcRnMessage
bad_bang Int
n BadFieldAnnotationReason
LazyFieldsDisabled)
| HsSrcBang SourceText
_ (HsBang SrcUnpackedness
want_unpack SrcStrictness
strict_mark) <- HsSrcBang
bang
, SrcUnpackedness -> Bool
isSrcUnpacked SrcUnpackedness
want_unpack, Bool -> Bool
not (SrcStrictness -> Bool
is_strict SrcStrictness
strict_mark)
, Bool -> Bool
not (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
orig_arg_ty)
= TcRnMessage -> TcRn ()
addDiagnosticTc (Int -> BadFieldAnnotationReason -> TcRnMessage
bad_bang Int
n BadFieldAnnotationReason
UnpackWithoutStrictness)
| HsSrcBang SourceText
_ (HsBang SrcUnpackedness
_ SrcStrictness
SrcStrict) <- HsSrcBang
bang
, HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
orig_arg_ty
= TcRnMessage -> TcRn ()
addDiagnosticTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Type -> TcRnMessage
TcRnBangOnUnliftedType Type
orig_arg_ty
| HsSrcBang SourceText
_ (HsBang SrcUnpackedness
_ SrcStrictness
SrcLazy) <- HsSrcBang
bang
, HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
orig_arg_ty
= TcRnMessage -> TcRn ()
addDiagnosticTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Type -> TcRnMessage
TcRnLazyBangOnUnliftedType Type
orig_arg_ty
| HsSrcBang SourceText
_ (HsBang SrcUnpackedness
want_unpack SrcStrictness
_) <- HsSrcBang
bang
, SrcUnpackedness -> Bool
isSrcUnpacked SrcUnpackedness
want_unpack
, case HsImplBang
rep_bang of { HsUnpack {} -> Bool
False; HsStrict Bool
True -> Bool
False; HsImplBang
_ -> Bool
True }
, HomeUnit -> Bool
forall u. GenHomeUnit u -> Bool
isHomeUnitDefinite (HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env)
= TcRnMessage -> TcRn ()
addDiagnosticTc (Int -> BadFieldAnnotationReason -> TcRnMessage
bad_bang Int
n BadFieldAnnotationReason
BackpackUnpackAbstractType)
| Bool
otherwise
= () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; void $ zipWith4M check_bang (map scaledThing $ dataConOrigArgTys con)
(dataConSrcBangs con) (dataConImplBangs con) [1..]
; when debugIsOn $ whenNoErrs $
massertPpr (checkDataConTyVars con) $
ppr con $$ ppr (dataConFullSig con) $$ ppr (dataConUserTyVars con)
; traceTc "Done validity of data con" $
vcat [ ppr con
, text "Datacon wrapper type:" <+> ppr (dataConWrapperType con)
, text "Datacon rep type:" <+> ppr (dataConRepType con)
, text "Datacon display type:" <+> ppr data_con_display_type
, text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con))
, case tyConFamInst_maybe (dataConTyCon con) of
Maybe (TyCon, ThetaType)
Nothing -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"not family"
Just (TyCon
f, ThetaType
_) -> [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [TyConBinder]
tyConBinders TyCon
f) ]
}
where
bang_opts :: BangOpts
bang_opts = DynFlags -> BangOpts
initBangOpts DynFlags
dflags
con_name :: Name
con_name = DataCon -> Name
dataConName DataCon
con
con_loc :: SrcSpan
con_loc = Name -> SrcSpan
nameSrcSpan Name
con_name
ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
ConArgCtxt Name
con_name
is_strict :: SrcStrictness -> Bool
is_strict = \case
SrcStrictness
NoSrcStrict -> BangOpts -> Bool
bang_opt_strict_data BangOpts
bang_opts
SrcStrictness
bang -> SrcStrictness -> Bool
isSrcStrict SrcStrictness
bang
bad_bang :: Int -> BadFieldAnnotationReason -> TcRnMessage
bad_bang Int
n
= Int -> DataCon -> BadFieldAnnotationReason -> TcRnMessage
TcRnBadFieldAnnotation Int
n DataCon
con
show_linear_types :: Bool
show_linear_types = Extension -> DynFlags -> Bool
xopt Extension
LangExt.LinearTypes DynFlags
dflags
data_con_display_type :: Type
data_con_display_type = Bool -> DataCon -> Type
dataConDisplayType Bool
show_linear_types DataCon
con
checkNewDataCon :: DataCon -> TcM ()
checkNewDataCon :: DataCon -> TcRn ()
checkNewDataCon DataCon
con
= do { show_linear_types <- Extension -> DynFlags -> Bool
xopt Extension
LangExt.LinearTypes (DynFlags -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> TcRnIf TcGblEnv TcLclEnv Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; checkNoErrs $
do { case arg_tys of
[Scaled Type
arg_mult Type
_] ->
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Type -> Bool
ok_mult Type
arg_mult) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcRn ()
addErrTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
DataCon -> Bool -> IllegalNewtypeReason -> TcRnMessage
TcRnIllegalNewtype DataCon
con Bool
show_linear_types IllegalNewtypeReason
IsNonLinear
[Scaled Type]
_ ->
TcRnMessage -> TcRn ()
addErrTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
DataCon -> Bool -> IllegalNewtypeReason -> TcRnMessage
TcRnIllegalNewtype DataCon
con Bool
show_linear_types (Int -> IllegalNewtypeReason
DoesNotHaveSingleField (Int -> IllegalNewtypeReason) -> Int -> IllegalNewtypeReason
forall a b. (a -> b) -> a -> b
$ [Scaled Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Scaled Type]
arg_tys)
; if not (null eq_spec)
then addErrTc $ TcRnIllegalNewtype con show_linear_types IsGADT
else unless (null ex_tvs) $
addErrTc $
TcRnIllegalNewtype con show_linear_types HasExistentialTyVar
; unless (null theta) $
addErrTc $
TcRnIllegalNewtype con show_linear_types HasConstructorContext
; unless (all ok_bang (dataConSrcBangs con)) $
addErrTc $
TcRnIllegalNewtype con show_linear_types HasStrictnessAnnotation } }
where
([Var]
_univ_tvs, [Var]
ex_tvs, [EqSpec]
eq_spec, ThetaType
theta, [Scaled Type]
arg_tys, Type
_res_ty)
= DataCon -> ([Var], [Var], [EqSpec], ThetaType, [Scaled Type], Type)
dataConFullSig DataCon
con
ok_bang :: HsSrcBang -> Bool
ok_bang (HsSrcBang SourceText
_ (HsBang SrcUnpackedness
_ SrcStrictness
SrcStrict)) = Bool
False
ok_bang (HsSrcBang SourceText
_ (HsBang SrcUnpackedness
_ SrcStrictness
SrcLazy)) = Bool
False
ok_bang HsSrcBang
_ = Bool
True
ok_mult :: Type -> Bool
ok_mult Type
OneTy = Bool
True
ok_mult Type
_ = Bool
False
checkValidClass :: Class -> TcM ()
checkValidClass :: Class -> TcRn ()
checkValidClass Class
cls
= do { constrained_class_methods <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ConstrainedClassMethods
; multi_param_type_classes <- xoptM LangExt.MultiParamTypeClasses
; nullary_type_classes <- xoptM LangExt.NullaryTypeClasses
; fundep_classes <- xoptM LangExt.FunctionalDependencies
; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses
; checkTc (multi_param_type_classes || cls_arity == 1 ||
(nullary_type_classes && cls_arity == 0))
(TcRnClassExtensionDisabled cls (MultiParamDisabled cls_arity))
; unless (fundep_classes || null fundeps) $
addErrTc (TcRnClassExtensionDisabled cls FunDepsDisabled)
; checkValidTheta (ClassSCCtxt (className cls)) theta
; unless undecidable_super_classes $
case checkClassCycles cls of
Just SuperclassCycle
err -> SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Class -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Class
cls) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcRn ()
addErrTc (SuperclassCycle -> TcRnMessage
TcRnSuperclassCycle SuperclassCycle
err)
Maybe SuperclassCycle
Nothing -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; whenNoErrs $
mapM_ (check_op constrained_class_methods) op_stuff
; mapM_ check_at at_stuff }
where
([Var]
tyvars, [([Var], [Var])]
fundeps, ThetaType
theta, [Var]
_, [ClassATItem]
at_stuff, [(Var, DefMethInfo)]
op_stuff) = Class
-> ([Var], [([Var], [Var])], ThetaType, [Var], [ClassATItem],
[(Var, DefMethInfo)])
classExtraBigSig Class
cls
cls_arity :: Int
cls_arity = [Var] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TyCon -> [Var]
tyConVisibleTyVars (Class -> TyCon
classTyCon Class
cls))
cls_tv_set :: VarSet
cls_tv_set = [Var] -> VarSet
mkVarSet [Var]
tyvars
check_op :: Bool -> (Var, DefMethInfo) -> TcRn ()
check_op Bool
constrained_class_methods (Var
sel_id, DefMethInfo
dm)
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Var -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Var
sel_id) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn () -> TcRn ()
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (Var -> Type -> SDoc
classOpCtxt Var
sel_id Type
op_ty) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
{ String -> SDoc -> TcRn ()
traceTc String
"class op type" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
op_ty)
; UserTypeCtxt -> Type -> TcRn ()
checkValidType UserTypeCtxt
ctxt Type
op_ty
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
constrained_class_methods (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
(Type -> TcRn ()) -> ThetaType -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Type -> TcRn ()
check_constraint ThetaType
op_theta
; UserTypeCtxt -> Var -> Type -> Type -> DefMethInfo -> TcRn ()
check_dm UserTypeCtxt
ctxt Var
sel_id Type
cls_pred Type
tau2 DefMethInfo
dm
}
where
ctxt :: UserTypeCtxt
ctxt = Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
op_name (SrcSpan -> ReportRedundantConstraints
WantRRC (Class -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Class
cls))
op_name :: Name
op_name = Var -> Name
idName Var
sel_id
op_ty :: Type
op_ty = Var -> Type
idType Var
sel_id
([Var]
_,Type
cls_pred,Type
tau1) = Type -> ([Var], Type, Type)
tcSplitMethodTy Type
op_ty
([Var]
_,ThetaType
op_theta,Type
tau2) = Type -> ([Var], ThetaType, Type)
tcSplitNestedSigmaTys Type
tau1
check_constraint :: TcPredType -> TcM ()
check_constraint :: Type -> TcRn ()
check_constraint Type
pred
= Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (VarSet -> Bool
isEmptyVarSet VarSet
pred_tvs) Bool -> Bool -> Bool
&&
VarSet
pred_tvs VarSet -> VarSet -> Bool
`subVarSet` VarSet
cls_tv_set)
(TcRnMessage -> TcRn ()
addErrTc (Class -> DisabledClassExtension -> TcRnMessage
TcRnClassExtensionDisabled Class
cls (Var -> Type -> DisabledClassExtension
ConstrainedClassMethodsDisabled Var
sel_id Type
pred)))
where
pred_tvs :: VarSet
pred_tvs = Type -> VarSet
tyCoVarsOfType Type
pred
check_at :: ClassATItem -> TcRn ()
check_at (ATI TyCon
fam_tc Maybe (Type, TyFamEqnValidityInfo)
m_dflt_rhs)
= do { String -> SDoc -> TcRn ()
traceTc String
"ati" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
tyvars SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
fam_tvs)
; Bool -> TcRnMessage -> TcRn ()
checkTc (Int
cls_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| (Var -> Bool) -> [Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Var -> VarSet -> Bool
`elemVarSet` VarSet
cls_tv_set) [Var]
fam_tvs) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
IllegalInstanceReason -> TcRnMessage
TcRnIllegalInstance (IllegalInstanceReason -> TcRnMessage)
-> IllegalInstanceReason -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ IllegalFamilyInstanceReason -> IllegalInstanceReason
IllegalFamilyInstance (IllegalFamilyInstanceReason -> IllegalInstanceReason)
-> IllegalFamilyInstanceReason -> IllegalInstanceReason
forall a b. (a -> b) -> a -> b
$
InvalidAssoc -> IllegalFamilyInstanceReason
InvalidAssoc (InvalidAssoc -> IllegalFamilyInstanceReason)
-> InvalidAssoc -> IllegalFamilyInstanceReason
forall a b. (a -> b) -> a -> b
$ InvalidAssocInstance -> InvalidAssoc
InvalidAssocInstance (InvalidAssocInstance -> InvalidAssoc)
-> InvalidAssocInstance -> InvalidAssoc
forall a b. (a -> b) -> a -> b
$
Class -> TyCon -> InvalidAssocInstance
AssocNoClassTyVar Class
cls TyCon
fam_tc
; Maybe (Type, TyFamEqnValidityInfo)
-> ((Type, TyFamEqnValidityInfo) -> TcRn ()) -> TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust Maybe (Type, TyFamEqnValidityInfo)
m_dflt_rhs (((Type, TyFamEqnValidityInfo) -> TcRn ()) -> TcRn ())
-> ((Type, TyFamEqnValidityInfo) -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \ (Type
_, TyFamEqnValidityInfo
at_validity_info) ->
case TyFamEqnValidityInfo
at_validity_info of
TyFamEqnValidityInfo
NoVI -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
VI { vi_loc :: TyFamEqnValidityInfo -> SrcSpan
vi_loc = SrcSpan
loc
, vi_qtvs :: TyFamEqnValidityInfo -> [Var]
vi_qtvs = [Var]
qtvs
, vi_non_user_tvs :: TyFamEqnValidityInfo -> VarSet
vi_non_user_tvs = VarSet
non_user_tvs
, vi_pats :: TyFamEqnValidityInfo -> ThetaType
vi_pats = ThetaType
pats
, vi_rhs :: TyFamEqnValidityInfo -> Type
vi_rhs = Type
orig_rhs } ->
SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> Name -> TcRn () -> TcRn ()
forall a. SDoc -> Name -> TcM a -> TcM a
tcAddFamInstCtxt (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"default type instance") (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
fam_tc) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do { TyCon -> ThetaType -> TcRn ()
checkValidAssocTyFamDeflt TyCon
fam_tc ThetaType
pats
; TyCon -> [Var] -> VarSet -> ThetaType -> Type -> TcRn ()
checkFamPatBinders TyCon
fam_tc [Var]
qtvs VarSet
non_user_tvs ThetaType
pats Type
orig_rhs
; TyCon -> ThetaType -> Type -> TcRn ()
checkValidTyFamEqn TyCon
fam_tc ThetaType
pats Type
orig_rhs }}
where
fam_tvs :: [Var]
fam_tvs = TyCon -> [Var]
tyConTyVars TyCon
fam_tc
check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM ()
check_dm :: UserTypeCtxt -> Var -> Type -> Type -> DefMethInfo -> TcRn ()
check_dm UserTypeCtxt
ctxt Var
sel_id Type
vanilla_cls_pred Type
vanilla_tau
(Just (Name
dm_name, dm_spec :: DefMethSpec Type
dm_spec@(GenericDM Type
dm_ty)))
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
dm_name) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
let cls_pred :: Type
cls_pred = Class -> ThetaType -> Type
mkClassPred Class
cls (ThetaType -> Type) -> ThetaType -> Type
forall a b. (a -> b) -> a -> b
$ [Var] -> ThetaType
mkTyVarTys ([Var] -> ThetaType) -> [Var] -> ThetaType
forall a b. (a -> b) -> a -> b
$ Class -> [Var]
classTyVars Class
cls
([Var]
_, ThetaType
_, Type
dm_tau) = Type -> ([Var], ThetaType, Type)
tcSplitNestedSigmaTys Type
dm_ty
vanilla_phi_ty :: Type
vanilla_phi_ty = ThetaType -> Type -> Type
HasDebugCallStack => ThetaType -> Type -> Type
mkPhiTy [Type
vanilla_cls_pred] Type
vanilla_tau
dm_phi_ty :: Type
dm_phi_ty = ThetaType -> Type -> Type
HasDebugCallStack => ThetaType -> Type -> Type
mkPhiTy [Type
cls_pred] Type
dm_tau
String -> SDoc -> TcRn ()
traceTc String
"check_dm" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"vanilla_phi_ty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
vanilla_phi_ty
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"dm_phi_ty" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
dm_phi_ty ]
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe Subst -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Subst -> Bool) -> Maybe Subst -> Bool
forall a b. (a -> b) -> a -> b
$ ThetaType -> ThetaType -> Maybe Subst
tcMatchTys [Type
dm_phi_ty, Type
vanilla_phi_ty]
[Type
vanilla_phi_ty, Type
dm_phi_ty]) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcRn ()
addErrTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Var -> Type -> TcRnMessage
TcRnDefaultSigMismatch Var
sel_id Type
dm_ty
UserTypeCtxt -> Type -> TcRn ()
checkValidType UserTypeCtxt
ctxt (Class -> Var -> DefMethSpec Type -> Type
mkDefaultMethodType Class
cls Var
sel_id DefMethSpec Type
dm_spec)
check_dm UserTypeCtxt
_ Var
_ Type
_ Type
_ DefMethInfo
_ = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkFamFlag :: Name -> TcM ()
checkFamFlag :: Name -> TcRn ()
checkFamFlag Name
tc_name
= do { idx_tys <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TypeFamilies
; unless idx_tys $ addErrTc (TcRnTyFamsDisabled (TyFamsDisabledFamily tc_name)) }
checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM ()
checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcRn ()
checkResultSigFlag Name
tc_name (TyVarSig XTyVarSig GhcRn
_ LHsTyVarBndr () GhcRn
tvb)
= do { ty_fam_deps <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TypeFamilyDependencies
; unless ty_fam_deps $ addErrTc (TcRnTyFamResultDisabled tc_name tvb) }
checkResultSigFlag Name
_ FamilyResultSig GhcRn
_ = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM ()
checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcRn ()
checkValidRoleAnnots RoleAnnotEnv
role_annots TyCon
tc
| TyCon -> Bool
isTypeSynonymTyCon TyCon
tc = TcRn ()
check_no_roles
| TyCon -> Bool
isFamilyTyCon TyCon
tc = TcRn ()
check_no_roles
| TyCon -> Bool
isAlgTyCon TyCon
tc = TcRn ()
check_roles
| Bool
otherwise = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
name :: Name
name = TyCon -> Name
tyConName TyCon
tc
roles :: [Role]
roles = TyCon -> [Role]
tyConRoles TyCon
tc
([Role]
vis_roles, [Var]
vis_vars) = [(Role, Var)] -> ([Role], [Var])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Role, Var)] -> ([Role], [Var]))
-> [(Role, Var)] -> ([Role], [Var])
forall a b. (a -> b) -> a -> b
$ ((Role, TyConBinder) -> Maybe (Role, Var))
-> [(Role, TyConBinder)] -> [(Role, Var)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Role, TyConBinder) -> Maybe (Role, Var)
pick_vis ([(Role, TyConBinder)] -> [(Role, Var)])
-> [(Role, TyConBinder)] -> [(Role, Var)]
forall a b. (a -> b) -> a -> b
$
[Role] -> [TyConBinder] -> [(Role, TyConBinder)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Role]
roles (TyCon -> [TyConBinder]
tyConBinders TyCon
tc)
role_annot_decl_maybe :: Maybe (LRoleAnnotDecl GhcRn)
role_annot_decl_maybe = RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl GhcRn)
lookupRoleAnnot RoleAnnotEnv
role_annots Name
name
pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar)
pick_vis :: (Role, TyConBinder) -> Maybe (Role, Var)
pick_vis (Role
role, TyConBinder
tvb)
| TyConBinder -> Bool
forall tv. VarBndr tv TyConBndrVis -> Bool
isVisibleTyConBinder TyConBinder
tvb = (Role, Var) -> Maybe (Role, Var)
forall a. a -> Maybe a
Just (Role
role, TyConBinder -> Var
forall tv argf. VarBndr tv argf -> tv
binderVar TyConBinder
tvb)
| Bool
otherwise = Maybe (Role, Var)
forall a. Maybe a
Nothing
check_roles :: TcRn ()
check_roles = case Maybe (LRoleAnnotDecl GhcRn)
role_annot_decl_maybe of
Maybe (LRoleAnnotDecl GhcRn)
Nothing ->
SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
name) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Bool -> TcRnMessage -> TcRn ()
warnIf (Bool -> Bool
not (TyCon -> Bool
isClassTyCon TyCon
tc) Bool -> Bool -> Bool
&& Bool -> Bool
not ([Role] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Role]
vis_roles)) (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Name -> [Role] -> TcRnMessage
TcRnMissingRoleAnnotation Name
name [Role]
vis_roles
Just (decl :: LRoleAnnotDecl GhcRn
decl@(L SrcSpanAnnA
loc (RoleAnnotDecl XCRoleAnnotDecl GhcRn
_ LIdP GhcRn
_ [XRec GhcRn (Maybe Role)]
the_role_annots))) ->
Name -> TcRn () -> TcRn ()
forall a. Name -> TcM a -> TcM a
addRoleAnnotCtxt Name
name (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SrcSpanAnnA -> TcRn () -> TcRn ()
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
{ role_annots_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.RoleAnnotations
; unless role_annots_ok $ addErrTc $ TcRnRoleAnnotationsDisabled tc
; checkTc (vis_vars `equalLength` the_role_annots)
(TcRnRoleCountMismatch (length vis_vars) decl)
; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles
; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances
; checkTc ( incoherent_roles_ok
|| (not $ isClassTyCon tc)
|| (all (== Nominal) vis_roles))
(TcRnIncoherentRoles tc)
; lint <- goptM Opt_DoCoreLinting
; when lint $ checkValidRoles tc }
check_no_roles :: TcRn ()
check_no_roles
= Maybe (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn))
-> (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn) -> TcRn ())
-> TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust Maybe (LRoleAnnotDecl GhcRn)
Maybe (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn))
role_annot_decl_maybe LRoleAnnotDecl GhcRn -> TcRn ()
GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn) -> TcRn ()
illegalRoleAnnotDecl
checkRoleAnnot :: TyVar -> LocatedAn NoEpAnns (Maybe Role) -> Role -> TcM ()
checkRoleAnnot :: Var -> GenLocated EpAnnCO (Maybe Role) -> Role -> TcRn ()
checkRoleAnnot Var
_ (L EpAnnCO
_ Maybe Role
Nothing) Role
_ = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkRoleAnnot Var
tv (L EpAnnCO
_ (Just Role
r1)) Role
r2
= Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Role
r1 Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
/= Role
r2) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcRn ()
addErrTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Name -> Role -> Role -> TcRnMessage
TcRnRoleMismatch (Var -> Name
tyVarName Var
tv) Role
r1 Role
r2
checkValidRoles :: TyCon -> TcM ()
checkValidRoles :: TyCon -> TcRn ()
checkValidRoles TyCon
tc
| TyCon -> Bool
isAlgTyCon TyCon
tc
= (DataCon -> TcRn ()) -> [DataCon] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DataCon -> TcRn ()
check_dc_roles (TyCon -> [DataCon]
tyConDataCons TyCon
tc)
| Just Type
rhs <- TyCon -> Maybe Type
synTyConRhs_maybe TyCon
tc
= VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles ([Var] -> [Role] -> VarEnv Role
forall a. [Var] -> [a] -> VarEnv a
zipVarEnv (TyCon -> [Var]
tyConTyVars TyCon
tc) (TyCon -> [Role]
tyConRoles TyCon
tc)) Role
Representational Type
rhs
| Bool
otherwise
= () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
check_dc_roles :: DataCon -> TcRn ()
check_dc_roles DataCon
datacon
= do { String -> SDoc -> TcRn ()
traceTc String
"check_dc_roles" (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
datacon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Role] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [Role]
tyConRoles TyCon
tc))
; (Type -> TcRn ()) -> ThetaType -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
role_env Role
Representational) (ThetaType -> TcRn ()) -> ThetaType -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[EqSpec] -> ThetaType
eqSpecPreds [EqSpec]
eq_spec ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ ThetaType
theta ThetaType -> ThetaType -> ThetaType
forall a. [a] -> [a] -> [a]
++ (Scaled Type -> Type) -> [Scaled Type] -> ThetaType
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys }
where
([Var]
univ_tvs, [Var]
ex_tvs, [EqSpec]
eq_spec, ThetaType
theta, [Scaled Type]
arg_tys, Type
_res_ty)
= DataCon -> ([Var], [Var], [EqSpec], ThetaType, [Scaled Type], Type)
dataConFullSig DataCon
datacon
univ_roles :: VarEnv Role
univ_roles = [Var] -> [Role] -> VarEnv Role
forall a. [Var] -> [a] -> VarEnv a
zipVarEnv [Var]
univ_tvs (TyCon -> [Role]
tyConRoles TyCon
tc)
ex_roles :: VarEnv Role
ex_roles = [(Var, Role)] -> VarEnv Role
forall a. [(Var, a)] -> VarEnv a
mkVarEnv ((Var -> (Var, Role)) -> [Var] -> [(Var, Role)]
forall a b. (a -> b) -> [a] -> [b]
map (, Role
Nominal) [Var]
ex_tvs)
role_env :: VarEnv Role
role_env = VarEnv Role
univ_roles VarEnv Role -> VarEnv Role -> VarEnv Role
forall a. VarEnv a -> VarEnv a -> VarEnv a
`plusVarEnv` VarEnv Role
ex_roles
check_ty_roles :: VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
role Type
ty
| Just Type
ty' <- Type -> Maybe Type
coreView Type
ty
= VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
role Type
ty'
check_ty_roles VarEnv Role
env Role
role (TyVarTy Var
tv)
= case VarEnv Role -> Var -> Maybe Role
forall a. VarEnv a -> Var -> Maybe a
lookupVarEnv VarEnv Role
env Var
tv of
Just Role
role' -> Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Role
role' Role -> Role -> Bool
`ltRole` Role
role Bool -> Bool -> Bool
|| Role
role' Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
role) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Role -> RoleValidationFailedReason -> TcRn ()
report_error Role
role (RoleValidationFailedReason -> TcRn ())
-> RoleValidationFailedReason -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Var -> Role -> RoleValidationFailedReason
TyVarRoleMismatch Var
tv Role
role'
Maybe Role
Nothing -> Role -> RoleValidationFailedReason -> TcRn ()
report_error Role
role (RoleValidationFailedReason -> TcRn ())
-> RoleValidationFailedReason -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Var -> RoleValidationFailedReason
TyVarMissingInEnv Var
tv
check_ty_roles VarEnv Role
env Role
Representational (TyConApp TyCon
tc ThetaType
tys)
= let roles' :: [Role]
roles' = TyCon -> [Role]
tyConRoles TyCon
tc in
(Role -> Type -> TcRn ()) -> [Role] -> ThetaType -> TcRn ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (VarEnv Role -> Role -> Type -> TcRn ()
maybe_check_ty_roles VarEnv Role
env) [Role]
roles' ThetaType
tys
check_ty_roles VarEnv Role
env Role
Nominal (TyConApp TyCon
_ ThetaType
tys)
= (Type -> TcRn ()) -> ThetaType -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
Nominal) ThetaType
tys
check_ty_roles VarEnv Role
_ Role
Phantom ty :: Type
ty@(TyConApp {})
= String -> SDoc -> TcRn ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"check_ty_roles" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
check_ty_roles VarEnv Role
env Role
role (AppTy Type
ty1 Type
ty2)
= VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
role Type
ty1
TcRn () -> TcRn () -> TcRn ()
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
Nominal Type
ty2
check_ty_roles VarEnv Role
env Role
role (FunTy FunTyFlag
_ Type
w Type
ty1 Type
ty2)
= VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
Nominal Type
w
TcRn () -> TcRn () -> TcRn ()
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
role Type
ty1
TcRn () -> TcRn () -> TcRn ()
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
role Type
ty2
check_ty_roles VarEnv Role
env Role
role (ForAllTy (Bndr Var
tv ForAllTyFlag
_) Type
ty)
= VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
Nominal (Var -> Type
tyVarKind Var
tv)
TcRn () -> TcRn () -> TcRn ()
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles (VarEnv Role -> Var -> Role -> VarEnv Role
forall a. VarEnv a -> Var -> a -> VarEnv a
extendVarEnv VarEnv Role
env Var
tv Role
Nominal) Role
role Type
ty
check_ty_roles VarEnv Role
_ Role
_ (LitTy {}) = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check_ty_roles VarEnv Role
env Role
role (CastTy Type
t Coercion
_)
= VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
role Type
t
check_ty_roles VarEnv Role
_ Role
role (CoercionTy Coercion
co)
= Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Role
role Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Phantom) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Role -> RoleValidationFailedReason -> TcRn ()
report_error Role
role (RoleValidationFailedReason -> TcRn ())
-> RoleValidationFailedReason -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Coercion -> RoleValidationFailedReason
BadCoercionRole Coercion
co
maybe_check_ty_roles :: VarEnv Role -> Role -> Type -> TcRn ()
maybe_check_ty_roles VarEnv Role
env Role
role Type
ty
= Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Role
role Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Nominal Bool -> Bool -> Bool
|| Role
role Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Representational) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
role Type
ty
report_error :: Role -> RoleValidationFailedReason -> TcRn ()
report_error Role
role RoleValidationFailedReason
reason
= TcRnMessage -> TcRn ()
addErrTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ Role -> RoleValidationFailedReason -> TcRnMessage
TcRnRoleValidationFailed Role
role RoleValidationFailedReason
reason
tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc
tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc
tcMkDeclCtxt TyClDecl GhcRn
decl = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the", TyClDecl GhcRn -> SDoc
forall (p :: Pass). TyClDecl (GhcPass p) -> SDoc
pprTyClDeclFlavour TyClDecl GhcRn
decl,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"declaration for", SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyClDecl GhcRn -> IdP GhcRn
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
decl))]
addVDQNote :: TcTyCon -> TcM a -> TcM a
addVDQNote :: forall a. TyCon -> TcM a -> TcM a
addVDQNote TyCon
tycon TcM a
thing_inside
| Bool -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (TyCon -> Bool
isMonoTcTyCon TyCon
tycon) (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tycon SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
tc_kind)
Bool
has_vdq
= SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addLandmarkErrCtxt SDoc
vdq_warning TcM a
thing_inside
| Bool
otherwise
= TcM a
thing_inside
where
has_vdq :: Bool
has_vdq = (TyConBinder -> Bool) -> [TyConBinder] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TyConBinder -> Bool
is_vdq_tcb (TyCon -> [TyConBinder]
tyConBinders TyCon
tycon)
tc_kind :: Type
tc_kind = TyCon -> Type
tyConKind TyCon
tycon
kind_fvs :: VarSet
kind_fvs = Type -> VarSet
tyCoVarsOfType Type
tc_kind
is_vdq_tcb :: TyConBinder -> Bool
is_vdq_tcb TyConBinder
tcb = (TyConBinder -> Var
forall tv argf. VarBndr tv argf -> tv
binderVar TyConBinder
tcb Var -> VarSet -> Bool
`elemVarSet` VarSet
kind_fvs) Bool -> Bool -> Bool
&&
TyConBinder -> Bool
forall tv. VarBndr tv TyConBndrVis -> Bool
isVisibleTyConBinder TyConBinder
tcb
vdq_warning :: SDoc
vdq_warning = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NB: Type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tycon) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"was inferred to use visible dependent quantification."
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Most types with visible dependent quantification are"
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"polymorphically recursive and need a standalone kind"
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"signature. Perhaps supply one, with StandaloneKindSignatures."
]
tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a
tcAddDeclCtxt :: forall a. TyClDecl GhcRn -> TcM a -> TcM a
tcAddDeclCtxt TyClDecl GhcRn
decl TcM a
thing_inside
= SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (TyClDecl GhcRn -> SDoc
tcMkDeclCtxt TyClDecl GhcRn
decl) TcM a
thing_inside
tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a
tcAddTyFamInstCtxt :: forall a. TyFamInstDecl GhcRn -> TcM a -> TcM a
tcAddTyFamInstCtxt TyFamInstDecl GhcRn
decl
= SDoc -> Name -> TcM a -> TcM a
forall a. SDoc -> Name -> TcM a -> TcM a
tcAddFamInstCtxt (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"type instance") (TyFamInstDecl GhcRn -> IdP GhcRn
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)
tyFamInstDeclName TyFamInstDecl GhcRn
decl)
tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc
tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc
tcMkDataFamInstCtxt decl :: DataFamInstDecl GhcRn
decl@(DataFamInstDecl { dfid_eqn :: forall pass. DataFamInstDecl pass -> FamEqn pass (HsDataDefn pass)
dfid_eqn = FamEqn GhcRn (HsDataDefn GhcRn)
eqn })
= SDoc -> Name -> SDoc
tcMkFamInstCtxt (DataFamInstDecl GhcRn -> SDoc
forall (p :: Pass). DataFamInstDecl (GhcPass p) -> SDoc
pprDataFamInstFlavour DataFamInstDecl GhcRn
decl SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"instance")
(LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc (FamEqn GhcRn (HsDataDefn GhcRn) -> LIdP GhcRn
forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon FamEqn GhcRn (HsDataDefn GhcRn)
eqn))
tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a
tcAddDataFamInstCtxt :: forall a. DataFamInstDecl GhcRn -> TcM a -> TcM a
tcAddDataFamInstCtxt DataFamInstDecl GhcRn
decl
= SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (DataFamInstDecl GhcRn -> SDoc
tcMkDataFamInstCtxt DataFamInstDecl GhcRn
decl)
tcMkFamInstCtxt :: SDoc -> Name -> SDoc
tcMkFamInstCtxt :: SDoc -> Name -> SDoc
tcMkFamInstCtxt SDoc
flavour Name
tycon
= [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
flavour SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"declaration for"
, SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tycon) ]
tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a
tcAddFamInstCtxt :: forall a. SDoc -> Name -> TcM a -> TcM a
tcAddFamInstCtxt SDoc
flavour Name
tycon TcM a
thing_inside
= SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (SDoc -> Name -> SDoc
tcMkFamInstCtxt SDoc
flavour Name
tycon) TcM a
thing_inside
tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a
tcAddClosedTypeFamilyDeclCtxt :: forall a. TyCon -> TcM a -> TcM a
tcAddClosedTypeFamilyDeclCtxt TyCon
tc
= SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
ctxt
where
ctxt :: SDoc
ctxt = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the equations for closed type family" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
dataConCtxt :: NonEmpty (LocatedN Name) -> SDoc
dataConCtxt :: NonEmpty (LocatedN Name) -> SDoc
dataConCtxt NonEmpty (LocatedN Name)
cons = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the definition of data constructor" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [LocatedN Name] -> SDoc
forall a. [a] -> SDoc
plural (NonEmpty (LocatedN Name) -> [LocatedN Name]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (LocatedN Name)
cons)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [LocatedN Name] -> SDoc
ppr_cons (NonEmpty (LocatedN Name) -> [LocatedN Name]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (LocatedN Name)
cons)
dataConResCtxt :: NonEmpty (LocatedN Name) -> SDoc
dataConResCtxt :: NonEmpty (LocatedN Name) -> SDoc
dataConResCtxt NonEmpty (LocatedN Name)
cons = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In the result type of data constructor" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [LocatedN Name] -> SDoc
forall a. [a] -> SDoc
plural (NonEmpty (LocatedN Name) -> [LocatedN Name]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (LocatedN Name)
cons)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [LocatedN Name] -> SDoc
ppr_cons (NonEmpty (LocatedN Name) -> [LocatedN Name]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (LocatedN Name)
cons)
ppr_cons :: [LocatedN Name] -> SDoc
ppr_cons :: [LocatedN Name] -> SDoc
ppr_cons [LocatedN Name
con] = SDoc -> SDoc
quotes (LocatedN Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedN Name
con)
ppr_cons [LocatedN Name]
cons = [LocatedN Name] -> SDoc
forall a. Outputable a => [a] -> SDoc
interpp'SP [LocatedN Name]
cons
classOpCtxt :: Var -> Type -> SDoc
classOpCtxt :: Var -> Type -> SDoc
classOpCtxt Var
sel_id Type
tau = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"When checking the class method:",
Int -> SDoc -> SDoc
nest Int
2 (Var -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc Var
sel_id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
tau)]
illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM ()
illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcRn ()
illegalRoleAnnotDecl (L SrcSpanAnnA
loc RoleAnnotDecl GhcRn
role)
= [ErrCtxt] -> TcRn () -> TcRn ()
forall a. [ErrCtxt] -> TcM a -> TcM a
setErrCtxt [] (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SrcSpanAnnA -> TcRn () -> TcRn ()
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcRn ()
addErrTc (TcRnMessage -> TcRn ()) -> TcRnMessage -> TcRn ()
forall a b. (a -> b) -> a -> b
$ RoleAnnotDecl GhcRn -> TcRnMessage
TcRnIllegalRoleAnnotation RoleAnnotDecl GhcRn
role
addTyConCtxt :: TyCon -> TcM a -> TcM a
addTyConCtxt :: forall a. TyCon -> TcM a -> TcM a
addTyConCtxt TyCon
tc = Name -> TyConFlavour TyCon -> TcM a -> TcM a
forall tc a. Name -> TyConFlavour tc -> TcM a -> TcM a
addTyConFlavCtxt Name
name TyConFlavour TyCon
flav
where
name :: Name
name = TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc
flav :: TyConFlavour TyCon
flav = TyCon -> TyConFlavour TyCon
tyConFlavour TyCon
tc
addRoleAnnotCtxt :: Name -> TcM a -> TcM a
addRoleAnnotCtxt :: forall a. Name -> TcM a -> TcM a
addRoleAnnotCtxt Name
name
= SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (SDoc -> TcM a -> TcM a) -> SDoc -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"while checking a role annotation for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)