diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs
index 6bf3a88b0046dddcd98e2cef357dbbee07b12c23..e5c820d2551607c237ef621e570fd3425d9fa095 100644
--- a/ghc/compiler/basicTypes/Var.lhs
+++ b/ghc/compiler/basicTypes/Var.lhs
@@ -150,12 +150,24 @@ setTyVarName = setVarName
\begin{code}
mkTyVar :: Name -> Kind -> TyVar
-mkTyVar name kind = Var { varName = name, realUnique = getKey (nameUnique name),
- varType = kind, varDetails = TyVar }
+mkTyVar name kind = Var { varName = name
+ , realUnique = getKey (nameUnique name)
+ , varType = kind
+ , varDetails = TyVar
+#ifdef DEBUG
+ , varInfo = pprPanic "mkTyVar" (ppr name)
+#endif
+ }
mkSysTyVar :: Unique -> Kind -> TyVar
-mkSysTyVar uniq kind = Var { varName = name, realUnique = getKey uniq,
- varType = kind, varDetails = TyVar }
+mkSysTyVar uniq kind = Var { varName = name
+ , realUnique = getKey uniq
+ , varType = kind
+ , varDetails = TyVar
+#ifdef DEBUG
+ , varInfo = pprPanic "mkSysTyVar" (ppr name)
+#endif
+ }
where
name = mkSysLocalName uniq SLIT("t")
diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index 2f278b28e87fe7c65298c9401e259301f640b955..2e79cc75e605c8a74f7643c98b0efdf287d4f5bc 100644
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -21,7 +21,7 @@ import CoreUtils ( idFreeVars )
import Bag
import Const ( Con(..), DataCon, conType, conOkForApp, conOkForAlt )
import Id ( isConstantId, idMustBeINLINEd )
-import Var ( IdOrTyVar, Id, TyVar, idType, tyVarKind, isTyVar )
+import Var ( IdOrTyVar, Id, TyVar, idType, tyVarKind, isTyVar, isId )
import VarSet
import VarEnv ( mkVarEnv )
import Name ( isLocallyDefined, getSrcLoc )
@@ -147,11 +147,20 @@ We use this to check all unfoldings that come in from interfaces
(it is very painful to catch errors otherwise):
\begin{code}
-lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr
+lintUnfolding :: SrcLoc
+ -> [IdOrTyVar] -- Treat these as in scope
+ -> CoreExpr
+ -> Maybe CoreExpr
-lintUnfolding locn expr
+lintUnfolding locn vars expr
+ | not opt_DoCoreLinting
+ = Just expr
+
+ | otherwise
= case
- initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
+ initL (addLoc (ImportedUnfolding locn) $
+ addInScopeVars vars $
+ lintCoreExpr expr)
of
Nothing -> Just expr
Just msg ->
@@ -560,13 +569,13 @@ checkBndrIdInScope binder id
ppr binder
checkInScope :: SDoc -> IdOrTyVar -> LintM ()
-checkInScope loc_msg id loc scope errs
- | isLocallyDefined id
- && not (id `elemVarSet` scope)
- && not (idMustBeINLINEd id) -- Constructors and dict selectors
- -- don't have bindings,
- -- just MustInline prags
- = (Nothing, addErr errs (hsep [ppr id, loc_msg]) loc)
+checkInScope loc_msg var loc scope errs
+ | isLocallyDefined var
+ && not (var `elemVarSet` scope)
+ && not (isId var && idMustBeINLINEd var) -- Constructors and dict selectors
+ -- don't have bindings,
+ -- just MustInline prags
+ = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc)
| otherwise
= (Nothing,errs)
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 494857ad8b10d1c4571d42b513c591a210af7abc..8bf17a65495a43d68203e003af4ba8e93d14e663 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -91,6 +91,7 @@ module CmdLineOpts (
opt_UnfoldingKeenessFactor,
opt_Verbose,
+
opt_WarnNameShadowing,
opt_WarnUnusedMatches,
opt_WarnUnusedBinds,
@@ -98,6 +99,7 @@ module CmdLineOpts (
opt_WarnIncompletePatterns,
opt_WarnOverlappingPatterns,
opt_WarnSimplePatterns,
+ opt_WarnTypeDefaults,
opt_WarnMissingMethods,
opt_WarnDuplicateExports,
opt_WarnHiShadows,
@@ -352,6 +354,7 @@ opt_WarnHiShadows = lookUp SLIT("-fwarn-hi-shadowing")
opt_WarnIncompletePatterns = lookUp SLIT("-fwarn-incomplete-patterns")
opt_WarnOverlappingPatterns = lookUp SLIT("-fwarn-overlapping-patterns")
opt_WarnSimplePatterns = lookUp SLIT("-fwarn-simple-patterns")
+opt_WarnTypeDefaults = lookUp SLIT("-fwarn-type-defaults")
opt_WarnUnusedMatches = lookUp SLIT("-fwarn-unused-matches")
opt_WarnUnusedBinds = lookUp SLIT("-fwarn-unused-binds")
opt_WarnUnusedImports = lookUp SLIT("-fwarn-unused-imports")
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 5010eed132397e658715963a79ad22b523bf0366..5baa12f9dc27b4b4d884cbd54ee1281f5b8932e1 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -11,7 +11,7 @@ module RnIfaces (
importDecl, recordSlurp,
getImportVersions, getSlurpedNames, getRnStats, getImportedFixities,
- checkUpToDate, loadHomeInterface,
+ checkUpToDate,
getDeclBinders,
mkSearchPath
@@ -72,7 +72,6 @@ import Outputable
import IO ( isDoesNotExistError )
import List ( nub )
-
\end{code}
@@ -784,10 +783,26 @@ getSpecialInstModules
= getIfacesRn `thenRn` \ ifaces ->
returnRn (iInstMods ifaces)
-getImportedFixities :: RnMG FixityEnv
-getImportedFixities
- = getIfacesRn `thenRn` \ ifaces ->
+getImportedFixities :: GlobalRdrEnv -> RnMG FixityEnv
+ -- Get all imported fixities
+ -- We first make sure that all the home modules
+ -- of all in-scope variables are loaded.
+getImportedFixities gbl_env
+ = let
+ home_modules = [ nameModule name | names <- rdrEnvElts gbl_env,
+ name <- names,
+ not (isLocallyDefined name)
+ ]
+ in
+ mapRn load (nub home_modules) `thenRn_`
+
+ -- Now we can snaffle the fixity env
+ getIfacesRn `thenRn` \ ifaces ->
returnRn (iFixes ifaces)
+ where
+ load mod = loadInterface doc_str mod
+ where
+ doc_str = ptext SLIT("Need fixities from") <+> ppr mod
\end{code}
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 926fd59b402cb28bc040235f7e7bcaddec37f1e2..2eb5a8de42de0c3f26ed1f548363c92af78274cf 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -24,7 +24,7 @@ import RdrHsSyn ( RdrNameIE, RdrNameImportDecl,
RdrNameHsModule, RdrNameHsDecl
)
import RnIfaces ( getInterfaceExports, getDeclBinders, getImportedFixities,
- recordSlurp, checkUpToDate, loadHomeInterface
+ recordSlurp, checkUpToDate
)
import RnEnv
import RnMonad
@@ -42,7 +42,6 @@ import NameSet ( elemNameSet, emptyNameSet )
import Outputable
import Unique ( getUnique )
import Util ( removeDups, equivClassesByUniq, sortLt )
-import List ( nubBy )
\end{code}
@@ -65,12 +64,15 @@ getGlobalNames :: RdrNameHsModule
getGlobalNames (HsModule this_mod _ exports imports decls mod_loc)
= -- These two fix-loops are to get the right
-- provenance information into a Name
- fixRn (\ ~(rec_exp_fn, _) ->
+ fixRn (\ ~(rec_exported_avails, _) ->
fixRn (\ ~(rec_rn_env, _) ->
let
rec_unqual_fn :: Name -> Bool -- Is this chap in scope unqualified?
rec_unqual_fn = unQualInScope rec_rn_env
+
+ rec_exp_fn :: Name -> ExportFlag
+ rec_exp_fn = mk_export_fn (availsToNameSet rec_exported_avails)
in
setOmitQualFn rec_unqual_fn $
setModuleRn this_mod $
@@ -91,11 +93,11 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc)
imp_gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv imp_gbl_envs
gbl_env = imp_gbl_env `plusGlobalRdrEnv` local_gbl_env
- export_avails :: ExportAvails
- export_avails = foldr plusExportAvails local_mod_avails imp_avails_s
+ all_avails :: ExportAvails
+ all_avails = foldr plusExportAvails local_mod_avails imp_avails_s
in
- returnRn (gbl_env, export_avails)
- ) `thenRn` \ (gbl_env, export_avails) ->
+ returnRn (gbl_env, all_avails)
+ ) `thenRn` \ (gbl_env, all_avails) ->
-- TRY FOR EARLY EXIT
-- We can't go for an early exit before this because we have to check
@@ -117,23 +119,42 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc)
returnRn (junk_exp_fn, Nothing)
else
- -- FIXITIES
- fixitiesFromLocalDecls gbl_env decls `thenRn` \ local_fixity_env ->
- getImportedFixities `thenRn` \ imp_fixity_env ->
- let
- fixity_env = imp_fixity_env `plusNameEnv` local_fixity_env
- rn_env = RnEnv gbl_env fixity_env
- (_, global_avail_env) = export_avails
- in
- traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts fixity_env))) `thenRn_`
-
-- PROCESS EXPORT LISTS
- exportsFromAvail this_mod exports export_avails rn_env `thenRn` \ (export_fn, export_env) ->
+ exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ exported_avails ->
-- DONE
- returnRn (export_fn, Just (export_env, rn_env, global_avail_env))
- ) `thenRn` \ (_, result) ->
- returnRn result
+ returnRn (exported_avails, Just (all_avails, gbl_env))
+ ) `thenRn` \ (exported_avails, maybe_stuff) ->
+
+ case maybe_stuff of {
+ Nothing -> returnRn Nothing ;
+ Just (all_avails, gbl_env) ->
+
+
+ -- DEAL WITH FIXITIES
+ fixitiesFromLocalDecls gbl_env decls `thenRn` \ local_fixity_env ->
+ getImportedFixities gbl_env `thenRn` \ imp_fixity_env ->
+ let
+ -- Export only those fixities that are for names that are
+ -- (a) defined in this module
+ -- (b) exported
+ exported_fixities :: [(Name,Fixity)]
+ exported_fixities = [(name,fixity) | FixitySig name fixity _ <- nameEnvElts local_fixity_env,
+ isLocallyDefined name
+ ]
+
+ fixity_env = imp_fixity_env `plusNameEnv` local_fixity_env
+ in
+ traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts fixity_env))) `thenRn_`
+
+ --- TIDY UP
+ let
+ export_env = ExportEnv exported_avails exported_fixities
+ rn_env = RnEnv gbl_env fixity_env
+ (_, global_avail_env) = all_avails
+ in
+ returnRn (Just (export_env, rn_env, global_avail_env))
+ }
where
junk_exp_fn = error "RnNames:export_fn"
@@ -198,26 +219,6 @@ importsFromImportDecl (ImportDecl imp_mod qual_only as_mod import_spec iloc)
filterImports imp_mod import_spec avails `thenRn` \ (filtered_avails, hides, explicits) ->
- -- Load all the home modules for the things being
- -- bought into scope. This makes sure their fixities
- -- are loaded before we grab the FixityEnv from Ifaces
- let
- home_modules = [name | avail <- filtered_avails,
- -- Doesn't take account of hiding, but that doesn't matter
-
- let name = availName avail,
- not (isLocallyDefined name || nameModule name == imp_mod)
- -- Don't try to load the module being compiled
- -- (this can happen in mutual-recursion situations)
- -- or from the module being imported (it's already loaded)
- ]
-
- same_module n1 n2 = nameModule n1 == nameModule n2
- load n = loadHomeInterface (doc_str n) n
- doc_str n = ptext SLIT("Need fixities from") <+> ppr (nameModule n) <+> parens (ppr n)
- in
- mapRn load (nubBy same_module home_modules) `thenRn_`
-
-- 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
@@ -515,40 +516,25 @@ type ExportOccMap = FiniteMap OccName (Name, RdrNameIE)
exportsFromAvail :: Module
-> Maybe [RdrNameIE] -- Export spec
-> ExportAvails
- -> RnEnv
- -> RnMG (Name -> ExportFlag, ExportEnv)
+ -> GlobalRdrEnv
+ -> RnMG Avails
-- Complains if two distinct exports have same OccName
-- Warns about identical exports.
-- Complains about exports items not in scope
-exportsFromAvail this_mod Nothing export_avails rn_env
- = exportsFromAvail this_mod (Just [IEModuleContents this_mod]) export_avails rn_env
+exportsFromAvail this_mod Nothing export_avails global_name_env
+ = exportsFromAvail this_mod (Just [IEModuleContents this_mod])
+ export_avails global_name_env
exportsFromAvail this_mod (Just export_items)
(mod_avail_env, entity_avail_env)
- (RnEnv global_name_env fixity_env)
+ global_name_env
= foldlRn exports_from_item
([], emptyFM, emptyNameEnv) export_items `thenRn` \ (_, _, export_avail_map) ->
let
export_avails :: [AvailInfo]
export_avails = nameEnvElts export_avail_map
-
- export_names :: NameSet
- export_names = availsToNameSet export_avails
-
- -- Export only those fixities that are for names that are
- -- (a) defined in this module
- -- (b) exported
- export_fixities :: [(Name,Fixity)]
- export_fixities = [ (name,fixity)
- | FixitySig name fixity _ <- nameEnvElts fixity_env,
- name `elemNameSet` export_names,
- isLocallyDefined name
- ]
-
- export_fn :: Name -> ExportFlag
- export_fn = mk_export_fn export_names
in
- returnRn (export_fn, ExportEnv export_avails export_fixities)
+ returnRn export_avails
where
exports_from_item :: ExportAccum -> RdrNameIE -> RnMG ExportAccum
diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index f0b4b725b428c7fd4c917f445d2b20d32a5988be..97e38a34884c2a5829ace66102bf43e84028b791 100644
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -50,7 +50,7 @@ import PrelInfo ( unpackCStringId, unpackCString2Id,
int2IntegerId, addr2IntegerId
)
import Type ( Type, splitAlgTyConApp_maybe,
- isUnLiftedType, mkTyVarTy,
+ isUnLiftedType,
tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
Type
)
diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 6c5d53d9079c365d0a261e7c18d20241c6ce0566..9c5c64743d1b4c4d21712a06f38712b9c7371293 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -30,8 +30,8 @@ import Maybes ( maybeToBool )
import Const ( Con(..) )
import Name ( isLocalName )
import SimplMonad
-import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, mkTyVarTys,
- splitTyConApp_maybe, mkTyVarTy, substTyVar
+import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys,
+ splitTyConApp_maybe, substTyVar, mkTyVarTys
)
import Var ( setVarUnique )
import VarSet
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 39ff6052e8a396b6468524129d3b024d88ee47bd..d4063e250bf9ab547266999da1c3c25ca51bb476 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -1032,7 +1032,13 @@ rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff
rebuild expr cont
= tick LeavesExamined `thenSmpl_`
- do_rebuild expr cont
+ case expr of
+ Var v -> case getIdStrictness v of
+ NoStrictnessInfo -> do_rebuild expr cont
+ StrictnessInfo demands result_bot _ -> ASSERT( not (null demands) || result_bot )
+ -- If this happened we'd get an infinite loop
+ rebuild_strict demands result_bot expr (idType v) cont
+ other -> do_rebuild expr cont
rebuild_done expr
= getInScope `thenSmpl` \ in_scope ->
@@ -1053,16 +1059,8 @@ do_rebuild expr (ArgOf _ cont_fn _) = cont_fn expr
-- ApplyTo continuation
do_rebuild expr cont@(ApplyTo _ arg se cont')
- = case expr of
- Var v -> case getIdStrictness v of
- NoStrictnessInfo -> non_strict_case
- StrictnessInfo demands result_bot _ -> ASSERT( not (null demands) || result_bot )
- -- If this happened we'd get an infinite loop
- rebuild_strict demands result_bot expr (idType v) cont
- other -> non_strict_case
- where
- non_strict_case = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
- do_rebuild (App expr arg') cont'
+ = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' ->
+ do_rebuild (App expr arg') cont'
---------------------------------------------------------
@@ -1072,9 +1070,6 @@ do_rebuild expr (CoerceIt _ to_ty se cont)
= setSubstEnv se $
simplType to_ty `thenSmpl` \ to_ty' ->
do_rebuild (mk_coerce to_ty' expr) cont
- where
- mk_coerce to_ty' (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty' from_ty) expr
- mk_coerce to_ty' expr = Note (Coerce to_ty' (coreExprType expr)) expr
---------------------------------------------------------
@@ -1209,6 +1204,8 @@ If so, then we can replace the case with one of the rhss.
\begin{code}
---------------------------------------------------------
-- Rebuiling a function with strictness info
+-- This just a version of do_rebuild, enhanced with info about
+-- the strictness of the thing being rebuilt.
rebuild_strict :: [Demand] -> Bool -- Stricness info
-> OutExpr -> OutType -- Function and type
@@ -1218,6 +1215,11 @@ rebuild_strict :: [Demand] -> Bool -- Stricness info
rebuild_strict [] True fun fun_ty cont = rebuild_bot fun fun_ty cont
rebuild_strict [] False fun fun_ty cont = do_rebuild fun cont
+rebuild_strict ds result_bot fun fun_ty (CoerceIt _ to_ty se cont)
+ = setSubstEnv se $
+ simplType to_ty `thenSmpl` \ to_ty' ->
+ rebuild_strict ds result_bot (mk_coerce to_ty' fun) to_ty' cont
+
rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont)
-- Type arg; don't consume a demand
= setSubstEnv se (simplType ty_arg) `thenSmpl` \ ty_arg' ->
@@ -1225,7 +1227,8 @@ rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont)
(applyTy fun_ty ty_arg') cont
rebuild_strict (d:ds) result_bot fun fun_ty (ApplyTo _ val_arg se cont)
- | isStrict d || isUnLiftedType arg_ty -- Strict value argument
+ | isStrict d || isUnLiftedType arg_ty
+ -- Strict value argument
= getInScope `thenSmpl` \ in_scope ->
let
cont_ty = contResultType in_scope res_ty cont
@@ -1248,6 +1251,7 @@ rebuild_strict ds result_bot fun fun_ty cont = do_rebuild fun cont
-- Dealing with
-- * case (error "hello") of { ... }
-- * (error "Hello") arg
+-- * f (error "Hello") where f is strict
-- etc
rebuild_bot expr expr_ty Stop -- No coerce needed
@@ -1259,13 +1263,17 @@ rebuild_bot expr expr_ty (CoerceIt _ to_ty se Stop) -- Don't "tick" on this,
simplType to_ty `thenSmpl` \ to_ty' ->
rebuild_done (mkNote (Coerce to_ty' expr_ty) expr)
-rebuild_bot expr expr_ty cont
+rebuild_bot expr expr_ty cont -- Abandon the (strict) continuation,
+ -- and just return expr
= tick CaseOfError `thenSmpl_`
getInScope `thenSmpl` \ in_scope ->
let
result_ty = contResultType in_scope expr_ty cont
in
rebuild_done (mkNote (Coerce result_ty expr_ty) expr)
+
+mk_coerce to_ty (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty from_ty) expr
+mk_coerce to_ty expr = Note (Coerce to_ty (coreExprType expr)) expr
\end{code}
Blob of helper functions for the "case-of-something-else" situation.
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 1ac48cfd87ddc1118b08bffb7d2f0b06949a88d6..ba0fa38e7adf2b385d8ca0b9e5e3b14c60ecc04f 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -24,6 +24,7 @@ import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
)
import TcEnv ( tcExtendLocalValEnv,
newSpecPragmaId,
+ tcLookupTyCon,
tcGetGlobalTyVars, tcExtendGlobalTyVars
)
import TcSimplify ( tcSimplify, tcSimplifyAndCheck )
@@ -39,11 +40,13 @@ import TcType ( TcType, TcThetaType,
)
import TcUnify ( unifyTauTy, unifyTauTyLists )
+import PrelInfo ( main_NAME, ioTyCon_NAME )
+
import Id ( mkUserId )
import Var ( idType, idName, setIdInfo )
import IdInfo ( IdInfo, noIdInfo, setInlinePragInfo, InlinePragInfo(..) )
-import Name ( Name )
-import Type ( mkTyVarTy, tyVarsOfTypes,
+import Name ( Name, getName )
+import Type ( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
splitSigmaTy, mkForAllTys, mkFunTys, getTyVar,
mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType,
isUnboxedType, unboxedTypeKind, boxedTypeKind
@@ -52,6 +55,7 @@ import Var ( TyVar, tyVarKind )
import VarSet
import Bag
import Util ( isIn )
+import Maybes ( maybeToBool )
import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
import SrcLoc ( SrcLoc )
import Outputable
@@ -250,18 +254,17 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn
-- TYPECHECK THE BINDINGS
tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) ->
- let
- mono_id_tys = map idType mono_ids
- in
-
-- CHECK THAT THE SIGNATURES MATCH
-- (must do this before getTyVarsToGen)
- checkSigMatch tc_ty_sigs `thenTc` \ (sig_theta, lie_avail) ->
+ checkSigMatch top_lvl binder_names mono_ids tc_ty_sigs `thenTc` \ maybe_sig_theta ->
-- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
-- The tyvars_not_to_gen are free in the environment, and hence
-- candidates for generalisation, but sometimes the monomorphism
-- restriction means we can't generalise them nevertheless
+ let
+ mono_id_tys = map idType mono_ids
+ in
getTyVarsToGen is_unrestricted mono_id_tys lie_req `thenNF_Tc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
-- Finally, zonk the generalised type variables to real TyVars
@@ -288,7 +291,8 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn
-- No polymorphism, so no need to simplify context
returnTc (lie_req, EmptyMonoBinds, [])
else
- if null tc_ty_sigs then
+ case maybe_sig_theta of
+ Nothing ->
-- No signatures, so just simplify the lie
-- NB: no signatures => no polymorphic recursion, so no
-- need to use lie_avail (which will be empty anyway)
@@ -296,7 +300,11 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn
top_lvl real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) ->
returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
- else
+ Just (sig_theta, lie_avail) ->
+ -- There are signatures, and their context is sig_theta
+ -- Furthermore, lie_avail is an LIE containing the 'method insts'
+ -- for the things bound here
+
zonkTcThetaType sig_theta `thenNF_Tc` \ sig_theta' ->
newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (dicts_sig, dict_ids) ->
-- It's important that sig_theta is zonked, because
@@ -682,13 +690,46 @@ The error message here is somewhat unsatisfactory, but it'll do for
now (ToDo).
\begin{code}
-checkSigMatch []
- = returnTc (error "checkSigMatch", emptyLIE)
+checkSigMatch top_lvl binder_names mono_ids sigs
+ | main_bound_here
+ = mapTc check_one_sig sigs `thenTc_`
+ mapTc check_main_ctxt sigs `thenTc_`
+
+ -- Now unify the main_id with IO t, for any old t
+ tcSetErrCtxt mainTyCheckCtxt (
+ tcLookupTyCon ioTyCon_NAME `thenTc` \ ioTyCon ->
+ newTyVarTy boxedTypeKind `thenNF_Tc` \ t_tv ->
+ unifyTauTy ((mkTyConApp ioTyCon [t_tv]))
+ (idType main_mono_id)
+ ) `thenTc_`
+ returnTc (Just ([], emptyLIE))
+
+ | not (null sigs)
+ = mapTc check_one_sig sigs `thenTc_`
+ mapTc check_one_ctxt all_sigs_but_first `thenTc_`
+ returnTc (Just (theta1, sig_lie))
+
+ | otherwise
+ = returnTc Nothing -- No constraints from type sigs
+
+ where
+ (TySigInfo _ id1 _ theta1 _ _ _ _ : all_sigs_but_first) = sigs
+
+ sig1_dict_tys = mk_dict_tys theta1
+ n_sig1_dict_tys = length sig1_dict_tys
+ sig_lie = mkLIE [inst | TySigInfo _ _ _ _ _ _ inst _ <- sigs]
-checkSigMatch tc_ty_sigs@( sig1@(TySigInfo _ id1 _ theta1 _ _ _ _) : all_sigs_but_first )
- = -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
+ maybe_main = find_main top_lvl binder_names mono_ids
+ main_bound_here = maybeToBool maybe_main
+ Just main_mono_id = maybe_main
+
+ -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
-- Doesn't affect substitution
- mapTc check_one_sig tc_ty_sigs `thenTc_`
+ check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc)
+ = tcAddSrcLoc src_loc $
+ tcAddErrCtxtM (sigCtxt (sig_msg id) (idType id)) $
+ checkSigTyVars sig_tyvars
+
-- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
-- The type signatures on a mutually-recursive group of definitions
@@ -697,15 +738,7 @@ checkSigMatch tc_ty_sigs@( sig1@(TySigInfo _ id1 _ theta1 _ _ _ _) : all_sigs_bu
-- We unify them because, with polymorphic recursion, their types
-- might not otherwise be related. This is a rather subtle issue.
-- ToDo: amplify
- mapTc check_one_cxt all_sigs_but_first `thenTc_`
-
- returnTc (theta1, sig_lie)
- where
- sig1_dict_tys = mk_dict_tys theta1
- n_sig1_dict_tys = length sig1_dict_tys
- sig_lie = mkLIE [inst | TySigInfo _ _ _ _ _ _ inst _ <- tc_ty_sigs]
-
- check_one_cxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
+ check_one_ctxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
= tcAddSrcLoc src_loc $
tcAddErrCtxt (sigContextsCtxt id1 id) $
checkTc (length this_sig_dict_tys == n_sig1_dict_tys)
@@ -714,15 +747,23 @@ checkSigMatch tc_ty_sigs@( sig1@(TySigInfo _ id1 _ theta1 _ _ _ _) : all_sigs_bu
where
this_sig_dict_tys = mk_dict_tys theta
- check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxtM (sigCtxt (sig_msg id) (idType id)) $
- checkSigTyVars sig_tyvars
+ -- CHECK THAT FOR A GROUP INVOLVING Main.main, all
+ -- the signature contexts are empty (what a bore)
+ check_main_ctxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
+ = tcAddSrcLoc src_loc $
+ checkTc (null theta) (mainContextsErr id)
mk_dict_tys theta = [mkDictTy c ts | (c,ts) <- theta]
sig_msg id tidy_ty = sep [ptext SLIT("When checking the type signature"),
nest 4 (ppr id <+> dcolon <+> ppr tidy_ty)]
+
+ -- Search for Main.main in the binder_names, return corresponding mono_id
+ find_main NotTopLevel binder_names mono_ids = Nothing
+ find_main TopLevel binder_names mono_ids = go binder_names mono_ids
+ go [] [] = Nothing
+ go (n:ns) (m:ms) | n == main_NAME = Just m
+ | otherwise = go ns ms
\end{code}
@@ -904,11 +945,20 @@ bindSigsCtxt ids
-----------------------------------------------
sigContextsErr
= ptext SLIT("Mismatched contexts")
+
sigContextsCtxt s1 s2
= hang (hsep [ptext SLIT("When matching the contexts of the signatures for"),
quotes (ppr s1), ptext SLIT("and"), quotes (ppr s2)])
4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
+mainContextsErr id
+ | getName id == main_NAME = ptext SLIT("Main.main cannot be overloaded")
+ | otherwise
+ = quotes (ppr id) <+> ptext SLIT("cannot be overloaded, because it is mutually recursive with Main.main")
+
+mainTyCheckCtxt
+ = hsep [ptext SLIT("When checking that"), ppr main_NAME, ptext SLIT("has the required type")]
+
-----------------------------------------------
unliftedBindErr flavour mbind
= hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed"))
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 158e22b4e05b0070fb80dac6430b97ba6ac2343f..3c63d34acbaaf99e02e5c25fee4c41c1059e7eb6 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -265,7 +265,9 @@ tcLookupTy name
maybe_arity | isSynTyCon tc = Just (tyConArity tc)
| otherwise = Nothing
- Nothing -> pprPanic "tcLookupTy" (ppr name)
+ Nothing -> -- This can happen if an interface-file
+ -- unfolding is screwed up
+ failWithTc (tyNameOutOfScope name)
}
tcLookupClass :: Name -> NF_TcM s Class
@@ -422,4 +424,7 @@ badCon con_id
= quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
badPrimOp op
= quotes (ppr op) <+> ptext SLIT("is not a primop")
+
+tyNameOutOfScope name
+ = quotes (ppr name) <+> ptext SLIT("is not in scope")
\end{code}
diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 40cc5dfc86bca853d29a85cbf08e9459a96ca144..9500baf9cdd9b395ce190f10de9cf1e1e442e0fd 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -31,6 +31,7 @@ import Const ( Con(..), Literal(..) )
import CoreSyn
import CoreUtils ( coreExprType )
import CoreUnfold
+import CoreLint ( lintUnfolding )
import WwLib ( mkWrapper )
import PrimOp ( PrimOp(..) )
@@ -41,7 +42,7 @@ import IdInfo
import DataCon ( dataConSig, dataConArgTys )
import SpecEnv ( addToSpecEnv )
import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp )
-import Var ( mkTyVar, tyVarKind )
+import Var ( IdOrTyVar, mkTyVar, tyVarKind )
import VarEnv
import Name ( Name, NamedThing(..) )
import Unique ( rationalTyConKey )
@@ -90,7 +91,7 @@ tcIdInfo unf_env name ty info info_ins
tcPrag info (HsUnfold inline_prag maybe_expr)
= (case maybe_expr of
- Just expr -> tcPragExpr unf_env name expr
+ Just expr -> tcPragExpr unf_env name [] expr
Nothing -> returnNF_Tc Nothing
) `thenNF_Tc` \ maybe_expr' ->
let
@@ -115,7 +116,7 @@ tcIdInfo unf_env name ty info info_ins
-- type variables of the function; this is, after all, an
-- interface file generated by the compiler!
- tcPragExpr unf_env name rhs `thenNF_Tc` \ maybe_rhs' ->
+ tcPragExpr unf_env name tyvars' rhs `thenNF_Tc` \ maybe_rhs' ->
let
-- If spec_env isn't looked at, none of this
-- actually takes place
@@ -165,13 +166,16 @@ For unfoldings we try to do the job lazily, so that we never type check
an unfolding that isn't going to be looked at.
\begin{code}
-tcPragExpr :: ValueEnv -> Name -> UfExpr Name -> NF_TcM s (Maybe CoreExpr)
-tcPragExpr unf_env name core_expr
+tcPragExpr :: ValueEnv -> Name -> [IdOrTyVar] -> UfExpr Name -> NF_TcM s (Maybe CoreExpr)
+tcPragExpr unf_env name in_scope_vars core_expr
= forkNF_Tc (
recoverNF_Tc no_unfolding (
tcSetValueEnv unf_env $
tcCoreExpr core_expr `thenTc` \ core_expr' ->
- returnTc (Just core_expr')
+
+ -- Check for type consistency in the unfolding
+ tcGetSrcLoc `thenNF_Tc` \ src_loc ->
+ returnTc (lintUnfolding src_loc in_scope_vars core_expr')
))
where
-- The trace tells what wasn't available, for the benefit of
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 0358f11e88e348303535ba90d75d88d7f102f73a..14e6a7a6af3efc5f9aa522f80e883f49ca7af849 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -52,16 +52,15 @@ import Name ( Name, nameUnique, isLocallyDefined, pprModule, NamedThing(..) )
import TyCon ( TyCon, tyConKind )
import DataCon ( dataConId )
import Class ( Class, classSelIds, classTyCon )
-import Type ( mkTyConApp, mkForAllTy, mkTyVarTy,
+import Type ( mkTyConApp, mkForAllTy,
boxedTypeKind, getTyVar, Type )
import TysWiredIn ( unitTy )
import PrelMods ( mAIN )
-import PrelInfo ( main_NAME, ioTyCon_NAME,
- thinAirIdNames, setThinAirIds
- )
+import PrelInfo ( main_NAME, thinAirIdNames, setThinAirIds )
import TcUnify ( unifyTauTy )
import Unique ( Unique )
import UniqSupply ( UniqSupply )
+import Maybes ( maybeToBool )
import Util
import Bag ( Bag, isEmptyBag )
import Outputable
@@ -224,8 +223,6 @@ tcModule rn_name_supply
tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
- -- Check that "main" has the right signature
- tcCheckMainSig mod_name `thenTc_`
-- Deal with constant or ambiguous InstIds. How could
-- there be ambiguous ones? They can only arise if a
@@ -241,9 +238,16 @@ tcModule rn_name_supply
in
tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
+ -- Check that Main defines main
+ (if mod_name == mAIN then
+ tcLookupValueMaybe main_NAME `thenNF_Tc` \ maybe_main ->
+ checkTc (maybeToBool maybe_main) noMainErr
+ else
+ returnTc ()
+ ) `thenTc_`
-- Backsubstitution. This must be done last.
- -- Even tcCheckMainSig and tcSimplifyTop may do some unification.
+ -- Even tcSimplifyTop may do some unification.
let
all_binds = data_binds `AndMonoBinds`
val_binds `AndMonoBinds`
@@ -278,45 +282,8 @@ get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
\begin{code}
-tcCheckMainSig mod_name
- | mod_name /= mAIN
- = returnTc () -- A non-main module
-
- | otherwise
- = -- Check that main is defined
- tcLookupTyCon ioTyCon_NAME `thenTc` \ ioTyCon ->
- tcLookupValueMaybe main_NAME `thenNF_Tc` \ maybe_main_id ->
- case maybe_main_id of {
- Nothing -> failWithTc noMainErr ;
- Just main_id ->
-
- -- Check that it has the right type (or a more general one)
- -- As of Haskell 98, anything that unifies with (IO a) is OK.
- newTyVarTy boxedTypeKind `thenNF_Tc` \ t_tv ->
- let
- tv = getTyVar "tcCheckMainSig" t_tv
- expected_tau = typeToTcType ((mkTyConApp ioTyCon [t_tv]))
- in
- tcId main_NAME `thenNF_Tc` \ (_, lie, main_tau) ->
- tcSetErrCtxt mainTyCheckCtxt $
- unifyTauTy expected_tau
- main_tau `thenTc_`
- checkTc (isEmptyBag lie) (mainTyMisMatch expected_tau (idType main_id))
- }
-
-
-mainTyCheckCtxt
- = hsep [ptext SLIT("When checking that"), ppr main_NAME, ptext SLIT("has the required type")]
-
noMainErr
= hsep [ptext SLIT("Module"), quotes (pprModule mAIN),
ptext SLIT("must include a definition for"), quotes (ppr main_NAME)]
-
-mainTyMisMatch :: TcType -> TcType -> Message
-mainTyMisMatch expected actual
- = hang (hsep [ppr main_NAME, ptext SLIT("has the wrong type")])
- 4 (vcat [
- hsep [ptext SLIT("Expected:"), ppr expected],
- hsep [ptext SLIT("Inferred:"), ppr actual]
- ])
\end{code}
+
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index ad166c1776707d5f828670f67072626a6d0b154f..137c54a9e82bc8eef8fed0bee5273d70a5f40045 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -123,7 +123,7 @@ module TcSimplify (
#include "HsVersions.h"
-import CmdLineOpts ( opt_MaxContextReductionDepth, opt_GlasgowExts )
+import CmdLineOpts ( opt_MaxContextReductionDepth, opt_GlasgowExts, opt_WarnTypeDefaults )
import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
import TcHsSyn ( TcExpr, TcId,
TcMonoBinds, TcDictBinds
@@ -972,7 +972,7 @@ tcSimplifyTop wanted_lie
d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
complain d | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
- | otherwise = addAmbigErr tyVarsOfInst d
+ | otherwise = addAmbigErr tyVarsOfInst d
get_tv d = case getDictClassTys d of
(clas, [ty]) -> getTyVar "tcSimplifyTop" ty
@@ -1034,8 +1034,9 @@ disambigGroup dicts
in
unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) `thenTc_`
reduceContext (text "disambig" <+> ppr dicts)
- try_me [] dicts `thenTc` \ (binds, frees, ambigs) ->
+ try_me [] dicts `thenTc` \ (binds, frees, ambigs) ->
ASSERT( null frees && null ambigs )
+ warnDefault dicts chosen_default_ty `thenTc_`
returnTc binds
| all isCreturnableClass classes
@@ -1112,6 +1113,23 @@ addAmbigErr ambig_tv_fn dict
ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)
(tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
+warnDefault dicts default_ty
+ | not opt_WarnTypeDefaults
+ = returnNF_Tc ()
+
+ | otherwise
+ = tcAddSrcLoc (instLoc (head dicts)) $
+ warnTc True msg
+ where
+ msg | length dicts > 1
+ = (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty))
+ $$ pprInstsInFull tidy_dicts
+ | otherwise
+ = ptext SLIT("Defaulting") <+> quotes (pprInst (head tidy_dicts)) <+>
+ ptext SLIT("to type") <+> quotes (ppr default_ty)
+
+ (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
+
-- Used for top-level irreducibles
addTopInstanceErr dict
= tcAddSrcLoc (instLoc dict) $