diff options
Diffstat (limited to 'ghc/compiler/rename')
25 files changed, 1798 insertions, 2046 deletions
diff --git a/ghc/compiler/rename/Rename.hi b/ghc/compiler/rename/Rename.hi deleted file mode 100644 index 5529665937..0000000000 --- a/ghc/compiler/rename/Rename.hi +++ /dev/null @@ -1,43 +0,0 @@ -{-# GHC_PRAGMA INTERFACE VERSION 5 #-} -interface Rename where -import AbsSyn(Module) -import Bag(Bag) -import CmdLineOpts(GlobalSwitch) -import ErrUtils(Error(..)) -import HsBinds(Binds, Sig) -import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl) -import HsImpExp(IE, ImportedInterface) -import HsLit(Literal) -import HsPat(InPat, ProtoNamePat(..), RenamedPat(..)) -import Id(Id) -import Maybes(Labda) -import Name(Name) -import NameTypes(FullName, ShortName) -import PreludePS(_PackedString) -import Pretty(PprStyle, Pretty(..), PrettyRep) -import ProtoName(ProtoName) -import RenameAuxFuns(GlobalNameFun(..), GlobalNameFuns(..), PreludeNameFun(..), PreludeNameFuns(..)) -import SplitUniq(SplitUniqSupply) -import SrcLoc(SrcLoc) -import TyCon(TyCon) -import Unique(Unique) -data Module a b -data Bag a -data GlobalSwitch -type Error = PprStyle -> Int -> Bool -> PrettyRep -data InPat a -type ProtoNamePat = InPat ProtoName -type RenamedPat = InPat Name -data Labda a -data Name -data PprStyle -type Pretty = Int -> Bool -> PrettyRep -data PrettyRep -data ProtoName -type GlobalNameFun = ProtoName -> Labda Name -type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name) -type PreludeNameFun = _PackedString -> Labda Name -type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name) -data SplitUniqSupply -renameModule :: (GlobalSwitch -> Bool) -> (_PackedString -> Labda Name, _PackedString -> Labda Name) -> Module ProtoName (InPat ProtoName) -> SplitUniqSupply -> (Module Name (InPat Name), [_PackedString], (ProtoName -> Labda Name, ProtoName -> Labda Name), Bag (PprStyle -> Int -> Bool -> PrettyRep)) - diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index a2900c7671..3b7cdf2c86 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -1,39 +1,37 @@ % -% (c) The GRASP Project, Glasgow University, 1992-1994 +% (c) The GRASP Project, Glasgow University, 1992-1996 % \section[Rename]{Renaming and dependency analysis passes} \begin{code} #include "HsVersions.h" -module Rename ( - renameModule, - - -- for completeness - Module, Bag, InPat, ProtoNamePat(..), RenamedPat(..), Name, - ProtoName, SplitUniqSupply, PreludeNameFun(..), - PreludeNameFuns(..), Maybe, Error(..), Pretty(..), PprStyle, - PrettyRep, GlobalNameFuns(..), GlobalNameFun(..), - GlobalSwitch - ) where - -import AbsSyn -import Bag ( isEmptyBag, unionBags, Bag ) -import CmdLineOpts ( GlobalSwitch(..) ) -import RenameMonad12 -import Rename1 -import Rename2 -import Rename3 -import Rename4 -import RenameAuxFuns ( PreludeNameFuns(..), GlobalNameFuns(..) ) ---import Pretty -- ToDo: rm debugging -import SplitUniq ( splitUniqSupply, SplitUniqSupply ) -import Util +module Rename ( renameModule ) where + +import Ubiq{-uitous-} + +import HsSyn +import RdrHsSyn ( ProtoNameHsModule(..) ) +import RnHsSyn ( RenamedHsModule(..) ) + +import Bag ( isEmptyBag, unionBags ) +import CmdLineOpts ( opt_UseGetMentionedVars ) +import ErrUtils ( Error(..) ) +import Pretty ( Pretty(..){-ToDo:rm?-} ) +import RnMonad12 ( initRn12 ) +import RnMonad4 ( initRn4 ) +import RnPass1 +import RnPass2 +import RnPass3 +import RnPass4 +import RnUtils ( PreludeNameMappers(..), GlobalNameMappers(..) ) +import UniqSupply ( splitUniqSupply ) +import Util ( panic ) \end{code} Here's what the renamer does, basically: \begin{description} -\item[@Rename1@:] +\item[@RnPass1@:] Flattens out the declarations from the interfaces which this module imports. The result is a new module with no imports, but with more declarations. (Obviously, the imported declarations have ``funny @@ -41,7 +39,7 @@ names'' [@ProtoNames@] to indicate their origin.) Handles selective import, renaming, \& such. %-------------------------------------------------------------------- -\item[@Rename2@:] +\item[@RnPass2@:] Removes duplicate declarations. Duplicates can arise when two imported interface have a signature (or whatever) for the same thing. We check that the two are consistent and then drop one. @@ -49,13 +47,13 @@ Considerable huff and puff to pick the one with the ``better'' pragmatic information. %-------------------------------------------------------------------- -\item[@Rename3@:] +\item[@RnPass3@:] Find all the top-level-ish (i.e., global) entities, assign them @Uniques@, and make a \tr{ProtoName -> Name} mapping for them, in preparation for... %-------------------------------------------------------------------- -\item[@Rename4@:] +\item[@RnPass4@:] Actually prepare the ``renamed'' module. In sticking @Names@ on everything, it will catch out-of-scope errors (and a couple of similar type-variable-use errors). We also our initial dependency analysis of @@ -63,14 +61,13 @@ the program (required before typechecking). \end{description} \begin{code} -renameModule :: (GlobalSwitch -> Bool) -- to check cmd-line opts - -> PreludeNameFuns -- lookup funs for deeply wired-in names - -> ProtoNameModule -- input - -> SplitUniqSupply - -> (RenamedModule, -- output, after renaming - [FAST_STRING], -- Names of the imported modules +renameModule :: PreludeNameMappers -- lookup funs for deeply wired-in names + -> ProtoNameHsModule -- input + -> UniqSupply + -> (RenamedHsModule, -- output, after renaming + Bag FAST_STRING, -- Names of the imported modules -- (profiling needs to know this) - GlobalNameFuns, -- final name funs; used later + GlobalNameMappers, -- final name funs; used later -- to rename generated `deriving' -- bindings. Bag Error -- Errors, from passes 1-4 @@ -78,33 +75,21 @@ renameModule :: (GlobalSwitch -> Bool) -- to check cmd-line opts -- Very space-leak sensitive -renameModule sw_chkr gnfs@(val_pnf, tc_pnf) - input@(Module mod_name _ _ _ _ _ _ _ _ _ _ _ _) +renameModule gnfs@(val_pnf, tc_pnf) + input@(HsModule mod_name _ _ _ _ _ _ _ _ _ _ _ _) uniqs = let - use_mentioned_vars = sw_chkr UseGetMentionedVars + use_mentioned_vars = opt_UseGetMentionedVars in - BIND ( - BSCC("Rename1") - initRn12 mod_name (rnModule1 gnfs use_mentioned_vars input) - ESCC - ) _TO_ ((mod1, imported_module_names), errs1) -> + case (initRn12 mod_name (rnModule1 gnfs use_mentioned_vars input)) + of { ((mod1, imported_module_names), errs1) -> - BIND ( - BSCC("Rename2") - initRn12 mod_name (rnModule2 mod1) - ESCC - ) _TO_ (mod2, errs2) -> + case (initRn12 mod_name (rnModule2 mod1)) of { (mod2, errs2) -> --- pprTrace "rename2:" (ppr PprDebug mod2) ( + case (splitUniqSupply uniqs) of { (us1, us2) -> - BIND (splitUniqSupply uniqs) _TO_ (us1, us2) -> - - BIND ( - BSCC("Rename3") - initRn3 (rnModule3 gnfs imported_module_names mod2) us1 - ESCC - ) _TO_ (val_space, tc_space, v_gnf, tc_gnf, errs3) -> + case (initRn3 (rnModule3 gnfs imported_module_names mod2) us1) + of { (val_space, tc_space, v_gnf, tc_gnf, errs3) -> let final_name_funs = (v_gnf, tc_gnf) @@ -115,19 +100,11 @@ renameModule sw_chkr gnfs@(val_pnf, tc_pnf) if not (isEmptyBag errs_so_far) then -- give up now ( panic "rename", imported_module_names, final_name_funs, errs_so_far ) else - BIND ( - BSCC("Rename4") - initRn4 sw_chkr final_name_funs (rnModule4 mod2) us2 - ESCC - ) _TO_ (mod4, errs4) -> - - ( mod4, imported_module_names, final_name_funs, errs4 ) - BEND - BEND --- ) - BEND - BEND - BEND + case (initRn4 final_name_funs (rnModule mod2) us2) + of { (mod4, errs4) -> + + ( mod4, imported_module_names, final_name_funs, errs4 ) } + }}}} \end{code} Why stop if errors in the first three passes: Suppose you're compiling @@ -142,4 +119,4 @@ panic. Another way to handle this would be for the duplicate detector to clobber duplicates with some ``safe'' value. Then things would be -fine in \tr{rnModule4}. Maybe some other time... +fine in \tr{rnModule}. Maybe some other time... diff --git a/ghc/compiler/rename/Rename1.hi b/ghc/compiler/rename/Rename1.hi deleted file mode 100644 index 808dd8b1c6..0000000000 --- a/ghc/compiler/rename/Rename1.hi +++ /dev/null @@ -1,36 +0,0 @@ -{-# GHC_PRAGMA INTERFACE VERSION 5 #-} -interface Rename1 where -import AbsSyn(Module) -import Bag(Bag) -import CharSeq(CSeq) -import CmdLineOpts(GlobalSwitch) -import HsBinds(Binds, Sig) -import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl) -import HsImpExp(IE, ImportedInterface) -import HsLit(Literal) -import HsPat(InPat, ProtoNamePat(..)) -import Id(Id) -import Maybes(Labda) -import Name(Name) -import NameTypes(FullName, ShortName) -import PreludePS(_PackedString) -import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) -import ProtoName(ProtoName) -import RenameAuxFuns(PreludeNameFun(..), PreludeNameFuns(..)) -import SrcLoc(SrcLoc) -import TyCon(TyCon) -import Unique(Unique) -data Module a b -data Bag a -data InPat a -type ProtoNamePat = InPat ProtoName -data Labda a -data Name -data PprStyle -type Pretty = Int -> Bool -> PrettyRep -data PrettyRep -data ProtoName -type PreludeNameFun = _PackedString -> Labda Name -type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name) -rnModule1 :: (_PackedString -> Labda Name, _PackedString -> Labda Name) -> Bool -> Module ProtoName (InPat ProtoName) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ((Module ProtoName (InPat ProtoName), [_PackedString]), Bag (PprStyle -> Int -> Bool -> PrettyRep)) - diff --git a/ghc/compiler/rename/Rename2.hi b/ghc/compiler/rename/Rename2.hi deleted file mode 100644 index 68f4a63cf3..0000000000 --- a/ghc/compiler/rename/Rename2.hi +++ /dev/null @@ -1,26 +0,0 @@ -{-# GHC_PRAGMA INTERFACE VERSION 5 #-} -interface Rename2 where -import AbsSyn(Module) -import Bag(Bag) -import CharSeq(CSeq) -import CmdLineOpts(GlobalSwitch) -import HsBinds(Binds, Sig) -import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl) -import HsImpExp(IE, ImportedInterface) -import HsLit(Literal) -import HsPat(InPat, ProtoNamePat(..)) -import Name(Name) -import PreludePS(_PackedString) -import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) -import ProtoName(ProtoName) -import SrcLoc(SrcLoc) -data Module a b -data Bag a -data InPat a -type ProtoNamePat = InPat ProtoName -data PprStyle -type Pretty = Int -> Bool -> PrettyRep -data PrettyRep -data ProtoName -rnModule2 :: Module ProtoName (InPat ProtoName) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (Module ProtoName (InPat ProtoName), Bag (PprStyle -> Int -> Bool -> PrettyRep)) - diff --git a/ghc/compiler/rename/Rename3.hi b/ghc/compiler/rename/Rename3.hi deleted file mode 100644 index 484bf85563..0000000000 --- a/ghc/compiler/rename/Rename3.hi +++ /dev/null @@ -1,42 +0,0 @@ -{-# GHC_PRAGMA INTERFACE VERSION 5 #-} -interface Rename3 where -import AbsSyn(Module) -import Bag(Bag) -import FiniteMap(FiniteMap) -import HsBinds(Binds, Sig) -import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl) -import HsImpExp(IE, ImportedInterface) -import HsLit(Literal) -import HsPat(InPat, ProtoNamePat(..)) -import Id(Id) -import Maybes(Labda) -import Name(Name) -import NameTypes(FullName, ShortName) -import Outputable(ExportFlag) -import PreludePS(_PackedString) -import Pretty(PprStyle, Pretty(..), PrettyRep) -import ProtoName(ProtoName) -import RenameAuxFuns(PreludeNameFun(..), PreludeNameFuns(..)) -import RenameMonad3(Rn3M(..), initRn3) -import SplitUniq(SplitUniqSupply) -import SrcLoc(SrcLoc) -import TyCon(TyCon) -import Unique(Unique) -data Module a b -data Bag a -data InPat a -type ProtoNamePat = InPat ProtoName -data Labda a -data Name -data ExportFlag -data PprStyle -type Pretty = Int -> Bool -> PrettyRep -data PrettyRep -data ProtoName -type PreludeNameFun = _PackedString -> Labda Name -type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name) -type Rn3M a = (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a -data SplitUniqSupply -initRn3 :: ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> SplitUniqSupply -> a -rnModule3 :: (_PackedString -> Labda Name, _PackedString -> Labda Name) -> [_PackedString] -> Module ProtoName (InPat ProtoName) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> ([(ProtoName, Name)], [(ProtoName, Name)], ProtoName -> Labda Name, ProtoName -> Labda Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) - diff --git a/ghc/compiler/rename/Rename4.hi b/ghc/compiler/rename/Rename4.hi deleted file mode 100644 index 2e48e8a576..0000000000 --- a/ghc/compiler/rename/Rename4.hi +++ /dev/null @@ -1,51 +0,0 @@ -{-# GHC_PRAGMA INTERFACE VERSION 5 #-} -interface Rename4 where -import AbsSyn(Module) -import Bag(Bag) -import CharSeq(CSeq) -import CmdLineOpts(GlobalSwitch) -import ErrUtils(Error(..)) -import FiniteMap(FiniteMap) -import HsBinds(Binds, Sig) -import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl) -import HsImpExp(IE, ImportedInterface) -import HsLit(Literal) -import HsPat(InPat, ProtoNamePat(..), RenamedPat(..)) -import HsPragmas(GenPragmas) -import HsTypes(MonoType, PolyType) -import Id(Id) -import Maybes(Labda) -import Name(Name) -import NameTypes(FullName, ShortName) -import PreludePS(_PackedString) -import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) -import ProtoName(ProtoName) -import RenameAuxFuns(GlobalNameFun(..)) -import RenameMonad4(Rn4M(..), TyVarNamesEnv(..), initRn4) -import SplitUniq(SplitUniqSupply) -import SrcLoc(SrcLoc) -import TyCon(TyCon) -import Unique(Unique) -data Module a b -data Bag a -type Error = PprStyle -> Int -> Bool -> PrettyRep -data InPat a -type ProtoNamePat = InPat ProtoName -type RenamedPat = InPat Name -data PolyType a -data Labda a -data Name -data PprStyle -type Pretty = Int -> Bool -> PrettyRep -data PrettyRep -data ProtoName -type GlobalNameFun = ProtoName -> Labda Name -type Rn4M a = (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -type TyVarNamesEnv = [(ProtoName, Name)] -data SplitUniqSupply -data SrcLoc -initRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> SplitUniqSupply -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -rnGenPragmas4 :: GenPragmas ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (GenPragmas Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -rnModule4 :: Module ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Module Name (InPat Name), Bag (PprStyle -> Int -> Bool -> PrettyRep)) -rnPolyType4 :: Bool -> Bool -> [(ProtoName, Name)] -> PolyType ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (PolyType Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) - diff --git a/ghc/compiler/rename/RenameAuxFuns.hi b/ghc/compiler/rename/RenameAuxFuns.hi deleted file mode 100644 index a04866e348..0000000000 --- a/ghc/compiler/rename/RenameAuxFuns.hi +++ /dev/null @@ -1,17 +0,0 @@ -{-# GHC_PRAGMA INTERFACE VERSION 5 #-} -interface RenameAuxFuns where -import Bag(Bag) -import Maybes(Labda) -import Name(Name) -import PreludePS(_PackedString) -import ProtoName(ProtoName) -data Bag a -type GlobalNameFun = ProtoName -> Labda Name -type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name) -data Labda a -type PreludeNameFun = _PackedString -> Labda Name -type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name) -data ProtoName -mkGlobalNameFun :: _PackedString -> (_PackedString -> Labda Name) -> [(ProtoName, Name)] -> ProtoName -> Labda Name -mkNameFun :: Bag (_PackedString, a) -> (_PackedString -> Labda a, [[(_PackedString, a)]]) - diff --git a/ghc/compiler/rename/RenameBinds4.hi b/ghc/compiler/rename/RenameBinds4.hi deleted file mode 100644 index beedca4b85..0000000000 --- a/ghc/compiler/rename/RenameBinds4.hi +++ /dev/null @@ -1,50 +0,0 @@ -{-# GHC_PRAGMA INTERFACE VERSION 5 #-} -interface RenameBinds4 where -import Bag(Bag) -import CmdLineOpts(GlobalSwitch) -import ErrUtils(Error(..)) -import FiniteMap(FiniteMap) -import HsBinds(Bind, Binds, MonoBinds, Sig) -import HsExpr(Expr) -import HsLit(Literal) -import HsMatches(GRHSsAndBinds, Match) -import HsPat(InPat) -import Id(Id) -import Inst(Inst) -import Maybes(Labda) -import Name(Name) -import NameTypes(FullName, ShortName) -import PreludePS(_PackedString) -import Pretty(PprStyle, Pretty(..), PrettyRep) -import ProtoName(ProtoName) -import RenameAuxFuns(GlobalNameFun(..)) -import SplitUniq(SplitUniqSupply) -import SrcLoc(SrcLoc) -import TyCon(TyCon) -import TyVar(TyVar) -import UniqFM(UniqFM) -import UniqSet(UniqSet(..)) -import Unique(Unique) -data Bag a -type Error = PprStyle -> Int -> Bool -> PrettyRep -data Binds a b -type DefinedVars = UniqFM Name -type FreeVars = UniqFM Name -data MonoBinds a b -data InPat a -data Labda a -data Name -data PprStyle -type Pretty = Int -> Bool -> PrettyRep -data PrettyRep -data ProtoName -type GlobalNameFun = ProtoName -> Labda Name -data SplitUniqSupply -data SrcLoc -data UniqFM a -type UniqSet a = UniqFM a -data Unique -rnBinds4 :: Binds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((Binds Name (InPat Name), UniqFM Name, [Name]), Bag (PprStyle -> Int -> Bool -> PrettyRep)) -rnMethodBinds4 :: Name -> MonoBinds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (MonoBinds Name (InPat Name), Bag (PprStyle -> Int -> Bool -> PrettyRep)) -rnTopBinds4 :: Binds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Binds Name (InPat Name), Bag (PprStyle -> Int -> Bool -> PrettyRep)) - diff --git a/ghc/compiler/rename/RenameExpr4.hi b/ghc/compiler/rename/RenameExpr4.hi deleted file mode 100644 index cda02c4ba6..0000000000 --- a/ghc/compiler/rename/RenameExpr4.hi +++ /dev/null @@ -1,43 +0,0 @@ -{-# GHC_PRAGMA INTERFACE VERSION 5 #-} -interface RenameExpr4 where -import Bag(Bag) -import CmdLineOpts(GlobalSwitch) -import FiniteMap(FiniteMap) -import HsBinds(Binds) -import HsLit(Literal) -import HsMatches(GRHS, GRHSsAndBinds, Match) -import HsPat(InPat) -import Id(Id) -import Maybes(Labda) -import Name(Name) -import NameTypes(FullName, ShortName) -import PreludePS(_PackedString) -import Pretty(PprStyle, Pretty(..), PrettyRep) -import ProtoName(ProtoName) -import RenameAuxFuns(GlobalNameFun(..)) -import SplitUniq(SplitUniqSupply) -import SrcLoc(SrcLoc) -import TyCon(TyCon) -import UniType(UniType) -import UniqFM(UniqFM) -import UniqSet(UniqSet(..)) -import Unique(Unique) -data Bag a -data GRHSsAndBinds a b -data InPat a -data Labda a -data Name -data PprStyle -type Pretty = Int -> Bool -> PrettyRep -data PrettyRep -data ProtoName -type GlobalNameFun = ProtoName -> Labda Name -data SplitUniqSupply -data SrcLoc -data UniqFM a -type UniqSet a = UniqFM a -data Unique -rnGRHSsAndBinds4 :: GRHSsAndBinds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((GRHSsAndBinds Name (InPat Name), UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep)) -rnMatch4 :: Match ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((Match Name (InPat Name), UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep)) -rnPat4 :: InPat ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (InPat Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) - diff --git a/ghc/compiler/rename/RenameExpr4.lhs b/ghc/compiler/rename/RenameExpr4.lhs deleted file mode 100644 index 34c702e8b6..0000000000 --- a/ghc/compiler/rename/RenameExpr4.lhs +++ /dev/null @@ -1,431 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 -% -\section[RenameExpr]{Renaming of expressions} - -Basically dependency analysis. - -Handles @Match@, @GRHSsAndBinds@, @Expr@, and @Qual@ datatypes. In -general, all of these functions return a renamed thing, and a set of -free variables. - -\begin{code} -#include "HsVersions.h" - -module RenameExpr4 ( - rnMatch4, rnGRHSsAndBinds4, rnPat4, - - -- and to make the interface self-sufficient... - Bag, GRHSsAndBinds, InPat, Name, Maybe, - ProtoName, GlobalNameFun(..), UniqSet(..), UniqFM, SrcLoc, - Unique, SplitUniqSupply, - Pretty(..), PprStyle, PrettyRep - ) where - -import AbsSyn -import NameTypes ( FullName ) -import Outputable -import ProtoName ( ProtoName(..) ) -import Rename4 ( rnPolyType4 ) -import RenameAuxFuns ( GlobalNameFuns(..) ) -- ToDo: rm this line -import RenameBinds4 ( rnBinds4, FreeVars(..) ) -import RenameMonad4 -import UniqSet -import Util -\end{code} - - -********************************************************* -* * -\subsection{Patterns} -* * -********************************************************* - -\begin{code} -rnPat4 :: ProtoNamePat -> Rn4M RenamedPat - -rnPat4 WildPatIn = returnRn4 WildPatIn - -rnPat4 (VarPatIn name) - = lookupValue name `thenRn4` \ vname -> - returnRn4 (VarPatIn vname) - -rnPat4 (LitPatIn n) = returnRn4 (LitPatIn n) - -rnPat4 (LazyPatIn pat) - = rnPat4 pat `thenRn4` \ pat' -> - returnRn4 (LazyPatIn pat') - -rnPat4 (AsPatIn name pat) - = rnPat4 pat `thenRn4` \ pat' -> - lookupValue name `thenRn4` \ vname -> - returnRn4 (AsPatIn vname pat') - -rnPat4 (ConPatIn name pats) - = lookupValue name `thenRn4` \ name' -> - mapRn4 rnPat4 pats `thenRn4` \ patslist -> - returnRn4 (ConPatIn name' patslist) - -rnPat4 (ConOpPatIn pat1 name pat2) - = lookupValue name `thenRn4` \ name' -> - rnPat4 pat1 `thenRn4` \ pat1' -> - rnPat4 pat2 `thenRn4` \ pat2' -> - returnRn4 (ConOpPatIn pat1' name' pat2') - -rnPat4 (ListPatIn pats) - = mapRn4 rnPat4 pats `thenRn4` \ patslist -> - returnRn4 (ListPatIn patslist) - -rnPat4 (TuplePatIn pats) - = mapRn4 rnPat4 pats `thenRn4` \ patslist -> - returnRn4 (TuplePatIn patslist) - -rnPat4 (NPlusKPatIn name lit) - = lookupValue name `thenRn4` \ vname -> - returnRn4 (NPlusKPatIn vname lit) - -#ifdef DPH -rnPat4 (ProcessorPatIn pats pat) - = mapRn4 rnPat4 pats `thenRn4` \ pats' -> - rnPat4 pat `thenRn4` \ pat' -> - returnRn4 (ProcessorPatIn pats' pat') -#endif {- Data Parallel Haskell -} -\end{code} - -************************************************************************ -* * -\subsection{Match} -* * -************************************************************************ - -\begin{code} -rnMatch4 :: ProtoNameMatch -> Rn4M (RenamedMatch, FreeVars) - -rnMatch4 match - = getSrcLocRn4 `thenRn4` \ src_loc -> - namesFromProtoNames "variable in pattern" - (binders `zip` repeat src_loc) `thenRn4` \ new_binders -> - extendSS2 new_binders (rnMatch4_aux match) - where - binders = collect_binders match - - collect_binders :: ProtoNameMatch -> [ProtoName] - - collect_binders (GRHSMatch _) = [] - collect_binders (PatMatch pat match) - = collectPatBinders pat ++ collect_binders match - -rnMatch4_aux (PatMatch pat match) - = rnPat4 pat `thenRn4` \ pat' -> - rnMatch4_aux match `thenRn4` \ (match', fvMatch) -> - returnRn4 (PatMatch pat' match', fvMatch) - -rnMatch4_aux (GRHSMatch grhss_and_binds) - = rnGRHSsAndBinds4 grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) -> - returnRn4 (GRHSMatch grhss_and_binds', fvs) -\end{code} - -%************************************************************************ -%* * -\subsubsection[dep-GRHSs]{Guarded right-hand sides (GRHSsAndBinds)} -%* * -%************************************************************************ - -\begin{code} -rnGRHSsAndBinds4 :: ProtoNameGRHSsAndBinds -> Rn4M (RenamedGRHSsAndBinds, FreeVars) - -rnGRHSsAndBinds4 (GRHSsAndBindsIn grhss binds) - = rnBinds4 binds `thenRn4` \ (binds', fvBinds, scope) -> - extendSS2 scope (rnGRHSs4 grhss) `thenRn4` \ (grhss', fvGRHS) -> - returnRn4 (GRHSsAndBindsIn grhss' binds', fvBinds `unionUniqSets` fvGRHS) - where - rnGRHSs4 [] = returnRn4 ([], emptyUniqSet) - - rnGRHSs4 (grhs:grhss) - = rnGRHS4 grhs `thenRn4` \ (grhs', fvs) -> - rnGRHSs4 grhss `thenRn4` \ (grhss', fvss) -> - returnRn4 (grhs' : grhss', fvs `unionUniqSets` fvss) - - rnGRHS4 (GRHS guard expr locn) - = pushSrcLocRn4 locn ( - rnExpr4 guard `thenRn4` \ (guard', fvsg) -> - rnExpr4 expr `thenRn4` \ (expr', fvse) -> - returnRn4 (GRHS guard' expr' locn, fvsg `unionUniqSets` fvse) - ) - - rnGRHS4 (OtherwiseGRHS expr locn) - = pushSrcLocRn4 locn ( - rnExpr4 expr `thenRn4` \ (expr', fvs) -> - returnRn4 (OtherwiseGRHS expr' locn, fvs) - ) -\end{code} - -%************************************************************************ -%* * -\subsubsection[dep-Expr]{Expressions} -%* * -%************************************************************************ - -\begin{code} -rnExprs4 :: [ProtoNameExpr] -> Rn4M ([RenamedExpr], FreeVars) - -rnExprs4 [] = returnRn4 ([], emptyUniqSet) - -rnExprs4 (expr:exprs) - = rnExpr4 expr `thenRn4` \ (expr', fvExpr) -> - rnExprs4 exprs `thenRn4` \ (exprs', fvExprs) -> - returnRn4 (expr':exprs', fvExpr `unionUniqSets` fvExprs) -\end{code} - -Variables. We look up the variable and return the resulting name. The -interesting question is what the free-variable set should be. We -don't want to return imported or prelude things as free vars. So we -look at the Name returned from the lookup, and make it part of the -free-var set iff: -\begin{itemize} -\item -if it's a @Short@, -\item -or it's an @OtherTopId@ and it's defined in this module -(this includes locally-defined constructrs, but that's too bad) -\end{itemize} - -\begin{code} -rnExpr4 :: ProtoNameExpr -> Rn4M (RenamedExpr, FreeVars) - -rnExpr4 (Var v) - = lookupValue v `thenRn4` \ vname -> - returnRn4 (Var vname, fv_set vname) - where - fv_set n@(Short uniq sname) = singletonUniqSet n - fv_set n@(OtherTopId uniq fname) - | isLocallyDefined fname - && not (isConop (getOccurrenceName fname)) - = singletonUniqSet n - fv_set other = emptyUniqSet - -rnExpr4 (Lit lit) = returnRn4 (Lit lit, emptyUniqSet) - -rnExpr4 (Lam match) - = rnMatch4 match `thenRn4` \ (match', fvMatch) -> - returnRn4 (Lam match', fvMatch) - -rnExpr4 (App fun arg) - = rnExpr4 fun `thenRn4` \ (fun',fvFun) -> - rnExpr4 arg `thenRn4` \ (arg',fvArg) -> - returnRn4 (App fun' arg', fvFun `unionUniqSets` fvArg) - -rnExpr4 (OpApp e1 op e2) - = rnExpr4 e1 `thenRn4` \ (e1', fvs_e1) -> - rnExpr4 op `thenRn4` \ (op', fvs_op) -> - rnExpr4 e2 `thenRn4` \ (e2', fvs_e2) -> - returnRn4 (OpApp e1' op' e2', (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2) - -rnExpr4 (SectionL expr op) - = rnExpr4 expr `thenRn4` \ (expr', fvs_expr) -> - rnExpr4 op `thenRn4` \ (op', fvs_op) -> - returnRn4 (SectionL expr' op', fvs_op `unionUniqSets` fvs_expr) - -rnExpr4 (SectionR op expr) - = rnExpr4 op `thenRn4` \ (op', fvs_op) -> - rnExpr4 expr `thenRn4` \ (expr', fvs_expr) -> - returnRn4 (SectionR op' expr', fvs_op `unionUniqSets` fvs_expr) - -rnExpr4 (CCall fun args may_gc is_casm fake_result_ty) - = rnExprs4 args `thenRn4` \ (args', fvs_args) -> - returnRn4 (CCall fun args' may_gc is_casm fake_result_ty, fvs_args) - -rnExpr4 (SCC label expr) - = rnExpr4 expr `thenRn4` \ (expr', fvs_expr) -> - returnRn4 (SCC label expr', fvs_expr) - -rnExpr4 (Case expr ms) - = rnExpr4 expr `thenRn4` \ (new_expr, e_fvs) -> - mapAndUnzipRn4 rnMatch4 ms `thenRn4` \ (new_ms, ms_fvs) -> - returnRn4 (Case new_expr new_ms, unionManyUniqSets (e_fvs : ms_fvs)) - -rnExpr4 (ListComp expr quals) - = rnQuals4 quals `thenRn4` \ ((quals', qual_binders), fvQuals) -> - extendSS2 qual_binders (rnExpr4 expr) `thenRn4` \ (expr', fvExpr) -> - returnRn4 (ListComp expr' quals', fvExpr `unionUniqSets` fvQuals) - -rnExpr4 (Let binds expr) - = rnBinds4 binds `thenRn4` \ (binds', fvBinds, new_binders) -> - extendSS2 new_binders (rnExpr4 expr) `thenRn4` \ (expr',fvExpr) -> - returnRn4 (Let binds' expr', fvBinds `unionUniqSets` fvExpr) - -rnExpr4 (ExplicitList exps) - = rnExprs4 exps `thenRn4` \ (exps', fvs) -> - returnRn4 (ExplicitList exps', fvs) - -rnExpr4 (ExplicitTuple exps) - = rnExprs4 exps `thenRn4` \ (exps', fvExps) -> - returnRn4 (ExplicitTuple exps', fvExps) - -rnExpr4 (ExprWithTySig expr pty) - = rnExpr4 expr `thenRn4` \ (expr', fvExpr) -> - rnPolyType4 False True nullTyVarNamesEnv pty `thenRn4` \ pty' -> - returnRn4 (ExprWithTySig expr' pty', fvExpr) - -rnExpr4 (If p b1 b2) - = rnExpr4 p `thenRn4` \ (p', fvP) -> - rnExpr4 b1 `thenRn4` \ (b1', fvB1) -> - rnExpr4 b2 `thenRn4` \ (b2', fvB2) -> - returnRn4 (If p' b1' b2', unionManyUniqSets [fvP, fvB1, fvB2]) - -rnExpr4 (ArithSeqIn seq) - = rn_seq seq `thenRn4` \ (new_seq, fvs) -> - returnRn4 (ArithSeqIn new_seq, fvs) - where - rn_seq (From expr) - = rnExpr4 expr `thenRn4` \ (expr', fvExpr) -> - returnRn4 (From expr', fvExpr) - - rn_seq (FromThen expr1 expr2) - = rnExpr4 expr1 `thenRn4` \ (expr1', fvExpr1) -> - rnExpr4 expr2 `thenRn4` \ (expr2', fvExpr2) -> - returnRn4 (FromThen expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2) - - rn_seq (FromTo expr1 expr2) - = rnExpr4 expr1 `thenRn4` \ (expr1', fvExpr1) -> - rnExpr4 expr2 `thenRn4` \ (expr2', fvExpr2) -> - returnRn4 (FromTo expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2) - - rn_seq (FromThenTo expr1 expr2 expr3) - = rnExpr4 expr1 `thenRn4` \ (expr1', fvExpr1) -> - rnExpr4 expr2 `thenRn4` \ (expr2', fvExpr2) -> - rnExpr4 expr3 `thenRn4` \ (expr3', fvExpr3) -> - returnRn4 (FromThenTo expr1' expr2' expr3', - unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3]) - -#ifdef DPH -rnExpr4 (ParallelZF expr quals) - = rnParQuals4 quals `thenRn4` \ ((quals',binds),fvQuals)-> - extendSS2 binds - (rnExpr4 expr) `thenRn4` \ (expr', fvExpr ) -> - returnRn4 (ParallelZF expr' quals' , fvExpr `unionUniqSets` fvQuals) - -rnExpr4 (ExplicitProcessor exprs expr) - = rnExprs4 exprs `thenRn4` \ (exprs',fvExprs) -> - rnExpr4 expr `thenRn4` \ (expr' ,fvExpr) -> - returnRn4 (ExplicitProcessor exprs' expr',fvExprs `unionUniqSets` fvExpr) - -rnExpr4 (ExplicitPodIn exprs) - = rnExprs4 exprs `thenRn4` \ (exprs',fvExprs) -> - returnRn4 (ExplicitPodIn exprs',fvExprs) - --- ExplicitPodOut : not in ProtoNameExprs (pops out of typechecker :-) - -#endif {- Data Parallel Haskell -} - --- ArithSeqOut: not in ProtoNameExprs -\end{code} - -%************************************************************************ -%* * -\subsubsection[dep-Quals]{@Qual@s: in list comprehensions} -%* * -%************************************************************************ - -Note that although some bound vars may appear in the free var set for -the first qual, these will eventually be removed by the caller. For -example, if we have @[p | r <- s, q <- r, p <- q]@, when doing -@(AndQuals (q <- r) (p <- q))@, the free var set for @(q <- r)@ will -be @[r]@, and the free var set for the entire Quals will be @[r]@. This -@r@ will be removed only when we finally return from examining all the -Quals. - -\begin{code} -rnQuals4 :: [ProtoNameQual] -> Rn4M (([RenamedQual], [Name]), FreeVars) - -rnQuals4 [qual] - = rnQual4 qual `thenRn4` \ ((new_qual, bs), fvs) -> - returnRn4 (([new_qual], bs), fvs) - -rnQuals4 (qual: quals) - = rnQual4 qual `thenRn4` \ ((qual', bs1), fvQuals1) -> - extendSS2 bs1 (rnQuals4 quals) `thenRn4` \ ((quals', bs2), fvQuals2) -> - returnRn4 - ((qual' : quals', bs2 ++ bs1), -- The ones on the right (bs2) shadow the - -- ones on the left (bs1) - fvQuals1 `unionUniqSets` fvQuals2) - -rnQual4 (GeneratorQual pat expr) - = rnExpr4 expr `thenRn4` \ (expr', fvExpr) -> - let - binders = collectPatBinders pat - in - getSrcLocRn4 `thenRn4` \ src_loc -> - namesFromProtoNames "variable in list-comprehension-generator pattern" - (binders `zip` repeat src_loc) `thenRn4` \ new_binders -> - extendSS new_binders (rnPat4 pat) `thenRn4` \ pat' -> - - returnRn4 ((GeneratorQual pat' expr', new_binders), fvExpr) - -rnQual4 (FilterQual expr) - = rnExpr4 expr `thenRn4` \ (expr', fvs) -> - returnRn4 ((FilterQual expr', []), fvs) -\end{code} - -%************************************************************************ -%* * -%* Parallel Quals (in Parallel Zf expressions) * -%* * -%************************************************************************ -\subsubsection[dep-ParQuals]{ParQuals} - -\begin{code} -#ifdef DPH -rnPats4 :: [ProtoNamePat] -> Rn4M [RenamedPat] -rnPats4 [] = returnRn4 [] -rnPats4 (pat:pats) - = (rnPat4 pat) `thenRn4` (\ pat' -> - (rnPats4 pats) `thenRn4` (\ pats' -> - returnRn4 (pat':pats') )) - -rnParQuals4 :: ProtoNameParQuals -> Rn4M ((RenamedParQuals, [Name]), FreeVars) - -rnParQuals4 (AndParQuals q1 q2) - = rnParQuals4 q1 `thenRn4` (\ ((quals1', bs1), fvQuals1) -> - extendSS2 bs1 (rnParQuals4 q2) - `thenRn4` (\ ((quals2', bs2), fvQuals2) -> - returnRn4 ((AndParQuals quals1' quals2', bs2 ++ bs1), - fvQuals1 `unionUniqSets` fvQuals2) )) - - -rnParQuals4 (DrawnGenIn pats pat expr) - = rnExpr4 expr `thenRn4` (\ (expr', fvExpr) -> - let_1_0 (concat (map collectPatBinders pats)) (\ binders1 -> - getSrcLocRn4 `thenRn4` (\ src_loc -> - namesFromProtoNames "variable in pattern" - (binders1 `zip` repeat src_loc) - `thenRn4` (\ binders1' -> - extendSS binders1' (rnPats4 pats) - `thenRn4` (\ pats' -> - let_1_0 (collectPatBinders pat) (\ binders2 -> - namesFromProtoNames "variable in pattern" - (binders2 `zip` repeat src_loc) - `thenRn4` (\ binders2' -> - extendSS binders2' (rnPat4 pat) - `thenRn4` (\ pat' -> - returnRn4 ((DrawnGenIn pats' pat' expr' , binders1' ++ binders2'), - fvExpr) )))))))) - -rnParQuals4 (IndexGen exprs pat expr) - = rnExpr4 expr `thenRn4` (\ (expr', fvExpr) -> - rnExprs4 exprs `thenRn4` (\ (exprs', fvExprs) -> - let_1_0 (collectPatBinders pat) (\ binders -> - getSrcLocRn4 `thenRn4` (\ src_loc -> - namesFromProtoNames "variable in pattern" - (binders `zip` repeat src_loc) - `thenRn4` (\ binders' -> - extendSS binders' (rnPat4 pat) - `thenRn4` (\ pat' -> - returnRn4 ((IndexGen exprs' pat' expr' , binders'), - fvExpr `unionUniqSets` fvExprs) )))))) - -rnParQuals4 (ParFilter expr) - = rnExpr4 expr `thenRn4` (\ (expr', fvExpr) -> - returnRn4 ((ParFilter expr', []), fvExpr) ) -#endif {- Data Parallel Haskell -} -\end{code} diff --git a/ghc/compiler/rename/RenameMonad12.hi b/ghc/compiler/rename/RenameMonad12.hi deleted file mode 100644 index 0a929ad33d..0000000000 --- a/ghc/compiler/rename/RenameMonad12.hi +++ /dev/null @@ -1,23 +0,0 @@ -{-# GHC_PRAGMA INTERFACE VERSION 5 #-} -interface RenameMonad12 where -import Bag(Bag) -import CharSeq(CSeq) -import CmdLineOpts(GlobalSwitch) -import PreludePS(_PackedString) -import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) -infixr 9 `thenRn12` -data Bag a -data PprStyle -type Pretty = Int -> Bool -> PrettyRep -data PrettyRep -type Rn12M a = _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -addErrRn12 :: (PprStyle -> Int -> Bool -> PrettyRep) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ((), Bag (PprStyle -> Int -> Bool -> PrettyRep)) -foldrRn12 :: (a -> b -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> b -> [a] -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -getModuleNameRn12 :: _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (_PackedString, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -initRn12 :: _PackedString -> (_PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -mapRn12 :: (a -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ([b], Bag (PprStyle -> Int -> Bool -> PrettyRep)) -recoverQuietlyRn12 :: a -> (_PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -returnRn12 :: a -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -thenRn12 :: (_PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -zipWithRn12 :: (a -> b -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (c, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> [b] -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ([c], Bag (PprStyle -> Int -> Bool -> PrettyRep)) - diff --git a/ghc/compiler/rename/RenameMonad3.hi b/ghc/compiler/rename/RenameMonad3.hi deleted file mode 100644 index 9d7799b9dc..0000000000 --- a/ghc/compiler/rename/RenameMonad3.hi +++ /dev/null @@ -1,31 +0,0 @@ -{-# GHC_PRAGMA INTERFACE VERSION 5 #-} -interface RenameMonad3 where -import FiniteMap(FiniteMap) -import HsImpExp(IE) -import Maybes(Labda) -import Name(Name) -import NameTypes(FullName) -import Outputable(ExportFlag) -import PreludePS(_PackedString) -import ProtoName(ProtoName) -import SplitUniq(SplitUniqSupply) -import SrcLoc(SrcLoc) -import Unique(Unique) -infixr 9 `thenRn3` -data IE -data FullName -data ExportFlag -data ProtoName -type Rn3M a = (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a -data SplitUniqSupply -data Unique -andRn3 :: (a -> a -> a) -> ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a -fixRn3 :: (a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a -initRn3 :: ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> SplitUniqSupply -> a -mapRn3 :: (a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> b) -> [a] -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> [b] -newFullNameM3 :: ProtoName -> SrcLoc -> Bool -> Labda ExportFlag -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> (Unique, FullName) -newInvisibleNameM3 :: ProtoName -> SrcLoc -> Bool -> Labda ExportFlag -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> (Unique, FullName) -putInfoDownM3 :: _PackedString -> [IE] -> ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a -returnRn3 :: a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a -thenRn3 :: ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> b) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> b - diff --git a/ghc/compiler/rename/RenameMonad4.hi b/ghc/compiler/rename/RenameMonad4.hi deleted file mode 100644 index 4d3f3e41bc..0000000000 --- a/ghc/compiler/rename/RenameMonad4.hi +++ /dev/null @@ -1,79 +0,0 @@ -{-# GHC_PRAGMA INTERFACE VERSION 5 #-} -interface RenameMonad4 where -import AbsSyn(Module) -import Bag(Bag) -import CharSeq(CSeq) -import CmdLineOpts(GlobalSwitch) -import ErrUtils(Error(..)) -import FiniteMap(FiniteMap) -import HsBinds(Binds, Sig) -import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl) -import HsImpExp(IE, ImportedInterface) -import HsLit(Literal) -import HsPat(InPat, RenamedPat(..)) -import Id(Id) -import Maybes(Labda) -import Name(Name) -import NameTypes(FullName, ShortName) -import PreludePS(_PackedString) -import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) -import ProtoName(ProtoName) -import RenameAuxFuns(GlobalNameFun(..), GlobalNameFuns(..)) -import SplitUniq(SplitUniqSupply) -import SrcLoc(SrcLoc) -import TyCon(TyCon) -import UniqFM(UniqFM) -import UniqSet(UniqSet(..)) -import Unique(Unique) -infixr 9 `thenRn4` -infixr 9 `thenRn4_` -data Module a b -data Bag a -data GlobalSwitch -type Error = PprStyle -> Int -> Bool -> PrettyRep -data InPat a -type RenamedPat = InPat Name -data Labda a -data Name -data PprStyle -type Pretty = Int -> Bool -> PrettyRep -data PrettyRep -data ProtoName -type GlobalNameFun = ProtoName -> Labda Name -type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name) -type Rn4M a = (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -data SplitUniqSupply -data SrcLoc -type TyVarNamesEnv = [(ProtoName, Name)] -data UniqFM a -type UniqSet a = UniqFM a -data Unique -addErrRn4 :: (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((), Bag (PprStyle -> Int -> Bool -> PrettyRep)) -andRn4 :: (a -> a -> a) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -catTyVarNamesEnvs :: [(ProtoName, Name)] -> [(ProtoName, Name)] -> [(ProtoName, Name)] -domTyVarNamesEnv :: [(ProtoName, Name)] -> [ProtoName] -extendSS :: [Name] -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -extendSS2 :: [Name] -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((a, UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((a, UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep)) -failButContinueRn4 :: a -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -getSrcLocRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (SrcLoc, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -getSwitchCheckerRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> Bool, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -initRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> SplitUniqSupply -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -lookupClass :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -lookupClassOp :: Name -> ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -lookupFixityOp :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Labda Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -lookupTyCon :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -lookupTyConEvenIfInvisible :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -lookupTyVarName :: [(ProtoName, Name)] -> ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -lookupValue :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -lookupValueEvenIfInvisible :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -mapAndUnzipRn4 :: (a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((b, c), Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (([b], [c]), Bag (PprStyle -> Int -> Bool -> PrettyRep)) -mapRn4 :: (a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ([b], Bag (PprStyle -> Int -> Bool -> PrettyRep)) -mkTyVarNamesEnv :: SrcLoc -> [ProtoName] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (([(ProtoName, Name)], [Name]), Bag (PprStyle -> Int -> Bool -> PrettyRep)) -namesFromProtoNames :: [Char] -> [(ProtoName, SrcLoc)] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ([Name], Bag (PprStyle -> Int -> Bool -> PrettyRep)) -nullTyVarNamesEnv :: [(ProtoName, Name)] -pushSrcLocRn4 :: SrcLoc -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -recoverQuietlyRn4 :: a -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -returnRn4 :: a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -thenRn4 :: ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep)) -thenRn4_ :: ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep)) - diff --git a/ghc/compiler/rename/RenameBinds4.lhs b/ghc/compiler/rename/RnBinds4.lhs index 76943f958d..418c626967 100644 --- a/ghc/compiler/rename/RenameBinds4.lhs +++ b/ghc/compiler/rename/RnBinds4.lhs @@ -1,48 +1,55 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % -\section[RenameBinds4]{Renaming and dependency analysis of bindings} +\section[RnBinds4]{Renaming and dependency analysis of bindings} This module does renaming and dependency analysis on value bindings in -@AbsSyntax@ programs. It does {\em not} do cycle-checks on class or +the abstract syntax. It does {\em not} do cycle-checks on class or type-synonym declarations; those cannot be done at this stage because they may be affected by renaming (which isn't fully worked out yet). \begin{code} #include "HsVersions.h" -module RenameBinds4 ( - rnTopBinds4, rnMethodBinds4, - rnBinds4, - FreeVars(..), DefinedVars(..), +module RnBinds4 ( + rnTopBinds, rnMethodBinds, + rnBinds, + FreeVars(..), DefinedVars(..) -- and to make the interface self-sufficient... - Bag, Binds, MonoBinds, InPat, Name, ProtoName, - GlobalNameFun(..), Maybe, UniqSet(..), UniqFM, SrcLoc, Unique, - SplitUniqSupply, Error(..), Pretty(..), PprStyle, - PrettyRep ) where -import AbsSyn -import CmdLineOpts ( GlobalSwitch(..) ) -import Digraph ( stronglyConnComp {- MOVED HERE: , isCyclic -} ) -import Errors -- ( unknownSigDeclErr, dupSigDeclErr, methodBindErr ) -import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** -import Maybes ( catMaybes, Maybe(..) ) -import Name ( eqName, cmpName, isUnboundName ) -import ProtoName ( elemByLocalNames, eqByLocalName ) -import Rename4 ( rnPolyType4, rnGenPragmas4 ) -import RenameAuxFuns ( GlobalNameFuns(..) ) -import RenameMonad4 -import RenameExpr4 ( rnMatch4, rnGRHSsAndBinds4, rnPat4 ) -import UniqSet -import Util +import Ubiq{-uitous-} +import RnLoop -- break the RnPass4/RnExpr4/RnBinds4 loops + +import HsSyn +import RdrHsSyn +import RnHsSyn +import HsPragmas ( noGenPragmas ) +import RnMonad4 + +-- others: +import CmdLineOpts ( opt_SigsRequired ) +import Digraph ( stronglyConnComp ) +import ErrUtils ( addErrLoc, addShortErrLocLine ) +import Maybes ( catMaybes ) +import Name ( isUnboundName, Name{-instances-} ) +import Pretty +import ProtoName ( elemByLocalNames, eqByLocalName, ProtoName{-instances-} ) +import RnExpr4 -- OK to look here; but not the other way 'round +import UniqSet ( emptyUniqSet, singletonUniqSet, mkUniqSet, + unionUniqSets, unionManyUniqSets, + elementOfUniqSet, + uniqSetToList, + UniqSet(..) + ) +import Util ( isIn, removeDups, panic, panic# ) \end{code} -- ToDo: Put the annotations into the monad, so that they arrive in the proper -- place and can be used when complaining. -The code tree received by the function @rnBinds4@ contains definitions +The code tree received by the function @rnBinds@ contains definitions in where-clauses which are all apparently mutually recursive, but which may not really depend upon each other. For example, in the top level program \begin{verbatim} @@ -56,7 +63,7 @@ definitions. In Proceedings of the International Symposium on Programming, Toulouse, pp. 217-39. LNCS 167. Springer Verlag.} However, the typechecker usually can check definitions in which only the strongly connected components have been collected into recursive bindings. -This is precisely what the function @rnBinds4@ does. +This is precisely what the function @rnBinds@ does. ToDo: deal with case where a single monobinds binds the same variable twice. @@ -89,7 +96,7 @@ type Edge = (VertexTag, VertexTag) The basic algorithm involves walking over the tree and returning a tuple containing the new tree plus its free variables. Some functions, such -as those walking polymorphic bindings (Binds) and qualifier lists in +as those walking polymorphic bindings (HsBinds) and qualifier lists in list comprehensions (@Quals@), return the variables bound in local environments. These are then used to calculate the free variables of the expression evaluated in these environments. @@ -108,10 +115,10 @@ a set of variables free in @Exp@ is written @fvExp@ %************************************************************************ %* * -%* analysing polymorphic bindings (Binds, Bind, MonoBinds) * +%* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) * %* * %************************************************************************ -\subsubsection[dep-Binds]{Polymorphic bindings} +\subsubsection[dep-HsBinds]{Polymorphic bindings} Non-recursive expressions are reconstructed without any changes at top level, although their component expressions may have to be altered. @@ -146,83 +153,83 @@ free variables in each successive set of cumulative bindings is the union of those in the previous set plus those of the newest binding after the defined variables of the previous set have been removed. -@rnMethodBinds4@ deals only with the declarations in class and +@rnMethodBinds@ deals only with the declarations in class and instance declarations. It expects only to see @FunMonoBind@s, and it expects the global environment to contain bindings for the binders (which are all class operations). \begin{code} -rnTopBinds4 :: ProtoNameBinds -> Rn4M RenamedBinds -rnMethodBinds4 :: Name{-class-} -> ProtoNameMonoBinds -> Rn4M RenamedMonoBinds -rnBinds4 :: ProtoNameBinds -> Rn4M (RenamedBinds, FreeVars, [Name]) +rnTopBinds :: ProtoNameHsBinds -> Rn4M RenamedHsBinds +rnMethodBinds :: Name{-class-} -> ProtoNameMonoBinds -> Rn4M RenamedMonoBinds +rnBinds :: ProtoNameHsBinds -> Rn4M (RenamedHsBinds, FreeVars, [Name]) -rnTopBinds4 EmptyBinds = returnRn4 EmptyBinds -rnTopBinds4 (SingleBind (RecBind bind)) = rnTopMonoBinds4 bind [] -rnTopBinds4 (BindWith (RecBind bind) sigs) = rnTopMonoBinds4 bind sigs +rnTopBinds EmptyBinds = returnRn4 EmptyBinds +rnTopBinds (SingleBind (RecBind bind)) = rnTopMonoBinds bind [] +rnTopBinds (BindWith (RecBind bind) sigs) = rnTopMonoBinds bind sigs -- the parser doesn't produce other forms -- ******************************************************************** -rnMethodBinds4 class_name EmptyMonoBinds = returnRn4 EmptyMonoBinds +rnMethodBinds class_name EmptyMonoBinds = returnRn4 EmptyMonoBinds -rnMethodBinds4 class_name (AndMonoBinds mb1 mb2) - = andRn4 AndMonoBinds (rnMethodBinds4 class_name mb1) - (rnMethodBinds4 class_name mb2) +rnMethodBinds class_name (AndMonoBinds mb1 mb2) + = andRn4 AndMonoBinds (rnMethodBinds class_name mb1) + (rnMethodBinds class_name mb2) -rnMethodBinds4 class_name (FunMonoBind pname matches locn) +rnMethodBinds class_name (FunMonoBind pname matches locn) = pushSrcLocRn4 locn ( lookupClassOp class_name pname `thenRn4` \ op_name -> - mapAndUnzipRn4 rnMatch4 matches `thenRn4` \ (new_matches, _) -> + mapAndUnzipRn4 rnMatch matches `thenRn4` \ (new_matches, _) -> returnRn4 (FunMonoBind op_name new_matches locn) ) -rnMethodBinds4 class_name (PatMonoBind (VarPatIn pname) grhss_and_binds locn) +rnMethodBinds class_name (PatMonoBind (VarPatIn pname) grhss_and_binds locn) = pushSrcLocRn4 locn ( lookupClassOp class_name pname `thenRn4` \ op_name -> - rnGRHSsAndBinds4 grhss_and_binds `thenRn4` \ (grhss_and_binds', _) -> + rnGRHSsAndBinds grhss_and_binds `thenRn4` \ (grhss_and_binds', _) -> returnRn4 (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn) ) -- Can't handle method pattern-bindings which bind multiple methods. -rnMethodBinds4 _ mbind@(PatMonoBind other_pat _ locn) +rnMethodBinds _ mbind@(PatMonoBind other_pat _ locn) = failButContinueRn4 EmptyMonoBinds (methodBindErr mbind locn) -- ******************************************************************** -rnBinds4 EmptyBinds = returnRn4 (EmptyBinds,emptyUniqSet,[]) -rnBinds4 (SingleBind (RecBind bind)) = rnNestedMonoBinds4 bind [] -rnBinds4 (BindWith (RecBind bind) sigs) = rnNestedMonoBinds4 bind sigs +rnBinds EmptyBinds = returnRn4 (EmptyBinds,emptyUniqSet,[]) +rnBinds (SingleBind (RecBind bind)) = rnNestedMonoBinds bind [] +rnBinds (BindWith (RecBind bind) sigs) = rnNestedMonoBinds bind sigs -- the parser doesn't produce other forms \end{code} -@rnNestedMonoBinds4@ +@rnNestedMonoBinds@ - collects up the binders for this declaration group, - checkes that they form a set - extends the environment to bind them to new local names - - calls @rnMonoBinds4@ to do the real work + - calls @rnMonoBinds@ to do the real work -In contrast, @rnTopMonoBinds4@ doesn't extend the environment, because that's -already done in pass3. All it does is call @rnMonoBinds4@ and discards +In contrast, @rnTopMonoBinds@ doesn't extend the environment, because that's +already done in pass3. All it does is call @rnMonoBinds@ and discards the free var info. \begin{code} -rnTopMonoBinds4 :: ProtoNameMonoBinds -> [ProtoNameSig] -> Rn4M RenamedBinds +rnTopMonoBinds :: ProtoNameMonoBinds -> [ProtoNameSig] -> Rn4M RenamedHsBinds -rnTopMonoBinds4 EmptyMonoBinds sigs = returnRn4 EmptyBinds +rnTopMonoBinds EmptyMonoBinds sigs = returnRn4 EmptyBinds -rnTopMonoBinds4 mbs sigs - = rnBindSigs4 True{-top-level-} (collectMonoBinders mbs) sigs `thenRn4` \ siglist -> - rnMonoBinds4 mbs siglist `thenRn4` \ (new_binds, fv_set) -> +rnTopMonoBinds mbs sigs + = rnBindSigs True{-top-level-} (collectMonoBinders mbs) sigs `thenRn4` \ siglist -> + rnMonoBinds mbs siglist `thenRn4` \ (new_binds, fv_set) -> returnRn4 new_binds -rnNestedMonoBinds4 :: ProtoNameMonoBinds -> [ProtoNameSig] - -> Rn4M (RenamedBinds, FreeVars, [Name]) +rnNestedMonoBinds :: ProtoNameMonoBinds -> [ProtoNameSig] + -> Rn4M (RenamedHsBinds, FreeVars, [Name]) -rnNestedMonoBinds4 EmptyMonoBinds sigs +rnNestedMonoBinds EmptyMonoBinds sigs = returnRn4 (EmptyBinds, emptyUniqSet, []) -rnNestedMonoBinds4 mbinds sigs -- Non-empty monobinds +rnNestedMonoBinds mbinds sigs -- Non-empty monobinds = -- Extract all the binders in this group, -- and extend current scope, inventing new names for the new binders @@ -236,27 +243,27 @@ rnNestedMonoBinds4 mbinds sigs -- Non-empty monobinds mbinders_w_srclocs `thenRn4` \ new_mbinders -> extendSS2 new_mbinders ( - rnBindSigs4 False{-not top- level-} mbinders sigs `thenRn4` \ siglist -> - rnMonoBinds4 mbinds siglist + rnBindSigs False{-not top- level-} mbinders sigs `thenRn4` \ siglist -> + rnMonoBinds mbinds siglist ) `thenRn4` \ (new_binds, fv_set) -> returnRn4 (new_binds, fv_set, new_mbinders) \end{code} -@rnMonoBinds4@ is used by *both* top-level and nested bindings. It +@rnMonoBinds@ is used by *both* top-level and nested bindings. It assumes that all variables bound in this group are already in scope. This is done *either* by pass 3 (for the top-level bindings), -*or* by @rnNestedMonoBinds4@ (for the nested ones). +*or* by @rnNestedMonoBinds@ (for the nested ones). \begin{code} -rnMonoBinds4 :: ProtoNameMonoBinds +rnMonoBinds :: ProtoNameMonoBinds -> [RenamedSig] -- Signatures attached to this group - -> Rn4M (RenamedBinds, FreeVars) + -> Rn4M (RenamedHsBinds, FreeVars) -rnMonoBinds4 mbinds siglist +rnMonoBinds mbinds siglist = -- Rename the bindings, returning a MonoBindsInfo -- which is a list of indivisible vertices so far as - -- the SCC analysis is concerned + -- the strongly-connected-components (SCC) analysis is concerned flattenMonoBinds 0 siglist mbinds `thenRn4` \ (_, mbinds_info) -> -- Do the SCC analysis @@ -269,7 +276,7 @@ rnMonoBinds4 mbinds siglist rhs_free_vars = foldr f emptyUniqSet mbinds_info final_binds = reconstructRec scc_result edges mbinds_info - + happy_answer = returnRn4 (final_binds, rhs_free_vars) in case (inline_sigs_in_recursive_binds final_binds) of @@ -284,9 +291,9 @@ rnMonoBinds4 mbinds siglist f (_, _, fvs_body, _, _) fvs_sofar = fvs_sofar `unionUniqSets` fvs_body inline_sigs_in_recursive_binds (BindWith (RecBind _) sigs) - = case [(n, locn) | (InlineSig n _ locn) <- sigs ] of + = case [(n, locn) | (InlineSig n locn) <- sigs ] of [] -> Nothing - sigh -> + sigh -> #if OMIT_DEFORESTER Just sigh #else @@ -323,8 +330,8 @@ flattenMonoBinds uniq sigs (AndMonoBinds mB1 mB2) flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn) = pushSrcLocRn4 locn ( - rnPat4 pat `thenRn4` \ pat' -> - rnGRHSsAndBinds4 grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) -> + rnPat pat `thenRn4` \ pat' -> + rnGRHSsAndBinds grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) -> -- Find which things are bound in this group let @@ -350,18 +357,18 @@ flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn) flattenMonoBinds uniq sigs (FunMonoBind name matches locn) = pushSrcLocRn4 locn ( lookupValue name `thenRn4` \ name' -> - mapAndUnzipRn4 rnMatch4 matches `thenRn4` \ (new_matches, fv_lists) -> + mapAndUnzipRn4 rnMatch matches `thenRn4` \ (new_matches, fv_lists) -> let fvs = unionManyUniqSets fv_lists - sigs_for_me = foldl (sig_for_here (\ n -> n `eqName` name')) [] sigs + sigs_for_me = foldl (sig_for_here (\ n -> n == name')) [] sigs sigs_fvs = foldr sig_fv emptyUniqSet sigs_for_me in returnRn4 ( uniq + 1, [(uniq, - singletonUniqSet name', + singletonUniqSet name', fvs `unionUniqSets` sigs_fvs, FunMonoBind name' new_matches locn, sigs_for_me @@ -372,11 +379,11 @@ flattenMonoBinds uniq sigs (FunMonoBind name matches locn) Grab type-signatures/user-pragmas of interest: \begin{code} sig_for_here want_me acc s@(Sig n _ _ _) | want_me n = s:acc -sig_for_here want_me acc s@(InlineSig n _ _) | want_me n = s:acc +sig_for_here want_me acc s@(InlineSig n _) | want_me n = s:acc sig_for_here want_me acc s@(DeforestSig n _) | want_me n = s:acc sig_for_here want_me acc s@(SpecSig n _ _ _) | want_me n = s:acc sig_for_here want_me acc s@(MagicUnfoldingSig n _ _) - | want_me n = s:acc + | want_me n = s:acc sig_for_here want_me acc other_wise = acc -- If a SPECIALIZE pragma is of the "... = blah" form, @@ -398,15 +405,15 @@ This @MonoBinds@- and @ClassDecls@-specific code is segregated here, as the two cases are similar. \begin{code} -reconstructRec :: [Cycle] -- Result of SCC analysis; at least one - -> [Edge] -- Original edges +reconstructRec :: [Cycle] -- Result of SCC analysis; at least one + -> [Edge] -- Original edges -> FlatMonoBindsInfo - -> RenamedBinds + -> RenamedHsBinds reconstructRec cycles edges mbi = foldr1 ThenBinds (map (reconstructCycle mbi) cycles) where - reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedBinds + reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedHsBinds reconstructCycle mbi2 cycle = BIND [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle] @@ -428,7 +435,7 @@ reconstructRec cycles edges mbi is_elem = isIn "reconstructRec" mk_binds :: RenamedMonoBinds -> [RenamedSig] - -> Bool -> Bool -> RenamedBinds + -> Bool -> Bool -> RenamedHsBinds mk_binds bs ss True False = SingleBind (RecBind bs) mk_binds bs ss True True{-have sigs-} = BindWith (RecBind bs) ss @@ -500,17 +507,17 @@ mkEdges vertices flat_info %* * %************************************************************************ -@rnBindSigs4@ checks for: (a)~more than one sig for one thing; +@rnBindSigs@ checks for: (a)~more than one sig for one thing; (b)~signatures given for things not bound here; (c)~with suitably flaggery, that all top-level things have type signatures. \begin{code} -rnBindSigs4 :: Bool -- True <=> top-level binders +rnBindSigs :: Bool -- True <=> top-level binders -> [ProtoName] -- Binders for this decl group - -> [ProtoNameSig] + -> [ProtoNameSig] -> Rn4M [RenamedSig] -- List of Sig constructors -rnBindSigs4 is_toplev binder_pnames sigs +rnBindSigs is_toplev binder_pnames sigs = -- Rename the signatures -- Will complain about sigs for variables not in this group @@ -521,14 +528,13 @@ rnBindSigs4 is_toplev binder_pnames sigs -- Discard unbound ones we've already complained about, so we -- complain about duplicate ones. - (goodies, dups) = removeDups cmp (filter not_unbound sigs') + (goodies, dups) = removeDups compare (filter not_unbound sigs') in mapRn4 (addErrRn4 . dupSigDeclErr) dups `thenRn4_` - getSwitchCheckerRn4 `thenRn4` \ sw_chkr -> getSrcLocRn4 `thenRn4` \ locn -> - (if (is_toplev && sw_chkr SigsRequired) then + (if (is_toplev && opt_SigsRequired) then let sig_frees = catMaybes (map (sig_free sigs) binder_pnames) in @@ -548,9 +554,9 @@ rnBindSigs4 is_toplev binder_pnames sigs returnRn4 Nothing else lookupValue v `thenRn4` \ new_v -> - rnPolyType4 False True nullTyVarNamesEnv ty `thenRn4` \ new_ty -> - recoverQuietlyRn4 NoGenPragmas ( - rnGenPragmas4 pragma + rnPolyType False nullTyVarNamesEnv ty `thenRn4` \ new_ty -> + recoverQuietlyRn4 noGenPragmas ( + rnGenPragmas pragma ) `thenRn4` \ new_pragma -> returnRn4 (Just (Sig new_v new_ty new_pragma src_loc)) ) @@ -565,7 +571,7 @@ rnBindSigs4 is_toplev binder_pnames sigs returnRn4 Nothing else lookupValue v `thenRn4` \ new_v -> - rnPolyType4 False True nullTyVarNamesEnv ty `thenRn4` \ new_ty -> + rnPolyType False nullTyVarNamesEnv ty `thenRn4` \ new_ty -> rn_using using `thenRn4` \ new_using -> returnRn4 (Just (SpecSig new_v new_ty new_using src_loc)) ) @@ -574,7 +580,7 @@ rnBindSigs4 is_toplev binder_pnames sigs rn_using (Just x) = lookupValue x `thenRn4` \ new_x -> returnRn4 (Just new_x) - rename_sig (InlineSig v howto src_loc) + rename_sig (InlineSig v src_loc) = pushSrcLocRn4 src_loc ( if not (v `elemByLocalNames` binder_pnames) then @@ -582,7 +588,7 @@ rnBindSigs4 is_toplev binder_pnames sigs returnRn4 Nothing else lookupValue v `thenRn4` \ new_v -> - returnRn4 (Just (InlineSig new_v howto src_loc)) + returnRn4 (Just (InlineSig new_v src_loc)) ) rename_sig (DeforestSig v src_loc) @@ -611,7 +617,7 @@ rnBindSigs4 is_toplev binder_pnames sigs not_unbound (Sig n _ _ _) = not (isUnboundName n) not_unbound (SpecSig n _ _ _) = not (isUnboundName n) - not_unbound (InlineSig n _ _) = not (isUnboundName n) + not_unbound (InlineSig n _) = not (isUnboundName n) not_unbound (DeforestSig n _) = not (isUnboundName n) not_unbound (MagicUnfoldingSig n _ _) = not (isUnboundName n) @@ -626,19 +632,20 @@ rnBindSigs4 is_toplev binder_pnames sigs sig_free (_ : rest) ny = sig_free rest ny ------------------------------------- - cmp :: RenamedSig -> RenamedSig -> TAG_ + compare :: RenamedSig -> RenamedSig -> TAG_ + compare x y = c x y - cmp (Sig n1 _ _ _) (Sig n2 _ _ _) = n1 `cmpName` n2 - cmp (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 `cmpName` n2 - cmp (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmpName` n2 - cmp (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _) + c (Sig n1 _ _ _) (Sig n2 _ _ _) = n1 `cmp` n2 + c (InlineSig n1 _) (InlineSig n2 _) = n1 `cmp` n2 + c (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmp` n2 + c (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _) = -- may have many specialisations for one value; -- but not ones that are exactly the same... - case (n1 `cmpName` n2) of - EQ_ -> cmpPolyType cmpName ty1 ty2 + case (n1 `cmp` n2) of + EQ_ -> cmpPolyType cmp ty1 ty2 other -> other - cmp other_1 other_2 -- tags *must* be different + c other_1 other_2 -- tags *must* be different = let tag1 = tag other_1 tag2 = tag other_2 in @@ -646,8 +653,59 @@ rnBindSigs4 is_toplev binder_pnames sigs tag (Sig n1 _ _ _) = (ILIT(1) :: FAST_INT) tag (SpecSig n1 _ _ _) = ILIT(2) - tag (InlineSig n1 _ _) = ILIT(3) + tag (InlineSig n1 _) = ILIT(3) tag (MagicUnfoldingSig n1 _ _) = ILIT(4) tag (DeforestSig n1 _) = ILIT(5) - tag _ = case (panic "tag(RenameBinds4)") of { s -> tag s } -- BUG avoidance + tag _ = panic# "tag(RnBinds4)" +\end{code} + +%************************************************************************ +%* * +\subsection{Error messages} +%* * +%************************************************************************ + +\begin{code} +dupSigDeclErr sigs + = let + undup_sigs = fst (removeDups cmp_sig sigs) + in + addErrLoc locn1 + ("more than one "++what_it_is++"\n\thas been given for these variables") ( \ sty -> + ppAboves (map (ppr sty) undup_sigs) ) + where + (what_it_is, locn1) + = case (head sigs) of + Sig _ _ _ loc -> ("type signature",loc) + ClassOpSig _ _ _ loc -> ("class-method type signature", loc) + SpecSig _ _ _ loc -> ("SPECIALIZE pragma",loc) + InlineSig _ loc -> ("INLINE pragma",loc) + MagicUnfoldingSig _ _ loc -> ("MAGIC_UNFOLDING pragma",loc) + + cmp_sig a b = get_name a `cmp` get_name b + + get_name (Sig n _ _ _) = n + get_name (ClassOpSig n _ _ _) = n + get_name (SpecSig n _ _ _) = n + get_name (InlineSig n _) = n + get_name (MagicUnfoldingSig n _ _) = n + +------------------------ +methodBindErr mbind locn + = addErrLoc locn "Can't handle multiple methods defined by one pattern binding" + (\ sty -> ppr sty mbind) + +-------------------------- +missingSigErr locn var + = addShortErrLocLine locn ( \ sty -> + ppBesides [ppStr "a definition but no type signature for `", + ppr sty var, + ppStr "'."]) + +-------------------------------- +unknownSigDeclErr flavor var locn + = addShortErrLocLine locn ( \ sty -> + ppBesides [ppStr flavor, ppStr " but no definition for `", + ppr sty var, + ppStr "'."]) \end{code} diff --git a/ghc/compiler/rename/RnExpr4.lhs b/ghc/compiler/rename/RnExpr4.lhs new file mode 100644 index 0000000000..21f5346e22 --- /dev/null +++ b/ghc/compiler/rename/RnExpr4.lhs @@ -0,0 +1,407 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% +\section[RnExpr4]{Renaming of expressions (pass 4)} + +Basically dependency analysis. + +Handles @Match@, @GRHSsAndBinds@, @HsExpr@, and @Qual@ datatypes. In +general, all of these functions return a renamed thing, and a set of +free variables. + +\begin{code} +#include "HsVersions.h" + +module RnExpr4 ( + rnMatch, rnGRHSsAndBinds, rnPat + + -- and to make the interface self-sufficient... + ) where + +import Ubiq{-uitous-} +import RnLoop -- break the RnPass4/RnExpr4/RnBinds4 loops + +import HsSyn +import RdrHsSyn +import RnHsSyn +import RnMonad4 + +-- others: +import Name ( Name(..) ) +import NameTypes ( FullName{-instances-} ) +import Outputable ( isConop ) +import UniqSet ( emptyUniqSet, singletonUniqSet, + unionUniqSets, unionManyUniqSets, + UniqSet(..) + ) +import Util ( panic ) +\end{code} + + +********************************************************* +* * +\subsection{Patterns} +* * +********************************************************* + +\begin{code} +rnPat :: ProtoNamePat -> Rn4M RenamedPat + +rnPat WildPatIn = returnRn4 WildPatIn + +rnPat (VarPatIn name) + = lookupValue name `thenRn4` \ vname -> + returnRn4 (VarPatIn vname) + +rnPat (LitPatIn n) = returnRn4 (LitPatIn n) + +rnPat (LazyPatIn pat) + = rnPat pat `thenRn4` \ pat' -> + returnRn4 (LazyPatIn pat') + +rnPat (AsPatIn name pat) + = rnPat pat `thenRn4` \ pat' -> + lookupValue name `thenRn4` \ vname -> + returnRn4 (AsPatIn vname pat') + +rnPat (ConPatIn name pats) + = lookupValue name `thenRn4` \ name' -> + mapRn4 rnPat pats `thenRn4` \ patslist -> + returnRn4 (ConPatIn name' patslist) + +rnPat (ConOpPatIn pat1 name pat2) + = lookupValue name `thenRn4` \ name' -> + rnPat pat1 `thenRn4` \ pat1' -> + rnPat pat2 `thenRn4` \ pat2' -> + returnRn4 (ConOpPatIn pat1' name' pat2') + +rnPat (ListPatIn pats) + = mapRn4 rnPat pats `thenRn4` \ patslist -> + returnRn4 (ListPatIn patslist) + +rnPat (TuplePatIn pats) + = mapRn4 rnPat pats `thenRn4` \ patslist -> + returnRn4 (TuplePatIn patslist) + +rnPat (RecPatIn con rpats) + = panic "rnPat:RecPatIn" + +\end{code} + +************************************************************************ +* * +\subsection{Match} +* * +************************************************************************ + +\begin{code} +rnMatch :: ProtoNameMatch -> Rn4M (RenamedMatch, FreeVars) + +rnMatch match + = getSrcLocRn4 `thenRn4` \ src_loc -> + namesFromProtoNames "variable in pattern" + (binders `zip` repeat src_loc) `thenRn4` \ new_binders -> + extendSS2 new_binders (rnMatch_aux match) + where + binders = collect_binders match + + collect_binders :: ProtoNameMatch -> [ProtoName] + + collect_binders (GRHSMatch _) = [] + collect_binders (PatMatch pat match) + = collectPatBinders pat ++ collect_binders match + +rnMatch_aux (PatMatch pat match) + = rnPat pat `thenRn4` \ pat' -> + rnMatch_aux match `thenRn4` \ (match', fvMatch) -> + returnRn4 (PatMatch pat' match', fvMatch) + +rnMatch_aux (GRHSMatch grhss_and_binds) + = rnGRHSsAndBinds grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) -> + returnRn4 (GRHSMatch grhss_and_binds', fvs) +\end{code} + +%************************************************************************ +%* * +\subsubsection{Guarded right-hand sides (GRHSsAndBinds)} +%* * +%************************************************************************ + +\begin{code} +rnGRHSsAndBinds :: ProtoNameGRHSsAndBinds -> Rn4M (RenamedGRHSsAndBinds, FreeVars) + +rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds) + = rnBinds binds `thenRn4` \ (binds', fvBinds, scope) -> + extendSS2 scope (rnGRHSs grhss) `thenRn4` \ (grhss', fvGRHS) -> + returnRn4 (GRHSsAndBindsIn grhss' binds', fvBinds `unionUniqSets` fvGRHS) + where + rnGRHSs [] = returnRn4 ([], emptyUniqSet) + + rnGRHSs (grhs:grhss) + = rnGRHS grhs `thenRn4` \ (grhs', fvs) -> + rnGRHSs grhss `thenRn4` \ (grhss', fvss) -> + returnRn4 (grhs' : grhss', fvs `unionUniqSets` fvss) + + rnGRHS (GRHS guard expr locn) + = pushSrcLocRn4 locn ( + rnExpr guard `thenRn4` \ (guard', fvsg) -> + rnExpr expr `thenRn4` \ (expr', fvse) -> + returnRn4 (GRHS guard' expr' locn, fvsg `unionUniqSets` fvse) + ) + + rnGRHS (OtherwiseGRHS expr locn) + = pushSrcLocRn4 locn ( + rnExpr expr `thenRn4` \ (expr', fvs) -> + returnRn4 (OtherwiseGRHS expr' locn, fvs) + ) +\end{code} + +%************************************************************************ +%* * +\subsubsection{Expressions} +%* * +%************************************************************************ + +\begin{code} +rnExprs :: [ProtoNameHsExpr] -> Rn4M ([RenamedHsExpr], FreeVars) + +rnExprs [] = returnRn4 ([], emptyUniqSet) + +rnExprs (expr:exprs) + = rnExpr expr `thenRn4` \ (expr', fvExpr) -> + rnExprs exprs `thenRn4` \ (exprs', fvExprs) -> + returnRn4 (expr':exprs', fvExpr `unionUniqSets` fvExprs) +\end{code} + +Variables. We look up the variable and return the resulting name. The +interesting question is what the free-variable set should be. We +don't want to return imported or prelude things as free vars. So we +look at the Name returned from the lookup, and make it part of the +free-var set iff: +\begin{itemize} +\item +if it's a @Short@, +\item +or it's an @ValName@ and it's defined in this module +(this includes locally-defined constructrs, but that's too bad) +\end{itemize} + +\begin{code} +rnExpr :: ProtoNameHsExpr -> Rn4M (RenamedHsExpr, FreeVars) + +rnExpr (HsVar v) + = lookupValue v `thenRn4` \ vname -> + returnRn4 (HsVar vname, fv_set vname) + where + fv_set n@(Short uniq sname) = singletonUniqSet n + fv_set n@(ValName uniq fname) + | isLocallyDefined fname + && not (isConop (getOccurrenceName fname)) + = singletonUniqSet n + fv_set other = emptyUniqSet + +rnExpr (HsLit lit) = returnRn4 (HsLit lit, emptyUniqSet) + +rnExpr (HsLam match) + = rnMatch match `thenRn4` \ (match', fvMatch) -> + returnRn4 (HsLam match', fvMatch) + +rnExpr (HsApp fun arg) + = rnExpr fun `thenRn4` \ (fun',fvFun) -> + rnExpr arg `thenRn4` \ (arg',fvArg) -> + returnRn4 (HsApp fun' arg', fvFun `unionUniqSets` fvArg) + +rnExpr (OpApp e1 op e2) + = rnExpr e1 `thenRn4` \ (e1', fvs_e1) -> + rnExpr op `thenRn4` \ (op', fvs_op) -> + rnExpr e2 `thenRn4` \ (e2', fvs_e2) -> + returnRn4 (OpApp e1' op' e2', (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2) + +rnExpr (SectionL expr op) + = rnExpr expr `thenRn4` \ (expr', fvs_expr) -> + rnExpr op `thenRn4` \ (op', fvs_op) -> + returnRn4 (SectionL expr' op', fvs_op `unionUniqSets` fvs_expr) + +rnExpr (SectionR op expr) + = rnExpr op `thenRn4` \ (op', fvs_op) -> + rnExpr expr `thenRn4` \ (expr', fvs_expr) -> + returnRn4 (SectionR op' expr', fvs_op `unionUniqSets` fvs_expr) + +rnExpr (CCall fun args may_gc is_casm fake_result_ty) + = rnExprs args `thenRn4` \ (args', fvs_args) -> + returnRn4 (CCall fun args' may_gc is_casm fake_result_ty, fvs_args) + +rnExpr (HsSCC label expr) + = rnExpr expr `thenRn4` \ (expr', fvs_expr) -> + returnRn4 (HsSCC label expr', fvs_expr) + +rnExpr (HsCase expr ms src_loc) + = pushSrcLocRn4 src_loc $ + rnExpr expr `thenRn4` \ (new_expr, e_fvs) -> + mapAndUnzipRn4 rnMatch ms `thenRn4` \ (new_ms, ms_fvs) -> + returnRn4 (HsCase new_expr new_ms src_loc, unionManyUniqSets (e_fvs : ms_fvs)) + +rnExpr (HsLet binds expr) + = rnBinds binds `thenRn4` \ (binds', fvBinds, new_binders) -> + extendSS2 new_binders (rnExpr expr) `thenRn4` \ (expr',fvExpr) -> + returnRn4 (HsLet binds' expr', fvBinds `unionUniqSets` fvExpr) + +rnExpr (HsDo stmts src_loc) + = pushSrcLocRn4 src_loc $ + rnStmts stmts `thenRn4` \ (stmts', fvStmts) -> + returnRn4 (HsDo stmts' src_loc, fvStmts) + +rnExpr (ListComp expr quals) + = rnQuals quals `thenRn4` \ ((quals', qual_binders), fvQuals) -> + extendSS2 qual_binders (rnExpr expr) `thenRn4` \ (expr', fvExpr) -> + returnRn4 (ListComp expr' quals', fvExpr `unionUniqSets` fvQuals) + +rnExpr (ExplicitList exps) + = rnExprs exps `thenRn4` \ (exps', fvs) -> + returnRn4 (ExplicitList exps', fvs) + +rnExpr (ExplicitTuple exps) + = rnExprs exps `thenRn4` \ (exps', fvExps) -> + returnRn4 (ExplicitTuple exps', fvExps) + +rnExpr (RecordCon con rbinds) + = panic "rnExpr:RecordCon" +rnExpr (RecordUpd exp rbinds) + = panic "rnExpr:RecordUpd" + +rnExpr (ExprWithTySig expr pty) + = rnExpr expr `thenRn4` \ (expr', fvExpr) -> + rnPolyType False nullTyVarNamesEnv pty `thenRn4` \ pty' -> + returnRn4 (ExprWithTySig expr' pty', fvExpr) + +rnExpr (HsIf p b1 b2 src_loc) + = pushSrcLocRn4 src_loc $ + rnExpr p `thenRn4` \ (p', fvP) -> + rnExpr b1 `thenRn4` \ (b1', fvB1) -> + rnExpr b2 `thenRn4` \ (b2', fvB2) -> + returnRn4 (HsIf p' b1' b2' src_loc, unionManyUniqSets [fvP, fvB1, fvB2]) + +rnExpr (ArithSeqIn seq) + = rn_seq seq `thenRn4` \ (new_seq, fvs) -> + returnRn4 (ArithSeqIn new_seq, fvs) + where + rn_seq (From expr) + = rnExpr expr `thenRn4` \ (expr', fvExpr) -> + returnRn4 (From expr', fvExpr) + + rn_seq (FromThen expr1 expr2) + = rnExpr expr1 `thenRn4` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenRn4` \ (expr2', fvExpr2) -> + returnRn4 (FromThen expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2) + + rn_seq (FromTo expr1 expr2) + = rnExpr expr1 `thenRn4` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenRn4` \ (expr2', fvExpr2) -> + returnRn4 (FromTo expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2) + + rn_seq (FromThenTo expr1 expr2 expr3) + = rnExpr expr1 `thenRn4` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenRn4` \ (expr2', fvExpr2) -> + rnExpr expr3 `thenRn4` \ (expr3', fvExpr3) -> + returnRn4 (FromThenTo expr1' expr2' expr3', + unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3]) + +\end{code} + +%************************************************************************ +%* * +\subsubsection{@Qual@s: in list comprehensions} +%* * +%************************************************************************ + +Note that although some bound vars may appear in the free var set for +the first qual, these will eventually be removed by the caller. For +example, if we have @[p | r <- s, q <- r, p <- q]@, when doing +@[q <- r, p <- q]@, the free var set for @q <- r@ will +be @{r}@, and the free var set for the entire Quals will be @{r}@. This +@r@ will be removed only when we finally return from examining all the +Quals. + +\begin{code} +rnQuals :: [ProtoNameQual] + -> Rn4M (([RenamedQual], -- renamed qualifiers + [Name]), -- qualifiers' binders + FreeVars) -- free variables + +rnQuals [qual] -- must be at least one qual + = rnQual qual `thenRn4` \ ((new_qual, bs), fvs) -> + returnRn4 (([new_qual], bs), fvs) + +rnQuals (qual: quals) + = rnQual qual `thenRn4` \ ((qual', bs1), fvQuals1) -> + extendSS2 bs1 (rnQuals quals) `thenRn4` \ ((quals', bs2), fvQuals2) -> + returnRn4 + ((qual' : quals', bs2 ++ bs1), -- The ones on the right (bs2) shadow the + -- ones on the left (bs1) + fvQuals1 `unionUniqSets` fvQuals2) + +rnQual (GeneratorQual pat expr) + = rnExpr expr `thenRn4` \ (expr', fvExpr) -> + let + binders = collectPatBinders pat + in + getSrcLocRn4 `thenRn4` \ src_loc -> + namesFromProtoNames "variable in list-comprehension-generator pattern" + (binders `zip` repeat src_loc) `thenRn4` \ new_binders -> + extendSS new_binders (rnPat pat) `thenRn4` \ pat' -> + + returnRn4 ((GeneratorQual pat' expr', new_binders), fvExpr) + +rnQual (FilterQual expr) + = rnExpr expr `thenRn4` \ (expr', fvs) -> + returnRn4 ((FilterQual expr', []), fvs) + +rnQual (LetQual binds) + = rnBinds binds `thenRn4` \ (binds', binds_fvs, new_binders) -> + returnRn4 ((LetQual binds', new_binders), binds_fvs) +\end{code} + + +%************************************************************************ +%* * +\subsubsection{@Stmt@s: in @do@ expressions} +%* * +%************************************************************************ + +\begin{code} +rnStmts :: [ProtoNameStmt] + -> Rn4M ([RenamedStmt], -- renamed qualifiers + FreeVars) -- free variables + +rnStmts [stmt@(ExprStmt _ _)] -- last stmt must be ExprStmt + = rnStmt stmt `thenRn4` \ ((stmt',[]), fvStmt) -> + returnRn4 ([stmt'], fvStmt) + +rnStmts (stmt:stmts) + = rnStmt stmt `thenRn4` \ ((stmt',bs), fvStmt) -> + extendSS2 bs (rnStmts stmts) `thenRn4` \ (stmts', fvStmts) -> + returnRn4 (stmt':stmts', fvStmt `unionUniqSets` fvStmts) + + +rnStmt (BindStmt pat expr src_loc) + = pushSrcLocRn4 src_loc $ + rnExpr expr `thenRn4` \ (expr', fvExpr) -> + let + binders = collectPatBinders pat + in + namesFromProtoNames "variable in do binding" + (binders `zip` repeat src_loc) `thenRn4` \ new_binders -> + extendSS new_binders (rnPat pat) `thenRn4` \ pat' -> + + returnRn4 ((BindStmt pat' expr' src_loc, new_binders), fvExpr) + +rnStmt (ExprStmt expr src_loc) + = + rnExpr expr `thenRn4` \ (expr', fvs) -> + returnRn4 ((ExprStmt expr' src_loc, []), fvs) + +rnStmt (LetStmt binds) + = rnBinds binds `thenRn4` \ (binds', binds_fvs, new_binders) -> + returnRn4 ((LetStmt binds', new_binders), binds_fvs) + +\end{code} diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs new file mode 100644 index 0000000000..b141a30294 --- /dev/null +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -0,0 +1,60 @@ +% +% (c) The AQUA Project, Glasgow University, 1996 +% +\section[RnHsSyn]{Specialisations of the @HsSyn@ syntax for the renamer} + +\begin{code} +#include "HsVersions.h" + +module RnHsSyn where + +import Ubiq{-uitous-} + +import HsSyn +\end{code} + +\begin{code} +type RenamedArithSeqInfo = ArithSeqInfo Fake Fake Name RenamedPat +type RenamedBind = Bind Fake Fake Name RenamedPat +type RenamedClassDecl = ClassDecl Fake Fake Name RenamedPat +type RenamedClassOpPragmas = ClassOpPragmas Name +type RenamedClassOpSig = Sig Name +type RenamedClassPragmas = ClassPragmas Name +type RenamedConDecl = ConDecl Name +type RenamedContext = Context Name +type RenamedDataPragmas = DataPragmas Name +type RenamedSpecDataSig = SpecDataSig Name +type RenamedDefaultDecl = DefaultDecl Name +type RenamedFixityDecl = FixityDecl Name +type RenamedGRHS = GRHS Fake Fake Name RenamedPat +type RenamedGRHSsAndBinds = GRHSsAndBinds Fake Fake Name RenamedPat +type RenamedGenPragmas = GenPragmas Name +type RenamedHsBinds = HsBinds Fake Fake Name RenamedPat +type RenamedHsExpr = HsExpr Fake Fake Name RenamedPat +type RenamedHsModule = HsModule Fake Fake Name RenamedPat +type RenamedImportedInterface = ImportedInterface Fake Fake Name RenamedPat +type RenamedInstDecl = InstDecl Fake Fake Name RenamedPat +type RenamedInstancePragmas = InstancePragmas Name +type RenamedInterface = Interface Fake Fake Name RenamedPat +type RenamedMatch = Match Fake Fake Name RenamedPat +type RenamedMonoBinds = MonoBinds Fake Fake Name RenamedPat +type RenamedMonoType = MonoType Name +type RenamedPat = InPat Name +type RenamedPolyType = PolyType Name +type RenamedQual = Qual Fake Fake Name RenamedPat +type RenamedSig = Sig Name +type RenamedSpecInstSig = SpecInstSig Name +type RenamedStmt = Stmt Fake Fake Name RenamedPat +type RenamedTyDecl = TyDecl Name +\end{code} + +\begin{code} +collectQualBinders :: [RenamedQual] -> [Name] + +collectQualBinders quals + = concat (map collect quals) + where + collect (GeneratorQual pat _) = collectPatBinders pat + collect (FilterQual expr) = [] + collect (LetQual binds) = collectTopLevelBinders binds +\end{code} diff --git a/ghc/compiler/rename/RnLoop.lhi b/ghc/compiler/rename/RnLoop.lhi new file mode 100644 index 0000000000..92b7d418b6 --- /dev/null +++ b/ghc/compiler/rename/RnLoop.lhi @@ -0,0 +1,22 @@ +Breaks the RnPass4/RnExpr4/RnBind4 loops. + +\begin{code} +interface RnLoop where + +import Name ( Name ) +import RdrHsSyn ( ProtoNameHsBinds(..), ProtoNamePolyType(..), ProtoNameGenPragmas(..) ) +import RnHsSyn ( RenamedHsBinds(..), RenamedPolyType(..), RenamedGenPragmas(..) ) +import RnBinds4 ( rnBinds, FreeVars(..) ) +import RnMonad4 ( TyVarNamesEnv(..), Rn4M(..) ) +import RnPass4 ( rnPolyType, rnGenPragmas ) +import UniqSet ( UniqSet(..) ) + +rnBinds :: ProtoNameHsBinds -> Rn4M (RenamedHsBinds, FreeVars, [Name]) +rnGenPragmas :: ProtoNameGenPragmas -> Rn4M RenamedGenPragmas +rnPolyType :: Bool + -> TyVarNamesEnv + -> ProtoNamePolyType + -> Rn4M RenamedPolyType + +type FreeVars = UniqSet Name +\end{code} diff --git a/ghc/compiler/rename/RenameMonad12.lhs b/ghc/compiler/rename/RnMonad12.lhs index b60f2932b4..bfb7814657 100644 --- a/ghc/compiler/rename/RenameMonad12.lhs +++ b/ghc/compiler/rename/RnMonad12.lhs @@ -1,26 +1,25 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % -\section[RenameMonad12]{The monad used by the renamer passes 1 and 2} +\section[RnMonad12]{The monad used by the renamer passes 1 and 2} \begin{code} #include "HsVersions.h" -module RenameMonad12 ( +module RnMonad12 ( Rn12M(..), initRn12, thenRn12, returnRn12, mapRn12, zipWithRn12, foldrRn12, - addErrRn12, getModuleNameRn12, recoverQuietlyRn12, + addErrRn12, getModuleNameRn12, recoverQuietlyRn12 -- and to make the interface self-sufficient... - Bag, Pretty(..), PprStyle, PrettyRep ) where -import Bag -import Errors -import Outputable -import Pretty -- for type Pretty -import Util -- for pragmas only +import Ubiq{-uitous-} + +import Bag ( emptyBag, isEmptyBag, snocBag, Bag ) +import ErrUtils ( Error(..) ) +import Pretty ( Pretty(..) ) infixr 9 `thenRn12` \end{code} @@ -34,10 +33,8 @@ type Rn12M result -> Bag Error -> (result, Bag Error) -#ifdef __GLASGOW_HASKELL__ {-# INLINE thenRn12 #-} {-# INLINE returnRn12 #-} -#endif initRn12 :: FAST_STRING{-module name-} -> Rn12M a -> (a, Bag Error) initRn12 mod action = action mod emptyBag @@ -65,6 +62,8 @@ zipWithRn12 f (x:xs) (y:ys) = f x y `thenRn12` \ r -> zipWithRn12 f xs ys `thenRn12` \ rs -> returnRn12 (r:rs) +-- NB: zipWithRn12 behaves like zipWithEqual +-- (requires equal-length lists) foldrRn12 :: (a -> b -> Rn12M b) -> b -> [a] -> Rn12M b diff --git a/ghc/compiler/rename/RenameMonad3.lhs b/ghc/compiler/rename/RnMonad3.lhs index b9eddf94d3..ca69b1d575 100644 --- a/ghc/compiler/rename/RenameMonad3.lhs +++ b/ghc/compiler/rename/RnMonad3.lhs @@ -1,59 +1,56 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % -\section[RenameMonad3]{The monad used by the third renamer pass} +\section[RnMonad3]{The monad used by the third renamer pass} \begin{code} #include "HsVersions.h" -module RenameMonad3 ( +module RnMonad3 ( Rn3M(..), initRn3, thenRn3, andRn3, returnRn3, mapRn3, fixRn3, putInfoDownM3, - newFullNameM3, newInvisibleNameM3, + newFullNameM3, newInvisibleNameM3 -- for completeness - IE, FullName, ExportFlag, ProtoName, Unique, - SplitUniqSupply - IF_ATTACK_PRAGMAS(COMMA splitUniqSupply) ) where -import AbsSyn -- including, IE, getIEStrings, ... -import FiniteMap -import Maybes ( Maybe(..), assocMaybe ) -import NameTypes -import Outputable -import ProtoName -import RenameMonad4 ( GlobalNameFun(..) ) -import SplitUniq -import Unique -import Util +import Ubiq{-uitous-} + +import FiniteMap ( emptyFM, isEmptyFM, lookupFM, + emptySet, isEmptySet, elementOf + ) +import HsSyn ( IE ) +import NameTypes -- lots of stuff +import Outputable ( ExportFlag(..) ) +import ProtoName ( ProtoName(..) ) +import RdrHsSyn ( getExportees, ExportListInfo(..), ProtoNameIE(..) ) +import UniqSupply ( getUnique, splitUniqSupply ) +import Util ( panic ) infixr 9 `thenRn3` \end{code} %************************************************************************ %* * -\subsection{Plain @Rename3@ monadery} +\subsection{Plain @RnPass3@ monadery} %* * %************************************************************************ \begin{code} type Rn3M result - = ImExportListInfo -> FAST_STRING{-ModuleName-} -> SplitUniqSupply + = ExportListInfo -> FAST_STRING{-ModuleName-} -> UniqSupply -> result -#ifdef __GLASGOW_HASKELL__ {-# INLINE andRn3 #-} {-# INLINE thenRn3 #-} {-# INLINE returnRn3 #-} -#endif -initRn3 :: Rn3M a -> SplitUniqSupply -> a +initRn3 :: Rn3M a -> UniqSupply -> a -initRn3 m us = m (emptyFM,emptySet) (panic "initRn3: uninitialised module name") us +initRn3 m us = m Nothing{-no export list-} (panic "initRn3: uninitialised module name") us thenRn3 :: Rn3M a -> (a -> Rn3M b) -> Rn3M b andRn3 :: (a -> a -> a) -> Rn3M a -> Rn3M a -> Rn3M a @@ -87,15 +84,15 @@ fixRn3 m exps mod_name us where result = m result exps mod_name us -putInfoDownM3 :: FAST_STRING{-ModuleName-} -> [IE] -> Rn3M a -> Rn3M a +putInfoDownM3 :: FAST_STRING{-ModuleName-} -> Maybe [ProtoNameIE] -> Rn3M a -> Rn3M a putInfoDownM3 mod_name exports cont _ _ uniqs - = cont (getIEStrings exports) mod_name uniqs + = cont (getExportees exports) mod_name uniqs \end{code} %************************************************************************ %* * -\subsection[RenameMonad3-new-names]{Making new names} +\subsection[RnMonad3-new-names]{Making new names} %* * %************************************************************************ @@ -121,23 +118,35 @@ newInvisibleNameM3 pn src_loc is_tycon_ish frcd_exp exps mod_name uniqs new_name pn src_loc is_tycon_ish frcd_export_flag want_invisible exps mod_name uniqs = (uniq, name) where - uniq = getSUnique uniqs + uniq = getUnique uniqs mk_name = if want_invisible then mkPrivateFullName else mkFullName name = case pn of - Unk s -> mk_name mod_name s - (if fromPrelude mod_name - && is_tycon_ish then -- & tycon/clas/datacon => Core - HereInPreludeCore - else - ThisModule - ) - (case frcd_export_flag of - Just fl -> fl - Nothing -> mk_export_flag True [mod_name] s exps) - src_loc + Unk s -> mk_name mod_name s + (if fromPrelude mod_name + && is_tycon_ish then -- & tycon/clas/datacon => Core + HereInPreludeCore + else + ThisModule + ) + (case frcd_export_flag of + Just fl -> fl + Nothing -> mk_export_flag True [mod_name] s exps) + src_loc + + Qunk m s -> mk_name mod_name s + (if fromPrelude mod_name + && is_tycon_ish then -- & tycon/clas/datacon => Core + HereInPreludeCore + else + ThisModule + ) + (case frcd_export_flag of + Just fl -> fl + Nothing -> mk_export_flag (_trace "mk_export_flag?" True) [m] s exps) + src_loc -- note: the assigning of prelude-ness is most dubious (ToDo) @@ -154,11 +163,11 @@ new_name pn src_loc is_tycon_ish frcd_export_flag want_invisible exps mod_name u OtherModule l informant_mods -- for Other*, we save its occurrence name ) (case frcd_export_flag of - Just fl -> fl + Just fl -> fl Nothing -> mk_export_flag (m==mod_name) informant_mods l exps) src_loc - Prel n -> panic "RenameMonad3.new_name: prelude name" + Prel n -> panic "RnMonad3.new_name: prelude name" \end{code} In deciding the ``exportness'' of something, there are these cases to @@ -182,15 +191,15 @@ It isn't exported. \begin{code} mk_export_flag :: Bool -- True <=> originally from the module we're compiling - -> [FAST_STRING] -- modules that told us about this thing + -> [FAST_STRING]-- modules that told us about this thing -> FAST_STRING -- name of the thing we're looking at - -> ImExportListInfo + -> ExportListInfo -> ExportFlag -- result -mk_export_flag this_module informant_mods thing (exports_alist, dotdot_modules) - | isEmptyFM exports_alist && isEmptySet dotdot_modules +mk_export_flag this_module informant_mods thing Nothing{-no export list-} = if this_module then ExportAll else NotExported +mk_export_flag this_module informant_mods thing (Just (exports_alist, dotdot_modules)) | otherwise = case (lookupFM exports_alist thing) of Just how_to_export -> how_to_export diff --git a/ghc/compiler/rename/RenameMonad4.lhs b/ghc/compiler/rename/RnMonad4.lhs index 68e6ce47b4..a9e2e37099 100644 --- a/ghc/compiler/rename/RenameMonad4.lhs +++ b/ghc/compiler/rename/RnMonad4.lhs @@ -1,18 +1,17 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % -\section[RenameMonad4]{The monad used by the fourth renamer pass} +\section[RnMonad4]{The monad used by the fourth renamer pass} \begin{code} #include "HsVersions.h" -module RenameMonad4 ( +module RnMonad4 ( Rn4M(..), initRn4, thenRn4, thenRn4_, andRn4, returnRn4, mapRn4, mapAndUnzipRn4, addErrRn4, failButContinueRn4, recoverQuietlyRn4, pushSrcLocRn4, getSrcLocRn4, - getSwitchCheckerRn4, lookupValue, lookupValueEvenIfInvisible, lookupClassOp, lookupFixityOp, lookupTyCon, lookupTyConEvenIfInvisible, @@ -21,46 +20,36 @@ module RenameMonad4 ( namesFromProtoNames, TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv, - lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs, + lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs -- for completeness - Module, Bag, RenamedPat(..), InPat, Maybe, Name, Error(..), - Pretty(..), PprStyle, PrettyRep, ProtoName, GlobalSwitch, - GlobalNameFun(..), GlobalNameFuns(..), UniqSet(..), UniqFM, SrcLoc, - Unique, SplitUniqSupply - IF_ATTACK_PRAGMAS(COMMA splitUniqSupply) ) where -IMPORT_Trace -- ToDo: rm (debugging) -import Pretty -import Outputable +import Ubiq{-uitous-} -import AbsSyn -import Bag -import CmdLineOpts ( GlobalSwitch(..) ) -import Errors ( dupNamesErr, unknownNameErr, shadowedNameErr, - badClassOpErr, Error(..) - ) -import FiniteMap ( lookupFM, addToFM, addListToFM, emptyFM, FiniteMap ) -import Maybes ( Maybe(..), assocMaybe ) -import Name ( isTyConName, isClassName, isClassOpName, - isUnboundName, invisibleName +import Bag ( emptyBag, isEmptyBag, unionBags, snocBag, Bag ) +import CmdLineOpts ( opt_ShowPragmaNameErrs, opt_NameShadowingNotOK ) +import ErrUtils +import FiniteMap ( emptyFM, addListToFM, addToFM, lookupFM ) +import Name ( invisibleName, isTyConName, isClassName, + isClassOpName, isUnboundName, Name(..) ) -import NameTypes ( mkShortName, ShortName ) -import ProtoName -- lots of stuff -import RenameAuxFuns -- oh, why not ... all of it -import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) -import SplitUniq -import UniqSet -import Unique -import Util +import NameTypes ( mkShortName, ShortName{-instances-} ) +import Outputable ( pprNonOp ) +import Pretty +import ProtoName ( eqProtoName, cmpByLocalName, ProtoName(..) ) +import RnUtils ( dupNamesErr, GlobalNameMappers(..) ) +import SrcLoc ( mkUnknownSrcLoc, SrcLoc{-instance-} ) +import UniqSet ( mkUniqSet, minusUniqSet, UniqSet(..) ) +import UniqSupply ( getUniques, splitUniqSupply ) +import Util ( assoc, removeDups, zipWithEqual, panic ) infixr 9 `thenRn4`, `thenRn4_` \end{code} %************************************************************************ %* * -\subsection[RenameMonad]{Plain @Rename@ monadery} +\subsection[RnMonad4]{Plain @Rename@ monadery for pass~4} %* * %************************************************************************ @@ -68,72 +57,68 @@ infixr 9 `thenRn4`, `thenRn4_` type ScopeStack = FiniteMap FAST_STRING Name type Rn4M result - = (GlobalSwitch -> Bool) - -> GlobalNameFuns + = GlobalNameMappers -> ScopeStack -> Bag Error - -> SplitUniqSupply + -> UniqSupply -> SrcLoc -> (result, Bag Error) -#ifdef __GLASGOW_HASKELL__ {-# INLINE andRn4 #-} {-# INLINE thenRn4 #-} {-# INLINE thenLazilyRn4 #-} {-# INLINE thenRn4_ #-} {-# INLINE returnRn4 #-} -#endif -initRn4 :: (GlobalSwitch -> Bool) - -> GlobalNameFuns +initRn4 :: GlobalNameMappers -> Rn4M result - -> SplitUniqSupply + -> UniqSupply -> (result, Bag Error) -initRn4 sw_chkr gnfs renamer init_us - = renamer sw_chkr gnfs emptyFM emptyBag init_us mkUnknownSrcLoc +initRn4 gnfs renamer init_us + = renamer gnfs emptyFM emptyBag init_us mkUnknownSrcLoc thenRn4, thenLazilyRn4 :: Rn4M a -> (a -> Rn4M b) -> Rn4M b thenRn4_ :: Rn4M a -> Rn4M b -> Rn4M b andRn4 :: (a -> a -> a) -> Rn4M a -> Rn4M a -> Rn4M a -thenRn4 expr cont sw_chkr gnfs ss errs uniqs locn - = case (splitUniqSupply uniqs) of { (s1, s2) -> - case (expr sw_chkr gnfs ss errs s1 locn) of { (res1, errs1) -> - case (cont res1 sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) -> +thenRn4 expr cont gnfs ss errs uniqs locn + = case (splitUniqSupply uniqs) of { (s1, s2) -> + case (expr gnfs ss errs s1 locn) of { (res1, errs1) -> + case (cont res1 gnfs ss errs1 s2 locn) of { (res2, errs2) -> (res2, errs2) }}} -thenLazilyRn4 expr cont sw_chkr gnfs ss errs uniqs locn +thenLazilyRn4 expr cont gnfs ss errs uniqs locn = let (s1, s2) = splitUniqSupply uniqs - (res1, errs1) = expr sw_chkr gnfs ss errs s1 locn - (res2, errs2) = cont res1 sw_chkr gnfs ss errs1 s2 locn + (res1, errs1) = expr gnfs ss errs s1 locn + (res2, errs2) = cont res1 gnfs ss errs1 s2 locn in (res2, errs2) -thenRn4_ expr cont sw_chkr gnfs ss errs uniqs locn - = case (splitUniqSupply uniqs) of { (s1, s2) -> - case (expr sw_chkr gnfs ss errs s1 locn) of { (_, errs1) -> - case (cont sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) -> +thenRn4_ expr cont gnfs ss errs uniqs locn + = case (splitUniqSupply uniqs) of { (s1, s2) -> + case (expr gnfs ss errs s1 locn) of { (_, errs1) -> + case (cont gnfs ss errs1 s2 locn) of { (res2, errs2) -> (res2, errs2) }}} -andRn4 combiner m1 m2 sw_chkr gnfs ss errs us locn - = case (splitUniqSupply us) of { (s1, s2) -> - case (m1 sw_chkr gnfs ss errs s1 locn) of { (res1, errs1) -> - case (m2 sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) -> +andRn4 combiner m1 m2 gnfs ss errs us locn + = case (splitUniqSupply us) of { (s1, s2) -> + case (m1 gnfs ss errs s1 locn) of { (res1, errs1) -> + case (m2 gnfs ss errs1 s2 locn) of { (res2, errs2) -> (combiner res1 res2, errs2) }}} returnRn4 :: a -> Rn4M a -returnRn4 result sw_chkr gnfs ss errs_so_far uniqs locn +returnRn4 result gnfs ss errs_so_far uniqs locn = (result, errs_so_far) failButContinueRn4 :: a -> Error -> Rn4M a -failButContinueRn4 res err sw_chkr gnfs ss errs_so_far uniqs locn +failButContinueRn4 res err gnfs ss errs_so_far uniqs locn = (res, errs_so_far `snocBag` err) addErrRn4 :: Error -> Rn4M () -addErrRn4 err sw_chkr gnfs ss errs_so_far uniqs locn +addErrRn4 err gnfs ss errs_so_far uniqs locn = ((), errs_so_far `snocBag` err) \end{code} @@ -145,16 +130,16 @@ returning a triple immediately, no matter what. \begin{code} recoverQuietlyRn4 :: a -> Rn4M a -> Rn4M a -recoverQuietlyRn4 use_this_if_err action sw_chkr gnfs ss errs_so_far uniqs locn +recoverQuietlyRn4 use_this_if_err action gnfs ss errs_so_far uniqs locn = let (result, errs_out) - = case (action sw_chkr gnfs ss emptyBag{-leav out errs-} uniqs locn) of + = case (action gnfs ss emptyBag{-leav out errs-} uniqs locn) of (result1, errs1) -> if isEmptyBag errs1 then -- all's well! (but retain incoming errs) (result1, errs_so_far) else -- give up; return *incoming* UniqueSupply... (use_this_if_err, - if sw_chkr ShowPragmaNameErrs + if opt_ShowPragmaNameErrs then errs_so_far `unionBags` errs1 else errs_so_far) -- toss errs, otherwise in @@ -181,24 +166,19 @@ mapAndUnzipRn4 f (x:xs) \begin{code} pushSrcLocRn4 :: SrcLoc -> Rn4M a -> Rn4M a -pushSrcLocRn4 locn exp sw_chkr gnfs ss errs_so_far uniq_supply old_locn - = exp sw_chkr gnfs ss errs_so_far uniq_supply locn +pushSrcLocRn4 locn exp gnfs ss errs_so_far uniq_supply old_locn + = exp gnfs ss errs_so_far uniq_supply locn getSrcLocRn4 :: Rn4M SrcLoc -getSrcLocRn4 sw_chkr gnfs ss errs_so_far uniq_supply locn - = returnRn4 locn sw_chkr gnfs ss errs_so_far uniq_supply locn - -getSwitchCheckerRn4 :: Rn4M (GlobalSwitch -> Bool) - -getSwitchCheckerRn4 sw_chkr gnfs ss errs_so_far uniq_supply locn - = returnRn4 sw_chkr sw_chkr gnfs ss errs_so_far uniq_supply locn +getSrcLocRn4 gnfs ss errs_so_far uniq_supply locn + = returnRn4 locn gnfs ss errs_so_far uniq_supply locn \end{code} \begin{code} getNextUniquesFromRn4 :: Int -> Rn4M [Unique] -getNextUniquesFromRn4 n sw_chkr gnfs ss errs_so_far us locn - = case (getSUniques n us) of { next_uniques -> +getNextUniquesFromRn4 n gnfs ss errs_so_far us locn + = case (getUniques n us) of { next_uniques -> (next_uniques, errs_so_far) } \end{code} @@ -215,27 +195,27 @@ are distinct, and creates new full names for them. \begin{code} namesFromProtoNames :: String -- Documentation string -> [(ProtoName, SrcLoc)] - -> Rn4M [Name] + -> Rn4M [Name] -namesFromProtoNames kind pnames_w_src_loc sw_chkr gnfs ss errs_so_far us locn +namesFromProtoNames kind pnames_w_src_loc gnfs ss errs_so_far us locn = (mapRn4 (addErrRn4 . dupNamesErr kind) dups `thenRn4_` mkNewNames goodies - ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn + ) {-Rn4-} gnfs ss errs_so_far us locn where (goodies, dups) = removeDups cmp pnames_w_src_loc - -- We want to compare their local names rather than their + -- We want to compare their local names rather than their -- full protonames. It probably doesn't matter here, but it - -- does in Rename3.lhs! + -- does in RnPass3.lhs! cmp (a, _) (b, _) = cmpByLocalName a b \end{code} @mkNewNames@ assumes the names are unique. \begin{code} -mkNewNames :: [(ProtoName, SrcLoc)] -> Rn4M [Name] +mkNewNames :: [(ProtoName, SrcLoc)] -> Rn4M [Name] mkNewNames pnames_w_locs = getNextUniquesFromRn4 (length pnames_w_locs) `thenRn4` \ uniqs -> - returnRn4 (zipWith new_short_name uniqs pnames_w_locs) + returnRn4 (zipWithEqual new_short_name uniqs pnames_w_locs) where new_short_name uniq (Unk str, srcloc) -- gotta be an Unk... = Short uniq (mkShortName str srcloc) @@ -259,7 +239,8 @@ unboundName :: ProtoName -> Name unboundName pn = Unbound (grab_string pn) where - grab_string (Unk s) = s + grab_string (Unk s) = s + grab_string (Qunk _ s) = s grab_string (Imp _ _ _ s) = s \end{code} @@ -269,34 +250,36 @@ value is not visible to the user (e.g., came out of a pragma). @lookup_val@ is the help function to do the work. \begin{code} -lookupValue v {-Rn4-} sw_chkr gnfs ss errs_so_far us locn +lookupValue v {-Rn4-} gnfs ss errs_so_far us locn = (lookup_val v `thenLazilyRn4` \ name -> if invisibleName name then failButContinueRn4 (unboundName v) (unknownNameErr "value" v mkUnknownSrcLoc) else returnRn4 name - ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn + ) {-Rn4-} gnfs ss errs_so_far us locn lookupValueEvenIfInvisible v = lookup_val v lookup_val :: ProtoName -> Rn4M Name -lookup_val pname@(Unk v) sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn +lookup_val pname@(Unk v) gnfs@(v_gnf, tc_gnf) ss a b locn = case (lookupFM ss v) of - Just name -> returnRn4 name sw_chkr gnfs ss a b locn + Just name -> returnRn4 name gnfs ss a b locn Nothing -> case (v_gnf pname) of - Just name -> returnRn4 name sw_chkr gnfs ss a b locn + Just name -> returnRn4 name gnfs ss a b locn Nothing -> failButContinueRn4 (unboundName pname) (unknownNameErr "value" pname locn) - sw_chkr gnfs ss a b locn + gnfs ss a b locn + +lookup_val (Qunk _ _) _ _ _ _ _ = panic "RnMonad4:lookup_val:Qunk" -- If it ain't an Unk it must be in the global name fun; that includes -- prelude things. -lookup_val pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn +lookup_val pname gnfs@(v_gnf, tc_gnf) ss a b locn = case (v_gnf pname) of - Just name -> returnRn4 name sw_chkr gnfs ss a b locn + Just name -> returnRn4 name gnfs ss a b locn Nothing -> failButContinueRn4 (unboundName pname) (unknownNameErr "value" pname locn) - sw_chkr gnfs ss a b locn + gnfs ss a b locn \end{code} Looking up the operators in a fixity decl is done differently. We @@ -318,42 +301,42 @@ We're not going to export Prelude-related fixities (ToDo: correctly), so we nuke those, too. \begin{code} -lookupFixityOp (Prel _) sw_chkr gnfs@(v_gnf, tc_gnf) = returnRn4 Nothing sw_chkr gnfs -lookupFixityOp pname sw_chkr gnfs@(v_gnf, tc_gnf) = returnRn4 (v_gnf pname) sw_chkr gnfs +lookupFixityOp (Prel _) gnfs@(v_gnf, tc_gnf) = returnRn4 Nothing gnfs +lookupFixityOp pname gnfs@(v_gnf, tc_gnf) = returnRn4 (v_gnf pname) gnfs \end{code} \begin{code} lookupTyCon, lookupTyConEvenIfInvisible :: ProtoName -> Rn4M Name -- The global name funs handle Prel things -lookupTyCon tc {-Rn4-} sw_chkr gnfs ss errs_so_far us locn +lookupTyCon tc {-Rn4-} gnfs ss errs_so_far us locn = (lookup_tycon tc `thenLazilyRn4` \ name -> if invisibleName name then failButContinueRn4 (unboundName tc) (unknownNameErr "type constructor" tc mkUnknownSrcLoc) else returnRn4 name - ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn + ) {-Rn4-} gnfs ss errs_so_far us locn lookupTyConEvenIfInvisible tc = lookup_tycon tc -lookup_tycon (Prel name) sw_chkr gnfs ss a b locn = returnRn4 name sw_chkr gnfs ss a b locn +lookup_tycon (Prel name) gnfs ss a b locn = returnRn4 name gnfs ss a b locn -lookup_tycon pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn +lookup_tycon pname gnfs@(v_gnf, tc_gnf) ss a b locn = case (tc_gnf pname) of - Just name | isTyConName name -> returnRn4 name sw_chkr gnfs ss a b locn + Just name | isTyConName name -> returnRn4 name gnfs ss a b locn _ -> failButContinueRn4 (unboundName pname) (unknownNameErr "type constructor" pname locn) - sw_chkr gnfs ss a b locn + gnfs ss a b locn \end{code} \begin{code} lookupClass :: ProtoName -> Rn4M Name -lookupClass pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn +lookupClass pname gnfs@(v_gnf, tc_gnf) ss a b locn = case (tc_gnf pname) of - Just name | isClassName name -> returnRn4 name sw_chkr gnfs ss a b locn + Just name | isClassName name -> returnRn4 name gnfs ss a b locn _ -> failButContinueRn4 (unboundName pname) (unknownNameErr "class" pname locn) - sw_chkr gnfs ss a b locn + gnfs ss a b locn \end{code} @lookupClassOp@ is used when looking up the lhs identifiers in a class @@ -364,15 +347,15 @@ being looked at. \begin{code} lookupClassOp :: Name -> ProtoName -> Rn4M Name -lookupClassOp class_name pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn +lookupClassOp class_name pname gnfs@(v_gnf, tc_gnf) ss a b locn = case v_gnf pname of Just op_name | isClassOpName class_name op_name || isUnboundName class_name -- avoid spurious errors - -> returnRn4 op_name sw_chkr gnfs ss a b locn + -> returnRn4 op_name gnfs ss a b locn other -> failButContinueRn4 (unboundName pname) (badClassOpErr class_name pname locn) - sw_chkr gnfs ss a b locn + gnfs ss a b locn \end{code} @extendSS@ extends the scope; @extendSS2@ also removes the newly bound @@ -383,14 +366,14 @@ extendSS :: [Name] -- Newly bound names -> Rn4M a -> Rn4M a -extendSS binders expr sw_chkr gnfs ss errs us locn - = case (extend binders ss sw_chkr gnfs ss errs us locn) of { (new_ss, new_errs) -> - expr sw_chkr gnfs new_ss new_errs us locn } +extendSS binders expr gnfs ss errs us locn + = case (extend binders ss gnfs ss errs us locn) of { (new_ss, new_errs) -> + expr gnfs new_ss new_errs us locn } where extend :: [Name] -> ScopeStack -> Rn4M ScopeStack extend names ss - = if (sw_chkr NameShadowingNotOK) then + = if opt_NameShadowingNotOK then hard_way names ss else -- ignore shadowing; blast 'em in returnRn4 ( @@ -413,8 +396,8 @@ extendSS2 :: [Name] -- Newly bound names -> Rn4M (a, UniqSet Name) -> Rn4M (a, UniqSet Name) -extendSS2 binders expr sw_chkr gnfs ss errs_so_far us locn - = case (extendSS binders expr sw_chkr gnfs ss errs_so_far us locn) of +extendSS2 binders expr gnfs ss errs_so_far us locn + = case (extendSS binders expr gnfs ss errs_so_far us locn) of ((e2, freevars), errs) -> ((e2, freevars `minusUniqSet` (mkUniqSet binders)), errs) @@ -448,9 +431,9 @@ domTyVarNamesEnv env = map fst env mkTyVarNamesEnv :: SrcLoc -> [ProtoName] -- The type variables - -> Rn4M (TyVarNamesEnv,[Name]) -- Environment and renamed tyvars + -> Rn4M (TyVarNamesEnv,[Name]) -- Environment and renamed tyvars -mkTyVarNamesEnv src_loc tyvars {-Rn4-} sw_chkr gnfs ss errs_so_far us locn +mkTyVarNamesEnv src_loc tyvars {-Rn4-} gnfs ss errs_so_far us locn = (namesFromProtoNames "type variable" (tyvars `zip` repeat src_loc) `thenRn4` \ tyvars2 -> @@ -462,7 +445,7 @@ mkTyVarNamesEnv src_loc tyvars {-Rn4-} sw_chkr gnfs ss errs_so_far us locn tyvars2_in_orig_order = map snd tv_env in returnRn4 (tv_env, tyvars2_in_orig_order) - ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn + ) {-Rn4-} gnfs ss errs_so_far us locn where extend :: [Name] -> [(FAST_STRING, Name)] -> [(FAST_STRING, Name)] extend [] ss = ss @@ -476,15 +459,43 @@ mkTyVarNamesEnv src_loc tyvars {-Rn4-} sw_chkr gnfs ss errs_so_far us locn \begin{code} lookupTyVarName :: TyVarNamesEnv -> ProtoName -> Rn4M Name -lookupTyVarName env pname {-Rn4-} sw_chkr gnfs ss errs_so_far us locn +lookupTyVarName env pname {-Rn4-} gnfs ss errs_so_far us locn = (case (assoc_maybe env pname) of Just name -> returnRn4 name Nothing -> getSrcLocRn4 `thenRn4` \ loc -> failButContinueRn4 (unboundName pname) (unknownNameErr "type variable" pname loc) - ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn + ) {-Rn4-} gnfs ss errs_so_far us locn where assoc_maybe [] _ = Nothing assoc_maybe ((tv,xxx) : tvs) key = if tv `eqProtoName` key then Just xxx else assoc_maybe tvs key \end{code} + +%************************************************************************ +%* * +\subsection{Error messages} +%* * +%************************************************************************ + +\begin{code} +badClassOpErr clas op locn + = addErrLoc locn "" ( \ sty -> + ppBesides [ppChar '`', pprNonOp sty op, ppStr "' is not an operation of class `", + ppr sty clas, ppStr "'."] ) + +---------------------------- +-- dupNamesErr: from RnUtils + +--------------------------- +shadowedNameErr shadow locn + = addShortErrLocLine locn ( \ sty -> + ppBesides [ppStr "more than one value with the same name (shadowing): ", + ppr sty shadow] ) + +------------------------------------------ +unknownNameErr descriptor undef_thing locn + = addShortErrLocLine locn ( \ sty -> + ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", + pprNonOp sty undef_thing] ) +\end{code} diff --git a/ghc/compiler/rename/Rename1.lhs b/ghc/compiler/rename/RnPass1.lhs index 80f56d7ff0..53f4bb607c 100644 --- a/ghc/compiler/rename/Rename1.lhs +++ b/ghc/compiler/rename/RnPass1.lhs @@ -1,41 +1,39 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % -\section[Rename1]{@Rename1@: gather up imported information} +\section[RnPass1]{@RnPass1@: gather up imported information} See the @Rename@ module for a basic description of the renamer. \begin{code} #include "HsVersions.h" -module Rename1 ( - rnModule1, +module RnPass1 ( + rnModule1 -- for completeness - Module, Bag, ProtoNamePat(..), InPat, Maybe, - PprStyle, Pretty(..), PrettyRep, ProtoName, Name, - PreludeNameFun(..), PreludeNameFuns(..) ) where -IMPORT_Trace -- ToDo: rm -import Pretty -- these two too -import Outputable - -import AbsSyn -import AbsSynFuns ( getMentionedVars ) -- *** not via AbsSyn *** -import Bag ( Bag, emptyBag, unitBag, snocBag, unionBags, bagToList ) -import Errors -import HsPragmas -import FiniteMap -import Maybes ( maybeToBool, catMaybes, Maybe(..) ) ---OLD: import NameEnv ( mkStringLookupFn ) -import ProtoName ( ProtoName(..), mkPreludeProtoName ) -import RenameAuxFuns -import RenameMonad12 -import Util +import Ubiq{-uitous-} + +import HsSyn +import HsPragmas ( DataPragmas(..) ) +import RdrHsSyn -- ProtoName* instantiations... + +import Bag ( emptyBag, unitBag, snocBag, unionBags, Bag ) +import ErrUtils +import FiniteMap ( lookupFM, listToFM, elementOf ) +import Maybes ( catMaybes, maybeToBool ) +import Name ( Name{-instances-} ) +import Outputable ( isAvarid, getLocalName, interpp'SP ) +import PprStyle ( PprStyle(..) ) +import Pretty +import ProtoName ( mkPreludeProtoName, ProtoName(..) ) +import RnMonad12 +import RnUtils +import Util ( lengthExceeds, panic ) \end{code} - %************************************************************************ %* * \subsection{Types and things used herein} @@ -60,13 +58,13 @@ type SelectiveImporter = ProtoName -> Wantedness data Wantedness = Wanted | NotWanted - | WantedWith IE + | WantedWith (IE ProtoName) \end{code} The @ProtoNames@ supplied to these ``name functions'' are always @Unks@, unless they are fully-qualified names, which occur only in interface pragmas (and, therefore, never on the {\em definitions} of -things). That doesn't happen in @Rename1@! +things). That doesn't happen in @RnPass1@! \begin{code} type IntNameFun = ProtoName -> ProtoName type IntTCNameFun = ProtoName -> (ProtoName, IntNameFun) @@ -90,23 +88,24 @@ used}. This saves time later, because we don't need process the unused ones. \begin{code} -rnModule1 :: PreludeNameFuns +rnModule1 :: PreludeNameMappers -> Bool -- see use below - -> ProtoNameModule - -> Rn12M (ProtoNameModule, [FAST_STRING]) + -> ProtoNameHsModule + -> Rn12M (ProtoNameHsModule, Bag FAST_STRING) rnModule1 pnf@(v_pnf, tc_pnf) use_mentioned_vars_heuristic - (Module mod_name exports imports fixes - ty_decls absty_sigs class_decls inst_decls specinst_sigs - defaults binds _ src_loc) + (HsModule mod_name exports imports fixes + ty_decls absty_sigs class_decls inst_decls specinst_sigs + defaults binds _ src_loc) = -- slurp through the *body* of the module, collecting names of -- mentioned *variables*, 3+ letters long & not prelude names. -- Note: we *do* have to pick up top-level binders, -- so we can check for conflicts with imported guys! let -{- OLD:MENTIONED-} + is_mentioned_fn = \ x -> True -- wimp way out +{- OLD: (uses_Mdotdot_in_exports, mentioned_vars) = getMentionedVars v_pnf exports fixes class_decls inst_decls binds @@ -122,11 +121,10 @@ rnModule1 pnf@(v_pnf, tc_pnf) -- us this, and we act accordingly. is_mentioned_maybe - = lookupFM {-OLD: mkStringLookupFn-} (listToFM + = lookupFM (listToFM [ (x, panic "is_mentioned_fn") | x <- mentioned_vars ++ needed_for_deriving ] ) - -- OLD: False{-not-sorted-} where needed_for_deriving -- is this a HACK or what? = [ SLIT("&&"), @@ -145,8 +143,7 @@ rnModule1 pnf@(v_pnf, tc_pnf) && not (uses_Mdotdot_in_exports) then \ x -> maybeToBool (is_mentioned_maybe x) else \ x -> True -{- OLD:MENTIONED-} ---O:M is_mentioned_fn = \ x -> True -- ToDo: delete altogether +-} in -- OK, now do the business: doImportedIfaces pnf is_mentioned_fn imports @@ -157,19 +154,19 @@ rnModule1 pnf@(v_pnf, tc_pnf) inst_decls' = doRevoltingInstDecls tc_nf inst_decls in returnRn12 - ((Module mod_name - exports imports -- passed along mostly for later checking - (int_fixes ++ fixes) - (int_ty_decls ++ ty_decls) - absty_sigs - (int_class_decls ++ class_decls) - (int_inst_decls ++ inst_decls') - specinst_sigs - defaults - binds - int_sigs - src_loc), - bagToList import_names) + ((HsModule mod_name + exports imports -- passed along mostly for later checking + (int_fixes ++ fixes) + (int_ty_decls ++ ty_decls) + absty_sigs + (int_class_decls ++ class_decls) + (int_inst_decls ++ inst_decls') + specinst_sigs + defaults + binds + int_sigs + src_loc), + import_names) where -- This function just spots prelude names tc_nf pname@(Unk s) = case (tc_pnf s) of @@ -195,15 +192,13 @@ doRevoltingInstDecls :: IntNameFun -> [ProtoNameInstDecl] -> [ProtoNameInstDecl] doRevoltingInstDecls tc_nf decls = map revolt_me decls where - revolt_me (InstDecl context cname ty binds True modname imod uprags pragma src_loc) + revolt_me (InstDecl cname ty binds True modname uprags pragma src_loc) = InstDecl - context -- Context unchanged (tc_nf cname) -- Look up the class - (doIfaceMonoType1 tc_nf ty) -- Ditto the type + (doIfacePolyType1 tc_nf ty) -- Ditto the type binds -- Binds unchanged - True + True{-yes,defined in this module-} modname - imod uprags pragma src_loc @@ -219,7 +214,7 @@ doRevoltingInstDecls tc_nf decls module being renamed. \begin{code} -doImportedIfaces :: PreludeNameFuns +doImportedIfaces :: PreludeNameMappers -> (FAST_STRING -> Bool) -> [ProtoNameImportedInterface] -> Rn12M AllIntDecls @@ -244,53 +239,49 @@ doImportedIfaces pnfs is_mentioned_fn (iface:ifaces) \end{code} \begin{code} -doOneIface pnfs is_mentioned_fn (ImportAll int renamings) - = let - renaming_fn = mkRenamingFun renamings - -- if there are any renamings, then we don't use - -- the "is_mentioned_fn" hack; possibly dangerous (paranoia reigns) - revised_is_mentioned_fn - = if null renamings - then is_mentioned_fn - else (\ x -> True) -- pretend everything is mentioned - in --- pprTrace "ImportAll:mod_rns:" (ppr PprDebug renamings) ( - doIface1 renaming_fn pnfs (selectAll renaming_fn revised_is_mentioned_fn) int --- ) - -doOneIface pnfs unused_is_mentioned_fn (ImportSome int ie_list renamings) - = --pprTrace "ImportSome:mod_rns:" (ppr PprDebug renamings) ( - doIface1 (mkRenamingFun renamings) pnfs si_fun int - --) +doOneIface :: PreludeNameMappers + -> (FAST_STRING -> Bool) + -> ProtoNameImportedInterface + -> Rn12M AllIntDecls + +doOneIface _ _ (ImportMod _ True{-qualified-} _ _) + = panic "RnPass1.doOneIface:can't grok `qualified'" + +doOneIface _ _ (ImportMod _ _ (Just _) _) + = panic "RnPass1.doOneIface:can't grok `as' module (blech)" + +doOneIface pnfs is_mentioned_fn (ImportMod iface qual asmod Nothing{-all-}) + = doIface1 pnfs (selectAll is_mentioned_fn) iface + +doOneIface pnfs _ (ImportMod iface qual asmod (Just (False{-unhidden-}, ies))) + = doIface1 pnfs si_fun iface where -- the `selective import' function should not be applied -- to the Imps that occur on Ids in unfoldings. - si_fun (Unk str) = check_ie str ie_list - si_fun other = panic "si_fun in doOneIface" + si_fun (Unk n) = check_ie n ies + si_fun (Qunk _ n) = check_ie n ies check_ie name [] = NotWanted check_ie name (ie:ies) = case ie of - IEVar n | name == n -> Wanted - IEThingAbs n | name == n -> WantedWith ie - IEThingAll n | name == n -> WantedWith ie - IEConWithCons n ns | name == n -> WantedWith ie - IEClsWithOps n ns | name == n -> WantedWith ie - IEModuleContents _ -> panic "Module.. in import list?" - other -> check_ie name ies - -doOneIface pnfs unused_is_mentioned_fn (ImportButHide int ie_list renamings) - = --pprTrace "ImportButHide:mod_rns:" (ppr PprDebug renamings) ( - doIface1 (mkRenamingFun renamings) pnfs si_fun int - --) + IEVar (Unk n) | name == n -> Wanted + IEThingAbs (Unk n) | name == n -> WantedWith ie + IEThingAll (Unk n) | name == n -> WantedWith ie + IEModuleContents _ -> panic "Module.. in import list?" + other -> check_ie name ies + +doOneIface pnfs _ (ImportMod iface qual asmod (Just (True{-hidden-}, ies))) + = doIface1 pnfs si_fun iface where -- see comment above: - si_fun (Unk str) | str `elemFM` entity_info = NotWanted - | otherwise = Wanted + si_fun x | n `elementOf` entity_info = NotWanted + | otherwise = Wanted + where + n = case x of { Unk s -> s; Qunk _ s -> s } - entity_info = fst (getIEStrings ie_list) + entity_info = getImportees ies \end{code} @selectAll@ ``normally'' creates an @SelectiveImporter@ that declares @@ -311,11 +302,11 @@ Why would we want to keep long names which aren't mentioned when we're quite happy to throw away short names that aren't mentioned? \begin{code} -selectAll :: (FAST_STRING -> FAST_STRING) -> (FAST_STRING -> Bool) -> SelectiveImporter +selectAll :: (FAST_STRING -> Bool) -> SelectiveImporter -selectAll renaming_fn is_mentioned_fn (Unk str) -- gotta be an Unk +selectAll is_mentioned_fn n = let - rn_str = renaming_fn str + rn_str = case n of { Unk s -> s ; Qunk _ s -> s } in if (isAvarid rn_str) && (not (is_mentioned_fn rn_str)) @@ -354,58 +345,55 @@ The function @doIfaceImports1@ receives two association lists which will be described at its definition. \begin{code} -doIface1 :: (FAST_STRING -> FAST_STRING) -- Renamings in import stmt of module - -> PreludeNameFuns - -> SelectiveImporter - -> ProtoNameInterface - -> Rn12M AllIntDecls - -doIface1 mod_rn_fn (v_pnf, tc_pnf) sifun - (MkInterface i_name import_decls fix_decls ty_decls class_decls +doIface1 :: PreludeNameMappers + -> SelectiveImporter + -> ProtoNameInterface + -> Rn12M AllIntDecls + +doIface1 (v_pnf, tc_pnf) sifun + (Interface i_name import_decls fix_decls ty_decls class_decls inst_decls sig_decls anns) - = doIfaceImports1 mod_rn_fn i_name import_decls `thenRn12` \ (v_bag, tc_bag) -> + = doIfaceImports1 (panic "i_name"{-i_name-}) import_decls `thenRn12` \ (v_bag, tc_bag) -> do_body (v_bag, tc_bag) where do_body (v_bag, tc_bag) = report_all_errors `thenRn12` \ _ -> - doIfaceTyDecls1 sifun full_tc_nf ty_decls `thenRn12` \ ty_decls' -> + doIfaceTyDecls1 sifun full_tc_nf ty_decls `thenRn12` \ ty_decls' -> doIfaceClassDecls1 sifun full_tc_nf class_decls `thenRn12` \ class_decls' -> - let sig_decls' = doIfaceSigs1 sifun v_nf tc_nf sig_decls - fix_decls' = doIfaceFixes1 sifun v_nf fix_decls - inst_decls' = doIfaceInstDecls1 sifun tc_nf inst_decls + let sig_decls' = doIfaceSigs1 sifun v_nf tc_nf sig_decls + fix_decls' = doIfaceFixes1 sifun v_nf fix_decls + inst_decls' = doIfaceInstDecls1 sifun tc_nf inst_decls in returnRn12 (fix_decls', ty_decls', class_decls', inst_decls', sig_decls', unitBag i_name) where v_dups :: [[(FAST_STRING, ProtoName)]] tc_dups :: [[(FAST_STRING, (ProtoName, IntNameFun))]] - (imp_v_nf, v_dups) = mkNameFun {-OLD:v_pnf-} v_bag - (imp_tc_nf, tc_dups) = mkNameFun {-OLD:tc_pnf-} tc_bag + (imp_v_nf, v_dups) = mkNameFun v_bag + (imp_tc_nf, tc_dups) = mkNameFun tc_bag v_nf :: IntNameFun v_nf (Unk s) = case v_pnf s of Just n -> mkPreludeProtoName n Nothing -> case imp_v_nf s of Just n -> n - Nothing -> Imp i_name s [i_name] (mod_rn_fn s) + Nothing -> Imp i_name s [i_name] s + -- used for (..)'d parts of prelude datatype/class decls prel_con_or_op_nf :: FAST_STRING{-module name-}-> IntNameFun - -- Used for (..)'d parts of prelude datatype/class decls; - -- OLD:? For `data' types, we happen to know everything; - -- OLD:? For class decls, we *don't* know what the class-ops are. prel_con_or_op_nf m (Unk s) = case v_pnf s of Just n -> mkPreludeProtoName n - Nothing -> Imp m s [m] (mod_rn_fn s) + Nothing -> Imp m s [m] s -- Strictly speaking, should be *no renaming* here, folks - local_con_or_op_nf :: IntNameFun - -- used for non-prelude constructors/ops - local_con_or_op_nf (Unk s) = Imp i_name s [i_name] (mod_rn_fn s) + -- used for non-prelude constructors/ops/fields + local_con_or_op_nf :: IntNameFun + local_con_or_op_nf (Unk s) = Imp i_name s [i_name] s full_tc_nf :: IntTCNameFun full_tc_nf (Unk s) @@ -418,14 +406,14 @@ doIface1 mod_rn_fn (v_pnf, tc_pnf) sifun Nothing -> case imp_tc_nf s of Just pair -> pair - Nothing -> (Imp i_name s [i_name] (mod_rn_fn s), - local_con_or_op_nf) + Nothing -> (Imp i_name s [i_name] s, + local_con_or_op_nf) tc_nf = fst . full_tc_nf - -- ADR: commented out next new lines because I don't believe - -- ADR: the check is useful or required by the Standard. (It - -- ADR: also messes up the interpreter.) + -- ADR: commented out next new lines because I don't believe + -- ADR: the check is useful or required by the Standard. (It + -- ADR: also messes up the interpreter.) tc_errs = [] -- map (map (fst . snd)) tc_dups -- Ugh! Just keep the dup'd protonames @@ -456,23 +444,20 @@ type ImportNameBags = (Bag (FAST_STRING, ProtoName), \begin{code} doIfaceImports1 - :: (FAST_STRING -> FAST_STRING) -- Renamings in import stmt of module - -> FAST_STRING -- name of module whose interface we're doing - -> [IfaceImportDecl] + :: FAST_STRING -- name of module whose interface we're doing + -> [IfaceImportDecl ProtoName] -> Rn12M ImportNameBags -doIfaceImports1 _ _ [] = returnRn12 (emptyBag, emptyBag) +doIfaceImports1 _ [] = returnRn12 (emptyBag, emptyBag) -doIfaceImports1 mod_rn_fn int_mod_name (imp_decl1 : rest) - = do_decl imp_decl1 `thenRn12` \ (vb1, tcb1) -> - doIfaceImports1 mod_rn_fn int_mod_name rest `thenRn12` \ (vb2, tcb2) -> --- pprTrace "vbags/tcbags:" (ppr PprDebug (vb1 `unionBags` vb2, [(s,p) | (s,(p,_)) <- bagToList (tcb1 `unionBags` tcb2)])) ( +doIfaceImports1 int_mod_name (imp_decl1 : rest) + = do_decl imp_decl1 `thenRn12` \ (vb1, tcb1) -> + doIfaceImports1 int_mod_name rest `thenRn12` \ (vb2, tcb2) -> returnRn12 (vb1 `unionBags` vb2, tcb1 `unionBags` tcb2) --- ) where - do_decl (IfaceImportDecl orig_mod_name imports renamings src_loc) + do_decl (IfaceImportDecl orig_mod_name imports src_loc) = -- Look at the renamings to get a suitable renaming function - doRenamings mod_rn_fn int_mod_name orig_mod_name renamings + doRenamings{-not really-} int_mod_name orig_mod_name `thenRn12` \ (orig_to_pn, local_to_pn) -> -- Now deal with one import at a time, combining results. @@ -487,16 +472,16 @@ doIfaceImports1 mod_rn_fn int_mod_name (imp_decl1 : rest) returning a bag which maps local names to original names. \begin{code} -doIfaceImport1 :: ( FAST_STRING -- Original local name +doIfaceImport1 :: ( ProtoName -- Original local name -> (FAST_STRING, -- Local name in this interface ProtoName) -- Its full protoname - ) - + ) + -> IntNameFun -- Local name to ProtoName; use for -- constructors and class ops - + -> ImportNameBags -- Accumulator - -> IE -- An item in the import list + -> (IE ProtoName) -- An item in the import list -> ImportNameBags doIfaceImport1 orig_to_pn local_to_pn (v_bag, tc_bag) (IEVar orig_name) @@ -509,14 +494,16 @@ doIfaceImport1 orig_to_pn local_to_pn acc (IEThingAll orig_name) = int_import1_help orig_to_pn local_to_pn acc orig_name -- the next ones will go away with 1.3: +{- OLD: doIfaceImport1 orig_to_pn local_to_pn acc (IEConWithCons orig_name _) = int_import1_help orig_to_pn local_to_pn acc orig_name doIfaceImport1 orig_to_pn local_to_pn acc (IEClsWithOps orig_name _) = int_import1_help orig_to_pn local_to_pn acc orig_name +-} doIfaceImport1 orig_to_pn local_to_pn (v_bag, tc_bag) other - = panic "Rename1: strange import decl" + = panic "RnPass1: strange import decl" -- Little help guy... @@ -537,86 +524,32 @@ a @data@ or @class@ decl. It can produce errors, if there is a domain clash on the renamings. \begin{code} ---pprTrace ---instance Outputable _PackedString where --- ppr sty s = ppStr (_UNPK_ s) - -doRenamings :: (FAST_STRING -> FAST_STRING) -- Renamings in import stmt of module - -> FAST_STRING -- Name of the module whose interface we're working on +doRenamings :: FAST_STRING -- Name of the module whose interface we're working on -> FAST_STRING -- Original-name module for these renamings - -> [Renaming] -- Renamings -> Rn12M - ((FAST_STRING -- Original local name to... + ((ProtoName -- Original local name to... -> (FAST_STRING, -- ... Local name in this interface - ProtoName) -- ... Its full protoname - ), + ProtoName) -- ... Its full protoname + ), IntNameFun) -- Use for constructors, class ops -doRenamings mod_rn_fn int_mod orig_mod [] +doRenamings int_mod orig_mod = returnRn12 ( - \ s -> - let - result = (s, Imp orig_mod s [int_mod] (mod_rn_fn s)) - in --- pprTrace "name1a:" (ppCat [ppr PprDebug s, ppr PprDebug result]) ( - result --- ) - , - \ (Unk s) -> let - result = Imp orig_mod s [int_mod] (mod_rn_fn s) + result = (s, Imp orig_mod s [int_mod] s) in --- pprTrace "name2a:" (ppCat [ppr PprDebug s, ppr PprDebug result]) ( result --- ) - ) - -doRenamings mod_rn_fn int_mod orig_mod renamings - = let - local_rn_fn = mkRenamingFun renamings - in - --pprTrace "local_rns:" (ppr PprDebug renamings) ( - returnRn12 ( - \ s -> - let - local_name = local_rn_fn s - result - = (local_name, Imp orig_mod s [int_mod] (mod_rn_fn local_name)) - in --- pprTrace "name1:" (ppCat [ppr PprDebug s, ppr PprDebug result]) ( - result --- ) , \ (Unk s) -> let - result - = Imp orig_mod s [int_mod] (mod_rn_fn (local_rn_fn s)) + result = Imp orig_mod s [int_mod] s in --- pprTrace "name2:" (ppCat [ppr PprDebug s, ppr PprDebug result]) ( result --- ) ) - --) -\end{code} - -\begin{code} -mkRenamingFun :: [Renaming] -> FAST_STRING -> FAST_STRING - -mkRenamingFun [] = \ s -> s -mkRenamingFun renamings - = let - rn_fn = lookupFM (listToFM -- OLD: mkStringLookupFn - [ (old, new) | MkRenaming old new <- renamings ] - ) -- OLD: False {-not-sorted-} - in - \s -> case rn_fn s of - Nothing -> s - Just s' -> s' \end{code} - %************************************************************************ %* * \subsection{Type declarations} @@ -638,67 +571,92 @@ doIfaceTyDecls1 sifun full_tc_nf ty_decls = mapRn12 do_decl ty_decls `thenRn12` \ decls_maybe -> returnRn12 (catMaybes decls_maybe) where - do_decl (TyData context tycon tyvars condecls derivs (DataPragmas hidden_cons specs) src_loc) + do_decl (TySynonym tycon tyvars monoty src_loc) = let full_thing = returnRn12 (Just ty_decl') in - -- GHC doesn't allow derivings in interfaces - (if null derivs - then returnRn12 () - else addErrRn12 (derivingInIfaceErr tycon derivs src_loc) - ) `thenRn12` \ _ -> + case (sifun tycon) of + NotWanted -> returnRn12 Nothing + Wanted -> full_thing + WantedWith (IEThingAll _) -> full_thing + WantedWith weird_ie -> full_thing + where + (tycon_name,_) = full_tc_nf tycon + tc_nf = fst . full_tc_nf + monoty' = doIfaceMonoType1 tc_nf monoty + ty_decl' = TySynonym tycon_name tyvars monoty' src_loc + + do_decl (TyData context tycon tyvars condecls derivs pragmas src_loc) + = do_data context tycon condecls derivs pragmas src_loc `thenRn12` \ done_data -> + case done_data of + Nothing -> returnRn12 Nothing + Just (context', tycon', condecls', derivs', pragmas') -> + returnRn12 (Just (TyData context' tycon' tyvars condecls' derivs' pragmas' src_loc)) + + do_decl (TyNew context tycon tyvars condecl derivs pragmas src_loc) + = do_data context tycon condecl derivs pragmas src_loc `thenRn12` \ done_data -> + case done_data of + Nothing -> returnRn12 Nothing + Just (context', tycon', condecl', derivs', pragmas') -> + returnRn12 (Just (TyNew context' tycon' tyvars condecl' derivs' pragmas' src_loc)) + + -------------------------------------------- + do_data context tycon condecls derivs (DataPragmas hidden_cons specs) src_loc + = let + full_thing = Just (context', tycon_name, condecls', deriv', (pragmas' False)) + abs_thing = Just (context', tycon_name, [], deriv', (pragmas' True)) + in case (sifun tycon) of NotWanted -> returnRn12 Nothing - Wanted -> full_thing - WantedWith (IEThingAll _) -> full_thing - WantedWith (IEThingAbs _) -> returnRn12 (Just abs_ty_decl') - WantedWith ie@(IEConWithCons _ _) -> full_thing + Wanted -> returnRn12 full_thing + WantedWith (IEThingAll _) -> returnRn12 full_thing + WantedWith (IEThingAbs _) -> returnRn12 abs_thing WantedWith really_weird_ie -> -- probably a typo in the pgm addErrRn12 (weirdImportExportConstraintErr tycon really_weird_ie src_loc) `thenRn12` \ _ -> - full_thing + returnRn12 full_thing where - (tycon_name, constr_nf) = full_tc_nf tycon - tc_nf = fst . full_tc_nf + (tycon_name, constrfield_nf) = full_tc_nf tycon + tc_nf = fst . full_tc_nf - condecls' = map (do_condecl constr_nf tc_nf) condecls - hidden_cons' = map (do_condecl constr_nf tc_nf) hidden_cons + condecls' = map (do_condecl constrfield_nf tc_nf) condecls + hidden_cons' = map (do_condecl constrfield_nf tc_nf) hidden_cons pragmas' invent_hidden = DataPragmas (if null hidden_cons && invent_hidden - then condecls' -- if importing abstractly but condecls were - -- exported we add them to the data pragma + then condecls' -- if importing abstractly but condecls were + -- exported we add them to the data pragma else hidden_cons') specs {- ToDo: do_specs -} context' = doIfaceContext1 tc_nf context - deriv' = map tc_nf derivs -- rename derived classes + deriv' = case derivs of + Nothing -> Nothing + Just ds -> panic "doIfaceTyDecls1:derivs" -- Just (map tc_nf ds) + -- rename derived classes - ty_decl' = TyData context' tycon_name tyvars condecls' deriv' (pragmas' False) src_loc - abs_ty_decl'= TyData context' tycon_name tyvars [] deriv' (pragmas' True) src_loc + -------------------------------------------- + -- one name fun for the data constructor, another for the type: - do_decl (TySynonym tycon tyvars monoty pragmas src_loc) - = let - full_thing = returnRn12 (Just ty_decl') - in - case (sifun tycon) of - NotWanted -> returnRn12 Nothing - Wanted -> full_thing - WantedWith (IEThingAll _) -> full_thing + do_condecl cf_nf tc_nf (ConDecl name tys src_loc) + = ConDecl (cf_nf name) (map (do_bang tc_nf) tys) src_loc - WantedWith weird_ie -> full_thing - where - (tycon_name,_) = full_tc_nf tycon - tc_nf = fst . full_tc_nf - monoty' = doIfaceMonoType1 tc_nf monoty - ty_decl' = TySynonym tycon_name tyvars monoty' pragmas src_loc + do_condecl cf_nf tc_nf (ConOpDecl ty1 op ty2 src_loc) + = ConOpDecl (do_bang tc_nf ty1) (cf_nf op) (do_bang tc_nf ty2) src_loc - -- one name fun for the data constructor, another for the type: + do_condecl cf_nf tc_nf (NewConDecl name ty src_loc) + = NewConDecl (cf_nf name) (doIfaceMonoType1 tc_nf ty) src_loc + + do_condecl cf_nf tc_nf (RecConDecl con fields src_loc) + = RecConDecl (cf_nf con) (map do_field fields) src_loc + where + do_field (var, ty) = (cf_nf var, do_bang tc_nf ty) - do_condecl c_nf tc_nf (ConDecl name tys src_loc) - = ConDecl (c_nf name) (doIfaceMonoTypes1 tc_nf tys) src_loc + -------------------------------------------- + do_bang tc_nf (Banged ty) = Banged (doIfaceMonoType1 tc_nf ty) + do_bang tc_nf (Unbanged ty) = Unbanged (doIfaceMonoType1 tc_nf ty) \end{code} %************************************************************************ @@ -727,12 +685,10 @@ doIfaceClassDecls1 sifun full_tc_nf clas_decls = let full_thing = returnRn12 (Just class_decl') in - case (sifun cname) of + case (sifun cname) of NotWanted -> returnRn12 Nothing Wanted -> full_thing WantedWith (IEThingAll _) -> full_thing ---??? WantedWith (IEThingAbs _) -> returnRn12 (Just abs_class_decl') - WantedWith (IEClsWithOps _ _) -> full_thing -- ToDo: add checking of IEClassWithOps WantedWith really_weird_ie -> -- probably a typo in the pgm addErrRn12 (weirdImportExportConstraintErr @@ -770,28 +726,29 @@ are selected. \begin{code} doIfaceInstDecls1 :: SelectiveImporter - -> IntNameFun + -> IntNameFun -> [ProtoNameInstDecl] -> [ProtoNameInstDecl] doIfaceInstDecls1 si tc_nf inst_decls = catMaybes (map do_decl inst_decls) where - do_decl (InstDecl context cname ty EmptyMonoBinds False modname imod uprags pragmas src_loc) + do_decl (InstDecl cname ty EmptyMonoBinds False modname uprags pragmas src_loc) = case (si cname, tycon_reqd) of (NotWanted, NotWanted) -> Nothing _ -> Just inst_decl' where - context' = doIfaceContext1 tc_nf context - ty' = doIfaceMonoType1 tc_nf ty + ty' = doIfacePolyType1 tc_nf ty - inst_decl' = InstDecl context' (tc_nf cname) ty' EmptyMonoBinds False modname imod uprags pragmas src_loc + inst_decl' = InstDecl (tc_nf cname) ty' EmptyMonoBinds False modname uprags pragmas src_loc - tycon_reqd + tycon_reqd = _trace "RnPass1.tycon_reqd" NotWanted +{- LATER: = case getNonPrelOuterTyCon ty of Nothing -> NotWanted -- Type doesn't have a user-defined tycon -- at its outermost level Just tycon -> si tycon -- It does, so look up in the si-fun +-} \end{code} %************************************************************************ @@ -855,11 +812,11 @@ doIfaceFixes1 si vnf fixities \begin{code} doIfacePolyType1 :: IntNameFun -> ProtoNamePolyType -> ProtoNamePolyType -doIfacePolyType1 tc_nf (UnoverloadedTy ty) - = UnoverloadedTy (doIfaceMonoType1 tc_nf ty) +doIfacePolyType1 tc_nf (HsPreForAllTy ctxt ty) + = HsPreForAllTy (doIfaceContext1 tc_nf ctxt) (doIfaceMonoType1 tc_nf ty) -doIfacePolyType1 tc_nf (OverloadedTy ctxt ty) - = OverloadedTy (doIfaceContext1 tc_nf ctxt) (doIfaceMonoType1 tc_nf ty) +doIfacePolyType1 tc_nf (HsForAllTy tvs ctxt ty) + = HsForAllTy tvs (doIfaceContext1 tc_nf ctxt) (doIfaceMonoType1 tc_nf ty) \end{code} \begin{code} @@ -869,33 +826,36 @@ doIfaceContext1 tc_nf context = [(tc_nf clas, tyvar) | (clas,tyvar) <- context] \begin{code} -doIfaceMonoTypes1 :: IntNameFun -> [ProtoNameMonoType] -> [ProtoNameMonoType] -doIfaceMonoTypes1 tc_nf tys = map (doIfaceMonoType1 tc_nf) tys -\end{code} - - -\begin{code} doIfaceMonoType1 :: IntNameFun -> ProtoNameMonoType -> ProtoNameMonoType -doIfaceMonoType1 tc_nf (MonoTyVar tyvar) = MonoTyVar tyvar +doIfaceMonoType1 tc_nf tv@(MonoTyVar _) = tv -doIfaceMonoType1 tc_nf (ListMonoTy ty) - = ListMonoTy (doIfaceMonoType1 tc_nf ty) +doIfaceMonoType1 tc_nf (MonoListTy ty) + = MonoListTy (doIfaceMonoType1 tc_nf ty) -doIfaceMonoType1 tc_nf (FunMonoTy ty1 ty2) - = FunMonoTy (doIfaceMonoType1 tc_nf ty1) (doIfaceMonoType1 tc_nf ty2) +doIfaceMonoType1 tc_nf (MonoFunTy ty1 ty2) + = MonoFunTy (doIfaceMonoType1 tc_nf ty1) (doIfaceMonoType1 tc_nf ty2) -doIfaceMonoType1 tc_nf (TupleMonoTy tys) - = TupleMonoTy (map (doIfacePolyType1 tc_nf) tys) +doIfaceMonoType1 tc_nf (MonoTupleTy tys) + = MonoTupleTy (map (doIfaceMonoType1 tc_nf) tys) -doIfaceMonoType1 tc_nf (MonoTyCon name tys) - = MonoTyCon (tc_nf name) (doIfaceMonoTypes1 tc_nf tys) +doIfaceMonoType1 tc_nf (MonoTyApp name tys) + = MonoTyApp (tc_nf name) (map (doIfaceMonoType1 tc_nf) tys) +\end{code} -#ifdef DPH -doIfaceMonoType1 tc_nf (MonoTyProc tys ty) - = MonoTyProc (doIfaceMonoTypes1 tc_nf tys) (doIfaceMonoType1 tc_nf ty) +%************************************************************************ +%* * +\subsection{Error messages} +%* * +%************************************************************************ -doIfaceMonoType1 tc_nf (MonoTyPod ty) - = MonoTyPod (doIfaceMonoType1 tc_nf ty) -#endif {- Data Parallel Haskell -} +\begin{code} +duplicateImportsInInterfaceErr iface dups + = panic "duplicateImportsInInterfaceErr: NOT DONE YET?" + +weirdImportExportConstraintErr thing constraint locn + = addShortErrLocLine locn ( \ sty -> + ppBesides [ppStr "Illegal import/export constraint on `", + ppr sty thing, + ppStr "': ", ppr PprForUser constraint]) \end{code} diff --git a/ghc/compiler/rename/Rename2.lhs b/ghc/compiler/rename/RnPass2.lhs index bb7ac162c5..3feb281dbd 100644 --- a/ghc/compiler/rename/Rename2.lhs +++ b/ghc/compiler/rename/RnPass2.lhs @@ -1,34 +1,39 @@ % -% (c) The GRASP Project, Glasgow University, 1992-1995 +% (c) The GRASP Project, Glasgow University, 1992-1996 % -\section[Rename2]{Second renaming pass: boil down to non-duplicated info} +\section[RnPass2]{Second renaming pass: boil down to non-duplicated info} \begin{code} #include "HsVersions.h" -module Rename2 ( - rnModule2, +module RnPass2 ( + rnModule2 -- for completeness - Module, Bag, ProtoNamePat(..), InPat, - PprStyle, Pretty(..), PrettyRep, ProtoName ) where -IMPORT_Trace -- ToDo: rm (debugging) -import Pretty -import Outputable - -import AbsSyn -import Errors ( dupNamesErr, Error(..) ) -import HsCore -- ****** NEED TO SEE CONSTRUCTORS ****** -import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** -import HsTypes ( cmpMonoType, pprParendMonoType ) -import IdInfo ( DeforestInfo(..) ) -import Maybes ( Maybe(..) ) -import ProtoName -import RenameMonad12 -import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) -import Util +import Ubiq{-uitous-} + +import HsSyn +import HsCore +import HsPragmas +import RdrHsSyn +import RnMonad12 + +import Bag ( Bag ) +import IdInfo ( DeforestInfo(..), Demand{-instances-}, UpdateInfo{-instance-} ) +import Outputable ( Outputable(..){-instances-} ) +import PprStyle ( PprStyle(..) ) +import Pretty -- quite a bit of it +import ProtoName ( cmpProtoName, eqProtoName, eqByLocalName, + elemProtoNames, elemByLocalNames, + ProtoName(..) + ) +import RnUtils ( dupNamesErr ) +import SrcLoc ( mkUnknownSrcLoc, SrcLoc{-instances-} ) +import Util ( isIn, equivClasses, + panic, panic#, pprTrace, assertPanic + ) \end{code} This pass removes duplicate declarations. Duplicates can arise when @@ -53,9 +58,9 @@ without} actually checking that they contain the same information! [WDP 93/8/16] [Improved, at least WDP 93/08/26] \begin{code} -rnModule2 :: ProtoNameModule -> Rn12M ProtoNameModule +rnModule2 :: ProtoNameHsModule -> Rn12M ProtoNameHsModule -rnModule2 (Module mod_name exports imports fixes +rnModule2 (HsModule mod_name exports imports fixes ty_decls absty_sigs class_decls inst_decls specinst_sigs defaults binds int_sigs src_loc) @@ -87,22 +92,22 @@ rnModule2 (Module mod_name exports imports fixes rm_sigs_for_here mod_name int_sigs `thenRn12` \ non_here_int_sigs -> - uniquefy mod_name cmpSig selSig non_here_int_sigs + uniquefy mod_name cmpSig selSig non_here_int_sigs `thenRn12` \ int_sigs -> returnRn12 - (Module mod_name - exports -- export and import lists are passed along - imports -- for checking in Rename3; no other reason - fixes - ty_decls - absty_sigs - class_decls - inst_decls - specinst_sigs - defaults - binds - int_sigs - src_loc) + (HsModule mod_name + exports -- export and import lists are passed along + imports -- for checking in RnPass3; no other reason + fixes + ty_decls + absty_sigs + class_decls + inst_decls + specinst_sigs + defaults + binds + int_sigs + src_loc) where top_level_binders = collectTopLevelBinders binds @@ -136,7 +141,7 @@ rnModule2 (Module mod_name exports imports fixes %************************************************************************ %* * -\subsection[FixityDecls-Rename2]{Functions for @FixityDecls@} +\subsection[FixityDecls-RnPass2]{Functions for @FixityDecls@} %* * %************************************************************************ @@ -160,17 +165,25 @@ selFix f1 f2 = returnRn12 f1 %************************************************************************ %* * -\subsection[TyDecls-Rename2]{Functions for @TyDecls@} +\subsection[TyDecls-RnPass2]{Functions for @TyDecls@} %* * %************************************************************************ \begin{code} cmpTys :: ProtoNameTyDecl -> ProtoNameTyDecl -> TAG_ -cmpTys (TyData _ n1 _ _ _ _ _) (TyData _ n2 _ _ _ _ _) = cmpProtoName n1 n2 -cmpTys (TyData _ n1 _ _ _ _ _) other = LT_ -cmpTys (TySynonym n1 _ _ _ _) (TySynonym n2 _ _ _ _) = cmpProtoName n1 n2 -cmpTys a b = GT_ +cmpTys (TyData _ n1 _ _ _ _ _) (TyData _ n2 _ _ _ _ _) = cmpProtoName n1 n2 +cmpTys (TyNew _ n1 _ _ _ _ _) (TyNew _ n2 _ _ _ _ _) = cmpProtoName n1 n2 +cmpTys (TySynonym n1 _ _ _) (TySynonym n2 _ _ _) = cmpProtoName n1 n2 +cmpTys a b + = let tag1 = tag a + tag2 = tag b + in + if tag1 _LT_ tag2 then LT_ else GT_ + where + tag (TyData _ _ _ _ _ _ _) = (ILIT(1) :: FAST_INT) + tag (TyNew _ _ _ _ _ _ _) = ILIT(2) + tag (TySynonym _ _ _ _) = ILIT(3) \end{code} \begin{code} @@ -189,13 +202,23 @@ selTys td1@(TyData c name1 tvs cons1 ds pragmas1 locn1) (\ p -> TyData c name1 tvs cons1 ds p locn1) chooser_TyData -selTys ts1@(TySynonym name1 tvs expand1 pragmas1 locn1) - ts2@(TySynonym name2 _ expand2 pragmas2 locn2) +selTys td1@(TyNew c name1 tvs con1 ds pragmas1 locn1) + td2@(TyNew _ name2 _ con2 _ pragmas2 locn2) + = selByBetterName "algebraic newtype" + name1 pragmas1 locn1 td1 + name2 pragmas2 locn2 td2 + (\ p -> TyNew c name1 tvs con1 ds p locn1) + chooser_TyNew + +selTys ts1@(TySynonym name1 tvs expand1 locn1) + ts2@(TySynonym name2 _ expand2 locn2) = selByBetterName "type synonym" - name1 pragmas1 locn1 ts1 - name2 pragmas2 locn2 ts2 - (\ p -> TySynonym name1 tvs expand1 p locn1) + name1 bottom locn1 ts1 + name2 bottom locn2 ts2 + (\ p -> TySynonym name1 tvs expand1 locn1) chooser_TySynonym + where + bottom = panic "RnPass2:selTys:TySynonym" \end{code} If only one is ``abstract'' (no condecls), we take the other. @@ -205,6 +228,11 @@ constructors (what a disaster if those get through...); then we do a similar thing using pragmatic info. \begin{code} +chooser_TyNew wout pragmas1 locn1 td1@(TyNew _ name1 _ con1 _ _ _) + pragmas2 locn2 td2@(TyNew _ name2 _ con2 _ _ _) + = panic "RnPass2:chooser_TyNew" + + chooser_TyData wout pragmas1 locn1 td1@(TyData _ name1 _ cons1 _ _ _) pragmas2 locn2 td2@(TyData _ name2 _ cons2 _ _ _) = let @@ -260,7 +288,7 @@ chooser_TyData wout pragmas1 locn1 td1@(TyData _ name1 _ cons1 _ _ _) = ppBesides [ppStr "_SPECIALISE_ ", pp_the_list [ ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack] | ty_maybes <- specs ]] - + pp_the_list [p] = p pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps) @@ -274,62 +302,44 @@ Sort of similar deal on synonyms: this is the time to check that the expansions are really the same; otherwise, we use the pragmas. \begin{code} -chooser_TySynonym wout pragmas1 locn1 ts1@(TySynonym name1 _ expand1 _ _) - pragmas2 locn2 ts2@(TySynonym name2 _ expand2 _ _) +chooser_TySynonym wout _ locn1 ts1@(TySynonym name1 _ expand1 _) + _ locn2 ts2@(TySynonym name2 _ expand2 _) = if not (eqMonoType expand1 expand2) then report_dup "type synonym" name1 locn1 name2 locn2 ts1 else - sub_chooser pragmas1 pragmas2 - where - sub_chooser NoTypePragmas b = returnRn12 (wout b) - sub_chooser a NoTypePragmas = returnRn12 (wout a) - sub_chooser a _ = returnRn12 (wout a) -- same, just pick one + returnRn12 ts1 -- same, just pick one \end{code} %************************************************************************ %* * -\subsection[DataTypeSigs-Rename2]{Functions for @DataTypeSigs@} +\subsection[SpecDataSigs-RnPass2]{Functions for @SpecDataSigs@} %* * %************************************************************************ \begin{code} -cmpTySigs :: ProtoNameDataTypeSig -> ProtoNameDataTypeSig -> TAG_ +cmpTySigs :: ProtoNameSpecDataSig -> ProtoNameSpecDataSig -> TAG_ -cmpTySigs (AbstractTypeSig n1 _) (AbstractTypeSig n2 _) - = cmpProtoName n1 n2 cmpTySigs (SpecDataSig n1 ty1 _) (SpecDataSig n2 ty2 _) = case cmpProtoName n1 n2 of EQ_ -> LT_ -- multiple SPECIALIZE data pragmas allowed other -> other -cmpTySigs (AbstractTypeSig n1 _) (SpecDataSig n2 _ _) - = LT_ -cmpTySigs (SpecDataSig n1 _ _) (AbstractTypeSig n2 _) - = GT_ -selTySigs :: ProtoNameDataTypeSig - -> ProtoNameDataTypeSig - -> Rn12M ProtoNameDataTypeSig - -selTySigs s1@(AbstractTypeSig n1 locn1) s2@(AbstractTypeSig n2 locn2) - = selByBetterName "ABSTRACT user-pragma" - n1 bottom locn1 s1 - n2 bottom locn2 s2 - bottom bottom - where - bottom = panic "Rename2:selTySigs:AbstractTypeSig" +selTySigs :: ProtoNameSpecDataSig + -> ProtoNameSpecDataSig + -> Rn12M ProtoNameSpecDataSig selTySigs s1@(SpecDataSig n1 ty1 locn1) s2@(SpecDataSig n2 ty2 locn2) - = selByBetterName "ABSTRACT user-pragma" + = selByBetterName "SPECIALIZE data user-pragma" n1 bottom locn1 s1 n2 bottom locn2 s2 bottom bottom where - bottom = panic "Rename2:selTySigs:SpecDataSig" + bottom = panic "RnPass2:selTySigs:SpecDataSig" \end{code} %************************************************************************ %* * -\subsection[ClassDecl-Rename2]{Functions for @ClassDecls@} +\subsection[ClassDecl-RnPass2]{Functions for @ClassDecls@} %* * %************************************************************************ @@ -376,14 +386,14 @@ chooser_Class wout sd1@(SuperDictPragmas gs1) l1 _ sd2@(SuperDictPragmas gs2) l2 %************************************************************************ %* * -\subsection[InstDecls-Rename2]{Functions for @InstDecls@} +\subsection[InstDecls-RnPass2]{Functions for @InstDecls@} %* * %************************************************************************ \begin{code} cmpInst :: ProtoNameInstDecl -> ProtoNameInstDecl -> TAG_ -cmpInst (InstDecl _ c1 ty1 _ _ _ _ _ _ _) (InstDecl _ c2 ty2 _ _ _ _ _ _ _) +cmpInst (InstDecl c1 ty1 _ _ _ _ _ _) (InstDecl c2 ty2 _ _ _ _ _ _) = case cmpProtoName c1 c2 of EQ_ -> cmpInstanceTypes ty1 ty2 other -> other @@ -396,8 +406,8 @@ interface), if it exists. selInst :: ProtoNameInstDecl -> ProtoNameInstDecl -> Rn12M ProtoNameInstDecl -selInst i1@(InstDecl ctxt c ty bs from_here1 orig_mod1 infor_mod1 uprags pragmas1 locn1) - i2@(InstDecl _ _ _ _ from_here2 orig_mod2 infor_mod2 _ pragmas2 locn2) +selInst i1@(InstDecl c ty bs from_here1 orig_mod1 uprags pragmas1 locn1) + i2@(InstDecl _ _ _ from_here2 orig_mod2 _ pragmas2 locn2) = let have_orig_mod1 = not (_NULL_ orig_mod1) have_orig_mod2 = not (_NULL_ orig_mod2) @@ -433,6 +443,9 @@ selInst i1@(InstDecl ctxt c ty bs from_here1 orig_mod1 infor_mod1 uprags pragmas trace ("selInst: `same' instances coming in from two modules! (ToDo: msg!)") choose_no2 -- arbitrary else + panic "RnPass2: need original modules for imported instances" + +{- LATER ??? -- now we *cheat*: so we can use the "informing module" stuff -- in "selByBetterName", we *make up* some ProtoNames for -- these instance decls @@ -444,9 +457,10 @@ selInst i1@(InstDecl ctxt c ty bs from_here1 orig_mod1 infor_mod1 uprags pragmas selByBetterName "instance" n1 pragmas1 locn1 i1 n2 pragmas2 locn2 i2 - (\ p -> InstDecl ctxt c ty bs from_here1 orig_mod1 infor_mod1 + (\ p -> InstDecl c ty bs from_here1 orig_mod1 infor_mod1 [{-none-}] p locn1) chooser_Inst +-} \end{code} \begin{code} @@ -500,7 +514,7 @@ chooser_Inst wout iprags1 loc1 i1 iprags2 loc2 i2 %************************************************************************ %* * -\subsection[SpecInstSigs-Rename2]{Functions for @AbstractTypeSigs@} +\subsection[SpecInstSigs-RnPass2]{Functions for @AbstractTypeSigs@} %* * %************************************************************************ @@ -512,13 +526,14 @@ nothing for \tr{sel*} to do! \begin{code} cmpSpecInstSigs - :: ProtoNameSpecialisedInstanceSig -> ProtoNameSpecialisedInstanceSig -> TAG_ -selSpecInstSigs :: ProtoNameSpecialisedInstanceSig - -> ProtoNameSpecialisedInstanceSig - -> Rn12M ProtoNameSpecialisedInstanceSig + :: ProtoNameSpecInstSig -> ProtoNameSpecInstSig -> TAG_ + +selSpecInstSigs :: ProtoNameSpecInstSig + -> ProtoNameSpecInstSig + -> Rn12M ProtoNameSpecInstSig cmpSpecInstSigs a b = LT_ -selSpecInstSigs a b = panic "Rename2:selSpecInstSigs" +selSpecInstSigs a b = panic "RnPass2:selSpecInstSigs" \end{code} %************************************************************************ @@ -535,9 +550,7 @@ cmpSig :: ProtoNameSig -> ProtoNameSig -> TAG_ cmpSig (Sig n1 _ _ _) (Sig n2 _ _ _) = cmpProtoName n1 n2 --- avoid BUG (ToDo) -cmpSig _ _ = case (panic "cmpSig (rename2)") of { s -> -- should never happen - cmpSig s s } +cmpSig _ _ = panic# "cmpSig (rename2)" selSig :: ProtoNameSig -> ProtoNameSig -> Rn12M ProtoNameSig @@ -625,7 +638,7 @@ selGenPragmas g1@(GenPragmas arity1 upd1 def1 strict1 unfold1 specs1) locn1 sel_strict a@(ImpStrictness b1 i1 g1) (ImpStrictness b2 i2 g2) = if b1 /= b2 || i1 /= i2 - then pRAGMA_ERROR "strictness pragmas" a + then pRAGMA_ERROR "strictness pragmas" a else recoverQuietlyRn12 NoGenPragmas ( selGenPragmas g1 locn1 g2 locn2 ) `thenRn12` \ wrkr_prags -> @@ -684,7 +697,7 @@ selSpecialisations all_specs1@((spec1, dicts1, prags1) : rest_specs1) loc1 EQ_ -> ASSERT(dicts1 == dicts2) recoverQuietlyRn12 NoGenPragmas ( selGenPragmas prags1 loc1 prags2 loc2 - ) `thenRn12` \ new_prags -> + ) `thenRn12` \ new_prags -> selSpecialisations rest_specs1 loc1 rest_specs2 loc2 `thenRn12` \ rest -> returnRn12 ( (spec1, dicts1, new_prags) : rest ) @@ -724,7 +737,7 @@ uniquefy mod cmp sel things -> [a] -- things to be compared -> Rn12M a - check_group_consistency sel [] = panic "Rename2: runs produced an empty list" + check_group_consistency sel [] = panic "RnPass2: runs produced an empty list" check_group_consistency sel (thing:things) = foldrRn12 sel thing things \end{code} diff --git a/ghc/compiler/rename/Rename3.lhs b/ghc/compiler/rename/RnPass3.lhs index 845a2144f9..ce905edec1 100644 --- a/ghc/compiler/rename/Rename3.lhs +++ b/ghc/compiler/rename/RnPass3.lhs @@ -1,7 +1,7 @@ % -% (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} @@ -17,36 +17,35 @@ twice: that is up to the caller to sort out. \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} ********************************************************* @@ -68,15 +67,15 @@ type NameSpaceAssoc = [(ProtoName, Name)] -- List version ********************************************************* \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 ( @@ -96,7 +95,7 @@ rnModule3 pnfs@(val_pnf, tc_pnf) imported_mod_names 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 -> @@ -106,13 +105,13 @@ rnModule3 pnfs@(val_pnf, tc_pnf) imported_mod_names 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 @@ -135,11 +134,11 @@ rnModule3 pnfs@(val_pnf, tc_pnf) imported_mod_names (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 @@ -174,7 +173,7 @@ doTyDecls3 (tyd:tyds) 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 @@ -185,17 +184,31 @@ doTyDecls3 (tyd:tyds) 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?" @@ -219,7 +232,17 @@ doConDecls3 want_invisibles exp_flag (cd:cds) 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} @@ -248,7 +271,7 @@ doClassDecls3 (cd:cds) `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) -> @@ -271,6 +294,16 @@ doClassOps3 clas tag (sig:rest) 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 @@ -278,9 +311,12 @@ doClassOps3 clas tag (sig:rest) 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} @@ -296,7 +332,7 @@ doIntSigs3 (s:ss) 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} ********************************************************* @@ -306,7 +342,7 @@ doIntSigs3 (s:ss) ********************************************************* \begin{code} -doBinds3 :: ProtoNameBinds -> Rn3M BagAssoc +doBinds3 :: ProtoNameHsBinds -> Rn3M BagAssoc doBinds3 EmptyBinds = returnRn3 emptyBag @@ -350,7 +386,6 @@ doPat3 locn (LazyPatIn pat) = doPat3 locn pat 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) @@ -359,11 +394,6 @@ doPat3 locn (ConPatIn name pats) = doPats3 locn pats 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} @@ -371,91 +401,100 @@ doTopLevName :: SrcLoc -> ProtoName -> Rn3M BagAssoc 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) @@ -463,97 +502,119 @@ verifyImports v_gnf tc_gnf imports = 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} diff --git a/ghc/compiler/rename/Rename4.lhs b/ghc/compiler/rename/RnPass4.lhs index ab61d94fb0..9aaa2e7802 100644 --- a/ghc/compiler/rename/Rename4.lhs +++ b/ghc/compiler/rename/RnPass4.lhs @@ -1,38 +1,34 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % -\section[Rename4]{Fourth of the renaming passes} +\section[RnPass4]{Fourth of the renaming passes} \begin{code} #include "HsVersions.h" -module Rename4 ( - rnModule4, rnPolyType4, rnGenPragmas4, - - initRn4, Rn4M(..), TyVarNamesEnv(..), -- re-exported from the monad - - -- for completeness - - Module, Bag, InPat, ProtoNamePat(..), RenamedPat(..), - PolyType, Maybe, Name, ProtoName, GlobalNameFun(..), - SrcLoc, SplitUniqSupply, Error(..), PprStyle, - Pretty(..), PrettyRep - ) where - -IMPORT_Trace -- ToDo: rm (debugging) -import Outputable -import Pretty - -import AbsSyn -import AbsUniType ( derivableClassKeys ) -import Errors -import HsCore -- ****** NEED TO SEE CONSTRUCTORS ****** -import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** -import Maybes ( catMaybes, maybeToBool, Maybe(..) ) -import ProtoName ( eqProtoName, elemProtoNames ) -import RenameBinds4 ( rnTopBinds4, rnMethodBinds4 ) -import RenameMonad4 -import Util +module RnPass4 ( rnModule, rnPolyType, rnGenPragmas ) where + +import Ubiq{-uitous-} +import RnLoop -- *check* the RnPass4/RnExpr4/RnBinds4 loop-breaking + +import HsSyn +import RdrHsSyn +import RnHsSyn +import HsPragmas -- all of it +import HsCore -- all of it +import RnMonad4 + +import Class ( derivableClassKeys ) +import Maybes ( maybeToBool, catMaybes ) +import Name ( Name(..) ) +import Outputable ( Outputable(..), isAvarid ) +import Pretty ( ppHang, ppStr, ppCat, ppAboves ) +import ProtoName ( eqProtoName, elemProtoNames, ProtoName{-instance-} ) +import RnBinds4 ( rnTopBinds, rnMethodBinds ) +import SrcLoc ( SrcLoc{-instance-} ) +import Unique ( Unique{-instances-} ) +import UniqSet ( UniqSet(..) ) +import Util ( isIn, panic, assertPanic ) \end{code} This pass `renames' the module+imported info, simultaneously @@ -43,44 +39,40 @@ checks: Checks that tyvars are used properly. This includes checking for undefined tyvars, and tyvars in contexts that are ambiguous. \item -Checks that local variables are defined. +Checks that local variables are defined. \end{enumerate} \begin{code} -rnModule4 :: ProtoNameModule -> Rn4M RenamedModule +rnModule :: ProtoNameHsModule -> Rn4M RenamedHsModule -rnModule4 (Module mod_name exports _ fixes ty_decls absty_sigs +rnModule (HsModule mod_name exports _ fixes ty_decls specdata_sigs class_decls inst_decls specinst_sigs defaults binds int_sigs src_loc) = pushSrcLocRn4 src_loc ( - mapRn4 rnTyDecl4 ty_decls `thenRn4` \ new_ty_decls -> - - mapRn4 rnTySig4 absty_sigs `thenRn4` \ new_absty_sigs -> - - mapRn4 rnClassDecl4 class_decls `thenRn4` \ new_class_decls -> - - mapRn4 rnInstDecl4 inst_decls `thenRn4` \ new_inst_decls -> - - mapRn4 rnInstSpecSig4 specinst_sigs `thenRn4` \ new_specinst_sigs -> - - mapRn4 rnDefaultDecl4 defaults `thenRn4` \ new_defaults -> - - rnTopBinds4 binds `thenRn4` \ new_binds -> - - mapRn4 rnIntSig4 int_sigs `thenRn4` \ new_int_sigs -> - - rnFixes4 fixes `thenRn4` \ new_fixes -> - - returnRn4 (Module mod_name - exports [{-imports finally clobbered-}] new_fixes - new_ty_decls new_absty_sigs new_class_decls + mapRn4 rnTyDecl ty_decls `thenRn4` \ new_ty_decls -> + mapRn4 rnSpecDataSig specdata_sigs `thenRn4` \ new_specdata_sigs -> + mapRn4 rnClassDecl class_decls `thenRn4` \ new_class_decls -> + mapRn4 rnInstDecl inst_decls `thenRn4` \ new_inst_decls -> + mapRn4 rnSpecInstSig specinst_sigs `thenRn4` \ new_specinst_sigs -> + rnDefaultDecl defaults `thenRn4` \ new_defaults -> + rnTopBinds binds `thenRn4` \ new_binds -> + mapRn4 rnIntSig int_sigs `thenRn4` \ new_int_sigs -> + rnFixes fixes `thenRn4` \ new_fixes -> + rnExports exports `thenRn4` \ new_exports -> + + returnRn4 (HsModule mod_name + new_exports [{-imports finally clobbered-}] new_fixes + new_ty_decls new_specdata_sigs new_class_decls new_inst_decls new_specinst_sigs new_defaults new_binds new_int_sigs src_loc) ) -\end{code} +rnExports Nothing = returnRn4 Nothing +rnExports (Just exp_list) + = returnRn4 (Just (_trace "rnExports:trashing exports" [])) +\end{code} %********************************************************* %* * @@ -88,7 +80,7 @@ rnModule4 (Module mod_name exports _ fixes ty_decls absty_sigs %* * %********************************************************* -@rnTyDecl4@ uses the `global name function' to create a new type +@rnTyDecl@ uses the `global name function' to create a new type declaration in which local names have been replaced by their original names, reporting any unknown names. @@ -101,52 +93,72 @@ it again to rename the tyvars! However, we can also do some scoping checks at the same time. \begin{code} -rnTyDecl4 :: ProtoNameTyDecl -> Rn4M RenamedTyDecl +rnTyDecl :: ProtoNameTyDecl -> Rn4M RenamedTyDecl -rnTyDecl4 (TyData context tycon tyvars condecls derivings pragmas src_loc) +rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc) = pushSrcLocRn4 src_loc ( lookupTyCon tycon `thenRn4` \ tycon' -> mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env, tyvars') -> - rnContext4 tv_env context `thenRn4` \ context' -> - rnConDecls4 tv_env False condecls `thenRn4` \ condecls' -> - mapRn4 (rn_deriv tycon' src_loc) derivings `thenRn4` \ derivings' -> + rnContext tv_env context `thenRn4` \ context' -> + rnConDecls tv_env False condecls `thenRn4` \ condecls' -> + rn_derivs tycon' src_loc derivings `thenRn4` \ derivings' -> recoverQuietlyRn4 (DataPragmas [] []) ( - rnDataPragmas4 tv_env pragmas + rnDataPragmas tv_env pragmas ) `thenRn4` \ pragmas' -> returnRn4 (TyData context' tycon' tyvars' condecls' derivings' pragmas' src_loc) ) - where - rn_deriv tycon2 locn deriv - = lookupClass deriv `thenRn4` \ clas_name -> - case clas_name of - PreludeClass key _ | key `is_elem` derivableClassKeys - -> returnRn4 clas_name - _ -> addErrRn4 (derivingNonStdClassErr tycon2 deriv locn) `thenRn4_` - returnRn4 clas_name - where - is_elem = isIn "rn_deriv" -rnTyDecl4 (TySynonym name tyvars ty pragmas src_loc) +rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc) + = pushSrcLocRn4 src_loc ( + lookupTyCon tycon `thenRn4` \ tycon' -> + mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env, tyvars') -> + rnContext tv_env context `thenRn4` \ context' -> + rnConDecls tv_env False condecl `thenRn4` \ condecl' -> + rn_derivs tycon' src_loc derivings `thenRn4` \ derivings' -> + recoverQuietlyRn4 (DataPragmas [] []) ( + rnDataPragmas tv_env pragmas + ) `thenRn4` \ pragmas' -> + returnRn4 (TyNew context' tycon' tyvars' condecl' derivings' pragmas' src_loc) + ) + +rnTyDecl (TySynonym name tyvars ty src_loc) = pushSrcLocRn4 src_loc ( lookupTyCon name `thenRn4` \ name' -> mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env, tyvars') -> - rnMonoType4 False{-no invisible types-} tv_env ty + rnMonoType False{-no invisible types-} tv_env ty `thenRn4` \ ty' -> - returnRn4 (TySynonym name' tyvars' ty' pragmas src_loc) + returnRn4 (TySynonym name' tyvars' ty' src_loc) ) + +rn_derivs tycon2 locn Nothing -- derivs not specified + = returnRn4 Nothing + +rn_derivs tycon2 locn (Just ds) + = mapRn4 (rn_deriv tycon2 locn) ds `thenRn4` \ derivs -> + returnRn4 (Just derivs) + where + rn_deriv tycon2 locn clas + = lookupClass clas `thenRn4` \ clas_name -> + case clas_name of + ClassName key _ _ | key `is_elem` derivableClassKeys + -> returnRn4 clas_name + _ -> addErrRn4 (derivingNonStdClassErr clas locn) `thenRn4_` + returnRn4 clas_name + where + is_elem = isIn "rn_deriv" \end{code} -@rnConDecls4@ uses the `global name function' to create a new +@rnConDecls@ uses the `global name function' to create a new constructor in which local names have been replaced by their original names, reporting any unknown names. \begin{code} -rnConDecls4 :: TyVarNamesEnv +rnConDecls :: TyVarNamesEnv -> Bool -- True <=> allowed to see invisible data-cons -> [ProtoNameConDecl] -> Rn4M [RenamedConDecl] -rnConDecls4 tv_env invisibles_allowed con_decls +rnConDecls tv_env invisibles_allowed con_decls = mapRn4 rn_decl con_decls where lookup_fn @@ -156,38 +168,58 @@ rnConDecls4 tv_env invisibles_allowed con_decls rn_decl (ConDecl name tys src_loc) = pushSrcLocRn4 src_loc ( - lookup_fn name `thenRn4` \ new_name -> - mapRn4 (rnMonoType4 invisibles_allowed tv_env) tys - `thenRn4` \ new_tys -> - + lookup_fn name `thenRn4` \ new_name -> + mapRn4 rn_bang_ty tys `thenRn4` \ new_tys -> returnRn4 (ConDecl new_name new_tys src_loc) ) + + rn_decl (ConOpDecl ty1 op ty2 src_loc) + = pushSrcLocRn4 src_loc ( + lookup_fn op `thenRn4` \ new_op -> + rn_bang_ty ty1 `thenRn4` \ new_ty1 -> + rn_bang_ty ty2 `thenRn4` \ new_ty2 -> + returnRn4 (ConOpDecl new_ty1 new_op new_ty2 src_loc) + ) + + rn_decl (NewConDecl name ty src_loc) + = pushSrcLocRn4 src_loc ( + lookup_fn name `thenRn4` \ new_name -> + rn_mono_ty ty `thenRn4` \ new_ty -> + returnRn4 (NewConDecl new_name new_ty src_loc) + ) + + rn_decl (RecConDecl con fields src_loc) + = panic "rnConDecls:RecConDecl" + + ---------- + rn_mono_ty = rnMonoType invisibles_allowed tv_env + + rn_bang_ty (Banged ty) + = rn_mono_ty ty `thenRn4` \ new_ty -> + returnRn4 (Banged new_ty) + rn_bang_ty (Unbanged ty) + = rn_mono_ty ty `thenRn4` \ new_ty -> + returnRn4 (Unbanged new_ty) \end{code} %********************************************************* %* * -\subsection{ABSTRACT type-synonym pragmas} +\subsection{SPECIALIZE data pragmas} %* * %********************************************************* \begin{code} -rnTySig4 :: ProtoNameDataTypeSig - -> Rn4M RenamedDataTypeSig - -rnTySig4 (AbstractTypeSig tycon src_loc) - = pushSrcLocRn4 src_loc ( - lookupTyCon tycon `thenRn4` \ tycon' -> - returnRn4 (AbstractTypeSig tycon' src_loc) - ) +rnSpecDataSig :: ProtoNameSpecDataSig + -> Rn4M RenamedSpecDataSig -rnTySig4 (SpecDataSig tycon ty src_loc) +rnSpecDataSig (SpecDataSig tycon ty src_loc) = pushSrcLocRn4 src_loc ( let tyvars = extractMonoTyNames eqProtoName ty in mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) -> lookupTyCon tycon `thenRn4` \ tycon' -> - rnMonoType4 False tv_env ty `thenRn4` \ ty' -> + rnMonoType False tv_env ty `thenRn4` \ ty' -> returnRn4 (SpecDataSig tycon' ty' src_loc) ) \end{code} @@ -198,33 +230,42 @@ rnTySig4 (SpecDataSig tycon ty src_loc) %* * %********************************************************* -@rnClassDecl4@ uses the `global name function' to create a new +@rnClassDecl@ uses the `global name function' to create a new class declaration in which local names have been replaced by their original names, reporting any unknown names. \begin{code} -rnClassDecl4 :: ProtoNameClassDecl -> Rn4M RenamedClassDecl +rnClassDecl :: ProtoNameClassDecl -> Rn4M RenamedClassDecl -rnClassDecl4 (ClassDecl context cname tyvar sigs mbinds pragmas src_loc) +rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc) = pushSrcLocRn4 src_loc ( mkTyVarNamesEnv src_loc [tyvar] `thenRn4` \ (tv_env, [tyvar']) -> - rnContext4 tv_env context `thenRn4` \ context' -> + rnContext tv_env context `thenRn4` \ context' -> lookupClass cname `thenRn4` \ cname' -> mapRn4 (rn_op cname' tv_env) sigs `thenRn4` \ sigs' -> - rnMethodBinds4 cname' mbinds `thenRn4` \ mbinds' -> + rnMethodBinds cname' mbinds `thenRn4` \ mbinds' -> recoverQuietlyRn4 NoClassPragmas ( - rnClassPragmas4 pragmas + rnClassPragmas pragmas ) `thenRn4` \ pragmas' -> returnRn4 (ClassDecl context' cname' tyvar' sigs' mbinds' pragmas' src_loc) ) where rn_op clas tv_env (ClassOpSig op ty pragma locn) = pushSrcLocRn4 locn ( - lookupClassOp clas op `thenRn4` \ op_name -> - rnPolyType4 False True tv_env ty `thenRn4` \ new_ty -> + lookupClassOp clas op `thenRn4` \ op_name -> + rnPolyType False tv_env ty `thenRn4` \ new_ty -> + +{- +*** Please check here that tyvar' appears in new_ty *** +*** (used to be in tcClassSig, but it's better here) +*** not_elem = isn'tIn "tcClassSigs" +*** -- Check that the class type variable is mentioned +*** checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty) +*** (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_` +-} recoverQuietlyRn4 NoClassOpPragmas ( - rnClassOpPragmas4 pragma - ) `thenRn4` \ new_pragma -> + rnClassOpPragmas pragma + ) `thenRn4` \ new_pragma -> returnRn4 (ClassOpSig op_name new_ty new_pragma locn) ) \end{code} @@ -237,41 +278,42 @@ rnClassDecl4 (ClassDecl context cname tyvar sigs mbinds pragmas src_loc) %********************************************************* -@rnInstDecl4@ uses the `global name function' to create a new of +@rnInstDecl@ uses the `global name function' to create a new of instance declaration in which local names have been replaced by their original names, reporting any unknown names. \begin{code} -rnInstDecl4 :: ProtoNameInstDecl -> Rn4M RenamedInstDecl +rnInstDecl :: ProtoNameInstDecl -> Rn4M RenamedInstDecl -rnInstDecl4 (InstDecl context cname ty mbinds from_here modname imod uprags pragmas src_loc) +rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc) = pushSrcLocRn4 src_loc ( - let tyvars = extractMonoTyNames eqProtoName ty in + let + tyvars = extract_poly_ty_names ty + in mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) -> - rnContext4 tv_env context `thenRn4` \ context' -> lookupClass cname `thenRn4` \ cname' -> - rnMonoType4 False{-no invisibles-} tv_env ty + rnPolyType False{-no invisibles-} tv_env ty `thenRn4` \ ty' -> - rnMethodBinds4 cname' mbinds `thenRn4` \ mbinds' -> + rnMethodBinds cname' mbinds `thenRn4` \ mbinds' -> mapRn4 (rn_uprag cname') uprags `thenRn4` \ new_uprags -> recoverQuietlyRn4 NoInstancePragmas ( - rnInstancePragmas4 cname' tv_env pragmas + rnInstancePragmas cname' tv_env pragmas ) `thenRn4` \ new_pragmas -> - returnRn4 (InstDecl context' cname' ty' mbinds' - from_here modname imod new_uprags new_pragmas src_loc) + returnRn4 (InstDecl cname' ty' mbinds' + from_here modname new_uprags new_pragmas src_loc) ) where rn_uprag class_name (SpecSig op ty using locn) = ASSERT(not (maybeToBool using)) -- ToDo: SPEC method with explicit spec_id pushSrcLocRn4 src_loc ( - lookupClassOp class_name op `thenRn4` \ op_name -> - rnPolyType4 False True nullTyVarNamesEnv ty `thenRn4` \ new_ty -> + lookupClassOp class_name op `thenRn4` \ op_name -> + rnPolyType False nullTyVarNamesEnv ty `thenRn4` \ new_ty -> returnRn4 (SpecSig op_name new_ty Nothing locn) ) - rn_uprag class_name (InlineSig op guide locn) + rn_uprag class_name (InlineSig op locn) = pushSrcLocRn4 locn ( lookupClassOp class_name op `thenRn4` \ op_name -> - returnRn4 (InlineSig op_name guide locn) + returnRn4 (InlineSig op_name locn) ) rn_uprag class_name (DeforestSig op locn) = pushSrcLocRn4 locn ( @@ -292,16 +334,16 @@ rnInstDecl4 (InstDecl context cname ty mbinds from_here modname imod uprags prag %********************************************************* \begin{code} -rnInstSpecSig4 :: ProtoNameSpecialisedInstanceSig - -> Rn4M RenamedSpecialisedInstanceSig +rnSpecInstSig :: ProtoNameSpecInstSig + -> Rn4M RenamedSpecInstSig -rnInstSpecSig4 (InstSpecSig clas ty src_loc) +rnSpecInstSig (SpecInstSig clas ty src_loc) = pushSrcLocRn4 src_loc ( let tyvars = extractMonoTyNames eqProtoName ty in mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) -> lookupClass clas `thenRn4` \ new_clas -> - rnMonoType4 False tv_env ty `thenRn4` \ new_ty -> - returnRn4 (InstSpecSig new_clas new_ty src_loc) + rnMonoType False tv_env ty `thenRn4` \ new_ty -> + returnRn4 (SpecInstSig new_clas new_ty src_loc) ) \end{code} @@ -311,18 +353,21 @@ rnInstSpecSig4 (InstSpecSig clas ty src_loc) %* * %********************************************************* -@rnDefaultDecl4@ uses the `global name function' to create a new set +@rnDefaultDecl@ uses the `global name function' to create a new set of default declarations in which local names have been replaced by their original names, reporting any unknown names. \begin{code} -rnDefaultDecl4 :: ProtoNameDefaultDecl -> Rn4M RenamedDefaultDecl - -rnDefaultDecl4 (DefaultDecl tys src_loc) - = pushSrcLocRn4 src_loc ( - mapRn4 (rnMonoType4 False nullTyVarNamesEnv) tys `thenRn4` \ tys' -> - returnRn4 (DefaultDecl tys' src_loc) - ) +rnDefaultDecl :: [ProtoNameDefaultDecl] -> Rn4M [RenamedDefaultDecl] + +rnDefaultDecl [] = returnRn4 [] +rnDefaultDecl [DefaultDecl tys src_loc] + = pushSrcLocRn4 src_loc $ + mapRn4 (rnMonoType False nullTyVarNamesEnv) tys `thenRn4` \ tys' -> + returnRn4 [DefaultDecl tys' src_loc] +rnDefaultDecl defs@(d:ds) + = addErrRn4 (dupDefaultDeclErr defs) `thenRn4_` + rnDefaultDecl [d] \end{code} %************************************************************************* @@ -332,19 +377,19 @@ rnDefaultDecl4 (DefaultDecl tys src_loc) %************************************************************************* Non-interface type signatures (which may include user-pragmas) are -handled with @Binds@. +handled with @HsBinds@. @ClassOpSigs@ are dealt with in class declarations. \begin{code} -rnIntSig4 :: ProtoNameSig -> Rn4M RenamedSig +rnIntSig :: ProtoNameSig -> Rn4M RenamedSig -rnIntSig4 (Sig name ty pragma src_loc) +rnIntSig (Sig name ty pragma src_loc) = pushSrcLocRn4 src_loc ( lookupValue name `thenRn4` \ new_name -> - rnPolyType4 False True nullTyVarNamesEnv ty `thenRn4` \ new_ty -> + rnPolyType False nullTyVarNamesEnv ty `thenRn4` \ new_ty -> recoverQuietlyRn4 NoGenPragmas ( - rnGenPragmas4 pragma + rnGenPragmas pragma ) `thenRn4` \ new_pragma -> returnRn4 (Sig new_name new_ty new_pragma src_loc) ) @@ -357,9 +402,9 @@ rnIntSig4 (Sig name ty pragma src_loc) %************************************************************************* \begin{code} -rnFixes4 :: [ProtoNameFixityDecl] -> Rn4M [RenamedFixityDecl] +rnFixes :: [ProtoNameFixityDecl] -> Rn4M [RenamedFixityDecl] -rnFixes4 fixities +rnFixes fixities = mapRn4 rn_fixity fixities `thenRn4` \ fixes_maybe -> returnRn4 (catMaybes fixes_maybe) where @@ -395,119 +440,117 @@ rnFixes4 fixities %********************************************************* \begin{code} -rnPolyType4 :: Bool -- True <=> "invisible" tycons (in pragmas) allowed - -> Bool -- True <=> snaffle tyvars from ty and - -- stuff them in tyvar env; True for - -- signatures and things; False for type - -- synonym defns and things. +rnPolyType :: Bool -- True <=> "invisible" tycons (in pragmas) allowed -> TyVarNamesEnv -> ProtoNamePolyType -> Rn4M RenamedPolyType -rnPolyType4 invisibles_allowed snaffle_tyvars tv_env (UnoverloadedTy ty) - = rn_poly_help invisibles_allowed snaffle_tyvars tv_env [] ty `thenRn4` \ (_, new_ty) -> - returnRn4 (UnoverloadedTy new_ty) +rnPolyType invisibles_allowed tv_env (HsForAllTy tvs ctxt ty) + = rn_poly_help invisibles_allowed tv_env tvs ctxt ty -rnPolyType4 invisibles_allowed snaffle_tyvars tv_env (OverloadedTy ctxt ty) - = rn_poly_help invisibles_allowed snaffle_tyvars tv_env ctxt ty `thenRn4` \ (new_ctxt, new_ty) -> - returnRn4 (OverloadedTy new_ctxt new_ty) +rnPolyType invisibles_allowed tv_env poly_ty@(HsPreForAllTy ctxt ty) + = rn_poly_help invisibles_allowed tv_env forall_tyvars ctxt ty + where + mentioned_tyvars = extract_poly_ty_names poly_ty -rnPolyType4 invisibles_allowed snaffle_tyvars tv_env (ForAllTy tvs ty) - = getSrcLocRn4 `thenRn4` \ src_loc -> - mkTyVarNamesEnv src_loc tvs `thenRn4` \ (tvenv2, new_tvs) -> - let - new_tvenv = catTyVarNamesEnvs tvenv2 tv_env - in - rnMonoType4 invisibles_allowed new_tvenv ty `thenRn4` \ new_ty -> - returnRn4 (ForAllTy new_tvs new_ty) + forall_tyvars = mentioned_tyvars `minus_list` domTyVarNamesEnv tv_env + + -- URGH! Why is this here? SLPJ + -- Because we are doing very delicate comparisons + -- (eqProtoName and all that); if we got rid of + -- that, then we could use ListSetOps stuff. WDP + minus_list xs ys = [ x | x <- xs, not (x `elemProtoNames` ys)] ------------ -rn_poly_help invisibles_allowed snaffle_tyvars tv_env ctxt ty - = getSrcLocRn4 `thenRn4` \ src_loc -> - let - -- ToDo: this randomly-grabbing-tyvar names out - -- of the type seems a little weird to me - -- (WDP 94/11) +extract_poly_ty_names (HsPreForAllTy ctxt ty) + = extractCtxtTyNames eqProtoName ctxt + `union_list` + extractMonoTyNames eqProtoName ty + where + -- see comment above + union_list [] [] = [] + union_list [] b = b + union_list a [] = a + union_list (a:as) b + | a `elemProtoNames` b = union_list as b + | otherwise = a : union_list as b - new_tyvars - = extractMonoTyNames eqProtoName ty - `minus_list` domTyVarNamesEnv tv_env - in - mkTyVarNamesEnv src_loc new_tyvars `thenRn4` \ (tv_env2, _) -> +------------ +rn_poly_help :: Bool + -> TyVarNamesEnv + -> [ProtoName] + -> ProtoNameContext + -> ProtoNameMonoType + -> Rn4M RenamedPolyType + +rn_poly_help invisibles_allowed tv_env tyvars ctxt ty + = getSrcLocRn4 `thenRn4` \ src_loc -> + mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env1, new_tyvars) -> let - tv_env3 = if snaffle_tyvars - then catTyVarNamesEnvs tv_env2 tv_env - else tv_env -- leave it alone + tv_env2 = catTyVarNamesEnvs tv_env1 tv_env in - rnContext4 tv_env3 ctxt `thenRn4` \ new_ctxt -> - rnMonoType4 invisibles_allowed tv_env3 ty - `thenRn4` \ new_ty -> - returnRn4 (new_ctxt, new_ty) - where - minus_list xs ys = [ x | x <- xs, not (x `elemProtoNames` ys)] + rnContext tv_env2 ctxt `thenRn4` \ new_ctxt -> + rnMonoType invisibles_allowed tv_env2 ty `thenRn4` \ new_ty -> + returnRn4 (HsForAllTy new_tyvars new_ctxt new_ty) \end{code} \begin{code} -rnMonoType4 :: Bool -- allowed to look at invisible tycons +rnMonoType :: Bool -- allowed to look at invisible tycons -> TyVarNamesEnv -> ProtoNameMonoType -> Rn4M RenamedMonoType -rnMonoType4 invisibles_allowed tv_env (MonoTyVar tyvar) +rnMonoType invisibles_allowed tv_env (MonoTyVar tyvar) = lookupTyVarName tv_env tyvar `thenRn4` \ tyvar' -> returnRn4 (MonoTyVar tyvar') -rnMonoType4 invisibles_allowed tv_env (ListMonoTy ty) - = rnMonoType4 invisibles_allowed tv_env ty `thenRn4` \ ty' -> - returnRn4 (ListMonoTy ty') +rnMonoType invisibles_allowed tv_env (MonoListTy ty) + = rnMonoType invisibles_allowed tv_env ty `thenRn4` \ ty' -> + returnRn4 (MonoListTy ty') -rnMonoType4 invisibles_allowed tv_env (FunMonoTy ty1 ty2) - = andRn4 FunMonoTy (rnMonoType4 invisibles_allowed tv_env ty1) - (rnMonoType4 invisibles_allowed tv_env ty2) +rnMonoType invisibles_allowed tv_env (MonoFunTy ty1 ty2) + = andRn4 MonoFunTy (rnMonoType invisibles_allowed tv_env ty1) + (rnMonoType invisibles_allowed tv_env ty2) -rnMonoType4 invisibles_allowed tv_env (TupleMonoTy tys) - = mapRn4 (rnPolyType4 invisibles_allowed False tv_env) tys `thenRn4` \ tys' -> - returnRn4 (TupleMonoTy tys') +rnMonoType invisibles_allowed tv_env (MonoTupleTy tys) + = mapRn4 (rnMonoType invisibles_allowed tv_env) tys `thenRn4` \ tys' -> + returnRn4 (MonoTupleTy tys') -rnMonoType4 invisibles_allowed tv_env (MonoTyCon name tys) +rnMonoType invisibles_allowed tv_env (MonoTyApp name tys) = let - lookup_fn = if invisibles_allowed - then lookupTyConEvenIfInvisible - else lookupTyCon + lookup_fn = if isAvarid (getOccurrenceName name) + then lookupTyVarName tv_env + else if invisibles_allowed + then lookupTyConEvenIfInvisible + else lookupTyCon in - lookup_fn name `thenRn4` \ tycon_name' -> - mapRn4 (rnMonoType4 invisibles_allowed tv_env) tys `thenRn4` \ tys' -> - returnRn4 (MonoTyCon tycon_name' tys') + lookup_fn name `thenRn4` \ name' -> + mapRn4 (rnMonoType invisibles_allowed tv_env) tys `thenRn4` \ tys' -> + returnRn4 (MonoTyApp name' tys') -- for unfoldings only: -rnMonoType4 invisibles_allowed tv_env (MonoTyVarTemplate name) - = --pprTrace "rnMonoType4:MonoTyVarTemplate:" (ppAbove (ppr PprDebug name) (ppr PprDebug tv_env)) ( - lookupTyVarName tv_env name `thenRn4` \ new_name -> - returnRn4 (MonoTyVarTemplate new_name) - --) +rnMonoType invisibles_allowed tv_env (MonoForAllTy tyvars_w_kinds ty) + = getSrcLocRn4 `thenRn4` \ src_loc -> + mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env1, new_tyvars) -> + let + tv_env2 = catTyVarNamesEnvs tv_env1 tv_env + in + rnMonoType invisibles_allowed tv_env2 ty `thenRn4` \ ty' -> + returnRn4 (MonoForAllTy (new_tyvars `zip` kinds) ty') + where + (tyvars, kinds) = unzip tyvars_w_kinds -rnMonoType4 invisibles_allowed tv_env (MonoDict clas ty) +rnMonoType invisibles_allowed tv_env (MonoDictTy clas ty) = lookupClass clas `thenRn4` \ new_clas -> - rnMonoType4 invisibles_allowed tv_env ty `thenRn4` \ new_ty -> - returnRn4 (MonoDict new_clas new_ty) - -#ifdef DPH -rnMonoType4 invisibles_allowed tv_env (MonoTyProc tys ty) - = mapRn4 (rnMonoType4 invisibles_allowed tv_env) tys `thenRn4` \ tys' -> - rnMonoType4 invisibles_allowed tv_env ty `thenRn4` \ ty' -> - returnRn4 (MonoTyProc tys' ty') - -rnMonoType4 invisibles_allowed tv_env (MonoTyPod ty) - = rnMonoType4 invisibles_allowed tv_env ty `thenRn4` \ ty' -> - returnRn4 (MonoTyPod ty') -#endif {- Data Parallel Haskell -} + rnMonoType invisibles_allowed tv_env ty `thenRn4` \ new_ty -> + returnRn4 (MonoDictTy new_clas new_ty) \end{code} \begin{code} -rnContext4 :: TyVarNamesEnv -> ProtoNameContext -> Rn4M RenamedContext +rnContext :: TyVarNamesEnv -> ProtoNameContext -> Rn4M RenamedContext -rnContext4 tv_env ctxt +rnContext tv_env ctxt = mapRn4 rn_ctxt ctxt where rn_ctxt (clas, tyvar) @@ -523,8 +566,8 @@ rnContext4 tv_env ctxt %********************************************************* \begin{code} -rnDataPragmas4 tv_env (DataPragmas cons specs) - = rnConDecls4 tv_env True{-invisibles allowed-} cons `thenRn4` \ new_cons -> +rnDataPragmas tv_env (DataPragmas cons specs) + = rnConDecls tv_env True{-invisibles allowed-} cons `thenRn4` \ new_cons -> mapRn4 types_n_spec specs `thenRn4` \ new_specs -> returnRn4 (DataPragmas new_cons new_specs) where @@ -533,63 +576,65 @@ rnDataPragmas4 tv_env (DataPragmas cons specs) \end{code} \begin{code} -rnClassOpPragmas4 NoClassOpPragmas = returnRn4 NoClassOpPragmas +rnClassOpPragmas NoClassOpPragmas = returnRn4 NoClassOpPragmas -rnClassOpPragmas4 (ClassOpPragmas dsel defm) - = recoverQuietlyRn4 NoGenPragmas (rnGenPragmas4 dsel) `thenRn4` \ new_dsel -> - recoverQuietlyRn4 NoGenPragmas (rnGenPragmas4 defm) `thenRn4` \ new_defm -> +rnClassOpPragmas (ClassOpPragmas dsel defm) + = recoverQuietlyRn4 NoGenPragmas (rnGenPragmas dsel) `thenRn4` \ new_dsel -> + recoverQuietlyRn4 NoGenPragmas (rnGenPragmas defm) `thenRn4` \ new_defm -> returnRn4 (ClassOpPragmas new_dsel new_defm) \end{code} \begin{code} -rnClassPragmas4 NoClassPragmas = returnRn4 NoClassPragmas +rnClassPragmas NoClassPragmas = returnRn4 NoClassPragmas -rnClassPragmas4 (SuperDictPragmas sds) - = mapRn4 rnGenPragmas4 sds `thenRn4` \ new_sds -> +rnClassPragmas (SuperDictPragmas sds) + = mapRn4 rnGenPragmas sds `thenRn4` \ new_sds -> returnRn4 (SuperDictPragmas new_sds) \end{code} NB: In various cases around here, we don't @recoverQuietlyRn4@ around -calls to @rnGenPragmas4@; not really worth it. +calls to @rnGenPragmas@; not really worth it. \begin{code} -rnInstancePragmas4 _ _ NoInstancePragmas = returnRn4 NoInstancePragmas +rnInstancePragmas _ _ NoInstancePragmas = returnRn4 NoInstancePragmas -rnInstancePragmas4 _ _ (SimpleInstancePragma dfun) - = rnGenPragmas4 dfun `thenRn4` \ new_dfun -> +rnInstancePragmas _ _ (SimpleInstancePragma dfun) + = rnGenPragmas dfun `thenRn4` \ new_dfun -> returnRn4 (SimpleInstancePragma new_dfun) -rnInstancePragmas4 clas tv_env (ConstantInstancePragma dfun constms) +rnInstancePragmas clas tv_env (ConstantInstancePragma dfun constms) = recoverQuietlyRn4 NoGenPragmas ( - rnGenPragmas4 dfun + rnGenPragmas dfun ) `thenRn4` \ new_dfun -> mapRn4 name_n_gen constms `thenRn4` \ new_constms -> returnRn4 (ConstantInstancePragma new_dfun new_constms) where name_n_gen (op, gen) = lookupClassOp clas op `thenRn4` \ new_op -> - rnGenPragmas4 gen `thenRn4` \ new_gen -> + rnGenPragmas gen `thenRn4` \ new_gen -> returnRn4 (new_op, new_gen) -rnInstancePragmas4 clas tv_env (SpecialisedInstancePragma dfun specs) +rnInstancePragmas clas tv_env (SpecialisedInstancePragma dfun specs) = recoverQuietlyRn4 NoGenPragmas ( - rnGenPragmas4 dfun + rnGenPragmas dfun ) `thenRn4` \ new_dfun -> mapRn4 types_n_spec specs `thenRn4` \ new_specs -> returnRn4 (SpecialisedInstancePragma new_dfun new_specs) where types_n_spec (ty_maybes, dicts_to_ignore, inst) = mapRn4 (rn_ty_maybe tv_env) ty_maybes `thenRn4` \ new_tys -> - rnInstancePragmas4 clas tv_env inst `thenRn4` \ new_inst -> + rnInstancePragmas clas tv_env inst `thenRn4` \ new_inst -> returnRn4 (new_tys, dicts_to_ignore, new_inst) \end{code} And some general pragma stuff: (Not sure what, if any, of this would benefit from a TyVarNamesEnv passed in.... [ToDo]) \begin{code} -rnGenPragmas4 NoGenPragmas = returnRn4 NoGenPragmas +rnGenPragmas :: ProtoNameGenPragmas -> Rn4M RenamedGenPragmas -rnGenPragmas4 (GenPragmas arity upd def strict unfold specs) +rnGenPragmas NoGenPragmas = returnRn4 NoGenPragmas + +rnGenPragmas (GenPragmas arity upd def strict unfold specs) = recoverQuietlyRn4 NoImpUnfolding ( rn_unfolding unfold ) `thenRn4` \ new_unfold -> @@ -612,7 +657,7 @@ rnGenPragmas4 (GenPragmas arity upd def strict unfold specs) rn_strictness (ImpStrictness is_bot ww_info wrkr_info) = recoverQuietlyRn4 NoGenPragmas ( - rnGenPragmas4 wrkr_info + rnGenPragmas wrkr_info ) `thenRn4` \ new_wrkr_info -> returnRn4 (ImpStrictness is_bot ww_info new_wrkr_info) @@ -620,7 +665,7 @@ rnGenPragmas4 (GenPragmas arity upd def strict unfold specs) types_n_gen (ty_maybes, dicts_to_ignore, gen) = mapRn4 (rn_ty_maybe no_env) ty_maybes `thenRn4` \ new_tys -> recoverQuietlyRn4 NoGenPragmas ( - rnGenPragmas4 gen + rnGenPragmas gen ) `thenRn4` \ new_gen -> returnRn4 (new_tys, dicts_to_ignore, new_gen) where @@ -630,67 +675,50 @@ rnGenPragmas4 (GenPragmas arity upd def strict unfold specs) rn_ty_maybe tv_env Nothing = returnRn4 Nothing rn_ty_maybe tv_env (Just ty) - = rnMonoType4 True{-invisibles OK-} tv_env ty `thenRn4` \ new_ty -> + = rnMonoType True{-invisibles OK-} tv_env ty `thenRn4` \ new_ty -> returnRn4 (Just new_ty) ------------ -rn_core tvenv (UfCoVar v) +rn_core tvenv (UfVar v) = rn_uf_id tvenv v `thenRn4` \ vname -> - returnRn4 (UfCoVar vname) + returnRn4 (UfVar vname) -rn_core tvenv (UfCoLit lit) - = returnRn4 (UfCoLit lit) +rn_core tvenv (UfLit lit) + = returnRn4 (UfLit lit) -rn_core tvenv (UfCoCon con tys as) +rn_core tvenv (UfCon con tys as) = lookupValueEvenIfInvisible con `thenRn4` \ new_con -> mapRn4 (rn_core_type tvenv) tys `thenRn4` \ new_tys -> mapRn4 (rn_atom tvenv) as `thenRn4` \ new_as -> - returnRn4 (UfCoCon new_con new_tys new_as) + returnRn4 (UfCon new_con new_tys new_as) -rn_core tvenv (UfCoPrim op tys as) +rn_core tvenv (UfPrim op tys as) = rn_core_primop tvenv op `thenRn4` \ new_op -> mapRn4 (rn_core_type tvenv) tys `thenRn4` \ new_tys -> mapRn4 (rn_atom tvenv) as `thenRn4` \ new_as -> - returnRn4 (UfCoPrim new_op new_tys new_as) + returnRn4 (UfPrim new_op new_tys new_as) -rn_core tvenv (UfCoLam binders body) - = mapRn4 (rn_binder tvenv) binders `thenRn4` \ new_binders -> - let - bs = [ b | (b, ty) <- new_binders ] - in - extendSS bs (rn_core tvenv body) `thenRn4` \ new_body -> - returnRn4 (UfCoLam new_binders new_body) +rn_core tvenv (UfLam binder body) + = rn_binder tvenv binder `thenRn4` \ (b,ty) -> + extendSS [b] (rn_core tvenv body) `thenRn4` \ new_body -> + returnRn4 (UfLam (b,ty) new_body) -rn_core tvenv (UfCoTyLam tv body) - = getSrcLocRn4 `thenRn4` \ src_loc -> - mkTyVarNamesEnv src_loc [tv] `thenRn4` \ (tvenv2, [new_tv]) -> - let - new_tvenv = catTyVarNamesEnvs tvenv2 tvenv - in - rn_core new_tvenv body `thenRn4` \ new_body -> - returnRn4 (UfCoTyLam new_tv new_body) - -rn_core tvenv (UfCoApp fun arg) +rn_core tvenv (UfApp fun arg) = rn_core tvenv fun `thenRn4` \ new_fun -> rn_atom tvenv arg `thenRn4` \ new_arg -> - returnRn4 (UfCoApp new_fun new_arg) - -rn_core tvenv (UfCoTyApp expr ty) - = rn_core tvenv expr `thenRn4` \ new_expr -> - rn_core_type tvenv ty `thenRn4` \ new_ty -> - returnRn4 (UfCoTyApp new_expr new_ty) + returnRn4 (UfApp new_fun new_arg) -rn_core tvenv (UfCoCase expr alts) +rn_core tvenv (UfCase expr alts) = rn_core tvenv expr `thenRn4` \ new_expr -> rn_alts alts `thenRn4` \ new_alts -> - returnRn4 (UfCoCase new_expr new_alts) + returnRn4 (UfCase new_expr new_alts) where rn_alts (UfCoAlgAlts alg_alts deflt) = mapRn4 rn_alg_alt alg_alts `thenRn4` \ new_alts -> - rn_deflt deflt `thenRn4` \ new_deflt -> + rn_deflt deflt `thenRn4` \ new_deflt -> returnRn4 (UfCoAlgAlts new_alts new_deflt) where - rn_alg_alt (con, params, rhs) + rn_alg_alt (con, params, rhs) = lookupValueEvenIfInvisible con `thenRn4` \ new_con -> mapRn4 (rn_binder tvenv) params `thenRn4` \ new_params -> let @@ -701,10 +729,10 @@ rn_core tvenv (UfCoCase expr alts) rn_alts (UfCoPrimAlts prim_alts deflt) = mapRn4 rn_prim_alt prim_alts `thenRn4` \ new_alts -> - rn_deflt deflt `thenRn4` \ new_deflt -> + rn_deflt deflt `thenRn4` \ new_deflt -> returnRn4 (UfCoPrimAlts new_alts new_deflt) where - rn_prim_alt (lit, rhs) + rn_prim_alt (lit, rhs) = rn_core tvenv rhs `thenRn4` \ new_rhs -> returnRn4 (lit, new_rhs) @@ -714,14 +742,14 @@ rn_core tvenv (UfCoCase expr alts) extendSS [binder] (rn_core tvenv rhs) `thenRn4` \ new_rhs -> returnRn4 (UfCoBindDefault new_b new_rhs) -rn_core tvenv (UfCoLet bind body) +rn_core tvenv (UfLet bind body) = rn_bind bind `thenRn4` \ (new_bind, new_binders) -> extendSS new_binders (rn_core tvenv body) `thenRn4` \ new_body -> - returnRn4 (UfCoLet new_bind new_body) + returnRn4 (UfLet new_bind new_body) where rn_bind (UfCoNonRec b rhs) = rn_binder tvenv b `thenRn4` \ new_b@(binder, ty) -> - rn_core tvenv rhs `thenRn4` \ new_rhs -> + rn_core tvenv rhs `thenRn4` \ new_rhs -> returnRn4 (UfCoNonRec new_b new_rhs, [binder]) rn_bind (UfCoRec pairs) @@ -744,10 +772,10 @@ rn_core tvenv (UfCoLet bind body) rn_core tvenv rhs `thenRn4` \ new_rhs -> returnRn4 ((new_b, new_ty), new_rhs) -rn_core tvenv (UfCoSCC uf_cc body) +rn_core tvenv (UfSCC uf_cc body) = rn_cc uf_cc `thenRn4` \ new_cc -> rn_core tvenv body `thenRn4` \ new_body -> - returnRn4 (UfCoSCC new_cc new_body) + returnRn4 (UfSCC new_cc new_body) where rn_cc (UfAutoCC id m g is_dupd is_caf) = rn_uf_id tvenv id `thenRn4` \ new_id -> @@ -832,5 +860,18 @@ rn_core_type_maybe tvenv (Just ty) ------------ rn_core_type tvenv ty - = rnPolyType4 True{-invisible tycons OK-} False tvenv ty + = rnPolyType True{-invisible tycons OK-} tvenv ty +\end{code} + + +\begin{code} +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)) + where + pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc \end{code} diff --git a/ghc/compiler/rename/RenameAuxFuns.lhs b/ghc/compiler/rename/RnUtils.lhs index 68106c1090..1d4e45ba12 100644 --- a/ghc/compiler/rename/RenameAuxFuns.lhs +++ b/ghc/compiler/rename/RnUtils.lhs @@ -1,48 +1,46 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % -\section[Rename-aux-funs]{Functions used by both renaming passes} +\section[RnUtils]{Functions used by both renaming passes} \begin{code} #include "HsVersions.h" -module RenameAuxFuns ( +module RnUtils ( mkGlobalNameFun, mkNameFun, - GlobalNameFun(..), GlobalNameFuns(..), - PreludeNameFun(..), PreludeNameFuns(..), + GlobalNameMapper(..), GlobalNameMappers(..), + PreludeNameMapper(..), PreludeNameMappers(..), - -- and for self-containedness... - Bag, ProtoName, Maybe + dupNamesErr -- used in various places ) where -IMPORT_Trace -- ToDo: rm (for debugging) -import Outputable -import Pretty +import Ubiq{-uitous-} -import Bag ( Bag, bagToList ) -import FiniteMap -import Maybes -import Name ( Name ) -- for instances ---OLD: import NameEnv -import ProtoName -import Util +import Bag ( bagToList, Bag ) +import FiniteMap ( lookupFM, listToFM ) +import Name ( Name{-instances-} ) +import Outputable ( pprNonOp ) +import PprStyle ( PprStyle(..) ) +import Pretty +import ProtoName ( ProtoName(..) ) +import Util ( cmpPString, removeDups, pprPanic, panic ) \end{code} \begin{code} -type GlobalNameFun = ProtoName -> Maybe Name -type GlobalNameFuns = (GlobalNameFun, GlobalNameFun) +type GlobalNameMapper = ProtoName -> Maybe Name +type GlobalNameMappers = (GlobalNameMapper, GlobalNameMapper) -type PreludeNameFun = FAST_STRING -> Maybe Name -type PreludeNameFuns = (PreludeNameFun, -- Values - PreludeNameFun -- Types and classes +type PreludeNameMapper = FAST_STRING -> Maybe Name +type PreludeNameMappers = (PreludeNameMapper, -- Values + PreludeNameMapper -- Types and classes ) \end{code} \begin{code} mkGlobalNameFun :: FAST_STRING -- The module name - -> PreludeNameFun -- The prelude things - -> [(ProtoName, Name)] -- The local and imported things - -> GlobalNameFun -- The global name function + -> PreludeNameMapper -- The prelude things + -> [(ProtoName, Name)] -- The local and imported things + -> GlobalNameMapper -- The global name function mkGlobalNameFun this_module prel_nf alist = the_fun @@ -59,7 +57,7 @@ mkGlobalNameFun this_module prel_nf alist -- for a prelude thing. -- -- Neither should they be in the domain of the imp_fun, because - -- prelude things will have been converted to Prel x rather than + -- prelude things will have been converted to Prel x rather than -- Imp p q r s. -- -- So we strip out prelude things from the alist; this is not just @@ -76,10 +74,6 @@ mkGlobalNameFun this_module prel_nf alist unk_fun = lookupFM (listToFM [(get_local pn,n) | (pn,n) <- non_prel_alist]) imp_fun = lookupFM (listToFM [(get_orig pn,n) | (pn,n) <- non_prel_alist]) -{- OLD: - unk_fun = mkStringLookupFn [(get_local pn,n) | (pn,n) <- non_prel_alist] False{-not sorted-} - imp_fun = mk2StringLookupFn [(get_orig pn,n) | (pn,n) <- non_prel_alist] False{-not sorted-} --} -- the lists *are* sorted by *some* ordering (by local -- names), but not generally, and not in some way we -- are going to rely on. @@ -121,12 +115,24 @@ mkNameFun :: Bag (FAST_STRING, thing) -- Value bindings mkNameFun the_bag = case (removeDups cmp (bagToList the_bag)) of { (no_dup_list, dups) -> - case (lookupFM (listToFM no_dup_list)) of { the_fun -> - --OLD :case (mkStringLookupFn no_dup_list True{-list is pre-sorted-}) of the_fun -> - (the_fun, dups) - }} + case (lookupFM (listToFM no_dup_list)) of { the_fun -> + (the_fun, dups) }} where cmp :: (FAST_STRING, a) -> (FAST_STRING, a) -> TAG_ cmp (s1,_) (s2,_) = _CMP_STRING_ s1 s2 \end{code} + +\begin{code} +dupNamesErr descriptor ((first_pname,locn1) : dup_things) sty + = ppAboves (first_item : map dup_item dup_things) + where + first_item + = ppBesides [ ppr PprForUser locn1, + ppStr ": multiple declarations of a ", ppStr descriptor, ppStr ": ", + pprNonOp sty first_pname ] + + dup_item (pname, locn) + = ppBesides [ ppr PprForUser locn, + ppStr ": here was another declaration of `", pprNonOp sty pname, ppStr "'" ] +\end{code} |