{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables, MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.TyCl (
tcTyAndClassDecls,
kcConDecls, tcConDecls, DataDeclInfo(..),
dataDeclChecks, checkValidTyCon,
tcFamTyPats, tcTyFamInstEqn,
tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,
unravelFamInstPats, addConsistencyConstraints,
wrongKindOfFamily
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Hs
import GHC.Tc.TyCl.Build
import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX
, reportUnsolvedEqualities )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Unify( unifyType, emitResidualTvConstraint )
import GHC.Tc.Types.Constraint( emptyWC )
import GHC.Tc.Validity
import GHC.Tc.Utils.Zonk
import GHC.Tc.TyCl.Utils
import GHC.Tc.TyCl.Class
import {-# SOURCE #-} GHC.Tc.TyCl.Instance( tcInstDecls1 )
import GHC.Tc.Deriv (DerivInfo(..))
import GHC.Tc.Gen.HsType
import GHC.Tc.Instance.Class( AssocInstInfo(..) )
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
import GHC.Tc.Instance.Family
import GHC.Tc.Types.Origin
import GHC.Builtin.Types (oneDataConTy, unitTy, makeRecoveryTyCon )
import GHC.Rename.Env( lookupConstructorFields )
import GHC.Core.Multiplicity
import GHC.Core.FamInstEnv
import GHC.Core.Coercion
import GHC.Core.Type
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr( pprTyVars )
import GHC.Core.Class
import GHC.Core.Coercion.Axiom
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.Unify
import GHC.Types.Id
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Types.SrcLoc
import GHC.Types.SourceFile
import GHC.Types.Unique
import GHC.Types.Basic
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Data.List.SetOps
import GHC.Unit
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import Control.Monad
import Data.Function ( on )
import Data.Functor.Identity
import Data.List (nubBy, partition)
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.Set as Set
import Data.Tuple( swap )
tcTyAndClassDecls :: [TyClGroup GhcRn]
-> TcM ( TcGblEnv
, [InstInfo GhcRn]
, [DerivInfo]
)
tcTyAndClassDecls :: [TyClGroup GhcRn] -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
tcTyAndClassDecls [TyClGroup GhcRn]
tyclds_s
= forall r. TcM r -> TcM r
checkNoErrs forall a b. (a -> b) -> a -> b
$ [InstInfo GhcRn]
-> [DerivInfo]
-> [TyClGroup GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
fold_env [] [] [TyClGroup GhcRn]
tyclds_s
where
fold_env :: [InstInfo GhcRn]
-> [DerivInfo]
-> [TyClGroup GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
fold_env :: [InstInfo GhcRn]
-> [DerivInfo]
-> [TyClGroup GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
fold_env [InstInfo GhcRn]
inst_info [DerivInfo]
deriv_info []
= do { TcGblEnv
gbl_env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
gbl_env, [InstInfo GhcRn]
inst_info, [DerivInfo]
deriv_info) }
fold_env [InstInfo GhcRn]
inst_info [DerivInfo]
deriv_info (TyClGroup GhcRn
tyclds:[TyClGroup GhcRn]
tyclds_s)
= do { (TcGblEnv
tcg_env, [InstInfo GhcRn]
inst_info', [DerivInfo]
deriv_info') <- TyClGroup GhcRn -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
tcTyClGroup TyClGroup GhcRn
tyclds
; forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env forall a b. (a -> b) -> a -> b
$
[InstInfo GhcRn]
-> [DerivInfo]
-> [TyClGroup GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
fold_env ([InstInfo GhcRn]
inst_info' forall a. [a] -> [a] -> [a]
++ [InstInfo GhcRn]
inst_info)
([DerivInfo]
deriv_info' forall a. [a] -> [a] -> [a]
++ [DerivInfo]
deriv_info)
[TyClGroup GhcRn]
tyclds_s }
tcTyClGroup :: TyClGroup GhcRn
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
tcTyClGroup :: TyClGroup GhcRn -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
tcTyClGroup (TyClGroup { group_tyclds :: forall pass. TyClGroup pass -> [LTyClDecl pass]
group_tyclds = [LTyClDecl GhcRn]
tyclds
, group_roles :: forall pass. TyClGroup pass -> [LRoleAnnotDecl pass]
group_roles = [LRoleAnnotDecl GhcRn]
roles
, group_kisigs :: forall pass. TyClGroup pass -> [LStandaloneKindSig pass]
group_kisigs = [LStandaloneKindSig GhcRn]
kisigs
, group_instds :: forall pass. TyClGroup pass -> [LInstDecl pass]
group_instds = [LInstDecl GhcRn]
instds })
= do { let role_annots :: RoleAnnotEnv
role_annots = [LRoleAnnotDecl GhcRn] -> RoleAnnotEnv
mkRoleAnnotEnv [LRoleAnnotDecl GhcRn]
roles
; String -> SDoc -> TcRn ()
traceTc String
"---- tcTyClGroup ---- {" SDoc
empty
; String -> SDoc -> TcRn ()
traceTc String
"Decls for" (forall a. Outputable a => a -> SDoc
ppr (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LTyClDecl GhcRn]
tyclds))
; ([TyCon]
tyclss, [DerivInfo]
data_deriv_info, NameSet
kindless) <-
forall r. TcTypeEnv -> TcM r -> TcM r
tcExtendKindEnv ([LTyClDecl GhcRn] -> TcTypeEnv
mkPromotionErrorEnv [LTyClDecl GhcRn]
tyclds) forall a b. (a -> b) -> a -> b
$
do { NameEnv Type
kisig_env <- forall a. [(Name, a)] -> NameEnv a
mkNameEnv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse LStandaloneKindSig GhcRn -> TcM (Name, Type)
tcStandaloneKindSig [LStandaloneKindSig GhcRn]
kisigs
; [LTyClDecl GhcRn]
-> NameEnv Type
-> RoleAnnotEnv
-> TcM ([TyCon], [DerivInfo], NameSet)
tcTyClDecls [LTyClDecl GhcRn]
tyclds NameEnv Type
kisig_env RoleAnnotEnv
role_annots }
; String -> SDoc -> TcRn ()
traceTc String
"Starting synonym cycle check" (forall a. Outputable a => a -> SDoc
ppr [TyCon]
tyclss)
; HomeUnit
home_unit <- HscEnv -> HomeUnit
hsc_home_unit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcRn ()
checkSynCycles (HomeUnit -> Unit
homeUnitAsUnit HomeUnit
home_unit) [TyCon]
tyclss [LTyClDecl GhcRn]
tyclds
; String -> SDoc -> TcRn ()
traceTc String
"Done synonym cycle check" (forall a. Outputable a => a -> SDoc
ppr [TyCon]
tyclss)
; String -> SDoc -> TcRn ()
traceTc String
"Starting validity check" (forall a. Outputable a => a -> SDoc
ppr [TyCon]
tyclss)
; [TyCon]
tyclss <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM TyCon -> TcM [TyCon]
checkValidTyCl [TyCon]
tyclss
; String -> SDoc -> TcRn ()
traceTc String
"Done validity check" (forall a. Outputable a => a -> SDoc
ppr [TyCon]
tyclss)
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall r. TcRn r -> TcRn r -> TcRn r
recoverM (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall b c a. (b -> c) -> (a -> b) -> a -> c
. RoleAnnotEnv -> TyCon -> TcRn ()
checkValidRoleAnnots RoleAnnotEnv
role_annots) [TyCon]
tyclss
; String -> SDoc -> TcRn ()
traceTc String
"---- end tcTyClGroup ---- }" SDoc
empty
; TcGblEnv
gbl_env <- [TyCon] -> TcM TcGblEnv
addTyConsToGblEnv [TyCon]
tyclss
; (TcGblEnv
gbl_env', [InstInfo GhcRn]
inst_info, [DerivInfo]
datafam_deriv_info) <-
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
gbl_env forall a b. (a -> b) -> a -> b
$
[LInstDecl GhcRn] -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
tcInstDecls1 [LInstDecl GhcRn]
instds
; let deriv_info :: [DerivInfo]
deriv_info = [DerivInfo]
datafam_deriv_info forall a. [a] -> [a] -> [a]
++ [DerivInfo]
data_deriv_info
; let gbl_env'' :: TcGblEnv
gbl_env'' = TcGblEnv
gbl_env'
{ tcg_ksigs :: NameSet
tcg_ksigs = TcGblEnv -> NameSet
tcg_ksigs TcGblEnv
gbl_env' NameSet -> NameSet -> NameSet
`unionNameSet` NameSet
kindless }
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
gbl_env'', [InstInfo GhcRn]
inst_info, [DerivInfo]
deriv_info) }
type KindSigEnv = NameEnv Kind
tcTyClDecls
:: [LTyClDecl GhcRn]
-> KindSigEnv
-> RoleAnnotEnv
-> TcM ([TyCon], [DerivInfo], NameSet)
tcTyClDecls :: [LTyClDecl GhcRn]
-> NameEnv Type
-> RoleAnnotEnv
-> TcM ([TyCon], [DerivInfo], NameSet)
tcTyClDecls [LTyClDecl GhcRn]
tyclds NameEnv Type
kisig_env RoleAnnotEnv
role_annots
= do {
([TyCon]
tc_tycons, NameSet
kindless) <- NameEnv Type -> [LTyClDecl GhcRn] -> TcM ([TyCon], NameSet)
kcTyClGroup NameEnv Type
kisig_env [LTyClDecl GhcRn]
tyclds
; String -> SDoc -> TcRn ()
traceTc String
"tcTyAndCl generalized kinds" ([SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map TyCon -> SDoc
ppr_tc_tycon [TyCon]
tc_tycons))
; forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM forall a b. (a -> b) -> a -> b
$ \ ~([TyCon]
rec_tyclss, [DerivInfo]
_, NameSet
_) -> do
{ TcGblEnv
tcg_env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let !src :: HscSource
src = TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env
roles :: Name -> [Role]
roles = HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role]
inferRoles HscSource
src RoleAnnotEnv
role_annots [TyCon]
rec_tyclss
; ([TyCon]
tycons, [[DerivInfo]]
data_deriv_infos) <-
forall r. [(Name, TyThing)] -> TcM r -> TcM r
tcExtendRecEnv ([TyCon] -> [TyCon] -> [(Name, TyThing)]
zipRecTyClss [TyCon]
tc_tycons [TyCon]
rec_tyclss) forall a b. (a -> b) -> a -> b
$
forall a. [TyCon] -> TcM a -> TcM a
tcExtendKindEnvWithTyCons [TyCon]
tc_tycons forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ((Name -> [Role]) -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo])
tcTyClDecl Name -> [Role]
roles) [LTyClDecl GhcRn]
tyclds
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TyCon]
tycons, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[DerivInfo]]
data_deriv_infos, NameSet
kindless)
} }
where
ppr_tc_tycon :: TyCon -> SDoc
ppr_tc_tycon TyCon
tc = SDoc -> SDoc
parens ([SDoc] -> SDoc
sep [ forall a. Outputable a => a -> SDoc
ppr (TyCon -> Name
tyConName TyCon
tc) SDoc -> SDoc -> SDoc
<> SDoc
comma
, forall a. Outputable a => a -> SDoc
ppr (TyCon -> [TyConBinder]
tyConBinders TyCon
tc) SDoc -> SDoc -> SDoc
<> SDoc
comma
, forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConResKind TyCon
tc)
, forall a. Outputable a => a -> SDoc
ppr (TyCon -> Bool
isTcTyCon TyCon
tc) ])
zipRecTyClss :: [TcTyCon]
-> [TyCon]
-> [(Name,TyThing)]
zipRecTyClss :: [TyCon] -> [TyCon] -> [(Name, TyThing)]
zipRecTyClss [TyCon]
tc_tycons [TyCon]
rec_tycons
= [ (Name
name, TyCon -> TyThing
ATyCon (Name -> TyCon
get Name
name)) | TyCon
tc_tycon <- [TyCon]
tc_tycons, let name :: Name
name = forall a. NamedThing a => a -> Name
getName TyCon
tc_tycon ]
where
rec_tc_env :: NameEnv TyCon
rec_tc_env :: NameEnv TyCon
rec_tc_env = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyCon -> NameEnv TyCon -> NameEnv TyCon
add_tc forall a. NameEnv a
emptyNameEnv [TyCon]
rec_tycons
add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
add_tc TyCon
tc NameEnv TyCon
env = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyCon -> NameEnv TyCon -> NameEnv TyCon
add_one_tc NameEnv TyCon
env (TyCon
tc forall a. a -> [a] -> [a]
: TyCon -> [TyCon]
tyConATs TyCon
tc)
add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
add_one_tc TyCon
tc NameEnv TyCon
env = forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv NameEnv TyCon
env (TyCon -> Name
tyConName TyCon
tc) TyCon
tc
get :: Name -> TyCon
get Name
name = case forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv TyCon
rec_tc_env Name
name of
Just TyCon
tc -> TyCon
tc
Maybe TyCon
other -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"zipRecTyClss" (forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Maybe TyCon
other)
kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([TcTyCon], NameSet)
kcTyClGroup :: NameEnv Type -> [LTyClDecl GhcRn] -> TcM ([TyCon], NameSet)
kcTyClGroup NameEnv Type
kisig_env [LTyClDecl GhcRn]
decls
= do { Module
mod <- forall (m :: * -> *). HasModule m => m Module
getModule
; String -> SDoc -> TcRn ()
traceTc String
"---- kcTyClGroup ---- {"
(String -> SDoc
text String
"module" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [LTyClDecl GhcRn]
decls))
; Bool
cusks_enabled <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.CUSKs forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<&&> forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PolyKinds
; let ([GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
kindless_decls, [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)]
kinded_decls) = forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> Either
(GenLocated SrcSpanAnnA (TyClDecl GhcRn))
(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
get_kind [LTyClDecl GhcRn]
decls
kindless_names :: NameSet
kindless_names = [Name] -> NameSet
mkNameSet forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {p :: Pass} {l}.
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
GenLocated l (TyClDecl (GhcPass p)) -> IdGhcP p
get_name [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
kindless_decls
get_name :: GenLocated l (TyClDecl (GhcPass p)) -> IdP (GhcPass p)
get_name GenLocated l (TyClDecl (GhcPass p))
d = forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName (forall l e. GenLocated l e -> e
unLoc GenLocated l (TyClDecl (GhcPass p))
d)
get_kind :: GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> Either
(GenLocated SrcSpanAnnA (TyClDecl GhcRn))
(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
get_kind GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d
| Just Type
ki <- forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv Type
kisig_env (forall {p :: Pass} {l}.
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
GenLocated l (TyClDecl (GhcPass p)) -> IdGhcP p
get_name GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d)
= forall a b. b -> Either a b
Right (GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d, Type -> SAKS_or_CUSK
SAKS Type
ki)
| Bool
cusks_enabled Bool -> Bool -> Bool
&& TyClDecl GhcRn -> Bool
hsDeclHasCusk (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d)
= forall a b. b -> Either a b
Right (GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d, SAKS_or_CUSK
CUSK)
| Bool
otherwise = forall a b. a -> Either a b
Left GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d
; [TyCon]
checked_tcs <- forall r. TcM r -> TcM r
checkNoErrs forall a b. (a -> b) -> a -> b
$
[(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TyCon]
checkInitialKinds [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)]
kinded_decls
; [TyCon]
inferred_tcs
<- forall a. [TyCon] -> TcM a -> TcM a
tcExtendKindEnvWithTyCons [TyCon]
checked_tcs forall a b. (a -> b) -> a -> b
$
forall a. SkolemInfo -> [TyVar] -> TcM a -> TcM a
pushLevelAndSolveEqualities SkolemInfo
UnkSkol [] forall a b. (a -> b) -> a -> b
$
do {
[TyCon]
mono_tcs <- [LTyClDecl GhcRn] -> TcM [TyCon]
inferInitialKinds [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
kindless_decls
; String -> SDoc -> TcRn ()
traceTc String
"kcTyClGroup: initial kinds" forall a b. (a -> b) -> a -> b
$
[TyCon] -> SDoc
ppr_tc_kinds [TyCon]
mono_tcs
; forall r. TcM r -> TcM r
checkNoErrs forall a b. (a -> b) -> a -> b
$
forall a. [TyCon] -> TcM a -> TcM a
tcExtendKindEnvWithTyCons [TyCon]
mono_tcs forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ LTyClDecl GhcRn -> TcRn ()
kcLTyClDecl [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
kindless_decls
; forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon]
mono_tcs }
; let inferred_tc_env :: NameEnv TyCon
inferred_tc_env = forall a. [(Name, a)] -> NameEnv a
mkNameEnv forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (\TyCon
tc -> (TyCon -> Name
tyConName TyCon
tc, TyCon
tc)) [TyCon]
inferred_tcs
; [TyCon]
generalized_tcs <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (NameEnv TyCon -> LTyClDecl GhcRn -> TcM [TyCon]
generaliseTyClDecl NameEnv TyCon
inferred_tc_env)
[GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
kindless_decls
; let poly_tcs :: [TyCon]
poly_tcs = [TyCon]
checked_tcs forall a. [a] -> [a] -> [a]
++ [TyCon]
generalized_tcs
; String -> SDoc -> TcRn ()
traceTc String
"---- kcTyClGroup end ---- }" ([TyCon] -> SDoc
ppr_tc_kinds [TyCon]
poly_tcs)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TyCon]
poly_tcs, NameSet
kindless_names) }
where
ppr_tc_kinds :: [TyCon] -> SDoc
ppr_tc_kinds [TyCon]
tcs = [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map TyCon -> SDoc
pp_tc [TyCon]
tcs)
pp_tc :: TyCon -> SDoc
pp_tc TyCon
tc = forall a. Outputable a => a -> SDoc
ppr (TyCon -> Name
tyConName TyCon
tc) SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConKind TyCon
tc)
type ScopedPairs = [(Name, TcTyVar)]
generaliseTyClDecl :: NameEnv TcTyCon -> LTyClDecl GhcRn -> TcM [TcTyCon]
generaliseTyClDecl :: NameEnv TyCon -> LTyClDecl GhcRn -> TcM [TyCon]
generaliseTyClDecl NameEnv TyCon
inferred_tc_env (L SrcSpanAnnA
_ TyClDecl GhcRn
decl)
= do { let names_in_this_decl :: [Name]
names_in_this_decl :: [Name]
names_in_this_decl = TyClDecl GhcRn -> [Name]
tycld_names TyClDecl GhcRn
decl
; [(TyCon, [(Name, TyVar)])]
tc_with_tvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> TcM (TyCon, [(Name, TyVar)])
skolemise_tc_tycon [Name]
names_in_this_decl
; [(TyCon, [(Name, TyVar)], Type)]
tc_infos <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TyCon, [(Name, TyVar)]) -> TcM (TyCon, [(Name, TyVar)], Type)
zonk_tc_tycon [(TyCon, [(Name, TyVar)])]
tc_with_tvs
; [(TyCon, [(Name, TyVar)], Type)]
swizzled_infos <- forall a. TyClDecl GhcRn -> TcM a -> TcM a
tcAddDeclCtxt TyClDecl GhcRn
decl ([(TyCon, [(Name, TyVar)], Type)]
-> TcM [(TyCon, [(Name, TyVar)], Type)]
swizzleTcTyConBndrs [(TyCon, [(Name, TyVar)], Type)]
tc_infos)
; forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM (TyCon, [(Name, TyVar)], Type) -> TcM TyCon
generaliseTcTyCon [(TyCon, [(Name, TyVar)], Type)]
swizzled_infos }
where
tycld_names :: TyClDecl GhcRn -> [Name]
tycld_names :: TyClDecl GhcRn -> [Name]
tycld_names TyClDecl GhcRn
decl = forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
decl forall a. a -> [a] -> [a]
: TyClDecl GhcRn -> [Name]
at_names TyClDecl GhcRn
decl
at_names :: TyClDecl GhcRn -> [Name]
at_names :: TyClDecl GhcRn -> [Name]
at_names (ClassDecl { tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs = [LFamilyDecl GhcRn]
ats }) = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Pass). FamilyDecl (GhcPass p) -> IdP (GhcPass p)
familyDeclName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LFamilyDecl GhcRn]
ats
at_names TyClDecl GhcRn
_ = []
skolemise_tc_tycon :: Name -> TcM (TcTyCon, ScopedPairs)
skolemise_tc_tycon :: Name -> TcM (TyCon, [(Name, TyVar)])
skolemise_tc_tycon Name
tc_name
= do { let tc :: TyCon
tc = forall a. NameEnv a -> Name -> a
lookupNameEnv_NF NameEnv TyCon
inferred_tc_env Name
tc_name
; [(Name, TyVar)]
scoped_prs <- forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> [(a, b)] -> m [(a, c)]
mapSndM TyVar -> TcM TyVar
zonkAndSkolemise (TyCon -> [(Name, TyVar)]
tcTyConScopedTyVars TyCon
tc)
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
tc, [(Name, TyVar)]
scoped_prs) }
zonk_tc_tycon :: (TcTyCon, ScopedPairs) -> TcM (TcTyCon, ScopedPairs, TcKind)
zonk_tc_tycon :: (TyCon, [(Name, TyVar)]) -> TcM (TyCon, [(Name, TyVar)], Type)
zonk_tc_tycon (TyCon
tc, [(Name, TyVar)]
scoped_prs)
= do { [(Name, TyVar)]
scoped_prs <- forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> [(a, b)] -> m [(a, c)]
mapSndM HasDebugCallStack => TyVar -> TcM TyVar
zonkTcTyVarToTyVar [(Name, TyVar)]
scoped_prs
; Type
res_kind <- Type -> TcM Type
zonkTcType (TyCon -> Type
tyConResKind TyCon
tc)
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
tc, [(Name, TyVar)]
scoped_prs, Type
res_kind) }
swizzleTcTyConBndrs :: [(TcTyCon, ScopedPairs, TcKind)]
-> TcM [(TcTyCon, ScopedPairs, TcKind)]
swizzleTcTyConBndrs :: [(TyCon, [(Name, TyVar)], Type)]
-> TcM [(TyCon, [(Name, TyVar)], Type)]
swizzleTcTyConBndrs [(TyCon, [(Name, TyVar)], Type)]
tc_infos
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Name, TyVar) -> Bool
no_swizzle [(Name, TyVar)]
swizzle_prs
= do { String -> SDoc -> TcRn ()
traceTc String
"Skipping swizzleTcTyConBndrs for" (forall a. Outputable a => a -> SDoc
ppr (forall a b. (a -> b) -> [a] -> [b]
map forall a b c. (a, b, c) -> a
fstOf3 [(TyCon, [(Name, TyVar)], Type)]
tc_infos))
; forall (m :: * -> *) a. Monad m => a -> m a
return [(TyCon, [(Name, TyVar)], Type)]
tc_infos }
| Bool
otherwise
= do { TcRn ()
check_duplicate_tc_binders
; String -> SDoc -> TcRn ()
traceTc String
"swizzleTcTyConBndrs" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"before" SDoc -> SDoc -> SDoc
<+> forall {a} {a} {c}. Outputable a => [(a, [(a, TyVar)], c)] -> SDoc
ppr_infos [(TyCon, [(Name, TyVar)], Type)]
tc_infos
, String -> SDoc
text String
"swizzle_prs" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [(Name, TyVar)]
swizzle_prs
, String -> SDoc
text String
"after" SDoc -> SDoc -> SDoc
<+> forall {a} {a} {c}. Outputable a => [(a, [(a, TyVar)], c)] -> SDoc
ppr_infos [(TyCon, [(Name, TyVar)], Type)]
swizzled_infos ]
; forall (m :: * -> *) a. Monad m => a -> m a
return [(TyCon, [(Name, TyVar)], Type)]
swizzled_infos }
where
swizzled_infos :: [(TyCon, [(Name, TyVar)], Type)]
swizzled_infos = [ (TyCon
tc, forall b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd TyVar -> TyVar
swizzle_var [(Name, TyVar)]
scoped_prs, Type -> Type
swizzle_ty Type
kind)
| (TyCon
tc, [(Name, TyVar)]
scoped_prs, Type
kind) <- [(TyCon, [(Name, TyVar)], Type)]
tc_infos ]
swizzle_prs :: [(Name,TyVar)]
swizzle_prs :: [(Name, TyVar)]
swizzle_prs = [ (Name, TyVar)
pr | (TyCon
_, [(Name, TyVar)]
prs, Type
_) <- [(TyCon, [(Name, TyVar)], Type)]
tc_infos, (Name, TyVar)
pr <- [(Name, TyVar)]
prs ]
no_swizzle :: (Name,TyVar) -> Bool
no_swizzle :: (Name, TyVar) -> Bool
no_swizzle (Name
nm, TyVar
tv) = Name
nm forall a. Eq a => a -> a -> Bool
== TyVar -> Name
tyVarName TyVar
tv
ppr_infos :: [(a, [(a, TyVar)], c)] -> SDoc
ppr_infos [(a, [(a, TyVar)], c)]
infos = [SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr a
tc SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, TyVar)]
prs)
| (a
tc, [(a, TyVar)]
prs, c
_) <- [(a, [(a, TyVar)], c)]
infos ]
check_duplicate_tc_binders :: TcM ()
check_duplicate_tc_binders :: TcRn ()
check_duplicate_tc_binders = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, Name)]
err_prs) forall a b. (a -> b) -> a -> b
$
do { forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name, Name) -> TcRn ()
report_dup [(Name, Name)]
err_prs; forall env a. IOEnv env a
failM }
err_prs :: [(Name,Name)]
err_prs :: [(Name, Name)]
err_prs = [ (Name
n1,Name
n2)
| (Name, TyVar)
pr :| [(Name, TyVar)]
prs <- forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
findDupsEq (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> b
snd) [(Name, TyVar)]
swizzle_prs
, (Name
n1,TyVar
_):(Name
n2,TyVar
_):[(Name, TyVar)]
_ <- [forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) ((Name, TyVar)
prforall a. a -> [a] -> [a]
:[(Name, TyVar)]
prs)] ]
report_dup :: (Name,Name) -> TcM ()
report_dup :: (Name, Name) -> TcRn ()
report_dup (Name
n1,Name
n2)
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
n2) forall a b. (a -> b) -> a -> b
$ SDoc -> TcRn ()
addErrTc forall a b. (a -> b) -> a -> b
$
SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Different names for the same type variable:") Arity
2 SDoc
info
where
info :: SDoc
info | Name -> OccName
nameOccName Name
n1 forall a. Eq a => a -> a -> Bool
/= Name -> OccName
nameOccName Name
n2
= SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
n1) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"and" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
n2)
| Bool
otherwise
= [SDoc] -> SDoc
vcat [ SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
n1) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"bound at" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall a. NamedThing a => a -> SrcLoc
getSrcLoc Name
n1)
, SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
n2) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"bound at" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall a. NamedThing a => a -> SrcLoc
getSrcLoc Name
n2) ]
swizzle_env :: VarEnv Name
swizzle_env = forall a. [(TyVar, a)] -> VarEnv a
mkVarEnv (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> (b, a)
swap [(Name, TyVar)]
swizzle_prs)
swizzleMapper :: TyCoMapper () Identity
swizzleMapper :: TyCoMapper () Identity
swizzleMapper = TyCoMapper { tcm_tyvar :: () -> TyVar -> Identity Type
tcm_tyvar = forall {m :: * -> *} {p}. Monad m => p -> TyVar -> m Type
swizzle_tv
, tcm_covar :: () -> TyVar -> Identity Coercion
tcm_covar = forall {m :: * -> *} {p}. Monad m => p -> TyVar -> m Coercion
swizzle_cv
, tcm_hole :: () -> CoercionHole -> Identity Coercion
tcm_hole = forall {a} {p} {a}. Outputable a => p -> a -> a
swizzle_hole
, tcm_tycobinder :: () -> TyVar -> ArgFlag -> Identity ((), TyVar)
tcm_tycobinder = forall {m :: * -> *} {p} {p}.
Monad m =>
p -> TyVar -> p -> m ((), TyVar)
swizzle_bndr
, tcm_tycon :: TyCon -> Identity TyCon
tcm_tycon = forall {a} {a}. Outputable a => a -> a
swizzle_tycon }
swizzle_hole :: p -> a -> a
swizzle_hole p
_ a
hole = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"swizzle_hole" (forall a. Outputable a => a -> SDoc
ppr a
hole)
swizzle_tycon :: a -> a
swizzle_tycon a
tc = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"swizzle_tc" (forall a. Outputable a => a -> SDoc
ppr a
tc)
swizzle_tv :: p -> TyVar -> m Type
swizzle_tv p
_ TyVar
tv = forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Type
mkTyVarTy (TyVar -> TyVar
swizzle_var TyVar
tv))
swizzle_cv :: p -> TyVar -> m Coercion
swizzle_cv p
_ TyVar
cv = forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Coercion
mkCoVarCo (TyVar -> TyVar
swizzle_var TyVar
cv))
swizzle_bndr :: p -> TyVar -> p -> m ((), TyVar)
swizzle_bndr p
_ TyVar
tcv p
_
= forall (m :: * -> *) a. Monad m => a -> m a
return ((), TyVar -> TyVar
swizzle_var TyVar
tcv)
swizzle_var :: Var -> Var
swizzle_var :: TyVar -> TyVar
swizzle_var TyVar
v
| Just Name
nm <- forall a. VarEnv a -> TyVar -> Maybe a
lookupVarEnv VarEnv Name
swizzle_env TyVar
v
= (Type -> Type) -> TyVar -> TyVar
updateVarType Type -> Type
swizzle_ty (TyVar
v TyVar -> Name -> TyVar
`setVarName` Name
nm)
| Bool
otherwise
= (Type -> Type) -> TyVar -> TyVar
updateVarType Type -> Type
swizzle_ty TyVar
v
(Type -> Identity Type
map_type, [Type] -> Identity [Type]
_, Coercion -> Identity Coercion
_, [Coercion] -> Identity [Coercion]
_) = forall (m :: * -> *).
Monad m =>
TyCoMapper () m
-> (Type -> m Type, [Type] -> m [Type], Coercion -> m Coercion,
[Coercion] -> m [Coercion])
mapTyCo TyCoMapper () Identity
swizzleMapper
swizzle_ty :: Type -> Type
swizzle_ty Type
ty = forall a. Identity a -> a
runIdentity (Type -> Identity Type
map_type Type
ty)
generaliseTcTyCon :: (TcTyCon, ScopedPairs, TcKind) -> TcM TcTyCon
generaliseTcTyCon :: (TyCon, [(Name, TyVar)], Type) -> TcM TyCon
generaliseTcTyCon (TyCon
tc, [(Name, TyVar)]
scoped_prs, Type
tc_res_kind)
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyCon
tc) forall a b. (a -> b) -> a -> b
$
forall a. TyCon -> TcM a -> TcM a
addTyConCtxt TyCon
tc forall a b. (a -> b) -> a -> b
$
do {
; let spec_req_tvs :: [TyVar]
spec_req_tvs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, TyVar)]
scoped_prs
n_spec :: Arity
n_spec = forall (t :: * -> *) a. Foldable t => t a -> Arity
length [TyVar]
spec_req_tvs forall a. Num a => a -> a -> a
- TyCon -> Arity
tyConArity TyCon
tc
([TyVar]
spec_tvs, [TyVar]
req_tvs) = forall a. Arity -> [a] -> ([a], [a])
splitAt Arity
n_spec [TyVar]
spec_req_tvs
sorted_spec_tvs :: [TyVar]
sorted_spec_tvs = [TyVar] -> [TyVar]
scopedSort [TyVar]
spec_tvs
; CandidatesQTvs
dvs1 <- [Type] -> TcM CandidatesQTvs
candidateQTyVarsOfKinds forall a b. (a -> b) -> a -> b
$
(Type
tc_res_kind forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Type
tyVarKind [TyVar]
spec_req_tvs)
; let dvs2 :: CandidatesQTvs
dvs2 = CandidatesQTvs
dvs1 CandidatesQTvs -> [TyVar] -> CandidatesQTvs
`delCandidates` [TyVar]
spec_req_tvs
; [TyVar]
inferred <- CandidatesQTvs -> TcM [TyVar]
quantifyTyVars CandidatesQTvs
dvs2
; String -> SDoc -> TcRn ()
traceTc String
"generaliseTcTyCon: pre zonk"
([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"tycon =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyCon
tc
, String -> SDoc
text String
"spec_req_tvs =" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
spec_req_tvs
, String -> SDoc
text String
"tc_res_kind =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
tc_res_kind
, String -> SDoc
text String
"dvs1 =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr CandidatesQTvs
dvs1
, String -> SDoc
text String
"inferred =" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
inferred ])
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; (ZonkEnv
ze, [TyVar]
inferred) <- ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX ZonkEnv
ze [TyVar]
inferred
; (ZonkEnv
ze, [TyVar]
sorted_spec_tvs) <- ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX ZonkEnv
ze [TyVar]
sorted_spec_tvs
; (ZonkEnv
ze, [TyVar]
req_tvs) <- ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX ZonkEnv
ze [TyVar]
req_tvs
; Type
tc_res_kind <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
tc_res_kind
; String -> SDoc -> TcRn ()
traceTc String
"generaliseTcTyCon: post zonk" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"tycon =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyCon
tc
, String -> SDoc
text String
"inferred =" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
inferred
, String -> SDoc
text String
"spec_req_tvs =" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
spec_req_tvs
, String -> SDoc
text String
"sorted_spec_tvs =" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
sorted_spec_tvs
, String -> SDoc
text String
"req_tvs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyVar]
req_tvs
, String -> SDoc
text String
"zonk-env =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ZonkEnv
ze ]
; let dep_fv_set :: VarSet
dep_fv_set = CandidatesQTvs -> VarSet
candidateKindVars CandidatesQTvs
dvs1
inferred_tcbs :: [TyConBinder]
inferred_tcbs = ArgFlag -> [TyVar] -> [TyConBinder]
mkNamedTyConBinders ArgFlag
Inferred [TyVar]
inferred
specified_tcbs :: [TyConBinder]
specified_tcbs = ArgFlag -> [TyVar] -> [TyConBinder]
mkNamedTyConBinders ArgFlag
Specified [TyVar]
sorted_spec_tvs
required_tcbs :: [TyConBinder]
required_tcbs = forall a b. (a -> b) -> [a] -> [b]
map (VarSet -> TyVar -> TyConBinder
mkRequiredTyConBinder VarSet
dep_fv_set) [TyVar]
req_tvs
final_tcbs :: [TyConBinder]
final_tcbs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [TyConBinder]
inferred_tcbs
, [TyConBinder]
specified_tcbs
, [TyConBinder]
required_tcbs ]
tycon :: TyCon
tycon = Name
-> [TyConBinder]
-> Type
-> [(Name, TyVar)]
-> Bool
-> TyConFlavour
-> TyCon
mkTcTyCon (TyCon -> Name
tyConName TyCon
tc) [TyConBinder]
final_tcbs Type
tc_res_kind
([TyVar] -> [(Name, TyVar)]
mkTyVarNamePairs ([TyVar]
sorted_spec_tvs forall a. [a] -> [a] -> [a]
++ [TyVar]
req_tvs))
Bool
True
(TyCon -> TyConFlavour
tyConFlavour TyCon
tc)
; String -> SDoc -> TcRn ()
traceTc String
"generaliseTcTyCon done" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"tycon =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyCon
tc
, String -> SDoc
text String
"tc_res_kind =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
tc_res_kind
, String -> SDoc
text String
"dep_fv_set =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr VarSet
dep_fv_set
, String -> SDoc
text String
"inferred_tcbs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
inferred_tcbs
, String -> SDoc
text String
"specified_tcbs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
specified_tcbs
, String -> SDoc
text String
"required_tcbs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
required_tcbs
, String -> SDoc
text String
"final_tcbs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
final_tcbs ]
; TyCon -> TcRn ()
checkTyConTelescope TyCon
tycon
; forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tycon }
tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a
tcExtendKindEnvWithTyCons :: forall a. [TyCon] -> TcM a -> TcM a
tcExtendKindEnvWithTyCons [TyCon]
tcs
= forall r. [(Name, TcTyThing)] -> TcM r -> TcM r
tcExtendKindEnvList [ (TyCon -> Name
tyConName TyCon
tc, TyCon -> TcTyThing
ATcTyCon TyCon
tc) | TyCon
tc <- [TyCon]
tcs ]
mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv
mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv
mkPromotionErrorEnv [LTyClDecl GhcRn]
decls
= forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyClDecl GhcRn -> TcTypeEnv
mk_prom_err_env forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc)
forall a. NameEnv a
emptyNameEnv [LTyClDecl GhcRn]
decls
mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv
mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv
mk_prom_err_env (ClassDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
nm, tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs = [LFamilyDecl GhcRn]
ats })
= forall a. Name -> a -> NameEnv a
unitNameEnv Name
nm (PromotionErr -> TcTyThing
APromotionErr PromotionErr
ClassPE)
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv`
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (forall (p :: Pass). FamilyDecl (GhcPass p) -> IdP (GhcPass p)
familyDeclName FamilyDecl GhcRn
at, PromotionErr -> TcTyThing
APromotionErr PromotionErr
TyConPE)
| L SrcSpanAnnA
_ FamilyDecl GhcRn
at <- [LFamilyDecl GhcRn]
ats ]
mk_prom_err_env (DataDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
name
, tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn { dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons = [LConDecl GhcRn]
cons } })
= forall a. Name -> a -> NameEnv a
unitNameEnv Name
name (PromotionErr -> TcTyThing
APromotionErr PromotionErr
TyConPE)
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv`
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (Name
con, PromotionErr -> TcTyThing
APromotionErr PromotionErr
RecDataConPE)
| L SrcSpanAnnA
_ ConDecl GhcRn
con' <- [LConDecl GhcRn]
cons
, L SrcSpanAnnN
_ Name
con <- ConDecl GhcRn -> [GenLocated SrcSpanAnnN Name]
getConNames ConDecl GhcRn
con' ]
mk_prom_err_env TyClDecl GhcRn
decl
= forall a. Name -> a -> NameEnv a
unitNameEnv (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
decl) (PromotionErr -> TcTyThing
APromotionErr PromotionErr
TyConPE)
inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TyCon]
inferInitialKinds [LTyClDecl GhcRn]
decls
= do { String -> SDoc -> TcRn ()
traceTc String
"inferInitialKinds {" forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LTyClDecl GhcRn]
decls)
; [TyCon]
tcs <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM forall {ann}.
GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn) -> TcM [TyCon]
infer_initial_kind [LTyClDecl GhcRn]
decls
; String -> SDoc -> TcRn ()
traceTc String
"inferInitialKinds done }" SDoc
empty
; forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon]
tcs }
where
infer_initial_kind :: GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn) -> TcM [TyCon]
infer_initial_kind = forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA (InitialKindStrategy -> TyClDecl GhcRn -> TcM [TyCon]
getInitialKind InitialKindStrategy
InitialKindInfer)
checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon]
checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TyCon]
checkInitialKinds [(LTyClDecl GhcRn, SAKS_or_CUSK)]
decls
= do { String -> SDoc -> TcRn ()
traceTc String
"checkInitialKinds {" forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr (forall a c b. (a -> c) -> [(a, b)] -> [(c, b)]
mapFst (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [(LTyClDecl GhcRn, SAKS_or_CUSK)]
decls)
; [TyCon]
tcs <- forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM forall {ann}.
(GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn), SAKS_or_CUSK)
-> TcM [TyCon]
check_initial_kind [(LTyClDecl GhcRn, SAKS_or_CUSK)]
decls
; String -> SDoc -> TcRn ()
traceTc String
"checkInitialKinds done }" SDoc
empty
; forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon]
tcs }
where
check_initial_kind :: (GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn), SAKS_or_CUSK)
-> TcM [TyCon]
check_initial_kind (GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn)
ldecl, SAKS_or_CUSK
msig) =
forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA (InitialKindStrategy -> TyClDecl GhcRn -> TcM [TyCon]
getInitialKind (SAKS_or_CUSK -> InitialKindStrategy
InitialKindCheck SAKS_or_CUSK
msig)) GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn)
ldecl
getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon]
getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TyCon]
getInitialKind InitialKindStrategy
strategy
(ClassDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
name
, tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars = LHsQTyVars GhcRn
ktvs
, tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs = [LFamilyDecl GhcRn]
ats })
= do { TyCon
cls <- InitialKindStrategy
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM TyCon
kcDeclHeader InitialKindStrategy
strategy Name
name TyConFlavour
ClassFlavour LHsQTyVars GhcRn
ktvs forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> ContextKind
TheKind Type
constraintKind)
; let parent_tv_prs :: [(Name, TyVar)]
parent_tv_prs = TyCon -> [(Name, TyVar)]
tcTyConScopedTyVars TyCon
cls
; [TyCon]
inner_tcs <-
forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, TyVar)]
parent_tv_prs forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA (TyCon -> FamilyDecl GhcRn -> TcM TyCon
getAssocFamInitialKind TyCon
cls)) [LFamilyDecl GhcRn]
ats
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
cls forall a. a -> [a] -> [a]
: [TyCon]
inner_tcs) }
where
getAssocFamInitialKind :: TyCon -> FamilyDecl GhcRn -> TcM TyCon
getAssocFamInitialKind TyCon
cls =
case InitialKindStrategy
strategy of
InitialKindStrategy
InitialKindInfer -> Maybe TyCon -> FamilyDecl GhcRn -> TcM TyCon
get_fam_decl_initial_kind (forall a. a -> Maybe a
Just TyCon
cls)
InitialKindCheck SAKS_or_CUSK
_ -> TyCon -> FamilyDecl GhcRn -> TcM TyCon
check_initial_kind_assoc_fam TyCon
cls
getInitialKind InitialKindStrategy
strategy
(DataDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
name
, tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars = LHsQTyVars GhcRn
ktvs
, tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn { dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (LHsKind GhcRn)
m_sig
, dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_ND = NewOrData
new_or_data } })
= do { let flav :: TyConFlavour
flav = NewOrData -> TyConFlavour
newOrDataToFlavour NewOrData
new_or_data
ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
DataKindCtxt Name
name
; TyCon
tc <- InitialKindStrategy
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM TyCon
kcDeclHeader InitialKindStrategy
strategy Name
name TyConFlavour
flav LHsQTyVars GhcRn
ktvs forall a b. (a -> b) -> a -> b
$
case Maybe (LHsKind GhcRn)
m_sig of
Just LHsKind GhcRn
ksig -> Type -> ContextKind
TheKind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserTypeCtxt -> LHsKind GhcRn -> TcM Type
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
ksig
Maybe (LHsKind GhcRn)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ InitialKindStrategy -> NewOrData -> ContextKind
dataDeclDefaultResultKind InitialKindStrategy
strategy NewOrData
new_or_data
; forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon
tc] }
getInitialKind InitialKindStrategy
InitialKindInfer (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl GhcRn
decl })
= do { TyCon
tc <- Maybe TyCon -> FamilyDecl GhcRn -> TcM TyCon
get_fam_decl_initial_kind forall a. Maybe a
Nothing FamilyDecl GhcRn
decl
; forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon
tc] }
getInitialKind (InitialKindCheck SAKS_or_CUSK
msig) (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam =
FamilyDecl { fdLName :: forall pass. FamilyDecl pass -> LIdP pass
fdLName = forall l e. GenLocated l e -> e
unLoc -> Name
name
, fdTyVars :: forall pass. FamilyDecl pass -> LHsQTyVars pass
fdTyVars = LHsQTyVars GhcRn
ktvs
, fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdResultSig = forall l e. GenLocated l e -> e
unLoc -> FamilyResultSig GhcRn
resultSig
, fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcRn
info } } )
= do { let flav :: TyConFlavour
flav = forall pass. Maybe TyCon -> FamilyInfo pass -> TyConFlavour
getFamFlav forall a. Maybe a
Nothing FamilyInfo GhcRn
info
ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
TyFamResKindCtxt Name
name
; TyCon
tc <- InitialKindStrategy
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM TyCon
kcDeclHeader (SAKS_or_CUSK -> InitialKindStrategy
InitialKindCheck SAKS_or_CUSK
msig) Name
name TyConFlavour
flav LHsQTyVars GhcRn
ktvs forall a b. (a -> b) -> a -> b
$
case forall (p :: Pass).
FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p))
famResultKindSignature FamilyResultSig GhcRn
resultSig of
Just LHsKind GhcRn
ksig -> Type -> ContextKind
TheKind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserTypeCtxt -> LHsKind GhcRn -> TcM Type
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
ksig
Maybe (LHsKind GhcRn)
Nothing ->
case SAKS_or_CUSK
msig of
SAKS_or_CUSK
CUSK -> forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> ContextKind
TheKind Type
liftedTypeKind)
SAKS Type
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ContextKind
AnyKind
; forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon
tc] }
getInitialKind InitialKindStrategy
strategy
(SynDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
name
, tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars = LHsQTyVars GhcRn
ktvs
, tcdRhs :: forall pass. TyClDecl pass -> LHsType pass
tcdRhs = LHsKind GhcRn
rhs })
= do { let ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
TySynKindCtxt Name
name
; TyCon
tc <- InitialKindStrategy
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM TyCon
kcDeclHeader InitialKindStrategy
strategy Name
name TyConFlavour
TypeSynonymFlavour LHsQTyVars GhcRn
ktvs forall a b. (a -> b) -> a -> b
$
case forall (p :: Pass).
LHsType (GhcPass p) -> Maybe (LHsType (GhcPass p))
hsTyKindSig LHsKind GhcRn
rhs of
Just LHsKind GhcRn
rhs_sig -> Type -> ContextKind
TheKind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserTypeCtxt -> LHsKind GhcRn -> TcM Type
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
rhs_sig
Maybe (LHsKind GhcRn)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ContextKind
AnyKind
; forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon
tc] }
get_fam_decl_initial_kind
:: Maybe TcTyCon
-> FamilyDecl GhcRn
-> TcM TcTyCon
get_fam_decl_initial_kind :: Maybe TyCon -> FamilyDecl GhcRn -> TcM TyCon
get_fam_decl_initial_kind Maybe TyCon
mb_parent_tycon
FamilyDecl { fdLName :: forall pass. FamilyDecl pass -> LIdP pass
fdLName = L SrcSpanAnnN
_ Name
name
, fdTyVars :: forall pass. FamilyDecl pass -> LHsQTyVars pass
fdTyVars = LHsQTyVars GhcRn
ktvs
, fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdResultSig = L SrcSpan
_ FamilyResultSig GhcRn
resultSig
, fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcRn
info }
= InitialKindStrategy
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM TyCon
kcDeclHeader InitialKindStrategy
InitialKindInfer Name
name TyConFlavour
flav LHsQTyVars GhcRn
ktvs forall a b. (a -> b) -> a -> b
$
case FamilyResultSig GhcRn
resultSig of
KindSig XCKindSig GhcRn
_ LHsKind GhcRn
ki -> Type -> ContextKind
TheKind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserTypeCtxt -> LHsKind GhcRn -> TcM Type
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
ki
TyVarSig XTyVarSig GhcRn
_ (L SrcSpanAnnA
_ (KindedTyVar XKindedTyVar GhcRn
_ ()
_ LIdP GhcRn
_ LHsKind GhcRn
ki)) -> Type -> ContextKind
TheKind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserTypeCtxt -> LHsKind GhcRn -> TcM Type
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
ki
FamilyResultSig GhcRn
_
| TyConFlavour -> Bool
tcFlavourIsOpen TyConFlavour
flav -> forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> ContextKind
TheKind Type
liftedTypeKind)
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ContextKind
AnyKind
where
flav :: TyConFlavour
flav = forall pass. Maybe TyCon -> FamilyInfo pass -> TyConFlavour
getFamFlav Maybe TyCon
mb_parent_tycon FamilyInfo GhcRn
info
ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
TyFamResKindCtxt Name
name
check_initial_kind_assoc_fam
:: TcTyCon
-> FamilyDecl GhcRn
-> TcM TcTyCon
check_initial_kind_assoc_fam :: TyCon -> FamilyDecl GhcRn -> TcM TyCon
check_initial_kind_assoc_fam TyCon
cls
FamilyDecl
{ fdLName :: forall pass. FamilyDecl pass -> LIdP pass
fdLName = forall l e. GenLocated l e -> e
unLoc -> Name
name
, fdTyVars :: forall pass. FamilyDecl pass -> LHsQTyVars pass
fdTyVars = LHsQTyVars GhcRn
ktvs
, fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdResultSig = forall l e. GenLocated l e -> e
unLoc -> FamilyResultSig GhcRn
resultSig
, fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcRn
info }
= InitialKindStrategy
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM TyCon
kcDeclHeader (SAKS_or_CUSK -> InitialKindStrategy
InitialKindCheck SAKS_or_CUSK
CUSK) Name
name TyConFlavour
flav LHsQTyVars GhcRn
ktvs forall a b. (a -> b) -> a -> b
$
case forall (p :: Pass).
FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p))
famResultKindSignature FamilyResultSig GhcRn
resultSig of
Just LHsKind GhcRn
ksig -> Type -> ContextKind
TheKind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserTypeCtxt -> LHsKind GhcRn -> TcM Type
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
ksig
Maybe (LHsKind GhcRn)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> ContextKind
TheKind Type
liftedTypeKind)
where
ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
TyFamResKindCtxt Name
name
flav :: TyConFlavour
flav = forall pass. Maybe TyCon -> FamilyInfo pass -> TyConFlavour
getFamFlav (forall a. a -> Maybe a
Just TyCon
cls) FamilyInfo GhcRn
info
dataDeclDefaultResultKind :: InitialKindStrategy -> NewOrData -> ContextKind
dataDeclDefaultResultKind :: InitialKindStrategy -> NewOrData -> ContextKind
dataDeclDefaultResultKind InitialKindStrategy
strategy NewOrData
new_or_data
| NewOrData
NewType <- NewOrData
new_or_data
= ContextKind
OpenKind
| NewOrData
DataType <- NewOrData
new_or_data
, InitialKindCheck (SAKS Type
_) <- InitialKindStrategy
strategy
= ContextKind
OpenKind
| Bool
otherwise
= Type -> ContextKind
TheKind Type
liftedTypeKind
getFamFlav
:: Maybe TcTyCon
-> FamilyInfo pass
-> TyConFlavour
getFamFlav :: forall pass. Maybe TyCon -> FamilyInfo pass -> TyConFlavour
getFamFlav Maybe TyCon
mb_parent_tycon FamilyInfo pass
info =
case FamilyInfo pass
info of
FamilyInfo pass
DataFamily -> Maybe TyCon -> TyConFlavour
DataFamilyFlavour Maybe TyCon
mb_parent_tycon
FamilyInfo pass
OpenTypeFamily -> Maybe TyCon -> TyConFlavour
OpenTypeFamilyFlavour Maybe TyCon
mb_parent_tycon
ClosedTypeFamily Maybe [LTyFamInstEqn pass]
_ -> ASSERT( isNothing mb_parent_tycon )
TyConFlavour
ClosedTypeFamilyFlavour
kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()
kcLTyClDecl :: LTyClDecl GhcRn -> TcRn ()
kcLTyClDecl (L SrcSpanAnnA
loc TyClDecl GhcRn
decl)
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
do { TyCon
tycon <- HasDebugCallStack => Name -> TcM TyCon
tcLookupTcTyCon IdP GhcRn
tc_name
; String -> SDoc -> TcRn ()
traceTc String
"kcTyClDecl {" (forall a. Outputable a => a -> SDoc
ppr IdP GhcRn
tc_name)
; forall a. TyCon -> TcM a -> TcM a
addVDQNote TyCon
tycon forall a b. (a -> b) -> a -> b
$
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (TyClDecl GhcRn -> SDoc
tcMkDeclCtxt TyClDecl GhcRn
decl) forall a b. (a -> b) -> a -> b
$
TyClDecl GhcRn -> TyCon -> TcRn ()
kcTyClDecl TyClDecl GhcRn
decl TyCon
tycon
; String -> SDoc -> TcRn ()
traceTc String
"kcTyClDecl done }" (forall a. Outputable a => a -> SDoc
ppr IdP GhcRn
tc_name) }
where
tc_name :: IdP GhcRn
tc_name = forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
decl
kcTyClDecl :: TyClDecl GhcRn -> TcTyCon -> TcM ()
kcTyClDecl :: TyClDecl GhcRn -> TyCon -> TcRn ()
kcTyClDecl (DataDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = (L SrcSpanAnnN
_ Name
name), tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn GhcRn
defn }) TyCon
tycon
| HsDataDefn { dd_ctxt :: forall pass. HsDataDefn pass -> Maybe (LHsContext pass)
dd_ctxt = Maybe (LHsContext GhcRn)
ctxt, dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons = [LConDecl GhcRn]
cons, dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_ND = NewOrData
new_or_data } <- HsDataDefn GhcRn
defn
= forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
name forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
_ Type
_ ->
do { String -> SDoc -> TcRn ()
traceTc String
"kcTyClDecl" (forall a. Outputable a => a -> SDoc
ppr TyCon
tycon SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr (TyCon -> [TyVar]
tyConTyVars TyCon
tycon) SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConResKind TyCon
tycon))
; [Type]
_ <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
ctxt
; NewOrData -> Type -> [LConDecl GhcRn] -> TcRn ()
kcConDecls NewOrData
new_or_data (TyCon -> Type
tyConResKind TyCon
tycon) [LConDecl GhcRn]
cons
}
kcTyClDecl (SynDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
name, tcdRhs :: forall pass. TyClDecl pass -> LHsType pass
tcdRhs = LHsKind GhcRn
rhs }) TyCon
_tycon
= forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
name forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
_ Type
res_kind ->
forall a. TcM a -> TcRn ()
discardResult forall a b. (a -> b) -> a -> b
$ LHsKind GhcRn -> ContextKind -> TcM Type
tcCheckLHsType LHsKind GhcRn
rhs (Type -> ContextKind
TheKind Type
res_kind)
kcTyClDecl (ClassDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
name
, tcdCtxt :: forall pass. TyClDecl pass -> Maybe (LHsContext pass)
tcdCtxt = Maybe (LHsContext GhcRn)
ctxt, tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
tcdSigs = [LSig GhcRn]
sigs }) TyCon
_tycon
= forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
name forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
_ Type
_ ->
do { [Type]
_ <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
ctxt
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. (a -> TcRn ()) -> LocatedA a -> TcRn ()
wrapLocMA_ Sig GhcRn -> TcRn ()
kc_sig) [LSig GhcRn]
sigs }
where
kc_sig :: Sig GhcRn -> TcRn ()
kc_sig (ClassOpSig XClassOpSig GhcRn
_ Bool
_ [LIdP GhcRn]
nms LHsSigType GhcRn
op_ty) = [GenLocated SrcSpanAnnN Name] -> LHsSigType GhcRn -> TcRn ()
kcClassSigType [LIdP GhcRn]
nms LHsSigType GhcRn
op_ty
kc_sig Sig GhcRn
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
kcTyClDecl (FamDecl XFamDecl GhcRn
_ (FamilyDecl { fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcRn
fd_info })) TyCon
fam_tc
= case FamilyInfo GhcRn
fd_info of
ClosedTypeFamily (Just [LTyFamInstEqn GhcRn]
eqns) -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TyCon -> LTyFamInstEqn GhcRn -> TcRn ()
kcTyFamInstEqn TyCon
fam_tc) [LTyFamInstEqn GhcRn]
eqns
FamilyInfo GhcRn
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
kcConArgTys :: NewOrData -> Kind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM ()
kcConArgTys :: NewOrData -> Type -> [HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ()
kcConArgTys NewOrData
new_or_data Type
res_kind [HsScaled GhcRn (LHsKind GhcRn)]
arg_tys = do
{ let exp_kind :: ContextKind
exp_kind = NewOrData -> Type -> ContextKind
getArgExpKind NewOrData
new_or_data Type
res_kind
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [HsScaled GhcRn (LHsKind GhcRn)]
arg_tys (\(HsScaled HsArrow GhcRn
mult GenLocated SrcSpanAnnA (HsType GhcRn)
ty) -> do Type
_ <- LHsKind GhcRn -> ContextKind -> TcM Type
tcCheckLHsType (forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p)
getBangType GenLocated SrcSpanAnnA (HsType GhcRn)
ty) ContextKind
exp_kind
HsArrow GhcRn -> TcM Type
tcMult HsArrow GhcRn
mult)
}
kcConH98Args :: NewOrData -> Kind -> HsConDeclH98Details GhcRn -> TcM ()
kcConH98Args :: NewOrData -> Type -> HsConDeclH98Details GhcRn -> TcRn ()
kcConH98Args NewOrData
new_or_data Type
res_kind HsConDeclH98Details GhcRn
con_args = case HsConDeclH98Details GhcRn
con_args of
PrefixCon [Void]
_ [HsScaled GhcRn (LHsKind GhcRn)]
tys -> NewOrData -> Type -> [HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ()
kcConArgTys NewOrData
new_or_data Type
res_kind [HsScaled GhcRn (LHsKind GhcRn)]
tys
InfixCon HsScaled GhcRn (LHsKind GhcRn)
ty1 HsScaled GhcRn (LHsKind GhcRn)
ty2 -> NewOrData -> Type -> [HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ()
kcConArgTys NewOrData
new_or_data Type
res_kind [HsScaled GhcRn (LHsKind GhcRn)
ty1, HsScaled GhcRn (LHsKind GhcRn)
ty2]
RecCon (L SrcSpanAnnL
_ [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
flds) -> NewOrData -> Type -> [HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ()
kcConArgTys NewOrData
new_or_data Type
res_kind forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (forall a pass. a -> HsScaled pass a
hsLinear forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. ConDeclField pass -> LBangType pass
cd_fld_type forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
flds
kcConGADTArgs :: NewOrData -> Kind -> HsConDeclGADTDetails GhcRn -> TcM ()
kcConGADTArgs :: NewOrData -> Type -> HsConDeclGADTDetails GhcRn -> TcRn ()
kcConGADTArgs NewOrData
new_or_data Type
res_kind HsConDeclGADTDetails GhcRn
con_args = case HsConDeclGADTDetails GhcRn
con_args of
PrefixConGADT [HsScaled GhcRn (LHsKind GhcRn)]
tys -> NewOrData -> Type -> [HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ()
kcConArgTys NewOrData
new_or_data Type
res_kind [HsScaled GhcRn (LHsKind GhcRn)]
tys
RecConGADT (L SrcSpanAnnL
_ [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
flds) -> NewOrData -> Type -> [HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ()
kcConArgTys NewOrData
new_or_data Type
res_kind forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (forall a pass. a -> HsScaled pass a
hsLinear forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. ConDeclField pass -> LBangType pass
cd_fld_type forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
flds
kcConDecls :: NewOrData
-> Kind
-> [LConDecl GhcRn]
-> TcM ()
kcConDecls :: NewOrData -> Type -> [LConDecl GhcRn] -> TcRn ()
kcConDecls NewOrData
new_or_data Type
tc_res_kind [LConDecl GhcRn]
cons
= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. (a -> TcRn ()) -> LocatedA a -> TcRn ()
wrapLocMA_ (NewOrData -> Type -> ConDecl GhcRn -> TcRn ()
kcConDecl NewOrData
new_or_data Type
tc_res_kind)) [LConDecl GhcRn]
cons
kcConDecl :: NewOrData
-> Kind
-> ConDecl GhcRn
-> TcM ()
kcConDecl :: NewOrData -> Type -> ConDecl GhcRn -> TcRn ()
kcConDecl NewOrData
new_or_data Type
tc_res_kind (ConDeclH98
{ con_name :: forall pass. ConDecl pass -> LIdP pass
con_name = LIdP GhcRn
name, con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_ex_tvs = [LHsTyVarBndr Specificity GhcRn]
ex_tvs
, con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcRn)
ex_ctxt, con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_args = HsConDeclH98Details GhcRn
args })
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([GenLocated SrcSpanAnnN Name] -> SDoc
dataConCtxt [LIdP GhcRn
name]) forall a b. (a -> b) -> a -> b
$
forall a. TcM a -> TcRn ()
discardResult forall a b. (a -> b) -> a -> b
$
forall flag a.
OutputableBndrFlag flag 'Renamed =>
[LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrs_Tv [LHsTyVarBndr Specificity GhcRn]
ex_tvs forall a b. (a -> b) -> a -> b
$
do { [Type]
_ <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
ex_ctxt
; NewOrData -> Type -> HsConDeclH98Details GhcRn -> TcRn ()
kcConH98Args NewOrData
new_or_data Type
tc_res_kind HsConDeclH98Details GhcRn
args
}
kcConDecl NewOrData
new_or_data
Type
_tc_res_kind
(ConDeclGADT
{ con_names :: forall pass. ConDecl pass -> [LIdP pass]
con_names = [LIdP GhcRn]
names, con_bndrs :: forall pass. ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)
con_bndrs = L SrcSpanAnnA
_ HsOuterSigTyVarBndrs GhcRn
outer_bndrs, con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcRn)
cxt
, con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_g_args = HsConDeclGADTDetails GhcRn
args, con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_res_ty = LHsKind GhcRn
res_ty })
=
forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([GenLocated SrcSpanAnnN Name] -> SDoc
dataConCtxt [LIdP GhcRn]
names) forall a b. (a -> b) -> a -> b
$
forall a. TcM a -> TcRn ()
discardResult forall a b. (a -> b) -> a -> b
$
forall a.
HsOuterSigTyVarBndrs GhcRn
-> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)
bindOuterSigTKBndrs_Tv HsOuterSigTyVarBndrs GhcRn
outer_bndrs forall a b. (a -> b) -> a -> b
$
do { [Type]
_ <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
cxt
; String -> SDoc -> TcRn ()
traceTc String
"kcConDecl:GADT {" (forall a. Outputable a => a -> SDoc
ppr [LIdP GhcRn]
names SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr LHsKind GhcRn
res_ty)
; Type
con_res_kind <- TcM Type
newOpenTypeKind
; Type
_ <- LHsKind GhcRn -> ContextKind -> TcM Type
tcCheckLHsType LHsKind GhcRn
res_ty (Type -> ContextKind
TheKind Type
con_res_kind)
; NewOrData -> Type -> HsConDeclGADTDetails GhcRn -> TcRn ()
kcConGADTArgs NewOrData
new_or_data Type
con_res_kind HsConDeclGADTDetails GhcRn
args
; String -> SDoc -> TcRn ()
traceTc String
"kcConDecl:GADT }" (forall a. Outputable a => a -> SDoc
ppr [LIdP GhcRn]
names SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Type
con_res_kind)
; forall (m :: * -> *) a. Monad m => a -> m a
return () }
tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo])
tcTyClDecl :: (Name -> [Role]) -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo])
tcTyClDecl Name -> [Role]
roles_info (L SrcSpanAnnA
loc TyClDecl GhcRn
decl)
| Just TyThing
thing <- Name -> Maybe TyThing
wiredInNameTyThing_maybe (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
decl)
= case TyThing
thing of
ATyCon TyCon
tc -> forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
tc, TyCon -> TyClDecl GhcRn -> [DerivInfo]
wiredInDerivInfo TyCon
tc TyClDecl GhcRn
decl)
TyThing
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcTyClDecl" (forall a. Outputable a => a -> SDoc
ppr TyThing
thing)
| Bool
otherwise
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ forall a. TyClDecl GhcRn -> TcM a -> TcM a
tcAddDeclCtxt TyClDecl GhcRn
decl forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"---- tcTyClDecl ---- {" (forall a. Outputable a => a -> SDoc
ppr TyClDecl GhcRn
decl)
; (TyCon
tc, [DerivInfo]
deriv_infos) <- Maybe Class
-> (Name -> [Role]) -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo])
tcTyClDecl1 forall a. Maybe a
Nothing Name -> [Role]
roles_info TyClDecl GhcRn
decl
; String -> SDoc -> TcRn ()
traceTc String
"---- tcTyClDecl end ---- }" (forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
tc, [DerivInfo]
deriv_infos) }
noDerivInfos :: a -> (a, [DerivInfo])
noDerivInfos :: forall a. a -> (a, [DerivInfo])
noDerivInfos a
a = (a
a, [])
wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo]
wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo]
wiredInDerivInfo TyCon
tycon TyClDecl GhcRn
decl
| DataDecl { tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn GhcRn
dataDefn } <- TyClDecl GhcRn
decl
, HsDataDefn { dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs = HsDeriving GhcRn
derivs } <- HsDataDefn GhcRn
dataDefn
= [ DerivInfo { di_rep_tc :: TyCon
di_rep_tc = TyCon
tycon
, di_scoped_tvs :: [(Name, TyVar)]
di_scoped_tvs =
if TyCon -> Bool
isFunTyCon TyCon
tycon Bool -> Bool -> Bool
|| TyCon -> Bool
isPrimTyCon TyCon
tycon
then []
else [TyVar] -> [(Name, TyVar)]
mkTyVarNamePairs (TyCon -> [TyVar]
tyConTyVars TyCon
tycon)
, di_clauses :: HsDeriving GhcRn
di_clauses = HsDeriving GhcRn
derivs
, di_ctxt :: SDoc
di_ctxt = TyClDecl GhcRn -> SDoc
tcMkDeclCtxt TyClDecl GhcRn
decl } ]
wiredInDerivInfo TyCon
_ TyClDecl GhcRn
_ = []
tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo])
tcTyClDecl1 :: Maybe Class
-> (Name -> [Role]) -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo])
tcTyClDecl1 Maybe Class
parent Name -> [Role]
_roles_info (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl GhcRn
fd })
= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> (a, [DerivInfo])
noDerivInfos forall a b. (a -> b) -> a -> b
$
Maybe Class -> FamilyDecl GhcRn -> TcM TyCon
tcFamDecl1 Maybe Class
parent FamilyDecl GhcRn
fd
tcTyClDecl1 Maybe Class
_parent Name -> [Role]
roles_info
(SynDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
tc_name
, tcdRhs :: forall pass. TyClDecl pass -> LHsType pass
tcdRhs = LHsKind GhcRn
rhs })
= ASSERT( isNothing _parent )
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> (a, [DerivInfo])
noDerivInfos forall a b. (a -> b) -> a -> b
$
(Name -> [Role]) -> Name -> LHsKind GhcRn -> TcM TyCon
tcTySynRhs Name -> [Role]
roles_info Name
tc_name LHsKind GhcRn
rhs
tcTyClDecl1 Maybe Class
_parent Name -> [Role]
roles_info
decl :: TyClDecl GhcRn
decl@(DataDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
tc_name
, tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn GhcRn
defn })
= ASSERT( isNothing _parent )
SDoc
-> (Name -> [Role])
-> Name
-> HsDataDefn GhcRn
-> TcM (TyCon, [DerivInfo])
tcDataDefn (TyClDecl GhcRn -> SDoc
tcMkDeclCtxt TyClDecl GhcRn
decl) Name -> [Role]
roles_info Name
tc_name HsDataDefn GhcRn
defn
tcTyClDecl1 Maybe Class
_parent Name -> [Role]
roles_info
(ClassDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
class_name
, tcdCtxt :: forall pass. TyClDecl pass -> Maybe (LHsContext pass)
tcdCtxt = Maybe (LHsContext GhcRn)
hs_ctxt
, tcdMeths :: forall pass. TyClDecl pass -> LHsBinds pass
tcdMeths = LHsBinds GhcRn
meths
, tcdFDs :: forall pass. TyClDecl pass -> [LHsFunDep pass]
tcdFDs = [LHsFunDep GhcRn]
fundeps
, tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
tcdSigs = [LSig GhcRn]
sigs
, tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs = [LFamilyDecl GhcRn]
ats
, tcdATDefs :: forall pass. TyClDecl pass -> [LTyFamDefltDecl pass]
tcdATDefs = [LTyFamDefltDecl GhcRn]
at_defs })
= ASSERT( isNothing _parent )
do { Class
clas <- (Name -> [Role])
-> Name
-> Maybe (LHsContext GhcRn)
-> LHsBinds GhcRn
-> [LHsFunDep GhcRn]
-> [LSig GhcRn]
-> [LFamilyDecl GhcRn]
-> [LTyFamDefltDecl GhcRn]
-> TcM Class
tcClassDecl1 Name -> [Role]
roles_info Name
class_name Maybe (LHsContext GhcRn)
hs_ctxt
LHsBinds GhcRn
meths [LHsFunDep GhcRn]
fundeps [LSig GhcRn]
sigs [LFamilyDecl GhcRn]
ats [LTyFamDefltDecl GhcRn]
at_defs
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> (a, [DerivInfo])
noDerivInfos (Class -> TyCon
classTyCon Class
clas)) }
tcClassDecl1 :: RolesInfo -> Name -> Maybe (LHsContext GhcRn)
-> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn]
-> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn]
-> TcM Class
tcClassDecl1 :: (Name -> [Role])
-> Name
-> Maybe (LHsContext GhcRn)
-> LHsBinds GhcRn
-> [LHsFunDep GhcRn]
-> [LSig GhcRn]
-> [LFamilyDecl GhcRn]
-> [LTyFamDefltDecl GhcRn]
-> TcM Class
tcClassDecl1 Name -> [Role]
roles_info Name
class_name Maybe (LHsContext GhcRn)
hs_ctxt LHsBinds GhcRn
meths [LHsFunDep GhcRn]
fundeps [LSig GhcRn]
sigs [LFamilyDecl GhcRn]
ats [LTyFamDefltDecl GhcRn]
at_defs
= forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM forall a b. (a -> b) -> a -> b
$ \ Class
clas ->
forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
class_name forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
binders Type
res_kind ->
do { Type -> TcRn ()
checkClassKindSig Type
res_kind
; String -> SDoc -> TcRn ()
traceTc String
"tcClassDecl 1" (forall a. Outputable a => a -> SDoc
ppr Name
class_name SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
binders)
; let tycon_name :: Name
tycon_name = Name
class_name
roles :: [Role]
roles = Name -> [Role]
roles_info Name
tycon_name
; ([Type]
ctxt, [([TyVar], [TyVar])]
fds, [TcMethInfo]
sig_stuff, [ClassATItem]
at_stuff)
<- forall a. SkolemInfo -> [TyVar] -> TcM a -> TcM a
pushLevelAndSolveEqualities SkolemInfo
skol_info (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
binders) forall a b. (a -> b) -> a -> b
$
do { [Type]
ctxt <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
hs_ctxt
; [([TyVar], [TyVar])]
fds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA FunDep GhcRn -> TcM ([TyVar], [TyVar])
tc_fundep) [LHsFunDep GhcRn]
fundeps
; [TcMethInfo]
sig_stuff <- Name -> [LSig GhcRn] -> LHsBinds GhcRn -> TcM [TcMethInfo]
tcClassSigs Name
class_name [LSig GhcRn]
sigs LHsBinds GhcRn
meths
; [ClassATItem]
at_stuff <- Name
-> Class
-> [LFamilyDecl GhcRn]
-> [LTyFamDefltDecl GhcRn]
-> TcM [ClassATItem]
tcClassATs Name
class_name Class
clas [LFamilyDecl GhcRn]
ats [LTyFamDefltDecl GhcRn]
at_defs
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
ctxt, [([TyVar], [TyVar])]
fds, [TcMethInfo]
sig_stuff, [ClassATItem]
at_stuff) }
; CandidatesQTvs
dvs <- [Type] -> TcM CandidatesQTvs
candidateQTyVarsOfTypes [Type]
ctxt
; let mk_doc :: TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
mk_doc TidyEnv
tidy_env = do { (TidyEnv
tidy_env2, [Type]
ctxt) <- TidyEnv -> [Type] -> TcM (TidyEnv, [Type])
zonkTidyTcTypes TidyEnv
tidy_env [Type]
ctxt
; forall (m :: * -> *) a. Monad m => a -> m a
return ( TidyEnv
tidy_env2
, [SDoc] -> SDoc
sep [ String -> SDoc
text String
"the class context:"
, [Type] -> SDoc
pprTheta [Type]
ctxt ] ) }
; CandidatesQTvs
-> (TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc))
-> TcRn ()
doNotQuantifyTyVars CandidatesQTvs
dvs TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
mk_doc
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; [Type]
ctxt <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
ctxt
; [TcMethInfo]
sig_stuff <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> TcMethInfo -> TcM TcMethInfo
zonkTcMethInfoToMethInfoX ZonkEnv
ze) [TcMethInfo]
sig_stuff
; ClassMinimalDef
mindef <- Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef
tcClassMinimalDef Name
class_name [LSig GhcRn]
sigs [TcMethInfo]
sig_stuff
; Bool
is_boot <- IOEnv (Env TcGblEnv TcLclEnv) Bool
tcIsHsBootOrSig
; let body :: Maybe ([Type], [ClassATItem], [TcMethInfo], ClassMinimalDef)
body | Bool
is_boot, forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
ctxt, forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClassATItem]
at_stuff, forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcMethInfo]
sig_stuff
= forall a. Maybe a
Nothing
| Bool
otherwise
= forall a. a -> Maybe a
Just ([Type]
ctxt, [ClassATItem]
at_stuff, [TcMethInfo]
sig_stuff, ClassMinimalDef
mindef)
; Class
clas <- forall m n.
Name
-> [TyConBinder]
-> [Role]
-> [([TyVar], [TyVar])]
-> Maybe ([Type], [ClassATItem], [TcMethInfo], ClassMinimalDef)
-> TcRnIf m n Class
buildClass Name
class_name [TyConBinder]
binders [Role]
roles [([TyVar], [TyVar])]
fds Maybe ([Type], [ClassATItem], [TcMethInfo], ClassMinimalDef)
body
; String -> SDoc -> TcRn ()
traceTc String
"tcClassDecl" (forall a. Outputable a => a -> SDoc
ppr [LHsFunDep GhcRn]
fundeps SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
binders SDoc -> SDoc -> SDoc
$$
forall a. Outputable a => a -> SDoc
ppr [([TyVar], [TyVar])]
fds)
; forall (m :: * -> *) a. Monad m => a -> m a
return Class
clas }
where
skol_info :: SkolemInfo
skol_info = TyConFlavour -> Name -> SkolemInfo
TyConSkol TyConFlavour
ClassFlavour Name
class_name
tc_fundep :: GHC.Hs.FunDep GhcRn -> TcM ([Var],[Var])
tc_fundep :: FunDep GhcRn -> TcM ([TyVar], [TyVar])
tc_fundep (FunDep XCFunDep GhcRn
_ [LIdP GhcRn]
tvs1 [LIdP GhcRn]
tvs2)
= do { [TyVar]
tvs1' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> TcM TyVar
tcLookupTyVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LIdP GhcRn]
tvs1 ;
; [TyVar]
tvs2' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> TcM TyVar
tcLookupTyVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LIdP GhcRn]
tvs2 ;
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
tvs1',[TyVar]
tvs2') }
tcClassATs :: Name
-> Class
-> [LFamilyDecl GhcRn]
-> [LTyFamDefltDecl GhcRn]
-> TcM [ClassATItem]
tcClassATs :: Name
-> Class
-> [LFamilyDecl GhcRn]
-> [LTyFamDefltDecl GhcRn]
-> TcM [ClassATItem]
tcClassATs Name
class_name Class
cls [LFamilyDecl GhcRn]
ats [LTyFamDefltDecl GhcRn]
at_defs
= do {
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ forall a. SDoc -> TcM a
failWithTc (Name -> Name -> SDoc
badATErr Name
class_name Name
n)
| Name
n <- forall a b. (a -> b) -> [a] -> [b]
map LTyFamDefltDecl GhcRn -> Name
at_def_tycon [LTyFamDefltDecl GhcRn]
at_defs
, Bool -> Bool
not (Name
n Name -> NameSet -> Bool
`elemNameSet` NameSet
at_names) ]
; forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) ClassATItem
tc_at [LFamilyDecl GhcRn]
ats }
where
at_def_tycon :: LTyFamDefltDecl GhcRn -> Name
at_def_tycon :: LTyFamDefltDecl GhcRn -> Name
at_def_tycon = forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)
tyFamInstDeclName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc
at_fam_name :: LFamilyDecl GhcRn -> Name
at_fam_name :: LFamilyDecl GhcRn -> Name
at_fam_name = forall (p :: Pass). FamilyDecl (GhcPass p) -> IdP (GhcPass p)
familyDeclName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc
at_names :: NameSet
at_names = [Name] -> NameSet
mkNameSet (forall a b. (a -> b) -> [a] -> [b]
map LFamilyDecl GhcRn -> Name
at_fam_name [LFamilyDecl GhcRn]
ats)
at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn]
at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn]
at_defs_map = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
at_def NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
nenv -> forall a. (a -> a -> a) -> NameEnv a -> Name -> a -> NameEnv a
extendNameEnv_C forall a. [a] -> [a] -> [a]
(++) NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
nenv
(LTyFamDefltDecl GhcRn -> Name
at_def_tycon GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
at_def) [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
at_def])
forall a. NameEnv a
emptyNameEnv [LTyFamDefltDecl GhcRn]
at_defs
tc_at :: GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) ClassATItem
tc_at GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
at = do { TyCon
fam_tc <- forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA (Maybe Class -> FamilyDecl GhcRn -> TcM TyCon
tcFamDecl1 (forall a. a -> Maybe a
Just Class
cls)) GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
at
; let at_defs :: [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
at_defs = forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv [LTyFamDefltDecl GhcRn]
at_defs_map (LFamilyDecl GhcRn -> Name
at_fam_name GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
at)
forall a. Maybe a -> a -> a
`orElse` []
; Maybe (Type, ATValidityInfo)
atd <- TyCon
-> [LTyFamDefltDecl GhcRn] -> TcM (Maybe (Type, ATValidityInfo))
tcDefaultAssocDecl TyCon
fam_tc [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
at_defs
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> Maybe (Type, ATValidityInfo) -> ClassATItem
ATI TyCon
fam_tc Maybe (Type, ATValidityInfo)
atd) }
tcDefaultAssocDecl ::
TyCon
-> [LTyFamDefltDecl GhcRn]
-> TcM (Maybe (KnotTied Type, ATValidityInfo))
tcDefaultAssocDecl :: TyCon
-> [LTyFamDefltDecl GhcRn] -> TcM (Maybe (Type, ATValidityInfo))
tcDefaultAssocDecl TyCon
_ []
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
tcDefaultAssocDecl TyCon
_ (LTyFamDefltDecl GhcRn
d1:LTyFamDefltDecl GhcRn
_:[LTyFamDefltDecl GhcRn]
_)
= forall a. SDoc -> TcM a
failWithTc (String -> SDoc
text String
"More than one default declaration for"
SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)
tyFamInstDeclName (forall l e. GenLocated l e -> e
unLoc LTyFamDefltDecl GhcRn
d1)))
tcDefaultAssocDecl TyCon
fam_tc
[L SrcSpanAnnA
loc (TyFamInstDecl { tfid_eqn :: forall pass. TyFamInstDecl pass -> TyFamInstEqn pass
tfid_eqn =
FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = L SrcSpanAnnN
_ Name
tc_name
, feqn_bndrs :: forall pass rhs. FamEqn pass rhs -> HsOuterFamEqnTyVarBndrs pass
feqn_bndrs = HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs
, feqn_pats :: forall pass rhs. FamEqn pass rhs -> HsTyPats pass
feqn_pats = HsTyPats GhcRn
hs_pats
, feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = LHsKind GhcRn
hs_rhs_ty }})]
=
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
forall a. SDoc -> Name -> TcM a -> TcM a
tcAddFamInstCtxt (String -> SDoc
text String
"default type instance") Name
tc_name forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcDefaultAssocDecl 1" (forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
; let fam_tc_name :: Name
fam_tc_name = TyCon -> Name
tyConName TyCon
fam_tc
vis_arity :: Arity
vis_arity = forall (t :: * -> *) a. Foldable t => t a -> Arity
length (TyCon -> [TyVar]
tyConVisibleTyVars TyCon
fam_tc)
vis_pats :: Arity
vis_pats = forall tm ty. [HsArg tm ty] -> Arity
numVisibleArgs HsTyPats GhcRn
hs_pats
; ASSERT( fam_tc_name == tc_name )
Bool -> SDoc -> TcRn ()
checkTc (TyCon -> Bool
isTypeFamilyTyCon TyCon
fam_tc) (TyCon -> SDoc
wrongKindOfFamily TyCon
fam_tc)
; Bool -> SDoc -> TcRn ()
checkTc (Arity
vis_pats forall a. Eq a => a -> a -> Bool
== Arity
vis_arity)
(Arity -> SDoc
wrongNumberOfParmsErr Arity
vis_arity)
; ([TyVar]
qtvs, [Type]
pats, Type
rhs_ty) <- TyCon
-> AssocInstInfo
-> HsOuterFamEqnTyVarBndrs GhcRn
-> HsTyPats GhcRn
-> LHsKind GhcRn
-> TcM ([TyVar], [Type], Type)
tcTyFamInstEqnGuts TyCon
fam_tc AssocInstInfo
NotAssociated
HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs HsTyPats GhcRn
hs_pats LHsKind GhcRn
hs_rhs_ty
; let fam_tvs :: [TyVar]
fam_tvs = TyCon -> [TyVar]
tyConTyVars TyCon
fam_tc
; String -> SDoc -> TcRn ()
traceTc String
"tcDefaultAssocDecl 2" ([SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"hs_pats" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr HsTyPats GhcRn
hs_pats
, String -> SDoc
text String
"hs_rhs_ty" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr LHsKind GhcRn
hs_rhs_ty
, String -> SDoc
text String
"fam_tvs" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyVar]
fam_tvs
, String -> SDoc
text String
"qtvs" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyVar]
qtvs
])
; let subst :: TCvSubst
subst = case forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Type -> Maybe TyVar
getTyVar_maybe [Type]
pats of
Just [TyVar]
cpt_tvs -> HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst
zipTvSubst [TyVar]
cpt_tvs ([TyVar] -> [Type]
mkTyVarTys [TyVar]
fam_tvs)
Maybe [TyVar]
Nothing -> TCvSubst
emptyTCvSubst
; forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (TCvSubst -> Type -> Type
substTyUnchecked TCvSubst
subst Type
rhs_ty, SrcSpan -> [Type] -> ATValidityInfo
ATVI (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) [Type]
pats)
}
tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon
tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon
tcFamDecl1 Maybe Class
parent (FamilyDecl { fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcRn
fam_info
, fdLName :: forall pass. FamilyDecl pass -> LIdP pass
fdLName = tc_lname :: LIdP GhcRn
tc_lname@(L SrcSpanAnnN
_ Name
tc_name)
, fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdResultSig = L SrcSpan
_ FamilyResultSig GhcRn
sig
, fdInjectivityAnn :: forall pass. FamilyDecl pass -> Maybe (LInjectivityAnn pass)
fdInjectivityAnn = Maybe (LInjectivityAnn GhcRn)
inj })
| FamilyInfo GhcRn
DataFamily <- FamilyInfo GhcRn
fam_info
= forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tc_name forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
binders Type
res_kind -> do
{ String -> SDoc -> TcRn ()
traceTc String
"data family:" (forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
; Name -> TcRn ()
checkFamFlag Name
tc_name
; DataSort -> Type -> TcRn ()
checkDataKindSig DataSort
DataFamilySort Type
res_kind
; Name
tc_rep_name <- forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
tc_name
; let inj :: Injectivity
inj = [Bool] -> Injectivity
Injective forall a b. (a -> b) -> a -> b
$ forall a. Arity -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Arity
length [TyConBinder]
binders) Bool
True
tycon :: TyCon
tycon = Name
-> [TyConBinder]
-> Type
-> Maybe Name
-> FamTyConFlav
-> Maybe Class
-> Injectivity
-> TyCon
mkFamilyTyCon Name
tc_name [TyConBinder]
binders
Type
res_kind
(forall (a :: Pass).
FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
resultVariableName FamilyResultSig GhcRn
sig)
(Name -> FamTyConFlav
DataFamilyTyCon Name
tc_rep_name)
Maybe Class
parent Injectivity
inj
; forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tycon }
| FamilyInfo GhcRn
OpenTypeFamily <- FamilyInfo GhcRn
fam_info
= forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tc_name forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
binders Type
res_kind -> do
{ String -> SDoc -> TcRn ()
traceTc String
"open type family:" (forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
; Name -> TcRn ()
checkFamFlag Name
tc_name
; Injectivity
inj' <- [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) -> TcM Injectivity
tcInjectivity [TyConBinder]
binders Maybe (LInjectivityAnn GhcRn)
inj
; Name -> FamilyResultSig GhcRn -> TcRn ()
checkResultSigFlag Name
tc_name FamilyResultSig GhcRn
sig
; let tycon :: TyCon
tycon = Name
-> [TyConBinder]
-> Type
-> Maybe Name
-> FamTyConFlav
-> Maybe Class
-> Injectivity
-> TyCon
mkFamilyTyCon Name
tc_name [TyConBinder]
binders Type
res_kind
(forall (a :: Pass).
FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
resultVariableName FamilyResultSig GhcRn
sig) FamTyConFlav
OpenSynFamilyTyCon
Maybe Class
parent Injectivity
inj'
; forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tycon }
| ClosedTypeFamily Maybe [LTyFamInstEqn GhcRn]
mb_eqns <- FamilyInfo GhcRn
fam_info
=
do { String -> SDoc -> TcRn ()
traceTc String
"Closed type family:" (forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
; (Injectivity
inj', [TyConBinder]
binders, Type
res_kind)
<- forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tc_name forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
binders Type
res_kind ->
do { Injectivity
inj' <- [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) -> TcM Injectivity
tcInjectivity [TyConBinder]
binders Maybe (LInjectivityAnn GhcRn)
inj
; forall (m :: * -> *) a. Monad m => a -> m a
return (Injectivity
inj', [TyConBinder]
binders, Type
res_kind) }
; Name -> TcRn ()
checkFamFlag Name
tc_name
; Name -> FamilyResultSig GhcRn -> TcRn ()
checkResultSigFlag Name
tc_name FamilyResultSig GhcRn
sig
; case Maybe [LTyFamInstEqn GhcRn]
mb_eqns of
Maybe [LTyFamInstEqn GhcRn]
Nothing ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name
-> [TyConBinder]
-> Type
-> Maybe Name
-> FamTyConFlav
-> Maybe Class
-> Injectivity
-> TyCon
mkFamilyTyCon Name
tc_name [TyConBinder]
binders Type
res_kind
(forall (a :: Pass).
FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
resultVariableName FamilyResultSig GhcRn
sig)
FamTyConFlav
AbstractClosedSynFamilyTyCon Maybe Class
parent
Injectivity
inj'
Just [LTyFamInstEqn GhcRn]
eqns -> do {
; let tc_fam_tc :: TyCon
tc_fam_tc = Name
-> [TyConBinder]
-> Type
-> [(Name, TyVar)]
-> Bool
-> TyConFlavour
-> TyCon
mkTcTyCon Name
tc_name [TyConBinder]
binders Type
res_kind
[(Name, TyVar)]
noTcTyConScopedTyVars
Bool
False
TyConFlavour
ClosedTypeFamilyFlavour
; [KnotTied CoAxBranch]
branches <- forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM (TyCon
-> AssocInstInfo
-> LTyFamInstEqn GhcRn
-> TcM (KnotTied CoAxBranch)
tcTyFamInstEqn TyCon
tc_fam_tc AssocInstInfo
NotAssociated) [LTyFamInstEqn GhcRn]
eqns
; Name
co_ax_name <- GenLocated SrcSpanAnnN Name -> [[Type]] -> TcM Name
newFamInstAxiomName LIdP GhcRn
tc_lname []
; let mb_co_ax :: Maybe (CoAxiom Branched)
mb_co_ax
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LTyFamInstEqn GhcRn]
eqns = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just (Name -> TyCon -> [KnotTied CoAxBranch] -> CoAxiom Branched
mkBranchedCoAxiom Name
co_ax_name TyCon
fam_tc [KnotTied CoAxBranch]
branches)
fam_tc :: TyCon
fam_tc = Name
-> [TyConBinder]
-> Type
-> Maybe Name
-> FamTyConFlav
-> Maybe Class
-> Injectivity
-> TyCon
mkFamilyTyCon Name
tc_name [TyConBinder]
binders Type
res_kind (forall (a :: Pass).
FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
resultVariableName FamilyResultSig GhcRn
sig)
(Maybe (CoAxiom Branched) -> FamTyConFlav
ClosedSynFamilyTyCon Maybe (CoAxiom Branched)
mb_co_ax) Maybe Class
parent Injectivity
inj'
; forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
fam_tc } }
#if __GLASGOW_HASKELL__ <= 810
| otherwise = panic "tcFamInst1"
#endif
tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn)
-> TcM Injectivity
tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) -> TcM Injectivity
tcInjectivity [TyConBinder]
_ Maybe (LInjectivityAnn GhcRn)
Nothing
= forall (m :: * -> *) a. Monad m => a -> m a
return Injectivity
NotInjective
tcInjectivity [TyConBinder]
tcbs (Just (L SrcSpan
loc (InjectivityAnn XCInjectivityAnn GhcRn
_ LIdP GhcRn
_ [LIdP GhcRn]
lInjNames)))
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$
do { let tvs :: [TyVar]
tvs = forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tcbs
; DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Bool -> SDoc -> TcRn ()
checkTc (Extension -> DynFlags -> Bool
xopt Extension
LangExt.TypeFamilyDependencies DynFlags
dflags)
(String -> SDoc
text String
"Illegal injectivity annotation" SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"Use TypeFamilyDependencies to allow this")
; [TyVar]
inj_tvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> TcM TyVar
tcLookupTyVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LIdP GhcRn]
lInjNames
; [TyVar]
inj_tvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasDebugCallStack => TyVar -> TcM TyVar
zonkTcTyVarToTyVar [TyVar]
inj_tvs
; let inj_ktvs :: VarSet
inj_ktvs = (TyVar -> Bool) -> VarSet -> VarSet
filterVarSet TyVar -> Bool
isTyVar forall a b. (a -> b) -> a -> b
$
VarSet -> VarSet
closeOverKinds ([TyVar] -> VarSet
mkVarSet [TyVar]
inj_tvs)
; let inj_bools :: [Bool]
inj_bools = forall a b. (a -> b) -> [a] -> [b]
map (TyVar -> VarSet -> Bool
`elemVarSet` VarSet
inj_ktvs) [TyVar]
tvs
; String -> SDoc -> TcRn ()
traceTc String
"tcInjectivity" ([SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs, forall a. Outputable a => a -> SDoc
ppr [LIdP GhcRn]
lInjNames, forall a. Outputable a => a -> SDoc
ppr [TyVar]
inj_tvs
, forall a. Outputable a => a -> SDoc
ppr VarSet
inj_ktvs, forall a. Outputable a => a -> SDoc
ppr [Bool]
inj_bools ])
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Bool] -> Injectivity
Injective [Bool]
inj_bools }
tcTySynRhs :: RolesInfo -> Name
-> LHsType GhcRn -> TcM TyCon
tcTySynRhs :: (Name -> [Role]) -> Name -> LHsKind GhcRn -> TcM TyCon
tcTySynRhs Name -> [Role]
roles_info Name
tc_name LHsKind GhcRn
hs_ty
= forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tc_name forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
binders Type
res_kind ->
do { TcLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; String -> SDoc -> TcRn ()
traceTc String
"tc-syn" (forall a. Outputable a => a -> SDoc
ppr Name
tc_name SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr (TcLclEnv -> TcTypeEnv
tcl_env TcLclEnv
env))
; Type
rhs_ty <- forall a. SkolemInfo -> [TyVar] -> TcM a -> TcM a
pushLevelAndSolveEqualities SkolemInfo
skol_info (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
binders) forall a b. (a -> b) -> a -> b
$
LHsKind GhcRn -> ContextKind -> TcM Type
tcCheckLHsType LHsKind GhcRn
hs_ty (Type -> ContextKind
TheKind Type
res_kind)
; CandidatesQTvs
dvs <- Type -> TcM CandidatesQTvs
candidateQTyVarsOfType Type
rhs_ty
; let mk_doc :: TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
mk_doc TidyEnv
tidy_env = do { (TidyEnv
tidy_env2, Type
rhs_ty) <- TidyEnv -> Type -> TcM (TidyEnv, Type)
zonkTidyTcType TidyEnv
tidy_env Type
rhs_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return ( TidyEnv
tidy_env2
, [SDoc] -> SDoc
sep [ String -> SDoc
text String
"the type synonym right-hand side:"
, forall a. Outputable a => a -> SDoc
ppr Type
rhs_ty ] ) }
; CandidatesQTvs
-> (TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc))
-> TcRn ()
doNotQuantifyTyVars CandidatesQTvs
dvs TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
mk_doc
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; Type
rhs_ty <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
rhs_ty
; let roles :: [Role]
roles = Name -> [Role]
roles_info Name
tc_name
; forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [TyConBinder] -> Type -> [Role] -> Type -> TyCon
buildSynTyCon Name
tc_name [TyConBinder]
binders Type
res_kind [Role]
roles Type
rhs_ty) }
where
skol_info :: SkolemInfo
skol_info = TyConFlavour -> Name -> SkolemInfo
TyConSkol TyConFlavour
TypeSynonymFlavour Name
tc_name
tcDataDefn :: SDoc -> RolesInfo -> Name
-> HsDataDefn GhcRn -> TcM (TyCon, [DerivInfo])
tcDataDefn :: SDoc
-> (Name -> [Role])
-> Name
-> HsDataDefn GhcRn
-> TcM (TyCon, [DerivInfo])
tcDataDefn SDoc
err_ctxt Name -> [Role]
roles_info Name
tc_name
(HsDataDefn { dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_ND = NewOrData
new_or_data, dd_cType :: forall pass. HsDataDefn pass -> Maybe (XRec pass CType)
dd_cType = Maybe (XRec GhcRn CType)
cType
, dd_ctxt :: forall pass. HsDataDefn pass -> Maybe (LHsContext pass)
dd_ctxt = Maybe (LHsContext GhcRn)
ctxt
, dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (LHsKind GhcRn)
mb_ksig
, dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons = [LConDecl GhcRn]
cons
, dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs = HsDeriving GhcRn
derivs })
= forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tc_name forall a b. (a -> b) -> a -> b
$ \ TyCon
tctc [TyConBinder]
tycon_binders Type
res_kind ->
do { Bool
gadt_syntax <- Name
-> NewOrData
-> Maybe (LHsContext GhcRn)
-> [LConDecl GhcRn]
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
dataDeclChecks Name
tc_name NewOrData
new_or_data Maybe (LHsContext GhcRn)
ctxt [LConDecl GhcRn]
cons
; ([TyConBinder]
extra_bndrs, Type
final_res_kind) <- [TyConBinder] -> Type -> TcM ([TyConBinder], Type)
etaExpandAlgTyCon [TyConBinder]
tycon_binders Type
res_kind
; TcGblEnv
tcg_env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let hsc_src :: HscSource
hsc_src = TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall {a}. HscSource -> [a] -> Bool
mk_permissive_kind HscSource
hsc_src [LConDecl GhcRn]
cons) forall a b. (a -> b) -> a -> b
$
DataSort -> Type -> TcRn ()
checkDataKindSig (NewOrData -> DataSort
DataDeclSort NewOrData
new_or_data) Type
final_res_kind
; let skol_tvs :: [TyVar]
skol_tvs = forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tycon_binders
; [Type]
stupid_tc_theta <- forall a. SkolemInfo -> [TyVar] -> TcM a -> TcM a
pushLevelAndSolveEqualities SkolemInfo
skol_info [TyVar]
skol_tvs forall a b. (a -> b) -> a -> b
$
Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
ctxt
; CandidatesQTvs
dvs <- [Type] -> TcM CandidatesQTvs
candidateQTyVarsOfTypes [Type]
stupid_tc_theta
; let mk_doc :: TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
mk_doc TidyEnv
tidy_env
= do { (TidyEnv
tidy_env2, [Type]
theta) <- TidyEnv -> [Type] -> TcM (TidyEnv, [Type])
zonkTidyTcTypes TidyEnv
tidy_env [Type]
stupid_tc_theta
; forall (m :: * -> *) a. Monad m => a -> m a
return ( TidyEnv
tidy_env2
, [SDoc] -> SDoc
sep [ String -> SDoc
text String
"the datatype context:"
, [Type] -> SDoc
pprTheta [Type]
theta ] ) }
; CandidatesQTvs
-> (TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc))
-> TcRn ()
doNotQuantifyTyVars CandidatesQTvs
dvs TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
mk_doc
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; [Type]
stupid_theta <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
stupid_tc_theta
; Bool
kind_signatures <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.KindSignatures
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe (LHsKind GhcRn)
mb_ksig) forall a b. (a -> b) -> a -> b
$
Bool -> SDoc -> TcRn ()
checkTc (Bool
kind_signatures) (Name -> SDoc
badSigTyDecl Name
tc_name)
; TyCon
tycon <- forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM forall a b. (a -> b) -> a -> b
$ \ TyCon
rec_tycon -> do
{ let final_bndrs :: [TyConBinder]
final_bndrs = [TyConBinder]
tycon_binders forall a. [a] -> [a] -> [a]
`chkAppend` [TyConBinder]
extra_bndrs
roles :: [Role]
roles = Name -> [Role]
roles_info Name
tc_name
; [DataCon]
data_cons <- NewOrData
-> DataDeclInfo
-> TyCon
-> [TyConBinder]
-> Type
-> [LConDecl GhcRn]
-> TcM [DataCon]
tcConDecls
NewOrData
new_or_data DataDeclInfo
DDataType
TyCon
rec_tycon [TyConBinder]
final_bndrs Type
final_res_kind
[LConDecl GhcRn]
cons
; AlgTyConRhs
tc_rhs <- HscSource
-> TyCon -> [DataCon] -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
mk_tc_rhs HscSource
hsc_src TyCon
rec_tycon [DataCon]
data_cons
; Name
tc_rep_nm <- forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
tc_name
; forall (m :: * -> *) a. Monad m => a -> m a
return (Name
-> [TyConBinder]
-> Type
-> [Role]
-> Maybe CType
-> [Type]
-> AlgTyConRhs
-> AlgTyConFlav
-> Bool
-> TyCon
mkAlgTyCon Name
tc_name
[TyConBinder]
final_bndrs
Type
final_res_kind
[Role]
roles
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l e. GenLocated l e -> e
unLoc Maybe (XRec GhcRn CType)
cType)
[Type]
stupid_theta AlgTyConRhs
tc_rhs
(Name -> AlgTyConFlav
VanillaAlgTyCon Name
tc_rep_nm)
Bool
gadt_syntax) }
; let deriv_info :: DerivInfo
deriv_info = DerivInfo { di_rep_tc :: TyCon
di_rep_tc = TyCon
tycon
, di_scoped_tvs :: [(Name, TyVar)]
di_scoped_tvs = TyCon -> [(Name, TyVar)]
tcTyConScopedTyVars TyCon
tctc
, di_clauses :: HsDeriving GhcRn
di_clauses = HsDeriving GhcRn
derivs
, di_ctxt :: SDoc
di_ctxt = SDoc
err_ctxt }
; String -> SDoc -> TcRn ()
traceTc String
"tcDataDefn" (forall a. Outputable a => a -> SDoc
ppr Name
tc_name SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
tycon_binders SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
extra_bndrs)
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
tycon, [DerivInfo
deriv_info]) }
where
skol_info :: SkolemInfo
skol_info = TyConFlavour -> Name -> SkolemInfo
TyConSkol TyConFlavour
flav Name
tc_name
flav :: TyConFlavour
flav = NewOrData -> TyConFlavour
newOrDataToFlavour NewOrData
new_or_data
mk_permissive_kind :: HscSource -> [a] -> Bool
mk_permissive_kind HscSource
HsigFile [] = Bool
True
mk_permissive_kind HscSource
_ [a]
_ = Bool
False
mk_tc_rhs :: HscSource
-> TyCon -> [DataCon] -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
mk_tc_rhs HscSource
HsBootFile TyCon
_ []
= forall (m :: * -> *) a. Monad m => a -> m a
return AlgTyConRhs
AbstractTyCon
mk_tc_rhs HscSource
HsigFile TyCon
_ []
= forall (m :: * -> *) a. Monad m => a -> m a
return AlgTyConRhs
AbstractTyCon
mk_tc_rhs HscSource
_ TyCon
tycon [DataCon]
data_cons
= case NewOrData
new_or_data of
NewOrData
DataType -> forall (m :: * -> *) a. Monad m => a -> m a
return ([DataCon] -> AlgTyConRhs
mkDataTyConRhs [DataCon]
data_cons)
NewOrData
NewType -> ASSERT( not (null data_cons) )
forall m n. Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
mkNewTyConRhs Name
tc_name TyCon
tycon (forall a. [a] -> a
head [DataCon]
data_cons)
kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM ()
kcTyFamInstEqn :: TyCon -> LTyFamInstEqn GhcRn -> TcRn ()
kcTyFamInstEqn TyCon
tc_fam_tc
(L SrcSpanAnnA
loc (FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = L SrcSpanAnnN
_ Name
eqn_tc_name
, feqn_bndrs :: forall pass rhs. FamEqn pass rhs -> HsOuterFamEqnTyVarBndrs pass
feqn_bndrs = HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs
, feqn_pats :: forall pass rhs. FamEqn pass rhs -> HsTyPats pass
feqn_pats = HsTyPats GhcRn
hs_pats
, feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = GenLocated SrcSpanAnnA (HsType GhcRn)
hs_rhs_ty }))
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"kcTyFamInstEqn" ([SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"tc_name =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
eqn_tc_name
, String -> SDoc
text String
"fam_tc =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyCon
tc_fam_tc SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConKind TyCon
tc_fam_tc)
, String -> SDoc
text String
"feqn_bndrs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs
, String -> SDoc
text String
"feqn_pats =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr HsTyPats GhcRn
hs_pats ])
; forall tm ty. TyCon -> Name -> [HsArg tm ty] -> TcRn ()
checkTyFamInstEqn TyCon
tc_fam_tc Name
eqn_tc_name HsTyPats GhcRn
hs_pats
; forall a. TcM a -> TcRn ()
discardResult forall a b. (a -> b) -> a -> b
$
forall a.
HsOuterFamEqnTyVarBndrs GhcRn -> TcM a -> TcM ([TyVar], a)
bindOuterFamEqnTKBndrs_Q_Tv HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs forall a b. (a -> b) -> a -> b
$
do { (Type
_fam_app, Type
res_kind) <- TyCon -> HsTyPats GhcRn -> TcM (Type, Type)
tcFamTyPats TyCon
tc_fam_tc HsTyPats GhcRn
hs_pats
; LHsKind GhcRn -> ContextKind -> TcM Type
tcCheckLHsType GenLocated SrcSpanAnnA (HsType GhcRn)
hs_rhs_ty (Type -> ContextKind
TheKind Type
res_kind) }
}
tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn
-> TcM (KnotTied CoAxBranch)
tcTyFamInstEqn :: TyCon
-> AssocInstInfo
-> LTyFamInstEqn GhcRn
-> TcM (KnotTied CoAxBranch)
tcTyFamInstEqn TyCon
fam_tc AssocInstInfo
mb_clsinfo
(L SrcSpanAnnA
loc (FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = L SrcSpanAnnN
_ Name
eqn_tc_name
, feqn_bndrs :: forall pass rhs. FamEqn pass rhs -> HsOuterFamEqnTyVarBndrs pass
feqn_bndrs = HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs
, feqn_pats :: forall pass rhs. FamEqn pass rhs -> HsTyPats pass
feqn_pats = HsTyPats GhcRn
hs_pats
, feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = GenLocated SrcSpanAnnA (HsType GhcRn)
hs_rhs_ty }))
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcTyFamInstEqn" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr SrcSpanAnnA
loc, forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr HsTyPats GhcRn
hs_pats
, String -> SDoc
text String
"fam tc bndrs" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars (TyCon -> [TyVar]
tyConTyVars TyCon
fam_tc)
, case AssocInstInfo
mb_clsinfo of
NotAssociated {} -> SDoc
empty
InClsInst { ai_class :: AssocInstInfo -> Class
ai_class = Class
cls } -> String -> SDoc
text String
"class" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Class
cls SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars (Class -> [TyVar]
classTyVars Class
cls) ]
; forall tm ty. TyCon -> Name -> [HsArg tm ty] -> TcRn ()
checkTyFamInstEqn TyCon
fam_tc Name
eqn_tc_name HsTyPats GhcRn
hs_pats
; ([TyVar]
qtvs, [Type]
pats, Type
rhs_ty) <- TyCon
-> AssocInstInfo
-> HsOuterFamEqnTyVarBndrs GhcRn
-> HsTyPats GhcRn
-> LHsKind GhcRn
-> TcM ([TyVar], [Type], Type)
tcTyFamInstEqnGuts TyCon
fam_tc AssocInstInfo
mb_clsinfo
HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs HsTyPats GhcRn
hs_pats GenLocated SrcSpanAnnA (HsType GhcRn)
hs_rhs_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
-> [TyVar]
-> [TyVar]
-> [Type]
-> Type
-> [Role]
-> SrcSpan
-> KnotTied CoAxBranch
mkCoAxBranch [TyVar]
qtvs [] [] [Type]
pats Type
rhs_ty
(forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Role
Nominal) [TyVar]
qtvs)
(forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)) }
checkTyFamInstEqn :: TcTyCon -> Name -> [HsArg tm ty] -> TcM ()
checkTyFamInstEqn :: forall tm ty. TyCon -> Name -> [HsArg tm ty] -> TcRn ()
checkTyFamInstEqn TyCon
tc_fam_tc Name
eqn_tc_name [HsArg tm ty]
hs_pats =
do {
let tc_fam_tc_name :: Name
tc_fam_tc_name = forall a. NamedThing a => a -> Name
getName TyCon
tc_fam_tc
; Bool -> SDoc -> TcRn ()
checkTc (Name
tc_fam_tc_name forall a. Eq a => a -> a -> Bool
== Name
eqn_tc_name) forall a b. (a -> b) -> a -> b
$
Name -> Name -> SDoc
wrongTyFamName Name
tc_fam_tc_name Name
eqn_tc_name
; let vis_arity :: Arity
vis_arity = forall (t :: * -> *) a. Foldable t => t a -> Arity
length (TyCon -> [TyVar]
tyConVisibleTyVars TyCon
tc_fam_tc)
vis_pats :: Arity
vis_pats = forall tm ty. [HsArg tm ty] -> Arity
numVisibleArgs [HsArg tm ty]
hs_pats
; Bool -> SDoc -> TcRn ()
checkTc (Arity
vis_pats forall a. Eq a => a -> a -> Bool
== Arity
vis_arity) forall a b. (a -> b) -> a -> b
$
Arity -> SDoc
wrongNumberOfParmsErr Arity
vis_arity
}
tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo
-> HsOuterFamEqnTyVarBndrs GhcRn
-> HsTyPats GhcRn
-> LHsType GhcRn
-> TcM ([TyVar], [TcType], TcType)
tcTyFamInstEqnGuts :: TyCon
-> AssocInstInfo
-> HsOuterFamEqnTyVarBndrs GhcRn
-> HsTyPats GhcRn
-> LHsKind GhcRn
-> TcM ([TyVar], [Type], Type)
tcTyFamInstEqnGuts TyCon
fam_tc AssocInstInfo
mb_clsinfo HsOuterFamEqnTyVarBndrs GhcRn
outer_hs_bndrs HsTyPats GhcRn
hs_pats LHsKind GhcRn
hs_rhs_ty
= do { String -> SDoc -> TcRn ()
traceTc String
"tcTyFamInstEqnGuts {" (forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc)
; (TcLevel
tclvl, WantedConstraints
wanted, ([TyVar]
outer_tvs, (Type
lhs_ty, Type
rhs_ty)))
<- forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tcTyFamInstEqnGuts" forall a b. (a -> b) -> a -> b
$
forall a.
HsOuterFamEqnTyVarBndrs GhcRn -> TcM a -> TcM ([TyVar], a)
bindOuterFamEqnTKBndrs HsOuterFamEqnTyVarBndrs GhcRn
outer_hs_bndrs forall a b. (a -> b) -> a -> b
$
do { (Type
lhs_ty, Type
rhs_kind) <- TyCon -> HsTyPats GhcRn -> TcM (Type, Type)
tcFamTyPats TyCon
fam_tc HsTyPats GhcRn
hs_pats
; AssocInstInfo -> Type -> TcRn ()
addConsistencyConstraints AssocInstInfo
mb_clsinfo Type
lhs_ty
; Type
rhs_ty <- LHsKind GhcRn -> ContextKind -> TcM Type
tcCheckLHsType LHsKind GhcRn
hs_rhs_ty (Type -> ContextKind
TheKind Type
rhs_kind)
; forall (m :: * -> *) a. Monad m => a -> m a
return (Type
lhs_ty, Type
rhs_ty) }
; CandidatesQTvs
dvs <- [Type] -> TcM CandidatesQTvs
candidateQTyVarsOfTypes (Type
lhs_ty forall a. a -> [a] -> [a]
: [TyVar] -> [Type]
mkTyVarTys [TyVar]
outer_tvs)
; [TyVar]
qtvs <- CandidatesQTvs -> TcM [TyVar]
quantifyTyVars CandidatesQTvs
dvs
; SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcRn ()
reportUnsolvedEqualities SkolemInfo
FamInstSkol [TyVar]
qtvs TcLevel
tclvl WantedConstraints
wanted
; TcLevel -> HsOuterFamEqnTyVarBndrs GhcRn -> [TyVar] -> TcRn ()
checkFamTelescope TcLevel
tclvl HsOuterFamEqnTyVarBndrs GhcRn
outer_hs_bndrs [TyVar]
outer_tvs
; String -> SDoc -> TcRn ()
traceTc String
"tcTyFamInstEqnGuts 2" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc
, String -> SDoc
text String
"lhs_ty" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
lhs_ty
, String -> SDoc
text String
"qtvs" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
qtvs ]
; CandidatesQTvs
dvs_rhs <- Type -> TcM CandidatesQTvs
candidateQTyVarsOfType Type
rhs_ty
; let mk_doc :: TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
mk_doc TidyEnv
tidy_env
= do { (TidyEnv
tidy_env2, Type
rhs_ty) <- TidyEnv -> Type -> TcM (TidyEnv, Type)
zonkTidyTcType TidyEnv
tidy_env Type
rhs_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return ( TidyEnv
tidy_env2
, [SDoc] -> SDoc
sep [ String -> SDoc
text String
"type family equation right-hand side:"
, forall a. Outputable a => a -> SDoc
ppr Type
rhs_ty ] ) }
; CandidatesQTvs
-> (TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc))
-> TcRn ()
doNotQuantifyTyVars CandidatesQTvs
dvs_rhs TidyEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
mk_doc
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; (ZonkEnv
ze, [TyVar]
qtvs) <- ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX ZonkEnv
ze [TyVar]
qtvs
; Type
lhs_ty <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
lhs_ty
; Type
rhs_ty <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
rhs_ty
; let pats :: [Type]
pats = Type -> [Type]
unravelFamInstPats Type
lhs_ty
; String -> SDoc -> TcRn ()
traceTc String
"tcTyFamInstEqnGuts }" (forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
qtvs)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
qtvs, [Type]
pats, Type
rhs_ty) }
checkFamTelescope :: TcLevel -> HsOuterFamEqnTyVarBndrs GhcRn
-> [TcTyVar] -> TcM ()
checkFamTelescope :: TcLevel -> HsOuterFamEqnTyVarBndrs GhcRn -> [TyVar] -> TcRn ()
checkFamTelescope TcLevel
tclvl HsOuterFamEqnTyVarBndrs GhcRn
hs_outer_bndrs [TyVar]
outer_tvs
| HsOuterExplicit { hso_bndrs :: forall flag pass.
HsOuterTyVarBndrs flag pass -> [LHsTyVarBndr flag (NoGhcTc pass)]
hso_bndrs = [LHsTyVarBndr () (NoGhcTc GhcRn)]
bndrs } <- HsOuterFamEqnTyVarBndrs GhcRn
hs_outer_bndrs
, (LHsTyVarBndr () (NoGhcTc GhcRn)
b_first : [LHsTyVarBndr () (NoGhcTc GhcRn)]
_) <- [LHsTyVarBndr () (NoGhcTc GhcRn)]
bndrs
, let b_last :: GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
b_last = forall a. [a] -> a
last [LHsTyVarBndr () (NoGhcTc GhcRn)]
bndrs
skol_info :: SkolemInfo
skol_info = SDoc -> SkolemInfo
ForAllSkol ([SDoc] -> SDoc
fsep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr () (NoGhcTc GhcRn)]
bndrs))
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsTyVarBndr () (NoGhcTc GhcRn)
b_first) (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
b_last)) forall a b. (a -> b) -> a -> b
$
SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcRn ()
emitResidualTvConstraint SkolemInfo
skol_info [TyVar]
outer_tvs TcLevel
tclvl WantedConstraints
emptyWC
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
unravelFamInstPats :: TcType -> [TcType]
unravelFamInstPats :: Type -> [Type]
unravelFamInstPats Type
fam_app
= case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
fam_app of
Just (TyCon
_, [Type]
pats) -> [Type]
pats
Maybe (TyCon, [Type])
Nothing -> forall a. String -> a
panic String
"unravelFamInstPats: Ill-typed LHS of family instance"
addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM ()
addConsistencyConstraints :: AssocInstInfo -> Type -> TcRn ()
addConsistencyConstraints AssocInstInfo
mb_clsinfo Type
fam_app
| InClsInst { ai_inst_env :: AssocInstInfo -> VarEnv Type
ai_inst_env = VarEnv Type
inst_env } <- AssocInstInfo
mb_clsinfo
, Just (TyCon
fam_tc, [Type]
pats) <- HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
fam_app
= do { let eqs :: [(Type, Type)]
eqs = [ (Type
cls_ty, Type
pat)
| (TyVar
fam_tc_tv, Type
pat) <- TyCon -> [TyVar]
tyConTyVars TyCon
fam_tc forall a b. [a] -> [b] -> [(a, b)]
`zip` [Type]
pats
, Just Type
cls_ty <- [forall a. VarEnv a -> TyVar -> Maybe a
lookupVarEnv VarEnv Type
inst_env TyVar
fam_tc_tv] ]
; String -> SDoc -> TcRn ()
traceTc String
"addConsistencyConstraints" (forall a. Outputable a => a -> SDoc
ppr [(Type, Type)]
eqs)
; CtOrigin -> [(Type, Type)] -> TcRn ()
emitDerivedEqs CtOrigin
AssocFamPatOrigin [(Type, Type)]
eqs }
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
dataDeclChecks :: Name -> NewOrData
-> Maybe (LHsContext GhcRn) -> [LConDecl GhcRn]
-> TcM Bool
dataDeclChecks :: Name
-> NewOrData
-> Maybe (LHsContext GhcRn)
-> [LConDecl GhcRn]
-> IOEnv (Env TcGblEnv TcLclEnv) Bool
dataDeclChecks Name
tc_name NewOrData
new_or_data Maybe (LHsContext GhcRn)
mctxt [LConDecl GhcRn]
cons
= do { let stupid_theta :: HsContext GhcRn
stupid_theta = forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext Maybe (LHsContext GhcRn)
mctxt
; Bool
gadtSyntax_ok <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.GADTSyntax
; let gadt_syntax :: Bool
gadt_syntax = [LConDecl GhcRn] -> Bool
consUseGadtSyntax [LConDecl GhcRn]
cons
; Bool -> SDoc -> TcRn ()
checkTc (Bool
gadtSyntax_ok Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
gadt_syntax) (Name -> SDoc
badGadtDecl Name
tc_name)
; Bool -> SDoc -> TcRn ()
checkTc (forall (t :: * -> *) a. Foldable t => t a -> Bool
null HsContext GhcRn
stupid_theta Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
gadt_syntax) (Name -> SDoc
badStupidTheta Name
tc_name)
; Bool -> SDoc -> TcRn ()
checkTc (NewOrData
new_or_data forall a. Eq a => a -> a -> Bool
== NewOrData
DataType Bool -> Bool -> Bool
|| forall a. [a] -> Bool
isSingleton [LConDecl GhcRn]
cons)
(Name -> Arity -> SDoc
newtypeConError Name
tc_name (forall (t :: * -> *) a. Foldable t => t a -> Arity
length [LConDecl GhcRn]
cons))
; Bool
empty_data_decls <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.EmptyDataDecls
; Bool
is_boot <- IOEnv (Env TcGblEnv TcLclEnv) Bool
tcIsHsBootOrSig
; Bool -> SDoc -> TcRn ()
checkTc (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LConDecl GhcRn]
cons) Bool -> Bool -> Bool
|| Bool
empty_data_decls Bool -> Bool -> Bool
|| Bool
is_boot)
(Name -> SDoc
emptyConDeclsErr Name
tc_name)
; forall (m :: * -> *) a. Monad m => a -> m a
return Bool
gadt_syntax }
consUseGadtSyntax :: [LConDecl GhcRn] -> Bool
consUseGadtSyntax :: [LConDecl GhcRn] -> Bool
consUseGadtSyntax (L SrcSpanAnnA
_ (ConDeclGADT {}) : [LConDecl GhcRn]
_) = Bool
True
consUseGadtSyntax [LConDecl GhcRn]
_ = Bool
False
data DataDeclInfo
= DDataType
| DDataInstance
Type
mkDDHeaderTy :: DataDeclInfo -> TyCon -> [TyConBinder] -> Type
DataDeclInfo
dd_info TyCon
rep_tycon [TyConBinder]
tc_bndrs
= case DataDeclInfo
dd_info of
DataDeclInfo
DDataType -> TyCon -> [Type] -> Type
mkTyConApp TyCon
rep_tycon forall a b. (a -> b) -> a -> b
$
[TyVar] -> [Type]
mkTyVarTys (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tc_bndrs)
DDataInstance Type
header_ty -> Type
header_ty
tcConDecls :: NewOrData
-> DataDeclInfo
-> KnotTied TyCon
-> [TyConBinder]
-> TcKind
-> [LConDecl GhcRn] -> TcM [DataCon]
tcConDecls :: NewOrData
-> DataDeclInfo
-> TyCon
-> [TyConBinder]
-> Type
-> [LConDecl GhcRn]
-> TcM [DataCon]
tcConDecls NewOrData
new_or_data DataDeclInfo
dd_info TyCon
rep_tycon [TyConBinder]
tmpl_bndrs Type
res_kind
= forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM forall a b. (a -> b) -> a -> b
$ forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA forall a b. (a -> b) -> a -> b
$
NewOrData
-> DataDeclInfo
-> TyCon
-> [TyConBinder]
-> Type
-> NameEnv Arity
-> ConDecl GhcRn
-> TcM [DataCon]
tcConDecl NewOrData
new_or_data DataDeclInfo
dd_info TyCon
rep_tycon [TyConBinder]
tmpl_bndrs Type
res_kind
(TyCon -> NameEnv Arity
mkTyConTagMap TyCon
rep_tycon)
tcConDecl :: NewOrData
-> DataDeclInfo
-> KnotTied TyCon
-> [TyConBinder]
-> TcKind
-> NameEnv ConTag
-> ConDecl GhcRn
-> TcM [DataCon]
tcConDecl :: NewOrData
-> DataDeclInfo
-> TyCon
-> [TyConBinder]
-> Type
-> NameEnv Arity
-> ConDecl GhcRn
-> TcM [DataCon]
tcConDecl NewOrData
new_or_data DataDeclInfo
dd_info TyCon
rep_tycon [TyConBinder]
tc_bndrs Type
res_kind NameEnv Arity
tag_map
(ConDeclH98 { con_name :: forall pass. ConDecl pass -> LIdP pass
con_name = lname :: LIdP GhcRn
lname@(L SrcSpanAnnN
_ Name
name)
, con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_ex_tvs = [LHsTyVarBndr Specificity GhcRn]
explicit_tkv_nms
, con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcRn)
hs_ctxt
, con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_args = HsConDeclH98Details GhcRn
hs_args })
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([GenLocated SrcSpanAnnN Name] -> SDoc
dataConCtxt [LIdP GhcRn
lname]) forall a b. (a -> b) -> a -> b
$
do {
; String -> SDoc -> TcRn ()
traceTc String
"tcConDecl 1" ([SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr Name
name, forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr Specificity GhcRn]
explicit_tkv_nms ])
; (TcLevel
tclvl, WantedConstraints
wanted, ([VarBndr TyVar Specificity]
exp_tvbndrs, ([Type]
ctxt, [Scaled Type]
arg_tys, [FieldLabel]
field_lbls, [HsSrcBang]
stricts)))
<- forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tcConDecl:H98" forall a b. (a -> b) -> a -> b
$
forall flag a.
OutputableBndrFlag flag 'Renamed =>
[LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a)
tcExplicitTKBndrs [LHsTyVarBndr Specificity GhcRn]
explicit_tkv_nms forall a b. (a -> b) -> a -> b
$
do { [Type]
ctxt <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
hs_ctxt
; let exp_kind :: ContextKind
exp_kind = NewOrData -> Type -> ContextKind
getArgExpKind NewOrData
new_or_data Type
res_kind
; [(Scaled Type, HsSrcBang)]
btys <- ContextKind
-> HsConDeclH98Details GhcRn -> TcM [(Scaled Type, HsSrcBang)]
tcConH98Args ContextKind
exp_kind HsConDeclH98Details GhcRn
hs_args
; [FieldLabel]
field_lbls <- Name -> RnM [FieldLabel]
lookupConstructorFields Name
name
; let ([Scaled Type]
arg_tys, [HsSrcBang]
stricts) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Scaled Type, HsSrcBang)]
btys
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
ctxt, [Scaled Type]
arg_tys, [FieldLabel]
field_lbls, [HsSrcBang]
stricts)
}
; let tc_tvs :: [TyVar]
tc_tvs = forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tc_bndrs
fake_ty :: Type
fake_ty = [TyVar] -> Type -> Type
mkSpecForAllTys [TyVar]
tc_tvs forall a b. (a -> b) -> a -> b
$
[VarBndr TyVar Specificity] -> Type -> Type
mkInvisForAllTys [VarBndr TyVar Specificity]
exp_tvbndrs forall a b. (a -> b) -> a -> b
$
[Type] -> Type -> Type
mkPhiTy [Type]
ctxt forall a b. (a -> b) -> a -> b
$
[Scaled Type] -> Type -> Type
mkVisFunTys [Scaled Type]
arg_tys forall a b. (a -> b) -> a -> b
$
Type
unitTy
; [TyVar]
kvs <- Type -> TcM [TyVar]
kindGeneralizeAll Type
fake_ty
; let skol_tvs :: [TyVar]
skol_tvs = [TyVar]
tc_tvs forall a. [a] -> [a] -> [a]
++ [TyVar]
kvs forall a. [a] -> [a] -> [a]
++ forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TyVar Specificity]
exp_tvbndrs
; SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcRn ()
reportUnsolvedEqualities SkolemInfo
skol_info [TyVar]
skol_tvs TcLevel
tclvl WantedConstraints
wanted
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; (ZonkEnv
ze, [TyVar]
qkvs) <- ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX ZonkEnv
ze [TyVar]
kvs
; (ZonkEnv
ze, [VarBndr TyVar Specificity]
user_qtvbndrs) <- forall vis.
ZonkEnv
-> [VarBndr TyVar vis] -> TcM (ZonkEnv, [VarBndr TyVar vis])
zonkTyVarBindersX ZonkEnv
ze [VarBndr TyVar Specificity]
exp_tvbndrs
; [Scaled Type]
arg_tys <- ZonkEnv -> [Scaled Type] -> TcM [Scaled Type]
zonkScaledTcTypesToTypesX ZonkEnv
ze [Scaled Type]
arg_tys
; [Type]
ctxt <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
ctxt
; String -> SDoc -> TcRn ()
traceTc String
"tcConDecl 2" (forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [FieldLabel]
field_lbls)
; let univ_tvbs :: [VarBndr TyVar Specificity]
univ_tvbs = [TyConBinder] -> [VarBndr TyVar Specificity]
tyConInvisTVBinders [TyConBinder]
tc_bndrs
ex_tvbs :: [VarBndr TyVar Specificity]
ex_tvbs = forall vis. vis -> [TyVar] -> [VarBndr TyVar vis]
mkTyVarBinders Specificity
InferredSpec [TyVar]
qkvs forall a. [a] -> [a] -> [a]
++ [VarBndr TyVar Specificity]
user_qtvbndrs
ex_tvs :: [TyVar]
ex_tvs = forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TyVar Specificity]
ex_tvbs
user_tvbs :: [VarBndr TyVar Specificity]
user_tvbs = [VarBndr TyVar Specificity]
univ_tvbs forall a. [a] -> [a] -> [a]
++ [VarBndr TyVar Specificity]
ex_tvbs
user_res_ty :: Type
user_res_ty = DataDeclInfo -> TyCon -> [TyConBinder] -> Type
mkDDHeaderTy DataDeclInfo
dd_info TyCon
rep_tycon [TyConBinder]
tc_bndrs
; String -> SDoc -> TcRn ()
traceTc String
"tcConDecl 2" (forall a. Outputable a => a -> SDoc
ppr Name
name)
; Bool
is_infix <- Name
-> HsConDeclH98Details GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Bool
tcConIsInfixH98 Name
name HsConDeclH98Details GhcRn
hs_args
; Name
rep_nm <- forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
name
; FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; DataCon
dc <- forall m n.
FamInstEnvs
-> Name
-> Bool
-> Name
-> [HsSrcBang]
-> Maybe [HsImplBang]
-> [FieldLabel]
-> [TyVar]
-> [TyVar]
-> [VarBndr TyVar Specificity]
-> [EqSpec]
-> [Type]
-> [Scaled Type]
-> Type
-> TyCon
-> NameEnv Arity
-> TcRnIf m n DataCon
buildDataCon FamInstEnvs
fam_envs Name
name Bool
is_infix Name
rep_nm
[HsSrcBang]
stricts forall a. Maybe a
Nothing [FieldLabel]
field_lbls
[TyVar]
tc_tvs [TyVar]
ex_tvs [VarBndr TyVar Specificity]
user_tvbs
[] [Type]
ctxt [Scaled Type]
arg_tys
Type
user_res_ty TyCon
rep_tycon NameEnv Arity
tag_map
; forall (m :: * -> *) a. Monad m => a -> m a
return [DataCon
dc] }
where
skol_info :: SkolemInfo
skol_info = Name -> SkolemInfo
DataConSkol Name
name
tcConDecl NewOrData
new_or_data DataDeclInfo
dd_info TyCon
rep_tycon [TyConBinder]
tc_bndrs Type
_res_kind NameEnv Arity
tag_map
(ConDeclGADT { con_names :: forall pass. ConDecl pass -> [LIdP pass]
con_names = [LIdP GhcRn]
names
, con_bndrs :: forall pass. ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)
con_bndrs = L SrcSpanAnnA
_ HsOuterSigTyVarBndrs GhcRn
outer_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 })
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([GenLocated SrcSpanAnnN Name] -> SDoc
dataConCtxt [LIdP GhcRn]
names) forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcConDecl 1 gadt" (forall a. Outputable a => a -> SDoc
ppr [LIdP GhcRn]
names)
; let (L SrcSpanAnnN
_ Name
name : [LIdP GhcRn]
_) = [LIdP GhcRn]
names
; (TcLevel
tclvl, WantedConstraints
wanted, (HsOuterSigTyVarBndrs GhcTc
outer_bndrs, ([Type]
ctxt, [Scaled Type]
arg_tys, Type
res_ty, [FieldLabel]
field_lbls, [HsSrcBang]
stricts)))
<- forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tcConDecl:GADT" forall a b. (a -> b) -> a -> b
$
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemInfo
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
tcOuterTKBndrs SkolemInfo
skol_info HsOuterSigTyVarBndrs GhcRn
outer_hs_bndrs forall a b. (a -> b) -> a -> b
$
do { [Type]
ctxt <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
cxt
; (Type
res_ty, Type
res_kind) <- LHsKind GhcRn -> TcM (Type, Type)
tcInferLHsTypeKind LHsKind GhcRn
hs_res_ty
; case DataDeclInfo
dd_info of
DataDeclInfo
DDataType -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
DDataInstance Type
hdr_ty ->
do { (TCvSubst
subst, [TyVar]
_meta_tvs) <- [TyVar] -> TcM (TCvSubst, [TyVar])
newMetaTyVars (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tc_bndrs)
; let head_shape :: Type
head_shape = HasCallStack => TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
hdr_ty
; forall a. TcM a -> TcRn ()
discardResult forall a b. (a -> b) -> a -> b
$
forall r. TcM r -> TcM r
popErrCtxt forall a b. (a -> b) -> a -> b
$
forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([GenLocated SrcSpanAnnN Name] -> SDoc
dataConResCtxt [LIdP GhcRn]
names) forall a b. (a -> b) -> a -> b
$
Maybe SDoc -> Type -> Type -> TcM Coercion
unifyType forall a. Maybe a
Nothing Type
res_ty Type
head_shape }
; let exp_kind :: ContextKind
exp_kind = NewOrData -> Type -> ContextKind
getArgExpKind NewOrData
new_or_data Type
res_kind
; [(Scaled Type, HsSrcBang)]
btys <- ContextKind
-> HsConDeclGADTDetails GhcRn -> TcM [(Scaled Type, HsSrcBang)]
tcConGADTArgs ContextKind
exp_kind HsConDeclGADTDetails GhcRn
hs_args
; let ([Scaled Type]
arg_tys, [HsSrcBang]
stricts) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Scaled Type, HsSrcBang)]
btys
; [FieldLabel]
field_lbls <- Name -> RnM [FieldLabel]
lookupConstructorFields Name
name
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
ctxt, [Scaled Type]
arg_tys, Type
res_ty, [FieldLabel]
field_lbls, [HsSrcBang]
stricts)
}
; [VarBndr TyVar Specificity]
outer_tv_bndrs <- HsOuterSigTyVarBndrs GhcTc -> TcM [VarBndr TyVar Specificity]
scopedSortOuter HsOuterSigTyVarBndrs GhcTc
outer_bndrs
; [TyVar]
tkvs <- Type -> TcM [TyVar]
kindGeneralizeAll ([VarBndr TyVar Specificity] -> Type -> Type
mkInvisForAllTys [VarBndr TyVar Specificity]
outer_tv_bndrs forall a b. (a -> b) -> a -> b
$
[Type] -> Type -> Type
mkPhiTy [Type]
ctxt forall a b. (a -> b) -> a -> b
$
[Scaled Type] -> Type -> Type
mkVisFunTys [Scaled Type]
arg_tys forall a b. (a -> b) -> a -> b
$
Type
res_ty)
; String -> SDoc -> TcRn ()
traceTc String
"tcConDecl:GADT" (forall a. Outputable a => a -> SDoc
ppr [LIdP GhcRn]
names SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Type
res_ty SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [TyVar]
tkvs)
; SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcRn ()
reportUnsolvedEqualities SkolemInfo
skol_info [TyVar]
tkvs TcLevel
tclvl WantedConstraints
wanted
; let tvbndrs :: [VarBndr TyVar Specificity]
tvbndrs = forall vis. vis -> [TyVar] -> [VarBndr TyVar vis]
mkTyVarBinders Specificity
InferredSpec [TyVar]
tkvs forall a. [a] -> [a] -> [a]
++ [VarBndr TyVar Specificity]
outer_tv_bndrs
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; (ZonkEnv
ze, [VarBndr TyVar Specificity]
tvbndrs) <- forall vis.
ZonkEnv
-> [VarBndr TyVar vis] -> TcM (ZonkEnv, [VarBndr TyVar vis])
zonkTyVarBindersX ZonkEnv
ze [VarBndr TyVar Specificity]
tvbndrs
; [Scaled Type]
arg_tys <- ZonkEnv -> [Scaled Type] -> TcM [Scaled Type]
zonkScaledTcTypesToTypesX ZonkEnv
ze [Scaled Type]
arg_tys
; [Type]
ctxt <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
ctxt
; Type
res_ty <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
res_ty
; let res_tmpl :: Type
res_tmpl = DataDeclInfo -> TyCon -> [TyConBinder] -> Type
mkDDHeaderTy DataDeclInfo
dd_info TyCon
rep_tycon [TyConBinder]
tc_bndrs
([TyVar]
univ_tvs, [TyVar]
ex_tvs, [VarBndr TyVar Specificity]
tvbndrs', [EqSpec]
eq_preds, TCvSubst
arg_subst)
= [TyConBinder]
-> Type
-> [VarBndr TyVar Specificity]
-> Type
-> ([TyVar], [TyVar], [VarBndr TyVar Specificity], [EqSpec],
TCvSubst)
rejigConRes [TyConBinder]
tc_bndrs Type
res_tmpl [VarBndr TyVar Specificity]
tvbndrs Type
res_ty
ctxt' :: [Type]
ctxt' = HasCallStack => TCvSubst -> [Type] -> [Type]
substTys TCvSubst
arg_subst [Type]
ctxt
arg_tys' :: [Scaled Type]
arg_tys' = HasCallStack => TCvSubst -> [Scaled Type] -> [Scaled Type]
substScaledTys TCvSubst
arg_subst [Scaled Type]
arg_tys
res_ty' :: Type
res_ty' = HasCallStack => TCvSubst -> Type -> Type
substTy TCvSubst
arg_subst Type
res_ty
; String -> SDoc -> TcRn ()
traceTc String
"tcConDecl 2" (forall a. Outputable a => a -> SDoc
ppr [LIdP GhcRn]
names SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [FieldLabel]
field_lbls)
; FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; let
buildOneDataCon :: GenLocated SrcSpanAnnN Name
-> IOEnv (Env TcGblEnv TcLclEnv) DataCon
buildOneDataCon (L SrcSpanAnnN
_ Name
name) = do
{ Bool
is_infix <- Name
-> HsConDeclGADTDetails GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Bool
tcConIsInfixGADT Name
name HsConDeclGADTDetails GhcRn
hs_args
; Name
rep_nm <- forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
name
; forall m n.
FamInstEnvs
-> Name
-> Bool
-> Name
-> [HsSrcBang]
-> Maybe [HsImplBang]
-> [FieldLabel]
-> [TyVar]
-> [TyVar]
-> [VarBndr TyVar Specificity]
-> [EqSpec]
-> [Type]
-> [Scaled Type]
-> Type
-> TyCon
-> NameEnv Arity
-> TcRnIf m n DataCon
buildDataCon FamInstEnvs
fam_envs Name
name Bool
is_infix
Name
rep_nm
[HsSrcBang]
stricts forall a. Maybe a
Nothing [FieldLabel]
field_lbls
[TyVar]
univ_tvs [TyVar]
ex_tvs [VarBndr TyVar Specificity]
tvbndrs' [EqSpec]
eq_preds
[Type]
ctxt' [Scaled Type]
arg_tys' Type
res_ty' TyCon
rep_tycon NameEnv Arity
tag_map
}
; forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnN Name
-> IOEnv (Env TcGblEnv TcLclEnv) DataCon
buildOneDataCon [LIdP GhcRn]
names }
where
skol_info :: SkolemInfo
skol_info = Name -> SkolemInfo
DataConSkol (forall l e. GenLocated l e -> e
unLoc (forall a. [a] -> a
head [LIdP GhcRn]
names))
getArgExpKind :: NewOrData -> Kind -> 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 -> IOEnv (Env TcGblEnv TcLclEnv) Bool
tcConIsInfixH98 Name
_ HsConDeclH98Details GhcRn
details
= case HsConDeclH98Details GhcRn
details of
InfixCon{} -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
RecCon{} -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
PrefixCon{} -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
tcConIsInfixGADT :: Name
-> HsConDeclGADTDetails GhcRn
-> TcM Bool
tcConIsInfixGADT :: Name
-> HsConDeclGADTDetails GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) Bool
tcConIsInfixGADT Name
con HsConDeclGADTDetails GhcRn
details
= case HsConDeclGADTDetails GhcRn
details of
RecConGADT{} -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
PrefixConGADT [HsScaled GhcRn (LHsKind GhcRn)]
arg_tys
| OccName -> Bool
isSymOcc (forall a. NamedThing a => a -> OccName
getOccName Name
con)
, [GenLocated SrcSpanAnnA (HsType GhcRn)
_ty1,GenLocated SrcSpanAnnA (HsType GhcRn)
_ty2] <- forall a b. (a -> b) -> [a] -> [b]
map forall pass a. HsScaled pass a -> a
hsScaledThing [HsScaled GhcRn (LHsKind GhcRn)]
arg_tys
-> do { FixityEnv
fix_env <- TcRn FixityEnv
getFixityEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (Name
con forall a. Name -> NameEnv a -> Bool
`elemNameEnv` FixityEnv
fix_env) }
| Bool
otherwise -> 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)
= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ContextKind
-> HsScaled GhcRn (LHsKind GhcRn) -> TcM (Scaled Type, HsSrcBang)
tcConArg ContextKind
exp_kind) [HsScaled GhcRn (LHsKind GhcRn)]
btys
tcConH98Args ContextKind
exp_kind (InfixCon HsScaled GhcRn (LHsKind GhcRn)
bty1 HsScaled GhcRn (LHsKind GhcRn)
bty2)
= do { (Scaled Type, HsSrcBang)
bty1' <- ContextKind
-> HsScaled GhcRn (LHsKind GhcRn) -> TcM (Scaled Type, HsSrcBang)
tcConArg ContextKind
exp_kind HsScaled GhcRn (LHsKind GhcRn)
bty1
; (Scaled Type, HsSrcBang)
bty2' <- ContextKind
-> HsScaled GhcRn (LHsKind GhcRn) -> TcM (Scaled Type, HsSrcBang)
tcConArg ContextKind
exp_kind HsScaled GhcRn (LHsKind GhcRn)
bty2
; forall (m :: * -> *) a. Monad m => a -> m a
return [(Scaled Type, HsSrcBang)
bty1', (Scaled Type, HsSrcBang)
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]
fields
tcConGADTArgs :: ContextKind
-> HsConDeclGADTDetails GhcRn
-> TcM [(Scaled TcType, HsSrcBang)]
tcConGADTArgs :: ContextKind
-> HsConDeclGADTDetails GhcRn -> TcM [(Scaled Type, HsSrcBang)]
tcConGADTArgs ContextKind
exp_kind (PrefixConGADT [HsScaled GhcRn (LHsKind GhcRn)]
btys)
= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ContextKind
-> HsScaled GhcRn (LHsKind GhcRn) -> TcM (Scaled Type, HsSrcBang)
tcConArg ContextKind
exp_kind) [HsScaled GhcRn (LHsKind GhcRn)]
btys
tcConGADTArgs ContextKind
exp_kind (RecConGADT XRec GhcRn [LConDeclField GhcRn]
fields)
= ContextKind
-> LocatedL [LConDeclField GhcRn] -> TcM [(Scaled Type, HsSrcBang)]
tcRecConDeclFields ContextKind
exp_kind XRec GhcRn [LConDeclField GhcRn]
fields
tcConArg :: ContextKind
-> HsScaled GhcRn (LHsType GhcRn) -> TcM (Scaled TcType, HsSrcBang)
tcConArg :: ContextKind
-> HsScaled GhcRn (LHsKind GhcRn) -> TcM (Scaled Type, HsSrcBang)
tcConArg ContextKind
exp_kind (HsScaled HsArrow GhcRn
w LHsKind GhcRn
bty)
= do { String -> SDoc -> TcRn ()
traceTc String
"tcConArg 1" (forall a. Outputable a => a -> SDoc
ppr LHsKind GhcRn
bty)
; Type
arg_ty <- LHsKind GhcRn -> ContextKind -> TcM Type
tcCheckLHsType (forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p)
getBangType LHsKind GhcRn
bty) ContextKind
exp_kind
; Type
w' <- HsArrow GhcRn -> TcM Type
tcDataConMult HsArrow GhcRn
w
; String -> SDoc -> TcRn ()
traceTc String
"tcConArg 2" (forall a. Outputable a => a -> SDoc
ppr LHsKind GhcRn
bty)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Type -> a -> Scaled a
Scaled Type
w' Type
arg_ty, forall (p :: Pass). LHsType (GhcPass p) -> HsSrcBang
getBangStrictness LHsKind GhcRn
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
= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ContextKind
-> HsScaled GhcRn (LHsKind GhcRn) -> TcM (Scaled Type, HsSrcBang)
tcConArg ContextKind
exp_kind) [HsScaled GhcRn (LHsKind GhcRn)]
btys
where
combined :: [([XRec GhcRn (FieldOcc GhcRn)], HsScaled GhcRn (LHsKind GhcRn))]
combined = forall a b. (a -> b) -> [a] -> [b]
map (\(L SrcSpanAnnA
_ ConDeclField GhcRn
f) -> (forall pass. ConDeclField pass -> [LFieldOcc pass]
cd_fld_names ConDeclField GhcRn
f,forall a pass. a -> HsScaled pass a
hsLinear (forall pass. ConDeclField pass -> LBangType pass
cd_fld_type ConDeclField GhcRn
f)))
(forall l e. GenLocated l e -> e
unLoc LocatedL [LConDeclField GhcRn]
fields)
explode :: ([a], b) -> [(a, b)]
explode ([a]
ns,b
ty) = forall a b. [a] -> [b] -> [(a, b)]
zip [a]
ns (forall a. a -> [a]
repeat b
ty)
exploded :: [(XRec GhcRn (FieldOcc GhcRn), HsScaled GhcRn (LHsKind GhcRn))]
exploded = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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) = 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 -> TcM Type
tcDataConMult arr :: HsArrow GhcRn
arr@(HsUnrestrictedArrow IsUnicodeSyntax
_) = do
Bool
linearEnabled <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.LinearTypes
if Bool
linearEnabled then HsArrow GhcRn -> TcM Type
tcMult HsArrow GhcRn
arr else forall (m :: * -> *) a. Monad m => a -> m a
return Type
oneDataConTy
tcDataConMult HsArrow GhcRn
arr = HsArrow GhcRn -> TcM Type
tcMult HsArrow GhcRn
arr
rejigConRes :: [KnotTied TyConBinder]
-> KnotTied Type
-> [InvisTVBinder]
-> KnotTied Type
-> ([TyVar],
[TyVar],
[InvisTVBinder],
[EqSpec],
TCvSubst)
rejigConRes :: [TyConBinder]
-> Type
-> [VarBndr TyVar Specificity]
-> Type
-> ([TyVar], [TyVar], [VarBndr TyVar Specificity], [EqSpec],
TCvSubst)
rejigConRes [TyConBinder]
tc_tvbndrs Type
res_tmpl [VarBndr TyVar Specificity]
dc_tvbndrs Type
res_ty
| Just TCvSubst
subst <- Type -> Type -> Maybe TCvSubst
tcMatchTy Type
res_tmpl Type
res_ty
= let ([TyVar]
univ_tvs, [EqSpec]
raw_eqs, TCvSubst
kind_subst) = [TyVar] -> [TyVar] -> TCvSubst -> ([TyVar], [EqSpec], TCvSubst)
mkGADTVars [TyVar]
tc_tvs [TyVar]
dc_tvs TCvSubst
subst
raw_ex_tvs :: [TyVar]
raw_ex_tvs = [TyVar]
dc_tvs forall a. Ord a => [a] -> [a] -> [a]
`minusList` [TyVar]
univ_tvs
(TCvSubst
arg_subst, [TyVar]
substed_ex_tvs) = HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
substTyVarBndrs TCvSubst
kind_subst [TyVar]
raw_ex_tvs
subst_user_tvs :: [VarBndr TyVar Specificity] -> [VarBndr TyVar Specificity]
subst_user_tvs = forall var var' flag.
(var -> var') -> [VarBndr var flag] -> [VarBndr var' flag]
mapVarBndrs (String -> Type -> TyVar
getTyVar String
"rejigConRes" forall b c a. (b -> c) -> (a -> b) -> a -> c
. TCvSubst -> TyVar -> Type
substTyVar TCvSubst
arg_subst)
substed_tvbndrs :: [VarBndr TyVar Specificity]
substed_tvbndrs = [VarBndr TyVar Specificity] -> [VarBndr TyVar Specificity]
subst_user_tvs [VarBndr TyVar Specificity]
dc_tvbndrs
substed_eqs :: [EqSpec]
substed_eqs = forall a b. (a -> b) -> [a] -> [b]
map (TCvSubst -> EqSpec -> EqSpec
substEqSpec TCvSubst
arg_subst) [EqSpec]
raw_eqs
in
([TyVar]
univ_tvs, [TyVar]
substed_ex_tvs, [VarBndr TyVar Specificity]
substed_tvbndrs, [EqSpec]
substed_eqs, TCvSubst
arg_subst)
| Bool
otherwise
= ([TyVar]
tc_tvs, [TyVar]
dc_tvs forall a. Ord a => [a] -> [a] -> [a]
`minusList` [TyVar]
tc_tvs, [VarBndr TyVar Specificity]
dc_tvbndrs, [], TCvSubst
emptyTCvSubst)
where
dc_tvs :: [TyVar]
dc_tvs = forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TyVar Specificity]
dc_tvbndrs
tc_tvs :: [TyVar]
tc_tvs = forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tc_tvbndrs
mkGADTVars :: [TyVar]
-> [TyVar]
-> TCvSubst
-> ( [TyVar]
, [EqSpec]
, TCvSubst )
mkGADTVars :: [TyVar] -> [TyVar] -> TCvSubst -> ([TyVar], [EqSpec], TCvSubst)
mkGADTVars [TyVar]
tmpl_tvs [TyVar]
dc_tvs TCvSubst
subst
= [TyVar]
-> [EqSpec]
-> TCvSubst
-> TCvSubst
-> [TyVar]
-> ([TyVar], [EqSpec], TCvSubst)
choose [] [] TCvSubst
empty_subst TCvSubst
empty_subst [TyVar]
tmpl_tvs
where
in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet ([TyVar] -> VarSet
mkVarSet [TyVar]
tmpl_tvs VarSet -> VarSet -> VarSet
`unionVarSet` [TyVar] -> VarSet
mkVarSet [TyVar]
dc_tvs)
InScopeSet -> InScopeSet -> InScopeSet
`unionInScope` TCvSubst -> InScopeSet
getTCvInScope TCvSubst
subst
empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst InScopeSet
in_scope
choose :: [TyVar]
-> [EqSpec]
-> TCvSubst
-> TCvSubst
-> [TyVar]
-> ( [TyVar]
, [EqSpec]
, TCvSubst )
choose :: [TyVar]
-> [EqSpec]
-> TCvSubst
-> TCvSubst
-> [TyVar]
-> ([TyVar], [EqSpec], TCvSubst)
choose [TyVar]
univs [EqSpec]
eqs TCvSubst
_t_sub TCvSubst
r_sub []
= (forall a. [a] -> [a]
reverse [TyVar]
univs, forall a. [a] -> [a]
reverse [EqSpec]
eqs, TCvSubst
r_sub)
choose [TyVar]
univs [EqSpec]
eqs TCvSubst
t_sub TCvSubst
r_sub (TyVar
t_tv:[TyVar]
t_tvs)
| Just Type
r_ty <- TCvSubst -> TyVar -> Maybe Type
lookupTyVar TCvSubst
subst TyVar
t_tv
= case Type -> Maybe TyVar
getTyVar_maybe Type
r_ty of
Just TyVar
r_tv
| Bool -> Bool
not (TyVar
r_tv forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TyVar]
univs)
, TyVar -> Type
tyVarKind TyVar
r_tv Type -> Type -> Bool
`eqType` (HasCallStack => TCvSubst -> Type -> Type
substTy TCvSubst
t_sub (TyVar -> Type
tyVarKind TyVar
t_tv))
->
[TyVar]
-> [EqSpec]
-> TCvSubst
-> TCvSubst
-> [TyVar]
-> ([TyVar], [EqSpec], TCvSubst)
choose (TyVar
r_tvforall a. a -> [a] -> [a]
:[TyVar]
univs) [EqSpec]
eqs
(TCvSubst -> TyVar -> Type -> TCvSubst
extendTvSubst TCvSubst
t_sub TyVar
t_tv Type
r_ty')
(TCvSubst -> TyVar -> Type -> TCvSubst
extendTvSubst TCvSubst
r_sub TyVar
r_tv Type
r_ty')
[TyVar]
t_tvs
where
r_tv1 :: TyVar
r_tv1 = TyVar -> Name -> TyVar
setTyVarName TyVar
r_tv (TyVar -> TyVar -> Name
choose_tv_name TyVar
r_tv TyVar
t_tv)
r_ty' :: Type
r_ty' = TyVar -> Type
mkTyVarTy TyVar
r_tv1
Maybe TyVar
_ -> [TyVar]
-> [EqSpec]
-> TCvSubst
-> TCvSubst
-> [TyVar]
-> ([TyVar], [EqSpec], TCvSubst)
choose (TyVar
t_tv'forall a. a -> [a] -> [a]
:[TyVar]
univs) (TyVar -> Type -> EqSpec
mkEqSpec TyVar
t_tv' Type
r_ty forall a. a -> [a] -> [a]
: [EqSpec]
eqs)
(TCvSubst -> TyVar -> Type -> TCvSubst
extendTvSubst TCvSubst
t_sub TyVar
t_tv (TyVar -> Type
mkTyVarTy TyVar
t_tv'))
TCvSubst
r_sub [TyVar]
t_tvs
where
t_tv' :: TyVar
t_tv' = (Type -> Type) -> TyVar -> TyVar
updateTyVarKind (HasCallStack => TCvSubst -> Type -> Type
substTy TCvSubst
t_sub) TyVar
t_tv
| Bool
otherwise
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkGADTVars" (forall a. Outputable a => a -> SDoc
ppr [TyVar]
tmpl_tvs SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr TCvSubst
subst)
choose_tv_name :: TyVar -> TyVar -> Name
choose_tv_name :: TyVar -> TyVar -> Name
choose_tv_name TyVar
r_tv TyVar
t_tv
| Name -> Bool
isSystemName Name
r_tv_name
= Name -> Unique -> Name
setNameUnique Name
t_tv_name (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 = forall a. NamedThing a => a -> Name
getName TyVar
r_tv
t_tv_name :: Name
t_tv_name = forall a. NamedThing a => a -> Name
getName TyVar
t_tv
checkValidTyCl :: TyCon -> TcM [TyCon]
checkValidTyCl :: TyCon -> TcM [TyCon]
checkValidTyCl TyCon
tc
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyCon
tc) forall a b. (a -> b) -> a -> b
$
forall a. TyCon -> TcM a -> TcM a
addTyConCtxt TyCon
tc forall a b. (a -> b) -> a -> b
$
forall r. TcRn r -> TcRn r -> TcRn r
recoverM TcM [TyCon]
recovery_code forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"Starting validity for tycon" (forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; TyCon -> TcRn ()
checkValidTyCon TyCon
tc
; String -> SDoc -> TcRn ()
traceTc String
"Done validity for tycon" (forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; 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" (forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map TyCon -> TyCon
mk_fake_tc forall a b. (a -> b) -> a -> b
$
TyCon
tc 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 forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map DataCon -> TyCon
promoteDataCon (TyCon -> [DataCon]
tyConDataCons TyCon
tc)
checkValidTyCon :: TyCon -> TcM ()
checkValidTyCon :: TyCon -> TcRn ()
checkValidTyCon TyCon
tc
| TyCon -> Bool
isPrimTyCon TyCon
tc
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
| forall thing. NamedThing thing => thing -> Bool
isWiredIn TyCon
tc
= String -> SDoc -> TcRn ()
traceTc String
"Skipping validity check for wired-in" (forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
| Bool
otherwise
= do { String -> SDoc -> TcRn ()
traceTc String
"checkValidTyCon" (forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> 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)
-> forall a. TyCon -> TcM a -> TcM a
tcAddClosedTypeFamilyDeclCtxt TyCon
tc forall a b. (a -> b) -> a -> b
$
CoAxiom Branched -> TcRn ()
checkValidCoAxiom CoAxiom Branched
ax
; ClosedSynFamilyTyCon Maybe (CoAxiom Branched)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
; FamTyConFlav
AbstractClosedSynFamilyTyCon ->
do { Bool
hsBoot <- IOEnv (Env TcGblEnv TcLclEnv) Bool
tcIsHsBootOrSig
; Bool -> SDoc -> TcRn ()
checkTc Bool
hsBoot forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"You may define an abstract closed type family" SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"only in a .hs-boot file" }
; DataFamilyTyCon {} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
; FamTyConFlav
OpenSynFamilyTyCon -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
; BuiltInSynFamTyCon BuiltInSynFamily
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return () }
| Bool
otherwise -> do
{
String -> SDoc -> TcRn ()
traceTc String
"cvtc1" (forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; UserTypeCtxt -> [Type] -> TcRn ()
checkValidTheta (Name -> UserTypeCtxt
DataTyCtxt Name
name) (TyCon -> [Type]
tyConStupidTheta TyCon
tc)
; String -> SDoc -> TcRn ()
traceTc String
"cvtc2" (forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Bool
existential_ok <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ExistentialQuantification
; Bool
gadt_ok <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.GADTs
; let ex_ok :: Bool
ex_ok = Bool
existential_ok Bool -> Bool -> Bool
|| Bool
gadt_ok
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DynFlags -> Bool -> TyCon -> DataCon -> TcRn ()
checkValidDataCon DynFlags
dflags Bool
ex_ok TyCon
tc) [DataCon]
data_cons
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([DataCon] -> FieldLabel -> TcRn ()
checkPartialRecordField [DataCon]
data_cons) (TyCon -> [FieldLabel]
tyConFieldLabels TyCon
tc)
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NonEmpty (FieldLabel, DataCon) -> TcRn ()
check_fields [NonEmpty (FieldLabel, DataCon)]
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 = forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a]
equivClasses forall {b} {b}. (FieldLabel, b) -> (FieldLabel, b) -> Ordering
cmp_fld (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
_) = FieldLabel -> FieldLabelString
flLabel FieldLabel
f1 FieldLabelString -> FieldLabelString -> Ordering
`uniqCompareFS` FieldLabel -> FieldLabelString
flLabel FieldLabel
f2
get_fields :: DataCon -> [(FieldLabel, DataCon)]
get_fields DataCon
con = DataCon -> [FieldLabel]
dataConFieldLabels DataCon
con forall a b. [a] -> [b] -> [(a, b)]
`zip` forall a. a -> [a]
repeat DataCon
con
check_fields :: NonEmpty (FieldLabel, DataCon) -> TcRn ()
check_fields ((FieldLabel
label, DataCon
con1) :| [(FieldLabel, DataCon)]
other_fields)
= forall r. TcRn r -> TcRn r -> TcRn r
recoverM (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall a b. (a -> b) -> a -> b
$ 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
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$
WarningFlag -> Bool -> SDoc -> TcRn ()
warnIfFlag WarningFlag
Opt_WarnPartialFields
(Bool -> Bool
not Bool
is_exhaustive Bool -> Bool -> Bool
&& Bool -> Bool
not (OccName -> Bool
startsWithUnderscore OccName
occ_name))
([SDoc] -> SDoc
sep [String -> SDoc
text String
"Use of partial record field selector" SDoc -> SDoc -> SDoc
<> SDoc
colon,
Arity -> SDoc -> SDoc
nest Arity
2 forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr OccName
occ_name)])
where
loc :: SrcSpan
loc = forall a. NamedThing a => a -> SrcSpan
getSrcSpan (FieldLabel -> Name
flSelector FieldLabel
fld)
occ_name :: OccName
occ_name = forall name. HasOccName name => name -> OccName
occName FieldLabel
fld
([DataCon]
cons_with_field, [DataCon]
cons_without_field) = 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (DataCon -> [FieldLabel]
dataConFieldLabels DataCon
con)
is_exhaustive :: Bool
is_exhaustive = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Type] -> DataCon -> Bool
dataConCannotMatch [Type]
inst_tys) [DataCon]
cons_without_field
con1 :: DataCon
con1 = ASSERT( not (null cons_with_field) ) head cons_with_field
([TyVar]
univ_tvs, [TyVar]
_, [EqSpec]
eq_spec, [Type]
_, [Scaled Type]
_, Type
_) = DataCon
-> ([TyVar], [TyVar], [EqSpec], [Type], [Scaled Type], Type)
dataConFullSig DataCon
con1
eq_subst :: TCvSubst
eq_subst = [(TyVar, Type)] -> TCvSubst
mkTvSubstPrs (forall a b. (a -> b) -> [a] -> [b]
map EqSpec -> (TyVar, Type)
eqSpecPair [EqSpec]
eq_spec)
inst_tys :: [Type]
inst_tys = TCvSubst -> [TyVar] -> [Type]
substTyVars TCvSubst
eq_subst [TyVar]
univ_tvs
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 -> SDoc -> TcRn ()
checkTc (forall a. Maybe a -> Bool
isJust Maybe TCvSubst
mb_subst1) (FieldLabelString -> DataCon -> DataCon -> SDoc
resultTypeMisMatch FieldLabelString
fld DataCon
con1 DataCon
con2)
; Bool -> SDoc -> TcRn ()
checkTc (forall a. Maybe a -> Bool
isJust Maybe TCvSubst
mb_subst2) (FieldLabelString -> DataCon -> DataCon -> SDoc
fieldTypeMisMatch FieldLabelString
fld DataCon
con1 DataCon
con2) }
where
mb_subst1 :: Maybe TCvSubst
mb_subst1 = Type -> Type -> Maybe TCvSubst
tcMatchTy Type
res1 Type
res2
mb_subst2 :: Maybe TCvSubst
mb_subst2 = TCvSubst -> Type -> Type -> Maybe TCvSubst
tcMatchTyX (forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"checkFieldCompat" Maybe TCvSubst
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
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
con_loc forall a b. (a -> b) -> a -> b
$
forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([GenLocated SrcSpanAnnN Name] -> SDoc
dataConCtxt [forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
con_loc) Name
con_name]) forall a b. (a -> b) -> a -> b
$
do { let tc_tvs :: [TyVar]
tc_tvs = TyCon -> [TyVar]
tyConTyVars TyCon
tc
res_ty_tmpl :: Type
res_ty_tmpl = TyCon -> [Type] -> Type
mkFamilyTyConApp TyCon
tc ([TyVar] -> [Type]
mkTyVarTys [TyVar]
tc_tvs)
orig_res_ty :: Type
orig_res_ty = DataCon -> Type
dataConOrigResTy DataCon
con
; String -> SDoc -> TcRn ()
traceTc String
"checkValidDataCon" ([SDoc] -> SDoc
vcat
[ forall a. Outputable a => a -> SDoc
ppr DataCon
con, forall a. Outputable a => a -> SDoc
ppr TyCon
tc, forall a. Outputable a => a -> SDoc
ppr [TyVar]
tc_tvs
, forall a. Outputable a => a -> SDoc
ppr Type
res_ty_tmpl SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
tcTypeKind Type
res_ty_tmpl)
, forall a. Outputable a => a -> SDoc
ppr Type
orig_res_ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
tcTypeKind Type
orig_res_ty)])
; Bool -> SDoc -> TcRn ()
checkTc (forall a. Maybe a -> Bool
isJust (Type -> Type -> Maybe TCvSubst
tcMatchTyKi Type
res_ty_tmpl Type
orig_res_ty))
(DataCon -> Type -> SDoc
badDataConTyCon DataCon
con Type
res_ty_tmpl)
; String -> SDoc -> TcRn ()
traceTc String
"checkValidDataCon 2" (forall a. Outputable a => a -> SDoc
ppr Type
data_con_display_type)
; Type -> TcRn ()
checkValidMonoType Type
orig_res_ty
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TyCon -> Bool
isNewTyCon TyCon
tc) forall a b. (a -> b) -> a -> b
$
forall r. TcM r -> TcM r
checkNoErrs forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SDoc -> Type -> TcRn ()
checkForLevPoly SDoc
empty) (forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing forall a b. (a -> b) -> a -> b
$ DataCon -> [Scaled Type]
dataConOrigArgTys DataCon
con)
; 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 -> SDoc -> TcRn ()
checkTc (Bool
existential_ok Bool -> Bool -> Bool
|| DataCon -> Bool
isVanillaDataCon DataCon
con)
(DataCon -> SDoc
badExistential DataCon
con)
; HscEnv
hsc_env <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; let check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()
check_bang :: HsSrcBang -> HsImplBang -> Arity -> TcRn ()
check_bang HsSrcBang
bang HsImplBang
rep_bang Arity
n
| HsSrcBang SourceText
_ SrcUnpackedness
_ SrcStrictness
SrcLazy <- HsSrcBang
bang
, Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.StrictData DynFlags
dflags)
= SDoc -> TcRn ()
addErrTc (Arity -> SDoc -> SDoc
bad_bang Arity
n (String -> SDoc
text String
"Lazy annotation (~) without StrictData"))
| HsSrcBang SourceText
_ SrcUnpackedness
want_unpack SrcStrictness
strict_mark <- HsSrcBang
bang
, SrcUnpackedness -> Bool
isSrcUnpacked SrcUnpackedness
want_unpack, Bool -> Bool
not (SrcStrictness -> Bool
is_strict SrcStrictness
strict_mark)
= WarnReason -> SDoc -> TcRn ()
addWarnTc WarnReason
NoReason (Arity -> SDoc -> SDoc
bad_bang Arity
n (String -> SDoc
text String
"UNPACK pragma lacks '!'"))
| HsSrcBang SourceText
_ SrcUnpackedness
want_unpack SrcStrictness
_ <- HsSrcBang
bang
, SrcUnpackedness -> Bool
isSrcUnpacked SrcUnpackedness
want_unpack
, case HsImplBang
rep_bang of { HsUnpack {} -> Bool
False; HsImplBang
_ -> Bool
True }
, Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_OmitInterfacePragmas DynFlags
dflags)
, forall u. GenHomeUnit u -> Bool
isHomeUnitDefinite (HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env)
= WarnReason -> SDoc -> TcRn ()
addWarnTc WarnReason
NoReason (Arity -> SDoc -> SDoc
bad_bang Arity
n (String -> SDoc
text String
"Ignoring unusable UNPACK pragma"))
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
; forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m ()
zipWith3M_ HsSrcBang -> HsImplBang -> Arity -> TcRn ()
check_bang (DataCon -> [HsSrcBang]
dataConSrcBangs DataCon
con) (DataCon -> [HsImplBang]
dataConImplBangs DataCon
con) [Arity
1..]
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugIsOn forall a b. (a -> b) -> a -> b
$
do { let ([TyVar]
univs, [TyVar]
exs, [EqSpec]
eq_spec, [Type]
_, [Scaled Type]
_, Type
_) = DataCon
-> ([TyVar], [TyVar], [EqSpec], [Type], [Scaled Type], Type)
dataConFullSig DataCon
con
user_tvs :: [TyVar]
user_tvs = DataCon -> [TyVar]
dataConUserTyVars DataCon
con
user_tvbs_invariant :: Bool
user_tvbs_invariant
= forall a. Ord a => [a] -> Set a
Set.fromList ([EqSpec] -> [TyVar] -> [TyVar]
filterEqSpec [EqSpec]
eq_spec [TyVar]
univs forall a. [a] -> [a] -> [a]
++ [TyVar]
exs)
forall a. Eq a => a -> a -> Bool
== forall a. Ord a => [a] -> Set a
Set.fromList [TyVar]
user_tvs
; MASSERT2( user_tvbs_invariant
, vcat ([ ppr con
, ppr univs
, ppr exs
, ppr eq_spec
, ppr user_tvs ])) }
; String -> SDoc -> TcRn ()
traceTc String
"Done validity of data con" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr DataCon
con
, String -> SDoc
text String
"Datacon wrapper type:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (DataCon -> Type
dataConWrapperType DataCon
con)
, String -> SDoc
text String
"Datacon rep type:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (DataCon -> Type
dataConRepType DataCon
con)
, String -> SDoc
text String
"Datacon display type:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
data_con_display_type
, String -> SDoc
text String
"Rep typcon binders:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (TyCon -> [TyConBinder]
tyConBinders (DataCon -> TyCon
dataConTyCon DataCon
con))
, case TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe (DataCon -> TyCon
dataConTyCon DataCon
con) of
Maybe (TyCon, [Type])
Nothing -> String -> SDoc
text String
"not family"
Just (TyCon
f, [Type]
_) -> forall a. Outputable a => a -> SDoc
ppr (TyCon -> [TyConBinder]
tyConBinders TyCon
f) ]
}
where
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 -> Extension -> DynFlags -> Bool
xopt Extension
LangExt.StrictData DynFlags
dflags
SrcStrictness
bang -> SrcStrictness -> Bool
isSrcStrict SrcStrictness
bang
bad_bang :: Arity -> SDoc -> SDoc
bad_bang Arity
n SDoc
herald
= SDoc -> Arity -> SDoc -> SDoc
hang SDoc
herald Arity
2 (String -> SDoc
text String
"on the" SDoc -> SDoc -> SDoc
<+> Arity -> SDoc
speakNth Arity
n
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"argument of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr 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 { Bool -> SDoc -> TcRn ()
checkTc (forall a. [a] -> Bool
isSingleton [Scaled Type]
arg_tys) (DataCon -> Arity -> SDoc
newtypeFieldErr DataCon
con (forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Scaled Type]
arg_tys))
; Bool
unlifted_newtypes <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.UnliftedNewtypes
; let allowedArgType :: Bool
allowedArgType =
Bool
unlifted_newtypes Bool -> Bool -> Bool
|| HasDebugCallStack => Type -> Maybe Bool
isLiftedType_maybe (forall a. Scaled a -> a
scaledThing Scaled Type
arg_ty1) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True
; Bool -> SDoc -> TcRn ()
checkTc Bool
allowedArgType forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"A newtype cannot have an unlifted argument type"
, String -> SDoc
text String
"Perhaps you intended to use UnliftedNewtypes"
]
; Bool
show_linear_types <- Extension -> DynFlags -> Bool
xopt Extension
LangExt.LinearTypes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let check_con :: Bool -> SDoc -> TcRn ()
check_con Bool
what SDoc
msg =
Bool -> SDoc -> TcRn ()
checkTc Bool
what (SDoc
msg SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr DataCon
con SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (Bool -> DataCon -> Type
dataConDisplayType Bool
show_linear_types DataCon
con))
; Bool -> SDoc -> TcRn ()
checkTc (Type -> Bool
ok_mult (forall a. Scaled a -> Type
scaledMult Scaled Type
arg_ty1)) forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"A newtype constructor must be linear"
; Bool -> SDoc -> TcRn ()
check_con (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EqSpec]
eq_spec) forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"A newtype constructor must have a return type of form T a1 ... an"
; Bool -> SDoc -> TcRn ()
check_con (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
theta) forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"A newtype constructor cannot have a context in its type"
; Bool -> SDoc -> TcRn ()
check_con (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
ex_tvs) forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"A newtype constructor cannot have existential type variables"
; Bool -> SDoc -> TcRn ()
checkTc (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all HsSrcBang -> Bool
ok_bang (DataCon -> [HsSrcBang]
dataConSrcBangs DataCon
con))
(DataCon -> SDoc
newtypeStrictError DataCon
con)
}
where
([TyVar]
_univ_tvs, [TyVar]
ex_tvs, [EqSpec]
eq_spec, [Type]
theta, [Scaled Type]
arg_tys, Type
_res_ty)
= DataCon
-> ([TyVar], [TyVar], [EqSpec], [Type], [Scaled Type], Type)
dataConFullSig DataCon
con
(Scaled Type
arg_ty1 : [Scaled Type]
_) = [Scaled Type]
arg_tys
ok_bang :: HsSrcBang -> Bool
ok_bang (HsSrcBang SourceText
_ SrcUnpackedness
_ SrcStrictness
SrcStrict) = Bool
False
ok_bang (HsSrcBang SourceText
_ SrcUnpackedness
_ SrcStrictness
SrcLazy) = Bool
False
ok_bang HsSrcBang
_ = Bool
True
ok_mult :: Type -> Bool
ok_mult Type
One = Bool
True
ok_mult Type
_ = Bool
False
checkValidClass :: Class -> TcM ()
checkValidClass :: Class -> TcRn ()
checkValidClass Class
cls
= do { Bool
constrained_class_methods <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ConstrainedClassMethods
; Bool
multi_param_type_classes <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.MultiParamTypeClasses
; Bool
nullary_type_classes <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.NullaryTypeClasses
; Bool
fundep_classes <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.FunctionalDependencies
; Bool
undecidable_super_classes <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.UndecidableSuperClasses
; Bool -> SDoc -> TcRn ()
checkTc (Bool
multi_param_type_classes Bool -> Bool -> Bool
|| Arity
cls_arity forall a. Eq a => a -> a -> Bool
== Arity
1 Bool -> Bool -> Bool
||
(Bool
nullary_type_classes Bool -> Bool -> Bool
&& Arity
cls_arity forall a. Eq a => a -> a -> Bool
== Arity
0))
(Arity -> Class -> SDoc
classArityErr Arity
cls_arity Class
cls)
; Bool -> SDoc -> TcRn ()
checkTc (Bool
fundep_classes Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([TyVar], [TyVar])]
fundeps) (Class -> SDoc
classFunDepsErr Class
cls)
; UserTypeCtxt -> [Type] -> TcRn ()
checkValidTheta (Name -> UserTypeCtxt
ClassSCCtxt (Class -> Name
className Class
cls)) [Type]
theta
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
undecidable_super_classes forall a b. (a -> b) -> a -> b
$
case Class -> Maybe SDoc
checkClassCycles Class
cls of
Just SDoc
err -> forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a. NamedThing a => a -> SrcSpan
getSrcSpan Class
cls) forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
addErrTc SDoc
err
Maybe SDoc
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
; TcRn () -> TcRn ()
whenNoErrs forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> (TyVar, DefMethInfo) -> TcRn ()
check_op Bool
constrained_class_methods) [(TyVar, DefMethInfo)]
op_stuff
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ClassATItem -> TcRn ()
check_at [ClassATItem]
at_stuff }
where
([TyVar]
tyvars, [([TyVar], [TyVar])]
fundeps, [Type]
theta, [TyVar]
_, [ClassATItem]
at_stuff, [(TyVar, DefMethInfo)]
op_stuff) = Class
-> ([TyVar], [([TyVar], [TyVar])], [Type], [TyVar], [ClassATItem],
[(TyVar, DefMethInfo)])
classExtraBigSig Class
cls
cls_arity :: Arity
cls_arity = forall (t :: * -> *) a. Foldable t => t a -> Arity
length (TyCon -> [TyVar]
tyConVisibleTyVars (Class -> TyCon
classTyCon Class
cls))
cls_tv_set :: VarSet
cls_tv_set = [TyVar] -> VarSet
mkVarSet [TyVar]
tyvars
check_op :: Bool -> (TyVar, DefMethInfo) -> TcRn ()
check_op Bool
constrained_class_methods (TyVar
sel_id, DefMethInfo
dm)
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
sel_id) forall a b. (a -> b) -> a -> b
$
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (TyVar -> Type -> SDoc
classOpCtxt TyVar
sel_id Type
op_ty) forall a b. (a -> b) -> a -> b
$ do
{ String -> SDoc -> TcRn ()
traceTc String
"class op type" (forall a. Outputable a => a -> SDoc
ppr Type
op_ty)
; UserTypeCtxt -> Type -> TcRn ()
checkValidType UserTypeCtxt
ctxt Type
op_ty
; SDoc -> Type -> TcRn ()
checkForLevPoly SDoc
empty Type
tau1
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
constrained_class_methods forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Type -> TcRn ()
check_constraint (forall a. [a] -> [a]
tail (Type
cls_predforall a. a -> [a] -> [a]
:[Type]
op_theta))
; UserTypeCtxt -> TyVar -> Type -> Type -> DefMethInfo -> TcRn ()
check_dm UserTypeCtxt
ctxt TyVar
sel_id Type
cls_pred Type
tau2 DefMethInfo
dm
}
where
ctxt :: UserTypeCtxt
ctxt = Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
op_name Bool
True
op_name :: Name
op_name = TyVar -> Name
idName TyVar
sel_id
op_ty :: Type
op_ty = TyVar -> Type
idType TyVar
sel_id
([TyVar]
_,Type
cls_pred,Type
tau1) = Type -> ([TyVar], Type, Type)
tcSplitMethodTy Type
op_ty
([TyVar]
_,[Type]
op_theta,Type
tau2) = Type -> ([TyVar], [Type], Type)
tcSplitNestedSigmaTys Type
tau1
check_constraint :: TcPredType -> TcM ()
check_constraint :: Type -> TcRn ()
check_constraint Type
pred
= 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)
(SDoc -> TcRn ()
addErrTc (TyVar -> Type -> SDoc
badMethPred TyVar
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, ATValidityInfo)
m_dflt_rhs)
= do { Bool -> SDoc -> TcRn ()
checkTc (Arity
cls_arity forall a. Eq a => a -> a -> Bool
== Arity
0 Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TyVar -> VarSet -> Bool
`elemVarSet` VarSet
cls_tv_set) [TyVar]
fam_tvs)
(Class -> TyCon -> SDoc
noClassTyVarErr Class
cls TyCon
fam_tc)
; forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust Maybe (Type, ATValidityInfo)
m_dflt_rhs forall a b. (a -> b) -> a -> b
$ \ (Type
rhs, ATValidityInfo
at_validity_info) ->
case ATValidityInfo
at_validity_info of
ATValidityInfo
NoATVI -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ATVI SrcSpan
loc [Type]
pats ->
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$
forall a. SDoc -> Name -> TcM a -> TcM a
tcAddFamInstCtxt (String -> SDoc
text String
"default type instance") (forall a. NamedThing a => a -> Name
getName TyCon
fam_tc) forall a b. (a -> b) -> a -> b
$
do { TyCon -> [Type] -> TcRn ()
checkValidAssocTyFamDeflt TyCon
fam_tc [Type]
pats
; TyCon -> [TyVar] -> [Type] -> Type -> TcRn ()
checkValidTyFamEqn TyCon
fam_tc [TyVar]
fam_tvs ([TyVar] -> [Type]
mkTyVarTys [TyVar]
fam_tvs) Type
rhs }}
where
fam_tvs :: [TyVar]
fam_tvs = TyCon -> [TyVar]
tyConTyVars TyCon
fam_tc
check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM ()
check_dm :: UserTypeCtxt -> TyVar -> Type -> Type -> DefMethInfo -> TcRn ()
check_dm UserTypeCtxt
ctxt TyVar
sel_id Type
vanilla_cls_pred Type
vanilla_tau
(Just (Name
dm_name, dm_spec :: DefMethSpec Type
dm_spec@(GenericDM Type
dm_ty)))
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
dm_name) forall a b. (a -> b) -> a -> b
$ do
let cls_pred :: Type
cls_pred = Class -> [Type] -> Type
mkClassPred Class
cls forall a b. (a -> b) -> a -> b
$ [TyVar] -> [Type]
mkTyVarTys forall a b. (a -> b) -> a -> b
$ Class -> [TyVar]
classTyVars Class
cls
([TyVar]
_, [Type]
_, Type
dm_tau) = Type -> ([TyVar], [Type], Type)
tcSplitNestedSigmaTys Type
dm_ty
vanilla_phi_ty :: Type
vanilla_phi_ty = [Type] -> Type -> Type
mkPhiTy [Type
vanilla_cls_pred] Type
vanilla_tau
dm_phi_ty :: Type
dm_phi_ty = [Type] -> Type -> Type
mkPhiTy [Type
cls_pred] Type
dm_tau
String -> SDoc -> TcRn ()
traceTc String
"check_dm" forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"vanilla_phi_ty" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
vanilla_phi_ty
, String -> SDoc
text String
"dm_phi_ty" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
dm_phi_ty ]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ [Type] -> [Type] -> Maybe TCvSubst
tcMatchTys [Type
dm_phi_ty, Type
vanilla_phi_ty]
[Type
vanilla_phi_ty, Type
dm_phi_ty]) forall a b. (a -> b) -> a -> b
$ SDoc -> TcRn ()
addErrTc forall a b. (a -> b) -> a -> b
$
SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"The default type signature for"
SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyVar
sel_id SDoc -> SDoc -> SDoc
<> SDoc
colon)
Arity
2 (forall a. Outputable a => a -> SDoc
ppr Type
dm_ty)
SDoc -> SDoc -> SDoc
$$ (String -> SDoc
text String
"does not match its corresponding"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"non-default type signature")
UserTypeCtxt -> Type -> TcRn ()
checkValidType UserTypeCtxt
ctxt (Class -> TyVar -> DefMethSpec Type -> Type
mkDefaultMethodType Class
cls TyVar
sel_id DefMethSpec Type
dm_spec)
check_dm UserTypeCtxt
_ TyVar
_ Type
_ Type
_ DefMethInfo
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkFamFlag :: Name -> TcM ()
checkFamFlag :: Name -> TcRn ()
checkFamFlag Name
tc_name
= do { Bool
idx_tys <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TypeFamilies
; Bool -> SDoc -> TcRn ()
checkTc Bool
idx_tys SDoc
err_msg }
where
err_msg :: SDoc
err_msg = SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Illegal family declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
tc_name))
Arity
2 (String -> SDoc
text String
"Enable TypeFamilies to allow indexed type families")
checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM ()
checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcRn ()
checkResultSigFlag Name
tc_name (TyVarSig XTyVarSig GhcRn
_ LHsTyVarBndr () GhcRn
tvb)
= do { Bool
ty_fam_deps <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TypeFamilyDependencies
; Bool -> SDoc -> TcRn ()
checkTc Bool
ty_fam_deps forall a b. (a -> b) -> a -> b
$
SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Illegal result type variable" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr LHsTyVarBndr () GhcRn
tvb SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
tc_name))
Arity
2 (String -> SDoc
text String
"Enable TypeFamilyDependencies to allow result variable names") }
checkResultSigFlag Name
_ FamilyResultSig GhcRn
_ = 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 = 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, [TyVar]
vis_vars) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Role, TyConBinder) -> Maybe (Role, TyVar)
pick_vis forall a b. (a -> b) -> a -> b
$
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, TyVar)
pick_vis (Role
role, TyConBinder
tvb)
| forall tv. VarBndr tv TyConBndrVis -> Bool
isVisibleTyConBinder TyConBinder
tvb = forall a. a -> Maybe a
Just (Role
role, forall tv argf. VarBndr tv argf -> tv
binderVar TyConBinder
tvb)
| Bool
otherwise = forall a. Maybe a
Nothing
check_roles :: TcRn ()
check_roles
= forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust Maybe (LRoleAnnotDecl GhcRn)
role_annot_decl_maybe forall a b. (a -> b) -> a -> b
$
\decl :: GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn)
decl@(L SrcSpanAnnA
loc (RoleAnnotDecl XCRoleAnnotDecl GhcRn
_ LIdP GhcRn
_ [XRec GhcRn (Maybe Role)]
the_role_annots)) ->
forall a. Name -> TcM a -> TcM a
addRoleAnnotCtxt Name
name forall a b. (a -> b) -> a -> b
$
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ do
{ Bool
role_annots_ok <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.RoleAnnotations
; Bool -> SDoc -> TcRn ()
checkTc Bool
role_annots_ok forall a b. (a -> b) -> a -> b
$ TyCon -> SDoc
needXRoleAnnotations TyCon
tc
; Bool -> SDoc -> TcRn ()
checkTc ([TyVar]
vis_vars forall a b. [a] -> [b] -> Bool
`equalLength` [XRec GhcRn (Maybe Role)]
the_role_annots)
(forall a. [a] -> LRoleAnnotDecl GhcRn -> SDoc
wrongNumberOfRoles [TyVar]
vis_vars GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn)
decl)
; [()]
_ <- forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]
zipWith3M TyVar -> Located (Maybe Role) -> Role -> TcRn ()
checkRoleAnnot [TyVar]
vis_vars [XRec GhcRn (Maybe Role)]
the_role_annots [Role]
vis_roles
; Bool
incoherent_roles_ok <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.IncoherentInstances
; Bool -> SDoc -> TcRn ()
checkTc ( Bool
incoherent_roles_ok
Bool -> Bool -> Bool
|| (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ TyCon -> Bool
isClassTyCon TyCon
tc)
Bool -> Bool -> Bool
|| (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== Role
Nominal) [Role]
vis_roles))
SDoc
incoherentRoles
; Bool
lint <- forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_DoCoreLinting
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
lint forall a b. (a -> b) -> a -> b
$ TyCon -> TcRn ()
checkValidRoles TyCon
tc }
check_no_roles :: TcRn ()
check_no_roles
= forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust Maybe (LRoleAnnotDecl GhcRn)
role_annot_decl_maybe LRoleAnnotDecl GhcRn -> TcRn ()
illegalRoleAnnotDecl
checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM ()
checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcRn ()
checkRoleAnnot TyVar
_ (L SrcSpan
_ Maybe Role
Nothing) Role
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkRoleAnnot TyVar
tv (L SrcSpan
_ (Just Role
r1)) Role
r2
= forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Role
r1 forall a. Eq a => a -> a -> Bool
/= Role
r2) forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
addErrTc forall a b. (a -> b) -> a -> b
$ Name -> Role -> Role -> SDoc
badRoleAnnot (TyVar -> Name
tyVarName TyVar
tv) Role
r1 Role
r2
checkValidRoles :: TyCon -> TcM ()
checkValidRoles :: TyCon -> TcRn ()
checkValidRoles TyCon
tc
| TyCon -> Bool
isAlgTyCon TyCon
tc
= 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
= UniqFM TyVar Role -> Role -> Type -> TcRn ()
check_ty_roles (forall a. [TyVar] -> [a] -> VarEnv a
zipVarEnv (TyCon -> [TyVar]
tyConTyVars TyCon
tc) (TyCon -> [Role]
tyConRoles TyCon
tc)) Role
Representational Type
rhs
| Bool
otherwise
= 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" (forall a. Outputable a => a -> SDoc
ppr DataCon
datacon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (TyCon -> [Role]
tyConRoles TyCon
tc))
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (UniqFM TyVar Role -> Role -> Type -> TcRn ()
check_ty_roles UniqFM TyVar Role
role_env Role
Representational) forall a b. (a -> b) -> a -> b
$
[EqSpec] -> [Type]
eqSpecPreds [EqSpec]
eq_spec forall a. [a] -> [a] -> [a]
++ [Type]
theta forall a. [a] -> [a] -> [a]
++ (forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys) }
where
([TyVar]
univ_tvs, [TyVar]
ex_tvs, [EqSpec]
eq_spec, [Type]
theta, [Scaled Type]
arg_tys, Type
_res_ty)
= DataCon
-> ([TyVar], [TyVar], [EqSpec], [Type], [Scaled Type], Type)
dataConFullSig DataCon
datacon
univ_roles :: UniqFM TyVar Role
univ_roles = forall a. [TyVar] -> [a] -> VarEnv a
zipVarEnv [TyVar]
univ_tvs (TyCon -> [Role]
tyConRoles TyCon
tc)
ex_roles :: UniqFM TyVar Role
ex_roles = forall a. [(TyVar, a)] -> VarEnv a
mkVarEnv (forall a b. (a -> b) -> [a] -> [b]
map (, Role
Nominal) [TyVar]
ex_tvs)
role_env :: UniqFM TyVar Role
role_env = UniqFM TyVar Role
univ_roles forall a. VarEnv a -> VarEnv a -> VarEnv a
`plusVarEnv` UniqFM TyVar Role
ex_roles
check_ty_roles :: UniqFM TyVar Role -> Role -> Type -> TcRn ()
check_ty_roles UniqFM TyVar Role
env Role
role Type
ty
| Just Type
ty' <- Type -> Maybe Type
coreView Type
ty
= UniqFM TyVar Role -> Role -> Type -> TcRn ()
check_ty_roles UniqFM TyVar Role
env Role
role Type
ty'
check_ty_roles UniqFM TyVar Role
env Role
role (TyVarTy TyVar
tv)
= case forall a. VarEnv a -> TyVar -> Maybe a
lookupVarEnv UniqFM TyVar Role
env TyVar
tv of
Just Role
role' -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Role
role' Role -> Role -> Bool
`ltRole` Role
role Bool -> Bool -> Bool
|| Role
role' forall a. Eq a => a -> a -> Bool
== Role
role) forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
report_error forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"type variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr TyVar
tv) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"cannot have role" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Role
role SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"because it was assigned role" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Role
role'
Maybe Role
Nothing -> SDoc -> TcRn ()
report_error forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"type variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr TyVar
tv) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"missing in environment"
check_ty_roles UniqFM TyVar Role
env Role
Representational (TyConApp TyCon
tc [Type]
tys)
= let roles' :: [Role]
roles' = TyCon -> [Role]
tyConRoles TyCon
tc in
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (UniqFM TyVar Role -> Role -> Type -> TcRn ()
maybe_check_ty_roles UniqFM TyVar Role
env) [Role]
roles' [Type]
tys
check_ty_roles UniqFM TyVar Role
env Role
Nominal (TyConApp TyCon
_ [Type]
tys)
= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (UniqFM TyVar Role -> Role -> Type -> TcRn ()
check_ty_roles UniqFM TyVar Role
env Role
Nominal) [Type]
tys
check_ty_roles UniqFM TyVar Role
_ Role
Phantom ty :: Type
ty@(TyConApp {})
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"check_ty_roles" (forall a. Outputable a => a -> SDoc
ppr Type
ty)
check_ty_roles UniqFM TyVar Role
env Role
role (AppTy Type
ty1 Type
ty2)
= UniqFM TyVar Role -> Role -> Type -> TcRn ()
check_ty_roles UniqFM TyVar Role
env Role
role Type
ty1
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UniqFM TyVar Role -> Role -> Type -> TcRn ()
check_ty_roles UniqFM TyVar Role
env Role
Nominal Type
ty2
check_ty_roles UniqFM TyVar Role
env Role
role (FunTy AnonArgFlag
_ Type
w Type
ty1 Type
ty2)
= UniqFM TyVar Role -> Role -> Type -> TcRn ()
check_ty_roles UniqFM TyVar Role
env Role
Nominal Type
w
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UniqFM TyVar Role -> Role -> Type -> TcRn ()
check_ty_roles UniqFM TyVar Role
env Role
role Type
ty1
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UniqFM TyVar Role -> Role -> Type -> TcRn ()
check_ty_roles UniqFM TyVar Role
env Role
role Type
ty2
check_ty_roles UniqFM TyVar Role
env Role
role (ForAllTy (Bndr TyVar
tv ArgFlag
_) Type
ty)
= UniqFM TyVar Role -> Role -> Type -> TcRn ()
check_ty_roles UniqFM TyVar Role
env Role
Nominal (TyVar -> Type
tyVarKind TyVar
tv)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UniqFM TyVar Role -> Role -> Type -> TcRn ()
check_ty_roles (forall a. VarEnv a -> TyVar -> a -> VarEnv a
extendVarEnv UniqFM TyVar Role
env TyVar
tv Role
Nominal) Role
role Type
ty
check_ty_roles UniqFM TyVar Role
_ Role
_ (LitTy {}) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
check_ty_roles UniqFM TyVar Role
env Role
role (CastTy Type
t Coercion
_)
= UniqFM TyVar Role -> Role -> Type -> TcRn ()
check_ty_roles UniqFM TyVar Role
env Role
role Type
t
check_ty_roles UniqFM TyVar Role
_ Role
role (CoercionTy Coercion
co)
= forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Role
role forall a. Eq a => a -> a -> Bool
== Role
Phantom) forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
report_error forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"coercion" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Coercion
co SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has bad role" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Role
role
maybe_check_ty_roles :: UniqFM TyVar Role -> Role -> Type -> TcRn ()
maybe_check_ty_roles UniqFM TyVar Role
env Role
role Type
ty
= forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Role
role forall a. Eq a => a -> a -> Bool
== Role
Nominal Bool -> Bool -> Bool
|| Role
role forall a. Eq a => a -> a -> Bool
== Role
Representational) forall a b. (a -> b) -> a -> b
$
UniqFM TyVar Role -> Role -> Type -> TcRn ()
check_ty_roles UniqFM TyVar Role
env Role
role Type
ty
report_error :: SDoc -> TcRn ()
report_error SDoc
doc
= SDoc -> TcRn ()
addErrTc forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [String -> SDoc
text String
"Internal error in role inference:",
SDoc
doc,
String -> SDoc
text String
"Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug"]
tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc
tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc
tcMkDeclCtxt TyClDecl GhcRn
decl = [SDoc] -> SDoc
hsep [String -> SDoc
text String
"In the", forall (p :: Pass). TyClDecl (GhcPass p) -> SDoc
pprTyClDeclFlavour TyClDecl GhcRn
decl,
String -> SDoc
text String
"declaration for", SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr (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
| ASSERT2( isTcTyCon tycon, ppr tycon )
ASSERT2( not (tcTyConIsPoly tycon), ppr tycon $$ ppr tc_kind )
Bool
has_vdq
= 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 = 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 = (forall tv argf. VarBndr tv argf -> tv
binderVar TyConBinder
tcb TyVar -> VarSet -> Bool
`elemVarSet` VarSet
kind_fvs) Bool -> Bool -> Bool
&&
forall tv. VarBndr tv TyConBndrVis -> Bool
isVisibleTyConBinder TyConBinder
tcb
vdq_warning :: SDoc
vdq_warning = [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"NB: Type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr TyCon
tycon) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"was inferred to use visible dependent quantification."
, String -> SDoc
text String
"Most types with visible dependent quantification are"
, String -> SDoc
text String
"polymorphically recursive and need a standalone kind"
, String -> SDoc
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
= 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
= forall a. SDoc -> Name -> TcM a -> TcM a
tcAddFamInstCtxt (String -> SDoc
text String
"type instance") (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 (forall (p :: Pass). DataFamInstDecl (GhcPass p) -> SDoc
pprDataFamInstFlavour DataFamInstDecl GhcRn
decl SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"instance")
(forall l e. GenLocated l e -> e
unLoc (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
= 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
hsep [ String -> SDoc
text String
"In the" SDoc -> SDoc -> SDoc
<+> SDoc
flavour SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"declaration for"
, SDoc -> SDoc
quotes (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
= 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
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
ctxt
where
ctxt :: SDoc
ctxt = String -> SDoc
text String
"In the equations for closed type family" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc
resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc
resultTypeMisMatch FieldLabelString
field_name DataCon
con1 DataCon
con2
= [SDoc] -> SDoc
vcat [[SDoc] -> SDoc
sep [String -> SDoc
text String
"Constructors" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr DataCon
con1 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"and" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr DataCon
con2,
String -> SDoc
text String
"have a common field" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr FieldLabelString
field_name) SDoc -> SDoc -> SDoc
<> SDoc
comma],
Arity -> SDoc -> SDoc
nest Arity
2 forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"but have different result types"]
fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc
fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc
fieldTypeMisMatch FieldLabelString
field_name DataCon
con1 DataCon
con2
= [SDoc] -> SDoc
sep [String -> SDoc
text String
"Constructors" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr DataCon
con1 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"and" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr DataCon
con2,
String -> SDoc
text String
"give different types for field", SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr FieldLabelString
field_name)]
dataConCtxt :: [LocatedN Name] -> SDoc
dataConCtxt :: [GenLocated SrcSpanAnnN Name] -> SDoc
dataConCtxt [GenLocated SrcSpanAnnN Name]
cons = String -> SDoc
text String
"In the definition of data constructor" SDoc -> SDoc -> SDoc
<> forall a. [a] -> SDoc
plural [GenLocated SrcSpanAnnN Name]
cons
SDoc -> SDoc -> SDoc
<+> [GenLocated SrcSpanAnnN Name] -> SDoc
ppr_cons [GenLocated SrcSpanAnnN Name]
cons
dataConResCtxt :: [LocatedN Name] -> SDoc
dataConResCtxt :: [GenLocated SrcSpanAnnN Name] -> SDoc
dataConResCtxt [GenLocated SrcSpanAnnN Name]
cons = String -> SDoc
text String
"In the result type of data constructor" SDoc -> SDoc -> SDoc
<> forall a. [a] -> SDoc
plural [GenLocated SrcSpanAnnN Name]
cons
SDoc -> SDoc -> SDoc
<+> [GenLocated SrcSpanAnnN Name] -> SDoc
ppr_cons [GenLocated SrcSpanAnnN Name]
cons
ppr_cons :: [LocatedN Name] -> SDoc
ppr_cons :: [GenLocated SrcSpanAnnN Name] -> SDoc
ppr_cons [GenLocated SrcSpanAnnN Name
con] = SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnN Name
con)
ppr_cons [GenLocated SrcSpanAnnN Name]
cons = forall a. Outputable a => [a] -> SDoc
interpp'SP [GenLocated SrcSpanAnnN Name]
cons
classOpCtxt :: Var -> Type -> SDoc
classOpCtxt :: TyVar -> Type -> SDoc
classOpCtxt TyVar
sel_id Type
tau = [SDoc] -> SDoc
sep [String -> SDoc
text String
"When checking the class method:",
Arity -> SDoc -> SDoc
nest Arity
2 (forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc TyVar
sel_id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
tau)]
classArityErr :: Int -> Class -> SDoc
classArityErr :: Arity -> Class -> SDoc
classArityErr Arity
n Class
cls
| Arity
n forall a. Eq a => a -> a -> Bool
== Arity
0 = String -> String -> SDoc
mkErr String
"No" String
"no-parameter"
| Bool
otherwise = String -> String -> SDoc
mkErr String
"Too many" String
"multi-parameter"
where
mkErr :: String -> String -> SDoc
mkErr String
howMany String
allowWhat =
[SDoc] -> SDoc
vcat [String -> SDoc
text (String
howMany forall a. [a] -> [a] -> [a]
++ String
" parameters for class") SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Class
cls),
SDoc -> SDoc
parens (String -> SDoc
text (String
"Enable MultiParamTypeClasses to allow "
forall a. [a] -> [a] -> [a]
++ String
allowWhat forall a. [a] -> [a] -> [a]
++ String
" classes"))]
classFunDepsErr :: Class -> SDoc
classFunDepsErr :: Class -> SDoc
classFunDepsErr Class
cls
= [SDoc] -> SDoc
vcat [String -> SDoc
text String
"Fundeps in class" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Class
cls),
SDoc -> SDoc
parens (String -> SDoc
text String
"Enable FunctionalDependencies to allow fundeps")]
badMethPred :: Id -> TcPredType -> SDoc
badMethPred :: TyVar -> Type -> SDoc
badMethPred TyVar
sel_id Type
pred
= [SDoc] -> SDoc
vcat [ SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Constraint" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Type
pred)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"in the type of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr TyVar
sel_id))
Arity
2 (String -> SDoc
text String
"constrains only the class type variables")
, String -> SDoc
text String
"Enable ConstrainedClassMethods to allow it" ]
noClassTyVarErr :: Class -> TyCon -> SDoc
noClassTyVarErr :: Class -> TyCon -> SDoc
noClassTyVarErr Class
clas TyCon
fam_tc
= [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The associated type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
hsep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr (TyCon -> [TyVar]
tyConTyVars TyCon
fam_tc)))
, String -> SDoc
text String
"mentions none of the type or kind variables of the class" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Class
clas SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
hsep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr (Class -> [TyVar]
classTyVars Class
clas)))]
badDataConTyCon :: DataCon -> Type -> SDoc
badDataConTyCon :: DataCon -> Type -> SDoc
badDataConTyCon DataCon
data_con Type
res_ty_tmpl
= SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Data constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr DataCon
data_con) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"returns type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Type
actual_res_ty))
Arity
2 (String -> SDoc
text String
"instead of an instance of its parent type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Type
res_ty_tmpl))
where
actual_res_ty :: Type
actual_res_ty = DataCon -> Type
dataConOrigResTy DataCon
data_con
badGadtDecl :: Name -> SDoc
badGadtDecl :: Name -> SDoc
badGadtDecl Name
tc_name
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Illegal generalised algebraic data declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
, Arity -> SDoc -> SDoc
nest Arity
2 (SDoc -> SDoc
parens forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Enable the GADTs extension to allow this") ]
badExistential :: DataCon -> SDoc
badExistential :: DataCon -> SDoc
badExistential DataCon
con
= forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocLinearTypes (\Bool
show_linear_types ->
SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Data constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr DataCon
con) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"has existential type variables, a context, or a specialised result type")
Arity
2 ([SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr DataCon
con SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (Bool -> DataCon -> Type
dataConDisplayType Bool
show_linear_types DataCon
con)
, SDoc -> SDoc
parens forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Enable ExistentialQuantification or GADTs to allow this" ]))
badStupidTheta :: Name -> SDoc
badStupidTheta :: Name -> SDoc
badStupidTheta Name
tc_name
= String -> SDoc
text String
"A data type declared in GADT style cannot have a context:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
newtypeConError :: Name -> Int -> SDoc
newtypeConError :: Name -> Arity -> SDoc
newtypeConError Name
tycon Arity
n
= [SDoc] -> SDoc
sep [String -> SDoc
text String
"A newtype must have exactly one constructor,",
Arity -> SDoc -> SDoc
nest Arity
2 forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"but" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
tycon) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has" SDoc -> SDoc -> SDoc
<+> Arity -> SDoc
speakN Arity
n ]
newtypeStrictError :: DataCon -> SDoc
newtypeStrictError :: DataCon -> SDoc
newtypeStrictError DataCon
con
= [SDoc] -> SDoc
sep [String -> SDoc
text String
"A newtype constructor cannot have a strictness annotation,",
Arity -> SDoc -> SDoc
nest Arity
2 forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"but" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr DataCon
con) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"does"]
newtypeFieldErr :: DataCon -> Int -> SDoc
newtypeFieldErr :: DataCon -> Arity -> SDoc
newtypeFieldErr DataCon
con_name Arity
n_flds
= [SDoc] -> SDoc
sep [String -> SDoc
text String
"The constructor of a newtype must have exactly one field",
Arity -> SDoc -> SDoc
nest Arity
2 forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"but" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr DataCon
con_name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has" SDoc -> SDoc -> SDoc
<+> Arity -> SDoc
speakN Arity
n_flds]
badSigTyDecl :: Name -> SDoc
badSigTyDecl :: Name -> SDoc
badSigTyDecl Name
tc_name
= [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Illegal kind signature" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
, Arity -> SDoc -> SDoc
nest Arity
2 (SDoc -> SDoc
parens forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Use KindSignatures to allow kind signatures") ]
emptyConDeclsErr :: Name -> SDoc
emptyConDeclsErr :: Name -> SDoc
emptyConDeclsErr Name
tycon
= [SDoc] -> SDoc
sep [SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
tycon) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has no constructors",
Arity -> SDoc -> SDoc
nest Arity
2 forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"(EmptyDataDecls permits this)"]
wrongKindOfFamily :: TyCon -> SDoc
wrongKindOfFamily :: TyCon -> SDoc
wrongKindOfFamily TyCon
family
= String -> SDoc
text String
"Wrong category of family instance; declaration was for a"
SDoc -> SDoc -> SDoc
<+> SDoc
kindOfFamily
where
kindOfFamily :: SDoc
kindOfFamily | TyCon -> Bool
isTypeFamilyTyCon TyCon
family = String -> SDoc
text String
"type family"
| TyCon -> Bool
isDataFamilyTyCon TyCon
family = String -> SDoc
text String
"data family"
| Bool
otherwise = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"wrongKindOfFamily" (forall a. Outputable a => a -> SDoc
ppr TyCon
family)
wrongNumberOfParmsErr :: Arity -> SDoc
wrongNumberOfParmsErr :: Arity -> SDoc
wrongNumberOfParmsErr Arity
max_args
= String -> SDoc
text String
"Number of parameters must match family declaration; expected"
SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Arity
max_args
badRoleAnnot :: Name -> Role -> Role -> SDoc
badRoleAnnot :: Name -> Role -> Role -> SDoc
badRoleAnnot Name
var Role
annot Role
inferred
= SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Role mismatch on variable" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
var SDoc -> SDoc -> SDoc
<> SDoc
colon)
Arity
2 ([SDoc] -> SDoc
sep [ String -> SDoc
text String
"Annotation says", forall a. Outputable a => a -> SDoc
ppr Role
annot
, String -> SDoc
text String
"but role", forall a. Outputable a => a -> SDoc
ppr Role
inferred
, String -> SDoc
text String
"is required" ])
wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc
wrongNumberOfRoles :: forall a. [a] -> LRoleAnnotDecl GhcRn -> SDoc
wrongNumberOfRoles [a]
tyvars d :: LRoleAnnotDecl GhcRn
d@(L SrcSpanAnnA
_ (RoleAnnotDecl XCRoleAnnotDecl GhcRn
_ LIdP GhcRn
_ [XRec GhcRn (Maybe Role)]
annots))
= SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Wrong number of roles listed in role annotation;" SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"Expected" SDoc -> SDoc -> SDoc
<+> (forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Arity
length [a]
tyvars) SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"got" SDoc -> SDoc -> SDoc
<+> (forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Arity
length [XRec GhcRn (Maybe Role)]
annots) SDoc -> SDoc -> SDoc
<> SDoc
colon)
Arity
2 (forall a. Outputable a => a -> SDoc
ppr LRoleAnnotDecl GhcRn
d)
illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM ()
illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcRn ()
illegalRoleAnnotDecl (L SrcSpanAnnA
loc (RoleAnnotDecl XCRoleAnnotDecl GhcRn
_ LIdP GhcRn
tycon [XRec GhcRn (Maybe Role)]
_))
= forall a. [ErrCtxt] -> TcM a -> TcM a
setErrCtxt [] forall a b. (a -> b) -> a -> b
$
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
addErrTc (String -> SDoc
text String
"Illegal role annotation for" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr LIdP GhcRn
tycon SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
';' SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"they are allowed only for datatypes and classes.")
needXRoleAnnotations :: TyCon -> SDoc
needXRoleAnnotations :: TyCon -> SDoc
needXRoleAnnotations TyCon
tc
= String -> SDoc
text String
"Illegal role annotation for" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
';' SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"did you intend to use RoleAnnotations?"
incoherentRoles :: SDoc
incoherentRoles :: SDoc
incoherentRoles = (String -> SDoc
text String
"Roles other than" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"nominal") SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"for class parameters can lead to incoherence.") SDoc -> SDoc -> SDoc
$$
(String -> SDoc
text String
"Use IncoherentInstances to allow this; bad role found")
wrongTyFamName :: Name -> Name -> SDoc
wrongTyFamName :: Name -> Name -> SDoc
wrongTyFamName Name
fam_tc_name Name
eqn_tc_name
= SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Mismatched type name in type family instance.")
Arity
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Expected:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
fam_tc_name
, String -> SDoc
text String
" Actual:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
eqn_tc_name ])
addTyConCtxt :: TyCon -> TcM a -> TcM a
addTyConCtxt :: forall a. TyCon -> TcM a -> TcM a
addTyConCtxt TyCon
tc = forall a. Name -> TyConFlavour -> TcM a -> TcM a
addTyConFlavCtxt Name
name TyConFlavour
flav
where
name :: Name
name = forall a. NamedThing a => a -> Name
getName TyCon
tc
flav :: TyConFlavour
flav = TyCon -> TyConFlavour
tyConFlavour TyCon
tc
addRoleAnnotCtxt :: Name -> TcM a -> TcM a
addRoleAnnotCtxt :: forall a. Name -> TcM a -> TcM a
addRoleAnnotCtxt Name
name
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"while checking a role annotation for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
name)