# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.47 1998/12/10 08:54:18 simonpj Exp $
+# $Id: Makefile,v 1.48 1999/01/07 12:48:13 simonpj Exp $
TOP = ..
include $(TOP)/mk/boilerplate.mk
# Heap was 6m with 2.10
reader/ReadPrefix_HC_OPTS = -fvia-C '-\#include"hspincl.h"' -H10m
-rename/ParseIface_HC_OPTS += -Onot -H30m -fno-warn-incomplete-patterns
+rename/ParseIface_HC_OPTS += -Onot -H45m -fno-warn-incomplete-patterns
rename/ParseIface_HAPPY_OPTS += -g
ifeq "$(TARGETPLATFORM)" "hppa1.1-hp-hpux9"
__interface HsExpr 1 0 where
__export HsExpr HsExpr pprExpr;
-1 data HsExpr f i p ;
-1 pprExpr :: __forall [_i _p _f] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => HsExpr.HsExpr _f _i _p -> Outputable.SDoc ;
+1 data HsExpr i p ;
+1 pprExpr :: __forall [_i _p] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => HsExpr.HsExpr _i _p -> Outputable.SDoc ;
__interface HsMatches 1 0 where
-__export HsMatches Match GRHSsAndBinds pprMatch pprMatches pprGRHSsAndBinds ;
-1 data Match a b c ;
-1 data GRHSsAndBinds a b c ;
-1 pprGRHSsAndBinds :: __forall [_i _p _f] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => PrelBase.Bool -> HsMatches.GRHSsAndBinds _f _i _p -> Outputable.SDoc ;
-1 pprMatch :: __forall [_i _p _f] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => PrelBase.Bool -> HsMatches.Match _f _i _p -> Outputable.SDoc ;
-1 pprMatches :: __forall [_i _p _f] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => (PrelBase.Bool, Outputable.SDoc) -> [HsMatches.Match _f _i _p] -> Outputable.SDoc ;
+__export HsMatches Match GRHSs pprMatch pprMatches pprGRHSs ;
+1 data Match a b ;
+1 data GRHSs a b ;
+1 pprGRHSs :: __forall [i p] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsMatches.GRHSs i p -> Outputable.SDoc ;
+1 pprMatch :: __forall [_i _p] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => (PrelBase.Bool, Outputable.SDoc) -> HsMatches.Match _i _p -> Outputable.SDoc ;
+1 pprMatches :: __forall [_i _p] {Name.NamedThing _i, Outputable.Outputable _i, Outputable.Outputable _p} => (PrelBase.Bool, Outputable.SDoc) -> [HsMatches.Match _i _p] -> Outputable.SDoc ;
__interface RnBinds 1 0 where
__export RnBinds rnBinds;
-1 rnBinds :: __forall [_a _b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS _a (_b, RnMonad.FreeVars)) -> RnMonad.RnMS _a (_b, RnMonad.FreeVars) ;
+1 rnBinds :: __forall [_a _b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS _a (_b, RnEnv.FreeVars)) -> RnMonad.RnMS _a (_b, RnEnv.FreeVars) ;
choose n' | n==n' && better_provenance n n' = n
| otherwise = n'
--- Choose a user-imported thing over a non-user-imported thing
--- and an explicitly-imported thing over an implicitly imported thing
+-- Choose
+-- a local thing over an imported thing
+-- a user-imported thing over a non-user-imported thing
+-- an explicitly-imported thing over an implicitly imported thing
better_provenance n1 n2
= case (getNameProvenance n1, getNameProvenance n2) of
+ (LocalDef _ _, _ ) -> True
(NonLocalDef (UserImport _ _ True) _ _, _ ) -> True
(NonLocalDef (UserImport _ _ _ ) _ _, NonLocalDef ImplicitImport _ _) -> True
- other -> False
+ other -> False
no_conflict :: Name -> Name -> Bool
no_conflict n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False
[ (name, (version,avail,decl',name==main_name))
| name <- sys_bndrs ++ availNames avail]
add_decl decls_map (name, stuff)
- = ASSERT2( not (name `elemNameEnv` decls_map), ppr name )
+ = WARN( name `elemNameEnv` decls_map, ppr name )
addToNameEnv decls_map name stuff
in
returnRn new_decls_map
importsFromLocalDecls this_mod rec_exp_fn decls `thenRn` \ (local_gbl_env, local_mod_avails) ->
-- PROCESS IMPORT DECLS
- mapAndUnzipRn (importsFromImportDecl rec_unqual_fn)
+ mapAndUnzipRn (importsFromImportDecl this_mod rec_unqual_fn)
all_imports `thenRn` \ (imp_gbl_envs, imp_avails_s) ->
-- COMBINE RESULTS
\end{code}
\begin{code}
-importsFromImportDecl :: (Name -> Bool) -- True => print unqualified
+importsFromImportDecl :: Module -- The module being compiled
+ -> (Name -> Bool) -- True => print unqualified
-> RdrNameImportDecl
-> RnMG (GlobalRdrEnv,
ExportAvails)
-importsFromImportDecl rec_unqual_fn (ImportDecl mod qual_only as_source as_mod import_spec iloc)
+importsFromImportDecl this_mod rec_unqual_fn (ImportDecl imp_mod qual_only as_source as_mod import_spec iloc)
= pushSrcLocRn iloc $
- getInterfaceExports mod as_source `thenRn` \ avails ->
+ getInterfaceExports imp_mod as_source `thenRn` \ avails ->
if null avails then
-- If there's an error in getInterfaceExports, (e.g. interface
-- file not found) we get lots of spurious errors from 'filterImports'
- returnRn (emptyRdrEnv, mkEmptyExportAvails mod)
+ returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod)
else
- filterImports mod import_spec avails `thenRn` \ (filtered_avails, hides, explicits) ->
+ 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
other -> True,
let name = availName avail,
- nameModule (availName avail) /= mod
- -- This nameModule predicate is a bit of a hack.
- -- PrelBase imports error from PrelErr.hi-boot; but error is
- -- wired in, so its provenance doesn't say it's from an hi-boot
- -- file. Result: disaster when PrelErr.hi doesn't exist.
- -- [Jan 99: I now can't see how the predicate achieves the goal!]
+ 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
| otherwise = setNameProvenance name (mk_new_prov name)
is_explicit name = name `elemNameSet` explicits
- mk_new_prov name = NonLocalDef (UserImport mod iloc (is_explicit name))
+ mk_new_prov name = NonLocalDef (UserImport imp_mod iloc (is_explicit name))
as_source
(rec_unqual_fn name)
in
- qualifyImports mod
+ qualifyImports imp_mod
(not qual_only) -- Maybe want unqualified names
as_mod hides
filtered_avails improve_prov `thenRn` \ (rdr_name_env, mod_avails) ->
available, and filters it through the import spec (if any).
\begin{code}
-filterImports :: Module
+filterImports :: Module -- The module being imported
-> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding
-> [AvailInfo] -- What's available
-> RnMG ([AvailInfo], -- What's actually imported
__interface RnSource 1 0 where
-__export RnSource rnHsSigType;
-1 rnHsSigType :: __forall [_a] => (Outputable.SDoc)
+__export RnSource rnHsSigType rnHsType;
+1 rnHsSigType :: __forall [_a] => Outputable.SDoc
-> RdrHsSyn.RdrNameHsType
- -> RnMonad.RnMS _a RnHsSyn.RenamedHsType ;
+ -> RnMonad.RnMS _a (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;
+1 rnHsType :: __forall [_a] => Outputable.SDoc
+ -> RdrHsSyn.RdrNameHsType
+ -> RnMonad.RnMS _a (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;
__interface TcEnv 1 0 where
__export TcEnv TcEnv;
-1 data TcEnv a;
+1 data TcEnv ;
__export TcExpr tcExpr ;
1 tcExpr :: __forall [_s] =>
RnHsSyn.RenamedHsExpr
- -> TcMonad.TcType _s
- -> TcMonad.TcM _s (TcHsSyn.TcExpr _s, Inst.LIE _s) ;
+ -> TcMonad.TcType
+ -> TcMonad.TcM _s (TcHsSyn.TcExpr, Inst.LIE) ;
tcMonoExpr (RecordUpd record_expr rbinds) res_ty
= tcAddErrCtxt recordUpdCtxt $
- -- STEP 1
- -- Figure out the tycon and data cons from the first field name
+ -- STEP 0
+ -- Check that the field names are really field names
ASSERT( not (null rbinds) )
let
- ((first_field_name, _, _) : rest) = rbinds
+ field_names = [field_name | (field_name, _, _) <- rbinds]
+ in
+ mapNF_Tc tcLookupValueMaybe field_names `thenNF_Tc` \ maybe_sel_ids ->
+ let
+ bad_guys = [field_name | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids,
+ case maybe_sel_id of
+ Nothing -> True
+ Just sel_id -> not (isRecordSelector sel_id)
+ ]
in
- tcLookupValueMaybe first_field_name `thenNF_Tc` \ maybe_sel_id ->
- (case maybe_sel_id of
- Just sel_id | isRecordSelector sel_id -> returnTc sel_id
- other -> failWithTc (notSelector first_field_name)
- ) `thenTc` \ sel_id ->
+ mapNF_Tc (addErrTc . notSelector) bad_guys `thenTc_`
+ if not (null bad_guys) then
+ failTc
+ else
+
+ -- STEP 1
+ -- Figure out the tycon and data cons from the first field name
let
+ (Just sel_id : _) = maybe_sel_ids
(_, tau) = splitForAllTys (idType sel_id)
Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector
(tycon, _, data_cons) = splitAlgTyConApp data_ty
tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) ->
-- STEP 2
- -- Check for bad fields
+ -- Check that at least one constructor has all the named fields
+ -- i.e. has an empty set of bad fields returned by badFields
checkTc (any (null . badFields rbinds) data_cons)
(badFieldsUpd rbinds) `thenTc_`
+
-- STEP 3
-- Typecheck the update bindings.
-- (Do this after checking for bad fields in case there's a field that
--- /dev/null
+__interface TcMatches 1 0 where
+__export TcMatches tcGRHSs tcMatchesFun;
+1 tcGRHSs :: __forall [s] =>
+ RnHsSyn.RenamedGRHSs
+ -> TcMonad.TcType
+ -> HsExpr.StmtCtxt
+ -> TcMonad.TcM s (TcHsSyn.TcGRHSs, Inst.LIE) ;
+1 tcMatchesFun :: __forall [s] =>
+ [(Name.Name,Var.Id)]
+ -> Name.Name
+ -> TcMonad.TcType
+ -> [RnHsSyn.RenamedMatch]
+ -> TcMonad.TcM s ([TcHsSyn.TcMatch], Inst.LIE) ;
+
1 type Kind = Type ;
1 type SuperKind = Type ;
+
projects / ghc-hetmet.git / commitdiff