diff options
Diffstat (limited to 'compiler/GHC/Tc')
| -rw-r--r-- | compiler/GHC/Tc/Errors.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Splice.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Instance/Class.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Instance/Family.hs | 18 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Instance/FunDeps.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Module.hs | 21 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Utils/Backpack.hs | 6 |
7 files changed, 33 insertions, 34 deletions
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 70f5d0ddd7..82aa8fcc6a 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -1897,7 +1897,7 @@ mkDictErr ctxt cts is_no_inst (ct, (matches, unifiers, _)) = no_givens && null matches - && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct)) + && (nullUnifiers unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct)) lookup_cls_inst inst_envs ct = (ct, lookupInstEnv True inst_envs clas tys) @@ -1988,13 +1988,13 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) cannot_resolve_msg :: Ct -> [ClsInst] -> RelevantBindings -> [ImportError] -> [GhcHint] -> TcReportMsg cannot_resolve_msg ct candidate_insts binds imp_errs field_suggestions - = CannotResolveInstance ct unifiers candidate_insts imp_errs field_suggestions binds + = CannotResolveInstance ct (getPotentialUnifiers unifiers) candidate_insts imp_errs field_suggestions binds -- Overlap errors. overlap_msg, safe_haskell_msg :: TcReportMsg -- Normal overlap error overlap_msg - = assert (not (null matches)) $ OverlappingInstances ct ispecs unifiers + = assert (not (null matches)) $ OverlappingInstances ct ispecs (getPotentialUnifiers unifiers) -- Overlap error because of Safe Haskell (first -- match should be the most specific match) diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 747b3a7d98..7264f2232a 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -1715,7 +1715,7 @@ reifyInstances' th_nm th_tys -> do { inst_envs <- tcGetInstEnvs ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys ; traceTc "reifyInstances'1" (ppr matches) - ; return $ Left (cls, map fst matches ++ unifies) } + ; return $ Left (cls, map fst matches ++ getPotentialUnifiers unifies) } | isOpenFamilyTyCon tc -> do { inst_envs <- tcGetFamInstEnvs ; let matches = lookupFamInstEnv inst_envs tc tys diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs index 8063ce7720..df7046c4fd 100644 --- a/compiler/GHC/Tc/Instance/Class.hs +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -172,12 +172,12 @@ matchInstEnv dflags short_cut_solver clas tys ; case (matches, unify, safeHaskFail) of -- Nothing matches - ([], [], _) + ([], NoUnifiers, _) -> do { traceTc "matchClass not matching" (ppr pred) ; return NoInstance } -- A single match (& no safe haskell failure) - ([(ispec, inst_tys)], [], False) + ([(ispec, inst_tys)], NoUnifiers, False) | short_cut_solver -- Called from the short-cut solver , isOverlappable ispec -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs index 6ce522385b..8b76c9f4cd 100644 --- a/compiler/GHC/Tc/Instance/Family.hs +++ b/compiler/GHC/Tc/Instance/Family.hs @@ -700,7 +700,7 @@ checkForConflicts :: FamInstEnvs -> FamInst -> TcM () checkForConflicts inst_envs fam_inst = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst ; traceTc "checkForConflicts" $ - vcat [ ppr (map fim_instance conflicts) + vcat [ ppr conflicts , ppr fam_inst -- , ppr inst_envs ] @@ -991,20 +991,18 @@ buildInjectivityError :: (TyCon -> NonEmpty CoAxBranch -> TcRnMessage) buildInjectivityError mkErr fam_tc branches = ( coAxBranchSpan (NE.head branches), mkErr fam_tc branches ) -reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn () +reportConflictInstErr :: FamInst -> [FamInst] -> TcRn () reportConflictInstErr _ [] = return () -- No conflicts -reportConflictInstErr fam_inst (match1 : _) - | FamInstMatch { fim_instance = conf_inst } <- match1 - , let sorted = NE.sortBy (SrcLoc.leftmost_smallest `on` getSpan) (fam_inst NE.:| [conf_inst]) - fi1 = NE.head sorted - span = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) - = setSrcSpan span $ addErr $ TcRnConflictingFamInstDecls sorted - where - getSpan = getSrcSpan . famInstAxiom +reportConflictInstErr fam_inst (conf_inst : _) = -- The sortBy just arranges that instances are displayed in order -- of source location, which reduced wobbling in error messages, -- and is better for users + let sorted = NE.sortBy (SrcLoc.leftmost_smallest `on` getSpan) (fam_inst NE.:| [conf_inst]) + fi1 = NE.head sorted + span = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) + getSpan = getSrcSpan . famInstAxiom + in setSrcSpan span $ addErr $ TcRnConflictingFamInstDecls sorted tcGetFamInstEnvs :: TcM FamInstEnvs -- Gets both the external-package inst-env diff --git a/compiler/GHC/Tc/Instance/FunDeps.hs b/compiler/GHC/Tc/Instance/FunDeps.hs index 4b45f2fa38..cfbebcd368 100644 --- a/compiler/GHC/Tc/Instance/FunDeps.hs +++ b/compiler/GHC/Tc/Instance/FunDeps.hs @@ -227,11 +227,12 @@ improveFromInstEnv inst_env mk_loc cls tys where (cls_tvs, cls_fds) = classTvsFds cls instances = classInstances inst_env cls - rough_tcs = roughMatchTcs tys + rough_tcs = RM_KnownTc (className cls) : roughMatchTcs tys pred = mkClassPred cls tys + improveClsFD :: [TyVar] -> FunDep TyVar -- One functional dependency from the class -> ClsInst -- An instance template -> [Type] -> [RoughMatchTc] -- Arguments of this (C tys) predicate @@ -673,8 +674,9 @@ trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [RoughMatchTc] -> [RoughMatchTc] -- Hence, we Nothing-ise the tb and tc types right here -- -- Result list is same length as input list, just with more Nothings -trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs - = zipWith select clas_tvs mb_tcs +trimRoughMatchTcs _clas_tvs _ [] = panic "trimRoughMatchTcs: nullary [RoughMatchTc]" +trimRoughMatchTcs clas_tvs (ltvs, _) (cls:mb_tcs) + = cls : zipWith select clas_tvs mb_tcs where select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc - | otherwise = OtherTc + | otherwise = RM_WildCard diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 505f0dd627..c8f65e2453 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -401,7 +401,7 @@ tcRnImports hsc_env import_decls tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env, tcg_imports = tcg_imports gbl `plusImportAvails` imports, tcg_rn_imports = rn_imports, - tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, + tcg_inst_env = tcg_inst_env gbl `unionInstEnv` home_insts, tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) home_fam_insts, tcg_hpc = hpc_info @@ -1721,7 +1721,7 @@ tcMissingParentClassWarn warnFlag isName shouldName -- "<location>: Warning: <type> is an instance of <is> but not -- <should>" e.g. "Foo is an instance of Monad but not Applicative" ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst - warnMsg (KnownTc name:_) = + warnMsg (RM_KnownTc name:_) = addDiagnosticAt instLoc $ TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ hsep [ (quotes . ppr . nameOccName) name @@ -1734,7 +1734,7 @@ tcMissingParentClassWarn warnFlag isName shouldName hsep [ text "This will become an error in" , text "a future release." ] warnMsg _ = pure () - ; when (null shouldInsts && null instanceMatches) $ + ; when (nullUnifiers shouldInsts && null instanceMatches) $ warnMsg (is_tcs isInst) } @@ -2041,7 +2041,7 @@ runTcInteractive hsc_env thing_inside withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $ do { traceTc "setInteractiveContext" $ vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) - , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts) + , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) (instEnvElts ic_insts)) , text "icReaderEnv (LocalDef)" <+> vcat (map ppr [ local_gres | gres <- nonDetOccEnvElts (icReaderEnv icxt) , let local_gres = filter isLocalGRE gres @@ -2064,13 +2064,12 @@ runTcInteractive hsc_env thing_inside where gbl_env' = gbl_env { tcg_rdr_env = icReaderEnv icxt , tcg_type_env = type_env - , tcg_inst_env = extendInstEnvList - (extendInstEnvList (tcg_inst_env gbl_env) ic_insts) - home_insts + + , tcg_inst_env = tcg_inst_env gbl_env `unionInstEnv` ic_insts `unionInstEnv` home_insts , tcg_fam_inst_env = extendFamInstEnvList - (extendFamInstEnvList (tcg_fam_inst_env gbl_env) - ic_finsts) - home_fam_insts + (extendFamInstEnvList (tcg_fam_inst_env gbl_env) + ic_finsts) + home_fam_insts , tcg_field_env = mkNameEnv con_fields -- setting tcg_field_env is necessary -- to make RecordWildCards work (test: ghci049) @@ -2103,7 +2102,7 @@ runTcInteractive hsc_env thing_inside = Right thing type_env1 = mkTypeEnvWithImplicits top_ty_things - type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts) + type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId (instEnvElts ic_insts)) -- Putting the dfuns in the type_env -- is just to keep Core Lint happy diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 20b81f8b3c..d553ec4fad 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -146,7 +146,7 @@ checkHsigIface tcg_env gr sig_iface tcg_fam_inst_env = emptyFamInstEnv, tcg_insts = [], tcg_fam_insts = [] } $ do - mapM_ check_inst sig_insts + mapM_ check_inst (instEnvElts sig_insts) failIfErrsM where -- NB: the Names in sig_type_env are bogus. Let's say we have H.hsig @@ -156,7 +156,7 @@ checkHsigIface tcg_env gr sig_iface sig_type_occ_env = mkOccEnv . map (\t -> (nameOccName (getName t), t)) $ nonDetNameEnvElts sig_type_env - dfun_names = map getName sig_insts + dfun_names = map getName (instEnvElts sig_insts) check_export name -- Skip instances, we'll check them later -- TODO: Actually this should never happen, because DFuns are @@ -865,7 +865,7 @@ mergeSignatures = (inst:insts, extendInstEnv inst_env inst) (insts, inst_env) = foldl' merge_inst (tcg_insts tcg_env, tcg_inst_env tcg_env) - (md_insts details) + (instEnvElts $ md_insts details) -- This is a HACK to prevent calculateAvails from including imp_mod -- in the listing. We don't want it because a module is NOT -- supposed to include itself in its dep_orphs/dep_finsts. See #13214 |