bindLocatedLocalsRn (text "a binding group") mbinders_w_srclocs
$ \ new_mbinders ->
let
- binder_set = mkNameSet new_mbinders
+ binder_set = mkNameSet new_mbinders
+ binder_occ_fm = listToFM [(nameOccName x,x) | x <- new_mbinders]
-- Weed out the fixity declarations that do not
-- apply to any of the binders in this group.
forLocalBind (FixSig sig@(FixitySig name _ _ )) =
isJust (lookupFM binder_occ_fm (rdrNameOcc name))
forLocalBind _ = True
-
- binder_occ_fm = listToFM [(nameOccName x,x) | x <- new_mbinders]
-
in
- -- Report the fixity declarations in this group that
- -- don't refer to any of the group's binders.
- --
- mapRn_ (unknownSigErr) fixes_not_for_me `thenRn_`
+ -- Rename the signatures
renameSigs False binder_set
(lookupSigOccRn binder_occ_fm) sigs_for_me `thenRn` \ (siglist, sig_fvs) ->
+
+ -- Report the fixity declarations in this group that
+ -- don't refer to any of the group's binders.
+ -- Then install the fixity declarations that do apply here
+ -- Notice that they scope over thing_inside too
+ mapRn_ (unknownSigErr) fixes_not_for_me `thenRn_`
let
fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- siglist ]
in
- -- Install the fixity declarations that do apply here and go.
- extendFixityEnv fixity_sigs (
- rn_mono_binds siglist mbinds
- ) `thenRn` \ (binds, bind_fvs) ->
+ extendFixityEnv fixity_sigs $
+
+ rn_mono_binds siglist mbinds `thenRn` \ (binds, bind_fvs) ->
-- Now do the "thing inside", and deal with the free-variable calculations
thing_inside binds `thenRn` \ (result,result_fvs) ->
-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
-- Doesn't seem worth much trouble to sort this.
+renameSig :: (RdrName -> RnMS Name) -> Sig RdrName -> RnMS (Sig Name, FreeVars)
+
renameSig lookup_occ_nm (Sig v ty src_loc)
= pushSrcLocRn src_loc $
lookup_occ_nm v `thenRn` \ new_v ->
lookup_occ_nm v `thenRn` \ new_v ->
returnRn (FixSig (FixitySig new_v fix src_loc), unitFV new_v)
-renameSig lookup_occ_nm (DeprecSig v txt src_loc)
+renameSig lookup_occ_nm (DeprecSig (Deprecation ie txt) src_loc)
= pushSrcLocRn src_loc $
- lookup_occ_nm v `thenRn` \ new_v ->
- returnRn (DeprecSig new_v txt src_loc, unitFV new_v)
+ renameIE lookup_occ_nm ie `thenRn` \ (new_ie, fvs) ->
+ returnRn (DeprecSig (Deprecation new_ie txt) src_loc, fvs)
renameSig lookup_occ_nm (InlineSig v p src_loc)
= pushSrcLocRn src_loc $
returnRn (NoInlineSig new_v p src_loc, unitFV new_v)
\end{code}
+\begin{code}
+renameIE :: (RdrName -> RnMS Name) -> IE RdrName -> RnMS (IE Name, FreeVars)
+renameIE lookup_occ_nm (IEVar v)
+ = lookup_occ_nm v `thenRn` \ new_v ->
+ returnRn (IEVar new_v, unitFV new_v)
+
+renameIE lookup_occ_nm (IEThingAbs v)
+ = lookup_occ_nm v `thenRn` \ new_v ->
+ returnRn (IEThingAbs new_v, unitFV new_v)
+
+renameIE lookup_occ_nm (IEThingAll v)
+ = lookup_occ_nm v `thenRn` \ new_v ->
+ returnRn (IEThingAll new_v, unitFV new_v)
+
+renameIE lookup_occ_nm (IEThingWith v vs)
+ = lookup_occ_nm v `thenRn` \ new_v ->
+ mapRn lookup_occ_nm vs `thenRn` \ new_vs ->
+ returnRn (IEThingWith new_v new_vs, plusFVs [ unitFV x | x <- new_v:new_vs ])
+
+renameIE lookup_occ_nm (IEModuleContents m)
+ = returnRn (IEModuleContents m, emptyFVs)
+\end{code}
+
Checking for distinct signatures; oh, so boring
+
\begin{code}
cmp_sig :: RenamedSig -> RenamedSig -> Ordering
-cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
-cmp_sig (DeprecSig n1 _ _) (DeprecSig n2 _ _) = n1 `compare` n2
-cmp_sig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 `compare` n2
-cmp_sig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 `compare` n2
-cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2
+cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
+cmp_sig (DeprecSig (Deprecation ie1 _) _)
+ (DeprecSig (Deprecation ie2 _) _) = cmp_ie ie1 ie2
+cmp_sig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 `compare` n2
+cmp_sig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 `compare` n2
+cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2
cmp_sig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _)
= -- may have many specialisations for one value;
-- but not ones that are exactly the same...
| (sig_tag other_1) _LT_ (sig_tag other_2) = LT
| otherwise = GT
+cmp_ie :: IE Name -> IE Name -> Ordering
+cmp_ie (IEVar n1 ) (IEVar n2 ) = n1 `compare` n2
+cmp_ie (IEThingAbs n1 ) (IEThingAbs n2 ) = n1 `compare` n2
+cmp_ie (IEThingAll n1 ) (IEThingAll n2 ) = n1 `compare` n2
+-- Hmmm...
+cmp_ie (IEThingWith n1 _) (IEThingWith n2 _) = n1 `compare` n2
+cmp_ie (IEModuleContents _ ) (IEModuleContents _ ) = EQ
+
sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)
sig_tag (SpecSig n1 _ _) = ILIT(2)
sig_tag (InlineSig n1 _ _) = ILIT(3)
sig_tag (NoInlineSig n1 _ _) = ILIT(4)
sig_tag (SpecInstSig _ _) = ILIT(5)
sig_tag (FixSig _) = ILIT(6)
-sig_tag (DeprecSig _ _ _) = ILIT(7)
+sig_tag (DeprecSig _ _) = ILIT(7)
sig_tag _ = panic# "tag(RnBinds)"
\end{code}
sig_doc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc)
sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
sig_doc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
-sig_doc (DeprecSig _ _ loc) = (SLIT("DEPRECATED pragma"), loc)
+sig_doc (DeprecSig _ loc) = (SLIT("DEPRECATED pragma"), loc)
missingSigWarn var
= sep [ptext SLIT("definition but no type signature for"), quotes (ppr var)]
projects / ghc-hetmet.git / blobdiff