Commit cc051dd7 authored by partain's avatar partain

[project @ 1996-04-30 13:08:34 by partain]

Sansom 1.3 changes through 960429
parent f16166e4
......@@ -36,13 +36,15 @@ module Name (
nameOrigName,
nameExportFlag,
nameSrcLoc,
nameImpLocs,
nameImportFlag,
isLocallyDefinedName,
isPreludeDefinedName,
origName, moduleOf, nameOf, moduleNamePair,
getOccName, getExportFlag,
getSrcLoc, isLocallyDefined, isPreludeDefined,
getSrcLoc, getImpLocs,
isLocallyDefined, isPreludeDefined,
getLocalName, ltLexical,
isSymLexeme, pprSym, pprNonSym,
......@@ -157,7 +159,7 @@ data Provenance
| Imported ExportFlag -- how it was imported
SrcLoc -- *original* source location
-- [SrcLoc] -- any import source location(s)
[SrcLoc] -- any import source location(s)
| Implicit
| Builtin
......@@ -167,7 +169,7 @@ data Provenance
mkLocalName = Local
mkTopLevName u orig locn exp occs = Global u orig (LocalDef locn) exp occs
mkImportedName u orig imp locn exp occs = Global u orig (Imported imp locn) exp occs
mkImportedName u orig imp locn imp_locs exp occs = Global u orig (Imported imp locn imp_locs) exp occs
mkImplicitName :: Unique -> RdrName -> Name
mkImplicitName u o = Global u o Implicit NotExported []
......@@ -274,23 +276,26 @@ nameOccName (Global _ orig _ _ occs) = head occs
nameExportFlag (Local _ _ _) = NotExported
nameExportFlag (Global _ _ _ exp _) = exp
nameSrcLoc (Local _ _ loc) = loc
nameSrcLoc (Global _ _ (LocalDef loc) _ _) = loc
nameSrcLoc (Global _ _ (Imported _ loc) _ _) = loc
nameSrcLoc (Global _ _ Implicit _ _) = mkUnknownSrcLoc
nameSrcLoc (Global _ _ Builtin _ _) = mkBuiltinSrcLoc
nameImportFlag (Local _ _ _) = NotExported
nameImportFlag (Global _ _ (LocalDef _) _ _) = ExportAll
nameImportFlag (Global _ _ (Imported exp _) _ _) = exp
nameImportFlag (Global _ _ Implicit _ _) = ExportAll
nameImportFlag (Global _ _ Builtin _ _) = ExportAll
isLocallyDefinedName (Local _ _ _) = True
isLocallyDefinedName (Global _ _ (LocalDef _) _ _) = True
isLocallyDefinedName (Global _ _ (Imported _ _) _ _) = False
isLocallyDefinedName (Global _ _ Implicit _ _) = False
isLocallyDefinedName (Global _ _ Builtin _ _) = False
nameSrcLoc (Local _ _ loc) = loc
nameSrcLoc (Global _ _ (LocalDef loc) _ _) = loc
nameSrcLoc (Global _ _ (Imported _ loc _) _ _) = loc
nameSrcLoc (Global _ _ Implicit _ _) = mkUnknownSrcLoc
nameSrcLoc (Global _ _ Builtin _ _) = mkBuiltinSrcLoc
nameImpLocs (Global _ _ (Imported _ _ locs) _ _) = locs
nameImpLocs _ = []
nameImportFlag (Local _ _ _) = NotExported
nameImportFlag (Global _ _ (LocalDef _) _ _) = ExportAll
nameImportFlag (Global _ _ (Imported exp _ _) _ _) = exp
nameImportFlag (Global _ _ Implicit _ _) = ExportAll
nameImportFlag (Global _ _ Builtin _ _) = ExportAll
isLocallyDefinedName (Local _ _ _) = True
isLocallyDefinedName (Global _ _ (LocalDef _) _ _) = True
isLocallyDefinedName (Global _ _ (Imported _ _ _) _ _) = False
isLocallyDefinedName (Global _ _ Implicit _ _) = False
isLocallyDefinedName (Global _ _ Builtin _ _) = False
isPreludeDefinedName (Local _ n _) = False
isPreludeDefinedName (Global _ orig _ _ _) = isUnqual orig
......@@ -375,6 +380,7 @@ getOccName :: NamedThing a => a -> RdrName
getLocalName :: NamedThing a => a -> FAST_STRING
getExportFlag :: NamedThing a => a -> ExportFlag
getSrcLoc :: NamedThing a => a -> SrcLoc
getImpLocs :: NamedThing a => a -> [SrcLoc]
isLocallyDefined :: NamedThing a => a -> Bool
isPreludeDefined :: NamedThing a => a -> Bool
......@@ -393,6 +399,7 @@ getLocalName = nameOf . origName
getOccName = nameOccName . getName
getExportFlag = nameExportFlag . getName
getSrcLoc = nameSrcLoc . getName
getImpLocs = nameImpLocs . getName
isLocallyDefined = isLocallyDefinedName . getName
isPreludeDefined = isPreludeDefinedName . getName
\end{code}
......
......@@ -46,7 +46,7 @@ import PrelInfo ( mkTupleTy, unitTy, nilDataCon, consDataCon,
)
import Pretty ( ppShow, ppBesides, ppPStr, ppStr )
import Type ( splitSigmaTy, splitFunTy, typePrimRep, getAppDataTyCon )
import TyVar ( nullTyVarEnv, addOneToTyVarEnv )
import TyVar ( GenTyVar, nullTyVarEnv, addOneToTyVarEnv )
import Usage ( UVar(..) )
import Util ( zipEqual, pprError, panic, assertPanic )
......@@ -358,26 +358,23 @@ before printing it as
dsExpr (RecordCon con_expr rbinds)
= dsExpr con_expr `thenDs` \ con_expr' ->
let
con_id = get_con_id con_expr'
con_id = get_con con_expr'
(arg_tys, _) = splitFunTy (coreExprType con_expr')
mk_arg lbl
mk_arg (arg_ty, lbl)
= case [rhs | (sel_id,rhs,_) <- rbinds,
lbl == recordSelectorFieldLabel sel_id] of
(rhs:rhss) -> ASSERT( null rhss )
dsExpr rhs
[] -> mkErrorAppDs rEC_CON_ERROR_ID (fieldLabelType lbl) (showForErr lbl)
-- ToDo Bug: fieldLabelType lbl needs to be instantiated with appropriate type args
-- problem also arises if ty is extraced by splitting the type of the con_id
[] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showForErr lbl)
in
mapDs mk_arg (dataConFieldLabels con_id) `thenDs` \ con_args ->
mapDs mk_arg (arg_tys `zipEqual` dataConFieldLabels con_id) `thenDs` \ con_args ->
mkAppDs con_expr' [] con_args
where
-- The "con_expr'" is simply an application of the constructor Id
-- to types and (perhaps) dictionaries. This boring little
-- function gets the constructor out.
get_con_id (App fun _) = get_con_id fun
get_con_id (Var con) = con
-- "con_expr'" is simply an application of the constructor Id
-- to types and (perhaps) dictionaries. This gets the constructor...
get_con (Var con) = con
get_con (App fun _) = get_con fun
\end{code}
Record update is a little harder. Suppose we have the decl:
......
......@@ -91,6 +91,12 @@ isRnImplicit _ = False
isRnUnbound (RnUnbound _) = True
isRnUnbound _ = False
isRnDecl (RnName _) = True
isRnDecl (RnSyn _) = True
isRnDecl (RnData _ _ _) = True
isRnDecl (RnClass _ _) = True
isRnDecl _ = False
-- Very general NamedThing comparison, used when comparing
-- Uniquable things with different types
......
......@@ -27,21 +27,21 @@ import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst )
import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags,
unionManyBags, mapBag, listToBag, bagToList )
unionManyBags, mapBag, filterBag, listToBag, bagToList )
import CmdLineOpts ( opt_NoImplicitPrelude )
import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine )
import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM )
import Id ( GenId )
import Maybes ( maybeToBool, catMaybes, MaybeErr(..) )
import Name ( RdrName(..), Name, isQual, mkTopLevName,
import Name ( RdrName(..), Name, isQual, mkTopLevName, origName,
mkImportedName, nameExportFlag, nameImportFlag,
getLocalName, getSrcLoc, pprNonSym, moduleNamePair,
isLexCon, isRdrLexCon, ExportFlag(..)
getLocalName, getSrcLoc, getImpLocs, moduleNamePair,
pprNonSym, isLexCon, isRdrLexCon, ExportFlag(..)
)
import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) )
import PrelMods ( fromPrelude, pRELUDE )
import Pretty
import SrcLoc ( SrcLoc, mkIfaceSrcLoc )
import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
import TyCon ( tyConDataCons )
import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM )
import UniqSupply ( splitUniqSupply )
......@@ -81,17 +81,20 @@ getGlobalNames iface_cache info us
\ (imp_vals, imp_tcs, imp_mods, unqual_imps, imp_fixes, imp_errs, imp_warns) ->
let
unqual_vals = mapBag (\rn -> (Unqual (getLocalName rn), rn)) src_vals
unqual_tcs = mapBag (\rn -> (Unqual (getLocalName rn), rn)) src_tcs
unqual_vals = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_vals)
unqual_tcs = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_tcs)
all_vals = bagToList (unqual_vals `unionBags` imp_vals)
all_tcs = bagToList (unqual_tcs `unionBags` imp_tcs)
(src_env, src_dups) = extendGlobalRnEnv emptyRnEnv unqual_vals unqual_tcs
(all_env, imp_dups) = extendGlobalRnEnv src_env (bagToList imp_vals) (bagToList imp_tcs)
(all_env, dups) = extendGlobalRnEnv emptyRnEnv all_vals all_tcs
-- remove dups of the same imported thing
diff_imp_dups = filterBag diff_orig imp_dups
diff_orig (_,rn1,rn2) = origName rn1 /= origName rn2
dup_errs = map dup_err (equivClasses cmp_rdr (bagToList dups))
all_dups = bagToList (src_dups `unionBags` diff_imp_dups)
dup_errs = map dup_err (equivClasses cmp_rdr all_dups)
cmp_rdr (rdr1,_,_) (rdr2,_,_) = cmp rdr1 rdr2
dup_err ((_,rn,rn'):rest) = globalDupNamesErr (rn:rn': [rn|(_,_,rn)<-rest])
dup_err ((rdr,rn1,rn2):rest) = globalDupNamesErr rdr (rn1:rn2: [rn|(_,_,rn)<-rest])
all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs
all_warns = src_warns `unionBags` imp_warns
......@@ -303,7 +306,7 @@ newGlobalName locn maybe_exp rdr
type ImportNameInfo = (GlobalNameInfo,
FiniteMap (Module,FAST_STRING) RnName, -- values imported so far
FiniteMap (Module,FAST_STRING) RnName, -- tycons/classes imported so far
Name -> ExportFlag) -- import flag
Name -> (ExportFlag, [SrcLoc])) -- import flag and src locns
type RnM_IInfo s r = RnMonad ImportNameInfo s r
......@@ -321,14 +324,15 @@ doImportDecls ::
Bag Warning)
doImportDecls iface_cache g_info us src_imps
= fixIO ( \ ~(_, _, _, _, _, _, rec_imp_flags) ->
= fixIO ( \ ~(_, _, _, _, _, _, rec_imp_stuff) ->
let
rec_imp_fm = addListToUFM_C lubExportFlag emptyUFM (bagToList rec_imp_flags)
rec_imp_fm = addListToUFM_C add_stuff emptyUFM (bagToList rec_imp_stuff)
add_stuff (imp1,locns1) (imp2,locns2) = (lubExportFlag imp1 imp2, locns1 `unionBags` locns2)
rec_imp_fn :: Name -> ExportFlag
rec_imp_fn :: Name -> (ExportFlag, [SrcLoc])
rec_imp_fn n = case lookupUFM rec_imp_fm n of
Nothing -> panic "RnNames:rec_imp_fn"
Just flag -> flag
Nothing -> panic "RnNames:rec_imp_fn"
Just (flag, locns) -> (flag, bagToList locns)
i_info = (g_info, emptyFM, emptyFM, rec_imp_fn)
in
......@@ -336,35 +340,37 @@ doImportDecls iface_cache g_info us src_imps
) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) ->
return (vals, tcs, imp_mods, unquals, fixes,
imp_errs `unionBags` errs,
imp_warns `unionBags` warns)
errs, imp_warns `unionBags` warns)
where
(ok_imps, src_qprels) = partition not_qual_prel src_imps
the_imps = prel_imp ++ ok_imps
all_imps = qprel_imp ++ the_imps
(src_qprels, ok_imps) = partition qual_prel src_imps
the_imps = ok_imps ++ prel_imp
all_imps = the_imps ++ qprel_imp
not_qual_prel (ImportDecl mod qual _ _ _) = not (fromPrelude mod && qual)
qual_prel (ImportDecl mod qual imp_as _ _)
= fromPrelude mod && qual && not (maybeToBool imp_as)
explicit_prelude_import
= null [() | (ImportDecl mod qual _ _ _) <- ok_imps,
fromPrelude mod && not qual]
= null [() | (ImportDecl mod qual _ _ _) <- ok_imps, fromPrelude mod]
qprel_imp = if opt_NoImplicitPrelude
then [{-the flag really means it: *NO* implicit "import Prelude" -}]
else [ImportDecl pRELUDE True Nothing Nothing mkIfaceSrcLoc]
else [ImportDecl pRELUDE True Nothing Nothing prel_loc]
prel_imp = if not explicit_prelude_import || opt_NoImplicitPrelude
then
[{- no "import Prelude" -}]
else
[ImportDecl pRELUDE False Nothing Nothing mkIfaceSrcLoc]
[ImportDecl pRELUDE False Nothing Nothing prel_loc]
prel_loc = mkBuiltinSrcLoc
(uniq_imps, imp_dups) = removeDups cmp_mod the_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)
`unionBags`
listToBag (map qualPreludeImportWarn src_qprels)
doImports iface_cache i_info us []
......@@ -399,13 +405,13 @@ doImport :: IfaceCache
-> ImportNameInfo
-> UniqSupply
-> RdrNameImportDecl
-> IO (Bag (RdrName,RnName), -- values
Bag (RdrName,RnName), -- tycons/classes
Bag (Module,RnName), -- unqual imports
-> IO (Bag (RdrName,RnName), -- values
Bag (RdrName,RnName), -- tycons/classes
Bag (Module,RnName), -- unqual imports
Bag RenamedFixityDecl,
Bag Error,
Bag Warning,
Bag (RnName,ExportFlag)) -- import flags
Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
= cachedIface iface_cache mod >>= \ maybe_iface ->
......@@ -440,9 +446,10 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
`unionBags` errs `unionBags` unionManyBags fix_errs
final_warns = mapBag (\ warn -> warn mod src_loc) (unionManyBags chk_warns)
`unionBags` warns
imp_stuff = mapBag (\ (n,imp) -> (n,(imp,unitBag src_loc))) imp_flags
in
return (final_vals, final_tcs, unquals, final_fixes,
final_errs, final_warns, imp_flags)
final_errs, final_warns, imp_stuff)
where
as_mod = case maybe_as of {Nothing -> mod; Just as_this -> as_this}
mk_occ str = if qual then Qual as_mod str else Unqual str
......@@ -452,6 +459,10 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
pair_as rn = (as_mod, rn)
getBuiltins _ 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)
......@@ -547,14 +558,14 @@ doOrigIEs iface_cache info mod src_loc us []
doOrigIEs iface_cache info mod src_loc us (ie:ies)
= doOrigIE iface_cache info mod src_loc us1 ie
>>= \ (vals1, tcs1, errs1, warns1, imps1) ->
>>= \ (vals1, tcs1, imps1, errs1, warns1) ->
doOrigIEs iface_cache info mod src_loc us2 ies
>>= \ (vals2, tcs2, errs2, warns2, imps2) ->
>>= \ (vals2, tcs2, imps2, errs2, warns2) ->
return (vals1 `unionBags` vals2,
tcs1 `unionBags` tcs2,
imps1 `unionBags` imps2,
errs1 `unionBags` errs2,
warns1 `unionBags` warns2,
imps1 `unionBags` imps2)
warns1 `unionBags` warns2)
where
(us1, us2) = splitUniqSupply us
......@@ -743,33 +754,35 @@ newImportedName tycon_or_class locn maybe_exp maybe_imp rdr
imp = case maybe_imp of
Just imp -> imp
Nothing -> imp_fn n
Nothing -> imp_flag
(imp_flag, imp_locs) = imp_fn n
n = mkImportedName uniq rdr imp locn exp (occ_fn n)
n = mkImportedName uniq rdr imp locn imp_locs exp (occ_fn n)
in
returnRn n
\end{code}
\begin{code}
globalDupNamesErr (rn1:dup_rns) sty
= ppAboves (item1 : map dup_item dup_rns)
globalDupNamesErr rdr rns sty
= ppAboves (message : map pp_dup rns)
where
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)"
message = ppBesides [ppStr "multiple declarations of `", pprNonSym sty rdr, ppStr "'"]
pp_dup rn = addShortErrLocLine (get_loc rn) (\ sty ->
ppBesides [pp_descrip rn, pprNonSym sty rn]) sty
get_loc rn = case getImpLocs rn of
[] -> getSrcLoc rn
locs -> head locs
pp_descrip (RnName _) = ppStr "a value"
pp_descrip (RnSyn _) = ppStr "a type synonym"
pp_descrip (RnData _ _ _) = ppStr "a data type"
pp_descrip (RnConstr _ _) = ppStr "a data constructor"
pp_descrip (RnField _ _) = ppStr "a record field"
pp_descrip (RnClass _ _) = ppStr "a class"
pp_descrip (RnClassOp _ _) = ppStr "a class method"
pp_descrip _ = ppNil
dupImportWarn (ImportDecl m1 _ _ _ locn1 : dup_imps) sty
......@@ -782,9 +795,9 @@ dupImportWarn (ImportDecl m1 _ _ _ locn1 : dup_imps) sty
= addShortErrLocLine locn (\ sty ->
ppCat [ppStr "here was another import from module", ppPStr m]) sty
qualPreludeImportErr (ImportDecl m _ _ _ locn)
qualPreludeImportWarn (ImportDecl m _ _ _ locn)
= addShortErrLocLine locn (\ sty ->
ppCat [ppStr "qualified import form prelude module", ppPStr m])
ppCat [ppStr "qualified import of prelude module", ppPStr m])
unknownImpSpecErr ie imp_mod locn
= addShortErrLocLine locn (\ sty ->
......
......@@ -135,7 +135,7 @@ rnExports mods unqual_imps (Just exps)
mod_fm = addListToFM_C unionBags emptyFM
[(mod, unitBag (getName rn, nameImportFlag (getName rn)))
| (mod,rn) <- bagToList unqual_imps]
| (mod,rn) <- bagToList unqual_imps, isRnDecl rn]
add_mod_names (exp_map, empty) mod
= case lookupFM mod_fm mod of
......@@ -586,8 +586,10 @@ rnPolyType tv_env (HsPreForAllTy ctxt ty)
= rn_poly_help tv_env forall_tyvars ctxt ty
where
mentioned_tyvars = extractCtxtTyNames ctxt `unionLists` extractMonoTyNames is_tyvar_name ty
forall_tyvars = --pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $
--pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $
forall_tyvars = {-
pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $
pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $
-}
mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
------------
......@@ -598,11 +600,13 @@ rn_poly_help :: TyVarNamesEnv
-> RnM_Fixes s RenamedPolyType
rn_poly_help tv_env tyvars ctxt ty
= --pprTrace "rnPolyType:" (ppCat [ppCat (map (ppr PprShowAll . snd) tv_env),
-- ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars),
-- ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt),
-- ppStr ";ty=", ppr PprShowAll ty]
-- ) $
= {-
pprTrace "rnPolyType:"
(ppCat [ppCat (map (ppr PprShowAll . snd) tv_env),
ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars),
ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt),
ppStr ";ty=", ppr PprShowAll ty]) $
-}
getSrcLocRn `thenRn` \ src_loc ->
mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) ->
let
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment