From fc7b70afcea572bee42fefd11d7bdd3f6515796b Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Wed, 17 Mar 1999 10:06:22 +0000
Subject: [PATCH] [project @ 1999-03-17 10:06:21 by simonpj] Make it so that
Local (i.e. non-top-level) names record whether they originally came from an
interface file. This means that when unifying two type variables we can
readily choose one that occurred in the source, rather than one imported from
an interface file. That in turn improves compiler error messages. E.g.
rd :: (RealFloat a, RealFrac b) => b -> Transformation a
rd degrees = r ((degrees / 180.0) * pi)
used to say
Could not deduce `Floating a'
(arising from use of `pi' at Foo.hs:11)
from the context: (RealFloat a1, RealFrac a)
Probable cause: missing `Floating a' in type signature for `rd'
[here the 'a' came from the signature for 'pi' in PrelBase;
the 'a1' is a renamed version of the 'a' in the source pgm]
but now says
Could not deduce `Floating b'
(arising from use of `pi' at Foo.hs:11)
from the context: (RealFloat a, RealFrac b)
Probable cause: missing `Floating b' in type signature for `rd'
---
ghc/compiler/basicTypes/Name.lhs | 26 +++++++++++++++++++++++---
ghc/compiler/typecheck/TcUnify.lhs | 5 ++---
2 files changed, 25 insertions(+), 6 deletions(-)
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index c895f1814e81..9c1fee1b124e 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -10,7 +10,8 @@ module Name (
-- The Name type
Name, -- Abstract
- mkLocalName, mkSysLocalName, mkTopName,
+ mkLocalName, mkImportedLocalName, mkSysLocalName,
+ mkTopName,
mkDerivedName, mkGlobalName,
mkWiredInIdName, mkWiredInTyConName,
maybeWiredInIdName, maybeWiredInTyConName,
@@ -24,12 +25,12 @@ module Name (
isLocallyDefinedName,
isSystemName, isLocalName, isGlobalName, isExternallyVisibleName,
-
+
-- Provenance
Provenance(..), ImportReason(..), pprProvenance,
ExportFlag(..), PrintUnqualified,
- pprNameProvenance, systemProvenance,
+ pprNameProvenance, systemProvenance, hasBetterProv,
-- Class NamedThing and overloaded friends
NamedThing(..),
@@ -93,6 +94,16 @@ mkLocalName uniq occ loc = Name { n_uniq = uniq, n_sort = Local, n_occ = occ,
-- * for interface files we tidyCore first, which puts the uniques
-- into the print name (see setNameVisibility below)
+mkImportedLocalName :: Unique -> OccName -> SrcLoc -> Name
+ -- Just the same as mkLocalName, except the provenance is different
+ -- Reason: this flags the name as one that came in from an interface file.
+ -- This is useful when trying to decide which of two type variables
+ -- should 'win' when unifying them.
+ -- NB: this is only for non-top-level names, so we use ImplicitImport
+mkImportedLocalName uniq occ loc = Name { n_uniq = uniq, n_sort = Local, n_occ = occ,
+ n_prov = NonLocalDef ImplicitImport True }
+
+
mkGlobalName :: Unique -> Module -> OccName -> Provenance -> Name
mkGlobalName uniq mod occ prov = Name { n_uniq = uniq, n_sort = Global mod,
n_occ = occ, n_prov = prov }
@@ -419,6 +430,15 @@ isGlobalName other = True
-- does not mean visible at the source level (that's isExported).
isExternallyVisibleName name = isGlobalName name
+hasBetterProv :: Name -> Name -> Bool
+hasBetterProv name1 name2
+ = case n_prov name1 of
+ LocalDef _ _ -> True
+ SystemProv -> False
+ NonLocalDef _ _ -> case n_prov name2 of
+ LocalDef _ _ -> False
+ other -> True
+
isSystemName (Name {n_prov = SystemProv}) = True
isSystemName other = False
\end{code}
diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs
index 6fd0ba76a1e0..f7a78e57c368 100644
--- a/ghc/compiler/typecheck/TcUnify.lhs
+++ b/ghc/compiler/typecheck/TcUnify.lhs
@@ -24,7 +24,7 @@ import Type ( Type(..), tyVarsOfType, funTyCon,
)
import TyCon ( TyCon, isTupleTyCon, isUnboxedTupleTyCon,
tyConArity )
-import Name ( isSystemName )
+import Name ( hasBetterProv )
import Var ( TyVar, tyVarKind, varName )
import VarEnv
import VarSet ( varSetElems )
@@ -272,8 +272,7 @@ uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2)
Nothing -> checkKinds swapped tv1 ty2 `thenTc_`
-- Try to update sys-y type variables in preference to sig-y ones
- -- (the latter respond False to isSystemName)
- if isSystemName (varName tv2) then
+ if varName tv1 `hasBetterProv` varName tv2 then
tcPutTyVar tv2 (TyVarTy tv1) `thenNF_Tc_`
returnTc ()
else
--
GitLab