diff options
| -rw-r--r-- | compiler/typecheck/TcBinds.hs | 11 | ||||
| -rw-r--r-- | compiler/typecheck/TcEnv.hs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcInstDcls.hs | 12 | ||||
| -rw-r--r-- | compiler/typecheck/TcPatSyn.hs | 8 | ||||
| -rw-r--r-- | compiler/typecheck/TcTyClsDecls.hs | 68 | ||||
| -rw-r--r-- | compiler/typecheck/TcTyDecls.hs | 52 | ||||
| -rw-r--r-- | testsuite/tests/dependent/should_fail/T15215.hs | 12 | ||||
| -rw-r--r-- | testsuite/tests/dependent/should_fail/T15215.stderr | 12 | ||||
| -rw-r--r-- | testsuite/tests/dependent/should_fail/all.T | 1 |
9 files changed, 111 insertions, 67 deletions
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index fadf0e9651..468950a1b2 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -9,7 +9,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, +module TcBinds ( tcLocalBinds, tcTopBinds, tcValBinds, tcHsBootSigs, tcPolyCheck, addTypecheckedBinds, chooseInferredQuantifiers, @@ -304,15 +304,6 @@ tcCompleteSigs sigs = <+> quotes (ppr tc')) in mapMaybeM (addLocM doOne) sigs -tcRecSelBinds :: HsValBinds GhcRn -> TcM TcGblEnv -tcRecSelBinds (XValBindsLR (NValBinds binds sigs)) - = tcExtendGlobalValEnv [sel_id | L _ (IdSig _ sel_id) <- sigs] $ - do { (rec_sel_binds, tcg_env) <- discardWarnings $ - tcValBinds TopLevel binds sigs getGblEnv - ; let tcg_env' = tcg_env `addTypecheckedBinds` map snd rec_sel_binds - ; return tcg_env' } -tcRecSelBinds (ValBinds {}) = panic "tcRecSelBinds" - tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] -- A hs-boot file has only one BindGroup, and it only has type -- signatures in it. The renamer checked all this diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 0d875d7380..4ea49ad011 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -330,7 +330,7 @@ setGlobalTypeEnv tcg_env new_type_env tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r -- Just extend the global environment with some TyThings - -- Do not extend tcg_tcs etc + -- Do not extend tcg_tcs, tcg_patsyns etc tcExtendGlobalEnvImplicit things thing_inside = do { tcg_env <- getGblEnv ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 13b91d51cc..1d9997822d 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -19,6 +19,7 @@ import GhcPrelude import HsSyn import TcBinds import TcTyClsDecls +import TcTyDecls ( addTyConsToGblEnv ) import TcClassDcl( tcClassDecl2, tcATDefault, HsSigFun, mkHsSigFun, findMethodBind, instantiateMethod ) @@ -416,13 +417,12 @@ addFamInsts :: [FamInst] -> TcM a -> TcM a -- (b) the type envt with stuff from data type decls addFamInsts fam_insts thing_inside = tcExtendLocalFamInstEnv fam_insts $ - tcExtendGlobalEnv axioms $ - tcExtendTyConEnv data_rep_tycons $ + tcExtendGlobalEnv axioms $ do { traceTc "addFamInsts" (pprFamInsts fam_insts) - ; tcg_env <- tcAddImplicits data_rep_tycons - -- Does not add its axiom; that comes from - -- adding the 'axioms' above - ; setGblEnv tcg_env thing_inside } + ; gbl_env <- addTyConsToGblEnv data_rep_tycons + -- Does not add its axiom; that comes + -- from adding the 'axioms' above + ; setGblEnv gbl_env thing_inside } where axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts data_rep_tycons = famInstsRepTyCons fam_insts diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index fdb9ead605..a8089b7256 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -709,12 +709,10 @@ tcPatSynMatcher (L loc name) lpat mkPatSynRecSelBinds :: PatSyn -> [FieldLabel] -- ^ Visible field labels - -> HsValBinds GhcRn + -> [(Id, LHsBind GhcRn)] mkPatSynRecSelBinds ps fields - = XValBindsLR (NValBinds selector_binds sigs) - where - (sigs, selector_binds) = unzip (map mkRecSel fields) - mkRecSel fld_lbl = mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl + = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl + | fld_lbl <- fields ] isUnidirectional :: HsPatSynDir a -> Bool isUnidirectional Unidirectional = True diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 729be95796..0e095de2ea 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -10,7 +10,7 @@ TcTyClsDecls: Typecheck type and class declarations {-# LANGUAGE TypeFamilies #-} module TcTyClsDecls ( - tcTyAndClassDecls, tcAddImplicits, + tcTyAndClassDecls, -- Functions used by TcInstDcls to check -- data/type family instance declarations @@ -69,6 +69,7 @@ import SrcLoc import ListSetOps import DynFlags import Unique +import ConLike( ConLike(..) ) import BasicTypes import qualified GHC.LanguageExtensions as LangExt @@ -167,7 +168,7 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds -- Do it before Step 3 (adding implicit things) because the latter -- expects well-formed TyCons ; traceTc "Starting validity check" (ppr tyclss) - ; tyclss <- mapM checkValidTyCl tyclss + ; tyclss <- concatMapM checkValidTyCl tyclss ; traceTc "Done validity check" (ppr tyclss) ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss -- See Note [Check role annotations in a second pass] @@ -177,14 +178,12 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds -- Step 3: Add the implicit things; -- we want them in the environment because -- they may be mentioned in interface files - ; tcExtendTyConEnv tyclss $ - do { gbl_env <- tcAddImplicits tyclss + ; gbl_env <- addTyConsToGblEnv tyclss + + -- Step 4: check instance declarations ; setGblEnv gbl_env $ - do { - -- Step 4: check instance declarations - ; (gbl_env, inst_info, datafam_deriv_info) <- tcInstDecls1 instds + tcInstDecls1 instds } - ; return (gbl_env, inst_info, datafam_deriv_info) } } } tcTyClGroup (XTyClGroup _) = panic "tcTyClGroup" tcTyClDecls :: [LTyClDecl GhcRn] -> RoleAnnotEnv -> TcM [TyCon] @@ -2450,7 +2449,11 @@ Validity checking is done once the mutually-recursive knot has been tied, so we can look at things freely. -} -checkValidTyCl :: TyCon -> TcM TyCon +checkValidTyCl :: TyCon -> TcM [TyCon] +-- The returned list is either a singleton (if valid) +-- or a list of "fake tycons" (if not); the fake tycons +-- include any implicits, like promoted data constructors +-- See Note [Recover from validity error] checkValidTyCl tc = setSrcSpan (getSrcSpan tc) $ addTyConCtxt tc $ @@ -2458,15 +2461,19 @@ checkValidTyCl tc (do { traceTc "Starting validity for tycon" (ppr tc) ; checkValidTyCon tc ; traceTc "Done validity for tycon" (ppr tc) - ; return tc }) + ; return [tc] }) where recovery_code -- See Note [Recover from validity error] = do { traceTc "Aborted validity for tycon" (ppr tc) - ; return fake_tc } - fake_tc | not (isClassTyCon tc) - = makeRecoveryTyCon tc - | otherwise - = tc + ; return (concatMap mk_fake_tc $ + ATyCon tc : implicitTyConThings tc) } + + mk_fake_tc (ATyCon tc) + | isClassTyCon tc = [tc] -- Ugh! Note [Recover from validity error] + | otherwise = [makeRecoveryTyCon tc] + mk_fake_tc (AConLike (RealDataCon dc)) + = [makeRecoveryTyCon (promoteDataCon dc)] + mk_fake_tc _ = [] {- Note [Recover from validity error] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2480,14 +2487,29 @@ want to go on checking validity of subsequent type declarations. So we replace T with an abstract TyCon which will do no harm. See indexed-types/should_fail/BadSock and Trac #10896 -Painfully, though, we *don't* want to do this for classes. -Consider tcfail041: - class (?x::Int) => C a where ... - instance C Int -The class is invalid because of the superclass constraint. But -we still want it to look like a /class/, else the instance bleats -that the instance is mal-formed because it hasn't got a class in -the head. +Some notes: + +* We must make fakes for promoted DataCons too. Consider (Trac #15215) + data T a = MkT ... + data S a = ...T...MkT.... + If there is an error in the definition of 'T' we add a "fake type + constructor" to the type environment, so that we can continue to + typecheck 'S'. But we /were not/ adding a fake anything for 'MkT' + and so there was an internal error when we met 'MkT' in the body of + 'S'. + +* Painfully, we *don't* want to do this for classes. + Consider tcfail041: + class (?x::Int) => C a where ... + instance C Int + The class is invalid because of the superclass constraint. But + we still want it to look like a /class/, else the instance bleats + that the instance is mal-formed because it hasn't got a class in + the head. + + This is really bogus; now we have in scope a Class that is invalid + in some way, with unknown downstream consequences. A better + alterantive might be to make a fake class TyCon. A job for another day. -} ------------------------- diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index da8221d72b..cce0f02a0b 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -19,10 +19,10 @@ module TcTyDecls( checkClassCycles, -- * Implicits - tcAddImplicits, mkDefaultMethodType, + addTyConsToGblEnv, mkDefaultMethodType, -- * Record selectors - mkRecSelBinds, mkOneRecordSelector + tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector ) where #include "HsVersions.h" @@ -31,7 +31,7 @@ import GhcPrelude import TcRnMonad import TcEnv -import TcBinds( tcRecSelBinds ) +import TcBinds( tcValBinds, addTypecheckedBinds ) import TyCoRep( Type(..), Coercion(..), UnivCoProvenance(..) ) import TcType import TysWiredIn( unitTy ) @@ -743,23 +743,24 @@ updateRoleEnv name n role * * ********************************************************************* -} -tcAddImplicits :: [TyCon] -> TcM TcGblEnv +addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv -- Given a [TyCon], add to the TcGblEnv +-- * extend the TypeEnv with the tycons -- * extend the TypeEnv with their implicitTyThings -- * extend the TypeEnv with any default method Ids -- * add bindings for record selectors --- * add bindings for type representations for the TyThings -tcAddImplicits tycons - = discardWarnings $ +addTyConsToGblEnv tyclss + = tcExtendTyConEnv tyclss $ tcExtendGlobalEnvImplicit implicit_things $ tcExtendGlobalValEnv def_meth_ids $ - do { traceTc "tcAddImplicits" $ vcat - [ text "tycons" <+> ppr tycons + do { traceTc "tcAddTyCons" $ vcat + [ text "tycons" <+> ppr tyclss , text "implicits" <+> ppr implicit_things ] - ; tcRecSelBinds (mkRecSelBinds tycons) } + ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss) + ; return gbl_env } where - implicit_things = concatMap implicitTyConThings tycons - def_meth_ids = mkDefaultMethodIds tycons + implicit_things = concatMap implicitTyConThings tyclss + def_meth_ids = mkDefaultMethodIds tyclss mkDefaultMethodIds :: [TyCon] -> [Id] -- We want to put the default-method Ids (both vanilla and generic) @@ -822,30 +823,37 @@ when typechecking the [d| .. |] quote, and typecheck them later. ************************************************************************ -} -mkRecSelBinds :: [TyCon] -> HsValBinds GhcRn +tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv +tcRecSelBinds sel_bind_prs + = tcExtendGlobalValEnv [sel_id | L _ (IdSig _ sel_id) <- sigs] $ + do { (rec_sel_binds, tcg_env) <- discardWarnings $ + tcValBinds TopLevel binds sigs getGblEnv + ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } + where + sigs = [ L loc (IdSig noExt sel_id) | (sel_id, _) <- sel_bind_prs + , let loc = getSrcSpan sel_id ] + binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs] + +mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)] -- NB We produce *un-typechecked* bindings, rather like 'deriving' -- This makes life easier, because the later type checking will add -- all necessary type abstractions and applications mkRecSelBinds tycons - = XValBindsLR (NValBinds binds sigs) - where - (sigs, binds) = unzip rec_sels - rec_sels = map mkRecSelBind [ (tc,fld) - | tc <- tycons + = map mkRecSelBind [ (tc,fld) | tc <- tycons , fld <- tyConFieldLabels tc ] -mkRecSelBind :: (TyCon, FieldLabel) -> (LSig GhcRn, (RecFlag, LHsBinds GhcRn)) +mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn) mkRecSelBind (tycon, fl) = mkOneRecordSelector all_cons (RecSelData tycon) fl where all_cons = map RealDataCon (tyConDataCons tycon) mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel - -> (LSig GhcRn, (RecFlag, LHsBinds GhcRn)) + -> (Id, LHsBind GhcRn) mkOneRecordSelector all_cons idDetails fl - = (L loc (IdSig noExt sel_id), (NonRecursive, unitBag (L loc sel_bind))) + = (sel_id, L loc sel_bind) where - loc = getSrcSpan sel_name + loc = getSrcSpan sel_name lbl = flLabel fl sel_name = flSelector fl diff --git a/testsuite/tests/dependent/should_fail/T15215.hs b/testsuite/tests/dependent/should_fail/T15215.hs new file mode 100644 index 0000000000..96fe04385b --- /dev/null +++ b/testsuite/tests/dependent/should_fail/T15215.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeInType #-} +module T15215 where + +import Data.Kind + +data A :: Type -> Type where + MkA :: Show (Maybe a) => A a + +data SA :: forall a. A a -> Type where + SMkA :: SA MkA diff --git a/testsuite/tests/dependent/should_fail/T15215.stderr b/testsuite/tests/dependent/should_fail/T15215.stderr new file mode 100644 index 0000000000..80181b44bd --- /dev/null +++ b/testsuite/tests/dependent/should_fail/T15215.stderr @@ -0,0 +1,12 @@ + +T15215.hs:9:3: error: + • Non type-variable argument in the constraint: Show (Maybe a) + (Use FlexibleContexts to permit this) + • In the definition of data constructor ‘MkA’ + In the data type declaration for ‘A’ + +T15215.hs:12:14: error: + • Illegal constraint in a type: Show (Maybe a0) + • In the first argument of ‘SA’, namely ‘MkA’ + In the type ‘SA MkA’ + In the definition of data constructor ‘SMkA’ diff --git a/testsuite/tests/dependent/should_fail/all.T b/testsuite/tests/dependent/should_fail/all.T index 5ae037dc54..8e5185f1ae 100644 --- a/testsuite/tests/dependent/should_fail/all.T +++ b/testsuite/tests/dependent/should_fail/all.T @@ -28,3 +28,4 @@ test('T14066g', normal, compile_fail, ['']) test('T14066h', normal, compile_fail, ['']) test('InferDependency', normal, compile_fail, ['']) test('T15245', normal, compile_fail, ['']) +test('T15215', normal, compile_fail, ['']) |