diff options
Diffstat (limited to 'compiler/GHC/Tc/Instance')
| -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 |
3 files changed, 16 insertions, 16 deletions
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 |