From 9c26739695219d8343505a88457cb55c76b65449 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Wed, 18 Jun 1997 23:53:03 +0000
Subject: [PATCH] [project @ 1997-06-18 23:52:36 by simonpj] A raft of small
bug-fixes to 2.05 by SLPJ
---
ghc/compiler/absCSyn/PprAbsC.lhs | 4 +-
ghc/compiler/basicTypes/Name.lhs | 9 ++-
ghc/compiler/hsSyn/HsBinds.lhs | 18 +++--
ghc/compiler/hsSyn/HsTypes.lhs | 23 ++----
ghc/compiler/main/Main.lhs | 2 +-
ghc/compiler/nativeGen/MachRegs.lhs | 1 +
ghc/compiler/parser/hsparser.y | 12 ++--
ghc/compiler/reader/RdrHsSyn.lhs | 14 +++-
ghc/compiler/rename/RnEnv.lhs | 71 ++++++++++++-------
ghc/compiler/rename/RnMonad.lhs | 11 ++-
ghc/compiler/rename/RnNames.lhs | 44 +++++-------
ghc/compiler/rename/RnSource.lhs | 69 ++++++++++--------
ghc/compiler/tests/rename/rn019.hs | 4 ++
ghc/compiler/tests/rename/rn020.hs | 11 +++
ghc/compiler/tests/rename/rn021.hs | 17 +++++
.../tests/typecheck/should_fail/tcfail072.hs | 24 +++++++
.../tests/typecheck/should_succeed/Makefile | 3 +-
.../tests/typecheck/should_succeed/tc086.hs | 60 ++++++++++++++++
.../tests/typecheck/should_succeed/tc087.hs | 32 +++++++++
.../tests/typecheck/should_succeed/tc088.hs | 18 +++++
ghc/compiler/typecheck/Inst.lhs | 7 +-
ghc/compiler/typecheck/TcInstDcls.lhs | 2 +-
ghc/compiler/typecheck/TcMatches.lhs | 39 ++++++++--
ghc/compiler/utils/FiniteMap.lhs | 1 +
24 files changed, 362 insertions(+), 134 deletions(-)
create mode 100644 ghc/compiler/tests/rename/rn019.hs
create mode 100644 ghc/compiler/tests/rename/rn020.hs
create mode 100644 ghc/compiler/tests/rename/rn021.hs
create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail072.hs
create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc086.hs
create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc087.hs
create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc088.hs
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index 6d4f3bac9257..3454645897cc 100644
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -954,7 +954,7 @@ ppr_amode sty (CAddr reg_rel)
ppr_amode sty (CReg magic_id) = pprMagicId sty magic_id
-ppr_amode sty (CTemp uniq kind) = pprUnique uniq
+ppr_amode sty (CTemp uniq kind) = pprUnique uniq <> char '_'
ppr_amode sty (CLbl label kind) = pprCLabel sty label
@@ -1214,7 +1214,7 @@ labelSeenTE label env@(seen_uniqs, seen_labels)
\begin{code}
pprTempDecl :: Unique -> PrimRep -> Doc
pprTempDecl uniq kind
- = hcat [ pprPrimKind PprDebug kind, space, pprUnique uniq, semi ]
+ = hcat [ pprPrimKind PprDebug kind, space, pprUnique uniq, ptext SLIT("_;") ]
pprExternDecl :: CLabel -> PrimRep -> Doc
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index 89fe13580c67..198fc42c4e9a 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -256,9 +256,12 @@ mkInstDeclName uniq mod occ loc from_here
| otherwise = Implicit
-setNameProvenance :: Name -> Provenance -> Name -- Implicit Globals only
-setNameProvenance (Global uniq mod occ def Implicit) prov = Global uniq mod occ def prov
-setNameProvenance other_name prov = other_name
+setNameProvenance :: Name -> Provenance -> Name
+ -- setNameProvenance used to only change the provenance of Implicit-provenance things,
+ -- but that gives bad error messages for names defined twice in the same
+ -- module, so I changed it to set the proveance of *any* global (SLPJ Jun 97)
+setNameProvenance (Global uniq mod occ def _) prov = Global uniq mod occ def prov
+setNameProvenance other_name prov = other_name
getNameProvenance :: Name -> Provenance
getNameProvenance (Global uniq mod occ def prov) = prov
diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index 1f32b3e8646b..f28cff83aeba 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -261,27 +261,25 @@ instance (NamedThing name, Outputable name) => Outputable (Sig name) where
ppr_sig sty (Sig var ty _)
- = hang (hsep [ppr sty var, ptext SLIT("::")])
- 4 (ppr sty ty)
+ = sep [ppr sty var <+> ptext SLIT("::"),
+ nest 4 (ppr sty ty)]
ppr_sig sty (ClassOpSig var _ ty _)
- = hang (hsep [ppr sty (getOccName var), ptext SLIT("::")])
- 4 (ppr sty ty)
+ = sep [ppr sty (getOccName var) <+> ptext SLIT("::"),
+ nest 4 (ppr sty ty)]
ppr_sig sty (DeforestSig var _)
- = hang (hsep [text "{-# DEFOREST", ppr sty var])
- 4 (text "#-")
+ = hsep [text "{-# DEFOREST", ppr sty var, text "#-}"]
ppr_sig sty (SpecSig var ty using _)
- = hang (hsep [text "{-# SPECIALIZE", ppr sty var, ptext SLIT("::")])
- 4 (hsep [ppr sty ty, pp_using using, text "#-}"])
-
+ = sep [ hsep [text "{-# SPECIALIZE", ppr sty var, ptext SLIT("::")],
+ nest 4 (hsep [ppr sty ty, pp_using using, text "#-}"])
+ ]
where
pp_using Nothing = empty
pp_using (Just me) = hsep [char '=', ppr sty me]
ppr_sig sty (InlineSig var _)
-
= hsep [text "{-# INLINE", ppr sty var, text "#-}"]
ppr_sig sty (MagicUnfoldingSig var str _)
diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index 25c19992b506..b83f4b8fcd4e 100644
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -24,7 +24,7 @@ module HsTypes (
IMP_Ubiq()
import CmdLineOpts ( opt_PprUserLength )
-import Outputable ( Outputable(..), PprStyle(..), interppSP, ifnotPprForUser )
+import Outputable ( Outputable(..), PprStyle(..), pprQuote, interppSP )
import Kind ( Kind {- instance Outputable -} )
import Name ( nameOccName )
import Pretty
@@ -100,20 +100,12 @@ replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k
\begin{code}
instance (Outputable name) => Outputable (HsType name) where
- ppr = pprHsType
+ ppr sty ty = pprQuote sty $ \ sty -> pprHsType sty ty
instance (Outputable name) => Outputable (HsTyVar name) where
- ppr sty (UserTyVar name) = ppr_hs_tyname sty name
- ppr sty (IfaceTyVar name kind) = hsep [ppr_hs_tyname sty name, ptext SLIT("::"), ppr sty kind]
-
-
--- Here comes a rather gross hack.
--- We want to print data and class decls in interface files, from the original source
--- When we do, we want the type variables to come out with their original names, not
--- some new unique (or else interfaces wobble too much). So when we come to one of
--- these type variables we sneakily change the style to PprForUser!
-ppr_hs_tyname PprInterface tv_name = ppr (PprForUser opt_PprUserLength) tv_name
-ppr_hs_tyname other_sty tv_name = ppr other_sty tv_name
+ ppr sty (UserTyVar name) = ppr sty name
+ ppr sty (IfaceTyVar name kind) = pprQuote sty $ \ sty ->
+ hsep [ppr sty name, ptext SLIT("::"), ppr sty kind]
ppr_forall sty ctxt_prec [] [] ty
= ppr_mono_ty sty ctxt_prec ty
@@ -150,7 +142,7 @@ pprParendHsType sty ty = ppr_mono_ty sty pREC_CON ty
ppr_mono_ty sty ctxt_prec (HsPreForAllTy ctxt ty) = ppr_forall sty ctxt_prec [] ctxt ty
ppr_mono_ty sty ctxt_prec (HsForAllTy tvs ctxt ty) = ppr_forall sty ctxt_prec tvs ctxt ty
-ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr_hs_tyname sty name
+ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr sty name
ppr_mono_ty sty ctxt_prec (MonoFunTy ty1 ty2)
= let p1 = ppr_mono_ty sty pREC_FUN ty1
@@ -170,8 +162,7 @@ ppr_mono_ty sty ctxt_prec (MonoTyApp fun_ty arg_ty)
(hsep [ppr_mono_ty sty pREC_FUN fun_ty, ppr_mono_ty sty pREC_CON arg_ty])
ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty)
- = braces (hsep [ppr sty clas, ppr_mono_ty sty pREC_CON ty])
- -- Curlies are temporary
+ = hsep [ppr sty clas, ppr_mono_ty sty pREC_CON ty]
\end{code}
diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs
index afd261798c73..2ed03b4f1f49 100644
--- a/ghc/compiler/main/Main.lhs
+++ b/ghc/compiler/main/Main.lhs
@@ -74,7 +74,7 @@ main =
doIt :: ([CoreToDo], [StgToDo]) -> String -> IO ()
doIt (core_cmds, stg_cmds) input_pgm
- = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.03, for Haskell 1.4" "" >>
+ = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.04, for Haskell 1.4" "" >>
-- ******* READER
show_pass "Reader" >>
diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs
index 5beabc150588..a2af7420cea3 100644
--- a/ghc/compiler/nativeGen/MachRegs.lhs
+++ b/ghc/compiler/nativeGen/MachRegs.lhs
@@ -80,6 +80,7 @@ import Unique ( mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
Unique{-instance Ord3-}
)
import UniqSupply ( getUnique, returnUs, thenUs, SYN_IE(UniqSM) )
+import UniqFM ( Uniquable(..) )
import Util ( panic, Ord3(..) )
\end{code}
diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y
index 5203c1ee7901..58db2df53fa5 100644
--- a/ghc/compiler/parser/hsparser.y
+++ b/ghc/compiler/parser/hsparser.y
@@ -475,12 +475,12 @@ topdecls: topdecl
}
;
-topdecl : typed { $$ = $1; }
- | datad { $$ = $1; }
- | newtd { $$ = $1; }
- | classd { $$ = $1; }
- | instd { $$ = $1; }
- | defaultd { $$ = $1; }
+topdecl : typed { $$ = $1; FN = NULL; SAMEFN = 0; }
+ | datad { $$ = $1; FN = NULL; SAMEFN = 0; }
+ | newtd { $$ = $1; FN = NULL; SAMEFN = 0; }
+ | classd { $$ = $1; FN = NULL; SAMEFN = 0; }
+ | instd { $$ = $1; FN = NULL; SAMEFN = 0; }
+ | defaultd { $$ = $1; FN = NULL; SAMEFN = 0; }
| decl { $$ = $1; }
;
diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs
index f7d4e9263f3e..9f4aa0054992 100644
--- a/ghc/compiler/reader/RdrHsSyn.lhs
+++ b/ghc/compiler/reader/RdrHsSyn.lhs
@@ -124,9 +124,17 @@ extractHsTyVars ty
get (MonoFunTy ty1 ty2) acc = get ty1 (get ty2 acc)
get (MonoDictTy cls ty) acc = get ty acc
get (MonoTyVar tv) acc = insert tv acc
- get (HsPreForAllTy ctxt ty) acc = foldr (get . snd) (get ty acc) ctxt
- get (HsForAllTy tvs ctxt ty) acc = filter (`notElem` locals) $
- foldr (get . snd) (get ty acc) ctxt
+
+ -- In (All a => a -> a) -> Int, there are no free tyvars
+ -- We just assume that we quantify over all type variables mentioned in the context.
+ get (HsPreForAllTy ctxt ty) acc = filter (`notElem` locals) (get ty [])
+ ++ acc
+ where
+ locals = foldr (get . snd) [] ctxt
+
+ get (HsForAllTy tvs ctxt ty) acc = (filter (`notElem` locals) $
+ foldr (get . snd) (get ty []) ctxt)
+ ++ acc
where
locals = map getTyVarName tvs
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 2844c72e11ba..d9265832d730 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -31,7 +31,7 @@ import TysWiredIn ( tupleTyCon, listTyCon, charTyCon, intTyCon )
import FiniteMap
import Outputable
import Unique ( Unique, unboundKey )
-import UniqFM ( Uniquable(..) )
+import UniqFM ( Uniquable(..), listToUFM, plusUFM_C )
import Maybes ( maybeToBool )
import UniqSupply
import SrcLoc ( SrcLoc, noSrcLoc )
@@ -88,26 +88,29 @@ newLocallyDefinedGlobalName mod occ rec_exp_fn loc
-- If it's not in the cache we put it there with the correct provenance.
-- The idea is that, after all this, the cache
-- will contain a Name with the correct Provenance (i.e. Local)
+
+ -- OLD (now wrong) COMMENT:
+ -- "Actually, there's a catch. If this is the *second* binding for something
+ -- we want to allocate a *fresh* unique, rather than using the same Name as before.
+ -- Otherwise we don't detect conflicting definitions of the same top-level name!
+ -- So the only time we re-use a Name already in the cache is when it's one of
+ -- the Implicit magic-unique ones mentioned in the previous para"
+
+ -- This (incorrect) patch doesn't work for record decls, when we have
+ -- the same field declared in multiple constructors. With the above patch,
+ -- each occurrence got a new Name --- aargh!
--
- -- Actually, there's a catch. If this is the *second* binding for something
- -- we want to allocate a *fresh* unique, rather than using the same Name as before.
- -- Otherwise we don't detect conflicting definitions of the same top-level name!
- -- So the only time we re-use a Name already in the cache is when it's one of
- -- the Implicit magic-unique ones mentioned in the previous para
+ -- So I reverted to the simple caching method (no "second-binding" thing)
+ -- The multiple-local-binding case is now handled by improving the conflict
+ -- detection in plusNameEnv.
let
provenance = LocalDef (rec_exp_fn new_name) loc
(us', us1) = splitUniqSupply us
uniq = getUnique us1
key = (mod,occ)
new_name = case lookupFM cache key of
- Just name | is_implicit_prov
- -> setNameProvenance name provenance
- where
- is_implicit_prov = case getNameProvenance name of
- Implicit -> True
- other -> False
- other -> mkGlobalName uniq mod occ VanillaDefn provenance
-
+ Just name -> setNameProvenance name provenance
+ other -> mkGlobalName uniq mod occ VanillaDefn provenance
new_cache = addToFM cache key new_name
in
setNameSupplyRn (us', inst_ns, new_cache) `thenRn_`
@@ -358,17 +361,28 @@ plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2)
=============== NameEnv ================
\begin{code}
plusNameEnvRn :: NameEnv -> NameEnv -> RnM s d NameEnv
-plusNameEnvRn n1 n2
- = mapRn (addErrRn.nameClashErr) (conflictsFM (/=) n1 n2) `thenRn_`
- returnRn (n1 `plusFM` n2)
+plusNameEnvRn env1 env2
+ = mapRn (addErrRn.nameClashErr) (conflictsFM conflicting_name env1 env2) `thenRn_`
+ returnRn (env1 `plusFM` env2)
addOneToNameEnv :: NameEnv -> RdrName -> Name -> RnM s d NameEnv
addOneToNameEnv env rdr_name name
= case lookupFM env rdr_name of
- Nothing -> returnRn (addToFM env rdr_name name)
- Just name2 -> addErrRn (nameClashErr (rdr_name, (name, name2))) `thenRn_`
+ Just name2 | conflicting_name name name2
+ -> addErrRn (nameClashErr (rdr_name, (name, name2))) `thenRn_`
returnRn env
+ Nothing -> returnRn (addToFM env rdr_name name)
+
+conflicting_name n1 n2 = (n1 /= n2) || (isLocallyDefinedName n1 && isLocallyDefinedName n2)
+ -- We complain of a conflict if one RdrName maps to two different Names,
+ -- OR if one RdrName maps to the same *locally-defined* Name. The latter
+ -- case is to catch two separate, local definitions of the same thing.
+ --
+ -- If a module imports itself then there might be a local defn and an imported
+ -- defn of the same name; in this case the names will compare as equal, but
+ -- will still have different provenances.
+
lookupNameEnv :: NameEnv -> RdrName -> Maybe Name
lookupNameEnv = lookupFM
@@ -400,13 +414,20 @@ pprFixityProvenance sty (fixity, prov) = pprProvenance sty prov
=============== Avails ================
\begin{code}
-emptyModuleAvails :: ModuleAvails
-plusModuleAvails :: ModuleAvails -> ModuleAvails -> ModuleAvails
-lookupModuleAvails :: ModuleAvails -> Module -> Maybe [AvailInfo]
+mkExportAvails :: Bool -> Module -> [AvailInfo] -> ExportAvails
+mkExportAvails unqualified_import mod_name avails
+ = (mod_avail_env, entity_avail_env)
+ where
+ -- The "module M" syntax only applies to *unqualified* imports (1.4 Report, Section 5.1.1)
+ mod_avail_env | unqualified_import = unitFM mod_name avails
+ | otherwise = emptyFM
+
+ entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
+ name <- availEntityNames avail]
-emptyModuleAvails = emptyFM
-plusModuleAvails = plusFM_C (++)
-lookupModuleAvails = lookupFM
+plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails
+plusExportAvails (m1, e1) (m2, e2)
+ = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2)
\end{code}
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index f1d6f4507677..dcdc7186fecc 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -55,6 +55,7 @@ import Pretty
import Outputable ( PprStyle(..) )
import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
import Unique ( Unique )
+import UniqFM ( UniqFM )
import FiniteMap ( FiniteMap, emptyFM, bagToFM )
import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
import UniqSet
@@ -185,7 +186,15 @@ type Fixities = [(OccName, (Fixity, Provenance))]
-- or the same type/class/id, more than once. Hence a boring old list.
-- This allows us to report duplicates in just one place, namely plusRnEnv.
-type ModuleAvails = FiniteMap Module Avails
+type ExportAvails = (FiniteMap Module Avails, -- Used to figure out "module M" export specifiers
+ -- Includes avails only from *unqualified* imports
+ -- (see 1.4 Report Section 5.1.1)
+
+ UniqFM AvailInfo) -- Used to figure out all other export specifiers.
+ -- Maps a Name to the AvailInfo that contains it
+ -- NB: Contain bindings for class ops but
+ -- not constructors (see defn of availEntityNames)
+
data AvailInfo = NotAvailable
| Avail Name -- An ordinary identifier
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index beca595d5aee..4e745f192a52 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -72,13 +72,13 @@ getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc)
else
-- COMBINE RESULTS
- -- We put the local env first, so that a local provenance
+ -- We put the local env second, so that a local provenance
-- "wins", even if a module imports itself.
foldlRn plusRnEnv emptyRnEnv imp_rn_envs `thenRn` \ imp_rn_env ->
- plusRnEnv local_rn_env imp_rn_env `thenRn` \ rn_env ->
+ plusRnEnv imp_rn_env local_rn_env `thenRn` \ rn_env ->
let
- all_avails :: ModuleAvails
- all_avails = foldr plusModuleAvails local_mod_avails imp_avails_s
+ export_avails :: ExportAvails
+ export_avails = foldr plusExportAvails local_mod_avails imp_avails_s
explicit_names :: NameSet -- locally defined or explicitly imported
explicit_names = foldr add_on emptyNameSet (local_avails : explicit_imports_s)
@@ -86,7 +86,7 @@ getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc)
in
-- PROCESS EXPORT LISTS
- exportsFromAvail this_mod exports all_avails rn_env
+ exportsFromAvail this_mod exports export_avails rn_env
`thenRn` \ (export_fn, export_env) ->
-- RECORD THAT LOCALLY DEFINED THINGS ARE AVAILABLE
@@ -145,7 +145,7 @@ checkEarlyExit mod
\begin{code}
importsFromImportDecl :: RdrNameImportDecl
- -> RnMG (RnEnv, ModuleAvails, [AvailInfo])
+ -> RnMG (RnEnv, ExportAvails, [AvailInfo])
importsFromImportDecl (ImportDecl mod qual_only as_source as_mod import_spec loc)
= pushSrcLocRn loc $
@@ -277,7 +277,7 @@ qualifyImports :: Module -- Imported module
-> Maybe Module -- Optional "as M" part
-> ExportEnv -- What's imported
-> [AvailInfo] -- What's to be hidden
- -> RnMG (RnEnv, ModuleAvails)
+ -> RnMG (RnEnv, ExportAvails)
qualifyImports this_mod qual_imp unqual_imp as_mod (ExportEnv avails fixities) hides
=
@@ -292,11 +292,10 @@ qualifyImports this_mod qual_imp unqual_imp as_mod (ExportEnv avails fixities) h
-- Create the fixity env
fixity_env = foldl (add_fixity name_env2) emptyFixityEnv fixities
- -- The "module M" syntax only applies to *unqualified* imports (1.4 Report, Section 5.1.1)
- mod_avail_env | unqual_imp = unitFM qual_mod avails
- | otherwise = emptyFM
+ -- Create the export-availability info
+ export_avails = mkExportAvails unqual_imp qual_mod avails
in
- returnRn (RnEnv name_env2 fixity_env, mod_avail_env)
+ returnRn (RnEnv name_env2 fixity_env, export_avails)
where
qual_mod = case as_mod of
Nothing -> this_mod
@@ -395,15 +394,17 @@ includes ConcBase.StateAndSynchVar#, and so on...
\begin{code}
exportsFromAvail :: Module
-> Maybe [RdrNameIE] -- Export spec
- -> ModuleAvails
+ -> ExportAvails
-> RnEnv
-> RnMG (Name -> ExportFlag, ExportEnv)
-- Complains if two distinct exports have same OccName
-- Complains about exports items not in scope
-exportsFromAvail this_mod Nothing all_avails rn_env
- = exportsFromAvail this_mod (Just [IEModuleContents this_mod]) all_avails rn_env
+exportsFromAvail this_mod Nothing export_avails rn_env
+ = exportsFromAvail this_mod (Just [IEModuleContents this_mod]) export_avails rn_env
-exportsFromAvail this_mod (Just export_items) all_avails (RnEnv name_env fixity_env)
+exportsFromAvail this_mod (Just export_items)
+ (mod_avail_env, entity_avail_env)
+ (RnEnv name_env fixity_env)
= mapRn exports_from_item export_items `thenRn` \ avail_envs ->
foldlRn plusAvailEnv emptyAvailEnv avail_envs `thenRn` \ export_avail_env ->
let
@@ -414,18 +415,9 @@ exportsFromAvail this_mod (Just export_items) all_avails (RnEnv name_env fixity_
returnRn (export_fn, ExportEnv export_avails export_fixities)
where
- full_avail_env :: UniqFM AvailInfo
- full_avail_env = addListToUFM_C plusAvail emptyUFM
- [(name, avail) | avail <- concat (eltsFM all_avails),
- name <- availEntityNames avail
- ]
-
- -- NB: full_avail_env will contain bindings for class ops but not constructors
- -- (see defn of availEntityNames)
-
exports_from_item :: RdrNameIE -> RnMG AvailEnv
exports_from_item ie@(IEModuleContents mod)
- = case lookupFM all_avails mod of
+ = case lookupFM mod_avail_env mod of
Nothing -> failWithRn emptyAvailEnv (modExportErr mod)
Just avails -> listToAvailEnv ie avails
@@ -449,7 +441,7 @@ exportsFromAvail this_mod (Just export_items) all_avails (RnEnv name_env fixity_
where
maybe_in_scope = lookupNameEnv name_env (ieName ie)
Just name = maybe_in_scope
- maybe_avail = lookupUFM full_avail_env name
+ maybe_avail = lookupUFM entity_avail_env name
Just avail = maybe_avail
export_avail = filterAvail ie avail
enough_avail = case export_avail of {NotAvailable -> False; other -> True}
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 7affaf057dae..ff3620e1750e 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -57,8 +57,8 @@ import SrcLoc ( SrcLoc )
import Unique ( Unique )
import UniqSet ( SYN_IE(UniqSet) )
import UniqFM ( UniqFM, lookupUFM )
-import Util {- ( isIn, isn'tIn, thenCmp, removeDups, cmpPString,
- panic, assertPanic{- , pprTrace ToDo:rm-} ) -}
+import Util
+IMPORT_1_3(List(nub))
\end{code}
rnDecl `renames' declarations.
@@ -213,11 +213,6 @@ rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc))
(classTyVarNotInOpTyErr clas_tyvar sig)
`thenRn_`
- -- Check that class tyvar *doesn't* appear in the sig's context
- checkRn (not (clas_tyvar `elemNameSet` ctxt_fvs))
- (classTyVarInOpCtxtErr clas_tyvar sig)
- `thenRn_`
-
returnRn (ClassOpSig op_name dm_name new_ty locn)
\end{code}
@@ -398,25 +393,34 @@ rnHsSigType :: (PprStyle -> Doc) -> RdrNameHsType -> RnMS s RenamedHsType
-- rnHsSigType is used for source-language type signatures,
-- which use *implicit* universal quantification.
+-- Given the signature C => T we universally quantify over FV(T) \ {in-scope-tyvars}
+--
+-- We insist that the universally quantified type vars is a superset of FV(C)
+-- It follows that FV(T) is a superset of FV(C), so that the context constrains
+-- no type variables that don't appear free in the tau-type part.
+
rnHsSigType doc_str full_ty@(HsPreForAllTy ctxt ty) -- From source code (no kinds on tyvars)
= getNameEnv `thenRn` \ name_env ->
let
- mentioned_tyvars = extractHsTyVars full_ty
- forall_tyvars = filter not_in_scope mentioned_tyvars
- not_in_scope tv = case lookupFM name_env tv of
- Nothing -> True
- Just _ -> False
-
- non_foralld_constrained = [tv | (clas, ty) <- ctxt,
- tv <- extractHsTyVars ty,
- not (tv `elem` forall_tyvars)
- ]
+ mentioned_tyvars = extractHsTyVars ty
+ forall_tyvars = filter (not . in_scope) mentioned_tyvars
+ in_scope tv = maybeToBool (lookupFM name_env tv)
+
+ constrained_tyvars = nub (concat (map (extractHsTyVars . snd) ctxt))
+ constrained_and_in_scope = filter in_scope constrained_tyvars
+ constrained_and_not_mentioned = filter (not . (`elem` mentioned_tyvars)) constrained_tyvars
+
+ -- Zap the context if there's a problem, to avoid duplicate error message.
+ ctxt' | null constrained_and_in_scope && null constrained_and_not_mentioned = ctxt
+ | otherwise = []
in
- checkRn (null non_foralld_constrained)
- (ctxtErr sig_doc non_foralld_constrained) `thenRn_`
+ checkRn (null constrained_and_in_scope)
+ (ctxtErr1 sig_doc constrained_and_in_scope) `thenRn_`
+ checkRn (null constrained_and_not_mentioned)
+ (ctxtErr2 sig_doc constrained_and_not_mentioned ty) `thenRn_`
(bindTyVarsRn sig_doc (map UserTyVar forall_tyvars) $ \ new_tyvars ->
- rnContext ctxt `thenRn` \ new_ctxt ->
+ rnContext ctxt' `thenRn` \ new_ctxt ->
rnHsType ty `thenRn` \ new_ty ->
returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
)
@@ -693,17 +697,12 @@ rnCorePrim (UfCCallOp str casm gc arg_tys res_ty)
\begin{code}
derivingNonStdClassErr clas sty
- = hsep [ptext SLIT("non-standard class in deriving:"), ppr sty clas]
+ = hsep [ptext SLIT("non-standard class"), ppr sty clas, ptext SLIT("in deriving clause")]
classTyVarNotInOpTyErr clas_tyvar sig sty
- = hang (hcat [ptext SLIT("Class type variable `"),
+ = hang (hsep [ptext SLIT("Class type variable"),
ppr sty clas_tyvar,
- ptext SLIT("' does not appear in method signature:")])
- 4 (ppr sty sig)
-
-classTyVarInOpCtxtErr clas_tyvar sig sty
- = hang (hcat [ ptext SLIT("Class type variable `"), ppr sty clas_tyvar,
- ptext SLIT("' present in method's local overloading context:")])
+ ptext SLIT("does not appear in method signature")])
4 (ppr sty sig)
dupClassAssertWarn ctxt dups sty
@@ -718,8 +717,16 @@ badDataCon name sty
allOfNonTyVar ty sty
= hsep [ptext SLIT("`All' applied to a non-type variable:"), ppr sty ty]
-ctxtErr doc tyvars sty
- = hsep [ptext SLIT("Context constrains type variable(s)"),
+ctxtErr1 doc tyvars sty
+ = hsep [ptext SLIT("Context constrains in-scope type variable(s)"),
hsep (punctuate comma (map (ppr sty) tyvars))]
- $$ nest 4 (ptext SLIT("in") <+> doc sty)
+ $$
+ nest 4 (ptext SLIT("in") <+> doc sty)
+
+ctxtErr2 doc tyvars ty sty
+ = (ptext SLIT("Context constrains type variable(s)")
+ <+> hsep (punctuate comma (map (ppr sty) tyvars)))
+ $$
+ nest 4 (vcat [ptext SLIT("that do not appear in") <+> ppr sty ty,
+ ptext SLIT("in") <+> doc sty])
\end{code}
diff --git a/ghc/compiler/tests/rename/rn019.hs b/ghc/compiler/tests/rename/rn019.hs
new file mode 100644
index 000000000000..4ff7c0d9f7d2
--- /dev/null
+++ b/ghc/compiler/tests/rename/rn019.hs
@@ -0,0 +1,4 @@
+module Silly (
+ Array.accum
+ ) where
+import qualified Array
diff --git a/ghc/compiler/tests/rename/rn020.hs b/ghc/compiler/tests/rename/rn020.hs
new file mode 100644
index 000000000000..4b9dbde226b7
--- /dev/null
+++ b/ghc/compiler/tests/rename/rn020.hs
@@ -0,0 +1,11 @@
+-- Duplicate fields in record decls
+
+module OK where
+
+data X = A {a :: Int} | B {a :: Int}
+
+f x = x
+
+-- data Y = V {a :: Int}
+
+-- f y = y
diff --git a/ghc/compiler/tests/rename/rn021.hs b/ghc/compiler/tests/rename/rn021.hs
new file mode 100644
index 000000000000..a9074e2c9201
--- /dev/null
+++ b/ghc/compiler/tests/rename/rn021.hs
@@ -0,0 +1,17 @@
+{- Check that the context of a type does not
+ constrain any in-scope variables, and only constrains
+ type variables free in the type.
+-}
+
+module Foo where
+
+instance Eq a => Eq Bool where
+ (==) = error "help"
+
+
+f :: Eq a => Int -> Int
+f x = x
+
+
+class Foo a where
+ op :: Eq a => a -> a
diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail072.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail072.hs
new file mode 100644
index 000000000000..f7f57a76f4ed
--- /dev/null
+++ b/ghc/compiler/tests/typecheck/should_fail/tcfail072.hs
@@ -0,0 +1,24 @@
+{- This program crashed GHC 2.03
+
+ From: Marc van Dongen <dongen@cs.ucc.ie>
+ Date: Sat, 31 May 1997 14:35:40 +0100 (BST)
+
+ zonkIdOcc: g_aoQ
+
+ panic! (the `impossible' happened):
+ lookupBindC:no info!
+ for: g_aoQ
+ (probably: data dependencies broken by an optimisation pass)
+ static binds for:
+ Tmp.$d1{-rmM,x-}
+ local binds for:
+-}
+
+module Tmp( g ) where
+
+data AB p q = A
+ | B p q
+
+g :: (Ord p,Ord q) => (AB p q) -> Bool
+g (B _ _) = g A
+
diff --git a/ghc/compiler/tests/typecheck/should_succeed/Makefile b/ghc/compiler/tests/typecheck/should_succeed/Makefile
index ce60b0c41624..faa19119eef9 100644
--- a/ghc/compiler/tests/typecheck/should_succeed/Makefile
+++ b/ghc/compiler/tests/typecheck/should_succeed/Makefile
@@ -6,13 +6,14 @@ HS_SRCS = $(wildcard *.hs)
SRC_RUNTEST_OPTS += -o1 $*.stdout -o2 $*.stderr -x 0
HC_OPTS += -noC -ddump-tc -dcore-lint -hi
+# Expect failure. Why aren't they in "should-fail"?
tc075_RUNTEST_OPTS += -x 1
tc080_RUNTEST_OPTS += -x 1
%.o : %.hs
%.o : %.hs
- $(RUNTEST) $(HC) $(RUNTEST_OPTS) -- $(HC_OPTS) -c $< -o $@ -osuf $(subst .,,$(suffix $@))
+ $(RUNTEST) $(HC) $(RUNTEST_OPTS) -- $(HC_OPTS) -c $< -o $@
all :: $(HS_OBJS)
diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc086.hs b/ghc/compiler/tests/typecheck/should_succeed/tc086.hs
new file mode 100644
index 000000000000..4d9ba6edb646
--- /dev/null
+++ b/ghc/compiler/tests/typecheck/should_succeed/tc086.hs
@@ -0,0 +1,60 @@
+{-
+ From: Marc van Dongen <dongen@cs.ucc.ie>
+ Date: Sat, 31 May 1997 19:57:46 +0100 (BST)
+
+ panic! (the `impossible' happened):
+ tcLookupTyVar:a_r6F
+
+ Please report it as a compiler bug to glasgow-haskell-bugs@dcs.gla.ac.uk.
+
+
+If the instance definition for (*) at the end of this toy module
+is replaced by the definition that is commented, this all compiles
+fine. Strange, because the two implementations are equivalent modulo
+the theory {(*) = multiply}.
+
+Remove the `multiply :: a -> a -> a' part, and it compiles without
+problems.
+
+
+SPJ note: the type signature on "multiply" should be
+ multiply :: Group a => a -> a -> a
+
+-}
+
+module Rings( Group, Ring ) where
+
+import qualified Prelude( Ord(..), Eq(..), Num(..) )
+import Prelude hiding( Ord(..), Eq(..), Num(..), MonadZero( zero ) )
+
+class Group a where
+ compare :: a -> a -> Prelude.Ordering
+ fromInteger :: Integer -> a
+ (+) :: a -> a -> a
+ (-) :: a -> a -> a
+ zero :: a
+ one :: a
+ zero = fromInteger 0
+ one = fromInteger 1
+
+-- class (Group a) => Ring a where
+-- (*) :: a -> a -> a
+-- (*) a b =
+-- case (compare a zero) of
+-- EQ -> zero
+-- LT -> zero - ((*) (zero - a) b)
+-- GT -> case compare a one of
+-- EQ -> b
+-- _ -> b + ((*) (a - one) b)
+
+class (Group a) => Ring a where
+ (*) :: a -> a -> a
+ (*) a b = multiply a b
+ where multiply :: Group a => a -> a ->a
+ multiply a b
+ = case (compare a zero) of
+ EQ -> zero
+ LT -> zero - (multiply (zero - a) b)
+ GT -> case compare a one of
+ EQ -> b
+ _ -> b + (multiply (a - one) b)
diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc087.hs b/ghc/compiler/tests/typecheck/should_succeed/tc087.hs
new file mode 100644
index 000000000000..8477427e1176
--- /dev/null
+++ b/ghc/compiler/tests/typecheck/should_succeed/tc087.hs
@@ -0,0 +1,32 @@
+module SOL where
+
+import GlaExts
+
+data SeqView t a = Null
+ | Cons a (t a)
+
+class PriorityQueue q where
+ empty :: (Ord a) => q a
+ single :: (Ord a) => a -> q a
+ insert :: (Ord a) => a -> q a -> q a
+ meld :: (Ord a) => q a -> q a -> q a
+ splitMin :: (Ord a) => q a -> SeqView q a
+ insert a q = single a `meld` q
+
+toOrderedList q = case splitMin q of
+ Null -> []
+ Cons a q -> a : toOrderedList q
+
+insertMany x q = foldr insert q x
+pqSort q x = toOrderedList (insertMany x q)
+
+check :: (PriorityQueue q) => (Ord a => q a) -> IO ()
+check empty = do
+ putStr "*** sorting\n"
+ out (pqSort empty [1 .. 99])
+ out (pqSort empty [1.0, 1.1 ..99.9])
+
+out :: (Num a) => [a] -> IO ()
+out x | sum x == 0 = putStr "ok\n"
+ | otherwise = putStr "ok\n"
+
diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc088.hs b/ghc/compiler/tests/typecheck/should_succeed/tc088.hs
new file mode 100644
index 000000000000..e1b8b88dd6eb
--- /dev/null
+++ b/ghc/compiler/tests/typecheck/should_succeed/tc088.hs
@@ -0,0 +1,18 @@
+-- Check that "->" is an instance of Eval
+
+module Foo where
+
+instance (Eq b) => Eq (a -> b) where
+ (==) f g = error "attempt to compare functions"
+
+ -- Since Eval is a superclass of Num this fails
+ -- unless -> is an instance of Eval
+instance (Num b) => Num (a -> b) where
+ f + g = \a -> f a + g a
+ f - g = \a -> f a - g a
+ f * g = \a -> f a * g a
+ negate f = \a -> negate (f a)
+ abs f = \a -> abs (f a)
+ signum f = \a -> signum (f a)
+ fromInteger n = \a -> fromInteger n
+ fromInt n = \a -> fromInt n
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 6e0740641d7d..9e23da42ff06 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -380,11 +380,14 @@ ppr_inst sty ppr_orig (LitInst u lit ty orig loc)
ppr_inst sty ppr_orig (Dict u clas ty orig loc)
= hang (ppr_orig orig loc)
- 4 (hsep [ppr sty clas, pprParendGenType sty ty, show_uniq sty u])
+ 4 (pprQuote sty $ \ sty ->
+ hsep [ppr sty clas, pprParendGenType sty ty, show_uniq sty u])
ppr_inst sty ppr_orig (Method u id tys rho orig loc)
= hang (ppr_orig orig loc)
- 4 (hsep [ppr sty id, ptext SLIT("at"), interppSP sty tys, show_uniq sty u])
+ 4 (hsep [ppr sty id, ptext SLIT("at"),
+ pprQuote sty $ \ sty -> interppSP sty tys,
+ show_uniq sty u])
show_uniq PprDebug u = ppr PprDebug u
show_uniq sty u = empty
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 6aaedcd9f9ac..8d988abc2ef7 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -239,7 +239,7 @@ tcInstDecl1 mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
other -> ([], [], poly_ty)
(class_name, inst_ty) = case dict_ty of
MonoDictTy cls ty -> (cls,ty)
- other -> pprPanic "Malformed intance decl" (ppr PprDebug poly_ty)
+ other -> pprPanic "Malformed instance decl" (ppr PprDebug poly_ty)
\end{code}
diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index a5ca1ddc4abd..be45c99e8fa6 100644
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -16,8 +16,9 @@ IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds )
import {-# SOURCE #-} TcGRHSs ( tcGRHSsAndBinds )
#endif
-import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
- HsExpr, HsBinds, OutPat, Fake, Stmt,
+import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
+ HsExpr(..), HsBinds(..), MonoBinds(..), OutPat, Fake, Stmt,
+ Sig, HsLit, DoOrListComp, Fixity, HsType, ArithSeqInfo,
collectPatBinders, pprMatch )
import RnHsSyn ( SYN_IE(RenamedMatch) )
import TcHsSyn ( TcIdOcc(..), SYN_IE(TcMatch) )
@@ -27,12 +28,13 @@ import Inst ( Inst, SYN_IE(LIE), plusLIE )
import TcEnv ( newMonoIds )
import TcPat ( tcPat )
import TcType ( SYN_IE(TcType), TcMaybe, zonkTcType )
+import TcSimplify ( bindInstsOfLocalFuns )
import Unify ( unifyTauTy, unifyTauTyList )
import Name ( Name {- instance Outputable -} )
import Kind ( Kind, mkTypeKind )
import Pretty
-import Type ( isTyVarTy, mkFunTy, getFunTy_maybe )
+import Type ( isTyVarTy, isTauTy, mkFunTy, getFunTy_maybe )
import Util
import Outputable
#if __GLASGOW_HASKELL__ >= 202
@@ -149,16 +151,38 @@ tcMatchExpected expected_ty the_match@(PatMatch pat match)
Just (arg_ty,rest_ty) -> -- It's a function type!
let binders = collectPatBinders pat
in
- newMonoIds binders mkTypeKind (\ _ ->
+ newMonoIds binders mkTypeKind (\ mono_ids ->
tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
unifyTauTy pat_ty arg_ty `thenTc_`
tcMatchExpected rest_ty match `thenTc` \ (match', lie_match) ->
- returnTc (PatMatch pat' match',
- plusLIE lie_pat lie_match)
+
+ -- In case there are any polymorpic, overloaded binders in the pattern
+ -- (which can happen in the case of rank-2 type signatures, or data constructors
+ -- with polymorphic arguments), we must dd a bindInstsOfLocalFns here
+ --
+ -- 99% of the time there are no bindings. In the unusual case we
+ -- march down the match to dump them in the right place (boring but easy).
+ bindInstsOfLocalFuns lie_match mono_ids `thenTc` \ (lie_match', inst_mbinds) ->
+ let
+ inst_binds = MonoBind inst_mbinds [] False
+ match'' = case inst_mbinds of
+ EmptyMonoBinds -> match'
+ other -> glue_on match'
+ glue_on (PatMatch p m) = PatMatch p (glue_on m)
+ glue_on (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
+ = (GRHSMatch (GRHSsAndBindsOut grhss
+ (inst_binds `ThenBinds` binds)
+ ty))
+ glue_on (SimpleMatch expr) = SimpleMatch (HsLet inst_binds expr)
+ in
+ returnTc (PatMatch pat' match'',
+ plusLIE lie_pat lie_match')
)
tcMatchExpected expected_ty (GRHSMatch grhss_and_binds)
= tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) ->
+ checkTc (isTauTy expected_ty)
+ lurkingRank2SigErr `thenTc_`
unifyTauTy expected_ty grhss_ty `thenTc_`
returnTc (GRHSMatch grhss_and_binds', lie)
@@ -230,4 +254,7 @@ matchCtxt (MFun fun) match sty
\begin{code}
varyingArgsErr name matches sty
= sep [ptext SLIT("Varying number of arguments for function"), ppr sty name]
+
+lurkingRank2SigErr sty
+ = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
\end{code}
diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs
index 319e386a8e9b..e550d1e9fb69 100644
--- a/ghc/compiler/utils/FiniteMap.lhs
+++ b/ghc/compiler/utils/FiniteMap.lhs
@@ -303,6 +303,7 @@ plusFM_C combiner fm1 (Branch split_key elt2 _ left right)
-- It's worth doing plusFM specially, because we don't need
-- to do the lookup in fm1.
+-- FM2 over-rides FM1.
plusFM EmptyFM fm2 = fm2
plusFM fm1 EmptyFM = fm1
--
GitLab