compile(nativeGen/AbsCStixGen,lhs,)
compile(nativeGen/AsmCodeGen,lhs,-I$(COMPINFO_DIR))
compile(nativeGen/AsmRegAlloc,lhs,-I$(COMPINFO_DIR))
-compile(nativeGen/MachCode,lhs,)
-compile(nativeGen/MachMisc,lhs,)
-compile(nativeGen/MachRegs,lhs,)
-compile(nativeGen/PprMach,lhs,)
-compile(nativeGen/RegAllocInfo,lhs,)
+compile(nativeGen/MachCode,lhs,-I$(NATIVEGEN_DIR))
+compile(nativeGen/MachMisc,lhs,-I$(NATIVEGEN_DIR))
+compile(nativeGen/MachRegs,lhs,-I$(NATIVEGEN_DIR))
+compile(nativeGen/PprMach,lhs,-I$(NATIVEGEN_DIR))
+compile(nativeGen/RegAllocInfo,lhs,-I$(NATIVEGEN_DIR))
compile(nativeGen/Stix,lhs,)
-compile(nativeGen/StixInfo,lhs,-I$(NATIVEGEN_DIR))
+compile(nativeGen/StixInfo,lhs,)
compile(nativeGen/StixInteger,lhs,)
-compile(nativeGen/StixMacro,lhs,-I$(NATIVEGEN_DIR))
+compile(nativeGen/StixMacro,lhs,)
compile(nativeGen/StixPrim,lhs,)
#endif
TupleConId n _ -> [nameOf (origName n)]
- RecordSelId lbl -> panic "getIdNamePieces:RecordSelId"
+ RecordSelId lbl ->
+ let n = fieldLabelName lbl
+ in
+ case (moduleNamePair n) of { (mod, name) ->
+ if isPreludeDefinedName n then [name] else [mod, name] }
ImportedId n -> get_fullname_pieces n
PreludeId n -> get_fullname_pieces n
outPatType (ConOpPat _ _ _ ty) = ty
outPatType (ListPat ty _) = mkListTy ty
outPatType (TuplePat pats) = mkTupleTy (length pats) (map outPatType pats)
+outPatType (RecPat _ ty _) = ty
outPatType (LitPat lit ty) = ty
outPatType (NPat lit ty _) = ty
outPatType (DictPat ds ms) = case (length ds + length ms) of
(HsExpr tyvar uvar id pat) -- right operand
-- We preserve prefix negation and parenthesis for the precedence parser.
+ -- They are eventually removed by the type checker.
| NegApp (HsExpr tyvar uvar id pat) -- negated expr
+ id -- the negate id
+
| HsPar (HsExpr tyvar uvar id pat) -- parenthesised expr
| SectionL (HsExpr tyvar uvar id pat) -- operand
pp_infixly v
= ppSep [pp_e1, ppCat [pprSym sty v, pp_e2]]
-pprExpr sty (NegApp e)
+pprExpr sty (NegApp e _)
= ppBeside (ppChar '-') (pprParendExpr sty e)
pprExpr sty (HsPar e)
= ppHang thing 4
(ppBesides [ppChar '{', ppInterleave ppComma (map (pp_rbind sty) rbinds), ppChar '}'])
where
- pp_rbind sty (v, _, True{-pun-}) = ppr sty v
- pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppStr "<-", ppr sty e]
+ pp_rbind PprForUser (v, _, True) = ppr PprForUser v
+ pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppStr "=", ppr sty e]
\end{code}
%************************************************************************
| RecPat Id -- record constructor
(GenType tyvar uvar) -- the type of the pattern
- [(id, OutPat tyvar uvar id, Bool)] -- True <=> source used punning
+ [(Id, OutPat tyvar uvar id, Bool)] -- True <=> source used punning
| LitPat -- Used for *non-overloaded* literal patterns:
-- Int#, Char#, Int, Char, String, etc.
(HsExpr tyvar uvar id (OutPat tyvar uvar id))
-- of type t -> Bool; detects match
- | DictPat -- Used when destructing Dictionaries with an explicit case
+ | DictPat -- Used when destructing Dictionaries with an explicit case
[id] -- superclass dicts
[id] -- methods
\end{code}
= ppBesides [ppLparen, interpp'SP sty pats, ppRparen]
pprInPat sty (RecPatIn con rpats)
- = ppBesides [ppr sty con, ppSP, ppChar '{', ppInterleave ppComma (map pp_rpat rpats), ppChar '}']
+ = ppBesides [ppr sty con, ppSP, ppChar '{', ppInterleave ppComma (map (pp_rpat sty) rpats), ppChar '}']
where
- pp_rpat (v, _, True{-pun-}) = ppr sty v
- pp_rpat (v, p, _) = ppCat [ppr sty v, ppStr "<-", ppr sty p]
+ pp_rpat PprForUser (v, _, True) = ppr PprForUser v
+ pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppStr "=", ppr sty p]
\end{code}
\begin{code}
= ppBesides [ppLparen, interpp'SP sty pats, ppRparen]
pprOutPat sty (RecPat con ty rpats)
- = ppBesides [ppr sty con, ppChar '{', ppInterleave ppComma (map pp_rpat rpats), ppChar '}']
+ = ppBesides [ppr sty con, ppChar '{', ppInterleave ppComma (map (pp_rpat sty) rpats), ppChar '}']
where
--- pp_rpat (v, _, True{-pun-}) = ppr sty v
- pp_rpat (v, p, _) = ppBesides [ppr sty v, ppStr "<-", ppr sty p]
+ pp_rpat PprForUser (v, _, True) = ppr PprForUser v
+ pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppStr "=", ppr sty p]
pprOutPat sty (LitPat l ty) = ppr sty l -- ToDo: print more
pprOutPat sty (NPat l ty e) = ppr sty l -- ToDo: print more
\begin{code}
collectPatBinders :: InPat a -> [a]
-collectPatBinders (VarPatIn var) = [var]
-collectPatBinders (LazyPatIn pat) = collectPatBinders pat
-collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat
-collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats)
+collectPatBinders WildPatIn = []
+collectPatBinders (VarPatIn var) = [var]
+collectPatBinders (LazyPatIn pat) = collectPatBinders pat
+collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat
+collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats)
collectPatBinders (ConOpPatIn p1 c p2)= collectPatBinders p1 ++ collectPatBinders p2
-collectPatBinders (NegPatIn pat) = collectPatBinders pat
-collectPatBinders (ParPatIn pat) = collectPatBinders pat
-collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats)
-collectPatBinders (TuplePatIn pats) = concat (map collectPatBinders pats)
-collectPatBinders any_other_pat = [ {-no binders-} ]
+collectPatBinders (NegPatIn pat) = collectPatBinders pat
+collectPatBinders (ParPatIn pat) = collectPatBinders pat
+collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats)
+collectPatBinders (TuplePatIn pats) = concat (map collectPatBinders pats)
+collectPatBinders (RecPatIn c fields) = concat (map (\ (f,pat,_) -> collectPatBinders pat) fields)
\end{code}
of { (wiredin_fm, key_fm, idinfo_fm) ->
renameModule wiredin_fm key_fm rn_uniqs rdr_module `thenMn`
- \ (rn_mod, import_names,
+ \ (rn_mod, rn_env, import_names,
version_info, instance_modules,
rn_errs_bag, rn_warns_bag) ->
-- ******* TYPECHECKER
show_pass "TypeCheck" `thenMn_`
- let
- rn_info = trace "Main.rn_info" (\ x -> Nothing, \ x -> Nothing)
- in
- case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_info rn_mod) of
+ case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_env rn_mod) of
Succeeded (stuff, warns)
-> (emptyBag, warns, stuff)
Failed (errs, warns)
do_fixity :: -> RenamedFixityDecl -> Pretty
do_fixity fixity_decl
- = case (getExportFlag (get_name fixity_decl)) of
- ExportAll -> ppr PprInterface fixity_decl
- _ -> ppNil
+ = case (isLocallyDefined name, getExportFlag name) of
+ (True, ExportAll) -> ppr PprInterface fixity_decl
+ _ -> ppNil
where
+ name = get_name fixity_decl
get_name (InfixL n _) = n
get_name (InfixR n _) = n
get_name (InfixN n _) = n
, (SLIT("enumFromTo"), enumFromToClassOpKey)
, (SLIT("enumFromThenTo"), enumFromThenToClassOpKey)
, (SLIT("=="), eqClassOpKey)
--- , (SLIT(">="), geClassOpKey)
]]
\end{code}
U_negate nexp -> -- prefix negation
wlkExpr nexp `thenUgn` \ expr ->
- returnUgn (NegApp expr)
+ returnUgn (NegApp expr (Unqual SLIT("negate")) )
U_llist llist -> -- explicit list
wlkList rdExpr llist `thenUgn` \ exprs ->
-- with specified constrs/methods
wlkQid x `thenUgn` \ thing ->
wlkList rdQid ns `thenUgn` \ names ->
- returnUgn (IEThingAll thing)
- -- returnUgn (IEThingWith thing names)
+ returnUgn (IEThingWith thing names)
- U_entmod mod -> -- everything provided by a module
+ U_entmod mod -> -- everything provided unqualified by a module
returnUgn (IEModuleContents mod)
\end{code}
-----------------------------------------------------------------
data RdrIfaceDecl
- = TypeSig RdrName SrcLoc RdrNameTyDecl
- | NewTypeSig RdrName RdrName SrcLoc RdrNameTyDecl
- | DataSig RdrName [RdrName] SrcLoc RdrNameTyDecl
- | ClassSig RdrName [RdrName] SrcLoc RdrNameClassDecl
- | ValSig RdrName SrcLoc RdrNamePolyType
+ = TypeSig RdrName SrcLoc RdrNameTyDecl
+ | NewTypeSig RdrName RdrName SrcLoc RdrNameTyDecl
+ | DataSig RdrName [RdrName] [RdrName] SrcLoc RdrNameTyDecl
+ | ClassSig RdrName [RdrName] SrcLoc RdrNameClassDecl
+ | ValSig RdrName SrcLoc RdrNamePolyType
data RdrIfaceInst
= InstSig RdrName RdrName SrcLoc RdrNameInstDecl
mk_data ctxt (qtycon, tyvars) names_and_constrs
= let
(qconnames, constrs) = unzip names_and_constrs
- tycon = de_qual qtycon
- connames = map de_qual qconnames
- qtyvars = map Unqual tyvars
+ qfieldnames = [] -- ToDo ...
+ tycon = de_qual qtycon
+ connames = map de_qual qconnames
+ fieldnames = map de_qual qfieldnames
+ qtyvars = map Unqual tyvars
- decl = DataSig qtycon qconnames mkIfaceSrcLoc (
+ decl = DataSig qtycon qconnames qfieldnames mkIfaceSrcLoc (
TyData ctxt qtycon qtyvars constrs Nothing noDataPragmas mkIfaceSrcLoc)
in
- (unitFM tycon decl, listToFM [(c,decl) | c <- connames])
+ (unitFM tycon decl, listToFM [(c,decl) | c <- connames]
+ `plusFM`
+ listToFM [(f,decl) | f <- fieldnames])
mk_new :: RdrNameContext
-> (RdrName, [FAST_STRING])
import RnNames ( getGlobalNames, GlobalNameInfo(..) )
import RnSource ( rnSource )
import RnIfaces ( findHiFiles, rnIfaces, finalIfaceInfo, VersionInfo(..) )
-import RnUtils ( extendGlobalRnEnv, emptyRnEnv, multipleOccWarn )
+import RnUtils ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv, multipleOccWarn )
import MainMonad
import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag )
-> RdrNameHsModule
-> IO (RenamedHsModule, -- output, after renaming
+ RnEnv, -- final env (for renaming derivings)
[Module], -- imported modules; for profiling
VersionInfo, -- version info; for usage
\end{code}
ToDo: May want to arrange to return old interface for this module!
-ToDo: Return OrigName RnEnv to rename derivings etc with.
ToDo: Builtin names which must be read.
ToDo: Deal with instances (instance version, this module on instance list ???)
}) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, _) ->
if not (isEmptyBag errs_so_far) then
- return (rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far)
+ return (rn_panic, rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far)
else
-- No errors renaming source so rename the interfaces ...
-- We also divide by tycon/class and value names (as usual).
occ_rns = [ rn | (rn,_) <- eltsUFM occ_fm ]
- -- all occurrence names, from this module and imported
+ -- all occurrence names, from this module and imported
(defined_here, defined_elsewhere)
= partition isLocallyDefined occ_rns
- (_, imports_used) = partition isRnWired defined_elsewhere
+ (_, imports_used)
+ = partition isRnWired defined_elsewhere
(def_tcs, def_vals) = partition isRnTyConOrClass defined_here
(occ_tcs, occ_vals) = partition isRnTyConOrClass occ_rns
- -- the occ stuff includes *all* occurrences,
- -- including those for which we have definitions
+ -- the occ stuff includes *all* occurrences,
+ -- including those for which we have definitions
(orig_def_env, orig_def_dups)
= extendGlobalRnEnv emptyRnEnv (map pair_orig def_vals)
pair_orig rn = (origName rn, rn)
- must_haves -- everything in the BuiltinKey table; as we *may* need these
- -- later, we'd better bring their definitions in
- = catMaybes [ mk_key_name str name_fn u | (str, (u, name_fn)) <- fmToList b_keys ]
- where
- mk_key_name str name_fn u
- = -- this is emphatically *not* the Right Way to do this... (WDP 96/04)
- if (str == SLIT("main") || str == SLIT("mainPrimIO")) then
- Nothing
- else
- Just (name_fn (mkBuiltinName u pRELUDE str))
+ -- we must ensure that the definitions of things in the BuiltinKey
+ -- table which may be *required* by the typechecker etc are read.
+
+ must_haves
+ = [ name_fn (mkBuiltinName u pRELUDE str)
+ | (str, (u, name_fn)) <- fmToList b_keys,
+ str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ]
in
ASSERT (isEmptyBag orig_occ_dups)
ASSERT (isEmptyBag orig_def_dups)
- rnIfaces iface_cache us3 orig_def_env orig_occ_env rn_module (imports_used ++ must_haves) >>=
- \ (rn_module_with_imports, (implicit_val_fm, implicit_tc_fm), iface_errs, iface_warns) ->
+ rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env
+ rn_module (must_haves ++ imports_used) >>=
+ \ (rn_module_with_imports, final_env,
+ (implicit_val_fm, implicit_tc_fm),
+ (iface_errs, iface_warns)) ->
let
- all_imports_used = bagToList (unionManyBags [listToBag imports_used,
- listToBag (eltsFM implicit_tc_fm),
- listToBag (eltsFM implicit_val_fm)])
+ all_imports_used = imports_used ++ eltsFM implicit_tc_fm
+ ++ eltsFM implicit_val_fm
in
finalIfaceInfo iface_cache all_imports_used imp_mods >>=
\ (version_info, instance_mods) ->
- return (rn_module_with_imports, imp_mods, version_info, instance_mods,
- errs_so_far `unionBags` iface_errs, warns_so_far `unionBags` iface_warns)
+ return (rn_module_with_imports,
+ final_env,
+ imp_mods,
+ version_info,
+ instance_mods,
+ errs_so_far `unionBags` iface_errs,
+ warns_so_far `unionBags` iface_warns)
where
rn_panic = panic "renameModule: aborted with errors"
= ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; ", ppr PprDebug decl]
pprRdrIfaceDecl (NewTypeSig tc dc _ decl)
- = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacon=", ppr PprDebug dc, ppStr "; ", ppr PprDebug decl]
+ = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacon=", ppr PprDebug dc,
+ ppStr "; ", ppr PprDebug decl]
-pprRdrIfaceDecl (DataSig tc dcs _ decl)
- = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacons=", ppr PprDebug dcs, ppStr "; ", ppr PprDebug decl]
+pprRdrIfaceDecl (DataSig tc dcs dfs _ decl)
+ = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacons=", ppr PprDebug dcs,
+ ppStr "; fields=", ppr PprDebug dfs, ppStr "; ", ppr PprDebug decl]
pprRdrIfaceDecl (ClassSig c ops _ decl)
- = ppBesides [ppStr "class=", ppr PprDebug c, ppStr "; ops=", ppr PprDebug ops, ppStr "; ", ppr PprDebug decl]
+ = ppBesides [ppStr "class=", ppr PprDebug c, ppStr "; ops=", ppr PprDebug ops,
+ ppStr "; ", ppr PprDebug decl]
pprRdrIfaceDecl (ValSig f _ ty)
= ppBesides [ppr PprDebug f, ppStr " :: ", ppr PprDebug ty]
import RnHsSyn
import RnMonad
-import ErrUtils ( addErrLoc )
+import ErrUtils ( addErrLoc, addShortErrLocLine )
import Name ( isLocallyDefinedName, pprSym, Name, RdrName )
import Pretty
import UniqFM ( lookupUFM )
import UniqSet ( emptyUniqSet, unitUniqSet,
unionUniqSets, unionManyUniqSets,
UniqSet(..) )
-import Util ( Ord3(..), panic )
+import Util ( Ord3(..), removeDups, panic )
\end{code}
returnRn (LazyPatIn pat')
rnPat (AsPatIn name pat)
- = rnPat pat `thenRn` \ pat' ->
+ = rnPat pat `thenRn` \ pat' ->
lookupValue name `thenRn` \ vname ->
returnRn (AsPatIn vname pat')
-rnPat (ConPatIn name pats)
- = lookupValue name `thenRn` \ name' ->
+rnPat (ConPatIn con pats)
+ = lookupConstr con `thenRn` \ con' ->
mapRn rnPat pats `thenRn` \ patslist ->
- returnRn (ConPatIn name' patslist)
+ returnRn (ConPatIn con' patslist)
-rnPat (ConOpPatIn pat1 name pat2)
- = lookupValue name `thenRn` \ name' ->
+rnPat (ConOpPatIn pat1 con pat2)
+ = lookupConstr con `thenRn` \ con' ->
rnPat pat1 `thenRn` \ pat1' ->
rnPat pat2 `thenRn` \ pat2' ->
- precParsePat (ConOpPatIn pat1' name' pat2')
+ precParsePat (ConOpPatIn pat1' con' pat2')
rnPat neg@(NegPatIn pat)
= getSrcLocRn `thenRn` \ src_loc ->
returnRn (TuplePatIn patslist)
rnPat (RecPatIn con rpats)
- = panic "rnPat:RecPatIn"
-
+ = lookupConstr con `thenRn` \ con' ->
+ rnRpats rpats `thenRn` \ rpats' ->
+ returnRn (RecPatIn con' rpats')
\end{code}
************************************************************************
\end{itemize}
\begin{code}
+fv_set vname@(RnName n) | isLocallyDefinedName n
+ = unitUniqSet vname
+fv_set _ = emptyUniqSet
+
+
rnExpr :: RdrNameHsExpr -> RnM_Fixes s (RenamedHsExpr, FreeVars)
rnExpr (HsVar v)
= lookupValue v `thenRn` \ vname ->
returnRn (HsVar vname, fv_set vname)
- where
- fv_set vname@(RnName n)
- | isLocallyDefinedName n = unitUniqSet vname
- fv_set _ = emptyUniqSet
rnExpr (HsLit lit)
= returnRn (HsLit lit, emptyUniqSet)
precParseExpr (OpApp e1' op' e2') `thenRn` \ exp ->
returnRn (exp, (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2)
-rnExpr (NegApp e)
+rnExpr (NegApp e n)
= rnExpr e `thenRn` \ (e', fvs_e) ->
- returnRn (NegApp e', fvs_e)
+ lookupValue n `thenRn` \ nname ->
+ returnRn (NegApp e' nname, fvs_e `unionUniqSets` fv_set nname)
rnExpr (HsPar e)
= rnExpr e `thenRn` \ (e', fvs_e) ->
= rnExprs exps `thenRn` \ (exps', fvExps) ->
returnRn (ExplicitTuple exps', fvExps)
-rnExpr (RecordCon con rbinds)
- = panic "rnExpr:RecordCon"
-rnExpr (RecordUpd exp rbinds)
- = panic "rnExpr:RecordUpd"
+rnExpr (RecordCon (HsVar con) rbinds)
+ = lookupConstr con `thenRn` \ conname ->
+ rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
+ returnRn (RecordCon (HsVar conname) rbinds', fvRbinds)
+
+rnExpr (RecordUpd expr rbinds)
+ = rnExpr expr `thenRn` \ (expr', fvExpr) ->
+ rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
+ returnRn (RecordUpd expr' rbinds', fvExpr `unionUniqSets` fvRbinds)
rnExpr (ExprWithTySig expr pty)
= rnExpr expr `thenRn` \ (expr', fvExpr) ->
rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
returnRn (FromThenTo expr1' expr2' expr3',
unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3])
+\end{code}
+%************************************************************************
+%* *
+\subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
+%* *
+%************************************************************************
+
+\begin{code}
+rnRbinds str rbinds
+ = mapRn field_dup_err dup_fields `thenRn_`
+ mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) ->
+ returnRn (rbinds', unionManyUniqSets fvRbind_s)
+ where
+ (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rbinds ]
+
+ field_dup_err dups = getSrcLocRn `thenRn` \ src_loc ->
+ addErrRn (dupFieldErr str src_loc dups)
+
+ rn_rbind (field, expr, pun)
+ = lookupField field `thenRn` \ fieldname ->
+ rnExpr expr `thenRn` \ (expr', fvExpr) ->
+ returnRn ((fieldname, expr', pun), fvExpr)
+
+rnRpats rpats
+ = mapRn field_dup_err dup_fields `thenRn_`
+ mapRn rn_rpat rpats
+ where
+ (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rpats ]
+
+ field_dup_err dups = getSrcLocRn `thenRn` \ src_loc ->
+ addErrRn (dupFieldErr "pattern" src_loc dups)
+
+ rn_rpat (field, pat, pun)
+ = lookupField field `thenRn` \ fieldname ->
+ rnPat pat `thenRn` \ pat' ->
+ returnRn (fieldname, pat', pun)
\end{code}
%************************************************************************
precParseExpr :: RenamedHsExpr -> RnM_Fixes s RenamedHsExpr
precParsePat :: RenamedPat -> RnM_Fixes s RenamedPat
-precParseExpr exp@(OpApp (NegApp e1) (HsVar op) e2)
+precParseExpr exp@(OpApp (NegApp e1 n) (HsVar op) e2)
= lookupFixity op `thenRn` \ (op_fix, op_prec) ->
if 6 < op_prec then
-- negate precedence 6 wired in
-- (-x)*y ==> -(x*y)
precParseExpr (OpApp e1 (HsVar op) e2) `thenRn` \ op_app ->
- returnRn (NegApp op_app)
+ returnRn (NegApp op_app n)
else
returnRn exp
\end{code}
\begin{code}
+dupFieldErr str src_loc (dup:rest)
+ = addShortErrLocLine src_loc (\ sty ->
+ ppBesides [ppStr "duplicate field name `", ppr sty dup, ppStr "' in record ", ppStr str])
+
negPatErr pat src_loc
- = addErrLoc src_loc "prefix `-' not applied to literal in pattern" ( \sty ->
- ppr sty pat)
+ = addShortErrLocLine src_loc (\ sty ->
+ ppSep [ppStr "prefix `-' not applied to literal in pattern", ppr sty pat])
precParseNegPatErr op src_loc
= addErrLoc src_loc "precedence parsing error" (\ sty ->
data RnName
= WiredInId Id
| WiredInTyCon TyCon
- | RnName Name -- functions/binders/tyvars
- | RnSyn Name -- type synonym
- | RnData Name [Name] -- data type (with constrs)
- | RnConstr Name Name -- constructor (with data type)
- | RnClass Name [Name] -- class (with class ops)
- | RnClassOp Name Name -- class op (with class)
- | RnImplicit Name -- implicitly imported
- | RnImplicitTyCon Name -- implicitly imported
- | RnImplicitClass Name -- implicitly imported
- | RnUnbound RdrName -- place holder
+ | RnName Name -- functions/binders/tyvars
+ | RnSyn Name -- type synonym
+ | RnData Name [Name] [Name] -- data type (with constrs and fields)
+ | RnConstr Name Name -- constructor (with data type)
+ | RnField Name Name -- field (with data type)
+ | RnClass Name [Name] -- class (with class ops)
+ | RnClassOp Name Name -- class op (with class)
+ | RnImplicit Name -- implicitly imported
+ | RnImplicitTyCon Name -- implicitly imported
+ | RnImplicitClass Name -- implicitly imported
+ | RnUnbound RdrName -- place holder
mkRnName = RnName
mkRnImplicit = RnImplicit
isRnLocal (RnName n) = isLocalName n
isRnLocal _ = False
-
isRnTyCon (WiredInTyCon _) = True
isRnTyCon (RnSyn _) = True
-isRnTyCon (RnData _ _) = True
+isRnTyCon (RnData _ _ _) = True
isRnTyCon (RnImplicitTyCon _) = True
isRnTyCon _ = False
-- a common need: isRnTyCon || isRnClass:
isRnTyConOrClass (WiredInTyCon _) = True
isRnTyConOrClass (RnSyn _) = True
-isRnTyConOrClass (RnData _ _) = True
+isRnTyConOrClass (RnData _ _ _) = True
isRnTyConOrClass (RnImplicitTyCon _) = True
isRnTyConOrClass (RnClass _ _) = True
isRnTyConOrClass (RnImplicitClass _) = True
isRnTyConOrClass _ = False
+isRnConstr (RnConstr _ _) = True
+isRnConstr _ = False
+
+isRnField (RnField _ _) = True
+isRnField _ = False
+
isRnClassOp cls (RnClassOp _ op_cls) = eqUniqsNamed cls op_cls
-isRnClassOp cls (RnImplicit _) = True -- ho hummm ...
isRnClassOp cls _ = False
isRnImplicit (RnImplicit _) = True
getName (WiredInTyCon tc) = getName tc
getName (RnName n) = n
getName (RnSyn n) = n
- getName (RnData n _) = n
+ getName (RnData n _ _) = n
getName (RnConstr n _) = n
+ getName (RnField n _) = n
getName (RnClass n _) = n
getName (RnClassOp n _) = n
getName (RnImplicit n) = n
instance Outputable RnName where
#ifdef DEBUG
- ppr sty@PprShowAll (RnData n cs) = ppBesides [ppr sty n, ppStr "{-", ppr sty cs, ppStr "-}"]
- ppr sty@PprShowAll (RnConstr n d) = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"]
- ppr sty@PprShowAll (RnClass n ops) = ppBesides [ppr sty n, ppStr "{-", ppr sty ops, ppStr "-}"]
- ppr sty@PprShowAll (RnClassOp n c) = ppBesides [ppr sty n, ppStr "{-", ppr sty c, ppStr "-}"]
+ ppr sty@PprShowAll (RnData n cs fs) = ppBesides [ppr sty n, ppStr "{-", ppr sty cs, ppr sty fs, ppStr "-}"]
+ ppr sty@PprShowAll (RnConstr n d) = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"]
+ ppr sty@PprShowAll (RnField n d) = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"]
+ ppr sty@PprShowAll (RnClass n ops) = ppBesides [ppr sty n, ppStr "{-", ppr sty ops, ppStr "-}"]
+ ppr sty@PprShowAll (RnClassOp n c) = ppBesides [ppr sty n, ppStr "{-", ppr sty c, ppStr "-}"]
#endif
ppr sty (WiredInId id) = ppr sty id
ppr sty (WiredInTyCon tycon)= ppr sty tycon
import RnMonad
import RnSource ( rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType )
-import RnUtils ( RnEnv(..), lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv )
+import RnUtils ( RnEnv(..), emptyRnEnv, lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv )
import ParseIface ( parseIface )
import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..) )
-import Bag ( emptyBag, snocBag, unionBags, unionManyBags, isEmptyBag, bagToList )
+import Bag ( emptyBag, consBag, snocBag, unionBags, unionManyBags, isEmptyBag, bagToList )
import CmdLineOpts ( opt_HiSuffix, opt_SysHiSuffix )
import ErrUtils ( Error(..), Warning(..) )
-import FiniteMap ( emptyFM, lookupFM, addToFM, plusFM, eltsFM,
- fmToList, delListFromFM, keysFM{-ToDo:rm-}
- )
+import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
+ fmToList, delListFromFM, sizeFM, keysFM{-ToDo:rm-} )
import Maybes ( maybeToBool )
import Name ( moduleNamePair, origName, isRdrLexCon,
RdrName(..){-instance NamedThing-}
import Maybes ( MaybeErr(..) )
import UniqFM ( emptyUFM )
import UniqSupply ( splitUniqSupply )
-import Util ( startsWith, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
+import Util ( sortLt, removeDups, cmpPString, startsWith,
+ panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
\end{code}
\begin{code}
RnUnbound _ -> pprPanic "cachedDeclByType:" (ppr PprDebug rn)
RnSyn _ -> return_maybe_decl
- RnData _ _ -> return_maybe_decl
+ RnData _ _ _ -> return_maybe_decl
RnImplicitTyCon _ -> if is_tycon_decl if_decl
then return_maybe_decl
else return_failed (badIfaceLookupErr "type constructor" rn if_decl)
then return_maybe_decl
else return_failed (badIfaceLookupErr "class" rn if_decl)
- RnName _ -> return_maybe_decl
- RnConstr _ _ -> return_maybe_decl
- RnClassOp _ _ -> return_maybe_decl
- RnImplicit _ -> if is_val_decl if_decl
- then return_maybe_decl
- else return_failed (badIfaceLookupErr "value/method" rn if_decl)
+ RnName _ -> return_maybe_decl
+ RnConstr _ _ -> return_maybe_decl
+ RnField _ _ -> return_maybe_decl
+ RnClassOp _ _ -> return_maybe_decl
+ RnImplicit _ -> if is_val_decl if_decl
+ then return_maybe_decl
+ else return_failed (badIfaceLookupErr "value" rn if_decl)
where
is_tycon_decl (TypeSig _ _ _) = True
is_tycon_decl (NewTypeSig _ _ _ _) = True
- is_tycon_decl (DataSig _ _ _ _) = True
+ is_tycon_decl (DataSig _ _ _ _ _) = True
is_tycon_decl _ = False
is_class_decl (ClassSig _ _ _ _) = True
is_class_decl _ = False
is_val_decl (ValSig _ _ _) = True
- is_val_decl (ClassSig _ _ _ _) = True -- if the thing we were after *happens* to
- -- be a class op; we will have fished a ClassSig
- -- out of the interface for it.
+ is_val_decl (DataSig _ _ _ _ _) = True -- may be a constr or field
+ is_val_decl (NewTypeSig _ _ _ _) = True -- may be a constr
+ is_val_decl (ClassSig _ _ _ _) = True -- may be a method
is_val_decl _ = False
\end{code}
\begin{code}
rnIfaces :: IfaceCache -- iface cache (mutvar)
+ -> [Module] -- directly imported modules
-> UniqSupply
-> RnEnv -- defined (in the source) name env
-> RnEnv -- mentioned (in the source) name env
-- Also, all the things we may look up
-- later by key (Unique).
-> IO (RenamedHsModule, -- extended module
+ RnEnv, -- final env (for renaming derivings)
ImplicitEnv, -- implicit names used (for usage info)
- Bag Error,
- Bag Warning)
+ (Bag Error, Bag Warning))
-rnIfaces iface_cache us
+rnIfaces iface_cache imp_mods us
def_env@((dqual, dunqual, dtc_qual, dtc_unqual), dstack)
occ_env@((qual, unqual, tc_qual, tc_unqual), stack)
rn_module@(HsModule modname iface_version exports imports fixities
typedecls typesigs classdecls instdecls instsigs
defdecls binds sigs src_loc)
todo
- = {-pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
+ = {-
+ pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
pprTrace "rnIfaces:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM qual]) $
pprTrace "rnIfaces:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
pprTrace "rnIfaces:dtc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM dtc_qual]) $
pprTrace "rnIfaces:dtc_unqual:"(ppCat (map ppPStr (keysFM dtc_unqual))) $
-}
- let
- (us1,us2) = splitUniqSupply us
- in
-
- -- do transitive closure to bring in all needed names/defns:
- loop todo -- initial batch of names to process
- (def_env, occ_env, us1) -- init stuff down
- empty_return -- init acc results
- >>= \ (((if_typedecls, if_classdecls, if_sigs),
- if_implicits,
- (if_errs, if_warns)),
- new_occ_env) ->
+ -- do transitive closure to bring in all needed names/defns and insts:
- -- go back and handle instance things:
+ decls_and_insts todo def_env occ_env empty_return us
+ >>= \ (((if_typedecls, if_classdecls, if_instdecls, if_sigs),
+ if_implicits,
+ if_errs_warns),
+ if_final_env) ->
- rnIfaceInstStuff iface_cache modname us2 new_occ_env if_implicits
- >>= \ (if_instdecls, (ifi_errs, ifi_warns)) ->
-
- return (
- HsModule modname iface_version exports imports fixities
+ return (HsModule modname iface_version exports imports fixities
(typedecls ++ if_typedecls)
typesigs
(classdecls ++ if_classdecls)
instsigs defdecls binds
(sigs ++ if_sigs)
src_loc,
- if_implicits,
- if_errs `unionBags` ifi_errs,
- if_warns `unionBags` ifi_warns
- )
+ if_final_env,
+ if_implicits,
+ if_errs_warns)
where
- loop :: [RnName] -- Names we're looking for; we keep adding/deleting
- -- from this list; we're done when empty (nothing
- -- more needs to be looked for)
- -> Go_Down -- see defn below
- -> To_Return -- accumulated result
- -> IO (To_Return, RnEnv{-final occurrence env; to pass on for doing instances-})
+ decls_and_insts todo def_env occ_env to_return us
+ = do_decls todo -- initial batch of names to process
+ (def_env, occ_env, us1) -- init stuff down
+ to_return -- acc results
+ >>= \ (decls_return,
+ decls_def_env,
+ decls_occ_env) ->
+
+ cacheInstModules iface_cache imp_mods >>= \ errs ->
+
+ do_insts decls_def_env decls_occ_env emptyRnEnv emptyFM
+ (add_errs errs decls_return) us2
+ where
+ (us1,us2) = splitUniqSupply us
+
+ do_insts def_env occ_env prev_env done_insts to_return us
+ | size_tc_env occ_env == size_tc_env prev_env
+ = return (to_return, occ_env)
+
+ | otherwise
+ = rnIfaceInstStuff iface_cache modname us1 occ_env done_insts to_return
+ >>= \ (insts_return,
+ new_insts,
+ insts_occ_env,
+ new_unknowns) ->
+
+ do_decls new_unknowns -- new batch of names to process
+ (def_env, insts_occ_env, us2) -- init stuff down
+ insts_return -- acc results
+ >>= \ (decls_return,
+ decls_def_env,
+ decls_occ_env) ->
+
+ do_insts decls_def_env decls_occ_env occ_env new_insts decls_return us3
+ where
+ (us1,us') = splitUniqSupply us
+ (us2,us3) = splitUniqSupply us'
+
+ size_tc_env ((_, _, qual, unqual), _)
+ = sizeFM qual + sizeFM unqual
- loop to_find@[] down to_return = return (to_return, occenv down)
- loop to_find@(n:ns) down to_return
- = case (lookup_defd down (origName n)) of
+ do_decls :: [RnName] -- Names we're looking for; we keep adding/deleting
+ -- from this list; we're done when empty (nothing
+ -- more needs to be looked for)
+ -> Go_Down -- see defn below
+ -> To_Return -- accumulated result
+ -> IO (To_Return,
+ RnEnv, -- extended decl env
+ RnEnv) -- extended occ env
+
+ do_decls to_find@[] down to_return
+ = return (to_return, defenv down, occenv down)
+
+ do_decls to_find@(n:ns) down to_return
+ = case (lookup_defd down n) of
Just _ -> -- previous processing must've found the stuff for this name;
-- continue with the rest:
- -- pprTrace "loop:done:" (ppr PprDebug n) $
- loop ns down to_return
+ -- pprTrace "do_decls:done:" (ppr PprDebug n) $
+ do_decls ns down to_return
Nothing -> -- OK, see what the cache has for us...
cachedDeclByType iface_cache n >>= \ maybe_ans ->
case maybe_ans of
Failed err -> -- add the error, but keep going:
- -- pprTrace "loop:cache error:" (ppr PprDebug n) $
- loop ns down (add_err err to_return)
+ -- pprTrace "do_decls:cache error:" (ppr PprDebug n) $
+ do_decls ns down (add_err err to_return)
Succeeded iface_decl -> -- something needing renaming!
let
(us1, us2) = splitUniqSupply (uniqsupply down)
in
case (initRn False{-iface-} modname (occenv down) us1 (
- setExtraRn emptyUFM{-ignore fixities-} $
+ setExtraRn emptyUFM{-no fixities-} $
rnIfaceDecl iface_decl)) of {
((if_decl, if_defd, if_implicits), if_errs, if_warns) ->
let
new_unknowns = eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits)
in
--- pprTrace "loop:renamed:" (ppAboves [ppr PprDebug n
--- , ppCat [ppStr "new unknowns:", interpp'SP PprDebug new_unknowns]
--- , ppCat [ppStr "defd vals:", interpp'SP PprDebug [n | (_,n) <- fst if_defd] ]
--- , ppCat [ppStr "defd tcs:", interpp'SP PprDebug [n | (_,n) <- snd if_defd] ]
--- ]) $
- loop (new_unknowns ++ ns)
- (add_occs if_defd if_implicits $
- new_uniqsupply us2 down)
- (add_decl if_decl $
- add_implicits if_implicits $
- add_errs if_errs $
- add_warns if_warns to_return)
+ {-
+ pprTrace "do_decls:renamed:" (ppAboves [ppr PprDebug n
+ , ppCat [ppStr "new unknowns:", interpp'SP PprDebug new_unknowns]
+ , ppCat [ppStr "defd vals:", interpp'SP PprDebug [n | (_,n) <- fst if_defd] ]
+ , ppCat [ppStr "defd tcs:", interpp'SP PprDebug [n | (_,n) <- snd if_defd] ]
+ ]) $
+ -}
+ do_decls (new_unknowns ++ ns)
+ (add_occs if_defd if_implicits $
+ new_uniqsupply us2 down)
+ (add_decl if_decl $
+ add_implicits if_implicits $
+ add_errs if_errs $
+ add_warns if_warns to_return)
}
-----------
)
lookup_defd (def_env, _, _) n
- = (if isRdrLexCon n then lookupTcRnEnv else lookupRnEnv) def_env n
+ | isRnTyConOrClass n
+ = lookupTcRnEnv def_env (origName n)
+ | otherwise
+ = lookupRnEnv def_env (origName n)
+defenv (def_env, _, _) = def_env
occenv (_, occ_env, _) = occ_env
uniqsupply (_, _, us) = us
case (extendGlobalRnEnv occ_env val_occs tc_occs) of { (new_occ_env, occ_dups) ->
-- ASSERT(isEmptyBag occ_dups)
--- False because we may get a dup on the name we just shoved in
+-- False because we may get a dup on the name we just shoved in
(new_def_env, new_occ_env, us) }}
----------------
-type To_Return = (([RenamedTyDecl], [RenamedClassDecl], [RenamedSig]),
+type To_Return = (([RenamedTyDecl], [RenamedClassDecl], [RenamedInstDecl], [RenamedSig]),
ImplicitEnv, -- new names used implicitly
(Bag Error, Bag Warning)
)
empty_return :: To_Return
-empty_return = (([],[],[]), emptyImplicitEnv, (emptyBag,emptyBag))
+empty_return = (([],[],[],[]), emptyImplicitEnv, (emptyBag,emptyBag))
-add_decl decl ((tydecls, classdecls, sigs), implicit, msgs)
+add_decl decl ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
= case decl of
- AddedTy t -> ((t:tydecls, classdecls, sigs), implicit, msgs)
- AddedClass c -> ((tydecls, c:classdecls, sigs), implicit, msgs)
- AddedSig s -> ((tydecls, classdecls, s:sigs), implicit, msgs)
+ AddedTy t -> ((t:tydecls, classdecls, instdecls, sigs), implicit, msgs)
+ AddedClass c -> ((tydecls, c:classdecls, instdecls, sigs), implicit, msgs)
+ AddedSig s -> ((tydecls, classdecls, instdecls, s:sigs), implicit, msgs)
+
+add_insts is ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
+ = ((tydecls, classdecls, is ++ instdecls, sigs), implicit, msgs)
add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs)
= (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs)
- where
- pairify rn = (origName rn, rn)
add_err err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag` err,warns))
add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns))
in
returnRn (AddedTy rn_decl, defds, implicits)
-rnIfaceDecl (DataSig tc dcs _ decl)
+rnIfaceDecl (DataSig tc dcs fcs _ decl)
= rnTyDecl decl `thenRn` \ rn_decl ->
lookupTyCon tc `thenRn` \ rn_tc ->
mapRn lookupValue dcs `thenRn` \ rn_dcs ->
+ mapRn lookupValue fcs `thenRn` \ rn_fcs ->
getImplicitUpRn `thenRn` \ mentioned ->
let
- defds = (dcs `zip` rn_dcs, [(tc, rn_tc)])
+ defds = (zip dcs rn_dcs ++ zip fcs rn_fcs , [(tc, rn_tc)])
implicits = mentioned `sub` defds
in
returnRn (AddedTy rn_decl, defds, implicits)
% ------------------------------
+@cacheInstModules@: cache instance modules specified in imports
+
+\begin{code}
+cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error)
+cacheInstModules iface_cache imp_mods
+ = readVar iface_cache `thenPrimIO` \ (iface_fm, _) ->
+ let
+ imp_ifaces = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ]
+ (imp_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces)))
+ get_ims (ParsedIface _ _ _ _ _ ims _ _ _ _ _) = ims
+ in
+ accumulate (map (cachedIface iface_cache) imp_imods) >>= \ err_or_ifaces ->
+
+ -- Sanity Check:
+ -- Assert that instance modules given by direct imports contains
+ -- instance modules extracted from all visited modules
+
+ readVar iface_cache `thenPrimIO` \ (all_iface_fm, _) ->
+ let
+ all_ifaces = eltsFM all_iface_fm
+ (all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces))))
+ in
+ ASSERT(sortLt (<) imp_imods == sortLt (<) all_imods)
+
+ return (bag_errs err_or_ifaces)
+ where
+ bag_errs [] = emptyBag
+ bag_errs (Failed err :rest) = err `consBag` bag_errs rest
+ bag_errs (Succeeded _:rest) = bag_errs rest
+\end{code}
+
+
@rnIfaceInstStuff@: Deal with instance declarations from interface files.
\begin{code}
+type InstanceEnv = FiniteMap (RdrName, RdrName) Int
+
rnIfaceInstStuff
- :: IfaceCache -- all about ifaces we've read
+ :: IfaceCache -- all about ifaces we've read
-> Module
-> UniqSupply
- -> RnEnv
- -> ImplicitEnv -- info about all names we've used
- -> IO ([RenamedInstDecl],
- (Bag Error, Bag Warning))
-
-rnIfaceInstStuff iface_cache modname us occ_env implicit_env
- = -- nearly all the instance decls we might even want
- -- to consider are in the ParsedIfaces that are in our
- -- cache; any *other* instances to consider are in any
- -- "instance modules" fields that we've encounted.
- -- Get both:
+ -> RnEnv -- current occ env
+ -> InstanceEnv -- instances for these tycon/class pairs done
+ -> To_Return
+ -> IO (To_Return,
+ InstanceEnv, -- extended instance env
+ RnEnv, -- final occ env
+ [RnName]) -- new unknown names
+
+rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return
+ = -- all the instance decls we might even want to consider
+ -- are in the ParsedIfaces that are in our cache
readVar iface_cache `thenPrimIO` \ (iface_fm, _) ->
let
- ifaces_so_far = eltsFM iface_fm
- all_iface_imods = unionManyBags (map get_ims ifaces_so_far)
- insts_so_far = unionManyBags (map get_insts ifaces_so_far)
- in
- -- OK, get all the instance decls out of the "instance module"
- -- modules:
+ all_ifaces = eltsFM iface_fm
+ all_insts = unionManyBags (map get_insts all_ifaces)
+ interesting_insts = filter want_inst (bagToList all_insts)
- read_iface_imods iface_fm (bagToList all_iface_imods) emptyBag emptyBag{-accumulators-}
- >>= \ (more_insts, ims_errs) ->
- let
- all_insts = insts_so_far `unionBags` more_insts
+ -- Sanity Check:
+ -- Assert that there are no more instances for the done instances
- -- an instance decl can only be of interest if *both*
- -- its class and tycon have made their way into our
- -- purview:
- interesting_insts = filter (good_inst implicit_env) (bagToList all_insts)
+ claim_done = filter is_done_inst (bagToList all_insts)
+ claim_done_env = foldr add_done_inst emptyFM claim_done
+ has_val fm (k,i) = case lookupFM fm k of { Nothing -> False; Just v -> i == v }
in
--- pprTrace "in implicit:\n" (ppCat (map (ppr PprDebug) (keysFM (snd implicit_env)))) $
--- pprTrace "insts_so_far:\n" (ppr_insts (bagToList insts_so_far)) $
--- pprTrace "more_insts:\n" (ppr_insts (bagToList more_insts)) $
--- pprTrace "interesting_insts:\n" (ppr_insts interesting_insts) $
- -- Do the renaming for real:
- --
- case (initRn False{-iface-} modname occ_env us (
- setExtraRn emptyUFM{-ignore fixities-} $
- mapRn rnIfaceInst interesting_insts)) of {
- (if_inst_decls, if_errs, if_warns) ->
+ {-
+ pprTrace "all_insts:\n" (ppr_insts (bagToList all_insts)) $
+ pprTrace "interesting_insts:\n" (ppr_insts interesting_insts) $
+ -}
+ ASSERT(sizeFM done_inst_env == sizeFM claim_done_env)
+ ASSERT(all (has_val claim_done_env) (fmToList done_inst_env))
- return (if_inst_decls, (ims_errs `unionBags` if_errs, if_warns))
+ case (initRn False{-iface-} modname occ_env us (
+ setExtraRn emptyUFM{-no fixities-} $
+ mapRn rnIfaceInst interesting_insts `thenRn` \ insts ->
+ getImplicitUpRn `thenRn` \ implicits ->
+ returnRn (insts, implicits))) of {
+ ((if_insts, if_implicits), if_errs, if_warns) ->
+
+ return (add_insts if_insts $
+ add_implicits if_implicits $
+ add_errs if_errs $
+ add_warns if_warns to_return,
+ foldr add_done_inst done_inst_env interesting_insts,
+ add_imp_occs if_implicits occ_env,
+ eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits))
}
where
- get_insts (ParsedIface _ _ _ _ _ _ _ _ _ insts _) = insts
- get_ims (ParsedIface _ _ _ _ _ ims _ _ _ _ _) = ims
-
- good_inst (_, tc_imp_env) i@(InstSig clas tycon _ _)
- = -- it's a "good instance" (one to hang onto) if we have
- -- some chance of referring to *both* the class and tycon
- -- later on.
- mentionable clas && mentionable tycon
+ get_insts (ParsedIface _ _ _ _ _ _ _ _ _ insts _) = insts
+
+ add_done_inst (InstSig clas tycon _ _) inst_env
+ = addToFM_C (+) inst_env (tycon,clas) 1
+
+ is_done_inst (InstSig clas tycon _ _)
+ = maybeToBool (lookupFM done_inst_env (tycon,clas))
+
+ add_imp_occs (val_imps, tc_imps) occ_env
+ = case extendGlobalRnEnv occ_env (fmToList val_imps) (fmToList tc_imps) of
+ (ext_occ_env, occ_dups) -> ASSERT(isEmptyBag occ_dups)
+ ext_occ_env
+
+ want_inst i@(InstSig clas tycon _ _)
+ = -- it's a "good instance" (one to hang onto) if we have a
+ -- chance of referring to *both* the class and tycon later on ...
+
+ mentionable tycon && mentionable clas && not (is_done_inst i)
where
mentionable nm
- = case (lookupFM tc_imp_env nm) of
+ = case lookupTcRnEnv occ_env nm of
Just _ -> True
Nothing -> -- maybe it's builtin
case nm of
where
ppr_inst (InstSig c t _ inst_decl)
= ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug inst_decl]
-
- read_iface_imods :: ModuleToIfaceContents
- -> [Module]
- -> Bag RdrIfaceInst -> Bag Error
- -> IO (Bag RdrIfaceInst, Bag Error)
-
- read_iface_imods iface_fm [] iacc eacc = return (iacc, eacc)
- read_iface_imods iface_fm (m:ms) iacc eacc
- = case (lookupFM iface_fm m) of
- Just _ -> -- module's already in our cache; keep going
- read_iface_imods iface_fm ms iacc eacc
-
- Nothing -> -- bring it in
- cachedIface iface_cache m >>= \ read_res ->
- case read_res of
- Failed msg -> -- oh well, keep going anyway (saving the error)
- read_iface_imods iface_fm ms iacc (eacc `snocBag` msg)
-
- Succeeded iface ->
- read_iface_imods iface_fm ms (iacc `unionBags` get_insts iface) eacc
\end{code}
\begin{code}
module RnMonad (
RnMonad(..), RnM(..), RnM_Fixes(..), RnDown, SST_R,
initRn, thenRn, thenRn_, andRn, returnRn,
- mapRn, mapAndUnzipRn,
+ mapRn, mapAndUnzipRn, mapAndUnzip3Rn,
addErrRn, addErrIfRn, addWarnRn, addWarnIfRn,
failButContinueRn, warnAndContinueRn,
- setExtraRn, getExtraRn,
+ setExtraRn, getExtraRn, getRnEnv,
getModuleRn, pushSrcLocRn, getSrcLocRn,
getSourceRn, getOccurrenceUpRn,
getImplicitUpRn, ImplicitEnv(..), emptyImplicitEnv,
rnGetUnique, rnGetUniques,
newLocalNames,
- lookupValue, lookupValueMaybe, lookupClassOp,
+ lookupValue, lookupConstr, lookupField, lookupClassOp,
lookupTyCon, lookupClass, lookupTyConOrClass,
extendSS2, extendSS,
import RnHsSyn ( RnName, mkRnName, mkRnUnbound, mkRnImplicit,
mkRnImplicitTyCon, mkRnImplicitClass,
isRnLocal, isRnWired, isRnTyCon, isRnClass,
- isRnTyConOrClass, isRnClassOp,
- RenamedFixityDecl(..) )
+ isRnTyConOrClass, isRnConstr, isRnField,
+ isRnClassOp, RenamedFixityDecl(..) )
import RnUtils ( RnEnv(..), extendLocalRnEnv,
- lookupRnEnv, lookupTcRnEnv,
+ lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv,
unknownNameErr, badClassOpErr, qualNameErr,
- dupNamesErr, shadowedNameWarn )
+ dupNamesErr, shadowedNameWarn, negateNameWarn )
import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
import CmdLineOpts ( opt_WarnNameShadowing )
= f x `thenRn` \ (r1, r2) ->
mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) ->
returnRn (r1:rs1, r2:rs2)
+
+mapAndUnzip3Rn f [] = returnRn ([],[],[])
+mapAndUnzip3Rn f (x:xs)
+ = f x `thenRn` \ (r1, r2, r3) ->
+ mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
+ returnRn (r1:rs1, r2:rs2, r3:rs3)
\end{code}
For errors and warnings ...
\begin{code}
+getRnEnv :: RnMonad x s RnEnv
+getRnEnv (RnDown _ _ _ _ env _ _)
+ = returnSST env
+
setExtraRn :: x -> RnMonad x s r -> RnMonad y s r
setExtraRn x m (RnDown _ mod locn mode env us errs)
= m (RnDown x mod locn mode env us errs)
-> RnMonad x s [RnName]
newLocalNames str names_w_loc
- = mapRn (addErrRn . qualNameErr str) quals `thenRn_`
- mapRn (addErrRn . dupNamesErr str) dups `thenRn_`
+ = mapRn (addWarnRn . negateNameWarn) negs `thenRn_`
+ mapRn (addErrRn . qualNameErr str) quals `thenRn_`
+ mapRn (addErrRn . dupNamesErr str) dups `thenRn_`
mkLocalNames these
where
- quals = filter (isQual.fst) names_w_loc
+ negs = filter ((== Unqual SLIT("negate")).fst) names_w_loc
+ quals = filter (isQual.fst) names_w_loc
(these, dups) = removeDups cmp_fst names_w_loc
cmp_fst (a,_) (b,_) = cmp a b
\end{code}
\begin{code}
lookupValue :: RdrName -> RnMonad x s RnName
+lookupConstr :: RdrName -> RnMonad x s RnName
+lookupField :: RdrName -> RnMonad x s RnName
lookupClassOp :: RnName -> RdrName -> RnMonad x s RnName
lookupValue rdr
- = lookup_val rdr (\ rn -> True) (unknownNameErr "value")
+ = lookup_val rdr lookupRnEnv (\ rn -> True) (unknownNameErr "value")
+
+lookupConstr rdr
+ = lookup_val rdr lookupGlobalRnEnv isRnConstr (unknownNameErr "constructor")
+
+lookupField rdr
+ = lookup_val rdr lookupGlobalRnEnv isRnField (unknownNameErr "field")
lookupClassOp cls rdr
- = lookup_val rdr (\ rn -> True){-WAS:(isRnClassOp cls)-} (badClassOpErr cls)
+ = lookup_val rdr lookupGlobalRnEnv (\ rn -> isRnClassOp cls rn) (badClassOpErr cls)
+-- Note: the lookup checks are only performed when renaming source
-lookup_val rdr check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _)
- = case lookupRnEnv env rdr of
+lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _)
+ = case lookup env rdr of
Just name | check name -> succ name
| otherwise -> fail
Nothing -> fail
returnSST name
fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
-lookup_val rdr check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
- = case lookupRnEnv env rdr of
- Just name | check name -> returnSST name
- | otherwise -> failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
- Nothing -> lookup_nonexisting_val b_names b_key imp_var us_var rdr
+lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
+ = case lookup env rdr of
+ Just name -> returnSST name
+ Nothing -> lookup_nonexisting_val b_names b_key imp_var us_var rdr
lookup_nonexisting_val (b_names,_) b_key imp_var us_var rdr
= case rdr of
in
writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_`
returnSST implicit
-
-
-lookupValueMaybe :: RdrName -> RnMonad x s (Maybe RnName)
-lookupValueMaybe rdr down@(RnDown _ _ _ (RnSource _) env _ _)
- = returnSST (lookupRnEnv env rdr)
\end{code}
import RnMonad
import RnIfaces ( IfaceCache(..), cachedIface, cachedDecl )
import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv,
- lubExportFlag, qualNameErr, dupNamesErr )
+ lubExportFlag, qualNameErr, dupNamesErr, negateNameWarn )
import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst )
-import Bag ( emptyBag, unitBag, consBag, unionBags, unionManyBags,
- mapBag, listToBag, bagToList )
+import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags,
+ unionManyBags, mapBag, listToBag, bagToList )
import CmdLineOpts ( opt_NoImplicitPrelude )
-import ErrUtils ( Error(..), Warning(..), addShortErrLocLine )
+import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine )
import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM )
import Id ( GenId )
import Maybes ( maybeToBool, catMaybes, MaybeErr(..) )
import TyCon ( tyConDataCons )
import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM )
import UniqSupply ( splitUniqSupply )
-import Util ( isIn, cmpPString, sortLt, removeDups, equivClasses, panic, assertPanic )
+import Util ( isIn, assoc, cmpPString, sortLt, removeDups,
+ equivClasses, panic, assertPanic )
\end{code}
dup_errs = map dup_err (equivClasses cmp_rdr (bagToList dups))
cmp_rdr (rdr1,_,_) (rdr2,_,_) = cmp rdr1 rdr2
- dup_err ((rdr,rn,rn'):rest) = globalDupNamesErr rdr (rn:rn': [rn|(_,_,rn)<-rest])
+ dup_err ((_,rn,rn'):rest) = globalDupNamesErr (rn:rn': [rn|(_,_,rn)<-rest])
all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs
all_warns = src_warns `unionBags` imp_warns
Bag RnName) -- tycons/classes
getSourceNames ty_decls cls_decls binds
- = mapAndUnzipRn getTyDeclNames ty_decls `thenRn` \ (tycon_s, constrs_s) ->
- mapAndUnzipRn getClassNames cls_decls `thenRn` \ (cls_s, cls_ops_s) ->
- getTopBindsNames binds `thenRn` \ bind_names ->
+ = mapAndUnzip3Rn getTyDeclNames ty_decls `thenRn` \ (tycon_s, constrs_s, fields_s) ->
+ mapAndUnzipRn getClassNames cls_decls `thenRn` \ (cls_s, cls_ops_s) ->
+ getTopBindsNames binds `thenRn` \ bind_names ->
returnRn (unionManyBags constrs_s `unionBags`
+ unionManyBags fields_s `unionBags`
unionManyBags cls_ops_s `unionBags` bind_names,
listToBag tycon_s `unionBags` listToBag cls_s)
getTyDeclNames :: RdrNameTyDecl
- -> RnM_Info s (RnName, Bag RnName) -- tycon and constrs
+ -> RnM_Info s (RnName, Bag RnName, Bag RnName) -- tycon, constrs and fields
getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc)
= newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
- mapRn (getConDeclName (Just (nameExportFlag tycon_name)))
- condecls `thenRn` \ con_names ->
- returnRn (RnData tycon_name con_names,
- listToBag (map (\ n -> RnConstr n tycon_name) con_names))
+ getConFieldNames (Just (nameExportFlag tycon_name)) emptyBag emptyBag emptyFM
+ condecls `thenRn` \ (con_names, field_names) ->
+ let
+ rn_tycon = RnData tycon_name con_names field_names
+ rn_constrs = [ RnConstr name tycon_name | name <- con_names]
+ rn_fields = [ RnField name tycon_name | name <- field_names]
+ in
+ returnRn (rn_tycon, listToBag rn_constrs, listToBag rn_fields)
-getTyDeclNames (TyNew _ tycon _ condecls _ _ src_loc)
+getTyDeclNames (TyNew _ tycon _ [NewConDecl con _ con_loc] _ _ src_loc)
= newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
- mapRn (getConDeclName (Just (nameExportFlag tycon_name)))
- condecls `thenRn` \ con_names ->
- returnRn (RnData tycon_name con_names,
- listToBag (map (\ n -> RnConstr n tycon_name) con_names))
+ newGlobalName con_loc (Just (nameExportFlag tycon_name)) con
+ `thenRn` \ con_name ->
+ returnRn (RnData tycon_name [con_name] [],
+ unitBag (RnConstr con_name tycon_name),
+ emptyBag)
getTyDeclNames (TySynonym tycon _ _ src_loc)
= newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
- returnRn (RnSyn tycon_name, emptyBag)
+ returnRn (RnSyn tycon_name, emptyBag, emptyBag)
+
-getConDeclName exp (ConDecl con _ src_loc)
- = newGlobalName src_loc exp con
-getConDeclName exp (ConOpDecl _ op _ src_loc)
- = newGlobalName src_loc exp op
-getConDeclName exp (NewConDecl con _ src_loc)
- = newGlobalName src_loc exp con
-getConDeclName exp (RecConDecl con fields src_loc)
- = panic "getConDeclName:RecConDecl"
- newGlobalName src_loc exp con
+getConFieldNames exp constrs fields have []
+ = returnRn (bagToList constrs, bagToList fields)
+getConFieldNames exp constrs fields have (ConDecl con _ src_loc : rest)
+ = newGlobalName src_loc exp con `thenRn` \ con_name ->
+ getConFieldNames exp (constrs `snocBag` con_name) fields have rest
+
+getConFieldNames exp constrs fields have (ConOpDecl _ con _ src_loc : rest)
+ = newGlobalName src_loc exp con `thenRn` \ con_name ->
+ getConFieldNames exp (constrs `snocBag` con_name) fields have rest
+
+getConFieldNames exp constrs fields have (RecConDecl con fielddecls src_loc : rest)
+ = mapRn (addErrRn . dupFieldErr con src_loc) dups `thenRn_`
+ newGlobalName src_loc exp con `thenRn` \ con_name ->
+ mapRn (newGlobalName src_loc exp) new_fields `thenRn` \ field_names ->
+ let
+ all_constrs = constrs `snocBag` con_name
+ all_fields = fields `unionBags` listToBag field_names
+ in
+ getConFieldNames exp all_constrs all_fields new_have rest
+ where
+ (uniq_fields, dups) = removeDups cmp (concat (map fst fielddecls))
+ new_fields = filter (not . maybeToBool . lookupFM have) uniq_fields
+ new_have = addListToFM have (zip new_fields (repeat ()))
getClassNames :: RdrNameClassDecl
-> RnM_Info s (RnName, Bag RnName) -- class and class ops
n = mkTopLevName uniq orig locn exp (occ_fn n)
in
+ addWarnIfRn (rdr == Unqual SLIT("negate")) (negateNameWarn (rdr, locn)) `thenRn_`
addErrIfRn (isQual rdr) (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
returnRn n
\end{code}
i_info = (g_info, emptyFM, emptyFM, rec_imp_fn)
in
- doImports iface_cache i_info us (qprel_imp ++ prel_imp ++ src_imps)
+ doImports iface_cache i_info us all_imps
) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) ->
- let
- imp_mods = [ mod | ImportDecl mod _ _ _ _ <- src_imps ]
- imp_warns = listToBag (map dupImportWarn imp_dups)
- prel_warns = listToBag (map qualPreludeImportWarn qual_prels)
-
- (_, imp_dups) = removeDups cmp_mod src_imps
- cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2
- qual_prels = [imp | imp@(ImportDecl mod qual _ _ _) <- src_imps,
- fromPrelude mod && qual]
- in
- return (vals, tcs, imp_mods, unquals, fixes, errs,
- prel_warns `unionBags` imp_warns `unionBags` warns)
+
+ return (vals, tcs, imp_mods, unquals, fixes,
+ imp_errs `unionBags` errs,
+ imp_warns `unionBags` warns)
where
+ (ok_imps, src_qprels) = partition not_qual_prel src_imps
+ all_imps = qprel_imp ++ prel_imp ++ ok_imps
+
+ not_qual_prel (ImportDecl mod qual _ _ _) = not (fromPrelude mod && qual)
+
explicit_prelude_import
- = null [() | (ImportDecl mod qual _ _ _) <- src_imps,
+ = null [() | (ImportDecl mod qual _ _ _) <- ok_imps,
fromPrelude mod && not qual]
qprel_imp = if opt_NoImplicitPrelude
prel_imp = if not explicit_prelude_import || opt_NoImplicitPrelude
then
- [ {-prelude imported explicitly => no import Prelude-} ]
+ [{- no "import Prelude" -}]
else
[ImportDecl pRELUDE False Nothing Nothing mkIfaceSrcLoc]
+ (uniq_imps, imp_dups) = removeDups cmp_mod all_imps
+ cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2
+
+ imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ]
+ imp_warns = listToBag (map dupImportWarn imp_dups)
+ imp_errs = listToBag (map qualPreludeImportErr src_qprels)
+
+
doImports iface_cache i_info us []
= return (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
doImports iface_cache i_info@(g_info,done_vals,done_tcs,imp_fn) us (imp:imps)
pair_as rn = (as_mod, rn)
-getBuiltins info mod maybe_spec
- | not (fromPrelude mod)
- = (emptyBag, emptyBag, maybe_spec)
-
getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec
= case maybe_spec of
Nothing -> (all_vals, all_tcs, Nothing)
(found_ies, errs) = lookupIEs exps ies
exps_left = delListFromFM exps (map (getLocalName.ie_name.fst) found_ies)
-getOrigNames (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies))
+getOrigIEs (ParsedIface _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these
= (map fst found_ies, found_ies, errs)
where
(found_ies, errs) = lookupIEs exps ies
= with_decl iface_cache n
(\ err -> (unitBag (\ mod locn -> err), emptyBag))
(\ decl -> case decl of
- NewTypeSig _ con _ _ -> (check_with "constructrs" [con] ns, emptyBag)
- DataSig _ cons _ _ -> (check_with "constructrs" cons ns, emptyBag)
- ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag))
+ NewTypeSig _ con _ _ -> (check_with "constructrs" [con] ns, emptyBag)
+ DataSig _ cons fields _ _ -> (check_with "constructrs (and fields)" (cons++fields) ns, emptyBag)
+ ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag))
where
check_with str has rdrs
| sortLt (<) (map getLocalName has) == sortLt (<) (map unqual_str rdrs)
Bag (RnName,ExportFlag)) -- import flags
getIfaceDeclNames ie (ValSig val src_loc _)
- = newImportedName False src_loc Nothing Nothing val `thenRn` \ val_name ->
+ = newImportedName False src_loc Nothing Nothing val `thenRn` \ val_name ->
returnRn (unitBag (RnName val_name),
emptyBag,
unitBag (RnName val_name, ExportAll))
getIfaceDeclNames ie (TypeSig tycon src_loc _)
- = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
+ = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
returnRn (emptyBag,
unitBag (RnSyn tycon_name),
unitBag (RnSyn tycon_name, ExportAll))
getIfaceDeclNames ie (NewTypeSig tycon con src_loc _)
- = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
- mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name))
- (Just (nameImportFlag tycon_name)))
- [con] `thenRn` \ con_names ->
+ = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
+ newImportedName False src_loc (Just (nameExportFlag tycon_name))
+ (Just (nameImportFlag tycon_name))
+ con `thenRn` \ con_name ->
returnRn (if imp_all (imp_flag ie) then
- listToBag (map (\ n -> RnConstr n tycon_name) con_names)
+ unitBag (RnConstr con_name tycon_name)
else
emptyBag,
- unitBag (RnData tycon_name con_names),
- unitBag (RnData tycon_name con_names, imp_flag ie))
+ unitBag (RnData tycon_name [con_name] []),
+ unitBag (RnData tycon_name [con_name] [], imp_flag ie))
-getIfaceDeclNames ie (DataSig tycon cons src_loc _)
+getIfaceDeclNames ie (DataSig tycon cons fields src_loc _)
= newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name))
(Just (nameImportFlag tycon_name)))
cons `thenRn` \ con_names ->
+ mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name))
+ (Just (nameImportFlag tycon_name)))
+ fields `thenRn` \ field_names ->
+ let
+ rn_tycon = RnData tycon_name con_names field_names
+ rn_constrs = [ RnConstr name tycon_name | name <- con_names ]
+ rn_fields = [ RnField name tycon_name | name <- field_names ]
+ in
returnRn (if imp_all (imp_flag ie) then
- listToBag (map (\ n -> RnConstr n tycon_name) con_names)
+ listToBag rn_constrs `unionBags` listToBag rn_fields
else
emptyBag,
- unitBag (RnData tycon_name con_names),
- unitBag (RnData tycon_name con_names, imp_flag ie))
+ unitBag rn_tycon,
+ unitBag (rn_tycon, imp_flag ie))
getIfaceDeclNames ie (ClassSig cls ops src_loc _)
= newImportedName True src_loc Nothing Nothing cls `thenRn` \ cls_name ->
\end{code}
\begin{code}
-globalDupNamesErr rdr rns sty
- = ppHang (ppBesides [pprNonSym sty rdr, ppStr " multiply defined:"])
- 4 (ppAboves (map pp_def rns))
+globalDupNamesErr (rn1:dup_rns) sty
+ = ppAboves (item1 : map dup_item dup_rns)
where
- pp_def rn = addShortErrLocLine (getSrcLoc rn) (\ sty -> ppr sty rn) sty
-
-dupImportWarn dup_imps sty
- = ppStr "dupImportWarn"
-
-qualPreludeImportWarn imp sty
- = ppStr "qualPreludeImportWarn"
-
-unknownImpSpecErr ie imp_mod locn sty
- = ppStr "unknownImpSpecErr"
-
-duplicateImpSpecErr ie imp_mod locn sty
- = ppStr "duplicateImpSpecErr"
-
-allWhenSynImpSpecWarn n imp_mod locn sty
- = ppStr "allWhenSynImpSpecWarn"
-
-allWhenAbsImpSpecErr n imp_mod locn sty
- = ppStr "allWhenAbsImpSpecErr"
-
-withWhenAbsImpSpecErr n imp_mod locn sty
- = ppStr "withWhenAbsImpSpecErr"
-
-withImpSpecErr str n has ns imp_mod locn sty
- = ppStr "withImpSpecErr"
+ item1 = addShortErrLocLine (getSrcLoc rn1) (\ sty ->
+ ppBesides [ppStr "multiple declarations of `",
+ pprNonSym sty rn1, ppStr "' ", pp_descrip rn1]) sty
+
+ dup_item rn
+ = addShortErrLocLine (getSrcLoc rn) (\ sty ->
+ ppBesides [ppStr "here was another declaration of `",
+ pprNonSym sty rn, ppStr "' ", pp_descrip rn]) sty
+
+ pp_descrip (RnName _) = ppStr "(as a value)"
+ pp_descrip (RnSyn _) = ppStr "(as a type synonym)"
+ pp_descrip (RnData _ _ _) = ppStr "(as a data type)"
+ pp_descrip (RnConstr _ _) = ppStr "(as a data constructor)"
+ pp_descrip (RnField _ _) = ppStr "(as a record field)"
+ pp_descrip (RnClass _ _) = ppStr "(as a class)"
+ pp_descrip (RnClassOp _ _) = ppStr "(as a class method)"
+ pp_descrip _ = ppNil
+
+dupImportWarn (ImportDecl m1 _ _ _ locn1 : dup_imps) sty
+ = ppAboves (item1 : map dup_item dup_imps)
+ where
+ item1 = addShortErrLocLine locn1 (\ sty ->
+ ppCat [ppStr "multiple imports from module", ppPStr m1]) sty
+
+ dup_item (ImportDecl m _ _ _ locn)
+ = addShortErrLocLine locn (\ sty ->
+ ppCat [ppStr "here was another import from module", ppPStr m]) sty
+
+qualPreludeImportErr (ImportDecl m _ _ _ locn)
+ = addShortErrLocLine locn (\ sty ->
+ ppCat [ppStr "qualified import form prelude module", ppPStr m])
+
+unknownImpSpecErr ie imp_mod locn
+ = addShortErrLocLine locn (\ sty ->
+ ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " does not export `", ppr sty (ie_name ie), ppStr "'"])
+
+duplicateImpSpecErr ie imp_mod locn
+ = addShortErrLocLine locn (\ sty ->
+ ppBesides [ppStr "`", ppr sty (ie_name ie), ppStr "' already seen in import list"])
+
+allWhenSynImpSpecWarn n imp_mod locn
+ = addShortErrLocLine locn (\ sty ->
+ ppBesides [ppStr "type synonym `", ppr sty n, ppStr "' should not be imported with (..)"])
+
+allWhenAbsImpSpecErr n imp_mod locn
+ = addShortErrLocLine locn (\ sty ->
+ ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"])
+
+withWhenAbsImpSpecErr n imp_mod locn
+ = addShortErrLocLine locn (\ sty ->
+ ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"])
+
+withImpSpecErr str n has ns imp_mod locn
+ = addErrLoc locn "" (\ sty ->
+ ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in import list for `", ppr sty n, ppStr "'"],
+ ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)],
+ ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) ns)] ])
+
+dupFieldErr con locn (dup:rest)
+ = addShortErrLocLine locn (\ sty ->
+ ppBesides [ppStr "record field `", ppr sty dup, ppStr "declared multiple times in `", ppr sty con, ppStr "'"])
\end{code}
import RnHsSyn
import RnMonad
import RnBinds ( rnTopBinds, rnMethodBinds )
-import RnUtils ( lubExportFlag )
+import RnUtils ( lookupGlobalRnEnv, lubExportFlag )
import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
import Class ( derivableClassKeys )
+import ErrUtils ( addErrLoc, addShortErrLocLine )
import FiniteMap ( emptyFM, lookupFM, addListToFM_C )
import ListSetOps ( unionLists, minusList )
import Maybes ( maybeToBool, catMaybes )
import Pretty
import SrcLoc ( SrcLoc )
import Unique ( Unique )
-import UniqFM ( emptyUFM, addListToUFM, addListToUFM_C, listToUFM, lookupUFM, eltsUFM )
+import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, lookupUFM, eltsUFM )
import UniqSet ( UniqSet(..) )
-import Util ( isIn, isn'tIn, sortLt, removeDups, cmpPString, panic, assertPanic, pprTrace{-ToDo:rm-} )
+import Util ( isIn, isn'tIn, sortLt, removeDups, cmpPString, assertPanic, pprTrace{-ToDo:rm-} )
\end{code}
rnSource `renames' the source module and export list.
rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ exported_fn ->
rnFixes fixes `thenRn` \ src_fixes ->
let
- pair_name inf@(InfixL n _) = (n, inf)
- pair_name inf@(InfixR n _) = (n, inf)
- pair_name inf@(InfixN n _) = (n, inf)
+ pair_name inf = (nameFixDecl inf, inf)
- imp_fixes_fm = listToUFM (map pair_name (bagToList imp_fixes))
- all_fixes_fm = addListToUFM imp_fixes_fm (map pair_name src_fixes)
+ all_fixes = src_fixes ++ bagToList imp_fixes
+ all_fixes_fm = listToUFM (map pair_name all_fixes)
in
setExtraRn all_fixes_fm $
returnRn (
HsModule mod version
- trashed_exports trashed_imports src_fixes
+ trashed_exports trashed_imports all_fixes
new_ty_decls new_specdata_sigs new_class_decls
new_inst_decls new_specinst_sigs new_defaults
new_binds [] src_loc,
-- Build finite map of exported names to export flag
exp_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst uniq_exp_names)
- exp_map1 = foldl add_mod_names exp_map0 uniq_exp_mods
+ (exp_map1, empty_mods) = foldl add_mod_names (exp_map0, []) uniq_exp_mods
mod_fm = addListToFM_C unionBags emptyFM
[(mod, unitBag (getName rn, nameImportFlag (getName rn)))
| (mod,rn) <- bagToList unqual_imps]
- add_mod_names exp_map mod
+ add_mod_names (exp_map, empty) mod
= case lookupFM mod_fm mod of
- Nothing -> exp_map
- Just mod_names -> addListToUFM_C lub_expflag exp_map (map pair_fst (bagToList mod_names))
+ Nothing -> (exp_map, mod:empty)
+ Just mod_names -> (addListToUFM_C lub_expflag exp_map (map pair_fst (bagToList mod_names)), empty)
pair_fst p@(f,_) = (f,p)
lub_expflag (n, flag1) (_, flag2) = (n, lubExportFlag flag1 flag2)
(_, dup_locals) = removeDups cmp_local exp_locals
cmp_local (x,_) (y,_) = x `cmpPString` y
-
-- Build export flag function
exp_fn n = case lookupUFM exp_map1 n of
Nothing -> NotExported
Just (_,flag) -> flag
in
getSrcLocRn `thenRn` \ src_loc ->
- mapRn (addWarnRn . dupNameExportWarn src_loc) dup_names `thenRn_`
- mapRn (addWarnRn . dupModuleExportWarn src_loc) dup_mods `thenRn_`
- mapRn (addErrRn . dupLocalsExportErr src_loc) dup_locals `thenRn_`
+ mapRn (addWarnRn . dupNameExportWarn src_loc) dup_names `thenRn_`
+ mapRn (addWarnRn . dupModExportWarn src_loc) dup_mods `thenRn_`
+ mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods `thenRn_`
+ mapRn (addErrRn . dupLocalsExportErr src_loc) dup_locals `thenRn_`
returnRn exp_fn
returnRn (Nothing, exps)
where
checkIEVar (RnName n) = returnRn (unitBag (n,ExportAll))
- checkIEVar (RnUnbound _) = returnRn emptyBag
checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc ->
failButContinueRn emptyBag (classOpExportErr rn src_loc)
- checkIEVar rn = panic "checkIEVar"
+ checkIEVar rn = returnRn emptyBag
rnIE mods (IEThingAbs name)
= lookupTyConOrClass name `thenRn` \ rn ->
checkIEAbs rn `thenRn` \ exps ->
returnRn (Nothing, exps)
where
- checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs))
- checkIEAbs (RnData n _) = returnRn (unitBag (n,ExportAbs))
- checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs))
- checkIEAbs (RnUnbound _) = returnRn emptyBag
- checkIEAbs rn = panic "checkIEAbs"
+ checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs))
+ checkIEAbs (RnData n _ _) = returnRn (unitBag (n,ExportAbs))
+ checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs))
+ checkIEAbs rn = returnRn emptyBag
rnIE mods (IEThingAll name)
= lookupTyConOrClass name `thenRn` \ rn ->
checkImportAll rn `thenRn_`
returnRn (Nothing, exps)
where
- checkIEAll (RnData n cons) = returnRn (consBag (exp_all n) (listToBag (map exp_all cons)))
- checkIEAll (RnClass n ops) = returnRn (consBag (exp_all n) (listToBag (map exp_all ops)))
- checkIEAll (RnUnbound _) = returnRn emptyBag
- checkIEAll rn@(RnSyn _) = getSrcLocRn `thenRn` \ src_loc ->
- warnAndContinueRn emptyBag (synAllExportErr rn src_loc)
- checkIEAll rn = panic "checkIEAll"
+ checkIEAll (RnData n cons fields) = returnRn (exp_all n `consBag` listToBag (map exp_all cons)
+ `unionBags` listToBag (map exp_all fields))
+ checkIEAll (RnClass n ops) = returnRn (exp_all n `consBag` listToBag (map exp_all ops))
+ checkIEAll rn@(RnSyn _) = getSrcLocRn `thenRn` \ src_loc ->
+ warnAndContinueRn emptyBag (synAllExportErr rn src_loc)
+ checkIEAll rn = returnRn emptyBag
exp_all n = (n, ExportAll)
checkImportAll rn `thenRn_`
returnRn (Nothing, exps)
where
- checkIEWith rn@(RnData n cons) rns
- | same_names cons rns = returnRn (consBag (exp_all n) (listToBag (map exp_all cons)))
- | otherwise = rnWithErr "constructrs" rn cons rns
+ checkIEWith rn@(RnData n cons fields) rns
+ | same_names (cons++fields) rns
+ = returnRn (consBag (exp_all n) (listToBag (map exp_all cons)))
+ | otherwise
+ = rnWithErr "constructrs (and fields)" rn (cons++fields) rns
checkIEWith rn@(RnClass n ops) rns
- | same_names ops rns = returnRn (consBag (exp_all n) (listToBag (map exp_all ops)))
- | otherwise = rnWithErr "class ops" rn ops rns
- checkIEWith (RnUnbound _) rns = returnRn emptyBag
- checkIEWith rn@(RnSyn _) rns = getSrcLocRn `thenRn` \ src_loc ->
- failButContinueRn emptyBag (synAllExportErr rn src_loc)
- checkIEWith rn rns = panic "checkIEWith"
+ | same_names ops rns
+ = returnRn (consBag (exp_all n) (listToBag (map exp_all ops)))
+ | otherwise
+ = rnWithErr "class ops" rn ops rns
+ checkIEWith rn@(RnSyn _) rns
+ = getSrcLocRn `thenRn` \ src_loc ->
+ failButContinueRn emptyBag (synAllExportErr rn src_loc)
+ checkIEWith rn rns
+ = returnRn emptyBag
exp_all n = (n, ExportAll)
where
rn_decl (ConDecl name tys src_loc)
= pushSrcLocRn src_loc $
- lookupValue name `thenRn` \ new_name ->
+ lookupConstr name `thenRn` \ new_name ->
mapRn rn_bang_ty tys `thenRn` \ new_tys ->
returnRn (ConDecl new_name new_tys src_loc)
rn_decl (ConOpDecl ty1 op ty2 src_loc)
= pushSrcLocRn src_loc $
- lookupValue op `thenRn` \ new_op ->
+ lookupConstr op `thenRn` \ new_op ->
rn_bang_ty ty1 `thenRn` \ new_ty1 ->
rn_bang_ty ty2 `thenRn` \ new_ty2 ->
returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
rn_decl (NewConDecl name ty src_loc)
= pushSrcLocRn src_loc $
- lookupValue name `thenRn` \ new_name ->
+ lookupConstr name `thenRn` \ new_name ->
rn_mono_ty ty `thenRn` \ new_ty ->
returnRn (NewConDecl new_name new_ty src_loc)
- rn_decl (RecConDecl con fields src_loc)
- = panic "rnConDecls:RecConDecl"
+ rn_decl (RecConDecl name fields src_loc)
+ = pushSrcLocRn src_loc $
+ lookupConstr name `thenRn` \ new_name ->
+ mapRn rn_field fields `thenRn` \ new_fields ->
+ returnRn (RecConDecl new_name new_fields src_loc)
+
+ rn_field (names, ty)
+ = mapRn lookupField names `thenRn` \ new_names ->
+ rn_bang_ty ty `thenRn` \ new_ty ->
+ returnRn (new_names, new_ty)
- ----------
rn_mono_ty = rnMonoType tv_env
rn_bang_ty (Banged ty)
rnFixes :: [RdrNameFixityDecl] -> RnM s [RenamedFixityDecl]
rnFixes fixities
- = mapRn rn_fixity fixities `thenRn` \ fixes_maybe ->
+ = getSrcLocRn `thenRn` \ src_loc ->
+ let
+ (_, dup_fixes) = removeDups cmp_fix fixities
+ cmp_fix fix1 fix2 = nameFixDecl fix1 `cmp` nameFixDecl fix2
+
+ rn_fixity fix@(InfixL name i)
+ = rn_fixity_pieces InfixL name i fix
+ rn_fixity fix@(InfixR name i)
+ = rn_fixity_pieces InfixR name i fix
+ rn_fixity fix@(InfixN name i)
+ = rn_fixity_pieces InfixN name i fix
+
+ rn_fixity_pieces mk_fixity name i fix
+ = getRnEnv `thenRn` \ env ->
+ case lookupGlobalRnEnv env name of
+ Just res | isLocallyDefined res
+ -> returnRn (Just (mk_fixity res i))
+ _ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix)
+ in
+ mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_`
+ mapRn rn_fixity fixities `thenRn` \ fixes_maybe ->
returnRn (catMaybes fixes_maybe)
- where
- rn_fixity fix@(InfixL name i)
- = rn_fixity_pieces InfixL name i fix
- rn_fixity fix@(InfixR name i)
- = rn_fixity_pieces InfixR name i fix
- rn_fixity fix@(InfixN name i)
- = rn_fixity_pieces InfixN name i fix
-
- rn_fixity_pieces mk_fixity name i fix
- = lookupValueMaybe name `thenRn` \ maybe_res ->
- case maybe_res of
- Just res | isLocallyDefined res
- -> returnRn (Just (mk_fixity res i))
- _ -> failButContinueRn Nothing (undefinedFixityDeclErr fix)
-
+
+nameFixDecl (InfixL name i) = name
+nameFixDecl (InfixR name i) = name
+nameFixDecl (InfixN name i) = name
\end{code}
%*********************************************************
\begin{code}
-dupNameExportWarn locn names@((n,_):_) sty
- = ppHang (ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times:"])
- 4 (ppr sty locn)
-
-dupModuleExportWarn locn mods@(mod:_) sty
- = ppHang (ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list:"])
- 4 (ppr sty locn)
-
-dupLocalsExportErr locn locals@((str,_):_) sty
- = ppHang (ppBesides [ppStr "Exported names have same local name `", ppPStr str, ppStr "': ", ppr sty locn])
- 4 (ppInterleave ppSP (map (pprNonSym sty . snd) locals))
-
-classOpExportErr op locn sty
- = ppHang (ppStr "Class operation can only be exported with class:")
- 4 (ppCat [ppr sty op, ppr sty locn])
-
-synAllExportErr syn locn sty
- = ppHang (ppStr "Type synonym should be exported abstractly:")
- 4 (ppCat [ppr sty syn, ppr sty locn])
-
-withExportErr str rn has rns locn sty
- = ppHang (ppBesides [ppStr "Inconsistent list of ", ppStr str, ppStr ": ", ppr sty locn])
- 4 (ppAbove (ppCat [ppStr "expected:", ppInterleave ppComma (map (ppr sty) has)])
- (ppCat [ppStr "found: ", ppInterleave ppComma (map (ppr sty) rns)]))
-
-importAllErr rn locn sty
- = ppHang (ppCat [pprNonSym sty rn, ppStr "exported concretely but only imported abstractly"])
- 4 (ppr sty locn)
-
-badModExportErr mod locn sty
- = ppHang (ppStr "Unknown module in export list:")
- 4 (ppCat [ppStr "module", ppPStr mod, ppr sty locn])
-
-derivingNonStdClassErr clas locn sty
- = ppHang (ppStr "Non-standard class in deriving:")
- 4 (ppCat [ppr sty clas, ppr sty locn])
-
-dupDefaultDeclErr defs sty
- = ppHang (ppStr "Duplicate default declarations:")
- 4 (ppAboves (map pp_def_loc defs))
+dupNameExportWarn locn names@((n,_):_)
+ = addShortErrLocLine locn (\ sty ->
+ ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"])
+
+dupLocalsExportErr locn locals@((str,_):_)
+ = addErrLoc locn "exported names have same local name" (\ sty ->
+ ppInterleave ppSP (map (pprNonSym sty . snd) locals))
+
+classOpExportErr op locn
+ = addShortErrLocLine locn (\ sty ->
+ ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"])
+
+synAllExportErr syn locn
+ = addShortErrLocLine locn (\ sty ->
+ ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"])
+
+withExportErr str rn has rns locn
+ = addErrLoc locn "" (\ sty ->
+ ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in export list for `", ppr sty rn, ppStr "'"],
+ ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)],
+ ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) rns)] ])
+
+importAllErr rn locn
+ = addShortErrLocLine locn (\ sty ->
+ ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"])
+
+badModExportErr mod locn
+ = addShortErrLocLine locn (\ sty ->
+ ppCat [ ppStr "unknown module in export list:", ppPStr mod])
+
+dupModExportWarn locn mods@(mod:_)
+ = addShortErrLocLine locn (\ sty ->
+ ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"])
+
+emptyModExportWarn locn mod
+ = addShortErrLocLine locn (\ sty ->
+ ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"])
+
+derivingNonStdClassErr clas locn
+ = addShortErrLocLine locn (\ sty ->
+ ppCat [ppStr "non-standard class in deriving:", ppr sty clas])
+
+dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
+ = ppAboves (item1 : map dup_item dup_things)
where
- pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc
+ item1
+ = addShortErrLocLine locn1 (\ sty -> ppStr "multiple default declarations") sty
+
+ dup_item (DefaultDecl _ locn)
+ = addShortErrLocLine locn (\ sty -> ppStr "here was another default declaration") sty
+
+undefinedFixityDeclErr locn decl
+ = addErrLoc locn "fixity declaration for unknown operator" (\ sty ->
+ ppr sty decl)
-undefinedFixityDeclErr decl sty
- = ppHang (ppStr "Fixity declaration for unknown operator:")
- 4 (ppr sty decl)
+dupFixityDeclErr locn dups
+ = addErrLoc locn "multiple fixity declarations for same operator" (\ sty ->
+ ppAboves (map (ppr sty) dups))
\end{code}
RnEnv(..), QualNames(..),
UnqualNames(..), ScopeStack(..),
emptyRnEnv, extendGlobalRnEnv, extendLocalRnEnv,
- lookupRnEnv, lookupTcRnEnv,
+ lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv,
lubExportFlag,
dupNamesErr,
shadowedNameWarn,
multipleOccWarn,
-
- -- ToDo: nuke/move? WDP 96/04/05
- GlobalNameMapper(..), GlobalNameMappers(..)
+ negateNameWarn
) where
import Ubiq
import Pretty
import RnHsSyn ( RnName )
import Util ( assertPanic )
-
-type GlobalNameMapper = RnName -> Maybe Name
-type GlobalNameMappers = (GlobalNameMapper, GlobalNameMapper)
\end{code}
*********************************************************
-> (RnEnv, Bag (RdrName, RnName, RnName))
extendLocalRnEnv :: Bool -> RnEnv -> [RnName] -> (RnEnv, [RnName])
lookupRnEnv :: RnEnv -> RdrName -> Maybe RnName
+lookupGlobalRnEnv :: RnEnv -> RdrName -> Maybe RnName
lookupTcRnEnv :: RnEnv -> RdrName -> Maybe RnName
\end{code}
found@(Just name) -> found
Nothing -> do_on_fail
+lookupGlobalRnEnv ((qual, unqual, _, _), _) rdr
+ = case rdr of
+ Unqual str -> lookupFM unqual str
+ Qual mod str -> lookupFM qual (str,mod)
+
lookupTcRnEnv ((_, _, tc_qual, tc_unqual), _) rdr
= case rdr of
Unqual str -> lookupFM tc_unqual str
= ppAboves (item1 : map dup_item dup_things)
where
item1
- = ppBesides [ ppr PprForUser locn1,
- ppStr ": multiple declarations of a ", ppStr descriptor, ppStr ": ",
- pprNonSym sty name1 ]
+ = addShortErrLocLine locn1 (\ sty ->
+ ppBesides [ppStr "multiple declarations of a ", ppStr descriptor, ppStr " `",
+ pprNonSym sty name1, ppStr "'" ]) sty
dup_item (name, locn)
- = ppBesides [ ppr PprForUser locn,
- ppStr ": here was another declaration of `", pprNonSym sty name, ppStr "'" ]
+ = addShortErrLocLine locn (\ sty ->
+ ppBesides [ppStr "here was another declaration of `",
+ pprNonSym sty name, ppStr "'" ]) sty
shadowedNameWarn locn shadow
= addShortErrLocLine locn ( \ sty ->
multipleOccWarn (name, occs) sty
= ppBesides [ppStr "multiple names used to refer to `", ppr sty name, ppStr "': ",
ppInterleave ppComma (map (ppr sty) occs)]
+
+negateNameWarn (name,locn)
+ = addShortErrLocLine locn ( \ sty ->
+ ppBesides [ppStr "local binding of `negate' will be used for prefix `-'"])
\end{code}
import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
import TcSimplify ( tcSimplifyThetas )
---import RnMonad4
-import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
---import RnBinds4 ( rnMethodBinds, rnTopBinds )
+import RnMonad
+import RnUtils ( RnEnv(..) )
+import RnBinds ( rnMethodBinds, rnTopBinds )
import Bag ( emptyBag{-ToDo:rm-}, Bag, isEmptyBag, unionBags, listToBag )
import Class ( GenClass, getClassKey )
mkSigmaTy, mkDictTy, isPrimType, instantiateTy,
getAppTyCon, getAppDataTyCon )
import TyVar ( GenTyVar )
-import UniqFM ( eltsUFM )
+import UniqFM ( emptyUFM )
import Unique -- Keys stuff
import Util ( zipWithEqual, zipEqual, sortLt, removeDups,
thenCmp, cmpList, panic, pprPanic, pprPanic# )
\begin{code}
tcDeriving :: Module -- name of module under scrutiny
- -> GlobalNameMappers -- for "renaming" bits of generated code
+ -> RnEnv -- for "renaming" bits of generated code
-> Bag InstInfo -- What we already know about instances
-> [RenamedFixityDecl] -- Fixity info; used by Read and Show
-> TcM s (Bag InstInfo, -- The generated "instance decls".
PprStyle -> Pretty) -- Printable derived instance decls;
-- for debugging via -ddump-derivings.
-tcDeriving modname renamer_name_funs inst_decl_infos_in fixities
+tcDeriving modname rn_env inst_decl_infos_in fixities
= returnTc (trace "tcDeriving:ToDo" (emptyBag, EmptyBinds, \ x -> ppNil))
{- LATER:
-tcDeriving modname renamer_name_funs inst_decl_infos_in fixities
+tcDeriving modname rn_env inst_decl_infos_in fixities
= -- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
makeDerivEqns `thenTc` \ eqns ->
assoc_maybe ((k,v) : vs) key
= if k `eqProtoName` key then Just v else assoc_maybe vs key
in
- gen_tag_n_con_binds deriver_name_funs nm_alist_etc `thenTc` \ extra_binds ->
+ gen_tag_n_con_binds deriver_rn_env nm_alist_etc `thenTc` \ extra_binds ->
- mapTc (gen_inst_info maybe_mod fixities deriver_name_funs) new_inst_infos
+ mapTc (gen_inst_info maybe_mod fixities deriver_rn_env) new_inst_infos
`thenTc` \ really_new_inst_infos ->
returnTc (listToBag really_new_inst_infos,
gen_inst_info :: Maybe Module -- Module name; Nothing => Prelude
-> [RenamedFixityDecl] -- all known fixities;
-- may be needed for Text
- -> GlobalNameMappers -- lookup stuff for names we may use
+ -> RnEnv -- lookup stuff for names we may use
-> InstInfo -- the main stuff to work on
-> TcM s InstInfo -- the gen'd (filled-in) "instance decl"
-gen_inst_info modname fixities deriver_name_funs
+gen_inst_info modname fixities deriver_rn_env
info@(InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
=
-- Generate the various instance-related Ids
| clas_key == binaryClassKey = gen_Binary_binds tycon
| otherwise = panic "gen_inst_info:bad derived class"
in
- rn4MtoTcM deriver_name_funs (
+ rnMtoTcM deriver_rn_env (
+ setExtraRn emptyUFM{-no fixities-} $
rnMethodBinds clas_Name proto_mbinds
) `thenNF_Tc` \ (mbinds, errs) ->
maxtag_Foo :: Int -- ditto (NB: not unboxed)
\begin{code}
-gen_tag_n_con_binds :: GlobalNameMappers
+gen_tag_n_con_binds :: RnEnv
-> [(RdrName, RnName, TyCon, TagThingWanted)]
-> TcM s RenamedHsBinds
-gen_tag_n_con_binds deriver_name_funs nm_alist_etc
+gen_tag_n_con_binds deriver_rn_env nm_alist_etc
= let
proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
proto_mbinds = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list
in
- rn4MtoTcM deriver_name_funs (
+ rnMtoTcM deriver_rn_env (
+ setExtraRn emptyUFM{-no fixities-} $
rnTopBinds (SingleBind (RecBind proto_mbinds))
) `thenNF_Tc` \ (binds, errs) ->
\begin{code}
tcExpr (HsPar expr) = tcExpr expr
-tcExpr (NegApp expr) = panic "tcExpr:NegApp"
+tcExpr (NegApp expr n) = tcExpr (HsApp (HsVar n) expr)
tcExpr (HsLam match)
= tcMatch match `thenTc` \ (match',lie,ty) ->
%* *
%************************************************************************
-ToDo: panic on things that can't be in @TypecheckedHsExpr@.
-
\begin{code}
zonkExpr :: TcExpr s -> NF_TcM s TypecheckedHsExpr
= zonkId name `thenNF_Tc` \ new_name ->
returnNF_Tc (HsVar new_name)
+zonkExpr (HsLit _) = panic "zonkExpr:HsLit"
+
zonkExpr (HsLitOut lit ty)
= zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
returnNF_Tc (HsLitOut lit new_ty)
zonkExpr e2 `thenNF_Tc` \ new_e2 ->
returnNF_Tc (OpApp new_e1 new_op new_e2)
-zonkExpr (NegApp _) = panic "zonkExpr:NegApp"
-zonkExpr (HsPar _) = panic "zonkExpr:HsPar"
+zonkExpr (NegApp _ _) = panic "zonkExpr:NegApp"
+zonkExpr (HsPar _) = panic "zonkExpr:HsPar"
zonkExpr (SectionL expr op)
= zonkExpr expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (ExplicitTuple new_exprs)
zonkExpr (RecordCon con rbinds)
- = panic "zonkExpr:RecordCon"
-zonkExpr (RecordUpd exp rbinds)
- = panic "zonkExpr:RecordUpd"
-zonkExpr (RecordUpdOut exp ids rbinds)
- = panic "zonkExpr:RecordUpdOut"
+ = zonkExpr con `thenNF_Tc` \ new_con ->
+ zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
+ returnNF_Tc (RecordCon new_con new_rbinds)
+
+zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
+
+zonkExpr (RecordUpdOut expr ids rbinds)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ mapNF_Tc zonkId ids `thenNF_Tc` \ new_ids ->
+ zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
+ returnNF_Tc (RecordUpdOut new_expr new_ids new_rbinds)
zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
zonk_stmt (LetStmt binds)
= zonkBinds binds `thenNF_Tc` \ new_binds ->
returnNF_Tc (LetStmt new_binds)
+
+-------------------------------------------------------------------------
+zonkRbinds :: TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds
+
+zonkRbinds rbinds
+ = mapNF_Tc zonk_rbind rbinds
+ where
+ zonk_rbind (field, expr, pun)
+ = zonkId field `thenNF_Tc` \ new_field ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (new_field, new_expr, pun)
\end{code}
%************************************************************************
returnNF_Tc (ListPat new_ty new_pats)
zonkPat (TuplePat pats)
- = mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats ->
+ = mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats ->
returnNF_Tc (TuplePat new_pats)
+zonkPat (RecPat n ty rpats)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ mapNF_Tc zonk_rpat rpats `thenNF_Tc` \ new_rpats ->
+ returnNF_Tc (RecPat n new_ty new_rpats)
+ where
+ zonk_rpat (f, pat, pun)
+ = zonkPat pat `thenNF_Tc` \ new_pat ->
+ returnNF_Tc (f, new_pat, pun)
+
zonkPat (LitPat lit ty)
= zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
returnNF_Tc (LitPat lit new_ty)
)
import PprStyle
import Pretty
-import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
+import RnUtils ( RnEnv(..) )
import TyCon ( derivedFor )
import Type ( GenType(..), ThetaType(..), mkTyVarTys,
splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
tcInstDecls1 :: Bag RenamedInstDecl
-> [RenamedSpecInstSig]
-> Module -- module name for deriving
- -> GlobalNameMappers -- renamer fns for deriving
+ -> RnEnv -- for renaming derivings
-> [RenamedFixityDecl] -- fixities for deriving
-> TcM s (Bag InstInfo,
RenamedHsBinds,
PprStyle -> Pretty)
-tcInstDecls1 inst_decls specinst_sigs mod_name renamer_name_funs fixities
+tcInstDecls1 inst_decls specinst_sigs mod_name rn_env fixities
= -- Do the ordinary instance declarations
mapBagNF_Tc (tcInstDecl1 mod_name) inst_decls
`thenNF_Tc` \ inst_info_bags ->
-- for things in this module; we ignore deriving decls from
-- interfaces! We pass fixities, because they may be used
-- in deriving Read and Show.
- tcDeriving mod_name renamer_name_funs decl_inst_info fixities
+ tcDeriving mod_name rn_env decl_inst_info fixities
`thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
let
import Name ( isExported, isLocallyDefined )
import PrelInfo ( unitTy, mkPrimIoTy )
import Pretty
-import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
+import RnUtils ( RnEnv(..) )
import TyCon ( TyCon )
import Type ( mkSynTy )
import Unify ( unifyTauTy )
\end{code}
\begin{code}
-tcModule :: GlobalNameMappers -- final renamer info for derivings
+tcModule :: RnEnv -- for renaming derivings
-> RenamedHsModule -- input
-> TcM s ((TypecheckedHsBinds, -- record selector binds
TypecheckedHsBinds, -- binds from class decls; does NOT
PprStyle -> Pretty) -- -ddump-deriving info
-tcModule renamer_name_funs
+tcModule rn_env
(HsModule mod_name verion exports imports fixities
ty_decls specdata_sigs cls_decls inst_decls specinst_sigs
default_decls val_decls sigs src_loc)
tcSetEnv env (
--trace "tcInstDecls:" $
tcInstDecls1 inst_decls_bag specinst_sigs
- mod_name renamer_name_funs fixities
+ mod_name rn_env fixities
) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
tcNewMutVar, tcReadMutVar, tcWriteMutVar,
- rn4MtoTcM,
+ rnMtoTcM,
TcError(..), TcWarning(..),
mkTcErr, arityErr,
Warning(..) )
import SST
---import RnMonad4
---LATER:import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
+import RnMonad ( RnM(..), RnDown, initRn, setExtraRn )
+import RnUtils ( RnEnv(..) )
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
%~~~~~~~~~~~~~~~~~~
\begin{code}
-rn4MtoTcM = panic "TcMonad.rn4MtoTcM (ToDo LATER)"
-{- LATER:
-rn4MtoTcM :: GlobalNameMappers -> Rn4M a -> NF_TcM s (a, Bag Error)
+rnMtoTcM :: RnEnv -> RnM _RealWorld a -> NF_TcM s (a, Bag Error)
-rn4MtoTcM name_funs rn_action down env
+rnMtoTcM rn_env rn_action down env
= readMutVarSST u_var `thenSST` \ uniq_supply ->
let
(new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
in
writeMutVarSST u_var new_uniq_supply `thenSST_`
let
- (rn_result, rn_errs)
- = rn_action name_funs emptyFM emptyBag uniq_s mkUnknownSrcLoc
+ (rn_result, rn_errs, rn_warns)
+ = initRn True (panic "rnMtoTcM:module") rn_env uniq_s rn_action
in
returnSST (rn_result, rn_errs)
where
u_var = getUniqSupplyVar down
--}
\end{code}
= newTyVarTy mkTypeKind `thenNF_Tc` \ tyvar_ty ->
returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty)
+tcPat (NegPatIn pat)
+ = tcPat (negate_lit pat)
+ where
+ negate_lit (LitPatIn (HsInt i)) = LitPatIn (HsInt (-i))
+ negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f))
+ negate_lit _ = panic "TcPat:negate_pat"
+
tcPat (ParPatIn parend_pat)
= tcPat parend_pat
\end{code}
lie,
data_ty)
-tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form...
+tcPat pat_in@(ConOpPatIn pat1 op pat2) -- in binary-op form...
= tcPat pat1 `thenTc` \ (pat1', lie1, ty1) ->
tcPat pat2 `thenTc` \ (pat2', lie2, ty2) ->
(_, record_ty) = splitFunTy con_tau
in
-- Con is syntactically constrained to be a data constructor
- ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
+ ASSERT( maybeToBool (maybeAppDataTyCon record_ty) )
mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) ->
- returnTc (panic "tcPat:RecPatIn:avoid type errors"{-RecPat con_id record_ty rpats',
+ returnTc (RecPat con_id record_ty rpats',
plusLIEs lies,
- record_ty-})
+ record_ty)
where
do_bind expected_record_ty (field_label, rhs_pat, pun_flag)
returnTc (con_ids ++ sel_ids,
SingleBind $ NonRecBind $
foldr AndMonoBinds
- (foldr AndMonoBinds EmptyMonoBinds con_binds)
+ (foldr AndMonoBinds EmptyMonoBinds sel_binds)
con_binds
)
where
selector_body = HsCase (HsVar record_id) (map mk_match fields) (getSrcLoc tycon)
mk_match (con_id, field_label)
- = PatMatch (RecPat con_id data_ty' [(RealId selector_id, VarPat field_id, False)]) $
+ = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $
SimpleMatch $
HsVar field_id
in
import ErrUtils ( Warning(..), Error(..) )
import Pretty
-import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
+import RnUtils ( RnEnv(..) )
import Maybes ( MaybeErr(..) )
\end{code}
\begin{code}
typecheckModule
:: UniqSupply -- name supply in
- -> GlobalNameMappers -- renamer info (for doing derivings)
+ -> RnEnv -- renamer env (for doing derivings)
-> RenamedHsModule -- input module
-> -- OUTPUTS ...
(Bag Error, -- pretty-print this to get errors
Bag Warning) -- pretty-print this to get warnings
-typecheckModule us renamer_name_funs mod
- = initTc us (tcModule renamer_name_funs mod)
+typecheckModule us rn_env mod
+ = initTc us (tcModule rn_env mod)
\end{code}
emptyFM, unitFM, listToFM,
- addToFM, addListToFM,
- IF_NOT_GHC(addToFM_C COMMA)
+ addToFM,
+ addToFM_C,
+ addListToFM,
addListToFM_C,
IF_NOT_GHC(delFromFM COMMA)
delListFromFM,
- plusFM, plusFM_C,
- IF_NOT_GHC(intersectFM COMMA intersectFM_C COMMA)
- minusFM, -- exported for GHCI only
+ plusFM,
+ plusFM_C,
+ minusFM, -- exported for GHCI only
+ IF_NOT_GHC(intersectFM COMMA)
+ IF_NOT_GHC(intersectFM_C COMMA)
IF_NOT_GHC(mapFM COMMA foldFM COMMA filterFM COMMA)
- IF_NOT_GHC(sizeFM COMMA)
- isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM,
+ sizeFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM,
- fmToList, keysFM, eltsFM{-used in GHCI-}
+ fmToList, keysFM, eltsFM
#ifdef COMPILING_GHC
, bagToFM
projects / ghc-hetmet.git / commitdiff