- rename_sig (Sig v ty pragmas src_loc)
- = pushSrcLocRn src_loc $
- if not (v `elem` binder_occnames) then
- addErrRn (unknownSigDeclErr "type signature" v src_loc) `thenRn_`
- returnRn Nothing
- else
- lookupValue v `thenRn` \ new_v ->
- rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
-
- ASSERT(isNoGenPragmas pragmas)
- returnRn (Just (Sig new_v new_ty noGenPragmas src_loc))
-
- -- and now, the various flavours of value-modifying user-pragmas:
-
- rename_sig (SpecSig v ty using src_loc)
- = pushSrcLocRn src_loc $
- if not (v `elem` binder_occnames) then
- addErrRn (unknownSigDeclErr "SPECIALIZE pragma" v src_loc) `thenRn_`
- returnRn Nothing
- else
- lookupValue v `thenRn` \ new_v ->
- rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
- rn_using using `thenRn` \ new_using ->
- returnRn (Just (SpecSig new_v new_ty new_using src_loc))
- where
- rn_using Nothing = returnRn Nothing
- rn_using (Just x) = lookupValue x `thenRn` \ new_x ->
- returnRn (Just new_x)
-
- rename_sig (InlineSig v src_loc)
- = pushSrcLocRn src_loc $
- if not (v `elem` binder_occnames) then
- addErrRn (unknownSigDeclErr "INLINE pragma" v src_loc) `thenRn_`
- returnRn Nothing
- else
- lookupValue v `thenRn` \ new_v ->
- returnRn (Just (InlineSig new_v src_loc))
-
- rename_sig (DeforestSig v src_loc)
- = pushSrcLocRn src_loc $
- if not (v `elem` binder_occnames) then
- addErrRn (unknownSigDeclErr "DEFOREST pragma" v src_loc) `thenRn_`
- returnRn Nothing
- else
- lookupValue v `thenRn` \ new_v ->
- returnRn (Just (DeforestSig new_v src_loc))
-
- rename_sig (MagicUnfoldingSig v str src_loc)
- = pushSrcLocRn src_loc $
- if not (v `elem` binder_occnames) then
- addErrRn (unknownSigDeclErr "MAGIC_UNFOLDING pragma" v src_loc) `thenRn_`
- returnRn Nothing
- else
- lookupValue v `thenRn` \ new_v ->
- returnRn (Just (MagicUnfoldingSig new_v str src_loc))
-
- not_unbound :: RenamedSig -> Bool
-
- not_unbound (Sig n _ _ _) = not (isRnUnbound n)
- not_unbound (SpecSig n _ _ _) = not (isRnUnbound n)
- not_unbound (InlineSig n _) = not (isRnUnbound n)
- not_unbound (DeforestSig n _) = not (isRnUnbound n)
- not_unbound (MagicUnfoldingSig n _ _) = not (isRnUnbound n)
-
- -------------------------------------
- sig_free :: [RdrNameSig] -> RdrName -> Maybe RdrName
- -- Return "Just x" if "x" has no type signature in
- -- sigs. Nothing, otherwise.
-
- sig_free [] ny = Just ny
- sig_free (Sig nx _ _ _ : rest) ny
- = if (nx == ny) then Nothing else sig_free rest ny
- sig_free (_ : rest) ny = sig_free rest ny
-
- -------------------------------------
- compare :: RenamedSig -> RenamedSig -> TAG_
- compare (Sig n1 _ _ _) (Sig n2 _ _ _) = n1 `cmp` n2
- compare (InlineSig n1 _) (InlineSig n2 _) = n1 `cmp` n2
- compare (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmp` n2
- compare (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
- = -- may have many specialisations for one value;
- -- but not ones that are exactly the same...
- thenCmp (n1 `cmp` n2) (cmpPolyType cmp ty1 ty2)
-
- compare other_1 other_2 -- tags *must* be different
- = let tag1 = tag other_1
- tag2 = tag other_2
- in
- if tag1 _LT_ tag2 then LT_ else GT_
-
- tag (Sig n1 _ _ _) = (ILIT(1) :: FAST_INT)
- tag (SpecSig n1 _ _ _) = ILIT(2)
- tag (InlineSig n1 _) = ILIT(3)
- tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
- tag (DeforestSig n1 _) = ILIT(5)
- tag _ = panic# "tag(RnBinds)"
+ bad sig = not (ok_sig sig) &&
+ case sigName sig of
+ Just n | isUnboundName n -> False
+ -- Don't complain about an unbound name again
+ other -> True
+
+-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
+-- because this won't work for:
+-- instance Foo T where
+-- {-# INLINE op #-}
+-- Baz.op = ...
+-- We'll just rename the INLINE prag to refer to whatever other 'op'
+-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
+-- Doesn't seem worth much trouble to sort this.
+
+renameSigs :: [LSig RdrName] -> RnM [LSig Name]
+renameSigs sigs = mappM (wrapLocM renameSig) (filter (not . isFixitySig . unLoc) sigs)
+ -- Remove fixity sigs which have been dealt with already
+
+renameSig :: Sig RdrName -> RnM (Sig Name)
+-- FixitSig is renamed elsewhere.
+renameSig (Sig v ty)
+ = lookupLocatedSigOccRn v `thenM` \ new_v ->
+ rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty ->
+ returnM (Sig new_v new_ty)
+
+renameSig (SpecInstSig ty)
+ = rnLHsType (text "A SPECIALISE instance pragma") ty `thenM` \ new_ty ->
+ returnM (SpecInstSig new_ty)
+
+renameSig (SpecSig v ty)
+ = lookupLocatedSigOccRn v `thenM` \ new_v ->
+ rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty ->
+ returnM (SpecSig new_v new_ty)
+
+renameSig (InlineSig b v p)
+ = lookupLocatedSigOccRn v `thenM` \ new_v ->
+ returnM (InlineSig b new_v p)
projects / ghc-hetmet.git / blobdiff