{-# LANGUAGE CPP, TupleSections, MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module TcTyClsDecls (
tcTyAndClassDecls,
kcConDecl, tcConDecls, dataDeclChecks, checkValidTyCon,
tcFamTyPats, tcTyFamInstEqn,
tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,
unravelFamInstPats, addConsistencyConstraints,
wrongKindOfFamily
) where
#include "GhclibHsVersions.h"
import GhcPrelude
import HsSyn
import HscTypes
import BuildTyCl
import TcRnMonad
import TcEnv
import TcValidity
import TcHsSyn
import TcTyDecls
import TcClassDcl
import {-# SOURCE #-} TcInstDcls( tcInstDecls1 )
import TcDeriv (DerivInfo)
import TcHsType
import ClsInst( AssocInstInfo(..) )
import Inst( tcInstTyBinders )
import TcMType
import TysWiredIn ( unitTy )
import TcType
import RnEnv( lookupConstructorFields )
import FamInst
import FamInstEnv
import Coercion
import Type
import TyCoRep
import Class
import CoAxiom
import TyCon
import DataCon
import Id
import Var
import VarEnv
import VarSet
import Module
import Name
import NameSet
import NameEnv
import Outputable
import Maybes
import Unify
import Util
import SrcLoc
import ListSetOps
import DynFlags
import Unique
import ConLike( ConLike(..) )
import BasicTypes
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.List
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.Set as Set
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_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" ([Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((LTyClDecl GhcRn -> Name) -> [LTyClDecl GhcRn] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (TyClDecl GhcRn -> Name
forall pass. TyClDecl pass -> IdP pass
tcdName (TyClDecl GhcRn -> Name)
-> (LTyClDecl GhcRn -> TyClDecl GhcRn) -> LTyClDecl GhcRn -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LTyClDecl GhcRn -> TyClDecl GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LTyClDecl GhcRn]
tyclds))
; [TyCon]
tyclss <- [LTyClDecl GhcRn] -> RoleAnnotEnv -> TcM [TyCon]
tcTyClDecls [LTyClDecl GhcRn]
tyclds RoleAnnotEnv
role_annots
; String -> SDoc -> TcRn ()
traceTc String
"Starting synonym cycle check" ([TyCon] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCon]
tyclss)
; UnitId
this_uid <- (DynFlags -> UnitId)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> IOEnv (Env TcGblEnv TcLclEnv) UnitId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DynFlags -> UnitId
thisPackage IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; UnitId -> [TyCon] -> [LTyClDecl GhcRn] -> TcRn ()
checkSynCycles UnitId
this_uid [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 -> TcM [TyCon]) -> [TyCon] -> TcM [TyCon]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM TyCon -> TcM [TyCon]
checkValidTyCl [TyCon]
tyclss
; String -> SDoc -> TcRn ()
traceTc String
"Done validity check" ([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
-> 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 }
tcTyClGroup (XTyClGroup XXTyClGroup GhcRn
_) = String -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
forall a. String -> a
panic String
"tcTyClGroup"
tcTyClDecls :: [LTyClDecl GhcRn] -> RoleAnnotEnv -> TcM [TyCon]
tcTyClDecls :: [LTyClDecl GhcRn] -> RoleAnnotEnv -> TcM [TyCon]
tcTyClDecls [LTyClDecl GhcRn]
tyclds RoleAnnotEnv
role_annots
= NameEnv TcTyThing -> TcM [TyCon] -> TcM [TyCon]
forall r. NameEnv TcTyThing -> TcM r -> TcM r
tcExtendKindEnv NameEnv TcTyThing
promotion_err_env (TcM [TyCon] -> TcM [TyCon]) -> TcM [TyCon] -> TcM [TyCon]
forall a b. (a -> b) -> a -> b
$
do {
[TyCon]
tc_tycons <- [LTyClDecl GhcRn] -> TcM [TyCon]
kcTyClGroup [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] -> TcM [TyCon]) -> TcM [TyCon]
forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM (([TyCon] -> TcM [TyCon]) -> TcM [TyCon])
-> ([TyCon] -> TcM [TyCon]) -> TcM [TyCon]
forall a b. (a -> b) -> a -> b
$ \ ~[TyCon]
rec_tyclss -> do
{ TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let roles :: Name -> [Role]
roles = HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role]
inferRoles (TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env) RoleAnnotEnv
role_annots [TyCon]
rec_tyclss
; [(Name, TyThing)] -> TcM [TyCon] -> TcM [TyCon]
forall r. [(Name, TyThing)] -> TcM r -> TcM r
tcExtendRecEnv ([TyCon] -> [TyCon] -> [(Name, TyThing)]
zipRecTyClss [TyCon]
tc_tycons [TyCon]
rec_tyclss) (TcM [TyCon] -> TcM [TyCon]) -> TcM [TyCon] -> TcM [TyCon]
forall a b. (a -> b) -> a -> b
$
[TyCon] -> TcM [TyCon] -> TcM [TyCon]
forall a. [TyCon] -> TcM a -> TcM a
tcExtendKindEnvWithTyCons [TyCon]
tc_tycons (TcM [TyCon] -> TcM [TyCon]) -> TcM [TyCon] -> TcM [TyCon]
forall a b. (a -> b) -> a -> b
$
(LTyClDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> [LTyClDecl GhcRn] -> TcM [TyCon]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Name -> [Role])
-> LTyClDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcTyClDecl Name -> [Role]
roles) [LTyClDecl GhcRn]
tyclds
} }
where
promotion_err_env :: NameEnv TcTyThing
promotion_err_env = [LTyClDecl GhcRn] -> NameEnv TcTyThing
mkPromotionErrorEnv [LTyClDecl GhcRn]
tyclds
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
, Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Kind
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 :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
kcTyClGroup :: [LTyClDecl GhcRn] -> TcM [TyCon]
kcTyClGroup [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 ((LTyClDecl GhcRn -> SDoc) -> [LTyClDecl GhcRn] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map LTyClDecl GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LTyClDecl GhcRn]
decls))
; let ([LTyClDecl GhcRn]
cusk_decls, [LTyClDecl GhcRn]
no_cusk_decls)
= (LTyClDecl GhcRn -> Bool)
-> [LTyClDecl GhcRn] -> ([LTyClDecl GhcRn], [LTyClDecl GhcRn])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (TyClDecl GhcRn -> Bool
hsDeclHasCusk (TyClDecl GhcRn -> Bool)
-> (LTyClDecl GhcRn -> TyClDecl GhcRn) -> LTyClDecl GhcRn -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LTyClDecl GhcRn -> TyClDecl GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [LTyClDecl GhcRn]
decls
; [TyCon]
poly_cusk_tcs <- Bool -> [LTyClDecl GhcRn] -> TcM [TyCon]
getInitialKinds Bool
True [LTyClDecl GhcRn]
cusk_decls
; [TyCon]
mono_tcs
<- [TyCon] -> TcM [TyCon] -> TcM [TyCon]
forall a. [TyCon] -> TcM a -> TcM a
tcExtendKindEnvWithTyCons [TyCon]
poly_cusk_tcs (TcM [TyCon] -> TcM [TyCon]) -> TcM [TyCon] -> TcM [TyCon]
forall a b. (a -> b) -> a -> b
$
TcM [TyCon] -> TcM [TyCon]
forall r. TcM r -> TcM r
pushTcLevelM_ (TcM [TyCon] -> TcM [TyCon]) -> TcM [TyCon] -> TcM [TyCon]
forall a b. (a -> b) -> a -> b
$
TcM [TyCon] -> TcM [TyCon]
forall r. TcM r -> TcM r
solveEqualities (TcM [TyCon] -> TcM [TyCon]) -> TcM [TyCon] -> TcM [TyCon]
forall a b. (a -> b) -> a -> b
$
do {
[TyCon]
mono_tcs <- Bool -> [LTyClDecl GhcRn] -> TcM [TyCon]
getInitialKinds Bool
False [LTyClDecl GhcRn]
no_cusk_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
; [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
$
(LTyClDecl GhcRn -> TcRn ()) -> [LTyClDecl GhcRn] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ LTyClDecl GhcRn -> TcRn ()
kcLTyClDecl [LTyClDecl GhcRn]
no_cusk_decls
; [TyCon] -> TcM [TyCon]
forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon]
mono_tcs }
; [TyCon]
poly_no_cusk_tcs <- (TyCon -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> [TyCon] -> TcM [TyCon]
forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM TyCon -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
generaliseTcTyCon [TyCon]
mono_tcs
; let poly_tcs :: [TyCon]
poly_tcs = [TyCon]
poly_cusk_tcs [TyCon] -> [TyCon] -> [TyCon]
forall a. [a] -> [a] -> [a]
++ [TyCon]
poly_no_cusk_tcs
; String -> SDoc -> TcRn ()
traceTc String
"---- kcTyClGroup end ---- }" ([TyCon] -> SDoc
ppr_tc_kinds [TyCon]
poly_tcs)
; [TyCon] -> TcM [TyCon]
forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon]
poly_tcs }
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
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Kind
tyConKind TyCon
tc)
generaliseTcTyCon :: TcTyCon -> TcM TcTyCon
generaliseTcTyCon :: TyCon -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
generaliseTcTyCon 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
$
do { let tc_name :: Name
tc_name = TyCon -> Name
tyConName TyCon
tc
tc_flav :: TyConFlavour
tc_flav = TyCon -> TyConFlavour
tyConFlavour TyCon
tc
tc_res_kind :: Kind
tc_res_kind = TyCon -> Kind
tyConResKind TyCon
tc
tc_tvs :: [TyVar]
tc_tvs = TyCon -> [TyVar]
tyConTyVars TyCon
tc
user_tyvars :: SDoc
user_tyvars = TyCon -> SDoc
tcTyConUserTyVars TyCon
tc
([Name]
scoped_tv_names, [TyVar]
scoped_tvs) = [(Name, TyVar)] -> ([Name], [TyVar])
forall a b. [(a, b)] -> ([a], [b])
unzip (TyCon -> [(Name, TyVar)]
tcTyConScopedTyVars TyCon
tc)
; CandidatesQTvs
dvs <- [Kind] -> TcM CandidatesQTvs
candidateQTyVarsOfKinds ([Kind] -> TcM CandidatesQTvs) -> [Kind] -> TcM CandidatesQTvs
forall a b. (a -> b) -> a -> b
$
(Kind
tc_res_kind Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
: (TyVar -> Kind) -> [TyVar] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Kind
tyVarKind [TyVar]
scoped_tvs)
; [TyVar]
tc_tvs <- (TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [TyVar] -> IOEnv (Env TcGblEnv TcLclEnv) [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]
tc_tvs
; let full_dvs :: CandidatesQTvs
full_dvs = CandidatesQTvs
dvs { dv_tvs :: DTyVarSet
dv_tvs = [TyVar] -> DTyVarSet
mkDVarSet [TyVar]
tc_tvs }
; [TyVar]
qtkvs <- TcTyCoVarSet
-> CandidatesQTvs -> IOEnv (Env TcGblEnv TcLclEnv) [TyVar]
quantifyTyVars TcTyCoVarSet
emptyVarSet CandidatesQTvs
full_dvs
; [TyVar]
scoped_tvs <- (TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [TyVar] -> IOEnv (Env TcGblEnv TcLclEnv) [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]
scoped_tvs
; [TyVar]
tc_tvs <- (TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [TyVar] -> IOEnv (Env TcGblEnv TcLclEnv) [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]
tc_tvs
; Kind
tc_res_kind <- Kind -> TcM Kind
zonkTcType Kind
tc_res_kind
; String -> SDoc -> TcRn ()
traceTc String
"Generalise kind pre" (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_tvs =" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
tc_tvs
, String -> SDoc
text String
"scoped_tvs =" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
scoped_tvs ]
; let qtkv_set :: TcTyCoVarSet
qtkv_set = [TyVar] -> TcTyCoVarSet
mkVarSet [TyVar]
qtkvs
tc_tv_set :: TcTyCoVarSet
tc_tv_set = [TyVar] -> TcTyCoVarSet
mkVarSet [TyVar]
tc_tvs
specified :: [TyVar]
specified = [TyVar] -> [TyVar]
scopedSort ([TyVar] -> [TyVar]) -> [TyVar] -> [TyVar]
forall a b. (a -> b) -> a -> b
$
[ TyVar
tv | TyVar
tv <- [TyVar]
scoped_tvs
, Bool -> Bool
not (TyVar
tv TyVar -> TcTyCoVarSet -> Bool
`elemVarSet` TcTyCoVarSet
tc_tv_set)
, TyVar
tv TyVar -> TcTyCoVarSet -> Bool
`elemVarSet` TcTyCoVarSet
qtkv_set ]
spec_req_set :: TcTyCoVarSet
spec_req_set = [TyVar] -> TcTyCoVarSet
mkVarSet [TyVar]
specified TcTyCoVarSet -> TcTyCoVarSet -> TcTyCoVarSet
`unionVarSet` TcTyCoVarSet
tc_tv_set
inferred :: [TyVar]
inferred = (TyVar -> Bool) -> [TyVar] -> [TyVar]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (TyVar -> TcTyCoVarSet -> Bool
`elemVarSet` TcTyCoVarSet
spec_req_set) [TyVar]
qtkvs
dep_fv_set :: TcTyCoVarSet
dep_fv_set = CandidatesQTvs -> TcTyCoVarSet
candidateKindVars CandidatesQTvs
dvs
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]
specified
required_tcbs :: [TyConBinder]
required_tcbs = (TyVar -> TyConBinder) -> [TyVar] -> [TyConBinder]
forall a b. (a -> b) -> [a] -> [b]
map (TcTyCoVarSet -> TyVar -> TyConBinder
mkRequiredTyConBinder TcTyCoVarSet
dep_fv_set) [TyVar]
tc_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 ]
scoped_tv_pairs :: [(Name, TyVar)]
scoped_tv_pairs = [Name]
scoped_tv_names [Name] -> [TyVar] -> [(Name, TyVar)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TyVar]
scoped_tvs
tycon :: TyCon
tycon = Name
-> SDoc
-> [TyConBinder]
-> Kind
-> [(Name, TyVar)]
-> Bool
-> TyConFlavour
-> TyCon
mkTcTyCon Name
tc_name SDoc
user_tyvars [TyConBinder]
final_tcbs Kind
tc_res_kind
[(Name, TyVar)]
scoped_tv_pairs
Bool
True
(TyCon -> TyConFlavour
tyConFlavour TyCon
tc)
; String -> SDoc -> TcRn ()
traceTc String
"Generalise kind" (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_tvs =" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
tc_tvs
, String -> SDoc
text String
"tc_res_kind =" SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
tc_res_kind
, String -> SDoc
text String
"scoped_tvs =" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
scoped_tvs
, String -> SDoc
text String
"inferred =" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
inferred
, String -> SDoc
text String
"specified =" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
specified
, 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 ]
; let floating_specified :: [TyVar]
floating_specified = (TyVar -> Bool) -> [TyVar] -> [TyVar]
forall a. (a -> Bool) -> [a] -> [a]
filter TyVar -> Bool
isTyVarTyVar [TyVar]
scoped_tvs
; Name -> TyConFlavour -> [TyVar] -> [TyVar] -> TcRn ()
reportFloatingKvs Name
tc_name TyConFlavour
tc_flav
[TyVar]
scoped_tvs [TyVar]
floating_specified
; ((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 ()
forall a a.
(NamedThing a, Outputable a, Outputable a) =>
(a, a) -> TcRn ()
report_sig_tv_err ([(Name, TyVar)] -> [(Name, Name)]
findDupTyVarTvs [(Name, TyVar)]
scoped_tv_pairs)
; TyCon -> TcRn ()
checkValidTelescope TyCon
tycon
; TyCon -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tycon }
where
report_sig_tv_err :: (a, a) -> TcRn ()
report_sig_tv_err (a
n1, a
n2)
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (a -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan a
n2) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
addErrTc (String -> SDoc
text String
"Couldn't match" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
n1)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"with" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
n2))
tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a
tcExtendKindEnvWithTyCons :: [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] -> NameEnv TcTyThing
mkPromotionErrorEnv [LTyClDecl GhcRn]
decls
= (LTyClDecl GhcRn -> NameEnv TcTyThing -> NameEnv TcTyThing)
-> NameEnv TcTyThing -> [LTyClDecl GhcRn] -> NameEnv TcTyThing
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NameEnv TcTyThing -> NameEnv TcTyThing -> NameEnv TcTyThing
forall a. NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv (NameEnv TcTyThing -> NameEnv TcTyThing -> NameEnv TcTyThing)
-> (LTyClDecl GhcRn -> NameEnv TcTyThing)
-> LTyClDecl GhcRn
-> NameEnv TcTyThing
-> NameEnv TcTyThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyClDecl GhcRn -> NameEnv TcTyThing
mk_prom_err_env (TyClDecl GhcRn -> NameEnv TcTyThing)
-> (LTyClDecl GhcRn -> TyClDecl GhcRn)
-> LTyClDecl GhcRn
-> NameEnv TcTyThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LTyClDecl GhcRn -> TyClDecl GhcRn
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc)
NameEnv TcTyThing
forall a. NameEnv a
emptyNameEnv [LTyClDecl GhcRn]
decls
mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv
mk_prom_err_env :: TyClDecl GhcRn -> NameEnv TcTyThing
mk_prom_err_env (ClassDecl { tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = L SrcSpan
_ IdP GhcRn
nm, tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs = [LFamilyDecl GhcRn]
ats })
= Name -> TcTyThing -> NameEnv TcTyThing
forall a. Name -> a -> NameEnv a
unitNameEnv IdP GhcRn
Name
nm (PromotionErr -> TcTyThing
APromotionErr PromotionErr
ClassPE)
NameEnv TcTyThing -> NameEnv TcTyThing -> NameEnv TcTyThing
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv`
[(Name, TcTyThing)] -> NameEnv TcTyThing
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (SrcSpanLess (Located Name)
Name
name, PromotionErr -> TcTyThing
APromotionErr PromotionErr
TyConPE)
| (LFamilyDecl GhcRn -> Located (SrcSpanLess (LFamilyDecl GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (FamilyDecl { fdLName = (dL->L _ name) })) <- [LFamilyDecl GhcRn]
ats ]
mk_prom_err_env (DataDecl { tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = (GenLocated SrcSpan (IdP GhcRn)
-> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located 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 -> NameEnv TcTyThing
forall a. Name -> a -> NameEnv a
unitNameEnv SrcSpanLess (Located Name)
Name
name (PromotionErr -> TcTyThing
APromotionErr PromotionErr
TyConPE)
NameEnv TcTyThing -> NameEnv TcTyThing -> NameEnv TcTyThing
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv`
[(Name, TcTyThing)] -> NameEnv TcTyThing
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [ (SrcSpanLess (Located Name)
Name
con, PromotionErr -> TcTyThing
APromotionErr PromotionErr
RecDataConPE)
| (LConDecl GhcRn -> Located (SrcSpanLess (LConDecl GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (LConDecl GhcRn)
con') <- [LConDecl GhcRn]
cons
, (Located Name -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located Name)
con) <- ConDecl GhcRn -> [GenLocated SrcSpan (IdP GhcRn)]
forall pass. ConDecl pass -> [Located (IdP pass)]
getConNames ConDecl GhcRn
SrcSpanLess (LConDecl GhcRn)
con' ]
mk_prom_err_env TyClDecl GhcRn
decl
= Name -> TcTyThing -> NameEnv TcTyThing
forall a. Name -> a -> NameEnv a
unitNameEnv (TyClDecl GhcRn -> IdP GhcRn
forall pass. TyClDecl pass -> IdP pass
tcdName TyClDecl GhcRn
decl) (PromotionErr -> TcTyThing
APromotionErr PromotionErr
TyConPE)
getInitialKinds :: Bool -> [LTyClDecl GhcRn] -> TcM [TcTyCon]
getInitialKinds :: Bool -> [LTyClDecl GhcRn] -> TcM [TyCon]
getInitialKinds Bool
cusk [LTyClDecl GhcRn]
decls
= do { String -> SDoc -> TcRn ()
traceTc String
"getInitialKinds {" SDoc
empty
; [TyCon]
tcs <- (LTyClDecl GhcRn -> TcM [TyCon])
-> [LTyClDecl GhcRn] -> TcM [TyCon]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ((SrcSpanLess (LTyClDecl GhcRn) -> TcM [TyCon])
-> LTyClDecl GhcRn -> TcM [TyCon]
forall a b. HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
addLocM (Bool -> TyClDecl GhcRn -> TcM [TyCon]
getInitialKind Bool
cusk)) [LTyClDecl GhcRn]
decls
; String -> SDoc -> TcRn ()
traceTc String
"getInitialKinds done }" SDoc
empty
; [TyCon] -> TcM [TyCon]
forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon]
tcs }
getInitialKind :: Bool -> TyClDecl GhcRn -> TcM [TcTyCon]
getInitialKind :: Bool -> TyClDecl GhcRn -> TcM [TyCon]
getInitialKind Bool
cusk
(ClassDecl { tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = GenLocated SrcSpan (IdP GhcRn)
-> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located 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
tycon <- Name
-> TyConFlavour
-> Bool
-> LHsQTyVars GhcRn
-> TcM Kind
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
kcLHsQTyVars SrcSpanLess (Located Name)
Name
name TyConFlavour
ClassFlavour Bool
cusk LHsQTyVars GhcRn
ktvs (TcM Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> TcM Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a b. (a -> b) -> a -> b
$
Kind -> TcM Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
constraintKind
; let parent_tv_prs :: [(Name, TyVar)]
parent_tv_prs = TyCon -> [(Name, TyVar)]
tcTyConScopedTyVars TyCon
tycon
; [TyCon]
inner_tcs <- [(Name, TyVar)] -> TcM [TyCon] -> TcM [TyCon]
forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, TyVar)]
parent_tv_prs (TcM [TyCon] -> TcM [TyCon]) -> TcM [TyCon] -> TcM [TyCon]
forall a b. (a -> b) -> a -> b
$
Maybe TyCon -> [LFamilyDecl GhcRn] -> TcM [TyCon]
getFamDeclInitialKinds (TyCon -> Maybe TyCon
forall a. a -> Maybe a
Just TyCon
tycon) [LFamilyDecl GhcRn]
ats
; [TyCon] -> TcM [TyCon]
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon
tycon TyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
: [TyCon]
inner_tcs) }
getInitialKind Bool
cusk
(DataDecl { tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = GenLocated SrcSpan (IdP GhcRn)
-> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located 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
; TyCon
tc <- Name
-> TyConFlavour
-> Bool
-> LHsQTyVars GhcRn
-> TcM Kind
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
kcLHsQTyVars SrcSpanLess (Located Name)
Name
name TyConFlavour
flav Bool
cusk LHsQTyVars GhcRn
ktvs (TcM Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> TcM Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a b. (a -> b) -> a -> b
$
case Maybe (LHsKind GhcRn)
m_sig of
Just LHsKind GhcRn
ksig -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind
tcLHsKindSig (Name -> UserTypeCtxt
DataKindCtxt SrcSpanLess (Located Name)
Name
name) LHsKind GhcRn
ksig
Maybe (LHsKind GhcRn)
Nothing -> Kind -> TcM Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
liftedTypeKind
; [TyCon] -> TcM [TyCon]
forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon
tc] }
getInitialKind Bool
_ (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl GhcRn
decl })
= do { TyCon
tc <- Maybe TyCon
-> FamilyDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
getFamDeclInitialKind Maybe TyCon
forall a. Maybe a
Nothing FamilyDecl GhcRn
decl
; [TyCon] -> TcM [TyCon]
forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon
tc] }
getInitialKind Bool
cusk (SynDecl { tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = GenLocated SrcSpan (IdP GhcRn)
-> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located 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 { TyCon
tycon <- Name
-> TyConFlavour
-> Bool
-> LHsQTyVars GhcRn
-> TcM Kind
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
kcLHsQTyVars SrcSpanLess (Located Name)
Name
name TyConFlavour
TypeSynonymFlavour Bool
cusk LHsQTyVars GhcRn
ktvs (TcM Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> TcM Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a b. (a -> b) -> a -> b
$
case LHsKind GhcRn -> Maybe (LHsKind GhcRn)
forall pass. LHsType pass -> Maybe (LHsType pass)
kind_annotation LHsKind GhcRn
rhs of
Just LHsKind GhcRn
ksig -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind
tcLHsKindSig (Name -> UserTypeCtxt
TySynKindCtxt SrcSpanLess (Located Name)
Name
name) LHsKind GhcRn
ksig
Maybe (LHsKind GhcRn)
Nothing -> TcM Kind
newMetaKindVar
; [TyCon] -> TcM [TyCon]
forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon
tycon] }
where
kind_annotation :: LHsType pass -> Maybe (LHsType pass)
kind_annotation (LHsType pass -> Located (SrcSpanLess (LHsType pass))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (LHsType pass)
ty) = case SrcSpanLess (LHsType pass)
ty of
HsParTy _ lty -> LHsType pass -> Maybe (LHsType pass)
kind_annotation LHsType pass
lty
HsKindSig _ _ k -> LHsType pass -> Maybe (LHsType pass)
forall a. a -> Maybe a
Just LHsType pass
k
SrcSpanLess (LHsType pass)
_ -> Maybe (LHsType pass)
forall a. Maybe a
Nothing
getInitialKind Bool
_ (DataDecl XDataDecl GhcRn
_ GenLocated SrcSpan (IdP GhcRn)
_ LHsQTyVars GhcRn
_ LexicalFixity
_ (XHsDataDefn XXHsDataDefn GhcRn
_)) = String -> TcM [TyCon]
forall a. String -> a
panic String
"getInitialKind"
getInitialKind Bool
_ (XTyClDecl XXTyClDecl GhcRn
_) = String -> TcM [TyCon]
forall a. String -> a
panic String
"getInitialKind"
getFamDeclInitialKinds
:: Maybe TcTyCon
-> [LFamilyDecl GhcRn]
-> TcM [TcTyCon]
getFamDeclInitialKinds :: Maybe TyCon -> [LFamilyDecl GhcRn] -> TcM [TyCon]
getFamDeclInitialKinds Maybe TyCon
mb_parent_tycon [LFamilyDecl GhcRn]
decls
= (LFamilyDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> [LFamilyDecl GhcRn] -> TcM [TyCon]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (LFamilyDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> LFamilyDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a b. HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
addLocM (Maybe TyCon
-> FamilyDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
getFamDeclInitialKind Maybe TyCon
mb_parent_tycon)) [LFamilyDecl GhcRn]
decls
getFamDeclInitialKind
:: Maybe TcTyCon
-> FamilyDecl GhcRn
-> TcM TcTyCon
getFamDeclInitialKind :: Maybe TyCon
-> FamilyDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
getFamDeclInitialKind Maybe TyCon
mb_parent_tycon
decl :: FamilyDecl GhcRn
decl@(FamilyDecl { fdLName :: forall pass. FamilyDecl pass -> Located (IdP pass)
fdLName = (GenLocated SrcSpan (IdP GhcRn)
-> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located Name)
name)
, fdTyVars :: forall pass. FamilyDecl pass -> LHsQTyVars pass
fdTyVars = LHsQTyVars GhcRn
ktvs
, fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdResultSig = (LFamilyResultSig GhcRn
-> Located (SrcSpanLess (LFamilyResultSig GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (LFamilyResultSig GhcRn)
resultSig)
, fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcRn
info })
= Name
-> TyConFlavour
-> Bool
-> LHsQTyVars GhcRn
-> TcM Kind
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
kcLHsQTyVars SrcSpanLess (Located Name)
Name
name TyConFlavour
flav Bool
cusk LHsQTyVars GhcRn
ktvs (TcM Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> TcM Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a b. (a -> b) -> a -> b
$
case SrcSpanLess (LFamilyResultSig GhcRn)
resultSig of
KindSig _ ki -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
ki
TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind
tcLHsKindSig UserTypeCtxt
ctxt LHsKind GhcRn
ki
SrcSpanLess (LFamilyResultSig GhcRn)
_
| TyConFlavour -> Bool
tcFlavourIsOpen TyConFlavour
flav -> Kind -> TcM Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
liftedTypeKind
| Bool
otherwise -> TcM Kind
newMetaKindVar
where
mb_cusk :: Maybe Bool
mb_cusk = TyCon -> Bool
tcTyConIsPoly (TyCon -> Bool) -> Maybe TyCon -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TyCon
mb_parent_tycon
cusk :: Bool
cusk = Maybe Bool -> FamilyDecl GhcRn -> Bool
forall pass. Maybe Bool -> FamilyDecl pass -> Bool
famDeclHasCusk Maybe Bool
mb_cusk FamilyDecl GhcRn
decl
flav :: TyConFlavour
flav = case FamilyInfo GhcRn
info of
FamilyInfo GhcRn
DataFamily -> Maybe TyCon -> TyConFlavour
DataFamilyFlavour Maybe TyCon
mb_parent_tycon
FamilyInfo GhcRn
OpenTypeFamily -> Maybe TyCon -> TyConFlavour
OpenTypeFamilyFlavour Maybe TyCon
mb_parent_tycon
ClosedTypeFamily Maybe [LTyFamInstEqn GhcRn]
_ -> ASSERT( isNothing mb_parent_tycon )
TyConFlavour
ClosedTypeFamilyFlavour
ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
TyFamResKindCtxt SrcSpanLess (Located Name)
Name
name
getFamDeclInitialKind Maybe TyCon
_ (XFamilyDecl XXFamilyDecl GhcRn
_) = String -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a. String -> a
panic String
"getFamDeclInitialKind"
kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()
kcLTyClDecl :: LTyClDecl GhcRn -> TcRn ()
kcLTyClDecl (LTyClDecl GhcRn -> Located (SrcSpanLess (LTyClDecl GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LTyClDecl GhcRn)
decl)
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TyClDecl GhcRn -> TcRn () -> TcRn ()
forall a. TyClDecl GhcRn -> TcM a -> TcM a
tcAddDeclCtxt TyClDecl GhcRn
SrcSpanLess (LTyClDecl GhcRn)
decl (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"kcTyClDecl {" (Located Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan (IdP GhcRn)
Located Name
tc_name)
; TyClDecl GhcRn -> TcRn ()
kcTyClDecl TyClDecl GhcRn
SrcSpanLess (LTyClDecl GhcRn)
decl
; String -> SDoc -> TcRn ()
traceTc String
"kcTyClDecl done }" (Located Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan (IdP GhcRn)
Located Name
tc_name) }
where
tc_name :: GenLocated SrcSpan (IdP GhcRn)
tc_name = TyClDecl GhcRn -> GenLocated SrcSpan (IdP GhcRn)
forall pass. TyClDecl pass -> Located (IdP pass)
tyClDeclLName TyClDecl GhcRn
SrcSpanLess (LTyClDecl GhcRn)
decl
kcTyClDecl :: TyClDecl GhcRn -> TcM ()
kcTyClDecl :: TyClDecl GhcRn -> TcRn ()
kcTyClDecl (DataDecl { tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = (GenLocated SrcSpan (IdP GhcRn)
-> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located Name)
name)
, tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn GhcRn
defn })
| HsDataDefn { dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons = cons :: [LConDecl GhcRn]
cons@((LConDecl GhcRn -> Located (SrcSpanLess (LConDecl GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (ConDeclGADT {})) : [LConDecl GhcRn]
_)
, dd_ctxt :: forall pass. HsDataDefn pass -> LHsContext pass
dd_ctxt = (LHsContext GhcRn -> Located (SrcSpanLess (LHsContext GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ []) } <- HsDataDefn GhcRn
defn
= (LConDecl GhcRn -> TcRn ()) -> [LConDecl GhcRn] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((SrcSpanLess (LConDecl GhcRn) -> TcRn ())
-> LConDecl GhcRn -> TcRn ()
forall a.
HasSrcSpan a =>
(SrcSpanLess a -> TcRn ()) -> a -> TcRn ()
wrapLocM_ ConDecl GhcRn -> TcRn ()
SrcSpanLess (LConDecl GhcRn) -> TcRn ()
kcConDecl) [LConDecl GhcRn]
cons
| HsDataDefn { dd_ctxt :: forall pass. HsDataDefn pass -> LHsContext pass
dd_ctxt = LHsContext GhcRn
ctxt, dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons = [LConDecl GhcRn]
cons } <- HsDataDefn GhcRn
defn
= Name -> ([TyConBinder] -> Kind -> TcRn ()) -> TcRn ()
forall a. Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a
bindTyClTyVars SrcSpanLess (Located Name)
Name
name (([TyConBinder] -> Kind -> TcRn ()) -> TcRn ())
-> ([TyConBinder] -> Kind -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
_ Kind
_ ->
do { [Kind]
_ <- LHsContext GhcRn -> TcM [Kind]
tcHsContext LHsContext GhcRn
ctxt
; (LConDecl GhcRn -> TcRn ()) -> [LConDecl GhcRn] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((SrcSpanLess (LConDecl GhcRn) -> TcRn ())
-> LConDecl GhcRn -> TcRn ()
forall a.
HasSrcSpan a =>
(SrcSpanLess a -> TcRn ()) -> a -> TcRn ()
wrapLocM_ ConDecl GhcRn -> TcRn ()
SrcSpanLess (LConDecl GhcRn) -> TcRn ()
kcConDecl) [LConDecl GhcRn]
cons }
kcTyClDecl (SynDecl { tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = GenLocated SrcSpan (IdP GhcRn)
-> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located Name)
name, tcdRhs :: forall pass. TyClDecl pass -> LHsType pass
tcdRhs = LHsKind GhcRn
rhs })
= Name -> ([TyConBinder] -> Kind -> TcRn ()) -> TcRn ()
forall a. Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a
bindTyClTyVars SrcSpanLess (Located Name)
Name
name (([TyConBinder] -> Kind -> TcRn ()) -> TcRn ())
-> ([TyConBinder] -> Kind -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
_ Kind
res_kind ->
TcM Kind -> TcRn ()
forall a. TcM a -> TcRn ()
discardResult (TcM Kind -> TcRn ()) -> TcM Kind -> TcRn ()
forall a b. (a -> b) -> a -> b
$ LHsKind GhcRn -> Kind -> TcM Kind
tcCheckLHsType LHsKind GhcRn
rhs Kind
res_kind
kcTyClDecl (ClassDecl { tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = (GenLocated SrcSpan (IdP GhcRn)
-> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located Name)
name)
, tcdCtxt :: forall pass. TyClDecl pass -> LHsContext pass
tcdCtxt = LHsContext GhcRn
ctxt, tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
tcdSigs = [LSig GhcRn]
sigs })
= Name -> ([TyConBinder] -> Kind -> TcRn ()) -> TcRn ()
forall a. Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a
bindTyClTyVars SrcSpanLess (Located Name)
Name
name (([TyConBinder] -> Kind -> TcRn ()) -> TcRn ())
-> ([TyConBinder] -> Kind -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
_ Kind
_ ->
do { [Kind]
_ <- LHsContext GhcRn -> TcM [Kind]
tcHsContext LHsContext GhcRn
ctxt
; (LSig GhcRn -> TcRn ()) -> [LSig GhcRn] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((SrcSpanLess (LSig GhcRn) -> TcRn ()) -> LSig GhcRn -> TcRn ()
forall a.
HasSrcSpan a =>
(SrcSpanLess a -> TcRn ()) -> a -> TcRn ()
wrapLocM_ Sig GhcRn -> TcRn ()
SrcSpanLess (LSig GhcRn) -> TcRn ()
kc_sig) [LSig GhcRn]
sigs }
where
kc_sig :: Sig GhcRn -> TcRn ()
kc_sig (ClassOpSig XClassOpSig GhcRn
_ Bool
_ [GenLocated SrcSpan (IdP GhcRn)]
nms LHsSigType GhcRn
op_ty) = SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcRn ()
kcClassSigType SkolemInfo
skol_info [GenLocated SrcSpan (IdP GhcRn)]
[Located Name]
nms LHsSigType GhcRn
op_ty
kc_sig Sig GhcRn
_ = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
skol_info :: SkolemInfo
skol_info = TyConFlavour -> Name -> SkolemInfo
TyConSkol TyConFlavour
ClassFlavour SrcSpanLess (Located Name)
Name
name
kcTyClDecl (FamDecl XFamDecl GhcRn
_ (FamilyDecl { fdLName :: forall pass. FamilyDecl pass -> Located (IdP pass)
fdLName = (GenLocated SrcSpan (IdP GhcRn)
-> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located Name)
fam_tc_name)
, fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcRn
fd_info }))
= case FamilyInfo GhcRn
fd_info of
ClosedTypeFamily (Just [LTyFamInstEqn GhcRn]
eqns) ->
do { TyCon
fam_tc <- Name -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
kcLookupTcTyCon SrcSpanLess (Located Name)
Name
fam_tc_name
; (LTyFamInstEqn GhcRn -> TcRn ())
-> [LTyFamInstEqn GhcRn] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TyCon -> LTyFamInstEqn GhcRn -> TcRn ()
kcTyFamInstEqn TyCon
fam_tc) [LTyFamInstEqn GhcRn]
eqns }
FamilyInfo GhcRn
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
kcTyClDecl (FamDecl XFamDecl GhcRn
_ (XFamilyDecl XXFamilyDecl GhcRn
_)) = String -> TcRn ()
forall a. String -> a
panic String
"kcTyClDecl"
kcTyClDecl (DataDecl XDataDecl GhcRn
_ GenLocated SrcSpan (IdP GhcRn)
_ LHsQTyVars GhcRn
_ LexicalFixity
_ (XHsDataDefn XXHsDataDefn GhcRn
_)) = String -> TcRn ()
forall a. String -> a
panic String
"kcTyClDecl"
kcTyClDecl (XTyClDecl XXTyClDecl GhcRn
_) = String -> TcRn ()
forall a. String -> a
panic String
"kcTyClDecl"
kcConDecl :: ConDecl GhcRn -> TcM ()
kcConDecl :: ConDecl GhcRn -> TcRn ()
kcConDecl (ConDeclH98 { con_name :: forall pass. ConDecl pass -> Located (IdP pass)
con_name = GenLocated SrcSpan (IdP GhcRn)
name, con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr pass]
con_ex_tvs = [LHsTyVarBndr 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 -> HsConDeclDetails pass
con_args = HsConDeclDetails GhcRn
args })
= SDoc -> TcRn () -> TcRn ()
forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([Located Name] -> SDoc
dataConCtxtName [GenLocated SrcSpan (IdP GhcRn)
Located Name
name]) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcM ([TyVar], ()) -> TcRn ()
forall a. TcM a -> TcRn ()
discardResult (TcM ([TyVar], ()) -> TcRn ()) -> TcM ([TyVar], ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[LHsTyVarBndr GhcRn] -> TcRn () -> TcM ([TyVar], ())
forall a. [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TyVar], a)
bindExplicitTKBndrs_Skol [LHsTyVarBndr GhcRn]
ex_tvs (TcRn () -> TcM ([TyVar], ())) -> TcRn () -> TcM ([TyVar], ())
forall a b. (a -> b) -> a -> b
$
do { [Kind]
_ <- Maybe (LHsContext GhcRn) -> TcM [Kind]
tcHsMbContext Maybe (LHsContext GhcRn)
ex_ctxt
; String -> SDoc -> TcRn ()
traceTc String
"kcConDecl {" (Located Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan (IdP GhcRn)
Located Name
name SDoc -> SDoc -> SDoc
$$ HsConDeclDetails GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsConDeclDetails GhcRn
args)
; (LHsKind GhcRn -> TcM Kind) -> [LHsKind GhcRn] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (LHsKind GhcRn -> TcM Kind
tcHsOpenType (LHsKind GhcRn -> TcM Kind)
-> (LHsKind GhcRn -> LHsKind GhcRn) -> LHsKind GhcRn -> TcM Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsKind GhcRn -> LHsKind GhcRn
forall a. LHsType a -> LHsType a
getBangType) (HsConDeclDetails GhcRn -> [LHsKind GhcRn]
forall pass. HsConDeclDetails pass -> [LBangType pass]
hsConDeclArgTys HsConDeclDetails GhcRn
args)
; String -> SDoc -> TcRn ()
traceTc String
"kcConDecl }" (Located Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan (IdP GhcRn)
Located Name
name)
}
kcConDecl (ConDeclGADT { con_names :: forall pass. ConDecl pass -> [Located (IdP pass)]
con_names = [GenLocated SrcSpan (IdP GhcRn)]
names
, con_qvars :: forall pass. ConDecl pass -> LHsQTyVars pass
con_qvars = LHsQTyVars GhcRn
qtvs, con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcRn)
cxt
, con_args :: forall pass. ConDecl pass -> HsConDeclDetails pass
con_args = HsConDeclDetails GhcRn
args, con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_res_ty = LHsKind GhcRn
res_ty })
| HsQTvs { hsq_ext :: forall pass. LHsQTyVars pass -> XHsQTvs pass
hsq_ext = HsQTvsRn { hsq_implicit = implicit_tkv_nms }
, hsq_explicit :: forall pass. LHsQTyVars pass -> [LHsTyVarBndr pass]
hsq_explicit = [LHsTyVarBndr GhcRn]
explicit_tkv_nms } <- LHsQTyVars GhcRn
qtvs
=
SDoc -> TcRn () -> TcRn ()
forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([Located Name] -> SDoc
dataConCtxtName [GenLocated SrcSpan (IdP GhcRn)]
[Located Name]
names) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcM ([TyVar], ([TyVar], ())) -> TcRn ()
forall a. TcM a -> TcRn ()
discardResult (TcM ([TyVar], ([TyVar], ())) -> TcRn ())
-> TcM ([TyVar], ([TyVar], ())) -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[Name] -> TcM ([TyVar], ()) -> TcM ([TyVar], ([TyVar], ()))
forall a. [Name] -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Tv [Name]
implicit_tkv_nms (TcM ([TyVar], ()) -> TcM ([TyVar], ([TyVar], ())))
-> TcM ([TyVar], ()) -> TcM ([TyVar], ([TyVar], ()))
forall a b. (a -> b) -> a -> b
$
[LHsTyVarBndr GhcRn] -> TcRn () -> TcM ([TyVar], ())
forall a. [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TyVar], a)
bindExplicitTKBndrs_Tv [LHsTyVarBndr GhcRn]
explicit_tkv_nms (TcRn () -> TcM ([TyVar], ())) -> TcRn () -> TcM ([TyVar], ())
forall a b. (a -> b) -> a -> b
$
do { [Kind]
_ <- Maybe (LHsContext GhcRn) -> TcM [Kind]
tcHsMbContext Maybe (LHsContext GhcRn)
cxt
; (LHsKind GhcRn -> TcM Kind) -> [LHsKind GhcRn] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (LHsKind GhcRn -> TcM Kind
tcHsOpenType (LHsKind GhcRn -> TcM Kind)
-> (LHsKind GhcRn -> LHsKind GhcRn) -> LHsKind GhcRn -> TcM Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsKind GhcRn -> LHsKind GhcRn
forall a. LHsType a -> LHsType a
getBangType) (HsConDeclDetails GhcRn -> [LHsKind GhcRn]
forall pass. HsConDeclDetails pass -> [LBangType pass]
hsConDeclArgTys HsConDeclDetails GhcRn
args)
; Kind
_ <- LHsKind GhcRn -> TcM Kind
tcHsOpenType LHsKind GhcRn
res_ty
; () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
kcConDecl (XConDecl XXConDecl GhcRn
_) = String -> TcRn ()
forall a. String -> a
panic String
"kcConDecl"
kcConDecl (ConDeclGADT XConDeclGADT GhcRn
_ [GenLocated SrcSpan (IdP GhcRn)]
_ Located Bool
_ (XLHsQTyVars XXLHsQTyVars GhcRn
_) Maybe (LHsContext GhcRn)
_ HsConDeclDetails GhcRn
_ LHsKind GhcRn
_ Maybe LHsDocString
_) = String -> TcRn ()
forall a. String -> a
panic String
"kcConDecl"
tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM TyCon
tcTyClDecl :: (Name -> [Role])
-> LTyClDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcTyClDecl Name -> [Role]
roles_info (LTyClDecl GhcRn -> Located (SrcSpanLess (LTyClDecl GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LTyClDecl GhcRn)
decl)
| Just TyThing
thing <- Name -> Maybe TyThing
wiredInNameTyThing_maybe (TyClDecl GhcRn -> IdP GhcRn
forall pass. TyClDecl pass -> IdP pass
tcdName TyClDecl GhcRn
SrcSpanLess (LTyClDecl GhcRn)
decl)
= case TyThing
thing of
ATyCon TyCon
tc -> TyCon -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tc
TyThing
_ -> String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcTyClDecl" (TyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyThing
thing)
| Bool
otherwise
= SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (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
$ TyClDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a. TyClDecl GhcRn -> TcM a -> TcM a
tcAddDeclCtxt TyClDecl GhcRn
SrcSpanLess (LTyClDecl GhcRn)
decl (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
"---- tcTyClDecl ---- {" (TyClDecl GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyClDecl GhcRn
SrcSpanLess (LTyClDecl GhcRn)
decl)
; TyCon
tc <- Maybe Class
-> (Name -> [Role])
-> TyClDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcTyClDecl1 Maybe Class
forall a. Maybe a
Nothing Name -> [Role]
roles_info TyClDecl GhcRn
SrcSpanLess (LTyClDecl GhcRn)
decl
; String -> SDoc -> TcRn ()
traceTc String
"---- tcTyClDecl end ---- }" (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 }
tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM TyCon
tcTyClDecl1 :: Maybe Class
-> (Name -> [Role])
-> TyClDecl GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcTyClDecl1 Maybe Class
parent Name -> [Role]
_roles_info (FamDecl { tcdFam :: forall pass. TyClDecl pass -> FamilyDecl pass
tcdFam = FamilyDecl GhcRn
fd })
= Maybe Class
-> FamilyDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcFamDecl1 Maybe Class
parent FamilyDecl GhcRn
fd
tcTyClDecl1 Maybe Class
_parent Name -> [Role]
roles_info
(SynDecl { tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = (GenLocated SrcSpan (IdP GhcRn)
-> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located Name)
tc_name)
, tcdRhs :: forall pass. TyClDecl pass -> LHsType pass
tcdRhs = LHsKind GhcRn
rhs })
= ASSERT( isNothing _parent )
Name
-> ([TyConBinder] -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a. Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a
bindTyClTyVars SrcSpanLess (Located Name)
Name
tc_name (([TyConBinder] -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> ([TyConBinder] -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
binders Kind
res_kind ->
(Name -> [Role])
-> Name
-> [TyConBinder]
-> Kind
-> LHsKind GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcTySynRhs Name -> [Role]
roles_info SrcSpanLess (Located Name)
Name
tc_name [TyConBinder]
binders Kind
res_kind LHsKind GhcRn
rhs
tcTyClDecl1 Maybe Class
_parent Name -> [Role]
roles_info
(DataDecl { tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = (GenLocated SrcSpan (IdP GhcRn)
-> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located Name)
tc_name)
, tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn GhcRn
defn })
= ASSERT( isNothing _parent )
Name
-> ([TyConBinder] -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a. Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a
bindTyClTyVars SrcSpanLess (Located Name)
Name
tc_name (([TyConBinder] -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> ([TyConBinder] -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
tycon_binders Kind
res_kind ->
(Name -> [Role])
-> Name
-> [TyConBinder]
-> Kind
-> HsDataDefn GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcDataDefn Name -> [Role]
roles_info SrcSpanLess (Located Name)
Name
tc_name [TyConBinder]
tycon_binders Kind
res_kind HsDataDefn GhcRn
defn
tcTyClDecl1 Maybe Class
_parent Name -> [Role]
roles_info
(ClassDecl { tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass)
tcdLName = (GenLocated SrcSpan (IdP GhcRn)
-> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located Name)
class_name)
, tcdCtxt :: forall pass. TyClDecl pass -> LHsContext pass
tcdCtxt = 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 -> [LTyFamDefltEqn pass]
tcdATDefs = [LTyFamDefltEqn GhcRn]
at_defs })
= ASSERT( isNothing _parent )
do { Class
clas <- (Name -> [Role])
-> Name
-> LHsContext GhcRn
-> LHsBinds GhcRn
-> [LHsFunDep GhcRn]
-> [LSig GhcRn]
-> [LFamilyDecl GhcRn]
-> [LTyFamDefltEqn GhcRn]
-> TcM Class
tcClassDecl1 Name -> [Role]
roles_info SrcSpanLess (Located Name)
Name
class_name LHsContext GhcRn
hs_ctxt
LHsBinds GhcRn
meths [LHsFunDep GhcRn]
fundeps [LSig GhcRn]
sigs [LFamilyDecl GhcRn]
ats [LTyFamDefltEqn GhcRn]
at_defs
; TyCon -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall (m :: * -> *) a. Monad m => a -> m a
return (Class -> TyCon
classTyCon Class
clas) }
tcTyClDecl1 Maybe Class
_ Name -> [Role]
_ (XTyClDecl XXTyClDecl GhcRn
_) = String -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a. String -> a
panic String
"tcTyClDecl1"
tcClassDecl1 :: RolesInfo -> Name -> LHsContext GhcRn
-> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn]
-> [LFamilyDecl GhcRn] -> [LTyFamDefltEqn GhcRn]
-> TcM Class
tcClassDecl1 :: (Name -> [Role])
-> Name
-> LHsContext GhcRn
-> LHsBinds GhcRn
-> [LHsFunDep GhcRn]
-> [LSig GhcRn]
-> [LFamilyDecl GhcRn]
-> [LTyFamDefltEqn GhcRn]
-> TcM Class
tcClassDecl1 Name -> [Role]
roles_info Name
class_name LHsContext GhcRn
hs_ctxt LHsBinds GhcRn
meths [LHsFunDep GhcRn]
fundeps [LSig GhcRn]
sigs [LFamilyDecl GhcRn]
ats [LTyFamDefltEqn GhcRn]
at_defs
= (Class -> TcM Class) -> TcM Class
forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM ((Class -> TcM Class) -> TcM Class)
-> (Class -> TcM Class) -> TcM Class
forall a b. (a -> b) -> a -> b
$ \ Class
clas ->
Name -> ([TyConBinder] -> Kind -> TcM Class) -> TcM Class
forall a. Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a
bindTyClTyVars Name
class_name (([TyConBinder] -> Kind -> TcM Class) -> TcM Class)
-> ([TyConBinder] -> Kind -> TcM Class) -> TcM Class
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
binders Kind
res_kind ->
do { MASSERT2( tcIsConstraintKind res_kind
, ppr class_name $$ ppr 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
; ([Kind]
ctxt, [([TyVar], [TyVar])]
fds, [TcMethInfo]
sig_stuff, [ClassATItem]
at_stuff)
<- TcM ([Kind], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
-> TcM ([Kind], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
forall r. TcM r -> TcM r
pushTcLevelM_ (TcM ([Kind], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
-> TcM ([Kind], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem]))
-> TcM ([Kind], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
-> TcM ([Kind], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
forall a b. (a -> b) -> a -> b
$
TcM ([Kind], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
-> TcM ([Kind], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
forall r. TcM r -> TcM r
solveEqualities (TcM ([Kind], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
-> TcM ([Kind], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem]))
-> TcM ([Kind], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
-> TcM ([Kind], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
forall a b. (a -> b) -> a -> b
$
do { [Kind]
ctxt <- LHsContext GhcRn -> TcM [Kind]
tcHsContext LHsContext GhcRn
hs_ctxt
; [([TyVar], [TyVar])]
fds <- (Located (FunDep (Located Name))
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], [TyVar]))
-> [Located (FunDep (Located Name))]
-> IOEnv (Env TcGblEnv TcLclEnv) [([TyVar], [TyVar])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SrcSpanLess (Located (FunDep (Located Name)))
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], [TyVar]))
-> Located (FunDep (Located Name))
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], [TyVar])
forall a b. HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
addLocM SrcSpanLess (Located (FunDep (Located Name)))
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], [TyVar])
forall (t :: * -> *) (t :: * -> *) a a.
(Traversable t, Traversable t, HasSrcSpan a, HasSrcSpan a,
SrcSpanLess a ~ Name, SrcSpanLess a ~ Name) =>
(t a, t a) -> IOEnv (Env TcGblEnv TcLclEnv) (t TyVar, t TyVar)
tc_fundep) [LHsFunDep GhcRn]
[Located (FunDep (Located Name))]
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]
-> [LTyFamDefltEqn GhcRn]
-> TcM [ClassATItem]
tcClassATs Name
class_name Class
clas [LFamilyDecl GhcRn]
ats [LTyFamDefltEqn GhcRn]
at_defs
; ([Kind], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
-> TcM ([Kind], [([TyVar], [TyVar])], [TcMethInfo], [ClassATItem])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Kind]
ctxt, [([TyVar], [TyVar])]
fds, [TcMethInfo]
sig_stuff, [ClassATItem]
at_stuff) }
; ZonkEnv
ze <- TcM ZonkEnv
emptyZonkEnv
; [Kind]
ctxt <- ZonkEnv -> [Kind] -> TcM [Kind]
zonkTcTypesToTypesX ZonkEnv
ze [Kind]
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 <- TcRn Bool
tcIsHsBootOrSig
; let body :: Maybe ([Kind], [ClassATItem], [TcMethInfo], ClassMinimalDef)
body | Bool
is_boot, [Kind] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Kind]
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 ([Kind], [ClassATItem], [TcMethInfo], ClassMinimalDef)
forall a. Maybe a
Nothing
| Bool
otherwise
= ([Kind], [ClassATItem], [TcMethInfo], ClassMinimalDef)
-> Maybe ([Kind], [ClassATItem], [TcMethInfo], ClassMinimalDef)
forall a. a -> Maybe a
Just ([Kind]
ctxt, [ClassATItem]
at_stuff, [TcMethInfo]
sig_stuff, ClassMinimalDef
mindef)
; Class
clas <- Name
-> [TyConBinder]
-> [Role]
-> [([TyVar], [TyVar])]
-> Maybe ([Kind], [ClassATItem], [TcMethInfo], ClassMinimalDef)
-> TcM Class
forall m n.
Name
-> [TyConBinder]
-> [Role]
-> [([TyVar], [TyVar])]
-> Maybe ([Kind], [ClassATItem], [TcMethInfo], ClassMinimalDef)
-> TcRnIf m n Class
buildClass Name
class_name [TyConBinder]
binders [Role]
roles [([TyVar], [TyVar])]
fds Maybe ([Kind], [ClassATItem], [TcMethInfo], ClassMinimalDef)
body
; String -> SDoc -> TcRn ()
traceTc String
"tcClassDecl" ([Located (FunDep (Located Name))] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsFunDep GhcRn]
[Located (FunDep (Located Name))]
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
tc_fundep :: (t a, t a) -> IOEnv (Env TcGblEnv TcLclEnv) (t TyVar, t TyVar)
tc_fundep (t a
tvs1, t a
tvs2) = do { t TyVar
tvs1' <- (a -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> t a -> IOEnv (Env TcGblEnv TcLclEnv) (t 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)
-> (a -> Name) -> a -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) t a
tvs1 ;
; t TyVar
tvs2' <- (a -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> t a -> IOEnv (Env TcGblEnv TcLclEnv) (t 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)
-> (a -> Name) -> a -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) t a
tvs2 ;
; (t TyVar, t TyVar)
-> IOEnv (Env TcGblEnv TcLclEnv) (t TyVar, t TyVar)
forall (m :: * -> *) a. Monad m => a -> m a
return (t TyVar
tvs1', t TyVar
tvs2') }
tcClassATs :: Name
-> Class
-> [LFamilyDecl GhcRn]
-> [LTyFamDefltEqn GhcRn]
-> TcM [ClassATItem]
tcClassATs :: Name
-> Class
-> [LFamilyDecl GhcRn]
-> [LTyFamDefltEqn GhcRn]
-> TcM [ClassATItem]
tcClassATs Name
class_name Class
cls [LFamilyDecl GhcRn]
ats [LTyFamDefltEqn 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 <- (LTyFamDefltEqn GhcRn -> Name) -> [LTyFamDefltEqn GhcRn] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LTyFamDefltEqn GhcRn -> Name
at_def_tycon [LTyFamDefltEqn GhcRn]
at_defs
, Bool -> Bool
not (Name
n Name -> NameSet -> Bool
`elemNameSet` NameSet
at_names) ]
; (LFamilyDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) ClassATItem)
-> [LFamilyDecl GhcRn] -> TcM [ClassATItem]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LFamilyDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) ClassATItem
tc_at [LFamilyDecl GhcRn]
ats }
where
at_def_tycon :: LTyFamDefltEqn GhcRn -> Name
at_def_tycon :: LTyFamDefltEqn GhcRn -> Name
at_def_tycon (LTyFamDefltEqn GhcRn
-> Located (SrcSpanLess (LTyFamDefltEqn GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (LTyFamDefltEqn GhcRn)
eqn) = Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (FamEqn GhcRn (LHsQTyVars GhcRn) (LHsKind GhcRn)
-> GenLocated SrcSpan (IdP GhcRn)
forall pass pats rhs. FamEqn pass pats rhs -> Located (IdP pass)
feqn_tycon FamEqn GhcRn (LHsQTyVars GhcRn) (LHsKind GhcRn)
SrcSpanLess (LTyFamDefltEqn GhcRn)
eqn)
at_fam_name :: LFamilyDecl GhcRn -> Name
at_fam_name :: LFamilyDecl GhcRn -> Name
at_fam_name (LFamilyDecl GhcRn -> Located (SrcSpanLess (LFamilyDecl GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (LFamilyDecl GhcRn)
decl) = Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (FamilyDecl GhcRn -> GenLocated SrcSpan (IdP GhcRn)
forall pass. FamilyDecl pass -> Located (IdP pass)
fdLName FamilyDecl GhcRn
SrcSpanLess (LFamilyDecl GhcRn)
decl)
at_names :: NameSet
at_names = [Name] -> NameSet
mkNameSet ((LFamilyDecl GhcRn -> Name) -> [LFamilyDecl GhcRn] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LFamilyDecl GhcRn -> Name
at_fam_name [LFamilyDecl GhcRn]
ats)
at_defs_map :: NameEnv [LTyFamDefltEqn GhcRn]
at_defs_map :: NameEnv [LTyFamDefltEqn GhcRn]
at_defs_map = (LTyFamDefltEqn GhcRn
-> NameEnv [LTyFamDefltEqn GhcRn]
-> NameEnv [LTyFamDefltEqn GhcRn])
-> NameEnv [LTyFamDefltEqn GhcRn]
-> [LTyFamDefltEqn GhcRn]
-> NameEnv [LTyFamDefltEqn GhcRn]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\LTyFamDefltEqn GhcRn
at_def NameEnv [LTyFamDefltEqn GhcRn]
nenv -> ([LTyFamDefltEqn GhcRn]
-> [LTyFamDefltEqn GhcRn] -> [LTyFamDefltEqn GhcRn])
-> NameEnv [LTyFamDefltEqn GhcRn]
-> Name
-> [LTyFamDefltEqn GhcRn]
-> NameEnv [LTyFamDefltEqn GhcRn]
forall a. (a -> a -> a) -> NameEnv a -> Name -> a -> NameEnv a
extendNameEnv_C [LTyFamDefltEqn GhcRn]
-> [LTyFamDefltEqn GhcRn] -> [LTyFamDefltEqn GhcRn]
forall a. [a] -> [a] -> [a]
(++) NameEnv [LTyFamDefltEqn GhcRn]
nenv
(LTyFamDefltEqn GhcRn -> Name
at_def_tycon LTyFamDefltEqn GhcRn
at_def) [LTyFamDefltEqn GhcRn
at_def])
NameEnv [LTyFamDefltEqn GhcRn]
forall a. NameEnv a
emptyNameEnv [LTyFamDefltEqn GhcRn]
at_defs
tc_at :: LFamilyDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) ClassATItem
tc_at LFamilyDecl GhcRn
at = do { TyCon
fam_tc <- (SrcSpanLess (LFamilyDecl GhcRn)
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> LFamilyDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a b. HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
addLocM (Maybe Class
-> FamilyDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcFamDecl1 (Class -> Maybe Class
forall a. a -> Maybe a
Just Class
cls)) LFamilyDecl GhcRn
at
; let at_defs :: [LTyFamDefltEqn GhcRn]
at_defs = NameEnv [LTyFamDefltEqn GhcRn]
-> Name -> Maybe [LTyFamDefltEqn GhcRn]
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv [LTyFamDefltEqn GhcRn]
at_defs_map (LFamilyDecl GhcRn -> Name
at_fam_name LFamilyDecl GhcRn
at)
Maybe [LTyFamDefltEqn GhcRn]
-> [LTyFamDefltEqn GhcRn] -> [LTyFamDefltEqn GhcRn]
forall a. Maybe a -> a -> a
`orElse` []
; Maybe (Kind, SrcSpan)
atd <- TyCon -> [LTyFamDefltEqn GhcRn] -> TcM (Maybe (Kind, SrcSpan))
tcDefaultAssocDecl TyCon
fam_tc [LTyFamDefltEqn GhcRn]
at_defs
; ClassATItem -> IOEnv (Env TcGblEnv TcLclEnv) ClassATItem
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> Maybe (Kind, SrcSpan) -> ClassATItem
ATI TyCon
fam_tc Maybe (Kind, SrcSpan)
atd) }
tcDefaultAssocDecl :: TyCon
-> [LTyFamDefltEqn GhcRn]
-> TcM (Maybe (KnotTied Type, SrcSpan))
tcDefaultAssocDecl :: TyCon -> [LTyFamDefltEqn GhcRn] -> TcM (Maybe (Kind, SrcSpan))
tcDefaultAssocDecl TyCon
_ []
= Maybe (Kind, SrcSpan) -> TcM (Maybe (Kind, SrcSpan))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Kind, SrcSpan)
forall a. Maybe a
Nothing
tcDefaultAssocDecl TyCon
_ (LTyFamDefltEqn GhcRn
d1:LTyFamDefltEqn GhcRn
_:[LTyFamDefltEqn GhcRn]
_)
= SDoc -> TcM (Maybe (Kind, SrcSpan))
forall a. SDoc -> TcM a
failWithTc (String -> SDoc
text String
"More than one default declaration for"
SDoc -> SDoc -> SDoc
<+> Located Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (FamEqn GhcRn (LHsQTyVars GhcRn) (LHsKind GhcRn)
-> GenLocated SrcSpan (IdP GhcRn)
forall pass pats rhs. FamEqn pass pats rhs -> Located (IdP pass)
feqn_tycon (LTyFamDefltEqn GhcRn -> SrcSpanLess (LTyFamDefltEqn GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LTyFamDefltEqn GhcRn
d1)))
tcDefaultAssocDecl TyCon
fam_tc [LTyFamDefltEqn GhcRn
-> Located (SrcSpanLess (LTyFamDefltEqn GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc (FamEqn { feqn_tycon = L _ tc_name
, feqn_pats = hs_tvs
, feqn_rhs = hs_rhs_ty })]
| HsQTvs { hsq_ext :: forall pass. LHsQTyVars pass -> XHsQTvs pass
hsq_ext = HsQTvsRn { hsq_implicit = imp_vars}
, hsq_explicit :: forall pass. LHsQTyVars pass -> [LHsTyVarBndr pass]
hsq_explicit = [LHsTyVarBndr GhcRn]
exp_vars } <- LHsQTyVars GhcRn
hs_tvs
=
SrcSpan
-> TcM (Maybe (Kind, SrcSpan)) -> TcM (Maybe (Kind, SrcSpan))
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (Maybe (Kind, SrcSpan)) -> TcM (Maybe (Kind, SrcSpan)))
-> TcM (Maybe (Kind, SrcSpan)) -> TcM (Maybe (Kind, SrcSpan))
forall a b. (a -> b) -> a -> b
$
SDoc
-> Name
-> TcM (Maybe (Kind, SrcSpan))
-> TcM (Maybe (Kind, SrcSpan))
forall a. SDoc -> Name -> TcM a -> TcM a
tcAddFamInstCtxt (String -> SDoc
text String
"default type instance") IdP GhcRn
Name
tc_name (TcM (Maybe (Kind, SrcSpan)) -> TcM (Maybe (Kind, SrcSpan)))
-> TcM (Maybe (Kind, SrcSpan)) -> TcM (Maybe (Kind, SrcSpan))
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcDefaultAssocDecl" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr IdP GhcRn
Name
tc_name)
; let fam_tc_name :: Name
fam_tc_name = TyCon -> Name
tyConName TyCon
fam_tc
fam_arity :: Int
fam_arity = [TyVar] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TyCon -> [TyVar]
tyConVisibleTyVars TyCon
fam_tc)
; 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 ([LHsTyVarBndr GhcRn]
exp_vars [LHsTyVarBndr GhcRn] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
fam_arity)
(Int -> SDoc
wrongNumberOfParmsErr Int
fam_arity)
; let hs_pats :: [HsArg (LHsKind GhcRn) (LHsKind GhcRn)]
hs_pats = (LHsTyVarBndr GhcRn -> HsArg (LHsKind GhcRn) (LHsKind GhcRn))
-> [LHsTyVarBndr GhcRn] -> [HsArg (LHsKind GhcRn) (LHsKind GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (LHsKind GhcRn -> HsArg (LHsKind GhcRn) (LHsKind GhcRn)
forall tm ty. tm -> HsArg tm ty
HsValArg (LHsKind GhcRn -> HsArg (LHsKind GhcRn) (LHsKind GhcRn))
-> (LHsTyVarBndr GhcRn -> LHsKind GhcRn)
-> LHsTyVarBndr GhcRn
-> HsArg (LHsKind GhcRn) (LHsKind GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsTyVarBndr GhcRn -> LHsKind GhcRn
forall (p :: Pass). LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p)
hsLTyVarBndrToType) [LHsTyVarBndr GhcRn]
exp_vars
; ([TyVar]
qtvs, [Kind]
pats, Kind
rhs_ty) <- TyCon
-> AssocInstInfo
-> [Name]
-> [LHsTyVarBndr GhcRn]
-> [HsArg (LHsKind GhcRn) (LHsKind GhcRn)]
-> LHsKind GhcRn
-> TcM ([TyVar], [Kind], Kind)
tcTyFamInstEqnGuts TyCon
fam_tc AssocInstInfo
NotAssociated
[Name]
imp_vars [LHsTyVarBndr GhcRn]
exp_vars
[HsArg (LHsKind GhcRn) (LHsKind GhcRn)]
hs_pats LHsKind GhcRn
hs_rhs_ty
; String -> SDoc -> TcRn ()
traceTc String
"tcDefault" ([SDoc] -> SDoc
vcat [[TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [TyVar]
tyConTyVars TyCon
fam_tc), [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
qtvs, [Kind] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Kind]
pats])
; case [Kind] -> [Kind] -> Maybe TCvSubst
tcMatchTys [Kind]
pats ([TyVar] -> [Kind]
mkTyVarTys (TyCon -> [TyVar]
tyConTyVars TyCon
fam_tc)) of
Just TCvSubst
subst -> Maybe (Kind, SrcSpan) -> TcM (Maybe (Kind, SrcSpan))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Kind, SrcSpan) -> Maybe (Kind, SrcSpan)
forall a. a -> Maybe a
Just (TCvSubst -> Kind -> Kind
substTyUnchecked TCvSubst
subst Kind
rhs_ty, SrcSpan
loc) )
Maybe TCvSubst
Nothing -> SDoc -> TcM (Maybe (Kind, SrcSpan))
forall a. SDoc -> TcM a
failWithTc (TyCon -> SDoc
defaultAssocKindErr TyCon
fam_tc)
}
tcDefaultAssocDecl TyCon
_ [LTyFamDefltEqn GhcRn
-> Located (SrcSpanLess (LTyFamDefltEqn GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (XFamEqn _)] = String -> TcM (Maybe (Kind, SrcSpan))
forall a. String -> a
panic String
"tcDefaultAssocDecl"
tcDefaultAssocDecl TyCon
_ [LTyFamDefltEqn GhcRn
-> Located (SrcSpanLess (LTyFamDefltEqn GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (FamEqn _ _ _ (XLHsQTyVars _) _ _)]
= String -> TcM (Maybe (Kind, SrcSpan))
forall a. String -> a
panic String
"tcDefaultAssocDecl"
tcDefaultAssocDecl TyCon
_ [LTyFamDefltEqn GhcRn
_]
= String -> TcM (Maybe (Kind, SrcSpan))
forall a. String -> a
panic String
"tcDefaultAssocDecl: Impossible Match"
tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon
tcFamDecl1 :: Maybe Class
-> FamilyDecl GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcFamDecl1 Maybe Class
parent (FamilyDecl { fdInfo :: forall pass. FamilyDecl pass -> FamilyInfo pass
fdInfo = FamilyInfo GhcRn
fam_info
, fdLName :: forall pass. FamilyDecl pass -> Located (IdP pass)
fdLName = tc_lname :: GenLocated SrcSpan (IdP GhcRn)
tc_lname@(GenLocated SrcSpan (IdP GhcRn)
-> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located Name)
tc_name)
, fdResultSig :: forall pass. FamilyDecl pass -> LFamilyResultSig pass
fdResultSig = (LFamilyResultSig GhcRn
-> Located (SrcSpanLess (LFamilyResultSig GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (LFamilyResultSig GhcRn)
sig)
, fdTyVars :: forall pass. FamilyDecl pass -> LHsQTyVars pass
fdTyVars = LHsQTyVars GhcRn
user_tyvars
, fdInjectivityAnn :: forall pass. FamilyDecl pass -> Maybe (LInjectivityAnn pass)
fdInjectivityAnn = Maybe (LInjectivityAnn GhcRn)
inj })
| FamilyInfo GhcRn
DataFamily <- FamilyInfo GhcRn
fam_info
= Name
-> ([TyConBinder] -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a. Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a
bindTyClTyVars SrcSpanLess (Located Name)
Name
tc_name (([TyConBinder] -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> ([TyConBinder] -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
binders Kind
res_kind -> do
{ String -> SDoc -> TcRn ()
traceTc String
"data family:" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess (Located Name)
Name
tc_name)
; Name -> TcRn ()
checkFamFlag SrcSpanLess (Located Name)
Name
tc_name
; let ([TyCoBinder]
_, Kind
final_res_kind) = Kind -> ([TyCoBinder], Kind)
splitPiTys Kind
res_kind
; Bool -> SDoc -> TcRn ()
checkTc (Kind -> Bool
tcIsLiftedTypeKind Kind
final_res_kind
Bool -> Bool -> Bool
|| Maybe (TyVar, CoercionN) -> Bool
forall a. Maybe a -> Bool
isJust (Kind -> Maybe (TyVar, CoercionN)
tcGetCastedTyVar_maybe Kind
final_res_kind))
(Bool -> Kind -> SDoc
badKindSig Bool
False Kind
res_kind)
; Name
tc_rep_name <- Name -> TcRnIf TcGblEnv TcLclEnv Name
forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName SrcSpanLess (Located Name)
Name
tc_name
; let tycon :: TyCon
tycon = Name
-> [TyConBinder]
-> Kind
-> Maybe Name
-> FamTyConFlav
-> Maybe Class
-> Injectivity
-> TyCon
mkFamilyTyCon SrcSpanLess (Located Name)
Name
tc_name [TyConBinder]
binders
Kind
res_kind
(FamilyResultSig GhcRn -> Maybe (IdP GhcRn)
forall a. FamilyResultSig a -> Maybe (IdP a)
resultVariableName FamilyResultSig GhcRn
SrcSpanLess (LFamilyResultSig GhcRn)
sig)
(Name -> FamTyConFlav
DataFamilyTyCon Name
tc_rep_name)
Maybe Class
parent Injectivity
NotInjective
; TyCon -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tycon }
| FamilyInfo GhcRn
OpenTypeFamily <- FamilyInfo GhcRn
fam_info
= Name
-> ([TyConBinder] -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a. Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a
bindTyClTyVars SrcSpanLess (Located Name)
Name
tc_name (([TyConBinder] -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> ([TyConBinder] -> Kind -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
binders Kind
res_kind -> do
{ String -> SDoc -> TcRn ()
traceTc String
"open type family:" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess (Located Name)
Name
tc_name)
; Name -> TcRn ()
checkFamFlag SrcSpanLess (Located Name)
Name
tc_name
; Injectivity
inj' <- [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) -> TcM Injectivity
tcInjectivity [TyConBinder]
binders Maybe (LInjectivityAnn GhcRn)
inj
; let tycon :: TyCon
tycon = Name
-> [TyConBinder]
-> Kind
-> Maybe Name
-> FamTyConFlav
-> Maybe Class
-> Injectivity
-> TyCon
mkFamilyTyCon SrcSpanLess (Located Name)
Name
tc_name [TyConBinder]
binders Kind
res_kind
(FamilyResultSig GhcRn -> Maybe (IdP GhcRn)
forall a. FamilyResultSig a -> Maybe (IdP a)
resultVariableName FamilyResultSig GhcRn
SrcSpanLess (LFamilyResultSig GhcRn)
sig) FamTyConFlav
OpenSynFamilyTyCon
Maybe Class
parent Injectivity
inj'
; TyCon -> IOEnv (Env TcGblEnv TcLclEnv) 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 SrcSpanLess (Located Name)
Name
tc_name)
; (Injectivity
inj', [TyConBinder]
binders, Kind
res_kind)
<- Name
-> ([TyConBinder]
-> Kind -> TcM (Injectivity, [TyConBinder], Kind))
-> TcM (Injectivity, [TyConBinder], Kind)
forall a. Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a
bindTyClTyVars SrcSpanLess (Located Name)
Name
tc_name (([TyConBinder] -> Kind -> TcM (Injectivity, [TyConBinder], Kind))
-> TcM (Injectivity, [TyConBinder], Kind))
-> ([TyConBinder]
-> Kind -> TcM (Injectivity, [TyConBinder], Kind))
-> TcM (Injectivity, [TyConBinder], Kind)
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
binders Kind
res_kind ->
do { Injectivity
inj' <- [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) -> TcM Injectivity
tcInjectivity [TyConBinder]
binders Maybe (LInjectivityAnn GhcRn)
inj
; (Injectivity, [TyConBinder], Kind)
-> TcM (Injectivity, [TyConBinder], Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Injectivity
inj', [TyConBinder]
binders, Kind
res_kind) }
; Name -> TcRn ()
checkFamFlag SrcSpanLess (Located Name)
Name
tc_name
; case Maybe [LTyFamInstEqn GhcRn]
mb_eqns of
Maybe [LTyFamInstEqn GhcRn]
Nothing ->
TyCon -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> TyCon -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a b. (a -> b) -> a -> b
$ Name
-> [TyConBinder]
-> Kind
-> Maybe Name
-> FamTyConFlav
-> Maybe Class
-> Injectivity
-> TyCon
mkFamilyTyCon SrcSpanLess (Located Name)
Name
tc_name [TyConBinder]
binders Kind
res_kind
(FamilyResultSig GhcRn -> Maybe (IdP GhcRn)
forall a. FamilyResultSig a -> Maybe (IdP a)
resultVariableName FamilyResultSig GhcRn
SrcSpanLess (LFamilyResultSig GhcRn)
sig)
FamTyConFlav
AbstractClosedSynFamilyTyCon Maybe Class
parent
Injectivity
inj'
Just [LTyFamInstEqn GhcRn]
eqns -> do {
; let tc_fam_tc :: TyCon
tc_fam_tc = Name
-> SDoc
-> [TyConBinder]
-> Kind
-> [(Name, TyVar)]
-> Bool
-> TyConFlavour
-> TyCon
mkTcTyCon SrcSpanLess (Located Name)
Name
tc_name (LHsQTyVars GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsQTyVars GhcRn
user_tyvars) [TyConBinder]
binders Kind
res_kind
[] Bool
False
TyConFlavour
ClosedTypeFamilyFlavour
; [KnotTied CoAxBranch]
branches <- (LTyFamInstEqn GhcRn -> TcRn (KnotTied CoAxBranch))
-> [LTyFamInstEqn 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) [LTyFamInstEqn GhcRn]
eqns
; Name
co_ax_name <- Located Name -> [[Kind]] -> TcRnIf TcGblEnv TcLclEnv Name
newFamInstAxiomName GenLocated SrcSpan (IdP GhcRn)
Located Name
tc_lname []
; let mb_co_ax :: Maybe (CoAxiom Branched)
mb_co_ax
| [LTyFamInstEqn GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [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]
-> Kind
-> Maybe Name
-> FamTyConFlav
-> Maybe Class
-> Injectivity
-> TyCon
mkFamilyTyCon SrcSpanLess (Located Name)
Name
tc_name [TyConBinder]
binders Kind
res_kind (FamilyResultSig GhcRn -> Maybe (IdP GhcRn)
forall a. FamilyResultSig a -> Maybe (IdP a)
resultVariableName FamilyResultSig GhcRn
SrcSpanLess (LFamilyResultSig GhcRn)
sig)
(Maybe (CoAxiom Branched) -> FamTyConFlav
ClosedSynFamilyTyCon Maybe (CoAxiom Branched)
mb_co_ax) Maybe Class
parent Injectivity
inj'
; TyCon -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
fam_tc } }
| Bool
otherwise = String -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a. String -> a
panic String
"tcFamInst1"
tcFamDecl1 Maybe Class
_ (XFamilyDecl XXFamilyDecl GhcRn
_) = String -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a. String -> a
panic String
"tcFamDecl1"
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 (LInjectivityAnn GhcRn
-> Located (SrcSpanLess (LInjectivityAnn GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc (InjectivityAnn _ 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 <- (Located Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [Located Name] -> IOEnv (Env TcGblEnv TcLclEnv) [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)
-> (Located Name -> Name)
-> Located Name
-> IOEnv (Env TcGblEnv TcLclEnv) TyVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located Name -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [GenLocated SrcSpan (IdP GhcRn)]
[Located Name]
lInjNames
; [TyVar]
inj_tvs <- (TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [TyVar] -> IOEnv (Env TcGblEnv TcLclEnv) [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 :: TcTyCoVarSet
inj_ktvs = (TyVar -> Bool) -> TcTyCoVarSet -> TcTyCoVarSet
filterVarSet TyVar -> Bool
isTyVar (TcTyCoVarSet -> TcTyCoVarSet) -> TcTyCoVarSet -> TcTyCoVarSet
forall a b. (a -> b) -> a -> b
$
TcTyCoVarSet -> TcTyCoVarSet
closeOverKinds ([TyVar] -> TcTyCoVarSet
mkVarSet [TyVar]
inj_tvs)
; let inj_bools :: [Bool]
inj_bools = (TyVar -> Bool) -> [TyVar] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (TyVar -> TcTyCoVarSet -> Bool
`elemVarSet` TcTyCoVarSet
inj_ktvs) [TyVar]
tvs
; String -> SDoc -> TcRn ()
traceTc String
"tcInjectivity" ([SDoc] -> SDoc
vcat [ [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tvs, [Located Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpan (IdP GhcRn)]
[Located Name]
lInjNames, [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
inj_tvs
, TcTyCoVarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyCoVarSet
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
-> [TyConBinder] -> Kind
-> LHsType GhcRn -> TcM TyCon
tcTySynRhs :: (Name -> [Role])
-> Name
-> [TyConBinder]
-> Kind
-> LHsKind GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcTySynRhs Name -> [Role]
roles_info Name
tc_name [TyConBinder]
binders Kind
res_kind LHsKind GhcRn
hs_ty
= 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
$$ NameEnv TcTyThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcLclEnv -> NameEnv TcTyThing
tcl_env TcLclEnv
env))
; Kind
rhs_ty <- TcM Kind -> TcM Kind
forall r. TcM r -> TcM r
pushTcLevelM_ (TcM Kind -> TcM Kind) -> TcM Kind -> TcM Kind
forall a b. (a -> b) -> a -> b
$
TcM Kind -> TcM Kind
forall r. TcM r -> TcM r
solveEqualities (TcM Kind -> TcM Kind) -> TcM Kind -> TcM Kind
forall a b. (a -> b) -> a -> b
$
LHsKind GhcRn -> Kind -> TcM Kind
tcCheckLHsType LHsKind GhcRn
hs_ty Kind
res_kind
; Kind
rhs_ty <- Kind -> TcM Kind
zonkTcTypeToType Kind
rhs_ty
; let roles :: [Role]
roles = Name -> [Role]
roles_info Name
tc_name
tycon :: TyCon
tycon = Name -> [TyConBinder] -> Kind -> [Role] -> Kind -> TyCon
buildSynTyCon Name
tc_name [TyConBinder]
binders Kind
res_kind [Role]
roles Kind
rhs_ty
; TyCon -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tycon }
tcDataDefn :: RolesInfo -> Name
-> [TyConBinder] -> Kind
-> HsDataDefn GhcRn -> TcM TyCon
tcDataDefn :: (Name -> [Role])
-> Name
-> [TyConBinder]
-> Kind
-> HsDataDefn GhcRn
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcDataDefn Name -> [Role]
roles_info
Name
tc_name [TyConBinder]
tycon_binders Kind
res_kind
(HsDataDefn { dd_ND :: forall pass. HsDataDefn pass -> NewOrData
dd_ND = NewOrData
new_or_data, dd_cType :: forall pass. HsDataDefn pass -> Maybe (Located CType)
dd_cType = Maybe (Located CType)
cType
, dd_ctxt :: forall pass. HsDataDefn pass -> LHsContext pass
dd_ctxt = 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 })
= do { Bool
gadt_syntax <- Name
-> NewOrData -> LHsContext GhcRn -> [LConDecl GhcRn] -> TcRn Bool
dataDeclChecks Name
tc_name NewOrData
new_or_data LHsContext GhcRn
ctxt [LConDecl GhcRn]
cons
; TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; ([TyConBinder]
extra_bndrs, Kind
final_res_kind) <- [TyConBinder] -> Kind -> TcM ([TyConBinder], Kind)
etaExpandAlgTyCon [TyConBinder]
tycon_binders Kind
res_kind
; 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 -> [LConDecl GhcRn] -> Bool
forall a. HscSource -> [a] -> Bool
mk_permissive_kind HscSource
hsc_src [LConDecl GhcRn]
cons) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Bool -> SDoc -> TcRn ()
checkTc (Kind -> Bool
tcIsLiftedTypeKind Kind
final_res_kind) (Bool -> Kind -> SDoc
badKindSig Bool
True Kind
res_kind)
; [Kind]
stupid_tc_theta <- TcM [Kind] -> TcM [Kind]
forall r. TcM r -> TcM r
pushTcLevelM_ (TcM [Kind] -> TcM [Kind]) -> TcM [Kind] -> TcM [Kind]
forall a b. (a -> b) -> a -> b
$ TcM [Kind] -> TcM [Kind]
forall r. TcM r -> TcM r
solveEqualities (TcM [Kind] -> TcM [Kind]) -> TcM [Kind] -> TcM [Kind]
forall a b. (a -> b) -> a -> b
$ LHsContext GhcRn -> TcM [Kind]
tcHsContext LHsContext GhcRn
ctxt
; [Kind]
stupid_theta <- [Kind] -> TcM [Kind]
zonkTcTypesToTypes [Kind]
stupid_tc_theta
; Bool
kind_signatures <- Extension -> TcRn 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 (LHsKind GhcRn) -> Bool
forall a. Maybe a -> Bool
isJust 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 -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM ((TyCon -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> (TyCon -> IOEnv (Env TcGblEnv TcLclEnv) TyCon)
-> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a b. (a -> b) -> a -> b
$ \ TyCon
tycon -> do
{ let final_bndrs :: [TyConBinder]
final_bndrs = [TyConBinder]
tycon_binders [TyConBinder] -> [TyConBinder] -> [TyConBinder]
forall a. [a] -> [a] -> [a]
`chkAppend` [TyConBinder]
extra_bndrs
res_ty :: Kind
res_ty = TyCon -> [Kind] -> Kind
mkTyConApp TyCon
tycon ([TyVar] -> [Kind]
mkTyVarTys ([TyConBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
final_bndrs))
roles :: [Role]
roles = Name -> [Role]
roles_info Name
tc_name
; [DataCon]
data_cons <- TyCon -> [TyConBinder] -> Kind -> [LConDecl GhcRn] -> TcM [DataCon]
tcConDecls TyCon
tycon [TyConBinder]
final_bndrs Kind
res_ty [LConDecl GhcRn]
cons
; AlgTyConRhs
tc_rhs <- HscSource
-> TyCon -> [DataCon] -> IOEnv (Env TcGblEnv TcLclEnv) AlgTyConRhs
mk_tc_rhs HscSource
hsc_src TyCon
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 -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
-> [TyConBinder]
-> Kind
-> [Role]
-> Maybe CType
-> [Kind]
-> AlgTyConRhs
-> AlgTyConFlav
-> Bool
-> TyCon
mkAlgTyCon Name
tc_name
[TyConBinder]
final_bndrs
Kind
final_res_kind
[Role]
roles
((Located CType -> CType) -> Maybe (Located CType) -> Maybe CType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Located CType -> CType
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Maybe (Located CType)
cType)
[Kind]
stupid_theta AlgTyConRhs
tc_rhs
(Name -> AlgTyConFlav
VanillaAlgTyCon Name
tc_rep_nm)
Bool
gadt_syntax) }
; 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 -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tycon }
where
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)
tcDataDefn Name -> [Role]
_ Name
_ [TyConBinder]
_ Kind
_ (XHsDataDefn XXHsDataDefn GhcRn
_) = String -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
forall a. String -> a
panic String
"tcDataDefn"
kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM ()
kcTyFamInstEqn :: TyCon -> LTyFamInstEqn GhcRn -> TcRn ()
kcTyFamInstEqn TyCon
tc_fam_tc
(LTyFamInstEqn GhcRn -> Located (SrcSpanLess (LTyFamInstEqn GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc (HsIB { hsib_ext = imp_vars
, hsib_body = FamEqn { feqn_tycon = dL->L _ eqn_tc_name
, feqn_bndrs = mb_expl_bndrs
, feqn_pats = hs_pats
, feqn_rhs = hs_rhs_ty }}))
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
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 SrcSpanLess (Located Name)
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
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Kind
tyConKind TyCon
tc_fam_tc)
, String -> SDoc
text String
"hsib_vars =" SDoc -> SDoc -> SDoc
<+> [Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
XHsIB
GhcRn
(FamEqn
GhcRn [HsArg (LHsKind GhcRn) (LHsKind GhcRn)] (LHsKind GhcRn))
imp_vars
, String -> SDoc
text String
"feqn_bndrs =" SDoc -> SDoc -> SDoc
<+> Maybe [LHsTyVarBndr GhcRn] -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe [LHsTyVarBndr GhcRn]
mb_expl_bndrs
, String -> SDoc
text String
"feqn_pats =" SDoc -> SDoc -> SDoc
<+> [HsArg (LHsKind GhcRn) (LHsKind GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsArg (LHsKind GhcRn) (LHsKind GhcRn)]
hs_pats ])
; let vis_pats :: Int
vis_pats = [HsArg (LHsKind GhcRn) (LHsKind GhcRn)] -> Int
forall tm ty. [HsArg tm ty] -> Int
numVisibleArgs [HsArg (LHsKind GhcRn) (LHsKind GhcRn)]
hs_pats
; Bool -> SDoc -> TcRn ()
checkTc (Int
vis_pats Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
vis_arity) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Int -> SDoc
wrongNumberOfParmsErr Int
vis_arity
; TcM ([TyVar], ([TyVar], Kind)) -> TcRn ()
forall a. TcM a -> TcRn ()
discardResult (TcM ([TyVar], ([TyVar], Kind)) -> TcRn ())
-> TcM ([TyVar], ([TyVar], Kind)) -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[Name] -> TcM ([TyVar], Kind) -> TcM ([TyVar], ([TyVar], Kind))
forall a. [Name] -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Q_Tv [Name]
XHsIB
GhcRn
(FamEqn
GhcRn [HsArg (LHsKind GhcRn) (LHsKind GhcRn)] (LHsKind GhcRn))
imp_vars (TcM ([TyVar], Kind) -> TcM ([TyVar], ([TyVar], Kind)))
-> TcM ([TyVar], Kind) -> TcM ([TyVar], ([TyVar], Kind))
forall a b. (a -> b) -> a -> b
$
ContextKind
-> [LHsTyVarBndr GhcRn] -> TcM Kind -> TcM ([TyVar], Kind)
forall a.
ContextKind -> [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TyVar], a)
bindExplicitTKBndrs_Q_Tv ContextKind
AnyKind (Maybe [LHsTyVarBndr GhcRn]
mb_expl_bndrs Maybe [LHsTyVarBndr GhcRn]
-> [LHsTyVarBndr GhcRn] -> [LHsTyVarBndr GhcRn]
forall a. Maybe a -> a -> a
`orElse` []) (TcM Kind -> TcM ([TyVar], Kind))
-> TcM Kind -> TcM ([TyVar], Kind)
forall a b. (a -> b) -> a -> b
$
do { (Kind
_, Kind
res_kind) <- TyCon
-> [HsArg (LHsKind GhcRn) (LHsKind GhcRn)] -> TcM (Kind, Kind)
tcFamTyPats TyCon
tc_fam_tc [HsArg (LHsKind GhcRn) (LHsKind GhcRn)]
hs_pats
; LHsKind GhcRn -> Kind -> TcM Kind
tcCheckLHsType LHsKind GhcRn
hs_rhs_ty Kind
res_kind }
}
where
vis_arity :: Int
vis_arity = [TyVar] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TyCon -> [TyVar]
tyConVisibleTyVars TyCon
tc_fam_tc)
kcTyFamInstEqn TyCon
_ (LTyFamInstEqn GhcRn -> Located (SrcSpanLess (LTyFamInstEqn GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (XHsImplicitBndrs _)) = String -> TcRn ()
forall a. String -> a
panic String
"kcTyFamInstEqn"
kcTyFamInstEqn TyCon
_ (LTyFamInstEqn GhcRn -> Located (SrcSpanLess (LTyFamInstEqn GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsIB _ (XFamEqn _))) = String -> TcRn ()
forall a. String -> a
panic String
"kcTyFamInstEqn"
kcTyFamInstEqn TyCon
_ LTyFamInstEqn GhcRn
_ = String -> TcRn ()
forall a. String -> a
panic String
"kcTyFamInstEqn: Impossible Match"
tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn
-> TcM (KnotTied CoAxBranch)
tcTyFamInstEqn :: TyCon
-> AssocInstInfo
-> LTyFamInstEqn GhcRn
-> TcRn (KnotTied CoAxBranch)
tcTyFamInstEqn TyCon
fam_tc AssocInstInfo
mb_clsinfo
(LTyFamInstEqn GhcRn -> Located (SrcSpanLess (LTyFamInstEqn GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc (HsIB { hsib_ext = imp_vars
, hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name
, feqn_bndrs = mb_expl_bndrs
, feqn_pats = hs_pats
, feqn_rhs = hs_rhs_ty }}))
= ASSERT( getName fam_tc == eqn_tc_name )
SrcSpan -> TcRn (KnotTied CoAxBranch) -> TcRn (KnotTied CoAxBranch)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn (KnotTied CoAxBranch) -> TcRn (KnotTied CoAxBranch))
-> TcRn (KnotTied CoAxBranch) -> TcRn (KnotTied CoAxBranch)
forall a b. (a -> b) -> a -> b
$
do {
; let vis_arity :: Int
vis_arity = [TyVar] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TyCon -> [TyVar]
tyConVisibleTyVars TyCon
fam_tc)
vis_pats :: Int
vis_pats = [HsArg (LHsKind GhcRn) (LHsKind GhcRn)] -> Int
forall tm ty. [HsArg tm ty] -> Int
numVisibleArgs [HsArg (LHsKind GhcRn) (LHsKind GhcRn)]
hs_pats
; Bool -> SDoc -> TcRn ()
checkTc (Int
vis_pats Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
vis_arity) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
Int -> SDoc
wrongNumberOfParmsErr Int
vis_arity
; ([TyVar]
qtvs, [Kind]
pats, Kind
rhs_ty) <- TyCon
-> AssocInstInfo
-> [Name]
-> [LHsTyVarBndr GhcRn]
-> [HsArg (LHsKind GhcRn) (LHsKind GhcRn)]
-> LHsKind GhcRn
-> TcM ([TyVar], [Kind], Kind)
tcTyFamInstEqnGuts TyCon
fam_tc AssocInstInfo
mb_clsinfo
[Name]
XHsIB
GhcRn
(FamEqn
GhcRn [HsArg (LHsKind GhcRn) (LHsKind GhcRn)] (LHsKind GhcRn))
imp_vars (Maybe [LHsTyVarBndr GhcRn]
mb_expl_bndrs Maybe [LHsTyVarBndr GhcRn]
-> [LHsTyVarBndr GhcRn] -> [LHsTyVarBndr GhcRn]
forall a. Maybe a -> a -> a
`orElse` [])
[HsArg (LHsKind GhcRn) (LHsKind GhcRn)]
hs_pats LHsKind GhcRn
hs_rhs_ty
; KnotTied CoAxBranch -> TcRn (KnotTied CoAxBranch)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
-> [TyVar]
-> [TyVar]
-> [Kind]
-> Kind
-> [Role]
-> SrcSpan
-> KnotTied CoAxBranch
mkCoAxBranch [TyVar]
qtvs [] [] [Kind]
pats Kind
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)
SrcSpan
loc) }
tcTyFamInstEqn TyCon
_ AssocInstInfo
_ LTyFamInstEqn GhcRn
_ = String -> TcRn (KnotTied CoAxBranch)
forall a. String -> a
panic String
"tcTyFamInstEqn"
tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo
-> [Name] -> [LHsTyVarBndr GhcRn]
-> HsTyPats GhcRn
-> LHsType GhcRn
-> TcM ([TyVar], [TcType], TcType)
tcTyFamInstEqnGuts :: TyCon
-> AssocInstInfo
-> [Name]
-> [LHsTyVarBndr GhcRn]
-> [HsArg (LHsKind GhcRn) (LHsKind GhcRn)]
-> LHsKind GhcRn
-> TcM ([TyVar], [Kind], Kind)
tcTyFamInstEqnGuts TyCon
fam_tc AssocInstInfo
mb_clsinfo [Name]
imp_vars [LHsTyVarBndr GhcRn]
exp_bndrs [HsArg (LHsKind GhcRn) (LHsKind GhcRn)]
hs_pats LHsKind GhcRn
hs_rhs_ty
= do { String -> SDoc -> TcRn ()
traceTc String
"tcTyFamInstEqnGuts {" ([SDoc] -> SDoc
vcat [ TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc SDoc -> SDoc -> SDoc
<+> [HsArg (LHsKind GhcRn) (LHsKind GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsArg (LHsKind GhcRn) (LHsKind GhcRn)]
hs_pats ])
; ([TyVar]
imp_tvs, ([TyVar]
exp_tvs, (Kind
lhs_ty, Kind
rhs_ty)))
<- TcM ([TyVar], ([TyVar], (Kind, Kind)))
-> TcM ([TyVar], ([TyVar], (Kind, Kind)))
forall r. TcM r -> TcM r
pushTcLevelM_ (TcM ([TyVar], ([TyVar], (Kind, Kind)))
-> TcM ([TyVar], ([TyVar], (Kind, Kind))))
-> TcM ([TyVar], ([TyVar], (Kind, Kind)))
-> TcM ([TyVar], ([TyVar], (Kind, Kind)))
forall a b. (a -> b) -> a -> b
$
TcM ([TyVar], ([TyVar], (Kind, Kind)))
-> TcM ([TyVar], ([TyVar], (Kind, Kind)))
forall r. TcM r -> TcM r
solveEqualities (TcM ([TyVar], ([TyVar], (Kind, Kind)))
-> TcM ([TyVar], ([TyVar], (Kind, Kind))))
-> TcM ([TyVar], ([TyVar], (Kind, Kind)))
-> TcM ([TyVar], ([TyVar], (Kind, Kind)))
forall a b. (a -> b) -> a -> b
$
[Name]
-> TcM ([TyVar], (Kind, Kind))
-> TcM ([TyVar], ([TyVar], (Kind, Kind)))
forall a. [Name] -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Q_Skol [Name]
imp_vars (TcM ([TyVar], (Kind, Kind))
-> TcM ([TyVar], ([TyVar], (Kind, Kind))))
-> TcM ([TyVar], (Kind, Kind))
-> TcM ([TyVar], ([TyVar], (Kind, Kind)))
forall a b. (a -> b) -> a -> b
$
ContextKind
-> [LHsTyVarBndr GhcRn]
-> TcM (Kind, Kind)
-> TcM ([TyVar], (Kind, Kind))
forall a.
ContextKind -> [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TyVar], a)
bindExplicitTKBndrs_Q_Skol ContextKind
AnyKind [LHsTyVarBndr GhcRn]
exp_bndrs (TcM (Kind, Kind) -> TcM ([TyVar], (Kind, Kind)))
-> TcM (Kind, Kind) -> TcM ([TyVar], (Kind, Kind))
forall a b. (a -> b) -> a -> b
$
do { (Kind
lhs_ty, Kind
rhs_kind) <- TcM (Kind, Kind)
tc_lhs
; AssocInstInfo -> Kind -> TcRn ()
addConsistencyConstraints AssocInstInfo
mb_clsinfo Kind
lhs_ty
; Kind
rhs_ty <- LHsKind GhcRn -> Kind -> TcM Kind
tcCheckLHsType LHsKind GhcRn
hs_rhs_ty Kind
rhs_kind
; (Kind, Kind) -> TcM (Kind, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind
lhs_ty, Kind
rhs_ty) }
; let scoped_tvs :: [TyVar]
scoped_tvs = [TyVar]
imp_tvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
exp_tvs
; CandidatesQTvs
dvs <- [Kind] -> TcM CandidatesQTvs
candidateQTyVarsOfTypes (Kind
lhs_ty Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
: [TyVar] -> [Kind]
mkTyVarTys [TyVar]
scoped_tvs)
; [TyVar]
qtvs <- TcTyCoVarSet
-> CandidatesQTvs -> IOEnv (Env TcGblEnv TcLclEnv) [TyVar]
quantifyTyVars TcTyCoVarSet
emptyVarSet CandidatesQTvs
dvs
; (ZonkEnv
ze, [TyVar]
qtvs) <- [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrs [TyVar]
qtvs
; Kind
lhs_ty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
ze Kind
lhs_ty
; Kind
rhs_ty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
ze Kind
rhs_ty
; let pats :: [Kind]
pats = Kind -> [Kind]
unravelFamInstPats Kind
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], [Kind], Kind) -> TcM ([TyVar], [Kind], Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
qtvs, [Kind]
pats, Kind
rhs_ty) }
where
tc_lhs :: TcM (Kind, Kind)
tc_lhs | [HsArg (LHsKind GhcRn) (LHsKind GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HsArg (LHsKind GhcRn) (LHsKind GhcRn)]
hs_pats
= do { ([Kind]
args, Kind
rhs_kind) <- ([TyCoBinder], Kind) -> TcM ([Kind], Kind)
HasDebugCallStack => ([TyCoBinder], Kind) -> TcM ([Kind], Kind)
tcInstTyBinders (([TyCoBinder], Kind) -> TcM ([Kind], Kind))
-> ([TyCoBinder], Kind) -> TcM ([Kind], Kind)
forall a b. (a -> b) -> a -> b
$
Int -> Kind -> ([TyCoBinder], Kind)
splitPiTysInvisibleN (TyCon -> Int
tyConArity TyCon
fam_tc)
(TyCon -> Kind
tyConKind TyCon
fam_tc)
; (Kind, Kind) -> TcM (Kind, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> [Kind] -> Kind
mkTyConApp TyCon
fam_tc [Kind]
args, Kind
rhs_kind) }
| Bool
otherwise
= TyCon
-> [HsArg (LHsKind GhcRn) (LHsKind GhcRn)] -> TcM (Kind, Kind)
tcFamTyPats TyCon
fam_tc [HsArg (LHsKind GhcRn) (LHsKind GhcRn)]
hs_pats
tcFamTyPats :: TyCon
-> HsTyPats GhcRn
-> TcM (TcType, TcKind)
tcFamTyPats :: TyCon
-> [HsArg (LHsKind GhcRn) (LHsKind GhcRn)] -> TcM (Kind, Kind)
tcFamTyPats TyCon
fam_tc [HsArg (LHsKind GhcRn) (LHsKind GhcRn)]
hs_pats
= do { String -> SDoc -> TcRn ()
traceTc String
"tcFamTyPats {" (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 SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
fam_kind
, String -> SDoc
text String
"arity:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
fam_arity
, String -> SDoc
text String
"kind:" SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
fam_kind ]
; let fun_ty :: Kind
fun_ty = TyCon -> [Kind] -> Kind
mkTyConApp TyCon
fam_tc []
; (Kind
fam_app, Kind
res_kind) <- WarningFlag -> TcM (Kind, Kind) -> TcM (Kind, Kind)
forall gbl lcl a.
WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetWOptM WarningFlag
Opt_WarnPartialTypeSignatures (TcM (Kind, Kind) -> TcM (Kind, Kind))
-> TcM (Kind, Kind) -> TcM (Kind, Kind)
forall a b. (a -> b) -> a -> b
$
Extension -> TcM (Kind, Kind) -> TcM (Kind, Kind)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.PartialTypeSignatures (TcM (Kind, Kind) -> TcM (Kind, Kind))
-> TcM (Kind, Kind) -> TcM (Kind, Kind)
forall a b. (a -> b) -> a -> b
$
TcTyMode
-> LHsKind GhcRn
-> Kind
-> Kind
-> [HsArg (LHsKind GhcRn) (LHsKind GhcRn)]
-> TcM (Kind, Kind)
tcInferApps TcTyMode
typeLevelMode LHsKind GhcRn
lhs_fun Kind
fun_ty
Kind
fam_kind [HsArg (LHsKind GhcRn) (LHsKind GhcRn)]
hs_pats
; String -> SDoc -> TcRn ()
traceTc String
"End tcFamTyPats }" (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 SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
fam_kind
, String -> SDoc
text String
"res_kind:" SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
res_kind ]
; (Kind, Kind) -> TcM (Kind, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind
fam_app, Kind
res_kind) }
where
fam_name :: Name
fam_name = TyCon -> Name
tyConName TyCon
fam_tc
fam_arity :: Int
fam_arity = TyCon -> Int
tyConArity TyCon
fam_tc
fam_kind :: Kind
fam_kind = TyCon -> Kind
tyConKind TyCon
fam_tc
lhs_fun :: LHsKind GhcRn
lhs_fun = SrcSpanLess (LHsKind GhcRn) -> LHsKind GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (XTyVar GhcRn
-> PromotionFlag -> GenLocated SrcSpan (IdP GhcRn) -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar NoExt
XTyVar GhcRn
noExt PromotionFlag
NotPromoted (SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located Name)
Name
fam_name))
unravelFamInstPats :: TcType -> [TcType]
unravelFamInstPats :: Kind -> [Kind]
unravelFamInstPats Kind
fam_app
= case HasDebugCallStack => Kind -> Maybe (TyCon, [Kind])
Kind -> Maybe (TyCon, [Kind])
splitTyConApp_maybe Kind
fam_app of
Just (TyCon
_, [Kind]
pats) -> [Kind]
pats
Maybe (TyCon, [Kind])
Nothing -> WARN( True, bad_lhs fam_app ) []
where
bad_lhs :: Kind -> SDoc
bad_lhs Kind
fam_app
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Ill-typed LHS of family instance")
Int
2 (Kind -> SDoc
debugPprType Kind
fam_app)
addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM ()
addConsistencyConstraints :: AssocInstInfo -> Kind -> TcRn ()
addConsistencyConstraints AssocInstInfo
mb_clsinfo Kind
fam_app
| InClsInst { ai_inst_env :: AssocInstInfo -> VarEnv Kind
ai_inst_env = VarEnv Kind
inst_env } <- AssocInstInfo
mb_clsinfo
, Just (TyCon
fam_tc, [Kind]
pats) <- HasCallStack => Kind -> Maybe (TyCon, [Kind])
Kind -> Maybe (TyCon, [Kind])
tcSplitTyConApp_maybe Kind
fam_app
= do { let eqs :: [(Kind, Kind)]
eqs = [ (Kind
cls_ty, Kind
pat)
| (TyVar
fam_tc_tv, Kind
pat) <- TyCon -> [TyVar]
tyConTyVars TyCon
fam_tc [TyVar] -> [Kind] -> [(TyVar, Kind)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Kind]
pats
, Just Kind
cls_ty <- [VarEnv Kind -> TyVar -> Maybe Kind
forall a. VarEnv a -> TyVar -> Maybe a
lookupVarEnv VarEnv Kind
inst_env TyVar
fam_tc_tv] ]
; String -> SDoc -> TcRn ()
traceTc String
"addConsistencyConstraints" ([(Kind, Kind)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Kind, Kind)]
eqs)
; CtOrigin -> [(Kind, Kind)] -> TcRn ()
emitDerivedEqs CtOrigin
AssocFamPatOrigin [(Kind, Kind)]
eqs }
| Bool
otherwise
= () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
dataDeclChecks :: Name -> NewOrData
-> LHsContext GhcRn -> [LConDecl GhcRn]
-> TcM Bool
dataDeclChecks :: Name
-> NewOrData -> LHsContext GhcRn -> [LConDecl GhcRn] -> TcRn Bool
dataDeclChecks Name
tc_name NewOrData
new_or_data (L SrcSpan
_ [LHsKind GhcRn]
stupid_theta) [LConDecl GhcRn]
cons
= do {
Bool
gadtSyntax_ok <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.GADTSyntax
; let gadt_syntax :: Bool
gadt_syntax = [LConDecl GhcRn] -> Bool
forall a. [LConDecl a] -> 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 ([LHsKind GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsKind 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
|| [LConDecl GhcRn] -> Bool
forall a. [a] -> Bool
isSingleton [LConDecl GhcRn]
cons)
(Name -> Int -> SDoc
newtypeConError Name
tc_name ([LConDecl GhcRn] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LConDecl GhcRn]
cons))
; Bool
empty_data_decls <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.EmptyDataDecls
; Bool
is_boot <- TcRn Bool
tcIsHsBootOrSig
; Bool -> SDoc -> TcRn ()
checkTc (Bool -> Bool
not ([LConDecl GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LConDecl GhcRn]
cons) Bool -> Bool -> Bool
|| Bool
empty_data_decls Bool -> Bool -> Bool
|| Bool
is_boot)
(Name -> SDoc
emptyConDeclsErr Name
tc_name)
; Bool -> TcRn Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
gadt_syntax }
consUseGadtSyntax :: [LConDecl a] -> Bool
consUseGadtSyntax :: [LConDecl a] -> Bool
consUseGadtSyntax ((LConDecl a -> Located (SrcSpanLess (LConDecl a))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (ConDeclGADT {})) : [LConDecl a]
_) = Bool
True
consUseGadtSyntax [LConDecl a]
_ = Bool
False
tcConDecls :: KnotTied TyCon -> [KnotTied TyConBinder] -> KnotTied Type
-> [LConDecl GhcRn] -> TcM [DataCon]
tcConDecls :: TyCon -> [TyConBinder] -> Kind -> [LConDecl GhcRn] -> TcM [DataCon]
tcConDecls TyCon
rep_tycon [TyConBinder]
tmpl_bndrs Kind
res_tmpl
= (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
$ (SrcSpanLess (LConDecl GhcRn) -> TcM [DataCon])
-> LConDecl GhcRn -> TcM [DataCon]
forall a b. HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
addLocM ((SrcSpanLess (LConDecl GhcRn) -> TcM [DataCon])
-> LConDecl GhcRn -> TcM [DataCon])
-> (SrcSpanLess (LConDecl GhcRn) -> TcM [DataCon])
-> LConDecl GhcRn
-> TcM [DataCon]
forall a b. (a -> b) -> a -> b
$
TyCon
-> NameEnv Int
-> [TyConBinder]
-> Kind
-> ConDecl GhcRn
-> TcM [DataCon]
tcConDecl TyCon
rep_tycon (TyCon -> NameEnv Int
mkTyConTagMap TyCon
rep_tycon) [TyConBinder]
tmpl_bndrs Kind
res_tmpl
tcConDecl :: KnotTied TyCon
-> NameEnv ConTag
-> [KnotTied TyConBinder] -> KnotTied Type
-> ConDecl GhcRn
-> TcM [DataCon]
tcConDecl :: TyCon
-> NameEnv Int
-> [TyConBinder]
-> Kind
-> ConDecl GhcRn
-> TcM [DataCon]
tcConDecl TyCon
rep_tycon NameEnv Int
tag_map [TyConBinder]
tmpl_bndrs Kind
res_tmpl
(ConDeclH98 { con_name :: forall pass. ConDecl pass -> Located (IdP pass)
con_name = GenLocated SrcSpan (IdP GhcRn)
name
, con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr pass]
con_ex_tvs = [LHsTyVarBndr 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 -> HsConDeclDetails pass
con_args = HsConDeclDetails GhcRn
hs_args })
= SDoc -> TcM [DataCon] -> TcM [DataCon]
forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([Located Name] -> SDoc
dataConCtxtName [GenLocated SrcSpan (IdP GhcRn)
Located Name
name]) (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 [ Located Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan (IdP GhcRn)
Located Name
name, [LHsTyVarBndr GhcRn] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr GhcRn]
explicit_tkv_nms ])
; ([TyVar]
exp_tvs, ([Kind]
ctxt, [Kind]
arg_tys, [FieldLabel]
field_lbls, [HsSrcBang]
stricts))
<- TcM ([TyVar], ([Kind], [Kind], [FieldLabel], [HsSrcBang]))
-> TcM ([TyVar], ([Kind], [Kind], [FieldLabel], [HsSrcBang]))
forall r. TcM r -> TcM r
pushTcLevelM_ (TcM ([TyVar], ([Kind], [Kind], [FieldLabel], [HsSrcBang]))
-> TcM ([TyVar], ([Kind], [Kind], [FieldLabel], [HsSrcBang])))
-> TcM ([TyVar], ([Kind], [Kind], [FieldLabel], [HsSrcBang]))
-> TcM ([TyVar], ([Kind], [Kind], [FieldLabel], [HsSrcBang]))
forall a b. (a -> b) -> a -> b
$
TcM ([TyVar], ([Kind], [Kind], [FieldLabel], [HsSrcBang]))
-> TcM ([TyVar], ([Kind], [Kind], [FieldLabel], [HsSrcBang]))
forall r. TcM r -> TcM r
solveEqualities (TcM ([TyVar], ([Kind], [Kind], [FieldLabel], [HsSrcBang]))
-> TcM ([TyVar], ([Kind], [Kind], [FieldLabel], [HsSrcBang])))
-> TcM ([TyVar], ([Kind], [Kind], [FieldLabel], [HsSrcBang]))
-> TcM ([TyVar], ([Kind], [Kind], [FieldLabel], [HsSrcBang]))
forall a b. (a -> b) -> a -> b
$
[LHsTyVarBndr GhcRn]
-> TcM ([Kind], [Kind], [FieldLabel], [HsSrcBang])
-> TcM ([TyVar], ([Kind], [Kind], [FieldLabel], [HsSrcBang]))
forall a. [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TyVar], a)
bindExplicitTKBndrs_Skol [LHsTyVarBndr GhcRn]
explicit_tkv_nms (TcM ([Kind], [Kind], [FieldLabel], [HsSrcBang])
-> TcM ([TyVar], ([Kind], [Kind], [FieldLabel], [HsSrcBang])))
-> TcM ([Kind], [Kind], [FieldLabel], [HsSrcBang])
-> TcM ([TyVar], ([Kind], [Kind], [FieldLabel], [HsSrcBang]))
forall a b. (a -> b) -> a -> b
$
do { [Kind]
ctxt <- Maybe (LHsContext GhcRn) -> TcM [Kind]
tcHsMbContext Maybe (LHsContext GhcRn)
hs_ctxt
; [(Kind, HsSrcBang)]
btys <- HsConDeclDetails GhcRn -> TcM [(Kind, HsSrcBang)]
tcConArgs HsConDeclDetails GhcRn
hs_args
; [FieldLabel]
field_lbls <- Name -> RnM [FieldLabel]
lookupConstructorFields (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc GenLocated SrcSpan (IdP GhcRn)
Located Name
name)
; let ([Kind]
arg_tys, [HsSrcBang]
stricts) = [(Kind, HsSrcBang)] -> ([Kind], [HsSrcBang])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Kind, HsSrcBang)]
btys
; ([Kind], [Kind], [FieldLabel], [HsSrcBang])
-> TcM ([Kind], [Kind], [FieldLabel], [HsSrcBang])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Kind]
ctxt, [Kind]
arg_tys, [FieldLabel]
field_lbls, [HsSrcBang]
stricts)
}
; [TyVar]
kvs <- Kind -> IOEnv (Env TcGblEnv TcLclEnv) [TyVar]
kindGeneralize ([TyVar] -> Kind -> Kind
mkSpecForAllTys ([TyConBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tmpl_bndrs) (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
[TyVar] -> Kind -> Kind
mkSpecForAllTys [TyVar]
exp_tvs (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
[Kind] -> Kind -> Kind
mkFunTys [Kind]
ctxt (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
[Kind] -> Kind -> Kind
mkFunTys [Kind]
arg_tys (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
Kind
unitTy)
; (ZonkEnv
ze, [TyVar]
qkvs) <- [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrs [TyVar]
kvs
; (ZonkEnv
ze, [TyVar]
user_qtvs) <- ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX ZonkEnv
ze [TyVar]
exp_tvs
; [Kind]
arg_tys <- ZonkEnv -> [Kind] -> TcM [Kind]
zonkTcTypesToTypesX ZonkEnv
ze [Kind]
arg_tys
; [Kind]
ctxt <- ZonkEnv -> [Kind] -> TcM [Kind]
zonkTcTypesToTypesX ZonkEnv
ze [Kind]
ctxt
; FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; String -> SDoc -> TcRn ()
traceTc String
"tcConDecl 2" (Located Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan (IdP GhcRn)
Located Name
name SDoc -> SDoc -> SDoc
$$ [FieldLabel] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [FieldLabel]
field_lbls)
; let
univ_tvbs :: [TyVarBinder]
univ_tvbs = [TyConBinder] -> [TyVarBinder]
tyConTyVarBinders [TyConBinder]
tmpl_bndrs
univ_tvs :: [TyVar]
univ_tvs = [TyVarBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyVarBinder]
univ_tvbs
ex_tvbs :: [TyVarBinder]
ex_tvbs = ArgFlag -> [TyVar] -> [TyVarBinder]
mkTyVarBinders ArgFlag
Inferred [TyVar]
qkvs [TyVarBinder] -> [TyVarBinder] -> [TyVarBinder]
forall a. [a] -> [a] -> [a]
++
ArgFlag -> [TyVar] -> [TyVarBinder]
mkTyVarBinders ArgFlag
Specified [TyVar]
user_qtvs
ex_tvs :: [TyVar]
ex_tvs = [TyVar]
qkvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
user_qtvs
user_tvbs :: [TyVarBinder]
user_tvbs = [TyVarBinder]
univ_tvbs [TyVarBinder] -> [TyVarBinder] -> [TyVarBinder]
forall a. [a] -> [a] -> [a]
++ [TyVarBinder]
ex_tvbs
buildOneDataCon :: Located Name -> IOEnv (Env TcGblEnv TcLclEnv) DataCon
buildOneDataCon (Located Name -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located Name)
name) = do
{ Bool
is_infix <- Name -> HsConDeclDetails GhcRn -> TcRn Bool
tcConIsInfixH98 SrcSpanLess (Located Name)
Name
name HsConDeclDetails GhcRn
hs_args
; Name
rep_nm <- Name -> TcRnIf TcGblEnv TcLclEnv Name
forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName SrcSpanLess (Located Name)
Name
name
; FamInstEnvs
-> Name
-> Bool
-> Name
-> [HsSrcBang]
-> Maybe [HsImplBang]
-> [FieldLabel]
-> [TyVar]
-> [TyVar]
-> [TyVarBinder]
-> [EqSpec]
-> [Kind]
-> [Kind]
-> Kind
-> TyCon
-> NameEnv Int
-> IOEnv (Env TcGblEnv TcLclEnv) DataCon
forall m n.
FamInstEnvs
-> Name
-> Bool
-> Name
-> [HsSrcBang]
-> Maybe [HsImplBang]
-> [FieldLabel]
-> [TyVar]
-> [TyVar]
-> [TyVarBinder]
-> [EqSpec]
-> [Kind]
-> [Kind]
-> Kind
-> TyCon
-> NameEnv Int
-> TcRnIf m n DataCon
buildDataCon FamInstEnvs
fam_envs SrcSpanLess (Located Name)
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 [TyVarBinder]
user_tvbs
[] [Kind]
ctxt [Kind]
arg_tys
Kind
res_tmpl TyCon
rep_tycon NameEnv Int
tag_map
}
; String -> SDoc -> TcRn ()
traceTc String
"tcConDecl 2" (Located Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan (IdP GhcRn)
Located Name
name)
; (Located Name -> IOEnv (Env TcGblEnv TcLclEnv) DataCon)
-> [Located Name] -> TcM [DataCon]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located Name -> IOEnv (Env TcGblEnv TcLclEnv) DataCon
buildOneDataCon [GenLocated SrcSpan (IdP GhcRn)
Located Name
name]
}
tcConDecl TyCon
rep_tycon NameEnv Int
tag_map [TyConBinder]
tmpl_bndrs Kind
res_tmpl
(ConDeclGADT { con_names :: forall pass. ConDecl pass -> [Located (IdP pass)]
con_names = [GenLocated SrcSpan (IdP GhcRn)]
names
, con_qvars :: forall pass. ConDecl pass -> LHsQTyVars pass
con_qvars = LHsQTyVars GhcRn
qtvs
, con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcRn)
cxt, con_args :: forall pass. ConDecl pass -> HsConDeclDetails pass
con_args = HsConDeclDetails GhcRn
hs_args
, con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_res_ty = LHsKind GhcRn
hs_res_ty })
| HsQTvs { hsq_ext :: forall pass. LHsQTyVars pass -> XHsQTvs pass
hsq_ext = HsQTvsRn { hsq_implicit = implicit_tkv_nms }
, hsq_explicit :: forall pass. LHsQTyVars pass -> [LHsTyVarBndr pass]
hsq_explicit = [LHsTyVarBndr GhcRn]
explicit_tkv_nms } <- LHsQTyVars GhcRn
qtvs
= SDoc -> TcM [DataCon] -> TcM [DataCon]
forall a. SDoc -> TcM a -> TcM a
addErrCtxt ([Located Name] -> SDoc
dataConCtxtName [GenLocated SrcSpan (IdP GhcRn)]
[Located Name]
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" ([Located Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpan (IdP GhcRn)]
[Located Name]
names)
; let ((Located Name -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located Name)
name) : [Located Name]
_) = [GenLocated SrcSpan (IdP GhcRn)]
[Located Name]
names
; ([TyVar]
imp_tvs, ([TyVar]
exp_tvs, ([Kind]
ctxt, [Kind]
arg_tys, Kind
res_ty, [FieldLabel]
field_lbls, [HsSrcBang]
stricts)))
<- TcM
([TyVar],
([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang])))
-> TcM
([TyVar],
([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang])))
forall r. TcM r -> TcM r
pushTcLevelM_ (TcM
([TyVar],
([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang])))
-> TcM
([TyVar],
([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang]))))
-> TcM
([TyVar],
([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang])))
-> TcM
([TyVar],
([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang])))
forall a b. (a -> b) -> a -> b
$
TcM
([TyVar],
([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang])))
-> TcM
([TyVar],
([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang])))
forall r. TcM r -> TcM r
solveEqualities (TcM
([TyVar],
([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang])))
-> TcM
([TyVar],
([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang]))))
-> TcM
([TyVar],
([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang])))
-> TcM
([TyVar],
([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang])))
forall a b. (a -> b) -> a -> b
$
[Name]
-> TcM ([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang]))
-> TcM
([TyVar],
([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang])))
forall a. [Name] -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Skol [Name]
implicit_tkv_nms (TcM ([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang]))
-> TcM
([TyVar],
([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang]))))
-> TcM ([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang]))
-> TcM
([TyVar],
([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang])))
forall a b. (a -> b) -> a -> b
$
[LHsTyVarBndr GhcRn]
-> TcM ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang])
-> TcM ([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang]))
forall a. [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TyVar], a)
bindExplicitTKBndrs_Skol [LHsTyVarBndr GhcRn]
explicit_tkv_nms (TcM ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang])
-> TcM
([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang])))
-> TcM ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang])
-> TcM ([TyVar], ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang]))
forall a b. (a -> b) -> a -> b
$
do { [Kind]
ctxt <- Maybe (LHsContext GhcRn) -> TcM [Kind]
tcHsMbContext Maybe (LHsContext GhcRn)
cxt
; [(Kind, HsSrcBang)]
btys <- HsConDeclDetails GhcRn -> TcM [(Kind, HsSrcBang)]
tcConArgs HsConDeclDetails GhcRn
hs_args
; Kind
res_ty <- LHsKind GhcRn -> TcM Kind
tcHsLiftedType LHsKind GhcRn
hs_res_ty
; [FieldLabel]
field_lbls <- Name -> RnM [FieldLabel]
lookupConstructorFields SrcSpanLess (Located Name)
Name
name
; let ([Kind]
arg_tys, [HsSrcBang]
stricts) = [(Kind, HsSrcBang)] -> ([Kind], [HsSrcBang])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Kind, HsSrcBang)]
btys
; ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang])
-> TcM ([Kind], [Kind], Kind, [FieldLabel], [HsSrcBang])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Kind]
ctxt, [Kind]
arg_tys, Kind
res_ty, [FieldLabel]
field_lbls, [HsSrcBang]
stricts)
}
; [TyVar]
imp_tvs <- [TyVar] -> IOEnv (Env TcGblEnv TcLclEnv) [TyVar]
zonkAndScopedSort [TyVar]
imp_tvs
; let user_tvs :: [TyVar]
user_tvs = [TyVar]
imp_tvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
exp_tvs
; [TyVar]
tkvs <- Kind -> IOEnv (Env TcGblEnv TcLclEnv) [TyVar]
kindGeneralize ([TyVar] -> Kind -> Kind
mkSpecForAllTys [TyVar]
user_tvs (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
[Kind] -> Kind -> Kind
mkFunTys [Kind]
ctxt (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
[Kind] -> Kind -> Kind
mkFunTys [Kind]
arg_tys (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
Kind
res_ty)
; (ZonkEnv
ze, [TyVar]
tkvs) <- [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrs [TyVar]
tkvs
; (ZonkEnv
ze, [TyVar]
user_tvs) <- ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar])
zonkTyBndrsX ZonkEnv
ze [TyVar]
user_tvs
; [Kind]
arg_tys <- ZonkEnv -> [Kind] -> TcM [Kind]
zonkTcTypesToTypesX ZonkEnv
ze [Kind]
arg_tys
; [Kind]
ctxt <- ZonkEnv -> [Kind] -> TcM [Kind]
zonkTcTypesToTypesX ZonkEnv
ze [Kind]
ctxt
; Kind
res_ty <- ZonkEnv -> Kind -> TcM Kind
zonkTcTypeToTypeX ZonkEnv
ze Kind
res_ty
; let ([TyVar]
univ_tvs, [TyVar]
ex_tvs, [TyVar]
tkvs', [TyVar]
user_tvs', [EqSpec]
eq_preds, TCvSubst
arg_subst)
= [TyConBinder]
-> Kind
-> [TyVar]
-> [TyVar]
-> Kind
-> ([TyVar], [TyVar], [TyVar], [TyVar], [EqSpec], TCvSubst)
rejigConRes [TyConBinder]
tmpl_bndrs Kind
res_tmpl [TyVar]
tkvs [TyVar]
user_tvs Kind
res_ty
tkv_bndrs :: [TyVarBinder]
tkv_bndrs = ArgFlag -> [TyVar] -> [TyVarBinder]
mkTyVarBinders ArgFlag
Inferred [TyVar]
tkvs'
user_tv_bndrs :: [TyVarBinder]
user_tv_bndrs = ArgFlag -> [TyVar] -> [TyVarBinder]
mkTyVarBinders ArgFlag
Specified [TyVar]
user_tvs'
all_user_bndrs :: [TyVarBinder]
all_user_bndrs = [TyVarBinder]
tkv_bndrs [TyVarBinder] -> [TyVarBinder] -> [TyVarBinder]
forall a. [a] -> [a] -> [a]
++ [TyVarBinder]
user_tv_bndrs
ctxt' :: [Kind]
ctxt' = HasCallStack => TCvSubst -> [Kind] -> [Kind]
TCvSubst -> [Kind] -> [Kind]
substTys TCvSubst
arg_subst [Kind]
ctxt
arg_tys' :: [Kind]
arg_tys' = HasCallStack => TCvSubst -> [Kind] -> [Kind]
TCvSubst -> [Kind] -> [Kind]
substTys TCvSubst
arg_subst [Kind]
arg_tys
res_ty' :: Kind
res_ty' = HasCallStack => TCvSubst -> Kind -> Kind
TCvSubst -> Kind -> Kind
substTy TCvSubst
arg_subst Kind
res_ty
; FamInstEnvs
fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; String -> SDoc -> TcRn ()
traceTc String
"tcConDecl 2" ([Located Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpan (IdP GhcRn)]
[Located Name]
names SDoc -> SDoc -> SDoc
$$ [FieldLabel] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [FieldLabel]
field_lbls)
; let
buildOneDataCon :: Located Name -> IOEnv (Env TcGblEnv TcLclEnv) DataCon
buildOneDataCon (Located Name -> Located (SrcSpanLess (Located Name))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located Name)
name) = do
{ Bool
is_infix <- Name -> HsConDeclDetails GhcRn -> TcRn Bool
tcConIsInfixGADT SrcSpanLess (Located Name)
Name
name HsConDeclDetails GhcRn
hs_args
; Name
rep_nm <- Name -> TcRnIf TcGblEnv TcLclEnv Name
forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName SrcSpanLess (Located Name)
Name
name
; FamInstEnvs
-> Name
-> Bool
-> Name
-> [HsSrcBang]
-> Maybe [HsImplBang]
-> [FieldLabel]
-> [TyVar]
-> [TyVar]
-> [TyVarBinder]
-> [EqSpec]
-> [Kind]
-> [Kind]
-> Kind
-> TyCon
-> NameEnv Int
-> IOEnv (Env TcGblEnv TcLclEnv) DataCon
forall m n.
FamInstEnvs
-> Name
-> Bool
-> Name
-> [HsSrcBang]
-> Maybe [HsImplBang]
-> [FieldLabel]
-> [TyVar]
-> [TyVar]
-> [TyVarBinder]
-> [EqSpec]
-> [Kind]
-> [Kind]
-> Kind
-> TyCon
-> NameEnv Int
-> TcRnIf m n DataCon
buildDataCon FamInstEnvs
fam_envs SrcSpanLess (Located Name)
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 [TyVarBinder]
all_user_bndrs [EqSpec]
eq_preds
[Kind]
ctxt' [Kind]
arg_tys' Kind
res_ty' TyCon
rep_tycon NameEnv Int
tag_map
}
; String -> SDoc -> TcRn ()
traceTc String
"tcConDecl 2" ([Located Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpan (IdP GhcRn)]
[Located Name]
names)
; (Located Name -> IOEnv (Env TcGblEnv TcLclEnv) DataCon)
-> [Located Name] -> TcM [DataCon]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located Name -> IOEnv (Env TcGblEnv TcLclEnv) DataCon
buildOneDataCon [GenLocated SrcSpan (IdP GhcRn)]
[Located Name]
names
}
tcConDecl TyCon
_ NameEnv Int
_ [TyConBinder]
_ Kind
_ (ConDeclGADT XConDeclGADT GhcRn
_ [GenLocated SrcSpan (IdP GhcRn)]
_ Located Bool
_ (XLHsQTyVars XXLHsQTyVars GhcRn
_) Maybe (LHsContext GhcRn)
_ HsConDeclDetails GhcRn
_ LHsKind GhcRn
_ Maybe LHsDocString
_)
= String -> TcM [DataCon]
forall a. String -> a
panic String
"tcConDecl"
tcConDecl TyCon
_ NameEnv Int
_ [TyConBinder]
_ Kind
_ (XConDecl XXConDecl GhcRn
_) = String -> TcM [DataCon]
forall a. String -> a
panic String
"tcConDecl"
tcConIsInfixH98 :: Name
-> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
-> TcM Bool
tcConIsInfixH98 :: Name -> HsConDeclDetails GhcRn -> TcRn Bool
tcConIsInfixH98 Name
_ HsConDeclDetails GhcRn
details
= case HsConDeclDetails GhcRn
details of
InfixCon {} -> Bool -> TcRn Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
HsConDeclDetails GhcRn
_ -> Bool -> TcRn Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
tcConIsInfixGADT :: Name
-> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
-> TcM Bool
tcConIsInfixGADT :: Name -> HsConDeclDetails GhcRn -> TcRn Bool
tcConIsInfixGADT Name
con HsConDeclDetails GhcRn
details
= case HsConDeclDetails GhcRn
details of
InfixCon {} -> Bool -> TcRn Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
RecCon {} -> Bool -> TcRn Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
PrefixCon [LHsKind GhcRn]
arg_tys
| OccName -> Bool
isSymOcc (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
con)
, [LHsKind GhcRn
_ty1,LHsKind GhcRn
_ty2] <- [LHsKind GhcRn]
arg_tys
-> do { FixityEnv
fix_env <- TcRn FixityEnv
getFixityEnv
; Bool -> TcRn 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 -> TcRn Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
tcConArgs :: HsConDeclDetails GhcRn
-> TcM [(TcType, HsSrcBang)]
tcConArgs :: HsConDeclDetails GhcRn -> TcM [(Kind, HsSrcBang)]
tcConArgs (PrefixCon [LHsKind GhcRn]
btys)
= (LHsKind GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (Kind, HsSrcBang))
-> [LHsKind GhcRn] -> TcM [(Kind, HsSrcBang)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsKind GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (Kind, HsSrcBang)
tcConArg [LHsKind GhcRn]
btys
tcConArgs (InfixCon LHsKind GhcRn
bty1 LHsKind GhcRn
bty2)
= do { (Kind, HsSrcBang)
bty1' <- LHsKind GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (Kind, HsSrcBang)
tcConArg LHsKind GhcRn
bty1
; (Kind, HsSrcBang)
bty2' <- LHsKind GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (Kind, HsSrcBang)
tcConArg LHsKind GhcRn
bty2
; [(Kind, HsSrcBang)] -> TcM [(Kind, HsSrcBang)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Kind, HsSrcBang)
bty1', (Kind, HsSrcBang)
bty2'] }
tcConArgs (RecCon Located [LConDeclField GhcRn]
fields)
= (LHsKind GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (Kind, HsSrcBang))
-> [LHsKind GhcRn] -> TcM [(Kind, HsSrcBang)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsKind GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (Kind, HsSrcBang)
tcConArg [LHsKind GhcRn]
btys
where
combined :: [([LFieldOcc GhcRn], LHsKind GhcRn)]
combined = (LConDeclField GhcRn -> ([LFieldOcc GhcRn], LHsKind GhcRn))
-> [LConDeclField GhcRn] -> [([LFieldOcc GhcRn], LHsKind GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (\(LConDeclField GhcRn -> Located (SrcSpanLess (LConDeclField GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (LConDeclField GhcRn)
f) -> (ConDeclField GhcRn -> [LFieldOcc GhcRn]
forall pass. ConDeclField pass -> [LFieldOcc pass]
cd_fld_names ConDeclField GhcRn
SrcSpanLess (LConDeclField GhcRn)
f,ConDeclField GhcRn -> LHsKind GhcRn
forall pass. ConDeclField pass -> LBangType pass
cd_fld_type ConDeclField GhcRn
SrcSpanLess (LConDeclField GhcRn)
f))
(Located [LConDeclField GhcRn]
-> SrcSpanLess (Located [LConDeclField GhcRn])
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located [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 :: [(LFieldOcc GhcRn, LHsKind GhcRn)]
exploded = (([LFieldOcc GhcRn], LHsKind GhcRn)
-> [(LFieldOcc GhcRn, LHsKind GhcRn)])
-> [([LFieldOcc GhcRn], LHsKind GhcRn)]
-> [(LFieldOcc GhcRn, LHsKind GhcRn)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([LFieldOcc GhcRn], LHsKind GhcRn)
-> [(LFieldOcc GhcRn, LHsKind GhcRn)]
forall a b. ([a], b) -> [(a, b)]
explode [([LFieldOcc GhcRn], LHsKind GhcRn)]
combined
([LFieldOcc GhcRn]
_,[LHsKind GhcRn]
btys) = [(LFieldOcc GhcRn, LHsKind GhcRn)]
-> ([LFieldOcc GhcRn], [LHsKind GhcRn])
forall a b. [(a, b)] -> ([a], [b])
unzip [(LFieldOcc GhcRn, LHsKind GhcRn)]
exploded
tcConArg :: LHsType GhcRn -> TcM (TcType, HsSrcBang)
tcConArg :: LHsKind GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) (Kind, HsSrcBang)
tcConArg LHsKind GhcRn
bty
= do { String -> SDoc -> TcRn ()
traceTc String
"tcConArg 1" (LHsKind GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsKind GhcRn
bty)
; Kind
arg_ty <- LHsKind GhcRn -> TcM Kind
tcHsOpenType (LHsKind GhcRn -> LHsKind GhcRn
forall a. LHsType a -> LHsType a
getBangType LHsKind GhcRn
bty)
; String -> SDoc -> TcRn ()
traceTc String
"tcConArg 2" (LHsKind GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsKind GhcRn
bty)
; (Kind, HsSrcBang)
-> IOEnv (Env TcGblEnv TcLclEnv) (Kind, HsSrcBang)
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind
arg_ty, LHsKind GhcRn -> HsSrcBang
forall a. LHsType a -> HsSrcBang
getBangStrictness LHsKind GhcRn
bty) }
rejigConRes :: [KnotTied TyConBinder] -> KnotTied Type
-> [TyVar]
-> [TyVar]
-> KnotTied Type
-> ([TyVar],
[TyVar],
[TyVar],
[TyVar],
[EqSpec],
TCvSubst)
rejigConRes :: [TyConBinder]
-> Kind
-> [TyVar]
-> [TyVar]
-> Kind
-> ([TyVar], [TyVar], [TyVar], [TyVar], [EqSpec], TCvSubst)
rejigConRes [TyConBinder]
tmpl_bndrs Kind
res_tmpl [TyVar]
dc_inferred_tvs [TyVar]
dc_specified_tvs Kind
res_ty
| Just TCvSubst
subst <- ASSERT( isLiftedTypeKind (tcTypeKind res_ty) )
ASSERT( isLiftedTypeKind (tcTypeKind res_tmpl) )
Kind -> Kind -> Maybe TCvSubst
tcMatchTy Kind
res_tmpl Kind
res_ty
= let ([TyVar]
univ_tvs, [EqSpec]
raw_eqs, TCvSubst
kind_subst) = [TyVar] -> [TyVar] -> TCvSubst -> ([TyVar], [EqSpec], TCvSubst)
mkGADTVars [TyVar]
tmpl_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 :: [TyVar] -> [TyVar]
subst_user_tvs = (TyVar -> TyVar) -> [TyVar] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Kind -> TyVar
getTyVar String
"rejigConRes" (Kind -> TyVar) -> (TyVar -> Kind) -> TyVar -> TyVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TCvSubst -> TyVar -> Kind
substTyVar TCvSubst
arg_subst)
substed_inferred_tvs :: [TyVar]
substed_inferred_tvs = [TyVar] -> [TyVar]
subst_user_tvs [TyVar]
dc_inferred_tvs
substed_specified_tvs :: [TyVar]
substed_specified_tvs = [TyVar] -> [TyVar]
subst_user_tvs [TyVar]
dc_specified_tvs
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, [TyVar]
substed_inferred_tvs, [TyVar]
substed_specified_tvs,
[EqSpec]
substed_eqs, TCvSubst
arg_subst)
| Bool
otherwise
= ([TyVar]
tmpl_tvs, [TyVar]
dc_tvs [TyVar] -> [TyVar] -> [TyVar]
forall a. Ord a => [a] -> [a] -> [a]
`minusList` [TyVar]
tmpl_tvs, [TyVar]
dc_inferred_tvs, [TyVar]
dc_specified_tvs,
[], TCvSubst
emptyTCvSubst)
where
dc_tvs :: [TyVar]
dc_tvs = [TyVar]
dc_inferred_tvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
dc_specified_tvs
tmpl_tvs :: [TyVar]
tmpl_tvs = [TyConBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tmpl_bndrs
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 = TcTyCoVarSet -> InScopeSet
mkInScopeSet ([TyVar] -> TcTyCoVarSet
mkVarSet [TyVar]
tmpl_tvs TcTyCoVarSet -> TcTyCoVarSet -> TcTyCoVarSet
`unionVarSet` [TyVar] -> TcTyCoVarSet
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 Kind
r_ty <- TCvSubst -> TyVar -> Maybe Kind
lookupTyVar TCvSubst
subst TyVar
t_tv
= case Kind -> Maybe TyVar
getTyVar_maybe Kind
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 -> Kind
tyVarKind TyVar
r_tv Kind -> Kind -> Bool
`eqType` (HasCallStack => TCvSubst -> Kind -> Kind
TCvSubst -> Kind -> Kind
substTy TCvSubst
t_sub (TyVar -> Kind
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 -> Kind -> TCvSubst
extendTvSubst TCvSubst
t_sub TyVar
t_tv Kind
r_ty')
(TCvSubst -> TyVar -> Kind -> TCvSubst
extendTvSubst TCvSubst
r_sub TyVar
r_tv Kind
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' :: Kind
r_ty' = TyVar -> Kind
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 -> Kind -> EqSpec
mkEqSpec TyVar
t_tv' Kind
r_ty EqSpec -> [EqSpec] -> [EqSpec]
forall a. a -> [a] -> [a]
: [EqSpec]
eqs)
(TCvSubst -> TyVar -> Kind -> TCvSubst
extendTvSubst TCvSubst
t_sub TyVar
t_tv (TyVar -> Kind
mkTyVarTy TyVar
t_tv'))
TCvSubst
r_sub [TyVar]
t_tvs
where
t_tv' :: TyVar
t_tv' = (Kind -> Kind) -> TyVar -> TyVar
updateTyVarKind (HasCallStack => TCvSubst -> Kind -> Kind
TCvSubst -> Kind -> Kind
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 -> TcM [TyCon]
checkValidTyCl TyCon
tc
= SrcSpan -> TcM [TyCon] -> TcM [TyCon]
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (TyCon -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyCon
tc) (TcM [TyCon] -> TcM [TyCon]) -> TcM [TyCon] -> TcM [TyCon]
forall a b. (a -> b) -> a -> b
$
TyCon -> TcM [TyCon] -> TcM [TyCon]
forall a. TyCon -> TcM a -> TcM a
addTyConCtxt TyCon
tc (TcM [TyCon] -> TcM [TyCon]) -> TcM [TyCon] -> TcM [TyCon]
forall a b. (a -> b) -> a -> b
$
TcM [TyCon] -> TcM [TyCon] -> TcM [TyCon]
forall r. TcRn r -> TcRn r -> TcRn r
recoverM TcM [TyCon]
recovery_code
(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] -> TcM [TyCon]
forall (m :: * -> *) a. Monad m => a -> m a
return [TyCon
tc] })
where
recovery_code :: TcM [TyCon]
recovery_code
= do { String -> SDoc -> TcRn ()
traceTc String
"Aborted validity for tycon" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
; [TyCon] -> TcM [TyCon]
forall (m :: * -> *) a. Monad m => a -> m a
return ((TyThing -> [TyCon]) -> [TyThing] -> [TyCon]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TyThing -> [TyCon]
mk_fake_tc ([TyThing] -> [TyCon]) -> [TyThing] -> [TyCon]
forall a b. (a -> b) -> a -> b
$
TyCon -> TyThing
ATyCon TyCon
tc TyThing -> [TyThing] -> [TyThing]
forall a. a -> [a] -> [a]
: TyCon -> [TyThing]
implicitTyConThings TyCon
tc) }
mk_fake_tc :: TyThing -> [TyCon]
mk_fake_tc (ATyCon TyCon
tc)
| TyCon -> Bool
isClassTyCon TyCon
tc = [TyCon
tc]
| Bool
otherwise = [TyCon -> TyCon
makeRecoveryTyCon TyCon
tc]
mk_fake_tc (AConLike (RealDataCon DataCon
dc))
= [TyCon -> TyCon
makeRecoveryTyCon (DataCon -> TyCon
promoteDataCon DataCon
dc)]
mk_fake_tc TyThing
_ = []
checkValidTyCon :: TyCon -> TcM ()
checkValidTyCon :: TyCon -> TcRn ()
checkValidTyCon TyCon
tc
| TyCon -> Bool
isPrimTyCon TyCon
tc
= () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| 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 Kind
syn_rhs <- TyCon -> Maybe Kind
synTyConRhs_maybe TyCon
tc
-> do { UserTypeCtxt -> Kind -> TcRn ()
checkValidType UserTypeCtxt
syn_ctxt Kind
syn_rhs
; UserTypeCtxt -> Kind -> TcRn ()
checkTySynRhs UserTypeCtxt
syn_ctxt Kind
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 <- TcRn 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 -> [Kind] -> TcRn ()
checkValidTheta (Name -> UserTypeCtxt
DataTyCtxt Name
name) (TyCon -> [Kind]
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 -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ExistentialQuantification
; Bool
gadt_ok <- Extension -> TcRn 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 ()
forall a. NonEmpty (FieldLbl a, 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 a b a b. (FieldLbl a, b) -> (FieldLbl a, 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 :: (FieldLbl a, b) -> (FieldLbl a, b) -> Ordering
cmp_fld (FieldLbl a
f1,b
_) (FieldLbl a
f2,b
_) = FieldLbl a -> FieldLabelString
forall a. FieldLbl a -> FieldLabelString
flLabel FieldLbl a
f1 FieldLabelString -> FieldLabelString -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` FieldLbl a -> FieldLabelString
forall a. FieldLbl a -> FieldLabelString
flLabel FieldLbl a
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 (FieldLbl a, DataCon) -> TcRn ()
check_fields ((FieldLbl a
label, DataCon
con1) :| [(FieldLbl a, 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
$ ((FieldLbl a, DataCon) -> TcRn ())
-> [(FieldLbl a, DataCon)] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FieldLbl a, DataCon) -> TcRn ()
checkOne [(FieldLbl a, DataCon)]
other_fields
where
([TyVar]
_, [Kind]
_, [Kind]
_, Kind
res1) = DataCon -> ([TyVar], [Kind], [Kind], Kind)
dataConSig DataCon
con1
fty1 :: Kind
fty1 = DataCon -> FieldLabelString -> Kind
dataConFieldType DataCon
con1 FieldLabelString
lbl
lbl :: FieldLabelString
lbl = FieldLbl a -> FieldLabelString
forall a. FieldLbl a -> FieldLabelString
flLabel FieldLbl a
label
checkOne :: (FieldLbl a, DataCon) -> TcRn ()
checkOne (FieldLbl a
_, DataCon
con2)
= do { FieldLabelString
-> DataCon -> DataCon -> Kind -> Kind -> Kind -> Kind -> TcRn ()
checkFieldCompat FieldLabelString
lbl DataCon
con1 DataCon
con2 Kind
res1 Kind
res2 Kind
fty1 Kind
fty2
; FieldLabelString
-> DataCon -> DataCon -> Kind -> Kind -> Kind -> Kind -> TcRn ()
checkFieldCompat FieldLabelString
lbl DataCon
con2 DataCon
con1 Kind
res2 Kind
res1 Kind
fty2 Kind
fty1 }
where
([TyVar]
_, [Kind]
_, [Kind]
_, Kind
res2) = DataCon -> ([TyVar], [Kind], [Kind], Kind)
dataConSig DataCon
con2
fty2 :: Kind
fty2 = DataCon -> FieldLabelString -> Kind
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,
Int -> SDoc -> SDoc
nest Int
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
sel_name :: Name
sel_name = FieldLabel -> Name
forall a. FieldLbl a -> a
flSelector FieldLabel
fld
loc :: SrcSpan
loc = Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
sel_name
occ_name :: OccName
occ_name = Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
sel_name
([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 ([Kind] -> DataCon -> Bool
dataConCannotMatch [Kind]
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, [Kind]
_, [Kind]
_, Kind
_) = DataCon -> ([TyVar], [TyVar], [EqSpec], [Kind], [Kind], Kind)
dataConFullSig DataCon
con1
eq_subst :: TCvSubst
eq_subst = [(TyVar, Kind)] -> TCvSubst
mkTvSubstPrs ((EqSpec -> (TyVar, Kind)) -> [EqSpec] -> [(TyVar, Kind)]
forall a b. (a -> b) -> [a] -> [b]
map EqSpec -> (TyVar, Kind)
eqSpecPair [EqSpec]
eq_spec)
inst_tys :: [Kind]
inst_tys = TCvSubst -> [TyVar] -> [Kind]
substTyVars TCvSubst
eq_subst [TyVar]
univ_tvs
checkFieldCompat :: FieldLabelString -> DataCon -> DataCon
-> Type -> Type -> Type -> Type -> TcM ()
checkFieldCompat :: FieldLabelString
-> DataCon -> DataCon -> Kind -> Kind -> Kind -> Kind -> TcRn ()
checkFieldCompat FieldLabelString
fld DataCon
con1 DataCon
con2 Kind
res1 Kind
res2 Kind
fty1 Kind
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 = Kind -> Kind -> Maybe TCvSubst
tcMatchTy Kind
res1 Kind
res2
mb_subst2 :: Maybe TCvSubst
mb_subst2 = TCvSubst -> Kind -> Kind -> Maybe TCvSubst
tcMatchTyX (String -> Maybe TCvSubst -> TCvSubst
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"checkFieldCompat" Maybe TCvSubst
mb_subst1) Kind
fty1 Kind
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 (DataCon -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan DataCon
con) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn () -> TcRn ()
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
dataConCtxt DataCon
con) (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 :: Kind
res_ty_tmpl = TyCon -> [Kind] -> Kind
mkFamilyTyConApp TyCon
tc ([TyVar] -> [Kind]
mkTyVarTys [TyVar]
tc_tvs)
orig_res_ty :: Kind
orig_res_ty = DataCon -> Kind
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
, Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
res_ty_tmpl SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Kind -> Kind
Kind -> Kind
tcTypeKind Kind
res_ty_tmpl)
, Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
orig_res_ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Kind -> Kind
Kind -> Kind
tcTypeKind Kind
orig_res_ty)])
; Bool -> SDoc -> TcRn ()
checkTc (Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust (Kind -> Kind -> Maybe TCvSubst
tcMatchTy Kind
res_ty_tmpl
Kind
orig_res_ty))
(DataCon -> Kind -> Kind -> SDoc
badDataConTyCon DataCon
con Kind
res_ty_tmpl Kind
orig_res_ty)
; String -> SDoc -> TcRn ()
traceTc String
"checkValidDataCon 2" (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DataCon -> Kind
dataConUserType DataCon
con))
; Kind -> TcRn ()
checkValidMonoType Kind
orig_res_ty
; UserTypeCtxt -> Kind -> TcRn ()
checkValidType UserTypeCtxt
ctxt (DataCon -> Kind
dataConUserType DataCon
con)
; (Kind -> TcRn ()) -> [Kind] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SDoc -> Kind -> TcRn ()
checkForLevPoly SDoc
empty)
(DataCon -> [Kind]
dataConOrigArgTys DataCon
con)
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyCon -> Bool
isNewTyCon TyCon
tc) (DataCon -> TcRn ()
checkNewDataCon DataCon
con)
; Bool -> SDoc -> TcRn ()
checkTc (Bool
existential_ok Bool -> Bool -> Bool
|| DataCon -> Bool
isVanillaDataCon DataCon
con)
(DataCon -> SDoc
badExistential DataCon
con)
; (HsSrcBang -> HsImplBang -> Int -> TcRn ())
-> [HsSrcBang] -> [HsImplBang] -> [Int] -> TcRn ()
forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m ()
zipWith3M_ HsSrcBang -> HsImplBang -> Int -> TcRn ()
check_bang (DataCon -> [HsSrcBang]
dataConSrcBangs DataCon
con) (DataCon -> [HsImplBang]
dataConImplBangs DataCon
con) [Int
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, [Kind]
_, [Kind]
_, Kind
_) = DataCon -> ([TyVar], [TyVar], [EqSpec], [Kind], [Kind], Kind)
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
; WARN( not user_tvbs_invariant
, vcat ([ ppr con
, ppr univs
, ppr exs
, ppr eq_spec
, ppr user_tvs ])) return () }
; 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 user type:" SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DataCon -> Kind
dataConUserType DataCon
con)
, String -> SDoc
text String
"Datacon rep type:" SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DataCon -> Kind
dataConRepType DataCon
con)
, 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, [Kind])
tyConFamInst_maybe (DataCon -> TyCon
dataConTyCon DataCon
con) of
Maybe (TyCon, [Kind])
Nothing -> String -> SDoc
text String
"not family"
Just (TyCon
f, [Kind]
_) -> [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [TyConBinder]
tyConBinders TyCon
f) ]
}
where
ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
ConArgCtxt (DataCon -> Name
dataConName DataCon
con)
check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()
check_bang :: HsSrcBang -> HsImplBang -> Int -> TcRn ()
check_bang (HsSrcBang SourceText
_ SrcUnpackedness
_ SrcStrictness
SrcLazy) HsImplBang
_ Int
n
| Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.StrictData DynFlags
dflags)
= SDoc -> TcRn ()
addErrTc
(Int -> SDoc -> SDoc
bad_bang Int
n (String -> SDoc
text String
"Lazy annotation (~) without StrictData"))
check_bang (HsSrcBang SourceText
_ SrcUnpackedness
want_unpack SrcStrictness
strict_mark) HsImplBang
rep_bang Int
n
| SrcUnpackedness -> Bool
isSrcUnpacked SrcUnpackedness
want_unpack, Bool -> Bool
not Bool
is_strict
= WarnReason -> SDoc -> TcRn ()
addWarnTc WarnReason
NoReason (Int -> SDoc -> SDoc
bad_bang Int
n (String -> SDoc
text String
"UNPACK pragma lacks '!'"))
| 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)
, UnitId -> Bool
unitIdIsDefinite (DynFlags -> UnitId
thisPackage DynFlags
dflags)
= WarnReason -> SDoc -> TcRn ()
addWarnTc WarnReason
NoReason (Int -> SDoc -> SDoc
bad_bang Int
n (String -> SDoc
text String
"Ignoring unusable UNPACK pragma"))
where
is_strict :: Bool
is_strict = case SrcStrictness
strict_mark of
SrcStrictness
NoSrcStrict -> Extension -> DynFlags -> Bool
xopt Extension
LangExt.StrictData DynFlags
dflags
SrcStrictness
bang -> SrcStrictness -> Bool
isSrcStrict SrcStrictness
bang
check_bang HsSrcBang
_ HsImplBang
_ Int
_
= () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
bad_bang :: Int -> SDoc -> SDoc
bad_bang Int
n SDoc
herald
= SDoc -> Int -> SDoc -> SDoc
hang SDoc
herald Int
2 (String -> SDoc
text String
"on the" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakNth Int
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))
checkNewDataCon :: DataCon -> TcM ()
checkNewDataCon :: DataCon -> TcRn ()
checkNewDataCon DataCon
con
= do { Bool -> SDoc -> TcRn ()
checkTc ([Kind] -> Bool
forall a. [a] -> Bool
isSingleton [Kind]
arg_tys) (DataCon -> Int -> SDoc
newtypeFieldErr DataCon
con ([Kind] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Kind]
arg_tys))
; Bool -> SDoc -> TcRn ()
checkTc (Bool -> Bool
not (HasDebugCallStack => Kind -> Bool
Kind -> Bool
isUnliftedType Kind
arg_ty1)) (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"A newtype cannot have an unlifted argument type"
; 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 ([Kind] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Kind]
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, [Kind]
theta, [Kind]
arg_tys, Kind
_res_ty)
= DataCon -> ([TyVar], [TyVar], [EqSpec], [Kind], [Kind], Kind)
dataConFullSig DataCon
con
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
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DataCon -> Kind
dataConUserType DataCon
con))
(Kind
arg_ty1 : [Kind]
_) = [Kind]
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
checkValidClass :: Class -> TcM ()
checkValidClass :: Class -> TcRn ()
checkValidClass Class
cls
= do { Bool
constrained_class_methods <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ConstrainedClassMethods
; Bool
multi_param_type_classes <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.MultiParamTypeClasses
; Bool
nullary_type_classes <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.NullaryTypeClasses
; Bool
fundep_classes <- Extension -> TcRn Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.FunctionalDependencies
; Bool
undecidable_super_classes <- Extension -> TcRn 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
|| Int
cls_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
||
(Bool
nullary_type_classes Bool -> Bool -> Bool
&& Int
cls_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0))
(Int -> Class -> SDoc
classArityErr Int
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 -> [Kind] -> TcRn ()
checkValidTheta (Name -> UserTypeCtxt
ClassSCCtxt (Class -> Name
className Class
cls)) [Kind]
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, [Kind]
theta, [TyVar]
_, [ClassATItem]
at_stuff, [(TyVar, DefMethInfo)]
op_stuff) = Class
-> ([TyVar], [([TyVar], [TyVar])], [Kind], [TyVar], [ClassATItem],
[(TyVar, DefMethInfo)])
classExtraBigSig Class
cls
cls_arity :: Int
cls_arity = [TyVar] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TyCon -> [TyVar]
tyConVisibleTyVars (Class -> TyCon
classTyCon Class
cls))
cls_tv_set :: TcTyCoVarSet
cls_tv_set = [TyVar] -> TcTyCoVarSet
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 -> Kind -> SDoc
classOpCtxt TyVar
sel_id Kind
op_ty) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
{ String -> SDoc -> TcRn ()
traceTc String
"class op type" (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
op_ty)
; UserTypeCtxt -> Kind -> TcRn ()
checkValidType UserTypeCtxt
ctxt Kind
op_ty
; SDoc -> Kind -> TcRn ()
checkForLevPoly SDoc
empty Kind
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
$
(Kind -> TcRn ()) -> [Kind] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Kind -> TcRn ()
check_constraint ([Kind] -> [Kind]
forall a. [a] -> [a]
tail (Kind
cls_predKind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
:[Kind]
op_theta))
; UserTypeCtxt -> TyVar -> Kind -> Kind -> DefMethInfo -> TcRn ()
check_dm UserTypeCtxt
ctxt TyVar
sel_id Kind
cls_pred Kind
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 :: Kind
op_ty = TyVar -> Kind
idType TyVar
sel_id
([TyVar]
_,Kind
cls_pred,Kind
tau1) = Kind -> ([TyVar], Kind, Kind)
tcSplitMethodTy Kind
op_ty
([TyVar]
_,[Kind]
op_theta,Kind
tau2) = Kind -> ([TyVar], [Kind], Kind)
tcSplitNestedSigmaTys Kind
tau1
check_constraint :: TcPredType -> TcM ()
check_constraint :: Kind -> TcRn ()
check_constraint Kind
pred
= Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (TcTyCoVarSet -> Bool
isEmptyVarSet TcTyCoVarSet
pred_tvs) Bool -> Bool -> Bool
&&
TcTyCoVarSet
pred_tvs TcTyCoVarSet -> TcTyCoVarSet -> Bool
`subVarSet` TcTyCoVarSet
cls_tv_set)
(SDoc -> TcRn ()
addErrTc (TyVar -> Kind -> SDoc
badMethPred TyVar
sel_id Kind
pred))
where
pred_tvs :: TcTyCoVarSet
pred_tvs = Kind -> TcTyCoVarSet
tyCoVarsOfType Kind
pred
check_at :: ClassATItem -> TcRn ()
check_at (ATI TyCon
fam_tc Maybe (Kind, SrcSpan)
m_dflt_rhs)
= do { Bool -> SDoc -> TcRn ()
checkTc (Int
cls_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| (TyVar -> Bool) -> [TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TyVar -> TcTyCoVarSet -> Bool
`elemVarSet` TcTyCoVarSet
cls_tv_set) [TyVar]
fam_tvs)
(Class -> TyCon -> SDoc
noClassTyVarErr Class
cls TyCon
fam_tc)
; Maybe (Kind, SrcSpan) -> ((Kind, SrcSpan) -> TcRn ()) -> TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust Maybe (Kind, SrcSpan)
m_dflt_rhs (((Kind, SrcSpan) -> TcRn ()) -> TcRn ())
-> ((Kind, SrcSpan) -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$ \ (Kind
rhs, SrcSpan
loc) ->
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
$
TyCon -> [TyVar] -> [Kind] -> Kind -> TcRn ()
checkValidTyFamEqn TyCon
fam_tc [TyVar]
fam_tvs ([TyVar] -> [Kind]
mkTyVarTys [TyVar]
fam_tvs) Kind
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 -> Kind -> Kind -> DefMethInfo -> TcRn ()
check_dm UserTypeCtxt
ctxt TyVar
sel_id Kind
vanilla_cls_pred Kind
vanilla_tau
(Just (Name
dm_name, dm_spec :: DefMethSpec Kind
dm_spec@(GenericDM Kind
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 :: Kind
cls_pred = Class -> [Kind] -> Kind
mkClassPred Class
cls ([Kind] -> Kind) -> [Kind] -> Kind
forall a b. (a -> b) -> a -> b
$ [TyVar] -> [Kind]
mkTyVarTys ([TyVar] -> [Kind]) -> [TyVar] -> [Kind]
forall a b. (a -> b) -> a -> b
$ Class -> [TyVar]
classTyVars Class
cls
([TyVar]
_, [Kind]
_, Kind
dm_tau) = Kind -> ([TyVar], [Kind], Kind)
tcSplitNestedSigmaTys Kind
dm_ty
vanilla_phi_ty :: Kind
vanilla_phi_ty = [Kind] -> Kind -> Kind
mkPhiTy [Kind
vanilla_cls_pred] Kind
vanilla_tau
dm_phi_ty :: Kind
dm_phi_ty = [Kind] -> Kind -> Kind
mkPhiTy [Kind
cls_pred] Kind
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
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
vanilla_phi_ty
, String -> SDoc
text String
"dm_phi_ty" SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
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
$ [Kind] -> [Kind] -> Maybe TCvSubst
tcMatchTys [Kind
dm_phi_ty, Kind
vanilla_phi_ty]
[Kind
vanilla_phi_ty, Kind
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 -> Int -> 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)
Int
2 (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
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 -> Kind -> TcRn ()
checkValidType UserTypeCtxt
ctxt (Class -> TyVar -> DefMethSpec Kind -> Kind
mkDefaultMethodType Class
cls TyVar
sel_id DefMethSpec Kind
dm_spec)
check_dm UserTypeCtxt
_ TyVar
_ Kind
_ Kind
_ 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 -> TcRn 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 -> Int -> 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))
Int
2 (String -> SDoc
text String
"Enable TypeFamilies to allow indexed type families")
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 (LRoleAnnotDecl GhcRn)
-> (LRoleAnnotDecl GhcRn -> TcRn ()) -> TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust Maybe (LRoleAnnotDecl GhcRn)
role_annot_decl_maybe ((LRoleAnnotDecl GhcRn -> TcRn ()) -> TcRn ())
-> (LRoleAnnotDecl GhcRn -> TcRn ()) -> TcRn ()
forall a b. (a -> b) -> a -> b
$
\decl :: LRoleAnnotDecl GhcRn
decl@(LRoleAnnotDecl GhcRn
-> Located (SrcSpanLess (LRoleAnnotDecl GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc (RoleAnnotDecl _ _ 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
$
SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ do
{ Bool
role_annots_ok <- Extension -> TcRn 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] -> [Located (Maybe Role)] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [Located (Maybe Role)]
the_role_annots)
([TyVar] -> LRoleAnnotDecl GhcRn -> SDoc
forall a. [a] -> LRoleAnnotDecl GhcRn -> SDoc
wrongNumberOfRoles [TyVar]
vis_vars LRoleAnnotDecl GhcRn
decl)
; [()]
_ <- (TyVar -> Located (Maybe Role) -> Role -> TcRn ())
-> [TyVar]
-> [Located (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 -> Located (Maybe Role) -> Role -> TcRn ()
checkRoleAnnot [TyVar]
vis_vars [Located (Maybe Role)]
the_role_annots [Role]
vis_roles
; Bool
incoherent_roles_ok <- Extension -> TcRn 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 -> TcRn 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 (LRoleAnnotDecl GhcRn)
-> (LRoleAnnotDecl GhcRn -> TcRn ()) -> TcRn ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust Maybe (LRoleAnnotDecl GhcRn)
role_annot_decl_maybe LRoleAnnotDecl GhcRn -> TcRn ()
illegalRoleAnnotDecl
checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM ()
checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcRn ()
checkRoleAnnot TyVar
_ (Located (Maybe Role)
-> Located (SrcSpanLess (Located (Maybe Role)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located (Maybe Role))
Nothing) Role
_ = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkRoleAnnot TyVar
tv (Located (Maybe Role)
-> Located (SrcSpanLess (Located (Maybe Role)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (Just 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
checkRoleAnnot TyVar
_ Located (Maybe Role)
_ Role
_ = String -> TcRn ()
forall a. String -> a
panic String
"checkRoleAnnot: Impossible Match"
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 Kind
rhs <- TyCon -> Maybe Kind
synTyConRhs_maybe TyCon
tc
= UniqFM Role -> Role -> Kind -> TcRn ()
check_ty_roles ([TyVar] -> [Role] -> UniqFM Role
forall a. [TyVar] -> [a] -> VarEnv a
zipVarEnv (TyCon -> [TyVar]
tyConTyVars TyCon
tc) (TyCon -> [Role]
tyConRoles TyCon
tc)) Role
Representational Kind
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))
; (Kind -> TcRn ()) -> [Kind] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (UniqFM Role -> Role -> Kind -> TcRn ()
check_ty_roles UniqFM Role
role_env Role
Representational) ([Kind] -> TcRn ()) -> [Kind] -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[EqSpec] -> [Kind]
eqSpecPreds [EqSpec]
eq_spec [Kind] -> [Kind] -> [Kind]
forall a. [a] -> [a] -> [a]
++ [Kind]
theta [Kind] -> [Kind] -> [Kind]
forall a. [a] -> [a] -> [a]
++ [Kind]
arg_tys }
where
([TyVar]
univ_tvs, [TyVar]
ex_tvs, [EqSpec]
eq_spec, [Kind]
theta, [Kind]
arg_tys, Kind
_res_ty)
= DataCon -> ([TyVar], [TyVar], [EqSpec], [Kind], [Kind], Kind)
dataConFullSig DataCon
datacon
univ_roles :: UniqFM Role
univ_roles = [TyVar] -> [Role] -> UniqFM Role
forall a. [TyVar] -> [a] -> VarEnv a
zipVarEnv [TyVar]
univ_tvs (TyCon -> [Role]
tyConRoles TyCon
tc)
ex_roles :: UniqFM Role
ex_roles = [(TyVar, Role)] -> UniqFM 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 :: UniqFM Role
role_env = UniqFM Role
univ_roles UniqFM Role -> UniqFM Role -> UniqFM Role
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusVarEnv` UniqFM Role
ex_roles
check_ty_roles :: UniqFM Role -> Role -> Kind -> TcRn ()
check_ty_roles UniqFM Role
env Role
role Kind
ty
| Just Kind
ty' <- Kind -> Maybe Kind
coreView Kind
ty
= UniqFM Role -> Role -> Kind -> TcRn ()
check_ty_roles UniqFM Role
env Role
role Kind
ty'
check_ty_roles UniqFM Role
env Role
role (TyVarTy TyVar
tv)
= case UniqFM Role -> TyVar -> Maybe Role
forall a. VarEnv a -> TyVar -> Maybe a
lookupVarEnv UniqFM 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 UniqFM Role
env Role
Representational (TyConApp TyCon
tc [Kind]
tys)
= let roles' :: [Role]
roles' = TyCon -> [Role]
tyConRoles TyCon
tc in
(Role -> Kind -> TcRn ()) -> [Role] -> [Kind] -> TcRn ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (UniqFM Role -> Role -> Kind -> TcRn ()
maybe_check_ty_roles UniqFM Role
env) [Role]
roles' [Kind]
tys
check_ty_roles UniqFM Role
env Role
Nominal (TyConApp TyCon
_ [Kind]
tys)
= (Kind -> TcRn ()) -> [Kind] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (UniqFM Role -> Role -> Kind -> TcRn ()
check_ty_roles UniqFM Role
env Role
Nominal) [Kind]
tys
check_ty_roles UniqFM Role
_ Role
Phantom ty :: Kind
ty@(TyConApp {})
= String -> SDoc -> TcRn ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"check_ty_roles" (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
ty)
check_ty_roles UniqFM Role
env Role
role (AppTy Kind
ty1 Kind
ty2)
= UniqFM Role -> Role -> Kind -> TcRn ()
check_ty_roles UniqFM Role
env Role
role Kind
ty1
TcRn () -> TcRn () -> TcRn ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UniqFM Role -> Role -> Kind -> TcRn ()
check_ty_roles UniqFM Role
env Role
Nominal Kind
ty2
check_ty_roles UniqFM Role
env Role
role (FunTy Kind
ty1 Kind
ty2)
= UniqFM Role -> Role -> Kind -> TcRn ()
check_ty_roles UniqFM Role
env Role
role Kind
ty1
TcRn () -> TcRn () -> TcRn ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UniqFM Role -> Role -> Kind -> TcRn ()
check_ty_roles UniqFM Role
env Role
role Kind
ty2
check_ty_roles UniqFM Role
env Role
role (ForAllTy (Bndr TyVar
tv ArgFlag
_) Kind
ty)
= UniqFM Role -> Role -> Kind -> TcRn ()
check_ty_roles UniqFM Role
env Role
Nominal (TyVar -> Kind
tyVarKind TyVar
tv)
TcRn () -> TcRn () -> TcRn ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UniqFM Role -> Role -> Kind -> TcRn ()
check_ty_roles (UniqFM Role -> TyVar -> Role -> UniqFM Role
forall a. VarEnv a -> TyVar -> a -> VarEnv a
extendVarEnv UniqFM Role
env TyVar
tv Role
Nominal) Role
role Kind
ty
check_ty_roles UniqFM Role
_ Role
_ (LitTy {}) = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check_ty_roles UniqFM Role
env Role
role (CastTy Kind
t CoercionN
_)
= UniqFM Role -> Role -> Kind -> TcRn ()
check_ty_roles UniqFM Role
env Role
role Kind
t
check_ty_roles UniqFM Role
_ Role
role (CoercionTy CoercionN
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
<+> CoercionN -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoercionN
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 :: UniqFM Role -> Role -> Kind -> TcRn ()
maybe_check_ty_roles UniqFM Role
env Role
role Kind
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
$
UniqFM Role -> Role -> Kind -> TcRn ()
check_ty_roles UniqFM Role
env Role
role Kind
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"]
tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a
tcAddTyFamInstCtxt :: 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 pass. TyFamInstDecl pass -> IdP pass
tyFamInstDeclName TyFamInstDecl GhcRn
decl)
tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc
tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc
tcMkDataFamInstCtxt decl :: DataFamInstDecl GhcRn
decl@(DataFamInstDecl { dfid_eqn :: forall pass.
DataFamInstDecl pass -> FamInstEqn pass (HsDataDefn pass)
dfid_eqn =
HsIB { hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = FamEqn
GhcRn [HsArg (LHsKind GhcRn) (LHsKind 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")
(Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (FamEqn
GhcRn [HsArg (LHsKind GhcRn) (LHsKind GhcRn)] (HsDataDefn GhcRn)
-> GenLocated SrcSpan (IdP GhcRn)
forall pass pats rhs. FamEqn pass pats rhs -> Located (IdP pass)
feqn_tycon FamEqn
GhcRn [HsArg (LHsKind GhcRn) (LHsKind GhcRn)] (HsDataDefn GhcRn)
eqn))
tcMkDataFamInstCtxt (DataFamInstDecl (XHsImplicitBndrs XXHsImplicitBndrs
GhcRn
(FamEqn
GhcRn [HsArg (LHsKind GhcRn) (LHsKind GhcRn)] (HsDataDefn GhcRn))
_))
= String -> SDoc
forall a. String -> a
panic String
"tcMkDataFamInstCtxt"
tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a
tcAddDataFamInstCtxt :: 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 :: 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 :: 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],
Int -> SDoc -> SDoc
nest Int
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)]
dataConCtxtName :: [Located Name] -> SDoc
dataConCtxtName :: [Located Name] -> SDoc
dataConCtxtName [Located Name
con]
= String -> SDoc
text String
"In the definition of data constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Located Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located Name
con)
dataConCtxtName [Located Name]
con
= String -> SDoc
text String
"In the definition of data constructors" SDoc -> SDoc -> SDoc
<+> [Located Name] -> SDoc
forall a. Outputable a => [a] -> SDoc
interpp'SP [Located Name]
con
dataConCtxt :: Outputable a => a -> SDoc
dataConCtxt :: a -> SDoc
dataConCtxt a
con = String -> SDoc
text String
"In the definition of data constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
con)
classOpCtxt :: Var -> Type -> SDoc
classOpCtxt :: TyVar -> Kind -> SDoc
classOpCtxt TyVar
sel_id Kind
tau = [SDoc] -> SDoc
sep [String -> SDoc
text String
"When checking the class method:",
Int -> SDoc -> SDoc
nest Int
2 (TyVar -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc TyVar
sel_id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
tau)]
classArityErr :: Int -> Class -> SDoc
classArityErr :: Int -> Class -> SDoc
classArityErr Int
n Class
cls
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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 -> Kind -> SDoc
badMethPred TyVar
sel_id Kind
pred
= [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Constraint" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
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))
Int
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)
, 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 -> Type -> SDoc
badDataConTyCon :: DataCon -> Kind -> Kind -> SDoc
badDataConTyCon DataCon
data_con Kind
res_ty_tmpl Kind
actual_res_ty
| ASSERT( all isTyVar actual_ex_tvs )
Kind -> Bool
tcIsForAllTy Kind
actual_res_ty
= SDoc
nested_foralls_contexts_suggestion
| Maybe (Kind, Kind) -> Bool
forall a. Maybe a -> Bool
isJust (Kind -> Maybe (Kind, Kind)
tcSplitPredFunTy_maybe Kind
actual_res_ty)
= SDoc
nested_foralls_contexts_suggestion
| Bool
otherwise
= SDoc -> Int -> 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 (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
actual_res_ty))
Int
2 (String -> SDoc
text String
"instead of an instance of its parent type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
res_ty_tmpl))
where
nested_foralls_contexts_suggestion :: SDoc
nested_foralls_contexts_suggestion =
String -> SDoc
text String
"GADT constructor type signature cannot contain nested"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes SDoc
forAllLit SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"s or contexts"
SDoc -> SDoc -> SDoc
$+$ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Suggestion: instead use this type signature:")
Int
2 (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DataCon -> Name
dataConName DataCon
data_con) SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
suggested_ty)
actual_ex_tvs :: [TyVar]
actual_ex_tvs = DataCon -> [TyVar]
dataConExTyCoVars DataCon
data_con
actual_theta :: [Kind]
actual_theta = DataCon -> [Kind]
dataConTheta DataCon
data_con
([TyVar]
actual_res_tvs, [Kind]
actual_res_theta, Kind
actual_res_rho)
= Kind -> ([TyVar], [Kind], Kind)
tcSplitNestedSigmaTys Kind
actual_res_ty
suggested_ty :: Kind
suggested_ty = [TyVar] -> Kind -> Kind
mkSpecForAllTys ([TyVar]
actual_ex_tvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
actual_res_tvs) (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$
[Kind] -> Kind -> Kind
mkFunTys ([Kind]
actual_theta [Kind] -> [Kind] -> [Kind]
forall a. [a] -> [a] -> [a]
++ [Kind]
actual_res_theta)
Kind
actual_res_rho
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)
, Int -> SDoc -> SDoc
nest Int
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
= SDoc -> Int -> 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")
Int
2 ([SDoc] -> SDoc
vcat [ DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DataCon -> Kind
dataConUserType 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 -> Int -> SDoc
newtypeConError Name
tycon Int
n
= [SDoc] -> SDoc
sep [String -> SDoc
text String
"A newtype must have exactly one constructor,",
Int -> SDoc -> SDoc
nest Int
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
<+> Int -> SDoc
speakN Int
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,",
Int -> SDoc -> SDoc
nest Int
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 -> Int -> SDoc
newtypeFieldErr DataCon
con_name Int
n_flds
= [SDoc] -> SDoc
sep [String -> SDoc
text String
"The constructor of a newtype must have exactly one field",
Int -> SDoc -> SDoc
nest Int
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
<+> Int -> SDoc
speakN Int
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)
, Int -> SDoc -> SDoc
nest Int
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",
Int -> SDoc -> SDoc
nest Int
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 :: Int -> SDoc
wrongNumberOfParmsErr Int
max_args
= String -> SDoc
text String
"Number of parameters must match family declaration; expected"
SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
max_args
defaultAssocKindErr :: TyCon -> SDoc
defaultAssocKindErr :: TyCon -> SDoc
defaultAssocKindErr TyCon
fam_tc
= String -> SDoc
text String
"Kind mis-match on LHS of default declaration for"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc)
badRoleAnnot :: Name -> Role -> Role -> SDoc
badRoleAnnot :: Name -> Role -> Role -> SDoc
badRoleAnnot Name
var Role
annot Role
inferred
= SDoc -> Int -> 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)
Int
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 :: [a] -> LRoleAnnotDecl GhcRn -> SDoc
wrongNumberOfRoles [a]
tyvars d :: LRoleAnnotDecl GhcRn
d@(LRoleAnnotDecl GhcRn
-> Located (SrcSpanLess (LRoleAnnotDecl GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (RoleAnnotDecl _ _ annots))
= SDoc -> Int -> 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
<+> (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int -> SDoc) -> Int -> SDoc
forall a b. (a -> b) -> a -> b
$ [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
tyvars) SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"got" SDoc -> SDoc -> SDoc
<+> (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int -> SDoc) -> Int -> SDoc
forall a b. (a -> b) -> a -> b
$ [Located (Maybe Role)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Located (Maybe Role)]
annots) SDoc -> SDoc -> SDoc
<> SDoc
colon)
Int
2 (LRoleAnnotDecl GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr LRoleAnnotDecl GhcRn
d)
wrongNumberOfRoles [a]
_ (LRoleAnnotDecl GhcRn
-> Located (SrcSpanLess (LRoleAnnotDecl GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (XRoleAnnotDecl _)) = String -> SDoc
forall a. String -> a
panic String
"wrongNumberOfRoles"
wrongNumberOfRoles [a]
_ LRoleAnnotDecl GhcRn
_ = String -> SDoc
forall a. String -> a
panic String
"wrongNumberOfRoles: Impossible Match"
illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM ()
illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcRn ()
illegalRoleAnnotDecl (LRoleAnnotDecl GhcRn
-> Located (SrcSpanLess (LRoleAnnotDecl GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc (RoleAnnotDecl _ tycon _))
= [ErrCtxt] -> TcRn () -> TcRn ()
forall a. [ErrCtxt] -> TcM a -> TcM a
setErrCtxt [] (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
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 -> TcRn ()
addErrTc (String -> SDoc
text String
"Illegal role annotation for" SDoc -> SDoc -> SDoc
<+> Located Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpan (IdP GhcRn)
Located Name
tycon SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
';' SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"they are allowed only for datatypes and classes.")
illegalRoleAnnotDecl (LRoleAnnotDecl GhcRn
-> Located (SrcSpanLess (LRoleAnnotDecl GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (XRoleAnnotDecl _)) = String -> TcRn ()
forall a. String -> a
panic String
"illegalRoleAnnotDecl"
illegalRoleAnnotDecl LRoleAnnotDecl GhcRn
_ = String -> TcRn ()
forall a. String -> a
panic String
"illegalRoleAnnotDecl: Impossible Match"
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")
addTyConCtxt :: TyCon -> TcM a -> TcM a
addTyConCtxt :: 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 :: 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)