diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs
index cbec03c8d197deb226ff4d0771c649c787456a0e..2650e2e53782392cecbfadd12a8bd84678cdb8e1 100644
--- a/ghc/compiler/basicTypes/Module.lhs
+++ b/ghc/compiler/basicTypes/Module.lhs
@@ -183,9 +183,7 @@ instance Ord Module where
\begin{code}
pprModule :: Module -> SDoc
pprModule (Module mod p) = getPprStyle $ \ sty ->
- if userStyle sty then
- text (moduleNameUserString mod)
- else if debugStyle sty then
+ if debugStyle sty then
-- Print the package too
text (show p) <> dot <> pprModuleName mod
else
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index ddc7fec4cd07890f8280762f13d908d60770fb31..83508b525aff604340bd27af26f44415955908ec 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -37,7 +37,7 @@ module Name (
-- Class NamedThing and overloaded friends
NamedThing(..),
- getSrcLoc, isLocallyDefined, getOccString
+ getSrcLoc, isLocallyDefined, getOccString, toRdrName
) where
#include "HsVersions.h"
@@ -423,6 +423,12 @@ nameRdrName :: Name -> RdrName
nameRdrName (Name { n_sort = Local, n_occ = occ }) = mkRdrUnqual occ
nameRdrName (Name { n_sort = sort, n_occ = occ }) = mkRdrQual (moduleName (nameSortModule sort)) occ
+ifaceNameRdrName :: Name -> RdrName
+-- Makes a qualified naem for imported things,
+-- and an unqualified one for local things
+ifaceNameRdrName n | isLocallyDefined n = mkRdrUnqual (nameOccName n)
+ | otherwise = mkRdrQual (moduleName (nameModule n)) (nameOccName n)
+
isUserExportedName (Name { n_prov = LocalDef _ Exported }) = True
isUserExportedName other = False
@@ -622,10 +628,12 @@ class NamedThing a where
getSrcLoc :: NamedThing a => a -> SrcLoc
isLocallyDefined :: NamedThing a => a -> Bool
getOccString :: NamedThing a => a -> String
+toRdrName :: NamedThing a => a -> RdrName
getSrcLoc = nameSrcLoc . getName
isLocallyDefined = isLocallyDefinedName . getName
getOccString x = occNameString (getOccName x)
+toRdrName = ifaceNameRdrName . getName
\end{code}
\begin{code}
diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs
index 8de9aae902f590e06021cac77edcf49f6f4fab48..d52773be47c50b3acdf97d4f70cdc8026ff99daf 100644
--- a/ghc/compiler/basicTypes/OccName.lhs
+++ b/ghc/compiler/basicTypes/OccName.lhs
@@ -19,7 +19,7 @@ module OccName (
mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
- isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc,
+ isSysOcc, isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc, isIPOcc, isValOcc,
occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour,
setOccNameSpace,
@@ -310,6 +310,13 @@ mkSpecOcc = mk_simple_deriv varName "$s"
mkForeignExportOcc = mk_simple_deriv varName "$f"
mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ)
+
+
+isSysOcc :: OccName -> Bool -- True for all these '$' things
+isSysOcc occ = case occNameUserString occ of
+ ('$' : _ ) -> True
+ other -> False -- We don't care about the ':' ones
+ -- isSysOcc is only called for Ids anyway
\end{code}
\begin{code}
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index ea1eeebea2fdf654c4b6f477c3612f32be5d4053..5eefa471ab731ab2c26da3fbc71865311b8d84ca 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -373,8 +373,6 @@ dsExpr (TyApp expr tys)
dsExpr (ExplicitListOut ty xs)
= go xs
where
- list_ty = mkListTy ty
-
go [] = returnDs (mkNilExpr ty)
go (x:xs) = dsExpr x `thenDs` \ core_x ->
go xs `thenDs` \ core_xs ->
@@ -490,10 +488,10 @@ dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds)
-- necessary so that we don't lose sharing
let
- record_in_ty = exprType record_expr'
- (tycon, in_inst_tys, cons) = splitAlgTyConApp record_in_ty
- (_, out_inst_tys, _) = splitAlgTyConApp record_out_ty
- cons_to_upd = filter has_all_fields cons
+ record_in_ty = exprType record_expr'
+ (_, in_inst_tys, cons) = splitAlgTyConApp record_in_ty
+ (_, out_inst_tys, _) = splitAlgTyConApp record_out_ty
+ cons_to_upd = filter has_all_fields cons
mk_val_arg field old_arg_id
= case [rhs | (sel_id, rhs, _) <- rbinds,
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 3c95d90ab6046bbc2151405957f88444c88e8261..181beeb3dd41513a47ee7994310d831ce194bf19 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -288,14 +288,15 @@ mkCoAlgCaseMatchResult var match_alts
where
-- Common stuff
scrut_ty = idType var
- (tycon, tycon_arg_tys, _) = splitAlgTyConApp scrut_ty
+ (tycon, _, _) = splitAlgTyConApp scrut_ty
-- Stuff for newtype
- (con_id, arg_ids, match_result) = head match_alts
- arg_id = head arg_ids
- coercion_bind = NonRec arg_id
- (Note (Coerce (unUsgTy (idType arg_id)) (unUsgTy scrut_ty)) (Var var))
- newtype_sanity = null (tail match_alts) && null (tail arg_ids)
+ (_, arg_ids, match_result) = head match_alts
+ arg_id = head arg_ids
+ coercion_bind = NonRec arg_id (Note (Coerce (unUsgTy (idType arg_id))
+ (unUsgTy scrut_ty))
+ (Var var))
+ newtype_sanity = null (tail match_alts) && null (tail arg_ids)
-- Stuff for data types
data_cons = tyConDataCons tycon
diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index 16f135f4b2c3cb3f2b53f352f1089d192271e412..4e2f98bcbd0d7d3772828da441275b241116c5b1 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -103,15 +103,19 @@ data MonoBinds id pat
| AndMonoBinds (MonoBinds id pat)
(MonoBinds id pat)
- | PatMonoBind pat
- (GRHSs id pat)
- SrcLoc
-
- | FunMonoBind id
+ | FunMonoBind id -- Used for both functions f x = e
+ -- and variables f = \x -> e
+ -- Reason: the Match stuff lets us have an optional
+ -- result type sig f :: a->a = ...mentions a...
Bool -- True => infix declaration
[Match id pat]
SrcLoc
+ | PatMonoBind pat -- The pattern is never a simple variable;
+ -- That case is done by FunMonoBind
+ (GRHSs id pat)
+ SrcLoc
+
| VarMonoBind id -- TRANSLATION
(HsExpr id pat)
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index ccaeac86c9654ed7cd3ae4cb04e81d21ecbda531..ca1b58d012eda1ac85205417d3b96a6354faed02 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -38,6 +38,7 @@ module CmdLineOpts (
opt_D_dump_stg,
opt_D_dump_stranal,
opt_D_dump_tc,
+ opt_D_dump_types,
opt_D_dump_usagesp,
opt_D_dump_worker_wrapper,
opt_D_show_passes,
@@ -324,6 +325,7 @@ opt_D_dump_spec = opt_D_dump_most || lookUp SLIT("-ddump-spec")
opt_D_dump_stg = opt_D_dump_most || lookUp SLIT("-ddump-stg")
opt_D_dump_stranal = opt_D_dump_most || lookUp SLIT("-ddump-stranal")
opt_D_dump_tc = opt_D_dump_most || lookUp SLIT("-ddump-tc")
+opt_D_dump_types = opt_D_dump_most || lookUp SLIT("-ddump-types")
opt_D_dump_rules = opt_D_dump_most || lookUp SLIT("-ddump-rules")
opt_D_dump_usagesp = opt_D_dump_most || lookUp SLIT("-ddump-usagesp")
opt_D_dump_cse = opt_D_dump_most || lookUp SLIT("-ddump-cse")
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 21991ea247fa350f7a3e5f9272ea2be5fd05291b..6ed5e4c8b5f7992f5ef8d62dded68023994d0f06 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -548,7 +548,7 @@ ifaceTyCon tycon
braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels))
]
where
- (tyvars1, theta1, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
+ (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
field_labels = dataConFieldLabels data_con
strict_marks = dataConStrictMarks data_con
name = getName data_con
diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index 2372e4a769f5691fdf7aaae8f7103b8d3dca4e22..93aa715702a8669eacd217a0e2cbd46ac1384d69 100644
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -340,11 +340,12 @@ checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc))
checkValSig other ty loc = parseError "Type signature given for an expression"
--- A variable binding is parsed as an RdrNamePatBind.
+-- A variable binding is parsed as an RdrNameFunMonoBind.
+-- See comments with HsBinds.MonoBinds
isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
= Just (op, True, (l:r:es))
-isFunLhs (HsVar f) es@(_:_) | not (isRdrDataCon f)
+isFunLhs (HsVar f) es | not (isRdrDataCon f)
= Just (f,False,es)
isFunLhs (HsApp f e) es = isFunLhs f (e:es)
isFunLhs (HsPar e) es = isFunLhs e es
diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index b705f8934ac7c835e1f05121d0cc1adc9d2ba59d..d5521bfdf0189640c41d445b4b48a945b6d8ce5f 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.29 2000/03/24 17:49:30 simonpj Exp $
+$Id: Parser.y,v 1.30 2000/05/23 11:35:37 simonpj Exp $
Haskell grammar.
@@ -397,10 +397,6 @@ opt_phase :: { Maybe Int }
: INTEGER { Just (fromInteger $1) }
| {- empty -} { Nothing }
-sigtypes :: { [RdrNameHsType] }
- : sigtype { [ $1 ] }
- | sigtypes ',' sigtype { $3 : $1 }
-
wherebinds :: { RdrNameHsBinds }
: where { cvBinds cvValSig (groupBindings $1) }
@@ -421,13 +417,6 @@ fixdecl :: { RdrBinding }
(Fixity $3 $2) $1))
| n <- $4 ] }
-sigtype :: { RdrNameHsType }
- : ctype { mkHsForAllTy Nothing [] $1 }
-
-sig_vars :: { [RdrName] }
- : sig_vars ',' var { $3 : $1 }
- | var { [ $1 ] }
-
-----------------------------------------------------------------------------
-- Transformation Rules
@@ -485,6 +474,29 @@ ext_name :: { Maybe ExtName }
| STRING STRING { Just (ExtName $2 (Just $1)) }
| {- empty -} { Nothing }
+
+-----------------------------------------------------------------------------
+-- Type signatures
+
+opt_sig :: { Maybe RdrNameHsType }
+ : {- empty -} { Nothing }
+ | '::' sigtype { Just $2 }
+
+opt_asig :: { Maybe RdrNameHsType }
+ : {- empty -} { Nothing }
+ | '::' atype { Just $2 }
+
+sigtypes :: { [RdrNameHsType] }
+ : sigtype { [ $1 ] }
+ | sigtypes ',' sigtype { $3 : $1 }
+
+sigtype :: { RdrNameHsType }
+ : ctype { mkHsForAllTy Nothing [] $1 }
+
+sig_vars :: { [RdrName] }
+ : sig_vars ',' var { $3 : $1 }
+ | var { [ $1 ] }
+
-----------------------------------------------------------------------------
-- Types
@@ -797,14 +809,6 @@ alt :: { RdrNameMatch }
returnP (Match [] [p] $2
(GRHSs $3 $4 Nothing)) }
-opt_sig :: { Maybe RdrNameHsType }
- : {- empty -} { Nothing }
- | '::' sigtype { Just $2 }
-
-opt_asig :: { Maybe RdrNameHsType }
- : {- empty -} { Nothing }
- | '::' atype { Just $2 }
-
ralt :: { [RdrNameGRHS] }
: '->' srcloc exp { [GRHS [ExprStmt $3 $2] $2] }
| gdpats { (reverse $1) }
diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index abd60a07455f2b125f5ac8bc4c720670b074923b..ff10456d0ec8f649f288153de210ce35b16a79e3 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -379,12 +379,6 @@ rnMethodBinds (FunMonoBind name inf matches locn)
mapRn_ (checkPrecMatch inf sel_name) new_matches `thenRn_`
returnRn (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name)
-rnMethodBinds (PatMonoBind (VarPatIn name) grhss locn)
- = pushSrcLocRn locn $
- lookupGlobalOccRn name `thenRn` \ sel_name ->
- rnGRHSs grhss `thenRn` \ (grhss', fvs) ->
- returnRn (PatMonoBind (VarPatIn sel_name) grhss' locn, fvs `addOneFV` sel_name)
-
-- Can't handle method pattern-bindings which bind multiple methods.
rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
= pushSrcLocRn locn $
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 7cef968fe5c289d6d791954ecdedf38c8c702092..8c81f2e3d1078dc74a97e30afd52c415ce6d133b 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -35,17 +35,15 @@ import OccName ( OccName,
)
import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon )
import Type ( funTyCon )
-import Module ( ModuleName, mkThisModule, moduleName, mkVanillaModule )
+import Module ( ModuleName, mkThisModule, moduleName, mkVanillaModule, pprModuleName )
import TyCon ( TyCon )
import FiniteMap
import Unique ( Unique, Uniquable(..) )
-import UniqFM ( emptyUFM, listToUFM, plusUFM_C )
import UniqSupply
import SrcLoc ( SrcLoc, noSrcLoc )
import Outputable
import Util ( removeDups, equivClasses, thenCmp )
import List ( nub )
-import Maybes ( mapMaybe )
\end{code}
@@ -595,46 +593,6 @@ will still have different provenances.
-\subsubsection{ExportAvails}% ================
-
-\begin{code}
-mkEmptyExportAvails :: ModuleName -> ExportAvails
-mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM)
-
-mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails
-mkExportAvails mod_name unqual_imp name_env avails
- = (mod_avail_env, entity_avail_env)
- where
- mod_avail_env = unitFM mod_name unqual_avails
-
- -- unqual_avails is the Avails that are visible in *unqualfied* form
- -- (1.4 Report, Section 5.1.1)
- -- For example, in
- -- import T hiding( f )
- -- we delete f from avails
-
- unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports
- | otherwise = mapMaybe prune avails
-
- prune (Avail n) | unqual_in_scope n = Just (Avail n)
- prune (Avail n) | otherwise = Nothing
- prune (AvailTC n ns) | null uqs = Nothing
- | otherwise = Just (AvailTC n uqs)
- where
- uqs = filter unqual_in_scope ns
-
- unqual_in_scope n = unQualInScope name_env n
-
- entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
- name <- availNames avail]
-
-plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails
-plusExportAvails (m1, e1) (m2, e2)
- = (plusFM_C (++) m1 m2, plusAvailEnv e1 e2)
- -- ToDo: wasteful: we do this once for each constructor!
-\end{code}
-
-
\subsubsection{AvailInfo}% ================
\begin{code}
@@ -768,7 +726,7 @@ warnUnusedModules mods
| not opt_WarnUnusedImports = returnRn ()
| otherwise = mapRn_ (addWarnRn . unused_mod) mods
where
- unused_mod m = ptext SLIT("Module") <+> quotes (ppr m) <+>
+ unused_mod m = ptext SLIT("Module") <+> quotes (pprModuleName m) <+>
ptext SLIT("is imported, but nothing from it is used")
warnUnusedLocalBinds, warnUnusedImports, warnUnusedMatches :: [Name] -> RnM d ()
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 65bf0f83676c3b167827fe5dc73a6e0b85a43956..8669ca64e60c8ebe06f0bd8a62187e79021f4844 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -174,7 +174,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss)
tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats
rhs_sig_tyvars = case maybe_rhs_sig of
Nothing -> []
- Just ty -> extractHsTyRdrNames ty
+ Just ty -> extractHsTyRdrTyVars ty
tyvars_in_pats = extractPatsTyVars pats
forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs
doc_sig = text "a pattern type-signature"
@@ -191,7 +191,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss)
rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
(case maybe_rhs_sig of
Nothing -> returnRn (Nothing, emptyFVs)
- Just ty | opt_GlasgowExts -> rnHsType doc_sig ty `thenRn` \ (ty', ty_fvs) ->
+ Just ty | opt_GlasgowExts -> rnHsPolyType doc_sig ty `thenRn` \ (ty', ty_fvs) ->
returnRn (Just ty', ty_fvs)
| otherwise -> addErrRn (patSigErr ty) `thenRn_`
returnRn (Nothing, emptyFVs)
@@ -638,7 +638,7 @@ mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg neg_op) -- NegApp can occur on the righ
= addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_`
returnRn (OpApp e1 op1 fix1 e2)
where
- (nofix_err, associate_right) = compareFixity fix1 negateFixity
+ (_, associate_right) = compareFixity fix1 negateFixity
---------------------------
-- Default case
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 788440b22545fca7972dba3614d792321a217bbc..275f8302c91961e19eb7ed935480d0905b8196ae 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -34,7 +34,6 @@ import PrelMods
import PrelInfo ( main_RDR )
import UniqFM ( lookupUFM )
import Bag ( bagToList )
-import Maybes ( maybeToBool, catMaybes )
import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) )
import NameSet
import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..),
@@ -46,6 +45,8 @@ import OccName ( setOccNameSpace, dataName )
import SrcLoc ( SrcLoc )
import NameSet ( elemNameSet, emptyNameSet )
import Outputable
+import Maybes ( maybeToBool, catMaybes, mapMaybe )
+import UniqFM ( emptyUFM, listToUFM, plusUFM_C )
import Unique ( getUnique )
import Util ( removeDups, equivClassesByUniq, sortLt )
import List ( partition )
@@ -241,27 +242,29 @@ importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod i
returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod_name)
else
- filterImports imp_mod_name import_spec avails
- `thenRn` \ (filtered_avails, hides, explicits) ->
+ filterImports imp_mod_name import_spec avails `thenRn` \ (filtered_avails, hides, explicits) ->
+ qualifyImports imp_mod_name
+ (not qual_only) -- Maybe want unqualified names
+ as_mod hides
+ (improveAvails imp_mod iloc explicits
+ is_unqual filtered_avails)
+
+
+improveAvails imp_mod iloc explicits is_unqual avails
-- We 'improve' the provenance by setting
-- (a) the import-reason field, so that the Name says how it came into scope
-- including whether it's explicitly imported
-- (b) the print-unqualified field
- -- But don't fiddle with wired-in things or we get in a twist
- let
- improve_prov name =
- setNameProvenance name (NonLocalDef (UserImport imp_mod iloc (is_explicit name))
- (is_unqual name))
- is_explicit name = name `elemNameSet` explicits
- in
- qualifyImports imp_mod_name
- (not qual_only) -- Maybe want unqualified names
- as_mod hides
- filtered_avails improve_prov
- `thenRn` \ (rdr_name_env, mod_avails) ->
+ = map improve_avail avails
+ where
+ improve_avail (Avail n) = Avail (improve n)
+ improve_avail (AvailTC n ns) = AvailTC n (map improve ns) -- n doesn't matter
- returnRn (rdr_name_env, mod_avails)
+ improve name = setNameProvenance name
+ (NonLocalDef (UserImport imp_mod iloc (is_explicit name))
+ (is_unqual name))
+ is_explicit name = name `elemNameSet` explicits
\end{code}
@@ -290,7 +293,6 @@ importsFromLocalDecls mod_name rec_exp_fn decls
Nothing -- no 'as M'
[] -- Hide nothing
avails
- (\n -> n)
where
mod = mkThisModule mod_name
@@ -437,9 +439,6 @@ filterImports mod (Just (want_hiding, import_items)) avails
Nothing -> bale_out item
Just avail -> returnRn [(avail, availNames avail)]
- ok_dotdot_item (AvailTC _ [n]) = False
- ok_dotdot_item other = True
-
check_item item
| not (maybeToBool maybe_in_import_avails) ||
not (maybeToBool maybe_filtered_avail)
@@ -476,14 +475,9 @@ qualifyImports :: ModuleName -- Imported module
-> Maybe ModuleName -- Optional "as M" part
-> [AvailInfo] -- What's to be hidden
-> Avails -- Whats imported and how
- -> (Name -> Name) -- Improves the provenance on imported things
-> RnMG (GlobalRdrEnv, ExportAvails)
- -- NB: the Names in ExportAvails don't have the improve-provenance
- -- function applied to them
- -- We could fix that, but I don't think it matters
-qualifyImports this_mod unqual_imp as_mod hides
- avails improve_prov
+qualifyImports this_mod unqual_imp as_mod hides avails
=
-- Make the name environment. We're talking about a
-- single module here, so there must be no name clashes.
@@ -513,14 +507,49 @@ qualifyImports this_mod unqual_imp as_mod hides
| unqual_imp = env2
| otherwise = env1
where
- env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) better_name
- env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) better_name
- occ = nameOccName name
- better_name = improve_prov name
+ env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) name
+ env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) name
+ occ = nameOccName name
del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names
where
rdr_names = map (mkRdrUnqual . nameOccName) (availNames avail)
+
+
+mkEmptyExportAvails :: ModuleName -> ExportAvails
+mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM)
+
+mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails
+mkExportAvails mod_name unqual_imp name_env avails
+ = (mod_avail_env, entity_avail_env)
+ where
+ mod_avail_env = unitFM mod_name unqual_avails
+
+ -- unqual_avails is the Avails that are visible in *unqualfied* form
+ -- (1.4 Report, Section 5.1.1)
+ -- For example, in
+ -- import T hiding( f )
+ -- we delete f from avails
+
+ unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports
+ | otherwise = mapMaybe prune avails
+
+ prune (Avail n) | unqual_in_scope n = Just (Avail n)
+ prune (Avail n) | otherwise = Nothing
+ prune (AvailTC n ns) | null uqs = Nothing
+ | otherwise = Just (AvailTC n uqs)
+ where
+ uqs = filter unqual_in_scope ns
+
+ unqual_in_scope n = unQualInScope name_env n
+
+ entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
+ name <- availNames avail]
+
+plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails
+plusExportAvails (m1, e1) (m2, e2)
+ = (plusFM_C (++) m1 m2, plusAvailEnv e1 e2)
+ -- ToDo: wasteful: we do this once for each constructor!
\end{code}
diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs
index ad08f3a40df27ca9b56bfc7354b44e1aff081835..97dee5c0cd463671a0d7565545422a948a55c271 100644
--- a/ghc/compiler/simplCore/SimplMonad.lhs
+++ b/ghc/compiler/simplCore/SimplMonad.lhs
@@ -54,6 +54,7 @@ import PprCore () -- Instances
import Rules ( RuleBase )
import CostCentre ( CostCentreStack, subsumedCCS )
import Name ( isLocallyDefined )
+import OccName ( UserFS )
import Var ( TyVar )
import VarEnv
import VarSet
@@ -674,20 +675,19 @@ setSimplBinderStuff (subst, us) m env _ sc
\begin{code}
-newId :: Type -> (Id -> SimplM a) -> SimplM a
+newId :: UserFS -> Type -> (Id -> SimplM a) -> SimplM a
-- Extends the in-scope-env too
-newId ty m env@(SimplEnv {seSubst = subst}) us sc
+newId fs ty m env@(SimplEnv {seSubst = subst}) us sc
= case splitUniqSupply us of
(us1, us2) -> m v (env {seSubst = Subst.extendInScope subst v}) us2 sc
where
- v = mkSysLocal SLIT("s") (uniqFromSupply us1) ty
+ v = mkSysLocal fs (uniqFromSupply us1) ty
-newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a
-newIds tys m env@(SimplEnv {seSubst = subst}) us sc
+newIds :: UserFS -> [Type] -> ([Id] -> SimplM a) -> SimplM a
+newIds fs tys m env@(SimplEnv {seSubst = subst}) us sc
= case splitUniqSupply us of
(us1, us2) -> m vs (env {seSubst = Subst.extendInScopes subst vs}) us2 sc
where
- vs = zipWithEqual "newIds" (mkSysLocal SLIT("s"))
+ vs = zipWithEqual "newIds" (mkSysLocal fs)
(uniqsFromSupply (length tys) us1) tys
-
\end{code}
diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index fd5f21e5cc50fbea0ec615e0478eadd25029d375..f09d6aeb0a31b1ec503c56228ef5c53441eeeb03 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -567,7 +567,7 @@ tryEtaExpansion rhs
= returnSmpl rhs
| otherwise -- Consider eta expansion
- = newIds y_tys $ ( \ y_bndrs ->
+ = newIds SLIT("y") y_tys $ ( \ y_bndrs ->
tick (EtaExpansion (head y_bndrs)) `thenSmpl_`
mapAndUnzipSmpl bind_z_arg (args `zip` trivial_args) `thenSmpl` (\ (maybe_z_binds, z_args) ->
returnSmpl (mkLams x_bndrs $
@@ -582,7 +582,7 @@ tryEtaExpansion rhs
bind_z_arg (arg, trivial_arg)
| trivial_arg = returnSmpl (Nothing, arg)
- | otherwise = newId (exprType arg) $ \ z ->
+ | otherwise = newId SLIT("z") (exprType arg) $ \ z ->
returnSmpl (Just (NonRec z arg), Var z)
-- Note: I used to try to avoid the exprType call by using
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 6cacbdb613c668a3a984071d086bf2b58125ee01..caaa51ea4d8a01944acc8b06754e30a87dc812f1 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -898,7 +898,7 @@ prepareArgs no_case_of_case fun orig_cont thing_inside
= simplValArg arg_ty dem val_arg se (contResultType cont) $ \ new_arg ->
-- A data constructor whose argument is now non-trivial;
-- so let/case bind it.
- newId arg_ty $ \ arg_id ->
+ newId SLIT("a") arg_ty $ \ arg_id ->
addNonRecBind arg_id new_arg $
go (Var arg_id : acc) ds' res_ty cont
@@ -1345,10 +1345,10 @@ prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts
let
ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
+ arg_tys = dataConArgTys data_con
+ (inst_tys ++ mkTyVarTys ex_tyvars')
in
- newIds (dataConArgTys
- data_con
- (inst_tys ++ mkTyVarTys ex_tyvars')) $ \ bndrs ->
+ newIds SLIT("a") arg_tys $ \ bndrs ->
returnSmpl ((DataAlt data_con, ex_tyvars' ++ bndrs, rhs) : alts_no_deflt)
other -> returnSmpl filtered_alts
@@ -1452,13 +1452,15 @@ mkDupableCont ty (InlinePlease cont) thing_inside
mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside
= -- Build the RHS of the join point
- newId join_arg_ty ( \ arg_id ->
+ newId SLIT("a") join_arg_ty ( \ arg_id ->
cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) ->
returnSmpl (Lam (setOneShotLambda arg_id) (mkLets binds rhs))
) `thenSmpl` \ join_rhs ->
-- Build the join Id and continuation
- newId (exprType join_rhs) $ \ join_id ->
+ -- We give it a "$j" name just so that for later amusement
+ -- we can identify any join points that don't end up as let-no-escapes
+ newId SLIT("$j") (exprType join_rhs) $ \ join_id ->
let
new_cont = ArgOf OkToDup cont_ty
(\arg' -> rebuild_done (App (Var join_id) arg'))
@@ -1476,9 +1478,9 @@ mkDupableCont ty (ApplyTo _ arg se cont) thing_inside
if exprIsDupable arg' then
thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
else
- newId (exprType arg') $ \ bndr ->
+ newId SLIT("a") (exprType arg') $ \ bndr ->
- tick (CaseOfCase bndr) `thenSmpl_`
+ tick (CaseOfCase bndr) `thenSmpl_`
-- Want to tick here so that we go round again,
-- and maybe copy or inline the code;
-- not strictly CaseOf Case
@@ -1574,14 +1576,15 @@ mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs)
-- then 78
-- else 5
- then newId realWorldStatePrimTy $ \ rw_id ->
+ then newId SLIT("w") realWorldStatePrimTy $ \ rw_id ->
returnSmpl ([rw_id], [Var realWorldPrimId])
else
returnSmpl (used_bndrs', map varToCoreExpr used_bndrs)
)
`thenSmpl` \ (final_bndrs', final_args) ->
- newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
+ -- See comment about "$j" name above
+ newId SLIT("$j") (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
-- Notice that we make the lambdas into one-shot-lambdas. The
-- join point is sure to be applied at most once, and doing so
diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs
index 350ef60051101118b5735d10f5fc46bd20d7d800..6b3f65f9565d24f46789386225aa8a96895d5134 100644
--- a/ghc/compiler/simplStg/StgVarInfo.lhs
+++ b/ghc/compiler/simplStg/StgVarInfo.lhs
@@ -22,7 +22,8 @@ import IdInfo ( ArityInfo(..), OccInfo(..),
import PrimOp ( PrimOp(..), ccallMayGC )
import TysWiredIn ( isForeignObjTy )
import Maybes ( maybeToBool, orElse )
-import Name ( isLocallyDefined )
+import Name ( isLocallyDefined, getOccName )
+import OccName ( occNameUserString )
import BasicTypes ( Arity )
import Outputable
@@ -543,12 +544,8 @@ vars_let let_no_escape bind body
-- Compute the new let-expression
let
- new_let = if let_no_escape then
- -- trace "StgLetNoEscape!" (
- StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
- -- )
- else
- StgLet bind2 body2
+ new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
+ | otherwise = StgLet bind2 body2
free_in_whole_let
= (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders
@@ -568,6 +565,18 @@ vars_let let_no_escape bind body
-- this let(rec)
no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
+
+#ifdef DEBUG
+ -- Debugging code as requested by Andrew Kennedy
+ checked_no_binder_escapes
+ | not no_binder_escapes && any is_join_var binders
+ = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
+ False
+ | otherwise = no_binder_escapes
+#else
+ checked_no_binder_escapes = no_binder_escapes
+#endif
+
-- Mustn't depend on the passed-in let_no_escape flag, since
-- no_binder_escapes is used by the caller to derive the flag!
in
@@ -575,7 +584,7 @@ vars_let let_no_escape bind body
new_let,
free_in_whole_let,
let_escs,
- no_binder_escapes
+ checked_no_binder_escapes
))
where
set_of_binders = mkVarSet binders
@@ -626,6 +635,11 @@ vars_let let_no_escape bind body
in
returnLne (StgRec (binders' `zip` rhss2), fvs, escs, env_ext)
))
+
+is_join_var :: Id -> Bool
+-- A hack (used only for compiler debuggging) to tell if
+-- a variable started life as a join point ($j)
+is_join_var j = occNameUserString (getOccName j) == "$j"
\end{code}
%************************************************************************
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index b252acae08e0f1d29c4db1f7408080ee0bfbbeca..342529ca9adf77f79d96b8867260fe9f9f71c0d6 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -13,7 +13,7 @@ import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcExpr )
import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..),
- collectMonoBinders, andMonoBindList, andMonoBinds
+ Match(..), collectMonoBinders, andMonoBindList, andMonoBinds
)
import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
@@ -573,13 +573,16 @@ isUnRestrictedGroup :: [Name] -- Signatures given for these
is_elem v vs = isIn "isUnResMono" v vs
-isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs
isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
-isUnRestrictedGroup sigs (FunMonoBind _ _ _ _) = True
+isUnRestrictedGroup sigs (FunMonoBind v _ matches _) = any isUnRestrictedMatch matches ||
+ v `is_elem` sigs
isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
isUnRestrictedGroup sigs mb2
isUnRestrictedGroup sigs EmptyMonoBinds = True
+
+isUnRestrictedMatch (Match _ [] Nothing _) = False -- No args, no signature
+isUnRestrictedMatch other = True -- Some args or a signature
\end{code}
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index efc05e1aa0ec843353dfcb6e27d62d84f6573951..a04654541686ec33312e9188a35025c091e980c3 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -13,8 +13,8 @@ module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, mkImplicitClassBin
import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
InPat(..), HsBinds(..), GRHSs(..),
HsExpr(..), HsLit(..), HsType(..), HsPred(..),
- pprHsClassAssertion, unguardedRHS,
- andMonoBinds, andMonoBindList, getTyVarName,
+ pprHsClassAssertion, mkSimpleMatch,
+ andMonoBinds, andMonoBindList, getTyVarName,
isClassDecl, isClassOpSig, isPragSig, collectMonoBinders
)
import HsPragmas ( ClassPragmas(..) )
@@ -248,8 +248,6 @@ tcClassContext class_name rec_class rec_tyvars context sc_sel_names
returnTc (sc_theta', sc_tys, sc_sel_ids)
where
- rec_tyvar_tys = mkTyVarTys rec_tyvars
-
check_constraint (HsPClass c tys) = checkTc (all is_tyvar tys)
(superClassErr class_name (c, tys))
@@ -605,8 +603,6 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta
-- but we must use the method name; so we substitute it here. Crude but simple.
find_bind meth_name (FunMonoBind op_name fix matches loc)
| op_name == sel_name = Just (FunMonoBind meth_name fix matches loc)
- find_bind meth_name (PatMonoBind (VarPatIn op_name) grhss loc)
- | op_name == sel_name = Just (PatMonoBind (VarPatIn meth_name) grhss loc)
find_bind meth_name (AndMonoBinds b1 b2)
= find_bind meth_name b1 `seqMaybe` find_bind meth_name b2
find_bind meth_name other = Nothing -- Default case
@@ -624,8 +620,9 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta
find_prags meth_name (prag:prags) = find_prags meth_name prags
mk_default_bind local_meth_name loc
- = PatMonoBind (VarPatIn local_meth_name)
- (GRHSs (unguardedRHS (default_expr loc) loc) EmptyBinds Nothing)
+ = FunMonoBind local_meth_name
+ False -- Not infix decl
+ [mkSimpleMatch [] (default_expr loc) Nothing loc]
loc
default_expr loc
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 81b468f66206c2acb90653e94d474b7c9070b190..d940d97651806166441b31e93a3599feb8a6bb15 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -384,7 +384,6 @@ tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
newTyVarTy boxedTypeKind `thenNF_Tc` \ result_ty ->
let
io_result_ty = mkTyConApp ioTyCon [result_ty]
- [ioDataCon] = tyConDataCons ioTyCon
in
unifyTauTy res_ty io_result_ty `thenTc_`
@@ -568,8 +567,8 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
splitSigmaTy (idType sel_id) -- Selectors can be overloaded
-- when the data type has a context
Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector
- (tycon, _, data_cons) = splitAlgTyConApp data_ty
- (con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
+ (tycon, _, data_cons) = splitAlgTyConApp data_ty
+ (con_tyvars, _, _, _, _, _) = dataConSig (head data_cons)
in
tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) ->
diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index de9c9b0f27e039dc7b69262f642c92a21e135b39..cd5d05cac4028e4b8b4085b9728b7e9c9b58a188 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -341,11 +341,11 @@ tcCoreAlt scrut_ty (UfDataAlt con_name, names, rhs)
(main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
- (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty
- ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
- ex_tys' = mkTyVarTys ex_tyvars'
- arg_tys = dataConArgTys con (inst_tys ++ ex_tys')
- id_names = drop (length ex_tyvars) names
+ (_, inst_tys, cons) = splitAlgTyConApp scrut_ty
+ ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
+ ex_tys' = mkTyVarTys ex_tyvars'
+ arg_tys = dataConArgTys con (inst_tys ++ ex_tys')
+ id_names = drop (length ex_tyvars) names
arg_ids
#ifdef DEBUG
| length id_names /= length arg_tys
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index b50818d026746b9164959bcb2d87f1005a8fc97d..882123f387f4001e6231c6b7936090a025a8a70e 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -538,12 +538,9 @@ scrutiniseInstanceHead clas inst_taus
Just (tycon, arg_tys) = maybe_tycon_app
-- Stuff for an *algebraic* data type
- alg_tycon_app_maybe = splitAlgTyConApp_maybe first_inst_tau
- -- The "Alg" part looks through synonyms
- is_alg_tycon_app = maybeToBool alg_tycon_app_maybe
- Just (alg_tycon, _, data_cons) = alg_tycon_app_maybe
-
- constructors_visible = not (null data_cons)
+ alg_tycon_app_maybe = splitAlgTyConApp_maybe first_inst_tau
+ -- The "Alg" part looks through synonyms
+ Just (alg_tycon, _, _) = alg_tycon_app_maybe
ccallable_type ty = isFFIArgumentTy False {- Not safe call -} ty
creturnable_type ty = isFFIResultTy ty
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 4fc393756534722b3939a0b44685e07a643f9539..14adb46edce4ddd68030bd6ad9e05cc4b3b2c297 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -11,7 +11,7 @@ module TcModule (
#include "HsVersions.h"
-import CmdLineOpts ( opt_D_dump_tc )
+import CmdLineOpts ( opt_D_dump_tc, opt_D_dump_types, opt_PprStyle_Debug )
import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) )
import RnHsSyn ( RenamedHsModule )
import TcHsSyn ( TcMonoBinds, TypecheckedMonoBinds,
@@ -27,7 +27,7 @@ import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv, tcExtendTypeEnv,
getEnvTyCons, getEnvClasses, tcLookupValueMaybe,
explicitLookupValueByKey, tcSetValueEnv,
- tcLookupTyCon, initEnv,
+ tcLookupTyCon, initEnv, valueEnvIds,
ValueEnv, TcTyThing(..)
)
import TcExpr ( tcId )
@@ -49,7 +49,10 @@ import Bag ( isEmptyBag )
import ErrUtils ( Message, printErrorsAndWarnings, dumpIfSet )
import Id ( Id, idType )
import Module ( pprModuleName )
-import Name ( Name, nameUnique, isLocallyDefined, NamedThing(..) )
+import OccName ( isSysOcc )
+import Name ( Name, nameUnique, nameOccName, isLocallyDefined,
+ toRdrName, NamedThing(..)
+ )
import TyCon ( TyCon, tyConKind )
import Class ( Class, classSelIds, classTyCon )
import Type ( mkTyConApp, mkForAllTy,
@@ -104,18 +107,19 @@ typecheckModule us rn_name_supply iface_det mod
Nothing -> return ()
) >>
- dumpIfSet opt_D_dump_tc "Typechecked"
- (case maybe_result of
- Just results -> ppr (tc_binds results)
- $$
- pp_rules (tc_rules results)
- Nothing -> text "Typecheck failed") >>
-
+ (case maybe_result of
+ Nothing -> return ()
+ Just results -> dumpIfSet opt_D_dump_tc "Typechecked" (dump_tc results)
+ ) >>
+
return (if isEmptyBag errs then
maybe_result
else
Nothing)
+dump_tc results
+ = ppr (tc_binds results) $$ pp_rules (tc_rules results)
+
pp_rules [] = empty
pp_rules rs = vcat [ptext SLIT("{-# RULES"),
nest 4 (vcat (map ppr rs)),
diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index b036e39fbc6eca5210bde34c5d68b75d10a39278..e193c7eadaa1fe1f139315d246d299c739209687 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -476,7 +476,7 @@ badFieldCon con field
polyPatSig :: TcType -> SDoc
polyPatSig sig_ty
- = hang (ptext SLIT("Polymorphic type signature in pattern"))
+ = hang (ptext SLIT("Illegal polymorphic type signature in pattern:"))
4 (ppr sig_ty)
\end{code}
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 1be4d68ed7baee922aa86657625fb8ba65066b5e..b24673a70e6420c0c4492d1498344a33b66e624d 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -134,18 +134,12 @@ tcDecl :: RecFlag -- True => recursive group
tcDecl is_rec_group unf_env inst_mapper vrcs_env decl
= tcAddDeclCtxt decl $
--- traceTc (text "Starting" <+> ppr name) `thenTc_`
if isClassDecl decl then
tcClassDecl1 unf_env inst_mapper vrcs_env decl `thenTc` \ clas ->
--- traceTc (text "Finished" <+> ppr name) `thenTc_`
returnTc (getName clas, AClass clas)
else
tcTyDecl is_rec_group vrcs_env decl `thenTc` \ tycon ->
--- traceTc (text "Finished" <+> ppr name) `thenTc_`
returnTc (getName tycon, ATyCon tycon)
-
- where
- name = tyClDeclName decl
tcAddDeclCtxt decl thing_inside
@@ -257,7 +251,6 @@ sortByDependency decls
edges = map mk_edges tycl_decls
is_syn_decl (d, _, _) = isSynDecl d
- is_cls_decl (d, _, _) = isClassDecl d
\end{code}
Edges in Type/Class decls