diff options
319 files changed, 5971 insertions, 5170 deletions
diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs index bfb11e0b19..f4ca912eb5 100644 --- a/compiler/basicTypes/RdrName.hs +++ b/compiler/basicTypes/RdrName.hs @@ -383,7 +383,7 @@ Note [Local bindings with Exact Names] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ With Template Haskell we can make local bindings that have Exact Names. Computing shadowing etc may use elemLocalRdrEnv (at least it certainly -does so in RnTpes.bindHsTyVars), so for an Exact Name we must consult +does so in RnTpes.bindHsQTyVars), so for an Exact Name we must consult the in-scope-name-set. @@ -515,7 +515,6 @@ have any parent. Note [Parents for record fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - For record fields, in addition to the Name of the type constructor (stored in par_is), we use FldParent to store the field label. This extra information is used for identifying overloaded record fields diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index ac9438f2aa..85f603fac1 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -545,8 +545,8 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds }) ; flds' <- mapM addTickHsRecField flds ; return (expr { rupd_expr = e', rupd_flds = flds' }) } -addTickHsExpr (ExprWithTySigOut e ty) = - liftM2 ExprWithTySigOut +addTickHsExpr (ExprWithTySig e ty) = + liftM2 ExprWithTySig (addTickLHsExprNever e) -- No need to tick the inner expression -- for expressions with signatures (return ty) @@ -594,11 +594,16 @@ addTickHsExpr (HsProc pat cmdtop) = addTickHsExpr (HsWrap w e) = liftM2 HsWrap (return w) - (addTickHsExpr e) -- explicitly no tick on inside + (addTickHsExpr e) -- Explicitly no tick on inside + +addTickHsExpr (ExprWithTySigOut e ty) = + liftM2 ExprWithTySigOut + (addTickLHsExprNever e) -- No need to tick the inner expression + (return ty) -- for expressions with signatures addTickHsExpr e@(HsType _) = return e --- Others dhould never happen in expression content. +-- Others should never happen in expression content. addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id) diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 3d592b1c0c..7735aa8e50 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -616,7 +616,7 @@ dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do dsCmd ids local_vars stack_ty res_ty (HsCmdCast coercion cmd) env_ids = do (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids - wrapped_cmd <- dsHsWrapper (mkWpCast coercion) core_cmd + wrapped_cmd <- dsHsWrapper (mkWpCastN coercion) core_cmd return (wrapped_cmd, env_ids') dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index f29353b47b..64d5521927 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -173,10 +173,10 @@ dsHsBind dflags ; let core_bind = Rec bind_prs ; ds_binds <- dsTcEvBinds_s ev_binds ; rhs <- dsHsWrapper wrap $ -- Usually the identity - mkLams tyvars $ mkLams dicts $ - mkCoreLets ds_binds $ - Let core_bind $ - Var local + mkLams tyvars $ mkLams dicts $ + mkCoreLets ds_binds $ + Let core_bind $ + Var local ; (spec_binds, rules) <- dsSpecs rhs prags diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 7100e0b219..cd6b96c290 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -653,7 +653,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields Nothing -> mkTcReflCo Nominal ty in if null eq_spec then rhs - else mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs + else mkLHsWrap (mkWpCastN wrap_co) rhs -- eq_spec is always null for a PatSynCon PatSynCon _ -> rhs diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index acea47c57b..5893ae80f8 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -101,14 +101,14 @@ dsForeigns' fos = do where do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) - do_decl (ForeignImport id _ co spec) = do + do_decl (ForeignImport { fd_name = id, fd_co = co, fd_fi = spec }) = do traceIf (text "fi start" <+> ppr id) (bs, h, c) <- dsFImport (unLoc id) co spec traceIf (text "fi end" <+> ppr id) return (h, c, [], bs) - do_decl (ForeignExport (L _ id) _ co - (CExport (L _ (CExportStatic _ ext_nm cconv)) _)) = do + do_decl (ForeignExport { fd_name = L _ id, fd_co = co + , fd_fe = CExport (L _ (CExportStatic _ ext_nm cconv)) _ }) = do (h, c, _, _) <- dsFExport id co ext_nm cconv False return (h, c, [id], []) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index df452ea7d0..8d701af329 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -180,9 +180,19 @@ repTopDs group@(HsGroup { hs_valds = valds hsSigTvBinders :: HsValBinds Name -> [Name] -- See Note [Scoped type variables in bindings] hsSigTvBinders binds - = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit _ qtvs _ _)) _) <- sigs - , tv <- hsQTvBndrs qtvs] + = concatMap get_scoped_tvs sigs where + get_scoped_tvs :: LSig Name -> [Name] + -- Both implicit and explicit quantified variables + -- We need the implicit ones for f :: forall (a::k). blah + -- here 'k' scopes too + get_scoped_tvs (L _ (TypeSig _ sig)) + | HsIB { hsib_kvs = implicit_kvs, hsib_tvs = implicit_tvs + , hsib_body = sig1 } <- sig + , (explicit_tvs, _) <- splitLHsForAllTy (hswc_body sig1) + = implicit_kvs ++ implicit_tvs ++ map hsLTyVarName explicit_tvs + get_scoped_tvs _ = [] + sigs = case binds of ValBindsIn _ sigs -> sigs ValBindsOut _ sigs -> sigs @@ -312,7 +322,8 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, fdResultSig = L _ resultSig, fdInjectivityAnn = injectivity })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; let mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs } + ; let mkHsQTvs :: [LHsTyVarBndr Name] -> LHsQTyVars Name + mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs } resTyVar = case resultSig of TyVarSig bndr -> mkHsQTvs [bndr] _ -> mkHsQTvs [] @@ -389,8 +400,8 @@ repAssocTyFamDefaults = mapM rep_deflt ; repTySynInst tc1 eqn1 } ------------------------- -mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name - -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name) +mk_extra_tvs :: Located Name -> LHsQTyVars Name + -> HsDataDefn Name -> DsM (LHsQTyVars Name) -- If there is a kind signature it must be of form -- k1 -> .. -> kn -> * -- Return type variables [tv1:k1, tv2:k2, .., tvn:kn] @@ -445,7 +456,7 @@ repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ) repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds , cid_sigs = prags, cid_tyfam_insts = ats , cid_datafam_insts = adts }) - = addTyVarBinds tvs $ \_ -> + = addSimpleTyVarBinds tvs $ -- We must bring the type variables into scope, so their -- occurrences don't fail, even though the binders don't -- appear in the resulting data structure @@ -455,10 +466,8 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds -- For example, the method names should be bound to -- the selector Ids, not to fresh names (Trac #5410) -- - do { cxt1 <- repContext cxt - ; cls_tcon <- repTy (HsTyVar cls) - ; cls_tys <- repLTys tys - ; inst_ty1 <- repTapps cls_tcon cls_tys + do { cxt1 <- repLContext cxt + ; inst_ty1 <- repLTy inst_ty ; binds1 <- rep_binds binds ; prags1 <- rep_sigs prags ; ats1 <- mapM (repTyFamInstD . unLoc) ats @@ -466,19 +475,17 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1) ; repInst cxt1 inst_ty1 decls } where - Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty + (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ) repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty })) - = do { dec <- addTyVarBinds tvs $ \_ -> - do { cxt' <- repContext cxt - ; cls_tcon <- repTy (HsTyVar cls) - ; cls_tys <- repLTys tys - ; inst_ty <- repTapps cls_tcon cls_tys - ; repDeriv cxt' inst_ty } + = do { dec <- addSimpleTyVarBinds tvs $ + do { cxt' <- repLContext cxt + ; inst_ty' <- repLTy inst_ty + ; repDeriv cxt' inst_ty' } ; return (loc, dec) } where - Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty + (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ) repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) @@ -488,9 +495,9 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) ; repTySynInst tc eqn1 } repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ) -repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys - , hswb_kvs = kv_names - , hswb_tvs = tv_names } +repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsIB { hsib_body = tys + , hsib_kvs = kv_names + , hsib_tvs = tv_names } , tfe_rhs = rhs })) = do { let hs_tvs = HsQTvs { hsq_kvs = kv_names , hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk @@ -502,7 +509,7 @@ repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ) repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name - , dfid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names } + , dfid_pats = HsIB { hsib_body = tys, hsib_kvs = kv_names, hsib_tvs = tv_names } , dfid_defn = defn }) = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] ; let loc = getLoc tc_name @@ -512,9 +519,10 @@ repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name ; repDataDefn tc bndrs (Just tys1) tv_names defn } } repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ) -repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _))) +repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ + , fd_fi = CImport (L _ cc) (L _ s) mch cis _ })) = do MkC name' <- lookupLOcc name - MkC typ' <- repLTy typ + MkC typ' <- repHsSigType typ MkC cc' <- repCCallConv cc MkC s' <- repSafety s cis' <- conv_cimportspec cis @@ -580,16 +588,17 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) ruleBndrNames :: LRuleBndr Name -> [Name] ruleBndrNames (L _ (RuleBndr n)) = [unLoc n] -ruleBndrNames (L _ (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs }))) +ruleBndrNames (L _ (RuleBndrSig n sig)) + | HsIB { hsib_kvs = kvs, hsib_tvs = tvs } <- sig = unLoc n : kvs ++ tvs repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ) repRuleBndr (L _ (RuleBndr n)) = do { MkC n' <- lookupLBinder n ; rep2 ruleVarName [n'] } -repRuleBndr (L _ (RuleBndrSig n (HsWB { hswb_cts = ty }))) +repRuleBndr (L _ (RuleBndrSig n sig)) = do { MkC n' <- lookupLBinder n - ; MkC ty' <- repLTy ty + ; MkC ty' <- repLTy (hsSigWcType sig) ; rep2 typedRuleVarName [n', ty'] } repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ) @@ -701,15 +710,15 @@ repBangTy ty = do -- Deriving clause ------------------------------------------------------- -repDerivs :: Maybe (Located [LHsType Name]) -> DsM (Core [TH.Name]) +repDerivs :: HsDeriving Name -> DsM (Core [TH.Name]) repDerivs Nothing = coreList nameTyConName [] repDerivs (Just (L _ ctxt)) - = repList nameTyConName rep_deriv ctxt + = repList nameTyConName (rep_deriv . hsSigType) ctxt where rep_deriv :: LHsType Name -> DsM (Core TH.Name) -- Deriving clauses must have the simple H98 form rep_deriv ty - | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty) + | Just (L _ cls, []) <- splitLHsClassTy_maybe ty = lookupOcc cls | otherwise = notHandled "Non-H98 deriving clause" (ppr ty) @@ -729,9 +738,11 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; return (concat sigs1) } rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] -rep_sig (L loc (TypeSig nms ty _)) = mapM (rep_ty_sig sigDName loc ty) nms +rep_sig (L loc (TypeSig nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms rep_sig (L _ (PatSynSig {})) = notHandled "Pattern type signatures" empty -rep_sig (L loc (GenericSig nms ty)) = mapM (rep_ty_sig defaultSigDName loc ty) nms +rep_sig (L loc (ClassOpSig is_deflt nms ty)) + | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms + | otherwise = mapM (rep_ty_sig sigDName loc ty) nms rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc @@ -740,25 +751,33 @@ rep_sig (L loc (SpecSig nm tys ispec)) rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty -rep_ty_sig :: Name -> SrcSpan -> LHsType Name -> Located Name +rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name -> DsM (SrcSpan, Core TH.DecQ) -rep_ty_sig mk_sig loc (L _ ty) nm +rep_ty_sig mk_sig loc sig_ty nm = do { nm1 <- lookupLOcc nm - ; ty1 <- rep_ty ty + ; ty1 <- repHsSigType sig_ty ; sig <- repProto mk_sig nm1 ty1 ; return (loc, sig) } - where + +rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name + -> DsM (SrcSpan, Core TH.DecQ) -- We must special-case the top-level explicit for-all of a TypeSig -- See Note [Scoped type variables in bindings] - rep_ty (HsForAllTy Explicit _ tvs ctxt ty) - = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) - ; repTyVarBndrWithKind tv name } - ; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs) - ; ctxt1 <- repLContext ctxt - ; ty1 <- repLTy ty - ; repTForall bndrs1 ctxt1 ty1 } - - rep_ty ty = repTy ty +rep_wc_ty_sig mk_sig loc sig_ty nm + | HsIB { hsib_tvs = implicit_tvs, hsib_body = sig1 } <- sig_ty + , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy (hswc_body sig1) + = do { nm1 <- lookupLOcc nm + ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) + ; repTyVarBndrWithKind tv name } + all_tvs = map (noLoc . UserTyVar . noLoc) implicit_tvs ++ explicit_tvs + ; th_tvs <- repList tyVarBndrTyConName rep_in_scope_tv all_tvs + ; th_ctxt <- repLContext ctxt + ; th_ty <- repLTy ty + ; ty1 <- if null all_tvs && null (unLoc ctxt) + then return th_ty + else repTForall th_tvs th_ctxt th_ty + ; sig <- repProto mk_sig nm1 ty1 + ; return (loc, sig) } rep_inline :: Located Name -> InlinePragma -- Never defaultInlinePragma @@ -773,11 +792,11 @@ rep_inline nm ispec loc ; return [(loc, pragma)] } -rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan +rep_specialise :: Located Name -> LHsSigType Name -> InlinePragma -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_specialise nm ty ispec loc = do { nm1 <- lookupLOcc nm - ; ty1 <- repLTy ty + ; ty1 <- repHsSigType ty ; phases <- repPhases $ inl_act ispec ; let inline = inl_inline ispec ; pragma <- if isEmptyInlineSpec inline @@ -789,9 +808,9 @@ rep_specialise nm ty ispec loc ; return [(loc, pragma)] } -rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] +rep_specialiseInst :: LHsSigType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_specialiseInst ty loc - = do { ty1 <- repLTy ty + = do { ty1 <- repHsSigType ty ; pragma <- repPragSpecInst ty1 ; return [(loc, pragma)] } @@ -816,7 +835,15 @@ repPhases _ = dataCon allPhasesDataConName -- Types ------------------------------------------------------- -addTyVarBinds :: LHsTyVarBndrs Name -- the binders to be added +addSimpleTyVarBinds :: [Name] -- the binders to be added + -> DsM (Core (TH.Q a)) -- action in the ext env + -> DsM (Core (TH.Q a)) +addSimpleTyVarBinds names thing_inside + = do { fresh_names <- mkGenSyms names + ; term <- addBinds fresh_names thing_inside + ; wrapGenSyms fresh_names term } + +addTyVarBinds :: LHsQTyVars Name -- the binders to be added -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env -> DsM (Core (TH.Q a)) -- gensym a list of type variables and enter them into the meta environment; @@ -834,7 +861,7 @@ addTyVarBinds (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) m where mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) -addTyClTyVarBinds :: LHsTyVarBndrs Name +addTyClTyVarBinds :: LHsQTyVars Name -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -> DsM (Core (TH.Q a)) @@ -885,6 +912,24 @@ repContext :: HsContext Name -> DsM (Core TH.CxtQ) repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt repCtxt preds +repHsSigType :: LHsSigType Name -> DsM (Core TH.TypeQ) +repHsSigType ty = repLTy (hsSigType ty) + +repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ) +repHsSigWcType (HsIB { hsib_kvs = implicit_kvs + , hsib_tvs = implicit_tvs + , hsib_body = sig1 }) + | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy (hswc_body sig1) + = addTyVarBinds (HsQTvs { hsq_kvs = implicit_kvs + , hsq_tvs = map (noLoc . UserTyVar . noLoc) implicit_tvs + ++ explicit_tvs }) + $ \ th_tvs -> + do { th_ctxt <- repLContext ctxt + ; th_ty <- repLTy ty + ; if null implicit_tvs && null explicit_tvs && null (unLoc ctxt) + then return th_ty + else repTForall th_tvs th_ctxt th_ty } + -- yield the representation of a list of types -- repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ] @@ -895,27 +940,18 @@ repLTys tys = mapM repLTy tys repLTy :: LHsType Name -> DsM (Core TH.TypeQ) repLTy (L _ ty) = repTy ty -repTy :: HsType Name -> DsM (Core TH.TypeQ) -repTy (HsForAllTy _ extra tvs ctxt ty) = - addTyVarBinds tvs $ \bndrs -> do - ctxt1 <- repLContext ctxt' - ty1 <- repLTy ty - repTForall bndrs ctxt1 ty1 - where - -- If extra is not Nothing, an extra-constraints wild card was removed - -- (just) before renaming. It must be put back now, otherwise the - -- represented type won't include this extra-constraints wild card. - ctxt' - | Just loc <- extra - = let uniq = panic "addExtraCtsWC" - -- This unique will be discarded by repLContext, but is required - -- to make a Name - name = mkInternalName uniq (mkTyVarOcc "_") loc - in (++ [L loc (HsWildCardTy (AnonWildCard (L loc name)))]) `fmap` ctxt - | otherwise - = ctxt - +repForall :: HsType Name -> DsM (Core TH.TypeQ) +-- Arg of repForall is always HsForAllTy or HsQualTy +repForall ty + | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty) + = addTyVarBinds (HsQTvs { hsq_kvs = [], hsq_tvs = tvs}) $ \bndrs -> + do { ctxt1 <- repLContext ctxt + ; ty1 <- repLTy tau + ; repTForall bndrs ctxt1 ty1 } +repTy :: HsType Name -> DsM (Core TH.TypeQ) +repTy ty@(HsForAllTy {}) = repForall ty +repTy ty@(HsQualTy {}) = repForall ty repTy (HsTyVar (L _ n)) | isTvOcc occ = do tv1 <- lookupOcc n @@ -1152,7 +1188,11 @@ repE (RecordUpd { rupd_expr = e, rupd_flds = flds }) fs <- repUpdFields flds; repRecUpd x fs } -repE (ExprWithTySig e ty _) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 } +repE (ExprWithTySig e ty) + = do { e1 <- repLE e + ; t1 <- repHsSigWcType ty + ; repSigExp e1 t1 } + repE (ArithSeq _ _ aseq) = case aseq of From e -> do { ds1 <- repLE e; repFrom ds1 } diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 74cbd29eaf..eb6292d5f7 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -510,7 +510,6 @@ compiler_stage2_dll0_MODULES = \ CoreSeq \ CoreStats \ CostCentre \ - Ctype \ DataCon \ Demand \ Digraph \ @@ -550,7 +549,6 @@ compiler_stage2_dll0_MODULES = \ InstEnv \ Kind \ Lexeme \ - Lexer \ ListSetOps \ Literal \ Maybes \ diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 29dd48c86a..1fc4f09ad9 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -14,7 +14,6 @@ module Convert( convertToHsExpr, convertToPat, convertToHsDecls, thRdrNameGuesses ) where import HsSyn as Hs -import HsTypes ( mkHsForAllTy ) import qualified Class import RdrName import qualified Name @@ -173,10 +172,10 @@ cvtDec (TH.FunD nm cls) cvtDec (TH.SigD nm typ) = do { nm' <- vNameL nm ; ty' <- cvtType typ - ; returnJustL $ Hs.SigD (TypeSig [nm'] ty' PlaceHolder) } + ; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) } cvtDec (TH.InfixD fx nm) - -- fixity signatures are allowed for variables, constructors, and types + -- Fixity signatures are allowed for variables, constructors, and types -- the renamer automatically looks for types during renaming, even when -- the RdrName says it's a variable or a constructor. So, just assume -- it's a variable or constructor and proceed. @@ -229,7 +228,8 @@ cvtDec (ClassD ctxt cl tvs fds decs) ; at_defs <- mapM cvt_at_def ats' ; returnJustL $ TyClD $ ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' - , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds' + , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs' + , tcdMeths = binds' , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = [] , tcdFVs = placeHolderNames } -- no docs in TH ^^ @@ -247,9 +247,13 @@ cvtDec (InstanceD ctxt ty decs) ; unless (null fams') (failWith (mkBadDecMsg doc fams')) ; ctxt' <- cvtContext ctxt ; L loc ty' <- cvtType ty - ; let inst_ty' = L loc $ mkHsForAllTy Implicit [] ctxt' $ L loc ty' + ; let inst_ty' = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = L loc ty' } ; returnJustL $ InstD $ ClsInstD $ - ClsInstDecl inst_ty' binds' sigs' ats' adts' Nothing } + ClsInstDecl { cid_poly_ty = mkLHsSigType inst_ty' + , cid_binds = binds' + , cid_sigs = Hs.mkClassOpSigs sigs' + , cid_tyfam_insts = ats', cid_datafam_insts = adts' + , cid_overlap_mode = Nothing } } cvtDec (ForeignD ford) = do { ford' <- cvtForD ford @@ -319,21 +323,21 @@ cvtDec (TH.RoleAnnotD tc roles) cvtDec (TH.StandaloneDerivD cxt ty) = do { cxt' <- cvtContext cxt ; L loc ty' <- cvtType ty - ; let inst_ty' = L loc $ mkHsForAllTy Implicit [] cxt' $ L loc ty' + ; let inst_ty' = L loc $ HsQualTy { hst_ctxt = cxt', hst_body = L loc ty' } ; returnJustL $ DerivD $ - DerivDecl { deriv_type = inst_ty', deriv_overlap_mode = Nothing } } + DerivDecl { deriv_type = mkLHsSigType inst_ty', deriv_overlap_mode = Nothing } } cvtDec (TH.DefaultSigD nm typ) = do { nm' <- vNameL nm ; ty' <- cvtType typ - ; returnJustL $ Hs.SigD $ GenericSig [nm'] ty' } + ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') } ---------------- cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName) cvtTySynEqn tc (TySynEqn lhs rhs) = do { lhs' <- mapM cvtType lhs ; rhs' <- cvtType rhs ; returnL $ TyFamEqn { tfe_tycon = tc - , tfe_pats = mkHsWithBndrs lhs' + , tfe_pats = mkHsImplicitBndrs lhs' , tfe_rhs = rhs' } } ---------------- @@ -361,7 +365,7 @@ cvt_ci_decs doc decs cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] -> CvtM ( LHsContext RdrName , Located RdrName - , LHsTyVarBndrs RdrName) + , LHsQTyVars RdrName) cvt_tycl_hdr cxt tc tvs = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc @@ -372,12 +376,12 @@ cvt_tycl_hdr cxt tc tvs cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type] -> CvtM ( LHsContext RdrName , Located RdrName - , HsWithBndrs RdrName [LHsType RdrName]) + , HsImplicitBndrs RdrName [LHsType RdrName]) cvt_tyinst_hdr cxt tc tys = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc ; tys' <- mapM cvtType tys - ; return (cxt', tc', mkHsWithBndrs tys') } + ; return (cxt', tc', mkHsImplicitBndrs tys') } ------------------------------------------------------------------- -- Partitioning declarations @@ -419,13 +423,13 @@ cvtConstr (NormalC c strtys) = do { c' <- cNameL c ; cxt' <- returnL [] ; tys' <- mapM cvt_arg strtys - ; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') } + ; returnL $ mkSimpleConDecl c' Nothing cxt' (PrefixCon tys') } cvtConstr (RecC c varstrtys) = do { c' <- cNameL c ; cxt' <- returnL [] ; args' <- mapM cvt_id_arg varstrtys - ; returnL $ mkSimpleConDecl c' noExistentials cxt' + ; returnL $ mkSimpleConDecl c' Nothing cxt' (RecCon (noLoc args')) } cvtConstr (InfixC st1 c st2) @@ -433,13 +437,14 @@ cvtConstr (InfixC st1 c st2) ; cxt' <- returnL [] ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 - ; returnL $ mkSimpleConDecl c' noExistentials cxt' (InfixCon st1' st2') } + ; returnL $ mkSimpleConDecl c' Nothing cxt' (InfixCon st1' st2') } cvtConstr (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs ; L loc ctxt' <- cvtContext ctxt ; L _ con' <- cvtConstr con ; returnL $ con' { con_qvars = mkHsQTvs (hsQTvBndrs tvs' ++ hsQTvBndrs (con_qvars con')) + , con_explicit = True , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } } cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName) @@ -459,21 +464,20 @@ cvt_id_arg (i, str, ty) , cd_fld_type = ty' , cd_fld_doc = Nothing}) } -cvtDerivs :: [TH.Name] -> CvtM (Maybe (Located [LHsType RdrName])) +cvtDerivs :: [TH.Name] -> CvtM (HsDeriving RdrName) cvtDerivs [] = return Nothing cvtDerivs cs = do { cs' <- mapM cvt_one cs ; return (Just (noLoc cs')) } where cvt_one c = do { c' <- tconName c - ; returnL $ HsTyVar (noLoc c') } + ; ty <- returnL $ HsTyVar (noLoc c') + ; return (mkLHsSigType ty) } cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName))) cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs ; ys' <- mapM tName ys ; returnL (map noLoc xs', map noLoc ys') } -noExistentials :: [LHsTyVarBndr RdrName] -noExistentials = [] ------------------------------------------ -- Foreign declarations @@ -498,7 +502,10 @@ cvtForD (ImportF callconv safety from nm ty) mk_imp impspec = do { nm' <- vNameL nm ; ty' <- cvtType ty - ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec) + ; return (ForeignImport { fd_name = nm' + , fd_sig_ty = mkLHsSigType ty' + , fd_co = noForeignImportCoercionYet + , fd_fi = impspec }) } safety' = case safety of Unsafe -> PlayRisky @@ -512,7 +519,10 @@ cvtForD (ExportF callconv as nm ty) (mkFastString as) (cvt_conv callconv))) (noLoc as) - ; return $ ForeignExport nm' ty' noForeignExportCoercionYet e } + ; return $ ForeignExport { fd_name = nm' + , fd_sig_ty = mkLHsSigType ty' + , fd_co = noForeignExportCoercionYet + , fd_fe = e } } cvt_conv :: TH.Callconv -> CCallConv cvt_conv TH.CCall = CCallConv @@ -547,11 +557,12 @@ cvtPragmaD (SpecialiseP nm ty inline phases) , inl_rule = Hs.FunLike , inl_act = cvtPhases phases dflt , inl_sat = Nothing } - ; returnJustL $ Hs.SigD $ SpecSig nm' [ty'] ip } + ; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip } cvtPragmaD (SpecialiseInstP ty) = do { ty' <- cvtType ty - ; returnJustL $ Hs.SigD $ SpecInstSig "{-# SPECIALISE" ty' } + ; returnJustL $ Hs.SigD $ + SpecInstSig "{-# SPECIALISE" (mkLHsSigType ty') } cvtPragmaD (RuleP nm bndrs lhs rhs phases) = do { let nm' = mkFastString nm @@ -608,7 +619,7 @@ cvtRuleBndr (RuleVar n) cvtRuleBndr (TypedRuleVar n ty) = do { n' <- vNameL n ; ty' <- cvtType ty - ; return $ noLoc $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' } + ; return $ noLoc $ Hs.RuleBndrSig n' $ mkLHsSigWcType ty' } --------------------------------------------------- -- Declarations @@ -709,7 +720,7 @@ cvtl e = wrapL (cvt e) cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar e' } cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t - ; return $ ExprWithTySig e' t' PlaceHolder } + ; return $ ExprWithTySig e' (mkLHsSigWcType t') } cvt (RecConE c flds) = do { c' <- cNameL c ; flds' <- mapM (cvtFld mkFieldOcc) flds ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) } @@ -952,7 +963,7 @@ cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs cvtp (ListP ps) = do { ps' <- cvtPats ps ; return $ ListPat ps' placeHolderType Nothing } cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t - ; return $ SigPatIn p' (mkHsWithBndrs t') } + ; return $ SigPatIn p' (mkLHsSigWcType t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p ; return $ ViewPat e' p' placeHolderType } @@ -980,7 +991,7 @@ cvtOpAppP x op y ----------------------------------------------------------- -- Types and type variables -cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsTyVarBndrs RdrName) +cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars RdrName) cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName) @@ -1045,8 +1056,15 @@ cvtTypeKind ty_str ty -> do { tvs' <- cvtTvs tvs ; cxt' <- cvtContext cxt ; ty' <- cvtType ty - ; returnL $ mkExplicitHsForAllTy (hsQTvBndrs tvs') cxt' ty' - } + ; loc <- getL + ; let hs_ty | null tvs = rho_ty + | otherwise = L loc (HsForAllTy { hst_bndrs = hsQTvBndrs tvs' + , hst_body = rho_ty }) + rho_ty | null cxt = ty' + | otherwise = L loc (HsQualTy { hst_ctxt = cxt' + , hst_body = ty' }) + + ; return hs_ty } SigT ty ki -> do { ty' <- cvtType ty diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index 978d36349a..25ce654ecd 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -447,7 +447,7 @@ plusHsValBinds _ _ getTypeSigNames :: HsValBinds a -> NameSet -- Get the names that have a user type sig getTypeSigNames (ValBindsOut _ sigs) - = mkNameSet [unLoc n | L _ (TypeSig names _ _) <- sigs, n <- names] + = mkNameSet [unLoc n | L _ (TypeSig names _) <- sigs, n <- names] getTypeSigNames _ = panic "HsBinds.getTypeSigNames" @@ -627,9 +627,8 @@ data Sig name -- For details on above see note [Api annotations] in ApiAnnotation TypeSig - [Located name] -- LHS of the signature; e.g. f,g,h :: blah - (LHsType name) -- RHS of the signature - (PostRn name [Name]) -- Wildcards (both named and anonymous) of the RHS + [Located name] -- LHS of the signature; e.g. f,g,h :: blah + (LHsSigWcType name) -- RHS of the signature; can have wildcards -- | A pattern synonym type signature -- @@ -640,21 +639,20 @@ data Sig name -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | PatSynSig (Located name) - (HsExplicitFlag, LHsTyVarBndrs name) - (LHsContext name) -- Required context - (LHsContext name) -- Provided context - (LHsType name) - - -- | A type signature for a default method inside a class - -- - -- > default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault', - -- 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - | GenericSig [Located name] (LHsType name) + | PatSynSig (Located name) (LHsSigType name) + -- P :: forall a b. Prov => Req => ty + + -- | A signature for a class method + -- False: ordinary class-method signauure + -- True: default class method signature + -- e.g. class C a where + -- op :: a -> a -- Ordinary + -- default op :: Eq a => a -> a -- Generic default + -- No wildcards allowed here + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault', + -- 'ApiAnnotation.AnnDcolon' + | ClassOpSig Bool [Located name] (LHsSigType name) -- | A type signature in generated code, notably the code -- generated for record selectors. We simply record @@ -700,11 +698,11 @@ data Sig name -- 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation - | SpecSig (Located name) -- Specialise a function or datatype ... - [LHsType name] -- ... to these types - InlinePragma -- The pragma on SPECIALISE_INLINE form. - -- If it's just defaultInlinePragma, then we said - -- SPECIALISE, not SPECIALISE_INLINE + | SpecSig (Located name) -- Specialise a function or datatype ... + [LHsSigType name] -- ... to these types + InlinePragma -- The pragma on SPECIALISE_INLINE form. + -- If it's just defaultInlinePragma, then we said + -- SPECIALISE, not SPECIALISE_INLINE -- | A specialisation pragma for instance declarations only -- @@ -717,7 +715,7 @@ data Sig name -- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | SpecInstSig SourceText (LHsType name) + | SpecInstSig SourceText (LHsSigType name) -- Note [Pragma source text] in BasicTypes -- | A minimal complete definition pragma @@ -782,7 +780,7 @@ isVanillaLSig _ = False isTypeLSig :: LSig name -> Bool -- Type signatures isTypeLSig (L _(TypeSig {})) = True -isTypeLSig (L _(GenericSig {})) = True +isTypeLSig (L _(ClassOpSig {})) = True isTypeLSig (L _(IdSig {})) = True isTypeLSig _ = False @@ -812,7 +810,9 @@ isMinimalLSig _ = False hsSigDoc :: Sig name -> SDoc hsSigDoc (TypeSig {}) = ptext (sLit "type signature") hsSigDoc (PatSynSig {}) = ptext (sLit "pattern synonym signature") -hsSigDoc (GenericSig {}) = ptext (sLit "default type signature") +hsSigDoc (ClassOpSig is_deflt _ _) + | is_deflt = ptext (sLit "default type signature") + | otherwise = ptext (sLit "class method signature") hsSigDoc (IdSig {}) = ptext (sLit "id signature") hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma") hsSigDoc (InlineSig _ prag) = ppr (inlinePragmaSpec prag) <+> ptext (sLit "pragma") @@ -830,21 +830,26 @@ instance (OutputableBndr name) => Outputable (Sig name) where ppr sig = ppr_sig sig ppr_sig :: OutputableBndr name => Sig name -> SDoc -ppr_sig (TypeSig vars ty _wcs) = pprVarSig (map unLoc vars) (ppr ty) -ppr_sig (GenericSig vars ty) = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty) -ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id)) -ppr_sig (FixSig fix_sig) = ppr fix_sig +ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (ClassOpSig is_deflt vars ty) + | is_deflt = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty) + | otherwise = pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id)) +ppr_sig (FixSig fix_sig) = ppr fix_sig ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl) ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var)) ppr_sig (SpecInstSig _ ty) = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty) ppr_sig (MinimalSig _ bf) = pragBrackets (pprMinimalSig bf) -ppr_sig (PatSynSig name (flag, qtvs) (L _ req) (L _ prov) ty) +ppr_sig (PatSynSig name sig_ty) = pprPatSynSig (unLoc name) False -- TODO: is_bindir - (pprHsForAll flag qtvs (noLoc [])) - (pprHsContextMaybe req) (pprHsContextMaybe prov) + (pprHsForAllTvs qtvs) + (pprHsContextMaybe (unLoc req)) + (pprHsContextMaybe (unLoc prov)) (ppr ty) + where + (qtvs, req, prov, ty) = splitLHsPatSynTy (hsSigType sig_ty) pprPatSynSig :: (OutputableBndr name) => name -> Bool -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc -> SDoc diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index f75fff10af..b8612ed2be 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -19,7 +19,8 @@ -- @InstDecl@, @DefaultDecl@ and @ForeignDecl@. module HsDecls ( -- * Toplevel declarations - HsDecl(..), LHsDecl, HsDataDefn(..), + HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, + -- ** Class or type declarations TyClDecl(..), LTyClDecl, TyClGroup(..), tyClGroupConcat, mkTyClGroup, @@ -481,10 +482,10 @@ data TyClDecl name -- 'ApiAnnotation.AnnEqual', -- For details on above see note [Api annotations] in ApiAnnotation - SynDecl { tcdLName :: Located name -- ^ Type constructor - , tcdTyVars :: LHsTyVarBndrs name -- ^ Type variables; for an associated type + SynDecl { tcdLName :: Located name -- ^ Type constructor + , tcdTyVars :: LHsQTyVars name -- ^ Type variables; for an associated type -- these include outer binders - , tcdRhs :: LHsType name -- ^ RHS of type declaration + , tcdRhs :: LHsType name -- ^ RHS of type declaration , tcdFVs :: PostRn name NameSet } | -- | @data@ declaration @@ -497,7 +498,7 @@ data TyClDecl name -- For details on above see note [Api annotations] in ApiAnnotation DataDecl { tcdLName :: Located name -- ^ Type constructor - , tcdTyVars :: LHsTyVarBndrs name -- ^ Type variables; for an associated type + , tcdTyVars :: LHsQTyVars name -- ^ Type variables; for an associated type -- these include outer binders -- Eg class T a where -- type F a :: * @@ -509,7 +510,7 @@ data TyClDecl name | ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context... tcdLName :: Located name, -- ^ Name of the class - tcdTyVars :: LHsTyVarBndrs name, -- ^ Class type variables + tcdTyVars :: LHsQTyVars name, -- ^ Class type variables tcdFDs :: [Located (FunDep (Located name))], -- ^ Functional deps tcdSigs :: [LSig name], -- ^ Methods' signatures @@ -548,7 +549,6 @@ tyClGroupConcat = concatMap group_tyclds mkTyClGroup :: [LTyClDecl name] -> TyClGroup name mkTyClGroup decls = TyClGroup { group_tyclds = decls, group_roles = [] } - -- Simple classifiers for TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -613,7 +613,7 @@ tyClDeclLName decl = tcdLName decl tcdName :: TyClDecl name -> name tcdName = unLoc . tyClDeclLName -tyClDeclTyVars :: TyClDecl name -> LHsTyVarBndrs name +tyClDeclTyVars :: TyClDecl name -> LHsQTyVars name tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs tyClDeclTyVars d = tcdTyVars d @@ -685,7 +685,7 @@ instance OutputableBndr name => Outputable (TyClGroup name) where pp_vanilla_decl_head :: OutputableBndr name => Located name - -> LHsTyVarBndrs name + -> LHsQTyVars name -> HsContext name -> SDoc pp_vanilla_decl_head thing tyvars context @@ -796,7 +796,7 @@ type LFamilyDecl name = Located (FamilyDecl name) data FamilyDecl name = FamilyDecl { fdInfo :: FamilyInfo name -- type/data, closed/open , fdLName :: Located name -- type constructor - , fdTyVars :: LHsTyVarBndrs name -- type variables + , fdTyVars :: LHsQTyVars name -- type variables , fdResultSig :: LFamilyResultSig name -- result signature , fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann } @@ -960,26 +960,31 @@ data HsDataDefn name -- The payload of a data type defn -- For @data T a where { T1 :: T a }@ -- the 'LConDecls' all have 'ResTyGADT'. - dd_derivs :: Maybe (Located [LHsType name]) - -- ^ Derivings; @Nothing@ => not specified, - -- @Just []@ => derive exactly what is asked - -- - -- These "types" must be of form - -- @ - -- forall ab. C ty1 ty2 - -- @ - -- Typically the foralls and ty args are empty, but they - -- are non-empty for the newtype-deriving case - -- - -- - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnDeriving', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' + dd_derivs :: HsDeriving name -- ^ Optional 'deriving' claues -- For details on above see note [Api annotations] in ApiAnnotation } deriving( Typeable ) deriving instance (DataId id) => Data (HsDataDefn id) +type HsDeriving name = Maybe (Located [LHsSigType name]) + -- ^ The optional 'deriving' clause of a data declaration + -- + -- @Nothing@ => not specified, + -- @Just []@ => derive exactly what is asked + -- + -- It's a 'LHsSigType' because, with Generalised Newtype + -- Deriving, we can mention type variables that aren't + -- bound by the date type. e.g. + -- data T b = ... deriving( C [a] ) + -- should producd a derived instance for (C [a] (T b)) + -- + -- The payload of the Maybe is Located so that we have a + -- place to hang the API annotations: + -- - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnDeriving', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' + data NewOrData = NewType -- ^ @newtype Blah ...@ | DataType -- ^ @data Blah ...@ @@ -1021,17 +1026,28 @@ data ConDecl name -- the user-callable wrapper Id. -- It is a list to deal with GADT constructors of the form -- T1, T2, T3 :: <payload> - , con_explicit :: HsExplicitFlag - -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy') - , con_qvars :: LHsTyVarBndrs name + , con_explicit :: Bool + -- ^ Is there an user-written forall? + -- For ResTyH98, "explicit" means something like: + -- data T = forall a. MkT { x :: a -> a } + -- For ResTyGADT, "explicit" means something like + -- data T where { MkT :: forall a. <blah> } + + , con_qvars :: LHsQTyVars name -- ^ Type variables. Depending on 'con_res' this describes the -- following entities -- -- - ResTyH98: the constructor's *existential* type variables + -- e.g. data T a = forall b. MkT b (b->a) + -- con_qvars = {b} + -- -- - ResTyGADT: *all* the constructor's quantified type variables + -- e.g. data T a where + -- MkT :: forall a b. b -> (b->a) -> T a + -- con_qvars = {a,b} -- - -- If con_explicit is Implicit, then con_qvars is irrelevant + -- If con_explicit is False, then con_qvars is irrelevant -- until after renaming. , con_cxt :: LHsContext name @@ -1087,9 +1103,9 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context Nothing -> empty Just kind -> dcolon <+> ppr kind pp_derivings = case derivings of - Nothing -> empty - Just (L _ ds) -> hsep [ptext (sLit "deriving"), - parens (interpp'SP ds)] + Nothing -> empty + Just (L _ ds) -> hsep [ ptext (sLit "deriving") + , parens (interpp'SP ds)] instance OutputableBndr name => Outputable (HsDataDefn name) where ppr d = pp_data_defn (\_ -> ptext (sLit "Naked HsDataDefn")) d @@ -1112,7 +1128,7 @@ pprConDecl (ConDecl { con_names = [L _ con] -- NB: non-GADT means 1 con , con_explicit = expl, con_qvars = tvs , con_cxt = cxt, con_details = details , con_res = ResTyH98, con_doc = doc }) - = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details] + = sep [ppr_mbDoc doc, ppr_con_forall expl tvs cxt, ppr_details details] where ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2] ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con @@ -1124,7 +1140,7 @@ pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs , con_cxt = cxt, con_details = PrefixCon arg_tys , con_res = ResTyGADT _ res_ty, con_doc = doc }) = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon <+> - sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)] + sep [ppr_con_forall expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)] where mk_fun_ty a b = noLoc (HsFunTy a b) @@ -1132,7 +1148,7 @@ pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs , con_cxt = cxt, con_details = RecCon fields , con_res = ResTyGADT _ res_ty, con_doc = doc }) = sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon - <+> pprHsForAll expl tvs cxt, + <+> ppr_con_forall expl tvs cxt, pprConDeclFields (unLoc fields) <+> arrow <+> ppr res_ty] pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {} }) @@ -1145,6 +1161,14 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT { -- than one constructor, which should indeed be impossible pprConDecl (ConDecl { con_names = cons }) = pprPanic "pprConDecl" (ppr cons) +ppr_con_forall :: OutputableBndr name => Bool -> LHsQTyVars name + -> LHsContext name -> SDoc +ppr_con_forall explicit_forall qtvs (L _ ctxt) + | explicit_forall + = pprHsForAllTvs (hsQTvBndrs qtvs) <+> pprHsContext ctxt + | otherwise + = pprHsContext ctxt + ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) @@ -1183,12 +1207,12 @@ type LTyFamInstEqn name = Located (TyFamInstEqn name) type LTyFamDefltEqn name = Located (TyFamDefltEqn name) -type HsTyPats name = HsWithBndrs name [LHsType name] +type HsTyPats name = HsImplicitBndrs name [LHsType name] -- ^ Type patterns (with kind and type bndrs) -- See Note [Family instance declaration binders] type TyFamInstEqn name = TyFamEqn name (HsTyPats name) -type TyFamDefltEqn name = TyFamEqn name (LHsTyVarBndrs name) +type TyFamDefltEqn name = TyFamEqn name (LHsQTyVars name) -- See Note [Type family instance declarations in HsSyn] -- | One equation in a type family instance declaration @@ -1244,9 +1268,9 @@ deriving instance (DataId name) => Data (DataFamInstDecl name) type LClsInstDecl name = Located (ClsInstDecl name) data ClsInstDecl name = ClsInstDecl - { cid_poly_ty :: LHsType name -- Context => Class Instance-type - -- Using a polytype means that the renamer conveniently - -- figures out the quantified type variables for us. + { cid_poly_ty :: LHsSigType name -- Context => Class Instance-type + -- Using a polytype means that the renamer conveniently + -- figures out the quantified type variables for us. , cid_binds :: LHsBinds name -- Class methods , cid_sigs :: [LSig name] -- User-supplied pragmatic info , cid_tyfam_insts :: [LTyFamInstDecl name] -- Type family instances @@ -1344,7 +1368,7 @@ pp_fam_inst_lhs :: OutputableBndr name -> HsTyPats name -> HsContext name -> SDoc -pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patterns +pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) context -- explicit type patterns = hsep [ pprHsContext context, pprPrefixOcc (unLoc thing) , hsep (map (pprParendHsType.unLoc) typats)] @@ -1404,7 +1428,7 @@ instDeclDataFamInsts inst_decls type LDerivDecl name = Located (DerivDecl name) data DerivDecl name = DerivDecl - { deriv_type :: LHsType name + { deriv_type :: LHsSigType name , deriv_overlap_mode :: Maybe (Located OverlapMode) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose', @@ -1466,14 +1490,17 @@ instance (OutputableBndr name) type LForeignDecl name = Located (ForeignDecl name) data ForeignDecl name - = ForeignImport (Located name) -- defines this name - (LHsType name) -- sig_ty - (PostTc name Coercion) -- rep_ty ~ sig_ty - ForeignImport - | ForeignExport (Located name) -- uses this name - (LHsType name) -- sig_ty - (PostTc name Coercion) -- sig_ty ~ rep_ty - ForeignExport + = ForeignImport + { fd_name :: Located name -- defines this name + , fd_sig_ty :: LHsSigType name -- sig_ty + , fd_co :: PostTc name Coercion -- rep_ty ~ sig_ty + , fd_fi :: ForeignImport } + + | ForeignExport + { fd_name :: Located name -- uses this name + , fd_sig_ty :: LHsSigType name -- sig_ty + , fd_co :: PostTc name Coercion -- rep_ty ~ sig_ty + , fd_fe :: ForeignExport } -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign', -- 'ApiAnnotation.AnnImport','ApiAnnotation.AnnExport', @@ -1481,6 +1508,7 @@ data ForeignDecl name -- For details on above see note [Api annotations] in ApiAnnotation deriving (Typeable) + deriving instance (DataId name) => Data (ForeignDecl name) {- In both ForeignImport and ForeignExport: @@ -1543,10 +1571,10 @@ data ForeignExport = CExport (Located CExportSpec) -- contains the calling -- instance OutputableBndr name => Outputable (ForeignDecl name) where - ppr (ForeignImport n ty _ fimport) = - hang (ptext (sLit "foreign import") <+> ppr fimport <+> ppr n) - 2 (dcolon <+> ppr ty) - ppr (ForeignExport n ty _ fexport) = + ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport }) + = hang (ptext (sLit "foreign import") <+> ppr fimport <+> ppr n) + 2 (dcolon <+> ppr ty) + ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) = hang (ptext (sLit "foreign export") <+> ppr fexport <+> ppr n) 2 (dcolon <+> ppr ty) @@ -1621,7 +1649,7 @@ flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls type LRuleBndr name = Located (RuleBndr name) data RuleBndr name = RuleBndr (Located name) - | RuleBndrSig (Located name) (HsWithBndrs name (LHsType name)) + | RuleBndrSig (Located name) (LHsSigWcType name) -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' @@ -1630,7 +1658,7 @@ data RuleBndr name deriving (Typeable) deriving instance (DataId name) => Data (RuleBndr name) -collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs name (LHsType name)] +collectRuleBndrSigTys :: [RuleBndr name] -> [LHsSigWcType name] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] instance OutputableBndr name => Outputable (RuleDecls name) where @@ -1709,7 +1737,7 @@ data VectDecl name | HsVectClassOut -- post type-checking Class | HsVectInstIn -- pre type-checking (always SCALAR) !!!FIXME: should be superfluous now - (LHsType name) + (LHsSigType name) | HsVectInstOut -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now ClsInst deriving (Typeable) diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 7106b068a8..127d87a3ec 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -321,16 +321,13 @@ data HsExpr id -- For details on above see note [Api annotations] in ApiAnnotation | ExprWithTySig (LHsExpr id) - (LHsType id) - (PostRn id [Name]) -- After renaming, the list of Names - -- contains the named and unnamed - -- wildcards brought in scope by the - -- signature + (LHsSigWcType id) - | ExprWithTySigOut -- TRANSLATION + | ExprWithTySigOut -- Post typechecking (LHsExpr id) - (LHsType Name) -- Retain the signature for - -- round-tripping purposes + (LHsSigWcType Name) -- Retain the signature, + -- as HsSigType Name, for + -- round-tripping purposes -- | Arithmetic sequence -- @@ -571,28 +568,21 @@ So we use Nothing to mean "use the old built-in typing rule". Note [Record Update HsWrapper] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There is a wrapper in RecordUpd which is used for the *required* constraints for -pattern synonyms. This wrapper is created in the typechecking and is then -directly used in the desugaring without modification. +There is a wrapper in RecordUpd which is used for the *required* +constraints for pattern synonyms. This wrapper is created in the +typechecking and is then directly used in the desugaring without +modification. For example, if we have the record pattern synonym P, + pattern P :: (Show a) => a -> Maybe a + pattern P{x} = Just x -``` -pattern P :: (Show a) => a -> Maybe a -pattern P{x} = Just x - -foo = (Just True) { x = False } -``` - + foo = (Just True) { x = False } then `foo` desugars to something like - -``` -P x = P False -``` - -hence we need to provide the correct dictionaries to P on the RHS so that we can -build the expression. + foo = case Just True of + P x -> P False +hence we need to provide the correct dictionaries to P's matcher on +the RHS so that we can build the expression. Note [Located RdrNames] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -604,6 +594,7 @@ in the ParsedSource. There are unfortunately enough differences between the ParsedSource and the RenamedSource that the API Annotations cannot be used directly with RenamedSource, so this allows a simple mapping to be used based on the location. +>>>>>>> origin/master -} instance OutputableBndr id => Outputable (HsExpr id) where @@ -751,7 +742,7 @@ ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds }) ppr_expr (RecordUpd { rupd_expr = aexp, rupd_flds = rbinds }) = hang (pprLExpr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) -ppr_expr (ExprWithTySig expr sig _) +ppr_expr (ExprWithTySig expr sig) = hang (nest 2 (ppr_lexpr expr) <+> dcolon) 4 (ppr sig) ppr_expr (ExprWithTySigOut expr sig) @@ -979,7 +970,7 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdCast TcCoercion -- A simpler version of HsWrap in HsExpr + | HsCmdCast TcCoercionN -- A simpler version of HsWrap in HsExpr (HsCmd id) -- If cmd :: arg1 --> res -- co :: arg1 ~ arg2 -- Then (HsCmdCast co cmd) :: arg2 --> res @@ -1147,6 +1138,7 @@ data Match id body m_type :: (Maybe (LHsType id)), -- A type signature for the result of the match -- Nothing after typechecking + -- NB: No longer supported m_grhss :: (GRHSs id body) } deriving (Typeable) deriving instance (Data body,DataId id) => Data (Match id body) diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 320956261e..24ef065e2a 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -157,6 +157,8 @@ data Pat id pat_binds :: TcEvBinds, -- Bindings involving those dictionaries pat_args :: HsConPatDetails id, pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher + -- Only relevant for pattern-synonyms; + -- ignored for data cons } ------------ View patterns --------------- @@ -199,9 +201,9 @@ data Pat id -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation - | SigPatIn (LPat id) -- Pattern with a type signature - (HsWithBndrs id (LHsType id)) -- Signature can bind both - -- kind and type vars + | SigPatIn (LPat id) -- Pattern with a type signature + (LHsSigWcType id) -- Signature can bind both + -- kind and type vars | SigPatOut (LPat id) -- Pattern with a type signature Type diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs index d084dc2f7c..72525b2519 100644 --- a/compiler/hsSyn/HsSyn.hs +++ b/compiler/hsSyn/HsSyn.hs @@ -40,7 +40,7 @@ import HsImpExp import HsLit import PlaceHolder import HsPat -import HsTypes hiding ( mkHsForAllTy ) +import HsTypes import BasicTypes ( Fixity, WarningTxt ) import HsUtils import HsDoc diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index eda643c43c..cd8f20342c 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -20,9 +20,11 @@ module HsTypes ( HsType(..), LHsType, HsKind, LHsKind, HsTyOp,LHsTyOp, HsTyVarBndr(..), LHsTyVarBndr, - LHsTyVarBndrs(..), - HsWithBndrs(..), - HsTupleSort(..), HsExplicitFlag(..), + LHsQTyVars(..), + HsImplicitBndrs(..), + HsWildCardBndrs(..), + LHsSigType, LHsSigWcType, LHsWcType, + HsTupleSort(..), HsContext, LHsContext, HsTyWrapper(..), HsTyLit(..), @@ -44,23 +46,23 @@ module HsTypes ( wildCardName, sameWildCard, sameNamedWildCard, isAnonWildCard, isNamedWildCard, + mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody, + mkEmptyImplicitBndrs, mkEmptyWildCardBndrs, mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded, - mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy, - mkHsForAllTy, - flattenTopLevelLHsForAllTy,flattenTopLevelHsForAllTy, - flattenHsForAllTyKeepAnns, - hsExplicitTvs, - hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames, - hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, + hsScopedTvs, hsWcScopedTvs, dropWildCards, + hsTyVarName, hsLKiTyVarNames, + hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, + splitLHsInstDeclTy, getLHsInstDeclClass_maybe, + splitLHsPatSynTy, + splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy, + splitLHsClassTy_maybe, + splitHsFunType, splitHsAppTys, hsTyGetAppHead_maybe, + mkHsAppTys, mkHsOpTy, + ignoreParens, hsSigType, hsSigWcType, hsLTyVarBndrsToTypes, - splitLHsInstDeclTy_maybe, - splitHsClassTy_maybe, splitLHsClassTy_maybe, - splitHsFunType, - splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy, - ignoreParens, -- Printing - pprParendHsType, pprHsForAll, pprHsForAllExtra, + pprParendHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra, pprHsContext, pprHsContextNoArrow, pprHsContextMaybe ) where @@ -81,15 +83,15 @@ import SrcLoc import StaticFlags import Outputable import FastString -import Lexer ( AddAnn, mkParensApiAnn ) import Maybes( isJust ) import Data.Data hiding ( Fixity ) import Data.Maybe ( fromMaybe ) #if __GLASGOW_HASKELL__ < 709 -import Data.Monoid hiding ((<>)) +-- SPJ temp +-- import Data.Monoid hiding((<>)) #endif -#if __GLASGOW_HASKELL__ > 710 +#if __GLASGOW_HASKELL > 710 import Data.Semigroup ( Semigroup ) import qualified Data.Semigroup as Semigroup #endif @@ -132,6 +134,52 @@ renamer can decorate it with the variables bound by the pattern ('a' in the first example, 'k' in the second), assuming that neither of them is in scope already See also Note [Kind and type-variable binders] in RnTypes + +Note [HsType binders] +~~~~~~~~~~~~~~~~~~~~~ +The system fr recording type and kind-variable binders in HsTypes +is a bit complicated. Here's how it works. + +* In a HsType, + HsForAllTy represents an /explicit, user-written/ 'forall' + e.g. forall a b. ... + HsQualTy reprsents an /explicit, user-written/ context + e.g. (Eq a, Show a) => ... + The context can be empty if that's what the user wrote + These constructors reprsents what the user wrote, no more + and no less. + +* HsTyVarBndr describes a quantified type variable written by the + user. For example + f :: forall a (b :: *). blah + here 'a' and '(b::*)' are each a HsTyVarBndr. A HsForAllTy has + a list of LHsTyVarBndrs. + +* HsImplicitBndrs is a wrapper that gives the implicitly-quantified + kind and type variables of the wrapped thing. It is filled in by + the renamer. For example, if the + user writes + f :: a -> a + the HsImplicitBinders binds the 'a' (not a HsForAllTy!). + NB: this implicit quantification is purely lexical: we bind any + type or kind variables that are not in scope. The type checker + may subsequently quantify over further kind variables. + +* HsWildCardBndrs is a wrapper that binds the wildcard variables + of the wrapped thing. It is filled in by the renamer + f :: _a -> _ + The enclosing HsWildCardBndrs binds the wildcards _a and _. + +* The explicit presence of these wrappers specifies, in the HsSyn, + exactly where implicit quantification is allowed, and where + wildcards are allowed. + +* LHsQTyVars is used in data/class declarations, where the user gives + explicit *type* variable bindings, but we need to implicitly bind + *kind* variables. For example + class C (a :: k -> *) where ... + The 'k' is implicitly bound in the hsq_tvs field of LHsQTyVars + -} type LHsContext name = Located (HsContext name) @@ -153,45 +201,42 @@ type LHsKind name = Located (HsKind name) -- For details on above see note [Api annotations] in ApiAnnotation -------------------------------------------------- --- LHsTyVarBndrs --- The quantified binders in a HsForallTy +-- LHsQTyVars +-- The explicitly-quantified binders in a data/type declaration type LHsTyVarBndr name = Located (HsTyVarBndr name) + -- See Note [HsType binders] -data LHsTyVarBndrs name - = HsQTvs { hsq_kvs :: [Name] -- Kind variables +data LHsQTyVars name -- See Note [HsType binders] + = HsQTvs { hsq_kvs :: PostRn name [Name] -- Kind variables , hsq_tvs :: [LHsTyVarBndr name] -- Type variables -- See Note [HsForAllTy tyvar binders] } deriving( Typeable ) -deriving instance (DataId name) => Data (LHsTyVarBndrs name) -mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsTyVarBndrs RdrName --- Just at RdrName because in the Name variant we should know just --- what the kind-variable binders are; and we don't --- We put an empty list (rather than a panic) for the kind vars so --- that the pretty printer works ok on them. -mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs } +deriving instance (DataId name) => Data (LHsQTyVars name) -emptyHsQTvs :: LHsTyVarBndrs name -- Use only when you know there are no kind binders -emptyHsQTvs = HsQTvs { hsq_kvs = [], hsq_tvs = [] } +mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsQTyVars RdrName +mkHsQTvs tvs = HsQTvs { hsq_kvs = PlaceHolder, hsq_tvs = tvs } -hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name] +hsQTvBndrs :: LHsQTyVars name -> [LHsTyVarBndr name] hsQTvBndrs = hsq_tvs +{- #if __GLASGOW_HASKELL__ > 710 instance Semigroup (LHsTyVarBndrs name) where HsQTvs kvs1 tvs1 <> HsQTvs kvs2 tvs2 = HsQTvs (kvs1 ++ kvs2) (tvs1 ++ tvs2) #endif -instance Monoid (LHsTyVarBndrs name) where - mempty = emptyHsQTvs +instance Monoid (LHsQTyVars name) where + mempty = mkHsQTvs [] mappend (HsQTvs kvs1 tvs1) (HsQTvs kvs2 tvs2) = HsQTvs (kvs1 ++ kvs2) (tvs1 ++ tvs2) +-} ------------------------------------------------ --- HsWithBndrs +-- HsImplicitBndrs -- Used to quantify the binders of a type in cases -- when a HsForAll isn't appropriate: -- * Patterns in a type/data family instance (HsTyPats) @@ -199,20 +244,96 @@ instance Monoid (LHsTyVarBndrs name) where -- * Pattern type signatures (SigPatIn) -- In the last of these, wildcards can happen, so we must accommodate them -data HsWithBndrs name thing - = HsWB { hswb_cts :: thing -- Main payload (type or list of types) - , hswb_kvs :: PostRn name [Name] -- Kind vars - , hswb_tvs :: PostRn name [Name] -- Type vars - , hswb_wcs :: PostRn name [Name] -- Wild cards +data HsImplicitBndrs name thing -- See Note [HsType binders] + = HsIB { hsib_kvs :: PostRn name [Name] -- Implicitly-bound kind vars + , hsib_tvs :: PostRn name [Name] -- Implicitly-bound type vars + , hsib_body :: thing -- Main payload (type or list of types) } deriving (Typeable) + +data HsWildCardBndrs name thing -- See Note [HsType binders] + = HsWC { hswc_wcs :: PostRn name [Name] + -- Wild cards, both named and anonymous + + , hswc_ctx :: Maybe SrcSpan + -- Indicates whether hswc_body has an + -- extra-constraint wildcard, and if so where + -- e.g. (Eq a, _) => a -> a + -- NB: the wildcard stays in HsQualTy inside the type! + -- So for pretty printing purposes you can ignore + -- hswc_ctx + + , hswc_body :: thing -- Main payload (type or list of types) + } + deriving( Typeable ) + deriving instance (Data name, Data thing, Data (PostRn name [Name])) - => Data (HsWithBndrs name thing) + => Data (HsImplicitBndrs name thing) -mkHsWithBndrs :: thing -> HsWithBndrs RdrName thing -mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = PlaceHolder - , hswb_tvs = PlaceHolder - , hswb_wcs = PlaceHolder } +deriving instance (Data name, Data thing, Data (PostRn name [Name])) + => Data (HsWildCardBndrs name thing) + +type LHsSigType name = HsImplicitBndrs name (LHsType name) -- Implicit only +type LHsWcType name = HsWildCardBndrs name (LHsType name) -- Wildcard only +type LHsSigWcType name = HsImplicitBndrs name (LHsWcType name) -- Both + +-- See Note [Representing type signatures] + +hsImplicitBody :: HsImplicitBndrs name thing -> thing +hsImplicitBody (HsIB { hsib_body = body }) = body + +hsSigType :: LHsSigType name -> LHsType name +hsSigType = hsImplicitBody + +hsSigWcType :: LHsSigWcType name -> LHsType name +hsSigWcType sig_ty = hswc_body (hsib_body sig_ty) + +dropWildCards :: LHsSigWcType name -> LHsSigType name +-- Drop the wildcard part of a LHsSigWcType +dropWildCards sig_ty = sig_ty { hsib_body = hsSigWcType sig_ty } + +{- Note [Representing type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +HsSigType is used to represent an explicit user type signature +such as f :: a -> a + or g (x :: a -> a) = x + +A HsSigType is just a HsImplicitBndrs wrapping a LHsType. + * The HsImplicitBndrs binds the /implicitly/ quantified tyvars + * The LHsType binds the /explictly/ quantified tyvars + +E.g. For a signature like + f :: forall (a::k). blah +we get + HsIB { hsib_kvs = [k] + , hsib_tvs = [] + , hsib_body = HsForAllTy { hst_bndrs = [(a::*)] + , hst_body = blah } +The implicit kind variable 'k' is bound by the HsIB; +the explictly forall'd tyvar 'a' is bounnd by the HsForAllTy +-} + +mkHsImplicitBndrs :: thing -> HsImplicitBndrs RdrName thing +mkHsImplicitBndrs x = HsIB { hsib_body = x + , hsib_kvs = PlaceHolder + , hsib_tvs = PlaceHolder } + +mkHsWildCardBndrs :: thing -> HsWildCardBndrs RdrName thing +mkHsWildCardBndrs x = HsWC { hswc_body = x + , hswc_wcs = PlaceHolder + , hswc_ctx = Nothing } + +-- Add empty binders. This is a bit suspicious; what if +-- the wrapped thing had free type variables? +mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs Name thing +mkEmptyImplicitBndrs x = HsIB { hsib_body = x + , hsib_kvs = [] + , hsib_tvs = [] } + +mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs Name thing +mkEmptyWildCardBndrs x = HsWC { hswc_body = x + , hswc_wcs = [] + , hswc_ctx = Nothing } -------------------------------------------------- @@ -254,27 +375,22 @@ isHsKindedTyVar (UserTyVar {}) = False isHsKindedTyVar (KindedTyVar {}) = True -- | Do all type variables in this 'LHsTyVarBndr' come with kind annotations? -hsTvbAllKinded :: LHsTyVarBndrs name -> Bool +hsTvbAllKinded :: LHsQTyVars name -> Bool hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvBndrs data HsType name - = HsForAllTy HsExplicitFlag -- Renamer leaves this flag unchanged, to record the way - -- the user wrote it originally, so that the printer can - -- print it as the user wrote it - (Maybe SrcSpan) -- Indicates whether extra constraints may be inferred. - -- When Nothing, no, otherwise the location of the extra- - -- constraints wildcard is stored. For instance, for the - -- signature (Eq a, _) => a -> a -> Bool, this field would - -- be something like (Just 1:8), with 1:8 being line 1, - -- column 8. - (LHsTyVarBndrs name) - (LHsContext name) - (LHsType name) + = HsForAllTy -- See Note [HsType binders] + { hst_bndrs :: [LHsTyVarBndr name] -- Explicit, user-supplied 'forall a b c' + , hst_body :: LHsType name -- body type + } -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall', -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' - -- For details on above see note [Api annotations] in ApiAnnotation + | HsQualTy -- See Note [HsType binders] + { hst_ctxt :: LHsContext name -- Context C => blah + , hst_body :: LHsType name } + | HsTyVar (Located name) -- Type variable, type constructor, or data constructor -- see Note [Promotions (HsTyVar)] @@ -439,7 +555,8 @@ mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2 data HsWildCardInfo name = AnonWildCard (PostRn name (Located Name)) - -- A anonymous wild card ('_'). A name is generated during renaming. + -- A anonymous wild card ('_'). A fresh Name is generated for + -- each individual anonymous wildcard during renaming | NamedWildCard (Located name) -- A named wild card ('_a'). deriving (Typeable) @@ -548,13 +665,6 @@ data HsTupleSort = HsUnboxedTuple | HsBoxedOrConstraintTuple deriving (Data, Typeable) -data HsExplicitFlag - = Explicit -- An explicit forall, eg f :: forall a. a-> a - | Implicit -- No explicit forall, eg f :: a -> a, or f :: Eq a => a -> a - | Qualified -- A *nested* occurrences of (ctxt => ty), with no explicit forall - -- e.g. f :: (Eq a => a -> a) -> Int - deriving (Data, Typeable) - type LConDeclField name = Located (ConDeclField name) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when -- in a list @@ -655,86 +765,38 @@ gives -- A valid type must have a for-all at the top of the type, or of the fn arg -- types -mkImplicitHsForAllTy :: LHsType RdrName -> HsType RdrName -mkExplicitHsForAllTy :: [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName -mkQualifiedHsForAllTy :: LHsContext RdrName -> LHsType RdrName -> HsType RdrName - --- | mkImplicitHsForAllTy is called when we encounter --- f :: type --- Wrap around a HsForallTy if one is not there already. -mkImplicitHsForAllTy (L _ (HsForAllTy exp extra tvs cxt ty)) - = HsForAllTy exp' extra tvs cxt ty - where - exp' = case exp of - Qualified -> Implicit - -- Qualified is used only for a nested forall, - -- this is now top level - _ -> exp -mkImplicitHsForAllTy ty = mkHsForAllTy Implicit [] (noLoc []) ty - -mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty -mkQualifiedHsForAllTy ctxt ty = mkHsForAllTy Qualified [] ctxt ty - --- |Smart constructor for HsForAllTy, which populates the extra-constraints --- field if a wildcard is present in the context. -mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName -mkHsForAllTy exp tvs ctxt ty - = HsForAllTy exp Nothing (mkHsQTvs tvs) ctxt ty - --- |When a sigtype is parsed, the type found is wrapped in an Implicit --- HsForAllTy via mkImplicitHsForAllTy, to ensure that a signature always has a --- forall at the outer level. For Api Annotations this nested structure is --- important to ensure that all `forall` and `.` locations are retained. From --- the renamer onwards this structure is flattened, to ease the renaming and --- type checking process. -flattenTopLevelLHsForAllTy :: LHsType name -> LHsType name -flattenTopLevelLHsForAllTy (L l ty) = L l (flattenTopLevelHsForAllTy ty) - -flattenTopLevelHsForAllTy :: HsType name -> HsType name -flattenTopLevelHsForAllTy (HsForAllTy exp extra tvs (L l []) ty) - = snd $ mk_forall_ty [] l exp extra tvs ty -flattenTopLevelHsForAllTy ty = ty - -flattenHsForAllTyKeepAnns :: HsType name -> ([AddAnn],HsType name) -flattenHsForAllTyKeepAnns (HsForAllTy exp extra tvs (L l []) ty) - = mk_forall_ty [] l exp extra tvs ty -flattenHsForAllTyKeepAnns ty = ([],ty) - --- mk_forall_ty makes a pure for-all type (no context) -mk_forall_ty :: [AddAnn] -> SrcSpan -> HsExplicitFlag -> Maybe SrcSpan - -> LHsTyVarBndrs name - -> LHsType name -> ([AddAnn],HsType name) -mk_forall_ty ann _ exp1 extra1 tvs1 (L _ (HsForAllTy exp2 extra qtvs2 ctxt ty)) - = (ann,HsForAllTy (exp1 `plus` exp2) (mergeExtra extra1 extra) - (tvs1 `mappend` qtvs2) ctxt ty) - where - -- Bias the merging of extra's to the top level, so that a single - -- wildcard context will prevail - mergeExtra (Just s) _ = Just s - mergeExtra _ e = e -mk_forall_ty ann l exp extra tvs (L lp (HsParTy ty)) - = mk_forall_ty (ann ++ mkParensApiAnn lp) l exp extra tvs ty -mk_forall_ty ann l exp extra tvs ty - = (ann,HsForAllTy exp extra tvs (L l []) ty) - -- Even if tvs is empty, we still make a HsForAll! - -- In the Implicit case, this signals the place to do implicit quantification - -- In the Explicit case, it prevents implicit quantification - -- (see the sigtype production in Parser.y) - -- so that (forall. ty) isn't implicitly quantified - -plus :: HsExplicitFlag -> HsExplicitFlag -> HsExplicitFlag -Qualified `plus` Qualified = Qualified -Explicit `plus` _ = Explicit -_ `plus` Explicit = Explicit -_ `plus` _ = Implicit - -- NB: Implicit `plus` Qualified = Implicit - -- so that f :: Eq a => a -> a ends up Implicit - --------------------- -hsExplicitTvs :: LHsType Name -> [Name] --- The explicitly-given forall'd type variables of a HsType -hsExplicitTvs (L _ (HsForAllTy Explicit _ tvs _ _)) = hsLKiTyVarNames tvs -hsExplicitTvs _ = [] +hsWcScopedTvs :: LHsSigWcType Name -> [Name] +-- Get the lexically-scoped type variables of a HsSigType +-- - the explicitly-given forall'd type variables +-- - the implicitly-bound kind variables +-- - the named wildcars; see Note [Scoping of named wildcards] +-- because they scope in the same way +hsWcScopedTvs sig_ty + | HsIB { hsib_kvs = kvs, hsib_body = sig_ty1 } <- sig_ty + , HsWC { hswc_wcs = nwcs, hswc_body = sig_ty2 } <- sig_ty1 + , (tvs, _) <- splitLHsForAllTy sig_ty2 + = kvs ++ nwcs ++ map hsLTyVarName tvs + +hsScopedTvs :: LHsSigType Name -> [Name] +-- Same as hsWcScopedTvs, but for a LHsSigType +hsScopedTvs sig_ty + | HsIB { hsib_kvs = kvs, hsib_body = sig_ty2 } <- sig_ty + , (tvs, _) <- splitLHsForAllTy sig_ty2 + = kvs ++ map hsLTyVarName tvs + +{- Note [Scoping of named wildcards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: _a -> _a + f x = let g :: _a -> _a + g = ... + in ... + +Currently, for better or worse, the "_a" variables are all the same. So +although there is no explicit forall, the "_a" scopes over the definition. +I don't know if this is a good idea, but there it is. +-} --------------------- hsTyVarName :: HsTyVarBndr name -> name @@ -744,11 +806,11 @@ hsTyVarName (KindedTyVar (L _ n) _) = n hsLTyVarName :: LHsTyVarBndr name -> name hsLTyVarName = hsTyVarName . unLoc -hsLTyVarNames :: LHsTyVarBndrs name -> [name] +hsLTyVarNames :: LHsQTyVars name -> [name] -- Type variables only hsLTyVarNames qtvs = map hsLTyVarName (hsQTvBndrs qtvs) -hsLKiTyVarNames :: LHsTyVarBndrs Name -> [Name] +hsLKiTyVarNames :: LHsQTyVars Name -> [Name] -- Kind and type variables hsLKiTyVarNames (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) = kvs ++ map hsLTyVarName tvs @@ -756,9 +818,6 @@ hsLKiTyVarNames (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) hsLTyVarLocName :: LHsTyVarBndr name -> Located name hsLTyVarLocName = fmap hsTyVarName -hsLTyVarLocNames :: LHsTyVarBndrs name -> [Located name] -hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs) - -- | Convert a LHsTyVarBndr to an equivalent LHsType. Used in Template Haskell -- quoting for type family equations. hsLTyVarBndrToType :: LHsTyVarBndr name -> LHsType name @@ -770,7 +829,7 @@ hsLTyVarBndrToType = fmap cvt -- | Convert a LHsTyVarBndrs to a list of types. Used in Template Haskell -- quoting for type family equations. Works on *type* variable only, no kind -- vars. -hsLTyVarBndrsToTypes :: LHsTyVarBndrs name -> [LHsType name] +hsLTyVarBndrsToTypes :: LHsQTyVars name -> [LHsType name] hsLTyVarBndrsToTypes (HsQTvs { hsq_tvs = tvbs }) = map hsLTyVarBndrToType tvbs --------------------- @@ -836,33 +895,62 @@ mkHsAppTys fun_ty (arg_ty:arg_tys) -- Add noLocs for inner nodes of the application; -- they are never used -splitLHsInstDeclTy_maybe - :: LHsType name - -> Maybe (LHsTyVarBndrs name, HsContext name, Located name, [LHsType name]) +splitLHsPatSynTy :: LHsType name + -> ( [LHsTyVarBndr name] + , LHsContext name -- Required + , LHsContext name -- Provided + , LHsType name) -- Body +splitLHsPatSynTy ty + | L _ (HsQualTy { hst_ctxt = req, hst_body = ty2 }) <- ty1 + , L _ (HsQualTy { hst_ctxt = prov, hst_body = ty3 }) <- ty2 + = (tvs, req, prov, ty3) + + | L _ (HsQualTy { hst_ctxt = req, hst_body = ty2 }) <- ty1 + = (tvs, req, noLoc [], ty2) + + | otherwise + = (tvs, noLoc [], noLoc [], ty1) + where + (tvs, ty1) = splitLHsForAllTy ty + +splitLHsSigmaTy :: LHsType name -> ([LHsTyVarBndr name], LHsContext name, LHsType name) +splitLHsSigmaTy ty + | (tvs, ty1) <- splitLHsForAllTy ty + , (ctxt, ty2) <- splitLHsQualTy ty1 + = (tvs, ctxt, ty2) + +splitLHsForAllTy :: LHsType name -> ([LHsTyVarBndr name], LHsType name) +splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body) +splitLHsForAllTy body = ([], body) + +splitLHsQualTy :: LHsType name -> (LHsContext name, LHsType name) +splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body) +splitLHsQualTy body = (noLoc [], body) + +splitLHsInstDeclTy + :: LHsSigType Name + -> ([Name], LHsContext Name, LHsType Name) -- Split up an instance decl type, returning the pieces -splitLHsInstDeclTy_maybe inst_ty = do - let (tvs, cxt, ty) = splitLHsForAllTy inst_ty - (cls, tys) <- splitLHsClassTy_maybe ty - return (tvs, cxt, cls, tys) - -splitLHsForAllTy - :: LHsType name - -> (LHsTyVarBndrs name, HsContext name, LHsType name) -splitLHsForAllTy poly_ty - = case unLoc poly_ty of - HsParTy ty -> splitLHsForAllTy ty - HsForAllTy _ _ tvs cxt ty -> (tvs, unLoc cxt, ty) - _ -> (emptyHsQTvs, [], poly_ty) - -- The type vars should have been computed by now, even if they were implicit - -splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name]) -splitHsClassTy_maybe ty = fmap (\(L _ n, tys) -> (n, tys)) $ splitLHsClassTy_maybe (noLoc ty) +splitLHsInstDeclTy (HsIB { hsib_kvs = ikvs, hsib_tvs = itvs + , hsib_body = inst_ty }) + = (ikvs ++ itvs, cxt, body_ty) + -- Return implicitly bound type and kind vars + -- For an instance decl, all of them are in scope + where + (cxt, body_ty) = splitLHsQualTy inst_ty -splitLHsClassTy_maybe :: LHsType name -> Maybe (Located name, [LHsType name]) ---- Watch out.. in ...deriving( Show )... we use this on ---- the list of partially applied predicates in the deriving, ---- so there can be zero args. +getLHsInstDeclClass_maybe :: LHsSigType name -> Maybe (Located name) +-- Works on (HsSigType RdrName) +getLHsInstDeclClass_maybe inst_ty + = do { let (_, tau) = splitLHsQualTy (hsSigType inst_ty) + ; (cls, _) <- splitLHsClassTy_maybe tau + ; return cls } +splitLHsClassTy_maybe :: LHsType name -> Maybe (Located name, [LHsType name]) +-- Watch out.. in ...deriving( Show )... we use this on +-- the list of partially applied predicates in the deriving, +-- so there can be zero args. +-- -- In TcDeriv we also use this to figure out what data type is being -- mentioned in a deriving (Generic (Foo bar baz)) declaration (i.e. "Foo"). splitLHsClassTy_maybe ty @@ -921,23 +1009,26 @@ instance (OutputableBndr name) => Outputable (HsType name) where instance Outputable HsTyLit where ppr = ppr_tylit -instance (OutputableBndr name) => Outputable (LHsTyVarBndrs name) where - ppr (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) - = sep [ ifPprDebug $ braces (interppSP kvs), interppSP tvs ] +instance (OutputableBndr name) + => Outputable (LHsQTyVars name) where + ppr (HsQTvs { hsq_tvs = tvs }) = interppSP tvs instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where ppr (UserTyVar n) = ppr n ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k] -instance (Outputable thing) => Outputable (HsWithBndrs name thing) where - ppr (HsWB { hswb_cts = ty }) = ppr ty +instance (Outputable thing) => Outputable (HsImplicitBndrs name thing) where + ppr (HsIB { hsib_body = ty }) = ppr ty + +instance (Outputable thing) => Outputable (HsWildCardBndrs name thing) where + ppr (HsWC { hswc_body = ty }) = ppr ty instance (Outputable name) => Outputable (HsWildCardInfo name) where ppr (AnonWildCard _) = char '_' ppr (NamedWildCard n) = ppr n -pprHsForAll :: OutputableBndr name => HsExplicitFlag -> LHsTyVarBndrs name -> LHsContext name -> SDoc -pprHsForAll exp = pprHsForAllExtra exp Nothing +pprHsForAll :: OutputableBndr name => [LHsTyVarBndr name] -> LHsContext name -> SDoc +pprHsForAll = pprHsForAllExtra Nothing -- | Version of 'pprHsForAll' that can also print an extra-constraints -- wildcard, e.g. @_ => a -> Bool@ or @(Show a, _) => a -> String@. This @@ -946,16 +1037,18 @@ pprHsForAll exp = pprHsForAllExtra exp Nothing -- function for this is needed, as the extra-constraints wildcard is removed -- from the actual context and type, and stored in a separate field, thus just -- printing the type will not print the extra-constraints wildcard. -pprHsForAllExtra :: OutputableBndr name => HsExplicitFlag -> Maybe SrcSpan -> LHsTyVarBndrs name -> LHsContext name -> SDoc -pprHsForAllExtra exp extra qtvs cxt - | show_forall = forall_part <+> pprHsContextExtra show_extra (unLoc cxt) - | otherwise = pprHsContextExtra show_extra (unLoc cxt) +pprHsForAllExtra :: OutputableBndr name => Maybe SrcSpan -> [LHsTyVarBndr name] -> LHsContext name -> SDoc +pprHsForAllExtra extra qtvs cxt + = pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt) where - show_extra = isJust extra - show_forall = opt_PprStyle_Debug - || (not (null (hsQTvBndrs qtvs)) && is_explicit) - is_explicit = case exp of {Explicit -> True; Implicit -> False; Qualified -> False} - forall_part = forAllLit <+> ppr qtvs <> dot + show_extra = isJust extra + +pprHsForAllTvs :: OutputableBndr name => [LHsTyVarBndr name] -> SDoc +pprHsForAllTvs qtvs + | show_forall = forAllLit <+> interppSP qtvs <> dot + | otherwise = empty + where + show_forall = opt_PprStyle_Debug || not (null qtvs) pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe @@ -970,12 +1063,15 @@ pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt) -- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@ pprHsContextExtra :: (OutputableBndr name) => Bool -> HsContext name -> SDoc -pprHsContextExtra False = pprHsContext -pprHsContextExtra True - = \ctxt -> case ctxt of - [] -> char '_' <+> darrow - _ -> parens (sep (punctuate comma ctxt')) <+> darrow - where ctxt' = map ppr ctxt ++ [char '_'] +pprHsContextExtra show_extra ctxt + | not show_extra + = pprHsContext ctxt + | null ctxt + = char '_' <+> darrow + | otherwise + = parens (sep (punctuate comma ctxt')) <+> darrow + where + ctxt' = map ppr ctxt ++ [char '_'] pprConDeclFields :: OutputableBndr name => [LConDeclField name] -> SDoc pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) @@ -1018,9 +1114,13 @@ ppr_mono_lty :: (OutputableBndr name) => TyPrec -> LHsType name -> SDoc ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) ppr_mono_ty :: (OutputableBndr name) => TyPrec -> HsType name -> SDoc -ppr_mono_ty ctxt_prec (HsForAllTy exp extra tvs ctxt ty) +ppr_mono_ty ctxt_prec (HsForAllTy { hst_bndrs = tvs, hst_body = ty }) + = maybeParen ctxt_prec FunPrec $ + sep [pprHsForAllTvs tvs, ppr_mono_lty TopPrec ty] + +ppr_mono_ty ctxt_prec (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty }) = maybeParen ctxt_prec FunPrec $ - sep [pprHsForAllExtra exp extra tvs ctxt, ppr_mono_lty TopPrec ty] + sep [pprHsContext ctxt, ppr_mono_lty TopPrec ty] ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty TyConPrec ty ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 62aabe34fa..19996fd0f1 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -23,14 +23,14 @@ module HsUtils( mkSimpleMatch, unguardedGRHSs, unguardedRHS, mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf, mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo, - coToHsWrapper, coToHsWrapperR, mkHsDictLet, mkHsLams, + mkHsDictLet, mkHsLams, mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, mkLHsPar, mkHsCmdCast, nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, - toHsType, toHsKind, + toLHsSigWcType, -- * Constructing general big tuples -- $big_tuples @@ -52,6 +52,7 @@ module HsUtils( -- Types mkHsAppTy, userHsTyVarBndrs, + mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, -- Stmts @@ -91,12 +92,13 @@ import HsTypes import HsLit import PlaceHolder +import TcType( tcSplitForAllTys, tcSplitPhiTy ) import TcEvidence import RdrName import Var +import Type( isPredTy ) +import Kind( isKind ) import TypeRep -import TcType -import Kind import DataCon import Name import NameSet @@ -516,48 +518,67 @@ chunkify xs {- ************************************************************************ * * - Converting a Type to an HsType RdrName + LHsSigType and LHsSigWcType * * -************************************************************************ +********************************************************************* -} -This is needed to implement GeneralizedNewtypeDeriving. --} +mkLHsSigType :: LHsType RdrName -> LHsSigType RdrName +mkLHsSigType ty = mkHsImplicitBndrs ty -toHsType :: Type -> LHsType RdrName -toHsType ty - | [] <- tvs_only - , [] <- theta - = to_hs_type tau - | otherwise - = noLoc $ - mkExplicitHsForAllTy (map mk_hs_tvb tvs_only) - (noLoc $ map toHsType theta) - (to_hs_type tau) +mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName +mkLHsSigWcType ty = mkHsImplicitBndrs (mkHsWildCardBndrs ty) +mkClassOpSigs :: [LSig RdrName] -> [LSig RdrName] +-- Convert TypeSig to ClassOpSig +-- The former is what is parsed, but the latter is +-- what we need in class/instance declarations +mkClassOpSigs sigs + = map fiddle sigs where - (tvs, theta, tau) = tcSplitSigmaTy ty - tvs_only = filter isTypeVar tvs + fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty)) + fiddle sig = sig - to_hs_type (TyVarTy tv) = nlHsTyVar (getRdrName tv) - to_hs_type (AppTy t1 t2) = nlHsAppTy (toHsType t1) (toHsType t2) - to_hs_type (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map toHsType args') +toLHsSigWcType :: Type -> LHsSigWcType RdrName +-- ^ Converting a Type to an HsType RdrName +-- This is needed to implement GeneralizedNewtypeDeriving. +-- +-- Note that we use 'getRdrName' extensively, which +-- generates Exact RdrNames rather than strings. +toLHsSigWcType ty + = mkLHsSigWcType (go ty) + where + go :: Type -> LHsType RdrName + go ty@(ForAllTy {}) + | (tvs, tau) <- tcSplitForAllTys ty + = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs + , hst_body = go tau }) + go ty@(FunTy arg _) + | isPredTy arg + , (theta, tau) <- tcSplitPhiTy ty + = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta) + , hst_body = go tau }) + go (FunTy arg res) = nlHsFunTy (go arg) (go res) + go (TyVarTy tv) = nlHsTyVar (getRdrName tv) + go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2) + go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n) + go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s) + go (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map go args') where args' = filterOut isKind args -- Source-language types have _implicit_ kind arguments, -- so we must remove them here (Trac #8563) - to_hs_type (FunTy arg res) = ASSERT( not (isConstraintKind (typeKind arg)) ) - nlHsFunTy (toHsType arg) (toHsType res) - to_hs_type t@(ForAllTy {}) = pprPanic "toHsType" (ppr t) - to_hs_type (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n) - to_hs_type (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s) - mk_hs_tvb tv = noLoc $ KindedTyVar (noLoc (getRdrName tv)) - (toHsKind (tyVarKind tv)) + go_tv :: TyVar -> LHsTyVarBndr RdrName + go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv)) + (go (tyVarKind tv)) -toHsKind :: Kind -> LHsKind RdrName -toHsKind = toHsType ---------- HsWrappers: type args, dict args, casts --------- +{- ********************************************************************* +* * + --------- HsWrappers: type args, dict args, casts --------- +* * +********************************************************************* -} + mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) @@ -567,35 +588,26 @@ mkHsWrap co_fn e | isIdHsWrapper co_fn = e mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b -> HsExpr id -> HsExpr id -mkHsWrapCo co e = mkHsWrap (coToHsWrapper co) e +mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b -> HsExpr id -> HsExpr id -mkHsWrapCoR co e = mkHsWrap (coToHsWrapperR co) e +mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e -mkLHsWrapCo :: TcCoercion -> LHsExpr id -> LHsExpr id +mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e) mkHsCmdCast :: TcCoercion -> HsCmd id -> HsCmd id mkHsCmdCast co cmd | isTcReflCo co = cmd | otherwise = HsCmdCast co cmd -coToHsWrapper :: TcCoercion -> HsWrapper -- A Nominal coercion -coToHsWrapper co | isTcReflCo co = idHsWrapper - | otherwise = mkWpCast (mkTcSubCo co) - -coToHsWrapperR :: TcCoercion -> HsWrapper -- A Representational coercion -coToHsWrapperR co | isTcReflCo co = idHsWrapper - | otherwise = mkWpCast co - mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p | otherwise = CoPat co_fn p ty --- input coercion is Nominal -mkHsWrapPatCo :: TcCoercion -> Pat id -> Type -> Pat id +mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id mkHsWrapPatCo co pat ty | isTcReflCo co = pat - | otherwise = CoPat (mkWpCast (mkTcSubCo co)) pat ty + | otherwise = CoPat (mkWpCastN co) pat ty mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr @@ -869,8 +881,8 @@ hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = ([L loc name] hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name , tcdSigs = sigs, tcdATs = ats })) = (L loc cls_name : - [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++ - [ L mem_loc mem_name | L mem_loc (TypeSig ns _ _) <- sigs, L _ mem_name <- ns ] + [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++ + [ L mem_loc mem_name | L mem_loc (ClassOpSig False ns _) <- sigs, L _ mem_name <- ns ] , []) hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn })) = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn @@ -880,7 +892,7 @@ hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name] -- See Note [SrcSpan for binders] hsForeignDeclsBinders foreign_decls = [ L decl_loc n - | L decl_loc (ForeignImport (L _ n) _ _ _) <- foreign_decls] + | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls] diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 463078ce67..307a448ec9 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -869,9 +869,12 @@ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConExTvs = ex_tvs, ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, - ifConStricts = stricts, ifConFields = labels }) - | gadt_style = pp_prefix_con <+> dcolon <+> ppr_ty - | otherwise = ppr_fields tys_w_strs + ifConStricts = stricts, ifConFields = fields }) + | gadt_style = pp_prefix_con <+> dcolon <+> ppr_ty + | not (null fields) = pp_prefix_con <+> pp_field_args + | is_infix + , [ty1, ty2] <- pp_args = sep [ty1, pprInfixIfDeclBndr ss name, ty2] + | otherwise = pp_prefix_con <+> sep pp_args where tys_w_strs :: [(IfaceBang, IfaceType)] tys_w_strs = zip stricts arg_tys @@ -882,9 +885,12 @@ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls -- A bit gruesome this, but we can't form the full con_tau, and ppr it, -- because we don't have a Name for the tycon, only an OccName - pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of + pp_tau | null fields + = case pp_args ++ [pp_res_ty] of (t:ts) -> fsep (t : map (arrow <+>) ts) [] -> panic "pp_con_taus" + | otherwise + = sep [pp_field_args, arrow <+> pp_res_ty] ppr_bang IfNoBang = ppWhen opt_PprStyle_Debug $ char '_' ppr_bang IfStrict = char '!' @@ -895,6 +901,13 @@ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls pprParendBangTy (bang, ty) = ppr_bang bang <> pprParendIfaceType ty pprBangTy (bang, ty) = ppr_bang bang <> ppr ty + pp_args :: [SDoc] -- With parens, e.g (Maybe a) or !(Maybe a) + pp_args = map pprParendBangTy tys_w_strs + + pp_field_args :: SDoc -- Braces form: { x :: !Maybe a, y :: Int } + pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $ + map maybe_show_label (zip fields tys_w_strs) + maybe_show_label (sel,bty) | showSub ss sel = Just (pprPrefixIfDeclBndr ss lbl <+> dcolon <+> pprBangTy bty) | otherwise = Nothing @@ -904,14 +917,6 @@ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls -- DuplicateRecordFields was used for the definition) lbl = maybe sel (mkVarOccFS . flLabel) $ find (\ fl -> flSelector fl == sel) fls - ppr_fields [ty1, ty2] - | is_infix && null labels - = sep [pprParendBangTy ty1, pprInfixIfDeclBndr ss name, pprParendBangTy ty2] - ppr_fields fields - | null labels = pp_prefix_con <+> sep (map pprParendBangTy fields) - | otherwise = pp_prefix_con <+> (braces $ sep $ punctuate comma $ ppr_trim $ - map maybe_show_label (zip labels fields)) - instance Outputable IfaceRule where ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index d32f619675..b7f3dd756e 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -45,7 +45,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) ("InstType ", inst_type_ds), ("InstData ", inst_data_ds), ("TypeSigs ", bind_tys), - ("GenericSigs ", generic_sigs), + ("ClassOpSigs ", generic_sigs), ("ValBinds ", val_bind_ds), ("FunBinds ", fn_bind_ds), ("PatSynBinds ", patsyn_ds), @@ -105,12 +105,12 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) count_sigs sigs = sum5 (map sig_info sigs) - sig_info (FixSig _) = (1,0,0,0,0) - sig_info (TypeSig _ _ _) = (0,1,0,0,0) - sig_info (SpecSig _ _ _) = (0,0,1,0,0) - sig_info (InlineSig _ _) = (0,0,0,1,0) - sig_info (GenericSig _ _) = (0,0,0,0,1) - sig_info _ = (0,0,0,0,0) + sig_info (FixSig {}) = (1,0,0,0,0) + sig_info (TypeSig {}) = (0,1,0,0,0) + sig_info (SpecSig {}) = (0,0,1,0,0) + sig_info (InlineSig {}) = (0,0,0,1,0) + sig_info (ClassOpSig {}) = (0,0,0,0,1) + sig_info _ = (0,0,0,0,0) import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual , ideclAs = as, ideclHiding = spec })) @@ -126,7 +126,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs , dd_derivs = derivs}}) - = (length cs, case derivs of Nothing -> 0 + = (length cs, case derivs of Nothing -> 0 Just (L _ ds) -> length ds) data_info _ = (0,0) diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 290f27b71c..b5abdf4374 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -1709,10 +1709,12 @@ implicitClassThings :: Class -> [TyThing] implicitClassThings cl = -- Does not include default methods, because those Ids may have -- their own pragmas, unfoldings etc, not derived from the Class object + -- associated types -- No recursive call for the classATs, because they -- are only the family decls; they have no implicit things map ATyCon (classATs cl) ++ + -- superclass and operation selectors map AnId (classAllSelIds cl) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 32f4254703..db96acbcbc 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -2641,11 +2641,15 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag)) %************************************************************************ -} --- |Encapsulated call to addAnnotation, requiring only the SrcSpan of --- the AST element the annotation belongs to -type AddAnn = (SrcSpan -> P ()) - -addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P () +-- | Encapsulated call to addAnnotation, requiring only the SrcSpan of +-- the AST construct the annotation belongs to; together with the +-- AnnKeywordId, this is is the key of the annotation map +type AddAnn = SrcSpan -> P () + +addAnnotation :: SrcSpan -- SrcSpan of enclosing AST construct + -> AnnKeywordId -- The first two parameters are the key + -> SrcSpan -- The location of the keyword itself + -> P () addAnnotation l a v = do addAnnotationOnly l a v allocateComments l diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index dac78dfcae..fb5c8dbd45 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -900,10 +900,11 @@ inst_decl :: { LInstDecl RdrName } : 'instance' overlap_pragma inst_type where_inst {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4) ; let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds - , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_sigs = mkClassOpSigs sigs + , cid_tyfam_insts = ats , cid_overlap_mode = $2 , cid_datafam_insts = adts } - ; ams (L (comb3 $1 $3 $4) (ClsInstD { cid_inst = cid })) + ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_inst = cid })) (mj AnnInstance $1 : (fst $ unLoc $4)) } } -- type instance declarations @@ -1122,11 +1123,10 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}' -- Glasgow extension: stand-alone deriving declarations stand_alone_deriving :: { LDerivDecl RdrName } : 'deriving' 'instance' overlap_pragma inst_type - {% do { - let err = text "in the stand-alone deriving instance" - <> colon <+> quotes (ppr $4) - ; ams (sLL $1 $> (DerivDecl $4 $3)) - [mj AnnDeriving $1,mj AnnInstance $2] }} + {% do { let { err = text "in the stand-alone deriving instance" + <> colon <+> quotes (ppr $4) } + ; ams (sLL $1 (hsSigType $>) (DerivDecl $4 $3)) + [mj AnnDeriving $1, mj AnnInstance $2] } } ----------------------------------------------------------------------------- -- Role annotations @@ -1160,10 +1160,12 @@ pattern_synonym_decl :: { LHsDecl RdrName } ImplicitBidirectional) (as ++ [mj AnnPattern $1, mj AnnEqual $3]) } + | 'pattern' pattern_synonym_lhs '<-' pat {% let (name, args, as) = $2 in ams (sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) } + | 'pattern' pattern_synonym_lhs '<-' pat where_decls {% do { let (name, args, as) = $2 ; mg <- mkPatSynMatchGroup name (snd $ unLoc $5) @@ -1192,29 +1194,30 @@ where_decls :: { Located ([AddAnn] :mcc $4:(fst $ unLoc $3)),sL1 $3 (snd $ unLoc $3)) } | 'where' vocurly decls close { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3)) ,sL1 $3 (snd $ unLoc $3)) } + pattern_synonym_sig :: { LSig RdrName } : 'pattern' con '::' ptype - {% do { let (flag, qtvs, req, prov, ty) = snd $ unLoc $4 - ; let sig = PatSynSig $2 (flag, mkHsQTvs qtvs) req prov ty - ; ams (sLL $1 $> $ sig) - (mj AnnPattern $1:mu AnnDcolon $3:(fst $ unLoc $4)) } } - -ptype :: { Located ([AddAnn] - ,( HsExplicitFlag, [LHsTyVarBndr RdrName], LHsContext RdrName - , LHsContext RdrName, LHsType RdrName)) } + {% ams (sLL $1 $> $ PatSynSig $2 (mkLHsSigType $4)) + [mj AnnPattern $1, mu AnnDcolon $3] } + +ptype :: { LHsType RdrName } : 'forall' tv_bndrs '.' ptype - {% do { hintExplicitForall (getLoc $1) - ; let (_, qtvs', prov, req, ty) = snd $ unLoc $4 - ; return $ sLL $1 $> - ((mu AnnForall $1:mj AnnDot $3:(fst $ unLoc $4)) - ,(Explicit, $2 ++ qtvs', prov, req ,ty)) }} + {% hintExplicitForall (getLoc $1) >> + ams (sLL $1 $> $ + HsForAllTy { hst_bndrs = $2 + , hst_body = $4 }) + [mu AnnForall $1, mj AnnDot $3] } + | context '=>' context '=>' type - { sLL $1 $> ([mu AnnDarrow $2,mu AnnDarrow $4] - ,(Implicit, [], $1, $3, $5)) } + {% ams (sLL $1 $> $ + HsQualTy { hst_ctxt = $1, hst_body = sLL $3 $> $ + HsQualTy { hst_ctxt = $3, hst_body = $5 } }) + [mu AnnDarrow $2, mu AnnDarrow $4] } | context '=>' type - { sLL $1 $> ([mu AnnDarrow $2],(Implicit, [], $1, noLoc [], $3)) } - | type - { sL1 $1 ([],(Implicit, [], noLoc [], noLoc [], $1)) } + {% ams (sLL $1 $> $ + HsQualTy { hst_ctxt = $1, hst_body = $3 }) + [mu AnnDarrow $2] } + | type { $1 } ----------------------------------------------------------------------------- -- Nested declarations @@ -1227,10 +1230,10 @@ decl_cls : at_decl_cls { $1 } -- A 'default' signature used with the generic-programming extension | 'default' infixexp '::' sigtypedoc - {% do { (TypeSig l ty _) <- checkValSig $2 $4 + {% do { v <- checkValSigLhs $2 ; let err = text "in default signature" <> colon <+> - quotes (ppr ty) - ; ams (sLL $1 $> $ SigD (GenericSig l ty)) + quotes (ppr $2) + ; ams (sLL $1 $> $ SigD $ ClassOpSig True [v] $ mkLHsSigType $4) [mj AnnDefault $1,mu AnnDcolon $3] } } decls_cls :: { Located ([AddAnn],OrdList (LHsDecl RdrName)) } -- Reversed @@ -1399,7 +1402,7 @@ rule_var_list :: { [LRuleBndr RdrName] } rule_var :: { LRuleBndr RdrName } : varid { sLL $1 $> (RuleBndr $1) } | '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleBndrSig $2 - (mkHsWithBndrs $4))) + (mkLHsSigWcType $4))) [mop $1,mu AnnDcolon $3,mcp $5] } ----------------------------------------------------------------------------- @@ -1491,12 +1494,12 @@ safety :: { Located Safety } | 'interruptible' { sLL $1 $> PlayInterruptible } fspec :: { Located ([AddAnn] - ,(Located StringLiteral, Located RdrName, LHsType RdrName)) } + ,(Located StringLiteral, Located RdrName, LHsSigType RdrName)) } : STRING var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $3] ,(L (getLoc $1) - (getStringLiteral $1), $2, $4)) } + (getStringLiteral $1), $2, mkLHsSigType $4)) } | var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $2] - ,(noLoc (StringLiteral "" nilFS), $1, $3)) } + ,(noLoc (StringLiteral "" nilFS), $1, mkLHsSigType $3)) } -- if the entity string is missing, it defaults to the empty string; -- the meaning of an empty entity string depends on the calling -- convention @@ -1504,7 +1507,7 @@ fspec :: { Located ([AddAnn] ----------------------------------------------------------------------------- -- Type signatures -opt_sig :: { ([AddAnn],Maybe (LHsType RdrName)) } +opt_sig :: { ([AddAnn], Maybe (LHsType RdrName)) } : {- empty -} { ([],Nothing) } | '::' sigtype { ([mu AnnDcolon $1],Just $2) } @@ -1512,14 +1515,12 @@ opt_asig :: { ([AddAnn],Maybe (LHsType RdrName)) } : {- empty -} { ([],Nothing) } | '::' atype { ([mu AnnDcolon $1],Just $2) } -sigtype :: { LHsType RdrName } -- Always a HsForAllTy, - -- to tell the renamer where to generalise - : ctype { sL1 $1 (mkImplicitHsForAllTy $1) } - -- Wrap an Implicit forall if there isn't one there already +sigtype :: { LHsType RdrName } + : ctype { $1 } + +sigtypedoc :: { LHsType RdrName } + : ctypedoc { $1 } -sigtypedoc :: { LHsType RdrName } -- Always a HsForAllTy - : ctypedoc { sL1 $1 (mkImplicitHsForAllTy $1) } - -- Wrap an Implicit forall if there isn't one there already sig_vars :: { Located [Located RdrName] } -- Returned in reversed order : sig_vars ',' var {% addAnnotation (gl $ head $ unLoc $1) @@ -1527,10 +1528,10 @@ sig_vars :: { Located [Located RdrName] } -- Returned in reversed order >> return (sLL $1 $> ($3 : unLoc $1)) } | var { sL1 $1 [$1] } -sigtypes1 :: { (OrdList (LHsType RdrName)) } -- Always HsForAllTys - : sigtype { unitOL $1 } - | sigtype ',' sigtypes1 {% addAnnotation (gl $1) AnnComma (gl $2) - >> return ((unitOL $1) `appOL` $3) } +sigtypes1 :: { (OrdList (LHsSigType RdrName)) } + : sigtype { unitOL (mkLHsSigType $1) } + | sigtype ',' sigtypes1 {% addAnnotation (gl $1) AnnComma (gl $2) + >> return (unitOL (mkLHsSigType $1) `appOL` $3) } ----------------------------------------------------------------------------- -- Types @@ -1555,12 +1556,14 @@ unpackedness :: { Located ([AddAnn], Maybe SourceText, SrcUnpackedness) } -- A ctype is a for-all type ctype :: { LHsType RdrName } : 'forall' tv_bndrs '.' ctype {% hintExplicitForall (getLoc $1) >> - ams (sLL $1 $> $ mkExplicitHsForAllTy $2 - (noLoc []) $4) - [mu AnnForall $1,mj AnnDot $3] } + ams (sLL $1 $> $ + HsForAllTy { hst_bndrs = $2 + , hst_body = $4 }) + [mu AnnForall $1, mj AnnDot $3] } | context '=>' ctype {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) >> return (sLL $1 $> $ - mkQualifiedHsForAllTy $1 $3) } + HsQualTy { hst_ctxt = $1 + , hst_body = $3 }) } | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3)) [mj AnnVal $1,mu AnnDcolon $2] } | type { $1 } @@ -1578,12 +1581,14 @@ ctype :: { LHsType RdrName } ctypedoc :: { LHsType RdrName } : 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >> - ams (sLL $1 $> $ mkExplicitHsForAllTy $2 - (noLoc []) $4) + ams (sLL $1 $> $ + HsForAllTy { hst_bndrs = $2 + , hst_body = $4 }) [mu AnnForall $1,mj AnnDot $3] } | context '=>' ctypedoc {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) >> return (sLL $1 $> $ - mkQualifiedHsForAllTy $1 $3) } + HsQualTy { hst_ctxt = $1 + , hst_body = $3 }) } | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3)) [mj AnnVal $1,mu AnnDcolon $2] } | typedoc { $1 } @@ -1723,16 +1728,15 @@ atype :: { LHsType RdrName } -- An inst_type is what occurs in the head of an instance decl -- e.g. (Foo a, Gaz b) => Wibble a b --- It's kept as a single type, with a MonoDictTy at the right --- hand corner, for convenience. -inst_type :: { LHsType RdrName } - : sigtype { $1 } +-- It's kept as a single type for convenience. +inst_type :: { LHsSigType RdrName } + : sigtype { mkLHsSigType $1 } -inst_types1 :: { [LHsType RdrName] } - : inst_type { [$1] } +deriv_types :: { [LHsSigType RdrName] } + : type { [mkLHsSigType $1] } - | inst_type ',' inst_types1 {% addAnnotation (gl $1) AnnComma (gl $2) - >> return ($1 : $3) } + | type ',' deriv_types {% addAnnotation (gl $1) AnnComma (gl $2) + >> return (mkLHsSigType $1 : $3) } comma_types0 :: { [LHsType RdrName] } -- Zero or more: ty,ty,ty : comma_types1 { $1 } @@ -1891,8 +1895,8 @@ gadt_constr_with_doc gadt_constr :: { LConDecl RdrName } -- see Note [Difference in parsing GADT and data constructors] -- Returns a list because of: C,D :: ty - : con_list '::' sigtype - {% do { let { (anns, gadtDecl) = mkGadtDecl (unLoc $1) $3 } + : con_list '::' ctype + {% do { let { (anns,gadtDecl) = mkGadtDecl (unLoc $1) $3 } ; ams (sLL $1 $> gadtDecl) (mu AnnDcolon $2:anns) } } @@ -1932,9 +1936,9 @@ constr :: { LConDecl RdrName } ($1 `mplus` $4)) (fst $ unLoc $2) } -forall :: { Located ([AddAnn],[LHsTyVarBndr RdrName]) } - : 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3],$2) } - | {- empty -} { noLoc ([],[]) } +forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr RdrName]) } + : 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) } + | {- empty -} { noLoc ([], Nothing) } constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) } -- see Note [Parsing data constructors is hard] @@ -1969,21 +1973,23 @@ fielddecl :: { LConDeclField RdrName } (ConDeclField (reverse (map (fmap (flip FieldOcc PlaceHolder)) (unLoc $2))) $4 ($1 `mplus` $5))) [mu AnnDcolon $3] } --- We allow the odd-looking 'inst_type' in a deriving clause, so that --- we can do deriving( forall a. C [a] ) in a newtype (GHC extension). --- The 'C [a]' part is converted to an HsPredTy by checkInstType --- We don't allow a context, but that's sorted out by the type checker. -deriving :: { Located (Maybe (Located [LHsType RdrName])) } +-- The outer Located is just to allow the caller to +-- know the rightmost extremity of the 'deriving' clause +deriving :: { Located (HsDeriving RdrName) } : {- empty -} { noLoc Nothing } - | 'deriving' qtycon {% aljs ( let { L loc tv = $2 } - in (sLL $1 $> (Just (sLL $1 $> - [L loc (HsTyVar $2)])))) - [mj AnnDeriving $1] } - | 'deriving' '(' ')' {% aljs (sLL $1 $> (Just (sLL $1 $> []))) - [mj AnnDeriving $1,mop $2,mcp $3] } - - | 'deriving' '(' inst_types1 ')' {% aljs (sLL $1 $> (Just (sLL $1 $> $3))) - [mj AnnDeriving $1,mop $2,mcp $4] } + | 'deriving' qtycon {% let { L tv_loc tv = $2 + ; full_loc = comb2 $1 $> } + in ams (L full_loc $ Just $ L full_loc $ + [mkLHsSigType (L tv_loc (HsTyVar $2))]) + [mj AnnDeriving $1] } + + | 'deriving' '(' ')' {% let { full_loc = comb2 $1 $> } + in ams (L full_loc $ Just $ L full_loc []) + [mj AnnDeriving $1,mop $2,mcp $3] } + + | 'deriving' '(' deriv_types ')' {% let { full_loc = comb2 $1 $> } + in ams (L full_loc $ Just $ L full_loc $3) + [mj AnnDeriving $1,mop $2,mcp $4] } -- Glasgow extension: allow partial -- applications in derivings @@ -2077,12 +2083,14 @@ sigdecl :: { LHsDecl RdrName } : -- See Note [Declaration/signature overlap] for why we need infixexp here infixexp '::' sigtypedoc - {% do s <- checkValSig $1 $3 + {% do v <- checkValSigLhs $1 ; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2] - ; return (sLL $1 $> $ SigD s) } + ; return (sLL $1 $> $ SigD $ + TypeSig [v] (mkLHsSigWcType $3)) } | var ',' sig_vars '::' sigtypedoc - {% do { let sig = TypeSig ($1 : reverse (unLoc $3)) $5 PlaceHolder + {% do { let sig = TypeSig ($1 : reverse (unLoc $3)) + (mkLHsSigWcType $5) ; addAnnotation (gl $1) AnnComma (gl $2) ; ams ( sLL $1 $> $ SigD sig ) [mu AnnDcolon $4] } } @@ -2149,7 +2157,7 @@ quasiquote :: { Located (HsSplice RdrName) } in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } exp :: { LHsExpr RdrName } - : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig $1 $3 PlaceHolder) + : infixexp '::' sigtype {% ams (sLL $1 $> $ ExprWithTySig $1 (mkLHsSigWcType $3)) [mu AnnDcolon $2] } | infixexp '-<' exp {% ams (sLL $1 $> $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True) @@ -2176,8 +2184,12 @@ infixexp :: { LHsExpr RdrName } exp10 :: { LHsExpr RdrName } : '\\' apat apats opt_asig '->' exp {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource - [sLL $1 $> $ Match NonFunBindMatch ($2:$3) (snd $4) (unguardedGRHSs $6)])) + [sLL $1 $> $ Match { m_fixity = NonFunBindMatch + , m_pats = $2:$3 + , m_type = snd $4 + , m_grhss = unguardedGRHSs $6 }])) (mj AnnLam $1:mu AnnRarrow $5:(fst $4)) } + | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4) (mj AnnLet $1:mj AnnIn $3 :(fst $ unLoc $2)) } @@ -2577,9 +2589,11 @@ alts1 :: { Located ([AddAnn],[LMatch RdrName (LHsExpr RdrName)]) } | alt { sL1 $1 ([],[$1]) } alt :: { LMatch RdrName (LHsExpr RdrName) } - : pat opt_sig alt_rhs {%ams (sLL $1 $> (Match NonFunBindMatch [$1] (snd $2) - (snd $ unLoc $3))) - ((fst $2) ++ (fst $ unLoc $3))} + : pat opt_asig alt_rhs {%ams (sLL $1 $> (Match { m_fixity = NonFunBindMatch + , m_pats = [$1] + , m_type = snd $2 + , m_grhss = snd $ unLoc $3 })) + (fst $2 ++ (fst $ unLoc $3))} alt_rhs :: { Located ([AddAnn],GRHSs RdrName (LHsExpr RdrName)) } : ralt wherebinds { sLL $1 $> (fst $ unLoc $2, @@ -3367,10 +3381,13 @@ in ApiAnnotation.hs -} +addAnnsAt :: SrcSpan -> [AddAnn] -> P () +addAnnsAt loc anns = mapM_ (\a -> a loc) anns + -- |Construct an AddAnn from the annotation keyword and the location --- of the keyword +-- of the keyword itself mj :: AnnKeywordId -> Located e -> AddAnn -mj a l = (\s -> addAnnotation s a (gl l)) +mj a l s = addAnnotation s a (gl l) -- |Construct an AddAnn from the annotation keyword and the Located Token. If -- the token has a unicode equivalent and this has been used, provide the @@ -3399,35 +3416,41 @@ am a (b,s) = do -- |Add a list of AddAnns to the given AST element ams :: Located a -> [AddAnn] -> P (Located a) -ams a@(L l _) bs = mapM_ (\a -> a l) bs >> return a +ams a@(L l _) bs = addAnnsAt l bs >> return a +-- |Add all [AddAnn] to an AST element wrapped in a Just +aljs :: Located (Maybe a) -> [AddAnn] -> P (Located (Maybe a)) +aljs a@(L l _) bs = addAnnsAt l bs >> return a + +-- |Add all [AddAnn] to an AST element wrapped in a Just +ajs a@(Just (L l _)) bs = addAnnsAt l bs >> return a -- |Add a list of AddAnns to the given AST element, where the AST element is the -- result of a monadic action amms :: P (Located a) -> [AddAnn] -> P (Located a) -amms a bs = do - av@(L l _) <- a - (mapM_ (\a -> a l) bs) >> return av +amms a bs = do { av@(L l _) <- a + ; addAnnsAt l bs + ; return av } -- |Add a list of AddAnns to the AST element, and return the element as a -- OrdList amsu :: Located a -> [AddAnn] -> P (OrdList (Located a)) -amsu a@(L l _) bs = (mapM_ (\a -> a l) bs) >> return (unitOL a) +amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a) -- |Synonyms for AddAnn versions of AnnOpen and AnnClose -mo,mc :: Located Token -> SrcSpan -> P () +mo,mc :: Located Token -> AddAnn mo ll = mj AnnOpen ll mc ll = mj AnnClose ll -moc,mcc :: Located Token -> SrcSpan -> P () +moc,mcc :: Located Token -> AddAnn moc ll = mj AnnOpenC ll mcc ll = mj AnnCloseC ll -mop,mcp :: Located Token -> SrcSpan -> P () +mop,mcp :: Located Token -> AddAnn mop ll = mj AnnOpenP ll mcp ll = mj AnnCloseP ll -mos,mcs :: Located Token -> SrcSpan -> P () +mos,mcs :: Located Token -> AddAnn mos ll = mj AnnOpenS ll mcs ll = mj AnnCloseS ll @@ -3436,19 +3459,6 @@ mcs ll = mj AnnCloseS ll mcommas :: [SrcSpan] -> [AddAnn] mcommas ss = map (\s -> mj AnnCommaTuple (L s ())) ss --- |Add the annotation to an AST element wrapped in a Just -ajl :: Located (Maybe (Located a)) -> AnnKeywordId -> SrcSpan - -> P (Located (Maybe (Located a))) -ajl a@(L _ (Just (L l _))) b s = addAnnotation l b s >> return a - --- |Add all [AddAnn] to an AST element wrapped in a Just -aljs :: Located (Maybe (Located a)) -> [AddAnn] - -> P (Located (Maybe (Located a))) -aljs a@(L _ (Just (L l _))) bs = (mapM_ (\a -> a l) bs) >> return a - --- |Add all [AddAnn] to an AST element wrapped in a Just -ajs a@(Just (L l _)) bs = (mapM_ (\a -> a l) bs) >> return a - -- |Get the location of the last element of a OrdList, or noSrcSpan oll :: OrdList (Located a) -> SrcSpan oll l = diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 7d14f6568d..4b744fe69a 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -16,7 +16,7 @@ module RdrHsSyn ( mkTyData, mkDataFamInst, mkTySynonym, mkTyFamInstEqn, mkTyFamInst, - mkFamDecl, + mkFamDecl, mkLHsSigType, splitCon, mkInlinePragma, mkPatSynMatchGroup, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp @@ -48,7 +48,7 @@ module RdrHsSyn ( checkMonadComp, -- P (HsStmtContext RdrName) checkCommand, -- LHsExpr RdrName -> P (LHsCmd RdrName) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl - checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl + checkValSigLhs, checkDoAndIfThenElse, checkRecordSyntax, parseErrorSDoc, @@ -140,11 +140,12 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan ; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams ; at_defs <- mapM (eitherToP . mkATDefault) at_insts - ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars, - tcdFDs = snd (unLoc fds), tcdSigs = sigs, - tcdMeths = binds, - tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs, - tcdFVs = placeHolderNames })) } + ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars + , tcdFDs = snd (unLoc fds) + , tcdSigs = mkClassOpSigs sigs + , tcdMeths = binds + , tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs + , tcdFVs = placeHolderNames })) } mkATDefault :: LTyFamInstDecl RdrName -> Either (SrcSpan, SDoc) (LTyFamDefltEqn RdrName) @@ -156,7 +157,7 @@ mkATDefault :: LTyFamInstDecl RdrName -- from Convert.hs mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e })) | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs } <- e - = do { tvs <- checkTyVars (ptext (sLit "default")) equalsDots tc (hswb_cts pats) + = do { tvs <- checkTyVars (ptext (sLit "default")) equalsDots tc (hsib_body pats) ; return (L loc (TyFamEqn { tfe_tycon = tc , tfe_pats = tvs , tfe_rhs = rhs })) } @@ -167,7 +168,7 @@ mkTyData :: SrcSpan -> Located (Maybe (LHsContext RdrName), LHsType RdrName) -> Maybe (LHsKind RdrName) -> [LConDecl RdrName] - -> Maybe (Located [LHsType RdrName]) + -> HsDeriving RdrName -> P (LTyClDecl RdrName) mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams,ann) <- checkTyClHdr False tycl_hdr @@ -183,7 +184,7 @@ mkDataDefn :: NewOrData -> Maybe (LHsContext RdrName) -> Maybe (LHsKind RdrName) -> [LConDecl RdrName] - -> Maybe (Located [LHsType RdrName]) + -> HsDeriving RdrName -> P (HsDataDefn RdrName) mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv = do { checkDatatypeContext mcxt @@ -212,7 +213,7 @@ mkTyFamInstEqn :: LHsType RdrName mkTyFamInstEqn lhs rhs = do { (tc, tparams, ann) <- checkTyClHdr False lhs ; return (TyFamEqn { tfe_tycon = tc - , tfe_pats = mkHsWithBndrs tparams + , tfe_pats = mkHsImplicitBndrs tparams , tfe_rhs = rhs }, ann) } @@ -222,7 +223,7 @@ mkDataFamInst :: SrcSpan -> Located (Maybe (LHsContext RdrName), LHsType RdrName) -> Maybe (LHsKind RdrName) -> [LConDecl RdrName] - -> Maybe (Located [LHsType RdrName]) + -> HsDeriving RdrName -> P (LInstDecl RdrName) mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams,ann) <- checkTyClHdr False tycl_hdr @@ -230,7 +231,7 @@ mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_ ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ; return (L loc (DataFamInstD ( DataFamInstDecl { dfid_tycon = tc - , dfid_pats = mkHsWithBndrs tparams + , dfid_pats = mkHsImplicitBndrs tparams , dfid_defn = defn, dfid_fvs = placeHolderNames }))) } mkTyFamInst :: SrcSpan @@ -486,52 +487,58 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) = text "pattern synonym 'where' clause must bind the pattern synonym's name" <+> quotes (ppr patsyn_name) $$ ppr decl -mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName] +mkSimpleConDecl :: Located RdrName -> Maybe [LHsTyVarBndr RdrName] -> LHsContext RdrName -> HsConDeclDetails RdrName -> ConDecl RdrName -mkSimpleConDecl name qvars cxt details +mkSimpleConDecl name mb_forall cxt details = ConDecl { con_names = [name] - , con_explicit = Explicit - , con_qvars = mkHsQTvs qvars + , con_explicit = explicit + , con_qvars = qvars , con_cxt = cxt , con_details = details , con_res = ResTyH98 , con_doc = Nothing } + where + (explicit, qvars) = case mb_forall of + Nothing -> (False, mkHsQTvs []) + Just tvs -> (True, mkHsQTvs tvs) mkGadtDecl :: [Located RdrName] -> LHsType RdrName -- Always a HsForAllTy -> ([AddAnn], ConDecl RdrName) -mkGadtDecl names (L l ty) = - let (anns, ty') = flattenHsForAllTyKeepAnns ty - gadt = mkGadtDecl' names (L l ty') - in (anns, gadt) +mkGadtDecl names ty = ([], mkGadtDecl' names ty) mkGadtDecl' :: [Located RdrName] - -> LHsType RdrName -- Always a HsForAllTy - -> (ConDecl RdrName) + -> LHsType RdrName + -> ConDecl RdrName -- We allow C,D :: ty -- and expand it as if it had been -- C :: ty; D :: ty -- (Just like type signatures in general.) -mkGadtDecl' names (L ls (HsForAllTy imp _ qvars cxt tau)) + +mkGadtDecl' names lbody_ty@(L loc body_ty) = mk_gadt_con names where + (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty (details, res_ty) -- See Note [Sorting out the result type] = case tau of L _ (HsFunTy (L l (HsRecTy flds)) res_ty) - -> (RecCon (L l flds), res_ty) - _other -> (PrefixCon [], tau) + -> (RecCon (L l flds), res_ty) + _other -> (PrefixCon [], tau) + + explicit = case body_ty of + HsForAllTy {} -> True + _ -> False mk_gadt_con names = ConDecl { con_names = names - , con_explicit = imp - , con_qvars = qvars + , con_explicit = explicit + , con_qvars = mkHsQTvs tvs , con_cxt = cxt , con_details = details - , con_res = ResTyGADT ls res_ty + , con_res = ResTyGADT loc res_ty , con_doc = Nothing } -mkGadtDecl' _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty) tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName) tyConToDataCon loc tc @@ -647,7 +654,7 @@ really doesn't matter! -- * For PrefixCon we keep all the args in the ResTyGADT -- * For RecCon we do not -checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName) +checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsQTyVars RdrName) -- Same as checkTyVars, but in the P monad checkTyVarsP pp_what equals_or_where tc tparms = eitherToP $ checkTyVars pp_what equals_or_where tc tparms @@ -657,7 +664,7 @@ eitherToP :: Either (SrcSpan, SDoc) a -> P a eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc eitherToP (Right thing) = return thing checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] - -> Either (SrcSpan, SDoc) (LHsTyVarBndrs RdrName) + -> Either (SrcSpan, SDoc) (LHsQTyVars RdrName) -- Check whether the given list of type parameters are all type variables -- (possibly with a kind signature) -- We use the Either monad because it's also called (via mkATDefault) from @@ -815,15 +822,8 @@ checkAPat msg loc e0 = do -- view pattern is well-formed if the pattern is EViewPat expr patE -> checkLPat msg patE >>= (return . (\p -> ViewPat expr p placeHolderType)) - ExprWithTySig e t _ -> do e <- checkLPat msg e - -- Pattern signatures are parsed as sigtypes, - -- but they aren't explicit forall points. Hence - -- we have to remove the implicit forall here. - let t' = case t of - L _ (HsForAllTy Implicit _ _ - (L _ []) ty) -> ty - other -> other - return (SigPatIn e (mkHsWithBndrs t')) + ExprWithTySig e t -> do e <- checkLPat msg e + return (SigPatIn e t) -- n+k patterns OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _ @@ -890,14 +890,14 @@ checkValDef :: SDoc checkValDef msg lhs (Just sig) grhss -- x :: ty = rhs parses as a *pattern* binding = checkPatBind msg (L (combineLocs lhs sig) - (ExprWithTySig lhs sig PlaceHolder)) grhss + (ExprWithTySig lhs (mkLHsSigWcType sig))) grhss checkValDef msg lhs opt_sig g@(L l (_,grhss)) = do { mb_fun <- isFunLhs lhs ; case mb_fun of Just (fun, is_infix, pats, ann) -> checkFunBind msg ann (getLoc lhs) - fun is_infix pats opt_sig (L l grhss) + fun is_infix pats opt_sig (L l grhss) Nothing -> checkPatBind msg lhs g } checkFunBind :: SDoc @@ -914,9 +914,11 @@ checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) let match_span = combineSrcSpans lhs_loc rhs_span -- Add back the annotations stripped from any HsPar values in the lhs -- mapM_ (\a -> a match_span) ann - return (ann,makeFunBind fun - [L match_span (Match (FunBindMatch fun is_infix) - ps opt_sig grhss)]) + return (ann, makeFunBind fun + [L match_span (Match { m_fixity = FunBindMatch fun is_infix + , m_pats = ps + , m_type = opt_sig + , m_grhss = grhss })]) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. @@ -939,26 +941,26 @@ checkPatBind msg lhs (L _ (_,grhss)) ; return ([],PatBind lhs grhss placeHolderType placeHolderNames ([],[])) } -checkValSig - :: LHsExpr RdrName - -> LHsType RdrName - -> P (Sig RdrName) -checkValSig (L l (HsVar (L _ v))) ty - | isUnqual v && not (isDataOcc (rdrNameOcc v)) - = return (TypeSig [L l v] ty PlaceHolder) -checkValSig lhs@(L l _) ty +checkValSigLhs :: LHsExpr RdrName -> P (Located RdrName) +checkValSigLhs (L _ (HsVar lrdr@(L _ v))) + | isUnqual v + , not (isDataOcc (rdrNameOcc v)) + = return lrdr + +checkValSigLhs lhs@(L l _) = parseErrorSDoc l ((text "Invalid type signature:" <+> - ppr lhs <+> text "::" <+> ppr ty) - $$ text hint) + ppr lhs <+> text ":: ...") + $$ text hint) where - hint | foreign_RDR `looks_like` lhs = - "Perhaps you meant to use ForeignFunctionInterface?" - | default_RDR `looks_like` lhs = - "Perhaps you meant to use DefaultSignatures?" - | pattern_RDR `looks_like` lhs = - "Perhaps you meant to use PatternSynonyms?" - | otherwise = - "Should be of form <variable> :: <type>" + hint | foreign_RDR `looks_like` lhs + = "Perhaps you meant to use ForeignFunctionInterface?" + | default_RDR `looks_like` lhs + = "Perhaps you meant to use DefaultSignatures?" + | pattern_RDR `looks_like` lhs + = "Perhaps you meant to use PatternSynonyms?" + | otherwise + = "Should be of form <variable> :: <type>" + -- A common error is to forget the ForeignFunctionInterface flag -- so check for that, and suggest. cf Trac #3805 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword @@ -1242,24 +1244,30 @@ mkInlinePragma src (inl, match_info) mb_act -- mkImport :: Located CCallConv -> Located Safety - -> (Located StringLiteral, Located RdrName, LHsType RdrName) + -> (Located StringLiteral, Located RdrName, LHsSigType RdrName) -> P (HsDecl RdrName) mkImport (L lc cconv) (L ls safety) (L loc (StringLiteral esrc entity), v, ty) | cconv == PrimCallConv = do let funcTarget = CFunction (StaticTarget esrc entity Nothing True) importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget (L loc (unpackFS entity)) - return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) + return (ForD (ForeignImport { fd_name = v, fd_sig_ty = ty + , fd_co = noForeignImportCoercionYet + , fd_fi = importSpec })) | cconv == JavaScriptCallConv = do let funcTarget = CFunction (StaticTarget esrc entity Nothing True) importSpec = CImport (L lc JavaScriptCallConv) (L ls safety) Nothing funcTarget (L loc (unpackFS entity)) - return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) + return (ForD (ForeignImport { fd_name = v, fd_sig_ty = ty + , fd_co = noForeignImportCoercionYet + , fd_fi = importSpec })) | otherwise = do case parseCImport (L lc cconv) (L ls safety) (mkExtName (unLoc v)) (unpackFS entity) (L loc (unpackFS entity)) of Nothing -> parseErrorSDoc loc (text "Malformed entity string") - Just importSpec -> return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) + Just importSpec -> return (ForD (ForeignImport { fd_name = v, fd_sig_ty = ty + , fd_co = noForeignImportCoercionYet + , fd_fi = importSpec })) -- the string "foo" is ambigous: either a header or a C identifier. The -- C identifier case comes first in the alternatives below, so we pick @@ -1321,12 +1329,14 @@ parseCImport cconv safety nm str sourceText = -- construct a foreign export declaration -- mkExport :: Located CCallConv - -> (Located StringLiteral, Located RdrName, LHsType RdrName) + -> (Located StringLiteral, Located RdrName, LHsSigType RdrName) -> P (HsDecl RdrName) -mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty) = do - return $ ForD (ForeignExport v ty noForeignExportCoercionYet - (CExport (L lc (CExportStatic esrc entity' cconv)) - (L le (unpackFS entity)))) +mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty) + = return $ ForD $ + ForeignExport { fd_name = v, fd_sig_ty = ty + , fd_co = noForeignExportCoercionYet + , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv)) + (L le (unpackFS entity)) } where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 27194a203c..11d7d191ff 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -154,8 +154,8 @@ itName uniq loc = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) loc -- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly -- during compiler debugging. -mkUnboundName :: RdrName -> Name -mkUnboundName rdr_name = mkInternalName unboundKey (rdrNameOcc rdr_name) noSrcSpan +mkUnboundName :: OccName -> Name +mkUnboundName occ = mkInternalName unboundKey occ noSrcSpan isUnboundName :: Name -> Bool isUnboundName name = name `hasKey` unboundKey diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 9ec71df7e1..c2a45b0fd8 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -19,7 +19,7 @@ module RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, -- Other bindings - rnMethodBinds, renameSigs, mkSigTvFn, + rnMethodBinds, renameSigs, rnMatchGroup, rnGRHSs, rnGRHS, makeMiniFixityEnv, MiniFixityEnv, HsSigCtxt(..) @@ -554,35 +554,23 @@ depAnalBinds binds_w_dus mkSigTvFn :: [LSig Name] -> (Name -> [Name]) -- Return a lookup function that maps an Id Name to the names --- of the type variables that should scope over its body.. +-- of the type variables that should scope over its body. mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` [] where - extractScopedTyVars :: LHsType Name -> [Name] - extractScopedTyVars (L _ (HsForAllTy Explicit _ ltvs _ _)) = hsLKiTyVarNames ltvs - extractScopedTyVars _ = [] - env :: NameEnv [Name] - env = mkNameEnv [ (name, nwcs ++ extractScopedTyVars ty) -- Kind variables and type variables - -- nwcs: see Note [Scoping of named wildcards] - | L _ (TypeSig names ty nwcs) <- sigs - , L _ name <- names] - -- Note the pattern-match on "Explicit"; we only bind - -- type variables from signatures with an explicit top-level for-all - - -{- Note [Scoping of named wildcards] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: _a -> _a - f x = let g :: _a -> _a - g = ... - in ... - -Currently, for better or worse, the "_a" variables are all the same. So -although there is no explicit forall, the "_a" scopes over the definition. -I don't know if this is a good idea, but there it is. --} + env = foldr add_scoped_sig emptyNameEnv sigs + + add_scoped_sig :: LSig Name -> NameEnv [Name] -> NameEnv [Name] + add_scoped_sig (L _ (ClassOpSig _ names sig_ty)) env + = add_scoped_tvs names (hsScopedTvs sig_ty) env + add_scoped_sig (L _ (TypeSig names sig_ty)) env + = add_scoped_tvs names (hsWcScopedTvs sig_ty) env + add_scoped_sig _ env = env + + add_scoped_tvs :: [Located Name] -> [Name] -> NameEnv [Name] -> NameEnv [Name] + add_scoped_tvs id_names tv_names env + = foldr (\(L _ id_n) env -> extendNameEnv env id_n tv_names) env id_names -- Process the fixity declarations, making a FastString -> (Located Fixity) map -- (We keep the location around for reporting duplicate fixity declarations.) @@ -886,29 +874,26 @@ renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars) renameSig _ (IdSig x) = return (IdSig x, emptyFVs) -- Actually this never occurs -renameSig ctxt sig@(TypeSig vs ty _) +renameSig ctxt sig@(TypeSig vs ty) = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs - ; let doc = ppr_sig_bndrs vs - wildCardsAllowed = case ctxt of - TopSigCtxt _ -> True - LocalBindCtxt _ -> True - _ -> False - ; (new_ty, fvs, wcs) - <- if wildCardsAllowed - then rnHsSigTypeWithWildCards doc ty - else do { (new_ty, fvs) <- rnHsSigType doc ty - ; return (new_ty, fvs, []) } - ; return (TypeSig new_vs new_ty wcs, fvs) } - -renameSig ctxt sig@(GenericSig vs ty) + ; let doc = TypeSigCtx (ppr_sig_bndrs vs) + ; (new_ty, fvs) <- rnHsSigWcType doc ty + ; return (TypeSig new_vs new_ty, fvs) } + +renameSig ctxt sig@(ClassOpSig is_deflt vs ty) = do { defaultSigs_on <- xoptM Opt_DefaultSignatures - ; unless defaultSigs_on (addErr (defaultSigErr sig)) + ; when (is_deflt && not defaultSigs_on) $ + addErr (defaultSigErr sig) ; new_v <- mapM (lookupSigOccRn ctxt sig) vs - ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty - ; return (GenericSig new_v new_ty, fvs) } + ; (new_ty, fvs) <- rnHsSigType ty_ctxt ty + ; return (ClassOpSig is_deflt new_v new_ty, fvs) } + where + (v1:_) = vs + ty_ctxt = GenericCtx (ptext (sLit "a class method signature for") + <+> quotes (ppr v1)) renameSig _ (SpecInstSig src ty) - = do { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty + = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx ty ; return (SpecInstSig src new_ty,fvs) } -- {-# SPECIALISE #-} pragmas can refer to imported Ids @@ -919,12 +904,13 @@ renameSig ctxt sig@(SpecSig v tys inl) = do { new_v <- case ctxt of TopSigCtxt {} -> lookupLocatedOccRn v _ -> lookupSigOccRn ctxt sig v - -- ; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys ; return (SpecSig new_v new_ty inl, fvs) } where + ty_ctxt = GenericCtx (ptext (sLit "a SPECIALISE signature for") + <+> quotes (ppr v)) do_one (tys,fvs) ty - = do { (new_ty, fvs_ty) <- rnHsSigType (quotes (ppr v)) ty + = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt ty ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } renameSig ctxt sig@(InlineSig v s) @@ -939,29 +925,13 @@ renameSig ctxt sig@(MinimalSig s (L l bf)) = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf return (MinimalSig s (L l new_bf), emptyFVs) -renameSig ctxt sig@(PatSynSig v (flag, qtvs) req prov ty) +renameSig ctxt sig@(PatSynSig v ty) = do { v' <- lookupSigOccRn ctxt sig v - ; let doc = TypeSigCtx $ quotes (ppr v) - ; loc <- getSrcSpanM - - ; let (tv_kvs, mentioned) = extractHsTysRdrTyVars (ty:unLoc prov ++ unLoc req) - ; tv_bndrs <- case flag of - Implicit -> - return $ mkHsQTvs . userHsTyVarBndrs loc $ mentioned - Explicit -> - do { let heading = ptext (sLit "In the pattern synonym type signature") - <+> quotes (ppr sig) - ; warnUnusedForAlls (heading $$ docOfHsDocContext doc) qtvs mentioned - ; return qtvs } - Qualified -> panic "renameSig: Qualified" - - ; bindHsTyVars doc Nothing tv_kvs tv_bndrs $ \ tyvars -> do - { (req', fvs2) <- rnContext doc req - ; (prov', fvs1) <- rnContext doc prov - ; (ty', fvs3) <- rnLHsType doc ty - - ; let fvs = plusFVs [fvs1, fvs2, fvs3] - ; return (PatSynSig v' (flag, tyvars) req' prov' ty', fvs) }} + ; (ty', fvs) <- rnHsSigType ty_ctxt ty + ; return (PatSynSig v' ty', fvs) } + where + ty_ctxt = GenericCtx (ptext (sLit "a pattern synonym signature for") + <+> quotes (ppr v)) ppr_sig_bndrs :: [Located RdrName] -> SDoc ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) @@ -969,10 +939,13 @@ ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) okHsSig :: HsSigCtxt -> LSig a -> Bool okHsSig ctxt (L _ sig) = case (sig, ctxt) of - (GenericSig {}, ClsDeclCtxt {}) -> True - (GenericSig {}, _) -> False + (ClassOpSig {}, ClsDeclCtxt {}) -> True + (ClassOpSig {}, InstDeclCtxt {}) -> True + (ClassOpSig {}, _) -> False - (TypeSig {}, _) -> True + (TypeSig {}, ClsDeclCtxt {}) -> False + (TypeSig {}, InstDeclCtxt {}) -> False + (TypeSig {}, _) -> True (PatSynSig {}, TopSigCtxt{}) -> True (PatSynSig {}, _) -> False @@ -1012,16 +985,16 @@ findDupSigs sigs = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs) where expand_sig sig@(FixSig (FixitySig ns _)) = zip ns (repeat sig) - expand_sig sig@(InlineSig n _) = [(n,sig)] - expand_sig sig@(TypeSig ns _ _) = [(n,sig) | n <- ns] - expand_sig sig@(GenericSig ns _) = [(n,sig) | n <- ns] + expand_sig sig@(InlineSig n _) = [(n,sig)] + expand_sig sig@(TypeSig ns _) = [(n,sig) | n <- ns] + expand_sig sig@(ClassOpSig _ ns _) = [(n,sig) | n <- ns] expand_sig _ = [] - matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2 - mtch (FixSig {}) (FixSig {}) = True - mtch (InlineSig {}) (InlineSig {}) = True - mtch (TypeSig {}) (TypeSig {}) = True - mtch (GenericSig {}) (GenericSig {}) = True + matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2 + mtch (FixSig {}) (FixSig {}) = True + mtch (InlineSig {}) (InlineSig {}) = True + mtch (TypeSig {}) (TypeSig {}) = True + mtch (ClassOpSig d1 _ _) (ClassOpSig d2 _ _) = d1 == d2 mtch _ _ = False -- Warn about multiple MINIMAL signatures diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 0ce8e41039..57b427b0de 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -22,11 +22,11 @@ module RnEnv ( lookupSigCtxtOccRn, lookupFixityRn, lookupTyFixityRn, - lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName, - lookupSubBndrGREs, lookupConstructorFields, + lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName, + lookupConstructorFields, lookupSyntaxName, lookupSyntaxNames, lookupIfThenElse, lookupGreAvailRn, - getLookupOccRn, + getLookupOccRn,mkUnboundName, mkUnboundNameRdr, isUnboundName, addUsedGRE, addUsedGREs, addUsedDataCons, newLocalBndrRn, newLocalBndrsRn, @@ -43,7 +43,8 @@ module RnEnv ( warnUnusedTopBinds, warnUnusedLocalBinds, mkFieldEnv, dataTcOccs, kindSigErr, perhapsForallMsg, unknownSubordinateErr, - HsDocContext(..), docOfHsDocContext + HsDocContext(..), pprHsDocContext, + inHsDocContext, withHsDocContext ) where #include "HsVersions.h" @@ -224,7 +225,7 @@ newTopSrcBinder (L loc rdr_name) -- ToDo: more helpful error messages ; addErr (unknownNameErr (pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))) rdr_name) - ; return (mkUnboundName rdr_name) + ; return (mkUnboundNameRdr rdr_name) } } Nothing -> @@ -412,11 +413,15 @@ lookupInstDeclBndr cls what rdr -- In an instance decl you aren't allowed -- to use a qualified name for the method -- (Although it'd make perfect sense.) - ; lookupSubBndrOcc False -- False => we don't give deprecated + ; mb_name <- lookupSubBndrOcc + False -- False => we don't give deprecated -- warnings when a deprecated class -- method is defined. We only warn -- when it's used - (Just cls) doc rdr } + cls doc rdr + ; case mb_name of + Left err -> do { addErr err; return (mkUnboundNameRdr rdr) } + Right nm -> return nm } where doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls) @@ -445,9 +450,11 @@ lookupConstructorFields con_name = do { this_mod <- getModule ; if nameIsLocalOrFrom this_mod con_name then do { field_env <- getRecFieldEnv + ; traceTc "lookupCF" (ppr con_name $$ ppr (lookupNameEnv field_env con_name) $$ ppr field_env) ; return (lookupNameEnv field_env con_name `orElse` []) } else do { con <- tcLookupDataCon con_name + ; traceTc "lookupCF 2" (ppr con) ; return (dataConFieldLabels con) } } ----------------------------------------------- @@ -462,58 +469,77 @@ lookupConstructorFields con_name -- Arguably this should work, because the reference to 'fld' is -- unambiguous because there is only one field id 'fld' in scope. -- But currently it's rejected. + +lookupRecFieldOcc :: Maybe Name -- Nothing => just look it up as usual + -- Just tycon => use tycon to disambiguate + -> SDoc -> RdrName + -> RnM Name +lookupRecFieldOcc parent doc rdr_name + | Just tc_name <- parent + = do { mb_name <- lookupSubBndrOcc True tc_name doc rdr_name + ; case mb_name of + Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) } + Right n -> return n } + + | otherwise + = lookupGlobalOccRn rdr_name + lookupSubBndrOcc :: Bool - -> Maybe Name -- Nothing => just look it up as usual - -- Just p => use parent p to disambiguate - -> SDoc -> RdrName - -> RnM Name -lookupSubBndrOcc warnIfDeprec parent doc rdr_name + -> Name -- Parent + -> SDoc + -> RdrName + -> RnM (Either MsgDoc Name) +-- Find all the things the rdr-name maps to +-- and pick the one with the right parent namep +lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name | Just n <- isExact_maybe rdr_name -- This happens in derived code - = lookupExactOcc n + = do { n <- lookupExactOcc n + ; return (Right n) } | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = lookupOrig rdr_mod rdr_occ + = do { n <- lookupOrig rdr_mod rdr_occ + ; return (Right n) } + + | isUnboundName the_parent + -- Avoid an error cascade from malformed decls: + -- instance Int where { foo = e } + -- We have already generated an error in rnLHsInstDecl + = return (Right (mkUnboundNameRdr rdr_name)) - | otherwise -- Find all the things the rdr-name maps to - = do { -- and pick the one with the right parent namep - env <- getGlobalRdrEnv - ; case lookupSubBndrGREs env parent rdr_name of + | otherwise + = do { env <- getGlobalRdrEnv + ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) -- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName! -- The latter does pickGREs, but we want to allow 'x' -- even if only 'M.x' is in scope - [gre] -> do { addUsedGRE warnIfDeprec gre - -- Add a usage; this is an *occurrence* site - -- Note [Usage for sub-bndrs] - ; return (gre_name gre) } - [] -> do { ns <- lookupQualifiedNameGHCi rdr_name - ; case ns of { - (n:_) -> return n ; - -- Unlikely to be more than one...? - [] -> do - { addErr (unknownSubordinateErr doc rdr_name) - ; return (mkUnboundName rdr_name) } } } - gres -> do { addNameClashErrRn rdr_name gres - ; return (gre_name (head gres)) } } - -lookupSubBndrGREs :: GlobalRdrEnv -> Maybe Name -> RdrName -> [GlobalRdrElt] --- If parent = Nothing, just do a normal lookup --- If parent = Just p then find all GREs that --- (a) have parent p --- (b) for Unqual, are in scope qualified or unqualified --- for Qual, are in scope with that qualification -lookupSubBndrGREs env parent rdr_name - = case parent of - Nothing -> pickGREs rdr_name gres - Just p - | isUnqual rdr_name -> filter (parent_is p) gres - | otherwise -> filter (parent_is p) (pickGREs rdr_name gres) - + ; traceRn (text "lookupSubBndrOcc" <+> vcat [ppr the_parent, ppr rdr_name, ppr gres, ppr (pick_gres rdr_name gres)]) + ; case pick_gres rdr_name gres of + (gre:_) -> do { addUsedGRE warn_if_deprec gre + -- Add a usage; this is an *occurrence* site + -- Note [Usage for sub-bndrs] + ; return (Right (gre_name gre)) } + -- If there is more than one local GRE for the + -- same OccName 'f', that will be reported separately + -- as a duplicate top-level binding for 'f' + [] -> do { ns <- lookupQualifiedNameGHCi rdr_name + ; case ns of + (n:_) -> return (Right n) -- Unlikely to be more than one...? + [] -> return (Left (unknownSubordinateErr doc rdr_name)) + } } where - gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) - - parent_is p (GRE { gre_par = ParentIs p' }) = p == p' - parent_is p (GRE { gre_par = FldParent { par_is = p'}}) = p == p' - parent_is _ _ = False + -- If Parent = NoParent, just do a normal lookup + -- If Parent = Parent p then find all GREs that + -- (a) have parent p + -- (b) for Unqual, are in scope qualified or unqualified + -- for Qual, are in scope with that qualification + pick_gres rdr_name gres + | isUnqual rdr_name = filter right_parent gres + | otherwise = filter right_parent (pickGREs rdr_name gres) + + right_parent (GRE { gre_par = p }) + | ParentIs parent <- p = parent == the_parent + | FldParent { par_is = parent } <- p = parent == the_parent + | otherwise = False {- Note [Family instance binders] @@ -655,6 +681,9 @@ getLookupOccRn = do local_env <- getLocalRdrEnv return (lookupLocalRdrOcc local_env . nameOccName) +mkUnboundNameRdr :: RdrName -> Name +mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr) + lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) lookupLocatedOccRn = wrapLocM lookupOccRn @@ -764,16 +793,33 @@ lookupOccRn_maybe rdr_name ; case lookupLocalRdrEnv local_env rdr_name of { Just name -> return (Just name) ; Nothing -> do - { mb_name <- lookupGlobalOccRn_maybe rdr_name - ; case mb_name of { - Just name -> return (Just name) ; - Nothing -> do - { ns <- lookupQualifiedNameGHCi rdr_name + ; lookupGlobalOccRn_maybe rdr_name } } + +lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) +-- Looks up a RdrName occurrence in the top-level +-- environment, including using lookupQualifiedNameGHCi +-- for the GHCi case +-- No filter function; does not report an error on failure +-- Uses addUsedRdrName to record use and deprecations +lookupGlobalOccRn_maybe rdr_name + | Just n <- isExact_maybe rdr_name -- This happens in derived code + = do { n' <- lookupExactOcc n; return (Just n') } + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { n <- lookupOrig rdr_mod rdr_occ + ; return (Just n) } + + | otherwise + = do { mb_gre <- lookupGreRn_maybe rdr_name + ; case mb_gre of { + Just gre -> return (Just (gre_name gre)) ; + Nothing -> + do { ns <- lookupQualifiedNameGHCi rdr_name -- This test is not expensive, -- and only happens for failed lookups ; case ns of (n:_) -> return (Just n) -- Unlikely to be more than one...? - [] -> return Nothing } } } } } + [] -> return Nothing } } } lookupGlobalOccRn :: RdrName -> RnM Name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global @@ -804,24 +850,6 @@ lookupInfoOccRn rdr_name ; qual_ns <- lookupQualifiedNameGHCi rdr_name ; return (ns ++ (qual_ns `minusList` ns)) } -lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) --- No filter function; does not report an error on failure - -lookupGlobalOccRn_maybe rdr_name - | Just n <- isExact_maybe rdr_name -- This happens in derived code - = do { n' <- lookupExactOcc n; return (Just n') } - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { n <- lookupOrig rdr_mod rdr_occ - ; return (Just n) } - - | otherwise - = do { mb_gre <- lookupGreRn_maybe rdr_name - ; case mb_gre of - Nothing -> return Nothing - Just gre -> return (Just (gre_name gre)) } - - -- | Like 'lookupOccRn_maybe', but with a more informative result if -- the 'RdrName' happens to be a record selector: -- @@ -863,7 +891,8 @@ lookupGlobalOccRn_overloaded overload_ok rdr_name [] -> return Nothing [gre] | isRecFldGRE gre -> do { addUsedGRE True gre - ; let fld_occ = FieldOcc rdr_name (gre_name gre) + ; let fld_occ :: FieldOcc Name + fld_occ = FieldOcc rdr_name (gre_name gre) ; return (Just (Right [fld_occ])) } | otherwise -> do { addUsedGRE True gre @@ -887,6 +916,7 @@ lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) -- Many bindings: report "ambiguous", return an arbitrary (Just gre) -- (This API is a bit strange; lookupGRERn2_maybe is simpler. -- But it works and I don't want to fiddle too much.) +-- Uses addUsedRdrName to record use and deprecations lookupGreRn_maybe rdr_name = do { env <- getGlobalRdrEnv ; case lookupGRE_RdrName rdr_name env of @@ -902,6 +932,7 @@ lookupGreRn2_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) -- Exactly one binding: record it as "used", return (Just gre) -- No bindings: report "not in scope", return Nothing -- Many bindings: report "ambiguous", return Nothing +-- Uses addUsedRdrName to record use and deprecations lookupGreRn2_maybe rdr_name = do { env <- getGlobalRdrEnv ; case lookupGRE_RdrName rdr_name env of @@ -916,13 +947,14 @@ lookupGreRn2_maybe rdr_name lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo) -- Used in export lists -- If not found or ambiguous, add error message, and fake with UnboundName +-- Uses addUsedRdrName to record use and deprecations lookupGreAvailRn rdr_name = do { mb_gre <- lookupGreRn2_maybe rdr_name ; case mb_gre of { Just gre -> return (gre_name gre, availFromGRE gre) ; Nothing -> do { traceRn (text "lookupGreRn" <+> ppr rdr_name) - ; let name = mkUnboundName rdr_name + ; let name = mkUnboundNameRdr rdr_name ; return (name, avail name) } } } {- @@ -1089,7 +1121,8 @@ lookupQualifiedNameGHCi rdr_name ; return [] } } | otherwise - = return [] + = do { traceRn (text "lookupQualifedNameGHCi: off" <+> ppr rdr_name) + ; return [] } doc = ptext (sLit "Need to find") <+> ppr rdr_name @@ -1163,7 +1196,7 @@ lookupSigCtxtOccRn ctxt what = wrapLocM $ \ rdr_name -> do { mb_name <- lookupBindGroupOcc ctxt what rdr_name ; case mb_name of - Left err -> do { addErr err; return (mkUnboundName rdr_name) } + Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) } Right name -> return name } lookupBindGroupOcc :: HsSigCtxt @@ -1195,14 +1228,7 @@ lookupBindGroupOcc ctxt what rdr_name InstDeclCtxt ns -> lookup_top (`elemNameSet` ns) where lookup_cls_op cls - = do { env <- getGlobalRdrEnv - ; let gres = lookupSubBndrGREs env (Just cls) rdr_name - ; case gres of - [] -> return (Left (unknownSubordinateErr doc rdr_name)) - (gre:_) -> return (Right (gre_name gre)) } - -- If there is more than one local GRE for the - -- same OccName 'f', that will be reported separately - -- as a duplicate top-level binding for 'f' + = lookupSubBndrOcc True cls doc rdr_name where doc = ptext (sLit "method of class") <+> quotes (ppr cls) @@ -1640,7 +1666,7 @@ unboundNameX where_look rdr_name extra ; let suggestions = unknownNameSuggestions_ where_look dflags global_env local_env impInfo rdr_name ; addErr (err $$ suggestions) } - ; return (mkUnboundName rdr_name) } + ; return (mkUnboundNameRdr rdr_name) } unknownNameErr :: SDoc -> RdrName -> SDoc unknownNameErr what rdr_name @@ -2108,6 +2134,7 @@ data HsDocContext | TyDataCtx (Located RdrName) | TySynCtx (Located RdrName) | TyFamilyCtx (Located RdrName) + | FamPatCtx (Located RdrName) -- The patterns of a type/data family instance | ConDeclCtx [Located RdrName] | ClassDeclCtx (Located RdrName) | ExprWithTySigCtx @@ -2119,29 +2146,37 @@ data HsDocContext | VectDeclCtx (Located RdrName) | GenericCtx SDoc -- Maybe we want to use this more! -docOfHsDocContext :: HsDocContext -> SDoc -docOfHsDocContext (GenericCtx doc) = doc -docOfHsDocContext (TypeSigCtx doc) = text "In the type signature for" <+> doc -docOfHsDocContext PatCtx = text "In a pattern type-signature" -docOfHsDocContext SpecInstSigCtx = text "In a SPECIALISE instance pragma" -docOfHsDocContext DefaultDeclCtx = text "In a `default' declaration" -docOfHsDocContext (ForeignDeclCtx name) = ptext (sLit "In the foreign declaration for") <+> ppr name -docOfHsDocContext DerivDeclCtx = text "In a deriving declaration" -docOfHsDocContext (RuleCtx name) = text "In the transformation rule" <+> ftext name -docOfHsDocContext (TyDataCtx tycon) = text "In the data type declaration for" <+> quotes (ppr tycon) -docOfHsDocContext (TySynCtx name) = text "In the declaration for type synonym" <+> quotes (ppr name) -docOfHsDocContext (TyFamilyCtx name) = text "In the declaration for type family" <+> quotes (ppr name) - -docOfHsDocContext (ConDeclCtx [name]) - = text "In the definition of data constructor" <+> quotes (ppr name) -docOfHsDocContext (ConDeclCtx names) - = text "In the definition of data constructors" <+> interpp'SP names - -docOfHsDocContext (ClassDeclCtx name) = text "In the declaration for class" <+> ppr name -docOfHsDocContext ExprWithTySigCtx = text "In an expression type signature" -docOfHsDocContext TypBrCtx = ptext (sLit "In a Template-Haskell quoted type") -docOfHsDocContext HsTypeCtx = text "In a type argument" -docOfHsDocContext GHCiCtx = ptext (sLit "In GHCi input") -docOfHsDocContext (SpliceTypeCtx hs_ty) = ptext (sLit "In the spliced type") <+> ppr hs_ty -docOfHsDocContext ClassInstanceCtx = ptext (sLit "TcSplice.reifyInstances") -docOfHsDocContext (VectDeclCtx tycon) = ptext (sLit "In the VECTORISE pragma for type constructor") <+> quotes (ppr tycon) +withHsDocContext :: HsDocContext -> SDoc -> SDoc +withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt + +inHsDocContext :: HsDocContext -> SDoc +inHsDocContext ctxt = ptext (sLit "In") <+> pprHsDocContext ctxt + +pprHsDocContext :: HsDocContext -> SDoc +pprHsDocContext (GenericCtx doc) = doc +pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc +pprHsDocContext PatCtx = text "a pattern type-signature" +pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma" +pprHsDocContext DefaultDeclCtx = text "a `default' declaration" +pprHsDocContext DerivDeclCtx = text "a deriving declaration" +pprHsDocContext (RuleCtx name) = text "the transformation rule" <+> ftext name +pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon) +pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon) +pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name) +pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name) +pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name) +pprHsDocContext ExprWithTySigCtx = text "an expression type signature" +pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type" +pprHsDocContext HsTypeCtx = text "a type argument" +pprHsDocContext GHCiCtx = text "GHCi input" +pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty) +pprHsDocContext ClassInstanceCtx = text "TcSplice.reifyInstances" + +pprHsDocContext (ForeignDeclCtx name) + = ptext (sLit "the foreign declaration for") <+> quotes (ppr name) +pprHsDocContext (ConDeclCtx [name]) + = text "the definition of data constructor" <+> quotes (ppr name) +pprHsDocContext (ConDeclCtx names) + = text "the definition of data constructors" <+> interpp'SP names +pprHsDocContext (VectDeclCtx tycon) + = ptext (sLit "the VECTORISE pragma for type constructor") <+> quotes (ppr tycon) diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 31ef55cbb5..035b4db282 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -255,12 +255,19 @@ rnExpr (ExplicitTuple tup_args boxity) rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType) , emptyFVs) -rnExpr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds }) - = do { conname <- lookupLocatedOccRn con_id - ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds - ; return (RecordCon { rcon_con_name = conname, rcon_flds = rbinds' - , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }, - fvRbinds `addOneFV` unLoc conname ) } +rnExpr (RecordCon { rcon_con_name = con_id + , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) }) + = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id + ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds + ; (flds', fvss) <- mapAndUnzipM rn_field flds + ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd } + ; return (RecordCon { rcon_con_name = con_lname, rcon_flds = rec_binds' + , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder } + , fvs `plusFV` plusFVs fvss `addOneFV` con_name) } + where + mk_hs_var l n = HsVar (L l n) + rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) + ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) = do { (expr', fvExpr) <- rnLExpr expr @@ -270,11 +277,11 @@ rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) , rupd_out_tys = PlaceHolder, rupd_wrap = PlaceHolder } , fvExpr `plusFV` fvRbinds) } -rnExpr (ExprWithTySig expr pty PlaceHolder) - = do { (pty', fvTy, wcs) <- rnLHsTypeWithWildCards ExprWithTySigCtx pty - ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $ - rnLExpr expr - ; return (ExprWithTySig expr' pty' wcs, fvExpr `plusFV` fvTy) } +rnExpr (ExprWithTySig expr pty) + = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty + ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ + rnLExpr expr + ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) } rnExpr (HsIf _ p b1 b2) = do { (p', fvP) <- rnLExpr p @@ -417,26 +424,6 @@ rnSection other = pprPanic "rnSection" (ppr other) {- ************************************************************************ * * - Records -* * -************************************************************************ --} - -rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName - -> RnM (HsRecordBinds Name, FreeVars) -rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd }) - = do { (flds, fvs) <- rnHsRecFields ctxt mkHsVar rec_binds - ; (flds', fvss) <- mapAndUnzipM rn_field flds - ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }, - fvs `plusFV` plusFVs fvss) } - where - mkHsVar l n = HsVar (L l n) - rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) - ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } - -{- -************************************************************************ -* * Arrow commands * * ************************************************************************ diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index 32f0f9420f..b0b79f55e6 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -541,7 +541,7 @@ getLocalNonValBinders fixity_env = do { -- Process all type/class decls *except* family instances ; overload_ok <- xoptM Opt_DuplicateRecordFields ; (tc_avails, tc_fldss) <- fmap unzip $ mapM (new_tc overload_ok) - (tyClGroupConcat tycl_decls) + (tyClGroupConcat tycl_decls) ; traceRn (text "getLocalNonValBinders 1" <+> ppr tc_avails) ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env ; setEnvs envs $ do { @@ -573,6 +573,7 @@ getLocalNonValBinders fixity_env ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds envs = (tcg_env { tcg_field_env = field_env }, tcl_env) + ; traceRn (text "getLocalNonValBinders 3" <+> vcat [ppr flds, ppr field_env]) ; return (envs, new_bndrs) } } where ValBindsIn _val_binds val_sigs = binds @@ -583,7 +584,7 @@ getLocalNonValBinders fixity_env -- In a hs-boot file, the value binders come from the -- *signatures*, and there should be no foreign binders hs_boot_sig_bndrs = [ L decl_loc (unLoc n) - | L decl_loc (TypeSig ns _ _) <- val_sigs, n <- ns] + | L decl_loc (TypeSig ns _) <- val_sigs, n <- ns] -- the SrcSpan attached to the input should be the span of the -- declaration, not just the name @@ -636,8 +637,7 @@ getLocalNonValBinders fixity_env ; return ([avail], flds) } new_assoc overload_ok (L _ (ClsInstD (ClsInstDecl { cid_poly_ty = inst_ty , cid_datafam_insts = adts }))) - | Just (_, _, L loc cls_rdr, _) <- - splitLHsInstDeclTy_maybe (flattenTopLevelLHsForAllTy inst_ty) + | Just (L loc cls_rdr) <- getLHsInstDeclClass_maybe inst_ty = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr ; (avails, fldss) <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 9aee561a43..77f08f4049 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -206,10 +206,8 @@ matchNameMaker ctxt = LamMk report_unused ThPatQuote -> False _ -> True -rnHsSigCps :: HsWithBndrs RdrName (LHsType RdrName) - -> CpsRn (HsWithBndrs Name (LHsType Name)) -rnHsSigCps sig - = CpsRn (rnHsBndrSig PatCtx sig) +rnHsSigCps :: LHsSigWcType RdrName -> CpsRn (LHsSigWcType Name) +rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped PatCtx sig) newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name) newPatLName name_maker rdr_name@(L loc _) @@ -560,7 +558,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl = L loc (FieldOcc lbl _) , hsRecFieldArg = arg , hsRecPun = pun })) - = do { sel <- setSrcSpan loc $ lookupSubBndrOcc True parent doc lbl + = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent doc lbl ; arg' <- if pun then do { checkErr pun_ok (badPun (L loc lbl)) ; return (L loc (mk_arg loc lbl)) } @@ -683,7 +681,7 @@ rnHsRecUpdFields flds Nothing -> do { addErr (unknownSubordinateErr doc lbl) ; return (Right []) } Just r -> return r } - else fmap Left $ lookupSubBndrOcc True Nothing doc lbl + else fmap Left $ lookupGlobalOccRn lbl ; arg' <- if pun then do { checkErr pun_ok (badPun (L loc lbl)) ; return (L loc (HsVar (L loc lbl))) } diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 1b234bd088..2fbbea4179 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -31,8 +31,7 @@ import Module import HscTypes ( Warnings(..), plusWarns ) import Class ( FunDep ) import PrelNames ( applicativeClassName, pureAName, thenAName - , monadClassName, returnMName, thenMName - , isUnboundName ) + , monadClassName, returnMName, thenMName ) import Name import NameSet import NameEnv @@ -389,21 +388,26 @@ rnDefaultDecl (DefaultDecl tys) -} rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars) -rnHsForeignDecl (ForeignImport name ty _ spec) +rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) = do { topEnv :: HscEnv <- getTopEnv ; name' <- lookupLocatedTopBndrRn name - ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty + ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty -- Mark any PackageTarget style imports as coming from the current package ; let unitId = thisPackage $ hsc_dflags topEnv spec' = patchForeignImport unitId spec - ; return (ForeignImport name' ty' noForeignImportCoercionYet spec', fvs) } + ; return (ForeignImport { fd_name = name', fd_sig_ty = ty' + , fd_co = noForeignImportCoercionYet + , fd_fi = spec' }, fvs) } -rnHsForeignDecl (ForeignExport name ty _ spec) +rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) = do { name' <- lookupLocatedOccRn name - ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty - ; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') } + ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty + ; return (ForeignExport { fd_name = name', fd_sig_ty = ty' + , fd_co = noForeignExportCoercionYet + , fd_fe = spec } + , fvs `addOneFV` unLoc name') } -- NB: a foreign export is an *occurrence site* for name, so -- we add it to the free-variable list. It might, for example, -- be imported from another module @@ -464,7 +468,7 @@ rnSrcInstDecl (ClsInstD { cid_inst = cid }) -- * Warn if 'pure' is defined backwards (i.e. @pure = return@). -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@). -- -checkCanonicalMonadInstances :: Name -> LHsType Name -> LHsBinds Name -> RnM () +checkCanonicalMonadInstances :: Name -> LHsSigType Name -> LHsBinds Name -> RnM () checkCanonicalMonadInstances cls poly_ty mbinds | cls == applicativeClassName = do forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do @@ -524,11 +528,10 @@ checkCanonicalMonadInstances cls poly_ty mbinds ] -- stolen from TcInstDcls - instDeclCtxt1 :: LHsType Name -> SDoc + instDeclCtxt1 :: LHsSigType Name -> SDoc instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (case unLoc hs_inst_ty of - HsForAllTy _ _ _ _ (L _ ty') -> ppr ty' - _ -> ppr hs_inst_ty) + | (_, _, head_ty) <- splitLHsInstDeclTy hs_inst_ty + = inst_decl_ctxt (ppr head_ty) inst_decl_ctxt :: SDoc -> SDoc inst_decl_ctxt doc = hang (ptext (sLit "in the instance declaration for")) @@ -540,23 +543,19 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds , cid_sigs = uprags, cid_tyfam_insts = ats , cid_overlap_mode = oflag , cid_datafam_insts = adts }) - -- Used for both source and interface file decls - = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty - ; case splitLHsInstDeclTy_maybe inst_ty' of { - Nothing -> return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds - , cid_sigs = [], cid_tyfam_insts = [] - , cid_overlap_mode = oflag - , cid_datafam_insts = [] } - , inst_fvs) ; - Just (inst_tyvars, _, L _ cls,_) -> - - do { let ktv_names = hsLKiTyVarNames inst_tyvars - - -- Rename the bindings - -- The typechecker (not the renamer) checks that all - -- the bindings are for the right class - -- (Slightly strangely) when scoped type variables are on, the - -- forall-d tyvars scope over the method bindings too + = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "an instance declaration") inst_ty + ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' + ; let cls = case splitLHsClassTy_maybe head_ty' of + Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>")) + Just (L _ cls, _) -> cls + -- rnLHsInstType has added an error message + -- if splitLHsClassTy_maybe fails + + -- Rename the bindings + -- The typechecker (not the renamer) checks that all + -- the bindings are for the right class + -- (Slightly strangely) when scoped type variables are on, the + -- forall-d tyvars scope over the method bindings too ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags ; whenWOptM Opt_WarnNonCanonicalMonadInstances $ @@ -564,11 +563,11 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds -- Rename the associated types, and type signatures -- Both need to have the instance type variables in scope - ; traceRn (text "rnSrcInstDecl" <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names) + ; traceRn (text "rnSrcInstDecl" <+> ppr inst_ty' $$ ppr ktv_names) ; ((ats', adts'), more_fvs) <- extendTyVarEnvFVRn ktv_names $ - do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats - ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls inst_tyvars adts + do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats + ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) } ; let all_fvs = meth_fvs `plusFV` more_fvs @@ -577,7 +576,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds , cid_sigs = uprags', cid_tyfam_insts = ats' , cid_overlap_mode = oflag , cid_datafam_insts = adts' }, - all_fvs) } } } + all_fvs) } -- We return the renamed associated data type declarations so -- that they can be entered into the list of type declarations -- for the binding group, but we also keep a copy in the instance. @@ -592,12 +591,11 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds rnFamInstDecl :: HsDocContext -> Maybe (Name, [Name]) -> Located RdrName - -> [LHsType RdrName] + -> HsTyPats RdrName -> rhs -> (HsDocContext -> rhs -> RnM (rhs', FreeVars)) - -> RnM (Located Name, HsWithBndrs Name [LHsType Name], rhs', - FreeVars) -rnFamInstDecl doc mb_cls tycon pats payload rnPayload + -> RnM (Located Name, HsTyPats Name, rhs', FreeVars) +rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon ; let loc = case pats of [] -> pprPanic "rnFamInstDecl" (ppr tycon) @@ -605,7 +603,6 @@ rnFamInstDecl doc mb_cls tycon pats payload rnPayload (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps)) (kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats - ; rdr_env <- getLocalRdrEnv ; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names @@ -614,7 +611,7 @@ rnFamInstDecl doc mb_cls tycon pats payload rnPayload ; ((pats', payload'), fvs) <- bindLocalNamesFV kv_names $ bindLocalNamesFV tv_names $ - do { (pats', pat_fvs) <- rnLHsTypes doc pats + do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats ; (payload', rhs_fvs) <- rnPayload doc payload -- See Note [Renaming associated types] @@ -631,19 +628,12 @@ rnFamInstDecl doc mb_cls tycon pats payload rnPayload ; let all_fvs = fvs `addOneFV` unLoc tycon' - awcs = concatMap collectAnonymousWildCardNames pats' ; return (tycon', - HsWB { hswb_cts = pats', hswb_kvs = kv_names, - hswb_tvs = tv_names, hswb_wcs = awcs }, + HsIB { hsib_body = pats' + , hsib_kvs = kv_names, hsib_tvs = tv_names }, payload', all_fvs) } -- type instance => use, hence addOneFV - where - collectAnonymousWildCardNames ty - = [ wildCardName wc - | L _ wc <- snd (collectWildCards ty) - , isAnonWildCard wc ] - rnTyFamInstDecl :: Maybe (Name, [Name]) -> TyFamInstDecl RdrName @@ -657,7 +647,7 @@ rnTyFamInstEqn :: Maybe (Name, [Name]) -> TyFamInstEqn RdrName -> RnM (TyFamInstEqn Name, FreeVars) rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon - , tfe_pats = HsWB { hswb_cts = pats } + , tfe_pats = pats , tfe_rhs = rhs }) = do { (tycon', pats', rhs', fvs) <- rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn @@ -671,7 +661,7 @@ rnTyFamDefltEqn :: Name rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon , tfe_pats = tyvars , tfe_rhs = rhs }) - = bindHsTyVars ctx (Just cls) [] tyvars $ \ tyvars' -> + = bindHsQTyVars ctx (Just cls) [] tyvars $ \ tyvars' -> do { tycon' <- lookupFamInstName (Just cls) tycon ; (rhs', fvs) <- rnLHsType ctx rhs ; return (TyFamEqn { tfe_tycon = tycon' @@ -684,7 +674,7 @@ rnDataFamInstDecl :: Maybe (Name, [Name]) -> DataFamInstDecl RdrName -> RnM (DataFamInstDecl Name, FreeVars) rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon - , dfid_pats = HsWB { hswb_cts = pats } + , dfid_pats = pats , dfid_defn = defn }) = do { (tycon', pats', defn', fvs) <- rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn @@ -706,7 +696,7 @@ rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames decl RdrName -> -- an instance. rnTyFamInstDecl RnM (decl Name, FreeVars)) -- or rnDataFamInstDecl -> Name -- Class - -> LHsTyVarBndrs Name + -> [Name] -> [Located (decl RdrName)] -> RnM ([Located (decl Name)], FreeVars) -- Used for data and type family defaults in a class decl @@ -714,10 +704,8 @@ rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames -- -- NB: We allow duplicate associated-type decls; -- See Note [Associated type instances] in TcInstDcls -rnATInstDecls rnFun cls hs_tvs at_insts +rnATInstDecls rnFun cls tv_ns at_insts = rnList (rnFun (Just (cls, tv_ns))) at_insts - where - tv_ns = hsLKiTyVarNames hs_tvs -- See Note [Renaming associated types] {- @@ -813,7 +801,7 @@ bindHsRuleVars rule_name vars names thing_inside thing_inside (L l (RuleBndr (L loc n)) : vars') go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside - = rnHsBndrSig doc bsig $ \ bsig' -> + = rnHsSigWcTypeScoped doc bsig $ \ bsig' -> go vars ns $ \ vars' -> thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars') @@ -940,7 +928,7 @@ rnHsVectDecl (HsVectClassIn s cls) rnHsVectDecl (HsVectClassOut _) = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'" rnHsVectDecl (HsVectInstIn instTy) - = do { (instTy', fvs) <- rnLHsInstType (text "In a VECTORISE pragma") instTy + = do { (instTy', fvs) <- rnLHsInstType (text "a VECTORISE pragma") instTy ; return (HsVectInstIn instTy', fvs) } rnHsVectDecl (HsVectInstOut _) @@ -1082,7 +1070,7 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs }) ; let kvs = fst (extractHsTyRdrTyVars rhs) doc = TySynCtx tycon ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs) - ; ((tyvars', rhs'), fvs) <- bindHsTyVars doc Nothing kvs tyvars $ + ; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' -> do { (rhs', fvs) <- rnTySyn doc rhs ; return ((tyvars', rhs'), fvs) } @@ -1096,17 +1084,16 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn ; let kvs = extractDataDefnKindVars defn doc = TyDataCtx tycon ; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs) - ; ((tyvars', defn'), fvs) <- - bindHsTyVars doc Nothing kvs tyvars $ \ tyvars' -> + ; ((tyvars', defn'), fvs) <- bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' -> do { (defn', fvs) <- rnDataDefn doc defn ; return ((tyvars', defn'), fvs) } ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars' , tcdDataDefn = defn', tcdFVs = fvs }, fvs) } -rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls, - tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, - tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, - tcdDocs = docs}) +rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, + tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, + tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, + tcdDocs = docs}) = do { lcls' <- lookupLocatedTopBndrRn lcls ; let cls' = unLoc lcls' kvs = [] -- No scoped kind vars except those in @@ -1114,7 +1101,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls, -- Tyvars scope over superclass context and method signatures ; ((tyvars', context', fds', ats'), stuff_fvs) - <- bindHsTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do + <- bindHsQTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do -- Checks for distinct tyvars { (context', cxt_fvs) <- rnContext cls_doc context ; fds' <- rnFds fds @@ -1131,7 +1118,8 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls, -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). - ; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _ _) <- sigs, op <- ops] + ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs + , op <- ops] ; checkDupRdrNames sig_rdr_names_w_locs -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. @@ -1257,9 +1245,11 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False _ -> True - rn_derivs Nothing = return (Nothing, emptyFVs) - rn_derivs (Just (L ld ds)) = do { (ds', fvs) <- rnLHsTypes doc ds - ; return (Just (L ld ds'), fvs) } + rn_derivs Nothing + = return (Nothing, emptyFVs) + rn_derivs (Just (L loc ds)) + = do { (ds', fvs) <- mapFvRn (rnHsSigType doc) ds + ; return (Just (L loc ds'), fvs) } badGadtStupidTheta :: HsDocContext -> SDoc badGadtStupidTheta _ @@ -1276,7 +1266,7 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars , fdInjectivityAnn = injectivity }) = do { tycon' <- lookupLocatedTopBndrRn tycon ; ((tyvars', res_sig', injectivity'), fv1) <- - bindHsTyVars doc mb_cls kvs tyvars $ \ tyvars' -> + bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' -> do { (res_sig', fv_kind) <- wrapLocFstM (rnFamResultSig doc) res_sig ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig') injectivity @@ -1369,7 +1359,7 @@ rnFamResultSig doc (TyVarSig tvbndr) -- | Rename injectivity annotation. Note that injectivity annotation is just the -- part after the "|". Everything that appears before it is renamed in -- rnFamDecl. -rnInjectivityAnn :: LHsTyVarBndrs Name -- ^ Type variables declared in +rnInjectivityAnn :: LHsQTyVars Name -- ^ Type variables declared in -- type family head -> LFamilyResultSig Name -- ^ Result signature -> LInjectivityAnn RdrName -- ^ Injectivity annotation @@ -1382,8 +1372,8 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv)) bindLocalNames [hsLTyVarName resTv] $ -- The return type variable scopes over the injectivity annotation -- e.g. type family F a = (r::*) | r -> a - do { injFrom' <- rnLTyVar True injFrom - ; injTo' <- mapM (rnLTyVar True) injTo + do { injFrom' <- rnLTyVar injFrom + ; injTo' <- mapM rnLTyVar injTo ; return $ L srcSpan (InjectivityAnn injFrom' injTo') } ; let tvNames = Set.fromList $ hsLKiTyVarNames tvBndrs @@ -1423,8 +1413,8 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv)) rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) = setSrcSpan srcSpan $ do (injDecl', _) <- askNoErrs $ do - injFrom' <- rnLTyVar True injFrom - injTo' <- mapM (rnLTyVar True) injTo + injFrom' <- rnLTyVar injFrom + injTo' <- mapM rnLTyVar injTo return $ L srcSpan (InjectivityAnn injFrom' injTo') return $ injDecl' @@ -1516,6 +1506,29 @@ modules), we get better error messages, too. \subsection{Support code for type/data declarations} * * ********************************************************* + +Note [Quantification in data constructor declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Four cases, afer renaming + * ResTyH98 + - data T a = forall b. MkT { x :: b -> a } + The 'b' is explicitly declared; + con_qvars = [b] + + - data T a = MkT { x :: a -> b } + Do *not* implicitly quantify over 'b'; it is + simply out of scope. con_qvars = [] + + * ResTyGADT + - data T a where { MkT :: forall b. (b -> a) -> T a } + con_qvars = [a,b] + + - data T a where { MkT :: (b -> a) -> T a } + con_qvars = [a,b], by implicit quantification + of the type signature + It is uncomfortable that we add implicitly-bound + type variables to the HsQTyVars, which usually + only has explicitly-bound type variables -} --------------- @@ -1530,49 +1543,53 @@ rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars) rnConDecls = mapFvRn (wrapLocFstM rnConDecl) rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars) -rnConDecl decl@(ConDecl { con_names = names, con_qvars = tvs +rnConDecl decl@(ConDecl { con_names = names, con_qvars = qtvs , con_cxt = lcxt@(L loc cxt), con_details = details , con_res = res_ty, con_doc = mb_doc - , con_explicit = expl }) + , con_explicit = explicit }) = do { mapM_ (addLocM checkConName) names - ; new_names <- mapM lookupLocatedTopBndrRn names - - -- For H98 syntax, the tvs are the existential ones - -- For GADT syntax, the tvs are all the quantified tyvars - -- Hence the 'filter' in the ResTyH98 case only - ; rdr_env <- getLocalRdrEnv - ; let arg_tys = hsConDeclArgTys details - (free_kvs, free_tvs) = case res_ty of - ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys) - ResTyGADT _ ty -> get_rdr_tvs (ty : arg_tys) - - -- With an Explicit forall, check for unused binders - -- With Implicit, find the mentioned ones, and use them as binders - -- With Qualified, do the same as with Implicit, but give a warning - -- See Note [Context quantification] - ; new_tvs <- case expl of - Implicit -> return (mkHsQTvs (userHsTyVarBndrs loc free_tvs)) - Qualified -> do { warnContextQuantification (docOfHsDocContext doc) - (userHsTyVarBndrs loc free_tvs) - ; return (mkHsQTvs (userHsTyVarBndrs loc free_tvs)) } - Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs free_tvs - ; return tvs } - - ; mb_doc' <- rnMbLHsDoc mb_doc - - ; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do + ; new_names <- mapM lookupLocatedTopBndrRn names + ; mb_doc' <- rnMbLHsDoc mb_doc + ; let (kvs, qtvs') = get_con_qtvs qtvs (hsConDeclArgTys details) res_ty + + ; bindHsQTyVars doc Nothing kvs qtvs' $ \new_tyvars -> do { (new_context, fvs1) <- rnContext doc lcxt ; (new_details, fvs2) <- rnConDeclDetails (unLoc $ head new_names) doc details ; (new_details', new_res_ty, fvs3) <- rnConResult doc (map unLoc new_names) new_details res_ty + ; traceRn (text "rnConDecl" <+> ppr names <+> vcat + [ text "free_kvs:" <+> ppr kvs + , text "qtvs:" <+> ppr qtvs + , text "qtvs':" <+> ppr qtvs' ]) + ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 + ; warnUnusedForAlls (inHsDocContext doc) (hsQTvBndrs new_tyvars) all_fvs ; return (decl { con_names = new_names, con_qvars = new_tyvars , con_cxt = new_context, con_details = new_details' , con_res = new_res_ty, con_doc = mb_doc' }, - fvs1 `plusFV` fvs2 `plusFV` fvs3) }} + all_fvs) }} where doc = ConDeclCtx names get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys) + get_con_qtvs :: LHsQTyVars RdrName -> [LHsType RdrName] + -> ResType (LHsType RdrName) + -> ([RdrName], LHsQTyVars RdrName) + get_con_qtvs qtvs arg_tys ResTyH98 + | explicit -- data T = forall a. MkT (a -> a) + = (free_kvs, qtvs) + | otherwise -- data T = MkT (a -> a) + = ([], mkHsQTvs []) + where + (free_kvs, _) = get_rdr_tvs arg_tys + + get_con_qtvs qtvs arg_tys (ResTyGADT _ ty) + | explicit -- data T x where { MkT :: forall a. a -> T a } + = (free_kvs, qtvs) + | otherwise -- data T x where { MkT :: a -> T a } + = (free_kvs, mkHsQTvs (userHsTyVarBndrs loc free_tvs)) + where + (free_kvs, free_tvs) = get_rdr_tvs (ty : arg_tys) + rnConResult :: HsDocContext -> [Name] -> HsConDetails (LHsType Name) (Located [LConDeclField Name]) -> ResType (LHsType RdrName) @@ -1591,7 +1608,7 @@ rnConResult doc _con details (ResTyGADT ls ty) -- See Note [Sorting out the result type] in RdrHsSyn RecCon {} -> do { unless (null arg_tys) - (addErr (badRecResTy (docOfHsDocContext doc))) + (addErr (badRecResTy doc)) ; return (details, ResTyGADT ls res_ty, fvs) } PrefixCon {} -> return (PrefixCon arg_tys, ResTyGADT ls res_ty, fvs)} @@ -1618,8 +1635,9 @@ rnConDeclDetails con doc (RecCon (L l fields)) ; return (RecCon (L l new_fields), fvs) } ------------------------------------------------- -badRecResTy :: SDoc -> SDoc -badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc +badRecResTy :: HsDocContext -> SDoc +badRecResTy ctxt = withHsDocContext ctxt $ + ptext (sLit "Malformed constructor signature") -- | Brings pattern synonym names and also pattern synonym selectors -- from record pattern synonyms into scope. diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index 20933125ee..3c7695bd29 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -33,7 +33,6 @@ import Control.Monad ( unless, when ) import {-# SOURCE #-} RnExpr ( rnLExpr ) -import PrelNames ( isUnboundName ) import TcEnv ( checkWellStaged ) import THNames ( liftName ) @@ -45,7 +44,6 @@ import Hooks import Var ( Id ) import THNames ( quoteExpName, quotePatName, quoteDecName, quoteTypeName , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) -import RnTypes ( collectWildCards ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) import {-# SOURCE #-} TcSplice ( runMetaD, runMetaE, runMetaP, runMetaT, tcTopSpliceExpr ) @@ -421,20 +419,19 @@ rnSpliceType splice k = do { traceRn (text "rnSpliceType: untyped type splice") ; hs_ty2 <- runRnSplice UntypedTypeSplice runMetaT ppr rn_splice ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2 - ; checkValidPartialTypeSplice doc hs_ty2 - -- See Note [Partial Type Splices] ; checkNoErrs $ rnLHsType doc hs_ty2 } -- checkNoErrs: see Note [Renamer errors] ; return (HsParTy hs_ty3, fvs) } -- Wrap the result of the splice in parens so that we don't -- lose the outermost location set by runQuasiQuote (#7918) -{- -Note [Partial Type Splices] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Partial Type Splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Partial Type Signatures are partially supported in TH type splices: only anonymous wild cards are allowed. + -- ToDo: SLPJ says: I don't understand all this + Normally, named wild cards are collected before renaming a (partial) type signature. However, TH type splices are run during renaming, i.e. after the initial traversal, leading to out of scope errors for named wild cards. We @@ -454,7 +451,7 @@ are given names during renaming. These names are collected right after renaming. The names generated for anonymous wild cards in TH type splices will thus be collected as well. -For more details about renaming wild cards, see rnLHsTypeWithWildCards. +For more details about renaming wild cards, see RnTypes.rnHsSigWcType Note that partial type signatures are fully supported in TH declaration splices, e.g.: @@ -463,28 +460,10 @@ splices, e.g.: foo x y = x == y |] This is because in this case, the partial type signature can be treated as a -whole signature, instead of as an arbitray type. +whole signature, instead of as an arbitrary type. -} --- | Check that the type splice doesn't contain an extra-constraint wild card. --- See Note [Partial Type Splices]. Named wild cards aren't supported in type --- splices either, but they will be caught during renaming, as they won't be --- in scope. --- --- Note that without this check, an error would still be reported, but it --- would tell the user an unexpected wild card was encountered. This message --- is confusing, as it doesn't mention the wild card was unexpected because it --- was an extra-constraints wild card. To avoid confusing, this function --- provides a specific error message for this case. -checkValidPartialTypeSplice :: HsDocContext -> LHsType RdrName -> RnM () -checkValidPartialTypeSplice doc ty - | (L loc _extraWc : _, _) <- collectWildCards ty - = failAt loc $ hang (text "Invalid partial type:") 2 (ppr ty) $$ - text "An extra-constraints wild card is not allowed in a type splice" $$ - docOfHsDocContext doc - | otherwise - = return () ---------------------- -- | Rename a splice pattern. See Note [rnSplicePat] diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 27c9fc8e7d..49b707c370 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -11,20 +11,22 @@ module RnTypes ( -- Type related stuff rnHsType, rnLHsType, rnLHsTypes, rnContext, rnHsKind, rnLHsKind, rnLHsMaybeKind, - rnHsSigType, rnLHsInstType, rnConDeclFields, - newTyVarNameRn, rnLHsTypeWithWildCards, - rnHsSigTypeWithWildCards, rnLTyVar, collectWildCards, + rnHsSigType, rnHsWcType, + rnHsSigWcType, rnHsSigWcTypeScoped, + rnLHsInstType, + newTyVarNameRn, collectAnonWildCards, + rnConDeclFields, + rnLTyVar, rnLHsTyVarBndr, -- Precence related stuff mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, checkPrecMatch, checkSectionPrec, -- Binding related stuff - warnContextQuantification, warnUnusedForAlls, - bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig, rnLHsTyVarBndr, + warnUnusedForAlls, + bindSigTyVarsFV, bindHsQTyVars, extractHsTyRdrTyVars, extractHsTysRdrTyVars, - extractRdrKindSigVars, extractDataDefnKindVars, - filterInScope + extractRdrKindSigVars, extractDataDefnKindVars ) where import {-# SOURCE #-} RnSplice( rnSpliceType ) @@ -35,7 +37,7 @@ import RnHsDoc ( rnLHsDoc, rnMbLHsDoc ) import RnEnv import TcRnMonad import RdrName -import PrelNames +import PrelNames ( negateName, dot_tv_RDR, forall_tv_RDR ) import TysPrim ( funTyConName ) import Name import SrcLoc @@ -48,7 +50,7 @@ import BasicTypes ( compareFixity, funTyFixity, negateFixity, import Outputable import FastString import Maybes -import Data.List ( nub, nubBy, deleteFirstsBy ) +import Data.List ( nub, nubBy ) import Control.Monad ( unless, when ) #if __GLASGOW_HASKELL__ < 709 @@ -62,32 +64,184 @@ These type renamers are in a separate module, rather than in (say) RnSource, to break several loop. ********************************************************* -* * -\subsection{Renaming types} -* * +* * + HsSigWcType (i.e with wildcards) +* * ********************************************************* -} -rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) - -- rnHsSigType is used for source-language type signatures, - -- which use *implicit* universal quantification. -rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty +rnHsSigWcType :: HsDocContext -> LHsSigWcType RdrName + -> RnM (LHsSigWcType Name, FreeVars) +rnHsSigWcType doc sig_ty + = rn_hs_sig_wc_type True doc sig_ty $ \sig_ty' -> + return (sig_ty', emptyFVs) + +rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType RdrName + -> (LHsSigWcType Name -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +-- Used for +-- - Signatures on binders in a RULE +-- - Pattern type signatures +-- Wildcards are allowed +rnHsSigWcTypeScoped ctx sig_ty thing_inside + = rn_hs_sig_wc_type False ctx sig_ty thing_inside + -- False: for pattern type sigs and rules we /do/ want + -- to bring those type varibles into scope + -- e.g \ (x :: forall a. a-> b) -> e + -- Here we do bring 'b' into scope + +rn_hs_sig_wc_type :: Bool -- see rnImplicitBndrs + -> HsDocContext + -> LHsSigWcType RdrName + -> (LHsSigWcType Name -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +-- rn_hs_sig_wc_type is used for source-language type signatures +rn_hs_sig_wc_type no_implicit_if_forall ctxt + (HsIB { hsib_body = wc_ty }) thing_inside + = rnImplicitBndrs no_implicit_if_forall (hswc_body wc_ty) $ \ kvs tvs -> + rn_hs_wc_type ctxt wc_ty $ \ wc_ty' -> + thing_inside (HsIB { hsib_kvs = kvs + , hsib_tvs = tvs + , hsib_body = wc_ty' }) + +rnHsWcType :: HsDocContext -> LHsWcType RdrName -> RnM (LHsWcType Name, FreeVars) +rnHsWcType ctxt wc_ty + = rn_hs_wc_type ctxt wc_ty $ \ wc_ty' -> + return (wc_ty', emptyFVs) + +rn_hs_wc_type :: HsDocContext -> LHsWcType RdrName + -> (LHsWcType Name -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rn_hs_wc_type ctxt (HsWC { hswc_body = hs_ty }) thing_inside + = do { let nwc_rdrs = collectNamedWildCards hs_ty + ; rdr_env <- getLocalRdrEnv + ; nwcs <- sequence [ newLocalBndrRn lrdr + | lrdr@(L _ rdr) <- nwc_rdrs + , not (inScope rdr_env rdr) ] + -- nwcs :: [Name] Named wildcards + ; bindLocalNamesFV nwcs $ + do { (wc_ty, fvs1) <- rnWcSigTy ctxt hs_ty + ; let wc_ty' :: HsWildCardBndrs Name (LHsType Name) + wc_ty' = wc_ty { hswc_wcs = nwcs ++ hswc_wcs wc_ty } + ; (res, fvs2) <- thing_inside wc_ty' + ; return (res, fvs1 `plusFV` fvs2) } } -rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) --- Rename the type in an instance or standalone deriving decl -rnLHsInstType doc_str ty - = do { (ty', fvs) <- rnLHsType (GenericCtx doc_str) ty - ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty)) - ; return (ty', fvs) } - where - good_inst_ty - | Just (_, _, L _ cls, _) <- - splitLHsInstDeclTy_maybe (flattenTopLevelLHsForAllTy ty) - , isTcOcc (rdrNameOcc cls) = True - | otherwise = False +rnWcSigTy :: HsDocContext -> LHsType RdrName + -> RnM (LHsWcType Name, FreeVars) +-- Renames just the top level of a type signature +-- It's exactly like rnHsTyKi, except that it uses rnWcSigContext +-- on a qualified type, and return info on any extra-constraints +-- wildcard. Some code duplication, but no big deal. +rnWcSigTy ctxt (L loc hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_tau })) + = bindLHsTyVarBndrs ctxt Nothing tvs $ \ tvs' -> + do { (hs_tau', fvs) <- rnWcSigTy ctxt hs_tau + ; warnUnusedForAlls (inTypeDoc hs_ty) tvs' fvs + ; let hs_ty' = HsForAllTy { hst_bndrs = tvs', hst_body = hswc_body hs_tau' } + ; return ( hs_tau' { hswc_body = L loc hs_ty' }, fvs) } + +rnWcSigTy ctxt (L loc (HsQualTy { hst_ctxt = hs_ctxt, hst_body = tau })) + = do { (hs_ctxt', fvs1) <- rnWcSigContext ctxt hs_ctxt + ; (tau', fvs2) <- rnLHsType ctxt tau + ; let awcs_tau = collectAnonWildCards tau' + hs_ty' = HsQualTy { hst_ctxt = hswc_body hs_ctxt' + , hst_body = tau' } + ; return ( HsWC { hswc_wcs = hswc_wcs hs_ctxt' ++ awcs_tau + , hswc_ctx = hswc_ctx hs_ctxt' + , hswc_body = L loc hs_ty' } + , fvs1 `plusFV` fvs2) } + +rnWcSigTy ctxt hs_ty + = do { (hs_ty', fvs) <- rnLHsType ctxt hs_ty + ; return (HsWC { hswc_wcs = collectAnonWildCards hs_ty' + , hswc_ctx = Nothing + , hswc_body = hs_ty' } + , fvs) } + +rnWcSigContext :: HsDocContext -> LHsContext RdrName + -> RnM (HsWildCardBndrs Name (LHsContext Name), FreeVars) +rnWcSigContext ctxt (L loc hs_ctxt) + | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt + , L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last + = do { (hs_ctxt1', fvs) <- mapFvRn (rnLHsTyKi RnTopConstraint ctxt) hs_ctxt1 + ; wc' <- setSrcSpan lx $ + rnExtraConstraintWildCard ctxt wc + ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')] + awcs = concatMap collectAnonWildCards hs_ctxt1' + -- NB: *not* including the extra-constraint wildcard + ; return ( HsWC { hswc_wcs = awcs + , hswc_ctx = Just lx + , hswc_body = L loc hs_ctxt' } + , fvs ) } + | otherwise + = do { (hs_ctxt', fvs) <- mapFvRn (rnLHsTyKi RnTopConstraint ctxt) hs_ctxt + ; return (HsWC { hswc_wcs = concatMap collectAnonWildCards hs_ctxt' + , hswc_ctx = Nothing + , hswc_body = L loc hs_ctxt' }, fvs) } -badInstTy :: LHsType RdrName -> SDoc -badInstTy ty = ptext (sLit "Malformed instance:") <+> ppr ty + +{- ****************************************************** +* * + HsSigtype (i.e. no wildcards) +* * +****************************************************** -} + +rnHsSigType :: HsDocContext -> LHsSigType RdrName + -> RnM (LHsSigType Name, FreeVars) +-- Used for source-language type signatures +-- that cannot have wildcards +rnHsSigType ctx (HsIB { hsib_body = hs_ty }) + = rnImplicitBndrs True hs_ty $ \ kvs tvs -> + do { (body', fvs) <- rnLHsType ctx hs_ty + ; return (HsIB { hsib_kvs = kvs + , hsib_tvs = tvs + , hsib_body = body' }, fvs) } + +rnImplicitBndrs :: Bool -- True <=> no implicit quantification + -- if type is headed by a forall + -- E.g. f :: forall a. a->b + -- Do not quantify over 'b' too. + -> LHsType RdrName + -> ([Name] -> [Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnImplicitBndrs no_implicit_if_forall hs_ty@(L loc _) thing_inside + = do { rdr_env <- getLocalRdrEnv + ; let (kv_rdrs, tv_rdrs) = filterInScope rdr_env $ + extractHsTyRdrTyVars hs_ty + real_tv_rdrs -- Implicit quantification only if + -- there is no explicit forall + | no_implicit_if_forall + , L _ (HsForAllTy {}) <- hs_ty = [] + | otherwise = tv_rdrs + ; traceRn (text "rnSigType" <+> (ppr hs_ty $$ ppr kv_rdrs $$ ppr tv_rdrs)) + ; kvs <- mapM (newLocalBndrRn . L loc) kv_rdrs + ; tvs <- mapM (newLocalBndrRn . L loc) real_tv_rdrs + ; bindLocalNamesFV (kvs ++ tvs) $ + thing_inside kvs tvs } + +rnLHsInstType :: SDoc -> LHsSigType RdrName -> RnM (LHsSigType Name, FreeVars) +-- Rename the type in an instance or standalone deriving decl +-- The 'doc_str' is "an instance declaration" or "a VECTORISE pragma" +rnLHsInstType doc_str inst_ty + | Just cls <- getLHsInstDeclClass_maybe inst_ty + , isTcOcc (rdrNameOcc (unLoc cls)) + -- The guards check that the instance type looks like + -- blah => C ty1 .. tyn + = do { let full_doc = doc_str <+> ptext (sLit "for") <+> quotes (ppr cls) + ; rnHsSigType (GenericCtx full_doc) inst_ty } + + | otherwise -- The instance is malformed, but we'd still like + -- to make progress rather than failing outright, so + -- we report more errors. So we rename it anyway. + = do { addErrAt (getLoc (hsSigType inst_ty)) $ + ptext (sLit "Malformed instance:") <+> ppr inst_ty + ; rnHsSigType (GenericCtx doc_str) inst_ty } + + +{- ****************************************************** +* * + LHsType and HsType +* * +****************************************************** -} {- rnHsType is here because we call it from loadInstDecl, and I didn't @@ -113,18 +267,22 @@ The -fwarn-context-quantification flag warns about this situation. See rnHsTyKi for case HsForAllTy Qualified. -} -rnLHsTyKi :: Bool -- True <=> renaming a type, False <=> a kind +rnLHsTyKi :: RnTyKiWhat -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -rnLHsTyKi isType doc (L loc ty) +rnLHsTyKi what doc (L loc ty) = setSrcSpan loc $ - do { (ty', fvs) <- rnHsTyKi isType doc ty + do { (ty', fvs) <- rnHsTyKi what doc ty ; return (L loc ty', fvs) } rnLHsType :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -rnLHsType = rnLHsTyKi True +rnLHsType cxt ty = -- pprTrace "rnHsType" (pprHsDocContext cxt $$ ppr ty) $ + rnLHsTyKi RnType cxt ty + +rnLHsPred :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) +rnLHsPred = rnLHsTyKi RnConstraint rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars) -rnLHsKind = rnLHsTyKi False +rnLHsKind = rnLHsTyKi RnKind rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName) -> RnM (Maybe (LHsKind Name), FreeVars) @@ -135,44 +293,74 @@ rnLHsMaybeKind doc (Just kind) ; return (Just kind', fvs) } rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) -rnHsType = rnHsTyKi True -rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars) -rnHsKind = rnHsTyKi False - -rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) - -rnHsTyKi isType doc ty@HsForAllTy{} - = rnHsTyKiForAll isType doc (flattenTopLevelHsForAllTy ty) +rnHsType cxt ty = rnHsTyKi RnType cxt ty -rnHsTyKi isType _ (HsTyVar (L l rdr_name)) - = do { name <- rnTyVar isType rdr_name - ; return (HsTyVar (L l name), unitFV name) } +rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars) +rnHsKind = rnHsTyKi RnKind + +data RnTyKiWhat = RnType + | RnKind + | RnTopConstraint -- Top-level context of HsSigWcTypes + | RnConstraint -- All other constraints + +instance Outputable RnTyKiWhat where + ppr RnType = ptext (sLit "RnType") + ppr RnKind = ptext (sLit "RnKind") + ppr RnTopConstraint = ptext (sLit "RnTopConstraint") + ppr RnConstraint = ptext (sLit "RnConstraint") + +isRnType :: RnTyKiWhat -> Bool +isRnType RnType = True +isRnType _ = False + +isRnKind :: RnTyKiWhat -> Bool +isRnKind RnKind = True +isRnKind _ = False + +rnHsTyKi :: RnTyKiWhat -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) + +rnHsTyKi _ doc ty@(HsForAllTy { hst_bndrs = tyvars, hst_body = tau }) + = bindLHsTyVarBndrs doc Nothing tyvars $ \ tyvars' -> + do { (tau', fvs) <- rnLHsType doc tau + ; warnUnusedForAlls (inTypeDoc ty) tyvars' fvs + ; return ( HsForAllTy { hst_bndrs = tyvars', hst_body = tau' } + , fvs) } + +rnHsTyKi _ doc (HsQualTy { hst_ctxt = lctxt + , hst_body = tau }) + = do { (ctxt', fvs1) <- rnContext doc lctxt + ; (tau', fvs2) <- rnLHsType doc tau + ; return (HsQualTy { hst_ctxt = ctxt', hst_body = tau' } + , fvs1 `plusFV` fvs2) } + +rnHsTyKi what _ (HsTyVar (L loc rdr_name)) + = do { name <- rnTyVar what rdr_name + ; return (HsTyVar (L loc name), unitFV name) } -- If we see (forall a . ty), without foralls on, the forall will give -- a sensible error message, but we don't want to complain about the dot too -- Hence the jiggery pokery with ty1 -rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2) - = ASSERT( isType ) setSrcSpan loc $ +rnHsTyKi what doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2) + = setSrcSpan loc $ do { ops_ok <- xoptM Opt_TypeOperators ; op' <- if ops_ok - then rnTyVar isType op + then rnTyVar what op else do { addErr (opTyErr op ty) - ; return (mkUnboundName op) } -- Avoid double complaint + ; return (mkUnboundNameRdr op) } -- Avoid double complaint ; let l_op' = L loc op' ; fix <- lookupTyFixityRn l_op' - ; (ty1', fvs1) <- rnLHsType doc ty1 - ; (ty2', fvs2) <- rnLHsType doc ty2 + ; (ty1', fvs1) <- rnLHsTyKi what doc ty1 + ; (ty2', fvs2) <- rnLHsTyKi what doc ty2 ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) op' fix ty1' ty2' ; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') } -rnHsTyKi isType doc (HsParTy ty) - = do { (ty', fvs) <- rnLHsTyKi isType doc ty +rnHsTyKi what doc (HsParTy ty) + = do { (ty', fvs) <- rnLHsTyKi what doc ty ; return (HsParTy ty', fvs) } -rnHsTyKi isType doc (HsBangTy b ty) - = ASSERT( isType ) - do { (ty', fvs) <- rnLHsType doc ty +rnHsTyKi _ doc (HsBangTy b ty) + = do { (ty', fvs) <- rnLHsType doc ty ; return (HsBangTy b ty', fvs) } rnHsTyKi _ doc ty@(HsRecTy flds) @@ -181,50 +369,51 @@ rnHsTyKi _ doc ty@(HsRecTy flds) ; (flds', fvs) <- rnConDeclFields [] doc flds ; return (HsRecTy flds', fvs) } -rnHsTyKi isType doc (HsFunTy ty1 ty2) - = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1 +rnHsTyKi what doc (HsFunTy ty1 ty2) + = do { (ty1', fvs1) <- rnLHsTyKi what doc ty1 -- Might find a for-all as the arg of a function type - ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2 + ; (ty2', fvs2) <- rnLHsTyKi what doc ty2 -- Or as the result. This happens when reading Prelude.hi -- when we find return :: forall m. Monad m -> forall a. a -> m a -- Check for fixity rearrangements - ; res_ty <- if isType + ; res_ty <- if isRnType what then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' else return (HsFunTy ty1' ty2') + ; return (res_ty, fvs1 `plusFV` fvs2) } -rnHsTyKi isType doc listTy@(HsListTy ty) +rnHsTyKi what doc listTy@(HsListTy ty) = do { data_kinds <- xoptM Opt_DataKinds - ; unless (data_kinds || isType) (addErr (dataKindsErr isType listTy)) - ; (ty', fvs) <- rnLHsTyKi isType doc ty + ; when (not data_kinds && isRnKind what) + (addErr (dataKindsErr what listTy)) + ; (ty', fvs) <- rnLHsTyKi what doc ty ; return (HsListTy ty', fvs) } -rnHsTyKi isType doc (HsKindSig ty k) - = ASSERT( isType ) - do { kind_sigs_ok <- xoptM Opt_KindSignatures - ; unless kind_sigs_ok (badSigErr False doc ty) +rnHsTyKi _ doc (HsKindSig ty k) + = do { kind_sigs_ok <- xoptM Opt_KindSignatures + ; unless kind_sigs_ok (badKindSigErr doc ty) ; (ty', fvs1) <- rnLHsType doc ty ; (k', fvs2) <- rnLHsKind doc k ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) } -rnHsTyKi isType doc (HsPArrTy ty) - = ASSERT( isType ) - do { (ty', fvs) <- rnLHsType doc ty +rnHsTyKi _ doc (HsPArrTy ty) + = do { (ty', fvs) <- rnLHsType doc ty ; return (HsPArrTy ty', fvs) } -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. -rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) +rnHsTyKi what doc tupleTy@(HsTupleTy tup_con tys) = do { data_kinds <- xoptM Opt_DataKinds - ; unless (data_kinds || isType) (addErr (dataKindsErr isType tupleTy)) - ; (tys', fvs) <- mapFvRn (rnLHsTyKi isType doc) tys + ; when (not data_kinds && isRnKind what) + (addErr (dataKindsErr what tupleTy)) + ; (tys', fvs) <- mapFvRn (rnLHsTyKi what doc) tys ; return (HsTupleTy tup_con tys', fvs) } -- Ensure that a type-level integer is nonnegative (#8306, #8412) -rnHsTyKi isType _ tyLit@(HsTyLit t) +rnHsTyKi what _ tyLit@(HsTyLit t) = do { data_kinds <- xoptM Opt_DataKinds - ; unless data_kinds (addErr (dataKindsErr isType tyLit)) + ; unless data_kinds (addErr (dataKindsErr what tyLit)) ; when (negLit t) (addErr negLitErr) ; return (HsTyLit t, emptyFVs) } where @@ -232,177 +421,175 @@ rnHsTyKi isType _ tyLit@(HsTyLit t) negLit (HsNumTy _ i) = i < 0 negLitErr = ptext (sLit "Illegal literal in type (type literals must not be negative):") <+> ppr tyLit -rnHsTyKi isType doc (HsAppTy ty1 ty2) - = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1 - ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2 +rnHsTyKi what doc (HsAppTy ty1 ty2) + = do { (ty1', fvs1) <- rnLHsTyKi what doc ty1 + ; (ty2', fvs2) <- rnLHsTyKi what doc ty2 ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) } -rnHsTyKi isType doc (HsIParamTy n ty) - = ASSERT( isType ) - do { (ty', fvs) <- rnLHsType doc ty +rnHsTyKi _ doc (HsIParamTy n ty) + = do { (ty', fvs) <- rnLHsType doc ty ; return (HsIParamTy n ty', fvs) } -rnHsTyKi isType doc (HsEqTy ty1 ty2) - = ASSERT( isType ) - do { (ty1', fvs1) <- rnLHsType doc ty1 +rnHsTyKi _ doc (HsEqTy ty1 ty2) + = do { (ty1', fvs1) <- rnLHsType doc ty1 ; (ty2', fvs2) <- rnLHsType doc ty2 ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) } -rnHsTyKi isType _ (HsSpliceTy sp k) - = ASSERT( isType ) - rnSpliceType sp k +rnHsTyKi _ _ (HsSpliceTy sp k) + = rnSpliceType sp k -rnHsTyKi isType doc (HsDocTy ty haddock_doc) - = ASSERT( isType ) - do { (ty', fvs) <- rnLHsType doc ty +rnHsTyKi _ doc (HsDocTy ty haddock_doc) + = do { (ty', fvs) <- rnLHsType doc ty ; haddock_doc' <- rnLHsDoc haddock_doc ; return (HsDocTy ty' haddock_doc', fvs) } -rnHsTyKi isType _ (HsCoreTy ty) - = ASSERT( isType ) - return (HsCoreTy ty, emptyFVs) +rnHsTyKi _ _ (HsCoreTy ty) + = return (HsCoreTy ty, emptyFVs) -- The emptyFVs probably isn't quite right -- but I don't think it matters rnHsTyKi _ _ (HsWrapTy {}) = panic "rnHsTyKi" -rnHsTyKi isType doc ty@(HsExplicitListTy k tys) - = ASSERT( isType ) - do { data_kinds <- xoptM Opt_DataKinds - ; unless data_kinds (addErr (dataKindsErr isType ty)) +rnHsTyKi what doc ty@(HsExplicitListTy k tys) + = do { data_kinds <- xoptM Opt_DataKinds + ; unless data_kinds (addErr (dataKindsErr what ty)) ; (tys', fvs) <- rnLHsTypes doc tys ; return (HsExplicitListTy k tys', fvs) } -rnHsTyKi isType doc ty@(HsExplicitTupleTy kis tys) - = ASSERT( isType ) - do { data_kinds <- xoptM Opt_DataKinds - ; unless data_kinds (addErr (dataKindsErr isType ty)) +rnHsTyKi what doc ty@(HsExplicitTupleTy kis tys) + = do { data_kinds <- xoptM Opt_DataKinds + ; unless data_kinds (addErr (dataKindsErr what ty)) ; (tys', fvs) <- rnLHsTypes doc tys ; return (HsExplicitTupleTy kis tys', fvs) } -rnHsTyKi isType _doc (HsWildCardTy (AnonWildCard PlaceHolder)) - = ASSERT( isType ) - do { loc <- getSrcSpanM - ; uniq <- newUnique - ; let name = mkInternalName uniq (mkTyVarOcc "_") loc - ; return (HsWildCardTy (AnonWildCard (L loc name)), emptyFVs) } - -- emptyFVs: this occurrence does not refer to a - -- binding, so don't treat it as a free variable - -rnHsTyKi isType doc (HsWildCardTy (NamedWildCard (L l rdr_name))) - = ASSERT( isType ) - do { not_in_scope <- isNothing `fmap` lookupOccRn_maybe rdr_name - ; when not_in_scope $ - -- When the named wild card is not in scope, it means it shouldn't be - -- there in the first place, i.e. rnHsSigTypeWithWildCards wasn't - -- used, so fail. - failWith $ text "Unexpected wild card:" <+> quotes (ppr rdr_name) $$ - docOfHsDocContext doc - ; name <- rnTyVar isType rdr_name - ; return (HsWildCardTy (NamedWildCard (L l name)), emptyFVs) } +rnHsTyKi what ctxt (HsWildCardTy wc) + = do { wc' <- case mb_bad of + Just msg -> do { addErr (wildCardMsg ctxt msg) + ; discardErrs (rnWildCard ctxt wc) } + -- discardErrs: avoid reporting + -- a second error + Nothing -> rnWildCard ctxt wc + + ; traceRn (text "rnHsTyKi wild" <+> ppr wc <+> ppr (isJust mb_bad)) + ; return (HsWildCardTy wc', emptyFVs) } -- emptyFVs: this occurrence does not refer to a - -- binding, so don't treat it as a free variable + -- user-written binding site, so don't treat + -- it as a free variable + where + mb_bad :: Maybe SDoc + mb_bad | not (wildCardsAllowed ctxt) + = Just (notAllowed wc) + | otherwise + = case what of + RnType -> Nothing + RnKind -> Just (notAllowed wc <+> ptext (sLit "in a kind")) + RnConstraint -> Just constraint_msg + RnTopConstraint -> case wc of + AnonWildCard {} -> Just constraint_msg + NamedWildCard {} -> Nothing + + constraint_msg = hang (notAllowed wc <+> ptext (sLit "in a constraint")) + 2 hint_msg + + hint_msg = case wc of + NamedWildCard {} -> empty + AnonWildCard {} -> vcat [ ptext (sLit "except as the last top-level constraint of a type signature") + , nest 2 (ptext (sLit "e.g f :: (Eq a, _) => blah")) ] + +notAllowed :: HsWildCardInfo RdrName -> SDoc +notAllowed wc = ptext (sLit "Wildcard") <+> quotes (ppr wc) + <+> ptext (sLit "not allowed") + +wildCardMsg :: HsDocContext -> SDoc -> SDoc +wildCardMsg ctxt doc + = vcat [doc, nest 2 (ptext (sLit "in") <+> pprHsDocContext ctxt)] -------------- -rnHsTyKiForAll :: Bool -> HsDocContext -> HsType RdrName - -> RnM (HsType Name, FreeVars) -rnHsTyKiForAll isType doc (HsForAllTy Implicit extra _ lctxt@(L _ ctxt) ty) - = ASSERT( isType ) do - -- Implicit quantifiction in source code (no kinds on tyvars) - -- Given the signature C => T we universally quantify - -- over FV(T) \ {in-scope-tyvars} - rdr_env <- getLocalRdrEnv - loc <- getSrcSpanM - let - (forall_kvs, forall_tvs) = filterInScope rdr_env $ - extractHsTysRdrTyVars (ty:ctxt) - -- In for-all types we don't bring in scope - -- kind variables mentioned in kind signatures - -- (Well, not yet anyway....) - -- f :: Int -> T (a::k) -- Not allowed - - -- The filterInScope is to ensure that we don't quantify over - -- type variables that are in scope; when GlasgowExts is off, - -- there usually won't be any, except for class signatures: - -- class C a where { op :: a -> a } - tyvar_bndrs = userHsTyVarBndrs loc forall_tvs - - rnForAll doc Implicit extra forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty - -rnHsTyKiForAll isType doc - fulltype@(HsForAllTy Qualified extra _ lctxt@(L _ ctxt) ty) - = ASSERT( isType ) do - rdr_env <- getLocalRdrEnv - loc <- getSrcSpanM - let - (forall_kvs, forall_tvs) = filterInScope rdr_env $ - extractHsTysRdrTyVars (ty:ctxt) - tyvar_bndrs = userHsTyVarBndrs loc forall_tvs - in_type_doc = ptext (sLit "In the type") <+> quotes (ppr fulltype) - - -- See Note [Context quantification] - warnContextQuantification (in_type_doc $$ docOfHsDocContext doc) tyvar_bndrs - rnForAll doc Implicit extra forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty - -rnHsTyKiForAll isType doc - ty@(HsForAllTy Explicit extra forall_tyvars lctxt@(L _ ctxt) tau) - = ASSERT( isType ) do { -- Explicit quantification. - -- Check that the forall'd tyvars are actually - -- mentioned in the type, and produce a warning if not - let (kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt) - in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty) - ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) - forall_tyvars mentioned - ; traceRn (text "rnHsTyKiForAll:Exlicit" <+> vcat - [ppr forall_tyvars, ppr lctxt,ppr tau ]) - ; rnForAll doc Explicit extra kvs forall_tyvars lctxt tau } - --- The following should never happen but keeps the completeness checker happy -rnHsTyKiForAll isType doc ty = rnHsTyKi isType doc ty --------------- -rnTyVar :: Bool -> RdrName -> RnM Name -rnTyVar is_type rdr_name - | is_type = lookupTypeOccRn rdr_name - | otherwise = lookupKindOccRn rdr_name +rnTyVar :: RnTyKiWhat -> RdrName -> RnM Name +rnTyVar what rdr_name + | isRnKind what = lookupKindOccRn rdr_name + | otherwise = lookupTypeOccRn rdr_name -rnLTyVar :: Bool -> Located RdrName -> RnM (Located Name) -rnLTyVar is_type (L loc rdr_name) = do - tyvar' <- rnTyVar is_type rdr_name - return (L loc tyvar') +rnLTyVar :: Located RdrName -> RnM (Located Name) +rnLTyVar (L loc rdr_name) + = do { tyvar <- lookupTypeOccRn rdr_name + ; return (L loc tyvar) } -------------- rnLHsTypes :: HsDocContext -> [LHsType RdrName] -> RnM ([LHsType Name], FreeVars) rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys -rnForAll :: HsDocContext -> HsExplicitFlag - -> Maybe SrcSpan -- Location of an extra-constraints wildcard - -> [RdrName] -- Kind variables - -> LHsTyVarBndrs RdrName -- Type variables - -> LHsContext RdrName -> LHsType RdrName - -> RnM (HsType Name, FreeVars) - -rnForAll doc exp extra kvs forall_tyvars ctxt ty - | null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt), isNothing extra - = rnHsType doc (unLoc ty) - -- One reason for this case is that a type like Int# - -- starts off as (HsForAllTy Implicit Nothing [] Int), in case - -- there is some quantification. Now that we have quantified - -- and discovered there are no type variables, it's nicer to turn - -- it into plain Int. If it were Int# instead of Int, we'd actually - -- get an error, because the body of a genuine for-all is - -- of kind *. +-------------- +extraConstraintWildCardsAllowed :: HsDocContext -> Bool +extraConstraintWildCardsAllowed ctxt + = case ctxt of + TypeSigCtx {} -> True + _ -> False + +wildCardsAllowed :: HsDocContext -> Bool +-- ^ In what contexts are wildcards permitted +wildCardsAllowed ctxt + = case ctxt of + TypeSigCtx {} -> True + TypBrCtx {} -> True -- Template Haskell quoted type + SpliceTypeCtx {} -> True -- Result of a Template Haskell splice + ExprWithTySigCtx {} -> True + PatCtx {} -> True + RuleCtx {} -> True + FamPatCtx {} -> True -- Not named wildcards though + GHCiCtx {} -> True + _ -> False + +rnExtraConstraintWildCard :: HsDocContext -> HsWildCardInfo RdrName + -> RnM (HsWildCardInfo Name) +-- Rename the extra-constraint spot in a type signature +-- (blah, _) => type +-- Check that extra-constraints are allowed at all, and +-- if so that it's an anonymous wildcard +rnExtraConstraintWildCard ctxt wc + = case mb_bad of + Nothing -> rnWildCard ctxt wc + Just msg -> do { addErr (wildCardMsg ctxt msg) + ; discardErrs (rnWildCard ctxt wc) } + where + mb_bad | not (extraConstraintWildCardsAllowed ctxt) + = Just (ptext (sLit "Extra-contraint wildcard") <+> quotes (ppr wc) + <+> ptext (sLit "not allowed")) + | isNamedWildCard wc + = Just (hang (ptext (sLit "Named wildcard") <+> quotes (ppr wc) + <+> ptext (sLit "not allowed as an extra-contraint")) + 2 (ptext (sLit "Use an anonymous wildcard instead"))) + | otherwise + = Nothing + +rnWildCard :: HsDocContext -> HsWildCardInfo RdrName -> RnM (HsWildCardInfo Name) +rnWildCard _ (AnonWildCard _) + = do { loc <- getSrcSpanM + ; uniq <- newUnique + ; let name = mkInternalName uniq (mkTyVarOcc "_") loc + ; return (AnonWildCard (L loc name)) } + +rnWildCard ctxt wc@(NamedWildCard (L loc rdr_name)) + -- NB: The parser only generates NamedWildCard if -XNamedWildCards + -- is on, so we don't need to check for that here + = do { mb_name <- lookupOccRn_maybe rdr_name + ; traceRn (text "rnWildCard named" <+> (ppr rdr_name $$ ppr mb_name)) + ; case mb_name of + Just n -> return (NamedWildCard (L loc n)) + Nothing -> do { addErr msg -- I'm not sure how this can happen + ; return (NamedWildCard (L loc (mkUnboundNameRdr rdr_name))) } } + where + msg = wildCardMsg ctxt (notAllowed wc) - | otherwise - = bindHsTyVars doc Nothing kvs forall_tyvars $ \ new_tyvars -> - do { (new_ctxt, fvs1) <- rnContext doc ctxt - ; (new_ty, fvs2) <- rnLHsType doc ty - ; return (HsForAllTy exp extra new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) } - -- Retain the same implicit/explicit flag as before - -- so that we can later print it correctly ---------------- +{- ***************************************************** +* * + Binding type variables +* * +***************************************************** -} + bindSigTyVarsFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) @@ -417,24 +604,24 @@ bindSigTyVarsFV tvs thing_inside bindLocalNamesFV tvs thing_inside } --------------- -bindHsTyVars :: HsDocContext - -> Maybe a -- Just _ => an associated type decl - -> [RdrName] -- Kind variables from scope - -> LHsTyVarBndrs RdrName -- Type variables - -> (LHsTyVarBndrs Name -> RnM (b, FreeVars)) - -> RnM (b, FreeVars) +bindHsQTyVars :: HsDocContext + -> Maybe a -- Just _ => an associated type decl + -> [RdrName] -- Kind variables from scope + -> LHsQTyVars RdrName -- Type variables + -> (LHsQTyVars Name -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) -- (a) Bring kind variables into scope -- both (i) passed in (kv_bndrs) -- and (ii) mentioned in the kinds of tv_bndrs -- (b) Bring type variables into scope -bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside +bindHsQTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside = do { rdr_env <- getLocalRdrEnv ; let tvs = hsQTvBndrs tv_bndrs kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs , let (_, kvs) = extractHsTyRdrTyVars kind , kv <- kvs ] all_kvs' = nub (kv_bndrs ++ kvs_from_tv_bndrs) - all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) all_kvs' + all_kvs = filterOut (inScope rdr_env) all_kvs' overlap_kvs = [ kv | kv <- all_kvs, any ((==) kv . hsLTyVarName) tvs ] -- These variables appear both as kind and type variables @@ -450,22 +637,26 @@ bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside ; loc <- getSrcSpanM ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs ; bindLocalNamesFV kv_names $ - do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs + bindLHsTyVarBndrs doc mb_assoc tvs $ \ tv_bndrs' -> + thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) } + +bindLHsTyVarBndrs :: HsDocContext + -> Maybe a -- Just _ => an associated type decl + -> [LHsTyVarBndr RdrName] + -> ([LHsTyVarBndr Name] -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +bindLHsTyVarBndrs doc mb_assoc tv_bndrs thing_inside + = do { let tv_names_w_loc = map hsLTyVarLocName tv_bndrs -- Check for duplicate or shadowed tyvar bindrs ; checkDupRdrNames tv_names_w_loc ; when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) - ; (tv_bndrs', fvs1) <- mapFvRn (rnLHsTyVarBndr doc mb_assoc rdr_env) tvs + ; rdr_env <- getLocalRdrEnv + ; (tv_bndrs', fvs1) <- mapFvRn (rnLHsTyVarBndr doc mb_assoc rdr_env) tv_bndrs ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $ - do { inner_rdr_env <- getLocalRdrEnv - ; traceRn (text "bhtv" <+> vcat - [ ppr tvs, ppr kv_bndrs, ppr kvs_from_tv_bndrs - , ppr $ map (`elemLocalRdrEnv` rdr_env) all_kvs' - , ppr $ map (getUnique . rdrNameOcc) all_kvs' - , ppr all_kvs, ppr rdr_env, ppr inner_rdr_env ]) - ; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) } - ; return (res, fvs1 `plusFV` fvs2) } } + thing_inside tv_bndrs' + ; return (res, fvs1 `plusFV` fvs2) } rnLHsTyVarBndr :: HsDocContext -> Maybe a -> LocalRdrEnv -> LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars) @@ -474,7 +665,7 @@ rnLHsTyVarBndr _ mb_assoc rdr_env (L loc (UserTyVar (L l rdr))) ; return (L loc (UserTyVar (L l nm)), emptyFVs) } rnLHsTyVarBndr doc mb_assoc rdr_env (L loc (KindedTyVar (L lv rdr) kind)) = do { sig_ok <- xoptM Opt_KindSignatures - ; unless sig_ok (badSigErr False doc kind) + ; unless sig_ok (badKindSigErr doc kind) ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr ; (kind', fvs) <- rnLHsKind doc kind ; return (L loc (KindedTyVar (L lv nm) kind'), fvs) } @@ -487,111 +678,20 @@ newTyVarNameRn mb_assoc rdr_env loc rdr | otherwise = newLocalBndrRn (L loc rdr) --------------------------------- -rnHsBndrSig :: HsDocContext - -> HsWithBndrs RdrName (LHsType RdrName) - -> (HsWithBndrs Name (LHsType Name) -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside - = do { sig_ok <- xoptM Opt_ScopedTypeVariables - ; unless sig_ok (badSigErr True doc ty) - ; rdr_env <- getLocalRdrEnv - ; let (kv_bndrs, tv_bndrs) = filterInScope rdr_env $ - extractHsTyRdrTyVars ty - ; kv_names <- newLocalBndrsRn (map (L loc) kv_bndrs) - ; tv_names <- newLocalBndrsRn (map (L loc) tv_bndrs) - ; bindLocalNamesFV kv_names $ - bindLocalNamesFV tv_names $ - do { (ty', fvs1, wcs) <- rnLHsTypeWithWildCards doc ty - ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty' - , hswb_kvs = kv_names - , hswb_tvs = tv_names - , hswb_wcs = wcs }) - ; return (res, fvs1 `plusFV` fvs2) } } - -overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc -overlappingKindVars doc kvs - = vcat [ ptext (sLit "Kind variable") <> plural kvs <+> - ptext (sLit "also used as type variable") <> plural kvs - <> colon <+> pprQuotedList kvs - , docOfHsDocContext doc ] +--------------------- +collectNamedWildCards :: LHsType RdrName -> [Located RdrName] +collectNamedWildCards hs_ty + = nubBy eqLocated $ + [n | L _ (NamedWildCard n) <- collectWildCards hs_ty ] -badKindBndrs :: HsDocContext -> [RdrName] -> SDoc -badKindBndrs doc kvs - = vcat [ hang (ptext (sLit "Unexpected kind variable") <> plural kvs - <+> pprQuotedList kvs) - 2 (ptext (sLit "Perhaps you intended to use PolyKinds")) - , docOfHsDocContext doc ] +collectAnonWildCards :: LHsType Name -> [Name] +collectAnonWildCards hs_ty + = [n | L _ (AnonWildCard (L _ n)) <- collectWildCards hs_ty ] -badSigErr :: Bool -> HsDocContext -> LHsType RdrName -> TcM () -badSigErr is_type doc (L loc ty) - = setSrcSpan loc $ addErr $ - vcat [ hang (ptext (sLit "Illegal") <+> what - <+> ptext (sLit "signature:") <+> quotes (ppr ty)) - 2 (ptext (sLit "Perhaps you intended to use") <+> flag) - , docOfHsDocContext doc ] +collectWildCards :: LHsType name -> [Located (HsWildCardInfo name)] +-- | Extract all wild cards from a type. +collectWildCards lty = go lty where - what | is_type = ptext (sLit "type") - | otherwise = ptext (sLit "kind") - flag | is_type = ptext (sLit "ScopedTypeVariables") - | otherwise = ptext (sLit "KindSignatures") - -dataKindsErr :: Bool -> HsType RdrName -> SDoc -dataKindsErr is_type thing - = hang (ptext (sLit "Illegal") <+> what <> colon <+> quotes (ppr thing)) - 2 (ptext (sLit "Perhaps you intended to use DataKinds")) - where - what | is_type = ptext (sLit "type") - | otherwise = ptext (sLit "kind") - --------------------------------- --- | Variant of @rnHsSigType@ that supports wild cards. Also returns the wild --- cards to bind. -rnHsSigTypeWithWildCards :: SDoc -> LHsType RdrName - -> RnM (LHsType Name, FreeVars, [Name]) -rnHsSigTypeWithWildCards doc_str ty - = rnLHsTypeWithWildCards (TypeSigCtx doc_str) ty' - where - ty' = extractExtraCtsWc `fmap` flattenTopLevelLHsForAllTy ty - -- When there is a wild card at the end of the context, remove it and add - -- its location as the extra-constraints wild card in the HsForAllTy. - extractExtraCtsWc (HsForAllTy flag _ bndrs (L l ctxt) ty) - | Just (ctxt', ct) <- snocView ctxt - , L lx (HsWildCardTy (AnonWildCard _)) <- ignoreParens ct - = HsForAllTy flag (Just lx) bndrs (L l ctxt') ty - extractExtraCtsWc ty = ty - --- | Variant of @rnLHsType@ that supports wild cards. The third element of the --- tuple consists of the freshly generated names of the anonymous wild cards --- occurring in the type, as well as the names of the named wild cards in the --- type that are not yet in scope. -rnLHsTypeWithWildCards :: HsDocContext -> LHsType RdrName - -> RnM (LHsType Name, FreeVars, [Name]) -rnLHsTypeWithWildCards doc ty - = do { checkValidPartialType doc ty - ; rdr_env <- getLocalRdrEnv - -- Filter out named wildcards that are already in scope - ; let (_, wcs) = collectWildCards ty - nwcs = [L loc n | L _ (NamedWildCard (L loc n)) <- wcs - , not (elemLocalRdrEnv n rdr_env) ] - ; bindLocatedLocalsRn nwcs $ \nwcs' -> do { - (ty', fvs) <- rnLHsType doc ty - -- Add the anonymous wildcards that have been given names during - -- renaming - ; let (_, wcs') = collectWildCards ty' - awcs = filter (isAnonWildCard . unLoc) wcs' - ; return (ty', fvs, nwcs' ++ map (HsSyn.wildCardName . unLoc) awcs) } } - --- | Extract all wild cards from a type. The named and anonymous --- extra-constraints wild cards are returned separately to be able to give --- more accurate error messages. -collectWildCards - :: Eq name => LHsType name - -> ([Located (HsWildCardInfo name)], -- extra-constraints wild cards - [Located (HsWildCardInfo name)]) -- wild cards -collectWildCards lty = (extra, nubBy sameNamedWildCard wcs) - where - (extra, wcs) = go lty go (L loc ty) = case ty of HsAppTy ty1 ty2 -> go ty1 `mappend` go ty2 HsFunTy ty1 ty2 -> go ty1 `mappend` go ty2 @@ -610,98 +710,14 @@ collectWildCards lty = (extra, nubBy sameNamedWildCard wcs) HsExplicitTupleTy _ tys -> gos tys HsWrapTy _ ty -> go (L loc ty) -- Interesting cases - HsWildCardTy wc -> ([], [L loc wc]) - HsForAllTy _ _ _ (L _ ctxt) ty -> ctxtWcs `mappend` go ty - where - ctxt' = map ignoreParens ctxt - extraWcs = [L l wc | L l (HsWildCardTy wc) <- ctxt'] - (_, wcs) = gos ctxt' - -- Remove extra-constraints wild cards from wcs - ctxtWcs = (extraWcs, deleteFirstsBy sameWildCard - (nubBy sameWildCard wcs) extraWcs) + HsWildCardTy wc -> [L loc wc] + HsForAllTy { hst_body = ty } -> go ty + HsQualTy { hst_ctxt = L _ ctxt + , hst_body = ty } -> gos ctxt `mappend` go ty -- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit _ -> mempty - gos = mconcat . map go --- | Check the validity of a partial type signature. The following things are --- checked: --- --- * Named extra-constraints wild cards aren't allowed, --- e.g. invalid: @(Show a, _x) => a -> String@. --- --- * There is only one extra-constraints wild card in the context and it must --- come last, e.g. invalid: @(_, Show a) => a -> String@ --- or @(_, Show a, _) => a -> String@. --- --- * There should be no unnamed wild cards in the context. --- --- * An extra-constraints wild card can only occur in the top-level context. --- This would be invalid: @(Eq a, _) => a -> (Num a, _) => a -> Bool@. --- --- * Named wild cards occurring in the context must also occur in the monotype. --- --- When an invalid wild card is found, we fail with an error. -checkValidPartialType :: HsDocContext -> LHsType RdrName -> RnM () -checkValidPartialType doc lty - = do { whenNonEmpty isNamedWildCard inExtra $ \(L loc _) -> - failAt loc $ typeDoc $$ - text "An extra-constraints wild card cannot be named" $$ - docOfHsDocContext doc - - ; whenNonEmpty isAnonWildCard extraTopLevel $ \(L loc _) -> - failAt loc $ typeDoc $$ - -- If there was a valid extra-constraints wild card, it should have - -- already been removed and its location should be stored in the - -- HsForAllTy - (case extra of - Just _ -> - -- We're in a top-level context with an extracted - -- extra-constraints wild card. - text "Only a single extra-constraints wild card is allowed" - _ | TypeSigCtx _ <- doc -> - -- We're in a top-level context, but the extra-constraints wild - -- card didn't occur at the end. - fcat [ text "An extra-constraints wild card must occur" - , text "at the end of the constraints" ] - _ -> - -- We're not in a top-level context, so no extra-constraints - -- wild cards are supported. - fcat [ text "An extra-constraints wild card is only allowed" - , text "in the top-level context" ]) $$ - docOfHsDocContext doc - - ; whenNonEmpty isAnonWildCard inCtxt $ \(L loc _) -> - failAt loc $ typeDoc $$ - text "Anonymous wild cards are not allowed in constraints" $$ - docOfHsDocContext doc - - ; whenNonEmpty isAnonWildCard nestedExtra $ \(L loc _) -> - failAt loc $ typeDoc $$ - fcat [ text "An extra-constraints wild card is only allowed" - , text "in the top-level context" ] $$ - docOfHsDocContext doc - - ; whenNonEmpty isNamedWildCard inCtxtNotInTau $ \(L loc name) -> - failAt loc $ typeDoc $$ - fcat [ text "The named wild card" <+> quotes (ppr name) <> space - , text "is only allowed in the constraints" - , text "when it also occurs in the rest of the type" ] $$ - docOfHsDocContext doc } - where - typeDoc = hang (text "Invalid partial type:") 2 (ppr lty) - (extra, ctxt, tau) = splitPartialType lty - (inExtra, _) = collectWildCards lty - (nestedExtra, inTau) = collectWildCards tau - (_, inCtxt) = mconcat $ map collectWildCards ctxt - inCtxtNotInTau = deleteFirstsBy sameWildCard inCtxt inTau - extraTopLevel = deleteFirstsBy sameWildCard inExtra nestedExtra - - splitPartialType (L _ (HsForAllTy _ extra _ (L _ ctxt) ty)) - = (extra, map ignoreParens ctxt, ty) - splitPartialType ty = (Nothing, [], ty) - - whenNonEmpty test wcs f - = whenIsJust (listToMaybe $ filter (test . unLoc) wcs) f + gos = mconcat . map go {- @@ -749,7 +765,8 @@ rnField fl_env doc (L l (ConDeclField names ty haddock_doc)) rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) rnContext doc (L loc cxt) - = do { (cxt', fvs) <- rnLHsTypes doc cxt + = do { traceRn (text "rncontext" <+> ppr cxt) + ; (cxt', fvs) <- mapFvRn (rnLHsPred doc) cxt ; return (L loc cxt', fvs) } {- @@ -871,7 +888,7 @@ get_op :: LHsExpr Name -> Name -- An unbound name could be either HsVar or HsUnboundVar -- See RnExpr.rnUnboundVar get_op (L _ (HsVar (L _ n))) = n -get_op (L _ (HsUnboundVar occ)) = mkUnboundName (mkRdrUnqual occ) +get_op (L _ (HsUnboundVar occ)) = mkUnboundName occ get_op other = pprPanic "get_op" (ppr other) -- Parser left-associates everything, but @@ -1037,38 +1054,53 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) pp_op | op == negateName = ptext (sLit "prefix `-'") | otherwise = quotes (ppr op) -{- -********************************************************* +{- ***************************************************** * * -\subsection{Errors} + Errors * * -********************************************************* --} +***************************************************** -} -warnUnusedForAlls :: SDoc -> LHsTyVarBndrs RdrName -> [RdrName] -> TcM () -warnUnusedForAlls in_doc bound mentioned_rdrs - = whenWOptM Opt_WarnUnusedMatches $ - mapM_ add_warn bound_but_not_used +overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc +overlappingKindVars doc kvs + = withHsDocContext doc $ + ptext (sLit "Kind variable") <> plural kvs + <+> ptext (sLit "also used as type variable") <> plural kvs + <> colon <+> pprQuotedList kvs + +badKindBndrs :: HsDocContext -> [RdrName] -> SDoc +badKindBndrs doc kvs + = withHsDocContext doc $ + hang (ptext (sLit "Unexpected kind variable") <> plural kvs + <+> pprQuotedList kvs) + 2 (ptext (sLit "Perhaps you intended to use PolyKinds")) + +badKindSigErr :: HsDocContext -> LHsType RdrName -> TcM () +badKindSigErr doc (L loc ty) + = setSrcSpan loc $ addErr $ + withHsDocContext doc $ + hang (ptext (sLit "Illegal kind signature:") <+> quotes (ppr ty)) + 2 (ptext (sLit "Perhaps you intended to use KindSignatures")) + +dataKindsErr :: RnTyKiWhat -> HsType RdrName -> SDoc +dataKindsErr what thing + = hang (ptext (sLit "Illegal") <+> pp_what <> colon <+> quotes (ppr thing)) + 2 (ptext (sLit "Perhaps you intended to use DataKinds")) where - bound_names = hsLTyVarLocNames bound - bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names + pp_what | isRnKind what = ptext (sLit "kind") + | otherwise = ptext (sLit "type") - add_warn (L loc tv) - = addWarnAt loc $ - vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv) - , in_doc ] +inTypeDoc :: HsType RdrName -> SDoc +inTypeDoc ty = ptext (sLit "In the type") <+> quotes (ppr ty) -warnContextQuantification :: SDoc -> [LHsTyVarBndr RdrName] -> TcM () -warnContextQuantification in_doc tvs - = whenWOptM Opt_WarnContextQuantification $ - mapM_ add_warn tvs +warnUnusedForAlls :: SDoc -> [LHsTyVarBndr Name] -> FreeVars -> TcM () +warnUnusedForAlls in_doc bound_names used_names + = whenWOptM Opt_WarnUnusedMatches $ + mapM_ add_warn bound_names where add_warn (L loc tv) - = addWarnAt loc $ - vcat [ ptext (sLit "Variable") <+> quotes (ppr tv) <+> - ptext (sLit "is implicitly quantified due to a context") $$ - ptext (sLit "Use explicit forall syntax instead.") $$ - ptext (sLit "This will become an error in GHC 7.12.") + = unless (hsTyVarName tv `elemNameSet` used_names) $ + addWarnAt loc $ + vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv) , in_doc ] opTyErr :: RdrName -> HsType RdrName -> SDoc @@ -1090,7 +1122,7 @@ opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty) ************************************************************************ * * Finding the free type variables of a (HsType RdrName) -* * +* * ************************************************************************ @@ -1123,18 +1155,20 @@ Hence we returns a pair (kind-vars, type vars) See also Note [HsBSig binder lists] in HsTypes -} -type FreeKiTyVars = ([RdrName], [RdrName]) +type FreeKiTyVars = ([RdrName], [RdrName]) -- (Kind vars, type vars) filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars filterInScope rdr_env (kvs, tvs) - = (filterOut in_scope kvs, filterOut in_scope tvs) - where - in_scope tv = tv `elemLocalRdrEnv` rdr_env + = (filterOut (inScope rdr_env) kvs, filterOut (inScope rdr_env) tvs) + +inScope :: LocalRdrEnv -> RdrName -> Bool +inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars -- extractHsTyRdrNames finds the free (kind, type) variables of a HsType -- or the free (sort, kind) variables of a HsKind -- It's used when making the for-alls explicit. +-- Does not return any wildcards -- See Note [Kind and type-variable binders] extractHsTyRdrTyVars ty = case extract_lty ty ([],[]) of @@ -1163,13 +1197,13 @@ extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig , dd_cons = cons, dd_derivs = derivs }) = fst $ extract_lctxt ctxt $ extract_mb extract_lkind ksig $ - extract_mb (extract_ltys . unLoc) derivs $ + extract_mb (extract_sig_tys . unLoc) derivs $ foldr (extract_con . unLoc) ([],[]) cons where extract_con (ConDecl { con_res = ResTyGADT {} }) acc = acc extract_con (ConDecl { con_res = ResTyH98, con_qvars = qvs , con_cxt = ctxt, con_details = details }) acc - = extract_hs_tv_bndrs qvs acc $ + = extract_hs_tv_bndrs (hsQTvBndrs qvs) acc $ extract_lctxt ctxt $ extract_ltys (hsConDeclArgTys details) ([],[]) @@ -1177,6 +1211,11 @@ extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars extract_lctxt ctxt = extract_ltys (unLoc ctxt) +extract_sig_tys :: [LHsSigType RdrName] -> FreeKiTyVars -> FreeKiTyVars +extract_sig_tys sig_tys acc + = foldr (\sig_ty acc -> extract_lty (hsSigType sig_ty) acc) + acc sig_tys + extract_ltys :: [LHsType RdrName] -> FreeKiTyVars -> FreeKiTyVars extract_ltys tys acc = foldr extract_lty acc tys @@ -1213,28 +1252,35 @@ extract_lty (L _ ty) acc HsTyLit _ -> acc HsWrapTy _ _ -> panic "extract_lty" HsKindSig ty ki -> extract_lty ty (extract_lkind ki acc) - HsForAllTy _ _ tvs cx ty -> extract_hs_tv_bndrs tvs acc $ - extract_lctxt cx $ + HsForAllTy { hst_bndrs = tvs, hst_body = ty } + -> extract_hs_tv_bndrs tvs acc $ extract_lty ty ([],[]) - -- We deal with these separately in rnLHsTypeWithWildCards - HsWildCardTy _ -> acc + HsQualTy { hst_ctxt = cx, hst_body = ty } + -> extract_lctxt cx (extract_lty ty acc) + HsWildCardTy {} -> acc -extract_hs_tv_bndrs :: LHsTyVarBndrs RdrName -> FreeKiTyVars +extract_hs_tv_bndrs :: [LHsTyVarBndr RdrName] -> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars -extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs }) +-- In (forall (a :: Maybe e). a -> b) we have +-- 'a' is bound by the forall +-- 'b' is a free type variable +-- 'e' is a free kind variable +extract_hs_tv_bndrs tvs (acc_kvs, acc_tvs) -- Note accumulator comes first (body_kvs, body_tvs) | null tvs = (body_kvs ++ acc_kvs, body_tvs ++ acc_tvs) | otherwise - = (acc_kvs ++ filterOut (`elem` local_kvs) body_kvs, + = (acc_kvs ++ bndr_kvs ++ body_kvs, acc_tvs ++ filterOut (`elem` local_tvs) body_tvs) where local_tvs = map hsLTyVarName tvs - (_, local_kvs) = foldr extract_lty ([], []) [k | L _ (KindedTyVar _ k) <- tvs] - -- These kind variables are bound here if not bound further out + (_, bndr_kvs) = foldr extract_lty ([], []) [k | L _ (KindedTyVar _ k) <- tvs] extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars extract_tv tv acc - | isRdrTyVar tv = case acc of (kvs,tvs) -> (kvs, tv : tvs) + | isRdrTyVar tv = add_tv tv acc | otherwise = acc + +add_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars +add_tv tv (kvs,tvs) = (kvs, tv : tvs) diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index 0d6e185ab8..47ee88cde3 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -317,7 +317,7 @@ tc_cmd _ cmd _ ptext (sLit "was found where an arrow command was expected")]) -matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercion, [TcType], TcType) +matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType) matchExpectedCmdArgs 0 ty = return (mkTcNomReflCo ty, [], ty) matchExpectedCmdArgs n ty diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index f55e643be3..d171b0c2a4 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -13,7 +13,8 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, tcVectDecls, addTypecheckedBinds, TcSigInfo(..), TcSigFun, TcPragEnv, mkPragEnv, - instTcTySig, instTcTySigFromId, findScopedTyVars, + tcUserTypeSig, instTcTySig, chooseInferredQuantifiers, + instTcTySigFromId, tcExtendTyVarEnvFromSig, badBootDeclErr, mkExport ) where import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) @@ -58,7 +59,7 @@ import BasicTypes import Outputable import FastString import Type(mkStrLitTy) -import PrelNames( gHC_PRIM ) +import PrelNames( mkUnboundName, gHC_PRIM ) import TcValidity (checkValidType) import Control.Monad @@ -209,10 +210,10 @@ tcHsBootSigs (ValBindsOut binds sigs) = do { checkTc (null binds) badBootDeclErr ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } where - tc_boot_sig (TypeSig lnames hs_ty _) = mapM f lnames + tc_boot_sig (TypeSig lnames hs_ty) = mapM f lnames where f (L _ name) - = do { sigma_ty <- tcHsSigType (FunSigCtxt name False) hs_ty + = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty ; return (mkVanillaGlobal name sigma_ty) } -- Notice that we make GlobalIds, not LocalIds tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) @@ -262,7 +263,7 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside -- Coerces a `t` into a dictionry for `IP "x" t`. -- co : t -> IP "x" t - toDict ipClass x ty = HsWrap $ mkWpCast $ TcCoercion $ + toDict ipClass x ty = HsWrap $ mkWpCastR $ TcCoercion $ wrapIP $ mkClassPred ipClass [x,ty] {- @@ -610,7 +611,7 @@ tcPolyCheck :: RecFlag -- Whether it's recursive after breaking -- it has a complete type signature, tcPolyCheck rec_tc prag_fn sig@(TISI { sig_bndr = CompleteSig poly_id - , sig_tvs = tvs_w_scoped + , sig_skols = skol_prs , sig_theta = theta , sig_tau = tau , sig_ctxt = ctxt @@ -619,14 +620,14 @@ tcPolyCheck rec_tc prag_fn = do { ev_vars <- newEvVars theta ; let skol_info = SigSkol ctxt (mkPhiTy theta tau) prag_sigs = lookupPragEnv prag_fn name - tvs = map snd tvs_w_scoped + skol_tvs = map snd skol_prs -- Find the location of the original source type sig, if -- there is was one. This will appear in messages like -- "type variable x is bound by .. at <loc>" name = idName poly_id ; (ev_binds, (binds', [mono_info])) <- setSrcSpan loc $ - checkConstraints skol_info tvs ev_vars $ + checkConstraints skol_info skol_tvs ev_vars $ tcMonoBinds rec_tc (\_ -> Just (TcIdSig sig)) LetLclBndr [bind] ; spec_prags <- tcSpecPrags poly_id prag_sigs @@ -638,7 +639,7 @@ tcPolyCheck rec_tc prag_fn , abe_mono = mono_id , abe_prags = SpecPrags spec_prags } abs_bind = L loc $ AbsBinds - { abs_tvs = tvs + { abs_tvs = skol_tvs , abs_ev_vars = ev_vars, abs_ev_binds = [ev_binds] , abs_exports = [export], abs_binds = binds' } ; return (unitBag abs_bind, [poly_id]) } @@ -655,16 +656,15 @@ tcPolyInfer -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId]) tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list - = do { ((binds', mono_infos), tclvl, wanted) + = do { (tclvl, wanted, (binds', mono_infos)) <- pushLevelAndCaptureConstraints $ tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos] - sig_qtvs = [ tv | (_, Just sig, _) <- mono_infos - , (_, tv) <- sig_tvs sig ] - ; traceTc "simplifyInfer call" (ppr name_taus $$ ppr wanted) + sigs = [ sig | (_, Just sig, _) <- mono_infos ] + ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted) ; (qtvs, givens, ev_binds) - <- simplifyInfer tclvl mono sig_qtvs name_taus wanted + <- simplifyInfer tclvl mono sigs name_taus wanted ; let inferred_theta = map evVarPred givens ; exports <- checkNoErrs $ @@ -699,41 +699,38 @@ mkExport :: TcPragEnv -- Pre-condition: the qtvs and theta are already zonked -mkExport prag_fn qtvs inferred_theta (poly_name, mb_sig, mono_id) - = do { mono_ty <- zonkTcType (idType mono_id) - - ; (poly_id, inferred) <- case mb_sig of - Nothing -> do { poly_id <- mkInferredPolyId poly_name qtvs inferred_theta mono_ty - ; return (poly_id, True) } +mkExport prag_fn qtvs theta mono_info@(poly_name, mb_sig, mono_id) + = do { mono_ty <- zonkTcType (idType mono_id) + ; poly_id <- case mb_sig of Just sig | Just poly_id <- completeIdSigPolyId_maybe sig - -> return (poly_id, False) - | otherwise - -> do { final_theta <- completeTheta inferred_theta sig - ; poly_id <- mkInferredPolyId poly_name qtvs final_theta mono_ty - ; return (poly_id, True) } + -> return poly_id + _other -> checkNoErrs $ + mkInferredPolyId qtvs theta + poly_name mb_sig mono_ty + -- The checkNoErrors ensures that if the type is ambiguous + -- we don't carry on to the impedence matching, and generate + -- a duplicate ambiguity error. There is a similar + -- checkNoErrs for complete type signatures too. -- NB: poly_id has a zonked type ; poly_id <- addInlinePrags poly_id prag_sigs ; spec_prags <- tcSpecPrags poly_id prag_sigs -- tcPrags requires a zonked poly_id - ; let sel_poly_ty = mkSigmaTy qtvs inferred_theta mono_ty - ; traceTc "mkExport: check sig" - (vcat [ ppr poly_name, ppr sel_poly_ty, ppr (idType poly_id) ]) - - -- Perform the impedance-matching and ambiguity check - -- right away. If it fails, we want to fail now (and recover - -- in tcPolyBinds). If we delay checking, we get an error cascade. - -- Remember we are in the tcPolyInfer case, so the type envt is - -- closed (unless we are doing NoMonoLocalBinds in which case all bets - -- are off) -- See Note [Impedence matching] - ; (wrap, wanted) <- addErrCtxtM (mk_bind_msg inferred True poly_name (idType poly_id)) $ - captureConstraints $ - tcSubType_NC sig_ctxt sel_poly_ty (idType poly_id) - ; ev_binds <- simplifyTop wanted - - ; return (ABE { abe_wrap = mkWpLet (EvBinds ev_binds) <.> wrap + -- NB: we have already done checkValidType on the type + -- for a complete sig, when we checked the sig; + -- otherwise in mkInferredPolyIe + ; let sel_poly_ty = mkSigmaTy qtvs theta mono_ty + poly_ty = idType poly_id + ; wrap <- if sel_poly_ty `eqType` poly_ty + then return idHsWrapper -- Fast path; also avoids complaint when we infer + -- an ambiguouse type and have AllowAmbiguousType + -- e..g infer x :: forall a. F a -> Int + else addErrCtxtM (mk_impedence_match_msg mono_info sel_poly_ty poly_ty) $ + tcSubType_NC sig_ctxt sel_poly_ty poly_ty + ; return (ABE { abe_wrap = wrap + -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty) , abe_poly = poly_id , abe_mono = mono_id , abe_prags = SpecPrags spec_prags}) } @@ -741,81 +738,119 @@ mkExport prag_fn qtvs inferred_theta (poly_name, mb_sig, mono_id) prag_sigs = lookupPragEnv prag_fn poly_name sig_ctxt = InfSigCtxt poly_name -mkInferredPolyId :: Name -> [TyVar] -> TcThetaType -> TcType -> TcM Id --- In the inference case (no signature) this stuff figures out --- the right type variables and theta to quantify over --- See Note [Validity of inferred types] -mkInferredPolyId poly_name qtvs theta mono_ty +mkInferredPolyId :: [TyVar] -> TcThetaType + -> Name -> Maybe TcIdSigInfo -> TcType + -> TcM TcId +mkInferredPolyId qtvs inferred_theta poly_name mb_sig mono_ty = do { fam_envs <- tcGetFamInstEnvs - - ; let (_co, norm_mono_ty) = normaliseType fam_envs Nominal mono_ty + ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty -- Unification may not have normalised the type, -- (see Note [Lazy flattening] in TcFlatten) so do it -- here to make it as uncomplicated as possible. -- Example: f :: [F Int] -> Bool -- should be rewritten to f :: [Char] -> Bool, if possible + -- + -- We can discard the coercion _co, becuase we'll reconstruct + -- it in the call to tcSubType below - my_tvs2 = closeOverKinds (growThetaTyVars theta (tyVarsOfType norm_mono_ty)) - -- Include kind variables! Trac #7916 - - ; my_theta <- pickQuantifiablePreds my_tvs2 theta + ; (my_tvs, theta') <- chooseInferredQuantifiers + inferred_theta (tyVarsOfType mono_ty') mb_sig - ; let my_tvs = filter (`elemVarSet` my_tvs2) qtvs -- Maintain original order - inferred_poly_ty = mkSigmaTy my_tvs my_theta norm_mono_ty + ; let qtvs' = filter (`elemVarSet` my_tvs) qtvs -- Maintain original order + ; let inferred_poly_ty = mkSigmaTy qtvs' theta' mono_ty' + msg = mk_inf_msg poly_name inferred_poly_ty - ; addErrCtxtM (mk_bind_msg True False poly_name inferred_poly_ty) $ + ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr my_tvs, ppr theta', ppr inferred_poly_ty]) + ; addErrCtxtM msg $ checkValidType (InfSigCtxt poly_name) inferred_poly_ty ; return (mkLocalId poly_name inferred_poly_ty) } -mk_bind_msg :: Bool -> Bool -> Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) -mk_bind_msg inferred want_ambig poly_name poly_ty tidy_env - = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env poly_ty - ; return (tidy_env', mk_msg tidy_ty) } - where - mk_msg ty = vcat [ ptext (sLit "When checking that") <+> quotes (ppr poly_name) - <+> ptext (sLit "has the") <+> what <+> ptext (sLit "type") - , nest 2 (ppr poly_name <+> dcolon <+> ppr ty) - , ppWhen want_ambig $ - ptext (sLit "Probable cause: the inferred type is ambiguous") ] - what | inferred = ptext (sLit "inferred") - | otherwise = ptext (sLit "specified") - - --- | Report the inferred constraints for an extra-constraints wildcard/hole as --- an error message, unless the PartialTypeSignatures flag is enabled. In this --- case, the extra inferred constraints are accepted without complaining. --- Returns the annotated constraints combined with the inferred constraints. -completeTheta :: TcThetaType -> TcIdSigInfo -> TcM TcThetaType -completeTheta inferred_theta - (TISI { sig_bndr = s_bndr - , sig_theta = annotated_theta }) - | PartialSig { sig_cts = Just loc } <- s_bndr + +chooseInferredQuantifiers :: TcThetaType -> TcTyVarSet -> Maybe TcIdSigInfo + -> TcM (TcTyVarSet, TcThetaType) +chooseInferredQuantifiers inferred_theta tau_tvs Nothing + = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs) + -- Include kind variables! Trac #7916 + + ; my_theta <- pickQuantifiablePreds free_tvs inferred_theta + ; return (free_tvs, my_theta) } + +chooseInferredQuantifiers inferred_theta tau_tvs + (Just (TISI { sig_bndr = bndr_info + , sig_ctxt = ctxt + , sig_theta = annotated_theta })) + | PartialSig { sig_cts = extra } <- bndr_info + , Nothing <- extra + = do { annotated_theta <- zonkTcThetaType annotated_theta + ; let free_tvs = closeOverKinds (tyVarsOfTypes annotated_theta + `unionVarSet` tau_tvs) + ; traceTc "ciq" (vcat [ ppr bndr_info, ppr annotated_theta, ppr free_tvs]) + ; return (free_tvs, annotated_theta) } + + | PartialSig { sig_cts = extra } <- bndr_info + , Just loc <- extra = do { annotated_theta <- zonkTcThetaType annotated_theta - ; let inferred_diff = minusList inferred_theta annotated_theta + ; let free_tvs = closeOverKinds (tyVarsOfTypes annotated_theta + `unionVarSet` tau_tvs) + ; my_theta <- pickQuantifiablePreds free_tvs inferred_theta + + -- Report the inferred constraints for an extra-constraints wildcard/hole as + -- an error message, unless the PartialTypeSignatures flag is enabled. In this + -- case, the extra inferred constraints are accepted without complaining. + -- Returns the annotated constraints combined with the inferred constraints. + ; let inferred_diff = minusList my_theta annotated_theta final_theta = annotated_theta ++ inferred_diff ; partial_sigs <- xoptM Opt_PartialTypeSignatures ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures ; msg <- mkLongErrAt loc (mk_msg inferred_diff partial_sigs) empty + ; traceTc "completeTheta" $ + vcat [ ppr bndr_info + , ppr annotated_theta, ppr inferred_theta + , ppr inferred_diff ] ; case partial_sigs of True | warn_partial_sigs -> reportWarning msg | otherwise -> return () False -> reportError msg - ; return final_theta } - | otherwise - = zonkTcThetaType annotated_theta - -- No extra-constraints wildcard means no extra constraints will be added - -- to the context, so just return the possibly empty (zonked) - -- annotated_theta. + ; return (free_tvs, final_theta) } + + | otherwise = pprPanic "chooseInferredQuantifiers" (ppr bndr_info) + where pts_hint = text "To use the inferred type, enable PartialTypeSignatures" mk_msg inferred_diff suppress_hint - = vcat [ hang ((text "Found hole") <+> quotes (char '_')) - 2 (text "with inferred constraints:") - <+> pprTheta inferred_diff + = vcat [ hang ((text "Found constraint wildcard") <+> quotes (char '_')) + 2 (text "standing for") <+> quotes (pprTheta inferred_diff) , if suppress_hint then empty else pts_hint - , typeSigCtxt s_bndr ] + , typeSigCtxt ctxt bndr_info ] + + +mk_impedence_match_msg :: MonoBindInfo + -> TcType -> TcType + -> TidyEnv -> TcM (TidyEnv, SDoc) +-- This is a rare but rather awkward error messages +mk_impedence_match_msg (name, mb_sig, _) inf_ty sig_ty tidy_env + = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env inf_ty + ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty + ; let msg = vcat [ ptext (sLit "When checking that the inferred type") + , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty + , ptext (sLit "is as general as its") <+> what <+> ptext (sLit "signature") + , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ] + ; return (tidy_env2, msg) } + where + what = case mb_sig of + Nothing -> ptext (sLit "inferred") + Just sig | isPartialSig sig -> ptext (sLit "(partial)") + | otherwise -> empty + + +mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) +mk_inf_msg poly_name poly_ty tidy_env + = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty + ; let msg = vcat [ ptext (sLit "When checking the inferred type") + , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ] + ; return (tidy_env1, msg) } {- Note [Partial type signatures and generalisation] @@ -889,7 +924,8 @@ We can get these by "impedance matching": Suppose the shared quantified tyvars are qtvs and constraints theta. Then we want to check that - f's polytype is more polymorphic than forall qtvs. theta => f_mono_ty + f's final inferred polytype is more polymorphic than + forall qtvs. theta => f_mono_ty and the proof is the impedance matcher. Notice that the impedance matcher may do defaulting. See Trac #7173. @@ -1410,7 +1446,7 @@ type MonoBindInfo = (Name, Maybe TcIdSigInfo, TcId) tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches }) | Just (TcIdSig sig) <- sig_fn name - , TISI { sig_bndr = s_bndr, sig_tau = tau } <- sig + , TISI { sig_tau = tau } <- sig = ASSERT2( case no_gen of { LetLclBndr -> True; LetGblBndr {} -> False } , ppr name ) -- { f :: ty; f x = e } is always done via CheckGen (full signature) @@ -1419,11 +1455,6 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches }) -- Both InferGen and CheckGen gives rise to LetLclBndr do { mono_name <- newLocalName name ; let mono_id = mkLocalId mono_name tau - ; case s_bndr of - PartialSig { sig_nwcs = nwcs } - -> addErrCtxt (typeSigCtxt s_bndr) $ - emitWildcardHoleConstraints nwcs - CompleteSig {} -> return () ; return (TcFunBind (name, Just sig, mono_id) nm_loc matches) } | otherwise @@ -1431,7 +1462,6 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_matches = matches }) ; mono_id <- newNoSigLetBndr no_gen name mono_ty ; return (TcFunBind (name, Nothing, mono_id) nm_loc matches) } --- TODO: emit Hole Constraints for wildcards tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss }) = do { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $ mapM lookup_info (collectPatBinders pat) @@ -1457,8 +1487,8 @@ tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind) ------------------- tcRhs :: TcMonoBind -> TcM (HsBind TcId) tcRhs (TcFunBind info@(_, mb_sig, mono_id) loc matches) - = tcExtendForRhs [info] $ - tcExtendTyVarEnv2 (lexically_scoped_tvs mb_sig) $ + = tcExtendIdBinderStackForRhs [info] $ + tcExtendTyVarEnvForRhs mb_sig $ do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) ; (co_fn, matches') <- tcMatchesFun (idName mono_id) matches (idType mono_id) @@ -1467,22 +1497,14 @@ tcRhs (TcFunBind info@(_, mb_sig, mono_id) loc matches) , fun_co_fn = co_fn , bind_fvs = placeHolderNamesTc , fun_tick = [] }) } - where - lexically_scoped_tvs :: Maybe TcIdSigInfo -> [(Name, TcTyVar)] - lexically_scoped_tvs (Just (TISI { sig_bndr = s_bndr, sig_tvs = user_tvs })) - = hole_tvs ++ [(n, tv) | (Just n, tv) <- user_tvs] - where - hole_tvs = case s_bndr of -- See RnBinds: Note [Scoping of named wildcards] - PartialSig { sig_nwcs = nwcs } -> nwcs - CompleteSig {} -> [] - lexically_scoped_tvs _ = [] +-- TODO: emit Hole Constraints for wildcards tcRhs (TcPatBind infos pat' grhss pat_ty) = -- When we are doing pattern bindings we *don't* bring any scoped -- type variables into scope unlike function bindings -- Wny not? They are not completely rigid. -- That's why we have the special case for a single FunBind in tcMonoBinds - tcExtendForRhs infos $ + tcExtendIdBinderStackForRhs infos $ do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ tcGRHSsPat grhss pat_ty @@ -1490,7 +1512,25 @@ tcRhs (TcPatBind infos pat' grhss pat_ty) , bind_fvs = placeHolderNamesTc , pat_ticks = ([],[]) }) } -tcExtendForRhs :: [MonoBindInfo] -> TcM a -> TcM a +tcExtendTyVarEnvForRhs :: Maybe TcIdSigInfo -> TcM a -> TcM a +tcExtendTyVarEnvForRhs Nothing thing_inside + = thing_inside +tcExtendTyVarEnvForRhs (Just sig) thing_inside + = tcExtendTyVarEnvFromSig sig thing_inside + +tcExtendTyVarEnvFromSig :: TcIdSigInfo -> TcM a -> TcM a +tcExtendTyVarEnvFromSig sig thing_inside + | TISI { sig_bndr = s_bndr, sig_skols = skol_prs, sig_ctxt = ctxt } <- sig + = tcExtendTyVarEnv2 skol_prs $ + case s_bndr of + CompleteSig {} -> thing_inside + PartialSig { sig_wcs = wc_prs } -- Extend the env ad emit the holes + -> tcExtendTyVarEnv2 wc_prs $ + do { addErrCtxt (typeSigCtxt ctxt s_bndr) $ + emitWildCardHoleConstraints wc_prs + ; thing_inside } + +tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a -- Extend the TcIdBinderStack for the RHS of the binding, with -- the monomorphic Id. That way, if we have, say -- f = \x -> blah @@ -1502,7 +1542,7 @@ tcExtendForRhs :: [MonoBindInfo] -> TcM a -> TcM a -- We can't unify True with [a], and a relevant binding is f :: [a] -> [a] -- If we had the *polymorphic* version of f in the TcIdBinderStack, it -- would not be reported as relevant, because its type is closed -tcExtendForRhs infos thing_inside +tcExtendIdBinderStackForRhs infos thing_inside = tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel | (_, _, mono_id) <- infos] thing_inside -- NotTopLevel: it's a monomorphic binding @@ -1608,44 +1648,38 @@ tcTySigs hs_sigs -- The returned [TcId] are the ones for which we have -- a complete type signature. -- See Note [Complete and partial type signatures] - env = mkNameEnv [(getName sig, sig) | sig <- ty_sigs] + env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs] ; return (poly_ids, lookupNameEnv env) } tcTySig :: LSig Name -> TcM [TcSigInfo] tcTySig (L _ (IdSig id)) = do { sig <- instTcTySigFromId id ; return [TcIdSig sig] } -tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty wcs)) - = setSrcSpan loc $ - pushTcLevelM_ $ -- When instantiating the signature, do so "one level in" - -- so that they can be unified under the forall - tcWildcardBinders wcs $ \ wc_prs -> - do { sigma_ty <- tcHsSigType (FunSigCtxt name1 False) hs_ty - ; mapM (do_one wc_prs sigma_ty) names } - where - extra_cts (L _ (HsForAllTy _ extra _ _ _)) = extra - extra_cts _ = Nothing - - do_one wc_prs sigma_ty (L _ name) - = do { let ctxt = FunSigCtxt name True - ; sig <- instTcTySig ctxt hs_ty sigma_ty (extra_cts hs_ty) wc_prs name - ; return (TcIdSig sig) } -tcTySig (L loc (PatSynSig (L _ name) (_, qtvs) req prov ty)) +tcTySig (L loc (TypeSig names sig_ty)) = setSrcSpan loc $ - do { traceTc "tcTySig {" $ ppr name $$ ppr qtvs $$ ppr req $$ ppr prov $$ ppr ty - ; let ctxt = PatSynCtxt name - ; tcHsTyVarBndrs qtvs $ \ qtvs' -> do - { ty' <- tcHsSigType ctxt ty - ; req' <- tcHsContext req + do { sigs <- sequence [ tcUserTypeSig sig_ty (Just name) + | L _ name <- names ] + ; return (map TcIdSig sigs) } + +tcTySig (L loc (PatSynSig (L _ name) sig_ty)) + | HsIB { hsib_kvs = sig_kvs + , hsib_tvs = sig_tvs + , hsib_body = hs_ty } <- sig_ty + , (tv_bndrs, req, prov, body_ty) <- splitLHsPatSynTy hs_ty + = setSrcSpan loc $ + tcImplicitTKBndrs sig_kvs sig_tvs $ \ _ tvs1 -> + tcHsTyVarBndrs tv_bndrs $ \ tvs2 -> + do { req' <- tcHsContext req ; prov' <- tcHsContext prov + ; ty' <- tcHsLiftedType body_ty -- These are /signatures/ so we zonk to squeeze out any kind - -- unification variables. Thta has happened automatically in tcHsSigType + -- unification variables. ToDo: checkValidType? + ; qtvs' <- mapM zonkQuantifiedTyVar (tvs1 ++ tvs2) ; req' <- zonkTcThetaType req' ; prov' <- zonkTcThetaType prov' - - ; qtvs' <- mapM zonkQuantifiedTyVar qtvs' + ; ty' <- zonkTcType ty' ; let (_, pat_ty) = tcSplitFunTys ty' univ_set = tyVarsOfType pat_ty @@ -1659,15 +1693,88 @@ tcTySig (L loc (PatSynSig (L _ name) (_, qtvs) req prov ty)) ; traceTc "tcTySig }" $ ppr (ex_tvs, prov') $$ ppr (univ_tvs, req') $$ ppr ty' ; let tpsi = TPSI{ patsig_name = name, - patsig_tau = ty', - patsig_ex = ex_tvs, + patsig_tau = ty', + patsig_ex = ex_tvs, patsig_univ = univ_tvs, patsig_prov = prov', - patsig_req = req' } - ; return [TcPatSynSig tpsi] }} + patsig_req = req' } + ; return [TcPatSynSig tpsi] } tcTySig _ = return [] +isCompleteHsSig :: LHsSigWcType Name -> Bool +-- ^ If there are no wildcards, return a LHsSigType +isCompleteHsSig sig_ty + | HsWC { hswc_wcs = wcs, hswc_ctx = extra } <- hsib_body sig_ty + , null wcs + , Nothing <- extra + = True + | otherwise + = False + +tcUserTypeSig :: LHsSigWcType Name -> Maybe Name -> TcM TcIdSigInfo +-- Just n => Function type signatre name :: type +-- Nothing => Expression type signature <expr> :: type +tcUserTypeSig hs_sig_ty mb_name + | isCompleteHsSig hs_sig_ty + = pushTcLevelM_ $ -- When instantiating the signature, do so "one level in" + -- so that they can be unified under the forall + do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty + ; (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty + ; loc <- getSrcSpanM + ; return $ + TISI { sig_bndr = CompleteSig (mkLocalId name sigma_ty) + , sig_skols = findScopedTyVars sigma_ty inst_tvs + , sig_theta = theta + , sig_tau = tau + , sig_ctxt = ctxt_T + , sig_loc = loc } } + + -- Partial sig with wildcards + | HsIB { hsib_kvs = kvs, hsib_tvs = tvs, hsib_body = wc_ty } <- hs_sig_ty + , HsWC { hswc_wcs = wcs, hswc_ctx = extra, hswc_body = hs_ty } <- wc_ty + , (hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty + = pushTcLevelM_ $ -- When instantiating the signature, do so "one level in" + -- so that they can be unified under the forall + tcImplicitTKBndrs kvs tvs $ \ kvs1 tvs1 -> + tcWildCardBinders wcs $ \ wcs -> + tcHsTyVarBndrs hs_tvs $ \ tvs2 -> + do { -- Instantiate the type-class context; but if there + -- is an extra-constraints wildcard, just discard it here + traceTc "tcPartial" (ppr name $$ ppr tvs $$ ppr tvs1 $$ ppr wcs) + ; theta <- mapM tcLHsPredType $ + case extra of + Nothing -> hs_ctxt + Just _ -> dropTail 1 hs_ctxt + + ; tau <- tcHsOpenType hs_tau + + -- Check for validity (eg rankN etc) + -- The ambiguity check will happen (from checkValidType), + -- but unnecessarily; it will always succeed becuase there + -- is no quantification + ; _ <- zonkAndCheckValidity ctxt_F (mkPhiTy theta tau) + + ; loc <- getSrcSpanM + ; return $ + TISI { sig_bndr = PartialSig { sig_name = name, sig_hs_ty = hs_ty + , sig_cts = extra, sig_wcs = wcs } + , sig_skols = [ (tyVarName tv, tv) | tv <- kvs1 ++ tvs1 ++ tvs2 ] + , sig_theta = theta + , sig_tau = tau + , sig_ctxt = ctxt_F + , sig_loc = loc } } + where + name = case mb_name of + Just n -> n + Nothing -> mkUnboundName (mkVarOcc "<expression>") + ctxt_F = case mb_name of + Just n -> FunSigCtxt n False + Nothing -> ExprSigCtxt + ctxt_T = case mb_name of + Just n -> FunSigCtxt n True + Nothing -> ExprSigCtxt + instTcTySigFromId :: Id -> TcM TcIdSigInfo -- Used for instance methods and record selectors instTcTySigFromId id @@ -1675,37 +1782,29 @@ instTcTySigFromId id loc = getSrcSpan name ; (tvs, theta, tau) <- tcInstType (tcInstSigTyVarsLoc loc) (idType id) - ; return (TISI { sig_bndr = CompleteSig id - , sig_tvs = [(Nothing, tv) | tv <- tvs] - , sig_theta = theta - , sig_tau = tau - , sig_ctxt = FunSigCtxt name False - -- Do not report redundant constraints for - -- instance methods and record selectors - , sig_loc = loc - }) } + ; return $ TISI { sig_bndr = CompleteSig id + -- False: do not report redundant constraints + -- The user has no control over the signature! + , sig_skols = [(tyVarName tv, tv) | tv <- tvs] + , sig_theta = theta + , sig_tau = tau + , sig_ctxt = FunSigCtxt name False + , sig_loc = loc } } instTcTySig :: UserTypeCtxt - -> LHsType Name + -> LHsSigType Name -- Used to get the scoped type variables -> TcType - -> Maybe SrcSpan -- Just loc <=> an extra-constraints - -- wildcard is present at location loc. - -> [(Name, TcTyVar)] -- Named wildcards -> Name -- Name of the function -> TcM TcIdSigInfo -instTcTySig ctxt hs_ty sigma_ty extra_cts nwcs name +instTcTySig ctxt hs_ty sigma_ty name = do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty - ; let bndr | isNothing extra_cts && null nwcs - = CompleteSig (mkLocalId name sigma_ty) - | otherwise - = PartialSig { sig_name = name, sig_nwcs = nwcs - , sig_cts = extra_cts, sig_hs_ty = hs_ty } - ; return (TISI { sig_bndr = bndr - , sig_tvs = findScopedTyVars hs_ty sigma_ty inst_tvs + ; return (TISI { sig_bndr = CompleteSig (mkLocalId name sigma_ty) + , sig_skols = findScopedTyVars sigma_ty inst_tvs , sig_theta = theta , sig_tau = tau , sig_ctxt = ctxt - , sig_loc = getLoc hs_ty -- SrcSpan from the signature + , sig_loc = getLoc (hsSigType hs_ty) + -- SrcSpan from the signature }) } ------------------------------- @@ -1731,18 +1830,29 @@ decideGeneralisationPlan :: DynFlags -> TcTypeEnv -> [Name] -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn - | unlifted_pat_binds = NoGen - | Just (lbind, sig) <- one_funbind_with_sig = if isPartialSig sig - -- See Note [Partial type signatures and generalisation] - then infer_plan - else CheckGen lbind sig - | mono_local_binds = NoGen - | otherwise = infer_plan + | unlifted_pat_binds = NoGen + | Just bind_sig <- one_funbind_with_sig = sig_plan bind_sig + | mono_local_binds = NoGen + | otherwise = InferGen mono_restriction where - infer_plan = InferGen mono_restriction bndr_set = mkNameSet bndr_names binds = map unLoc lbinds + sig_plan :: (LHsBind Name, TcIdSigInfo) -> GeneralisationPlan + -- See Note [Partial type signatures and generalisation] + -- We use InferGen False to say "do inference, but do not apply + -- the MR". It's stupid to apply the MR when we are given a + -- signature! C.f Trac #11016, function f2 + sig_plan (lbind, sig@(TISI { sig_bndr = s_bndr, sig_theta = theta })) + = case s_bndr of + CompleteSig {} -> CheckGen lbind sig + PartialSig { sig_cts = extra_constraints } + | Nothing <- extra_constraints + , [] <- theta + -> InferGen True -- No signature constraints: apply the MR + | otherwise + -> InferGen False -- Don't apply the MR + unlifted_pat_binds = any isUnliftedHsBind binds -- Unlifted patterns (unboxed tuple) must not -- be polymorphic, because we are going to force them @@ -1913,10 +2023,8 @@ patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Nam patMonoBindsCtxt pat grhss = hang (ptext (sLit "In a pattern binding:")) 2 (pprPatBind pat grhss) -typeSigCtxt :: TcIdSigBndr -> SDoc -typeSigCtxt (PartialSig { sig_name = n, sig_hs_ty = hs_ty }) - = vcat [ ptext (sLit "In the type signature for:") - , nest 2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty) ] -typeSigCtxt (CompleteSig id) - = vcat [ ptext (sLit "In the type signature for:") - , nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id)) ] +typeSigCtxt :: UserTypeCtxt -> TcIdSigBndr -> SDoc +typeSigCtxt ctxt (PartialSig { sig_hs_ty = hs_ty }) + = pprSigCtxt ctxt empty (ppr hs_ty) +typeSigCtxt ctxt (CompleteSig id) + = pprSigCtxt ctxt empty (ppr (idType id)) diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index 8be4cf6e13..8e6007b97d 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -20,7 +20,7 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2, import HsSyn import TcEnv -import TcPat( addInlinePrags, completeIdSigPolyId, lookupPragEnv, emptyPragEnv ) +import TcPat( addInlinePrags, lookupPragEnv, emptyPragEnv ) import TcEvidence( idHsWrapper ) import TcBinds import TcUnify @@ -122,14 +122,16 @@ tcClassSigs clas sigs def_methods ; traceTc "tcClassSigs 2" (ppr clas) ; return op_info } where - vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty _) <- sigs] - gen_sigs = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs] + vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig False nm ty) <- sigs] + gen_sigs = [L loc (nm,ty) | L loc (ClassOpSig True nm ty) <- sigs] dm_bind_names :: [Name] -- These ones have a value binding in the class decl dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] + tc_sig :: NameEnv Type -> ([Located Name], LHsSigType Name) + -> TcM [TcMethInfo] tc_sig gen_dm_env (op_names, op_hs_ty) = do { traceTc "ClsSig 1" (ppr op_names) - ; op_ty <- tcClassSigType op_hs_ty -- Class tyvars already in scope + ; op_ty <- tcClassSigType op_names op_hs_ty -- Class tyvars already in scope ; traceTc "ClsSig 2" (ppr op_names) ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] } where @@ -138,7 +140,7 @@ tcClassSigs clas sigs def_methods | otherwise = Nothing tc_gen_sig (op_names, gen_hs_ty) - = do { gen_op_ty <- tcClassSigType gen_hs_ty + = do { gen_op_ty <- tcClassSigType op_names gen_hs_ty ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] } {- @@ -239,7 +241,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn ctxt = FunSigCtxt sel_name warn_redundant - ; local_dm_sig <- instTcTySig ctxt hs_ty local_dm_ty Nothing [] local_dm_name + ; local_dm_sig <- instTcTySig ctxt hs_ty local_dm_ty local_dm_name ; (ev_binds, (tc_bind, _)) <- checkConstraints (ClsSkol clas) tyvars [this_dict] $ tcPolyCheck NonRecursive no_prag_fn local_dm_sig @@ -312,17 +314,17 @@ instantiateMethod clas sel_id inst_tys --------------------------- -type HsSigFun = NameEnv (LHsType Name) +type HsSigFun = NameEnv (LHsSigType Name) emptyHsSigs :: HsSigFun emptyHsSigs = emptyNameEnv mkHsSigFun :: [LSig Name] -> HsSigFun mkHsSigFun sigs = mkNameEnv [(n, hs_ty) - | L _ (TypeSig ns hs_ty _) <- sigs + | L _ (ClassOpSig False ns hs_ty) <- sigs , L _ n <- ns ] -lookupHsSig :: HsSigFun -> Name -> Maybe (LHsType Name) +lookupHsSig :: HsSigFun -> Name -> Maybe (LHsSigType Name) lookupHsSig = lookupNameEnv --------------------------- diff --git a/compiler/typecheck/TcDefaults.hs b/compiler/typecheck/TcDefaults.hs index c9ce0f6366..62325a0b54 100644 --- a/compiler/typecheck/TcDefaults.hs +++ b/compiler/typecheck/TcDefaults.hs @@ -62,7 +62,7 @@ tcDefaults decls@(L locn (DefaultDecl _) : _) tc_default_ty :: [Class] -> LHsType Name -> TcM Type tc_default_ty deflt_clss hs_ty - = do { ty <- tcHsSigType DefaultDeclCtxt hs_ty + = do { ty <- tcHsLiftedType hs_ty ; checkTc (isTauTy ty) (polyDefErr hs_ty) -- Check that the type is an instance of at least one of the deflt_clss diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 707195ea6b..9944831b4c 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -339,7 +339,7 @@ both of them. So we gather defs/uses from deriving just like anything else. data DerivInfo = DerivInfo { di_rep_tc :: TyCon -- ^ The data tycon for normal datatypes, -- or the *representation* tycon for data families - , di_preds :: [LHsType Name] + , di_preds :: [LHsSigType Name] , di_ctxt :: SDoc -- ^ error context } @@ -483,6 +483,7 @@ renameDeriv is_boot inst_infos bagBinds do { -- Bring the extra deriving stuff into scope -- before renaming the instances themselves + ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)) ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds ; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs) ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds @@ -602,7 +603,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode)) = setSrcSpan loc $ addErrCtxt (standaloneCtxt deriv_ty) $ do { traceTc "Standalone deriving decl for" (ppr deriv_ty) - ; (tvs, theta, cls, inst_tys) <- tcHsInstHead TcType.InstDeclCtxt deriv_ty + ; (tvs, theta, cls, inst_tys) <- tcHsClsInstType TcType.InstDeclCtxt deriv_ty ; traceTc "Standalone deriving;" $ vcat [ text "tvs:" <+> ppr tvs , text "theta:" <+> ppr theta @@ -645,12 +646,12 @@ warnUselessTypeable ------------------------------------------------------------------ deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance -- Can be a data instance, hence [Type] args - -> LHsType Name -- The deriving predicate + -> LHsSigType Name -- The deriving predicate -> TcM [EarlyDerivSpec] -- The deriving clause of a data or newtype declaration -- I.e. not standalone deriving -deriveTyData tvs tc tc_args (L loc deriv_pred) - = setSrcSpan loc $ -- Use the location of the 'deriving' item +deriveTyData tvs tc tc_args deriv_pred + = setSrcSpan (getLoc (hsSigType deriv_pred)) $ -- Use loc of the 'deriving' item do { (deriv_tvs, cls, cls_tys, cls_arg_kind) <- tcExtendTyVarEnv tvs $ tcHsDeriv deriv_pred @@ -1967,12 +1968,12 @@ genInst comauxs ; return ( InstInfo { iSpec = inst_spec , iBinds = InstBindings - { ib_binds = gen_Newtype_binds loc clas tvs tys rhs_ty - , ib_tyvars = map Var.varName tvs -- Scope over bindings - , ib_pragmas = [] + { ib_binds = gen_Newtype_binds loc clas tvs tys rhs_ty + , ib_tyvars = map Var.varName tvs -- Scope over bindings + , ib_pragmas = [] , ib_extensions = [ Opt_ImpredicativeTypes , Opt_RankNTypes ] - , ib_derived = True } } + , ib_derived = True } } , emptyBag , Just $ getName $ head $ tyConDataCons rep_tycon ) } -- See Note [Newtype deriving and unused constructors] @@ -2145,7 +2146,7 @@ derivingHiddenErr tc = hang (ptext (sLit "The data constructors of") <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope")) 2 (ptext (sLit "so you cannot derive an instance for it")) -standaloneCtxt :: LHsType Name -> SDoc +standaloneCtxt :: LHsSigType Name -> SDoc standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) 2 (quotes (ppr ty)) diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 4bf83b5f31..368fd178a8 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -686,20 +686,24 @@ as well as explicit user written ones. -} data InstInfo a - = InstInfo { - iSpec :: ClsInst, -- Includes the dfun id. Its forall'd type - iBinds :: InstBindings a -- variables scope over the stuff in InstBindings! - } + = InstInfo + { iSpec :: ClsInst -- Includes the dfun id + , iBinds :: InstBindings a + } iDFunId :: InstInfo a -> DFunId iDFunId info = instanceDFunId (iSpec info) data InstBindings a = InstBindings - { ib_tyvars :: [Name] -- Names of the tyvars from the instance head - -- that are lexically in scope in the bindings + { ib_tyvars :: [Name] -- Names of the tyvars from the instance head + -- that are lexically in scope in the bindings + -- Must correspond 1-1 with the forall'd tyvars + -- of the dfun Id. When typechecking, we are + -- going to extend the typechecker's envt with + -- ib_tyvars -> dfun_forall_tyvars - , ib_binds :: (LHsBinds a) -- Bindings for the instance methods + , ib_binds :: LHsBinds a -- Bindings for the instance methods , ib_pragmas :: [LSig a] -- User pragmas recorded for generating -- specialised instances @@ -851,16 +855,9 @@ pprBinders bndrs = pprWithCommas ppr bndrs notFound :: Name -> TcM TyThing notFound name = do { lcl_env <- getLclEnv - ; namedWildCardsEnabled <- xoptM Opt_NamedWildCards ; let stage = tcl_th_ctxt lcl_env - isWildCard = case getOccString name of - ('_':_:_) | namedWildCardsEnabled -> True - "_" -> True - _ -> False ; case stage of -- See Note [Out of scope might be a staging error] Splice {} -> stageRestrictionError (quotes (ppr name)) - _ | isWildCard -> failWithTc $ - text "Unexpected wild card:" <+> quotes (ppr name) _ -> failWithTc $ vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> ptext (sLit "is not in scope during type checking, but it passed the renamer"), diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 14885e74eb..156b1ff3e7 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -400,7 +400,7 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl -- type checking to get a Lint error later report1 = [ ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter) - , ("insoluble1", is_given, True, mkGroupReporter mkEqErr) + , ("insoluble1", is_given_eq, True, mkGroupReporter mkEqErr) , ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr) , ("insoluble3", rigid_nom_tv_eq, True, mkSkolReporter) , ("insoluble4", rigid_nom_eq, True, mkGroupReporter mkEqErr) @@ -424,8 +424,13 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl is_out_of_scope ct _ = isOutOfScopeCt ct is_hole ct _ = isHoleCt ct + + is_given_eq ct pred + | EqPred {} <- pred = arisesFromGivens ct + | otherwise = False + -- I think all given residuals are equalities + is_user_type_error ct _ = isUserTypeErrorCt ct - is_given ct _ = not (isWantedCt ct) -- The Derived ones are actually all from Givens -- Skolem (i.e. non-meta) type variable on the left rigid_nom_eq _ pred = isRigidEqPred tc_lvl pred @@ -531,9 +536,9 @@ reportGroup mk_err ctxt cts = maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM () maybeReportHoleError ctxt ct err -- When -XPartialTypeSignatures is on, warnings (instead of errors) are - -- generated for holes in partial type signatures. Unless - -- -fwarn_partial_type_signatures is not on, in which case the messages are - -- discarded. + -- generated for holes in partial type signatures. + -- Unless -fwarn_partial_type_signatures is not on, + -- in which case the messages are discarded. | isTypeHoleCt ct = -- For partial type signatures, generate warnings only, and do that -- only if -fwarn_partial_type_signatures is on @@ -553,14 +558,17 @@ maybeReportHoleError ctxt ct err maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM () -- Report the error and/or make a deferred binding for it maybeReportError ctxt err + | cec_suppress ctxt -- Some worse error has occurred; + = return () -- so suppress this error/warning + | cec_errors_as_warns ctxt = reportWarning err + | otherwise = case cec_defer_type_errors ctxt of - TypeDefer -> return () - TypeWarn -> reportWarning err - -- handle case when suppress is on like in the original code - TypeError -> if cec_suppress ctxt then return () else reportError err + TypeDefer -> return () + TypeWarn -> reportWarning err + TypeError -> reportError err addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () -- See Note [Deferring coercion errors to runtime] @@ -827,11 +835,9 @@ mkHoleError ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort }) loc_msg tv = case tcTyVarDetails tv of - SkolemTv {} -> quotes (ppr tv) <+> skol_msg + SkolemTv {} -> pprSkol (cec_encl ctxt) tv MetaTv {} -> quotes (ppr tv) <+> ptext (sLit "is an ambiguous type variable") det -> pprTcTyVarDetails det - where - skol_msg = pprSkol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv) mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct) @@ -887,9 +893,8 @@ mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct mkEqErr _ [] = panic "mkEqErr" mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg --- Wanted constraints only! mkEqErr1 ctxt ct - | isGivenCt ct + | arisesFromGivens ct = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct ; let (given_loc, given_msg) = mk_given (ctLoc ct) (cec_encl ctxt) ; dflags <- getDynFlags @@ -1221,7 +1226,7 @@ extraTyVarInfo ctxt tv1 ty2 tv_extra tv | isTcTyVar tv, isSkolemTyVar tv , let pp_tv = quotes (ppr tv) = case tcTyVarDetails tv of - SkolemTv {} -> pp_tv <+> pprSkol (getSkolemInfo implics tv) (getSrcLoc tv) + SkolemTv {} -> pprSkol implics tv FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable") RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem") MetaTv {} -> empty @@ -1242,7 +1247,7 @@ suggestAddSig ctxt ty1 ty2 inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2) get_inf ty | Just tv <- tcGetTyVar_maybe ty , isTcTyVar tv, isSkolemTyVar tv - , InferSkol prs <- getSkolemInfo (cec_encl ctxt) tv + , (_, InferSkol prs) <- getSkolemInfo (cec_encl ctxt) tv = map fst prs | otherwise = [] @@ -1981,28 +1986,34 @@ mkAmbigMsg prepend_msg ct | gopt Opt_PrintExplicitKinds dflags = empty | otherwise = ptext (sLit "Use -fprint-explicit-kinds to see the kind arguments") +pprSkol :: [Implication] -> TcTyVar -> SDoc +pprSkol implics tv + | (skol_tvs, skol_info) <- getSkolemInfo implics tv + = case skol_info of + UnkSkol -> pp_tv <+> ptext (sLit "is an unknown type variable") + SigSkol ctxt ty -> ppr_rigid (pprSigSkolInfo ctxt (mkForAllTys skol_tvs ty)) + _ -> ppr_rigid (pprSkolInfo skol_info) + where + pp_tv = quotes (ppr tv) + ppr_rigid pp_info = hang (pp_tv <+> ptext (sLit "is a rigid type variable bound by")) + 2 (sep [ pp_info + , ptext (sLit "at") <+> ppr (getSrcLoc tv) ]) + getAmbigTkvs :: Ct -> [Var] getAmbigTkvs ct = varSetElems ambig_tkv_set where ambig_tkv_set = filterVarSet isAmbiguousTyVar (tyVarsOfCt ct) - -pprSkol :: SkolemInfo -> SrcLoc -> SDoc -pprSkol UnkSkol _ - = ptext (sLit "is an unknown type variable") -pprSkol skol_info tv_loc - = sep [ ptext (sLit "is a rigid type variable bound by"), - sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]] - -getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo +getSkolemInfo :: [Implication] -> TcTyVar -> ([TcTyVar], SkolemInfo) -- Get the skolem info for a type variable -- from the implication constraint that binds it getSkolemInfo [] tv = pprPanic "No skolem info:" (ppr tv) getSkolemInfo (implic:implics) tv - | tv `elem` ic_skols implic = ic_info implic + | let skols = ic_skols implic + , tv `elem` ic_skols implic = (skols, ic_info implic) | otherwise = getSkolemInfo implics tv ----------------------- diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index 98db87fed3..18f162256d 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -6,7 +6,8 @@ module TcEvidence ( -- HsWrapper HsWrapper(..), - (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpLams, mkWpLet, mkWpCast, + (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, + mkWpLams, mkWpLet, mkWpCastN, mkWpCastR, mkWpFun, idHsWrapper, isIdHsWrapper, pprHsWrapper, -- Evidence bindings @@ -203,7 +204,7 @@ mkTcTyConAppCo role tc cos -- No need to expand type synonyms -- Input coercion is Nominal -- mkSubCo will do some normalisation. We do not do it for TcCoercions, but -- defer that to desugaring; just to reduce the code duplication a little bit -mkTcSubCo :: TcCoercion -> TcCoercion +mkTcSubCo :: TcCoercionN -> TcCoercionR mkTcSubCo (TcRefl _ ty) = TcRefl Representational ty mkTcSubCo co @@ -258,12 +259,11 @@ mkTcAxInstCo role ax index tys arg_roles = coAxBranchRoles branch rtys = zipWith mkTcReflCo (arg_roles ++ repeat Nominal) tys -mkTcAxiomRuleCo :: CoAxiomRule -> [TcType] -> [TcCoercion] -> TcCoercion +mkTcAxiomRuleCo :: CoAxiomRule -> [TcType] -> [TcCoercion] -> TcCoercionR mkTcAxiomRuleCo = TcAxiomRuleCo -mkTcUnbranchedAxInstCo :: Role -> CoAxiom Unbranched -> [TcType] -> TcCoercion -mkTcUnbranchedAxInstCo role ax tys - = mkTcAxInstCo role ax 0 tys +mkTcUnbranchedAxInstCo :: CoAxiom Unbranched -> [TcType] -> TcCoercionR +mkTcUnbranchedAxInstCo ax tys = mkTcAxInstCo Representational ax 0 tys mkTcAppCo :: TcCoercion -> TcCoercion -> TcCoercion -- No need to deal with TyConApp on the left; see Note [TcCoercions] @@ -570,7 +570,7 @@ data HsWrapper -- This isn't the same as for mkTcFunCo, but it has to be this way -- because we can't use 'sym' to flip around these HsWrappers - | WpCast TcCoercion -- A cast: [] `cast` co + | WpCast TcCoercionR -- A cast: [] `cast` co -- Guaranteed not the identity coercion -- At role Representational @@ -601,12 +601,19 @@ mkWpFun (WpCast co1) WpHole _ t2 = WpCast (mkTcFunCo Representational (mk mkWpFun (WpCast co1) (WpCast co2) _ _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2) mkWpFun co1 co2 t1 t2 = WpFun co1 co2 t1 t2 -mkWpCast :: TcCoercion -> HsWrapper -mkWpCast co +mkWpCastR :: TcCoercionR -> HsWrapper +mkWpCastR co | isTcReflCo co = WpHole | otherwise = ASSERT2(tcCoercionRole co == Representational, ppr co) WpCast co +mkWpCastN :: TcCoercionN -> HsWrapper +mkWpCastN co + | isTcReflCo co = WpHole + | otherwise = ASSERT2(tcCoercionRole co == Nominal, ppr co) + WpCast (mkTcSubCo co) + -- The mkTcSubCo converts Nominal to Representational + mkWpTyApps :: [Type] -> HsWrapper mkWpTyApps tys = mk_co_app_fn WpTyApp tys @@ -1156,7 +1163,7 @@ instance Outputable EvTypeable where -- and return a 'Coercion' `co :: IP sym ty ~ ty` or -- `co :: IsLabel sym ty ~ Proxy# sym -> ty`. See also -- Note [Type-checking overloaded labels] in TcExpr. -unwrapIP :: Type -> Coercion +unwrapIP :: Type -> CoercionR unwrapIP ty = case unwrapNewTyCon_maybe tc of Just (_,_,ax) -> mkUnbranchedAxInstCo Representational ax tys @@ -1168,5 +1175,5 @@ unwrapIP ty = -- | Create a 'Coercion' that wraps a value in an implicit-parameter -- dictionary. See 'unwrapIP'. -wrapIP :: Type -> Coercion +wrapIP :: Type -> CoercionR wrapIP ty = mkSymCo (unwrapIP ty) diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 2f26c646a1..26e920ead9 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -26,7 +26,9 @@ import TcRnMonad import TcUnify import BasicTypes import Inst -import TcBinds +import TcBinds ( chooseInferredQuantifiers, tcLocalBinds + , tcUserTypeSig, tcExtendTyVarEnvFromSig ) +import TcSimplify ( simplifyInfer ) import FamInst ( tcGetFamInstEnvs, tcLookupDataFamInst ) import FamInstEnv ( FamInstEnvs ) import RnEnv ( addUsedGRE, addNameClashErrRn @@ -211,7 +213,7 @@ tcExpr (HsIPVar x) res_ty ip_ty res_ty } where -- Coerces a dictionary for `IP "x" t` into `t`. - fromDict ipClass x ty = HsWrap $ mkWpCast $ TcCoercion $ + fromDict ipClass x ty = HsWrap $ mkWpCastR $ TcCoercion $ unwrapIP $ mkClassPred ipClass [x,ty] tcExpr (HsOverLabel l) res_ty -- See Note [Type-checking overloaded labels] @@ -228,7 +230,7 @@ tcExpr (HsOverLabel l) res_ty -- See Note [Type-checking overloaded labels] ; tcWrapResult tm alpha res_ty } where -- Coerces a dictionary for `IsLabel "x" t` into `Proxy# x -> t`. - fromDict pred = HsWrap $ mkWpCast $ TcCoercion $ unwrapIP pred + fromDict pred = HsWrap $ mkWpCastR $ TcCoercion $ unwrapIP pred tcExpr (HsLam match) res_ty = do { (co_fn, match') <- tcMatchLambda match res_ty @@ -242,25 +244,14 @@ tcExpr e@(HsLamCase _ matches) res_ty , ptext (sLit "requires")] match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } -tcExpr (ExprWithTySig expr sig_ty wcs) res_ty - = tcWildcardBinders wcs $ \ wc_prs -> - do { addErrCtxt (pprSigCtxt ExprSigCtxt empty (ppr sig_ty)) $ - emitWildcardHoleConstraints wc_prs - ; sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty - ; (gen_fn, expr') - <- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty -> - - -- Remember to extend the lexical type-variable environment - -- See Note [More instantiated than scoped] in TcBinds - tcExtendTyVarEnv2 - [(n,tv) | (Just n, tv) <- findScopedTyVars sig_ty sig_tc_ty skol_tvs] $ - - tcMonoExprNC expr res_ty - - ; let inner_expr = ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty - - ; (inst_wrap, rho) <- deeplyInstantiate ExprSigOrigin sig_tc_ty - ; tcWrapResult (mkHsWrap inst_wrap inner_expr) rho res_ty } +tcExpr (ExprWithTySig expr sig_ty) res_ty + = do { sig_info <- checkNoErrs $ -- Avoid error cascade + tcUserTypeSig sig_ty Nothing + ; (expr', poly_ty) <- tcExprSig expr sig_info + ; (inst_wrap, rho) <- deeplyInstantiate ExprSigOrigin poly_ty + ; let expr'' = mkHsWrap inst_wrap $ + ExprWithTySigOut expr' sig_ty + ; tcWrapResult expr'' rho res_ty } tcExpr (HsType ty) _ = failWithTc (text "Can't handle type argument:" <+> ppr ty) @@ -703,7 +694,6 @@ In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys): Note [Mixed Record Field Updates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Consider the following pattern synonym. data MyRec = MyRec { foo :: Int, qux :: String } @@ -737,10 +727,12 @@ following. tcExpr (RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty = ASSERT( notNull rbnds ) - do { + do { -- STEP -2: typecheck the record_expr, the record to bd updated + (record_expr', record_tau) <- tcInferFun record_expr + -- STEP -1 See Note [Disambiguating record fields] -- After this we know that rbinds is unambiguous - rbinds <- disambiguateRecordBinds record_expr rbnds res_ty + ; rbinds <- disambiguateRecordBinds record_expr record_tau rbnds res_ty ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds sel_ids = map selectorAmbiguousFieldOcc upd_flds @@ -766,20 +758,22 @@ tcExpr (RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty -- Figure out the tycon and data cons from the first field name ; let -- It's OK to use the non-tc splitters here (for a selector) sel_id : _ = sel_ids - mtycon = - case idDetails sel_id of - RecSelId (RecSelData tycon) _ -> Just tycon - _ -> Nothing - con_likes = - case idDetails sel_id of - RecSelId (RecSelData tc) _ -> - map RealDataCon (tyConDataCons tc) - RecSelId (RecSelPatSyn ps) _ -> - [PatSynCon ps] - _ -> panic "tcRecordUpd" + + mtycon :: Maybe TyCon + mtycon = case idDetails sel_id of + RecSelId (RecSelData tycon) _ -> Just tycon + _ -> Nothing + + con_likes :: [ConLike] + con_likes = case idDetails sel_id of + RecSelId (RecSelData tc) _ + -> map RealDataCon (tyConDataCons tc) + RecSelId (RecSelPatSyn ps) _ + -> [PatSynCon ps] + _ -> panic "tcRecordUpd" -- NB: for a data type family, the tycon is the instance tycon - relevant_cons = conLikesWithFields con_likes upd_fld_occs + relevant_cons = conLikesWithFields con_likes upd_fld_occs -- A constructor is only relevant to this process if -- it contains *all* the fields that are being updated -- Other ones will cause a runtime error if they occur @@ -791,12 +785,13 @@ tcExpr (RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty -- Take apart a representative constructor ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons - (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _) = - conLikeFullSig con1 - con1_flds = map flLabel $ conLikeFieldLabels con1 - def_res_ty = conLikeResTy con1 - con1_res_ty = - (maybe def_res_ty mkFamilyTyConApp mtycon) (mkTyVarTys con1_tvs) + (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _) + = conLikeFullSig con1 + con1_flds = map flLabel $ conLikeFieldLabels con1 + con1_tv_tys = mkTyVarTys con1_tvs + con1_res_ty = case mtycon of + Just tc -> mkFamilyTyConApp tc con1_tv_tys + Nothing -> conLikeResTy con1 con1_tv_tys -- Check that we're not dealing with a unidirectional pattern -- synonym @@ -843,22 +838,25 @@ tcExpr (RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty scrut_ty = TcType.substTy scrut_subst con1_res_ty con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys - ; co_res <- unifyType rec_res_ty res_ty + ; co_res <- unifyType rec_res_ty res_ty + ; co_scrut <- unifyType record_tau scrut_ty -- STEP 5 - -- Typecheck the thing to be updated, and the bindings - ; record_expr' <- tcMonoExpr record_expr scrut_ty + -- Typecheck the bindings ; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds -- STEP 6: Deal with the stupid theta ; let theta' = substTheta scrut_subst (conLikeStupidTheta con1) ; instStupidTheta RecordUpdOrigin theta' - -- Step 7: make a cast for the scrutinee, in the case that it's from a type family - ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe =<< mtycon - = mkWpCast (mkTcUnbranchedAxInstCo Representational co_con scrut_inst_tys) - | otherwise - = idHsWrapper + -- Step 7: make a cast for the scrutinee, in the + -- case that it's from a data family + ; let fam_co :: HsWrapper -- RepT t1 .. tn ~R scrut_ty + fam_co | Just tycon <- mtycon + , Just co_con <- tyConFamilyCoercion_maybe tycon + = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys) + | otherwise + = idHsWrapper -- Step 8: Check that the req constraints are satisfied -- For normal data constructors req_theta is empty but we must do @@ -868,7 +866,7 @@ tcExpr (RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty -- Phew! ; return $ mkHsWrapCo co_res $ - RecordUpd { rupd_expr = mkLHsWrap scrut_co record_expr' + RecordUpd { rupd_expr = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr') , rupd_flds = rbinds' , rupd_cons = relevant_cons, rupd_in_tys = scrut_inst_tys , rupd_out_tys = result_inst_tys, rupd_wrap = req_wrap } } @@ -1024,7 +1022,7 @@ tcApp (L loc (HsVar (L _ fun))) args res_ty -- with type signatures, see Note [Disambiguating record fields] tcApp (L loc (HsRecFld (Ambiguous lbl _))) args@(L _ arg:_) res_ty | Just sig_ty <- obviousSig arg - = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty + = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty ; sel_name <- disambiguateSelector lbl sig_tc_ty ; tcApp (L loc (HsRecFld (Unambiguous lbl sel_name))) args res_ty } @@ -1152,10 +1150,68 @@ in the other order, the extra signature in f2 is reqd. ************************************************************************ * * + Expressions with a type signature + expr :: type +* * +********************************************************************* -} + +tcExprSig :: LHsExpr Name -> TcIdSigInfo -> TcM (LHsExpr TcId, TcType) +tcExprSig expr sig@(TISI { sig_bndr = s_bndr + , sig_skols = skol_prs + , sig_theta = theta + , sig_tau = tau }) + | null skol_prs -- Fast path when there is no quantification at all + , null theta + , CompleteSig {} <- s_bndr + = do { expr' <- tcPolyExprNC expr tau + ; return (expr', tau) } + + | CompleteSig poly_id <- s_bndr + = do { given <- newEvVars theta + ; (ev_binds, expr') <- checkConstraints skol_info skol_tvs given $ + tcExtendTyVarEnvFromSig sig $ + tcPolyExprNC expr tau + + ; let poly_wrap = mkWpTyLams skol_tvs + <.> mkWpLams given + <.> mkWpLet ev_binds + ; return (mkLHsWrap poly_wrap expr', idType poly_id) } + + | PartialSig { sig_name = name } <- s_bndr + = do { (tclvl, wanted, expr') <- pushLevelAndCaptureConstraints $ + tcExtendTyVarEnvFromSig sig $ + tcPolyExprNC expr tau + ; (qtvs, givens, ev_binds) + <- simplifyInfer tclvl False [sig] [(name, tau)] wanted + ; tau <- zonkTcType tau + ; let inferred_theta = map evVarPred givens + tau_tvs = tyVarsOfType tau + ; (my_tv_set, my_theta) <- chooseInferredQuantifiers inferred_theta tau_tvs (Just sig) + ; let my_tvs = filter (`elemVarSet` my_tv_set) qtvs -- Maintain original order + inferred_sigma = mkSigmaTy qtvs inferred_theta tau + my_sigma = mkSigmaTy my_tvs my_theta tau + ; wrap <- if inferred_sigma `eqType` my_sigma + then return idHsWrapper -- Fast path; also avoids complaint when we infer + -- an ambiguouse type and have AllowAmbiguousType + -- e..g infer x :: forall a. F a -> Int + else tcSubType_NC ExprSigCtxt inferred_sigma my_sigma + + ; let poly_wrap = wrap + <.> mkWpTyLams qtvs + <.> mkWpLams givens + <.> mkWpLet ev_binds + ; return (mkLHsWrap poly_wrap expr', mkSigmaTy qtvs theta tau) } + + | otherwise = panic "tcExprSig" -- Can't happen + where + skol_info = SigSkol ExprSigCtxt (mkPhiTy theta tau) + skol_tvs = map snd skol_prs + +{- ********************************************************************* +* * tcInferId * * -************************************************************************ --} +********************************************************************* -} tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId) tcCheckId name res_ty @@ -1474,7 +1530,6 @@ getFixedTyVars upd_fld_occs univ_tvs cons {- Note [Disambiguating record fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - When the -XDuplicateRecordFields extension is used, and the renamer encounters a record selector or update that it cannot immediately disambiguate (because it involves fields that belong to multiple @@ -1589,9 +1644,10 @@ ambiguousSelector rdr -- Disambiguate the fields in a record update. -- See Note [Disambiguating record fields] -disambiguateRecordBinds :: LHsExpr Name -> [LHsRecUpdField Name] -> Type - -> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] -disambiguateRecordBinds record_expr rbnds res_ty +disambiguateRecordBinds :: LHsExpr Name -> TcType + -> [LHsRecUpdField Name] -> Type + -> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] +disambiguateRecordBinds record_expr record_tau rbnds res_ty -- Are all the fields unambiguous? = case mapM isUnambiguous rbnds of -- If so, just skip to looking up the Ids @@ -1628,18 +1684,20 @@ disambiguateRecordBinds record_expr rbnds res_ty = case foldr1 intersect possible_parents of -- No parents for all fields: record update is ill-typed [] -> failWithTc (noPossibleParents rbnds) + -- Exactly one datatype with all the fields: use that [p] -> return p + -- Multiple possible parents: try harder to disambiguate -- Can we get a parent TyCon from the pushed-in type? _:_ | Just p <- tyConOf fam_inst_envs res_ty -> return (RecSelData p) + -- Does the expression being updated have a type signature? -- If so, try to extract a parent TyCon from it - | Just sig_ty <- obviousSig (unLoc record_expr) - -> do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty - ; case tyConOf fam_inst_envs sig_tc_ty of - Just p -> return (RecSelData p) - Nothing -> failWithTc badOverloadedUpdate } + | Just {} <- obviousSig (unLoc record_expr) + , Just tc <- tyConOf fam_inst_envs record_tau + -> return (RecSelData tc) + -- Nothing else we can try... _ -> failWithTc badOverloadedUpdate @@ -1704,10 +1762,10 @@ lookupParents rdr -- A type signature on the argument of an ambiguous record selector or -- the record expression in an update must be "obvious", i.e. the -- outermost constructor ignoring parentheses. -obviousSig :: HsExpr Name -> Maybe (LHsType Name) -obviousSig (ExprWithTySig _ ty _) = Just ty -obviousSig (HsPar p) = obviousSig (unLoc p) -obviousSig _ = Nothing +obviousSig :: HsExpr Name -> Maybe (LHsSigWcType Name) +obviousSig (ExprWithTySig _ ty) = Just ty +obviousSig (HsPar p) = obviousSig (unLoc p) +obviousSig _ = Nothing {- diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs index 45b6479676..897f5d6c6f 100644 --- a/compiler/typecheck/TcForeign.hs +++ b/compiler/typecheck/TcForeign.hs @@ -65,13 +65,13 @@ import Control.Monad -- Defines a binding isForeignImport :: LForeignDecl name -> Bool -isForeignImport (L _ (ForeignImport _ _ _ _)) = True -isForeignImport _ = False +isForeignImport (L _ (ForeignImport {})) = True +isForeignImport _ = False -- Exports a binding isForeignExport :: LForeignDecl name -> Bool -isForeignExport (L _ (ForeignExport _ _ _ _)) = True -isForeignExport _ = False +isForeignExport (L _ (ForeignExport {})) = True +isForeignExport _ = False {- Note [Don't recur in normaliseFfiType'] @@ -234,7 +234,8 @@ tcForeignImports' decls ; return (ids, decls, unionManyBags gres) } tcFImport :: LForeignDecl Name -> TcM (Id, LForeignDecl Id, Bag GlobalRdrElt) -tcFImport (L dloc fo@(ForeignImport (L nloc nm) hs_ty _ imp_decl)) +tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty + , fd_fi = imp_decl })) = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo) $ do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty @@ -251,7 +252,10 @@ tcFImport (L dloc fo@(ForeignImport (L nloc nm) hs_ty _ imp_decl)) ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl -- Can't use sig_ty here because sig_ty :: Type and -- we need HsType Id hence the undefined - ; let fi_decl = ForeignImport (L nloc id) undefined (mkSymCo norm_co) imp_decl' + ; let fi_decl = ForeignImport { fd_name = L nloc id + , fd_sig_ty = undefined + , fd_co = mkSymCo norm_co + , fd_fi = imp_decl' } ; return (id, L dloc fi_decl, gres) } tcFImport d = pprPanic "tcFImport" (ppr d) @@ -371,7 +375,7 @@ tcForeignExports' decls return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2) tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id, Bag GlobalRdrElt) -tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec) +tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec }) = addErrCtxt (foreignDeclCtxt fo) $ do sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty @@ -391,7 +395,11 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec) -- is *stable* (i.e. the compiler won't change it later), -- because this name will be referred to by the C code stub. id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc - return (mkVarBind id rhs, ForeignExport (L loc id) undefined norm_co spec', gres) + return ( mkVarBind id rhs + , ForeignExport { fd_name = L loc id + , fd_sig_ty = undefined + , fd_co = norm_co, fd_fe = spec' } + , gres) tcFExport d = pprPanic "tcFExport" (ppr d) -- ------------ Checking argument types for foreign export ---------------------- diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index 284c594036..bba0abac3b 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -1304,10 +1304,10 @@ gen_Data_binds dflags loc rep_tc genDataTyCon :: (LHsBind RdrName, LSig RdrName) genDataTyCon -- $dT = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder)) + L loc (TypeSig [L loc rdr_name] sig_ty)) where rdr_name = mk_data_type_name rep_tc - sig_ty = nlHsTyVar dataType_RDR + sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR) constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons rep_tc] rhs = nlHsVar mkDataType_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc))) @@ -1316,10 +1316,10 @@ gen_Data_binds dflags loc rep_tc genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName) genDataDataCon dc -- $cT1 etc = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder)) + L loc (TypeSig [L loc rdr_name] sig_ty)) where rdr_name = mk_constr_name dc - sig_ty = nlHsTyVar constr_RDR + sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR) rhs = nlHsApps mkConstr_RDR constr_args constr_args @@ -2025,14 +2025,14 @@ gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty rhs_expr = ( nlHsVar coerce_RDR `nlHsApp` - (nlHsVar meth_RDR `nlExprWithTySig` toHsType tau_ty')) - `nlExprWithTySig` toHsType user_ty + (nlHsVar meth_RDR `nlExprWithTySig` toLHsSigWcType tau_ty')) + `nlExprWithTySig` toLHsSigWcType user_ty -- Open the representation type here, so that it's forall'ed type -- variables refer to the ones bound in the user_ty (_, _, tau_ty') = tcSplitSigmaTy tau_ty - nlExprWithTySig :: LHsExpr RdrName -> LHsType RdrName -> LHsExpr RdrName - nlExprWithTySig e s = noLoc (ExprWithTySig e s PlaceHolder) + nlExprWithTySig :: LHsExpr RdrName -> LHsSigWcType RdrName -> LHsExpr RdrName + nlExprWithTySig e s = noLoc (ExprWithTySig e s) {- ************************************************************************ @@ -2056,11 +2056,11 @@ fiddling around. genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName) genAuxBindSpec loc (DerivCon2Tag tycon) = (mk_FunBind loc rdr_name eqns, - L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder)) + L loc (TypeSig [L loc rdr_name] sig_ty)) where rdr_name = con2tag_RDR tycon - sig_ty = HsCoreTy $ + sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $ mkSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $ mkParentType tycon `mkFunTy` intPrimTy @@ -2082,19 +2082,20 @@ genAuxBindSpec loc (DerivTag2Con tycon) = (mk_FunBind loc rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], - L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder)) + L loc (TypeSig [L loc rdr_name] sig_ty)) where - sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $ + sig_ty = mkLHsSigWcType $ L loc $ + HsCoreTy $ mkForAllTys (tyConTyVars tycon) $ intTy `mkFunTy` mkParentType tycon rdr_name = tag2con_RDR tycon genAuxBindSpec loc (DerivMaxTag tycon) = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder)) + L loc (TypeSig [L loc rdr_name] sig_ty)) where rdr_name = maxtag_RDR tycon - sig_ty = HsCoreTy intTy + sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy)) rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim "" max_tag)) max_tag = case (tyConDataCons tycon) of data_cons -> toInteger ((length data_cons) - fIRST_TAG) diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 0a6ed8c5e5..ae095e0da3 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -731,8 +731,6 @@ zonkExpr env (ExprWithTySigOut e ty) = do { e' <- zonkLExpr env e ; return (ExprWithTySigOut e' ty) } -zonkExpr _ (ExprWithTySig _ _ _) = panic "zonkExpr env:ExprWithTySig" - zonkExpr env (ArithSeq expr wit info) = do new_expr <- zonkExpr env expr new_wit <- zonkWit env wit @@ -1207,8 +1205,10 @@ zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id] zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id) -zonkForeignExport env (ForeignExport i _hs_ty co spec) = - return (ForeignExport (fmap (zonkIdOcc env) i) undefined co spec) +zonkForeignExport env (ForeignExport { fd_name = i, fd_co = co, fd_fe = spec }) + = return (ForeignExport { fd_name = fmap (zonkIdOcc env) i + , fd_sig_ty = undefined, fd_co = co + , fd_fe = spec }) zonkForeignExport _ for_imp = return for_imp -- Foreign imports don't need zonking diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 217b2b1415..c0fef87334 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -8,29 +8,36 @@ {-# LANGUAGE CPP #-} module TcHsType ( - tcHsSigType, tcHsDeriv, tcHsVectInst, - tcHsInstHead, + -- Type signatures + kcClassSigType, tcClassSigType, + tcHsSigType, tcHsSigWcType, + zonkSigType, zonkAndCheckValidity, + funsSigCtxt, addSigCtxt, + + tcHsClsInstType, + tcHsDeriv, tcHsVectInst, UserTypeCtxt(..), + tcImplicitTKBndrs, tcHsTyVarBndrs, - -- Type checking type and class decls + -- Type checking type and class decls kcLookupKind, kcTyClTyVars, tcTyClTyVars, tcHsConArgType, tcDataKindSig, - tcClassSigType, - -- Kind-checking types - -- No kind generalisation, no checkValidType - tcWildcardBinders, - kcHsTyVarBndrs, tcHsTyVarBndrs, - tcHsLiftedType, tcHsOpenType, - tcLHsType, tcCheckLHsType, tcCheckLHsTypeAndGen, - tcHsContext, tcInferApps, tcHsArgTys, + -- Kind-checking types + -- No kind generalisation, no checkValidType + tcWildCardBinders, + kcHsTyVarBndrs, tcHsQTyVars, + tcHsLiftedType, tcHsOpenType, + tcHsLiftedTypeNC, tcHsOpenTypeNC, + tcLHsType, tcCheckLHsType, + tcHsContext, tcLHsPredType, tcInferApps, tcHsArgTys, kindGeneralize, checkKind, - -- Sort-checking kinds + -- Sort-checking kinds tcLHsKind, - -- Pattern type signatures + -- Pattern type signatures tcHsPatSigType, tcPatSig ) where @@ -71,7 +78,7 @@ import FastString import Util import Data.Maybe( isNothing ) -import Control.Monad ( unless, when, zipWithM ) +import Control.Monad ( unless, when, zipWithM, void ) import PrelNames( funTyConKey, allNameStrings ) {- @@ -158,50 +165,71 @@ the TyCon being defined. ************************************************************************ -} -tcHsSigType :: UserTypeCtxt -> LHsType Name -> TcM Type - -- NB: it's important that the foralls that come from the top-level - -- HsForAllTy in hs_ty occur *first* in the returned type. - -- See Note [Scoped] with TcSigInfo -tcHsSigType ctxt (L loc hs_ty) - = setSrcSpan loc $ - addErrCtxt (pprSigCtxt ctxt empty (ppr hs_ty)) $ - do { kind <- case expectedKindInCtxt ctxt of +funsSigCtxt :: [Located Name] -> UserTypeCtxt +-- Returns FunSigCtxt, with no redundant-context-reporting, +-- form a list of located names +funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False +funsSigCtxt [] = panic "funSigCtxt" + +addSigCtxt :: UserTypeCtxt -> LHsType Name -> TcM a -> TcM a +addSigCtxt ctxt sig_ty thing_inside + = setSrcSpan (getLoc sig_ty) $ + addErrCtxt (pprSigCtxt ctxt empty (ppr sig_ty)) $ + thing_inside + +tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType Name -> TcM Type +-- This one is used when we have a LHsSigWcType, but in +-- a place where wildards aren't allowed. The renamer has +-- alrady checked this, so we can simply ignore it. +tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) + +kcClassSigType :: [Located Name] -> LHsSigType Name -> TcM () +kcClassSigType names (HsIB { hsib_body = hs_ty + , hsib_kvs = sig_kvs + , hsib_tvs = sig_tvs }) + = addSigCtxt (funsSigCtxt names) hs_ty $ + do { tcImplicitTKBndrs sig_kvs sig_tvs $ \ _ _ -> + void $ tc_check_lhs_type hs_ty liftedTypeKind } + +tcClassSigType :: [Located Name] -> LHsSigType Name -> TcM Type +-- Does not do validity checking; this must be done outside +-- the recursive class declaration "knot" +tcClassSigType names sig_ty + = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $ + tc_hs_sig_type sig_ty liftedTypeKind + +tcHsSigType :: UserTypeCtxt -> LHsSigType Name -> TcM Type +-- Does validity checking +tcHsSigType ctxt sig_ty + = addSigCtxt ctxt (hsSigType sig_ty) $ + do { kind <- case expectedKindInCtxt ctxt of Nothing -> newMetaKindVar Just k -> return k - -- The kind is checked by checkValidType, and isn't necessarily - -- of kind * in a Template Haskell quote eg [t| Maybe |] + -- The kind is checked by checkValidType, and isn't necessarily + -- of kind * in a Template Haskell quote eg [t| Maybe |] + + ; ty <- tc_hs_sig_type sig_ty kind + ; checkValidType ctxt ty + ; return ty } + +tc_hs_sig_type :: LHsSigType Name -> Kind -> TcM Type +-- Does not do validity checking +tc_hs_sig_type (HsIB { hsib_body = hs_ty + , hsib_kvs = sig_kvs + , hsib_tvs = sig_tvs }) kind + = do { ty <- tcImplicitTKBndrs sig_kvs sig_tvs $ \ kvs tvs -> + do { ty <- tc_check_lhs_type hs_ty kind + ; return (mkForAllTys kvs $ mkForAllTys tvs ty) } -- Generalise here: see Note [Kind generalisation] - ; ty <- tcCheckHsTypeAndGen hs_ty kind + ; ty <- kindGeneralizeType ty -- Zonk to expose kind information to checkValidType - ; ty <- zonkSigType ty - ; checkValidType ctxt ty - ; return ty } + ; zonkSigType ty } ------------------ -tcHsInstHead :: UserTypeCtxt -> LHsType Name -> TcM ([TyVar], ThetaType, Class, [Type]) --- Like tcHsSigType, but for an instance head. -tcHsInstHead user_ctxt lhs_ty@(L loc hs_ty) - = setSrcSpan loc $ -- The "In the type..." context comes from the caller - do { inst_ty <- tc_inst_head hs_ty - ; kvs <- zonkTcTypeAndFV inst_ty - ; kvs <- kindGeneralize kvs - ; inst_ty <- zonkSigType (mkForAllTys kvs inst_ty) - ; checkValidInstance user_ctxt lhs_ty inst_ty } - -tc_inst_head :: HsType Name -> TcM TcType -tc_inst_head (HsForAllTy _ _ hs_tvs hs_ctxt hs_ty) - = tcHsTyVarBndrs hs_tvs $ \ tvs -> - do { ctxt <- tcHsContext hs_ctxt - ; ty <- tc_lhs_type hs_ty ekConstraint -- Body for forall has kind Constraint - ; return (mkSigmaTy tvs ctxt ty) } - -tc_inst_head hs_ty - = tc_hs_type hs_ty ekConstraint ----------------- -tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type], Kind) +tcHsDeriv :: LHsSigType Name -> TcM ([TyVar], Class, [Type], Kind) -- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause -- Returns the C, [ty1, ty2, and the kind of C's *next* argument -- E.g. class C (a::*) (b::k->k) @@ -211,19 +239,40 @@ tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type], Kind) -- if arg has a suitable kind tcHsDeriv hs_ty = do { arg_kind <- newMetaKindVar - ; ty <- tcCheckHsTypeAndGen hs_ty (mkArrowKind arg_kind constraintKind) - ; ty <- zonkSigType ty + ; ty <- tc_hs_sig_type hs_ty (mkArrowKind arg_kind constraintKind) ; arg_kind <- zonkSigType arg_kind ; let (tvs, pred) = splitForAllTys ty ; case getClassPredTys_maybe pred of Just (cls, tys) -> return (tvs, cls, tys, arg_kind) Nothing -> failWithTc (ptext (sLit "Illegal deriving item") <+> quotes (ppr hs_ty)) } +tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt + -> LHsSigType Name + -> TcM ([TyVar], ThetaType, Class, [Type]) +-- Like tcHsSigType, but for a class instance declaration +-- The significant difference is that we expect a /constraint/ +-- not a /type/ for the bit after the '=>'. +tcHsClsInstType user_ctxt hs_inst_ty@(HsIB { hsib_kvs = sig_kvs, hsib_tvs = sig_tvs + , hsib_body = hs_qual_ty }) + | (cxt, head_ty) <- splitLHsQualTy hs_qual_ty + -- An explicit forall in an instance declaration isn't + -- allowed, so there won't be any HsForAllTy here + = setSrcSpan (getLoc hs_qual_ty) $ + do { inst_ty <- tcImplicitTKBndrs sig_kvs sig_tvs $ \ kvs tvs -> + do { theta <- tcHsContext cxt + ; head_ty' <- tc_check_lhs_type head_ty constraintKind + ; return (mkForAllTys kvs $ mkForAllTys tvs $ + mkPhiTy theta head_ty') } + ; inst_ty <- kindGeneralizeType inst_ty + ; inst_ty <- zonkSigType inst_ty + ; checkValidInstance user_ctxt hs_inst_ty inst_ty } + -- Used for 'VECTORISE [SCALAR] instance' declarations -- -tcHsVectInst :: LHsType Name -> TcM (Class, [Type]) +tcHsVectInst :: LHsSigType Name -> TcM (Class, [Type]) tcHsVectInst ty - | Just (L _ cls_name, tys) <- splitLHsClassTy_maybe ty + | Just (L _ cls_name, tys) <- splitLHsClassTy_maybe (hsSigType ty) + -- Ignoring the binders looks pretty dodgy to me = do { (cls, cls_kind) <- tcClass cls_name ; (arg_tys, _res_kind) <- tcInferApps cls_name cls_kind tys ; return (cls, arg_tys) } @@ -245,11 +294,6 @@ tcHsVectInst ty First a couple of simple wrappers for kcHsType -} -tcClassSigType :: LHsType Name -> TcM Type -tcClassSigType lhs_ty - = do { ty <- tcCheckLHsTypeAndGen lhs_ty liftedTypeKind - ; zonkSigType ty } - tcHsConArgType :: NewOrData -> LHsType Name -> TcM Type -- Permit a bang, but discard it tcHsConArgType NewType bty = tcHsLiftedType (getBangType bty) @@ -275,42 +319,31 @@ tc_hs_arg_tys what tys kinds | (ty,kind,n) <- zip3 tys kinds [1..] ] --------------------------- -tcHsOpenType, tcHsLiftedType :: LHsType Name -> TcM TcType +tcHsOpenType, tcHsLiftedType, + tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType Name -> TcM TcType -- Used for type signatures -- Do not do validity checking -tcHsOpenType ty = addTypeCtxt ty $ tc_lhs_type ty ekOpen -tcHsLiftedType ty = addTypeCtxt ty $ tc_lhs_type ty ekLifted +tcHsOpenType ty = addTypeCtxt ty $ tcHsOpenTypeNC ty +tcHsLiftedType ty = addTypeCtxt ty $ tcHsLiftedTypeNC ty + +tcHsOpenTypeNC ty = tc_lhs_type ty ekOpen +tcHsLiftedTypeNC ty = tc_lhs_type ty ekLifted -- Like tcHsType, but takes an expected kind tcCheckLHsType :: LHsType Name -> Kind -> TcM Type tcCheckLHsType hs_ty exp_kind = addTypeCtxt hs_ty $ - tc_lhs_type hs_ty (EK exp_kind expectedKindMsg) + tc_check_lhs_type hs_ty exp_kind + +tc_check_lhs_type :: LHsType Name -> Kind -> TcM Type +tc_check_lhs_type hs_ty exp_kind + = tc_lhs_type hs_ty (EK exp_kind expectedKindMsg) tcLHsType :: LHsType Name -> TcM (TcType, TcKind) -- Called from outside: set the context tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type ty) --------------------------- -tcCheckLHsTypeAndGen :: LHsType Name -> Kind -> TcM Type --- Typecheck a type signature, and kind-generalise it --- The result is not necessarily zonked, and has not been checked for validity -tcCheckLHsTypeAndGen lhs_ty kind - = do { ty <- tcCheckLHsType lhs_ty kind - ; kvs <- zonkTcTypeAndFV ty - ; kvs <- kindGeneralize kvs - ; return (mkForAllTys kvs ty) } - -tcCheckHsTypeAndGen :: HsType Name -> Kind -> TcM Type --- Input type is HsType, not LHsType; the caller adds the context --- Otherwise same as tcCheckLHsTypeAndGen -tcCheckHsTypeAndGen hs_ty kind - = do { ty <- tc_hs_type hs_ty (EK kind expectedKindMsg) - ; traceTc "tcCheckHsTypeAndGen" (ppr hs_ty) - ; kvs <- zonkTcTypeAndFV ty - ; kvs <- kindGeneralize kvs - ; return (mkForAllTys kvs ty) } - {- Like tcExpr, tc_hs_type takes an expected kind which it unifies with the kind it figures out. When we don't know what kind to expect, we use @@ -393,25 +426,29 @@ tc_hs_type hs_ty@(HsAppTy ty1 ty2) exp_kind (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] --------- Foralls -tc_hs_type hs_ty@(HsForAllTy _ _ hs_tvs context ty) exp_kind@(EK exp_k _) +tc_hs_type hs_ty@(HsForAllTy { hst_bndrs = hs_tvs, hst_body = ty }) exp_kind@(EK exp_k _) | isConstraintKind exp_k = failWithTc (hang (ptext (sLit "Illegal constraint:")) 2 (ppr hs_ty)) | otherwise = tcHsTyVarBndrs hs_tvs $ \ tvs' -> -- Do not kind-generalise here! See Note [Kind generalisation] - do { ctxt' <- tcHsContext context - ; ty' <- if null (unLoc context) then -- Plain forall, no context + do { ty' <- tc_lhs_type ty exp_kind + ; return (mkForAllTys tvs' ty') } + +tc_hs_type hs_ty@(HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind + = do { ctxt' <- tcHsContext ctxt + ; ty' <- if null (unLoc ctxt) then -- Plain forall, no context tc_lhs_type ty exp_kind -- Why exp_kind? See Note [Body kind of forall] else -- If there is a context, then this forall is really a -- _function_, so the kind of the result really is * - -- The body kind (result of the function can be * or #, hence ekOpen + -- The body kind (result of the function) can be * or #, hence ekOpen do { checkExpectedKind hs_ty liftedTypeKind exp_kind ; tc_lhs_type ty ekOpen } - ; return (mkSigmaTy tvs' ctxt' ty') } + ; return (mkPhiTy ctxt' ty') } ---------- Lists, arrays, and tuples +--------- Lists, arraysp, and tuples tc_hs_type hs_ty@(HsListTy elt_ty) exp_kind = do { tau_ty <- tc_lhs_type elt_ty ekLifted ; checkExpectedKind hs_ty liftedTypeKind exp_kind @@ -537,9 +574,9 @@ tc_hs_type hs_ty@(HsTyLit (HsStrTy _ s)) exp_kind tc_hs_type hs_ty@(HsWildCardTy wc) exp_kind = do { let name = wildCardName wc - ; (ty, k) <- tcTyVar name - ; checkExpectedKind hs_ty k exp_kind - ; return ty } + ; tv <- tcLookupTyVar name + ; checkExpectedKind hs_ty (tyVarKind tv) exp_kind + ; return (mkTyVarTy tv) } --------------------------- tupKindSort_maybe :: TcKind -> Maybe TupleSort @@ -631,10 +668,10 @@ splitFunKind the_fun fun_kind args --------------------------- tcHsContext :: LHsContext Name -> TcM [PredType] -tcHsContext ctxt = mapM tcHsLPredType (unLoc ctxt) +tcHsContext ctxt = mapM tcLHsPredType (unLoc ctxt) -tcHsLPredType :: LHsType Name -> TcM PredType -tcHsLPredType pred = tc_lhs_type pred ekConstraint +tcLHsPredType :: LHsType Name -> TcM PredType +tcLHsPredType pred = tc_lhs_type pred ekConstraint --------------------------- tcTyVar :: Name -> TcM (TcType, TcKind) @@ -750,6 +787,13 @@ mkNakedAppTys ty1 [] = ty1 mkNakedAppTys (TyConApp tc tys1) tys2 = mkNakedTyConApp tc (tys1 ++ tys2) mkNakedAppTys ty1 tys2 = foldl AppTy ty1 tys2 +zonkAndCheckValidity :: UserTypeCtxt -> TcType -> TcM TcType +-- Zonk a user-written type signature, and check it for validity +zonkAndCheckValidity ctxt ty + = do { ty <- zonkSigType ty + ; checkValidType ctxt ty + ; return ty } + zonkSigType :: TcType -> TcM TcType -- Zonk the result of type-checking a user-written type signature -- It may have kind variables in it, but no meta type variables @@ -921,13 +965,16 @@ addTypeCtxt (L _ ty) thing ************************************************************************ -} -tcWildcardBinders :: [Name] - -> ([(Name,TcTyVar)] -> TcM a) +tcWildCardBinders :: [Name] + -> ([(Name, TcTyVar)] -> TcM a) -> TcM a -tcWildcardBinders wcs thing_inside - = do { wc_prs <- mapM new_wildcard wcs - ; tcExtendTyVarEnv2 wc_prs $ - thing_inside wc_prs } +-- Use the Unqique form the specified Name; don't clone it. There is +-- no need to clone, and not doing so avoids the need to return a list +-- of pairs to bring into scope. +tcWildCardBinders wcs thing_inside + = do { wcs <- mapM new_wildcard wcs + ; tcExtendTyVarEnv2 wcs $ + thing_inside wcs } where new_wildcard :: Name -> TcM (Name, TcTyVar) new_wildcard name = do { kind <- newMetaKindVar @@ -935,7 +982,9 @@ tcWildcardBinders wcs thing_inside ; return (name, tv) } mkKindSigVar :: Name -> TcM KindVar --- Use the specified name; don't clone it +-- Use the specified Name; don't clone it. There is no need to +-- clone, and not doing so avoids the need to return a list of +-- pairs to bring into scope. mkKindSigVar n = do { mb_thing <- tcLookupLcl_maybe n ; case mb_thing of @@ -953,12 +1002,12 @@ kcScopedKindVars kv_ns thing_inside -- NB: use mutable signature variables ; tcExtendTyVarEnv2 (kv_ns `zip` kvs) thing_inside } --- | Kind-check a 'LHsTyVarBndrs'. If the decl under consideration has a complete, +-- | Kind-check a 'LHsQTyVars'. If the decl under consideration has a complete, -- user-supplied kind signature (CUSK), generalise the result. Used in 'getInitialKind' -- and in kind-checking. See also Note [Complete user-supplied kind signatures] in -- HsDecls. kcHsTyVarBndrs :: Bool -- ^ True <=> the decl being checked has a CUSK - -> LHsTyVarBndrs Name + -> LHsQTyVars Name -> TcM (Kind, r) -- ^ the result kind, possibly with other info -> TcM (Kind, r) -- ^ The full kind of the thing being declared, -- with the other info @@ -997,50 +1046,71 @@ kcHsTyVarBndrs cusk (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside Just thing -> pprPanic "check_in_scope" (ppr thing) ; return (n, kind) } -tcHsTyVarBndrs :: LHsTyVarBndrs Name +tcImplicitTKBndrs :: [Name] -> [Name] -> ([TcTyVar] -> [TcTyVar] -> TcM a) -> TcM a +-- Returned TcTyVars have the supplied Names +-- i.e. no cloning of fresh names +tcImplicitTKBndrs kv_ns tv_ns thing_inside + = do { kvs <- mapM mkKindSigVar kv_ns + ; tvs <- mapM tc_tv tv_ns + ; tcExtendTyVarEnv (kvs ++ tvs) (thing_inside kvs tvs) } + where + tc_tv name = do { kind <- newMetaKindVar + ; return (mkTcTyVar name kind (SkolemTv False)) } + +tcHsQTyVars :: LHsQTyVars Name -> ([TcTyVar] -> TcM r) -> TcM r -- Bind the kind variables to fresh skolem variables -- and type variables to skolems, each with a meta-kind variable kind -tcHsTyVarBndrs (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside - = do { kvs <- mapM mkKindSigVar kv_ns - ; tcExtendTyVarEnv kvs $ do - { tvs <- mapM tcHsTyVarBndr hs_tvs - ; traceTc "tcHsTyVarBndrs {" (vcat [ text "Hs kind vars:" <+> ppr kv_ns - , text "Hs type vars:" <+> ppr hs_tvs - , text "Kind vars:" <+> ppr kvs - , text "Type vars:" <+> ppr tvs ]) - ; res <- tcExtendTyVarEnv tvs (thing_inside (kvs ++ tvs)) - ; traceTc "tcHsTyVarBndrs }" (vcat [ text "Hs kind vars:" <+> ppr kv_ns - , text "Hs type vars:" <+> ppr hs_tvs - , text "Kind vars:" <+> ppr kvs - , text "Type vars:" <+> ppr tvs ]) - ; return res } } - -tcHsTyVarBndr :: LHsTyVarBndr Name -> TcM TcTyVar --- Return a type variable --- initialised with a kind variable. --- Typically the Kind inside the HsTyVarBndr will be a tyvar with a mutable kind --- in it. +tcHsQTyVars (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside + = tcImplicitTKBndrs kv_ns [] $ \ kvs _ -> + do { tv_prs <- mapM tc_tv_bndr hs_tvs + ; tcExtendTyVarEnv [ tv | (tv, False) <- tv_prs ] $ + thing_inside (kvs ++ map fst tv_prs) } + where + -- If the variable is already in scope return it, instead of + -- introducing a new one. This can occur in + -- instance C (a,b) where + -- type F (a,b) c = ... + -- Here a,b will be in scope when processing the associated type instance for F. + -- See Note [Associated type tyvar names] in Class + tc_tv_bndr :: LHsTyVarBndr Name -> TcM (TcTyVar, Bool) + -- True <=> already in scope, do not extend envt + -- False <=> not already in scope + tc_tv_bndr (L _ hs_tv) + = do { let name = hsTyVarName hs_tv + ; mb_tv <- tcLookupLcl_maybe name + ; case mb_tv of + Just (ATyVar _ tv) -> return (tv, True) + _ -> do { tv <- tcHsTyVarBndr hs_tv + ; return (tv, False) } } + +tcHsTyVarBndrs :: [LHsTyVarBndr Name] -> ([TyVar] -> TcM a) -> TcM a +-- No cloning: returned TyVars have the same Name as the incoming LHsTyVarBndrs +tcHsTyVarBndrs hs_tvs thing_inside + = do { tvs <- mapM (tcHsTyVarBndr . unLoc) hs_tvs + ; tcExtendTyVarEnv tvs (thing_inside tvs) } + +tcHsTyVarBndr :: HsTyVarBndr Name -> TcM TcTyVar +-- Return a type variable initialised with a kind variable. +-- Typically the Kind inside the HsTyVarBndr will be a tyvar +-- with a mutable kind in it. -- --- If the variable is already in scope return it, instead of introducing a new --- one. This can occur in --- instance C (a,b) where --- type F (a,b) c = ... --- Here a,b will be in scope when processing the associated type instance for F. --- See Note [Associated type tyvar names] in Class -tcHsTyVarBndr (L _ hs_tv) - = do { let name = hsTyVarName hs_tv - ; mb_tv <- tcLookupLcl_maybe name - ; case mb_tv of { - Just (ATyVar _ tv) -> return tv ; - _ -> do - { kind <- case hs_tv of - UserTyVar {} -> newMetaKindVar - KindedTyVar _ kind -> tcLHsKind kind - ; return ( mkTcTyVar name kind (SkolemTv False)) } } } +-- Returned TcTyVar has the same name; no cloning +tcHsTyVarBndr (UserTyVar (L _ name)) + = do { kind <- newMetaKindVar + ; return (mkTcTyVar name kind (SkolemTv False)) } +tcHsTyVarBndr (KindedTyVar (L _ name) kind) + = do { kind <- tcLHsKind kind + ; return (mkTcTyVar name kind (SkolemTv False)) } ------------------ +kindGeneralizeType :: Type -> TcM Type +kindGeneralizeType ty + = do { kvs <- zonkTcTypeAndFV ty + ; kvs <- kindGeneralize kvs + ; return (mkForAllTys kvs ty) } + kindGeneralize :: TyVarSet -> TcM [KindVar] kindGeneralize tkvs = do { gbl_tvs <- tcGetGlobalTyVars -- Already zonked @@ -1107,7 +1177,7 @@ kcLookupKind nm AGlobal (ATyCon tc) -> return (tyConKind tc) _ -> pprPanic "kcLookupKind" (ppr tc_ty_thing) } -kcTyClTyVars :: Name -> LHsTyVarBndrs Name -> TcM a -> TcM a +kcTyClTyVars :: Name -> LHsQTyVars Name -> TcM a -> TcM a -- Used for the type variables of a type or class decl, -- when doing the initial kind-check. kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside @@ -1136,7 +1206,7 @@ kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside ; return (n, exp_k) } ----------------------- -tcTyClTyVars :: Name -> LHsTyVarBndrs Name -- LHS of the type or class decl +tcTyClTyVars :: Name -> LHsQTyVars Name -- LHS of the type or class decl -> ([TyVar] -> Kind -> TcM a) -> TcM a -- Used for the type variables of a type or class decl, -- on the second pass when constructing the final result @@ -1267,8 +1337,8 @@ Historical note: -} tcHsPatSigType :: UserTypeCtxt - -> HsWithBndrs Name (LHsType Name) -- The type signature - -> TcM ( Type -- The signature + -> LHsSigWcType Name -- The type signature + -> TcM ( Type -- The signature , [(Name, TcTyVar)] -- The new bit of type environment, binding -- the scoped type variables , [(Name, TcTyVar)] ) -- The wildcards @@ -1277,11 +1347,13 @@ tcHsPatSigType :: UserTypeCtxt -- (b) result signatures e.g. g x :: Int = e -- (c) RULE forall bndrs e.g. forall (x::Int). f x = x -tcHsPatSigType ctxt (HsWB { hswb_cts = hs_ty, hswb_kvs = sig_kvs, - hswb_tvs = sig_tvs, hswb_wcs = sig_wcs }) - = addErrCtxt (pprSigCtxt ctxt empty (ppr hs_ty)) $ - tcWildcardBinders sig_wcs $ \ nwc_binds -> - do { emitWildcardHoleConstraints nwc_binds +tcHsPatSigType ctxt sig_ty + | HsIB { hsib_kvs = sig_kvs, hsib_tvs = sig_tvs, hsib_body = wc_ty } <- sig_ty + , HsWC { hswc_wcs = sig_wcs, hswc_ctx = extra, hswc_body = hs_ty } <- wc_ty + = ASSERT( isNothing extra ) -- No extra-constraint wildcard in pattern sigs + addSigCtxt ctxt hs_ty $ + tcWildCardBinders sig_wcs $ \ wcs -> + do { emitWildCardHoleConstraints wcs ; kvs <- mapM new_kv sig_kvs ; tvs <- mapM new_tv sig_tvs ; let ktv_binds = (sig_kvs `zip` kvs) ++ (sig_tvs `zip` tvs) @@ -1289,7 +1361,8 @@ tcHsPatSigType ctxt (HsWB { hswb_cts = hs_ty, hswb_kvs = sig_kvs, tcHsLiftedType hs_ty ; sig_ty <- zonkSigType sig_ty ; checkValidType ctxt sig_ty - ; return (sig_ty, ktv_binds, nwc_binds) } + ; traceTc "tcHsPatSigType" (ppr sig_tvs $$ ppr ktv_binds) + ; return (sig_ty, ktv_binds, wcs) } where new_kv name = new_tkv name superKind new_tv name = do { kind <- newMetaKindVar @@ -1301,7 +1374,7 @@ tcHsPatSigType ctxt (HsWB { hswb_cts = hs_ty, hswb_kvs = sig_kvs, _ -> newSigTyVar name kind -- See Note [Unifying SigTvs] tcPatSig :: Bool -- True <=> pattern binding - -> HsWithBndrs Name (LHsType Name) + -> LHsSigWcType Name -> TcSigmaType -> TcM (TcType, -- The type to use for "inside" the signature [(Name, TcTyVar)], -- The new bit of type environment, binding @@ -1310,7 +1383,7 @@ tcPatSig :: Bool -- True <=> pattern binding HsWrapper) -- Coercion due to unification with actual ty -- Of shape: res_ty ~ sig_ty tcPatSig in_pat_bind sig res_ty - = do { (sig_ty, sig_tvs, sig_nwcs) <- tcHsPatSigType PatSigCtxt sig + = do { (sig_ty, sig_tvs, sig_wcs) <- tcHsPatSigType PatSigCtxt sig -- sig_tvs are the type variables free in 'sig', -- and not already in scope. These are the ones -- that should be brought into scope @@ -1319,7 +1392,7 @@ tcPatSig in_pat_bind sig res_ty -- Just do the subsumption check and return wrap <- addErrCtxtM (mk_msg sig_ty) $ tcSubType_NC PatSigCtxt res_ty sig_ty - ; return (sig_ty, [], sig_nwcs, wrap) + ; return (sig_ty, [], sig_wcs, wrap) } else do -- Type signature binds at least one scoped type variable @@ -1344,7 +1417,7 @@ tcPatSig in_pat_bind sig res_ty tcSubType_NC PatSigCtxt res_ty sig_ty -- Phew! - ; return (sig_ty, sig_tvs, sig_nwcs, wrap) + ; return (sig_ty, sig_tvs, sig_wcs, wrap) } } where mk_msg sig_ty tidy_env diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index dc281d1df2..c9b1363675 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -18,7 +18,7 @@ import TcTyClsDecls import TcClassDcl( tcClassDecl2, tcATDefault, HsSigFun, lookupHsSig, mkHsSigFun, findMethodBind, instantiateMethod ) -import TcPat ( TcIdSigInfo, addInlinePrags, completeIdSigPolyId, lookupPragEnv, emptyPragEnv ) +import TcPat ( addInlinePrags, lookupPragEnv, emptyPragEnv ) import TcRnMonad import TcValidity import TcMType @@ -62,6 +62,8 @@ import Control.Monad import Maybes import Data.List ( partition ) + + {- Typechecking instance declarations is done in two passes. The first pass, made by @tcInstDecls1@, collects information to be used in the @@ -522,7 +524,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags)) badBootDeclErr - ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead InstDeclCtxt poly_ty + ; (tyvars, theta, clas, inst_tys) <- tcHsClsInstType InstDeclCtxt poly_ty ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env mb_info = Just (clas, mini_env) @@ -546,7 +548,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) - ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty) + ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType poly_ty)) -- Dfun location is that of instance *header* ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name tyvars theta @@ -987,7 +989,7 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds _fam_envs sc_t loc = getSrcSpan dfun_id size = sizeTypes inst_tys tc_super (sc_pred, n) - = do { (sc_implic, sc_ev_id) <- checkInstConstraints $ \_ -> + = do { (sc_implic, sc_ev_id) <- checkInstConstraints $ emitWanted (ScOrigin size) sc_pred ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls)) @@ -1005,18 +1007,14 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds _fam_envs sc_t ; return (sc_top_id, L loc bind, sc_implic) } ------------------- -checkInstConstraints :: (EvBindsVar -> TcM result) - -> TcM (Implication, result) +checkInstConstraints :: TcM result -> TcM (Implication, result) -- See Note [Typechecking plan for instance declarations] --- The thing_inside is also passed the EvBindsVar, --- so that emit_sc_pred can add evidence for the superclass --- (not used for methods) checkInstConstraints thing_inside - = do { ev_binds_var <- newTcEvBinds - ; env <- getLclEnv - ; (result, tclvl, wanted) <- pushLevelAndCaptureConstraints $ - thing_inside ev_binds_var + = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints $ + thing_inside + ; ev_binds_var <- newTcEvBinds + ; env <- getLclEnv ; let implic = Implic { ic_tclvl = tclvl , ic_skols = [] , ic_no_eqs = False @@ -1374,7 +1372,7 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys ; global_meth_id <- addInlinePrags global_meth_id prags ; spec_prags <- tcSpecPrags global_meth_id prags ; (meth_implic, (tc_bind, _)) - <- checkInstConstraints $ \ _ev_binds -> + <- checkInstConstraints $ tcPolyCheck NonRecursive no_prag_fn local_meth_sig (L bind_loc lm_bind) @@ -1418,13 +1416,13 @@ mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id ; case lookupHsSig sig_fn sel_name of Just lhs_ty -- There is a signature in the instance declaration -- See Note [Instance method signatures] - -> setSrcSpan (getLoc lhs_ty) $ + -> setSrcSpan (getLoc (hsSigType lhs_ty)) $ do { inst_sigs <- xoptM Opt_InstanceSigs ; checkTc inst_sigs (misplacedInstSig sel_name lhs_ty) ; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) lhs_ty ; let poly_sig_ty = mkSigmaTy tyvars theta sig_ty ctxt = FunSigCtxt sel_name True - ; tc_sig <- instTcTySig ctxt lhs_ty sig_ty Nothing [] local_meth_name + ; tc_sig <- instTcTySig ctxt lhs_ty sig_ty local_meth_name ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name poly_sig_ty poly_meth_ty) $ tcSubType ctxt poly_sig_ty poly_meth_ty ; return (poly_meth_id, tc_sig, hs_wrap) } @@ -1455,7 +1453,7 @@ methSigCtxt sel_name sig_ty meth_ty env0 , ptext (sLit " Class sig:") <+> ppr meth_ty ]) ; return (env2, msg) } -misplacedInstSig :: Name -> LHsType Name -> SDoc +misplacedInstSig :: Name -> LHsSigType Name -> SDoc misplacedInstSig name hs_ty = vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:")) 2 (hang (pprPrefixName name) @@ -1727,7 +1725,7 @@ tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty) = addErrCtxt (spec_ctxt prag) $ - do { (tyvars, theta, clas, tys) <- tcHsInstHead SpecInstCtxt hs_ty + do { (tyvars, theta, clas, tys) <- tcHsClsInstType SpecInstCtxt hs_ty ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } @@ -1744,11 +1742,11 @@ tcSpecInst _ _ = panic "tcSpecInst" ************************************************************************ -} -instDeclCtxt1 :: LHsType Name -> SDoc +instDeclCtxt1 :: LHsSigType Name -> SDoc instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (case unLoc hs_inst_ty of - HsForAllTy _ _ _ _ (L _ ty') -> ppr ty' - _ -> ppr hs_inst_ty) -- Don't expect this + | (_, _, head_ty) <- splitLHsInstDeclTy hs_inst_ty + = inst_decl_ctxt (ppr head_ty) + instDeclCtxt2 :: Type -> SDoc instDeclCtxt2 dfun_ty = inst_decl_ctxt (ppr (mkClassPred cls tys)) diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index a9c608d21b..fb334eed34 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -21,7 +21,8 @@ module TcMType ( newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] newReturnTyVar, newReturnTyVarTy, newMetaKindVar, newMetaKindVars, - mkTcTyVarName, cloneMetaTyVar, + cloneMetaTyVar, + newFmvTyVar, newFskTyVar, newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, newMetaDetails, isFilledMetaTyVar, isUnfilledMetaTyVar, @@ -253,6 +254,12 @@ instSkolTyVarX mk_tv subst tyvar old_name = tyVarName tyvar kind = substTy subst (tyVarKind tyvar) +newFskTyVar :: TcType -> TcM TcTyVar +newFskTyVar fam_ty + = do { uniq <- newUnique + ; let name = mkSysTvName uniq (fsLit "fsk") + ; return (mkTcTyVar name (typeKind fam_ty) (FlatSkol fam_ty)) } + {- Note [Kind substitution when instantiating] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -277,11 +284,17 @@ instead of the buggous ************************************************************************ -} +mkMetaTyVarName :: Unique -> FastString -> Name +-- Makes a /System/ Name, which is eagerly eliminated by +-- the unifier; see TcUnify.nicer_to_update_tv1, and +-- TcCanonical.canEqTyVarTyVar (nicer_to_update_tv2) +mkMetaTyVarName uniq str = mkSysTvName uniq str + newMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar -- Make a new meta tyvar out of thin air newMetaTyVar meta_info kind = do { uniq <- newUnique - ; let name = mkTcTyVarName uniq s + ; let name = mkMetaTyVarName uniq s s = case meta_info of ReturnTv -> fsLit "r" TauTv -> fsLit "t" @@ -302,11 +315,26 @@ newSigTyVar name kind -- doesn't gratuitously rename 'a' to 'a0' etc ; return (mkTcTyVar fresh_name kind details) } +newFmvTyVar :: TcType -> TcM TcTyVar +-- Very like newMetaTyVar, except sets mtv_tclvl to one less +-- so that the fmv is untouchable. +newFmvTyVar fam_ty + = do { uniq <- newUnique + ; ref <- newMutVar Flexi + ; cur_lvl <- getTcLevel + ; let details = MetaTv { mtv_info = FlatMetaTv + , mtv_ref = ref + , mtv_tclvl = fmvTcLevel cur_lvl } + name = mkMetaTyVarName uniq (fsLit "s") + ; return (mkTcTyVar name (typeKind fam_ty) details) } + newMetaDetails :: MetaInfo -> TcM TcTyVarDetails newMetaDetails info = do { ref <- newMutVar Flexi ; tclvl <- getTcLevel - ; return (MetaTv { mtv_info = info, mtv_ref = ref, mtv_tclvl = tclvl }) } + ; return (MetaTv { mtv_info = info + , mtv_ref = ref + , mtv_tclvl = tclvl }) } cloneMetaTyVar :: TcTyVar -> TcM TcTyVar cloneMetaTyVar tv @@ -319,9 +347,6 @@ cloneMetaTyVar tv _ -> pprPanic "cloneMetaTyVar" (ppr tv) ; return (mkTcTyVar name' (tyVarKind tv) details') } -mkTcTyVarName :: Unique -> FastString -> Name -mkTcTyVarName uniq str = mkSysTvName uniq str - -- Works for both type and kind variables readMetaTyVar :: TyVar -> TcM MetaDetails readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar ) @@ -488,7 +513,8 @@ quantifyTyVars :: TcTyVarSet -> TcTyVarSet -> TcM [TcTyVar] quantifyTyVars gbl_tvs tkvs = do { tkvs <- zonkTyVarsAndFV tkvs ; gbl_tvs <- zonkTyVarsAndFV gbl_tvs - ; let (kvs, tvs) = partitionVarSet isKindVar (closeOverKinds tkvs `minusVarSet` gbl_tvs) + ; let (kvs, tvs) = partitionVarSet isKindVar $ + closeOverKinds tkvs `minusVarSet` gbl_tvs -- NB kinds of tvs are zonked by zonkTyVarsAndFV kvs2 = varSetElems kvs qtvs = varSetElems tvs diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index 3888f89233..26397761c1 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -153,7 +153,7 @@ matchFunTys matchFunTys herald arity res_ty thing_inside = do { (co, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty ; res <- thing_inside pat_tys res_ty - ; return (coToHsWrapper (mkTcSymCo co), res) } + ; return (mkWpCastN (mkTcSymCo co), res) } {- ************************************************************************ diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index bffcfb8596..de6772e0c7 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -10,9 +10,6 @@ TcPat: Typechecking patterns module TcPat ( tcLetPat, TcSigFun , TcPragEnv, lookupPragEnv, emptyPragEnv - , TcSigInfo(..), TcIdSigInfo(..), TcPatSynInfo(..), TcIdSigBndr(..) - , findScopedTyVars, isPartialSig, noCompleteSig - , completeIdSigPolyId, completeSigPolyId_maybe, completeIdSigPolyId_maybe , LetBndrSpec(..), addInlinePrags , tcPat, tcPats, newNoSigLetBndr , addDataConStupidTheta, badFieldCon, polyPatSig ) where @@ -28,7 +25,6 @@ import Inst import Id import Var import Name -import NameSet import NameEnv import RdrName import TcEnv @@ -146,198 +142,13 @@ emptyPragEnv = emptyNameEnv lookupPragEnv :: TcPragEnv -> Name -> [LSig Name] lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` [] -data TcSigInfo = TcIdSig TcIdSigInfo - | TcPatSynSig TcPatSynInfo - -data TcIdSigInfo - = TISI { - sig_bndr :: TcIdSigBndr, - - sig_tvs :: [(Maybe Name, TcTyVar)], - -- Instantiated type and kind variables - -- Just n <=> this skolem is lexically in scope with name n - -- See Note [Binding scoped type variables] - - sig_theta :: TcThetaType, -- Instantiated theta - sig_tau :: TcSigmaType, -- Instantiated tau - -- See Note [sig_tau may be polymorphic] - - sig_ctxt :: UserTypeCtxt, -- FunSigCtxt or CheckSigCtxt - sig_loc :: SrcSpan -- Location of the type signature - } - -data TcIdSigBndr -- See Note [Complete and partial type signatures] - = CompleteSig -- A complete signature with no wildards, - -- so the complete polymorphic type is known. - TcId -- The polymoprhic Id with that type - - | PartialSig -- A partial type signature (i.e. includes one or more - -- wildcards). In this case it doesn't make sense to give - -- the polymorphic Id, because we are going to /infer/ its - -- type, so we can't make the polymorphic Id ab-initio - { sig_name :: Name -- Name of the function - , sig_hs_ty :: LHsType Name -- The original partial signatur - , sig_nwcs :: [(Name, TcTyVar)] -- Instantiated wildcard variables - , sig_cts :: Maybe SrcSpan -- Just loc <=> An extra-constraints wildcard was present - } -- at location loc - -- e.g. f :: (Eq a, _) => a -> a - -- Any extra constraints inferred during - -- type-checking will be added to the sig_theta. - -data TcPatSynInfo - = TPSI { - patsig_name :: Name, - patsig_tau :: TcSigmaType, - patsig_ex :: [TcTyVar], - patsig_prov :: TcThetaType, - patsig_univ :: [TcTyVar], - patsig_req :: TcThetaType - } - -findScopedTyVars -- See Note [Binding scoped type variables] - :: LHsType Name -- The HsType - -> TcType -- The corresponding Type: - -- uses same Names as the HsType - -> [TcTyVar] -- The instantiated forall variables of the Type - -> [(Maybe Name, TcTyVar)] -- In 1-1 correspondence with the instantiated vars -findScopedTyVars hs_ty sig_ty inst_tvs - = zipWith find sig_tvs inst_tvs - where - find sig_tv inst_tv - | tv_name `elemNameSet` scoped_names = (Just tv_name, inst_tv) - | otherwise = (Nothing, inst_tv) - where - tv_name = tyVarName sig_tv - - scoped_names = mkNameSet (hsExplicitTvs hs_ty) - (sig_tvs,_) = tcSplitForAllTys sig_ty - -instance NamedThing TcIdSigInfo where - getName (TISI { sig_bndr = bndr }) = getName bndr - -instance NamedThing TcIdSigBndr where - getName (CompleteSig id) = idName id - getName (PartialSig { sig_name = n }) = n - -instance NamedThing TcSigInfo where - getName (TcIdSig idsi) = getName idsi - getName (TcPatSynSig tpsi) = patsig_name tpsi - -instance Outputable TcSigInfo where - ppr (TcIdSig idsi) = ppr idsi - ppr (TcPatSynSig tpsi) = text "TcPatSynInfo" <+> ppr tpsi - -instance Outputable TcIdSigInfo where - ppr (TISI { sig_bndr = bndr, sig_tvs = tyvars - , sig_theta = theta, sig_tau = tau }) - = ppr bndr <+> dcolon <+> - vcat [ pprSigmaType (mkSigmaTy (map snd tyvars) theta tau) - , ppr (map fst tyvars) ] - -instance Outputable TcIdSigBndr where - ppr s_bndr = ppr (getName s_bndr) - -instance Outputable TcPatSynInfo where - ppr (TPSI{ patsig_name = name}) = ppr name - -isPartialSig :: TcIdSigInfo -> Bool -isPartialSig (TISI { sig_bndr = PartialSig {} }) = True -isPartialSig _ = False - --- | No signature or a partial signature -noCompleteSig :: Maybe TcSigInfo -> Bool -noCompleteSig (Just (TcIdSig sig)) = isPartialSig sig -noCompleteSig _ = True - --- Helper for cases when we know for sure we have a complete type --- signature, e.g. class methods. -completeIdSigPolyId :: TcIdSigInfo -> TcId -completeIdSigPolyId (TISI { sig_bndr = CompleteSig id }) = id -completeIdSigPolyId _ = panic "completeSigPolyId" - -completeIdSigPolyId_maybe :: TcIdSigInfo -> Maybe TcId -completeIdSigPolyId_maybe (TISI { sig_bndr = CompleteSig id }) = Just id -completeIdSigPolyId_maybe _ = Nothing - -completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId -completeSigPolyId_maybe (TcIdSig sig) = completeIdSigPolyId_maybe sig -completeSigPolyId_maybe (TcPatSynSig {}) = Nothing - -{- -Note [Binding scoped type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The type variables *brought into lexical scope* by a type signature may -be a subset of the *quantified type variables* of the signatures, for two reasons: - -* With kind polymorphism a signature like - f :: forall f a. f a -> f a - may actually give rise to - f :: forall k. forall (f::k -> *) (a:k). f a -> f a - So the sig_tvs will be [k,f,a], but only f,a are scoped. - NB: the scoped ones are not necessarily the *inital* ones! - -* Even aside from kind polymorphism, tere may be more instantiated - type variables than lexically-scoped ones. For example: - type T a = forall b. b -> (a,b) - f :: forall c. T c - Here, the signature for f will have one scoped type variable, c, - but two instantiated type variables, c' and b'. - -The function findScopedTyVars takes - * hs_ty: the original HsForAllTy - * sig_ty: the corresponding Type (which is guaranteed to use the same Names - as the HsForAllTy) - * inst_tvs: the skolems instantiated from the forall's in sig_ty -It returns a [(Maybe Name, TcTyVar)], in 1-1 correspondence with inst_tvs -but with a (Just n) for the lexically scoped name of each in-scope tyvar. - -Note [sig_tau may be polymorphic] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note that "sig_tau" might actually be a polymorphic type, -if the original function had a signature like - forall a. Eq a => forall b. Ord b => .... -But that's ok: tcMatchesFun (called by tcRhs) can deal with that -It happens, too! See Note [Polymorphic methods] in TcClassDcl. - -Note [Existential check] -~~~~~~~~~~~~~~~~~~~~~~~~ -Lazy patterns can't bind existentials. They arise in two ways: - * Let bindings let { C a b = e } in b - * Twiddle patterns f ~(C a b) = e -The pe_lazy field of PatEnv says whether we are inside a lazy -pattern (perhaps deeply) - -If we aren't inside a lazy pattern then we can bind existentials, -but we need to be careful about "extra" tyvars. Consider - (\C x -> d) : pat_ty -> res_ty -When looking for existential escape we must check that the existential -bound by C don't unify with the free variables of pat_ty, OR res_ty -(or of course the environment). Hence we need to keep track of the -res_ty free vars. - -Note [Complete and partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A type signature is partial when it contains one or more wildcards -(= type holes). The wildcard can either be: -* A (type) wildcard occurring in sig_theta or sig_tau. These are - stored in sig_nwcs. - f :: Bool -> _ - g :: Eq _a => _a -> _a -> Bool -* Or an extra-constraints wildcard, stored in sig_cts: - h :: (Num a, _) => a -> a - -A type signature is a complete type signature when there are no -wildcards in the type signature, i.e. iff sig_nwcs is empty and -sig_extra_cts is Nothing. - -************************************************************************ +{- ********************************************************************* * * Binders * * -************************************************************************ --} +********************************************************************* -} -tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (TcCoercion, TcId) +tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (TcCoercionN, TcId) -- (coi, xp) = tcPatBndr penv x pat_ty -- Then coi : pat_ty ~ typeof(xp) -- @@ -580,9 +391,9 @@ tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside -- Type signatures in patterns -- See Note [Pattern coercions] below tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside - = do { (inner_ty, tv_binds, nwc_binds, wrap) <- tcPatSig (inPatBind penv) + = do { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv) sig_ty pat_ty - ; (pat', res) <- tcExtendTyVarEnv2 (tv_binds ++ nwc_binds) $ + ; (pat', res) <- tcExtendTyVarEnv2 (wcs ++ tv_binds) $ tc_lpat pat inner_ty penv thing_inside ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) } @@ -888,12 +699,12 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside ; checkExistentials ex_tvs penv ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs - ; let ty' = substTy tenv ty - arg_tys' = substTys tenv arg_tys + ; let ty' = substTy tenv ty + arg_tys' = substTys tenv arg_tys prov_theta' = substTheta tenv prov_theta - req_theta' = substTheta tenv req_theta + req_theta' = substTheta tenv req_theta - ; wrap <- coToHsWrapper <$> unifyType ty' pat_ty + ; wrap <- mkWpCastN <$> unifyType ty' pat_ty ; traceTc "tcPatSynPat" (ppr pat_syn $$ ppr pat_ty $$ ppr ty' $$ @@ -940,14 +751,15 @@ matchExpectedTyConAppR tc = downgrade (matchExpectedTyConApp tc) ---------------------------- matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionR, a)) - -> TcRhoType -> TcM (HsWrapper, a) + -> TcRhoType -- Type of the pattern + -> TcM (HsWrapper, a) -- See Note [Matching polytyped patterns] -- Returns a wrapper : pat_ty ~R inner_ty matchExpectedPatTy inner_match pat_ty | null tvs && null theta = do { (co, res) <- inner_match pat_ty -- 'co' is Representational ; traceTc "matchExpectedPatTy" (ppr pat_ty $$ ppr co $$ ppr (isTcReflCo co)) - ; return (coToHsWrapperR (mkTcSymCo co), res) } + ; return (mkWpCastR (mkTcSymCo co), res) } -- The Sym is because the inner_match returns a coercion -- that is the other way round to matchExpectedPatTy @@ -962,10 +774,14 @@ matchExpectedPatTy inner_match pat_ty ---------------------------- matchExpectedConTy :: TyCon -- The TyCon that this data -- constructor actually returns - -> TcRhoType -- The type of the pattern + -- In the case of a data family this is + -- the /representation/ TyCon + -> TcRhoType -- The type of the pattern; in the case + -- of a data family this would mention + -- the /family/ TyCon -> TcM (TcCoercionR, [TcSigmaType]) -- See Note [Matching constructor patterns] --- Returns a coercion : T ty1 ... tyn ~ pat_ty +-- Returns a coercion : T ty1 ... tyn ~R pat_ty -- This is the same way round as matchExpectedListTy etc -- but the other way round to matchExpectedPatTy matchExpectedConTy data_tc pat_ty @@ -982,7 +798,7 @@ matchExpectedConTy data_tc pat_ty -- co1 : T (ty1,ty2) ~N pat_ty ; let tys' = mkTyVarTys tvs' - co2 = mkTcUnbranchedAxInstCo Representational co_tc tys' + co2 = mkTcUnbranchedAxInstCo co_tc tys' -- co2 : T (ty1,ty2) ~R T7 ty1 ty2 ; return (mkTcSymCo co2 `mkTcTransCo` mkTcSubCo co1, tys') } diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 172fae60b6..30dcbf7b65 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -69,8 +69,7 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details, ; tcCheckPatSynPat lpat ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details - - ; ((lpat', (args, pat_ty)), tclvl, wanted) + ; (tclvl, wanted, (lpat', (args, pat_ty))) <- pushLevelAndCaptureConstraints $ do { pat_ty <- newFlexiTyVarTy openTypeKind ; tcPat PatSyn lpat pat_ty $ @@ -142,7 +141,7 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details, { arg <- tcLookupId arg_name ; let arg_ty' = substTy subst arg_ty ; coi <- unifyType (varType arg) arg_ty' - ; return (setVarType arg arg_ty, coToHsWrapper coi) } + ; return (setVarType arg arg_ty, mkWpCastN coi) } ; return (ex_tys, prov_theta', wrapped_args) } ; (ex_vars_rhs, prov_dicts_rhs) <- tcCollectEx lpat' diff --git a/compiler/typecheck/TcPatSyn.hs-boot b/compiler/typecheck/TcPatSyn.hs-boot index 477ce9bfda..61f79589ef 100644 --- a/compiler/typecheck/TcPatSyn.hs-boot +++ b/compiler/typecheck/TcPatSyn.hs-boot @@ -3,9 +3,8 @@ module TcPatSyn where import Name ( Name ) import Id ( Id ) import HsSyn ( PatSynBind, LHsBinds ) -import TcRnTypes ( TcM ) +import TcRnTypes ( TcM, TcPatSynInfo ) import PatSyn ( PatSyn ) -import TcPat ( TcPatSynInfo ) import TcRnMonad ( TcGblEnv ) import Outputable ( Outputable ) diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 2e86d322b3..ee95bb5594 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -815,7 +815,10 @@ checkHiBootIface' local_export_env = availsToNameEnv local_exports check_inst :: ClsInst -> TcM (Maybe (Id, Id)) - -- Returns a pair of the boot dfun in terms of the equivalent real dfun + -- Returns a pair of the boot dfun in terms of the equivalent + -- real dfun. Delicate (like checkBootDecl) because it depends + -- on the types lining up precisely even to the ordering of + -- the type variables in the foralls. check_inst boot_inst = case [dfun | inst <- local_insts, let dfun = instanceDFunId inst, @@ -825,7 +828,8 @@ checkHiBootIface' , text "boot_inst" <+> ppr boot_inst , text "boot_dfun_ty" <+> ppr boot_dfun_ty ] - ; addErrTc (instMisMatch True boot_inst); return Nothing } + ; addErrTc (instMisMatch True boot_inst) + ; return Nothing } (dfun:_) -> return (Just (local_boot_dfun, dfun)) where local_boot_dfun = Id.mkExportedLocalId VanillaId boot_dfun_name (idType dfun) @@ -1950,18 +1954,17 @@ getGhciStepIO = do ghciTy <- getGHCiMonad fresh_a <- newUnique loc <- getSrcSpanM - let a_tv = mkInternalName fresh_a (mkTyVarOccFS (fsLit "a")) loc - ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv) - ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) - - stepTy :: LHsType Name -- Renamed, so needs all binders in place - stepTy = noLoc $ HsForAllTy Implicit Nothing - (HsQTvs { hsq_tvs = [noLoc (UserTyVar (noLoc a_tv))] - , hsq_kvs = [] }) - (noLoc []) - (nlHsFunTy ghciM ioM) - step = noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy [] - return step + let a_tv = mkInternalName fresh_a (mkTyVarOccFS (fsLit "a")) loc + ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv) + ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) + + step_ty = noLoc $ HsForAllTy { hst_bndrs = [noLoc $ UserTyVar (noLoc a_tv)] + , hst_body = nlHsFunTy ghciM ioM } + + stepTy :: LHsSigWcType Name + stepTy = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs step_ty) + + return (noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy) isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name) isGHCiMonad hsc_env ty @@ -1997,7 +2000,7 @@ tcRnExpr hsc_env rdr_expr -- it might have a rank-2 type (e.g. :t runST) uniq <- newUnique ; let { fresh_it = itName uniq (getLoc rdr_expr) } ; - ((_tc_expr, res_ty), tclvl, lie) <- pushLevelAndCaptureConstraints $ + (tclvl, lie, (_tc_expr, res_ty)) <- pushLevelAndCaptureConstraints $ tcInferRho rn_expr ; ((qtvs, dicts, _), lie_top) <- captureConstraints $ {-# SCC "simplifyInfer" #-} @@ -2047,12 +2050,17 @@ tcRnType :: HscEnv tcRnType hsc_env normalise rdr_type = runTcInteractive hsc_env $ setXOptM Opt_PolyKinds $ -- See Note [Kind-generalise in tcRnType] - do { (rn_type, _fvs, wcs) <- rnLHsTypeWithWildCards GHCiCtx rdr_type + do { (HsWC { hswc_wcs = wcs, hswc_body = rn_type }, _fvs) + <- rnHsWcType GHCiCtx (mkHsWildCardBndrs rdr_type) + -- The type can have wild cards, but no implicit + -- generalisation; e.g. :kind (T _) ; failIfErrsM -- Now kind-check the type -- It can have any rank or kind - ; (ty, kind) <- tcWildcardBinders wcs $ \_ -> + -- First bring into scope any wildcards + ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type]) + ; (ty, kind) <- tcWildCardBinders wcs $ \ _ -> tcLHsType rn_type -- Do kind generalisation; see Note [Kind-generalise in tcRnType] diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 770b5bcfa5..d5654aee89 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -843,7 +843,7 @@ tryTc m -- (askNoErrs m) runs m -- If m fails, (askNoErrs m) fails -- If m succeeds with result r, (askNoErrs m) succeeds with result (r, b), --- where b is True iff m generated no error +-- where b is True iff m generated no errors -- Regardless of success or failure, any errors generated by m are propagated askNoErrs :: TcRn a -> TcRn (a, Bool) askNoErrs m @@ -853,13 +853,21 @@ askNoErrs m ; addMessages (warns, errs) ; return (res, isEmptyBag errs) } +discardErrs :: TcRn a -> TcRn a +-- (discardErrs m) runs m, +-- discarding all error messages and warnings generated by m +-- If m fails, discardErrs fails, and vice versa +discardErrs m + = do { errs_var <- newTcRef emptyMessages + ; setErrsVar errs_var m } + ----------------------- tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a) -- Run the thing, returning -- Just r, if m succceeds with no error messages -- Nothing, if m fails, or if it succeeds but has error messages --- Either way, the messages are returned; even in the Just case --- there might be warnings +-- Either way, the messages are returned; +-- even in the Just case there might be warnings tryTcErrs thing = do { (msgs, res) <- tryTc thing ; dflags <- getDynFlags @@ -1187,7 +1195,8 @@ emitImplication ct emitImplications :: Bag Implication -> TcM () emitImplications ct - = do { lie_var <- getConstraintVar ; + = unless (isEmptyBag ct) $ + do { lie_var <- getConstraintVar ; updTcRef lie_var (`addImplics` ct) } emitInsoluble :: Ct -> TcM () @@ -1206,7 +1215,7 @@ captureConstraints thing_inside lie <- readTcRef lie_var ; return (res, lie) } -pushLevelAndCaptureConstraints :: TcM a -> TcM (a, TcLevel, WantedConstraints) +pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a) pushLevelAndCaptureConstraints thing_inside = do { env <- getLclEnv ; lie_var <- newTcRef emptyWC ; @@ -1215,7 +1224,7 @@ pushLevelAndCaptureConstraints thing_inside , tcl_lie = lie_var }) thing_inside ; lie <- readTcRef lie_var - ; return (res, tclvl', lie) } + ; return (tclvl', lie, res) } pushTcLevelM_ :: TcM a -> TcM a pushTcLevelM_ = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) @@ -1260,19 +1269,18 @@ traceTcConstraints msg ; traceTc (msg ++ ": LIE:") (ppr lie) } -emitWildcardHoleConstraints :: [(Name, TcTyVar)] -> TcM () -emitWildcardHoleConstraints wcs +emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM () +emitWildCardHoleConstraints wcs = do { ctLoc <- getCtLocM HoleOrigin ; forM_ wcs $ \(name, tv) -> do { ; let real_span = case nameSrcSpan name of RealSrcSpan span -> span - UnhelpfulSpan str -> pprPanic "emitWildcardHoleConstraints" + UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints" (ppr name <+> quotes (ftext str)) -- Wildcards are defined locally, and so have RealSrcSpans ctLoc' = setCtLocSpan ctLoc real_span ty = mkTyVarTy tv - ev = mkLocalId name ty - can = CHoleCan { cc_ev = CtWanted ty ev ctLoc' + can = CHoleCan { cc_ev = CtDerived { ctev_pred = ty, ctev_loc = ctLoc' } , cc_occ = occName name , cc_hole = TypeHole } ; emitInsoluble can } } diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index bbf77be8e6..82bf1be007 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -54,6 +54,11 @@ module TcRnTypes( -- Arrows ArrowCtxt(..), + -- TcSigInfo + TcSigInfo(..), TcIdSigInfo(..), TcPatSynInfo(..), TcIdSigBndr(..), + findScopedTyVars, isPartialSig, noCompleteSig, tcSigInfoName, + completeIdSigPolyId, completeSigPolyId_maybe, completeIdSigPolyId_maybe, + -- Canonical constraints Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts, singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList, @@ -71,6 +76,7 @@ module TcRnTypes( andWC, unionsWC, addSimples, addImplics, mkSimpleWC, addInsols, dropDerivedWC, dropDerivedSimples, dropDerivedInsols, isDroppableDerivedLoc, insolubleImplic, trulyInsoluble, + arisesFromGivens, Implication(..), ImplicStatus(..), isInsolubleStatus, SubGoalDepth, initialSubGoalDepth, @@ -81,7 +87,7 @@ module TcRnTypes( CtOrigin(..), pprCtOrigin, pprCtLoc, pushErrCtxt, pushErrCtxtSameOrigin, - SkolemInfo(..), + SkolemInfo(..), pprSigSkolInfo, pprSkolInfo, CtEvidence(..), mkGivenLoc, @@ -119,6 +125,7 @@ import TyCon ( TyCon ) import ConLike ( ConLike(..) ) import DataCon ( DataCon, dataConUserType, dataConOrigArgTys ) import PatSyn ( PatSyn, patSynType ) +import Id ( idName ) import FieldLabel ( FieldLabel ) import TcType import Annotations @@ -1086,6 +1093,205 @@ instance Outputable WhereFrom where ppr ImportBySystem = ptext (sLit "{- SYSTEM -}") ppr ImportByPlugin = ptext (sLit "{- PLUGIN -}") + +{- ********************************************************************* +* * + Type signatures +* * +********************************************************************* -} + +data TcSigInfo = TcIdSig TcIdSigInfo + | TcPatSynSig TcPatSynInfo + +data TcIdSigInfo + = TISI + { sig_bndr :: TcIdSigBndr + + , sig_skols :: [(Name, TcTyVar)] + -- Instantiated type and kind variables SKOLEMS + -- The Name is the Name that the renamer chose; + -- but the TcTyVar may come from instantiating + -- the type and hence have a different unique. + -- No need to keep track of whether they are truly lexically + -- scoped because the renamer has named them uniquely + -- + -- For Partial signatures, this list /excludes/ any wildcards + -- the named wildcards scope over the binding, and hence + -- their Names may appear in renamed type signatures + -- in the binding; get them from sig_bndr + -- See Note [Binding scoped type variables] + + , sig_theta :: TcThetaType -- Instantiated theta. In the case of a + -- PartialSig, sig_theta does not include + -- the extra-constraints wildcard + + , sig_tau :: TcSigmaType -- Instantiated tau + -- See Note [sig_tau may be polymorphic] + + , sig_ctxt :: UserTypeCtxt -- In the case of type-class default methods, + -- the Name in the FunSigCtxt is not the same + -- as the TcId; the former is 'op', while the + -- latter is '$dmop' or some such + + , sig_loc :: SrcSpan -- Location of the type signature + } + +data TcIdSigBndr -- See Note [Complete and partial type signatures] + = CompleteSig -- A complete signature with no wildards, + -- so the complete polymorphic type is known. + TcId -- The polymoprhic Id with that type + + | PartialSig -- A partial type signature (i.e. includes one or more + -- wildcards). In this case it doesn't make sense to give + -- the polymorphic Id, because we are going to /infer/ its + -- type, so we can't make the polymorphic Id ab-initio + { sig_name :: Name -- Name of the function; used when report wildcards + , sig_hs_ty :: LHsType Name -- The original partial signature + , sig_wcs :: [(Name,TcTyVar)] -- Instantiated wildcard variables (named and anonymous) + -- The Name is what the user wrote, such as '_', + -- including SrcSpan for the error message; + -- The TcTyVar is just an ordinary unification variable + , sig_cts :: Maybe SrcSpan -- Just loc <=> An extra-constraints wildcard was present + } -- at location loc + -- e.g. f :: (Eq a, _) => a -> a + +data TcPatSynInfo + = TPSI { + patsig_name :: Name, + patsig_tau :: TcSigmaType, + patsig_ex :: [TcTyVar], + patsig_prov :: TcThetaType, + patsig_univ :: [TcTyVar], + patsig_req :: TcThetaType + } + +findScopedTyVars -- See Note [Binding scoped type variables] + :: TcType -- The Type: its forall'd variables are a superset + -- of the lexically scoped variables + -> [TcTyVar] -- The instantiated forall variables of the TcType + -> [(Name, TcTyVar)] -- In 1-1 correspondence with the instantiated vars +findScopedTyVars sig_ty inst_tvs + = zipWith find sig_tvs inst_tvs + where + find sig_tv inst_tv = (tyVarName sig_tv, inst_tv) + (sig_tvs,_) = tcSplitForAllTys sig_ty + +instance Outputable TcSigInfo where + ppr (TcIdSig idsi) = ppr idsi + ppr (TcPatSynSig tpsi) = text "TcPatSynInfo" <+> ppr tpsi + +instance Outputable TcIdSigInfo where + ppr (TISI { sig_bndr = bndr, sig_skols = tyvars + , sig_theta = theta, sig_tau = tau }) + = ppr (tcIdSigBndrName bndr) <+> dcolon <+> + vcat [ pprSigmaType (mkSigmaTy (map snd tyvars) theta tau) + , ppr (map fst tyvars) ] + +instance Outputable TcIdSigBndr where + ppr (CompleteSig f) = ptext (sLit "CompleteSig") <+> ppr f + ppr (PartialSig { sig_name = n }) = ptext (sLit "PartialSig") <+> ppr n + +instance Outputable TcPatSynInfo where + ppr (TPSI{ patsig_name = name}) = ppr name + +isPartialSig :: TcIdSigInfo -> Bool +isPartialSig (TISI { sig_bndr = PartialSig {} }) = True +isPartialSig _ = False + +-- | No signature or a partial signature +noCompleteSig :: Maybe TcSigInfo -> Bool +noCompleteSig (Just (TcIdSig sig)) = isPartialSig sig +noCompleteSig _ = True + +tcIdSigBndrName :: TcIdSigBndr -> Name +tcIdSigBndrName (CompleteSig id) = idName id +tcIdSigBndrName (PartialSig { sig_name = n }) = n + +tcSigInfoName :: TcSigInfo -> Name +tcSigInfoName (TcIdSig idsi) = tcIdSigBndrName (sig_bndr idsi) +tcSigInfoName (TcPatSynSig tpsi) = patsig_name tpsi + +-- Helper for cases when we know for sure we have a complete type +-- signature, e.g. class methods. +completeIdSigPolyId :: TcIdSigInfo -> TcId +completeIdSigPolyId (TISI { sig_bndr = CompleteSig id }) = id +completeIdSigPolyId _ = panic "completeSigPolyId" + +completeIdSigPolyId_maybe :: TcIdSigInfo -> Maybe TcId +completeIdSigPolyId_maybe (TISI { sig_bndr = CompleteSig id }) = Just id +completeIdSigPolyId_maybe _ = Nothing + +completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId +completeSigPolyId_maybe (TcIdSig sig) = completeIdSigPolyId_maybe sig +completeSigPolyId_maybe (TcPatSynSig {}) = Nothing + +{- +Note [Binding scoped type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type variables *brought into lexical scope* by a type signature may +be a subset of the *quantified type variables* of the signatures, for two reasons: + +* With kind polymorphism a signature like + f :: forall f a. f a -> f a + may actually give rise to + f :: forall k. forall (f::k -> *) (a:k). f a -> f a + So the sig_tvs will be [k,f,a], but only f,a are scoped. + NB: the scoped ones are not necessarily the *inital* ones! + +* Even aside from kind polymorphism, there may be more instantiated + type variables than lexically-scoped ones. For example: + type T a = forall b. b -> (a,b) + f :: forall c. T c + Here, the signature for f will have one scoped type variable, c, + but two instantiated type variables, c' and b'. + +The function findScopedTyVars takes + * hs_ty: the original HsForAllTy + * sig_ty: the corresponding Type (which is guaranteed to use the same Names + as the HsForAllTy) + * inst_tvs: the skolems instantiated from the forall's in sig_ty +It returns a [(Maybe Name, TcTyVar)], in 1-1 correspondence with inst_tvs +but with a (Just n) for the lexically scoped name of each in-scope tyvar. + +Note [sig_tau may be polymorphic] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that "sig_tau" might actually be a polymorphic type, +if the original function had a signature like + forall a. Eq a => forall b. Ord b => .... +But that's ok: tcMatchesFun (called by tcRhs) can deal with that +It happens, too! See Note [Polymorphic methods] in TcClassDcl. + +Note [Existential check] +~~~~~~~~~~~~~~~~~~~~~~~~ +Lazy patterns can't bind existentials. They arise in two ways: + * Let bindings let { C a b = e } in b + * Twiddle patterns f ~(C a b) = e +The pe_lazy field of PatEnv says whether we are inside a lazy +pattern (perhaps deeply) + +If we aren't inside a lazy pattern then we can bind existentials, +but we need to be careful about "extra" tyvars. Consider + (\C x -> d) : pat_ty -> res_ty +When looking for existential escape we must check that the existential +bound by C don't unify with the free variables of pat_ty, OR res_ty +(or of course the environment). Hence we need to keep track of the +res_ty free vars. + +Note [Complete and partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A type signature is partial when it contains one or more wildcards +(= type holes). The wildcard can either be: +* A (type) wildcard occurring in sig_theta or sig_tau. These are + stored in sig_wcs. + f :: Bool -> _ + g :: Eq _a => _a -> _a -> Bool +* Or an extra-constraints wildcard, stored in sig_cts: + h :: (Num a, _) => a -> a + +A type signature is a complete type signature when there are no +wildcards in the type signature, i.e. iff sig_wcs is empty and +sig_extra_cts is Nothing. -} + {- ************************************************************************ * * @@ -1325,12 +1531,28 @@ isDroppableDerivedLoc :: CtLoc -> Bool -- Note [Dropping derived constraints] isDroppableDerivedLoc loc = case ctLocOrigin loc of + HoleOrigin {} -> False KindEqOrigin {} -> False GivenOrigin {} -> False FunDepOrigin1 {} -> False FunDepOrigin2 {} -> False _ -> True +arisesFromGivens :: Ct -> Bool +arisesFromGivens ct + = case ctEvidence ct of + CtGiven {} -> True + CtWanted {} -> False + CtDerived { ctev_loc = loc } -> from_given loc + where + from_given :: CtLoc -> Bool + from_given loc = from_given_origin (ctLocOrigin loc) + + from_given_origin :: CtOrigin -> Bool + from_given_origin (GivenOrigin {}) = True + from_given_origin (FunDepOrigin1 _ l1 _ l2) = from_given l1 && from_given l2 + from_given_origin (FunDepOrigin2 _ o1 _ _) = from_given_origin o1 + from_given_origin _ = False {- Note [Dropping derived constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1357,6 +1579,9 @@ But (tiresomely) we do keep *some* Derived insolubles: - For Wanteds it is arguably better to get a fundep error than a no-instance error (Trac #9612) + * Type holes are derived constraints because they have no evidence + and we want to keep them so we get the error report + Moreover, we keep *all* derived insolubles under some circumstances: * They are looked at by simplifyInfer, to decide whether to @@ -1448,14 +1673,15 @@ isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of _ -> False instance Outputable Ct where - ppr ct = ppr (cc_ev ct) <+> parens (text ct_sort) - where ct_sort = case ct of - CTyEqCan {} -> "CTyEqCan" - CFunEqCan {} -> "CFunEqCan" - CNonCanonical {} -> "CNonCanonical" - CDictCan {} -> "CDictCan" - CIrredEvCan {} -> "CIrredEvCan" - CHoleCan {} -> "CHoleCan" + ppr ct = ppr (cc_ev ct) <+> parens pp_sort + where + pp_sort = case ct of + CTyEqCan {} -> text "CTyEqCan" + CFunEqCan {} -> text "CFunEqCan" + CNonCanonical {} -> text "CNonCanonical" + CDictCan {} -> text "CDictCan" + CIrredEvCan {} -> text "CIrredEvCan" + CHoleCan { cc_occ = occ } -> text "CHoleCan:" <+> ppr occ singleCt :: Ct -> Cts singleCt = unitBag @@ -2189,8 +2415,8 @@ pprSigSkolInfo :: UserTypeCtxt -> Type -> SDoc pprSigSkolInfo ctxt ty = case ctxt of FunSigCtxt f _ -> pp_sig f - _ -> hang (pprUserTypeCtxt ctxt <> colon) - 2 (ppr ty) + _ -> vcat [ pprUserTypeCtxt ctxt <> colon + , nest 2 (ppr ty) ] where pp_sig f = vcat [ ptext (sLit "the type signature for:") , nest 2 (pprPrefixOcc f <+> dcolon <+> ppr ty) ] diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs index 3625db182b..0d1c6d5baa 100644 --- a/compiler/typecheck/TcRules.hs +++ b/compiler/typecheck/TcRules.hs @@ -16,7 +16,7 @@ import TcType import TcHsType import TcExpr import TcEnv -import TcEvidence( TcEvBinds(..) ) +import TcUnify( buildImplicationFor ) import Type import Id import Var ( EvVar ) @@ -105,36 +105,21 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) ]) -- Simplify the RHS constraints - ; lcl_env <- getLclEnv - ; rhs_binds_var <- newTcEvBinds - ; emitImplication $ Implic { ic_tclvl = topTcLevel - , ic_skols = qtkvs - , ic_no_eqs = False - , ic_given = lhs_evs - , ic_wanted = rhs_wanted - , ic_status = IC_Unsolved - , ic_binds = rhs_binds_var - , ic_info = RuleSkol (snd $ unLoc name) - , ic_env = lcl_env } + ; let skol_info = RuleSkol (snd $ unLoc name) + ; (rhs_implic, rhs_binds) <- buildImplicationFor topTcLevel skol_info qtkvs + lhs_evs rhs_wanted -- For the LHS constraints we must solve the remaining constraints -- (a) so that we report insoluble ones -- (b) so that we bind any soluble ones - ; lhs_binds_var <- newTcEvBinds - ; emitImplication $ Implic { ic_tclvl = topTcLevel - , ic_skols = qtkvs - , ic_no_eqs = False - , ic_given = lhs_evs - , ic_wanted = other_lhs_wanted - , ic_status = IC_Unsolved - , ic_binds = lhs_binds_var - , ic_info = RuleSkol (snd $ unLoc name) - , ic_env = lcl_env } + ; (lhs_implic, lhs_binds) <- buildImplicationFor topTcLevel skol_info qtkvs + lhs_evs other_lhs_wanted + ; emitImplications (lhs_implic `unionBags` rhs_implic) ; return (HsRule name act (map (noLoc . RuleBndr . noLoc) (qtkvs ++ tpl_ids)) - (mkHsDictLet (TcEvBinds lhs_binds_var) lhs') fv_lhs - (mkHsDictLet (TcEvBinds rhs_binds_var) rhs') fv_rhs) } + (mkHsDictLet lhs_binds lhs') fv_lhs + (mkHsDictLet rhs_binds rhs') fv_rhs) } tcRuleBndrs :: [LRuleBndr Name] -> TcM [Var] tcRuleBndrs [] diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 34e7843f69..bf3f3977db 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -2681,20 +2681,8 @@ newFlattenSkolem Derived loc fam_ty ; return (ev, fmv) } newFsk, newFmv :: TcType -> TcS TcTyVar -newFsk fam_ty - = wrapTcS $ do { uniq <- TcM.newUnique - ; let name = TcM.mkTcTyVarName uniq (fsLit "fsk") - ; return (mkTcTyVar name (typeKind fam_ty) (FlatSkol fam_ty)) } - -newFmv fam_ty - = wrapTcS $ do { uniq <- TcM.newUnique - ; ref <- TcM.newMutVar Flexi - ; cur_lvl <- TcM.getTcLevel - ; let details = MetaTv { mtv_info = FlatMetaTv - , mtv_ref = ref - , mtv_tclvl = fmvTcLevel cur_lvl } - name = TcM.mkTcTyVarName uniq (fsLit "s") - ; return (mkTcTyVar name (typeKind fam_ty) details) } +newFsk fam_ty = wrapTcS (TcM.newFskTyVar fam_ty) +newFmv fam_ty = wrapTcS (TcM.newFmvTyVar fam_ty) extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcType, CtFlavour) -> TcS () extendFlatCache tc xi_args stuff diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index d1ba2d571c..b8e193b0bf 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -389,24 +389,24 @@ the let binding. simplifyInfer :: TcLevel -- Used when generating the constraints -> Bool -- Apply monomorphism restriction - -> [TcTyVar] -- The quantified tyvars of any signatures - -- see Note [Which type variables to quantify] + -> [TcIdSigInfo] -- Any signatures (possibly partial) -> [(Name, TcTauType)] -- Variables to be generalised, -- and their tau-types -> WantedConstraints -> TcM ([TcTyVar], -- Quantify over these type variables [EvVar], -- ... and these constraints (fully zonked) TcEvBinds) -- ... binding these evidence variables -simplifyInfer rhs_tclvl apply_mr sig_qtvs name_taus wanteds +simplifyInfer rhs_tclvl apply_mr sigs name_taus wanteds | isEmptyWC wanteds = do { gbl_tvs <- tcGetGlobalTyVars - ; qtkvs <- quantifyTyVars gbl_tvs (tyVarsOfTypes (map snd name_taus)) + ; qtkvs <- quantify_tvs sigs gbl_tvs (tyVarsOfTypes (map snd name_taus)) ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) ; return (qtkvs, [], emptyTcEvBinds) } | otherwise = do { traceTc "simplifyInfer {" $ vcat - [ ptext (sLit "binds =") <+> ppr name_taus + [ ptext (sLit "sigs =") <+> ppr sigs + , ptext (sLit "binds =") <+> ppr name_taus , ptext (sLit "rhs_tclvl =") <+> ppr rhs_tclvl , ptext (sLit "apply_mr =") <+> ppr apply_mr , ptext (sLit "(unzonked) wanted =") <+> ppr wanteds @@ -473,8 +473,8 @@ simplifyInfer rhs_tclvl apply_mr sig_qtvs name_taus wanteds -- Decide what type variables and constraints to quantify ; zonked_taus <- mapM (TcM.zonkTcType . snd) name_taus ; let zonked_tau_tvs = tyVarsOfTypes zonked_taus - ; (qtvs, bound_theta) <- decideQuantification apply_mr sig_qtvs name_taus - quant_pred_candidates zonked_tau_tvs + ; (qtvs, bound_theta) <- decideQuantification apply_mr sigs name_taus + quant_pred_candidates zonked_tau_tvs -- Emit an implication constraint for the -- remaining constraints from the RHS @@ -565,37 +565,38 @@ and the quantified constraints are empty/insoluble decideQuantification :: Bool -- Apply monomorphism restriction - -> [TcTyVar] + -> [TcIdSigInfo] -> [(Name, TcTauType)] -- Variables to be generalised (just for error msg) -> [PredType] -> TcTyVarSet -- Constraints and type variables from RHS -> TcM ( [TcTyVar] -- Quantify over these tyvars (skolems) , [PredType]) -- and this context (fully zonked) -- See Note [Deciding quantification] -decideQuantification apply_mr sig_qtvs name_taus constraints zonked_tau_tvs +decideQuantification apply_mr sigs name_taus constraints zonked_tau_tvs | apply_mr -- Apply the Monomorphism restriction = do { gbl_tvs <- tcGetGlobalTyVars ; let constrained_tvs = tyVarsOfTypes constraints mono_tvs = gbl_tvs `unionVarSet` constrained_tvs - mr_bites = constrained_tvs `intersectsVarSet` zonked_tau_tvs - ; qtvs <- quantify_tvs mono_tvs zonked_tau_tvs - ; traceTc "decideQuantification 1" (vcat [ppr constraints, ppr gbl_tvs, ppr mono_tvs - , ppr qtvs, ppr mr_bites]) + ; qtvs <- quantify_tvs sigs mono_tvs zonked_tau_tvs -- Warn about the monomorphism restriction ; warn_mono <- woptM Opt_WarnMonomorphism + ; let mr_bites = constrained_tvs `intersectsVarSet` zonked_tau_tvs ; warnTc (warn_mono && mr_bites) $ hang (ptext (sLit "The Monomorphism Restriction applies to the binding") <> plural bndrs <+> ptext (sLit "for") <+> pp_bndrs) 2 (ptext (sLit "Consider giving a type signature for") <+> if isSingleton bndrs then pp_bndrs else ptext (sLit "these binders")) + -- All done + ; traceTc "decideQuantification 1" (vcat [ppr constraints, ppr gbl_tvs, ppr mono_tvs + , ppr qtvs, ppr mr_bites]) ; return (qtvs, []) } | otherwise = do { gbl_tvs <- tcGetGlobalTyVars - ; let mono_tvs = growThetaTyVars (filter isEqPred constraints) gbl_tvs + ; let mono_tvs = growThetaTyVars equality_constraints gbl_tvs tau_tvs_plus = growThetaTyVars constraints zonked_tau_tvs - ; qtvs <- quantify_tvs mono_tvs tau_tvs_plus + ; qtvs <- quantify_tvs sigs mono_tvs tau_tvs_plus ; constraints <- zonkTcThetaType constraints -- quantifyTyVars turned some meta tyvars into -- quantified skolems, so we have to zonk again @@ -606,14 +607,21 @@ decideQuantification apply_mr sig_qtvs name_taus constraints zonked_tau_tvs ; traceTc "decideQuantification 2" (vcat [ppr constraints, ppr gbl_tvs, ppr mono_tvs , ppr tau_tvs_plus, ppr qtvs, ppr min_theta]) ; return (qtvs, min_theta) } - where bndrs = map fst name_taus pp_bndrs = pprWithCommas (quotes . ppr) bndrs - quantify_tvs mono_tvs tau_tvs -- See Note [Which type variable to quantify] - | null sig_qtvs = quantifyTyVars mono_tvs tau_tvs - | otherwise = quantifyTyVars (mono_tvs `delVarSetList` sig_qtvs) - (tau_tvs `extendVarSetList` sig_qtvs) + equality_constraints = filter isEqPred constraints + +quantify_tvs :: [TcIdSigInfo] -> TcTyVarSet -> TcTyVarSet -> TcM [TcTyVar] +-- See Note [Which type variable to quantify] +quantify_tvs sigs mono_tvs tau_tvs + = quantifyTyVars (mono_tvs `delVarSetList` sig_qtvs) + (tau_tvs `extendVarSetList` sig_qtvs `extendVarSetList` sig_wcs) + -- NB: quantifyTyVars zonks its arguments + where + sig_qtvs = [ skol | sig <- sigs, (_, skol) <- sig_skols sig ] + sig_wcs = [ wc | TISI { sig_bndr = PartialSig { sig_wcs = wcs } } <- sigs + , (_, wc) <- wcs ] ------------------ pickQuantifiablePreds :: TyVarSet -- Quantifying over these @@ -681,21 +689,32 @@ quantify over all type variables that are However, for a pattern binding, or with wildcards, we might be doing inference *in the presence of a type signature*. -Mostly, if there is a signature, we use CheckGen, not InferGen, -but with pattern bindings or wildcards we might do inference +Mostly, if there is a signature we use CheckGen, not InferGen, +but with pattern bindings or wildcards we might do InferGen and still have a type signature. For example: f :: _ -> a f x = ... or + g :: (Eq _a) => _b -> _b +or p :: a -> a (p,q) = e -In both cases we use plan InferGen, and hence call simplifyInfer. +In all these cases we use plan InferGen, and hence call simplifyInfer. But those 'a' variables are skolems, and we should be sure to quantify over them, regardless of the monomorphism restriction etc. If we don't, when reporting a type error we panic when we find that a skolem isn't bound by any enclosing implication. -That's why we pass sig_qtvs to simplifyInfer, and make sure (in +Moreover we must quantify over all wildcards that are not free in +the environment. In the case of 'g' for example, silly though it is, +we want to get the inferred type + g :: forall t. Eq t => Int -> Int +and then report ambiguity, rather than *not* quantifying over 't' +and getting some much more mysterious error later. A similar case +is + h :: F _a -> Int + +That's why we pass sigs to simplifyInfer, and make sure (in quantify_tvs) that we do quantify over them. Trac #10615 is a case in point. diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 7a13d8b932..ad8d06e9a0 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -821,7 +821,7 @@ instance TH.Quasi TcM where = return () checkTopDecl (AnnD _) = return () - checkTopDecl (ForD (ForeignImport (L _ name) _ _ _)) + checkTopDecl (ForD (ForeignImport { fd_name = L _ name })) = bindName name checkTopDecl _ = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl" @@ -874,10 +874,10 @@ reifyInstances th_nm th_tys hs_tvbs = mkHsQTvs tv_bndrs -- Rename to HsType Name ; ((rn_tvbs, rn_ty), _fvs) - <- bindHsTyVars doc Nothing kvs hs_tvbs $ \ rn_tvbs -> + <- bindHsQTyVars doc Nothing kvs hs_tvbs $ \ rn_tvbs -> do { (rn_ty, fvs) <- rnLHsType doc rdr_ty ; return ((rn_tvbs, rn_ty), fvs) } - ; (ty, _kind) <- tcHsTyVarBndrs rn_tvbs $ \ _tvs -> + ; (ty, _kind) <- tcHsQTyVars rn_tvbs $ \ _tvs -> tcLHsType rn_ty ; ty <- zonkTcTypeToType emptyZonkEnv ty -- Substitute out the meta type variables diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 8e42ff261f..a2b6a6386e 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -32,6 +32,7 @@ import TcTyDecls import TcClassDcl import TcHsType import TcMType +import RnTypes( collectAnonWildCards ) import TcType import FamInst import FamInstEnv @@ -171,10 +172,11 @@ tcTyClGroup tyclds zipRecTyClss :: [(Name, Kind)] -> [TyCon] -- Knot-tied -> [(Name,TyThing)] --- Build a name-TyThing mapping for the things bound by decls --- being careful not to look at the [TyThing] +-- Build a name-TyThing mapping for the TyCons bound by decls +-- being careful not to look at the knot-tied [TyThing] -- The TyThings in the result list must have a visible ATyCon, --- because typechecking types (in, say, tcTyClDecl) looks at this outer constructor +-- because typechecking types (in, say, tcTyClDecl) looks at +-- this outer constructor zipRecTyClss kind_pairs rec_tycons = [ (name, ATyCon (get name)) | (name, _kind) <- kind_pairs ] where @@ -478,9 +480,8 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs do { _ <- tcHsContext ctxt ; mapM_ (wrapLocM kc_sig) sigs } where - kc_sig (TypeSig _ op_ty _) = discardResult (tcHsLiftedType op_ty) - kc_sig (GenericSig _ op_ty) = discardResult (tcHsLiftedType op_ty) - kc_sig _ = return () + kc_sig (ClassOpSig _ nms op_ty) = kcClassSigType nms op_ty + kc_sig _ = return () -- closed type families look at their equations, but other families don't -- do anything here @@ -1046,9 +1047,9 @@ famTyConShape fam_tc tc_fam_ty_pats :: FamTyConShape -> Maybe ClsInfo - -> HsWithBndrs Name [LHsType Name] -- Patterns - -> (TcKind -> TcM ()) -- Kind checker for RHS - -- result is ignored + -> HsTyPats Name -- Patterns + -> (TcKind -> TcM ()) -- Kind checker for RHS + -- result is ignored -> TcM ([Kind], [Type], Kind) -- Check the type patterns of a type or data family instance -- type instance F <pat1> <pat2> = <type> @@ -1062,8 +1063,8 @@ tc_fam_ty_pats :: FamTyConShape -- (and, if C is poly-kinded, so will its kind parameter). tc_fam_ty_pats (name, arity, kind) mb_clsinfo - (HsWB { hswb_cts = arg_pats, hswb_kvs = kvars - , hswb_tvs = tvars, hswb_wcs = wcs }) + (HsIB { hsib_body = arg_pats, hsib_kvs = kvars + , hsib_tvs = tvars }) kind_checker = do { let (fam_kvs, fam_body) = splitForAllTys kind @@ -1089,14 +1090,16 @@ tc_fam_ty_pats (name, arity, kind) mb_clsinfo substKiWith fam_kvs fam_arg_kinds fam_body -- Treat (anonymous) wild cards as type variables without a name. -- See Note [Wild cards in family instances] - anon_tvs = [L (nameSrcSpan wc) - (UserTyVar (L (nameSrcSpan wc) wc)) | wc <- wcs] + wcs = concatMap collectAnonWildCards arg_pats + anon_tvs = [L loc (UserTyVar (L loc wc)) + | wc <- wcs + , let loc = nameSrcSpan wc ] hs_tvs = HsQTvs { hsq_kvs = kvars , hsq_tvs = anon_tvs ++ userHsTyVarBndrs loc tvars } -- Kind-check and quantify -- See Note [Quantifying over family patterns] - ; typats <- tcHsTyVarBndrs hs_tvs $ \ _ -> + ; typats <- tcHsQTyVars hs_tvs $ \ _ -> do { kind_checker res_kind ; tcHsArgTys (quotes (ppr name)) arg_pats arg_kinds } @@ -1105,8 +1108,8 @@ tc_fam_ty_pats (name, arity, kind) mb_clsinfo -- See Note [tc_fam_ty_pats vs tcFamTyPats] tcFamTyPats :: FamTyConShape -> Maybe ClsInfo - -> HsWithBndrs Name [LHsType Name] -- patterns - -> (TcKind -> TcM ()) -- kind-checker for RHS + -> HsTyPats Name -- patterns + -> (TcKind -> TcM ()) -- kind-checker for RHS -> ([TKVar] -- Kind and type variables -> [TcType] -- Kind and type arguments -> Kind -> TcM a) @@ -1264,9 +1267,10 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl = addErrCtxt (dataConCtxtName names) $ do { traceTc "tcConDecl 1" (ppr names) ; (ctxt, arg_tys, res_ty, field_lbls, stricts) - <- tcHsTyVarBndrs hs_tvs $ \ _ -> - do { ctxt <- tcHsContext hs_ctxt - ; btys <- tcConArgs new_or_data hs_details + <- tcHsQTyVars hs_tvs $ \ _ -> + do { traceTc "tcConDecl" (ppr names <+> text "tvs:" <+> ppr hs_tvs) + ; ctxt <- tcHsContext hs_ctxt + ; btys <- tcConArgs new_or_data hs_details ; res_ty <- tcConRes hs_res_ty ; field_lbls <- lookupConstructorFields (unLoc $ head names) ; let (arg_tys, stricts) = unzip btys @@ -1299,6 +1303,9 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl -- See Note [Checking GADT return types] ; fam_envs <- tcGetFamInstEnvs + + -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here + ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) ; let buildOneDataCon (L _ name) = do { is_infix <- tcConIsInfix name hs_details res_ty diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 73b3a0b4e5..ab63e8c070 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -30,7 +30,7 @@ module TcTyDecls( import TcRnMonad import TcEnv import TcTypeable( mkTypeableBinds ) -import TcBinds( tcRecSelBinds, addTypecheckedBinds ) +import TcBinds( tcRecSelBinds ) import TypeRep( Type(..) ) import TcType import TysWiredIn( unitTy ) @@ -807,6 +807,11 @@ updateRoleEnv name n role ********************************************************************* -} tcAddImplicits :: [TyCon] -> TcM TcGblEnv +-- Given a [TyCon], add to the TcGblEnv +-- * 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 $ tcExtendGlobalEnvImplicit implicit_things $ @@ -814,10 +819,10 @@ tcAddImplicits tycons do { traceTc "tcAddImplicits" $ vcat [ text "tycons" <+> ppr tycons , text "implicits" <+> ppr implicit_things ] - ; (typeable_ids, typeable_binds) <- mkTypeableBinds tycons - ; gbl_env <- tcExtendGlobalValEnv typeable_ids - $ tcRecSelBinds $ mkRecSelBinds tycons - ; return (gbl_env `addTypecheckedBinds` typeable_binds) } + ; gbl_env <- mkTypeableBinds tycons + ; gbl_env <- setGblEnv gbl_env $ + tcRecSelBinds (mkRecSelBinds tycons) + ; return gbl_env } where implicit_things = concatMap implicitTyConThings tycons def_meth_ids = mkDefaultMethodIds tycons @@ -849,8 +854,6 @@ mkDefaultMethodIds tycons -} {- --} -{- Note [Default method Ids and Template Haskell] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this (Trac #4169): @@ -868,6 +871,14 @@ must bring the default method Ids into scope first (so they can be seen when typechecking the [d| .. |] quote, and typecheck them later. -} +{- +************************************************************************ +* * + Building record selectors +* * +************************************************************************ +-} + mkRecSelBinds :: [TyCon] -> HsValBinds Name -- NB We produce *un-typechecked* bindings, rather like 'deriving' -- This makes life easier, because the later type checking will add diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index 78a0fbc594..48de69988a 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -29,7 +29,7 @@ module TcType ( -------------------------------- -- MetaDetails - UserTypeCtxt(..), pprUserTypeCtxt, pprSigCtxt, + UserTypeCtxt(..), pprUserTypeCtxt, pprSigCtxt, isSigMaybe, TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv, MetaDetails(Flexi, Indirect), MetaInfo(..), isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, @@ -423,14 +423,14 @@ data UserTypeCtxt -- will become type T = forall a. a->a -- -- With gla-exts that's right, but for H98 we should complain. +-} -************************************************************************ +{- ********************************************************************* * * Untoucable type variables * * -************************************************************************ --} +********************************************************************* -} newtype TcLevel = TcLevel Int deriving( Eq, Ord ) -- See Note [TcLevel and untouchable type variables] for what this Int is @@ -590,16 +590,22 @@ pprSigCtxt :: UserTypeCtxt -> SDoc -> SDoc -> SDoc -- f :: <type> -- The <extra> is either empty or "the ambiguity check for" pprSigCtxt ctxt extra pp_ty - = sep [ ptext (sLit "In") <+> extra <+> pprUserTypeCtxt ctxt <> colon - , nest 2 (pp_sig ctxt) ] + | Just n <- isSigMaybe ctxt + = vcat [ ptext (sLit "In") <+> extra <+> ptext (sLit "the type signature:") + , nest 2 (pprPrefixOcc n <+> dcolon <+> pp_ty) ] + + | otherwise + = hang (ptext (sLit "In") <+> extra <+> pprUserTypeCtxt ctxt <> colon) + 2 pp_ty + where - pp_sig (FunSigCtxt n _) = pp_n_colon n - pp_sig (ConArgCtxt n) = pp_n_colon n - pp_sig (ForSigCtxt n) = pp_n_colon n - pp_sig (PatSynCtxt n) = pp_n_colon n - pp_sig _ = pp_ty - pp_n_colon n = pprPrefixOcc n <+> dcolon <+> pp_ty +isSigMaybe :: UserTypeCtxt -> Maybe Name +isSigMaybe (FunSigCtxt n _) = Just n +isSigMaybe (ConArgCtxt n) = Just n +isSigMaybe (ForSigCtxt n) = Just n +isSigMaybe (PatSynCtxt n) = Just n +isSigMaybe _ = Nothing {- ************************************************************************ diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs index 32777831bc..62836d75ec 100644 --- a/compiler/typecheck/TcTypeable.hs +++ b/compiler/typecheck/TcTypeable.hs @@ -131,13 +131,13 @@ mkModIdBindings * * ********************************************************************* -} -mkTypeableBinds :: [TyCon] -> TcM ([Id], [LHsBinds Id]) +mkTypeableBinds :: [TyCon] -> TcM TcGblEnv mkTypeableBinds tycons = do { dflags <- getDynFlags ; gbl_env <- getGblEnv ; mod <- getModule ; if mod == gHC_TYPES - then return ([], []) -- Do not generate bindings for modules in GHC.Types + then return gbl_env -- Do not generate bindings for modules in GHC.Types else do { tr_datacon <- tcLookupDataCon trTyConDataConName ; trn_datacon <- tcLookupDataCon trNameSDataConName @@ -151,7 +151,9 @@ mkTypeableBinds tycons -- We need type representations for any associated types tc_binds = map (mk_typeable_binds stuff) all_tycons tycon_rep_ids = foldr ((++) . collectHsBindsBinders) [] tc_binds - ; return (tycon_rep_ids, tc_binds) } } + + ; gbl_env <- tcExtendGlobalValEnv tycon_rep_ids getGblEnv + ; return (gbl_env `addTypecheckedBinds` tc_binds) } } trNameLit :: DataCon -> FastString -> LHsExpr Id trNameLit tr_name_dc fs diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index af0b6115ff..18278ab9ad 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -12,7 +12,7 @@ module TcUnify ( -- Full-blown subsumption tcWrapResult, tcGen, tcSubType, tcSubType_NC, tcSubTypeDS, tcSubTypeDS_NC, - checkConstraints, buildImplication, + checkConstraints, buildImplication, buildImplicationFor, -- Various unifications unifyType, unifyTypeList, unifyTheta, @@ -438,7 +438,7 @@ tc_sub_type :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsW tc_sub_type origin ctxt ty_actual ty_expected | isTyVarTy ty_actual -- See Note [Higher rank types] = do { cow <- uType origin ty_actual ty_expected - ; return (coToHsWrapper cow) } + ; return (mkWpCastN cow) } | otherwise -- See Note [Deep skolemisation] = do { (sk_wrap, inner_wrap) <- tcGen ctxt ty_expected $ \ _ sk_rho -> @@ -471,7 +471,7 @@ tc_sub_type_ds origin ctxt ty_actual ty_expected | otherwise -- Revert to unification = do { cow <- uType origin ty_actual ty_expected - ; return (coToHsWrapper cow) } + ; return (mkWpCastN cow) } ----------------- tcWrapResult :: HsExpr TcId -> TcRhoType -> TcRhoType -> TcM (HsExpr TcId) @@ -530,8 +530,9 @@ tcGen ctxt expected_ty thing_inside = do { traceTc "tcGen" Outputable.empty ; (wrap, tvs', given, rho') <- deeplySkolemise expected_ty + ; lvl <- getTcLevel ; when debugIsOn $ - traceTc "tcGen" $ vcat [ + traceTc "tcGen" $ vcat [ ppr lvl, text "expected_ty" <+> ppr expected_ty, text "inst ty" <+> ppr tvs' <+> ppr rho' ] @@ -566,12 +567,6 @@ checkConstraints :: SkolemInfo -> TcM (TcEvBinds, result) checkConstraints skol_info skol_tvs given thing_inside - | null skol_tvs && null given - = do { res <- thing_inside; return (emptyTcEvBinds, res) } - -- Just for efficiency. We check every function argument with - -- tcPolyExpr, which uses tcGen and hence checkConstraints. - - | otherwise = do { (implics, ev_binds, result) <- buildImplication skol_info skol_tvs given thing_inside ; emitImplications implics ; return (ev_binds, result) } @@ -582,19 +577,32 @@ buildImplication :: SkolemInfo -> TcM result -> TcM (Bag Implication, TcEvBinds, result) buildImplication skol_info skol_tvs given thing_inside - = ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs ) + | null skol_tvs && null given + = do { res <- thing_inside + ; return (emptyBag, emptyTcEvBinds, res) } + -- Fast path. We check every function argument with + -- tcPolyExpr, which uses tcGen and hence checkConstraints. + + | otherwise + = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside + ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted + ; return (implics, ev_binds, result) } + +buildImplicationFor :: TcLevel -> SkolemInfo -> [TcTyVar] + -> [EvVar] -> WantedConstraints + -> TcM (Bag Implication, TcEvBinds) +buildImplicationFor tclvl skol_info skol_tvs given wanted + | isEmptyWC wanted && null given + -- Optimisation : if there are no wanteds, and no givens + -- don't generate an implication at all. + -- Reason for the (null given): we don't want to lose + -- the "inaccessible alternative" error check + = return (emptyBag, emptyTcEvBinds) + + | otherwise + = ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs ) ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs ) - do { (result, tclvl, wanted) <- pushLevelAndCaptureConstraints thing_inside - - ; if isEmptyWC wanted && null given - -- Optimisation : if there are no wanteds, and no givens - -- don't generate an implication at all. - -- Reason for the (null given): we don't want to lose - -- the "inaccessible alternative" error check - then - return (emptyBag, emptyTcEvBinds, result) - else do - { ev_binds_var <- newTcEvBinds + do { ev_binds_var <- newTcEvBinds ; env <- getLclEnv ; let implic = Implic { ic_tclvl = tclvl , ic_skols = skol_tvs @@ -606,7 +614,7 @@ buildImplication skol_info skol_tvs given thing_inside , ic_env = env , ic_info = skol_info } - ; return (unitBag implic, TcEvBinds ev_binds_var, result) } } + ; return (unitBag implic, TcEvBinds ev_binds_var) } {- ************************************************************************ diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index 91c5874e69..04bbd46425 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -190,15 +190,7 @@ so we can take their type variables into account as part of the checkAmbiguity :: UserTypeCtxt -> Type -> TcM () checkAmbiguity ctxt ty - | GhciCtxt <- ctxt -- Allow ambiguous types in GHCi's :kind command - = return () -- E.g. type family T a :: * -- T :: forall k. k -> * - -- Then :k T should work in GHCi, not complain that - -- (T k) is ambiguous! - - | InfSigCtxt {} <- ctxt -- See Note [Validity of inferred types] in TcBinds - = return () - - | otherwise + | wantAmbiguityCheck ctxt = do { traceTc "Ambiguity check for" (ppr ty) ; let free_tkvs = varSetElemsKvsFirst (closeOverKinds (tyVarsOfType ty)) ; (subst, _tvs) <- tcInstSkolTyVars free_tkvs @@ -214,20 +206,33 @@ checkAmbiguity ctxt ty -- Solve the constraints eagerly because an ambiguous type -- can cause a cascade of further errors. Since the free -- tyvars are skolemised, we can safely use tcSimplifyTop - ; (_wrap, wanted) <- addErrCtxtM (mk_msg ty') $ + ; allow_ambiguous <- xoptM Opt_AllowAmbiguousTypes + ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $ captureConstraints $ tcSubType_NC ctxt ty' ty' ; simplifyAmbiguityCheck ty wanted ; traceTc "Done ambiguity check for" (ppr ty) } + + | otherwise + = return () where - mk_msg ty tidy_env - = do { allow_ambiguous <- xoptM Opt_AllowAmbiguousTypes - ; (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env ty - ; return (tidy_env', mk_msg tidy_ty $$ ppWhen (not allow_ambiguous) ambig_msg) } - where - mk_msg ty = pprSigCtxt ctxt (ptext (sLit "the ambiguity check for")) (ppr ty) - ambig_msg = ptext (sLit "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes") + mk_msg allow_ambiguous + = vcat [ ptext (sLit "In the ambiguity check for") <+> what + , ppUnless allow_ambiguous ambig_msg ] + ambig_msg = ptext (sLit "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes") + what | Just n <- isSigMaybe ctxt = quotes (ppr n) + | otherwise = pprUserTypeCtxt ctxt + +wantAmbiguityCheck :: UserTypeCtxt -> Bool +wantAmbiguityCheck ctxt + = case ctxt of + GhciCtxt -> False -- Allow ambiguous types in GHCi's :kind command + -- E.g. type family T a :: * -- T :: forall k. k -> * + -- Then :k T should work in GHCi, not complain that + -- (T k) is ambiguous! +-- InfSigCtxt {} -> False -- See Note [Validity of inferred types] in TcBinds + _ -> True checkUserTypeError :: Type -> TcM () @@ -276,6 +281,7 @@ This might not necessarily show up in kind checking. checkValidType :: UserTypeCtxt -> Type -> TcM () -- Checks that the type is valid for the given context +-- Assumes arguemt is fully zonked -- Not used for instance decls; checkValidInstance instead checkValidType ctxt ty = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty)) @@ -302,7 +308,7 @@ checkValidType ctxt ty FunSigCtxt {} -> rank1 InfSigCtxt _ -> ArbitraryRank -- Inferred type ConArgCtxt _ -> rank1 -- We are given the type of the entire - -- constructor, hence rank 1 + -- constructor, hence rank 1 ForSigCtxt _ -> rank1 SpecInstCtxt -> rank1 @@ -329,6 +335,7 @@ checkValidType ctxt ty ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (typeKind ty)) } checkValidMonoType :: Type -> TcM () +-- Assumes arguemt is fully zonked checkValidMonoType ty = check_mono_type SigmaCtxt MustBeMonoType ty @@ -611,6 +618,7 @@ applying the instance decl would show up two uses of ?x. Trac #8912. -} checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM () +-- Assumes arguemt is fully zonked checkValidTheta ctxt theta = addErrCtxt (checkThetaCtxt ctxt theta) (check_valid_theta ctxt theta) @@ -977,7 +985,7 @@ validDerivPred tv_set pred ************************************************************************ -} -checkValidInstance :: UserTypeCtxt -> LHsType Name -> Type +checkValidInstance :: UserTypeCtxt -> LHsSigType Name -> Type -> TcM ([TyVar], ThetaType, Class, [Type]) checkValidInstance ctxt hs_type ty | Just (clas,inst_tys) <- getClassPredTys_maybe tau @@ -996,6 +1004,7 @@ checkValidInstance ctxt hs_type ty -- the termination condition, because 'a' appears more often -- in the constraint than in the head ; undecidable_ok <- xoptM Opt_UndecidableInstances + ; traceTc "cvi" (ppr undecidable_ok $$ ppr ty) ; if undecidable_ok then checkAmbiguity ctxt ty else checkInstTermination inst_tys theta @@ -1012,9 +1021,8 @@ checkValidInstance ctxt hs_type ty (tvs, theta, tau) = tcSplitSigmaTy ty -- The location of the "head" of the instance - head_loc = case hs_type of - L _ (HsForAllTy _ _ _ _ (L loc _)) -> loc - L loc _ -> loc + head_loc = case splitLHsInstDeclTy hs_type of + (_, _, L loc _) -> loc {- Note [Paterson conditions] diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs index fee8c343a9..9aff2c4407 100644 --- a/compiler/types/Coercion.hs +++ b/compiler/types/Coercion.hs @@ -8,7 +8,8 @@ -- module Coercion ( -- * Main data type - Coercion(..), Var, CoVar, + Coercion(..), CoercionN, CoercionR, + Var, CoVar, LeftOrRight(..), pickLR, Role(..), ltRole, @@ -121,6 +122,9 @@ import Control.Arrow ( first ) ************************************************************************ -} +type CoercionR = Coercion -- A coercion at Representation role ~R +type CoercionN = Coercion -- A coercion at Nominal role ~N + -- | A 'Coercion' is concrete evidence of the equality/convertibility -- of two types. diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs index 56df3a52ba..b0ee31e0cb 100644 --- a/compiler/types/InstEnv.hs +++ b/compiler/types/InstEnv.hs @@ -771,7 +771,8 @@ lookupInstEnv check_overlap_safe , ie_visible = vis_mods }) cls tys - = (final_matches, final_unifs, unsafe_overlapped) + = -- pprTrace "lookupInstEnv" (ppr cls <+> ppr tys $$ ppr home_ie) $ + (final_matches, final_unifs, unsafe_overlapped) where (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie vis_mods cls tys diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs index 7139eea6e9..406ee9c5cf 100644 --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -375,42 +375,41 @@ nOfThem n thing = replicate n thing -- -- @ -- atLength atLenPred atEndPred ls n --- | n < 0 = atLenPred n +-- | n < 0 = atLenPred ls -- | length ls < n = atEndPred (n - length ls) -- | otherwise = atLenPred (drop n ls) -- @ -atLength :: ([a] -> b) - -> (Int -> b) +atLength :: ([a] -> b) -- Called when length ls >= n, passed (drop n ls) + -- NB: arg passed to this function may be [] + -> b -- Called when length ls < n -> [a] -> Int -> b -atLength atLenPred atEndPred ls n - | n < 0 = atEndPred n +atLength atLenPred atEnd ls n + | n < 0 = atLenPred ls | otherwise = go n ls where - go n [] = atEndPred n - go 0 ls = atLenPred ls + -- go's first arg n >= 0 + go 0 ls = atLenPred ls + go _ [] = atEnd -- n > 0 here go n (_:xs) = go (n-1) xs -- Some special cases of atLength: lengthExceeds :: [a] -> Int -> Bool -- ^ > (lengthExceeds xs n) = (length xs > n) -lengthExceeds = atLength notNull (const False) +lengthExceeds = atLength notNull False lengthAtLeast :: [a] -> Int -> Bool -lengthAtLeast = atLength notNull (== 0) +lengthAtLeast = atLength (const True) False lengthIs :: [a] -> Int -> Bool -lengthIs = atLength null (==0) +lengthIs = atLength null False listLengthCmp :: [a] -> Int -> Ordering listLengthCmp = atLength atLen atEnd where - atEnd 0 = EQ - atEnd x - | x > 0 = LT -- not yet seen 'n' elts, so list length is < n. - | otherwise = GT + atEnd = LT -- Not yet seen 'n' elts, so list length is < n. atLen [] = EQ atLen _ = GT diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 393de5cb29..a55c9fe008 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -1326,8 +1326,8 @@ defineMacro overwrite s = do let stringTy = nlHsTyVar stringTy_RDR ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy body = nlHsVar compose_RDR `mkHsApp` step `mkHsApp` expr - tySig = stringTy `nlHsFunTy` ioM - new_expr = L (getLoc expr) $ ExprWithTySig body tySig PlaceHolder + tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM) + new_expr = L (getLoc expr) $ ExprWithTySig body tySig hv <- GHC.compileParsedExpr new_expr liftIO (writeIORef macros_ref -- later defined macros have precedence @@ -1377,8 +1377,8 @@ getGhciStepIO = do ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy body = nlHsVar (getRdrName ghciStepIoMName) - tySig = ghciM `nlHsFunTy` ioM - return $ noLoc $ ExprWithTySig body tySig PlaceHolder + tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM) + return $ noLoc $ ExprWithTySig body tySig ----------------------------------------------------------------------------- -- :check diff --git a/libraries/base/Data/Monoid.hs b/libraries/base/Data/Monoid.hs index eff3836396..f60a15fb58 100644 --- a/libraries/base/Data/Monoid.hs +++ b/libraries/base/Data/Monoid.hs @@ -211,7 +211,7 @@ newtype Alt f a = Alt {getAlt :: f a} deriving (Generic, Generic1, Read, Show, Eq, Ord, Num, Enum, Monad, MonadPlus, Applicative, Alternative, Functor) -instance forall f a . Alternative f => Monoid (Alt f a) where +instance Alternative f => Monoid (Alt f a) where mempty = Alt empty mappend = coerce ((<|>) :: f a -> f a -> f a) diff --git a/testsuite/tests/ado/ado005.stderr b/testsuite/tests/ado/ado005.stderr index 7203392d60..4bfc79eca4 100644 --- a/testsuite/tests/ado/ado005.stderr +++ b/testsuite/tests/ado/ado005.stderr @@ -1,14 +1,14 @@ -ado005.hs:8:3: +ado005.hs:8:3: error: Could not deduce (Monad f) arising from a do statement from the context: Applicative f bound by the type signature for: - test :: Applicative f => (Int -> f Int) -> f Int - at ado005.hs:6:9-48 + test :: Applicative f => (Int -> f Int) -> f Int + at ado005.hs:6:1-48 Possible fix: add (Monad f) to the context of the type signature for: - test :: Applicative f => (Int -> f Int) -> f Int + test :: Applicative f => (Int -> f Int) -> f Int In a stmt of a 'do' block: x <- f 3 In the expression: do { x <- f 3; diff --git a/testsuite/tests/arrows/should_fail/T5380.stderr b/testsuite/tests/arrows/should_fail/T5380.stderr index 177183225c..2aeb01f1c0 100644 --- a/testsuite/tests/arrows/should_fail/T5380.stderr +++ b/testsuite/tests/arrows/should_fail/T5380.stderr @@ -1,27 +1,29 @@ -T5380.hs:7:27: - Couldn't match expected type ‘Bool’ with actual type ‘not_bool’ +T5380.hs:7:27: error: + • Couldn't match expected type ‘Bool’ with actual type ‘not_bool’ ‘not_bool’ is a rigid type variable bound by - the type signature for: - testB :: not_bool -> (() -> ()) -> () -> not_unit - at T5380.hs:6:10 - In the expression: b - In the expression: proc () -> if b then f -< () else f -< () - Relevant bindings include - b :: not_bool (bound at T5380.hs:7:7) - testB :: not_bool -> (() -> ()) -> () -> not_unit - (bound at T5380.hs:7:1) + the type signature for: + testB :: forall not_bool not_unit. + not_bool -> (() -> ()) -> () -> not_unit + at T5380.hs:6:10 + • In the expression: b + In the expression: proc () -> if b then f -< () else f -< () + • Relevant bindings include + b :: not_bool (bound at T5380.hs:7:7) + testB :: not_bool -> (() -> ()) -> () -> not_unit + (bound at T5380.hs:7:1) -T5380.hs:7:34: - Couldn't match type ‘not_unit’ with ‘()’ +T5380.hs:7:34: error: + • Couldn't match type ‘not_unit’ with ‘()’ ‘not_unit’ is a rigid type variable bound by - the type signature for: - testB :: not_bool -> (() -> ()) -> () -> not_unit - at T5380.hs:6:10 - Expected type: () -> not_unit - Actual type: () -> () - In the expression: f - In the command: f -< () - Relevant bindings include - testB :: not_bool -> (() -> ()) -> () -> not_unit - (bound at T5380.hs:7:1) + the type signature for: + testB :: forall not_bool not_unit. + not_bool -> (() -> ()) -> () -> not_unit + at T5380.hs:6:10 + Expected type: () -> not_unit + Actual type: () -> () + • In the expression: f + In the command: f -< () + • Relevant bindings include + testB :: not_bool -> (() -> ()) -> () -> not_unit + (bound at T5380.hs:7:1) diff --git a/testsuite/tests/deriving/should_fail/T5287.stderr b/testsuite/tests/deriving/should_fail/T5287.stderr index 529751c2d3..3fb3e283d9 100644 --- a/testsuite/tests/deriving/should_fail/T5287.stderr +++ b/testsuite/tests/deriving/should_fail/T5287.stderr @@ -1,11 +1,11 @@ - -T5287.hs:6:10: - Could not deduce (A a oops0) - from the context: A a oops - bound by an instance declaration: A a oops => Read (D a) - at T5287.hs:6:10-31 - The type variable ‘oops0’ is ambiguous - In the ambiguity check for an instance declaration: - forall a oops. A a oops => Read (D a) - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the instance declaration for ‘Read (D a)’ +
+T5287.hs:6:10: error:
+ Could not deduce (A a oops0)
+ from the context: A a oops
+ bound by an instance declaration:
+ A a oops => Read (D a)
+ at T5287.hs:6:10-31
+ The type variable ‘oops0’ is ambiguous
+ In the ambiguity check for an instance declaration
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ In the instance declaration for ‘Read (D a)’
diff --git a/testsuite/tests/gadt/T3169.stderr b/testsuite/tests/gadt/T3169.stderr index 12a39ebe51..0ec531c526 100644 --- a/testsuite/tests/gadt/T3169.stderr +++ b/testsuite/tests/gadt/T3169.stderr @@ -1,16 +1,16 @@ -T3169.hs:13:22: - Couldn't match type ‘elt’ with ‘Map b elt’ +T3169.hs:13:22: error: + • Couldn't match type ‘elt’ with ‘Map b elt’ ‘elt’ is a rigid type variable bound by - the type signature for: - lookup :: (a, b) -> Map (a, b) elt -> Maybe elt - at T3169.hs:12:3 - Expected type: Map a (Map b elt) - Actual type: Map (a, b) elt - In the second argument of ‘lookup’, namely ‘m’ - In the expression: lookup a m :: Maybe (Map b elt) - Relevant bindings include - m :: Map (a, b) elt (bound at T3169.hs:12:17) - b :: b (bound at T3169.hs:12:13) - lookup :: (a, b) -> Map (a, b) elt -> Maybe elt - (bound at T3169.hs:12:3) + the type signature for: + lookup :: forall elt. (a, b) -> Map (a, b) elt -> Maybe elt + at T3169.hs:12:3 + Expected type: Map a (Map b elt) + Actual type: Map (a, b) elt + • In the second argument of ‘lookup’, namely ‘m’ + In the expression: lookup a m :: Maybe (Map b elt) + • Relevant bindings include + m :: Map (a, b) elt (bound at T3169.hs:12:17) + b :: b (bound at T3169.hs:12:13) + lookup :: (a, b) -> Map (a, b) elt -> Maybe elt + (bound at T3169.hs:12:3) diff --git a/testsuite/tests/gadt/T7558.stderr b/testsuite/tests/gadt/T7558.stderr index 3d09467402..15b9476af4 100644 --- a/testsuite/tests/gadt/T7558.stderr +++ b/testsuite/tests/gadt/T7558.stderr @@ -1,8 +1,10 @@ -T7558.hs:8:4:
+T7558.hs:8:4: error:
Couldn't match type ‘a’ with ‘Maybe a’
- ‘a’ is a rigid type variable bound by
- the type signature for: f :: T a a -> Bool at T7558.hs:7:6
+ ‘a’ is a rigid type variable bound by
+ the type signature for:
+ f :: forall a. T a a -> Bool
+ at T7558.hs:7:6
Inaccessible code in
a pattern with constructor:
MkT :: forall a b. (a ~ Maybe b) => a -> Maybe b -> T a b,
diff --git a/testsuite/tests/gadt/rw.stderr b/testsuite/tests/gadt/rw.stderr index dcd3e10397..39529a7003 100644 --- a/testsuite/tests/gadt/rw.stderr +++ b/testsuite/tests/gadt/rw.stderr @@ -1,27 +1,29 @@ -rw.hs:14:47: - Couldn't match expected type ‘a’ with actual type ‘Int’ +rw.hs:14:47: error: + • Couldn't match expected type ‘a’ with actual type ‘Int’ ‘a’ is a rigid type variable bound by - the type signature for: writeInt :: T a -> IORef a -> IO () - at rw.hs:12:12 - In the second argument of ‘writeIORef’, namely ‘(1 :: Int)’ - In the expression: writeIORef ref (1 :: Int) - In a case alternative: ~(Li x) -> writeIORef ref (1 :: Int) - Relevant bindings include - ref :: IORef a (bound at rw.hs:13:12) - v :: T a (bound at rw.hs:13:10) - writeInt :: T a -> IORef a -> IO () (bound at rw.hs:13:1) + the type signature for: + writeInt :: forall a. T a -> IORef a -> IO () + at rw.hs:12:12 + • In the second argument of ‘writeIORef’, namely ‘(1 :: Int)’ + In the expression: writeIORef ref (1 :: Int) + In a case alternative: ~(Li x) -> writeIORef ref (1 :: Int) + • Relevant bindings include + ref :: IORef a (bound at rw.hs:13:12) + v :: T a (bound at rw.hs:13:10) + writeInt :: T a -> IORef a -> IO () (bound at rw.hs:13:1) -rw.hs:19:51: - Couldn't match type ‘a’ with ‘Bool’ +rw.hs:19:51: error: + • Couldn't match type ‘a’ with ‘Bool’ ‘a’ is a rigid type variable bound by - the type signature for: readBool :: T a -> IORef a -> IO () - at rw.hs:16:12 - Expected type: a -> Bool - Actual type: Bool -> Bool - In the second argument of ‘(.)’, namely ‘not’ - In the second argument of ‘(>>=)’, namely ‘(print . not)’ - Relevant bindings include - ref :: IORef a (bound at rw.hs:17:12) - v :: T a (bound at rw.hs:17:10) - readBool :: T a -> IORef a -> IO () (bound at rw.hs:17:1) + the type signature for: + readBool :: forall a. T a -> IORef a -> IO () + at rw.hs:16:12 + Expected type: a -> Bool + Actual type: Bool -> Bool + • In the second argument of ‘(.)’, namely ‘not’ + In the second argument of ‘(>>=)’, namely ‘(print . not)’ + • Relevant bindings include + ref :: IORef a (bound at rw.hs:17:12) + v :: T a (bound at rw.hs:17:10) + readBool :: T a -> IORef a -> IO () (bound at rw.hs:17:1) diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T index c7c8542a11..4104bceebf 100644 --- a/testsuite/tests/ghc-api/annotations/all.T +++ b/testsuite/tests/ghc-api/annotations/all.T @@ -16,7 +16,7 @@ test('T10358', normal, run_command, ['$MAKE -s --no-print-directory T10358' test('T10278', normal, run_command, ['$MAKE -s --no-print-directory T10278']) test('T10354', normal, run_command, ['$MAKE -s --no-print-directory T10354']) test('T10396', normal, run_command, ['$MAKE -s --no-print-directory T10396']) -test('T10399', normal, run_command, ['$MAKE -s --no-print-directory T10399']) +test('T10399', expect_broken(11028), run_command, ['$MAKE -s --no-print-directory T10399']) test('T10313', normal, run_command, ['$MAKE -s --no-print-directory T10313']) test('T11018', normal, run_command, ['$MAKE -s --no-print-directory T11018']) test('bundle-export', normal, run_command, ['$MAKE -s --no-print-directory bundle-export']) diff --git a/testsuite/tests/ghc-api/landmines/landmines.stdout b/testsuite/tests/ghc-api/landmines/landmines.stdout index 63070b28e5..db0b651dfa 100644 --- a/testsuite/tests/ghc-api/landmines/landmines.stdout +++ b/testsuite/tests/ghc-api/landmines/landmines.stdout @@ -1,4 +1,4 @@ (12,12,7) (66,62,0) -(14,13,7) +(13,13,7) (10,10,7) diff --git a/testsuite/tests/ghci/scripts/Defer02.stderr b/testsuite/tests/ghci/scripts/Defer02.stderr index 48ddf4b598..83e9f7d157 100644 --- a/testsuite/tests/ghci/scripts/Defer02.stderr +++ b/testsuite/tests/ghci/scripts/Defer02.stderr @@ -1,195 +1,178 @@ ../../typecheck/should_run/Defer01.hs:11:40: warning: - Couldn't match type ‘Char’ with ‘[Char]’ - Expected type: String - Actual type: Char - In the first argument of ‘putStr’, namely ‘','’ - In the second argument of ‘(>>)’, namely ‘putStr ','’ - In the expression: putStr "Hello World" >> putStr ',' + • Couldn't match type ‘Char’ with ‘[Char]’ + Expected type: String + Actual type: Char + • In the first argument of ‘putStr’, namely ‘','’ + In the second argument of ‘(>>)’, namely ‘putStr ','’ + In the expression: putStr "Hello World" >> putStr ',' ../../typecheck/should_run/Defer01.hs:14:5: warning: - Couldn't match expected type ‘Int’ with actual type ‘Char’ - In the expression: 'p' - In an equation for ‘a’: a = 'p' - -../../typecheck/should_run/Defer01.hs:18:9: warning: - No instance for (Eq B) arising from a use of ‘==’ - In the expression: x == x - In an equation for ‘b’: b x = x == x + • Couldn't match expected type ‘Int’ with actual type ‘Char’ + • In the expression: 'p' + In an equation for ‘a’: a = 'p' ../../typecheck/should_run/Defer01.hs:25:4: warning: - Couldn't match type ‘Int’ with ‘Bool’ - Inaccessible code in - a pattern with constructor: C2 :: Bool -> C Bool, - in an equation for ‘c’ - In the pattern: C2 x - In an equation for ‘c’: c (C2 x) = True + • Couldn't match type ‘Int’ with ‘Bool’ + Inaccessible code in + a pattern with constructor: C2 :: Bool -> C Bool, + in an equation for ‘c’ + • In the pattern: C2 x + In an equation for ‘c’: c (C2 x) = True ../../typecheck/should_run/Defer01.hs:28:5: warning: - No instance for (Num (a -> a)) arising from the literal ‘1’ - (maybe you haven't applied a function to enough arguments?) - In the expression: 1 - In an equation for ‘d’: d = 1 + • No instance for (Num (a -> a)) arising from the literal ‘1’ + (maybe you haven't applied a function to enough arguments?) + • In the expression: 1 + In an equation for ‘d’: d = 1 ../../typecheck/should_run/Defer01.hs:31:5: warning: - Couldn't match expected type ‘Char -> t’ with actual type ‘Char’ - The function ‘e’ is applied to one argument, - but its type ‘Char’ has none - In the expression: e 'q' - In an equation for ‘f’: f = e 'q' - Relevant bindings include - f :: t (bound at ../../typecheck/should_run/Defer01.hs:31:1) + • Couldn't match expected type ‘Char -> t’ with actual type ‘Char’ + • The function ‘e’ is applied to one argument, + but its type ‘Char’ has none + In the expression: e 'q' + In an equation for ‘f’: f = e 'q' + • Relevant bindings include + f :: t (bound at ../../typecheck/should_run/Defer01.hs:31:1) ../../typecheck/should_run/Defer01.hs:34:8: warning: - Couldn't match expected type ‘Char’ with actual type ‘a’ - ‘a’ is a rigid type variable bound by + • Couldn't match expected type ‘Char’ with actual type ‘a’ + ‘a’ is a rigid type variable bound by the type signature for: - h :: a -> (Char, Char) + h :: forall a. a -> (Char, Char) at ../../typecheck/should_run/Defer01.hs:33:6 - In the expression: x - In the expression: (x, 'c') - Relevant bindings include - x :: a (bound at ../../typecheck/should_run/Defer01.hs:34:3) - h :: a -> (Char, Char) - (bound at ../../typecheck/should_run/Defer01.hs:34:1) + • In the expression: x + In the expression: (x, 'c') + • Relevant bindings include + x :: a (bound at ../../typecheck/should_run/Defer01.hs:34:3) + h :: a -> (Char, Char) + (bound at ../../typecheck/should_run/Defer01.hs:34:1) ../../typecheck/should_run/Defer01.hs:39:17: warning: - Couldn't match expected type ‘Bool’ with actual type ‘T a’ - In the first argument of ‘not’, namely ‘(K a)’ - In the expression: (not (K a)) - Relevant bindings include - a :: a (bound at ../../typecheck/should_run/Defer01.hs:39:3) - i :: a -> () (bound at ../../typecheck/should_run/Defer01.hs:39:1) + • Couldn't match expected type ‘Bool’ with actual type ‘T a’ + • In the first argument of ‘not’, namely ‘(K a)’ + In the expression: (not (K a)) + • Relevant bindings include + a :: a (bound at ../../typecheck/should_run/Defer01.hs:39:3) + i :: a -> () (bound at ../../typecheck/should_run/Defer01.hs:39:1) ../../typecheck/should_run/Defer01.hs:43:5: warning: - No instance for (MyClass a1) arising from a use of ‘myOp’ - In the expression: myOp 23 - In an equation for ‘j’: j = myOp 23 + • No instance for (MyClass a1) arising from a use of ‘myOp’ + • In the expression: myOp 23 + In an equation for ‘j’: j = myOp 23 ../../typecheck/should_run/Defer01.hs:43:10: warning: - Ambiguous type variable ‘a1’ arising from the literal ‘23’ - prevents the constraint ‘(Num a1)’ from being solved. - Probable fix: use a type annotation to specify what ‘a1’ should be. - These potential instances exist: - instance Num Integer -- Defined in ‘GHC.Num’ - instance Num Double -- Defined in ‘GHC.Float’ - instance Num Float -- Defined in ‘GHC.Float’ - ...plus two others - (use -fprint-potential-instances to see them all) - In the first argument of ‘myOp’, namely ‘23’ - In the expression: myOp 23 - In an equation for ‘j’: j = myOp 23 - -../../typecheck/should_run/Defer01.hs:45:6: warning: + • Ambiguous type variable ‘a1’ arising from the literal ‘23’ + prevents the constraint ‘(Num a1)’ from being solved. + Probable fix: use a type annotation to specify what ‘a1’ should be. + These potential instances exist: + instance Num Integer -- Defined in ‘GHC.Num’ + instance Num Double -- Defined in ‘GHC.Float’ + instance Num Float -- Defined in ‘GHC.Float’ + ...plus two others + (use -fprint-potential-instances to see them all) + • In the first argument of ‘myOp’, namely ‘23’ + In the expression: myOp 23 + In an equation for ‘j’: j = myOp 23 + +../../typecheck/should_run/Defer01.hs:45:1: warning: Couldn't match type ‘Int’ with ‘Bool’ Inaccessible code in the type signature for: k :: (Int ~ Bool) => Int -> Bool - In the ambiguity check for the type signature for ‘k’: - k :: (Int ~ Bool) => Int -> Bool - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the type signature for ‘k’: k :: (Int ~ Bool) => Int -> Bool - -../../typecheck/should_run/Defer01.hs:45:6: warning: - Couldn't match expected type ‘Bool’ with actual type ‘Int’ - In the ambiguity check for the type signature for ‘k’: - k :: (Int ~ Bool) => Int -> Bool - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the type signature for ‘k’: k :: (Int ~ Bool) => Int -> Bool ../../typecheck/should_run/Defer01.hs:45:6: warning: - Couldn't match type ‘Int’ with ‘Bool’ - Inaccessible code in - the type signature for: + • Couldn't match type ‘Int’ with ‘Bool’ + Inaccessible code in + the type signature for: + k :: (Int ~ Bool) => Int -> Bool + • In the ambiguity check for ‘k’ + To defer the ambiguity check to use sites, enable AllowAmbiguousTypes + In the type signature: k :: (Int ~ Bool) => Int -> Bool -../../typecheck/should_run/Defer01.hs:46:7: warning: - Couldn't match expected type ‘Bool’ with actual type ‘Int’ - In the expression: x - In an equation for ‘k’: k x = x - ../../typecheck/should_run/Defer01.hs:49:5: warning: - Couldn't match expected type ‘IO a0’ - with actual type ‘Char -> IO ()’ - Probable cause: ‘putChar’ is applied to too few arguments - In the first argument of ‘(>>)’, namely ‘putChar’ - In the expression: putChar >> putChar 'p' + • Couldn't match expected type ‘IO a0’ + with actual type ‘Char -> IO ()’ + • Probable cause: ‘putChar’ is applied to too few arguments + In the first argument of ‘(>>)’, namely ‘putChar’ + In the expression: putChar >> putChar 'p' *** Exception: ../../typecheck/should_run/Defer01.hs:11:40: error: - Couldn't match type ‘Char’ with ‘[Char]’ - Expected type: String - Actual type: Char - In the first argument of ‘putStr’, namely ‘','’ - In the second argument of ‘(>>)’, namely ‘putStr ','’ - In the expression: putStr "Hello World" >> putStr ',' + • Couldn't match type ‘Char’ with ‘[Char]’ + Expected type: String + Actual type: Char + • In the first argument of ‘putStr’, namely ‘','’ + In the second argument of ‘(>>)’, namely ‘putStr ','’ + In the expression: putStr "Hello World" >> putStr ',' (deferred type error) *** Exception: ../../typecheck/should_run/Defer01.hs:14:5: error: - Couldn't match expected type ‘Int’ with actual type ‘Char’ - In the expression: 'p' - In an equation for ‘a’: a = 'p' + • Couldn't match expected type ‘Int’ with actual type ‘Char’ + • In the expression: 'p' + In an equation for ‘a’: a = 'p' (deferred type error) *** Exception: ../../typecheck/should_run/Defer01.hs:18:9: error: - No instance for (Eq B) arising from a use of ‘==’ - In the expression: x == x - In an equation for ‘b’: b x = x == x + • No instance for (Eq B) arising from a use of ‘==’ + • In the expression: x == x + In an equation for ‘b’: b x = x == x (deferred type error) <interactive>:7:11: error: - Couldn't match type ‘Bool’ with ‘Int’ - Expected type: C Int - Actual type: C Bool - In the first argument of ‘c’, namely ‘(C2 True)’ - In the first argument of ‘print’, namely ‘(c (C2 True))’ + • Couldn't match type ‘Bool’ with ‘Int’ + Expected type: C Int + Actual type: C Bool + • In the first argument of ‘c’, namely ‘(C2 True)’ + In the first argument of ‘print’, namely ‘(c (C2 True))’ *** Exception: ../../typecheck/should_run/Defer01.hs:28:5: error: - No instance for (Num (a -> a)) arising from the literal ‘1’ - (maybe you haven't applied a function to enough arguments?) - In the expression: 1 - In an equation for ‘d’: d = 1 + • No instance for (Num (a -> a)) arising from the literal ‘1’ + (maybe you haven't applied a function to enough arguments?) + • In the expression: 1 + In an equation for ‘d’: d = 1 (deferred type error) *** Exception: ../../typecheck/should_run/Defer01.hs:31:5: error: - Couldn't match expected type ‘Char -> t’ with actual type ‘Char’ - The function ‘e’ is applied to one argument, - but its type ‘Char’ has none - In the expression: e 'q' - In an equation for ‘f’: f = e 'q' - Relevant bindings include - f :: t (bound at ../../typecheck/should_run/Defer01.hs:31:1) + • Couldn't match expected type ‘Char -> t’ with actual type ‘Char’ + • The function ‘e’ is applied to one argument, + but its type ‘Char’ has none + In the expression: e 'q' + In an equation for ‘f’: f = e 'q' + • Relevant bindings include + f :: t (bound at ../../typecheck/should_run/Defer01.hs:31:1) (deferred type error) *** Exception: ../../typecheck/should_run/Defer01.hs:34:8: error: - Couldn't match expected type ‘Char’ with actual type ‘a’ - ‘a’ is a rigid type variable bound by + • Couldn't match expected type ‘Char’ with actual type ‘a’ + ‘a’ is a rigid type variable bound by the type signature for: - h :: a -> (Char, Char) + h :: forall a. a -> (Char, Char) at ../../typecheck/should_run/Defer01.hs:33:6 - In the expression: x - In the expression: (x, 'c') - Relevant bindings include - x :: a (bound at ../../typecheck/should_run/Defer01.hs:34:3) - h :: a -> (Char, Char) - (bound at ../../typecheck/should_run/Defer01.hs:34:1) + • In the expression: x + In the expression: (x, 'c') + • Relevant bindings include + x :: a (bound at ../../typecheck/should_run/Defer01.hs:34:3) + h :: a -> (Char, Char) + (bound at ../../typecheck/should_run/Defer01.hs:34:1) (deferred type error) *** Exception: ../../typecheck/should_run/Defer01.hs:39:17: error: - Couldn't match expected type ‘Bool’ with actual type ‘T a’ - In the first argument of ‘not’, namely ‘(K a)’ - In the expression: (not (K a)) - Relevant bindings include - a :: a (bound at ../../typecheck/should_run/Defer01.hs:39:3) - i :: a -> () (bound at ../../typecheck/should_run/Defer01.hs:39:1) + • Couldn't match expected type ‘Bool’ with actual type ‘T a’ + • In the first argument of ‘not’, namely ‘(K a)’ + In the expression: (not (K a)) + • Relevant bindings include + a :: a (bound at ../../typecheck/should_run/Defer01.hs:39:3) + i :: a -> () (bound at ../../typecheck/should_run/Defer01.hs:39:1) (deferred type error) *** Exception: ../../typecheck/should_run/Defer01.hs:43:5: error: - No instance for (MyClass a1) arising from a use of ‘myOp’ - In the expression: myOp 23 - In an equation for ‘j’: j = myOp 23 + • No instance for (MyClass a1) arising from a use of ‘myOp’ + • In the expression: myOp 23 + In an equation for ‘j’: j = myOp 23 (deferred type error) <interactive>:13:8: error: - Couldn't match expected type ‘Bool’ with actual type ‘Int’ - In the first argument of ‘print’, namely ‘(k 2)’ - In the expression: print (k 2) - In an equation for ‘it’: it = print (k 2) + • Couldn't match expected type ‘Bool’ with actual type ‘Int’ + • In the first argument of ‘print’, namely ‘(k 2)’ + In the expression: print (k 2) + In an equation for ‘it’: it = print (k 2) *** Exception: ../../typecheck/should_run/Defer01.hs:49:5: error: - Couldn't match expected type ‘IO a0’ - with actual type ‘Char -> IO ()’ - Probable cause: ‘putChar’ is applied to too few arguments - In the first argument of ‘(>>)’, namely ‘putChar’ - In the expression: putChar >> putChar 'p' + • Couldn't match expected type ‘IO a0’ + with actual type ‘Char -> IO ()’ + • Probable cause: ‘putChar’ is applied to too few arguments + In the first argument of ‘(>>)’, namely ‘putChar’ + In the expression: putChar >> putChar 'p' (deferred type error) diff --git a/testsuite/tests/ghci/scripts/T10248.stderr b/testsuite/tests/ghci/scripts/T10248.stderr index 86b8c8d688..c9df22b056 100644 --- a/testsuite/tests/ghci/scripts/T10248.stderr +++ b/testsuite/tests/ghci/scripts/T10248.stderr @@ -1,14 +1,14 @@ <interactive>:2:10: error: - Found hole: _ :: f a - Where: ‘f’ is a rigid type variable bound by + • Found hole: _ :: f a + Where: ‘f’ is a rigid type variable bound by the inferred type of it :: Functor f => f (Maybe a) at <interactive>:2:1 - ‘a’ is a rigid type variable bound by + ‘a’ is a rigid type variable bound by the inferred type of it :: Functor f => f (Maybe a) at <interactive>:2:1 - In the second argument of ‘(<$>)’, namely ‘_’ - In the expression: Just <$> _ - In an equation for ‘it’: it = Just <$> _ - Relevant bindings include - it :: f (Maybe a) (bound at <interactive>:2:1) + • In the second argument of ‘(<$>)’, namely ‘_’ + In the expression: Just <$> _ + In an equation for ‘it’: it = Just <$> _ + • Relevant bindings include + it :: f (Maybe a) (bound at <interactive>:2:1) diff --git a/testsuite/tests/ghci/scripts/T7873.stdout b/testsuite/tests/ghci/scripts/T7873.stdout index 79a75ec7ea..84f3117958 100644 --- a/testsuite/tests/ghci/scripts/T7873.stdout +++ b/testsuite/tests/ghci/scripts/T7873.stdout @@ -1,7 +1,6 @@ -data D1 where - MkD1 :: (forall (k1 :: BOX) (p :: k1 -> *) (a :: k1). p a -> Int) - -> D1 - -- Defined at <interactive>:2:1 -data D2 where - MkD2 :: (forall (p :: k -> *) (a :: k). p a -> Int) -> D2 - -- Defined at <interactive>:3:1 +data D1 where
+ MkD1 :: (forall (p :: k -> *) (a :: k). p a -> Int) -> D1
+ -- Defined at <interactive>:2:1
+data D2 where
+ MkD2 :: (forall (p :: k -> *) (a :: k). p a -> Int) -> D2
+ -- Defined at <interactive>:3:1
diff --git a/testsuite/tests/ghci/scripts/ghci050.stderr b/testsuite/tests/ghci/scripts/ghci050.stderr index 31232b6b0b..e8cc7971db 100644 --- a/testsuite/tests/ghci/scripts/ghci050.stderr +++ b/testsuite/tests/ghci/scripts/ghci050.stderr @@ -11,3 +11,4 @@ a :: a (bound at <interactive>:5:41) asList :: (a, a) -> [ListableElem (a, a)] (bound at <interactive>:5:33) + diff --git a/testsuite/tests/indexed-types/should_compile/PushedInAsGivens.stderr b/testsuite/tests/indexed-types/should_compile/PushedInAsGivens.stderr index 66b24174ae..68412759e7 100644 --- a/testsuite/tests/indexed-types/should_compile/PushedInAsGivens.stderr +++ b/testsuite/tests/indexed-types/should_compile/PushedInAsGivens.stderr @@ -1,27 +1,28 @@ -PushedInAsGivens.hs:10:31: - Couldn't match expected type ‘a1’ with actual type ‘a’ - because type variable ‘a1’ would escape its scope - This (rigid, skolem) type variable is bound by - the type signature for: foo :: (F Int ~ [a1]) => a1 -> Int - at PushedInAsGivens.hs:9:20-44 - In the expression: y - In the first argument of ‘length’, namely ‘[x, y]’ - Relevant bindings include - x :: a1 (bound at PushedInAsGivens.hs:10:17) - foo :: a1 -> Int (bound at PushedInAsGivens.hs:10:13) - y :: a (bound at PushedInAsGivens.hs:9:5) - bar :: a -> (a, Int) (bound at PushedInAsGivens.hs:9:1) +PushedInAsGivens.hs:10:31: error: + • Couldn't match expected type ‘a1’ with actual type ‘a’ + because type variable ‘a1’ would escape its scope + This (rigid, skolem) type variable is bound by + the type signature for: + foo :: (F Int ~ [a1]) => a1 -> Int + at PushedInAsGivens.hs:9:13-44 + • In the expression: y + In the first argument of ‘length’, namely ‘[x, y]’ + • Relevant bindings include + x :: a1 (bound at PushedInAsGivens.hs:10:17) + foo :: a1 -> Int (bound at PushedInAsGivens.hs:10:13) + y :: a (bound at PushedInAsGivens.hs:9:5) + bar :: a -> (a, Int) (bound at PushedInAsGivens.hs:9:1) -PushedInAsGivens.hs:11:15: - Couldn't match expected type ‘[a]’ with actual type ‘F Int’ - In the expression: foo y - In the expression: (y, foo y) - In the expression: - let - foo :: (F Int ~ [a]) => a -> Int - foo x = length [...] - in (y, foo y) - Relevant bindings include - y :: a (bound at PushedInAsGivens.hs:9:5) - bar :: a -> (a, Int) (bound at PushedInAsGivens.hs:9:1) +PushedInAsGivens.hs:11:15: error: + • Couldn't match expected type ‘[a]’ with actual type ‘F Int’ + • In the expression: foo y + In the expression: (y, foo y) + In the expression: + let + foo :: (F Int ~ [a]) => a -> Int + foo x = length [...] + in (y, foo y) + • Relevant bindings include + y :: a (bound at PushedInAsGivens.hs:9:5) + bar :: a -> (a, Int) (bound at PushedInAsGivens.hs:9:1) diff --git a/testsuite/tests/indexed-types/should_compile/Records.hs b/testsuite/tests/indexed-types/should_compile/Records.hs index 4a08125e30..8508c66f65 100644 --- a/testsuite/tests/indexed-types/should_compile/Records.hs +++ b/testsuite/tests/indexed-types/should_compile/Records.hs @@ -26,7 +26,7 @@ f r = r { moo = 3 } class D c where data D1 c works :: Int -> D1 c -> D1 c - buggy :: Int -> D1 c -> D1 c + buggy :: Int -> D1 c -> D1 c buggy2 :: Int -> D1 c -> D1 c instance D FooC where @@ -34,7 +34,7 @@ instance D FooC where works x d = d -- d unchanged, so OK - buggy x d@(D1F { noo = k }) = + buggy x d@(D1F { noo = k }) = d { noo = k + x } buggy2 x d@(D1F { noo = k }) = diff --git a/testsuite/tests/indexed-types/should_compile/Simple14.stderr b/testsuite/tests/indexed-types/should_compile/Simple14.stderr index 861013259c..395149121e 100644 --- a/testsuite/tests/indexed-types/should_compile/Simple14.stderr +++ b/testsuite/tests/indexed-types/should_compile/Simple14.stderr @@ -1,17 +1,18 @@ - -Simple14.hs:8:8: - Couldn't match type ‘z0’ with ‘z’ - ‘z0’ is untouchable - inside the constraints: x ~ y - bound by the type signature for: eqE :: (x ~ y) => EQ_ z0 z0 - at Simple14.hs:8:8-39 - ‘z’ is a rigid type variable bound by - the type signature for: eqE :: EQ_ x y -> ((x ~ y) => EQ_ z z) -> p - at Simple14.hs:8:8 - Expected type: EQ_ z0 z0 - Actual type: EQ_ z z - In the ambiguity check for the type signature for ‘eqE’: - eqE :: forall x y z p. EQ_ x y -> ((x ~ y) => EQ_ z z) -> p - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the type signature for ‘eqE’: - eqE :: EQ_ x y -> (x ~ y => EQ_ z z) -> p +
+Simple14.hs:8:8: error:
+ Couldn't match type ‘z0’ with ‘z’
+ ‘z0’ is untouchable
+ inside the constraints: x ~ y
+ bound by the type signature for:
+ eqE :: (x ~ y) => EQ_ z0 z0
+ at Simple14.hs:8:8-39
+ ‘z’ is a rigid type variable bound by
+ the type signature for:
+ eqE :: forall x y z p. EQ_ x y -> ((x ~ y) => EQ_ z z) -> p
+ at Simple14.hs:8:8
+ Expected type: EQ_ z0 z0
+ Actual type: EQ_ z z
+ In the ambiguity check for ‘eqE’
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ In the type signature:
+ eqE :: EQ_ x y -> (x ~ y => EQ_ z z) -> p
diff --git a/testsuite/tests/indexed-types/should_compile/T3208b.stderr b/testsuite/tests/indexed-types/should_compile/T3208b.stderr index 10f3d2a26d..b40942a5a9 100644 --- a/testsuite/tests/indexed-types/should_compile/T3208b.stderr +++ b/testsuite/tests/indexed-types/should_compile/T3208b.stderr @@ -1,24 +1,24 @@ -T3208b.hs:15:10: - Could not deduce: OTerm o0 ~ STerm o0 - from the context: (OTerm a ~ STerm a, OBJECT a, SUBST a) - bound by the type signature for: - fce' :: (OTerm a ~ STerm a, OBJECT a, SUBST a) => a -> c - at T3208b.hs:14:9-56 - The type variable ‘o0’ is ambiguous - In the expression: fce (apply f) - In an equation for ‘fce'’: fce' f = fce (apply f) +T3208b.hs:15:10: error: + • Could not deduce: OTerm o0 ~ STerm o0 + from the context: (OTerm a ~ STerm a, OBJECT a, SUBST a) + bound by the type signature for: + fce' :: (OTerm a ~ STerm a, OBJECT a, SUBST a) => a -> c + at T3208b.hs:14:1-56 + The type variable ‘o0’ is ambiguous + • In the expression: fce (apply f) + In an equation for ‘fce'’: fce' f = fce (apply f) -T3208b.hs:15:15: - Could not deduce: OTerm o0 ~ STerm a - from the context: (OTerm a ~ STerm a, OBJECT a, SUBST a) - bound by the type signature for: - fce' :: (OTerm a ~ STerm a, OBJECT a, SUBST a) => a -> c - at T3208b.hs:14:9-56 - The type variable ‘o0’ is ambiguous - In the first argument of ‘fce’, namely ‘(apply f)’ - In the expression: fce (apply f) - In an equation for ‘fce'’: fce' f = fce (apply f) - Relevant bindings include - f :: a (bound at T3208b.hs:15:6) - fce' :: a -> c (bound at T3208b.hs:15:1) +T3208b.hs:15:15: error: + • Could not deduce: OTerm o0 ~ STerm a + from the context: (OTerm a ~ STerm a, OBJECT a, SUBST a) + bound by the type signature for: + fce' :: (OTerm a ~ STerm a, OBJECT a, SUBST a) => a -> c + at T3208b.hs:14:1-56 + The type variable ‘o0’ is ambiguous + • In the first argument of ‘fce’, namely ‘(apply f)’ + In the expression: fce (apply f) + In an equation for ‘fce'’: fce' f = fce (apply f) + • Relevant bindings include + f :: a (bound at T3208b.hs:15:6) + fce' :: a -> c (bound at T3208b.hs:15:1) diff --git a/testsuite/tests/indexed-types/should_fail/BadSock.hs b/testsuite/tests/indexed-types/should_fail/BadSock.hs index 3e72817b8d..c34c1657e6 100644 --- a/testsuite/tests/indexed-types/should_fail/BadSock.hs +++ b/testsuite/tests/indexed-types/should_fail/BadSock.hs @@ -27,8 +27,8 @@ data Socket :: SocketType -> * where -> Socket sock type family Foo (op :: SocketOperation) :: SocketType -> Constraint where - Foo 'Read = Readable - Foo Write = Writable + Foo 'Read = Readable + Foo Write = Writable type family Operation (op :: SocketOperation) :: * where Operation 'Read = IO Message @@ -54,4 +54,4 @@ pull = undefined readSocket :: forall sock . Readable sock => Socket sock -> IO Message readSocket (Socket _ f) = f (SRead :: SockOp sock 'Read) --}
\ No newline at end of file +-} diff --git a/testsuite/tests/indexed-types/should_fail/GADTwrong1.stderr b/testsuite/tests/indexed-types/should_fail/GADTwrong1.stderr index 694a7832ad..7f806db271 100644 --- a/testsuite/tests/indexed-types/should_fail/GADTwrong1.stderr +++ b/testsuite/tests/indexed-types/should_fail/GADTwrong1.stderr @@ -1,14 +1,16 @@ -
-GADTwrong1.hs:12:21:
- Couldn't match expected type ‘b’ with actual type ‘c’
- ‘c’ is a rigid type variable bound by
- a pattern with constructor: T :: forall c. c -> T (Const c),
- in a case alternative
- at GADTwrong1.hs:12:14
- ‘b’ is a rigid type variable bound by
- the type signature for: coerce :: a -> b at GADTwrong1.hs:10:20
- In the expression: y
- In a case alternative: T y -> y
- Relevant bindings include
- y :: c (bound at GADTwrong1.hs:12:16)
- coerce :: a -> b (bound at GADTwrong1.hs:11:1)
+ +GADTwrong1.hs:12:21: error: + • Couldn't match expected type ‘b’ with actual type ‘c’ + ‘c’ is a rigid type variable bound by + a pattern with constructor: T :: forall c. c -> T (Const c), + in a case alternative + at GADTwrong1.hs:12:14 + ‘b’ is a rigid type variable bound by + the type signature for: + coerce :: forall a b. a -> b + at GADTwrong1.hs:10:20 + • In the expression: y + In a case alternative: T y -> y + • Relevant bindings include + y :: c (bound at GADTwrong1.hs:12:16) + coerce :: a -> b (bound at GADTwrong1.hs:11:1) diff --git a/testsuite/tests/indexed-types/should_fail/NoMatchErr.stderr b/testsuite/tests/indexed-types/should_fail/NoMatchErr.stderr index 5a0443bfa1..73f1cbc157 100644 --- a/testsuite/tests/indexed-types/should_fail/NoMatchErr.stderr +++ b/testsuite/tests/indexed-types/should_fail/NoMatchErr.stderr @@ -1,11 +1,10 @@ - -NoMatchErr.hs:19:7: - Couldn't match type ‘Memo d0’ with ‘Memo d’ - NB: ‘Memo’ is a type function, and may not be injective - The type variable ‘d0’ is ambiguous - Expected type: Memo d a -> Memo d a - Actual type: Memo d0 a -> Memo d0 a - In the ambiguity check for the type signature for ‘f’: - f :: forall d a. Fun d => Memo d a -> Memo d a - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the type signature for ‘f’: f :: (Fun d) => Memo d a -> Memo d a +
+NoMatchErr.hs:19:7: error:
+ Couldn't match type ‘Memo d0’ with ‘Memo d’
+ NB: ‘Memo’ is a type function, and may not be injective
+ The type variable ‘d0’ is ambiguous
+ Expected type: Memo d a -> Memo d a
+ Actual type: Memo d0 a -> Memo d0 a
+ In the ambiguity check for ‘f’
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ In the type signature: f :: (Fun d) => Memo d a -> Memo d a
diff --git a/testsuite/tests/indexed-types/should_fail/Overlap6.stderr b/testsuite/tests/indexed-types/should_fail/Overlap6.stderr index b2dc99251f..6ffcda02ce 100644 --- a/testsuite/tests/indexed-types/should_fail/Overlap6.stderr +++ b/testsuite/tests/indexed-types/should_fail/Overlap6.stderr @@ -1,13 +1,14 @@ -Overlap6.hs:15:7: - Couldn't match type ‘x’ with ‘And x 'True’ +Overlap6.hs:15:7: error: + • Couldn't match type ‘x’ with ‘And x 'True’ ‘x’ is a rigid type variable bound by - the type signature for: g :: Proxy x -> Proxy (And x 'True) - at Overlap6.hs:14:6 - Expected type: Proxy (And x 'True) - Actual type: Proxy x - In the expression: x - In an equation for ‘g’: g x = x - Relevant bindings include - x :: Proxy x (bound at Overlap6.hs:15:3) - g :: Proxy x -> Proxy (And x 'True) (bound at Overlap6.hs:15:1) + the type signature for: + g :: forall (x :: Bool). Proxy x -> Proxy (And x 'True) + at Overlap6.hs:14:6 + Expected type: Proxy (And x 'True) + Actual type: Proxy x + • In the expression: x + In an equation for ‘g’: g x = x + • Relevant bindings include + x :: Proxy x (bound at Overlap6.hs:15:3) + g :: Proxy x -> Proxy (And x 'True) (bound at Overlap6.hs:15:1) diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail15.stderr b/testsuite/tests/indexed-types/should_fail/SimpleFail15.stderr index 133eccf642..9a10408997 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail15.stderr +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail15.stderr @@ -1,6 +1,5 @@ - -SimpleFail15.hs:5:8: - Illegal polymorphic or qualified type: (a ~ b) => t - Perhaps you intended to use RankNTypes or Rank2Types - In the type signature for ‘foo’: - foo :: (a, b) -> (a ~ b => t) -> (a, b) +
+SimpleFail15.hs:5:8: error:
+ Illegal polymorphic or qualified type: (a ~ b) => t
+ Perhaps you intended to use RankNTypes or Rank2Types
+ In the type signature: foo :: (a, b) -> (a ~ b => t) -> (a, b)
diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail16.stderr b/testsuite/tests/indexed-types/should_fail/SimpleFail16.stderr index 74db7b1dcf..fa635378a4 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail16.stderr +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail16.stderr @@ -1,5 +1,5 @@ -SimpleFail16.hs:10:12: +SimpleFail16.hs:10:12: error: Couldn't match expected type ‘p0 a0’ with actual type ‘F ()’ The type variables ‘p0’, ‘a0’ are ambiguous In the first argument of ‘foo’, namely ‘(undefined :: F ())’ diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail5a.stderr b/testsuite/tests/indexed-types/should_fail/SimpleFail5a.stderr index 8288d30619..4b9c3657db 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail5a.stderr +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail5a.stderr @@ -1,12 +1,13 @@ -SimpleFail5a.hs:31:11: - Couldn't match type ‘a’ with ‘Int’ +SimpleFail5a.hs:31:11: error: + • Couldn't match type ‘a’ with ‘Int’ ‘a’ is a rigid type variable bound by - the type signature for: bar3wrong :: S3 a -> a - at SimpleFail5a.hs:30:14 - Expected type: S3 a - Actual type: S3 Int - In the pattern: D3Int - In an equation for ‘bar3wrong’: bar3wrong D3Int = 1 - Relevant bindings include - bar3wrong :: S3 a -> a (bound at SimpleFail5a.hs:31:1) + the type signature for: + bar3wrong :: forall a. S3 a -> a + at SimpleFail5a.hs:30:14 + Expected type: S3 a + Actual type: S3 Int + • In the pattern: D3Int + In an equation for ‘bar3wrong’: bar3wrong D3Int = 1 + • Relevant bindings include + bar3wrong :: S3 a -> a (bound at SimpleFail5a.hs:31:1) diff --git a/testsuite/tests/indexed-types/should_fail/T1897b.stderr b/testsuite/tests/indexed-types/should_fail/T1897b.stderr index 936aa26924..459f6c8a17 100644 --- a/testsuite/tests/indexed-types/should_fail/T1897b.stderr +++ b/testsuite/tests/indexed-types/should_fail/T1897b.stderr @@ -1,12 +1,13 @@ -T1897b.hs:16:1: +T1897b.hs:16:1: error: Couldn't match type ‘Depend a’ with ‘Depend a0’ NB: ‘Depend’ is a type function, and may not be injective The type variable ‘a0’ is ambiguous Expected type: t (Depend a) -> Bool Actual type: t (Depend a0) -> Bool - When checking that ‘isValid’ has the inferred type + In the ambiguity check for the inferred type for ‘isValid’ + To defer the ambiguity check to use sites, enable AllowAmbiguousTypes + When checking the inferred type isValid :: forall a (t :: * -> *). (Foldable t, Bug a) => t (Depend a) -> Bool - Probable cause: the inferred type is ambiguous diff --git a/testsuite/tests/indexed-types/should_fail/T1900.stderr b/testsuite/tests/indexed-types/should_fail/T1900.stderr index f986888cfd..ce7d51c5de 100644 --- a/testsuite/tests/indexed-types/should_fail/T1900.stderr +++ b/testsuite/tests/indexed-types/should_fail/T1900.stderr @@ -1,12 +1,11 @@ -T1900.hs:7:3:
+T1900.hs:7:3: error:
Couldn't match type ‘Depend s0’ with ‘Depend s’
NB: ‘Depend’ is a type function, and may not be injective
The type variable ‘s0’ is ambiguous
Expected type: Depend s -> Depend s
Actual type: Depend s0 -> Depend s0
- In the ambiguity check for the type signature for ‘trans’:
- trans :: forall s. Bug s => Depend s -> Depend s
+ In the ambiguity check for ‘trans’
To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
When checking the class method:
trans :: forall s. Bug s => Depend s -> Depend s
diff --git a/testsuite/tests/indexed-types/should_fail/T2693.stderr b/testsuite/tests/indexed-types/should_fail/T2693.stderr index 182bbde8ed..d3546c21ba 100644 --- a/testsuite/tests/indexed-types/should_fail/T2693.stderr +++ b/testsuite/tests/indexed-types/should_fail/T2693.stderr @@ -1,38 +1,36 @@ -
-T2693.hs:11:7:
- Couldn't match expected type ‘TFn a’ with actual type ‘TFn a0’
- NB: ‘TFn’ is a type function, and may not be injective
- The type variable ‘a0’ is ambiguous
- When checking that ‘x’ has the inferred type
- x :: forall a. TFn a
- Probable cause: the inferred type is ambiguous
- In the expression:
- do { let Just x = ...;
- let n = fst x + fst x;
- return () }
- In an equation for ‘f’:
- f = do { let Just x = ...;
- let n = ...;
- return () }
-
-T2693.hs:19:15:
- Couldn't match expected type ‘(a5, b0)’ with actual type ‘TFn a2’
- The type variables ‘b0’, ‘a2’, ‘a5’ are ambiguous
- In the first argument of ‘fst’, namely ‘x’
- In the first argument of ‘(+)’, namely ‘fst x’
- Relevant bindings include n :: a5 (bound at T2693.hs:19:7)
-
-T2693.hs:19:23:
- Couldn't match expected type ‘(a3, a5)’ with actual type ‘TFn a4’
- The type variables ‘a3’, ‘a4’, ‘a5’ are ambiguous
- In the first argument of ‘snd’, namely ‘x’
- In the second argument of ‘(+)’, namely ‘snd x’
- Relevant bindings include n :: a5 (bound at T2693.hs:19:7)
-
-T2693.hs:29:20:
- Couldn't match type ‘TFn a0’ with ‘PVR a1’
- The type variables ‘a0’, ‘a1’ are ambiguous
- Expected type: () -> Maybe (PVR a1)
- Actual type: () -> Maybe (TFn a0)
- In the first argument of ‘mapM’, namely ‘g’
- In a stmt of a 'do' block: pvs <- mapM g undefined
+ +T2693.hs:12:15: error: + • Couldn't match expected type ‘(a8, b1)’ with actual type ‘TFn a6’ + The type variables ‘b1’, ‘a6’, ‘a8’ are ambiguous + • In the first argument of ‘fst’, namely ‘x’ + In the first argument of ‘(+)’, namely ‘fst x’ + • Relevant bindings include n :: a8 (bound at T2693.hs:12:7) + +T2693.hs:12:23: error: + • Couldn't match expected type ‘(a8, b2)’ with actual type ‘TFn a7’ + The type variables ‘b2’, ‘a7’, ‘a8’ are ambiguous + • In the first argument of ‘fst’, namely ‘x’ + In the second argument of ‘(+)’, namely ‘fst x’ + • Relevant bindings include n :: a8 (bound at T2693.hs:12:7) + +T2693.hs:19:15: error: + • Couldn't match expected type ‘(a5, b0)’ with actual type ‘TFn a2’ + The type variables ‘b0’, ‘a2’, ‘a5’ are ambiguous + • In the first argument of ‘fst’, namely ‘x’ + In the first argument of ‘(+)’, namely ‘fst x’ + • Relevant bindings include n :: a5 (bound at T2693.hs:19:7) + +T2693.hs:19:23: error: + • Couldn't match expected type ‘(a3, a5)’ with actual type ‘TFn a4’ + The type variables ‘a3’, ‘a4’, ‘a5’ are ambiguous + • In the first argument of ‘snd’, namely ‘x’ + In the second argument of ‘(+)’, namely ‘snd x’ + • Relevant bindings include n :: a5 (bound at T2693.hs:19:7) + +T2693.hs:29:20: error: + • Couldn't match type ‘TFn a0’ with ‘PVR a1’ + The type variables ‘a0’, ‘a1’ are ambiguous + Expected type: () -> Maybe (PVR a1) + Actual type: () -> Maybe (TFn a0) + • In the first argument of ‘mapM’, namely ‘g’ + In a stmt of a 'do' block: pvs <- mapM g undefined diff --git a/testsuite/tests/indexed-types/should_fail/T3330a.stderr b/testsuite/tests/indexed-types/should_fail/T3330a.stderr index a114158938..acefda7253 100644 --- a/testsuite/tests/indexed-types/should_fail/T3330a.stderr +++ b/testsuite/tests/indexed-types/should_fail/T3330a.stderr @@ -1,44 +1,52 @@ -T3330a.hs:19:34: - Couldn't match type ‘s’ with ‘(->) (s0 ix0 -> ix1)’ +T3330a.hs:19:34: error: + • Couldn't match type ‘s’ with ‘(->) (s0 ix0 -> ix1)’ ‘s’ is a rigid type variable bound by - the type signature for: children :: s ix -> PF s r ix -> [AnyF s] - at T3330a.hs:18:13 - Expected type: (s0 ix0 -> ix1) - -> r ix1 -> Writer [AnyF s] (r'0 ix1) - Actual type: s ix - In the first argument of ‘hmapM’, namely ‘p’ - In the first argument of ‘execWriter’, namely ‘(hmapM p collect x)’ - Relevant bindings include - x :: PF s r ix (bound at T3330a.hs:19:12) - p :: s ix (bound at T3330a.hs:19:10) - children :: s ix -> PF s r ix -> [AnyF s] (bound at T3330a.hs:19:1) + the type signature for: + children :: forall (s :: * -> *) ix (r :: * -> *). + s ix -> PF s r ix -> [AnyF s] + at T3330a.hs:18:13 + Expected type: (s0 ix0 -> ix1) + -> r ix1 -> Writer [AnyF s] (r'0 ix1) + Actual type: s ix + • In the first argument of ‘hmapM’, namely ‘p’ + In the first argument of ‘execWriter’, namely ‘(hmapM p collect x)’ + • Relevant bindings include + x :: PF s r ix (bound at T3330a.hs:19:12) + p :: s ix (bound at T3330a.hs:19:10) + children :: s ix -> PF s r ix -> [AnyF s] (bound at T3330a.hs:19:1) -T3330a.hs:19:34: - Couldn't match type ‘ix’ with ‘r ix1 -> Writer [AnyF s] (r'0 ix1)’ +T3330a.hs:19:34: error: + • Couldn't match type ‘ix’ + with ‘r ix1 -> Writer [AnyF s] (r'0 ix1)’ ‘ix’ is a rigid type variable bound by - the type signature for: children :: s ix -> PF s r ix -> [AnyF s] - at T3330a.hs:18:13 - Expected type: (s0 ix0 -> ix1) - -> r ix1 -> Writer [AnyF s] (r'0 ix1) - Actual type: s ix - In the first argument of ‘hmapM’, namely ‘p’ - In the first argument of ‘execWriter’, namely ‘(hmapM p collect x)’ - Relevant bindings include - x :: PF s r ix (bound at T3330a.hs:19:12) - p :: s ix (bound at T3330a.hs:19:10) - children :: s ix -> PF s r ix -> [AnyF s] (bound at T3330a.hs:19:1) + the type signature for: + children :: forall (s :: * -> *) ix (r :: * -> *). + s ix -> PF s r ix -> [AnyF s] + at T3330a.hs:18:13 + Expected type: (s0 ix0 -> ix1) + -> r ix1 -> Writer [AnyF s] (r'0 ix1) + Actual type: s ix + • In the first argument of ‘hmapM’, namely ‘p’ + In the first argument of ‘execWriter’, namely ‘(hmapM p collect x)’ + • Relevant bindings include + x :: PF s r ix (bound at T3330a.hs:19:12) + p :: s ix (bound at T3330a.hs:19:10) + children :: s ix -> PF s r ix -> [AnyF s] (bound at T3330a.hs:19:1) -T3330a.hs:19:44: - Couldn't match type ‘ix’ with ‘r0 ix0 -> Writer [AnyF s0] (r0 ix0)’ +T3330a.hs:19:44: error: + • Couldn't match type ‘ix’ + with ‘r0 ix0 -> Writer [AnyF s0] (r0 ix0)’ ‘ix’ is a rigid type variable bound by - the type signature for: children :: s ix -> PF s r ix -> [AnyF s] - at T3330a.hs:18:13 - Expected type: PF s r (r0 ix0 -> Writer [AnyF s0] (r0 ix0)) - Actual type: PF s r ix - In the third argument of ‘hmapM’, namely ‘x’ - In the first argument of ‘execWriter’, namely ‘(hmapM p collect x)’ - Relevant bindings include - x :: PF s r ix (bound at T3330a.hs:19:12) - p :: s ix (bound at T3330a.hs:19:10) - children :: s ix -> PF s r ix -> [AnyF s] (bound at T3330a.hs:19:1) + the type signature for: + children :: forall (s :: * -> *) ix (r :: * -> *). + s ix -> PF s r ix -> [AnyF s] + at T3330a.hs:18:13 + Expected type: PF s r (r0 ix0 -> Writer [AnyF s0] (r0 ix0)) + Actual type: PF s r ix + • In the third argument of ‘hmapM’, namely ‘x’ + In the first argument of ‘execWriter’, namely ‘(hmapM p collect x)’ + • Relevant bindings include + x :: PF s r ix (bound at T3330a.hs:19:12) + p :: s ix (bound at T3330a.hs:19:10) + children :: s ix -> PF s r ix -> [AnyF s] (bound at T3330a.hs:19:1) diff --git a/testsuite/tests/indexed-types/should_fail/T3440.stderr b/testsuite/tests/indexed-types/should_fail/T3440.stderr index cfc5570c66..7b29bb6f52 100644 --- a/testsuite/tests/indexed-types/should_fail/T3440.stderr +++ b/testsuite/tests/indexed-types/should_fail/T3440.stderr @@ -1,22 +1,23 @@ -T3440.hs:11:22: - Could not deduce: a1 ~ a - from the context: Fam a ~ Fam a1 - bound by a pattern with constructor: - GADT :: forall a. a -> Fam a -> GADT (Fam a), - in an equation for ‘unwrap’ - at T3440.hs:11:9-16 +T3440.hs:11:22: error: + • Could not deduce: a1 ~ a + from the context: Fam a ~ Fam a1 + bound by a pattern with constructor: + GADT :: forall a. a -> Fam a -> GADT (Fam a), + in an equation for ‘unwrap’ + at T3440.hs:11:9-16 ‘a1’ is a rigid type variable bound by - a pattern with constructor: - GADT :: forall a. a -> Fam a -> GADT (Fam a), - in an equation for ‘unwrap’ - at T3440.hs:11:9 + a pattern with constructor: + GADT :: forall a. a -> Fam a -> GADT (Fam a), + in an equation for ‘unwrap’ + at T3440.hs:11:9 ‘a’ is a rigid type variable bound by - the type signature for: unwrap :: GADT (Fam a) -> (a, Fam a) - at T3440.hs:10:11 - In the expression: x - In the expression: (x, y) - Relevant bindings include - y :: Fam a1 (bound at T3440.hs:11:16) - x :: a1 (bound at T3440.hs:11:14) - unwrap :: GADT (Fam a) -> (a, Fam a) (bound at T3440.hs:11:1) + the type signature for: + unwrap :: forall a. GADT (Fam a) -> (a, Fam a) + at T3440.hs:10:11 + • In the expression: x + In the expression: (x, y) + • Relevant bindings include + y :: Fam a1 (bound at T3440.hs:11:16) + x :: a1 (bound at T3440.hs:11:14) + unwrap :: GADT (Fam a) -> (a, Fam a) (bound at T3440.hs:11:1) diff --git a/testsuite/tests/indexed-types/should_fail/T4093a.stderr b/testsuite/tests/indexed-types/should_fail/T4093a.stderr index efeb34a94a..8f46170339 100644 --- a/testsuite/tests/indexed-types/should_fail/T4093a.stderr +++ b/testsuite/tests/indexed-types/should_fail/T4093a.stderr @@ -1,14 +1,16 @@ T4093a.hs:8:8: error: - Could not deduce: e ~ () - from the context: Foo e ~ Maybe e - bound by the type signature for: hang :: (Foo e ~ Maybe e) => Foo e - at T4093a.hs:7:9-34 + • Could not deduce: e ~ () + from the context: Foo e ~ Maybe e + bound by the type signature for: + hang :: (Foo e ~ Maybe e) => Foo e + at T4093a.hs:7:1-34 ‘e’ is a rigid type variable bound by - the type signature for: hang :: (Foo e ~ Maybe e) => Foo e - at T4093a.hs:7:9 - Expected type: Foo e - Actual type: Maybe () - In the expression: Just () - In an equation for ‘hang’: hang = Just () - Relevant bindings include hang :: Foo e (bound at T4093a.hs:8:1) + the type signature for: + hang :: forall e. (Foo e ~ Maybe e) => Foo e + at T4093a.hs:7:9 + Expected type: Foo e + Actual type: Maybe () + • In the expression: Just () + In an equation for ‘hang’: hang = Just () + • Relevant bindings include hang :: Foo e (bound at T4093a.hs:8:1) diff --git a/testsuite/tests/indexed-types/should_fail/T4093b.stderr b/testsuite/tests/indexed-types/should_fail/T4093b.stderr index 53d7844f4f..0950de8c66 100644 --- a/testsuite/tests/indexed-types/should_fail/T4093b.stderr +++ b/testsuite/tests/indexed-types/should_fail/T4093b.stderr @@ -1,41 +1,42 @@ -T4093b.hs:31:13: - Could not deduce: e ~ C - from the context: (EitherCO e (A C O n) (A O O n) ~ A e O n, - EitherCO x (A C C n) (A C O n) ~ A C x n) - bound by the type signature for: - blockToNodeList :: (EitherCO e (A C O n) (A O O n) ~ A e O n, - EitherCO x (A C C n) (A C O n) ~ A C x n) => - Block n e x -> A e x n - at T4093b.hs:(20,3)-(22,26) +T4093b.hs:31:13: error: + • Could not deduce: e ~ C + from the context: (EitherCO e (A C O n) (A O O n) ~ A e O n, + EitherCO x (A C C n) (A C O n) ~ A C x n) + bound by the type signature for: + blockToNodeList :: (EitherCO e (A C O n) (A O O n) ~ A e O n, + EitherCO x (A C C n) (A C O n) ~ A C x n) => + Block n e x -> A e x n + at T4093b.hs:(19,1)-(22,26) ‘e’ is a rigid type variable bound by - the type signature for: - blockToNodeList :: (EitherCO e (A C O n) (A O O n) ~ A e O n, + the type signature for: + blockToNodeList :: forall (n :: * -> * -> *) e x. + (EitherCO e (A C O n) (A O O n) ~ A e O n, EitherCO x (A C C n) (A C O n) ~ A C x n) => Block n e x -> A e x n - at T4093b.hs:20:12 - Expected type: EitherCO e (A C O n) (A O O n) - Actual type: (MaybeC C (n C O), MaybeC O (n O C)) - In the expression: (JustC n, NothingC) - In an equation for ‘f’: f n _ = (JustC n, NothingC) - In an equation for ‘blockToNodeList’: - blockToNodeList b - = foldBlockNodesF (f, l) b z - where - z :: - EitherCO e (EitherCO e (A C O n) (A O O n)) (EitherCO e (A C O n) (A O O n)) - z = undefined - f :: - n C O - -> EitherCO e (A C O n) (A O O n) -> EitherCO e (A C O n) (A O O n) - f n _ = (JustC n, NothingC) - .... - Relevant bindings include - f :: n C O - -> EitherCO e (A C O n) (A O O n) -> EitherCO e (A C O n) (A O O n) - (bound at T4093b.hs:31:5) - l :: n O C - -> EitherCO e (A C O n) (A O O n) -> EitherCO e (A C C n) (A O C n) - (bound at T4093b.hs:34:5) - b :: Block n e x (bound at T4093b.hs:25:17) - blockToNodeList :: Block n e x -> A e x n (bound at T4093b.hs:25:1) + at T4093b.hs:20:12 + Expected type: EitherCO e (A C O n) (A O O n) + Actual type: (MaybeC C (n C O), MaybeC O (n O C)) + • In the expression: (JustC n, NothingC) + In an equation for ‘f’: f n _ = (JustC n, NothingC) + In an equation for ‘blockToNodeList’: + blockToNodeList b + = foldBlockNodesF (f, l) b z + where + z :: + EitherCO e (EitherCO e (A C O n) (A O O n)) (EitherCO e (A C O n) (A O O n)) + z = undefined + f :: + n C O + -> EitherCO e (A C O n) (A O O n) -> EitherCO e (A C O n) (A O O n) + f n _ = (JustC n, NothingC) + .... + • Relevant bindings include + f :: n C O + -> EitherCO e (A C O n) (A O O n) -> EitherCO e (A C O n) (A O O n) + (bound at T4093b.hs:31:5) + l :: n O C + -> EitherCO e (A C O n) (A O O n) -> EitherCO e (A C C n) (A O C n) + (bound at T4093b.hs:34:5) + b :: Block n e x (bound at T4093b.hs:25:17) + blockToNodeList :: Block n e x -> A e x n (bound at T4093b.hs:25:1) diff --git a/testsuite/tests/indexed-types/should_fail/T4174.stderr b/testsuite/tests/indexed-types/should_fail/T4174.stderr index 872004519e..60ae24ccfa 100644 --- a/testsuite/tests/indexed-types/should_fail/T4174.stderr +++ b/testsuite/tests/indexed-types/should_fail/T4174.stderr @@ -1,28 +1,32 @@ -T4174.hs:42:12: - Couldn't match type ‘a’ with ‘SmStep’ +T4174.hs:42:12: error: + • Couldn't match type ‘a’ with ‘SmStep’ ‘a’ is a rigid type variable bound by - the type signature for: - testcase :: Monad m => m (Field (Way (GHC6'8 minor) n t p) a b) - at T4174.hs:41:13 - Expected type: m (Field (Way (GHC6'8 minor) n t p) a b) - Actual type: m (Field (WayOf m) SmStep RtsSpinLock) - In the expression: sync_large_objects - In an equation for ‘testcase’: testcase = sync_large_objects - Relevant bindings include - testcase :: m (Field (Way (GHC6'8 minor) n t p) a b) - (bound at T4174.hs:42:1) + the type signature for: + testcase :: forall (m :: * -> *) minor n t p a b. + Monad m => + m (Field (Way (GHC6'8 minor) n t p) a b) + at T4174.hs:41:13 + Expected type: m (Field (Way (GHC6'8 minor) n t p) a b) + Actual type: m (Field (WayOf m) SmStep RtsSpinLock) + • In the expression: sync_large_objects + In an equation for ‘testcase’: testcase = sync_large_objects + • Relevant bindings include + testcase :: m (Field (Way (GHC6'8 minor) n t p) a b) + (bound at T4174.hs:42:1) -T4174.hs:42:12: - Couldn't match type ‘b’ with ‘RtsSpinLock’ +T4174.hs:42:12: error: + • Couldn't match type ‘b’ with ‘RtsSpinLock’ ‘b’ is a rigid type variable bound by - the type signature for: - testcase :: Monad m => m (Field (Way (GHC6'8 minor) n t p) a b) - at T4174.hs:41:13 - Expected type: m (Field (Way (GHC6'8 minor) n t p) a b) - Actual type: m (Field (WayOf m) SmStep RtsSpinLock) - In the expression: sync_large_objects - In an equation for ‘testcase’: testcase = sync_large_objects - Relevant bindings include - testcase :: m (Field (Way (GHC6'8 minor) n t p) a b) - (bound at T4174.hs:42:1) + the type signature for: + testcase :: forall (m :: * -> *) minor n t p a b. + Monad m => + m (Field (Way (GHC6'8 minor) n t p) a b) + at T4174.hs:41:13 + Expected type: m (Field (Way (GHC6'8 minor) n t p) a b) + Actual type: m (Field (WayOf m) SmStep RtsSpinLock) + • In the expression: sync_large_objects + In an equation for ‘testcase’: testcase = sync_large_objects + • Relevant bindings include + testcase :: m (Field (Way (GHC6'8 minor) n t p) a b) + (bound at T4174.hs:42:1) diff --git a/testsuite/tests/indexed-types/should_fail/T4272.stderr b/testsuite/tests/indexed-types/should_fail/T4272.stderr index 84d50dc69f..a3b750a459 100644 --- a/testsuite/tests/indexed-types/should_fail/T4272.stderr +++ b/testsuite/tests/indexed-types/should_fail/T4272.stderr @@ -1,16 +1,17 @@ -T4272.hs:15:26: - Couldn't match type ‘a’ with ‘TermFamily a a’ +T4272.hs:15:26: error: + • Couldn't match type ‘a’ with ‘TermFamily a a’ ‘a’ is a rigid type variable bound by - the type signature for: laws :: TermLike a => TermFamily a a -> b - at T4272.hs:14:16 - Expected type: TermFamily a (TermFamily a a) - Actual type: TermFamily a a - In the first argument of ‘terms’, namely - ‘(undefined :: TermFamily a a)’ - In the second argument of ‘prune’, namely - ‘(terms (undefined :: TermFamily a a))’ - In the expression: prune t (terms (undefined :: TermFamily a a)) - Relevant bindings include - t :: TermFamily a a (bound at T4272.hs:15:6) - laws :: TermFamily a a -> b (bound at T4272.hs:15:1) + the type signature for: + laws :: forall a b. TermLike a => TermFamily a a -> b + at T4272.hs:14:16 + Expected type: TermFamily a (TermFamily a a) + Actual type: TermFamily a a + • In the first argument of ‘terms’, namely + ‘(undefined :: TermFamily a a)’ + In the second argument of ‘prune’, namely + ‘(terms (undefined :: TermFamily a a))’ + In the expression: prune t (terms (undefined :: TermFamily a a)) + • Relevant bindings include + t :: TermFamily a a (bound at T4272.hs:15:6) + laws :: TermFamily a a -> b (bound at T4272.hs:15:1) diff --git a/testsuite/tests/indexed-types/should_fail/T7194.stderr b/testsuite/tests/indexed-types/should_fail/T7194.stderr index b28868abdb..d8655f0146 100644 --- a/testsuite/tests/indexed-types/should_fail/T7194.stderr +++ b/testsuite/tests/indexed-types/should_fail/T7194.stderr @@ -1,13 +1,14 @@ -T7194.hs:18:35: - Couldn't match expected type ‘b0’ with actual type ‘F a’ - because type variable ‘a’ would escape its scope - This (rigid, skolem) type variable is bound by - the type signature for: g :: C (F a) => a -> Int - at T7194.hs:17:23-41 - In the expression: foo y - In the first argument of ‘length’, namely ‘[x, foo y]’ - Relevant bindings include - y :: a (bound at T7194.hs:18:20) - g :: a -> Int (bound at T7194.hs:18:18) - x :: b0 (bound at T7194.hs:17:9) +T7194.hs:18:35: error: + • Couldn't match expected type ‘b0’ with actual type ‘F a’ + because type variable ‘a’ would escape its scope + This (rigid, skolem) type variable is bound by + the type signature for: + g :: C (F a) => a -> Int + at T7194.hs:17:18-41 + • In the expression: foo y + In the first argument of ‘length’, namely ‘[x, foo y]’ + • Relevant bindings include + y :: a (bound at T7194.hs:18:20) + g :: a -> Int (bound at T7194.hs:18:18) + x :: b0 (bound at T7194.hs:17:9) diff --git a/testsuite/tests/indexed-types/should_fail/T9036.stderr b/testsuite/tests/indexed-types/should_fail/T9036.stderr index 2fdf9c6557..3bae5a6ef2 100644 --- a/testsuite/tests/indexed-types/should_fail/T9036.stderr +++ b/testsuite/tests/indexed-types/should_fail/T9036.stderr @@ -1,13 +1,11 @@ - -T9036.hs:17:17: - Couldn't match type ‘Curried t0 [t0]’ with ‘Curried t [t]’ - NB: ‘Curried’ is a type function, and may not be injective - The type variable ‘t0’ is ambiguous - Expected type: Maybe (GetMonad t after) -> Curried t [t] - Actual type: Maybe (GetMonad t0 after) -> Curried t0 [t0] - In the ambiguity check for the type signature for ‘simpleLogger’: - simpleLogger :: forall t after. - Maybe (GetMonad t after) -> Curried t [t] - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the type signature for ‘simpleLogger’: - simpleLogger :: Maybe (GetMonad t after) -> t `Curried` [t] +
+T9036.hs:17:17: error:
+ Couldn't match type ‘Curried t0 [t0]’ with ‘Curried t [t]’
+ NB: ‘Curried’ is a type function, and may not be injective
+ The type variable ‘t0’ is ambiguous
+ Expected type: Maybe (GetMonad t after) -> Curried t [t]
+ Actual type: Maybe (GetMonad t0 after) -> Curried t0 [t0]
+ In the ambiguity check for ‘simpleLogger’
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ In the type signature:
+ simpleLogger :: Maybe (GetMonad t after) -> t `Curried` [t]
diff --git a/testsuite/tests/indexed-types/should_fail/T9171.stderr b/testsuite/tests/indexed-types/should_fail/T9171.stderr index 28c1a2373f..9a618c50bf 100644 --- a/testsuite/tests/indexed-types/should_fail/T9171.stderr +++ b/testsuite/tests/indexed-types/should_fail/T9171.stderr @@ -1,22 +1,11 @@ - -T9171.hs:10:1: - Couldn't match expected type ‘GetParam Base (GetParam Base Int)’ - with actual type ‘GetParam Base (GetParam Base Int)’ - NB: ‘GetParam’ is a type function, and may not be injective - The kind variable ‘k0’ is ambiguous - Use -fprint-explicit-kinds to see the kind arguments - When checking that ‘foo’ has the inferred type - foo :: forall (k :: BOX). GetParam Base (GetParam Base Int) - Probable cause: the inferred type is ambiguous - -T9171.hs:10:20: - Couldn't match expected type ‘GetParam Base (GetParam Base Int)’ - with actual type ‘GetParam Base (GetParam Base Int)’ - NB: ‘GetParam’ is a type function, and may not be injective - The kind variable ‘k0’ is ambiguous - Use -fprint-explicit-kinds to see the kind arguments - In the ambiguity check for an expression type signature: - forall (k :: BOX). GetParam Base (GetParam Base Int) - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In an expression type signature: GetParam Base (GetParam Base Int) - In the expression: undefined :: GetParam Base (GetParam Base Int) +
+T9171.hs:10:20: error:
+ Couldn't match expected type ‘GetParam Base (GetParam Base Int)’
+ with actual type ‘GetParam Base (GetParam Base Int)’
+ NB: ‘GetParam’ is a type function, and may not be injective
+ The kind variable ‘k0’ is ambiguous
+ Use -fprint-explicit-kinds to see the kind arguments
+ In the ambiguity check for an expression type signature
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ In an expression type signature: GetParam Base (GetParam Base Int)
+ In the expression: undefined :: GetParam Base (GetParam Base Int)
diff --git a/testsuite/tests/indexed-types/should_fail/T9433.stderr b/testsuite/tests/indexed-types/should_fail/T9433.stderr index bd4ab42878..73dfe9e900 100644 --- a/testsuite/tests/indexed-types/should_fail/T9433.stderr +++ b/testsuite/tests/indexed-types/should_fail/T9433.stderr @@ -1,4 +1,4 @@ T9433.hs:14:6: error:
The type family ‘Id’ should have 1 argument, but has been given none
- In the type signature for ‘x’: x :: Map Id [Bool]
+ In the type signature: x :: Map Id [Bool]
diff --git a/testsuite/tests/indexed-types/should_fail/T9662.stderr b/testsuite/tests/indexed-types/should_fail/T9662.stderr index 3c800183a1..2d55f9dcea 100644 --- a/testsuite/tests/indexed-types/should_fail/T9662.stderr +++ b/testsuite/tests/indexed-types/should_fail/T9662.stderr @@ -1,84 +1,84 @@ T9662.hs:49:7: error: - Couldn't match type ‘k’ with ‘n’ + • Couldn't match type ‘k’ with ‘n’ ‘k’ is a rigid type variable bound by - the type signature for: - test :: Shape (((sh :. k) :. m) :. n) - -> Shape (((sh :. m) :. n) :. k) - at T9662.hs:44:9 + the type signature for: + test :: forall sh k m n. + Shape (((sh :. k) :. m) :. n) -> Shape (((sh :. m) :. n) :. k) + at T9662.hs:44:9 ‘n’ is a rigid type variable bound by - the type signature for: - test :: Shape (((sh :. k) :. m) :. n) - -> Shape (((sh :. m) :. n) :. k) - at T9662.hs:44:9 - Expected type: Exp (((sh :. m) :. n) :. k) - -> Exp (((sh :. k) :. m) :. n) - Actual type: Exp (((sh :. k) :. m) :. n) - -> Exp (((sh :. k) :. m) :. n) - In the second argument of ‘backpermute’, namely ‘id’ - In the expression: - backpermute - (modify - (atom :. atom :. atom :. atom) - (\ (sh :. k :. m :. n) -> (sh :. m :. n :. k))) - id - Relevant bindings include - test :: Shape (((sh :. k) :. m) :. n) - -> Shape (((sh :. m) :. n) :. k) - (bound at T9662.hs:45:1) + the type signature for: + test :: forall sh k m n. + Shape (((sh :. k) :. m) :. n) -> Shape (((sh :. m) :. n) :. k) + at T9662.hs:44:9 + Expected type: Exp (((sh :. m) :. n) :. k) + -> Exp (((sh :. k) :. m) :. n) + Actual type: Exp (((sh :. k) :. m) :. n) + -> Exp (((sh :. k) :. m) :. n) + • In the second argument of ‘backpermute’, namely ‘id’ + In the expression: + backpermute + (modify + (atom :. atom :. atom :. atom) + (\ (sh :. k :. m :. n) -> (sh :. m :. n :. k))) + id + • Relevant bindings include + test :: Shape (((sh :. k) :. m) :. n) + -> Shape (((sh :. m) :. n) :. k) + (bound at T9662.hs:45:1) T9662.hs:49:7: error: - Couldn't match type ‘m’ with ‘k’ + • Couldn't match type ‘m’ with ‘k’ ‘m’ is a rigid type variable bound by - the type signature for: - test :: Shape (((sh :. k) :. m) :. n) - -> Shape (((sh :. m) :. n) :. k) - at T9662.hs:44:9 + the type signature for: + test :: forall sh k m n. + Shape (((sh :. k) :. m) :. n) -> Shape (((sh :. m) :. n) :. k) + at T9662.hs:44:9 ‘k’ is a rigid type variable bound by - the type signature for: - test :: Shape (((sh :. k) :. m) :. n) - -> Shape (((sh :. m) :. n) :. k) - at T9662.hs:44:9 - Expected type: Exp (((sh :. m) :. n) :. k) - -> Exp (((sh :. k) :. m) :. n) - Actual type: Exp (((sh :. k) :. m) :. n) - -> Exp (((sh :. k) :. m) :. n) - In the second argument of ‘backpermute’, namely ‘id’ - In the expression: - backpermute - (modify - (atom :. atom :. atom :. atom) - (\ (sh :. k :. m :. n) -> (sh :. m :. n :. k))) - id - Relevant bindings include - test :: Shape (((sh :. k) :. m) :. n) - -> Shape (((sh :. m) :. n) :. k) - (bound at T9662.hs:45:1) + the type signature for: + test :: forall sh k m n. + Shape (((sh :. k) :. m) :. n) -> Shape (((sh :. m) :. n) :. k) + at T9662.hs:44:9 + Expected type: Exp (((sh :. m) :. n) :. k) + -> Exp (((sh :. k) :. m) :. n) + Actual type: Exp (((sh :. k) :. m) :. n) + -> Exp (((sh :. k) :. m) :. n) + • In the second argument of ‘backpermute’, namely ‘id’ + In the expression: + backpermute + (modify + (atom :. atom :. atom :. atom) + (\ (sh :. k :. m :. n) -> (sh :. m :. n :. k))) + id + • Relevant bindings include + test :: Shape (((sh :. k) :. m) :. n) + -> Shape (((sh :. m) :. n) :. k) + (bound at T9662.hs:45:1) T9662.hs:49:7: error: - Couldn't match type ‘n’ with ‘m’ + • Couldn't match type ‘n’ with ‘m’ ‘n’ is a rigid type variable bound by - the type signature for: - test :: Shape (((sh :. k) :. m) :. n) - -> Shape (((sh :. m) :. n) :. k) - at T9662.hs:44:9 + the type signature for: + test :: forall sh k m n. + Shape (((sh :. k) :. m) :. n) -> Shape (((sh :. m) :. n) :. k) + at T9662.hs:44:9 ‘m’ is a rigid type variable bound by - the type signature for: - test :: Shape (((sh :. k) :. m) :. n) - -> Shape (((sh :. m) :. n) :. k) - at T9662.hs:44:9 - Expected type: Exp (((sh :. m) :. n) :. k) - -> Exp (((sh :. k) :. m) :. n) - Actual type: Exp (((sh :. k) :. m) :. n) - -> Exp (((sh :. k) :. m) :. n) - In the second argument of ‘backpermute’, namely ‘id’ - In the expression: - backpermute - (modify - (atom :. atom :. atom :. atom) - (\ (sh :. k :. m :. n) -> (sh :. m :. n :. k))) - id - Relevant bindings include - test :: Shape (((sh :. k) :. m) :. n) - -> Shape (((sh :. m) :. n) :. k) - (bound at T9662.hs:45:1) + the type signature for: + test :: forall sh k m n. + Shape (((sh :. k) :. m) :. n) -> Shape (((sh :. m) :. n) :. k) + at T9662.hs:44:9 + Expected type: Exp (((sh :. m) :. n) :. k) + -> Exp (((sh :. k) :. m) :. n) + Actual type: Exp (((sh :. k) :. m) :. n) + -> Exp (((sh :. k) :. m) :. n) + • In the second argument of ‘backpermute’, namely ‘id’ + In the expression: + backpermute + (modify + (atom :. atom :. atom :. atom) + (\ (sh :. k :. m :. n) -> (sh :. m :. n :. k))) + id + • Relevant bindings include + test :: Shape (((sh :. k) :. m) :. n) + -> Shape (((sh :. m) :. n) :. k) + (bound at T9662.hs:45:1) diff --git a/testsuite/tests/module/mod98.stderr b/testsuite/tests/module/mod98.stderr index 0a6a23d124..86a970ccdf 100644 --- a/testsuite/tests/module/mod98.stderr +++ b/testsuite/tests/module/mod98.stderr @@ -1,4 +1,4 @@ - -mod98.hs:3:1: - Invalid type signature: M.x :: Char - Should be of form <variable> :: <type> +
+mod98.hs:3:1: error:
+ Invalid type signature: M.x :: ...
+ Should be of form <variable> :: <type>
diff --git a/testsuite/tests/monadfail/MonadFailErrors.stderr b/testsuite/tests/monadfail/MonadFailErrors.stderr index 8a478eecf3..84334b980b 100644 --- a/testsuite/tests/monadfail/MonadFailErrors.stderr +++ b/testsuite/tests/monadfail/MonadFailErrors.stderr @@ -6,7 +6,7 @@ MonadFailErrors.hs:16:5: error: from the context: Monad m bound by the type signature for: general :: Monad m => m a - at MonadFailErrors.hs:14:12-25 + at MonadFailErrors.hs:14:1-25 Possible fix: add (MonadFail m) to the context of the type signature for: diff --git a/testsuite/tests/monadfail/MonadFailWarnings.stderr b/testsuite/tests/monadfail/MonadFailWarnings.stderr index 94858c1945..3d05126623 100644 --- a/testsuite/tests/monadfail/MonadFailWarnings.stderr +++ b/testsuite/tests/monadfail/MonadFailWarnings.stderr @@ -1,60 +1,60 @@ MonadFailWarnings.hs:19:5: warning: - Could not deduce (MonadFail m) - arising from the failable pattern ‘Just x’ - (this will become an error a future GHC release) - from the context: Monad m - bound by the type signature for: - general :: Monad m => m a - at MonadFailWarnings.hs:17:12-25 - Possible fix: - add (MonadFail m) to the context of - the type signature for: - general :: Monad m => m a - In a stmt of a 'do' block: Just x <- undefined - In the expression: - do { Just x <- undefined; - undefined } - In an equation for ‘general’: - general - = do { Just x <- undefined; - undefined } + • Could not deduce (MonadFail m) + arising from the failable pattern ‘Just x’ + (this will become an error a future GHC release) + from the context: Monad m + bound by the type signature for: + general :: Monad m => m a + at MonadFailWarnings.hs:17:1-25 + Possible fix: + add (MonadFail m) to the context of + the type signature for: + general :: Monad m => m a + • In a stmt of a 'do' block: Just x <- undefined + In the expression: + do { Just x <- undefined; + undefined } + In an equation for ‘general’: + general + = do { Just x <- undefined; + undefined } MonadFailWarnings.hs:35:5: warning: - No instance for (MonadFail Identity) - arising from the failable pattern ‘Just x’ - (this will become an error a future GHC release) - In a stmt of a 'do' block: Just x <- undefined - In the expression: - do { Just x <- undefined; - undefined } - In an equation for ‘identity’: - identity - = do { Just x <- undefined; - undefined } + • No instance for (MonadFail Identity) + arising from the failable pattern ‘Just x’ + (this will become an error a future GHC release) + • In a stmt of a 'do' block: Just x <- undefined + In the expression: + do { Just x <- undefined; + undefined } + In an equation for ‘identity’: + identity + = do { Just x <- undefined; + undefined } MonadFailWarnings.hs:51:5: warning: - No instance for (MonadFail (ST s)) - arising from the failable pattern ‘Just x’ - (this will become an error a future GHC release) - In a stmt of a 'do' block: Just x <- undefined - In the expression: - do { Just x <- undefined; - undefined } - In an equation for ‘st’: - st - = do { Just x <- undefined; - undefined } + • No instance for (MonadFail (ST s)) + arising from the failable pattern ‘Just x’ + (this will become an error a future GHC release) + • In a stmt of a 'do' block: Just x <- undefined + In the expression: + do { Just x <- undefined; + undefined } + In an equation for ‘st’: + st + = do { Just x <- undefined; + undefined } MonadFailWarnings.hs:59:5: warning: - No instance for (MonadFail ((->) r)) - arising from the failable pattern ‘Just x’ - (this will become an error a future GHC release) - In a stmt of a 'do' block: Just x <- undefined - In the expression: - do { Just x <- undefined; - undefined } - In an equation for ‘reader’: - reader - = do { Just x <- undefined; - undefined } + • No instance for (MonadFail ((->) r)) + arising from the failable pattern ‘Just x’ + (this will become an error a future GHC release) + • In a stmt of a 'do' block: Just x <- undefined + In the expression: + do { Just x <- undefined; + undefined } + In an equation for ‘reader’: + reader + = do { Just x <- undefined; + undefined } diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr index 1631c6de6d..b9d3bba31b 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr @@ -26,6 +26,6 @@ overloadedlabelsfail01.hs:13:5: error: from the context: IsLabel "x" t bound by the type signature for: c :: IsLabel "x" t => t - at overloadedlabelsfail01.hs:12:6-23 + at overloadedlabelsfail01.hs:12:1-23 In the expression: #y In an equation for ‘c’: c = #y diff --git a/testsuite/tests/parser/should_fail/NoPatternSynonyms.stderr b/testsuite/tests/parser/should_fail/NoPatternSynonyms.stderr index b31ec8319e..ebb15492a1 100644 --- a/testsuite/tests/parser/should_fail/NoPatternSynonyms.stderr +++ b/testsuite/tests/parser/should_fail/NoPatternSynonyms.stderr @@ -1,4 +1,4 @@ - -NoPatternSynonyms.hs:3:1: error: - Invalid type signature: pattern P :: G Int - Perhaps you meant to use PatternSynonyms? +
+NoPatternSynonyms.hs:3:1: error:
+ Invalid type signature: pattern P :: ...
+ Perhaps you meant to use PatternSynonyms?
diff --git a/testsuite/tests/parser/should_fail/T3811.stderr b/testsuite/tests/parser/should_fail/T3811.stderr index afdead696e..e945f51e5e 100644 --- a/testsuite/tests/parser/should_fail/T3811.stderr +++ b/testsuite/tests/parser/should_fail/T3811.stderr @@ -1,4 +1,4 @@ - -T3811.hs:4:1: - Invalid type signature: f x :: Char - Should be of form <variable> :: <type> +
+T3811.hs:4:1: error:
+ Invalid type signature: f x :: ...
+ Should be of form <variable> :: <type>
diff --git a/testsuite/tests/parser/should_fail/T7848.stderr b/testsuite/tests/parser/should_fail/T7848.stderr index 902f303649..402dc642b0 100644 --- a/testsuite/tests/parser/should_fail/T7848.stderr +++ b/testsuite/tests/parser/should_fail/T7848.stderr @@ -1,43 +1,45 @@ T7848.hs:6:57: error: - Occurs check: cannot construct the infinite type: - t2 ~ t0 -> t -> t1 -> A -> A -> A -> A -> t2 - In the expression: y - In an equation for ‘x’: - x (+) ((&)@z) ((:&&) a b) (c :&& d) (e `A` f) (A g h) - = y - where - infixl 3 `y` - y _ = (&) - {-# INLINE (&) #-} - {-# SPECIALIZE (&) :: a #-} - (&) = x - Relevant bindings include - y :: forall t4. t4 -> t -> t1 -> A -> A -> A -> A -> t2 - (bound at T7848.hs:8:9) - (&) :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:11:9) - z :: t1 (bound at T7848.hs:6:12) - (&) :: t1 (bound at T7848.hs:6:8) - (+) :: t (bound at T7848.hs:6:3) - x :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:6:1) + • Occurs check: cannot construct the infinite type: + t2 ~ t0 -> t -> t1 -> A -> A -> A -> A -> t2 + • In the expression: y + In an equation for ‘x’: + x (+) ((&)@z) ((:&&) a b) (c :&& d) (e `A` f) (A g h) + = y + where + infixl 3 `y` + y _ = (&) + {-# INLINE (&) #-} + {-# SPECIALIZE (&) :: a #-} + (&) = x + • Relevant bindings include + y :: forall t4. t4 -> t -> t1 -> A -> A -> A -> A -> t2 + (bound at T7848.hs:8:9) + (&) :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:11:9) + z :: t1 (bound at T7848.hs:6:12) + (&) :: t1 (bound at T7848.hs:6:8) + (+) :: t (bound at T7848.hs:6:3) + x :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:6:1) T7848.hs:10:9: error: - Couldn't match expected type ‘t -> t1 -> A -> A -> A -> A -> t2’ - with actual type ‘a’ + • Couldn't match expected type ‘t -> t1 -> A -> A -> A -> A -> t2’ + with actual type ‘a’ ‘a’ is a rigid type variable bound by - the type signature for: (&) :: a at T7848.hs:10:9 - In the SPECIALISE pragma {-# SPECIALIZE (&) :: a #-} - In an equation for ‘x’: - x (+) ((&)@z) ((:&&) a b) (c :&& d) (e `A` f) (A g h) - = y - where - infixl 3 `y` - y _ = (&) - {-# INLINE (&) #-} - {-# SPECIALIZE (&) :: a #-} - (&) = x - Relevant bindings include - z :: t1 (bound at T7848.hs:6:12) - (&) :: t1 (bound at T7848.hs:6:8) - (+) :: t (bound at T7848.hs:6:3) - x :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:6:1) + the type signature for: + (&) :: forall a. a + at T7848.hs:10:9 + • In the SPECIALISE pragma {-# SPECIALIZE (&) :: a #-} + In an equation for ‘x’: + x (+) ((&)@z) ((:&&) a b) (c :&& d) (e `A` f) (A g h) + = y + where + infixl 3 `y` + y _ = (&) + {-# INLINE (&) #-} + {-# SPECIALIZE (&) :: a #-} + (&) = x + • Relevant bindings include + z :: t1 (bound at T7848.hs:6:12) + (&) :: t1 (bound at T7848.hs:6:8) + (+) :: t (bound at T7848.hs:6:3) + x :: t -> t1 -> A -> A -> A -> A -> t2 (bound at T7848.hs:6:1) diff --git a/testsuite/tests/parser/should_fail/readFail031.stderr b/testsuite/tests/parser/should_fail/readFail031.stderr index 628c8352f6..1ab3923256 100644 --- a/testsuite/tests/parser/should_fail/readFail031.stderr +++ b/testsuite/tests/parser/should_fail/readFail031.stderr @@ -1,4 +1,4 @@ - -readFail031.hs:4:3: - Invalid type signature: (:+) :: o -> o -> o - Should be of form <variable> :: <type> +
+readFail031.hs:4:3: error:
+ Invalid type signature: (:+) :: ...
+ Should be of form <variable> :: <type>
diff --git a/testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr b/testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr index 033dfab13d..7e40fd184b 100644 --- a/testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr +++ b/testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr @@ -1,5 +1,5 @@ TYPE SIGNATURES - bravo :: Integer + bravo :: forall t. Num t => t TYPE CONSTRUCTORS COERCION AXIOMS Dependent modules: [] diff --git a/testsuite/tests/partial-sigs/should_compile/ExprSigLocal.hs b/testsuite/tests/partial-sigs/should_compile/ExprSigLocal.hs new file mode 100644 index 0000000000..a15ff5f774 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ExprSigLocal.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE PartialTypeSignatures, RankNTypes #-} + +module ExprSigLocal where + +-- We expect this to compile fine, +-- reporting that '_' stands 'a' + +y :: forall b. b->b +y = ((\x -> x) :: forall a. a -> _) + +g :: forall a. a -> _ +g x = x diff --git a/testsuite/tests/partial-sigs/should_compile/ExprSigLocal.stderr b/testsuite/tests/partial-sigs/should_compile/ExprSigLocal.stderr new file mode 100644 index 0000000000..7e02028874 --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/ExprSigLocal.stderr @@ -0,0 +1,19 @@ + +ExprSigLocal.hs:9:35: warning: + • Found type wildcard ‘_’ standing for ‘a’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of <expression> :: a -> a at ExprSigLocal.hs:9:27 + • In an expression type signature: forall a. a -> _ + In the expression: ((\ x -> x) :: forall a. a -> _) + In an equation for ‘y’: y = ((\ x -> x) :: forall a. a -> _) + • Relevant bindings include + y :: b -> b (bound at ExprSigLocal.hs:9:1) + +ExprSigLocal.hs:11:21: warning: + • Found type wildcard ‘_’ standing for ‘a’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of g :: a -> a at ExprSigLocal.hs:11:13 + • In the type signature: + g :: forall a. a -> _ + • Relevant bindings include + g :: a -> a (bound at ExprSigLocal.hs:12:1) diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr index 763cd73cb5..965d492754 100644 --- a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr +++ b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr @@ -14,7 +14,7 @@ TYPE SIGNATURES < :: forall a. Ord a => a -> a -> Bool
<= :: forall a. Ord a => a -> a -> Bool
=<< ::
- forall a (m :: * -> *) b. Monad m => (a -> m b) -> m a -> m b
+ forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
== :: forall a. Eq a => a -> a -> Bool
> :: forall a. Ord a => a -> a -> Bool
>= :: forall a. Ord a => a -> a -> Bool
@@ -27,10 +27,10 @@ TYPE SIGNATURES acos :: forall a. Floating a => a -> a
acosh :: forall a. Floating a => a -> a
all ::
- forall a (t :: * -> *). Foldable t => (a -> Bool) -> t a -> Bool
+ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
and :: forall (t :: * -> *). Foldable t => t Bool -> Bool
any ::
- forall a (t :: * -> *). Foldable t => (a -> Bool) -> t a -> Bool
+ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
appendFile :: FilePath -> String -> IO ()
asTypeOf :: forall a. a -> a -> a
asin :: forall a. Floating a => a -> a
@@ -43,7 +43,7 @@ TYPE SIGNATURES compare :: forall a. Ord a => a -> a -> Ordering
concat :: forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concatMap ::
- forall a b (t :: * -> *). Foldable t => (a -> [b]) -> t a -> [b]
+ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
const :: forall a b. a -> b -> a
cos :: forall a. Floating a => a -> a
cosh :: forall a. Floating a => a -> a
@@ -117,11 +117,11 @@ TYPE SIGNATURES lookup :: forall a b. Eq a => a -> [(a, b)] -> Maybe b
map :: forall a b. (a -> b) -> [a] -> [b]
mapM ::
- forall (t :: * -> *) a (m :: * -> *) b.
+ forall (t :: * -> *) (m :: * -> *) a b.
(Monad m, Traversable t) =>
(a -> m b) -> t a -> m (t b)
mapM_ ::
- forall a (m :: * -> *) b (t :: * -> *).
+ forall (t :: * -> *) (m :: * -> *) a b.
(Monad m, Foldable t) =>
(a -> m b) -> t a -> m ()
max :: forall a. Ord a => a -> a -> a
@@ -135,7 +135,7 @@ TYPE SIGNATURES negate :: forall a. Num a => a -> a
not :: Bool -> Bool
notElem ::
- forall a (t :: * -> *). (Eq a, Foldable t) => a -> t a -> Bool
+ forall (t :: * -> *) a. (Eq a, Foldable t) => a -> t a -> Bool
null :: forall (t :: * -> *) a. Foldable t => t a -> Bool
odd :: forall a. Integral a => a -> Bool
or :: forall (t :: * -> *). Foldable t => t Bool -> Bool
diff --git a/testsuite/tests/partial-sigs/should_compile/SomethingShowable.hs b/testsuite/tests/partial-sigs/should_compile/SomethingShowable.hs index 338ae5cae8..393d1d12a4 100644 --- a/testsuite/tests/partial-sigs/should_compile/SomethingShowable.hs +++ b/testsuite/tests/partial-sigs/should_compile/SomethingShowable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PartialTypeSignatures, NamedWildCards #-} +{-# LANGUAGE FlexibleContexts, PartialTypeSignatures, NamedWildCards #-} module SomethingShowable where somethingShowable :: Show _x => _x -> _ diff --git a/testsuite/tests/partial-sigs/should_compile/SomethingShowable.stderr b/testsuite/tests/partial-sigs/should_compile/SomethingShowable.stderr index c087fda438..b0957a0b9b 100644 --- a/testsuite/tests/partial-sigs/should_compile/SomethingShowable.stderr +++ b/testsuite/tests/partial-sigs/should_compile/SomethingShowable.stderr @@ -1,7 +1,8 @@ TYPE SIGNATURES - somethingShowable :: Bool -> String + somethingShowable :: Show Bool => Bool -> String TYPE CONSTRUCTORS COERCION AXIOMS Dependent modules: [] Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0, integer-gmp-1.0.0.0] + diff --git a/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr index 1df0b889fd..333a78f97b 100644 --- a/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr +++ b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr @@ -1,82 +1,100 @@ -[1 of 2] Compiling Splices ( Splices.hs, Splices.o )
-[2 of 2] Compiling SplicesUsed ( SplicesUsed.hs, SplicesUsed.o )
-
-SplicesUsed.hs:7:16: warning:
- Found type wildcard ‘_’ standing for ‘Maybe Bool’
- In the type signature for:
- maybeBool :: _
-
-SplicesUsed.hs:8:15: warning:
- Found type wildcard ‘_a’ standing for ‘Maybe Bool’
- In an expression type signature: _a -> _a
- In the expression: id :: _a -> _a
- In the expression: (id :: _a -> _a) (Just True :: Maybe _)
- Relevant bindings include
- maybeBool :: Maybe Bool (bound at SplicesUsed.hs:8:1)
-
-SplicesUsed.hs:8:27: warning:
- Found type wildcard ‘_’ standing for ‘Bool’
- In an expression type signature: Maybe _
- In the first argument of ‘id :: _a -> _a’, namely
- ‘(Just True :: Maybe _)’
- In the expression: (id :: _a -> _a) (Just True :: Maybe _)
- Relevant bindings include
- maybeBool :: Maybe Bool (bound at SplicesUsed.hs:8:1)
-
-SplicesUsed.hs:10:17: warning:
- Found type wildcard ‘_’ standing for ‘(Char, a)’
- Where: ‘a’ is a rigid type variable bound by
- the inferred type of charA :: a -> (Char, a)
- at SplicesUsed.hs:10:10
- In the type signature for:
- charA :: a -> (_)
-
-SplicesUsed.hs:13:14: warning:
- Found type wildcard ‘_’ standing for ‘a -> Bool’
- Where: ‘a’ is a rigid type variable bound by
- the inferred type of filter' :: (a -> Bool) -> [a] -> [a]
- at SplicesUsed.hs:14:1
- In the type signature for:
- filter' :: _ -> _ -> _
-
-SplicesUsed.hs:13:14: warning:
- Found type wildcard ‘_’ standing for ‘[a]’
- Where: ‘a’ is a rigid type variable bound by
- the inferred type of filter' :: (a -> Bool) -> [a] -> [a]
- at SplicesUsed.hs:14:1
- In the type signature for:
- filter' :: _ -> _ -> _
-
-SplicesUsed.hs:13:14: warning:
- Found type wildcard ‘_’ standing for ‘[a]’
- Where: ‘a’ is a rigid type variable bound by
- the inferred type of filter' :: (a -> Bool) -> [a] -> [a]
- at SplicesUsed.hs:14:1
- In the type signature for:
- filter' :: _ -> _ -> _
-
-SplicesUsed.hs:16:3: warning:
- Found hole ‘_’ with inferred constraints: Eq a
- In the type signature for:
- foo :: _ => _
-
-SplicesUsed.hs:16:3: warning:
- Found type wildcard ‘_’ standing for ‘a -> a -> Bool’
- Where: ‘a’ is a rigid type variable bound by
- the inferred type of foo :: Eq a => a -> a -> Bool
- at SplicesUsed.hs:16:3
- In the type signature for:
- foo :: _ => _
-
-SplicesUsed.hs:18:3: warning:
- Found type wildcard ‘_a’ standing for ‘Bool’
- In the type signature for:
- bar :: _a -> _b -> (_a, _b)
-
-SplicesUsed.hs:18:3: warning:
- Found type wildcard ‘_b’ standing for ‘t’
- Where: ‘t’ is a rigid type variable bound by
- the inferred type of bar :: Bool -> t -> (Bool, t)
- at SplicesUsed.hs:18:3
- In the type signature for:
- bar :: _a -> _b -> (_a, _b)
+[1 of 2] Compiling Splices ( Splices.hs, Splices.o ) +[2 of 2] Compiling SplicesUsed ( SplicesUsed.hs, SplicesUsed.o ) + +SplicesUsed.hs:7:16: warning: + • Found type wildcard ‘_’ standing for ‘Maybe Bool’ + • In the type signature: + maybeBool :: _ + • Relevant bindings include + maybeBool :: Maybe Bool (bound at SplicesUsed.hs:8:1) + +SplicesUsed.hs:8:15: warning: + • Found type wildcard ‘_a’ standing for ‘t’ + Where: ‘t’ is a rigid type variable bound by + the inferred type of <expression> :: t -> t at SplicesUsed.hs:8:15 + • In an expression type signature: _a -> _a + In the expression: id :: _a -> _a + In the expression: (id :: _a -> _a) (Just True :: Maybe _) + • Relevant bindings include + maybeBool :: Maybe Bool (bound at SplicesUsed.hs:8:1) + +SplicesUsed.hs:8:27: warning: + • Found type wildcard ‘_’ standing for ‘Bool’ + • In an expression type signature: Maybe _ + In the first argument of ‘id :: _a -> _a’, namely + ‘(Just True :: Maybe _)’ + In the expression: (id :: _a -> _a) (Just True :: Maybe _) + • Relevant bindings include + maybeBool :: Maybe Bool (bound at SplicesUsed.hs:8:1) + +SplicesUsed.hs:10:17: warning: + • Found type wildcard ‘_’ standing for ‘(Char, a)’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of charA :: a -> (Char, a) + at SplicesUsed.hs:10:10 + • In the type signature: + charA :: a -> (_) + • Relevant bindings include + charA :: a -> (Char, a) (bound at SplicesUsed.hs:11:1) + +SplicesUsed.hs:13:14: warning: + • Found type wildcard ‘_’ standing for ‘a -> Bool’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of filter' :: (a -> Bool) -> [a] -> [a] + at SplicesUsed.hs:14:1 + • In the type signature: + filter' :: _ -> _ -> _ + • Relevant bindings include + filter' :: (a -> Bool) -> [a] -> [a] (bound at SplicesUsed.hs:14:1) + +SplicesUsed.hs:13:14: warning: + • Found type wildcard ‘_’ standing for ‘[a]’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of filter' :: (a -> Bool) -> [a] -> [a] + at SplicesUsed.hs:14:1 + • In the type signature: + filter' :: _ -> _ -> _ + • Relevant bindings include + filter' :: (a -> Bool) -> [a] -> [a] (bound at SplicesUsed.hs:14:1) + +SplicesUsed.hs:13:14: warning: + • Found type wildcard ‘_’ standing for ‘[a]’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of filter' :: (a -> Bool) -> [a] -> [a] + at SplicesUsed.hs:14:1 + • In the type signature: + filter' :: _ -> _ -> _ + • Relevant bindings include + filter' :: (a -> Bool) -> [a] -> [a] (bound at SplicesUsed.hs:14:1) + +SplicesUsed.hs:16:3: warning: + Found constraint wildcard ‘_’ standing for ‘Eq a’ + In the type signature: + foo :: _ => _ + +SplicesUsed.hs:16:3: warning: + • Found type wildcard ‘_’ standing for ‘a -> a -> Bool’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of foo :: Eq a => a -> a -> Bool + at SplicesUsed.hs:16:3 + • In the type signature: + foo :: _ => _ + • Relevant bindings include + foo :: a -> a -> Bool (bound at SplicesUsed.hs:16:3) + +SplicesUsed.hs:18:3: warning: + • Found type wildcard ‘_a’ standing for ‘Bool’ + • In the type signature: + bar :: _a -> _b -> (_a, _b) + • Relevant bindings include + bar :: Bool -> t -> (Bool, t) (bound at SplicesUsed.hs:18:3) + +SplicesUsed.hs:18:3: warning: + • Found type wildcard ‘_b’ standing for ‘t’ + Where: ‘t’ is a rigid type variable bound by + the inferred type of bar :: Bool -> t -> (Bool, t) + at SplicesUsed.hs:18:3 + • In the type signature: + bar :: _a -> _b -> (_a, _b) + • Relevant bindings include + bar :: Bool -> t -> (Bool, t) (bound at SplicesUsed.hs:18:3) diff --git a/testsuite/tests/partial-sigs/should_compile/T10403.hs b/testsuite/tests/partial-sigs/should_compile/T10403.hs index 97cda7ae2b..6610254805 100644 --- a/testsuite/tests/partial-sigs/should_compile/T10403.hs +++ b/testsuite/tests/partial-sigs/should_compile/T10403.hs @@ -17,6 +17,7 @@ h1 :: _ => _ h1 f b = (H . fmap (const ())) (fmap f b) h2 :: _ +-- MR applies -- h2 :: Functor m => (a -> b) -> m a -> H m h2 f b = (H . fmap (const ())) (fmap f b) diff --git a/testsuite/tests/partial-sigs/should_compile/T10403.stderr b/testsuite/tests/partial-sigs/should_compile/T10403.stderr index bfd5367bcd..1a71a3c803 100644 --- a/testsuite/tests/partial-sigs/should_compile/T10403.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T10403.stderr @@ -1,39 +1,80 @@ T10403.hs:15:7: warning: - Found hole ‘_’ with inferred constraints: Functor f - In the type signature for: + Found constraint wildcard ‘_’ standing for ‘Functor f’ + In the type signature: h1 :: _ => _ T10403.hs:15:12: warning: - Found type wildcard ‘_’ standing for ‘(a -> b) -> f a -> H f’ - Where: ‘b’ is a rigid type variable bound by + • Found type wildcard ‘_’ standing for ‘(a -> b) -> f a -> H f’ + Where: ‘b’ is a rigid type variable bound by the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f at T10403.hs:17:1 - ‘a’ is a rigid type variable bound by + ‘a’ is a rigid type variable bound by the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f at T10403.hs:17:1 - ‘f’ is a rigid type variable bound by + ‘f’ is a rigid type variable bound by the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f at T10403.hs:17:1 - In the type signature for: - h1 :: _ => _ + • In the type signature: + h1 :: _ => _ + • Relevant bindings include + h1 :: (a -> b) -> f a -> H f (bound at T10403.hs:17:1) T10403.hs:19:7: warning: - Found type wildcard ‘_’ standing for ‘(a -> b) -> f a -> H f’ - Where: ‘b’ is a rigid type variable bound by - the inferred type of h2 :: Functor f => (a -> b) -> f a -> H f - at T10403.hs:21:1 - ‘a’ is a rigid type variable bound by - the inferred type of h2 :: Functor f => (a -> b) -> f a -> H f - at T10403.hs:21:1 - ‘f’ is a rigid type variable bound by - the inferred type of h2 :: Functor f => (a -> b) -> f a -> H f - at T10403.hs:21:1 - In the type signature for: - h2 :: _ + • Found type wildcard ‘_’ standing for ‘(a -> b) -> f0 a -> H f0’ + Where: ‘b’ is a rigid type variable bound by + the inferred type of h2 :: (a -> b) -> f0 a -> H f0 + at T10403.hs:22:1 + ‘a’ is a rigid type variable bound by + the inferred type of h2 :: (a -> b) -> f0 a -> H f0 + at T10403.hs:22:1 + ‘f0’ is an ambiguous type variable + • In the type signature: + h2 :: _ + • Relevant bindings include + h2 :: (a -> b) -> f0 a -> H f0 (bound at T10403.hs:22:1) + +T10403.hs:22:15: warning: + • Ambiguous type variable ‘f0’ arising from a use of ‘fmap’ + prevents the constraint ‘(Functor f0)’ from being solved. + Relevant bindings include + b :: f0 a (bound at T10403.hs:22:6) + h2 :: (a -> b) -> f0 a -> H f0 (bound at T10403.hs:22:1) + Probable fix: use a type annotation to specify what ‘f0’ should be. + These potential instances exist: + instance Functor IO -- Defined in ‘GHC.Base’ + instance Functor (B t) -- Defined at T10403.hs:10:10 + instance Functor I -- Defined at T10403.hs:6:10 + ...plus four others + (use -fprint-potential-instances to see them all) + • In the second argument of ‘(.)’, namely ‘fmap (const ())’ + In the expression: H . fmap (const ()) + In the expression: (H . fmap (const ())) (fmap f b) + +T10403.hs:28:8: warning: + • Couldn't match type ‘f0’ with ‘B t’ + because type variable ‘t’ would escape its scope + This (rigid, skolem) type variable is bound by + the type signature for: + app2 :: H (B t) + at T10403.hs:27:1-15 + Expected type: H (B t) + Actual type: H f0 + • In the expression: h2 (H . I) (B ()) + In an equation for ‘app2’: app2 = h2 (H . I) (B ()) + • Relevant bindings include + app2 :: H (B t) (bound at T10403.hs:28:1) -T10403.hs:21:1: warning: - No instance for (Functor f) - When checking that ‘h2’ has the inferred type - h2 :: forall (f :: * -> *) b a. (a -> b) -> f a -> H f - Probable cause: the inferred type is ambiguous +T10403.hs:28:20: warning: + • Couldn't match type ‘f0’ with ‘B t’ + because type variable ‘t’ would escape its scope + This (rigid, skolem) type variable is bound by + the type signature for: + app2 :: H (B t) + at T10403.hs:27:1-15 + Expected type: f0 () + Actual type: B t () + • In the second argument of ‘h2’, namely ‘(B ())’ + In the expression: h2 (H . I) (B ()) + • Relevant bindings include + app2 :: H (B t) (bound at T10403.hs:28:1) diff --git a/testsuite/tests/partial-sigs/should_compile/T10438.stderr b/testsuite/tests/partial-sigs/should_compile/T10438.stderr index 2ae08675f2..f070b3b8a0 100644 --- a/testsuite/tests/partial-sigs/should_compile/T10438.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T10438.stderr @@ -1,27 +1,28 @@ -
-T10438.hs:7:22: warning:
- Found type wildcard ‘_’ standing for ‘t2’
- Where: ‘t2’ is a rigid type variable bound by
- the inferred type of g :: t2 -> t2 at T10438.hs:6:9
- In the type signature for:
- x :: _
- In an equation for ‘g’:
- g r
- = x
- where
- x :: _
- x = r
- In an equation for ‘foo’:
- foo f
- = g
- where
- g r
- = x
- where
- x :: _
- x = r
- Relevant bindings include
- r :: t2 (bound at T10438.hs:6:11)
- g :: t2 -> t2 (bound at T10438.hs:6:9)
- f :: t (bound at T10438.hs:5:5)
- foo :: t -> t1 -> t1 (bound at T10438.hs:5:1)
+ +T10438.hs:7:22: warning: + • Found type wildcard ‘_’ standing for ‘t2’ + Where: ‘t2’ is a rigid type variable bound by + the inferred type of g :: t2 -> t2 at T10438.hs:6:9 + • In the type signature: + x :: _ + In an equation for ‘g’: + g r + = x + where + x :: _ + x = r + In an equation for ‘foo’: + foo f + = g + where + g r + = x + where + x :: _ + x = r + • Relevant bindings include + x :: t2 (bound at T10438.hs:8:17) + r :: t2 (bound at T10438.hs:6:11) + g :: t2 -> t2 (bound at T10438.hs:6:9) + f :: t (bound at T10438.hs:5:5) + foo :: t -> t1 -> t1 (bound at T10438.hs:5:1) diff --git a/testsuite/tests/partial-sigs/should_compile/T10519.stderr b/testsuite/tests/partial-sigs/should_compile/T10519.stderr index de53da2d33..d34b06227a 100644 --- a/testsuite/tests/partial-sigs/should_compile/T10519.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T10519.stderr @@ -1,5 +1,5 @@ T10519.hs:5:18: warning:
- Found hole ‘_’ with inferred constraints: Eq a
- In the type signature for:
+ Found constraint wildcard ‘_’ standing for ‘Eq a’
+ In the type signature:
foo :: forall a. _ => a -> a -> Bool
diff --git a/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr b/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr index df7cbfcbac..def47612d3 100644 --- a/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr +++ b/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr @@ -1,53 +1,66 @@ -TYPE SIGNATURES
- bar :: forall t t1. t -> (t -> t1) -> t1
- foo :: forall a. (Show a, Enum a) => a -> String
-TYPE CONSTRUCTORS
-COERCION AXIOMS
-Dependent modules: []
-Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0,
- integer-gmp-1.0.0.0]
-
-WarningWildcardInstantiations.hs:5:14: warning:
- Found type wildcard ‘_a’ standing for ‘a’
- Where: ‘a’ is a rigid type variable bound by
- the inferred type of foo :: (Enum a, Show a) => a -> String
- at WarningWildcardInstantiations.hs:6:1
- In the type signature for:
- foo :: (Show _a, _) => _a -> _
-
-WarningWildcardInstantiations.hs:5:18: warning:
- Found hole ‘_’ with inferred constraints: Enum a
- In the type signature for:
- foo :: (Show _a, _) => _a -> _
-
-WarningWildcardInstantiations.hs:5:30: warning:
- Found type wildcard ‘_’ standing for ‘String’
- In the type signature for:
- foo :: (Show _a, _) => _a -> _
-
-WarningWildcardInstantiations.hs:8:8: warning:
- Found type wildcard ‘_’ standing for ‘t’
- Where: ‘t’ is a rigid type variable bound by
- the inferred type of bar :: t -> (t -> t1) -> t1
- at WarningWildcardInstantiations.hs:9:1
- In the type signature for:
- bar :: _ -> _ -> _
-
-WarningWildcardInstantiations.hs:8:13: warning:
- Found type wildcard ‘_’ standing for ‘t -> t1’
- Where: ‘t’ is a rigid type variable bound by
- the inferred type of bar :: t -> (t -> t1) -> t1
- at WarningWildcardInstantiations.hs:9:1
- ‘t1’ is a rigid type variable bound by
- the inferred type of bar :: t -> (t -> t1) -> t1
- at WarningWildcardInstantiations.hs:9:1
- In the type signature for:
- bar :: _ -> _ -> _
-
-WarningWildcardInstantiations.hs:8:18: warning:
- Found type wildcard ‘_’ standing for ‘t1’
- Where: ‘t1’ is a rigid type variable bound by
- the inferred type of bar :: t -> (t -> t1) -> t1
- at WarningWildcardInstantiations.hs:9:1
- In the type signature for:
- bar :: _ -> _ -> _
+TYPE SIGNATURES + bar :: forall t t1. t -> (t -> t1) -> t1 + foo :: forall a. (Show a, Enum a) => a -> String +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0, + integer-gmp-1.0.0.0] + +WarningWildcardInstantiations.hs:5:14: warning: + • Found type wildcard ‘_a’ standing for ‘a’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of foo :: (Enum a, Show a) => a -> String + at WarningWildcardInstantiations.hs:6:1 + • In the type signature: + foo :: (Show _a, _) => _a -> _ + • Relevant bindings include + foo :: a -> String (bound at WarningWildcardInstantiations.hs:6:1) + +WarningWildcardInstantiations.hs:5:18: warning: + Found constraint wildcard ‘_’ standing for ‘Enum a’ + In the type signature: + foo :: (Show _a, _) => _a -> _ + +WarningWildcardInstantiations.hs:5:30: warning: + • Found type wildcard ‘_’ standing for ‘String’ + • In the type signature: + foo :: (Show _a, _) => _a -> _ + • Relevant bindings include + foo :: a -> String (bound at WarningWildcardInstantiations.hs:6:1) + +WarningWildcardInstantiations.hs:8:8: warning: + • Found type wildcard ‘_’ standing for ‘t’ + Where: ‘t’ is a rigid type variable bound by + the inferred type of bar :: t -> (t -> t1) -> t1 + at WarningWildcardInstantiations.hs:9:1 + • In the type signature: + bar :: _ -> _ -> _ + • Relevant bindings include + bar :: t -> (t -> t1) -> t1 + (bound at WarningWildcardInstantiations.hs:9:1) + +WarningWildcardInstantiations.hs:8:13: warning: + • Found type wildcard ‘_’ standing for ‘t -> t1’ + Where: ‘t’ is a rigid type variable bound by + the inferred type of bar :: t -> (t -> t1) -> t1 + at WarningWildcardInstantiations.hs:9:1 + ‘t1’ is a rigid type variable bound by + the inferred type of bar :: t -> (t -> t1) -> t1 + at WarningWildcardInstantiations.hs:9:1 + • In the type signature: + bar :: _ -> _ -> _ + • Relevant bindings include + bar :: t -> (t -> t1) -> t1 + (bound at WarningWildcardInstantiations.hs:9:1) + +WarningWildcardInstantiations.hs:8:18: warning: + • Found type wildcard ‘_’ standing for ‘t1’ + Where: ‘t1’ is a rigid type variable bound by + the inferred type of bar :: t -> (t -> t1) -> t1 + at WarningWildcardInstantiations.hs:9:1 + • In the type signature: + bar :: _ -> _ -> _ + • Relevant bindings include + bar :: t -> (t -> t1) -> t1 + (bound at WarningWildcardInstantiations.hs:9:1) diff --git a/testsuite/tests/partial-sigs/should_compile/all.T b/testsuite/tests/partial-sigs/should_compile/all.T index e99a414b13..142d3318c8 100644 --- a/testsuite/tests/partial-sigs/should_compile/all.T +++ b/testsuite/tests/partial-sigs/should_compile/all.T @@ -56,3 +56,4 @@ test('T10403', normal, compile, ['']) test('T10438', normal, compile, ['']) test('T10519', normal, compile, ['']) test('T10463', normal, compile, ['']) +test('ExprSigLocal', normal, compile, ['']) diff --git a/testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.hs b/testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.hs index 0e101ff2c6..6adf8fc419 100644 --- a/testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.hs +++ b/testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.hs @@ -2,5 +2,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} module Defaulting1MROff where +-- Even without the MR, this signature forces monomorphism, +-- because of the partial signature with no '=>' alpha :: _ alpha = 3 diff --git a/testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.stderr b/testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.stderr index 43bd7b1938..6cc4f94d2f 100644 --- a/testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.stderr +++ b/testsuite/tests/partial-sigs/should_fail/Defaulting1MROff.stderr @@ -1,6 +1,7 @@ -
-Defaulting1MROff.hs:6:1: error:
- No instance for (Num t)
- When checking that ‘alpha’ has the inferred type
- alpha :: forall t. t
- Probable cause: the inferred type is ambiguous
+ +Defaulting1MROff.hs:7:10: warning: + • Found type wildcard ‘_’ standing for ‘Integer’ + • In the type signature: + alpha :: _ + • Relevant bindings include + alpha :: Integer (bound at Defaulting1MROff.hs:8:1) diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr index 5432eafc4e..f08e1807c0 100644 --- a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature.stderr @@ -1,6 +1,4 @@ - -ExtraConstraintsWildcardInExpressionSignature.hs:3:20: error: - Invalid partial type: _ => _ - An extra-constraints wild card is only allowed - in the top-level context - In an expression type signature +
+ExtraConstraintsWildcardInExpressionSignature.hs:3:20: error:
+ Extra-contraint wildcard ‘_’ not allowed
+ in an expression type signature
diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSignature.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSignature.stderr index 71b3132dc5..0e2a66a877 100644 --- a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSignature.stderr +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSignature.stderr @@ -1,6 +1,4 @@ - -ExtraConstraintsWildcardInPatternSignature.hs:4:11: error: - Invalid partial type: _ => _ - An extra-constraints wild card is only allowed - in the top-level context - In a pattern type-signature +
+ExtraConstraintsWildcardInPatternSignature.hs:4:11: error:
+ Extra-contraint wildcard ‘_’ not allowed
+ in a pattern type-signature
diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice2.hs b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice2.hs index 4f6822c7c4..801c37de36 100644 --- a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice2.hs +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice2.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, PartialTypeSignatures #-} module ExtraConstraintsWildcardInTypeSplice2 where import Language.Haskell.TH.Lib (wildCardT) diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice2.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice2.stderr index 30efa4d83f..05994d76f9 100644 --- a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice2.stderr +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSplice2.stderr @@ -1,4 +1,5 @@ - -ExtraConstraintsWildcardInTypeSplice2.hs:6:12: error: - Unexpected wild card: ‘_’ - In the type signature for ‘show'’: show' :: (_) => a -> String +
+ExtraConstraintsWildcardInTypeSplice2.hs:6:12: error:
+ Wildcard ‘_’ not allowed
+ in the spliced type ‘_’
+ In the untyped splice: $wildCardT
diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSpliceUsed.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSpliceUsed.stderr index c13fe94d89..31b90d9fc2 100644 --- a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSpliceUsed.stderr +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInTypeSpliceUsed.stderr @@ -1,8 +1,8 @@ -[1 of 2] Compiling ExtraConstraintsWildcardInTypeSplice ( ExtraConstraintsWildcardInTypeSplice.hs, ExtraConstraintsWildcardInTypeSplice.o ) -[2 of 2] Compiling ExtraConstraintsWildcardInTypeSpliceUsed ( ExtraConstraintsWildcardInTypeSpliceUsed.hs, ExtraConstraintsWildcardInTypeSpliceUsed.o ) - -ExtraConstraintsWildcardInTypeSpliceUsed.hs:7:9: error: - Invalid partial type: _ => _ - An extra-constraints wild card is not allowed in a type splice - In the spliced type _ => _ - In the untyped splice: $metaType +[1 of 2] Compiling ExtraConstraintsWildcardInTypeSplice ( ExtraConstraintsWildcardInTypeSplice.hs, ExtraConstraintsWildcardInTypeSplice.o )
+
+ExtraConstraintsWildcardInTypeSplice.hs:7:16: error:
+ Wildcard ‘_’ not allowed in a constraint
+ except as the last top-level constraint of a type signature
+ e.g f :: (Eq a, _) => blah
+ in a Template-Haskell quoted type
+ In the Template Haskell quotation [t| _ => _ |]
diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.stderr index a8ea30ecf7..3cd4150d02 100644 --- a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.stderr +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotEnabled.stderr @@ -1,6 +1,6 @@ ExtraConstraintsWildcardNotEnabled.hs:4:10: error:
- Found hole ‘_’ with inferred constraints: Show a
+ Found constraint wildcard ‘_’ standing for ‘Show a’
To use the inferred type, enable PartialTypeSignatures
- In the type signature for:
+ In the type signature:
show' :: _ => a -> String
diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotLast.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotLast.stderr index faf3ad1f84..3ffcb187ac 100644 --- a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotLast.stderr +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotLast.stderr @@ -1,6 +1,6 @@ - -ExtraConstraintsWildcardNotLast.hs:4:9: - Invalid partial type: (_, Eq a) => a -> a - An extra-constraints wild card must occur - at the end of the constraints - In the type signature for ‘foo’ +
+ExtraConstraintsWildcardNotLast.hs:4:9: error:
+ Wildcard ‘_’ not allowed in a constraint
+ except as the last top-level constraint of a type signature
+ e.g f :: (Eq a, _) => blah
+ in the type signature for ‘foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotPresent.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotPresent.stderr index 43d559cbf6..3072da9b7e 100644 --- a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotPresent.stderr +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardNotPresent.stderr @@ -1,6 +1,8 @@ -ExtraConstraintsWildcardNotPresent.hs:6:1: - No instance for (Show a) - When checking that ‘show'’ has the inferred type - show' :: forall a. a -> String - Probable cause: the inferred type is ambiguous +ExtraConstraintsWildcardNotPresent.hs:6:11: error: + No instance for (Show a) arising from a use of ‘show’ + Possible fix: + add (Show a) to the context of + the inferred type of show' :: a -> String + In the expression: show x + In an equation for ‘show'’: show' x = show x diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardTwice.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardTwice.stderr index 7110de0ea9..eb17e6d20b 100644 --- a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardTwice.stderr +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardTwice.stderr @@ -1,5 +1,6 @@ - -ExtraConstraintsWildcardTwice.hs:4:10: - Invalid partial type: (_, _) => a -> a - Only a single extra-constraints wild card is allowed - In the type signature for ‘foo’ +
+ExtraConstraintsWildcardTwice.hs:4:10: error:
+ Wildcard ‘_’ not allowed in a constraint
+ except as the last top-level constraint of a type signature
+ e.g f :: (Eq a, _) => blah
+ in the type signature for ‘foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr b/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr index 2bdc01e8ef..2df15443c9 100644 --- a/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr +++ b/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr @@ -1,15 +1,18 @@ -
-InstantiatedNamedWildcardsInConstraints.hs:4:14: error:
- Found type wildcard ‘_a’ standing for ‘b’
- Where: ‘b’ is a rigid type variable bound by
- the inferred type of foo :: (Enum b, Show b) => b -> (String, b)
- at InstantiatedNamedWildcardsInConstraints.hs:4:8
- To use the inferred type, enable PartialTypeSignatures
- In the type signature for:
- foo :: (Enum _a, _) => _a -> (String, b)
-
-InstantiatedNamedWildcardsInConstraints.hs:4:18: error:
- Found hole ‘_’ with inferred constraints: Show b
- To use the inferred type, enable PartialTypeSignatures
- In the type signature for:
- foo :: (Enum _a, _) => _a -> (String, b)
+ +InstantiatedNamedWildcardsInConstraints.hs:4:14: error: + • Found type wildcard ‘_a’ standing for ‘b’ + Where: ‘b’ is a rigid type variable bound by + the inferred type of foo :: (Enum b, Show b) => b -> (String, b) + at InstantiatedNamedWildcardsInConstraints.hs:4:8 + To use the inferred type, enable PartialTypeSignatures + • In the type signature: + foo :: (Enum _a, _) => _a -> (String, b) + • Relevant bindings include + foo :: b -> (String, b) + (bound at InstantiatedNamedWildcardsInConstraints.hs:5:1) + +InstantiatedNamedWildcardsInConstraints.hs:4:18: error: + Found constraint wildcard ‘_’ standing for ‘Show b’ + To use the inferred type, enable PartialTypeSignatures + In the type signature: + foo :: (Enum _a, _) => _a -> (String, b) diff --git a/testsuite/tests/partial-sigs/should_fail/NamedExtraConstraintsWildcard.stderr b/testsuite/tests/partial-sigs/should_fail/NamedExtraConstraintsWildcard.stderr index ca674c4a98..47e9b99135 100644 --- a/testsuite/tests/partial-sigs/should_fail/NamedExtraConstraintsWildcard.stderr +++ b/testsuite/tests/partial-sigs/should_fail/NamedExtraConstraintsWildcard.stderr @@ -1,5 +1,5 @@ - -NamedExtraConstraintsWildcard.hs:4:15: - Invalid partial type: (Eq a, _a) => a -> a - An extra-constraints wild card cannot be named - In the type signature for ‘foo’ +
+NamedExtraConstraintsWildcard.hs:4:15: error:
+ Named wildcard ‘_a’ not allowed as an extra-contraint
+ Use an anonymous wildcard instead
+ in the type signature for ‘foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardInDataFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_fail/NamedWildcardInDataFamilyInstanceLHS.stderr index f97cdc3f4d..e07751d2f4 100644 --- a/testsuite/tests/partial-sigs/should_fail/NamedWildcardInDataFamilyInstanceLHS.stderr +++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardInDataFamilyInstanceLHS.stderr @@ -1,4 +1,4 @@ - -NamedWildcardInDataFamilyInstanceLHS.hs:8:21: error: - Unexpected wild card: ‘_a’ - In the data type declaration for ‘Sing’ +
+NamedWildcardInDataFamilyInstanceLHS.hs:8:21: error:
+ Wildcard ‘_a’ not allowed
+ in a type pattern of family instance for ‘Sing’
diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeFamilyInstanceLHS.stderr index 550f6ceb2e..f56d972172 100644 --- a/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeFamilyInstanceLHS.stderr +++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeFamilyInstanceLHS.stderr @@ -1,4 +1,4 @@ - -NamedWildcardInTypeFamilyInstanceLHS.hs:5:5: error: - Unexpected wild card: ‘_t’ - In the declaration for type synonym ‘F’ +
+NamedWildcardInTypeFamilyInstanceLHS.hs:5:5: error:
+ Wildcard ‘_t’ not allowed
+ in a type pattern of family instance for ‘F’
diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeSplice.stderr b/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeSplice.stderr index 9071531a13..ba860445a3 100644 --- a/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeSplice.stderr +++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardInTypeSplice.stderr @@ -1,5 +1,10 @@ - -NamedWildcardInTypeSplice.hs:8:16: error: - Unexpected wild card: ‘_a’ - In a Template-Haskell quoted type - In the Template Haskell quotation [t| _a -> _a |] +
+NamedWildcardInTypeSplice.hs:8:16: error:
+ Wildcard ‘_a’ not allowed
+ in a Template-Haskell quoted type
+ In the Template Haskell quotation [t| _a -> _a |]
+
+NamedWildcardInTypeSplice.hs:8:22: error:
+ Wildcard ‘_a’ not allowed
+ in a Template-Haskell quoted type
+ In the Template Haskell quotation [t| _a -> _a |]
diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardsEnabled.stderr b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsEnabled.stderr index 6fa82994e4..805854a1f2 100644 --- a/testsuite/tests/partial-sigs/should_fail/NamedWildcardsEnabled.stderr +++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsEnabled.stderr @@ -1,12 +1,16 @@ -
-NamedWildcardsEnabled.hs:4:8: error:
- Found type wildcard ‘_a’ standing for ‘Bool’
- To use the inferred type, enable PartialTypeSignatures
- In the type signature for:
- foo :: _a -> _b
-
-NamedWildcardsEnabled.hs:4:14: error:
- Found type wildcard ‘_b’ standing for ‘Bool’
- To use the inferred type, enable PartialTypeSignatures
- In the type signature for:
- foo :: _a -> _b
+ +NamedWildcardsEnabled.hs:4:8: error: + • Found type wildcard ‘_a’ standing for ‘Bool’ + To use the inferred type, enable PartialTypeSignatures + • In the type signature: + foo :: _a -> _b + • Relevant bindings include + foo :: Bool -> Bool (bound at NamedWildcardsEnabled.hs:5:1) + +NamedWildcardsEnabled.hs:4:14: error: + • Found type wildcard ‘_b’ standing for ‘Bool’ + To use the inferred type, enable PartialTypeSignatures + • In the type signature: + foo :: _a -> _b + • Relevant bindings include + foo :: Bool -> Bool (bound at NamedWildcardsEnabled.hs:5:1) diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotEnabled.stderr b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotEnabled.stderr index 7029b0495c..0de48b4dcd 100644 --- a/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotEnabled.stderr +++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotEnabled.stderr @@ -1,21 +1,23 @@ -
-NamedWildcardsNotEnabled.hs:4:9:
- Couldn't match expected type ‘_b’ with actual type ‘Bool’
- ‘_b’ is a rigid type variable bound by
- the type signature for: foo :: _a -> _b
- at NamedWildcardsNotEnabled.hs:3:8
- In the expression: not x
- In an equation for ‘foo’: foo x = not x
- Relevant bindings include
- foo :: _a -> _b (bound at NamedWildcardsNotEnabled.hs:4:1)
-
-NamedWildcardsNotEnabled.hs:4:13:
- Couldn't match expected type ‘Bool’ with actual type ‘_a’
- ‘_a’ is a rigid type variable bound by
- the type signature for: foo :: _a -> _b
- at NamedWildcardsNotEnabled.hs:3:8
- In the first argument of ‘not’, namely ‘x’
- In the expression: not x
- Relevant bindings include
- x :: _a (bound at NamedWildcardsNotEnabled.hs:4:5)
- foo :: _a -> _b (bound at NamedWildcardsNotEnabled.hs:4:1)
+ +NamedWildcardsNotEnabled.hs:4:9: error: + • Couldn't match expected type ‘_b’ with actual type ‘Bool’ + ‘_b’ is a rigid type variable bound by + the type signature for: + foo :: forall _a _b. _a -> _b + at NamedWildcardsNotEnabled.hs:3:8 + • In the expression: not x + In an equation for ‘foo’: foo x = not x + • Relevant bindings include + foo :: _a -> _b (bound at NamedWildcardsNotEnabled.hs:4:1) + +NamedWildcardsNotEnabled.hs:4:13: error: + • Couldn't match expected type ‘Bool’ with actual type ‘_a’ + ‘_a’ is a rigid type variable bound by + the type signature for: + foo :: forall _a _b. _a -> _b + at NamedWildcardsNotEnabled.hs:3:8 + • In the first argument of ‘not’, namely ‘x’ + In the expression: not x + • Relevant bindings include + x :: _a (bound at NamedWildcardsNotEnabled.hs:4:5) + foo :: _a -> _b (bound at NamedWildcardsNotEnabled.hs:4:1) diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.hs b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.hs index 383115ef55..c2e57e71e3 100644 --- a/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.hs +++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PartialTypeSignatures, NamedWildCards #-} +{-# LANGUAGE PartialTypeSignatures, TypeFamilies, NamedWildCards, ConstraintKinds #-} module NamedWildcardsNotInMonotype where foo :: (Show _a, Eq _c, Eq _b) => _a -> _b -> String diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.stderr b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.stderr index 8e644374c8..59f5b93b59 100644 --- a/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.stderr +++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.stderr @@ -1,6 +1,12 @@ - -NamedWildcardsNotInMonotype.hs:4:21: - Invalid partial type: (Show _a, Eq _c, Eq _b) => _a -> _b -> String - The named wild card ‘_c’ is only allowed in the constraints - when it also occurs in the rest of the type - In the type signature for ‘foo’ +
+NamedWildcardsNotInMonotype.hs:5:1: error:
+ Could not deduce (Eq t0)
+ from the context: (Show a, Eq t, Eq a)
+ bound by the inferred type for ‘foo’:
+ (Show a, Eq t, Eq a) => a -> a -> String
+ at NamedWildcardsNotInMonotype.hs:5:1-33
+ The type variable ‘t0’ is ambiguous
+ In the ambiguity check for the inferred type for ‘foo’
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ When checking the inferred type
+ foo :: forall t a. (Show a, Eq t, Eq a) => a -> a -> String
diff --git a/testsuite/tests/partial-sigs/should_fail/NestedExtraConstraintsWildcard.stderr b/testsuite/tests/partial-sigs/should_fail/NestedExtraConstraintsWildcard.stderr index 784b282b60..dc5ff5b091 100644 --- a/testsuite/tests/partial-sigs/should_fail/NestedExtraConstraintsWildcard.stderr +++ b/testsuite/tests/partial-sigs/should_fail/NestedExtraConstraintsWildcard.stderr @@ -1,6 +1,6 @@ - -NestedExtraConstraintsWildcard.hs:4:23: - Invalid partial type: Bool -> (Eq a, _) => a - An extra-constraints wild card is only allowed - in the top-level context - In the type signature for ‘foo’ +
+NestedExtraConstraintsWildcard.hs:4:23: error:
+ Wildcard ‘_’ not allowed in a constraint
+ except as the last top-level constraint of a type signature
+ e.g f :: (Eq a, _) => blah
+ in the type signature for ‘foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/NestedNamedExtraConstraintsWildcard.stderr b/testsuite/tests/partial-sigs/should_fail/NestedNamedExtraConstraintsWildcard.stderr index 07e5839fde..afd5bdc24f 100644 --- a/testsuite/tests/partial-sigs/should_fail/NestedNamedExtraConstraintsWildcard.stderr +++ b/testsuite/tests/partial-sigs/should_fail/NestedNamedExtraConstraintsWildcard.stderr @@ -1,5 +1,4 @@ - -NestedNamedExtraConstraintsWildcard.hs:4:23: - Invalid partial type: Bool -> (Eq a, _a) => a - An extra-constraints wild card cannot be named - In the type signature for ‘foo’ +
+NestedNamedExtraConstraintsWildcard.hs:4:23: error:
+ Wildcard ‘_a’ not allowed in a constraint
+ in the type signature for ‘foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/PartialClassMethodSignature.stderr b/testsuite/tests/partial-sigs/should_fail/PartialClassMethodSignature.stderr index c3dcd7c71e..ebaf904a6f 100644 --- a/testsuite/tests/partial-sigs/should_fail/PartialClassMethodSignature.stderr +++ b/testsuite/tests/partial-sigs/should_fail/PartialClassMethodSignature.stderr @@ -1,5 +1,4 @@ - -PartialClassMethodSignature.hs:6:15: - Unexpected wild card: ‘_’ - In the type ‘a -> _’ - In the class declaration for ‘Foo’ +
+PartialClassMethodSignature.hs:6:15: error:
+ Wildcard ‘_’ not allowed
+ in a class method signature for ‘foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/PartialClassMethodSignature2.stderr b/testsuite/tests/partial-sigs/should_fail/PartialClassMethodSignature2.stderr index 1dfa192e3b..0f89e33e8b 100644 --- a/testsuite/tests/partial-sigs/should_fail/PartialClassMethodSignature2.stderr +++ b/testsuite/tests/partial-sigs/should_fail/PartialClassMethodSignature2.stderr @@ -1,5 +1,4 @@ - -PartialClassMethodSignature2.hs:5:17: - Unexpected wild card: ‘_’ - In the type ‘(Eq a, _) => a -> a’ - In the class declaration for ‘Foo’ +
+PartialClassMethodSignature2.hs:5:17: error:
+ Wildcard ‘_’ not allowed
+ in a class method signature for ‘foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/PartialTypeSignaturesDisabled.stderr b/testsuite/tests/partial-sigs/should_fail/PartialTypeSignaturesDisabled.stderr index fbff3580d0..025379a67d 100644 --- a/testsuite/tests/partial-sigs/should_fail/PartialTypeSignaturesDisabled.stderr +++ b/testsuite/tests/partial-sigs/should_fail/PartialTypeSignaturesDisabled.stderr @@ -1,12 +1,16 @@ -
-PartialTypeSignaturesDisabled.hs:4:8: error:
- Found type wildcard ‘_’ standing for ‘Bool’
- To use the inferred type, enable PartialTypeSignatures
- In the type signature for:
- foo :: _ -> _
-
-PartialTypeSignaturesDisabled.hs:4:13: error:
- Found type wildcard ‘_’ standing for ‘Bool’
- To use the inferred type, enable PartialTypeSignatures
- In the type signature for:
- foo :: _ -> _
+ +PartialTypeSignaturesDisabled.hs:4:8: error: + • Found type wildcard ‘_’ standing for ‘Bool’ + To use the inferred type, enable PartialTypeSignatures + • In the type signature: + foo :: _ -> _ + • Relevant bindings include + foo :: Bool -> Bool (bound at PartialTypeSignaturesDisabled.hs:5:1) + +PartialTypeSignaturesDisabled.hs:4:13: error: + • Found type wildcard ‘_’ standing for ‘Bool’ + To use the inferred type, enable PartialTypeSignatures + • In the type signature: + foo :: _ -> _ + • Relevant bindings include + foo :: Bool -> Bool (bound at PartialTypeSignaturesDisabled.hs:5:1) diff --git a/testsuite/tests/partial-sigs/should_fail/T10045.stderr b/testsuite/tests/partial-sigs/should_fail/T10045.stderr index 959bc0f52c..556201cc04 100644 --- a/testsuite/tests/partial-sigs/should_fail/T10045.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T10045.stderr @@ -1,24 +1,25 @@ T10045.hs:6:18: error: - Found type wildcard ‘_’ standing for ‘t1 -> Bool -> t2’ - Where: ‘t1’ is a rigid type variable bound by - the inferred type of copy :: t1 -> Bool -> t2 at T10045.hs:7:10 - ‘t2’ is a rigid type variable bound by - the inferred type of copy :: t1 -> Bool -> t2 at T10045.hs:7:10 - To use the inferred type, enable PartialTypeSignatures - In the type signature for: - copy :: _ - In the expression: - let + • Found type wildcard ‘_’ standing for ‘t1 -> Bool -> t2’ + Where: ‘t1’ is a rigid type variable bound by + the inferred type of copy :: t1 -> Bool -> t2 at T10045.hs:7:10 + ‘t2’ is a rigid type variable bound by + the inferred type of copy :: t1 -> Bool -> t2 at T10045.hs:7:10 + To use the inferred type, enable PartialTypeSignatures + • In the type signature: copy :: _ - copy w from = copy w True - in copy ws1 False - In an equation for ‘foo’: - foo (Meta ws1) - = let - copy :: _ - copy w from = copy w True - in copy ws1 False - Relevant bindings include - ws1 :: () (bound at T10045.hs:5:11) - foo :: Meta -> t (bound at T10045.hs:5:1) + In the expression: + let + copy :: _ + copy w from = copy w True + in copy ws1 False + In an equation for ‘foo’: + foo (Meta ws1) + = let + copy :: _ + copy w from = copy w True + in copy ws1 False + • Relevant bindings include + copy :: t1 -> Bool -> t2 (bound at T10045.hs:7:10) + ws1 :: () (bound at T10045.hs:5:11) + foo :: Meta -> t (bound at T10045.hs:5:1) diff --git a/testsuite/tests/partial-sigs/should_fail/T10615.stderr b/testsuite/tests/partial-sigs/should_fail/T10615.stderr index 3c2c2e9dab..842b2eb10a 100644 --- a/testsuite/tests/partial-sigs/should_fail/T10615.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T10615.stderr @@ -1,34 +1,36 @@ -
-T10615.hs:4:7: error:
- Found type wildcard ‘_’ standing for ‘a1’
- Where: ‘a1’ is an ambiguous type variable
- To use the inferred type, enable PartialTypeSignatures
- In the type signature for:
- f1 :: _ -> f
-
-T10615.hs:5:6: error:
- Couldn't match type ‘f’ with ‘b1 -> a1’
- ‘f’ is a rigid type variable bound by
- the inferred type of f1 :: a1 -> f at T10615.hs:4:7
- Expected type: a1 -> f
- Actual type: a1 -> b1 -> a1
- In the expression: const
- In an equation for ‘f1’: f1 = const
- Relevant bindings include f1 :: a1 -> f (bound at T10615.hs:5:1)
-
-T10615.hs:7:7: error:
- Found type wildcard ‘_’ standing for ‘a0’
- Where: ‘a0’ is an ambiguous type variable
- To use the inferred type, enable PartialTypeSignatures
- In the type signature for:
- f2 :: _ -> _f
-
-T10615.hs:8:6: error:
- Couldn't match type ‘_f’ with ‘b0 -> a0’
- ‘_f’ is a rigid type variable bound by
- the inferred type of f2 :: a0 -> _f at T10615.hs:7:7
- Expected type: a0 -> _f
- Actual type: a0 -> b0 -> a0
- In the expression: const
- In an equation for ‘f2’: f2 = const
- Relevant bindings include f2 :: a0 -> _f (bound at T10615.hs:8:1)
+ +T10615.hs:4:7: error: + • Found type wildcard ‘_’ standing for ‘a1’ + Where: ‘a1’ is an ambiguous type variable + To use the inferred type, enable PartialTypeSignatures + • In the type signature: + f1 :: _ -> f + • Relevant bindings include f1 :: a1 -> f (bound at T10615.hs:5:1) + +T10615.hs:5:6: error: + • Couldn't match type ‘f’ with ‘b1 -> a1’ + ‘f’ is a rigid type variable bound by + the inferred type of f1 :: a1 -> f at T10615.hs:4:7 + Expected type: a1 -> f + Actual type: a1 -> b1 -> a1 + • In the expression: const + In an equation for ‘f1’: f1 = const + • Relevant bindings include f1 :: a1 -> f (bound at T10615.hs:5:1) + +T10615.hs:7:7: error: + • Found type wildcard ‘_’ standing for ‘a0’ + Where: ‘a0’ is an ambiguous type variable + To use the inferred type, enable PartialTypeSignatures + • In the type signature: + f2 :: _ -> _f + • Relevant bindings include f2 :: a0 -> _f (bound at T10615.hs:8:1) + +T10615.hs:8:6: error: + • Couldn't match type ‘_f’ with ‘b0 -> a0’ + ‘_f’ is a rigid type variable bound by + the inferred type of f2 :: a0 -> _f at T10615.hs:7:7 + Expected type: a0 -> _f + Actual type: a0 -> b0 -> a0 + • In the expression: const + In an equation for ‘f2’: f2 = const + • Relevant bindings include f2 :: a0 -> _f (bound at T10615.hs:8:1) diff --git a/testsuite/tests/partial-sigs/should_fail/T10999.hs b/testsuite/tests/partial-sigs/should_fail/T10999.hs index 07d86ffe96..4a46a96d8b 100644 --- a/testsuite/tests/partial-sigs/should_fail/T10999.hs +++ b/testsuite/tests/partial-sigs/should_fail/T10999.hs @@ -2,7 +2,7 @@ module T10999 where import qualified Data.Set as Set -f :: () -> _ +f :: _ => () -> _ f _ = Set.fromList undefined g = map fst $ Set.toList $ f () diff --git a/testsuite/tests/partial-sigs/should_fail/T10999.stderr b/testsuite/tests/partial-sigs/should_fail/T10999.stderr index 2bf060b0aa..c74719addf 100644 --- a/testsuite/tests/partial-sigs/should_fail/T10999.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T10999.stderr @@ -1,14 +1,16 @@ -T10999.hs:5:12: error: - Found type wildcard ‘_’ standing for ‘Set.Set a’ - Where: ‘a’ is a rigid type variable bound by - the inferred type of f :: Ord a => () -> Set.Set a at T10999.hs:6:1 +T10999.hs:5:6: error: + Found constraint wildcard ‘_’ standing for ‘Ord a’ To use the inferred type, enable PartialTypeSignatures - In the type signature for: - f :: () -> _ + In the type signature: + f :: _ => () -> _ -T10999.hs:6:1: error: - No instance for (Ord a) - When checking that ‘f’ has the inferred type - f :: forall a. () -> Set.Set a - Probable cause: the inferred type is ambiguous +T10999.hs:5:17: error: + • Found type wildcard ‘_’ standing for ‘Set.Set a’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of f :: Ord a => () -> Set.Set a at T10999.hs:6:1 + To use the inferred type, enable PartialTypeSignatures + • In the type signature: + f :: _ => () -> _ + • Relevant bindings include + f :: () -> Set.Set a (bound at T10999.hs:6:1) diff --git a/testsuite/tests/partial-sigs/should_fail/TidyClash.stderr b/testsuite/tests/partial-sigs/should_fail/TidyClash.stderr index 795789185e..0c3d1549db 100644 --- a/testsuite/tests/partial-sigs/should_fail/TidyClash.stderr +++ b/testsuite/tests/partial-sigs/should_fail/TidyClash.stderr @@ -1,16 +1,20 @@ -
-TidyClash.hs:8:19: error:
- Found type wildcard ‘_’ standing for ‘t’
- Where: ‘t’ is a rigid type variable bound by
- the inferred type of bar :: w_ -> (w_, t -> t1) at TidyClash.hs:9:1
- To use the inferred type, enable PartialTypeSignatures
- In the type signature for:
- bar :: w_ -> (w_, _ -> _)
-
-TidyClash.hs:8:24: error:
- Found type wildcard ‘_’ standing for ‘t1’
- Where: ‘t1’ is a rigid type variable bound by
- the inferred type of bar :: w_ -> (w_, t -> t1) at TidyClash.hs:9:1
- To use the inferred type, enable PartialTypeSignatures
- In the type signature for:
- bar :: w_ -> (w_, _ -> _)
+ +TidyClash.hs:8:19: error: + • Found type wildcard ‘_’ standing for ‘t’ + Where: ‘t’ is a rigid type variable bound by + the inferred type of bar :: w_ -> (w_, t -> t1) at TidyClash.hs:9:1 + To use the inferred type, enable PartialTypeSignatures + • In the type signature: + bar :: w_ -> (w_, _ -> _) + • Relevant bindings include + bar :: w_ -> (w_, t -> t1) (bound at TidyClash.hs:9:1) + +TidyClash.hs:8:24: error: + • Found type wildcard ‘_’ standing for ‘t1’ + Where: ‘t1’ is a rigid type variable bound by + the inferred type of bar :: w_ -> (w_, t -> t1) at TidyClash.hs:9:1 + To use the inferred type, enable PartialTypeSignatures + • In the type signature: + bar :: w_ -> (w_, _ -> _) + • Relevant bindings include + bar :: w_ -> (w_, t -> t1) (bound at TidyClash.hs:9:1) diff --git a/testsuite/tests/partial-sigs/should_fail/Trac10045.hs b/testsuite/tests/partial-sigs/should_fail/Trac10045.hs deleted file mode 100644 index e7c07470aa..0000000000 --- a/testsuite/tests/partial-sigs/should_fail/Trac10045.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Trac10045 where - -newtype Meta = Meta () - -foo (Meta ws1) = - let copy :: _ - copy w from = copy w 1 - in copy ws1 1 diff --git a/testsuite/tests/partial-sigs/should_fail/Trac10045.stderr b/testsuite/tests/partial-sigs/should_fail/Trac10045.stderr deleted file mode 100644 index 045423ca0c..0000000000 --- a/testsuite/tests/partial-sigs/should_fail/Trac10045.stderr +++ /dev/null @@ -1,46 +0,0 @@ -
-Trac10045.hs:6:17: error:
- Found type wildcard ‘_’ standing for ‘t1 -> a -> t2’
- Where: ‘t1’ is a rigid type variable bound by
- the inferred type of copy :: Num a => t1 -> a -> t2
- at Trac10045.hs:7:9
- ‘a’ is a rigid type variable bound by
- the inferred type of copy :: Num a => t1 -> a -> t2
- at Trac10045.hs:7:9
- ‘t2’ is a rigid type variable bound by
- the inferred type of copy :: Num a => t1 -> a -> t2
- at Trac10045.hs:7:9
- To use the inferred type, enable PartialTypeSignatures
- In the type signature for:
- copy :: _
- In the expression:
- let
- copy :: _
- copy w from = copy w 1
- in copy ws1 1
- In an equation for ‘foo’:
- foo (Meta ws1)
- = let
- copy :: _
- copy w from = copy w 1
- in copy ws1 1
- Relevant bindings include
- ws1 :: () (bound at Trac10045.hs:5:11)
- foo :: Meta -> t (bound at Trac10045.hs:5:1)
-
-Trac10045.hs:7:9: error:
- No instance for (Num a)
- When checking that ‘copy’ has the inferred type
- copy :: forall t t1 a. t -> a -> t1
- Probable cause: the inferred type is ambiguous
- In the expression:
- let
- copy :: _
- copy w from = copy w 1
- in copy ws1 1
- In an equation for ‘foo’:
- foo (Meta ws1)
- = let
- copy :: _
- copy w from = copy w 1
- in copy ws1 1
diff --git a/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard1.stderr b/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard1.stderr index cb3a6a99d3..1176d4e510 100644 --- a/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard1.stderr +++ b/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard1.stderr @@ -1,5 +1,6 @@ - -UnnamedConstraintWildcard1.hs:4:13: - Invalid partial type: Show _ => a -> String - Anonymous wild cards are not allowed in constraints - In the type signature for ‘foo’ +
+UnnamedConstraintWildcard1.hs:4:13: error:
+ Wildcard ‘_’ not allowed in a constraint
+ except as the last top-level constraint of a type signature
+ e.g f :: (Eq a, _) => blah
+ in the type signature for ‘foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard2.stderr b/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard2.stderr index 6af7534356..3e01a2e760 100644 --- a/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard2.stderr +++ b/testsuite/tests/partial-sigs/should_fail/UnnamedConstraintWildcard2.stderr @@ -1,5 +1,6 @@ - -UnnamedConstraintWildcard2.hs:4:8: - Invalid partial type: _ a => a -> String - Anonymous wild cards are not allowed in constraints - In the type signature for ‘foo’ +
+UnnamedConstraintWildcard2.hs:4:8: error:
+ Wildcard ‘_’ not allowed in a constraint
+ except as the last top-level constraint of a type signature
+ e.g f :: (Eq a, _) => blah
+ in the type signature for ‘foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInADT1.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInADT1.stderr index 851767ad05..d5e7c72298 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInADT1.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInADT1.stderr @@ -1,6 +1,4 @@ - -WildcardInADT1.hs:4:26: - Unexpected wild card: ‘_’ - In the type ‘Either _ a’ - In the definition of data constructor ‘Foo’ - In the data declaration for ‘Foo’ +
+WildcardInADT1.hs:4:26: error:
+ Wildcard ‘_’ not allowed
+ in the definition of data constructor ‘Foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInADT2.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInADT2.stderr index e96d385f73..ec1ddf7189 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInADT2.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInADT2.stderr @@ -1,6 +1,4 @@ - -WildcardInADT2.hs:4:34: - Unexpected wild card: ‘_’ - In the type ‘Either _ a’ - In the definition of data constructor ‘Foo’ - In the data declaration for ‘Foo’ +
+WildcardInADT2.hs:4:34: error:
+ Wildcard ‘_’ not allowed
+ in the definition of data constructor ‘Foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInADT3.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInADT3.stderr index 1c504f6d39..26a3f68316 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInADT3.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInADT3.stderr @@ -1,6 +1,4 @@ - -WildcardInADT3.hs:4:27: - Unexpected wild card: ‘_’ - In the type ‘_ => a’ - In the definition of data constructor ‘Foo’ - In the data declaration for ‘Foo’ +
+WildcardInADT3.hs:4:27: error:
+ Wildcard ‘_’ not allowed
+ in the definition of data constructor ‘Foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext1.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext1.stderr index 419c63e608..02bcdfc504 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext1.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext1.stderr @@ -1,7 +1,7 @@ - -WildcardInADTContext1.hs:1:37: Warning: - -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. - -WildcardInADTContext1.hs:4:13: - Unexpected wild card: ‘_’ - In the data declaration for ‘Foo’ +
+WildcardInADTContext1.hs:1:37: warning:
+ -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.
+
+WildcardInADTContext1.hs:4:13: error:
+ Wildcard ‘_’ not allowed
+ in the data type declaration for ‘Foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext2.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext2.stderr index 20820848b9..ea145785e6 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext2.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInADTContext2.stderr @@ -1,7 +1,7 @@ - -WildcardInADTContext2.hs:1:53: Warning: - -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. - -WildcardInADTContext2.hs:4:10: - Unexpected wild card: ‘_a’ - In the data type declaration for ‘Foo’ +
+WildcardInADTContext2.hs:1:53: warning:
+ -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.
+
+WildcardInADTContext2.hs:4:10: error:
+ Wildcard ‘_a’ not allowed
+ in the data type declaration for ‘Foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInDefault.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInDefault.stderr index e4c2b1ac68..a02f8a6144 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInDefault.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInDefault.stderr @@ -1,5 +1,4 @@ - -WildcardInDefault.hs:4:10: - Unexpected wild card: ‘_’ - In a type in a `default' declaration: _ - When checking the types in a default declaration +
+WildcardInDefault.hs:4:10: error:
+ Wildcard ‘_’ not allowed
+ in a `default' declaration
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInDefaultSignature.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInDefaultSignature.stderr index 92e7c8fa95..0b15bd05fe 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInDefaultSignature.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInDefaultSignature.stderr @@ -1,5 +1,4 @@ - -WildcardInDefaultSignature.hs:7:16: - Unexpected wild card: ‘_’ - In the type ‘_’ - In the class declaration for ‘C’ +
+WildcardInDefaultSignature.hs:7:16: error:
+ Wildcard ‘_’ not allowed
+ in a class method signature for ‘f’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInDeriving.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInDeriving.stderr index 6c3f76ddff..6387f2a473 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInDeriving.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInDeriving.stderr @@ -1,4 +1,4 @@ - -WildcardInDeriving.hs:5:22: - Unexpected wild card: ‘_’ - In the data declaration for ‘Foo’ +
+WildcardInDeriving.hs:5:22: error:
+ Wildcard ‘_’ not allowed
+ in the data type declaration for ‘Foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInForeignExport.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInForeignExport.stderr index 00cdfa0282..812599b7c6 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInForeignExport.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInForeignExport.stderr @@ -1,6 +1,4 @@ - -WildcardInForeignExport.hs:6:37: - Unexpected wild card: ‘_’ - In the foreign declaration for ‘foo’: foo :: CInt -> _ - When checking declaration: - foreign export ccall "foo" foo :: CInt -> _ +
+WildcardInForeignExport.hs:6:37: error:
+ Wildcard ‘_’ not allowed
+ in the foreign declaration for ‘foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInForeignImport.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInForeignImport.stderr index 5930e338bf..27f877a445 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInForeignImport.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInForeignImport.stderr @@ -1,6 +1,4 @@ - -WildcardInForeignImport.hs:6:48: - Unexpected wild card: ‘_’ - In the foreign declaration for ‘c_sin’: c_sin :: CDouble -> _ - When checking declaration: - foreign import ccall safe "static sin" c_sin :: CDouble -> _ +
+WildcardInForeignImport.hs:6:48: error:
+ Wildcard ‘_’ not allowed
+ in the foreign declaration for ‘c_sin’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInGADT1.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInGADT1.stderr index f3a07de5bc..eb5e8414ee 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInGADT1.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInGADT1.stderr @@ -1,6 +1,4 @@ - -WildcardInGADT1.hs:5:19: - Unexpected wild card: ‘_’ - In the type ‘Either a _’ - In the definition of data constructor ‘Foo’ - In the data declaration for ‘Foo’ +
+WildcardInGADT1.hs:5:19: error:
+ Wildcard ‘_’ not allowed
+ in the definition of data constructor ‘Foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInGADT2.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInGADT2.stderr index d1839072fb..e338ae454f 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInGADT2.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInGADT2.stderr @@ -1,5 +1,4 @@ - -WildcardInGADT2.hs:5:17: - Unexpected wild card: ‘_’ - In the definition of data constructor ‘Foo’ - In the data declaration for ‘Foo’ +
+WildcardInGADT2.hs:5:17: error:
+ Wildcard ‘_’ not allowed
+ in the definition of data constructor ‘Foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceHead.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceHead.stderr index d85fd4d6ea..1bfeca73c3 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceHead.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceHead.stderr @@ -1,4 +1,4 @@ - -WildcardInInstanceHead.hs:7:14: - Unexpected wild card: ‘_’ - In the instance declaration for ‘Foo _’ +
+WildcardInInstanceHead.hs:7:14: error:
+ Wildcard ‘_’ not allowed
+ in an instance declaration for ‘Foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceSig.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceSig.stderr index 8e697bb322..e8e5e246f7 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceSig.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInInstanceSig.stderr @@ -1,5 +1,4 @@ WildcardInInstanceSig.hs:5:13: error:
- Unexpected wild card: ‘_’
- In the type signature for ‘negate’: negate :: _
- In the instance declaration for ‘Num Bool’
+ Wildcard ‘_’ not allowed
+ in a class method signature for ‘negate’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInNewtype.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInNewtype.stderr index a5f236cbff..b8d28fe528 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInNewtype.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInNewtype.stderr @@ -1,6 +1,4 @@ - -WildcardInNewtype.hs:7:29: - Unexpected wild card: ‘_’ - In the type ‘Either _ a’ - In the definition of data constructor ‘Foo’ - In the newtype declaration for ‘Foo’ +
+WildcardInNewtype.hs:7:29: error:
+ Wildcard ‘_’ not allowed
+ in the definition of data constructor ‘Foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInPatSynSig.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInPatSynSig.stderr index 7dd2a20a77..dbe95a88d3 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInPatSynSig.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInPatSynSig.stderr @@ -1,5 +1,4 @@ WildcardInPatSynSig.hs:4:37: error:
- Unexpected wild card: ‘_’
- In the type signature for pattern synonym ‘Single’:
- Single :: _ -> [a]
+ Wildcard ‘_’ not allowed
+ in a pattern synonym signature for ‘Single’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInStandaloneDeriving.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInStandaloneDeriving.stderr index d5b3dd1c2d..cbd06fdbcb 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInStandaloneDeriving.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInStandaloneDeriving.stderr @@ -1,2 +1,6 @@ - -WildcardInStandaloneDeriving.hs:4:19: Malformed instance: _ +
+WildcardInStandaloneDeriving.hs:4:19: error: Malformed instance: _
+
+WildcardInStandaloneDeriving.hs:4:19: error:
+ Wildcard ‘_’ not allowed
+ in In a deriving declaration
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceRHS.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceRHS.stderr index 46ca25b7f6..ae394f8a1d 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceRHS.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeFamilyInstanceRHS.stderr @@ -1,6 +1,4 @@ - -WildcardInTypeFamilyInstanceRHS.hs:8:25: - Unexpected wild card: ‘_’ - In the type ‘Maybe _’ - In the type instance declaration for ‘Dual’ - In the instance declaration for ‘Foo Int’ +
+WildcardInTypeFamilyInstanceRHS.hs:8:25: error:
+ Wildcard ‘_’ not allowed
+ in the declaration for type synonym ‘Dual’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymRHS.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymRHS.stderr index 929980e188..2ef322ff69 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymRHS.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInTypeSynonymRHS.stderr @@ -1,5 +1,4 @@ - -WildcardInTypeSynonymRHS.hs:4:18: - Unexpected wild card: ‘_’ - In the type ‘Maybe _’ - In the type declaration for ‘Foo’ +
+WildcardInTypeSynonymRHS.hs:4:18: error:
+ Wildcard ‘_’ not allowed
+ in the declaration for type synonym ‘Foo’
diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr index d0d7dff480..ac44a19e4b 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr @@ -1,51 +1,64 @@ -
-WildcardInstantiations.hs:5:14: error:
- Found type wildcard ‘_a’ standing for ‘a’
- Where: ‘a’ is a rigid type variable bound by
- the inferred type of foo :: (Enum a, Show a) => a -> String
- at WildcardInstantiations.hs:6:1
- To use the inferred type, enable PartialTypeSignatures
- In the type signature for:
- foo :: (Show _a, _) => _a -> _
-
-WildcardInstantiations.hs:5:18: error:
- Found hole ‘_’ with inferred constraints: Enum a
- To use the inferred type, enable PartialTypeSignatures
- In the type signature for:
- foo :: (Show _a, _) => _a -> _
-
-WildcardInstantiations.hs:5:30: error:
- Found type wildcard ‘_’ standing for ‘String’
- To use the inferred type, enable PartialTypeSignatures
- In the type signature for:
- foo :: (Show _a, _) => _a -> _
-
-WildcardInstantiations.hs:8:8: error:
- Found type wildcard ‘_’ standing for ‘t’
- Where: ‘t’ is a rigid type variable bound by
- the inferred type of bar :: t -> (t -> t1) -> t1
- at WildcardInstantiations.hs:9:1
- To use the inferred type, enable PartialTypeSignatures
- In the type signature for:
- bar :: _ -> _ -> _
-
-WildcardInstantiations.hs:8:13: error:
- Found type wildcard ‘_’ standing for ‘t -> t1’
- Where: ‘t’ is a rigid type variable bound by
- the inferred type of bar :: t -> (t -> t1) -> t1
- at WildcardInstantiations.hs:9:1
- ‘t1’ is a rigid type variable bound by
- the inferred type of bar :: t -> (t -> t1) -> t1
- at WildcardInstantiations.hs:9:1
- To use the inferred type, enable PartialTypeSignatures
- In the type signature for:
- bar :: _ -> _ -> _
-
-WildcardInstantiations.hs:8:18: error:
- Found type wildcard ‘_’ standing for ‘t1’
- Where: ‘t1’ is a rigid type variable bound by
- the inferred type of bar :: t -> (t -> t1) -> t1
- at WildcardInstantiations.hs:9:1
- To use the inferred type, enable PartialTypeSignatures
- In the type signature for:
- bar :: _ -> _ -> _
+ +WildcardInstantiations.hs:5:14: error: + • Found type wildcard ‘_a’ standing for ‘a’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of foo :: (Enum a, Show a) => a -> String + at WildcardInstantiations.hs:6:1 + To use the inferred type, enable PartialTypeSignatures + • In the type signature: + foo :: (Show _a, _) => _a -> _ + • Relevant bindings include + foo :: a -> String (bound at WildcardInstantiations.hs:6:1) + +WildcardInstantiations.hs:5:18: error: + Found constraint wildcard ‘_’ standing for ‘Enum a’ + To use the inferred type, enable PartialTypeSignatures + In the type signature: + foo :: (Show _a, _) => _a -> _ + +WildcardInstantiations.hs:5:30: error: + • Found type wildcard ‘_’ standing for ‘String’ + To use the inferred type, enable PartialTypeSignatures + • In the type signature: + foo :: (Show _a, _) => _a -> _ + • Relevant bindings include + foo :: a -> String (bound at WildcardInstantiations.hs:6:1) + +WildcardInstantiations.hs:8:8: error: + • Found type wildcard ‘_’ standing for ‘t’ + Where: ‘t’ is a rigid type variable bound by + the inferred type of bar :: t -> (t -> t1) -> t1 + at WildcardInstantiations.hs:9:1 + To use the inferred type, enable PartialTypeSignatures + • In the type signature: + bar :: _ -> _ -> _ + • Relevant bindings include + bar :: t -> (t -> t1) -> t1 + (bound at WildcardInstantiations.hs:9:1) + +WildcardInstantiations.hs:8:13: error: + • Found type wildcard ‘_’ standing for ‘t -> t1’ + Where: ‘t’ is a rigid type variable bound by + the inferred type of bar :: t -> (t -> t1) -> t1 + at WildcardInstantiations.hs:9:1 + ‘t1’ is a rigid type variable bound by + the inferred type of bar :: t -> (t -> t1) -> t1 + at WildcardInstantiations.hs:9:1 + To use the inferred type, enable PartialTypeSignatures + • In the type signature: + bar :: _ -> _ -> _ + • Relevant bindings include + bar :: t -> (t -> t1) -> t1 + (bound at WildcardInstantiations.hs:9:1) + +WildcardInstantiations.hs:8:18: error: + • Found type wildcard ‘_’ standing for ‘t1’ + Where: ‘t1’ is a rigid type variable bound by + the inferred type of bar :: t -> (t -> t1) -> t1 + at WildcardInstantiations.hs:9:1 + To use the inferred type, enable PartialTypeSignatures + • In the type signature: + bar :: _ -> _ -> _ + • Relevant bindings include + bar :: t -> (t -> t1) -> t1 + (bound at WildcardInstantiations.hs:9:1) diff --git a/testsuite/tests/partial-sigs/should_fail/all.T b/testsuite/tests/partial-sigs/should_fail/all.T index 913b7d813a..dbbe9462db 100644 --- a/testsuite/tests/partial-sigs/should_fail/all.T +++ b/testsuite/tests/partial-sigs/should_fail/all.T @@ -1,6 +1,6 @@ test('AnnotatedConstraint', normal, compile_fail, ['']) test('AnnotatedConstraintNotForgotten', normal, compile_fail, ['']) -test('Defaulting1MROff', normal, compile_fail, ['']) +test('Defaulting1MROff', normal, compile, ['']) test('ExtraConstraintsWildcardInExpressionSignature', normal, compile_fail, ['']) test('ExtraConstraintsWildcardInPatternSignature', normal, compile_fail, ['']) test('ExtraConstraintsWildcardInPatternSplice', normal, compile_fail, ['']) @@ -9,7 +9,7 @@ test('ExtraConstraintsWildcardInTypeSpliceUsed', extra_clean(['ExtraConstraintsWildcardInTypeSplice.o', 'ExtraConstraintsWildcardInTypeSplice.hi'])], multimod_compile_fail, ['ExtraConstraintsWildcardInTypeSpliceUsed', config.ghc_th_way_flags]) test('ExtraConstraintsWildcardInTypeSplice2', - req_interp, + [expect_broken(11101), req_interp], compile_fail, ['']) test('ExtraConstraintsWildcardNotEnabled', normal, compile_fail, ['']) test('ExtraConstraintsWildcardNotLast', normal, compile_fail, ['']) @@ -33,7 +33,6 @@ test('ScopedNamedWildcardsBad', normal, compile_fail, ['']) test('TidyClash', normal, compile_fail, ['']) # Bug test('TidyClash2', expect_broken(9478), compile_fail, ['']) -test('Trac10045', normal, compile_fail, ['']) test('UnnamedConstraintWildcard1', normal, compile_fail, ['']) test('UnnamedConstraintWildcard2', normal, compile_fail, ['']) test('WildcardInADT1', normal, compile_fail, ['']) diff --git a/testsuite/tests/patsyn/should_fail/T9161-1.stderr b/testsuite/tests/patsyn/should_fail/T9161-1.stderr index 1f05196ebb..4e744694e2 100644 --- a/testsuite/tests/patsyn/should_fail/T9161-1.stderr +++ b/testsuite/tests/patsyn/should_fail/T9161-1.stderr @@ -1,4 +1,5 @@ - -T9161-1.hs:6:14: - Pattern synonym ‘PATTERN’ used as a type - In the type signature for ‘wrongLift’: wrongLift :: PATTERN +
+T9161-1.hs:6:14: error:
+ Pattern synonym ‘PATTERN’ used as a type
+ In the type signature:
+ wrongLift :: PATTERN
diff --git a/testsuite/tests/patsyn/should_fail/T9161-2.stderr b/testsuite/tests/patsyn/should_fail/T9161-2.stderr index 8d21be5906..ebaea2d455 100644 --- a/testsuite/tests/patsyn/should_fail/T9161-2.stderr +++ b/testsuite/tests/patsyn/should_fail/T9161-2.stderr @@ -1,5 +1,5 @@ - -T9161-2.hs:8:20: - Pattern synonym ‘PATTERN’ used as a type - In the type signature for ‘wrongLift’: - wrongLift :: Proxy PATTERN () +
+T9161-2.hs:8:20: error:
+ Pattern synonym ‘PATTERN’ used as a type
+ In the type signature:
+ wrongLift :: Proxy PATTERN ()
diff --git a/testsuite/tests/perf/compiler/T5837.stderr b/testsuite/tests/perf/compiler/T5837.stderr index 7add7e39bc..324e817947 100644 --- a/testsuite/tests/perf/compiler/T5837.stderr +++ b/testsuite/tests/perf/compiler/T5837.stderr @@ -1,5 +1,5 @@ -T5837.hs:8:6: +T5837.hs:8:6: error: Reduction stack overflow; size = 51 When simplifying the following type: TF @@ -86,6 +86,6 @@ T5837.hs:8:6: (any upper bound you could choose might fail unpredictably with minor updates to GHC, so disabling the check is recommended if you're sure that type checking should terminate) - In the ambiguity check for the type signature for ‘t’: - t :: forall a. (a ~ TF (a, Int)) => Int - In the type signature for ‘t’: t :: (a ~ TF (a, Int)) => Int + In the ambiguity check for ‘t’ + In the type signature: + t :: (a ~ TF (a, Int)) => Int diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index bb43c47d9e..bbcb631f97 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -293,7 +293,7 @@ test('T3064', # 2014-12-01: 162457940 (Windows) # 2014-12-22: 122836340 (Windows) Death to silent superclasses - (wordsize(64), 243670824, 5)]), + (wordsize(64), 264952256, 5)]), # (amd64/Linux) (28/06/2011): 73259544 # (amd64/Linux) (07/02/2013): 224798696 # (amd64/Linux) (02/08/2013): 236404384, increase from roles @@ -310,6 +310,8 @@ test('T3064', # (Mac) (18/12/2014): 350418600, improvements to flattener # (amd64/Linux) (22/12/2014): 243670824, Ha! Death to superclass constraints, makes # much less code for Monad instances + # (amd64/Linux) (01/12/2015): 264952256, Regression due to Simon's wildcard refactor + # Tracked as #11151. ################################### # deactivated for now, as this metric became too volatile recently diff --git a/testsuite/tests/polykinds/PolyKinds02.stderr b/testsuite/tests/polykinds/PolyKinds02.stderr index ab646d81c7..7c5716a65e 100644 --- a/testsuite/tests/polykinds/PolyKinds02.stderr +++ b/testsuite/tests/polykinds/PolyKinds02.stderr @@ -1,5 +1,5 @@ - -PolyKinds02.hs:13:16: - The second argument of ‘Vec’ should have kind ‘Nat’, - but ‘Nat’ has kind ‘*’ - In the type signature for ‘vec’: vec :: Vec Nat Nat +
+PolyKinds02.hs:13:16: error:
+ The second argument of ‘Vec’ should have kind ‘Nat’,
+ but ‘Nat’ has kind ‘*’
+ In the type signature: vec :: Vec Nat Nat
diff --git a/testsuite/tests/polykinds/T10503.stderr b/testsuite/tests/polykinds/T10503.stderr index e2817fe776..071ab5e88e 100644 --- a/testsuite/tests/polykinds/T10503.stderr +++ b/testsuite/tests/polykinds/T10503.stderr @@ -1,16 +1,15 @@ - -T10503.hs:8:6: error: - Couldn't match kind ‘k’ with ‘*’ - ‘k’ is a rigid type variable bound by - the type signature for: - h :: ((Proxy 'KProxy ~ Proxy 'KProxy) => r) -> r - at T10503.hs:8:6 - Expected type: Proxy 'KProxy - Actual type: Proxy 'KProxy - In the ambiguity check for the type signature for ‘h’: - h :: forall (k :: BOX) r. - ((Proxy 'KProxy ~ Proxy 'KProxy) => r) -> r - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the type signature for ‘h’: - h :: forall r. - (Proxy (KProxy :: KProxy k) ~ Proxy (KProxy :: KProxy *) => r) -> r +
+T10503.hs:8:6: error:
+ Couldn't match kind ‘k’ with ‘*’
+ ‘k’ is a rigid type variable bound by
+ the type signature for:
+ h :: forall (k :: BOX) r.
+ ((Proxy 'KProxy ~ Proxy 'KProxy) => r) -> r
+ at T10503.hs:8:6
+ Expected type: Proxy 'KProxy
+ Actual type: Proxy 'KProxy
+ In the ambiguity check for ‘h’
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ In the type signature:
+ h :: forall r.
+ (Proxy (KProxy :: KProxy k) ~ Proxy (KProxy :: KProxy *) => r) -> r
diff --git a/testsuite/tests/polykinds/T10516.stderr b/testsuite/tests/polykinds/T10516.stderr index 0242722ea5..a6fa52471b 100644 --- a/testsuite/tests/polykinds/T10516.stderr +++ b/testsuite/tests/polykinds/T10516.stderr @@ -1,4 +1,4 @@ T10516.hs:8:6: error:
The type synonym ‘App’ should have 2 arguments, but has been given 1
- In the type signature for ‘f’: f :: f a -> X (App f) a
+ In the type signature: f :: f a -> X (App f) a
diff --git a/testsuite/tests/polykinds/T6021.stderr b/testsuite/tests/polykinds/T6021.stderr index ea3b9e3427..0b7ce77439 100644 --- a/testsuite/tests/polykinds/T6021.stderr +++ b/testsuite/tests/polykinds/T6021.stderr @@ -1,4 +1,5 @@ - -T6021.hs:5:10: - Kind variable also used as type variable: ‘b’ - In an instance declaration +
+T6021.hs:5:22: error:
+ Type variable ‘b’ used as a kind
+ In the kind ‘b’
+ In the instance declaration for ‘Panic (a :: b) b’
diff --git a/testsuite/tests/polykinds/T6068.hs b/testsuite/tests/polykinds/T6068.hs index 0b414a87b9..7b90b4ebaf 100644 --- a/testsuite/tests/polykinds/T6068.hs +++ b/testsuite/tests/polykinds/T6068.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, GADTs, MultiParamTypeClasses, +{-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, GADTs, MultiParamTypeClasses, KindSignatures, FunctionalDependencies, FlexibleInstances, UndecidableInstances, ExistentialQuantification #-} module T6068 where @@ -23,7 +23,7 @@ class HasSingleton a (kp :: KProxy k) | a -> kp where class Floop a b | a -> b -instance forall a (mp :: KProxy (Maybe ak)). Floop a mp => HasSingleton (Maybe a) mp where +instance Floop a (mp :: KProxy (Maybe ak)) => HasSingleton (Maybe a) mp where exists Nothing = Exists SNothing -- instance forall (a ::*) (mp :: KProxy (Maybe ak)). HasSingleton (Maybe ak) (Maybe a) mp where diff --git a/testsuite/tests/polykinds/T7224.stderr b/testsuite/tests/polykinds/T7224.stderr index 90ebc0f3ec..b957a1ba65 100644 --- a/testsuite/tests/polykinds/T7224.stderr +++ b/testsuite/tests/polykinds/T7224.stderr @@ -1,5 +1,6 @@ - -T7224.hs:6:19: - Kind variable ‘i’ used as a type - In the type ‘a -> m i i a’ - In the class declaration for ‘PMonad'’ +
+T7224.hs:6:19: error:
+ Kind variable ‘i’ used as a type
+ In the type signature:
+ ret' :: a -> m i i a
+ In the class declaration for ‘PMonad'’
diff --git a/testsuite/tests/polykinds/T7230.stderr b/testsuite/tests/polykinds/T7230.stderr index 0756cd5284..92938bedb1 100644 --- a/testsuite/tests/polykinds/T7230.stderr +++ b/testsuite/tests/polykinds/T7230.stderr @@ -1,28 +1,28 @@ -T7230.hs:48:32: - Could not deduce: (x :<<= x1) ~ 'True - from the context: Increasing xs ~ 'True - bound by the type signature for: - crash :: (Increasing xs ~ 'True) => - SList xs -> SBool (Increasing xs) - at T7230.hs:47:10-68 - or from: xs ~ (x : xs1) - bound by a pattern with constructor: - SCons :: forall (k :: BOX) (x :: k) (xs :: [k]). - Sing x -> Sing xs -> Sing (x : xs), - in an equation for ‘crash’ - at T7230.hs:48:8-27 - or from: xs1 ~ (x1 : xs2) - bound by a pattern with constructor: - SCons :: forall (k :: BOX) (x :: k) (xs :: [k]). - Sing x -> Sing xs -> Sing (x : xs), - in an equation for ‘crash’ - at T7230.hs:48:17-26 - Expected type: SBool (Increasing xs) - Actual type: SBool (x :<<= x1) - In the expression: x %:<<= y - In an equation for ‘crash’: - crash (SCons x (SCons y xs)) = x %:<<= y - Relevant bindings include - y :: Sing x1 (bound at T7230.hs:48:23) - x :: Sing x (bound at T7230.hs:48:14) +T7230.hs:48:32: error: + • Could not deduce: (x :<<= x1) ~ 'True + from the context: Increasing xs ~ 'True + bound by the type signature for: + crash :: (Increasing xs ~ 'True) => + SList xs -> SBool (Increasing xs) + at T7230.hs:47:1-68 + or from: xs ~ (x : xs1) + bound by a pattern with constructor: + SCons :: forall (k :: BOX) (x :: k) (xs :: [k]). + Sing x -> Sing xs -> Sing (x : xs), + in an equation for ‘crash’ + at T7230.hs:48:8-27 + or from: xs1 ~ (x1 : xs2) + bound by a pattern with constructor: + SCons :: forall (k :: BOX) (x :: k) (xs :: [k]). + Sing x -> Sing xs -> Sing (x : xs), + in an equation for ‘crash’ + at T7230.hs:48:17-26 + Expected type: SBool (Increasing xs) + Actual type: SBool (x :<<= x1) + • In the expression: x %:<<= y + In an equation for ‘crash’: + crash (SCons x (SCons y xs)) = x %:<<= y + • Relevant bindings include + y :: Sing x1 (bound at T7230.hs:48:23) + x :: Sing x (bound at T7230.hs:48:14) diff --git a/testsuite/tests/polykinds/T7278.stderr b/testsuite/tests/polykinds/T7278.stderr index 3d615c12f7..f8b2cfface 100644 --- a/testsuite/tests/polykinds/T7278.stderr +++ b/testsuite/tests/polykinds/T7278.stderr @@ -1,5 +1,5 @@ - -T7278.hs:8:43: - ‘t’ is applied to too many type arguments - In the type signature for ‘f’: - f :: (C (t :: k) (TF t)) => TF t p1 p0 -> t p1 p0 +
+T7278.hs:8:43: error:
+ ‘t’ is applied to too many type arguments
+ In the type signature:
+ f :: (C (t :: k) (TF t)) => TF t p1 p0 -> t p1 p0
diff --git a/testsuite/tests/polykinds/T7328.stderr b/testsuite/tests/polykinds/T7328.stderr index 7fcd8edf90..9e7cbab03a 100644 --- a/testsuite/tests/polykinds/T7328.stderr +++ b/testsuite/tests/polykinds/T7328.stderr @@ -1,7 +1,8 @@ - -T7328.hs:8:34: - Kind occurs check - The first argument of ‘Foo’ should have kind ‘k0’, - but ‘f’ has kind ‘k1 -> k0’ - In the type ‘a ~ f i => Proxy (Foo f)’ - In the class declaration for ‘Foo’ +
+T7328.hs:8:34: error:
+ Kind occurs check
+ The first argument of ‘Foo’ should have kind ‘k0’,
+ but ‘f’ has kind ‘k1 -> k0’
+ In the type signature:
+ foo :: a ~ f i => Proxy (Foo f)
+ In the class declaration for ‘Foo’
diff --git a/testsuite/tests/polykinds/T7438.stderr b/testsuite/tests/polykinds/T7438.stderr index d87e437b31..ca09383a2d 100644 --- a/testsuite/tests/polykinds/T7438.stderr +++ b/testsuite/tests/polykinds/T7438.stderr @@ -17,3 +17,4 @@ T7438.hs:6:14: error: Relevant bindings include acc :: t (bound at T7438.hs:6:8) go :: Thrist t2 t3 -> t -> t1 (bound at T7438.hs:6:1) + diff --git a/testsuite/tests/polykinds/T9222.stderr b/testsuite/tests/polykinds/T9222.stderr index a5b35ee2b1..6a45c4a7fb 100644 --- a/testsuite/tests/polykinds/T9222.stderr +++ b/testsuite/tests/polykinds/T9222.stderr @@ -7,18 +7,13 @@ T9222.hs:13:3: error: (a ~ '(b0, c0)) => Proxy b0 at T9222.hs:13:3 ‘b’ is a rigid type variable bound by - the type of the constructor ‘Want’: - ((a ~ '(b, c)) => Proxy b) -> Want a - at T9222.hs:13:3 + the type of the constructor ‘Want’: + forall (k :: BOX) (k1 :: BOX) (a :: (,) k k1) (b :: k) (c :: k1). + ((a ~ '(b, c)) => Proxy b) -> Want a + at T9222.hs:13:3 Expected type: '(b, c) Actual type: a - In the ambiguity check for the type of the constructor ‘Want’: - Want :: forall (k :: BOX) - (k1 :: BOX) - (a :: (,) k k1) - (b :: k) - (c :: k1). - ((a ~ '(b, c)) => Proxy b) -> Want a + In the ambiguity check for ‘Want’ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes In the definition of data constructor ‘Want’ In the data type declaration for ‘Want’ diff --git a/testsuite/tests/rename/should_compile/T4426.hs b/testsuite/tests/rename/should_compile/T4426.hs index b04f59cd03..610f670e44 100644 --- a/testsuite/tests/rename/should_compile/T4426.hs +++ b/testsuite/tests/rename/should_compile/T4426.hs @@ -1,8 +1,13 @@ {-# LANGUAGE RankNTypes #-} -{-# OPTIONS_GHC -fwarn-context-quantification #-} +{- # OPTIONS_GHC -fwarn-context-quantification #-} module T4426 where +-- GHC 8.0 no longer allows implicit quantification +-- on the RHS. This is more consistent: +-- type F a = a -> m a +-- has always been rejected and hence so should +-- these four. (It was already deprecated in 7.10.) type F a = Monad m => a -> m a data X a = X (Eq b => a -> b) @@ -12,6 +17,7 @@ data Y a = Y { k :: Eq b => a -> b -> c } f :: forall b. (Monad m => m b) -> b f = undefined +-- But these ones are fine: type F' a = forall m. Monad m => a -> m a data X' a = X' (forall b. Eq b => a -> b) diff --git a/testsuite/tests/rename/should_compile/T4426.stderr b/testsuite/tests/rename/should_compile/T4426.stderr index f4e0c471d6..f731f3544d 100644 --- a/testsuite/tests/rename/should_compile/T4426.stderr +++ b/testsuite/tests/rename/should_compile/T4426.stderr @@ -1,35 +1,18 @@ - -T4426.hs:6:12: Warning: - Variable ‘m’ is implicitly quantified due to a context - Use explicit forall syntax instead. - This will become an error in GHC 7.12. - In the type ‘Monad m => a -> m a’ - In the declaration for type synonym ‘F’ - -T4426.hs:8:15: Warning: - Variable ‘b’ is implicitly quantified due to a context - Use explicit forall syntax instead. - This will become an error in GHC 7.12. - In the type ‘Eq b => a -> b’ - In the definition of data constructor ‘X’ - -T4426.hs:10:21: Warning: - Variable ‘b’ is implicitly quantified due to a context - Use explicit forall syntax instead. - This will become an error in GHC 7.12. - In the type ‘Eq b => a -> b -> c’ - In the definition of data constructor ‘Y’ - -T4426.hs:10:21: Warning: - Variable ‘c’ is implicitly quantified due to a context - Use explicit forall syntax instead. - This will become an error in GHC 7.12. - In the type ‘Eq b => a -> b -> c’ - In the definition of data constructor ‘Y’ - -T4426.hs:12:17: Warning: - Variable ‘m’ is implicitly quantified due to a context - Use explicit forall syntax instead. - This will become an error in GHC 7.12. - In the type ‘Monad m => m b’ - In the type signature for ‘f’ +
+T4426.hs:11:18: error: Not in scope: type variable ‘m’
+
+T4426.hs:11:28: error: Not in scope: type variable ‘m’
+
+T4426.hs:13:18: error: Not in scope: type variable ‘b’
+
+T4426.hs:13:28: error: Not in scope: type variable ‘b’
+
+T4426.hs:15:24: error: Not in scope: type variable ‘b’
+
+T4426.hs:15:34: error: Not in scope: type variable ‘b’
+
+T4426.hs:15:39: error: Not in scope: type variable ‘c’
+
+T4426.hs:17:23: error: Not in scope: type variable ‘m’
+
+T4426.hs:17:28: error: Not in scope: type variable ‘m’
diff --git a/testsuite/tests/rename/should_compile/T5331.stderr b/testsuite/tests/rename/should_compile/T5331.stderr index 562aa69978..13249b0e17 100644 --- a/testsuite/tests/rename/should_compile/T5331.stderr +++ b/testsuite/tests/rename/should_compile/T5331.stderr @@ -1,13 +1,12 @@ - -T5331.hs:8:17: Warning: - Unused quantified type variable ‘a’ - In the definition of data constructor ‘S1’ - -T5331.hs:11:16: Warning: - Unused quantified type variable ‘a’ - In the definition of data constructor ‘W1’ - -T5331.hs:13:13: Warning: - Unused quantified type variable ‘a’ - In the type ‘forall a. Int’ - In the type signature for ‘f’ +
+T5331.hs:8:17: warning:
+ Unused quantified type variable ‘a’
+ In the definition of data constructor ‘S1’
+
+T5331.hs:11:16: warning:
+ Unused quantified type variable ‘a’
+ In the definition of data constructor ‘W1’
+
+T5331.hs:13:13: warning:
+ Unused quantified type variable ‘a’
+ In the type ‘forall a. Int’
diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T index 8a597827fe..c501eccd56 100644 --- a/testsuite/tests/rename/should_compile/all.T +++ b/testsuite/tests/rename/should_compile/all.T @@ -224,5 +224,5 @@ test('T7969', run_command, ['$MAKE -s --no-print-directory T7969']) test('T9127', normal, compile, ['']) -test('T4426', normal, compile, ['']) +test('T4426', normal, compile_fail, ['']) test('T9778', normal, compile, ['-fwarn-unticked-promoted-constructors']) diff --git a/testsuite/tests/rename/should_fail/T2901.stderr b/testsuite/tests/rename/should_fail/T2901.stderr index d5a2247ce1..2128989b4c 100644 --- a/testsuite/tests/rename/should_fail/T2901.stderr +++ b/testsuite/tests/rename/should_fail/T2901.stderr @@ -4,4 +4,5 @@ T2901.hs:6:5: error: No module named ‘F’ is imported. T2901.hs:6:13: error: - ‘F.field’ is not a (visible) constructor field name + Not in scope: ‘F.field’ + No module named ‘F’ is imported. diff --git a/testsuite/tests/rename/should_fail/T5372.hs b/testsuite/tests/rename/should_fail/T5372.hs index b0f5906c10..2e937b7cba 100644 --- a/testsuite/tests/rename/should_fail/T5372.hs +++ b/testsuite/tests/rename/should_fail/T5372.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DisambiguateRecordFields #-} -module T5372 where -import qualified T5372a -notScope (MkS { x = n }) = n +{-# LANGUAGE DisambiguateRecordFields #-} +module T5372 where +import qualified T5372a +notScope (MkS { x = n }) = n diff --git a/testsuite/tests/rename/should_fail/T5372.stderr b/testsuite/tests/rename/should_fail/T5372.stderr index 9d3f06e7d4..5d7a9c4ead 100644 --- a/testsuite/tests/rename/should_fail/T5372.stderr +++ b/testsuite/tests/rename/should_fail/T5372.stderr @@ -1,6 +1,8 @@ - -T5372.hs:4:11: - Not in scope: data constructor ‘MkS’ - Perhaps you meant ‘T5372a.MkS’ (imported from T5372a) - -T5372.hs:4:17: ‘x’ is not a (visible) constructor field name +
+T5372.hs:4:11: error:
+ Not in scope: data constructor ‘MkS’
+ Perhaps you meant ‘T5372a.MkS’ (imported from T5372a)
+
+T5372.hs:4:17: error:
+ Not in scope: ‘x’
+ Perhaps you meant ‘T5372a.x’ (imported from T5372a)
diff --git a/testsuite/tests/rename/should_fail/rnfail026.stderr b/testsuite/tests/rename/should_fail/rnfail026.stderr index 22caa11c1d..f220f81812 100644 --- a/testsuite/tests/rename/should_fail/rnfail026.stderr +++ b/testsuite/tests/rename/should_fail/rnfail026.stderr @@ -1,9 +1,9 @@ - -rnfail026.hs:16:17: - The first argument of ‘Monad’ should have kind ‘* -> *’, - but ‘forall a. Eq a => Set a’ has kind ‘*’ - In the instance declaration for ‘Monad (forall a. Eq a => Set a)’ - -rnfail026.hs:19:10: - Illegal polymorphic or qualified type: forall a. [a] - In the instance declaration for ‘Eq (forall a. [a])’ +
+rnfail026.hs:16:27: error:
+ The first argument of ‘Monad’ should have kind ‘* -> *’,
+ but ‘Eq a => Set a’ has kind ‘*’
+ In the instance declaration for ‘Monad (forall a. Eq a => Set a)’
+
+rnfail026.hs:19:10: error:
+ Illegal polymorphic or qualified type: forall a. [a]
+ In the instance declaration for ‘Eq (forall a. [a])’
diff --git a/testsuite/tests/roles/should_fail/RolesIArray.stderr b/testsuite/tests/roles/should_fail/RolesIArray.stderr index 8b844dc3eb..ea9bb30c86 100644 --- a/testsuite/tests/roles/should_fail/RolesIArray.stderr +++ b/testsuite/tests/roles/should_fail/RolesIArray.stderr @@ -2,11 +2,11 @@ RolesIArray.hs:10:13: error: Couldn't match type ‘Word64’ with ‘N’ arising from the coercion of the method ‘Data.Array.Base.unsafeAccumArray’ - from type ‘forall e' i. + from type ‘forall i e'. Ix i => (Word64 -> e' -> Word64) -> Word64 -> (i, i) -> [(Int, e')] -> UArray i Word64’ - to type ‘forall e' i. + to type ‘forall i e'. Ix i => (N -> e' -> N) -> N -> (i, i) -> [(Int, e')] -> UArray i N’ When deriving the instance for (IArray UArray N) @@ -14,11 +14,11 @@ RolesIArray.hs:10:13: error: RolesIArray.hs:10:13: error: Couldn't match type ‘Word64’ with ‘N’ arising from the coercion of the method ‘Data.Array.Base.unsafeAccum’ - from type ‘forall e' i. + from type ‘forall i e'. Ix i => (Word64 -> e' -> Word64) -> UArray i Word64 -> [(Int, e')] -> UArray i Word64’ - to type ‘forall e' i. + to type ‘forall i e'. Ix i => (N -> e' -> N) -> UArray i N -> [(Int, e')] -> UArray i N’ When deriving the instance for (IArray UArray N) diff --git a/testsuite/tests/simplCore/should_compile/T8848.stderr b/testsuite/tests/simplCore/should_compile/T8848.stderr index abd6839db2..71d3708ab4 100644 --- a/testsuite/tests/simplCore/should_compile/T8848.stderr +++ b/testsuite/tests/simplCore/should_compile/T8848.stderr @@ -23,7 +23,7 @@ Rule fired: Class op <*> Rule fired: Class op $p1Applicative Rule fired: Class op fmap Rule fired: Class op <*> -Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape 'Z) +Rule fired: SPEC/T8848 liftA2 @ (Shape 'Z) _ _ _ Rule fired: Class op $p1Applicative Rule fired: Class op $p1Applicative Rule fired: SPEC $cfmap @ 'Z @@ -71,7 +71,7 @@ Rule fired: Class op <*> Rule fired: Class op $p1Applicative Rule fired: Class op fmap Rule fired: Class op <*> -Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape ('S 'Z)) +Rule fired: SPEC/T8848 liftA2 @ (Shape ('S 'Z)) _ _ _ Rule fired: SPEC $fFunctorShape @ 'Z Rule fired: Class op fmap Rule fired: Class op fmap diff --git a/testsuite/tests/simplCore/should_compile/T8848a.stderr b/testsuite/tests/simplCore/should_compile/T8848a.stderr index 9d06c08461..bd2e0cd6cc 100644 --- a/testsuite/tests/simplCore/should_compile/T8848a.stderr +++ b/testsuite/tests/simplCore/should_compile/T8848a.stderr @@ -1,6 +1,6 @@ - -==================== Tidy Core rules ==================== -"SPEC f" [ALWAYS] - forall (@ b) ($dOrd :: Ord [Int]). f @ b @ [Int] $dOrd = f_$sf @ b - - +
+==================== Tidy Core rules ====================
+"SPEC f" [ALWAYS]
+ forall (@ b) ($dOrd :: Ord [Int]). f @ [Int] @ b $dOrd = f_$sf @ b
+
+
diff --git a/testsuite/tests/simplCore/should_compile/rule2.stderr b/testsuite/tests/simplCore/should_compile/rule2.stderr index da97b8859c..f18696489c 100644 --- a/testsuite/tests/simplCore/should_compile/rule2.stderr +++ b/testsuite/tests/simplCore/should_compile/rule2.stderr @@ -23,9 +23,9 @@ Total ticks: 13 1 f 1 m 1 a - 1 m 1 b 1 m + 1 m 1 b 9 SimplifierDone 9 diff --git a/testsuite/tests/th/T10267.stderr b/testsuite/tests/th/T10267.stderr index 909479389d..0a86955e1a 100644 --- a/testsuite/tests/th/T10267.stderr +++ b/testsuite/tests/th/T10267.stderr @@ -1,46 +1,46 @@ T10267.hs:8:1: error: - Found hole: _ :: a0 - Where: ‘a0’ is a rigid type variable bound by - the type signature for: - j :: a0 -> a0 - at T10267.hs:8:1 - In the expression: _ - In an equation for ‘j’: j x = _ - Relevant bindings include - x :: a0 (bound at T10267.hs:8:1) - j :: a0 -> a0 (bound at T10267.hs:8:1) + • Found hole: _ :: a0 + Where: ‘a0’ is a rigid type variable bound by + the type signature for: + j :: forall a0. a0 -> a0 + at T10267.hs:8:1 + • In the expression: _ + In an equation for ‘j’: j x = _ + • Relevant bindings include + x :: a0 (bound at T10267.hs:8:1) + j :: a0 -> a0 (bound at T10267.hs:8:1) T10267.hs:8:1: error: - Found hole: _foo :: a0 -> a0 - Where: ‘a0’ is a rigid type variable bound by - the type signature for: - i :: a0 -> a0 - at T10267.hs:8:1 - Or perhaps ‘_foo’ is mis-spelled, or not in scope - In the expression: _foo - In an equation for ‘i’: i = _foo - Relevant bindings include i :: a0 -> a0 (bound at T10267.hs:8:1) + • Found hole: _foo :: a0 -> a0 + Where: ‘a0’ is a rigid type variable bound by + the type signature for: + i :: forall a0. a0 -> a0 + at T10267.hs:8:1 + Or perhaps ‘_foo’ is mis-spelled, or not in scope + • In the expression: _foo + In an equation for ‘i’: i = _foo + • Relevant bindings include i :: a0 -> a0 (bound at T10267.hs:8:1) T10267.hs:14:3: error: - Found hole: _foo :: a -> a - Where: ‘a’ is a rigid type variable bound by + • Found hole: _foo :: a -> a + Where: ‘a’ is a rigid type variable bound by the type signature for: - k :: a -> a + k :: forall a. a -> a at T10267.hs:14:3 - Or perhaps ‘_foo’ is mis-spelled, or not in scope - In the expression: _foo - In an equation for ‘k’: k = _foo - Relevant bindings include k :: a -> a (bound at T10267.hs:14:3) + Or perhaps ‘_foo’ is mis-spelled, or not in scope + • In the expression: _foo + In an equation for ‘k’: k = _foo + • Relevant bindings include k :: a -> a (bound at T10267.hs:14:3) T10267.hs:23:3: error: - Found hole: _ :: a - Where: ‘a’ is a rigid type variable bound by + • Found hole: _ :: a + Where: ‘a’ is a rigid type variable bound by the type signature for: - l :: a -> a + l :: forall a. a -> a at T10267.hs:23:3 - In the expression: _ - In an equation for ‘l’: l x = _ - Relevant bindings include - x :: a (bound at T10267.hs:23:3) - l :: a -> a (bound at T10267.hs:23:3) + • In the expression: _ + In an equation for ‘l’: l x = _ + • Relevant bindings include + x :: a (bound at T10267.hs:23:3) + l :: a -> a (bound at T10267.hs:23:3) diff --git a/testsuite/tests/th/T3177a.stderr b/testsuite/tests/th/T3177a.stderr index d034e29430..33093fa2b1 100644 --- a/testsuite/tests/th/T3177a.stderr +++ b/testsuite/tests/th/T3177a.stderr @@ -1,8 +1,10 @@ - -T3177a.hs:8:8: - ‘Int’ is applied to too many type arguments - In the type signature for ‘f’: f :: Int Int - -T3177a.hs:11:6: - ‘Int’ is applied to too many type arguments - In the type signature for ‘g’: g :: Int Int +
+T3177a.hs:8:8: error:
+ ‘Int’ is applied to too many type arguments
+ In the type signature:
+ f :: Int Int
+
+T3177a.hs:11:6: error:
+ ‘Int’ is applied to too many type arguments
+ In the type signature:
+ g :: Int Int
diff --git a/testsuite/tests/th/T8625.stdout b/testsuite/tests/th/T8625.stdout index 4453d692ba..000050bc97 100644 --- a/testsuite/tests/th/T8625.stdout +++ b/testsuite/tests/th/T8625.stdout @@ -1,2 +1,2 @@ -[InstanceD [AppT (AppT EqualityT (VarT y_0)) (AppT (AppT ArrowT (VarT t_1)) (VarT t_1))] (AppT (ConT Ghci1.Member) (ConT GHC.Types.Bool)) []] -[SigD f_2 (ForallT [PlainTV y_3,PlainTV t_4] [AppT (AppT EqualityT (VarT y_3)) (AppT (AppT ArrowT (VarT t_4)) (VarT t_4))] (AppT (AppT ArrowT (VarT y_3)) (VarT t_4))),FunD f_2 [Clause [VarP x_5] (NormalB (VarE x_5)) []]] +[InstanceD [AppT (AppT EqualityT (VarT y_0)) (AppT (AppT ArrowT (VarT t_1)) (VarT t_1))] (AppT (ConT Ghci1.Member) (ConT GHC.Types.Bool)) []]
+[SigD f_4 (ForallT [PlainTV y_2,PlainTV t_3] [AppT (AppT EqualityT (VarT y_2)) (AppT (AppT ArrowT (VarT t_3)) (VarT t_3))] (AppT (AppT ArrowT (VarT y_2)) (VarT t_3))),FunD f_4 [Clause [VarP x_5] (NormalB (VarE x_5)) []]]
diff --git a/testsuite/tests/th/TH_pragma.stderr b/testsuite/tests/th/TH_pragma.stderr index 0fcd167aa4..07b56645cd 100644 --- a/testsuite/tests/th/TH_pragma.stderr +++ b/testsuite/tests/th/TH_pragma.stderr @@ -1,16 +1,16 @@ -TH_pragma.hs:(6,4)-(8,26): Splicing declarations - [d| foo :: Int -> Int - {-# NOINLINE foo #-} - foo x = x + 1 |] - ======> - foo :: Int -> Int - {-# NOINLINE foo #-} - foo x = (x + 1) -TH_pragma.hs:(10,4)-(12,31): Splicing declarations - [d| bar :: Num a => a -> a - {-# SPECIALIZE INLINE[~1] bar :: Float -> Float #-} - bar x = x * 10 |] - ======> - bar :: forall a. Num a => a -> a - {-# SPECIALIZE INLINE[~1] bar :: Float -> Float #-} - bar x = (x * 10) +TH_pragma.hs:(6,4)-(8,26): Splicing declarations
+ [d| foo :: Int -> Int
+ {-# NOINLINE foo #-}
+ foo x = x + 1 |]
+ ======>
+ foo :: Int -> Int
+ {-# NOINLINE foo #-}
+ foo x = (x + 1)
+TH_pragma.hs:(10,4)-(12,31): Splicing declarations
+ [d| bar :: Num a => a -> a
+ {-# SPECIALIZE INLINE[~1] bar :: Float -> Float #-}
+ bar x = x * 10 |]
+ ======>
+ bar :: forall a. Num a => a -> a
+ {-# SPECIALIZE INLINE[~1] bar :: Float -> Float #-}
+ bar x = (x * 10)
diff --git a/testsuite/tests/typecheck/should_compile/FD1.stderr b/testsuite/tests/typecheck/should_compile/FD1.stderr index 661bbcd9aa..19d698294a 100644 --- a/testsuite/tests/typecheck/should_compile/FD1.stderr +++ b/testsuite/tests/typecheck/should_compile/FD1.stderr @@ -1,9 +1,10 @@ -
-FD1.hs:16:1:
- Couldn't match expected type ‘Int -> Int’ with actual type ‘a’
- ‘a’ is a rigid type variable bound by
- the type signature for: plus :: E a (Int -> Int) => Int -> a
- at FD1.hs:15:9
- The equation(s) for ‘plus’ have two arguments,
- but its type ‘Int -> a’ has only one
- Relevant bindings include plus :: Int -> a (bound at FD1.hs:16:1)
+ +FD1.hs:16:1: error: + • Couldn't match expected type ‘Int -> Int’ with actual type ‘a’ + ‘a’ is a rigid type variable bound by + the type signature for: + plus :: forall a. E a (Int -> Int) => Int -> a + at FD1.hs:15:9 + • The equation(s) for ‘plus’ have two arguments, + but its type ‘Int -> a’ has only one + • Relevant bindings include plus :: Int -> a (bound at FD1.hs:16:1) diff --git a/testsuite/tests/typecheck/should_compile/FD2.stderr b/testsuite/tests/typecheck/should_compile/FD2.stderr index 590c9b6520..93997c52ec 100644 --- a/testsuite/tests/typecheck/should_compile/FD2.stderr +++ b/testsuite/tests/typecheck/should_compile/FD2.stderr @@ -1,19 +1,19 @@ -
-FD2.hs:26:34:
- Couldn't match expected type ‘e1’ with actual type ‘e’
- ‘e’ is a rigid type variable bound by
- the type signature for:
- foldr1 :: Elem a e => (e -> e -> e) -> a -> e
- at FD2.hs:21:13
- ‘e1’ is a rigid type variable bound by
- the type signature for:
- mf :: Elem a e1 => e1 -> Maybe e1 -> Maybe e1
- at FD2.hs:24:18
- In the first argument of ‘Just’, namely ‘(f x y)’
- In the expression: Just (f x y)
- Relevant bindings include
- y :: e1 (bound at FD2.hs:26:23)
- x :: e1 (bound at FD2.hs:26:15)
- mf :: e1 -> Maybe e1 -> Maybe e1 (bound at FD2.hs:25:12)
- f :: e -> e -> e (bound at FD2.hs:22:10)
- foldr1 :: (e -> e -> e) -> a -> e (bound at FD2.hs:22:3)
+ +FD2.hs:26:34: error: + • Couldn't match expected type ‘e1’ with actual type ‘e’ + ‘e’ is a rigid type variable bound by + the type signature for: + foldr1 :: forall e. Elem a e => (e -> e -> e) -> a -> e + at FD2.hs:21:13 + ‘e1’ is a rigid type variable bound by + the type signature for: + mf :: forall e1. Elem a e1 => e1 -> Maybe e1 -> Maybe e1 + at FD2.hs:24:18 + • In the first argument of ‘Just’, namely ‘(f x y)’ + In the expression: Just (f x y) + • Relevant bindings include + y :: e1 (bound at FD2.hs:26:23) + x :: e1 (bound at FD2.hs:26:15) + mf :: e1 -> Maybe e1 -> Maybe e1 (bound at FD2.hs:25:12) + f :: e -> e -> e (bound at FD2.hs:22:10) + foldr1 :: (e -> e -> e) -> a -> e (bound at FD2.hs:22:3) diff --git a/testsuite/tests/typecheck/should_compile/FD3.stderr b/testsuite/tests/typecheck/should_compile/FD3.stderr index 8d3c33fcaf..f0dafbe47c 100644 --- a/testsuite/tests/typecheck/should_compile/FD3.stderr +++ b/testsuite/tests/typecheck/should_compile/FD3.stderr @@ -1,14 +1,15 @@ FD3.hs:15:15: error: - Couldn't match type ‘a’ with ‘(String, a)’ - arising from a functional dependency between: - constraint ‘MkA (String, a) a’ arising from a use of ‘mkA’ - instance ‘MkA a1 a1’ at FD3.hs:12:10-16 - ‘a’ is a rigid type variable bound by - the type signature for: translate :: (String, a) -> A a + • Couldn't match type ‘a’ with ‘(String, a)’ + arising from a functional dependency between: + constraint ‘MkA (String, a) a’ arising from a use of ‘mkA’ + instance ‘MkA a1 a1’ at FD3.hs:12:10-16 + ‘a’ is a rigid type variable bound by + the type signature for: + translate :: forall a. (String, a) -> A a at FD3.hs:14:14 - In the expression: mkA a - In an equation for ‘translate’: translate a = mkA a - Relevant bindings include - a :: (String, a) (bound at FD3.hs:15:11) - translate :: (String, a) -> A a (bound at FD3.hs:15:1) + • In the expression: mkA a + In an equation for ‘translate’: translate a = mkA a + • Relevant bindings include + a :: (String, a) (bound at FD3.hs:15:11) + translate :: (String, a) -> A a (bound at FD3.hs:15:1) diff --git a/testsuite/tests/typecheck/should_compile/T10632.stderr b/testsuite/tests/typecheck/should_compile/T10632.stderr index 81377b3364..5a6809de5c 100644 --- a/testsuite/tests/typecheck/should_compile/T10632.stderr +++ b/testsuite/tests/typecheck/should_compile/T10632.stderr @@ -1,4 +1,5 @@ - -T10632.hs:3:6: warning: - Redundant constraint: ?file1::String - In the type signature for: f :: (?file1::String) => IO () +
+T10632.hs:3:1: warning:
+ Redundant constraint: ?file1::String
+ In the type signature for:
+ f :: (?file1::String) => IO ()
diff --git a/testsuite/tests/typecheck/should_compile/T7220a.stderr b/testsuite/tests/typecheck/should_compile/T7220a.stderr index ea0331b3dc..b728a1e8d9 100644 --- a/testsuite/tests/typecheck/should_compile/T7220a.stderr +++ b/testsuite/tests/typecheck/should_compile/T7220a.stderr @@ -1,14 +1,14 @@ - -T7220a.hs:17:6: - Could not deduce (C a b) - from the context: (C a0 b, TF b ~ Y) - bound by the type signature for: f :: (C a0 b, TF b ~ Y) => b - at T7220a.hs:17:6-44 - Possible fix: - add (C a b) to the context of - the type signature for: f :: (C a0 b, TF b ~ Y) => b - In the ambiguity check for the type signature for ‘f’: - f :: forall a. (forall b. (C a b, TF b ~ Y) => b) -> X - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the type signature for ‘f’: - f :: (forall b. (C a b, TF b ~ Y) => b) -> X +
+T7220a.hs:17:6: error:
+ Could not deduce (C a b)
+ from the context: (C a0 b, TF b ~ Y)
+ bound by the type signature for:
+ f :: (C a0 b, TF b ~ Y) => b
+ at T7220a.hs:17:6-44
+ Possible fix:
+ add (C a b) to the context of
+ the type signature for:
+ f :: (C a0 b, TF b ~ Y) => b
+ In the ambiguity check for ‘f’
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ In the type signature: f :: (forall b. (C a b, TF b ~ Y) => b) -> X
diff --git a/testsuite/tests/typecheck/should_compile/T9834.stderr b/testsuite/tests/typecheck/should_compile/T9834.stderr index c49e49bb9d..3ce53a0c51 100644 --- a/testsuite/tests/typecheck/should_compile/T9834.stderr +++ b/testsuite/tests/typecheck/should_compile/T9834.stderr @@ -1,8 +1,8 @@ -T9834.hs:23:10: Warning:
+T9834.hs:23:10: warning:
Couldn't match type ‘p’ with ‘(->) (p a0)’
- ‘p’ is a rigid type variable bound by
- the class declaration for ‘ApplicativeFix’ at T9834.hs:21:39
+ ‘p’ is a rigid type variable bound by
+ the class declaration for ‘ApplicativeFix’ at T9834.hs:21:39
Expected type: (forall (q :: * -> *).
Applicative q =>
Comp p q a -> Comp p q a)
@@ -20,15 +20,14 @@ T9834.hs:23:10: Warning: -> p a
(bound at T9834.hs:23:3)
-T9834.hs:23:10: Warning:
+T9834.hs:23:10: warning:
Couldn't match type ‘a’ with ‘p a0’
- ‘a’ is a rigid type variable bound by
- the type signature for:
- afix :: (forall (q :: * -> *).
- Applicative q =>
- Comp p q a -> Comp p q a)
- -> p a
- at T9834.hs:22:11
+ ‘a’ is a rigid type variable bound by
+ the type signature for:
+ afix :: forall a.
+ (forall (q :: * -> *). Applicative q => Comp p q a -> Comp p q a)
+ -> p a
+ at T9834.hs:22:11
Expected type: (forall (q :: * -> *).
Applicative q =>
Comp p q a -> Comp p q a)
@@ -46,19 +45,20 @@ T9834.hs:23:10: Warning: -> p a
(bound at T9834.hs:23:3)
-T9834.hs:23:10: Warning:
+T9834.hs:23:10: warning:
Couldn't match type ‘a’ with ‘a1’
- ‘a’ is a rigid type variable bound by
- the type signature for:
- afix :: (forall (q :: * -> *).
- Applicative q =>
- Comp p q a -> Comp p q a)
- -> p a
- at T9834.hs:22:11
- ‘a1’ is a rigid type variable bound by
- a type expected by the context:
- Applicative q => Comp p q a1 -> Comp p q a1
- at T9834.hs:23:10
+ ‘a’ is a rigid type variable bound by
+ the type signature for:
+ afix :: forall a.
+ (forall (q :: * -> *). Applicative q => Comp p q a -> Comp p q a)
+ -> p a
+ at T9834.hs:22:11
+ ‘a1’ is a rigid type variable bound by
+ a type expected by the context:
+ forall (q :: * -> *) a1.
+ Applicative q =>
+ Comp p q a1 -> Comp p q a1
+ at T9834.hs:23:10
Expected type: Comp p q a1 -> Comp p q a1
Actual type: Comp p q a -> Comp p q a
In the expression: wrapIdComp
diff --git a/testsuite/tests/typecheck/should_compile/T9939.stderr b/testsuite/tests/typecheck/should_compile/T9939.stderr index eda780ae0e..86decf0a5e 100644 --- a/testsuite/tests/typecheck/should_compile/T9939.stderr +++ b/testsuite/tests/typecheck/should_compile/T9939.stderr @@ -1,18 +1,20 @@ - -T9939.hs:5:7: Warning: - Redundant constraint: Eq a - In the type signature for: f1 :: (Eq a, Ord a) => a -> a -> Bool - -T9939.hs:9:7: Warning: - Redundant constraint: Eq a - In the type signature for: f2 :: (Eq a, Ord a) => a -> a -> Bool - -T9939.hs:13:7: Warning: - Redundant constraint: Eq b - In the type signature for: - f3 :: (Eq a, a ~ b, Eq b) => a -> b -> Bool - -T9939.hs:20:7: Warning: - Redundant constraint: Eq b - In the type signature for: - f4 :: (Eq a, Eq b) => a -> b -> Equal a b -> Bool +
+T9939.hs:5:1: warning:
+ Redundant constraint: Eq a
+ In the type signature for:
+ f1 :: (Eq a, Ord a) => a -> a -> Bool
+
+T9939.hs:9:1: warning:
+ Redundant constraint: Eq a
+ In the type signature for:
+ f2 :: (Eq a, Ord a) => a -> a -> Bool
+
+T9939.hs:13:1: warning:
+ Redundant constraint: Eq b
+ In the type signature for:
+ f3 :: (Eq a, a ~ b, Eq b) => a -> b -> Bool
+
+T9939.hs:20:1: warning:
+ Redundant constraint: Eq b
+ In the type signature for:
+ f4 :: (Eq a, Eq b) => a -> b -> Equal a b -> Bool
diff --git a/testsuite/tests/typecheck/should_compile/tc141.stderr b/testsuite/tests/typecheck/should_compile/tc141.stderr index 933eb03f55..b5ee77b689 100644 --- a/testsuite/tests/typecheck/should_compile/tc141.stderr +++ b/testsuite/tests/typecheck/should_compile/tc141.stderr @@ -1,46 +1,48 @@ -tc141.hs:11:12: - You cannot bind scoped type variable ‘a’ - in a pattern binding signature - In the pattern: p :: a - In the pattern: (p :: a, q :: a) - In a pattern binding: (p :: a, q :: a) = x +tc141.hs:11:12: error: + • You cannot bind scoped type variable ‘a’ + in a pattern binding signature + • In the pattern: p :: a + In the pattern: (p :: a, q :: a) + In a pattern binding: (p :: a, q :: a) = x -tc141.hs:11:31: - Couldn't match expected type ‘a1’ with actual type ‘a’ - because type variable ‘a1’ would escape its scope - This (rigid, skolem) type variable is bound by - an expression type signature: a1 - at tc141.hs:11:31-34 - In the expression: q :: a - In the expression: (q :: a, p) - Relevant bindings include - p :: a (bound at tc141.hs:11:12) - q :: a (bound at tc141.hs:11:17) - x :: (a, a) (bound at tc141.hs:11:3) - f :: (a, a) -> (t, a) (bound at tc141.hs:11:1) +tc141.hs:11:31: error: + • Couldn't match expected type ‘a1’ with actual type ‘a’ + because type variable ‘a1’ would escape its scope + This (rigid, skolem) type variable is bound by + an expression type signature: + a1 + at tc141.hs:11:31-34 + • In the expression: q :: a + In the expression: (q :: a, p) + • Relevant bindings include + p :: a (bound at tc141.hs:11:12) + q :: a (bound at tc141.hs:11:17) + x :: (a, a) (bound at tc141.hs:11:3) + f :: (a, a) -> (t, a) (bound at tc141.hs:11:1) -tc141.hs:13:13: - You cannot bind scoped type variable ‘a’ - in a pattern binding signature - In the pattern: y :: a - In a pattern binding: y :: a = a - In the expression: - let y :: a = a in - let - v :: a - v = b - in v +tc141.hs:13:13: error: + • You cannot bind scoped type variable ‘a’ + in a pattern binding signature + • In the pattern: y :: a + In a pattern binding: y :: a = a + In the expression: + let y :: a = a in + let + v :: a + v = b + in v -tc141.hs:15:18: - Couldn't match expected type ‘a2’ with actual type ‘t’ - because type variable ‘a2’ would escape its scope - This (rigid, skolem) type variable is bound by - the type signature for: v :: a2 - at tc141.hs:14:19 - In the expression: b - In an equation for ‘v’: v = b - Relevant bindings include - v :: a2 (bound at tc141.hs:15:14) - b :: t (bound at tc141.hs:13:5) - g :: a -> t -> a1 (bound at tc141.hs:13:1) +tc141.hs:15:18: error: + • Couldn't match expected type ‘a2’ with actual type ‘t’ + because type variable ‘a2’ would escape its scope + This (rigid, skolem) type variable is bound by + the type signature for: + v :: a2 + at tc141.hs:14:14-19 + • In the expression: b + In an equation for ‘v’: v = b + • Relevant bindings include + v :: a2 (bound at tc141.hs:15:14) + b :: t (bound at tc141.hs:13:5) + g :: a -> t -> a1 (bound at tc141.hs:13:1) diff --git a/testsuite/tests/typecheck/should_compile/tc166.hs b/testsuite/tests/typecheck/should_compile/tc166.hs index 75ea65c650..5739a347c8 100644 --- a/testsuite/tests/typecheck/should_compile/tc166.hs +++ b/testsuite/tests/typecheck/should_compile/tc166.hs @@ -14,9 +14,9 @@ module ShouldCompile where instance C Char a Bool data P t a = forall b. (C t a b) => MkP b - + data Q t = MkQ (forall a. P t a) - + f1 :: Q Char f1 = MkQ (MkP True) diff --git a/testsuite/tests/typecheck/should_compile/tc168.stderr b/testsuite/tests/typecheck/should_compile/tc168.stderr index 4eca08f17c..7d992a48a0 100644 --- a/testsuite/tests/typecheck/should_compile/tc168.stderr +++ b/testsuite/tests/typecheck/should_compile/tc168.stderr @@ -1,10 +1,12 @@ - -tc168.hs:17:1: - Could not deduce (C a1 (a, b0)) - from the context: C a1 (a, b) - bound by the inferred type for ‘g’: C a1 (a, b) => a1 -> a - at tc168.hs:17:1-16 - The type variable ‘b0’ is ambiguous - When checking that ‘g’ has the inferred type - g :: forall a b a1. C a1 (a, b) => a1 -> a - Probable cause: the inferred type is ambiguous +
+tc168.hs:17:1: error:
+ Could not deduce (C a1 (a, b0))
+ from the context: C a1 (a, b)
+ bound by the inferred type for ‘g’:
+ C a1 (a, b) => a1 -> a
+ at tc168.hs:17:1-16
+ The type variable ‘b0’ is ambiguous
+ In the ambiguity check for the inferred type for ‘g’
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ When checking the inferred type
+ g :: forall a b a1. C a1 (a, b) => a1 -> a
diff --git a/testsuite/tests/typecheck/should_compile/tc182.hs b/testsuite/tests/typecheck/should_compile/tc182.hs index f6e9164f47..00b3f724de 100644 --- a/testsuite/tests/typecheck/should_compile/tc182.hs +++ b/testsuite/tests/typecheck/should_compile/tc182.hs @@ -9,5 +9,3 @@ data (Show a) => Obs a = forall b. LiftObs a b f :: Show a => Obs a -> String f (LiftObs _ _) = "yes" - - diff --git a/testsuite/tests/typecheck/should_compile/tc244.hs b/testsuite/tests/typecheck/should_compile/tc244.hs index 4c5468809a..196f6e0990 100644 --- a/testsuite/tests/typecheck/should_compile/tc244.hs +++ b/testsuite/tests/typecheck/should_compile/tc244.hs @@ -1,30 +1,32 @@ -{-# LANGUAGE TypeFamilies, GADTs #-}
-
--- Tests record update in the presence of
--- existentials, GADTs, type families
-
-module Rec where
-
------------------ Existential
-data S a where
- S1 :: { fs1 :: a, fs2 :: b } -> S a
- S2 :: { fs1 :: a } -> S a
-
-updS s x = s { fs1=x }
-
------------------- GADT
-data T a b where
- T1 :: { ft1 :: a, ft2 :: c, ft3 :: d } -> T a Int
- T2 :: { ft1 :: a, ft3 :: c } -> T a Int
- T3 :: T Int b
-
-f :: T a1 b -> a2 -> T a2 b
-f x v = x { ft1 = v }
-
------------------- Type family
-data family R a
-data instance R (a,b) where
- R1 :: { fr1 :: a, fr2 :: b, fr3 :: c } -> R (a,b)
- R2 :: { fr1 :: a, fr3 :: c } -> R (a,b)
-
-updR r x = r { fr1=x }
+{-# LANGUAGE TypeFamilies, GADTs #-} + +-- Tests record update in the presence of +-- existentials, GADTs, type families + +module Rec where + +----------------- Existential +data S a where + S1 :: { fs1 :: a, fs2 :: b } -> S a + S2 :: { fs1 :: a } -> S a + +updS s x = s { fs1=x } + +{- +------------------ GADT +data T a b where + T1 :: { ft1 :: a, ft2 :: c, ft3 :: d } -> T a Int + T2 :: { ft1 :: a, ft3 :: c } -> T a Int + T3 :: T Int b + +f :: T a1 b -> a2 -> T a2 b +f x v = x { ft1 = v } + +------------------ Type family +data family R a +data instance R (a,b) where + R1 :: { fr1 :: a, fr2 :: b, fr3 :: c } -> R (a,b) + R2 :: { fr1 :: a, fr3 :: c } -> R (a,b) + +updR r x = r { fr1=x } +-} diff --git a/testsuite/tests/typecheck/should_fail/ContextStack2.stderr b/testsuite/tests/typecheck/should_fail/ContextStack2.stderr index 1a6d1d26aa..4c92698f02 100644 --- a/testsuite/tests/typecheck/should_fail/ContextStack2.stderr +++ b/testsuite/tests/typecheck/should_fail/ContextStack2.stderr @@ -1,13 +1,12 @@ - -ContextStack2.hs:8:6: - Reduction stack overflow; size = 11 - When simplifying the following type: - TF (TF (TF (TF (TF a)))) - ~ (TF (TF (TF (TF (TF (TF a))))), TF (TF (TF (TF (TF (TF Int)))))) - Use -freduction-depth=0 to disable this check - (any upper bound you could choose might fail unpredictably with - minor updates to GHC, so disabling the check is recommended if - you're sure that type checking should terminate) - In the ambiguity check for the type signature for ‘t’: - t :: forall a. (a ~ TF (a, Int)) => Int - In the type signature for ‘t’: t :: (a ~ TF (a, Int)) => Int +
+ContextStack2.hs:8:6: error:
+ Reduction stack overflow; size = 11
+ When simplifying the following type:
+ TF (TF (TF (TF (TF a))))
+ ~ (TF (TF (TF (TF (TF (TF a))))), TF (TF (TF (TF (TF (TF Int))))))
+ Use -freduction-depth=0 to disable this check
+ (any upper bound you could choose might fail unpredictably with
+ minor updates to GHC, so disabling the check is recommended if
+ you're sure that type checking should terminate)
+ In the ambiguity check for ‘t’
+ In the type signature: t :: (a ~ TF (a, Int)) => Int
diff --git a/testsuite/tests/typecheck/should_fail/CustomTypeErrors02.stderr b/testsuite/tests/typecheck/should_fail/CustomTypeErrors02.stderr index 02ae25931a..464c62d244 100644 --- a/testsuite/tests/typecheck/should_fail/CustomTypeErrors02.stderr +++ b/testsuite/tests/typecheck/should_fail/CustomTypeErrors02.stderr @@ -1,7 +1,7 @@ CustomTypeErrors02.hs:17:1: error: • The type 'a_aEN -> a_aEN' cannot be represented as an integer. - • When checking that ‘err’ has the inferred type + • When checking the inferred type err :: (TypeError ...) CustomTypeErrors02.hs:17:7: error: diff --git a/testsuite/tests/typecheck/should_fail/CustomTypeErrors03.stderr b/testsuite/tests/typecheck/should_fail/CustomTypeErrors03.stderr index 330fadb6fd..b1ceb26b5e 100644 --- a/testsuite/tests/typecheck/should_fail/CustomTypeErrors03.stderr +++ b/testsuite/tests/typecheck/should_fail/CustomTypeErrors03.stderr @@ -1,5 +1,5 @@ CustomTypeErrors03.hs:6:6: error: This is a type error - In the type signature for ‘f’: + In the type signature: f :: TypeError (Text "This is a type error") diff --git a/testsuite/tests/typecheck/should_fail/FDsFromGivens.stderr b/testsuite/tests/typecheck/should_fail/FDsFromGivens.stderr index a2a9928181..a2cab99ae9 100644 --- a/testsuite/tests/typecheck/should_fail/FDsFromGivens.stderr +++ b/testsuite/tests/typecheck/should_fail/FDsFromGivens.stderr @@ -1,17 +1,18 @@ - -FDsFromGivens.hs:9:7: error: - Couldn't match type ‘[a]’ with ‘Bool’ - arising from a functional dependency between constraints: - ‘C Char Bool’ - arising from the type signature for: - g1 :: (C Char [a], C Char Bool) => a -> () - at FDsFromGivens.hs:9:7-42 - ‘C Char [a]’ - arising from the type signature for: - g1 :: (C Char [a], C Char Bool) => a -> () - at FDsFromGivens.hs:9:7-42 - In the ambiguity check for the type signature for ‘g1’: - g1 :: forall a. (C Char [a], C Char Bool) => a -> () - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the type signature for ‘g1’: - g1 :: (C Char [a], C Char Bool) => a -> () +
+FDsFromGivens.hs:9:7: error:
+ Couldn't match type ‘[a]’ with ‘Bool’
+ arising from a functional dependency between constraints:
+ ‘C Char Bool’
+ arising from the type signature for:
+ g1 :: (C Char [a], C Char Bool) => a -> ()
+ at FDsFromGivens.hs:9:7-42
+ ‘C Char [a]’
+ arising from the type signature for:
+ g1 :: (C Char [a], C Char Bool) => a -> ()
+ at FDsFromGivens.hs:9:7-42
+ Inaccessible code in
+ the type signature for:
+ g1 :: (C Char [a], C Char Bool) => a -> ()
+ In the ambiguity check for ‘g1’
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ In the type signature: g1 :: (C Char [a], C Char Bool) => a -> ()
diff --git a/testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.stderr b/testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.stderr index 62354d3f02..b9a2629e32 100644 --- a/testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.stderr +++ b/testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.stderr @@ -1,12 +1,13 @@ - -FailDueToGivenOverlapping.hs:27:9: - Overlapping instances for E [t0] arising from a use of ‘eop’ - Matching givens (or their superclasses): - E [Int] - bound by the type signature for: bar :: E [Int] => () -> () - at FailDueToGivenOverlapping.hs:26:8-26 - Matching instances: - instance E [a] -- Defined at FailDueToGivenOverlapping.hs:21:10 - (The choice depends on the instantiation of ‘t0’) - In the expression: eop [undefined] - In an equation for ‘bar’: bar _ = eop [undefined] +
+FailDueToGivenOverlapping.hs:27:9: error:
+ Overlapping instances for E [t0] arising from a use of ‘eop’
+ Matching givens (or their superclasses):
+ E [Int]
+ bound by the type signature for:
+ bar :: E [Int] => () -> ()
+ at FailDueToGivenOverlapping.hs:26:1-26
+ Matching instances:
+ instance E [a] -- Defined at FailDueToGivenOverlapping.hs:21:10
+ (The choice depends on the instantiation of ‘t0’)
+ In the expression: eop [undefined]
+ In an equation for ‘bar’: bar _ = eop [undefined]
diff --git a/testsuite/tests/typecheck/should_fail/IPFail.stderr b/testsuite/tests/typecheck/should_fail/IPFail.stderr index 963ccd8b54..59aac31632 100644 --- a/testsuite/tests/typecheck/should_fail/IPFail.stderr +++ b/testsuite/tests/typecheck/should_fail/IPFail.stderr @@ -2,8 +2,9 @@ IPFail.hs:6:18: error:
Could not deduce (Num Bool) arising from the literal ‘5’
from the context: ?x::Int
- bound by the type signature for: f0 :: (?x::Int) => () -> Bool
- at IPFail.hs:5:7-31
+ bound by the type signature for:
+ f0 :: (?x::Int) => () -> Bool
+ at IPFail.hs:5:1-31
In the expression: 5
In the expression: let ?x = 5 in ?x
In an equation for ‘f0’: f0 () = let ?x = 5 in ?x
diff --git a/testsuite/tests/typecheck/should_fail/T10285.stderr b/testsuite/tests/typecheck/should_fail/T10285.stderr index d14bc3b427..b7bba0f575 100644 --- a/testsuite/tests/typecheck/should_fail/T10285.stderr +++ b/testsuite/tests/typecheck/should_fail/T10285.stderr @@ -1,20 +1,22 @@ T10285.hs:8:17: error: - Could not deduce: Coercible a b arising from a use of ‘coerce’ - from the context: Coercible (N a) (N b) - bound by a pattern with constructor: - Coercion :: forall (k :: BOX) (a :: k) (b :: k). - Coercible a b => - Coercion a b, - in an equation for ‘oops’ - at T10285.hs:8:6-13 + • Could not deduce: Coercible a b arising from a use of ‘coerce’ + from the context: Coercible (N a) (N b) + bound by a pattern with constructor: + Coercion :: forall (k :: BOX) (a :: k) (b :: k). + Coercible a b => + Coercion a b, + in an equation for ‘oops’ + at T10285.hs:8:6-13 ‘a’ is a rigid type variable bound by - the type signature for: oops :: Coercion (N a) (N b) -> a -> b - at T10285.hs:7:9 + the type signature for: + oops :: forall a b. Coercion (N a) (N b) -> a -> b + at T10285.hs:7:9 ‘b’ is a rigid type variable bound by - the type signature for: oops :: Coercion (N a) (N b) -> a -> b - at T10285.hs:7:9 - In the expression: coerce - In an equation for ‘oops’: oops Coercion = coerce - Relevant bindings include - oops :: Coercion (N a) (N b) -> a -> b (bound at T10285.hs:8:1) + the type signature for: + oops :: forall a b. Coercion (N a) (N b) -> a -> b + at T10285.hs:7:9 + • In the expression: coerce + In an equation for ‘oops’: oops Coercion = coerce + • Relevant bindings include + oops :: Coercion (N a) (N b) -> a -> b (bound at T10285.hs:8:1) diff --git a/testsuite/tests/typecheck/should_fail/T10351.stderr b/testsuite/tests/typecheck/should_fail/T10351.stderr index 58c28e463d..4a9e38eb3e 100644 --- a/testsuite/tests/typecheck/should_fail/T10351.stderr +++ b/testsuite/tests/typecheck/should_fail/T10351.stderr @@ -2,5 +2,5 @@ T10351.hs:6:1: error:
Non type-variable argument in the constraint: C [t]
(Use FlexibleContexts to permit this)
- When checking that ‘f’ has the inferred type
+ When checking the inferred type
f :: forall t. C [t] => t -> ()
diff --git a/testsuite/tests/typecheck/should_fail/T10534.stderr b/testsuite/tests/typecheck/should_fail/T10534.stderr index 41deac7063..ecdb6d2935 100644 --- a/testsuite/tests/typecheck/should_fail/T10534.stderr +++ b/testsuite/tests/typecheck/should_fail/T10534.stderr @@ -1,17 +1,19 @@ T10534a.hs:10:9: error: - Could not deduce: Coercible a b arising from a use of ‘coerce’ - from the context: Coercible (DF a) (DF b) - bound by the type signature for: - silly :: Coercible (DF a) (DF b) => a -> b - at T10534a.hs:9:10-42 + • Could not deduce: Coercible a b arising from a use of ‘coerce’ + from the context: Coercible (DF a) (DF b) + bound by the type signature for: + silly :: Coercible (DF a) (DF b) => a -> b + at T10534a.hs:9:1-42 ‘a’ is a rigid type variable bound by - the type signature for: silly :: Coercible (DF a) (DF b) => a -> b - at T10534a.hs:9:10 + the type signature for: + silly :: forall a b. Coercible (DF a) (DF b) => a -> b + at T10534a.hs:9:10 ‘b’ is a rigid type variable bound by - the type signature for: silly :: Coercible (DF a) (DF b) => a -> b - at T10534a.hs:9:10 - In the expression: coerce - In an equation for ‘silly’: silly = coerce - Relevant bindings include - silly :: a -> b (bound at T10534a.hs:10:1) + the type signature for: + silly :: forall a b. Coercible (DF a) (DF b) => a -> b + at T10534a.hs:9:10 + • In the expression: coerce + In an equation for ‘silly’: silly = coerce + • Relevant bindings include + silly :: a -> b (bound at T10534a.hs:10:1) diff --git a/testsuite/tests/typecheck/should_fail/T10715.stderr b/testsuite/tests/typecheck/should_fail/T10715.stderr index e6f85a5256..0bbaa35573 100644 --- a/testsuite/tests/typecheck/should_fail/T10715.stderr +++ b/testsuite/tests/typecheck/should_fail/T10715.stderr @@ -2,14 +2,13 @@ T10715.hs:9:13: error: Couldn't match representation of type ‘a’ with that of ‘X a’ ‘a’ is a rigid type variable bound by - the type signature for: - doCoerce :: Coercible a (X a) => a -> X a - at T10715.hs:9:13 + the type signature for: + doCoerce :: forall a. Coercible a (X a) => a -> X a + at T10715.hs:9:13 Inaccessible code in the type signature for: doCoerce :: Coercible a (X a) => a -> X a - In the ambiguity check for the type signature for ‘doCoerce’: - doCoerce :: forall a. Coercible a (X a) => a -> X a + In the ambiguity check for ‘doCoerce’ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the type signature for ‘doCoerce’: + In the type signature: doCoerce :: Coercible a (X a) => a -> X a diff --git a/testsuite/tests/typecheck/should_fail/T11112.stderr b/testsuite/tests/typecheck/should_fail/T11112.stderr index da0ab532a7..3534d33b51 100644 --- a/testsuite/tests/typecheck/should_fail/T11112.stderr +++ b/testsuite/tests/typecheck/should_fail/T11112.stderr @@ -1,4 +1,5 @@ T11112.hs:3:9: error: - Constraint ‘Ord s’ used as a type - In the type signature for ‘sort’: sort :: Ord s -> [s] -> [s] + • Constraint ‘Ord s’ used as a type + • In the type signature: + sort :: Ord s -> [s] -> [s] diff --git a/testsuite/tests/typecheck/should_fail/T1897a.stderr b/testsuite/tests/typecheck/should_fail/T1897a.stderr index 5e7a590fa5..101caab6e7 100644 --- a/testsuite/tests/typecheck/should_fail/T1897a.stderr +++ b/testsuite/tests/typecheck/should_fail/T1897a.stderr @@ -1,10 +1,12 @@ - -T1897a.hs:9:1: - Could not deduce (Wob a0 b) - from the context: Wob a b - bound by the inferred type for ‘foo’: Wob a b => b -> [b] - at T1897a.hs:9:1-24 - The type variable ‘a0’ is ambiguous - When checking that ‘foo’ has the inferred type - foo :: forall a b. Wob a b => b -> [b] - Probable cause: the inferred type is ambiguous +
+T1897a.hs:9:1: error:
+ Could not deduce (Wob a0 b)
+ from the context: Wob a b
+ bound by the inferred type for ‘foo’:
+ Wob a b => b -> [b]
+ at T1897a.hs:9:1-24
+ The type variable ‘a0’ is ambiguous
+ In the ambiguity check for the inferred type for ‘foo’
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ When checking the inferred type
+ foo :: forall a b. Wob a b => b -> [b]
diff --git a/testsuite/tests/typecheck/should_fail/T1899.stderr b/testsuite/tests/typecheck/should_fail/T1899.stderr index d41c96a787..8c2964cfc6 100644 --- a/testsuite/tests/typecheck/should_fail/T1899.stderr +++ b/testsuite/tests/typecheck/should_fail/T1899.stderr @@ -1,13 +1,14 @@ T1899.hs:14:36: error: - Couldn't match type ‘a’ with ‘Proposition a0’ + • Couldn't match type ‘a’ with ‘Proposition a0’ ‘a’ is a rigid type variable bound by - the type signature for: transRHS :: [a] -> Int -> Constraint a - at T1899.hs:9:14 - Expected type: [Proposition a0] - Actual type: [a] - In the first argument of ‘Auxiliary’, namely ‘varSet’ - In the first argument of ‘Prop’, namely ‘(Auxiliary varSet)’ - Relevant bindings include - varSet :: [a] (bound at T1899.hs:10:11) - transRHS :: [a] -> Int -> Constraint a (bound at T1899.hs:10:2) + the type signature for: + transRHS :: forall a. [a] -> Int -> Constraint a + at T1899.hs:9:14 + Expected type: [Proposition a0] + Actual type: [a] + • In the first argument of ‘Auxiliary’, namely ‘varSet’ + In the first argument of ‘Prop’, namely ‘(Auxiliary varSet)’ + • Relevant bindings include + varSet :: [a] (bound at T1899.hs:10:11) + transRHS :: [a] -> Int -> Constraint a (bound at T1899.hs:10:2) diff --git a/testsuite/tests/typecheck/should_fail/T2538.stderr b/testsuite/tests/typecheck/should_fail/T2538.stderr index 94583a42b4..a905d95b48 100644 --- a/testsuite/tests/typecheck/should_fail/T2538.stderr +++ b/testsuite/tests/typecheck/should_fail/T2538.stderr @@ -1,14 +1,14 @@ - -T2538.hs:6:6: error: - Illegal polymorphic or qualified type: Eq a => a -> a - Perhaps you intended to use RankNTypes or Rank2Types - In the type signature for ‘f’: f :: (Eq a => a -> a) -> Int - -T2538.hs:9:6: error: - Illegal polymorphic or qualified type: Eq a => a -> a - GHC doesn't yet support impredicative polymorphism - In the type signature for ‘g’: g :: [Eq a => a -> a] -> Int - -T2538.hs:12:6: error: - Illegal polymorphic or qualified type: Eq a => a -> a - In the type signature for ‘h’: h :: Ix (Eq a => a -> a) => Int +
+T2538.hs:6:6: error:
+ Illegal polymorphic or qualified type: Eq a => a -> a
+ Perhaps you intended to use RankNTypes or Rank2Types
+ In the type signature: f :: (Eq a => a -> a) -> Int
+
+T2538.hs:9:6: error:
+ Illegal polymorphic or qualified type: Eq a => a -> a
+ GHC doesn't yet support impredicative polymorphism
+ In the type signature: g :: [Eq a => a -> a] -> Int
+
+T2538.hs:12:6: error:
+ Illegal polymorphic or qualified type: Eq a => a -> a
+ In the type signature: h :: Ix (Eq a => a -> a) => Int
diff --git a/testsuite/tests/typecheck/should_fail/T2714.stderr b/testsuite/tests/typecheck/should_fail/T2714.stderr index 07a925cc10..0991ddeec0 100644 --- a/testsuite/tests/typecheck/should_fail/T2714.stderr +++ b/testsuite/tests/typecheck/should_fail/T2714.stderr @@ -1,9 +1,10 @@ -T2714.hs:8:5:
+T2714.hs:8:5: error:
Couldn't match type ‘a’ with ‘f0 b’
- ‘a’ is a rigid type variable bound by
- the type signature for: f :: ((a -> b) -> b) -> forall c. c -> a
- at T2714.hs:7:6
+ ‘a’ is a rigid type variable bound by
+ the type signature for:
+ f :: forall a b. ((a -> b) -> b) -> forall c. c -> a
+ at T2714.hs:7:6
Expected type: ((a -> b) -> b) -> c -> a
Actual type: ((a -> b) -> b) -> f0 (a -> b) -> f0 b
In the expression: ffmap
@@ -11,11 +12,12 @@ T2714.hs:8:5: Relevant bindings include
f :: ((a -> b) -> b) -> forall c. c -> a (bound at T2714.hs:8:1)
-T2714.hs:8:5:
+T2714.hs:8:5: error:
Couldn't match type ‘c’ with ‘f0 (a -> b)’
- ‘c’ is a rigid type variable bound by
- the type signature for: f :: ((a -> b) -> b) -> c -> a
- at T2714.hs:8:1
+ ‘c’ is a rigid type variable bound by
+ the type signature for:
+ f :: forall c. ((a -> b) -> b) -> c -> a
+ at T2714.hs:8:1
Expected type: ((a -> b) -> b) -> c -> a
Actual type: ((a -> b) -> b) -> f0 (a -> b) -> f0 b
In the expression: ffmap
diff --git a/testsuite/tests/typecheck/should_fail/T3102.stderr b/testsuite/tests/typecheck/should_fail/T3102.stderr index d23a2729c1..925e80f7fc 100644 --- a/testsuite/tests/typecheck/should_fail/T3102.stderr +++ b/testsuite/tests/typecheck/should_fail/T3102.stderr @@ -1,9 +1,11 @@ - -T3102.hs:11:12: - Couldn't match type ‘a’ with ‘(?p::Int) => a0’ - ‘a’ is a rigid type variable bound by - a type expected by the context: a -> String at T3102.hs:11:10 - Expected type: a -> String - Actual type: ((?p::Int) => a0) -> String - In the first argument of ‘f’, namely ‘t’ - In the expression: f t +
+T3102.hs:11:12: error:
+ Couldn't match type ‘a’ with ‘(?p::Int) => a0’
+ ‘a’ is a rigid type variable bound by
+ a type expected by the context:
+ forall a. a -> String
+ at T3102.hs:11:10
+ Expected type: a -> String
+ Actual type: ((?p::Int) => a0) -> String
+ In the first argument of ‘f’, namely ‘t’
+ In the expression: f t
diff --git a/testsuite/tests/typecheck/should_fail/T3540.stderr b/testsuite/tests/typecheck/should_fail/T3540.stderr index 9867b7401e..75c9dc2ea1 100644 --- a/testsuite/tests/typecheck/should_fail/T3540.stderr +++ b/testsuite/tests/typecheck/should_fail/T3540.stderr @@ -1,20 +1,25 @@ T3540.hs:4:12: error: - Constraint ‘a ~ Int’ used as a type - In the type signature for ‘thing’: thing :: a ~ Int + • Constraint ‘a ~ Int’ used as a type + • In the type signature: + thing :: a ~ Int T3540.hs:7:20: error: - Constraint ‘a ~ Int’ used as a type - In the type signature for ‘thing1’: thing1 :: Int -> (a ~ Int) + • Constraint ‘a ~ Int’ used as a type + • In the type signature: + thing1 :: Int -> (a ~ Int) T3540.hs:10:13: error: - Constraint ‘a ~ Int’ used as a type - In the type signature for ‘thing2’: thing2 :: (a ~ Int) -> Int + • Constraint ‘a ~ Int’ used as a type + • In the type signature: + thing2 :: (a ~ Int) -> Int T3540.hs:13:12: error: - Constraint ‘?dude :: Int’ used as a type - In the type signature for ‘thing3’: thing3 :: (?dude :: Int) -> Int + • Constraint ‘?dude :: Int’ used as a type + • In the type signature: + thing3 :: (?dude :: Int) -> Int T3540.hs:16:11: error: - Constraint ‘Eq a’ used as a type - In the type signature for ‘thing4’: thing4 :: (Eq a) -> Int + • Constraint ‘Eq a’ used as a type + • In the type signature: + thing4 :: (Eq a) -> Int diff --git a/testsuite/tests/typecheck/should_fail/T4875.stderr b/testsuite/tests/typecheck/should_fail/T4875.stderr index 6f885d24fe..98584a44f0 100644 --- a/testsuite/tests/typecheck/should_fail/T4875.stderr +++ b/testsuite/tests/typecheck/should_fail/T4875.stderr @@ -1,5 +1,5 @@ - -T4875.hs:27:24: - ‘r’ is applied to too many type arguments - In the type ‘r c -> [c]’ - In the class declaration for ‘Morphic’ +
+T4875.hs:27:24: error:
+ ‘r’ is applied to too many type arguments
+ In the type signature: multiplicities :: r c -> [c]
+ In the class declaration for ‘Morphic’
diff --git a/testsuite/tests/typecheck/should_fail/T5236.stderr b/testsuite/tests/typecheck/should_fail/T5236.stderr index c1cbae3699..825218c926 100644 --- a/testsuite/tests/typecheck/should_fail/T5236.stderr +++ b/testsuite/tests/typecheck/should_fail/T5236.stderr @@ -1,11 +1,14 @@ -T5236.hs:13:9:
+T5236.hs:13:9: error:
Couldn't match type ‘B’ with ‘A’
- arising from a functional dependency between:
- constraint ‘Id A B’
- arising from the type signature for: loop :: Id A B => Bool
- instance ‘Id B B’ at T5236.hs:11:10-15
- In the ambiguity check for the type signature for ‘loop’:
- loop :: Id A B => Bool
+ arising from a functional dependency between:
+ constraint ‘Id A B’
+ arising from the type signature for:
+ loop :: Id A B => Bool
+ instance ‘Id B B’ at T5236.hs:11:10-15
+ Inaccessible code in
+ the type signature for:
+ loop :: Id A B => Bool
+ In the ambiguity check for ‘loop’
To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
- In the type signature for ‘loop’: loop :: Id A B => Bool
+ In the type signature: loop :: Id A B => Bool
diff --git a/testsuite/tests/typecheck/should_fail/T5300.stderr b/testsuite/tests/typecheck/should_fail/T5300.stderr index 524edc4446..f751249677 100644 --- a/testsuite/tests/typecheck/should_fail/T5300.stderr +++ b/testsuite/tests/typecheck/should_fail/T5300.stderr @@ -6,12 +6,9 @@ T5300.hs:11:7: error: f1 :: (Monad m, C1 a b c) => a -> StateT (T b) m a at T5300.hs:11:7-50 The type variable ‘c0’ is ambiguous - • In the ambiguity check for the type signature for ‘f1’: - f1 :: forall a b (m :: * -> *) c. - (Monad m, C1 a b c) => - a -> StateT (T b) m a + • In the ambiguity check for ‘f1’ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the type signature for ‘f1’: + In the type signature: f1 :: (Monad m, C1 a b c) => a -> StateT (T b) m a T5300.hs:14:7: error: @@ -22,11 +19,8 @@ T5300.hs:14:7: error: a1 -> StateT (T b2) m a2 at T5300.hs:14:7-69 The type variable ‘c20’ is ambiguous - • In the ambiguity check for the type signature for ‘f2’: - f2 :: forall a1 b2 (m :: * -> *) a2 b1 c1 c2. - (Monad m, C1 a1 b1 c1, C2 a2 b2 c2) => - a1 -> StateT (T b2) m a2 + • In the ambiguity check for ‘f2’ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the type signature for ‘f2’: + In the type signature: f2 :: (Monad m, C1 a1 b1 c1, C2 a2 b2 c2) => a1 -> StateT (T b2) m a2 diff --git a/testsuite/tests/typecheck/should_fail/T5957.stderr b/testsuite/tests/typecheck/should_fail/T5957.stderr index 1c457ad6fb..c960ba9689 100644 --- a/testsuite/tests/typecheck/should_fail/T5957.stderr +++ b/testsuite/tests/typecheck/should_fail/T5957.stderr @@ -1,6 +1,5 @@ - -T5957.hs:3:9: - Illegal polymorphic or qualified type: Show a => a -> String - Perhaps you intended to use RankNTypes or Rank2Types - In the type signature for ‘flex’: - flex :: Int -> Show a => a -> String +
+T5957.hs:3:9: error:
+ Illegal polymorphic or qualified type: Show a => a -> String
+ Perhaps you intended to use RankNTypes or Rank2Types
+ In the type signature: flex :: Int -> Show a => a -> String
diff --git a/testsuite/tests/typecheck/should_fail/T6022.stderr b/testsuite/tests/typecheck/should_fail/T6022.stderr index a3cd78e2e1..61d44b2497 100644 --- a/testsuite/tests/typecheck/should_fail/T6022.stderr +++ b/testsuite/tests/typecheck/should_fail/T6022.stderr @@ -2,5 +2,5 @@ T6022.hs:3:1: error:
Non type-variable argument in the constraint: Eq ([a] -> a)
(Use FlexibleContexts to permit this)
- When checking that ‘f’ has the inferred type
+ When checking the inferred type
f :: forall a. Eq ([a] -> a) => ([a] -> a) -> Bool
diff --git a/testsuite/tests/typecheck/should_fail/T7279.stderr b/testsuite/tests/typecheck/should_fail/T7279.stderr index 33af730620..ca30f48069 100644 --- a/testsuite/tests/typecheck/should_fail/T7279.stderr +++ b/testsuite/tests/typecheck/should_fail/T7279.stderr @@ -1,11 +1,10 @@ - -T7279.hs:6:10: - Could not deduce (Show b0) - from the context: (Eq a, Show b) - bound by an instance declaration: (Eq a, Show b) => Eq (T a) - at T7279.hs:6:10-35 - The type variable ‘b0’ is ambiguous - In the ambiguity check for an instance declaration: - forall a b. (Eq a, Show b) => Eq (T a) - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the instance declaration for ‘Eq (T a)’ +
+T7279.hs:6:10: error:
+ Could not deduce (Show b0)
+ from the context: (Eq a, Show b)
+ bound by an instance declaration: (Eq a, Show b) => Eq (T a)
+ at T7279.hs:6:10-35
+ The type variable ‘b0’ is ambiguous
+ In the ambiguity check for an instance declaration
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ In the instance declaration for ‘Eq (T a)’
diff --git a/testsuite/tests/typecheck/should_fail/T7410.stderr b/testsuite/tests/typecheck/should_fail/T7410.stderr index 8126362633..46c7a8c2fc 100644 --- a/testsuite/tests/typecheck/should_fail/T7410.stderr +++ b/testsuite/tests/typecheck/should_fail/T7410.stderr @@ -1,6 +1,6 @@ - -T7410.hs:3:9: - Expecting one more argument to ‘Either Int’ - The first argument of a tuple should have kind ‘*’, - but ‘Either Int’ has kind ‘* -> *’ - In the type signature for ‘foo’: foo :: (Either Int, Int) +
+T7410.hs:3:9: error:
+ Expecting one more argument to ‘Either Int’
+ The first argument of a tuple should have kind ‘*’,
+ but ‘Either Int’ has kind ‘* -> *’
+ In the type signature: foo :: (Either Int, Int)
diff --git a/testsuite/tests/typecheck/should_fail/T7453.stderr b/testsuite/tests/typecheck/should_fail/T7453.stderr index 4ca1218772..d3b76c54bf 100644 --- a/testsuite/tests/typecheck/should_fail/T7453.stderr +++ b/testsuite/tests/typecheck/should_fail/T7453.stderr @@ -1,45 +1,48 @@ T7453.hs:10:30: error: - Couldn't match expected type ‘t1’ with actual type ‘t’ - because type variable ‘t1’ would escape its scope - This (rigid, skolem) type variable is bound by - the type signature for: z :: Id t1 - at T7453.hs:8:16-19 - In the first argument of ‘Id’, namely ‘v’ - In the expression: Id v - Relevant bindings include - aux :: Id t1 (bound at T7453.hs:10:21) - z :: Id t1 (bound at T7453.hs:9:11) - v :: t (bound at T7453.hs:7:7) - cast1 :: t -> a (bound at T7453.hs:7:1) + • Couldn't match expected type ‘t1’ with actual type ‘t’ + because type variable ‘t1’ would escape its scope + This (rigid, skolem) type variable is bound by + the type signature for: + z :: Id t1 + at T7453.hs:8:11-19 + • In the first argument of ‘Id’, namely ‘v’ + In the expression: Id v + • Relevant bindings include + aux :: Id t1 (bound at T7453.hs:10:21) + z :: Id t1 (bound at T7453.hs:9:11) + v :: t (bound at T7453.hs:7:7) + cast1 :: t -> a (bound at T7453.hs:7:1) T7453.hs:16:33: error: - Couldn't match expected type ‘t2’ with actual type ‘t’ - because type variable ‘t2’ would escape its scope - This (rigid, skolem) type variable is bound by - the type signature for: z :: () -> t2 - at T7453.hs:14:16-22 - In the first argument of ‘const’, namely ‘v’ - In the expression: const v - Relevant bindings include - aux :: b -> t2 (bound at T7453.hs:16:21) - z :: () -> t2 (bound at T7453.hs:15:11) - v :: t (bound at T7453.hs:13:7) - cast2 :: t -> t1 (bound at T7453.hs:13:1) + • Couldn't match expected type ‘t2’ with actual type ‘t’ + because type variable ‘t2’ would escape its scope + This (rigid, skolem) type variable is bound by + the type signature for: + z :: () -> t2 + at T7453.hs:14:11-22 + • In the first argument of ‘const’, namely ‘v’ + In the expression: const v + • Relevant bindings include + aux :: b -> t2 (bound at T7453.hs:16:21) + z :: () -> t2 (bound at T7453.hs:15:11) + v :: t (bound at T7453.hs:13:7) + cast2 :: t -> t1 (bound at T7453.hs:13:1) T7453.hs:21:15: error: - Couldn't match expected type ‘t2’ with actual type ‘t’ - because type variable ‘t2’ would escape its scope - This (rigid, skolem) type variable is bound by - the type signature for: z :: t2 - at T7453.hs:20:16 - In the expression: v - In an equation for ‘z’: - z = v - where - aux = const v - Relevant bindings include - aux :: forall b. b -> t2 (bound at T7453.hs:22:21) - z :: t2 (bound at T7453.hs:21:11) - v :: t (bound at T7453.hs:19:7) - cast3 :: t -> t1 (bound at T7453.hs:19:1) + • Couldn't match expected type ‘t2’ with actual type ‘t’ + because type variable ‘t2’ would escape its scope + This (rigid, skolem) type variable is bound by + the type signature for: + z :: t2 + at T7453.hs:20:11-16 + • In the expression: v + In an equation for ‘z’: + z = v + where + aux = const v + • Relevant bindings include + aux :: forall b. b -> t2 (bound at T7453.hs:22:21) + z :: t2 (bound at T7453.hs:21:11) + v :: t (bound at T7453.hs:19:7) + cast3 :: t -> t1 (bound at T7453.hs:19:1) diff --git a/testsuite/tests/typecheck/should_fail/T7609.stderr b/testsuite/tests/typecheck/should_fail/T7609.stderr index b02dbe20f8..c5ed9fcad9 100644 --- a/testsuite/tests/typecheck/should_fail/T7609.stderr +++ b/testsuite/tests/typecheck/should_fail/T7609.stderr @@ -1,10 +1,10 @@ - -T7609.hs:7:16: - Expecting one more argument to ‘Maybe’ - The second argument of a tuple should have kind ‘*’, - but ‘Maybe’ has kind ‘* -> *’ - In the type signature for ‘f’: f :: (a `X` a, Maybe) - -T7609.hs:10:7: - Expected a constraint, but ‘a `X` a’ has kind ‘*’ - In the type signature for ‘g’: g :: (a `X` a) => Maybe +
+T7609.hs:7:16: error:
+ Expecting one more argument to ‘Maybe’
+ The second argument of a tuple should have kind ‘*’,
+ but ‘Maybe’ has kind ‘* -> *’
+ In the type signature: f :: (a `X` a, Maybe)
+
+T7609.hs:10:7: error:
+ Expected a constraint, but ‘a `X` a’ has kind ‘*’
+ In the type signature: g :: (a `X` a) => Maybe
diff --git a/testsuite/tests/typecheck/should_fail/T7645.stderr b/testsuite/tests/typecheck/should_fail/T7645.stderr index 12d6c15e49..17420143f8 100644 --- a/testsuite/tests/typecheck/should_fail/T7645.stderr +++ b/testsuite/tests/typecheck/should_fail/T7645.stderr @@ -1,6 +1,6 @@ - -T7645.hs:6:23: - Expecting one more argument to ‘Maybe’ - The second argument of a tuple should have kind ‘*’, - but ‘Maybe’ has kind ‘* -> *’ - In the type signature for ‘f’: f :: ((+) a (a :: *), Maybe) +
+T7645.hs:6:23: error:
+ Expecting one more argument to ‘Maybe’
+ The second argument of a tuple should have kind ‘*’,
+ but ‘Maybe’ has kind ‘* -> *’
+ In the type signature: f :: ((+) a (a :: *), Maybe)
diff --git a/testsuite/tests/typecheck/should_fail/T7696.stderr b/testsuite/tests/typecheck/should_fail/T7696.stderr index 73da26c4f4..41f2296797 100644 --- a/testsuite/tests/typecheck/should_fail/T7696.stderr +++ b/testsuite/tests/typecheck/should_fail/T7696.stderr @@ -1,11 +1,7 @@ T7696.hs:7:6: error: - Couldn't match kind ‘* -> *’ with ‘*’ - When matching types - t0 :: (* -> *) -> * - w :: * -> * - Expected type: ((), w ()) - Actual type: (m0 a0, t0 m0) - In the expression: f1 - In an equation for ‘f2’: f2 = f1 - Relevant bindings include f2 :: ((), w ()) (bound at T7696.hs:7:1) + • Couldn't match type ‘m0 a0’ with ‘()’ + Expected type: ((), w ()) + Actual type: (m0 a0, t0 m0) + • In the expression: f1 + In an equation for ‘f2’: f2 = f1 diff --git a/testsuite/tests/typecheck/should_fail/T7697.stderr b/testsuite/tests/typecheck/should_fail/T7697.stderr index 477acc1d09..47d8336588 100644 --- a/testsuite/tests/typecheck/should_fail/T7697.stderr +++ b/testsuite/tests/typecheck/should_fail/T7697.stderr @@ -1,4 +1,4 @@ - -T7697.hs:3:6: - Expected a constraint, but ‘Int’ has kind ‘*’ - In the type signature for ‘f’: f :: Int => Int +
+T7697.hs:3:6: error:
+ Expected a constraint, but ‘Int’ has kind ‘*’
+ In the type signature: f :: Int => Int
diff --git a/testsuite/tests/typecheck/should_fail/T7748a.stderr b/testsuite/tests/typecheck/should_fail/T7748a.stderr index 5e546b171a..2f4c35598f 100644 --- a/testsuite/tests/typecheck/should_fail/T7748a.stderr +++ b/testsuite/tests/typecheck/should_fail/T7748a.stderr @@ -1,18 +1,20 @@ -T7748a.hs:16:24: - Couldn't match expected type ‘a’ - with actual type ‘Maybe (Maybe (r -> ()))’ +T7748a.hs:16:24: error: + • Couldn't match expected type ‘a’ + with actual type ‘Maybe (Maybe (r -> ()))’ ‘a’ is a rigid type variable bound by - the type signature for: test :: a -> r -> () at T7748a.hs:11:9 - In the pattern: Just (Just p) - In a case alternative: Just (Just p) -> p - In the expression: - case zd of { - Nothing -> const () - Just Nothing -> const () - Just (Just p) -> p } - Relevant bindings include - g :: r -> () (bound at T7748a.hs:13:16) - f :: r -> () (bound at T7748a.hs:13:8) - zd :: a (bound at T7748a.hs:12:6) - test :: a -> r -> () (bound at T7748a.hs:12:1) + the type signature for: + test :: forall a r. a -> r -> () + at T7748a.hs:11:9 + • In the pattern: Just (Just p) + In a case alternative: Just (Just p) -> p + In the expression: + case zd of { + Nothing -> const () + Just Nothing -> const () + Just (Just p) -> p } + • Relevant bindings include + g :: r -> () (bound at T7748a.hs:13:16) + f :: r -> () (bound at T7748a.hs:13:8) + zd :: a (bound at T7748a.hs:12:6) + test :: a -> r -> () (bound at T7748a.hs:12:1) diff --git a/testsuite/tests/typecheck/should_fail/T7778.stderr b/testsuite/tests/typecheck/should_fail/T7778.stderr index 136625af75..7538c15cce 100644 --- a/testsuite/tests/typecheck/should_fail/T7778.stderr +++ b/testsuite/tests/typecheck/should_fail/T7778.stderr @@ -1,5 +1,5 @@ - -T7778.hs:3:19: - Expecting one more argument to ‘Num’ - Expected a type, but ‘Num’ has kind ‘* -> Constraint’ - In the type signature for ‘v’: v :: ((Num Int => Num) ()) => () +
+T7778.hs:3:19: error:
+ Expecting one more argument to ‘Num’
+ Expected a type, but ‘Num’ has kind ‘* -> Constraint’
+ In the type signature: v :: ((Num Int => Num) ()) => ()
diff --git a/testsuite/tests/typecheck/should_fail/T7809.stderr b/testsuite/tests/typecheck/should_fail/T7809.stderr index 153c4d1c1f..aa44b44676 100644 --- a/testsuite/tests/typecheck/should_fail/T7809.stderr +++ b/testsuite/tests/typecheck/should_fail/T7809.stderr @@ -1,5 +1,5 @@ - -T7809.hs:8:8: error: - Illegal polymorphic or qualified type: PolyId - GHC doesn't yet support impredicative polymorphism - In the type signature for ‘foo’: foo :: F PolyId +
+T7809.hs:8:8: error:
+ Illegal polymorphic or qualified type: PolyId
+ GHC doesn't yet support impredicative polymorphism
+ In the type signature: foo :: F PolyId
diff --git a/testsuite/tests/typecheck/should_fail/T7869.stderr b/testsuite/tests/typecheck/should_fail/T7869.stderr index 74a483602d..6431c274e5 100644 --- a/testsuite/tests/typecheck/should_fail/T7869.stderr +++ b/testsuite/tests/typecheck/should_fail/T7869.stderr @@ -26,3 +26,4 @@ T7869.hs:3:12: In the expression: (\ x -> f x) :: [a] -> b In an equation for ‘f’: f = (\ x -> f x) :: [a] -> b Relevant bindings include f :: [a] -> b (bound at T7869.hs:3:1) + diff --git a/testsuite/tests/typecheck/should_fail/T8030.stderr b/testsuite/tests/typecheck/should_fail/T8030.stderr index 24c9d59ff7..c6c05f8cf1 100644 --- a/testsuite/tests/typecheck/should_fail/T8030.stderr +++ b/testsuite/tests/typecheck/should_fail/T8030.stderr @@ -3,8 +3,7 @@ T8030.hs:9:3: error: • Couldn't match expected type ‘Pr a’ with actual type ‘Pr a0’ NB: ‘Pr’ is a type function, and may not be injective The type variable ‘a0’ is ambiguous - • In the ambiguity check for the type signature for ‘op1’: - op1 :: forall (k :: BOX) (a :: k). C a => Pr a + • In the ambiguity check for ‘op1’ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes When checking the class method: op1 :: forall (k :: BOX) (a :: k). C a => Pr a @@ -16,8 +15,7 @@ T8030.hs:10:3: error: The type variable ‘a0’ is ambiguous Expected type: Pr a -> Pr a -> Pr a Actual type: Pr a0 -> Pr a0 -> Pr a0 - • In the ambiguity check for the type signature for ‘op2’: - op2 :: forall (k :: BOX) (a :: k). C a => Pr a -> Pr a -> Pr a + • In the ambiguity check for ‘op2’ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes When checking the class method: op2 :: forall (k :: BOX) (a :: k). C a => Pr a -> Pr a -> Pr a diff --git a/testsuite/tests/typecheck/should_fail/T8034.stderr b/testsuite/tests/typecheck/should_fail/T8034.stderr index cea9dbc18c..77a60294ce 100644 --- a/testsuite/tests/typecheck/should_fail/T8034.stderr +++ b/testsuite/tests/typecheck/should_fail/T8034.stderr @@ -1,12 +1,11 @@ - -T8034.hs:6:3: error: - Couldn't match type ‘F a0’ with ‘F a’ - NB: ‘F’ is a type function, and may not be injective - The type variable ‘a0’ is ambiguous - Expected type: F a -> F a - Actual type: F a0 -> F a0 - In the ambiguity check for the type signature for ‘foo’: - foo :: forall a. C a => F a -> F a - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - When checking the class method: foo :: forall a. C a => F a -> F a - In the class declaration for ‘C’ +
+T8034.hs:6:3: error:
+ Couldn't match type ‘F a0’ with ‘F a’
+ NB: ‘F’ is a type function, and may not be injective
+ The type variable ‘a0’ is ambiguous
+ Expected type: F a -> F a
+ Actual type: F a0 -> F a0
+ In the ambiguity check for ‘foo’
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ When checking the class method: foo :: forall a. C a => F a -> F a
+ In the class declaration for ‘C’
diff --git a/testsuite/tests/typecheck/should_fail/T8142.stderr b/testsuite/tests/typecheck/should_fail/T8142.stderr index 93b2bf4914..9ae86c5524 100644 --- a/testsuite/tests/typecheck/should_fail/T8142.stderr +++ b/testsuite/tests/typecheck/should_fail/T8142.stderr @@ -5,9 +5,10 @@ T8142.hs:6:18: error: The type variable ‘g0’ is ambiguous Expected type: Nu ((,) t) -> Nu g Actual type: Nu ((,) t0) -> Nu g0 - When checking that ‘h’ has the inferred type + In the ambiguity check for the inferred type for ‘h’ + To defer the ambiguity check to use sites, enable AllowAmbiguousTypes + When checking the inferred type h :: forall t (g :: * -> *). Nu ((,) t) -> Nu g - Probable cause: the inferred type is ambiguous In an equation for ‘tracer’: tracer = h diff --git a/testsuite/tests/typecheck/should_fail/T8392a.stderr b/testsuite/tests/typecheck/should_fail/T8392a.stderr index 290ae86a00..6795d9bd94 100644 --- a/testsuite/tests/typecheck/should_fail/T8392a.stderr +++ b/testsuite/tests/typecheck/should_fail/T8392a.stderr @@ -1,8 +1,8 @@ -T8392a.hs:6:8:
+T8392a.hs:6:8: error:
Couldn't match type ‘Int’ with ‘Bool’
Inaccessible code in
- the type signature for: foo :: (Int ~ Bool) => a -> a
- In the ambiguity check for the type signature for ‘foo’:
- foo :: forall a. (Int ~ Bool) => a -> a
- In the type signature for ‘foo’: foo :: (Int ~ Bool) => a -> a
+ the type signature for:
+ foo :: (Int ~ Bool) => a -> a
+ In the ambiguity check for ‘foo’
+ In the type signature: foo :: (Int ~ Bool) => a -> a
diff --git a/testsuite/tests/typecheck/should_fail/T8450.stderr b/testsuite/tests/typecheck/should_fail/T8450.stderr index 9cc70fa0df..5697e4db2b 100644 --- a/testsuite/tests/typecheck/should_fail/T8450.stderr +++ b/testsuite/tests/typecheck/should_fail/T8450.stderr @@ -1,9 +1,11 @@ -T8450.hs:8:7: - Couldn't match expected type ‘a’ with actual type ‘()’ +T8450.hs:8:7: error: + • Couldn't match expected type ‘a’ with actual type ‘()’ ‘a’ is a rigid type variable bound by - the type signature for: run :: a at T8450.hs:7:15 - In the expression: runEffect $ (undefined :: Either a ()) - In an equation for ‘run’: - run = runEffect $ (undefined :: Either a ()) - Relevant bindings include run :: a (bound at T8450.hs:8:1) + the type signature for: + run :: forall a. a + at T8450.hs:7:15 + • In the expression: runEffect $ (undefined :: Either a ()) + In an equation for ‘run’: + run = runEffect $ (undefined :: Either a ()) + • Relevant bindings include run :: a (bound at T8450.hs:8:1) diff --git a/testsuite/tests/typecheck/should_fail/T8603.stderr b/testsuite/tests/typecheck/should_fail/T8603.stderr index 2aaf55b3ff..a3d17ceb56 100644 --- a/testsuite/tests/typecheck/should_fail/T8603.stderr +++ b/testsuite/tests/typecheck/should_fail/T8603.stderr @@ -1,21 +1,30 @@ T8603.hs:13:10: error: - No instance for (Applicative RV) - arising from the superclasses of an instance declaration - In the instance declaration for ‘Monad RV’ + • No instance for (Applicative RV) + arising from the superclasses of an instance declaration + • In the instance declaration for ‘Monad RV’ T8603.hs:29:17: error: - Couldn't match kind ‘* -> *’ with ‘*’ - When matching types - t1 :: (* -> *) -> * -> * - (->) :: * -> * -> * - Expected type: [Integer] -> StateT s RV t0 - Actual type: t1 ((->) [a0]) (StateT s RV t0) - The function ‘lift’ is applied to two arguments, - but its type ‘([a0] -> StateT s RV t0) - -> t1 ((->) [a0]) (StateT s RV t0)’ - has only one - In a stmt of a 'do' block: prize <- lift uniform [1, 2, 3] - In the expression: - do { prize <- lift uniform [1, 2, ....]; - return False } + • Couldn't match kind ‘* -> *’ with ‘*’ + When matching types + t1 :: (* -> *) -> * -> * + (->) :: * -> * -> * + Expected type: [Integer] -> StateT s RV t0 + Actual type: t1 ((->) [a0]) (StateT s RV t0) + • The function ‘lift’ is applied to two arguments, + but its type ‘([a0] -> StateT s RV t0) + -> t1 ((->) [a0]) (StateT s RV t0)’ + has only one + In a stmt of a 'do' block: prize <- lift uniform [1, 2, 3] + In the expression: + do { prize <- lift uniform [1, 2, ....]; + return False } + +T8603.hs:29:22: error: + • Couldn't match type ‘RV a0’ with ‘StateT s RV t0’ + Expected type: [a0] -> StateT s RV t0 + Actual type: [a0] -> RV a0 + • In the first argument of ‘lift’, namely ‘uniform’ + In a stmt of a 'do' block: prize <- lift uniform [1, 2, 3] + • Relevant bindings include + testRVState1 :: RVState s Bool (bound at T8603.hs:28:1) diff --git a/testsuite/tests/typecheck/should_fail/T8806.stderr b/testsuite/tests/typecheck/should_fail/T8806.stderr index ab88b7f2eb..0131dbd929 100644 --- a/testsuite/tests/typecheck/should_fail/T8806.stderr +++ b/testsuite/tests/typecheck/should_fail/T8806.stderr @@ -1,8 +1,8 @@ - -T8806.hs:5:6: - Expected a constraint, but ‘Int’ has kind ‘*’ - In the type signature for ‘f’: f :: Int => Int - -T8806.hs:8:7: - Illegal constraint: Int => Show a - In the type signature for ‘g’: g :: (Int => Show a) => Int +
+T8806.hs:5:6: error:
+ Expected a constraint, but ‘Int’ has kind ‘*’
+ In the type signature: f :: Int => Int
+
+T8806.hs:8:7: error:
+ Expected a constraint, but ‘Int’ has kind ‘*’
+ In the type signature: g :: (Int => Show a) => Int
diff --git a/testsuite/tests/typecheck/should_fail/T8883.stderr b/testsuite/tests/typecheck/should_fail/T8883.stderr index 3f0a43033b..b18a97acb1 100644 --- a/testsuite/tests/typecheck/should_fail/T8883.stderr +++ b/testsuite/tests/typecheck/should_fail/T8883.stderr @@ -2,7 +2,7 @@ T8883.hs:20:1: error:
Non type-variable argument in the constraint: Functor (PF a)
(Use FlexibleContexts to permit this)
- When checking that ‘fold’ has the inferred type
+ When checking the inferred type
fold :: forall b a.
(Functor (PF a), Regular a) =>
(PF a b -> b) -> a -> b
diff --git a/testsuite/tests/typecheck/should_fail/T9196.stderr b/testsuite/tests/typecheck/should_fail/T9196.stderr index 6f5a204edd..fd10f24875 100644 --- a/testsuite/tests/typecheck/should_fail/T9196.stderr +++ b/testsuite/tests/typecheck/should_fail/T9196.stderr @@ -1,8 +1,8 @@ - -T9196.hs:4:7: - Illegal constraint: forall a. Eq a - In the type signature for ‘f’: f :: (forall a. Eq a) => a -> a - -T9196.hs:7:7: - Illegal constraint: Eq a => Ord a - In the type signature for ‘g’: g :: (Eq a => Ord a) => a -> a +
+T9196.hs:4:7: error:
+ Illegal constraint: forall a. Eq a
+ In the type signature: f :: (forall a. Eq a) => a -> a
+
+T9196.hs:7:7: error:
+ Expected a constraint, but ‘Eq a => Ord a’ has kind ‘*’
+ In the type signature: g :: (Eq a => Ord a) => a -> a
diff --git a/testsuite/tests/typecheck/should_fail/T9201.stderr b/testsuite/tests/typecheck/should_fail/T9201.stderr index 5f16dcaedd..2f1d0a2dae 100644 --- a/testsuite/tests/typecheck/should_fail/T9201.stderr +++ b/testsuite/tests/typecheck/should_fail/T9201.stderr @@ -2,5 +2,5 @@ T9201.hs:6:17: error: The first argument of ‘f’ should have kind ‘x1’, but ‘a’ has kind ‘y1’ - In the type ‘d a (f a)’ + In the type signature: ret :: d a (f a) In the class declaration for ‘MonoidalCCC’ diff --git a/testsuite/tests/typecheck/should_fail/mc19.stderr b/testsuite/tests/typecheck/should_fail/mc19.stderr index f8ca03f2f8..8cdd4f456b 100644 --- a/testsuite/tests/typecheck/should_fail/mc19.stderr +++ b/testsuite/tests/typecheck/should_fail/mc19.stderr @@ -1,9 +1,11 @@ - -mc19.hs:10:31: - Couldn't match type ‘a’ with ‘[a]’ - ‘a’ is a rigid type variable bound by - a type expected by the context: [a] -> [a] at mc19.hs:10:10 - Expected type: [a] -> [a] - Actual type: [a] -> [[a]] - In the expression: inits - In a stmt of a monad comprehension: then inits +
+mc19.hs:10:31: error:
+ Couldn't match type ‘a’ with ‘[a]’
+ ‘a’ is a rigid type variable bound by
+ a type expected by the context:
+ forall a. [a] -> [a]
+ at mc19.hs:10:10
+ Expected type: [a] -> [a]
+ Actual type: [a] -> [[a]]
+ In the expression: inits
+ In a stmt of a monad comprehension: then inits
diff --git a/testsuite/tests/typecheck/should_fail/mc21.stderr b/testsuite/tests/typecheck/should_fail/mc21.stderr index 950506543a..3017d2221c 100644 --- a/testsuite/tests/typecheck/should_fail/mc21.stderr +++ b/testsuite/tests/typecheck/should_fail/mc21.stderr @@ -1,9 +1,11 @@ - -mc21.hs:12:26: - Couldn't match type ‘a’ with ‘[a]’ - ‘a’ is a rigid type variable bound by - a type expected by the context: [a] -> [[a]] at mc21.hs:11:9 - Expected type: [a] -> [[a]] - Actual type: [[a]] -> [[a]] - In the expression: take 5 - In a stmt of a monad comprehension: then group using take 5 +
+mc21.hs:12:26: error:
+ Couldn't match type ‘a’ with ‘[a]’
+ ‘a’ is a rigid type variable bound by
+ a type expected by the context:
+ forall a. [a] -> [[a]]
+ at mc21.hs:11:9
+ Expected type: [a] -> [[a]]
+ Actual type: [[a]] -> [[a]]
+ In the expression: take 5
+ In a stmt of a monad comprehension: then group using take 5
diff --git a/testsuite/tests/typecheck/should_fail/mc22.stderr b/testsuite/tests/typecheck/should_fail/mc22.stderr index aab0c1bdc3..1c6dc386dd 100644 --- a/testsuite/tests/typecheck/should_fail/mc22.stderr +++ b/testsuite/tests/typecheck/should_fail/mc22.stderr @@ -1,19 +1,22 @@ -mc22.hs:9:9:
+mc22.hs:9:9: error:
No instance for (Functor t) arising from a use of ‘fmap’
Possible fix:
add (Functor t) to the context of
- a type expected by the context: (a -> b) -> t a -> t b
+ a type expected by the context:
+ (a -> b) -> t a -> t b
or the inferred type of foo :: [t [Char]]
In the expression: fmap
In a stmt of a monad comprehension: then group using take 5
In the expression:
[x + 1 | x <- ["Hello", "World"], then group using take 5]
-mc22.hs:10:26:
+mc22.hs:10:26: error:
Couldn't match type ‘a’ with ‘t a’
- ‘a’ is a rigid type variable bound by
- a type expected by the context: [a] -> [t a] at mc22.hs:9:9
+ ‘a’ is a rigid type variable bound by
+ a type expected by the context:
+ forall a. [a] -> [t a]
+ at mc22.hs:9:9
Expected type: [a] -> [t a]
Actual type: [t a] -> [t a]
In the expression: take 5
diff --git a/testsuite/tests/typecheck/should_fail/tcfail032.stderr b/testsuite/tests/typecheck/should_fail/tcfail032.stderr index 90888af1b2..649acb0b07 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail032.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail032.stderr @@ -10,3 +10,4 @@ tcfail032.hs:14:8: Relevant bindings include x :: t (bound at tcfail032.hs:14:3) f :: t -> a -> Int (bound at tcfail032.hs:14:1) + diff --git a/testsuite/tests/typecheck/should_fail/tcfail034.stderr b/testsuite/tests/typecheck/should_fail/tcfail034.stderr index f984848ea7..1a8d6d7802 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail034.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail034.stderr @@ -1,12 +1,14 @@ - -tcfail034.hs:17:13: - Could not deduce (Integral a) arising from a use of ‘mod’ - from the context: (Num a, Eq a) - bound by the type signature for: test :: (Num a, Eq a) => a -> Bool - at tcfail034.hs:16:7-32 - Possible fix: - add (Integral a) to the context of - the type signature for: test :: (Num a, Eq a) => a -> Bool - In the first argument of ‘(==)’, namely ‘(x `mod` 3)’ - In the expression: (x `mod` 3) == 0 - In an equation for ‘test’: test x = (x `mod` 3) == 0 +
+tcfail034.hs:17:13: error:
+ Could not deduce (Integral a) arising from a use of ‘mod’
+ from the context: (Num a, Eq a)
+ bound by the type signature for:
+ test :: (Num a, Eq a) => a -> Bool
+ at tcfail034.hs:16:1-32
+ Possible fix:
+ add (Integral a) to the context of
+ the type signature for:
+ test :: (Num a, Eq a) => a -> Bool
+ In the first argument of ‘(==)’, namely ‘(x `mod` 3)’
+ In the expression: (x `mod` 3) == 0
+ In an equation for ‘test’: test x = (x `mod` 3) == 0
diff --git a/testsuite/tests/typecheck/should_fail/tcfail057.stderr b/testsuite/tests/typecheck/should_fail/tcfail057.stderr index 9323ae7579..07a8116173 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail057.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail057.stderr @@ -1,4 +1,5 @@ tcfail057.hs:5:7: error: - Constraint ‘RealFrac a’ used as a type - In the type signature for ‘f’: f :: (RealFrac a) -> a -> a + • Constraint ‘RealFrac a’ used as a type + • In the type signature: + f :: (RealFrac a) -> a -> a diff --git a/testsuite/tests/typecheck/should_fail/tcfail058.stderr b/testsuite/tests/typecheck/should_fail/tcfail058.stderr index 74db76afd8..6fcd4ea85d 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail058.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail058.stderr @@ -1,5 +1,5 @@ - -tcfail058.hs:6:7: - Expecting one more argument to ‘Array a’ - Expected a constraint, but ‘Array a’ has kind ‘* -> *’ - In the type signature for ‘f’: f :: (Array a) => a -> b +
+tcfail058.hs:6:7: error:
+ Expecting one more argument to ‘Array a’
+ Expected a constraint, but ‘Array a’ has kind ‘* -> *’
+ In the type signature: f :: (Array a) => a -> b
diff --git a/testsuite/tests/typecheck/should_fail/tcfail063.stderr b/testsuite/tests/typecheck/should_fail/tcfail063.stderr index 45bdaa36e2..d4185fe5aa 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail063.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail063.stderr @@ -1,5 +1,5 @@ - -tcfail063.hs:6:9: - Expecting one more argument to ‘Num’ - Expected a constraint, but ‘Num’ has kind ‘* -> Constraint’ - In the type signature for ‘moby’: moby :: Num => Int -> a -> Int +
+tcfail063.hs:6:9: error:
+ Expecting one more argument to ‘Num’
+ Expected a constraint, but ‘Num’ has kind ‘* -> Constraint’
+ In the type signature: moby :: Num => Int -> a -> Int
diff --git a/testsuite/tests/typecheck/should_fail/tcfail065.stderr b/testsuite/tests/typecheck/should_fail/tcfail065.stderr index ddb40dd491..65befaf29e 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail065.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail065.stderr @@ -1,13 +1,14 @@ -
-tcfail065.hs:29:20:
- Couldn't match expected type ‘x’ with actual type ‘x1’
- ‘x1’ is a rigid type variable bound by
- the type signature for: setX :: x1 -> X x -> X x
- at tcfail065.hs:29:3
- ‘x’ is a rigid type variable bound by
- the instance declaration at tcfail065.hs:28:10
- In the first argument of ‘X’, namely ‘x’
- In the expression: X x
- Relevant bindings include
- x :: x1 (bound at tcfail065.hs:29:8)
- setX :: x1 -> X x -> X x (bound at tcfail065.hs:29:3)
+ +tcfail065.hs:29:20: error: + • Couldn't match expected type ‘x’ with actual type ‘x1’ + ‘x1’ is a rigid type variable bound by + the type signature for: + setX :: forall x1. x1 -> X x -> X x + at tcfail065.hs:29:3 + ‘x’ is a rigid type variable bound by + the instance declaration at tcfail065.hs:28:10 + • In the first argument of ‘X’, namely ‘x’ + In the expression: X x + • Relevant bindings include + x :: x1 (bound at tcfail065.hs:29:8) + setX :: x1 -> X x -> X x (bound at tcfail065.hs:29:3) diff --git a/testsuite/tests/typecheck/should_fail/tcfail067.stderr b/testsuite/tests/typecheck/should_fail/tcfail067.stderr index e539ea881f..0095d757d5 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail067.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail067.stderr @@ -1,76 +1,79 @@ - -tcfail067.hs:1:14: Warning: - -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. - -tcfail067.hs:12:16: - No instance for (Ord a) arising from a use of ‘SubRange’ - Possible fix: - add (Ord a) to the context of - the type signature for: subRangeValue :: SubRange a -> a - In the pattern: SubRange (lower, upper) value - In an equation for ‘subRangeValue’: - subRangeValue (SubRange (lower, upper) value) = value - -tcfail067.hs:15:11: - No instance for (Ord a) arising from a use of ‘SubRange’ - Possible fix: - add (Ord a) to the context of - the type signature for: subRange :: SubRange a -> (a, a) - In the pattern: SubRange r value - In an equation for ‘subRange’: subRange (SubRange r value) = r - -tcfail067.hs:46:12: - Could not deduce (Ord a) arising from a use of ‘SubRange’ - from the context: Show a - bound by the type signature for: - showRange :: Show a => SubRange a -> String - at tcfail067.hs:45:14-43 - Possible fix: - add (Ord a) to the context of - the type signature for: showRange :: Show a => SubRange a -> String - In the pattern: SubRange (lower, upper) value - In an equation for ‘showRange’: - showRange (SubRange (lower, upper) value) - = show value ++ " :" ++ show lower ++ ".." ++ show upper - -tcfail067.hs:61:12: - Could not deduce (Ord a) arising from a use of ‘numSubRangeNegate’ - from the context: Num a - bound by the instance declaration at tcfail067.hs:60:10-34 - Possible fix: - add (Ord a) to the context of the instance declaration - In the expression: numSubRangeNegate - In an equation for ‘negate’: negate = numSubRangeNegate - In the instance declaration for ‘Num (SubRange a)’ - -tcfail067.hs:65:19: - Could not deduce (Ord a) arising from a use of ‘SubRange’ - from the context: Num a - bound by the instance declaration at tcfail067.hs:60:10-34 - Possible fix: - add (Ord a) to the context of the instance declaration - In the expression: - SubRange (fromInteger a, fromInteger a) (fromInteger a) - In an equation for ‘fromInteger’: - fromInteger a - = SubRange (fromInteger a, fromInteger a) (fromInteger a) - In the instance declaration for ‘Num (SubRange a)’ - -tcfail067.hs:74:5: - Could not deduce (Ord a) arising from a use of ‘SubRange’ - from the context: Num a - bound by the type signature for: - numSubRangeBinOp :: Num a => - (a -> a -> a) -> SubRange a -> SubRange a -> SubRange a - at tcfail067.hs:(71,21)-(72,58) - Possible fix: - add (Ord a) to the context of - the type signature for: - numSubRangeBinOp :: Num a => - (a -> a -> a) -> SubRange a -> SubRange a -> SubRange a - In the expression: SubRange (result, result) result - In an equation for ‘numSubRangeBinOp’: - numSubRangeBinOp op a b - = SubRange (result, result) result - where - result = (subRangeValue a) `op` (subRangeValue b) +
+tcfail067.hs:1:14: warning:
+ -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.
+
+tcfail067.hs:12:16: error:
+ No instance for (Ord a) arising from a use of ‘SubRange’
+ Possible fix:
+ add (Ord a) to the context of
+ the type signature for:
+ subRangeValue :: SubRange a -> a
+ In the pattern: SubRange (lower, upper) value
+ In an equation for ‘subRangeValue’:
+ subRangeValue (SubRange (lower, upper) value) = value
+
+tcfail067.hs:15:11: error:
+ No instance for (Ord a) arising from a use of ‘SubRange’
+ Possible fix:
+ add (Ord a) to the context of
+ the type signature for:
+ subRange :: SubRange a -> (a, a)
+ In the pattern: SubRange r value
+ In an equation for ‘subRange’: subRange (SubRange r value) = r
+
+tcfail067.hs:46:12: error:
+ Could not deduce (Ord a) arising from a use of ‘SubRange’
+ from the context: Show a
+ bound by the type signature for:
+ showRange :: Show a => SubRange a -> String
+ at tcfail067.hs:45:1-43
+ Possible fix:
+ add (Ord a) to the context of
+ the type signature for:
+ showRange :: Show a => SubRange a -> String
+ In the pattern: SubRange (lower, upper) value
+ In an equation for ‘showRange’:
+ showRange (SubRange (lower, upper) value)
+ = show value ++ " :" ++ show lower ++ ".." ++ show upper
+
+tcfail067.hs:61:12: error:
+ Could not deduce (Ord a) arising from a use of ‘numSubRangeNegate’
+ from the context: Num a
+ bound by the instance declaration at tcfail067.hs:60:10-34
+ Possible fix:
+ add (Ord a) to the context of the instance declaration
+ In the expression: numSubRangeNegate
+ In an equation for ‘negate’: negate = numSubRangeNegate
+ In the instance declaration for ‘Num (SubRange a)’
+
+tcfail067.hs:65:19: error:
+ Could not deduce (Ord a) arising from a use of ‘SubRange’
+ from the context: Num a
+ bound by the instance declaration at tcfail067.hs:60:10-34
+ Possible fix:
+ add (Ord a) to the context of the instance declaration
+ In the expression:
+ SubRange (fromInteger a, fromInteger a) (fromInteger a)
+ In an equation for ‘fromInteger’:
+ fromInteger a
+ = SubRange (fromInteger a, fromInteger a) (fromInteger a)
+ In the instance declaration for ‘Num (SubRange a)’
+
+tcfail067.hs:74:5: error:
+ Could not deduce (Ord a) arising from a use of ‘SubRange’
+ from the context: Num a
+ bound by the type signature for:
+ numSubRangeBinOp :: Num a =>
+ (a -> a -> a) -> SubRange a -> SubRange a -> SubRange a
+ at tcfail067.hs:(71,1)-(72,58)
+ Possible fix:
+ add (Ord a) to the context of
+ the type signature for:
+ numSubRangeBinOp :: Num a =>
+ (a -> a -> a) -> SubRange a -> SubRange a -> SubRange a
+ In the expression: SubRange (result, result) result
+ In an equation for ‘numSubRangeBinOp’:
+ numSubRangeBinOp op a b
+ = SubRange (result, result) result
+ where
+ result = (subRangeValue a) `op` (subRangeValue b)
diff --git a/testsuite/tests/typecheck/should_fail/tcfail068.stderr b/testsuite/tests/typecheck/should_fail/tcfail068.stderr index 330b1dceb0..f80a2cf1bb 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail068.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail068.stderr @@ -1,70 +1,78 @@ -tcfail068.hs:14:9: - Couldn't match type ‘s1’ with ‘s’ +tcfail068.hs:14:9: error: + • Couldn't match type ‘s1’ with ‘s’ ‘s1’ is a rigid type variable bound by - a type expected by the context: ST s1 (IndTree s a) - at tcfail068.hs:13:9 + a type expected by the context: + forall s1. ST s1 (IndTree s a) + at tcfail068.hs:13:9 ‘s’ is a rigid type variable bound by - the type signature for: - itgen :: Constructed a => (Int, Int) -> a -> IndTree s a - at tcfail068.hs:11:10 - Expected type: ST s1 (IndTree s a) - Actual type: ST s1 (STArray s1 (Int, Int) a) - In the first argument of ‘runST’, namely - ‘(newSTArray ((1, 1), n) x)’ - In the expression: runST (newSTArray ((1, 1), n) x) - Relevant bindings include - itgen :: (Int, Int) -> a -> IndTree s a - (bound at tcfail068.hs:12:1) + the type signature for: + itgen :: forall a s. + Constructed a => + (Int, Int) -> a -> IndTree s a + at tcfail068.hs:11:10 + Expected type: ST s1 (IndTree s a) + Actual type: ST s1 (STArray s1 (Int, Int) a) + • In the first argument of ‘runST’, namely + ‘(newSTArray ((1, 1), n) x)’ + In the expression: runST (newSTArray ((1, 1), n) x) + • Relevant bindings include + itgen :: (Int, Int) -> a -> IndTree s a + (bound at tcfail068.hs:12:1) -tcfail068.hs:19:21: - Couldn't match type ‘s’ with ‘s1’ +tcfail068.hs:19:21: error: + • Couldn't match type ‘s’ with ‘s1’ ‘s’ is a rigid type variable bound by - the type signature for: - itiap :: Constructed a => + the type signature for: + itiap :: forall a s. + Constructed a => (Int, Int) -> (a -> a) -> IndTree s a -> IndTree s a - at tcfail068.hs:16:10 + at tcfail068.hs:16:10 ‘s1’ is a rigid type variable bound by - a type expected by the context: ST s1 (IndTree s a) - at tcfail068.hs:18:9 - Expected type: STArray s1 (Int, Int) a - Actual type: IndTree s a - In the first argument of ‘readSTArray’, namely ‘arr’ - In the first argument of ‘(>>=)’, namely ‘readSTArray arr i’ - Relevant bindings include - arr :: IndTree s a (bound at tcfail068.hs:17:11) - itiap :: (Int, Int) -> (a -> a) -> IndTree s a -> IndTree s a - (bound at tcfail068.hs:17:1) + a type expected by the context: + forall s1. ST s1 (IndTree s a) + at tcfail068.hs:18:9 + Expected type: STArray s1 (Int, Int) a + Actual type: IndTree s a + • In the first argument of ‘readSTArray’, namely ‘arr’ + In the first argument of ‘(>>=)’, namely ‘readSTArray arr i’ + • Relevant bindings include + arr :: IndTree s a (bound at tcfail068.hs:17:11) + itiap :: (Int, Int) -> (a -> a) -> IndTree s a -> IndTree s a + (bound at tcfail068.hs:17:1) -tcfail068.hs:24:36: - Couldn't match type ‘s’ with ‘s1’ +tcfail068.hs:24:36: error: + • Couldn't match type ‘s’ with ‘s1’ ‘s’ is a rigid type variable bound by - the type signature for: - itrap :: Constructed a => + the type signature for: + itrap :: forall a s. + Constructed a => ((Int, Int), (Int, Int)) -> (a -> a) -> IndTree s a -> IndTree s a - at tcfail068.hs:23:10 + at tcfail068.hs:23:10 ‘s1’ is a rigid type variable bound by - a type expected by the context: ST s1 (IndTree s a) - at tcfail068.hs:24:29 - Expected type: ST s1 (IndTree s a) - Actual type: ST s (IndTree s a) - In the first argument of ‘runST’, namely ‘(itrap' i k)’ - In the expression: runST (itrap' i k) - Relevant bindings include - itrap' :: Int -> Int -> ST s (IndTree s a) - (bound at tcfail068.hs:26:9) - itrapsnd :: Int -> Int -> ST s (IndTree s a) - (bound at tcfail068.hs:29:9) - arr :: IndTree s a (bound at tcfail068.hs:24:23) - itrap :: ((Int, Int), (Int, Int)) - -> (a -> a) -> IndTree s a -> IndTree s a - (bound at tcfail068.hs:24:1) + a type expected by the context: + forall s1. ST s1 (IndTree s a) + at tcfail068.hs:24:29 + Expected type: ST s1 (IndTree s a) + Actual type: ST s (IndTree s a) + • In the first argument of ‘runST’, namely ‘(itrap' i k)’ + In the expression: runST (itrap' i k) + • Relevant bindings include + itrap' :: Int -> Int -> ST s (IndTree s a) + (bound at tcfail068.hs:26:9) + itrapsnd :: Int -> Int -> ST s (IndTree s a) + (bound at tcfail068.hs:29:9) + arr :: IndTree s a (bound at tcfail068.hs:24:23) + itrap :: ((Int, Int), (Int, Int)) + -> (a -> a) -> IndTree s a -> IndTree s a + (bound at tcfail068.hs:24:1) -tcfail068.hs:36:46: - Couldn't match type ‘s’ with ‘s1’ +tcfail068.hs:36:46: error: + • Couldn't match type ‘s’ with ‘s1’ ‘s’ is a rigid type variable bound by - the type signature for: - itrapstate :: Constructed b => + the type signature for: + itrapstate :: forall b a c s. + Constructed b => ((Int, Int), (Int, Int)) -> (a -> b -> (a, b)) -> ((Int, Int) -> c -> a) @@ -72,25 +80,26 @@ tcfail068.hs:36:46: -> c -> IndTree s b -> (c, IndTree s b) - at tcfail068.hs:34:15 + at tcfail068.hs:34:15 ‘s1’ is a rigid type variable bound by - a type expected by the context: ST s1 (c, IndTree s b) - at tcfail068.hs:36:40 - Expected type: ST s1 (c, IndTree s b) - Actual type: ST s (c, IndTree s b) - In the first argument of ‘runST’, namely ‘(itrapstate' i k s)’ - In the expression: runST (itrapstate' i k s) - Relevant bindings include - itrapstate' :: Int -> Int -> c -> ST s (c, IndTree s b) - (bound at tcfail068.hs:38:9) - itrapstatesnd :: Int -> Int -> c -> ST s (c, IndTree s b) - (bound at tcfail068.hs:41:9) - arr :: IndTree s b (bound at tcfail068.hs:36:34) - itrapstate :: ((Int, Int), (Int, Int)) - -> (a -> b -> (a, b)) - -> ((Int, Int) -> c -> a) - -> (a -> c) - -> c - -> IndTree s b - -> (c, IndTree s b) - (bound at tcfail068.hs:36:1) + a type expected by the context: + forall s1. ST s1 (c, IndTree s b) + at tcfail068.hs:36:40 + Expected type: ST s1 (c, IndTree s b) + Actual type: ST s (c, IndTree s b) + • In the first argument of ‘runST’, namely ‘(itrapstate' i k s)’ + In the expression: runST (itrapstate' i k s) + • Relevant bindings include + itrapstate' :: Int -> Int -> c -> ST s (c, IndTree s b) + (bound at tcfail068.hs:38:9) + itrapstatesnd :: Int -> Int -> c -> ST s (c, IndTree s b) + (bound at tcfail068.hs:41:9) + arr :: IndTree s b (bound at tcfail068.hs:36:34) + itrapstate :: ((Int, Int), (Int, Int)) + -> (a -> b -> (a, b)) + -> ((Int, Int) -> c -> a) + -> (a -> c) + -> c + -> IndTree s b + -> (c, IndTree s b) + (bound at tcfail068.hs:36:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail072.stderr b/testsuite/tests/typecheck/should_fail/tcfail072.stderr index 68d7283244..fa6752b37b 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail072.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail072.stderr @@ -4,7 +4,7 @@ tcfail072.hs:23:13: error: from the context: (Ord p, Ord q) bound by the type signature for: g :: (Ord p, Ord q) => AB p q -> Bool - at tcfail072.hs:22:6-38 + at tcfail072.hs:22:1-38 The type variable ‘p0’ is ambiguous These potential instances exist: instance Ord Ordering -- Defined in ‘GHC.Classes’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail076.stderr b/testsuite/tests/typecheck/should_fail/tcfail076.stderr index 869b9472f3..8283ef0458 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail076.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail076.stderr @@ -1,16 +1,18 @@ -tcfail076.hs:18:82: - Couldn't match type ‘res’ with ‘res1’ +tcfail076.hs:18:82: error: + • Couldn't match type ‘res’ with ‘res1’ ‘res’ is a rigid type variable bound by - a type expected by the context: (a -> m res) -> m res - at tcfail076.hs:18:28 + a type expected by the context: + forall res. (a -> m res) -> m res + at tcfail076.hs:18:28 ‘res1’ is a rigid type variable bound by - a type expected by the context: (b -> m res1) -> m res1 - at tcfail076.hs:18:64 - Expected type: m res1 - Actual type: m res - In the expression: cont a - In the first argument of ‘KContT’, namely ‘(\ cont' -> cont a)’ - Relevant bindings include - cont' :: b -> m res1 (bound at tcfail076.hs:18:73) - cont :: a -> m res (bound at tcfail076.hs:18:37) + a type expected by the context: + forall res1. (b -> m res1) -> m res1 + at tcfail076.hs:18:64 + Expected type: m res1 + Actual type: m res + • In the expression: cont a + In the first argument of ‘KContT’, namely ‘(\ cont' -> cont a)’ + • Relevant bindings include + cont' :: b -> m res1 (bound at tcfail076.hs:18:73) + cont :: a -> m res (bound at tcfail076.hs:18:37) diff --git a/testsuite/tests/typecheck/should_fail/tcfail078.stderr b/testsuite/tests/typecheck/should_fail/tcfail078.stderr index 9266b951f1..8a7837df00 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail078.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail078.stderr @@ -1,4 +1,4 @@ - -tcfail078.hs:5:6: - ‘Integer’ is applied to too many type arguments - In the type signature for ‘f’: f :: Integer i => i +
+tcfail078.hs:5:6: error:
+ ‘Integer’ is applied to too many type arguments
+ In the type signature: f :: Integer i => i
diff --git a/testsuite/tests/typecheck/should_fail/tcfail080.stderr b/testsuite/tests/typecheck/should_fail/tcfail080.stderr index 3b8d8e9eb9..21ca3aa8a6 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail080.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail080.stderr @@ -1,10 +1,12 @@ - -tcfail080.hs:27:1: - Could not deduce (Collection c0 a) - from the context: Collection c a - bound by the inferred type for ‘q’: Collection c a => a -> Bool - at tcfail080.hs:27:1-27 - The type variable ‘c0’ is ambiguous - When checking that ‘q’ has the inferred type - q :: forall (c :: * -> *) a. Collection c a => a -> Bool - Probable cause: the inferred type is ambiguous +
+tcfail080.hs:27:1: error:
+ Could not deduce (Collection c0 a)
+ from the context: Collection c a
+ bound by the inferred type for ‘q’:
+ Collection c a => a -> Bool
+ at tcfail080.hs:27:1-27
+ The type variable ‘c0’ is ambiguous
+ In the ambiguity check for the inferred type for ‘q’
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ When checking the inferred type
+ q :: forall (c :: * -> *) a. Collection c a => a -> Bool
diff --git a/testsuite/tests/typecheck/should_fail/tcfail097.stderr b/testsuite/tests/typecheck/should_fail/tcfail097.stderr index e4a611774d..9fbd7c4d87 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail097.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail097.stderr @@ -1,11 +1,11 @@ - -tcfail097.hs:5:6: - Could not deduce (Eq a0) - from the context: Eq a - bound by the type signature for: f :: Eq a => Int -> Int - at tcfail097.hs:5:6-23 - The type variable ‘a0’ is ambiguous - In the ambiguity check for the type signature for ‘f’: - f :: forall a. Eq a => Int -> Int - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the type signature for ‘f’: f :: Eq a => Int -> Int +
+tcfail097.hs:5:6: error:
+ Could not deduce (Eq a0)
+ from the context: Eq a
+ bound by the type signature for:
+ f :: Eq a => Int -> Int
+ at tcfail097.hs:5:6-23
+ The type variable ‘a0’ is ambiguous
+ In the ambiguity check for ‘f’
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ In the type signature: f :: Eq a => Int -> Int
diff --git a/testsuite/tests/typecheck/should_fail/tcfail098.stderr b/testsuite/tests/typecheck/should_fail/tcfail098.stderr index 1d95319566..0b2baf0f51 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail098.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail098.stderr @@ -1,11 +1,10 @@ - -tcfail098.hs:12:10: - Could not deduce (Bar a0) - from the context: Bar a - bound by an instance declaration: Bar a => Bar Bool - at tcfail098.hs:12:10-26 - The type variable ‘a0’ is ambiguous - In the ambiguity check for an instance declaration: - forall a. Bar a => Bar Bool - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the instance declaration for ‘Bar Bool’ +
+tcfail098.hs:12:10: error:
+ Could not deduce (Bar a0)
+ from the context: Bar a
+ bound by an instance declaration: Bar a => Bar Bool
+ at tcfail098.hs:12:10-26
+ The type variable ‘a0’ is ambiguous
+ In the ambiguity check for an instance declaration
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ In the instance declaration for ‘Bar Bool’
diff --git a/testsuite/tests/typecheck/should_fail/tcfail101.stderr b/testsuite/tests/typecheck/should_fail/tcfail101.stderr index b88b77475e..7c10f4aebe 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail101.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail101.stderr @@ -1,4 +1,4 @@ tcfail101.hs:9:6: error:
The type synonym ‘A’ should have 1 argument, but has been given none
- In the type signature for ‘f’: f :: T A
+ In the type signature: f :: T A
diff --git a/testsuite/tests/typecheck/should_fail/tcfail102.stderr b/testsuite/tests/typecheck/should_fail/tcfail102.stderr index 6bd3750138..1f034ed39d 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail102.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail102.stderr @@ -1,13 +1,13 @@ - -tcfail102.hs:1:14: Warning: - -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. - -tcfail102.hs:9:15: - Could not deduce (Integral (Ratio a)) arising from a use of ‘p’ - from the context: Integral a - bound by the type signature for: - f :: Integral a => P (Ratio a) -> P (Ratio a) - at tcfail102.hs:8:6-45 - In the ‘p’ field of a record - In the expression: x {p = p x} - In an equation for ‘f’: f x = x {p = p x} +
+tcfail102.hs:1:14: warning:
+ -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.
+
+tcfail102.hs:9:15: error:
+ Could not deduce (Integral (Ratio a)) arising from a use of ‘p’
+ from the context: Integral a
+ bound by the type signature for:
+ f :: Integral a => P (Ratio a) -> P (Ratio a)
+ at tcfail102.hs:8:1-45
+ In the ‘p’ field of a record
+ In the expression: x {p = p x}
+ In an equation for ‘f’: f x = x {p = p x}
diff --git a/testsuite/tests/typecheck/should_fail/tcfail103.stderr b/testsuite/tests/typecheck/should_fail/tcfail103.stderr index 17a434f0ae..627ef1158c 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail103.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail103.stderr @@ -1,10 +1,14 @@ -tcfail103.hs:15:23:
+tcfail103.hs:15:23: error:
Couldn't match type ‘t’ with ‘s’
- ‘t’ is a rigid type variable bound by
- the type signature for: f :: ST t Int at tcfail103.hs:10:5
- ‘s’ is a rigid type variable bound by
- the type signature for: g :: ST s Int at tcfail103.hs:13:14
+ ‘t’ is a rigid type variable bound by
+ the type signature for:
+ f :: forall t. ST t Int
+ at tcfail103.hs:10:5
+ ‘s’ is a rigid type variable bound by
+ the type signature for:
+ g :: forall s. ST s Int
+ at tcfail103.hs:13:14
Expected type: STRef s Int
Actual type: STRef t Int
In the first argument of ‘readSTRef’, namely ‘v’
diff --git a/testsuite/tests/typecheck/should_fail/tcfail107.stderr b/testsuite/tests/typecheck/should_fail/tcfail107.stderr index 85f9a2de07..68b82627b8 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail107.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail107.stderr @@ -1,5 +1,5 @@ tcfail107.hs:13:9: error:
The type synonym ‘Const’ should have 2 arguments, but has been given 1
- In the type signature for ‘test’:
+ In the type signature:
test :: Thing (Const Int) -> Thing (Const Int)
diff --git a/testsuite/tests/typecheck/should_fail/tcfail110.stderr b/testsuite/tests/typecheck/should_fail/tcfail110.stderr index cb60a79d93..a9b070e46d 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail110.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail110.stderr @@ -1,6 +1,5 @@ - -tcfail110.hs:8:30: - Expecting one more argument to ‘Foo a’ - Expected a type, but ‘Foo a’ has kind ‘* -> *’ - In the type signature for ‘bar’: - bar :: String -> (forall a. Foo a) -> IO () +
+tcfail110.hs:8:30: error:
+ Expecting one more argument to ‘Foo a’
+ Expected a type, but ‘Foo a’ has kind ‘* -> *’
+ In the type signature: bar :: String -> (forall a. Foo a) -> IO ()
diff --git a/testsuite/tests/typecheck/should_fail/tcfail113.stderr b/testsuite/tests/typecheck/should_fail/tcfail113.stderr index 8584008cd3..06837f6f73 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail113.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail113.stderr @@ -1,14 +1,14 @@ - -tcfail113.hs:12:7: - Expecting one more argument to ‘Maybe’ - Expected kind ‘*’, but ‘Maybe’ has kind ‘* -> *’ - In the type signature for ‘f’: f :: [Maybe] - -tcfail113.hs:15:8: - The first argument of ‘T’ should have kind ‘* -> *’, - but ‘Int’ has kind ‘*’ - In the type signature for ‘g’: g :: T Int - -tcfail113.hs:18:6: - ‘Int’ is applied to too many type arguments - In the type signature for ‘h’: h :: Int Int +
+tcfail113.hs:12:7: error:
+ Expecting one more argument to ‘Maybe’
+ Expected kind ‘*’, but ‘Maybe’ has kind ‘* -> *’
+ In the type signature: f :: [Maybe]
+
+tcfail113.hs:15:8: error:
+ The first argument of ‘T’ should have kind ‘* -> *’,
+ but ‘Int’ has kind ‘*’
+ In the type signature: g :: T Int
+
+tcfail113.hs:18:6: error:
+ ‘Int’ is applied to too many type arguments
+ In the type signature: h :: Int Int
diff --git a/testsuite/tests/typecheck/should_fail/tcfail116.stderr b/testsuite/tests/typecheck/should_fail/tcfail116.stderr index abefc61eb8..723e6dba9a 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail116.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail116.stderr @@ -1,12 +1,12 @@ -tcfail116.hs:6:5:
+tcfail116.hs:6:5: error:
Could not deduce (Foo a0)
from the context: Foo a
- bound by the type signature for: bug :: Foo a => ()
+ bound by the type signature for:
+ bug :: Foo a => ()
at tcfail116.hs:6:5-13
The type variable ‘a0’ is ambiguous
- In the ambiguity check for the type signature for ‘bug’:
- bug :: forall a. Foo a => ()
+ In the ambiguity check for ‘bug’
To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
When checking the class method: bug :: forall a. Foo a => ()
In the class declaration for ‘Foo’
diff --git a/testsuite/tests/typecheck/should_fail/tcfail127.stderr b/testsuite/tests/typecheck/should_fail/tcfail127.stderr index 32af3d8382..feda55fc82 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail127.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail127.stderr @@ -1,5 +1,5 @@ - -tcfail127.hs:3:8: error: - Illegal polymorphic or qualified type: Num a => a -> a - GHC doesn't yet support impredicative polymorphism - In the type signature for ‘foo’: foo :: IO (Num a => a -> a) +
+tcfail127.hs:3:8: error:
+ Illegal polymorphic or qualified type: Num a => a -> a
+ GHC doesn't yet support impredicative polymorphism
+ In the type signature: foo :: IO (Num a => a -> a)
diff --git a/testsuite/tests/typecheck/should_fail/tcfail131.stderr b/testsuite/tests/typecheck/should_fail/tcfail131.stderr index 3a209ab5e0..03bdc72eff 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail131.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail131.stderr @@ -1,10 +1,12 @@ -
-tcfail131.hs:7:9:
- Couldn't match expected type ‘b’ with actual type ‘Integer’
- ‘b’ is a rigid type variable bound by
- the type signature for: g :: Num b => b -> b at tcfail131.hs:6:8
- In the expression: f x x
- In an equation for ‘g’: g x = f x x
- Relevant bindings include
- x :: b (bound at tcfail131.hs:7:5)
- g :: b -> b (bound at tcfail131.hs:7:3)
+ +tcfail131.hs:7:9: error: + • Couldn't match expected type ‘b’ with actual type ‘Integer’ + ‘b’ is a rigid type variable bound by + the type signature for: + g :: forall b. Num b => b -> b + at tcfail131.hs:6:8 + • In the expression: f x x + In an equation for ‘g’: g x = f x x + • Relevant bindings include + x :: b (bound at tcfail131.hs:7:5) + g :: b -> b (bound at tcfail131.hs:7:3) diff --git a/testsuite/tests/typecheck/should_fail/tcfail134.stderr b/testsuite/tests/typecheck/should_fail/tcfail134.stderr index b73d2f38a9..4ade82b8e6 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail134.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail134.stderr @@ -1,6 +1,6 @@ - -tcfail134.hs:5:33: - Expecting one more argument to ‘XML’ - Expected a type, but ‘XML’ has kind ‘* -> Constraint’ - In the type ‘a -> XML’ - In the class declaration for ‘XML’ +
+tcfail134.hs:5:33: error:
+ Expecting one more argument to ‘XML’
+ Expected a type, but ‘XML’ has kind ‘* -> Constraint’
+ In the type signature: toXML :: a -> XML
+ In the class declaration for ‘XML’
diff --git a/testsuite/tests/typecheck/should_fail/tcfail135.stderr b/testsuite/tests/typecheck/should_fail/tcfail135.stderr index 251284365c..bf953347d3 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail135.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail135.stderr @@ -1,6 +1,6 @@ - -tcfail135.hs:6:23: - Expecting one more argument to ‘f’ - Expected a type, but ‘f’ has kind ‘k0 -> *’ - In the type ‘f a -> f’ - In the class declaration for ‘Foo’ +
+tcfail135.hs:6:23: error:
+ Expecting one more argument to ‘f’
+ Expected a type, but ‘f’ has kind ‘k0 -> *’
+ In the type signature: baa :: f a -> f
+ In the class declaration for ‘Foo’
diff --git a/testsuite/tests/typecheck/should_fail/tcfail142.stderr b/testsuite/tests/typecheck/should_fail/tcfail142.stderr index c6553c1de6..1c854acc35 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail142.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail142.stderr @@ -1,11 +1,12 @@ - -tcfail142.hs:18:8: - Could not deduce (Bar a0 r) - from the context: Bar a r - bound by the type signature for: bar :: Bar a r => r -> () - at tcfail142.hs:18:8-25 - The type variable ‘a0’ is ambiguous - In the ambiguity check for the type signature for ‘bar’: - bar :: forall r a. Bar a r => r -> () - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the type signature for ‘bar’: bar :: Bar a r => r -> () +
+tcfail142.hs:18:8: error:
+ Could not deduce (Bar a0 r)
+ from the context: Bar a r
+ bound by the type signature for:
+ bar :: Bar a r => r -> ()
+ at tcfail142.hs:18:8-25
+ The type variable ‘a0’ is ambiguous
+ In the ambiguity check for ‘bar’
+ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
+ In the type signature:
+ bar :: Bar a r => r -> ()
diff --git a/testsuite/tests/typecheck/should_fail/tcfail153.stderr b/testsuite/tests/typecheck/should_fail/tcfail153.stderr index ec46f782ad..8034a804fc 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail153.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail153.stderr @@ -1,8 +1,10 @@ -tcfail153.hs:6:7:
+tcfail153.hs:6:7: error:
Couldn't match type ‘a’ with ‘Bool’
- ‘a’ is a rigid type variable bound by
- the type signature for: f :: a -> [a] at tcfail153.hs:5:6
+ ‘a’ is a rigid type variable bound by
+ the type signature for:
+ f :: forall a. a -> [a]
+ at tcfail153.hs:5:6
Expected type: [a]
Actual type: [Bool]
In the expression: g x
diff --git a/testsuite/tests/typecheck/should_fail/tcfail158.stderr b/testsuite/tests/typecheck/should_fail/tcfail158.stderr index e359c8bdb2..4110f87366 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail158.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail158.stderr @@ -1,5 +1,5 @@ - -tcfail158.hs:14:19: - Expecting one more argument to ‘Val v’ - Expected a type, but ‘Val v’ has kind ‘* -> *’ - In the type signature for ‘bar’: bar :: forall v. Val v +
+tcfail158.hs:14:19: error:
+ Expecting one more argument to ‘Val v’
+ Expected a type, but ‘Val v’ has kind ‘* -> *’
+ In the type signature: bar :: forall v. Val v
diff --git a/testsuite/tests/typecheck/should_fail/tcfail160.stderr b/testsuite/tests/typecheck/should_fail/tcfail160.stderr index 7a740403d8..7e17d5c476 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail160.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail160.stderr @@ -1,5 +1,5 @@ - -tcfail160.hs:7:8: - The first argument of ‘T’ should have kind ‘* -> *’, - but ‘Int’ has kind ‘*’ - In the type signature for ‘g’: g :: T Int +
+tcfail160.hs:7:8: error:
+ The first argument of ‘T’ should have kind ‘* -> *’,
+ but ‘Int’ has kind ‘*’
+ In the type signature: g :: T Int
diff --git a/testsuite/tests/typecheck/should_fail/tcfail161.stderr b/testsuite/tests/typecheck/should_fail/tcfail161.stderr index 90e1c2ec5e..afe989206f 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail161.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail161.stderr @@ -1,5 +1,5 @@ - -tcfail161.hs:5:7: - Expecting one more argument to ‘Maybe’ - Expected kind ‘*’, but ‘Maybe’ has kind ‘* -> *’ - In the type signature for ‘f’: f :: [Maybe] +
+tcfail161.hs:5:7: error:
+ Expecting one more argument to ‘Maybe’
+ Expected kind ‘*’, but ‘Maybe’ has kind ‘* -> *’
+ In the type signature: f :: [Maybe]
diff --git a/testsuite/tests/typecheck/should_fail/tcfail174.stderr b/testsuite/tests/typecheck/should_fail/tcfail174.stderr index 77bc7416b5..fec5748461 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail174.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail174.stderr @@ -1,11 +1,11 @@ -tcfail174.hs:9:10:
+tcfail174.hs:9:10: error:
Couldn't match expected type ‘forall a. a -> a’
with actual type ‘a0 -> a0’
In the first argument of ‘Base’, namely ‘id’
In the expression: Base id
-tcfail174.hs:13:14:
+tcfail174.hs:13:14: error:
Couldn't match type ‘a’ with ‘a1’
because type variable ‘a1’ would escape its scope
This (rigid, skolem) type variable is bound by
@@ -18,12 +18,15 @@ tcfail174.hs:13:14: Relevant bindings include
h1 :: Capture a (bound at tcfail174.hs:13:1)
-tcfail174.hs:16:14:
+tcfail174.hs:16:14: error:
Couldn't match type ‘a’ with ‘b’
- ‘a’ is a rigid type variable bound by
- the type forall a1. a1 -> a1 at tcfail174.hs:1:1
- ‘b’ is a rigid type variable bound by
- the type signature for: h2 :: Capture b at tcfail174.hs:15:7
+ ‘a’ is a rigid type variable bound by
+ the type forall a1. a1 -> a1
+ at tcfail174.hs:1:1
+ ‘b’ is a rigid type variable bound by
+ the type signature for:
+ h2 :: forall b. Capture b
+ at tcfail174.hs:15:7
Expected type: Capture (forall x. x -> b)
Actual type: Capture (forall a. a -> a)
In the first argument of ‘Capture’, namely ‘g’
diff --git a/testsuite/tests/typecheck/should_fail/tcfail175.stderr b/testsuite/tests/typecheck/should_fail/tcfail175.stderr index 50a2424fcc..82da98bc0c 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail175.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail175.stderr @@ -1,10 +1,12 @@ -
-tcfail175.hs:11:1:
- Couldn't match expected type ‘String -> String -> String’
- with actual type ‘a’
- ‘a’ is a rigid type variable bound by
- the type signature for: evalRHS :: Int -> a at tcfail175.hs:10:12
- The equation(s) for ‘evalRHS’ have three arguments,
- but its type ‘Int -> a’ has only one
- Relevant bindings include
- evalRHS :: Int -> a (bound at tcfail175.hs:11:1)
+ +tcfail175.hs:11:1: error: + • Couldn't match expected type ‘String -> String -> String’ + with actual type ‘a’ + ‘a’ is a rigid type variable bound by + the type signature for: + evalRHS :: forall a. Int -> a + at tcfail175.hs:10:12 + • The equation(s) for ‘evalRHS’ have three arguments, + but its type ‘Int -> a’ has only one + • Relevant bindings include + evalRHS :: Int -> a (bound at tcfail175.hs:11:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail179.stderr b/testsuite/tests/typecheck/should_fail/tcfail179.stderr index 14d2eae435..a50e75e6be 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail179.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail179.stderr @@ -1,17 +1,19 @@ -
-tcfail179.hs:14:39:
- Couldn't match expected type ‘s’ with actual type ‘x’
- ‘x’ is a rigid type variable bound by
- a pattern with constructor:
- T :: forall s x. (s -> (x -> s) -> (x, s, Int)) -> T s,
- in a case alternative
- at tcfail179.hs:14:14
- ‘s’ is a rigid type variable bound by
- the type signature for: run :: T s -> Int at tcfail179.hs:12:8
- In the first argument of ‘g’, namely ‘x’
- In the expression: g x id
- Relevant bindings include
- x :: x (bound at tcfail179.hs:14:26)
- g :: s -> (x -> s) -> (x, s, Int) (bound at tcfail179.hs:14:16)
- ts :: T s (bound at tcfail179.hs:13:5)
- run :: T s -> Int (bound at tcfail179.hs:13:1)
+ +tcfail179.hs:14:39: error: + • Couldn't match expected type ‘s’ with actual type ‘x’ + ‘x’ is a rigid type variable bound by + a pattern with constructor: + T :: forall s x. (s -> (x -> s) -> (x, s, Int)) -> T s, + in a case alternative + at tcfail179.hs:14:14 + ‘s’ is a rigid type variable bound by + the type signature for: + run :: forall s. T s -> Int + at tcfail179.hs:12:8 + • In the first argument of ‘g’, namely ‘x’ + In the expression: g x id + • Relevant bindings include + x :: x (bound at tcfail179.hs:14:26) + g :: s -> (x -> s) -> (x, s, Int) (bound at tcfail179.hs:14:16) + ts :: T s (bound at tcfail179.hs:13:5) + run :: T s -> Int (bound at tcfail179.hs:13:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail181.stderr b/testsuite/tests/typecheck/should_fail/tcfail181.stderr index 47aeccc586..6d483798b1 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail181.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail181.stderr @@ -12,6 +12,5 @@ tcfail181.hs:17:9: error: instance Monad ((->) r) -- Defined in ‘GHC.Base’ ...plus two others (use -fprint-potential-instances to see them all) - In the expression: foo In the expression: foo {bar = return True} In an equation for ‘wog’: wog x = foo {bar = return True} diff --git a/testsuite/tests/typecheck/should_fail/tcfail191.stderr b/testsuite/tests/typecheck/should_fail/tcfail191.stderr index d9237443df..bd1b04ca80 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail191.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail191.stderr @@ -1,9 +1,11 @@ - -tcfail191.hs:11:26: - Couldn't match type ‘a’ with ‘[a]’ - ‘a’ is a rigid type variable bound by - a type expected by the context: [a] -> [[a]] at tcfail191.hs:10:9 - Expected type: [a] -> [[a]] - Actual type: [[a]] -> [[a]] - In the expression: take 5 - In a stmt of a list comprehension: then group using take 5 +
+tcfail191.hs:11:26: error:
+ Couldn't match type ‘a’ with ‘[a]’
+ ‘a’ is a rigid type variable bound by
+ a type expected by the context:
+ forall a. [a] -> [[a]]
+ at tcfail191.hs:10:9
+ Expected type: [a] -> [[a]]
+ Actual type: [[a]] -> [[a]]
+ In the expression: take 5
+ In a stmt of a list comprehension: then group using take 5
diff --git a/testsuite/tests/typecheck/should_fail/tcfail193.stderr b/testsuite/tests/typecheck/should_fail/tcfail193.stderr index d2f3f26d92..bd8ef5348a 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail193.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail193.stderr @@ -1,9 +1,11 @@ - -tcfail193.hs:10:31: - Couldn't match type ‘a’ with ‘[a]’ - ‘a’ is a rigid type variable bound by - a type expected by the context: [a] -> [a] at tcfail193.hs:10:10 - Expected type: [a] -> [a] - Actual type: [a] -> [[a]] - In the expression: inits - In a stmt of a list comprehension: then inits +
+tcfail193.hs:10:31: error:
+ Couldn't match type ‘a’ with ‘[a]’
+ ‘a’ is a rigid type variable bound by
+ a type expected by the context:
+ forall a. [a] -> [a]
+ at tcfail193.hs:10:10
+ Expected type: [a] -> [a]
+ Actual type: [a] -> [[a]]
+ In the expression: inits
+ In a stmt of a list comprehension: then inits
diff --git a/testsuite/tests/typecheck/should_fail/tcfail196.stderr b/testsuite/tests/typecheck/should_fail/tcfail196.stderr index 723c91de5e..bcb2c32700 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail196.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail196.stderr @@ -1,5 +1,4 @@ - -tcfail196.hs:5:8: - Illegal polymorphic or qualified type: forall a. a - In the type signature for ‘bar’: - bar :: Num (forall a. a) => Int -> Int +
+tcfail196.hs:5:8: error:
+ Illegal polymorphic or qualified type: forall a. a
+ In the type signature: bar :: Num (forall a. a) => Int -> Int
diff --git a/testsuite/tests/typecheck/should_fail/tcfail197.stderr b/testsuite/tests/typecheck/should_fail/tcfail197.stderr index c15af60329..8b814870f2 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail197.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail197.stderr @@ -1,5 +1,5 @@ - -tcfail197.hs:5:8: error: - Illegal polymorphic or qualified type: forall a. a - GHC doesn't yet support impredicative polymorphism - In the type signature for ‘foo’: foo :: [forall a. a] -> Int +
+tcfail197.hs:5:8: error:
+ Illegal polymorphic or qualified type: forall a. a
+ GHC doesn't yet support impredicative polymorphism
+ In the type signature: foo :: [forall a. a] -> Int
diff --git a/testsuite/tests/typecheck/should_fail/tcfail201.stderr b/testsuite/tests/typecheck/should_fail/tcfail201.stderr index 0609229ae8..03efc08ff2 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail201.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail201.stderr @@ -1,15 +1,16 @@ tcfail201.hs:17:58: error: - Couldn't match expected type ‘a’ with actual type ‘HsDoc id0’ + • Couldn't match expected type ‘a’ with actual type ‘HsDoc id0’ ‘a’ is a rigid type variable bound by - the type signature for: - gfoldl' :: (forall a1 b. c (a1 -> b) -> a1 -> c b) + the type signature for: + gfoldl' :: forall a (c :: * -> *). + (forall a1 b. c (a1 -> b) -> a1 -> c b) -> (forall g. g -> c g) -> a -> c a - at tcfail201.hs:15:12 - In the first argument of ‘z’, namely ‘DocEmpty’ - In the expression: z DocEmpty - Relevant bindings include - hsDoc :: a (bound at tcfail201.hs:16:13) - gfoldl' :: (forall a1 b. c (a1 -> b) -> a1 -> c b) - -> (forall g. g -> c g) -> a -> c a - (bound at tcfail201.hs:16:1) + at tcfail201.hs:15:12 + • In the first argument of ‘z’, namely ‘DocEmpty’ + In the expression: z DocEmpty + • Relevant bindings include + hsDoc :: a (bound at tcfail201.hs:16:13) + gfoldl' :: (forall a1 b. c (a1 -> b) -> a1 -> c b) + -> (forall g. g -> c g) -> a -> c a + (bound at tcfail201.hs:16:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail206.stderr b/testsuite/tests/typecheck/should_fail/tcfail206.stderr index 5090ee165f..687619c9eb 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail206.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail206.stderr @@ -1,22 +1,24 @@ -tcfail206.hs:5:5:
+tcfail206.hs:5:5: error:
Couldn't match type ‘Bool’ with ‘Int’
Expected type: Bool -> (Int, Bool)
Actual type: Bool -> (Bool, Bool)
In the expression: (, True)
In an equation for ‘a’: a = (, True)
-tcfail206.hs:8:5:
+tcfail206.hs:8:5: error:
Couldn't match type ‘(Integer, Int)’ with ‘Bool -> (Int, Bool)’
Expected type: Int -> Bool -> (Int, Bool)
Actual type: Int -> (Integer, Int)
In the expression: (1,)
In an equation for ‘b’: b = (1,)
-tcfail206.hs:11:5:
+tcfail206.hs:11:5: error:
Couldn't match type ‘a’ with ‘Bool’
- ‘a’ is a rigid type variable bound by
- the type signature for: c :: a -> (a, Bool) at tcfail206.hs:10:6
+ ‘a’ is a rigid type variable bound by
+ the type signature for:
+ c :: forall a. a -> (a, Bool)
+ at tcfail206.hs:10:6
Expected type: a -> (a, Bool)
Actual type: a -> (a, a)
In the expression: (True || False,)
@@ -24,25 +26,27 @@ tcfail206.hs:11:5: Relevant bindings include
c :: a -> (a, Bool) (bound at tcfail206.hs:11:1)
-tcfail206.hs:14:5:
+tcfail206.hs:14:5: error:
Couldn't match type ‘Bool’ with ‘Int’
Expected type: Bool -> (# Int, Bool #)
Actual type: Bool -> (# Bool, Bool #)
In the expression: (# , True #)
In an equation for ‘d’: d = (# , True #)
-tcfail206.hs:17:5:
+tcfail206.hs:17:5: error:
Couldn't match type ‘(# Integer, Int #)’
- with ‘Bool -> (# Int, Bool #)’
+ with ‘Bool -> (# Int, Bool #)’
Expected type: Int -> Bool -> (# Int, Bool #)
Actual type: Int -> (# Integer, Int #)
In the expression: (# 1, #)
In an equation for ‘e’: e = (# 1, #)
-tcfail206.hs:20:5:
+tcfail206.hs:20:5: error:
Couldn't match type ‘a’ with ‘Bool’
- ‘a’ is a rigid type variable bound by
- the type signature for: f :: a -> (# a, Bool #) at tcfail206.hs:19:6
+ ‘a’ is a rigid type variable bound by
+ the type signature for:
+ f :: forall a. a -> (# a, Bool #)
+ at tcfail206.hs:19:6
Expected type: a -> (# a, Bool #)
Actual type: a -> (# a, a #)
In the expression: (# True || False, #)
diff --git a/testsuite/tests/typecheck/should_fail/tcfail208.stderr b/testsuite/tests/typecheck/should_fail/tcfail208.stderr index 4b88fc0e58..dd290d942c 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail208.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail208.stderr @@ -1,9 +1,9 @@ - -tcfail208.hs:4:19: - Could not deduce (Eq (m a)) arising from a use of ‘==’ - from the context: (Monad m, Eq a) - bound by the type signature for: - f :: (Monad m, Eq a) => a -> m a -> Bool - at tcfail208.hs:3:6-40 - In the expression: (return x == y) - In an equation for ‘f’: f x y = (return x == y) +
+tcfail208.hs:4:19: error:
+ Could not deduce (Eq (m a)) arising from a use of ‘==’
+ from the context: (Monad m, Eq a)
+ bound by the type signature for:
+ f :: (Monad m, Eq a) => a -> m a -> Bool
+ at tcfail208.hs:3:1-40
+ In the expression: (return x == y)
+ In an equation for ‘f’: f x y = (return x == y)
diff --git a/testsuite/tests/typecheck/should_fail/tcfail209a.stderr b/testsuite/tests/typecheck/should_fail/tcfail209a.stderr index 446d76f421..d3da3df44c 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail209a.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail209a.stderr @@ -1,6 +1,5 @@ - -tcfail209a.hs:3:6: - Illegal tuple constraint: (Show a, Num a) - (Use ConstraintKinds to permit this) - In the type signature for ‘g’: - g :: ((Show a, Num a), Eq a) => a -> a +
+tcfail209a.hs:3:6: error:
+ Illegal tuple constraint: (Show a, Num a)
+ (Use ConstraintKinds to permit this)
+ In the type signature: g :: ((Show a, Num a), Eq a) => a -> a
diff --git a/testsuite/tests/typecheck/should_fail/tcfail212.stderr b/testsuite/tests/typecheck/should_fail/tcfail212.stderr index 72e5fe8104..e14e62bddf 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail212.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail212.stderr @@ -1,10 +1,10 @@ - -tcfail212.hs:10:7: - Expecting one more argument to ‘Maybe’ - The first argument of a tuple should have kind ‘*’, - but ‘Maybe’ has kind ‘* -> *’ - In the type signature for ‘f’: f :: (Maybe, Either Int) - -tcfail212.hs:13:7: - Expecting a lifted type, but ‘Int#’ is unlifted - In the type signature for ‘g’: g :: (Int#, Int#) +
+tcfail212.hs:10:7: error:
+ Expecting one more argument to ‘Maybe’
+ The first argument of a tuple should have kind ‘*’,
+ but ‘Maybe’ has kind ‘* -> *’
+ In the type signature: f :: (Maybe, Either Int)
+
+tcfail212.hs:13:7: error:
+ Expecting a lifted type, but ‘Int#’ is unlifted
+ In the type signature: g :: (Int#, Int#)
diff --git a/testsuite/tests/typecheck/should_fail/tcfail215.stderr b/testsuite/tests/typecheck/should_fail/tcfail215.stderr index 2157561827..df27691960 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail215.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail215.stderr @@ -1,4 +1,4 @@ - -tcfail215.hs:8:15: - Expecting a lifted type, but ‘Int#’ is unlifted - In the type signature for ‘foo’: foo :: (?x :: Int#) => Int +
+tcfail215.hs:8:15: error:
+ Expecting a lifted type, but ‘Int#’ is unlifted
+ In the type signature: foo :: (?x :: Int#) => Int
diff --git a/testsuite/tests/typecheck/should_run/Defer01.hs b/testsuite/tests/typecheck/should_run/Defer01.hs index 368db9873f..f6c69dcfa7 100755 --- a/testsuite/tests/typecheck/should_run/Defer01.hs +++ b/testsuite/tests/typecheck/should_run/Defer01.hs @@ -30,10 +30,10 @@ d = 1 e = 'p' f = e 'q' -h :: a -> (Char,Char) +h :: a -> (Char,Char) h x = (x,'c') -data T a where +data T a where K :: a -> T a i a = seq (not (K a)) () @@ -48,6 +48,5 @@ k x = x l :: IO () l = putChar >> putChar 'p' - main :: IO () main = print "No errors!" diff --git a/testsuite/tests/typecheck/should_run/T7861.stderr b/testsuite/tests/typecheck/should_run/T7861.stderr index 2f8ae153ba..e0aac9a558 100644 --- a/testsuite/tests/typecheck/should_run/T7861.stderr +++ b/testsuite/tests/typecheck/should_run/T7861.stderr @@ -1,9 +1,9 @@ T7861: T7861.hs:10:5: error: Couldn't match type ‘a’ with ‘[a]’ ‘a’ is a rigid type variable bound by - the type signature for: - f :: (forall b. a) -> a - at T7861.hs:9:6 + the type signature for: + f :: forall a. (forall b. a) -> a + at T7861.hs:9:6 Expected type: (forall b. a) -> a Actual type: (forall b. a) -> [a] In the expression: doA diff --git a/testsuite/tests/typecheck/should_run/tcrun008.hs b/testsuite/tests/typecheck/should_run/tcrun008.hs index 80097a8f24..daabdf8fda 100644 --- a/testsuite/tests/typecheck/should_run/tcrun008.hs +++ b/testsuite/tests/typecheck/should_run/tcrun008.hs @@ -14,13 +14,10 @@ instance Foo Bool where bar x = [x, not x] data Record = R { - blub :: Foo a => a -> [a] + blub :: forall a. Foo a => a -> [a] } main = do { let r = R {blub = bar} - ; print (blub r (3::Int)) - ; print (blub r True) - } - - - + ; print (blub r (3::Int)) + ; print (blub r True) + } diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr index 23d1a2892b..7b6b501708 100644 --- a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr +++ b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr @@ -6,7 +6,7 @@ WCompatWarningsOn.hs:11:5: warning: from the context: Monad m bound by the type signature for: monadFail :: Monad m => m a - at WCompatWarningsOn.hs:9:14-27 + at WCompatWarningsOn.hs:9:1-27 Possible fix: add (MonadFail m) to the context of the type signature for: diff --git a/utils/haddock b/utils/haddock -Subproject fcd1bb7177a800f6f56a623c2468fc46a59c527 +Subproject 42b2cfc595f1ee62d1c1b8513c5df1d92709c06 |