- returnRn sigs' -- bad ones and all:
- -- we need bindings of *some* sort for every name
- where
- 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)"
+\begin{code}
+cmp_sig :: RenamedSig -> RenamedSig -> Ordering
+cmp_sig (Sig n1 _ _) (Sig 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 (SpecSig n1 ty1 _) (SpecSig n2 ty2 _)
+ = -- may have many specialisations for one value;
+ -- but not ones that are exactly the same...
+ thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
+
+cmp_sig other_1 other_2 -- Tags *must* be different
+ | (sig_tag other_1) _LT_ (sig_tag other_2) = LT
+ | otherwise = GT
+
+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 _ = panic# "tag(RnBinds)"