%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[Rename-three]{Third of the renaming passes}
+\section[RnPass3]{Third of the renaming passes}
The business of this pass is to:
\begin{itemize}
\begin{code}
#include "HsVersions.h"
-module Rename3 (
+module RnPass3 (
rnModule3,
- initRn3, Rn3M(..), -- re-exported from monad
+ initRn3, Rn3M(..) -- re-exported from monad
-- for completeness
- Module, Bag, ProtoNamePat(..), InPat, Maybe, Name,
- ExportFlag, PprStyle, Pretty(..), PrettyRep, ProtoName,
- PreludeNameFun(..), PreludeNameFuns(..), SplitUniqSupply
) where
-import AbsSyn
-import Bag -- lots of stuff
-import Errors ( dupNamesErr, dupPreludeNameErr,
- badExportNameErr, badImportNameErr,
- Error(..)
+import Ubiq{-uitous-}
+
+import RnMonad3
+import HsSyn
+import RdrHsSyn
+
+import Bag ( emptyBag, listToBag, unionBags, unionManyBags,
+ unitBag, snocBag, elemBag, bagToList, Bag
)
-import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
-import FiniteMap
-import Maybes ( Maybe(..) )
+import ErrUtils
+import HsPragmas ( DataPragmas(..) )
import Name ( Name(..) )
-import NameTypes ( fromPrelude, FullName )
-import ProtoName
-import RenameAuxFuns ( mkGlobalNameFun,
- GlobalNameFuns(..), GlobalNameFun(..),
- PreludeNameFuns(..), PreludeNameFun(..)
+import NameTypes ( fromPrelude, FullName{-instances-} )
+import Pretty
+import ProtoName ( cmpByLocalName, ProtoName(..) )
+import RnUtils ( mkGlobalNameFun,
+ GlobalNameMappers(..), GlobalNameMapper(..),
+ PreludeNameMappers(..), PreludeNameMapper(..),
+ dupNamesErr
)
-import RenameMonad3
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import Util
+import SrcLoc ( SrcLoc{-instance-} )
+import Util ( isIn, removeDups, cmpPString, panic )
\end{code}
*********************************************************
*********************************************************
\begin{code}
-rnModule3 :: PreludeNameFuns
- -> [FAST_STRING] -- list of imported module names
- -> ProtoNameModule
+rnModule3 :: PreludeNameMappers
+ -> Bag FAST_STRING -- list of imported module names
+ -> ProtoNameHsModule
-> Rn3M ( NameSpaceAssoc, NameSpaceAssoc,
- GlobalNameFun, GlobalNameFun,
+ GlobalNameMapper, GlobalNameMapper,
Bag Error )
rnModule3 pnfs@(val_pnf, tc_pnf) imported_mod_names
- (Module mod_name exports imports _ ty_decls _ class_decls
+ (HsModule mod_name exports imports _ ty_decls _ class_decls
inst_decls _ _ binds sigs _)
= putInfoDownM3 {- ???pnfs -} mod_name exports (
tc_gnf = mkGlobalNameFun mod_name tc_pnf tc_alist
in
- verifyExports v_gnf tc_gnf (mod_name : imported_mod_names) exports
+ verifyExports v_gnf tc_gnf (imported_mod_names `snocBag` mod_name) exports
`thenRn3` \ export_errs ->
verifyImports v_gnf tc_gnf imports `thenRn3` \ import_errs ->
export_errs `unionBags` import_errs
))
where
- deal_with_dups :: String -> PreludeNameFun -> NameSpaceAssoc
+ deal_with_dups :: String -> PreludeNameMapper -> NameSpaceAssoc
-> (NameSpaceAssoc, Bag Error)
deal_with_dups kind_str pnf alist
= (goodies,
listToBag (map mk_dup_err dup_lists) `unionBags`
- listToBag (map mk_prel_dup_err prel_dups)
+ listToBag (map mk_prel_dup_err prel_dups)
)
where
goodies :: [(ProtoName,Name)] --NameSpaceAssoc
(goodies, prel_dups) = if fromPrelude mod_name then
(singles, []) -- Compiling the prelude, so ignore this check
- else
+ else
partition local_def_of_prelude_thing singles
local_def_of_prelude_thing (Unk s, _)
- = case pnf s of
+ = case pnf s of
Just _ -> False -- Eek! It's a prelude name
Nothing -> True -- It isn't; all is ok
local_def_of_prelude_thing other = True
combiner (cons1, tycons1) (cons2, tycons2)
= (cons1 `unionBags` cons2, tycons1 `unionBags` tycons2)
- do_decl (TyData context tycon tyvars condecls deriv pragmas src_loc)
+ do_decl (TyData context tycon tyvars condecls _ pragmas src_loc)
= newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing
`thenRn3` \ (uniq, tycon_name) ->
let
doConDecls3 False{-not invisibles-} exp_flag condecls `thenRn3` \ data_cons ->
do_data_pragmas exp_flag pragmas `thenRn3` \ pragma_data_cons ->
returnRn3 (data_cons `unionBags` pragma_data_cons,
- unitBag (tycon, OtherTyCon uniq tycon_name (length tyvars)
- True -- indicates @data@ tycon
+ unitBag (tycon, TyConName uniq tycon_name (length tyvars)
+ True -- indicates data/newtype tycon
[ c | (_,c) <- bagToList data_cons ]))
-
- do_decl (TySynonym tycon tyvars monoty pragmas src_loc)
+ do_decl (TyNew context tycon tyvars condecl _ pragmas src_loc)
+ = newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing
+ `thenRn3` \ (uniq, tycon_name) ->
+ let
+ exp_flag = getExportFlag tycon_name
+ -- we want to force all data cons to have the very
+ -- same export flag as their type constructor
+ in
+ doConDecls3 False{-not invisibles-} exp_flag condecl `thenRn3` \ data_con ->
+ do_data_pragmas exp_flag pragmas `thenRn3` \ pragma_data_con ->
+ returnRn3 (data_con `unionBags` pragma_data_con,
+ unitBag (tycon, TyConName uniq tycon_name (length tyvars)
+ True -- indicates data/newtype tycon
+ [ c | (_,c) <- bagToList data_con ]))
+
+ do_decl (TySynonym tycon tyvars monoty src_loc)
= newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing
`thenRn3` \ (uniq, tycon_name) ->
returnRn3 (emptyBag,
- unitBag (tycon, OtherTyCon uniq tycon_name (length tyvars) False bottom))
- -- False indicates @type@ tycon
+ unitBag (tycon, TyConName uniq tycon_name (length tyvars) False bottom))
+ -- Flase indicates type tycon
where
bottom = panic "do_decl: data cons on synonym?"
do_decl (ConDecl con tys src_loc)
= mk_name con src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
- returnRn3 (unitBag (con, OtherTopId uniq con_name))
+ returnRn3 (unitBag (con, ValName uniq con_name))
+ do_decl (ConOpDecl ty1 op ty2 src_loc)
+ = mk_name op src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
+ returnRn3 (unitBag (op, ValName uniq con_name))
+ do_decl (NewConDecl con ty src_loc)
+ = mk_name con src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
+ returnRn3 (unitBag (con, ValName uniq con_name))
+ do_decl (RecConDecl con fields src_loc)
+ = _trace "doConDecls3:RecConDecl:nothing for fields\n" $
+ mk_name con src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
+ returnRn3 (unitBag (con, ValName uniq con_name))
\end{code}
`thenRn3` \ (uniq, class_name) ->
fixRn3 ( \ ~(clas_ops,_) ->
let
- class_Name = OtherClass uniq class_name
+ class_Name = ClassName uniq class_name
[ o | (_,o) <- bagToList clas_ops ]
in
doClassOps3 class_Name 1 sigs `thenRn3` \ (_, ops) ->
doClassOps3 clas tag1 rest `thenRn3` \ (tagr, bagr) ->
returnRn3 (tagr, bag1 `unionBags` bagr)
where
+{- LATER: NB: OtherVal is a Name, not a ProtoName
+ do_op (ClassOpSig op@(OtherVal uniq name) ty pragma src_loc)
+ = -- A classop whose unique is pre-ordained, so the type checker
+ -- can look it up easily
+ let
+ op_name = ClassOpName uniq clas (snd (getOrigName name)) tag
+ in
+ returnRn3 (tag+1, unitBag (op, op_name))
+-}
+
do_op (ClassOpSig op ty pragma src_loc)
= newFullNameM3 op src_loc False{-not tyconish-} Nothing `thenRn3` \ (uniq, _) ->
let
in
returnRn3 (tag+1, unitBag (op, op_name))
where
- -- A rather yukky function to get the original name out of a class operation.
+ -- A rather yukky function to get the original name out of a
+ -- class operation. The "snd (getOrigName ...)" in the other
+ -- ClassOpSig case does the corresponding yukky thing.
get_str :: ProtoName -> FAST_STRING
get_str (Unk s) = s
+ get_str (Qunk _ s) = s
get_str (Imp _ d _ _) = d
\end{code}
do_sig (Sig v ty pragma src_loc)
= newFullNameM3 v src_loc False{-distinctly untycon-ish-} Nothing
`thenRn3` \ (uniq, v_fname) ->
- returnRn3 (unitBag (v, OtherTopId uniq v_fname))
+ returnRn3 (unitBag (v, ValName uniq v_fname))
\end{code}
*********************************************************
*********************************************************
\begin{code}
-doBinds3 :: ProtoNameBinds -> Rn3M BagAssoc
+doBinds3 :: ProtoNameHsBinds -> Rn3M BagAssoc
doBinds3 EmptyBinds = returnRn3 emptyBag
doPat3 locn (VarPatIn n) = doTopLevName locn n
doPat3 locn (ListPatIn pats) = doPats3 locn pats
doPat3 locn (TuplePatIn pats) = doPats3 locn pats
-doPat3 locn (NPlusKPatIn n _) = doTopLevName locn n
doPat3 locn (AsPatIn p_name pat)
= andRn3 unionBags (doTopLevName locn p_name) (doPat3 locn pat)
doPat3 locn (ConOpPatIn pat1 name pat2)
= andRn3 unionBags (doPat3 locn pat1) (doPat3 locn pat2)
-
-#ifdef DPH
-doPat3 locn (ProcessorPatIn pats pat)
- = andRn3 unionBags (doPats3 locn pats) (doPat3 locn pat)
-#endif {- Data Parallel Haskell -}
\end{code}
\begin{code}
doTopLevName locn pn
= newFullNameM3 pn locn False{-un-tycon-ish-} Nothing `thenRn3` \ (uniq, name) ->
- returnRn3 (unitBag (pn, OtherTopId uniq name))
+ returnRn3 (unitBag (pn, ValName uniq name))
\end{code}
Have to check that export/imports lists aren't too drug-crazed.
\begin{code}
-verifyExports :: GlobalNameFun -> GlobalNameFun
- -> [FAST_STRING] -- module names that might appear
- -- in an export list; includes the
- -- name of this module
- -> [IE] -- export list
+verifyExports :: GlobalNameMapper -> GlobalNameMapper
+ -> Bag FAST_STRING -- module names that might appear
+ -- in an export list; includes the
+ -- name of this module
+ -> Maybe [IE ProtoName] -- export list
-> Rn3M (Bag Error)
-verifyExports v_gnf tc_gnf imported_mod_names exports
+verifyExports _ _ _ Nothing{-no export list-} = returnRn3 emptyBag
+
+verifyExports v_gnf tc_gnf imported_mod_names export_list@(Just exports)
= mapRn3 verify exports `thenRn3` \ errs ->
- chk_exp_dups exports `thenRn3` \ dup_errs ->
+ chk_exp_dups export_list `thenRn3` \ dup_errs ->
returnRn3 (unionManyBags (errs ++ dup_errs))
where
- present nf str = nf (Unk str)
-
ok = returnRn3 emptyBag
naughty nm msg = returnRn3 (unitBag (badExportNameErr (_UNPK_ nm) msg))
undef_name nm = naughty nm "is not defined."
dup_name (nm:_)= naughty nm "occurs more than once."
+ undef_name :: FAST_STRING -> Rn3M (Bag Error)
+ dup_name :: [FAST_STRING] -> Rn3M (Bag Error)
+
----------------
+ chk_exp_dups :: Maybe [IE ProtoName] -> Rn3M [Bag Error]
+
chk_exp_dups exports
= let
- export_strs = [ nm | (nm, _) <- fst (getRawIEStrings exports) ]
- (_, dup_lists) = removeDups _CMP_STRING_ export_strs
+ export_strs = [ nm | (nm, _) <- fst (getRawExportees exports) ]
+ (_, dup_lists) = removeDups cmpByLocalName{-????-} export_strs
in
- mapRn3 dup_name dup_lists
+ mapRn3 dup_name [map getOccurrenceName dl | dl <- dup_lists]
---------------- the more serious checking
+ verify :: IE ProtoName -> Rn3M (Bag Error)
+
verify (IEVar v)
- = case (present v_gnf v) of { Nothing -> undef_name v; _ -> ok }
+ = case (v_gnf v) of { Nothing -> undef_name (getOccurrenceName v); _ -> ok }
verify (IEModuleContents mod)
- = if not (mod `is_elem` imported_mod_names) then undef_name mod else ok
- where
- is_elem = isIn "verifyExports"
-
- verify (IEThingAbs tc)
- = case (present tc_gnf tc) of
- Nothing -> undef_name tc
- Just nm -> case nm of
- PreludeTyCon _ _ _ False{-syn-}
- -> naughty tc "must be exported with a `(..)' -- it's a Prelude synonym."
- OtherTyCon _ _ _ False{-syn-} _
- -> naughty tc "must be exported with a `(..)' -- it's a synonym."
-
- PreludeClass _ _
- -> naughty tc "cannot be exported \"abstractly\" (it's a Prelude class)."
- OtherClass _ _ _
- -> naughty tc "cannot be exported \"abstractly\" (it's a class)."
+ = if not (mod `elemBag` imported_mod_names) then undef_name mod else ok
+
+ verify (IEThingAbs tc)
+ = case (tc_gnf tc) of
+ Nothing -> undef_name (getOccurrenceName tc)
+ Just nm -> let
+ naughty_tc = naughty (getOccurrenceName tc)
+ in
+ case nm of
+ TyConName _ _ _ False{-syn-} _
+ -> naughty_tc "must be exported with a `(..)' -- it's a synonym."
+
+ ClassName _ _ _
+ -> naughty_tc "cannot be exported \"abstractly\" (it's a class)."
_ -> ok
verify (IEThingAll tc)
- = case (present tc_gnf tc) of
- Nothing -> undef_name tc
- Just nm -> case nm of
- OtherTyCon _ _ _ True{-data-} [{-no cons-}]
- -> naughty tc "can't be exported with a `(..)' -- it was imported abstractly."
+ = case (tc_gnf tc) of
+ Nothing -> undef_name (getOccurrenceName tc)
+ Just nm -> let
+ naughty_tc = naughty (getOccurrenceName tc)
+ in
+ case nm of
+ TyConName _ _ _ True{-data or newtype-} [{-no cons-}]
+ -> naughty_tc "can't be exported with a `(..)' -- it was imported abstractly."
_ -> ok
+{- OLD:
verify (IEConWithCons tc cs)
- = case (present tc_gnf tc) of
+ = case (tc_gnf tc) of
Nothing -> undef_name tc
Just nm -> mapRn3 verify (map IEVar cs) `thenRn3` \ errs ->
returnRn3 (unionManyBags errs)
-- ToDo: turgid checking which we don't care about (WDP 94/10)
verify (IEClsWithOps c ms)
- = case (present tc_gnf c) of
+ = case (tc_gnf c) of
Nothing -> undef_name c
Just _ -> mapRn3 verify (map IEVar ms) `thenRn3` \ errs ->
returnRn3 (unionManyBags errs)
-- ToDo: turgid checking which we don't care about (WDP 94/10)
+-}
\end{code}
Note: we're not too particular about whether something mentioned in an
import list is in {\em that} interface... (ToDo? Probably not.)
\begin{code}
-verifyImports :: GlobalNameFun -> GlobalNameFun
+verifyImports :: GlobalNameMapper -> GlobalNameMapper
-> [ProtoNameImportedInterface]
-> Rn3M (Bag Error)
= mapRn3 chk_one (map collect imports) `thenRn3` \ errs ->
returnRn3 (unionManyBags errs)
where
- -- collect: name/locn, import list, renamings list
+ -- collect: name/locn, import list
- collect (ImportAll iff renamings)
- = (iface iff, [], [], renamings)
- collect (ImportSome iff imp_list renamings)
- = (iface iff, imp_list, [], renamings)
- collect (ImportButHide iff hide_list renamings)
- = (iface iff, [], hide_list, renamings)
+ collect (ImportMod iff qual asmod details)
+ = (iface iff, imp_list, hide_list)
+ where
+ (imp_list, hide_list)
+ = case details of
+ Nothing -> ([], [])
+ Just (True{-hidden-}, ies) -> ([], ies)
+ Just (_ {-unhidden-}, ies) -> (ies, [])
------------
- iface (MkInterface name _ _ _ _ _ _ locn) = (name, locn)
+ iface (Interface name _ _ _ _ _ _ locn) = (name, locn)
------------
- chk_one :: ((FAST_STRING, SrcLoc), [IE], [IE], [Renaming])
+ chk_one :: ((FAST_STRING, SrcLoc), [IE ProtoName], [IE ProtoName])
-> Rn3M (Bag Error)
- chk_one ((mod_name, locn), import_list, hide_list, renamings)
+ chk_one ((mod_name, locn), import_list, hide_list)
= mapRn3 verify import_list `thenRn3` \ errs1 ->
chk_imp_dups import_list `thenRn3` \ dup_errs ->
-- ToDo: we could check the hiding list more carefully
chk_imp_dups hide_list `thenRn3` \ dup_errs2 ->
- mapRn3 chk_rn renamings `thenRn3` \ errs2 ->
- returnRn3 (unionManyBags (errs1 ++ dup_errs ++ dup_errs2 ++ errs2))
+ returnRn3 (unionManyBags (errs1 ++ dup_errs ++ dup_errs2))
where
- present nf str = nf (Unk (rename_it str))
-
- rename_it str
- = case [ too | (MkRenaming from too) <- renamings, str == from ] of
- [] -> str
- (x:_) -> x
-
ok = returnRn3 emptyBag
naughty nm msg = returnRn3 (unitBag (badImportNameErr (_UNPK_ mod_name) (_UNPK_ nm) msg locn))
undef_name nm = naughty nm "is not defined."
- undef_rn_name n r = naughty n ("is not defined (renamed to `"++ _UNPK_ r ++"').")
dup_name (nm:_) = naughty nm "occurs more than once."
+ undef_name :: FAST_STRING -> Rn3M (Bag Error)
+ dup_name :: [FAST_STRING] -> Rn3M (Bag Error)
+
----------------
chk_imp_dups imports
= let
- import_strs = [ nm | (nm, _) <- fst (getRawIEStrings imports) ]
+ import_strs = getRawImportees imports
(_, dup_lists) = removeDups _CMP_STRING_ import_strs
in
mapRn3 dup_name dup_lists
----------------
- chk_rn (MkRenaming from too) -- Note: "present" will rename
- = case (present v_gnf from) of -- the "from" to the "too"...
- Just _ -> ok
- Nothing -> case (present tc_gnf from) of
- Just _ -> ok
- Nothing -> undef_rn_name from too
+ verify :: IE ProtoName -> Rn3M (Bag Error)
- ----------------
verify (IEVar v)
- = case (present v_gnf v) of { Nothing -> undef_name v; _ -> ok }
-
- verify (IEThingAbs tc)
- = case (present tc_gnf tc) of
- Nothing -> undef_name tc
- Just nm -> case nm of
- PreludeTyCon _ _ _ False{-syn-}
- -> naughty tc "must be imported with a `(..)' -- it's a Prelude synonym."
- OtherTyCon _ _ _ False{-syn-} _
- -> naughty tc "must be imported with a `(..)' -- it's a synonym."
- PreludeClass _ _
- -> naughty tc "cannot be imported \"abstractly\" (it's a Prelude class)."
- OtherClass _ _ _
- -> naughty tc "cannot be imported \"abstractly\" (it's a class)."
+ = case (v_gnf v) of { Nothing -> undef_name (getOccurrenceName v); _ -> ok }
+
+ verify (IEThingAbs tc)
+ = case (tc_gnf tc) of
+ Nothing -> undef_name (getOccurrenceName tc)
+ Just nm -> let
+ naughty_tc = naughty (getOccurrenceName tc)
+ in
+ case nm of
+ TyConName _ _ _ False{-syn-} _
+ -> naughty_tc "must be imported with a `(..)' -- it's a synonym."
+ ClassName _ _ _
+ -> naughty_tc "cannot be imported \"abstractly\" (it's a class)."
_ -> ok
verify (IEThingAll tc)
- = case (present tc_gnf tc) of
- Nothing -> undef_name tc
- Just nm -> case nm of
- OtherTyCon _ _ _ True{-data-} [{-no cons-}]
- -> naughty tc "can't be imported with a `(..)' -- the interface says it's abstract."
+ = case (tc_gnf tc) of
+ Nothing -> undef_name (getOccurrenceName tc)
+ Just nm -> let
+ naughty_tc = naughty (getOccurrenceName tc)
+ in
+ case nm of
+ TyConName _ _ _ True{-data or newtype-} [{-no cons-}]
+ -> naughty_tc "can't be imported with a `(..)' -- the interface says it's abstract."
_ -> ok
+{- OLD:
verify (IEConWithCons tc cs)
- = case (present tc_gnf tc) of
- Nothing -> undef_name tc
+ = case (tc_gnf tc) of
+ Nothing -> undef_name (getOccurrenceName tc)
Just nm -> mapRn3 verify (map IEVar cs) `thenRn3` \ errs ->
returnRn3 (unionManyBags errs)
-- One could add a great wad of tedious checking
-- here, but I am too lazy to do so. WDP 94/10
verify (IEClsWithOps c ms)
- = case (present tc_gnf c) of
- Nothing -> undef_name c
+ = case (tc_gnf c) of
+ Nothing -> undef_name (getOccurrenceName c)
Just _ -> mapRn3 verify (map IEVar ms) `thenRn3` \ errs ->
returnRn3 (unionManyBags errs)
-- Ditto about tedious checking. WDP 94/10
+-}
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Error messages}
+%* *
+%************************************************************************
+
+\begin{code}
+badExportNameErr name whats_wrong
+ = dontAddErrLoc
+ "Error in the export list" ( \ sty ->
+ ppBesides [ppChar '`', ppStr name, ppStr "' ", ppStr whats_wrong] )
+
+------------------------------------------
+badImportNameErr mod name whats_wrong locn
+ = addErrLoc locn
+ ("Error in an import list for the module `"++mod++"'") ( \ sty ->
+ ppBesides [ppChar '`', ppStr name, ppStr "' ", ppStr whats_wrong] )
+
+----------------------------
+-- dupNamesErr: from RnUtils
+
+--------------------------------------
+dupPreludeNameErr descriptor (nm, locn)
+ = addShortErrLocLine locn ( \ sty ->
+ ppBesides [ ppStr "A conflict with a Prelude ", ppStr descriptor,
+ ppStr ": ", ppr sty nm ])
\end{code}
projects / ghc-hetmet.git / blobdiff