Commit 4250d641 authored by partain's avatar partain

[project @ 1996-04-25 13:02:32 by partain]

Sansom 1.3 changes to 960425
parent 1ffb620a
......@@ -594,15 +594,15 @@ compile(main/MkIface,lhs,)
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
......
......@@ -1013,7 +1013,11 @@ getIdNamePieces show_uniqs id
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
......
......@@ -33,6 +33,7 @@ outPatType (ConPat _ ty _) = ty
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
......
......@@ -57,8 +57,11 @@ data HsExpr tyvar uvar id pat
(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
......@@ -224,7 +227,7 @@ pprExpr sty (OpApp e1 op e2)
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)
......@@ -401,8 +404,8 @@ pp_rbinds sty thing rbinds
= 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}
%************************************************************************
......
......@@ -88,7 +88,7 @@ data OutPat tyvar uvar id
| 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.
......@@ -103,7 +103,7 @@ data OutPat tyvar uvar id
(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}
......@@ -153,10 +153,10 @@ pprInPat sty (TuplePatIn pats)
= 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}
......@@ -191,10 +191,10 @@ pprOutPat sty (TuplePat pats)
= 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
......@@ -293,14 +293,15 @@ collected is important; see @HsBinds.lhs@.
\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}
......@@ -109,7 +109,7 @@ doIt (core_cmds, stg_cmds) input_pgm
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) ->
......@@ -137,10 +137,7 @@ doIt (core_cmds, stg_cmds) input_pgm
-- ******* 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)
......
......@@ -341,10 +341,11 @@ generic_pair thing
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
......
......@@ -433,6 +433,5 @@ class_op_keys
, (SLIT("enumFromTo"), enumFromToClassOpKey)
, (SLIT("enumFromThenTo"), enumFromThenToClassOpKey)
, (SLIT("=="), eqClassOpKey)
-- , (SLIT(">="), geClassOpKey)
]]
\end{code}
......@@ -308,7 +308,7 @@ wlkExpr expr
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 ->
......@@ -899,10 +899,9 @@ rdEntity pt
-- 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}
......@@ -57,11 +57,11 @@ data ParsedIface
-----------------------------------------------------------------
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
......@@ -151,14 +151,18 @@ mk_data :: RdrNameContext
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])
......
......@@ -31,7 +31,7 @@ import RnMonad
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 )
......@@ -54,6 +54,7 @@ renameModule :: BuiltinNames
-> RdrNameHsModule
-> IO (RenamedHsModule, -- output, after renaming
RnEnv, -- final env (for renaming derivings)
[Module], -- imported modules; for profiling
VersionInfo, -- version info; for usage
......@@ -64,7 +65,6 @@ renameModule :: BuiltinNames
\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 ???)
......@@ -129,7 +129,7 @@ renameModule b_names b_keys us
}) >>= \ (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 ...
......@@ -139,17 +139,18 @@ renameModule b_names b_keys us
-- 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)
......@@ -160,32 +161,36 @@ renameModule b_names b_keys us
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"
......@@ -237,13 +242,16 @@ pprRdrIfaceDecl (TypeSig tc _ decl)
= 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]
......
......@@ -25,14 +25,14 @@ import RdrHsSyn
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}
......@@ -58,20 +58,20 @@ rnPat (LazyPatIn pat)
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 ->
......@@ -97,8 +97,9 @@ rnPat (TuplePatIn pats)
returnRn (TuplePatIn patslist)
rnPat (RecPatIn con rpats)
= panic "rnPat:RecPatIn"
= lookupConstr con `thenRn` \ con' ->
rnRpats rpats `thenRn` \ rpats' ->
returnRn (RecPatIn con' rpats')
\end{code}
************************************************************************
......@@ -194,15 +195,16 @@ ToDo: what about RnClassOps ???
\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)
......@@ -223,9 +225,10 @@ rnExpr (OpApp e1 op e2)
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) ->
......@@ -278,10 +281,15 @@ rnExpr (ExplicitTuple exps)
= 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) ->
......@@ -319,7 +327,43 @@ rnExpr (ArithSeqIn seq)
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}
%************************************************************************
......@@ -428,13 +472,13 @@ rnStmt (LetStmt binds)
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
......@@ -534,9 +578,13 @@ checkPrec op pat right
\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 ->
......
......@@ -30,16 +30,17 @@ import Util ( panic, pprPanic, pprTrace{-ToDo:rm-} )
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
......@@ -54,10 +55,9 @@ isRnWired _ = False
isRnLocal (RnName n) = isLocalName n
isRnLocal _ = False
isRnTyCon (WiredInTyCon _) = True
isRnTyCon (RnSyn _) = True
isRnTyCon (RnData _ _) = True
isRnTyCon (RnData _ _ _) = True
isRnTyCon (RnImplicitTyCon _) = True
isRnTyCon _ = False
......@@ -68,14 +68,19 @@ isRnClass _ = 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
......@@ -106,8 +111,9 @@ instance NamedThing RnName where
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
......@@ -122,10 +128,11 @@ instance NamedThing RnName where
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
......
This diff is collapsed.
......@@ -9,18 +9,18 @@
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,
......@@ -38,12 +38,12 @@ import HsSyn ( FixityDecl )
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 )
......@@ -161,6 +161,12 @@ mapAndUnzipRn f (x:xs)
= 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 ...
......@@ -194,6 +200,10 @@ addWarnIfRn False warn = returnRn ()
\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)
......@@ -281,11 +291,13 @@ newLocalNames :: String -- Documentation string
-> 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}
......@@ -319,17 +331,26 @@ If not found create new implicit name, adding it to the implicit env.
\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")