Commit 937b23b9 authored by simonpj's avatar simonpj

[project @ 1999-02-04 13:45:24 by simonpj]

a) Fix black hole bug when doing -dshow-rn-trace
   (Involved reorganising where fixity exports are dealt with
    in RnNames/RnIfaces.)

b) Arrange to apply Lint to imported unfoldings when -dcore-lint

c) Add -fwarn-type-defaults to report use of the defaulting rules for types

d) Make it so that f (error "help) --> error "help", if f is strict
   (Changes in Simplify.lhs.)
parent c8f077d4
......@@ -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")
......
......@@ -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)
......
......@@ -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")
......
......@@ -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}
......
......@@ -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
......
......@@ -50,7 +50,7 @@ import PrelInfo ( unpackCStringId, unpackCString2Id,
int2IntegerId, addr2IntegerId
)
import Type ( Type, splitAlgTyConApp_maybe,
isUnLiftedType, mkTyVarTy,
isUnLiftedType,
tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
Type
)
......
......@@ -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
......
......@@ -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.
......
......@@ -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"))
......
......@@ -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}
......@@ -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