{-# 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
= TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
forall r. TcM r -> TcM r
checkNoErrs (TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]))
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
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 <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
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
; TcGblEnv
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env (TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]))
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
forall a b. (a -> b) -> a -> b
$
[InstInfo GhcRn]
-> [DerivInfo]
-> [TyClGroup GhcRn]
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
fold_env ([InstInfo GhcRn]
inst_info' [InstInfo GhcRn] -> [InstInfo GhcRn] -> [InstInfo GhcRn]
forall a. [a] -> [a] -> [a]
++ [InstInfo GhcRn]
inst_info)
([DerivInfo]
deriv_info' [DerivInfo] -> [DerivInfo] -> [DerivInfo]
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" ([IdGhcP 'Renamed] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> IdGhcP 'Renamed)
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)] -> [IdGhcP 'Renamed]
forall a b. (a -> b) -> [a] -> [b]
map (TyClDecl GhcRn -> IdGhcP 'Renamed
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName (TyClDecl GhcRn -> IdGhcP 'Renamed)
-> (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn)
-> GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> IdGhcP 'Renamed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
[LTyClDecl GhcRn]
tyclds))
; ([TyCon]
tyclss, [DerivInfo]
data_deriv_info, NameSet
kindless) <-
TcTypeEnv
-> TcM ([TyCon], [DerivInfo], NameSet)
-> TcM ([TyCon], [DerivInfo], NameSet)
forall r. TcTypeEnv -> TcM r -> TcM r
tcExtendKindEnv ([LTyClDecl GhcRn] -> TcTypeEnv
mkPromotionErrorEnv [LTyClDecl GhcRn]
tyclds) (TcM ([TyCon], [DerivInfo], NameSet)
-> TcM ([TyCon], [DerivInfo], NameSet))
-> TcM ([TyCon], [DerivInfo], NameSet)
-> TcM ([TyCon], [DerivInfo], NameSet)
forall a b. (a -> b) -> a -> b
$
do { NameEnv Type
kisig_env <- [(Name, Type)] -> NameEnv Type
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ([(Name, Type)] -> NameEnv Type)
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, Type)]
-> IOEnv (Env TcGblEnv TcLclEnv) (NameEnv Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Name, Type))
-> [GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, Type)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Name, Type)
LStandaloneKindSig GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (Name, Type)
tcStandaloneKindSig [GenLocated SrcSpanAnnA (StandaloneKindSig GhcRn)]
[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" ([TyCon] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCon]
tyclss)
; HomeUnit
home_unit <- HscEnv -> HomeUnit
hsc_home_unit (HscEnv -> HomeUnit)
-> IOEnv (Env TcGblEnv TcLclEnv) HscEnv
-> IOEnv (Env TcGblEnv TcLclEnv) HomeUnit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) HscEnv
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" ([TyCon] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCon]
tyclss)
; String -> SDoc -> TcRn ()
traceTc String
"Starting validity check" ([TyCon] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCon]
tyclss)
; [TyCon]
tyclss <- (TyCon -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon])
-> [TyCon] -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM TyCon -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
checkValidTyCl [TyCon]
tyclss
; String -> SDoc -> TcRn ()
traceTc String
"Done validity check" ([TyCon] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCon]
tyclss)
; (TyCon -> TcRn ()) -> [TyCon] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TcRn () -> TcRn () -> TcRn ()
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (() -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (TcRn () -> TcRn ()) -> (TyCon -> TcRn ()) -> TyCon -> TcRn ()
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] -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
addTyConsToGblEnv [TyCon]
tyclss
; (TcGblEnv
gbl_env', [InstInfo GhcRn]
inst_info, [DerivInfo]
datafam_deriv_info) <-
TcGblEnv
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
gbl_env (TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]))
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
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 [DerivInfo] -> [DerivInfo] -> [DerivInfo]
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 }
; (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
-> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
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 ((TyCon -> SDoc) -> [TyCon] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map TyCon -> SDoc
ppr_tc_tycon [TyCon]
tc_tycons))
; (([TyCon], [DerivInfo], NameSet)
-> TcM ([TyCon], [DerivInfo], NameSet))
-> TcM ([TyCon], [DerivInfo], NameSet)
forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM ((([TyCon], [DerivInfo], NameSet)
-> TcM ([TyCon], [DerivInfo], NameSet))
-> TcM ([TyCon], [DerivInfo], NameSet))
-> (([TyCon], [DerivInfo], NameSet)
-> TcM ([TyCon], [DerivInfo], NameSet))
-> TcM ([TyCon], [DerivInfo], NameSet)
forall a b. (a -> b) -> a -> b
$ \ ~([TyCon]
rec_tyclss, [DerivInfo]
_, NameSet
_) -> do
{ TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
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) <-
[(Name, TyThing)]
-> TcM ([TyCon], [[DerivInfo]]) -> TcM ([TyCon], [[DerivInfo]])
forall r. [(Name, TyThing)] -> TcM r -> TcM r
tcExtendRecEnv ([TyCon] -> [TyCon] -> [(Name, TyThing)]
zipRecTyClss [TyCon]
tc_tycons [TyCon]
rec_tyclss) (TcM ([TyCon], [[DerivInfo]]) -> TcM ([TyCon], [[DerivInfo]]))
-> TcM ([TyCon], [[DerivInfo]]) -> TcM ([TyCon], [[DerivInfo]])
forall a b. (a -> b) -> a -> b
$
[TyCon]
-> TcM ([TyCon], [[DerivInfo]]) -> TcM ([TyCon], [[DerivInfo]])
forall a. [TyCon] -> TcM a -> TcM a
tcExtendKindEnvWithTyCons [TyCon]
tc_tycons (TcM ([TyCon], [[DerivInfo]]) -> TcM ([TyCon], [[DerivInfo]]))
-> TcM ([TyCon], [[DerivInfo]]) -> TcM ([TyCon], [[DerivInfo]])
forall a b. (a -> b) -> a -> b
$
(GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo]))
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
-> TcM ([TyCon], [[DerivInfo]])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ((Name -> [Role])
-> LTyClDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
tcTyClDecl Name -> [Role]
roles) [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
[LTyClDecl GhcRn]
tyclds
; ([TyCon], [DerivInfo], NameSet)
-> TcM ([TyCon], [DerivInfo], NameSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyCon]
tycons, [[DerivInfo]] -> [DerivInfo]
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 [ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Name
tyConName TyCon
tc) SDoc -> SDoc -> SDoc
<> SDoc
comma
, [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [TyConBinder]
tyConBinders TyCon
tc) SDoc -> SDoc -> SDoc
<> SDoc
comma
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConResKind TyCon
tc)
, Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Bool
isTcTyCon TyCon
tc) ])
zipRecTyClss :: [TcTyCon]
-> [TyCon]
-> [(Name,TyThing)]
zipRecTyClss :: [TyCon] -> [TyCon] -> [(Name, TyThing)]
zipRecTyClss [TyCon]
tc_tycons [TyCon]
rec_tycons
= [ (Name
name, TyCon -> TyThing
ATyCon (Name -> TyCon
get Name
name)) | TyCon
tc_tycon <- [TyCon]
tc_tycons, let name :: Name
name = TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc_tycon ]
where
rec_tc_env :: NameEnv TyCon
rec_tc_env :: NameEnv TyCon
rec_tc_env = (TyCon -> NameEnv TyCon -> NameEnv TyCon)
-> NameEnv TyCon -> [TyCon] -> NameEnv TyCon
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyCon -> NameEnv TyCon -> NameEnv TyCon
add_tc NameEnv TyCon
forall a. NameEnv a
emptyNameEnv [TyCon]
rec_tycons
add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
add_tc TyCon
tc NameEnv TyCon
env = (TyCon -> NameEnv TyCon -> NameEnv TyCon)
-> NameEnv TyCon -> [TyCon] -> NameEnv TyCon
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TyCon -> NameEnv TyCon -> NameEnv TyCon
add_one_tc NameEnv TyCon
env (TyCon
tc TyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
: TyCon -> [TyCon]
tyConATs TyCon
tc)
add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
add_one_tc TyCon
tc NameEnv TyCon
env = NameEnv TyCon -> Name -> TyCon -> NameEnv TyCon
forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv NameEnv TyCon
env (TyCon -> Name
tyConName TyCon
tc) TyCon
tc
get :: Name -> TyCon
get Name
name = case NameEnv TyCon -> Name -> Maybe TyCon
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv TyCon
rec_tc_env Name
name of
Just TyCon
tc -> TyCon
tc
Maybe TyCon
other -> String -> SDoc -> TyCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"zipRecTyClss" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
<+> Maybe TyCon -> 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 <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; String -> SDoc -> TcRn ()
traceTc String
"---- kcTyClGroup ---- {"
(String -> SDoc
text String
"module" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat ((GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> SDoc)
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
[LTyClDecl GhcRn]
decls))
; Bool
cusks_enabled <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.CUSKs TcRnIf TcGblEnv TcLclEnv Bool
-> TcRnIf TcGblEnv TcLclEnv Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<&&> Extension -> TcRnIf TcGblEnv TcLclEnv 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) = (GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> Either
(GenLocated SrcSpanAnnA (TyClDecl GhcRn))
(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK))
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
-> ([GenLocated SrcSpanAnnA (TyClDecl GhcRn)],
[(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)])
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 [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
[LTyClDecl GhcRn]
decls
kindless_names :: NameSet
kindless_names = [Name] -> NameSet
mkNameSet ([Name] -> NameSet) -> [Name] -> NameSet
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> Name)
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> Name
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 = TyClDecl (GhcPass p) -> IdP (GhcPass p)
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName (GenLocated l (TyClDecl (GhcPass p)) -> TyClDecl (GhcPass p)
forall l e. GenLocated l e -> e
unLoc GenLocated l (TyClDecl (GhcPass p))
d)
get_kind :: GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> Either
(GenLocated SrcSpanAnnA (TyClDecl GhcRn))
(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
get_kind GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d
| Just Type
ki <- NameEnv Type -> Name -> Maybe Type
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv Type
kisig_env (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> IdGhcP 'Renamed
forall {p :: Pass} {l}.
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
GenLocated l (TyClDecl (GhcPass p)) -> IdGhcP p
get_name GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d)
= (GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
-> Either
(GenLocated SrcSpanAnnA (TyClDecl GhcRn))
(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
forall a b. b -> Either a b
Right (GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d, Type -> SAKS_or_CUSK
SAKS Type
ki)
| Bool
cusks_enabled Bool -> Bool -> Bool
&& TyClDecl GhcRn -> Bool
hsDeclHasCusk (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d)
= (GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
-> Either
(GenLocated SrcSpanAnnA (TyClDecl GhcRn))
(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
forall a b. b -> Either a b
Right (GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d, SAKS_or_CUSK
CUSK)
| Bool
otherwise = GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> Either
(GenLocated SrcSpanAnnA (TyClDecl GhcRn))
(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
forall a b. a -> Either a b
Left GenLocated SrcSpanAnnA (TyClDecl GhcRn)
d
; [TyCon]
checked_tcs <- IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall r. TcM r -> TcM r
checkNoErrs (IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon])
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall a b. (a -> b) -> a -> b
$
[(LTyClDecl GhcRn, SAKS_or_CUSK)]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
checkInitialKinds [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)]
[(LTyClDecl GhcRn, SAKS_or_CUSK)]
kinded_decls
; [TyCon]
inferred_tcs
<- [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall a. [TyCon] -> TcM a -> TcM a
tcExtendKindEnvWithTyCons [TyCon]
checked_tcs (IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon])
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall a b. (a -> b) -> a -> b
$
SkolemInfo
-> [TyVar]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall a. SkolemInfo -> [TyVar] -> TcM a -> TcM a
pushLevelAndSolveEqualities SkolemInfo
UnkSkol [] (IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon])
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall a b. (a -> b) -> a -> b
$
do {
[TyCon]
mono_tcs <- [LTyClDecl GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
inferInitialKinds [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
[LTyClDecl GhcRn]
kindless_decls
; String -> SDoc -> TcRn ()
traceTc String
"kcTyClGroup: initial kinds" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[TyCon] -> SDoc
ppr_tc_kinds [TyCon]
mono_tcs
; TcRn () -> TcRn ()
forall r. TcM r -> TcM r
checkNoErrs (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[TyCon] -> TcRn () -> TcRn ()
forall a. [TyCon] -> TcM a -> TcM a
tcExtendKindEnvWithTyCons [TyCon]
mono_tcs (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
(GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TcRn ())
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TcRn ()
LTyClDecl GhcRn -> TcRn ()
kcLTyClDecl [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
kindless_decls
; [TyCon] -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon]
mono_tcs }
; let inferred_tc_env :: NameEnv TyCon
inferred_tc_env = [(Name, TyCon)] -> NameEnv TyCon
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ([(Name, TyCon)] -> NameEnv TyCon)
-> [(Name, TyCon)] -> NameEnv TyCon
forall a b. (a -> b) -> a -> b
$
(TyCon -> (Name, TyCon)) -> [TyCon] -> [(Name, TyCon)]
forall a b. (a -> b) -> [a] -> [b]
map (\TyCon
tc -> (TyCon -> Name
tyConName TyCon
tc, TyCon
tc)) [TyCon]
inferred_tcs
; [TyCon]
generalized_tcs <- (GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon])
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (NameEnv TyCon
-> LTyClDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
generaliseTyClDecl NameEnv TyCon
inferred_tc_env)
[GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
kindless_decls
; let poly_tcs :: [TyCon]
poly_tcs = [TyCon]
checked_tcs [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ [TyCon]
generalized_tcs
; String -> SDoc -> TcRn ()
traceTc String
"---- kcTyClGroup end ---- }" ([TyCon] -> SDoc
ppr_tc_kinds [TyCon]
poly_tcs)
; ([TyCon], NameSet) -> TcM ([TyCon], NameSet)
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 ((TyCon -> SDoc) -> [TyCon] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map TyCon -> SDoc
pp_tc [TyCon]
tcs)
pp_tc :: TyCon -> SDoc
pp_tc TyCon
tc = Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Name
tyConName TyCon
tc) SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> 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 -> IOEnv (Env TcGblEnv TcLclEnv) [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 <- (Name -> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [(Name, TyVar)]))
-> [Name]
-> IOEnv (Env TcGblEnv TcLclEnv) [(TyCon, [(Name, TyVar)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [(Name, TyVar)])
skolemise_tc_tycon [Name]
names_in_this_decl
; [(TyCon, [(Name, TyVar)], Type)]
tc_infos <- ((TyCon, [(Name, TyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [(Name, TyVar)], Type))
-> [(TyCon, [(Name, TyVar)])]
-> IOEnv (Env TcGblEnv TcLclEnv) [(TyCon, [(Name, TyVar)], Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TyCon, [(Name, TyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [(Name, TyVar)], Type)
zonk_tc_tycon [(TyCon, [(Name, TyVar)])]
tc_with_tvs
; [(TyCon, [(Name, TyVar)], Type)]
swizzled_infos <- TyClDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) [(TyCon, [(Name, TyVar)], Type)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(TyCon, [(Name, TyVar)], Type)]
forall a. TyClDecl GhcRn -> TcM a -> TcM a
tcAddDeclCtxt TyClDecl GhcRn
decl ([(TyCon, [(Name, TyVar)], Type)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(TyCon, [(Name, TyVar)], Type)]
swizzleTcTyConBndrs [(TyCon, [(Name, TyVar)], Type)]
tc_infos)
; ((TyCon, [(Name, TyVar)], Type) -> TcRn TyCon)
-> [(TyCon, [(Name, TyVar)], Type)]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM (TyCon, [(Name, TyVar)], Type) -> TcRn TyCon
generaliseTcTyCon [(TyCon, [(Name, TyVar)], Type)]
swizzled_infos }
where
tycld_names :: TyClDecl GhcRn -> [Name]
tycld_names :: TyClDecl GhcRn -> [Name]
tycld_names TyClDecl GhcRn
decl = TyClDecl GhcRn -> IdP GhcRn
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
decl Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: TyClDecl GhcRn -> [Name]
at_names TyClDecl GhcRn
decl
at_names :: TyClDecl GhcRn -> [Name]
at_names :: TyClDecl GhcRn -> [Name]
at_names (ClassDecl { tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs = [LFamilyDecl GhcRn]
ats }) = (GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> Name)
-> [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (FamilyDecl GhcRn -> Name
forall (p :: Pass). FamilyDecl (GhcPass p) -> IdP (GhcPass p)
familyDeclName (FamilyDecl GhcRn -> Name)
-> (GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> FamilyDecl GhcRn)
-> GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> FamilyDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
[LFamilyDecl GhcRn]
ats
at_names TyClDecl GhcRn
_ = []
skolemise_tc_tycon :: Name -> TcM (TcTyCon, ScopedPairs)
skolemise_tc_tycon :: Name -> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [(Name, TyVar)])
skolemise_tc_tycon Name
tc_name
= do { let tc :: TyCon
tc = NameEnv TyCon -> Name -> TyCon
forall a. NameEnv a -> Name -> a
lookupNameEnv_NF NameEnv TyCon
inferred_tc_env Name
tc_name
; [(Name, TyVar)]
scoped_prs <- (TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [(Name, TyVar)] -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, TyVar)]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> [(a, b)] -> m [(a, c)]
mapSndM TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
zonkAndSkolemise (TyCon -> [(Name, TyVar)]
tcTyConScopedTyVars TyCon
tc)
; (TyCon, [(Name, TyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [(Name, TyVar)])
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)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [(Name, TyVar)], Type)
zonk_tc_tycon (TyCon
tc, [(Name, TyVar)]
scoped_prs)
= do { [(Name, TyVar)]
scoped_prs <- (TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [(Name, TyVar)] -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, TyVar)]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> [(a, b)] -> m [(a, c)]
mapSndM HasDebugCallStack => TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
zonkTcTyVarToTyVar [(Name, TyVar)]
scoped_prs
; Type
res_kind <- Type -> TcM Type
zonkTcType (TyCon -> Type
tyConResKind TyCon
tc)
; (TyCon, [(Name, TyVar)], Type)
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [(Name, TyVar)], Type)
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)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(TyCon, [(Name, TyVar)], Type)]
swizzleTcTyConBndrs [(TyCon, [(Name, TyVar)], Type)]
tc_infos
| ((Name, TyVar) -> Bool) -> [(Name, TyVar)] -> Bool
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" ([TyCon] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (((TyCon, [(Name, TyVar)], Type) -> TyCon)
-> [(TyCon, [(Name, TyVar)], Type)] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map (TyCon, [(Name, TyVar)], Type) -> TyCon
forall a b c. (a, b, c) -> a
fstOf3 [(TyCon, [(Name, TyVar)], Type)]
tc_infos))
; [(TyCon, [(Name, TyVar)], Type)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(TyCon, [(Name, TyVar)], Type)]
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" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"before" SDoc -> SDoc -> SDoc
<+> [(TyCon, [(Name, TyVar)], Type)] -> 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
<+> [(Name, TyVar)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, TyVar)]
swizzle_prs
, String -> SDoc
text String
"after" SDoc -> SDoc -> SDoc
<+> [(TyCon, [(Name, TyVar)], Type)] -> SDoc
forall {a} {a} {c}. Outputable a => [(a, [(a, TyVar)], c)] -> SDoc
ppr_infos [(TyCon, [(Name, TyVar)], Type)]
swizzled_infos ]
; [(TyCon, [(Name, TyVar)], Type)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(TyCon, [(Name, TyVar)], Type)]
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, (TyVar -> TyVar) -> [(Name, TyVar)] -> [(Name, TyVar)]
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 Name -> Name -> Bool
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 [ a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
tc SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars (((a, TyVar) -> TyVar) -> [(a, TyVar)] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
map (a, TyVar) -> TyVar
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 = Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Name, Name)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, Name)]
err_prs) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do { ((Name, Name) -> TcRn ()) -> [(Name, Name)] -> TcRn ()
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; TcRn ()
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 <- ((Name, TyVar) -> (Name, TyVar) -> Bool)
-> [(Name, TyVar)] -> [NonEmpty (Name, TyVar)]
forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
findDupsEq (TyVar -> TyVar -> Bool
forall a. Eq a => a -> a -> Bool
(==) (TyVar -> TyVar -> Bool)
-> ((Name, TyVar) -> TyVar)
-> (Name, TyVar)
-> (Name, TyVar)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Name, TyVar) -> TyVar
forall a b. (a, b) -> b
snd) [(Name, TyVar)]
swizzle_prs
, (Name
n1,TyVar
_):(Name
n2,TyVar
_):[(Name, TyVar)]
_ <- [((Name, TyVar) -> (Name, TyVar) -> Bool)
-> [(Name, TyVar)] -> [(Name, TyVar)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Name -> Name -> Bool)
-> ((Name, TyVar) -> Name)
-> (Name, TyVar)
-> (Name, TyVar)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Name, TyVar) -> Name
forall a b. (a, b) -> a
fst) ((Name, TyVar)
pr(Name, TyVar) -> [(Name, TyVar)] -> [(Name, TyVar)]
forall a. a -> [a] -> [a]
:[(Name, TyVar)]
prs)] ]
report_dup :: (Name,Name) -> TcM ()
report_dup :: (Name, Name) -> TcRn ()
report_dup (Name
n1,Name
n2)
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
n2) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ SDoc -> TcRn ()
addErrTc (SDoc -> TcRn ()) -> SDoc -> TcRn ()
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 OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> OccName
nameOccName Name
n2
= SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n1) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"and" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n2)
| Bool
otherwise
= [SDoc] -> SDoc
vcat [ SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n1) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"bound at" SDoc -> SDoc -> SDoc
<+> SrcLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Name -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc Name
n1)
, SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n2) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"bound at" SDoc -> SDoc -> SDoc
<+> SrcLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Name -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc Name
n2) ]
swizzle_env :: VarEnv Name
swizzle_env = [(TyVar, Name)] -> VarEnv Name
forall a. [(TyVar, a)] -> VarEnv a
mkVarEnv (((Name, TyVar) -> (TyVar, Name))
-> [(Name, TyVar)] -> [(TyVar, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (Name, TyVar) -> (TyVar, Name)
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 = () -> TyVar -> Identity Type
forall {m :: * -> *} {p}. Monad m => p -> TyVar -> m Type
swizzle_tv
, tcm_covar :: () -> TyVar -> Identity Coercion
tcm_covar = () -> TyVar -> Identity Coercion
forall {m :: * -> *} {p}. Monad m => p -> TyVar -> m Coercion
swizzle_cv
, tcm_hole :: () -> CoercionHole -> Identity Coercion
tcm_hole = () -> CoercionHole -> Identity Coercion
forall {a} {p} {a}. Outputable a => p -> a -> a
swizzle_hole
, tcm_tycobinder :: () -> TyVar -> ArgFlag -> Identity ((), TyVar)
tcm_tycobinder = () -> TyVar -> ArgFlag -> Identity ((), TyVar)
forall {m :: * -> *} {p} {p}.
Monad m =>
p -> TyVar -> p -> m ((), TyVar)
swizzle_bndr
, tcm_tycon :: TyCon -> Identity TyCon
tcm_tycon = TyCon -> Identity TyCon
forall {a} {a}. Outputable a => a -> a
swizzle_tycon }
swizzle_hole :: p -> a -> a
swizzle_hole p
_ a
hole = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"swizzle_hole" (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
hole)
swizzle_tycon :: a -> a
swizzle_tycon a
tc = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"swizzle_tc" (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
tc)
swizzle_tv :: p -> TyVar -> m Type
swizzle_tv p
_ TyVar
tv = Type -> m Type
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 = Coercion -> m Coercion
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
_
= ((), TyVar) -> m ((), TyVar)
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 <- VarEnv Name -> TyVar -> Maybe Name
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]
_) = TyCoMapper () Identity
-> (Type -> Identity 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 = Identity Type -> Type
forall a. Identity a -> a
runIdentity (Type -> Identity Type
map_type Type
ty)
generaliseTcTyCon :: (TcTyCon, ScopedPairs, TcKind) -> TcM TcTyCon
generaliseTcTyCon :: (TyCon, [(Name, TyVar)], Type) -> TcRn TyCon
generaliseTcTyCon (TyCon
tc, [(Name, TyVar)]
scoped_prs, Type
tc_res_kind)
= SrcSpan -> TcRn TyCon -> TcRn TyCon
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (TyCon -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyCon
tc) (TcRn TyCon -> TcRn TyCon) -> TcRn TyCon -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$
TyCon -> TcRn TyCon -> TcRn TyCon
forall a. TyCon -> TcM a -> TcM a
addTyConCtxt TyCon
tc (TcRn TyCon -> TcRn TyCon) -> TcRn TyCon -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$
do {
; let spec_req_tvs :: [TyVar]
spec_req_tvs = ((Name, TyVar) -> TyVar) -> [(Name, TyVar)] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
map (Name, TyVar) -> TyVar
forall a b. (a, b) -> b
snd [(Name, TyVar)]
scoped_prs
n_spec :: Arity
n_spec = [TyVar] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [TyVar]
spec_req_tvs Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- TyCon -> Arity
tyConArity TyCon
tc
([TyVar]
spec_tvs, [TyVar]
req_tvs) = Arity -> [TyVar] -> ([TyVar], [TyVar])
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 ([Type] -> TcM CandidatesQTvs) -> [Type] -> TcM CandidatesQTvs
forall a b. (a -> b) -> a -> b
$
(Type
tc_res_kind Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: (TyVar -> Type) -> [TyVar] -> [Type]
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
<+> TyCon -> 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
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
tc_res_kind
, String -> SDoc
text String
"dvs1 =" SDoc -> SDoc -> SDoc
<+> CandidatesQTvs -> 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" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"tycon =" SDoc -> SDoc -> SDoc
<+> TyCon -> 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
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
req_tvs
, String -> SDoc
text String
"zonk-env =" SDoc -> SDoc -> SDoc
<+> ZonkEnv -> 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 = (TyVar -> TyConBinder) -> [TyVar] -> [TyConBinder]
forall a b. (a -> b) -> [a] -> [b]
map (VarSet -> TyVar -> TyConBinder
mkRequiredTyConBinder VarSet
dep_fv_set) [TyVar]
req_tvs
final_tcbs :: [TyConBinder]
final_tcbs = [[TyConBinder]] -> [TyConBinder]
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 [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
req_tvs))
Bool
True
(TyCon -> TyConFlavour
tyConFlavour TyCon
tc)
; String -> SDoc -> TcRn ()
traceTc String
"generaliseTcTyCon done" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"tycon =" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc
, String -> SDoc
text String
"tc_res_kind =" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
tc_res_kind
, String -> SDoc
text String
"dep_fv_set =" SDoc -> SDoc -> SDoc
<+> VarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarSet
dep_fv_set
, String -> SDoc
text String
"inferred_tcbs =" SDoc -> SDoc -> SDoc
<+> [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
inferred_tcbs
, String -> SDoc
text String
"specified_tcbs =" SDoc -> SDoc -> SDoc
<+> [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
specified_tcbs
, String -> SDoc
text String
"required_tcbs =" SDoc -> SDoc -> SDoc
<+> [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
required_tcbs
, String -> SDoc
text String
"final_tcbs =" SDoc -> SDoc -> SDoc
<+> [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
final_tcbs ]
; TyCon -> TcRn ()
checkTyConTelescope TyCon
tycon
; TyCon -> TcRn 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
= [(Name, TcTyThing)] -> TcM a -> TcM a
forall r. [(Name, TcTyThing)] -> TcM r -> TcM r
tcExtendKindEnvList [ (TyCon -> Name
tyConName TyCon
tc, TyCon -> TcTyThing
ATcTyCon TyCon
tc) | TyCon
tc <- [TyCon]
tcs ]
mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv
mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv
mkPromotionErrorEnv [LTyClDecl GhcRn]
decls
= (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TcTypeEnv -> TcTypeEnv)
-> TcTypeEnv
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
-> TcTypeEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TcTypeEnv -> TcTypeEnv -> TcTypeEnv
forall a. NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv (TcTypeEnv -> TcTypeEnv -> TcTypeEnv)
-> (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TcTypeEnv)
-> GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> TcTypeEnv
-> TcTypeEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyClDecl GhcRn -> TcTypeEnv
mk_prom_err_env (TyClDecl GhcRn -> TcTypeEnv)
-> (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn)
-> GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> TcTypeEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn
forall l e. GenLocated l e -> e
unLoc)
TcTypeEnv
forall a. NameEnv a
emptyNameEnv [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
[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 })
= Name -> TcTyThing -> TcTypeEnv
forall a. Name -> a -> NameEnv a
unitNameEnv Name
nm (PromotionErr -> TcTyThing
APromotionErr PromotionErr
ClassPE)
TcTypeEnv -> TcTypeEnv -> TcTypeEnv
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv`
[(Name, TcTyThing)] -> TcTypeEnv
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (FamilyDecl GhcRn -> IdP GhcRn
forall (p :: Pass). FamilyDecl (GhcPass p) -> IdP (GhcPass p)
familyDeclName FamilyDecl GhcRn
at, PromotionErr -> TcTyThing
APromotionErr PromotionErr
TyConPE)
| L SrcSpanAnnA
_ FamilyDecl GhcRn
at <- [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
[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 } })
= Name -> TcTyThing -> TcTypeEnv
forall a. Name -> a -> NameEnv a
unitNameEnv Name
name (PromotionErr -> TcTyThing
APromotionErr PromotionErr
TyConPE)
TcTypeEnv -> TcTypeEnv -> TcTypeEnv
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv`
[(Name, TcTyThing)] -> TcTypeEnv
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (Name
con, PromotionErr -> TcTyThing
APromotionErr PromotionErr
RecDataConPE)
| L SrcSpanAnnA
_ ConDecl GhcRn
con' <- [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
[LConDecl GhcRn]
cons
, L SrcSpanAnnN
_ Name
con <- ConDecl GhcRn -> [GenLocated SrcSpanAnnN Name]
getConNames ConDecl GhcRn
con' ]
mk_prom_err_env TyClDecl GhcRn
decl
= Name -> TcTyThing -> TcTypeEnv
forall a. Name -> a -> NameEnv a
unitNameEnv (TyClDecl GhcRn -> IdP GhcRn
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
decl) (PromotionErr -> TcTyThing
APromotionErr PromotionErr
TyConPE)
inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
inferInitialKinds :: [LTyClDecl GhcRn] -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
inferInitialKinds [LTyClDecl GhcRn]
decls
= do { String -> SDoc -> TcRn ()
traceTc String
"inferInitialKinds {" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [IdGhcP 'Renamed] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> IdGhcP 'Renamed)
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)] -> [IdGhcP 'Renamed]
forall a b. (a -> b) -> [a] -> [b]
map (TyClDecl GhcRn -> IdGhcP 'Renamed
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName (TyClDecl GhcRn -> IdGhcP 'Renamed)
-> (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn)
-> GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> IdGhcP 'Renamed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
[LTyClDecl GhcRn]
decls)
; [TyCon]
tcs <- (GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon])
-> [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall {ann}.
GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
infer_initial_kind [GenLocated SrcSpanAnnA (TyClDecl GhcRn)]
[LTyClDecl GhcRn]
decls
; String -> SDoc -> TcRn ()
traceTc String
"inferInitialKinds done }" SDoc
empty
; [TyCon] -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon]
tcs }
where
infer_initial_kind :: GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
infer_initial_kind = (TyClDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon])
-> GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA (InitialKindStrategy
-> TyClDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
getInitialKind InitialKindStrategy
InitialKindInfer)
checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon]
checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
checkInitialKinds [(LTyClDecl GhcRn, SAKS_or_CUSK)]
decls
= do { String -> SDoc -> TcRn ()
traceTc String
"checkInitialKinds {" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [(IdGhcP 'Renamed, SAKS_or_CUSK)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> IdGhcP 'Renamed)
-> [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)]
-> [(IdGhcP 'Renamed, SAKS_or_CUSK)]
forall a c b. (a -> c) -> [(a, b)] -> [(c, b)]
mapFst (TyClDecl GhcRn -> IdGhcP 'Renamed
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName (TyClDecl GhcRn -> IdGhcP 'Renamed)
-> (GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn)
-> GenLocated SrcSpanAnnA (TyClDecl GhcRn)
-> IdGhcP 'Renamed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (TyClDecl GhcRn) -> TyClDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)]
[(LTyClDecl GhcRn, SAKS_or_CUSK)]
decls)
; [TyCon]
tcs <- ((GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon])
-> [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall {ann}.
(GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn), SAKS_or_CUSK)
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
check_initial_kind [(GenLocated SrcSpanAnnA (TyClDecl GhcRn), SAKS_or_CUSK)]
[(LTyClDecl GhcRn, SAKS_or_CUSK)]
decls
; String -> SDoc -> TcRn ()
traceTc String
"checkInitialKinds done }" SDoc
empty
; [TyCon] -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon]
tcs }
where
check_initial_kind :: (GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn), SAKS_or_CUSK)
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
check_initial_kind (GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn)
ldecl, SAKS_or_CUSK
msig) =
(TyClDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon])
-> GenLocated (SrcSpanAnn' ann) (TyClDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA (InitialKindStrategy
-> TyClDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) [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 -> IOEnv (Env TcGblEnv TcLclEnv) [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
-> TcRn TyCon
kcDeclHeader InitialKindStrategy
strategy Name
name TyConFlavour
ClassFlavour LHsQTyVars GhcRn
ktvs (TcM ContextKind -> TcRn TyCon) -> TcM ContextKind -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$
ContextKind -> TcM ContextKind
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 <-
[(Name, TyVar)]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, TyVar)]
parent_tv_prs (IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon])
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall a b. (a -> b) -> a -> b
$
(GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> TcRn TyCon)
-> [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((FamilyDecl GhcRn -> TcRn TyCon)
-> GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> TcRn TyCon
forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA (TyCon -> FamilyDecl GhcRn -> TcRn TyCon
getAssocFamInitialKind TyCon
cls)) [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
[LFamilyDecl GhcRn]
ats
; [TyCon] -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
cls TyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
: [TyCon]
inner_tcs) }
where
getAssocFamInitialKind :: TyCon -> FamilyDecl GhcRn -> TcRn TyCon
getAssocFamInitialKind TyCon
cls =
case InitialKindStrategy
strategy of
InitialKindStrategy
InitialKindInfer -> Maybe TyCon -> FamilyDecl GhcRn -> TcRn TyCon
get_fam_decl_initial_kind (TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
cls)
InitialKindCheck SAKS_or_CUSK
_ -> TyCon -> FamilyDecl GhcRn -> TcRn TyCon
check_initial_kind_assoc_fam TyCon
cls
getInitialKind InitialKindStrategy
strategy
(DataDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
name
, tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars = LHsQTyVars GhcRn
ktvs
, tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn { dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (LHsKind GhcRn)
m_sig
, dd_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
-> TcRn TyCon
kcDeclHeader InitialKindStrategy
strategy Name
name TyConFlavour
flav LHsQTyVars GhcRn
ktvs (TcM ContextKind -> TcRn TyCon) -> TcM ContextKind -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$
case Maybe (LHsKind GhcRn)
m_sig of
Just LHsKind GhcRn
ksig -> Type -> ContextKind
TheKind (Type -> ContextKind) -> TcM Type -> TcM ContextKind
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 -> ContextKind -> TcM ContextKind
forall (m :: * -> *) a. Monad m => a -> m a
return (ContextKind -> TcM ContextKind) -> ContextKind -> TcM ContextKind
forall a b. (a -> b) -> a -> b
$ InitialKindStrategy -> NewOrData -> ContextKind
dataDeclDefaultResultKind InitialKindStrategy
strategy NewOrData
new_or_data
; [TyCon] -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
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 -> TcRn TyCon
get_fam_decl_initial_kind Maybe TyCon
forall a. Maybe a
Nothing FamilyDecl GhcRn
decl
; [TyCon] -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
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 = LIdP GhcRn -> Name
forall l e. GenLocated l e -> e
unLoc -> Name
name
, fdTyVars :: forall pass. FamilyDecl pass -> LHsQTyVars pass
fdTyVars = LHsQTyVars GhcRn
ktvs
, fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdResultSig = LFamilyResultSig GhcRn -> FamilyResultSig GhcRn
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 = Maybe TyCon -> FamilyInfo GhcRn -> TyConFlavour
forall pass. Maybe TyCon -> FamilyInfo pass -> TyConFlavour
getFamFlav Maybe TyCon
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
-> TcRn TyCon
kcDeclHeader (SAKS_or_CUSK -> InitialKindStrategy
InitialKindCheck SAKS_or_CUSK
msig) Name
name TyConFlavour
flav LHsQTyVars GhcRn
ktvs (TcM ContextKind -> TcRn TyCon) -> TcM ContextKind -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$
case FamilyResultSig GhcRn -> Maybe (LHsKind GhcRn)
forall (p :: Pass).
FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p))
famResultKindSignature FamilyResultSig GhcRn
resultSig of
Just LHsKind GhcRn
ksig -> Type -> ContextKind
TheKind (Type -> ContextKind) -> TcM Type -> TcM ContextKind
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 -> ContextKind -> TcM ContextKind
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> ContextKind
TheKind Type
liftedTypeKind)
SAKS Type
_ -> ContextKind -> TcM ContextKind
forall (m :: * -> *) a. Monad m => a -> m a
return ContextKind
AnyKind
; [TyCon] -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
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
-> TcRn TyCon
kcDeclHeader InitialKindStrategy
strategy Name
name TyConFlavour
TypeSynonymFlavour LHsQTyVars GhcRn
ktvs (TcM ContextKind -> TcRn TyCon) -> TcM ContextKind -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$
case LHsKind GhcRn -> Maybe (LHsKind GhcRn)
forall (p :: Pass).
LHsType (GhcPass p) -> Maybe (LHsType (GhcPass p))
hsTyKindSig LHsKind GhcRn
rhs of
Just LHsKind GhcRn
rhs_sig -> Type -> ContextKind
TheKind (Type -> ContextKind) -> TcM Type -> TcM ContextKind
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 -> ContextKind -> TcM ContextKind
forall (m :: * -> *) a. Monad m => a -> m a
return ContextKind
AnyKind
; [TyCon] -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
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 -> TcRn TyCon
get_fam_decl_initial_kind Maybe TyCon
mb_parent_tycon
FamilyDecl { fdLName :: forall pass. FamilyDecl pass -> LIdP pass
fdLName = L SrcSpanAnnN
_ Name
name
, fdTyVars :: forall pass. FamilyDecl pass -> LHsQTyVars pass
fdTyVars = LHsQTyVars GhcRn
ktvs
, fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdResultSig = L SrcSpan
_ FamilyResultSig GhcRn
resultSig
, fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcRn
info }
= InitialKindStrategy
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcRn TyCon
kcDeclHeader InitialKindStrategy
InitialKindInfer Name
name TyConFlavour
flav LHsQTyVars GhcRn
ktvs (TcM ContextKind -> TcRn TyCon) -> TcM ContextKind -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$
case FamilyResultSig GhcRn
resultSig of
KindSig XCKindSig GhcRn
_ LHsKind GhcRn
ki -> Type -> ContextKind
TheKind (Type -> ContextKind) -> TcM Type -> TcM ContextKind
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 (Type -> ContextKind) -> TcM Type -> TcM ContextKind
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 -> ContextKind -> TcM ContextKind
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> ContextKind
TheKind Type
liftedTypeKind)
| Bool
otherwise -> ContextKind -> TcM ContextKind
forall (m :: * -> *) a. Monad m => a -> m a
return ContextKind
AnyKind
where
flav :: TyConFlavour
flav = Maybe TyCon -> FamilyInfo GhcRn -> TyConFlavour
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 -> TcRn TyCon
check_initial_kind_assoc_fam TyCon
cls
FamilyDecl
{ fdLName :: forall pass. FamilyDecl pass -> LIdP pass
fdLName = LIdP GhcRn -> Name
forall l e. GenLocated l e -> e
unLoc -> Name
name
, fdTyVars :: forall pass. FamilyDecl pass -> LHsQTyVars pass
fdTyVars = LHsQTyVars GhcRn
ktvs
, fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdResultSig = LFamilyResultSig GhcRn -> FamilyResultSig GhcRn
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
-> TcRn TyCon
kcDeclHeader (SAKS_or_CUSK -> InitialKindStrategy
InitialKindCheck SAKS_or_CUSK
CUSK) Name
name TyConFlavour
flav LHsQTyVars GhcRn
ktvs (TcM ContextKind -> TcRn TyCon) -> TcM ContextKind -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$
case FamilyResultSig GhcRn -> Maybe (LHsKind GhcRn)
forall (p :: Pass).
FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p))
famResultKindSignature FamilyResultSig GhcRn
resultSig of
Just LHsKind GhcRn
ksig -> Type -> ContextKind
TheKind (Type -> ContextKind) -> TcM Type -> TcM ContextKind
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 -> ContextKind -> TcM ContextKind
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 = Maybe TyCon -> FamilyInfo GhcRn -> TyConFlavour
forall pass. Maybe TyCon -> FamilyInfo pass -> TyConFlavour
getFamFlav (TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
cls) FamilyInfo GhcRn
info
dataDeclDefaultResultKind :: InitialKindStrategy -> NewOrData -> ContextKind
dataDeclDefaultResultKind :: InitialKindStrategy -> NewOrData -> ContextKind
dataDeclDefaultResultKind InitialKindStrategy
strategy NewOrData
new_or_data
| NewOrData
NewType <- NewOrData
new_or_data
= ContextKind
OpenKind
| NewOrData
DataType <- NewOrData
new_or_data
, InitialKindCheck (SAKS Type
_) <- InitialKindStrategy
strategy
= ContextKind
OpenKind
| Bool
otherwise
= Type -> ContextKind
TheKind Type
liftedTypeKind
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)
= SrcSpanAnnA -> TcRn () -> TcRn ()
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do { TyCon
tycon <- HasDebugCallStack => Name -> TcRn TyCon
Name -> TcRn TyCon
tcLookupTcTyCon Name
IdP GhcRn
tc_name
; String -> SDoc -> TcRn ()
traceTc String
"kcTyClDecl {" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
IdP GhcRn
tc_name)
; TyCon -> TcRn () -> TcRn ()
forall a. TyCon -> TcM a -> TcM a
addVDQNote TyCon
tycon (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn () -> TcRn ()
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (TyClDecl GhcRn -> SDoc
tcMkDeclCtxt TyClDecl GhcRn
decl) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TyClDecl GhcRn -> TyCon -> TcRn ()
kcTyClDecl TyClDecl GhcRn
decl TyCon
tycon
; String -> SDoc -> TcRn ()
traceTc String
"kcTyClDecl done }" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
IdP GhcRn
tc_name) }
where
tc_name :: IdP GhcRn
tc_name = TyClDecl GhcRn -> IdP GhcRn
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
decl
kcTyClDecl :: TyClDecl GhcRn -> 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
= Name -> (TyCon -> [TyConBinder] -> Type -> TcRn ()) -> TcRn ()
forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
name ((TyCon -> [TyConBinder] -> Type -> TcRn ()) -> TcRn ())
-> (TyCon -> [TyConBinder] -> Type -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
_ Type
_ ->
do { String -> SDoc -> TcRn ()
traceTc String
"kcTyClDecl" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tycon SDoc -> SDoc -> SDoc
$$ [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [TyVar]
tyConTyVars TyCon
tycon) SDoc -> SDoc -> SDoc
$$ Type -> 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
= Name -> (TyCon -> [TyConBinder] -> Type -> TcRn ()) -> TcRn ()
forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
name ((TyCon -> [TyConBinder] -> Type -> TcRn ()) -> TcRn ())
-> (TyCon -> [TyConBinder] -> Type -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
_ Type
res_kind ->
TcM Type -> TcRn ()
forall a. TcM a -> TcRn ()
discardResult (TcM Type -> TcRn ()) -> TcM Type -> TcRn ()
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
= Name -> (TyCon -> [TyConBinder] -> Type -> TcRn ()) -> TcRn ()
forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
name ((TyCon -> [TyConBinder] -> Type -> TcRn ()) -> TcRn ())
-> (TyCon -> [TyConBinder] -> Type -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
_ Type
_ ->
do { [Type]
_ <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
ctxt
; (LocatedA (Sig GhcRn) -> TcRn ())
-> [LocatedA (Sig GhcRn)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Sig GhcRn -> TcRn ()) -> LocatedA (Sig GhcRn) -> TcRn ()
forall a. (a -> TcRn ()) -> LocatedA a -> TcRn ()
wrapLocMA_ Sig GhcRn -> TcRn ()
kc_sig) [LocatedA (Sig GhcRn)]
[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 [GenLocated SrcSpanAnnN Name]
[LIdP GhcRn]
nms LHsSigType GhcRn
op_ty
kc_sig Sig GhcRn
_ = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
kcTyClDecl (FamDecl XFamDecl GhcRn
_ (FamilyDecl { fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcRn
fd_info })) TyCon
fam_tc
= case FamilyInfo GhcRn
fd_info of
ClosedTypeFamily (Just [LTyFamInstEqn GhcRn]
eqns) -> (GenLocated
SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> TcRn ())
-> [GenLocated
SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
-> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TyCon -> LTyFamInstEqn GhcRn -> TcRn ()
kcTyFamInstEqn TyCon
fam_tc) [GenLocated
SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
[LTyFamInstEqn GhcRn]
eqns
FamilyInfo GhcRn
_ -> () -> TcRn ()
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
; [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
-> (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> TcM Type)
-> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
[HsScaled GhcRn (LHsKind GhcRn)]
arg_tys (\(HsScaled HsArrow GhcRn
mult GenLocated SrcSpanAnnA (HsType GhcRn)
ty) -> do Type
_ <- LHsKind GhcRn -> ContextKind -> TcM Type
tcCheckLHsType (LHsKind GhcRn -> LHsKind GhcRn
forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p)
getBangType GenLocated SrcSpanAnnA (HsType GhcRn)
LHsKind 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 ([HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ())
-> [HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ()
forall a b. (a -> b) -> a -> b
$
(GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall a pass. a -> HsScaled pass a
hsLinear (GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConDeclField GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall pass. ConDeclField pass -> LBangType pass
cd_fld_type (ConDeclField GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDeclField GhcRn) -> ConDeclField GhcRn
forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
flds
kcConGADTArgs :: NewOrData -> 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 ([HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ())
-> [HsScaled GhcRn (LHsKind GhcRn)] -> TcRn ()
forall a b. (a -> b) -> a -> b
$
(GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
forall a b. (a -> b) -> [a] -> [b]
map (GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall a pass. a -> HsScaled pass a
hsLinear (GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConDeclField GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall pass. ConDeclField pass -> LBangType pass
cd_fld_type (ConDeclField GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn))
-> (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDeclField GhcRn) -> ConDeclField GhcRn
forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
flds
kcConDecls :: NewOrData
-> Kind
-> [LConDecl GhcRn]
-> TcM ()
kcConDecls :: NewOrData -> Type -> [LConDecl GhcRn] -> TcRn ()
kcConDecls NewOrData
new_or_data Type
tc_res_kind [LConDecl GhcRn]
cons
= (GenLocated SrcSpanAnnA (ConDecl GhcRn) -> TcRn ())
-> [GenLocated SrcSpanAnnA (ConDecl GhcRn)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((ConDecl GhcRn -> TcRn ())
-> GenLocated SrcSpanAnnA (ConDecl GhcRn) -> TcRn ()
forall a. (a -> TcRn ()) -> LocatedA a -> TcRn ()
wrapLocMA_ (NewOrData -> Type -> ConDecl GhcRn -> TcRn ()
kcConDecl NewOrData
new_or_data Type
tc_res_kind)) [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
[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 })
= SDoc -> TcRn () -> TcRn ()
forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([GenLocated SrcSpanAnnN Name] -> SDoc
dataConCtxt [GenLocated SrcSpanAnnN Name
LIdP GhcRn
name]) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcM ([VarBndr TyVar Specificity], ()) -> TcRn ()
forall a. TcM a -> TcRn ()
discardResult (TcM ([VarBndr TyVar Specificity], ()) -> TcRn ())
-> TcM ([VarBndr TyVar Specificity], ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[LHsTyVarBndr Specificity GhcRn]
-> TcRn () -> TcM ([VarBndr TyVar Specificity], ())
forall flag a.
OutputableBndrFlag flag 'Renamed =>
[LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrs_Tv [LHsTyVarBndr Specificity GhcRn]
ex_tvs (TcRn () -> TcM ([VarBndr TyVar Specificity], ()))
-> TcRn () -> TcM ([VarBndr TyVar Specificity], ())
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 })
=
SDoc -> TcRn () -> TcRn ()
forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([GenLocated SrcSpanAnnN Name] -> SDoc
dataConCtxt [GenLocated SrcSpanAnnN Name]
[LIdP GhcRn]
names) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcM (HsOuterSigTyVarBndrs GhcTc, ()) -> TcRn ()
forall a. TcM a -> TcRn ()
discardResult (TcM (HsOuterSigTyVarBndrs GhcTc, ()) -> TcRn ())
-> TcM (HsOuterSigTyVarBndrs GhcTc, ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$
HsOuterSigTyVarBndrs GhcRn
-> TcRn () -> TcM (HsOuterSigTyVarBndrs GhcTc, ())
forall a.
HsOuterSigTyVarBndrs GhcRn
-> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)
bindOuterSigTKBndrs_Tv HsOuterSigTyVarBndrs GhcRn
outer_bndrs (TcRn () -> TcM (HsOuterSigTyVarBndrs GhcTc, ()))
-> TcRn () -> TcM (HsOuterSigTyVarBndrs GhcTc, ())
forall a b. (a -> b) -> a -> b
$
do { [Type]
_ <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
cxt
; String -> SDoc -> TcRn ()
traceTc String
"kcConDecl:GADT {" ([GenLocated SrcSpanAnnN Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnN Name]
[LIdP GhcRn]
names SDoc -> SDoc -> SDoc
$$ GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsType GhcRn)
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 }" ([GenLocated SrcSpanAnnN Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnN Name]
[LIdP GhcRn]
names SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
con_res_kind)
; () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo])
tcTyClDecl :: (Name -> [Role])
-> LTyClDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
tcTyClDecl Name -> [Role]
roles_info (L SrcSpanAnnA
loc TyClDecl GhcRn
decl)
| Just TyThing
thing <- Name -> Maybe TyThing
wiredInNameTyThing_maybe (TyClDecl GhcRn -> IdP GhcRn
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
decl)
= case TyThing
thing of
ATyCon TyCon
tc -> (TyCon, [DerivInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
tc, TyCon -> TyClDecl GhcRn -> [DerivInfo]
wiredInDerivInfo TyCon
tc TyClDecl GhcRn
decl)
TyThing
_ -> String
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcTyClDecl" (TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
thing)
| Bool
otherwise
= SrcSpanAnnA
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
forall a b. (a -> b) -> a -> b
$ TyClDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
forall a. TyClDecl GhcRn -> TcM a -> TcM a
tcAddDeclCtxt TyClDecl GhcRn
decl (IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"---- tcTyClDecl ---- {" (TyClDecl GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyClDecl GhcRn
decl)
; (TyCon
tc, [DerivInfo]
deriv_infos) <- Maybe Class
-> (Name -> [Role])
-> TyClDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
tcTyClDecl1 Maybe Class
forall a. Maybe a
Nothing Name -> [Role]
roles_info TyClDecl GhcRn
decl
; String -> SDoc -> TcRn ()
traceTc String
"---- tcTyClDecl end ---- }" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; (TyCon, [DerivInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
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
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
tcTyClDecl1 Maybe Class
parent Name -> [Role]
_roles_info (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl GhcRn
fd })
= (TyCon -> (TyCon, [DerivInfo]))
-> TcRn TyCon -> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyCon -> (TyCon, [DerivInfo])
forall a. a -> (a, [DerivInfo])
noDerivInfos (TcRn TyCon -> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo]))
-> TcRn TyCon -> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
forall a b. (a -> b) -> a -> b
$
Maybe Class -> FamilyDecl GhcRn -> TcRn 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 )
(TyCon -> (TyCon, [DerivInfo]))
-> TcRn TyCon -> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyCon -> (TyCon, [DerivInfo])
forall a. a -> (a, [DerivInfo])
noDerivInfos (TcRn TyCon -> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo]))
-> TcRn TyCon -> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
forall a b. (a -> b) -> a -> b
$
(Name -> [Role]) -> Name -> LHsKind GhcRn -> TcRn TyCon
tcTySynRhs Name -> [Role]
roles_info Name
tc_name LHsKind GhcRn
rhs
tcTyClDecl1 Maybe Class
_parent Name -> [Role]
roles_info
decl :: TyClDecl GhcRn
decl@(DataDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
tc_name
, tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn GhcRn
defn })
= ASSERT( isNothing _parent )
SDoc
-> (Name -> [Role])
-> Name
-> HsDataDefn GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
tcDataDefn (TyClDecl GhcRn -> SDoc
tcMkDeclCtxt TyClDecl GhcRn
decl) Name -> [Role]
roles_info Name
tc_name HsDataDefn GhcRn
defn
tcTyClDecl1 Maybe Class
_parent Name -> [Role]
roles_info
(ClassDecl { tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName = L SrcSpanAnnN
_ Name
class_name
, tcdCtxt :: forall pass. TyClDecl pass -> Maybe (LHsContext pass)
tcdCtxt = Maybe (LHsContext GhcRn)
hs_ctxt
, tcdMeths :: forall pass. TyClDecl pass -> LHsBinds pass
tcdMeths = LHsBinds GhcRn
meths
, tcdFDs :: forall pass. TyClDecl pass -> [LHsFunDep pass]
tcdFDs = [LHsFunDep GhcRn]
fundeps
, tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
tcdSigs = [LSig GhcRn]
sigs
, tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs = [LFamilyDecl GhcRn]
ats
, tcdATDefs :: forall pass. TyClDecl pass -> [LTyFamDefltDecl pass]
tcdATDefs = [LTyFamDefltDecl GhcRn]
at_defs })
= 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
; (TyCon, [DerivInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> (TyCon, [DerivInfo])
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
= (Class -> TcM Class) -> TcM Class
forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM ((Class -> TcM Class) -> TcM Class)
-> (Class -> TcM Class) -> TcM Class
forall a b. (a -> b) -> a -> b
$ \ Class
clas ->
Name -> (TyCon -> [TyConBinder] -> Type -> TcM Class) -> TcM Class
forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
class_name ((TyCon -> [TyConBinder] -> Type -> TcM Class) -> TcM Class)
-> (TyCon -> [TyConBinder] -> Type -> TcM Class) -> TcM Class
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" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
class_name SDoc -> SDoc -> SDoc
$$ [TyConBinder] -> 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)
<- SkolemInfo
-> [TyVar]
-> TcM ([Type], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
-> TcM ([Type], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
forall a. SkolemInfo -> [TyVar] -> TcM a -> TcM a
pushLevelAndSolveEqualities SkolemInfo
skol_info ([TyConBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
binders) (TcM ([Type], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
-> TcM ([Type], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem]))
-> TcM ([Type], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
-> TcM ([Type], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
forall a b. (a -> b) -> a -> b
$
do { [Type]
ctxt <- Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
hs_ctxt
; [([TyVar], [TyVar])]
fds <- (GenLocated SrcSpanAnnA (FunDep GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], [TyVar]))
-> [GenLocated SrcSpanAnnA (FunDep GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [([TyVar], [TyVar])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((FunDep GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], [TyVar]))
-> GenLocated SrcSpanAnnA (FunDep GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], [TyVar])
forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA FunDep GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], [TyVar])
tc_fundep) [GenLocated SrcSpanAnnA (FunDep GhcRn)]
[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
; ([Type], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
-> TcM ([Type], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
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
; (TidyEnv, SDoc) -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
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 <- (TcMethInfo -> IOEnv (Env TcGblEnv TcLclEnv) TcMethInfo)
-> [TcMethInfo] -> TcM [TcMethInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ZonkEnv -> TcMethInfo -> IOEnv (Env TcGblEnv TcLclEnv) 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 <- TcRnIf TcGblEnv TcLclEnv Bool
tcIsHsBootOrSig
; let body :: Maybe ([Type], [ClassATItem], [TcMethInfo], ClassMinimalDef)
body | Bool
is_boot, [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
ctxt, [ClassATItem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClassATItem]
at_stuff, [TcMethInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcMethInfo]
sig_stuff
= Maybe ([Type], [ClassATItem], [TcMethInfo], ClassMinimalDef)
forall a. Maybe a
Nothing
| Bool
otherwise
= ([Type], [ClassATItem], [TcMethInfo], ClassMinimalDef)
-> Maybe ([Type], [ClassATItem], [TcMethInfo], ClassMinimalDef)
forall a. a -> Maybe a
Just ([Type]
ctxt, [ClassATItem]
at_stuff, [TcMethInfo]
sig_stuff, ClassMinimalDef
mindef)
; Class
clas <- Name
-> [TyConBinder]
-> [Role]
-> [([TyVar], [TyVar])]
-> Maybe ([Type], [ClassATItem], [TcMethInfo], ClassMinimalDef)
-> TcM Class
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" ([GenLocated SrcSpanAnnA (FunDep GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (FunDep GhcRn)]
[LHsFunDep GhcRn]
fundeps SDoc -> SDoc -> SDoc
$$ [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
binders SDoc -> SDoc -> SDoc
$$
[([TyVar], [TyVar])] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [([TyVar], [TyVar])]
fds)
; Class -> TcM Class
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 -> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], [TyVar])
tc_fundep (FunDep XCFunDep GhcRn
_ [LIdP GhcRn]
tvs1 [LIdP GhcRn]
tvs2)
= do { [TyVar]
tvs1' <- (GenLocated SrcSpanAnnN Name
-> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [GenLocated SrcSpanAnnN Name] -> TcM [TyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
tcLookupTyVar (Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> (GenLocated SrcSpanAnnN Name -> Name)
-> GenLocated SrcSpanAnnN Name
-> IOEnv (Env TcGblEnv TcLclEnv) TyVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnN Name]
[LIdP GhcRn]
tvs1 ;
; [TyVar]
tvs2' <- (GenLocated SrcSpanAnnN Name
-> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [GenLocated SrcSpanAnnN Name] -> TcM [TyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
tcLookupTyVar (Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> (GenLocated SrcSpanAnnN Name -> Name)
-> GenLocated SrcSpanAnnN Name
-> IOEnv (Env TcGblEnv TcLclEnv) TyVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnN Name]
[LIdP GhcRn]
tvs2 ;
; ([TyVar], [TyVar])
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], [TyVar])
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 {
[IOEnv (Env TcGblEnv TcLclEnv) Any] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ SDoc -> IOEnv (Env TcGblEnv TcLclEnv) Any
forall a. SDoc -> TcM a
failWithTc (Name -> Name -> SDoc
badATErr Name
class_name Name
n)
| Name
n <- (GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn) -> Name)
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn) -> Name
LTyFamDefltDecl GhcRn -> Name
at_def_tycon [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
[LTyFamDefltDecl GhcRn]
at_defs
, Bool -> Bool
not (Name
n Name -> NameSet -> Bool
`elemNameSet` NameSet
at_names) ]
; (GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) ClassATItem)
-> [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)] -> TcM [ClassATItem]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) ClassATItem
tc_at [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
[LFamilyDecl GhcRn]
ats }
where
at_def_tycon :: LTyFamDefltDecl GhcRn -> Name
at_def_tycon :: LTyFamDefltDecl GhcRn -> Name
at_def_tycon = TyFamInstDecl GhcRn -> Name
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)
tyFamInstDeclName (TyFamInstDecl GhcRn -> Name)
-> (GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
-> TyFamInstDecl GhcRn)
-> GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn) -> TyFamInstDecl GhcRn
forall l e. GenLocated l e -> e
unLoc
at_fam_name :: LFamilyDecl GhcRn -> Name
at_fam_name :: LFamilyDecl GhcRn -> Name
at_fam_name = FamilyDecl GhcRn -> Name
forall (p :: Pass). FamilyDecl (GhcPass p) -> IdP (GhcPass p)
familyDeclName (FamilyDecl GhcRn -> Name)
-> (GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> FamilyDecl GhcRn)
-> GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> FamilyDecl GhcRn
forall l e. GenLocated l e -> e
unLoc
at_names :: NameSet
at_names = [Name] -> NameSet
mkNameSet ((GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> Name)
-> [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> Name
LFamilyDecl GhcRn -> Name
at_fam_name [GenLocated SrcSpanAnnA (FamilyDecl GhcRn)]
[LFamilyDecl GhcRn]
ats)
at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn]
at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn]
at_defs_map = (GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
-> NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)])
-> NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
at_def NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
nenv -> ([GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)])
-> NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> Name
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
forall a. (a -> a -> a) -> NameEnv a -> Name -> a -> NameEnv a
extendNameEnv_C [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
forall a. [a] -> [a] -> [a]
(++) NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
nenv
(LTyFamDefltDecl GhcRn -> Name
at_def_tycon GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
LTyFamDefltDecl GhcRn
at_def) [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
at_def])
NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
forall a. NameEnv a
emptyNameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
[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 <- (FamilyDecl GhcRn -> TcRn TyCon)
-> GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> TcRn TyCon
forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA (Maybe Class -> FamilyDecl GhcRn -> TcRn TyCon
tcFamDecl1 (Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls)) GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
at
; let at_defs :: [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
at_defs = NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> Name -> Maybe [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
NameEnv [LTyFamDefltDecl GhcRn]
at_defs_map (LFamilyDecl GhcRn -> Name
at_fam_name GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
LFamilyDecl GhcRn
at)
Maybe [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)]
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)]
[LTyFamDefltDecl GhcRn]
at_defs
; ClassATItem -> IOEnv (Env TcGblEnv TcLclEnv) ClassATItem
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
_ []
= Maybe (Type, ATValidityInfo) -> TcM (Maybe (Type, ATValidityInfo))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Type, ATValidityInfo)
forall a. Maybe a
Nothing
tcDefaultAssocDecl TyCon
_ (LTyFamDefltDecl GhcRn
d1:LTyFamDefltDecl GhcRn
_:[LTyFamDefltDecl GhcRn]
_)
= SDoc -> TcM (Maybe (Type, ATValidityInfo))
forall a. SDoc -> TcM a
failWithTc (String -> SDoc
text String
"More than one default declaration for"
SDoc -> SDoc -> SDoc
<+> IdGhcP 'Renamed -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyFamInstDecl GhcRn -> IdP GhcRn
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)
tyFamInstDeclName (GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn) -> TyFamInstDecl GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (TyFamInstDecl GhcRn)
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 }})]
=
SrcSpanAnnA
-> TcM (Maybe (Type, ATValidityInfo))
-> TcM (Maybe (Type, ATValidityInfo))
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (Maybe (Type, ATValidityInfo))
-> TcM (Maybe (Type, ATValidityInfo)))
-> TcM (Maybe (Type, ATValidityInfo))
-> TcM (Maybe (Type, ATValidityInfo))
forall a b. (a -> b) -> a -> b
$
SDoc
-> Name
-> TcM (Maybe (Type, ATValidityInfo))
-> TcM (Maybe (Type, ATValidityInfo))
forall a. SDoc -> Name -> TcM a -> TcM a
tcAddFamInstCtxt (String -> SDoc
text String
"default type instance") Name
tc_name (TcM (Maybe (Type, ATValidityInfo))
-> TcM (Maybe (Type, ATValidityInfo)))
-> TcM (Maybe (Type, ATValidityInfo))
-> TcM (Maybe (Type, ATValidityInfo))
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcDefaultAssocDecl 1" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
; let fam_tc_name :: Name
fam_tc_name = TyCon -> Name
tyConName TyCon
fam_tc
vis_arity :: Arity
vis_arity = [TyVar] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length (TyCon -> [TyVar]
tyConVisibleTyVars TyCon
fam_tc)
vis_pats :: Arity
vis_pats = [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> Arity
forall tm ty. [HsArg tm ty] -> Arity
numVisibleArgs [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
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 Arity -> Arity -> Bool
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
<+> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
HsTyPats GhcRn
hs_pats
, String -> SDoc
text String
"hs_rhs_ty" SDoc -> SDoc -> SDoc
<+> GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsType GhcRn)
LHsKind GhcRn
hs_rhs_ty
, String -> SDoc
text String
"fam_tvs" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
fam_tvs
, String -> SDoc
text String
"qtvs" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
qtvs
])
; let subst :: TCvSubst
subst = case (Type -> Maybe TyVar) -> [Type] -> Maybe [TyVar]
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 -> [TyVar] -> [Type] -> TCvSubst
HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst
zipTvSubst [TyVar]
cpt_tvs ([TyVar] -> [Type]
mkTyVarTys [TyVar]
fam_tvs)
Maybe [TyVar]
Nothing -> TCvSubst
emptyTCvSubst
; Maybe (Type, ATValidityInfo) -> TcM (Maybe (Type, ATValidityInfo))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Type, ATValidityInfo)
-> TcM (Maybe (Type, ATValidityInfo)))
-> Maybe (Type, ATValidityInfo)
-> TcM (Maybe (Type, ATValidityInfo))
forall a b. (a -> b) -> a -> b
$ (Type, ATValidityInfo) -> Maybe (Type, ATValidityInfo)
forall a. a -> Maybe a
Just (TCvSubst -> Type -> Type
substTyUnchecked TCvSubst
subst Type
rhs_ty, SrcSpan -> [Type] -> ATValidityInfo
ATVI (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) [Type]
pats)
}
tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon
tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcRn 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
= Name
-> (TyCon -> [TyConBinder] -> Type -> TcRn TyCon) -> TcRn TyCon
forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tc_name ((TyCon -> [TyConBinder] -> Type -> TcRn TyCon) -> TcRn TyCon)
-> (TyCon -> [TyConBinder] -> Type -> TcRn TyCon) -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
binders Type
res_kind -> do
{ String -> SDoc -> TcRn ()
traceTc String
"data family:" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
; Name -> TcRn ()
checkFamFlag Name
tc_name
; DataSort -> Type -> TcRn ()
checkDataKindSig DataSort
DataFamilySort Type
res_kind
; Name
tc_rep_name <- Name -> TcRnIf TcGblEnv TcLclEnv Name
forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
tc_name
; let inj :: Injectivity
inj = [Bool] -> Injectivity
Injective ([Bool] -> Injectivity) -> [Bool] -> Injectivity
forall a b. (a -> b) -> a -> b
$ Arity -> Bool -> [Bool]
forall a. Arity -> a -> [a]
replicate ([TyConBinder] -> Arity
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
(FamilyResultSig GhcRn -> Maybe (IdP GhcRn)
forall (a :: Pass).
FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
resultVariableName FamilyResultSig GhcRn
sig)
(Name -> FamTyConFlav
DataFamilyTyCon Name
tc_rep_name)
Maybe Class
parent Injectivity
inj
; TyCon -> TcRn TyCon
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tycon }
| FamilyInfo GhcRn
OpenTypeFamily <- FamilyInfo GhcRn
fam_info
= Name
-> (TyCon -> [TyConBinder] -> Type -> TcRn TyCon) -> TcRn TyCon
forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tc_name ((TyCon -> [TyConBinder] -> Type -> TcRn TyCon) -> TcRn TyCon)
-> (TyCon -> [TyConBinder] -> Type -> TcRn TyCon) -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
binders Type
res_kind -> do
{ String -> SDoc -> TcRn ()
traceTc String
"open type family:" (Name -> SDoc
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
(FamilyResultSig GhcRn -> Maybe (IdP GhcRn)
forall (a :: Pass).
FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
resultVariableName FamilyResultSig GhcRn
sig) FamTyConFlav
OpenSynFamilyTyCon
Maybe Class
parent Injectivity
inj'
; TyCon -> TcRn TyCon
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:" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
; (Injectivity
inj', [TyConBinder]
binders, Type
res_kind)
<- Name
-> (TyCon
-> [TyConBinder] -> Type -> TcM (Injectivity, [TyConBinder], Type))
-> TcM (Injectivity, [TyConBinder], Type)
forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tc_name ((TyCon
-> [TyConBinder] -> Type -> TcM (Injectivity, [TyConBinder], Type))
-> TcM (Injectivity, [TyConBinder], Type))
-> (TyCon
-> [TyConBinder] -> Type -> TcM (Injectivity, [TyConBinder], Type))
-> TcM (Injectivity, [TyConBinder], Type)
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
; (Injectivity, [TyConBinder], Type)
-> TcM (Injectivity, [TyConBinder], Type)
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 ->
TyCon -> TcRn TyCon
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> TcRn TyCon) -> TyCon -> TcRn TyCon
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
(FamilyResultSig GhcRn -> Maybe (IdP GhcRn)
forall (a :: Pass).
FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
resultVariableName FamilyResultSig GhcRn
sig)
FamTyConFlav
AbstractClosedSynFamilyTyCon Maybe Class
parent
Injectivity
inj'
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 <- (GenLocated
SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))
-> TcRn (KnotTied CoAxBranch))
-> [GenLocated
SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
-> TcRn [KnotTied CoAxBranch]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM (TyCon
-> AssocInstInfo
-> LTyFamInstEqn GhcRn
-> TcRn (KnotTied CoAxBranch)
tcTyFamInstEqn TyCon
tc_fam_tc AssocInstInfo
NotAssociated) [GenLocated
SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
[LTyFamInstEqn GhcRn]
eqns
; Name
co_ax_name <- GenLocated SrcSpanAnnN Name
-> [[Type]] -> TcRnIf TcGblEnv TcLclEnv Name
newFamInstAxiomName GenLocated SrcSpanAnnN Name
LIdP GhcRn
tc_lname []
; let mb_co_ax :: Maybe (CoAxiom Branched)
mb_co_ax
| [GenLocated
SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
-> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated
SrcSpanAnnA (FamEqn GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn)))]
[LTyFamInstEqn GhcRn]
eqns = Maybe (CoAxiom Branched)
forall a. Maybe a
Nothing
| Bool
otherwise = CoAxiom Branched -> Maybe (CoAxiom Branched)
forall a. a -> Maybe a
Just (Name -> TyCon -> [KnotTied CoAxBranch] -> CoAxiom Branched
mkBranchedCoAxiom Name
co_ax_name TyCon
fam_tc [KnotTied CoAxBranch]
branches)
fam_tc :: TyCon
fam_tc = Name
-> [TyConBinder]
-> Type
-> Maybe Name
-> FamTyConFlav
-> Maybe Class
-> Injectivity
-> TyCon
mkFamilyTyCon Name
tc_name [TyConBinder]
binders Type
res_kind (FamilyResultSig GhcRn -> Maybe (IdP GhcRn)
forall (a :: Pass).
FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
resultVariableName FamilyResultSig GhcRn
sig)
(Maybe (CoAxiom Branched) -> FamTyConFlav
ClosedSynFamilyTyCon Maybe (CoAxiom Branched)
mb_co_ax) Maybe Class
parent Injectivity
inj'
; TyCon -> TcRn TyCon
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
= Injectivity -> TcM Injectivity
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)))
= SrcSpan -> TcM Injectivity -> TcM Injectivity
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM Injectivity -> TcM Injectivity)
-> TcM Injectivity -> TcM Injectivity
forall a b. (a -> b) -> a -> b
$
do { let tvs :: [TyVar]
tvs = [TyConBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tcbs
; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
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 <- (GenLocated SrcSpanAnnN Name
-> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [GenLocated SrcSpanAnnN Name] -> TcM [TyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
tcLookupTyVar (Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> (GenLocated SrcSpanAnnN Name -> Name)
-> GenLocated SrcSpanAnnN Name
-> IOEnv (Env TcGblEnv TcLclEnv) TyVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnN Name]
[LIdP GhcRn]
lInjNames
; [TyVar]
inj_tvs <- (TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [TyVar] -> TcM [TyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasDebugCallStack => TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
zonkTcTyVarToTyVar [TyVar]
inj_tvs
; let inj_ktvs :: VarSet
inj_ktvs = (TyVar -> Bool) -> VarSet -> VarSet
filterVarSet TyVar -> Bool
isTyVar (VarSet -> VarSet) -> VarSet -> VarSet
forall a b. (a -> b) -> a -> b
$
VarSet -> VarSet
closeOverKinds ([TyVar] -> VarSet
mkVarSet [TyVar]
inj_tvs)
; let inj_bools :: [Bool]
inj_bools = (TyVar -> Bool) -> [TyVar] -> [Bool]
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 [ [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs, [GenLocated SrcSpanAnnN Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnN Name]
[LIdP GhcRn]
lInjNames, [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
inj_tvs
, VarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarSet
inj_ktvs, [Bool] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Bool]
inj_bools ])
; Injectivity -> TcM Injectivity
forall (m :: * -> *) a. Monad m => a -> m a
return (Injectivity -> TcM Injectivity) -> Injectivity -> TcM Injectivity
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 -> TcRn TyCon
tcTySynRhs Name -> [Role]
roles_info Name
tc_name LHsKind GhcRn
hs_ty
= Name
-> (TyCon -> [TyConBinder] -> Type -> TcRn TyCon) -> TcRn TyCon
forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tc_name ((TyCon -> [TyConBinder] -> Type -> TcRn TyCon) -> TcRn TyCon)
-> (TyCon -> [TyConBinder] -> Type -> TcRn TyCon) -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$ \ TyCon
_ [TyConBinder]
binders Type
res_kind ->
do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; String -> SDoc -> TcRn ()
traceTc String
"tc-syn" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tc_name SDoc -> SDoc -> SDoc
$$ TcTypeEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcLclEnv -> TcTypeEnv
tcl_env TcLclEnv
env))
; Type
rhs_ty <- SkolemInfo -> [TyVar] -> TcM Type -> TcM Type
forall a. SkolemInfo -> [TyVar] -> TcM a -> TcM a
pushLevelAndSolveEqualities SkolemInfo
skol_info ([TyConBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
binders) (TcM Type -> TcM Type) -> TcM Type -> TcM Type
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
; (TidyEnv, SDoc) -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
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:"
, Type -> SDoc
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
; TyCon -> TcRn TyCon
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
-> IOEnv (Env TcGblEnv TcLclEnv) (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 })
= Name
-> (TyCon
-> [TyConBinder]
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tc_name ((TyCon
-> [TyConBinder]
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo]))
-> (TyCon
-> [TyConBinder]
-> Type
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo]))
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
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]
-> TcRnIf 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 <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let hsc_src :: HscSource
hsc_src = TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (HscSource -> [GenLocated SrcSpanAnnA (ConDecl GhcRn)] -> Bool
forall {a}. HscSource -> [a] -> Bool
mk_permissive_kind HscSource
hsc_src [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
[LConDecl GhcRn]
cons) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
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 = [TyConBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tycon_binders
; [Type]
stupid_tc_theta <- SkolemInfo -> [TyVar] -> TcM [Type] -> TcM [Type]
forall a. SkolemInfo -> [TyVar] -> TcM a -> TcM a
pushLevelAndSolveEqualities SkolemInfo
skol_info [TyVar]
skol_tvs (TcM [Type] -> TcM [Type]) -> TcM [Type] -> TcM [Type]
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
; (TidyEnv, SDoc) -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
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 <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.KindSignatures
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (GenLocated SrcSpanAnnA (HsType GhcRn)) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (GenLocated SrcSpanAnnA (HsType GhcRn))
Maybe (LHsKind GhcRn)
mb_ksig) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Bool -> SDoc -> TcRn ()
checkTc (Bool
kind_signatures) (Name -> SDoc
badSigTyDecl Name
tc_name)
; TyCon
tycon <- (TyCon -> TcRn TyCon) -> TcRn TyCon
forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM ((TyCon -> TcRn TyCon) -> TcRn TyCon)
-> (TyCon -> TcRn TyCon) -> TcRn TyCon
forall a b. (a -> b) -> a -> b
$ \ TyCon
rec_tycon -> do
{ let final_bndrs :: [TyConBinder]
final_bndrs = [TyConBinder]
tycon_binders [TyConBinder] -> [TyConBinder] -> [TyConBinder]
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 <- Name -> TcRnIf TcGblEnv TcLclEnv Name
forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
tc_name
; TyCon -> TcRn TyCon
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
((GenLocated SrcSpanAnnP CType -> CType)
-> Maybe (GenLocated SrcSpanAnnP CType) -> Maybe CType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpanAnnP CType -> CType
forall l e. GenLocated l e -> e
unLoc Maybe (GenLocated SrcSpanAnnP CType)
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" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tc_name SDoc -> SDoc -> SDoc
$$ [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
tycon_binders SDoc -> SDoc -> SDoc
$$ [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
extra_bndrs)
; (TyCon, [DerivInfo])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyCon, [DerivInfo])
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
_ []
= AlgTyConRhs -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
forall (m :: * -> *) a. Monad m => a -> m a
return AlgTyConRhs
AbstractTyCon
mk_tc_rhs HscSource
HsigFile TyCon
_ []
= AlgTyConRhs -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
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 -> AlgTyConRhs -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
forall (m :: * -> *) a. Monad m => a -> m a
return ([DataCon] -> AlgTyConRhs
mkDataTyConRhs [DataCon]
data_cons)
NewOrData
NewType -> ASSERT( not (null data_cons) )
Name
-> TyCon -> DataCon -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
forall m n. Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
mkNewTyConRhs Name
tc_name TyCon
tycon ([DataCon] -> DataCon
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 }))
= SrcSpanAnnA -> TcRn () -> TcRn ()
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"kcTyFamInstEqn" ([SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"tc_name =" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
eqn_tc_name
, String -> SDoc
text String
"fam_tc =" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc_fam_tc SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Type
tyConKind TyCon
tc_fam_tc)
, String -> SDoc
text String
"feqn_bndrs =" SDoc -> SDoc -> SDoc
<+> HsOuterFamEqnTyVarBndrs GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs
, String -> SDoc
text String
"feqn_pats =" SDoc -> SDoc -> SDoc
<+> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
HsTyPats GhcRn
hs_pats ])
; TyCon
-> Name
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> TcRn ()
forall tm ty. TyCon -> Name -> [HsArg tm ty] -> TcRn ()
checkTyFamInstEqn TyCon
tc_fam_tc Name
eqn_tc_name [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
HsTyPats GhcRn
hs_pats
; TcM ([TyVar], Type) -> TcRn ()
forall a. TcM a -> TcRn ()
discardResult (TcM ([TyVar], Type) -> TcRn ()) -> TcM ([TyVar], Type) -> TcRn ()
forall a b. (a -> b) -> a -> b
$
HsOuterFamEqnTyVarBndrs GhcRn -> TcM Type -> TcM ([TyVar], Type)
forall a.
HsOuterFamEqnTyVarBndrs GhcRn -> TcM a -> TcM ([TyVar], a)
bindOuterFamEqnTKBndrs_Q_Tv HsOuterFamEqnTyVarBndrs GhcRn
outer_bndrs (TcM Type -> TcM ([TyVar], Type))
-> TcM Type -> TcM ([TyVar], Type)
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)
LHsKind GhcRn
hs_rhs_ty (Type -> ContextKind
TheKind Type
res_kind) }
}
tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn
-> TcM (KnotTied CoAxBranch)
tcTyFamInstEqn :: TyCon
-> AssocInstInfo
-> LTyFamInstEqn GhcRn
-> TcRn (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 }))
= SrcSpanAnnA
-> TcRn (KnotTied CoAxBranch) -> TcRn (KnotTied CoAxBranch)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn (KnotTied CoAxBranch) -> TcRn (KnotTied CoAxBranch))
-> TcRn (KnotTied CoAxBranch) -> TcRn (KnotTied CoAxBranch)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcTyFamInstEqn" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ SrcSpanAnnA -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanAnnA
loc, TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc SDoc -> SDoc -> SDoc
<+> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
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
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars (Class -> [TyVar]
classTyVars Class
cls) ]
; TyCon
-> Name
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> TcRn ()
forall tm ty. TyCon -> Name -> [HsArg tm ty] -> TcRn ()
checkTyFamInstEqn TyCon
fam_tc Name
eqn_tc_name [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
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)
LHsKind GhcRn
hs_rhs_ty
; KnotTied CoAxBranch -> TcRn (KnotTied CoAxBranch)
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
((TyVar -> Role) -> [TyVar] -> [Role]
forall a b. (a -> b) -> [a] -> [b]
map (Role -> TyVar -> Role
forall a b. a -> b -> a
const Role
Nominal) [TyVar]
qtvs)
(SrcSpanAnnA -> SrcSpan
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 = TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
tc_fam_tc
; Bool -> SDoc -> TcRn ()
checkTc (Name
tc_fam_tc_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
eqn_tc_name) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
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 = [TyVar] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length (TyCon -> [TyVar]
tyConVisibleTyVars TyCon
tc_fam_tc)
vis_pats :: Arity
vis_pats = [HsArg tm ty] -> Arity
forall tm ty. [HsArg tm ty] -> Arity
numVisibleArgs [HsArg tm ty]
hs_pats
; Bool -> SDoc -> TcRn ()
checkTc (Arity
vis_pats Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
vis_arity) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
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 {" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc)
; (TcLevel
tclvl, WantedConstraints
wanted, ([TyVar]
outer_tvs, (Type
lhs_ty, Type
rhs_ty)))
<- String
-> TcM ([TyVar], (Type, Type))
-> TcM (TcLevel, WantedConstraints, ([TyVar], (Type, Type)))
forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tcTyFamInstEqnGuts" (TcM ([TyVar], (Type, Type))
-> TcM (TcLevel, WantedConstraints, ([TyVar], (Type, Type))))
-> TcM ([TyVar], (Type, Type))
-> TcM (TcLevel, WantedConstraints, ([TyVar], (Type, Type)))
forall a b. (a -> b) -> a -> b
$
HsOuterFamEqnTyVarBndrs GhcRn
-> TcM (Type, Type) -> TcM ([TyVar], (Type, Type))
forall a.
HsOuterFamEqnTyVarBndrs GhcRn -> TcM a -> TcM ([TyVar], a)
bindOuterFamEqnTKBndrs HsOuterFamEqnTyVarBndrs GhcRn
outer_hs_bndrs (TcM (Type, Type) -> TcM ([TyVar], (Type, Type)))
-> TcM (Type, Type) -> TcM ([TyVar], (Type, Type))
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)
; (Type, Type) -> TcM (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
lhs_ty, Type
rhs_ty) }
; CandidatesQTvs
dvs <- [Type] -> TcM CandidatesQTvs
candidateQTyVarsOfTypes (Type
lhs_ty Type -> [Type] -> [Type]
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" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc
, String -> SDoc
text String
"lhs_ty" SDoc -> SDoc -> SDoc
<+> Type -> 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
; (TidyEnv, SDoc) -> IOEnv (Env TcGblEnv TcLclEnv) (TidyEnv, SDoc)
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:"
, Type -> SDoc
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 }" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
qtvs)
; ([TyVar], [Type], Type) -> TcM ([TyVar], [Type], Type)
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 = [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
-> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
forall a. [a] -> a
last [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
[LHsTyVarBndr () (NoGhcTc GhcRn)]
bndrs
skol_info :: SkolemInfo
skol_info = SDoc -> SkolemInfo
ForAllSkol ([SDoc] -> SDoc
fsep ((GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn) -> SDoc)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
[LHsTyVarBndr () (NoGhcTc GhcRn)]
bndrs))
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
LHsTyVarBndr () (NoGhcTc GhcRn)
b_first) (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
b_last)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
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
= () -> TcRn ()
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])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
fam_app of
Just (TyCon
_, [Type]
pats) -> [Type]
pats
Maybe (TyCon, [Type])
Nothing -> String -> [Type]
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])
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 [TyVar] -> [Type] -> [(TyVar, Type)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Type]
pats
, Just Type
cls_ty <- [VarEnv Type -> TyVar -> Maybe Type
forall a. VarEnv a -> TyVar -> Maybe a
lookupVarEnv VarEnv Type
inst_env TyVar
fam_tc_tv] ]
; String -> SDoc -> TcRn ()
traceTc String
"addConsistencyConstraints" ([(Type, Type)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Type, Type)]
eqs)
; CtOrigin -> [(Type, Type)] -> TcRn ()
emitDerivedEqs CtOrigin
AssocFamPatOrigin [(Type, Type)]
eqs }
| Bool
otherwise
= () -> TcRn ()
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]
-> TcRnIf 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 = Maybe (LHsContext GhcRn) -> HsContext GhcRn
forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext Maybe (LHsContext GhcRn)
mctxt
; Bool
gadtSyntax_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
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 ([GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsType GhcRn)]
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 NewOrData -> NewOrData -> Bool
forall a. Eq a => a -> a -> Bool
== NewOrData
DataType Bool -> Bool -> Bool
|| [GenLocated SrcSpanAnnA (ConDecl GhcRn)] -> Bool
forall a. [a] -> Bool
isSingleton [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
[LConDecl GhcRn]
cons)
(Name -> Arity -> SDoc
newtypeConError Name
tc_name ([GenLocated SrcSpanAnnA (ConDecl GhcRn)] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
[LConDecl GhcRn]
cons))
; Bool
empty_data_decls <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.EmptyDataDecls
; Bool
is_boot <- TcRnIf TcGblEnv TcLclEnv Bool
tcIsHsBootOrSig
; Bool -> SDoc -> TcRn ()
checkTc (Bool -> Bool
not ([GenLocated SrcSpanAnnA (ConDecl GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (ConDecl GhcRn)]
[LConDecl GhcRn]
cons) Bool -> Bool -> Bool
|| Bool
empty_data_decls Bool -> Bool -> Bool
|| Bool
is_boot)
(Name -> SDoc
emptyConDeclsErr Name
tc_name)
; Bool -> TcRnIf TcGblEnv TcLclEnv Bool
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 ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$
[TyVar] -> [Type]
mkTyVarTys ([TyConBinder] -> [TyVar]
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
= (LConDecl GhcRn -> TcM [DataCon])
-> [LConDecl GhcRn] -> TcM [DataCon]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ((LConDecl GhcRn -> TcM [DataCon])
-> [LConDecl GhcRn] -> TcM [DataCon])
-> (LConDecl GhcRn -> TcM [DataCon])
-> [LConDecl GhcRn]
-> TcM [DataCon]
forall a b. (a -> b) -> a -> b
$ (ConDecl GhcRn -> TcM [DataCon])
-> GenLocated SrcSpanAnnA (ConDecl GhcRn) -> TcM [DataCon]
forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA ((ConDecl GhcRn -> TcM [DataCon])
-> GenLocated SrcSpanAnnA (ConDecl GhcRn) -> TcM [DataCon])
-> (ConDecl GhcRn -> TcM [DataCon])
-> GenLocated SrcSpanAnnA (ConDecl GhcRn)
-> TcM [DataCon]
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 })
= SDoc -> TcM [DataCon] -> TcM [DataCon]
forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([GenLocated SrcSpanAnnN Name] -> SDoc
dataConCtxt [GenLocated SrcSpanAnnN Name
LIdP GhcRn
lname]) (TcM [DataCon] -> TcM [DataCon]) -> TcM [DataCon] -> TcM [DataCon]
forall a b. (a -> b) -> a -> b
$
do {
; String -> SDoc -> TcRn ()
traceTc String
"tcConDecl 1" ([SDoc] -> SDoc
vcat [ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name, [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcRn)]
[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)))
<- String
-> TcM
([VarBndr TyVar Specificity],
([Type], [Scaled Type], [FieldLabel], [HsSrcBang]))
-> TcM
(TcLevel, WantedConstraints,
([VarBndr TyVar Specificity],
([Type], [Scaled Type], [FieldLabel], [HsSrcBang])))
forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tcConDecl:H98" (TcM
([VarBndr TyVar Specificity],
([Type], [Scaled Type], [FieldLabel], [HsSrcBang]))
-> TcM
(TcLevel, WantedConstraints,
([VarBndr TyVar Specificity],
([Type], [Scaled Type], [FieldLabel], [HsSrcBang]))))
-> TcM
([VarBndr TyVar Specificity],
([Type], [Scaled Type], [FieldLabel], [HsSrcBang]))
-> TcM
(TcLevel, WantedConstraints,
([VarBndr TyVar Specificity],
([Type], [Scaled Type], [FieldLabel], [HsSrcBang])))
forall a b. (a -> b) -> a -> b
$
[LHsTyVarBndr Specificity GhcRn]
-> TcM ([Type], [Scaled Type], [FieldLabel], [HsSrcBang])
-> TcM
([VarBndr TyVar Specificity],
([Type], [Scaled Type], [FieldLabel], [HsSrcBang]))
forall flag a.
OutputableBndrFlag flag 'Renamed =>
[LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a)
tcExplicitTKBndrs [LHsTyVarBndr Specificity GhcRn]
explicit_tkv_nms (TcM ([Type], [Scaled Type], [FieldLabel], [HsSrcBang])
-> TcM
([VarBndr TyVar Specificity],
([Type], [Scaled Type], [FieldLabel], [HsSrcBang])))
-> TcM ([Type], [Scaled Type], [FieldLabel], [HsSrcBang])
-> TcM
([VarBndr TyVar Specificity],
([Type], [Scaled Type], [FieldLabel], [HsSrcBang]))
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) = [(Scaled Type, HsSrcBang)] -> ([Scaled Type], [HsSrcBang])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Scaled Type, HsSrcBang)]
btys
; ([Type], [Scaled Type], [FieldLabel], [HsSrcBang])
-> TcM ([Type], [Scaled Type], [FieldLabel], [HsSrcBang])
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 = [TyConBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tc_bndrs
fake_ty :: Type
fake_ty = [TyVar] -> Type -> Type
mkSpecForAllTys [TyVar]
tc_tvs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[VarBndr TyVar Specificity] -> Type -> Type
mkInvisForAllTys [VarBndr TyVar Specificity]
exp_tvbndrs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Type] -> Type -> Type
mkPhiTy [Type]
ctxt (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Scaled Type] -> Type -> Type
mkVisFunTys [Scaled Type]
arg_tys (Type -> Type) -> Type -> Type
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 [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
kvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [VarBndr TyVar Specificity] -> [TyVar]
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) <- ZonkEnv
-> [VarBndr TyVar Specificity]
-> TcM (ZonkEnv, [VarBndr TyVar Specificity])
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" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
$$ [FieldLabel] -> 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 = Specificity -> [TyVar] -> [VarBndr TyVar Specificity]
forall vis. vis -> [TyVar] -> [VarBndr TyVar vis]
mkTyVarBinders Specificity
InferredSpec [TyVar]
qkvs [VarBndr TyVar Specificity]
-> [VarBndr TyVar Specificity] -> [VarBndr TyVar Specificity]
forall a. [a] -> [a] -> [a]
++ [VarBndr TyVar Specificity]
user_qtvbndrs
ex_tvs :: [TyVar]
ex_tvs = [VarBndr TyVar Specificity] -> [TyVar]
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 [VarBndr TyVar Specificity]
-> [VarBndr TyVar Specificity] -> [VarBndr TyVar Specificity]
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" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
; Bool
is_infix <- Name -> HsConDeclH98Details GhcRn -> TcRnIf TcGblEnv TcLclEnv Bool
tcConIsInfixH98 Name
name HsConDeclH98Details GhcRn
hs_args
; Name
rep_nm <- Name -> TcRnIf TcGblEnv TcLclEnv Name
forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
name
; FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; DataCon
dc <- FamInstEnvs
-> Name
-> Bool
-> Name
-> [HsSrcBang]
-> Maybe [HsImplBang]
-> [FieldLabel]
-> [TyVar]
-> [TyVar]
-> [VarBndr TyVar Specificity]
-> [EqSpec]
-> [Type]
-> [Scaled Type]
-> Type
-> TyCon
-> NameEnv Arity
-> TcRnIf TcGblEnv TcLclEnv DataCon
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 Maybe [HsImplBang]
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
; [DataCon] -> TcM [DataCon]
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 })
= SDoc -> TcM [DataCon] -> TcM [DataCon]
forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([GenLocated SrcSpanAnnN Name] -> SDoc
dataConCtxt [GenLocated SrcSpanAnnN Name]
[LIdP GhcRn]
names) (TcM [DataCon] -> TcM [DataCon]) -> TcM [DataCon] -> TcM [DataCon]
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcConDecl 1 gadt" ([GenLocated SrcSpanAnnN Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnN Name]
[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)))
<- String
-> TcM
(HsOuterSigTyVarBndrs GhcTc,
([Type], [Scaled Type], Type, [FieldLabel], [HsSrcBang]))
-> TcM
(TcLevel, WantedConstraints,
(HsOuterSigTyVarBndrs GhcTc,
([Type], [Scaled Type], Type, [FieldLabel], [HsSrcBang])))
forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tcConDecl:GADT" (TcM
(HsOuterSigTyVarBndrs GhcTc,
([Type], [Scaled Type], Type, [FieldLabel], [HsSrcBang]))
-> TcM
(TcLevel, WantedConstraints,
(HsOuterSigTyVarBndrs GhcTc,
([Type], [Scaled Type], Type, [FieldLabel], [HsSrcBang]))))
-> TcM
(HsOuterSigTyVarBndrs GhcTc,
([Type], [Scaled Type], Type, [FieldLabel], [HsSrcBang]))
-> TcM
(TcLevel, WantedConstraints,
(HsOuterSigTyVarBndrs GhcTc,
([Type], [Scaled Type], Type, [FieldLabel], [HsSrcBang])))
forall a b. (a -> b) -> a -> b
$
SkolemInfo
-> HsOuterSigTyVarBndrs GhcRn
-> TcM ([Type], [Scaled Type], Type, [FieldLabel], [HsSrcBang])
-> TcM
(HsOuterSigTyVarBndrs GhcTc,
([Type], [Scaled Type], Type, [FieldLabel], [HsSrcBang]))
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 (TcM ([Type], [Scaled Type], Type, [FieldLabel], [HsSrcBang])
-> TcM
(HsOuterSigTyVarBndrs GhcTc,
([Type], [Scaled Type], Type, [FieldLabel], [HsSrcBang])))
-> TcM ([Type], [Scaled Type], Type, [FieldLabel], [HsSrcBang])
-> TcM
(HsOuterSigTyVarBndrs GhcTc,
([Type], [Scaled Type], Type, [FieldLabel], [HsSrcBang]))
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 -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
DDataInstance Type
hdr_ty ->
do { (TCvSubst
subst, [TyVar]
_meta_tvs) <- [TyVar] -> TcM (TCvSubst, [TyVar])
newMetaTyVars ([TyConBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tc_bndrs)
; let head_shape :: Type
head_shape = HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
hdr_ty
; TcM Coercion -> TcRn ()
forall a. TcM a -> TcRn ()
discardResult (TcM Coercion -> TcRn ()) -> TcM Coercion -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcM Coercion -> TcM Coercion
forall r. TcM r -> TcM r
popErrCtxt (TcM Coercion -> TcM Coercion) -> TcM Coercion -> TcM Coercion
forall a b. (a -> b) -> a -> b
$
SDoc -> TcM Coercion -> TcM Coercion
forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([GenLocated SrcSpanAnnN Name] -> SDoc
dataConResCtxt [GenLocated SrcSpanAnnN Name]
[LIdP GhcRn]
names) (TcM Coercion -> TcM Coercion) -> TcM Coercion -> TcM Coercion
forall a b. (a -> b) -> a -> b
$
Maybe SDoc -> Type -> Type -> TcM Coercion
unifyType Maybe SDoc
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) = [(Scaled Type, HsSrcBang)] -> ([Scaled Type], [HsSrcBang])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Scaled Type, HsSrcBang)]
btys
; [FieldLabel]
field_lbls <- Name -> RnM [FieldLabel]
lookupConstructorFields Name
name
; ([Type], [Scaled Type], Type, [FieldLabel], [HsSrcBang])
-> TcM ([Type], [Scaled Type], Type, [FieldLabel], [HsSrcBang])
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 (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Type] -> Type -> Type
mkPhiTy [Type]
ctxt (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Scaled Type] -> Type -> Type
mkVisFunTys [Scaled Type]
arg_tys (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type
res_ty)
; String -> SDoc -> TcRn ()
traceTc String
"tcConDecl:GADT" ([GenLocated SrcSpanAnnN Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnN Name]
[LIdP GhcRn]
names SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
res_ty SDoc -> SDoc -> SDoc
$$ [TyVar] -> 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 = Specificity -> [TyVar] -> [VarBndr TyVar Specificity]
forall vis. vis -> [TyVar] -> [VarBndr TyVar vis]
mkTyVarBinders Specificity
InferredSpec [TyVar]
tkvs [VarBndr TyVar Specificity]
-> [VarBndr TyVar Specificity] -> [VarBndr TyVar Specificity]
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) <- ZonkEnv
-> [VarBndr TyVar Specificity]
-> TcM (ZonkEnv, [VarBndr TyVar Specificity])
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]
TCvSubst -> [Type] -> [Type]
substTys TCvSubst
arg_subst [Type]
ctxt
arg_tys' :: [Scaled Type]
arg_tys' = HasCallStack => TCvSubst -> [Scaled Type] -> [Scaled Type]
TCvSubst -> [Scaled Type] -> [Scaled Type]
substScaledTys TCvSubst
arg_subst [Scaled Type]
arg_tys
res_ty' :: Type
res_ty' = HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
arg_subst Type
res_ty
; String -> SDoc -> TcRn ()
traceTc String
"tcConDecl 2" ([GenLocated SrcSpanAnnN Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnN Name]
[LIdP GhcRn]
names SDoc -> SDoc -> SDoc
$$ [FieldLabel] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [FieldLabel]
field_lbls)
; FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; let
buildOneDataCon :: GenLocated SrcSpanAnnN Name -> TcRnIf TcGblEnv TcLclEnv DataCon
buildOneDataCon (L SrcSpanAnnN
_ Name
name) = do
{ Bool
is_infix <- Name -> HsConDeclGADTDetails GhcRn -> TcRnIf TcGblEnv TcLclEnv Bool
tcConIsInfixGADT Name
name HsConDeclGADTDetails GhcRn
hs_args
; Name
rep_nm <- Name -> TcRnIf TcGblEnv TcLclEnv Name
forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
name
; FamInstEnvs
-> Name
-> Bool
-> Name
-> [HsSrcBang]
-> Maybe [HsImplBang]
-> [FieldLabel]
-> [TyVar]
-> [TyVar]
-> [VarBndr TyVar Specificity]
-> [EqSpec]
-> [Type]
-> [Scaled Type]
-> Type
-> TyCon
-> NameEnv Arity
-> TcRnIf TcGblEnv TcLclEnv DataCon
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 Maybe [HsImplBang]
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
}
; (GenLocated SrcSpanAnnN Name -> TcRnIf TcGblEnv TcLclEnv DataCon)
-> [GenLocated SrcSpanAnnN Name] -> TcM [DataCon]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpanAnnN Name -> TcRnIf TcGblEnv TcLclEnv DataCon
buildOneDataCon [GenLocated SrcSpanAnnN Name]
[LIdP GhcRn]
names }
where
skol_info :: SkolemInfo
skol_info = Name -> SkolemInfo
DataConSkol (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc ([GenLocated SrcSpanAnnN Name] -> GenLocated SrcSpanAnnN Name
forall a. [a] -> a
head [GenLocated SrcSpanAnnN Name]
[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 -> TcRnIf TcGblEnv TcLclEnv Bool
tcConIsInfixH98 Name
_ HsConDeclH98Details GhcRn
details
= case HsConDeclH98Details GhcRn
details of
InfixCon{} -> Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
RecCon{} -> Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
PrefixCon{} -> Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
tcConIsInfixGADT :: Name
-> HsConDeclGADTDetails GhcRn
-> TcM Bool
tcConIsInfixGADT :: Name -> HsConDeclGADTDetails GhcRn -> TcRnIf TcGblEnv TcLclEnv Bool
tcConIsInfixGADT Name
con HsConDeclGADTDetails GhcRn
details
= case HsConDeclGADTDetails GhcRn
details of
RecConGADT{} -> Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
PrefixConGADT [HsScaled GhcRn (LHsKind GhcRn)]
arg_tys
| OccName -> Bool
isSymOcc (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
con)
, [GenLocated SrcSpanAnnA (HsType GhcRn)
_ty1,GenLocated SrcSpanAnnA (HsType GhcRn)
_ty2] <- (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated SrcSpanAnnA (HsType GhcRn))
-> [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> GenLocated SrcSpanAnnA (HsType GhcRn)
forall pass a. HsScaled pass a -> a
hsScaledThing [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
[HsScaled GhcRn (LHsKind GhcRn)]
arg_tys
-> do { FixityEnv
fix_env <- TcRn FixityEnv
getFixityEnv
; Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
con Name -> FixityEnv -> Bool
forall a. Name -> NameEnv a -> Bool
`elemNameEnv` FixityEnv
fix_env) }
| Bool
otherwise -> Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
tcConH98Args :: ContextKind
-> HsConDeclH98Details GhcRn
-> TcM [(Scaled TcType, HsSrcBang)]
tcConH98Args :: ContextKind
-> HsConDeclH98Details GhcRn -> TcM [(Scaled Type, HsSrcBang)]
tcConH98Args ContextKind
exp_kind (PrefixCon [Void]
_ [HsScaled GhcRn (LHsKind GhcRn)]
btys)
= (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Type, HsSrcBang))
-> [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
-> TcM [(Scaled Type, HsSrcBang)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ContextKind
-> HsScaled GhcRn (LHsKind GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Type, HsSrcBang)
tcConArg ContextKind
exp_kind) [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
[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)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Type, HsSrcBang)
tcConArg ContextKind
exp_kind HsScaled GhcRn (LHsKind GhcRn)
bty1
; (Scaled Type, HsSrcBang)
bty2' <- ContextKind
-> HsScaled GhcRn (LHsKind GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Type, HsSrcBang)
tcConArg ContextKind
exp_kind HsScaled GhcRn (LHsKind GhcRn)
bty2
; [(Scaled Type, HsSrcBang)] -> TcM [(Scaled Type, HsSrcBang)]
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 LocatedL [LConDeclField GhcRn]
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)
= (HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Type, HsSrcBang))
-> [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
-> TcM [(Scaled Type, HsSrcBang)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ContextKind
-> HsScaled GhcRn (LHsKind GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Type, HsSrcBang)
tcConArg ContextKind
exp_kind) [HsScaled GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))]
[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 LocatedL [LConDeclField GhcRn]
XRec GhcRn [LConDeclField GhcRn]
fields
tcConArg :: ContextKind
-> HsScaled GhcRn (LHsType GhcRn) -> TcM (Scaled TcType, HsSrcBang)
tcConArg :: ContextKind
-> HsScaled GhcRn (LHsKind GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Type, HsSrcBang)
tcConArg ContextKind
exp_kind (HsScaled HsArrow GhcRn
w LHsKind GhcRn
bty)
= do { String -> SDoc -> TcRn ()
traceTc String
"tcConArg 1" (GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsType GhcRn)
LHsKind GhcRn
bty)
; Type
arg_ty <- LHsKind GhcRn -> ContextKind -> TcM Type
tcCheckLHsType (LHsKind GhcRn -> LHsKind GhcRn
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" (GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsType GhcRn)
LHsKind GhcRn
bty)
; (Scaled Type, HsSrcBang)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Type, HsSrcBang)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
w' Type
arg_ty, LHsKind GhcRn -> HsSrcBang
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
= (HsScaled GhcRn (LHsKind GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Type, HsSrcBang))
-> [HsScaled GhcRn (LHsKind GhcRn)]
-> TcM [(Scaled Type, HsSrcBang)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ContextKind
-> HsScaled GhcRn (LHsKind GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled Type, HsSrcBang)
tcConArg ContextKind
exp_kind) [HsScaled GhcRn (LHsKind GhcRn)]
btys
where
combined :: [([XRec GhcRn (FieldOcc GhcRn)], HsScaled GhcRn (LHsKind GhcRn))]
combined = (GenLocated SrcSpanAnnA (ConDeclField GhcRn)
-> ([XRec GhcRn (FieldOcc GhcRn)], HsScaled GhcRn (LHsKind GhcRn)))
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> [([XRec GhcRn (FieldOcc GhcRn)],
HsScaled GhcRn (LHsKind GhcRn))]
forall a b. (a -> b) -> [a] -> [b]
map (\(L SrcSpanAnnA
_ ConDeclField GhcRn
f) -> (ConDeclField GhcRn -> [XRec GhcRn (FieldOcc GhcRn)]
forall pass. ConDeclField pass -> [LFieldOcc pass]
cd_fld_names ConDeclField GhcRn
f,LHsKind GhcRn -> HsScaled GhcRn (LHsKind GhcRn)
forall a pass. a -> HsScaled pass a
hsLinear (ConDeclField GhcRn -> LHsKind GhcRn
forall pass. ConDeclField pass -> LBangType pass
cd_fld_type ConDeclField GhcRn
f)))
(GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
-> [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
forall l e. GenLocated l e -> e
unLoc GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcRn)]
LocatedL [LConDeclField GhcRn]
fields)
explode :: ([a], b) -> [(a, b)]
explode ([a]
ns,b
ty) = [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
ns (b -> [b]
forall a. a -> [a]
repeat b
ty)
exploded :: [(XRec GhcRn (FieldOcc GhcRn), HsScaled GhcRn (LHsKind GhcRn))]
exploded = (([XRec GhcRn (FieldOcc GhcRn)], HsScaled GhcRn (LHsKind GhcRn))
-> [(XRec GhcRn (FieldOcc GhcRn), HsScaled GhcRn (LHsKind GhcRn))])
-> [([XRec GhcRn (FieldOcc GhcRn)],
HsScaled GhcRn (LHsKind GhcRn))]
-> [(XRec GhcRn (FieldOcc GhcRn), HsScaled GhcRn (LHsKind GhcRn))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([XRec GhcRn (FieldOcc GhcRn)], HsScaled GhcRn (LHsKind GhcRn))
-> [(XRec GhcRn (FieldOcc GhcRn), HsScaled GhcRn (LHsKind GhcRn))]
forall {a} {b}. ([a], b) -> [(a, b)]
explode [([XRec GhcRn (FieldOcc GhcRn)], HsScaled GhcRn (LHsKind GhcRn))]
combined
([XRec GhcRn (FieldOcc GhcRn)]
_,[HsScaled GhcRn (LHsKind GhcRn)]
btys) = [(XRec GhcRn (FieldOcc GhcRn), HsScaled GhcRn (LHsKind GhcRn))]
-> ([XRec GhcRn (FieldOcc GhcRn)],
[HsScaled GhcRn (LHsKind GhcRn)])
forall a b. [(a, b)] -> ([a], [b])
unzip [(XRec GhcRn (FieldOcc GhcRn), HsScaled GhcRn (LHsKind GhcRn))]
exploded
tcDataConMult :: HsArrow GhcRn -> TcM Mult
tcDataConMult :: HsArrow GhcRn -> TcM Type
tcDataConMult arr :: HsArrow GhcRn
arr@(HsUnrestrictedArrow IsUnicodeSyntax
_) = do
Bool
linearEnabled <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
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 Type -> TcM Type
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 [TyVar] -> [TyVar] -> [TyVar]
forall a. Ord a => [a] -> [a] -> [a]
`minusList` [TyVar]
univ_tvs
(TCvSubst
arg_subst, [TyVar]
substed_ex_tvs) = HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])
substTyVarBndrs TCvSubst
kind_subst [TyVar]
raw_ex_tvs
subst_user_tvs :: [VarBndr TyVar Specificity] -> [VarBndr TyVar Specificity]
subst_user_tvs = (TyVar -> TyVar)
-> [VarBndr TyVar Specificity] -> [VarBndr TyVar Specificity]
forall var var' flag.
(var -> var') -> [VarBndr var flag] -> [VarBndr var' flag]
mapVarBndrs (String -> Type -> TyVar
getTyVar String
"rejigConRes" (Type -> TyVar) -> (TyVar -> Type) -> TyVar -> TyVar
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 = (EqSpec -> EqSpec) -> [EqSpec] -> [EqSpec]
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 [TyVar] -> [TyVar] -> [TyVar]
forall a. Ord a => [a] -> [a] -> [a]
`minusList` [TyVar]
tc_tvs, [VarBndr TyVar Specificity]
dc_tvbndrs, [], TCvSubst
emptyTCvSubst)
where
dc_tvs :: [TyVar]
dc_tvs = [VarBndr TyVar Specificity] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TyVar Specificity]
dc_tvbndrs
tc_tvs :: [TyVar]
tc_tvs = [TyConBinder] -> [TyVar]
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 []
= ([TyVar] -> [TyVar]
forall a. [a] -> [a]
reverse [TyVar]
univs, [EqSpec] -> [EqSpec]
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 TyVar -> [TyVar] -> Bool
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
TCvSubst -> Type -> Type
substTy TCvSubst
t_sub (TyVar -> Type
tyVarKind TyVar
t_tv))
->
[TyVar]
-> [EqSpec]
-> TCvSubst
-> TCvSubst
-> [TyVar]
-> ([TyVar], [EqSpec], TCvSubst)
choose (TyVar
r_tvTyVar -> [TyVar] -> [TyVar]
forall 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'TyVar -> [TyVar] -> [TyVar]
forall a. a -> [a] -> [a]
:[TyVar]
univs) (TyVar -> Type -> EqSpec
mkEqSpec TyVar
t_tv' Type
r_ty EqSpec -> [EqSpec] -> [EqSpec]
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
TCvSubst -> Type -> Type
substTy TCvSubst
t_sub) TyVar
t_tv
| Bool
otherwise
= String -> SDoc -> ([TyVar], [EqSpec], TCvSubst)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkGADTVars" ([TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tmpl_tvs SDoc -> SDoc -> SDoc
$$ TCvSubst -> 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 (Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique Name
r_tv_name)
| Bool
otherwise
= Name
r_tv_name
where
r_tv_name :: Name
r_tv_name = TyVar -> Name
forall a. NamedThing a => a -> Name
getName TyVar
r_tv
t_tv_name :: Name
t_tv_name = TyVar -> Name
forall a. NamedThing a => a -> Name
getName TyVar
t_tv
checkValidTyCl :: TyCon -> TcM [TyCon]
checkValidTyCl :: TyCon -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
checkValidTyCl TyCon
tc
= SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (TyCon -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyCon
tc) (IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon])
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall a b. (a -> b) -> a -> b
$
TyCon
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall a. TyCon -> TcM a -> TcM a
addTyConCtxt TyCon
tc (IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon])
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall a b. (a -> b) -> a -> b
$
IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall r. TcRn r -> TcRn r -> TcRn r
recoverM IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
recovery_code (IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon])
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
-> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"Starting validity for tycon" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; TyCon -> TcRn ()
checkValidTyCon TyCon
tc
; String -> SDoc -> TcRn ()
traceTc String
"Done validity for tycon" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; [TyCon] -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon
tc] }
where
recovery_code :: IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
recovery_code
= do { String -> SDoc -> TcRn ()
traceTc String
"Aborted validity for tycon" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; [TyCon] -> IOEnv (Env TcGblEnv TcLclEnv) [TyCon]
forall (m :: * -> *) a. Monad m => a -> m a
return ((TyCon -> TyCon) -> [TyCon] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map TyCon -> TyCon
mk_fake_tc ([TyCon] -> [TyCon]) -> [TyCon] -> [TyCon]
forall a b. (a -> b) -> a -> b
$
TyCon
tc TyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
: TyCon -> [TyCon]
child_tycons TyCon
tc) }
mk_fake_tc :: TyCon -> TyCon
mk_fake_tc TyCon
tc
| TyCon -> Bool
isClassTyCon TyCon
tc = TyCon
tc
| Bool
otherwise = TyCon -> TyCon
makeRecoveryTyCon TyCon
tc
child_tycons :: TyCon -> [TyCon]
child_tycons TyCon
tc = TyCon -> [TyCon]
tyConATs TyCon
tc [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ (DataCon -> TyCon) -> [DataCon] -> [TyCon]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> TyCon
promoteDataCon (TyCon -> [DataCon]
tyConDataCons TyCon
tc)
checkValidTyCon :: TyCon -> TcM ()
checkValidTyCon :: TyCon -> TcRn ()
checkValidTyCon TyCon
tc
| TyCon -> Bool
isPrimTyCon TyCon
tc
= () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| TyCon -> Bool
forall thing. NamedThing thing => thing -> Bool
isWiredIn TyCon
tc
= String -> SDoc -> TcRn ()
traceTc String
"Skipping validity check for wired-in" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
| Bool
otherwise
= do { String -> SDoc -> TcRn ()
traceTc String
"checkValidTyCon" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
$$ Maybe Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Maybe Class
tyConClass_maybe TyCon
tc))
; if | Just Class
cl <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc
-> Class -> TcRn ()
checkValidClass Class
cl
| Just Type
syn_rhs <- TyCon -> Maybe Type
synTyConRhs_maybe TyCon
tc
-> do { UserTypeCtxt -> Type -> TcRn ()
checkValidType UserTypeCtxt
syn_ctxt Type
syn_rhs
; UserTypeCtxt -> Type -> TcRn ()
checkTySynRhs UserTypeCtxt
syn_ctxt Type
syn_rhs }
| Just FamTyConFlav
fam_flav <- TyCon -> Maybe FamTyConFlav
famTyConFlav_maybe TyCon
tc
-> case FamTyConFlav
fam_flav of
{ ClosedSynFamilyTyCon (Just CoAxiom Branched
ax)
-> TyCon -> TcRn () -> TcRn ()
forall a. TyCon -> TcM a -> TcM a
tcAddClosedTypeFamilyDeclCtxt TyCon
tc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
CoAxiom Branched -> TcRn ()
checkValidCoAxiom CoAxiom Branched
ax
; ClosedSynFamilyTyCon Maybe (CoAxiom Branched)
Nothing -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; FamTyConFlav
AbstractClosedSynFamilyTyCon ->
do { Bool
hsBoot <- TcRnIf TcGblEnv TcLclEnv Bool
tcIsHsBootOrSig
; Bool -> SDoc -> TcRn ()
checkTc Bool
hsBoot (SDoc -> TcRn ()) -> SDoc -> TcRn ()
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 {} -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; FamTyConFlav
OpenSynFamilyTyCon -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; BuiltInSynFamTyCon BuiltInSynFamily
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
| Bool
otherwise -> do
{
String -> SDoc -> TcRn ()
traceTc String
"cvtc1" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; UserTypeCtxt -> [Type] -> TcRn ()
checkValidTheta (Name -> UserTypeCtxt
DataTyCtxt Name
name) (TyCon -> [Type]
tyConStupidTheta TyCon
tc)
; String -> SDoc -> TcRn ()
traceTc String
"cvtc2" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Bool
existential_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ExistentialQuantification
; Bool
gadt_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
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
; (DataCon -> TcRn ()) -> [DataCon] -> TcRn ()
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
; (FieldLabel -> TcRn ()) -> [FieldLabel] -> TcRn ()
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)
; (NonEmpty (FieldLabel, DataCon) -> TcRn ())
-> [NonEmpty (FieldLabel, DataCon)] -> TcRn ()
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 = ((FieldLabel, DataCon) -> (FieldLabel, DataCon) -> Ordering)
-> [(FieldLabel, DataCon)] -> [NonEmpty (FieldLabel, DataCon)]
forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a]
equivClasses (FieldLabel, DataCon) -> (FieldLabel, DataCon) -> Ordering
forall {b} {b}. (FieldLabel, b) -> (FieldLabel, b) -> Ordering
cmp_fld ((DataCon -> [(FieldLabel, DataCon)])
-> [DataCon] -> [(FieldLabel, DataCon)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DataCon -> [(FieldLabel, DataCon)]
get_fields [DataCon]
data_cons)
cmp_fld :: (FieldLabel, b) -> (FieldLabel, b) -> Ordering
cmp_fld (FieldLabel
f1,b
_) (FieldLabel
f2,b
_) = 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 [FieldLabel] -> [DataCon] -> [(FieldLabel, DataCon)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` DataCon -> [DataCon]
forall a. a -> [a]
repeat DataCon
con
check_fields :: NonEmpty (FieldLabel, DataCon) -> TcRn ()
check_fields ((FieldLabel
label, DataCon
con1) :| [(FieldLabel, DataCon)]
other_fields)
= TcRn () -> TcRn () -> TcRn ()
forall r. TcRn r -> TcRn r -> TcRn r
recoverM (() -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ ((FieldLabel, DataCon) -> TcRn ())
-> [(FieldLabel, DataCon)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FieldLabel, DataCon) -> TcRn ()
checkOne [(FieldLabel, DataCon)]
other_fields
where
res1 :: Type
res1 = DataCon -> Type
dataConOrigResTy DataCon
con1
fty1 :: Type
fty1 = DataCon -> FieldLabelString -> Type
dataConFieldType DataCon
con1 FieldLabelString
lbl
lbl :: FieldLabelString
lbl = FieldLabel -> FieldLabelString
flLabel FieldLabel
label
checkOne :: (FieldLabel, DataCon) -> TcRn ()
checkOne (FieldLabel
_, DataCon
con2)
= do { FieldLabelString
-> DataCon -> DataCon -> Type -> Type -> Type -> Type -> TcRn ()
checkFieldCompat FieldLabelString
lbl DataCon
con1 DataCon
con2 Type
res1 Type
res2 Type
fty1 Type
fty2
; FieldLabelString
-> DataCon -> DataCon -> Type -> Type -> Type -> Type -> TcRn ()
checkFieldCompat FieldLabelString
lbl DataCon
con2 DataCon
con1 Type
res2 Type
res1 Type
fty2 Type
fty1 }
where
res2 :: Type
res2 = DataCon -> Type
dataConOrigResTy DataCon
con2
fty2 :: Type
fty2 = DataCon -> FieldLabelString -> Type
dataConFieldType DataCon
con2 FieldLabelString
lbl
checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM ()
checkPartialRecordField :: [DataCon] -> FieldLabel -> TcRn ()
checkPartialRecordField [DataCon]
all_cons FieldLabel
fld
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
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 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ_name)])
where
loc :: SrcSpan
loc = Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan (FieldLabel -> Name
flSelector FieldLabel
fld)
occ_name :: OccName
occ_name = FieldLabel -> OccName
forall name. HasOccName name => name -> OccName
occName FieldLabel
fld
([DataCon]
cons_with_field, [DataCon]
cons_without_field) = (DataCon -> Bool) -> [DataCon] -> ([DataCon], [DataCon])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition DataCon -> Bool
has_field [DataCon]
all_cons
has_field :: DataCon -> Bool
has_field DataCon
con = FieldLabel
fld FieldLabel -> [FieldLabel] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (DataCon -> [FieldLabel]
dataConFieldLabels DataCon
con)
is_exhaustive :: Bool
is_exhaustive = (DataCon -> Bool) -> [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([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 ((EqSpec -> (TyVar, Type)) -> [EqSpec] -> [(TyVar, Type)]
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 (Maybe TCvSubst -> Bool
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 (Maybe TCvSubst -> Bool
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 (String -> Maybe TCvSubst -> TCvSubst
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
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
con_loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn () -> TcRn ()
forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([GenLocated SrcSpanAnnN Name] -> SDoc
dataConCtxt [SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
con_loc) Name
con_name]) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
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
[ DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con, TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc, [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tc_tvs
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
res_ty_tmpl SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
res_ty_tmpl)
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
orig_res_ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
orig_res_ty)])
; Bool -> SDoc -> TcRn ()
checkTc (Maybe TCvSubst -> Bool
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" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
data_con_display_type)
; Type -> TcRn ()
checkValidMonoType Type
orig_res_ty
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TyCon -> Bool
isNewTyCon TyCon
tc) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcRn () -> TcRn ()
forall r. TcM r -> TcM r
checkNoErrs (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
(Type -> TcRn ()) -> [Type] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SDoc -> Type -> TcRn ()
checkForLevPoly SDoc
empty) ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing ([Scaled Type] -> [Type]) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ DataCon -> [Scaled Type]
dataConOrigArgTys DataCon
con)
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyCon -> Bool
isNewTyCon TyCon
tc) (DataCon -> TcRn ()
checkNewDataCon DataCon
con)
; UserTypeCtxt -> Type -> TcRn ()
checkValidType UserTypeCtxt
ctxt Type
data_con_display_type
; Bool -> SDoc -> TcRn ()
checkTc (Bool
existential_ok Bool -> Bool -> Bool
|| DataCon -> Bool
isVanillaDataCon DataCon
con)
(DataCon -> SDoc
badExistential DataCon
con)
; HscEnv
hsc_env <- IOEnv (Env TcGblEnv TcLclEnv) HscEnv
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)
, HomeUnit -> Bool
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
= () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; (HsSrcBang -> HsImplBang -> Arity -> TcRn ())
-> [HsSrcBang] -> [HsImplBang] -> [Arity] -> TcRn ()
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..]
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugIsOn (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
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
= [TyVar] -> Set TyVar
forall a. Ord a => [a] -> Set a
Set.fromList ([EqSpec] -> [TyVar] -> [TyVar]
filterEqSpec [EqSpec]
eq_spec [TyVar]
univs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
exs)
Set TyVar -> Set TyVar -> Bool
forall a. Eq a => a -> a -> Bool
== [TyVar] -> Set TyVar
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" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con
, String -> SDoc
text String
"Datacon wrapper type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DataCon -> Type
dataConWrapperType DataCon
con)
, String -> SDoc
text String
"Datacon rep type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DataCon -> Type
dataConRepType DataCon
con)
, String -> SDoc
text String
"Datacon display type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
data_con_display_type
, String -> SDoc
text String
"Rep typcon binders:" SDoc -> SDoc -> SDoc
<+> [TyConBinder] -> 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]
_) -> [TyConBinder] -> SDoc
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 (DataCon -> SDoc
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 ([Scaled Type] -> Bool
forall a. [a] -> Bool
isSingleton [Scaled Type]
arg_tys) (DataCon -> Arity -> SDoc
newtypeFieldErr DataCon
con ([Scaled Type] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Scaled Type]
arg_tys))
; Bool
unlifted_newtypes <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
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
Type -> Maybe Bool
isLiftedType_maybe (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
arg_ty1) Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
; Bool -> SDoc -> TcRn ()
checkTc Bool
allowedArgType (SDoc -> TcRn ()) -> SDoc -> TcRn ()
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 (DynFlags -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> TcRnIf TcGblEnv TcLclEnv Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let check_con :: Bool -> SDoc -> TcRn ()
check_con Bool
what SDoc
msg =
Bool -> SDoc -> TcRn ()
checkTc Bool
what (SDoc
msg SDoc -> SDoc -> SDoc
$$ DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> 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 (Scaled Type -> Type
forall a. Scaled a -> Type
scaledMult Scaled Type
arg_ty1)) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"A newtype constructor must be linear"
; Bool -> SDoc -> TcRn ()
check_con ([EqSpec] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EqSpec]
eq_spec) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
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 ([Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
theta) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
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 ([TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
ex_tvs) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"A newtype constructor cannot have existential type variables"
; Bool -> SDoc -> TcRn ()
checkTc ((HsSrcBang -> Bool) -> [HsSrcBang] -> Bool
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 <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ConstrainedClassMethods
; Bool
multi_param_type_classes <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.MultiParamTypeClasses
; Bool
nullary_type_classes <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.NullaryTypeClasses
; Bool
fundep_classes <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.FunctionalDependencies
; Bool
undecidable_super_classes <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
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 Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
1 Bool -> Bool -> Bool
||
(Bool
nullary_type_classes Bool -> Bool -> Bool
&& Arity
cls_arity Arity -> Arity -> Bool
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
|| [([TyVar], [TyVar])] -> 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
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
undecidable_super_classes (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
case Class -> Maybe SDoc
checkClassCycles Class
cls of
Just SDoc
err -> SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Class -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Class
cls) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
addErrTc SDoc
err
Maybe SDoc
Nothing -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; TcRn () -> TcRn ()
whenNoErrs (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
((TyVar, DefMethInfo) -> TcRn ())
-> [(TyVar, DefMethInfo)] -> TcRn ()
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
; (ClassATItem -> TcRn ()) -> [ClassATItem] -> TcRn ()
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 = [TyVar] -> 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)
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (TyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
sel_id) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn () -> TcRn ()
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (TyVar -> Type -> SDoc
classOpCtxt TyVar
sel_id Type
op_ty) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
{ String -> SDoc -> TcRn ()
traceTc String
"class op type" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
op_ty)
; UserTypeCtxt -> Type -> TcRn ()
checkValidType UserTypeCtxt
ctxt Type
op_ty
; SDoc -> Type -> TcRn ()
checkForLevPoly SDoc
empty Type
tau1
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
constrained_class_methods (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
(Type -> TcRn ()) -> [Type] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Type -> TcRn ()
check_constraint ([Type] -> [Type]
forall a. [a] -> [a]
tail (Type
cls_predType -> [Type] -> [Type]
forall 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
= Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (VarSet -> Bool
isEmptyVarSet VarSet
pred_tvs) Bool -> Bool -> Bool
&&
VarSet
pred_tvs VarSet -> VarSet -> Bool
`subVarSet` VarSet
cls_tv_set)
(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 Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
0 Bool -> Bool -> Bool
|| (TyVar -> Bool) -> [TyVar] -> 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)
; Maybe (Type, ATValidityInfo)
-> ((Type, ATValidityInfo) -> TcRn ()) -> TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust Maybe (Type, ATValidityInfo)
m_dflt_rhs (((Type, ATValidityInfo) -> TcRn ()) -> TcRn ())
-> ((Type, ATValidityInfo) -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \ (Type
rhs, ATValidityInfo
at_validity_info) ->
case ATValidityInfo
at_validity_info of
ATValidityInfo
NoATVI -> () -> TcRn ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ATVI SrcSpan
loc [Type]
pats ->
SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> Name -> TcRn () -> TcRn ()
forall a. SDoc -> Name -> TcM a -> TcM a
tcAddFamInstCtxt (String -> SDoc
text String
"default type instance") (TyCon -> Name
forall a. NamedThing a => a -> Name
getName TyCon
fam_tc) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do { TyCon -> [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)))
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
dm_name) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
let cls_pred :: Type
cls_pred = Class -> [Type] -> Type
mkClassPred Class
cls ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ [TyVar] -> [Type]
mkTyVarTys ([TyVar] -> [Type]) -> [TyVar] -> [Type]
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" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"vanilla_phi_ty" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
vanilla_phi_ty
, String -> SDoc
text String
"dm_phi_ty" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
dm_phi_ty ]
Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust (Maybe TCvSubst -> Bool) -> Maybe TCvSubst -> Bool
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]) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ SDoc -> TcRn ()
addErrTc (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"The default type signature for"
SDoc -> SDoc -> SDoc
<+> TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
sel_id SDoc -> SDoc -> SDoc
<> SDoc
colon)
Arity
2 (Type -> SDoc
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
_ = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkFamFlag :: Name -> TcM ()
checkFamFlag :: Name -> TcRn ()
checkFamFlag Name
tc_name
= do { Bool
idx_tys <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
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 (Name -> SDoc
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 <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TypeFamilyDependencies
; Bool -> SDoc -> TcRn ()
checkTc Bool
ty_fam_deps (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Illegal result type variable" SDoc -> SDoc -> SDoc
<+> GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
LHsTyVarBndr () GhcRn
tvb SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
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
_ = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM ()
checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcRn ()
checkValidRoleAnnots RoleAnnotEnv
role_annots TyCon
tc
| TyCon -> Bool
isTypeSynonymTyCon TyCon
tc = TcRn ()
check_no_roles
| TyCon -> Bool
isFamilyTyCon TyCon
tc = TcRn ()
check_no_roles
| TyCon -> Bool
isAlgTyCon TyCon
tc = TcRn ()
check_roles
| Bool
otherwise = () -> TcRn ()
forall (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) = [(Role, TyVar)] -> ([Role], [TyVar])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Role, TyVar)] -> ([Role], [TyVar]))
-> [(Role, TyVar)] -> ([Role], [TyVar])
forall a b. (a -> b) -> a -> b
$ ((Role, TyConBinder) -> Maybe (Role, TyVar))
-> [(Role, TyConBinder)] -> [(Role, TyVar)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Role, TyConBinder) -> Maybe (Role, TyVar)
pick_vis ([(Role, TyConBinder)] -> [(Role, TyVar)])
-> [(Role, TyConBinder)] -> [(Role, TyVar)]
forall a b. (a -> b) -> a -> b
$
[Role] -> [TyConBinder] -> [(Role, TyConBinder)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Role]
roles (TyCon -> [TyConBinder]
tyConBinders TyCon
tc)
role_annot_decl_maybe :: Maybe (LRoleAnnotDecl GhcRn)
role_annot_decl_maybe = RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl GhcRn)
lookupRoleAnnot RoleAnnotEnv
role_annots Name
name
pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar)
pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar)
pick_vis (Role
role, TyConBinder
tvb)
| TyConBinder -> Bool
forall tv. VarBndr tv TyConBndrVis -> Bool
isVisibleTyConBinder TyConBinder
tvb = (Role, TyVar) -> Maybe (Role, TyVar)
forall a. a -> Maybe a
Just (Role
role, TyConBinder -> TyVar
forall tv argf. VarBndr tv argf -> tv
binderVar TyConBinder
tvb)
| Bool
otherwise = Maybe (Role, TyVar)
forall a. Maybe a
Nothing
check_roles :: TcRn ()
check_roles
= Maybe (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn))
-> (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn) -> TcRn ())
-> TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust Maybe (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn))
Maybe (LRoleAnnotDecl GhcRn)
role_annot_decl_maybe ((GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn) -> TcRn ())
-> TcRn ())
-> (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn) -> TcRn ())
-> TcRn ()
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)) ->
Name -> TcRn () -> TcRn ()
forall a. Name -> TcM a -> TcM a
addRoleAnnotCtxt Name
name (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SrcSpanAnnA -> TcRn () -> TcRn ()
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
{ Bool
role_annots_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.RoleAnnotations
; Bool -> SDoc -> TcRn ()
checkTc Bool
role_annots_ok (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TyCon -> SDoc
needXRoleAnnotations TyCon
tc
; Bool -> SDoc -> TcRn ()
checkTc ([TyVar]
vis_vars [TyVar] -> [GenLocated SrcSpan (Maybe Role)] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [GenLocated SrcSpan (Maybe Role)]
[XRec GhcRn (Maybe Role)]
the_role_annots)
([TyVar] -> LRoleAnnotDecl GhcRn -> SDoc
forall a. [a] -> LRoleAnnotDecl GhcRn -> SDoc
wrongNumberOfRoles [TyVar]
vis_vars GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn)
LRoleAnnotDecl GhcRn
decl)
; [()]
_ <- (TyVar -> GenLocated SrcSpan (Maybe Role) -> Role -> TcRn ())
-> [TyVar]
-> [GenLocated SrcSpan (Maybe Role)]
-> [Role]
-> IOEnv (Env TcGblEnv TcLclEnv) [()]
forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]
zipWith3M TyVar -> GenLocated SrcSpan (Maybe Role) -> Role -> TcRn ()
checkRoleAnnot [TyVar]
vis_vars [GenLocated SrcSpan (Maybe Role)]
[XRec GhcRn (Maybe Role)]
the_role_annots [Role]
vis_roles
; Bool
incoherent_roles_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ TyCon -> Bool
isClassTyCon TyCon
tc)
Bool -> Bool -> Bool
|| ((Role -> Bool) -> [Role] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Nominal) [Role]
vis_roles))
SDoc
incoherentRoles
; Bool
lint <- GeneralFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_DoCoreLinting
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
lint (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ TyCon -> TcRn ()
checkValidRoles TyCon
tc }
check_no_roles :: TcRn ()
check_no_roles
= Maybe (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn))
-> (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn) -> TcRn ())
-> TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust Maybe (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn))
Maybe (LRoleAnnotDecl GhcRn)
role_annot_decl_maybe GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn) -> TcRn ()
LRoleAnnotDecl GhcRn -> TcRn ()
illegalRoleAnnotDecl
checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM ()
checkRoleAnnot :: TyVar -> GenLocated SrcSpan (Maybe Role) -> Role -> TcRn ()
checkRoleAnnot TyVar
_ (L SrcSpan
_ Maybe Role
Nothing) Role
_ = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkRoleAnnot TyVar
tv (L SrcSpan
_ (Just Role
r1)) Role
r2
= Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Role
r1 Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
/= Role
r2) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
addErrTc (SDoc -> TcRn ()) -> SDoc -> TcRn ()
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
= (DataCon -> TcRn ()) -> [DataCon] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DataCon -> TcRn ()
check_dc_roles (TyCon -> [DataCon]
tyConDataCons TyCon
tc)
| Just Type
rhs <- TyCon -> Maybe Type
synTyConRhs_maybe TyCon
tc
= VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles ([TyVar] -> [Role] -> VarEnv Role
forall a. [TyVar] -> [a] -> VarEnv a
zipVarEnv (TyCon -> [TyVar]
tyConTyVars TyCon
tc) (TyCon -> [Role]
tyConRoles TyCon
tc)) Role
Representational Type
rhs
| Bool
otherwise
= () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
check_dc_roles :: DataCon -> TcRn ()
check_dc_roles DataCon
datacon
= do { String -> SDoc -> TcRn ()
traceTc String
"check_dc_roles" (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
datacon SDoc -> SDoc -> SDoc
<+> [Role] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [Role]
tyConRoles TyCon
tc))
; (Type -> TcRn ()) -> [Type] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
role_env Role
Representational) ([Type] -> TcRn ()) -> [Type] -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[EqSpec] -> [Type]
eqSpecPreds [EqSpec]
eq_spec [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
theta [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
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 :: VarEnv Role
univ_roles = [TyVar] -> [Role] -> VarEnv Role
forall a. [TyVar] -> [a] -> VarEnv a
zipVarEnv [TyVar]
univ_tvs (TyCon -> [Role]
tyConRoles TyCon
tc)
ex_roles :: VarEnv Role
ex_roles = [(TyVar, Role)] -> VarEnv Role
forall a. [(TyVar, a)] -> VarEnv a
mkVarEnv ((TyVar -> (TyVar, Role)) -> [TyVar] -> [(TyVar, Role)]
forall a b. (a -> b) -> [a] -> [b]
map (, Role
Nominal) [TyVar]
ex_tvs)
role_env :: VarEnv Role
role_env = VarEnv Role
univ_roles VarEnv Role -> VarEnv Role -> VarEnv Role
forall a. VarEnv a -> VarEnv a -> VarEnv a
`plusVarEnv` VarEnv Role
ex_roles
check_ty_roles :: VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
role Type
ty
| Just Type
ty' <- Type -> Maybe Type
coreView Type
ty
= VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
role Type
ty'
check_ty_roles VarEnv Role
env Role
role (TyVarTy TyVar
tv)
= case VarEnv Role -> TyVar -> Maybe Role
forall a. VarEnv a -> TyVar -> Maybe a
lookupVarEnv VarEnv Role
env TyVar
tv of
Just Role
role' -> Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Role
role' Role -> Role -> Bool
`ltRole` Role
role Bool -> Bool -> Bool
|| Role
role' Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
role) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
report_error (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"type variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
tv) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"cannot have role" SDoc -> SDoc -> SDoc
<+> Role -> 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
<+> Role -> SDoc
forall a. Outputable a => a -> SDoc
ppr Role
role'
Maybe Role
Nothing -> SDoc -> TcRn ()
report_error (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"type variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
tv) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"missing in environment"
check_ty_roles VarEnv Role
env Role
Representational (TyConApp TyCon
tc [Type]
tys)
= let roles' :: [Role]
roles' = TyCon -> [Role]
tyConRoles TyCon
tc in
(Role -> Type -> TcRn ()) -> [Role] -> [Type] -> TcRn ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (VarEnv Role -> Role -> Type -> TcRn ()
maybe_check_ty_roles VarEnv Role
env) [Role]
roles' [Type]
tys
check_ty_roles VarEnv Role
env Role
Nominal (TyConApp TyCon
_ [Type]
tys)
= (Type -> TcRn ()) -> [Type] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
Nominal) [Type]
tys
check_ty_roles VarEnv Role
_ Role
Phantom ty :: Type
ty@(TyConApp {})
= String -> SDoc -> TcRn ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"check_ty_roles" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
check_ty_roles VarEnv Role
env Role
role (AppTy Type
ty1 Type
ty2)
= VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
role Type
ty1
TcRn () -> TcRn () -> TcRn ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
Nominal Type
ty2
check_ty_roles VarEnv Role
env Role
role (FunTy AnonArgFlag
_ Type
w Type
ty1 Type
ty2)
= VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
Nominal Type
w
TcRn () -> TcRn () -> TcRn ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
role Type
ty1
TcRn () -> TcRn () -> TcRn ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
role Type
ty2
check_ty_roles VarEnv Role
env Role
role (ForAllTy (Bndr TyVar
tv ArgFlag
_) Type
ty)
= VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
Nominal (TyVar -> Type
tyVarKind TyVar
tv)
TcRn () -> TcRn () -> TcRn ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles (VarEnv Role -> TyVar -> Role -> VarEnv Role
forall a. VarEnv a -> TyVar -> a -> VarEnv a
extendVarEnv VarEnv Role
env TyVar
tv Role
Nominal) Role
role Type
ty
check_ty_roles VarEnv Role
_ Role
_ (LitTy {}) = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check_ty_roles VarEnv Role
env Role
role (CastTy Type
t Coercion
_)
= VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
role Type
t
check_ty_roles VarEnv Role
_ Role
role (CoercionTy Coercion
co)
= Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Role
role Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Phantom) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
report_error (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"coercion" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has bad role" SDoc -> SDoc -> SDoc
<+> Role -> SDoc
forall a. Outputable a => a -> SDoc
ppr Role
role
maybe_check_ty_roles :: VarEnv Role -> Role -> Type -> TcRn ()
maybe_check_ty_roles VarEnv Role
env Role
role Type
ty
= Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Role
role Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Nominal Bool -> Bool -> Bool
|| Role
role Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Representational) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
VarEnv Role -> Role -> Type -> TcRn ()
check_ty_roles VarEnv Role
env Role
role Type
ty
report_error :: SDoc -> TcRn ()
report_error SDoc
doc
= SDoc -> TcRn ()
addErrTc (SDoc -> TcRn ()) -> SDoc -> TcRn ()
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", TyClDecl GhcRn -> SDoc
forall (p :: Pass). TyClDecl (GhcPass p) -> SDoc
pprTyClDeclFlavour TyClDecl GhcRn
decl,
String -> SDoc
text String
"declaration for", SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyClDecl GhcRn -> IdP GhcRn
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcRn
decl))]
addVDQNote :: TcTyCon -> TcM a -> TcM a
addVDQNote :: forall a. TyCon -> TcM a -> TcM a
addVDQNote TyCon
tycon TcM a
thing_inside
| ASSERT2( isTcTyCon tycon, ppr tycon )
ASSERT2( not (tcTyConIsPoly tycon), ppr tycon $$ ppr tc_kind )
Bool
has_vdq
= SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addLandmarkErrCtxt SDoc
vdq_warning TcM a
thing_inside
| Bool
otherwise
= TcM a
thing_inside
where
has_vdq :: Bool
has_vdq = (TyConBinder -> Bool) -> [TyConBinder] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TyConBinder -> Bool
is_vdq_tcb (TyCon -> [TyConBinder]
tyConBinders TyCon
tycon)
tc_kind :: Type
tc_kind = TyCon -> Type
tyConKind TyCon
tycon
kind_fvs :: VarSet
kind_fvs = Type -> VarSet
tyCoVarsOfType Type
tc_kind
is_vdq_tcb :: TyConBinder -> Bool
is_vdq_tcb TyConBinder
tcb = (TyConBinder -> TyVar
forall tv argf. VarBndr tv argf -> tv
binderVar TyConBinder
tcb TyVar -> VarSet -> Bool
`elemVarSet` VarSet
kind_fvs) Bool -> Bool -> Bool
&&
TyConBinder -> Bool
forall tv. VarBndr tv TyConBndrVis -> Bool
isVisibleTyConBinder TyConBinder
tcb
vdq_warning :: SDoc
vdq_warning = [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"NB: Type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
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
= SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (TyClDecl GhcRn -> SDoc
tcMkDeclCtxt TyClDecl GhcRn
decl) TcM a
thing_inside
tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a
tcAddTyFamInstCtxt :: forall a. TyFamInstDecl GhcRn -> TcM a -> TcM a
tcAddTyFamInstCtxt TyFamInstDecl GhcRn
decl
= SDoc -> Name -> TcM a -> TcM a
forall a. SDoc -> Name -> TcM a -> TcM a
tcAddFamInstCtxt (String -> SDoc
text String
"type instance") (TyFamInstDecl GhcRn -> IdP GhcRn
forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)
tyFamInstDeclName TyFamInstDecl GhcRn
decl)
tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc
tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc
tcMkDataFamInstCtxt decl :: DataFamInstDecl GhcRn
decl@(DataFamInstDecl { dfid_eqn :: forall pass. DataFamInstDecl pass -> FamEqn pass (HsDataDefn pass)
dfid_eqn = FamEqn GhcRn (HsDataDefn GhcRn)
eqn })
= SDoc -> Name -> SDoc
tcMkFamInstCtxt (DataFamInstDecl GhcRn -> SDoc
forall (p :: Pass). DataFamInstDecl (GhcPass p) -> SDoc
pprDataFamInstFlavour DataFamInstDecl GhcRn
decl SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"instance")
(GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc (FamEqn GhcRn (HsDataDefn GhcRn) -> LIdP GhcRn
forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon FamEqn GhcRn (HsDataDefn GhcRn)
eqn))
tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a
tcAddDataFamInstCtxt :: forall a. DataFamInstDecl GhcRn -> TcM a -> TcM a
tcAddDataFamInstCtxt DataFamInstDecl GhcRn
decl
= SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (DataFamInstDecl GhcRn -> SDoc
tcMkDataFamInstCtxt DataFamInstDecl GhcRn
decl)
tcMkFamInstCtxt :: SDoc -> Name -> SDoc
tcMkFamInstCtxt :: SDoc -> Name -> SDoc
tcMkFamInstCtxt SDoc
flavour Name
tycon
= [SDoc] -> SDoc
hsep [ String -> SDoc
text String
"In the" SDoc -> SDoc -> SDoc
<+> SDoc
flavour SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"declaration for"
, SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tycon) ]
tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a
tcAddFamInstCtxt :: forall a. SDoc -> Name -> TcM a -> TcM a
tcAddFamInstCtxt SDoc
flavour Name
tycon TcM a
thing_inside
= SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (SDoc -> Name -> SDoc
tcMkFamInstCtxt SDoc
flavour Name
tycon) TcM a
thing_inside
tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a
tcAddClosedTypeFamilyDeclCtxt :: forall a. TyCon -> TcM a -> TcM a
tcAddClosedTypeFamilyDeclCtxt TyCon
tc
= SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
ctxt
where
ctxt :: SDoc
ctxt = String -> SDoc
text String
"In the equations for closed type family" SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
quotes (TyCon -> SDoc
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
<+> DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con1 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"and" SDoc -> SDoc -> SDoc
<+> DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con2,
String -> SDoc
text String
"have a common field" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (FieldLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FieldLabelString
field_name) SDoc -> SDoc -> SDoc
<> SDoc
comma],
Arity -> SDoc -> SDoc
nest Arity
2 (SDoc -> SDoc) -> SDoc -> SDoc
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
<+> DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con1 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"and" SDoc -> SDoc -> SDoc
<+> DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con2,
String -> SDoc
text String
"give different types for field", SDoc -> SDoc
quotes (FieldLabelString -> SDoc
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
<> [GenLocated SrcSpanAnnN Name] -> 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
<> [GenLocated SrcSpanAnnN Name] -> 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 (GenLocated SrcSpanAnnN Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnN Name
con)
ppr_cons [GenLocated SrcSpanAnnN Name]
cons = [GenLocated SrcSpanAnnN Name] -> SDoc
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 (TyVar -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc TyVar
sel_id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> 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 Arity -> Arity -> Bool
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" parameters for class") SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls),
SDoc -> SDoc
parens (String -> SDoc
text (String
"Enable MultiParamTypeClasses to allow "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
allowWhat String -> String -> String
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 (Class -> SDoc
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 (Type -> SDoc
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 (TyVar -> SDoc
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 (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
hsep ((TyVar -> SDoc) -> [TyVar] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> SDoc
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 (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
clas SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
hsep ((TyVar -> SDoc) -> [TyVar] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> SDoc
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 (DataCon -> SDoc
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 (Type -> SDoc
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 (Type -> SDoc
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 (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
, Arity -> SDoc -> SDoc
nest Arity
2 (SDoc -> SDoc
parens (SDoc -> SDoc) -> SDoc -> SDoc
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
= (SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
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 (DataCon -> SDoc
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 [ DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Bool -> DataCon -> Type
dataConDisplayType Bool
show_linear_types DataCon
con)
, SDoc -> SDoc
parens (SDoc -> SDoc) -> SDoc -> SDoc
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 (Name -> SDoc
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 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"but" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
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 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"but" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (DataCon -> SDoc
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 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"but" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (DataCon -> SDoc
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 (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tc_name)
, Arity -> SDoc -> SDoc
nest Arity
2 (SDoc -> SDoc
parens (SDoc -> SDoc) -> SDoc -> SDoc
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 (Name -> SDoc
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 (SDoc -> SDoc) -> SDoc -> SDoc
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 = String -> SDoc -> SDoc
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"wrongKindOfFamily" (TyCon -> SDoc
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
<+> Arity -> 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
<+> Name -> 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", Role -> SDoc
forall a. Outputable a => a -> SDoc
ppr Role
annot
, String -> SDoc
text String
"but role", Role -> SDoc
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
<+> (Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Arity -> SDoc) -> Arity -> SDoc
forall a b. (a -> b) -> a -> b
$ [a] -> Arity
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
<+> (Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Arity -> SDoc) -> Arity -> SDoc
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpan (Maybe Role)] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [GenLocated SrcSpan (Maybe Role)]
[XRec GhcRn (Maybe Role)]
annots) SDoc -> SDoc -> SDoc
<> SDoc
colon)
Arity
2 (GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (RoleAnnotDecl GhcRn)
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)]
_))
= [ErrCtxt] -> TcRn () -> TcRn ()
forall a. [ErrCtxt] -> TcM a -> TcM a
setErrCtxt [] (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SrcSpanAnnA -> TcRn () -> TcRn ()
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
addErrTc (String -> SDoc
text String
"Illegal role annotation for" SDoc -> SDoc -> SDoc
<+> GenLocated SrcSpanAnnN Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnN Name
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
<+> TyCon -> 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
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
fam_tc_name
, String -> SDoc
text String
" Actual:" SDoc -> SDoc -> SDoc
<+> Name -> 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 = Name -> TyConFlavour -> TcM a -> TcM a
forall a. Name -> TyConFlavour -> TcM a -> TcM a
addTyConFlavCtxt Name
name TyConFlavour
flav
where
name :: Name
name = TyCon -> 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
= SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (SDoc -> TcM a -> TcM a) -> SDoc -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"while checking a role annotation for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)