%
-% (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
[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)
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
%************************************************************************
%* *
-\subsection[FixityDecls-Rename2]{Functions for @FixityDecls@}
+\subsection[FixityDecls-RnPass2]{Functions for @FixityDecls@}
%* *
%************************************************************************
%************************************************************************
%* *
-\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}
(\ 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.
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
= 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)
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@}
%* *
%************************************************************************
%************************************************************************
%* *
-\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
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)
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
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}
%************************************************************************
%* *
-\subsection[SpecInstSigs-Rename2]{Functions for @AbstractTypeSigs@}
+\subsection[SpecInstSigs-RnPass2]{Functions for @AbstractTypeSigs@}
%* *
%************************************************************************
\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}
%************************************************************************
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
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 ->
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 )
-> [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}
projects / ghc-hetmet.git / blobdiff