ghc/compiler/rename/RnBinds.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnBinds]{Renaming and dependency analysis of bindings}
   5
   6 This module does renaming and dependency analysis on value bindings in
   7 the abstract syntax.  It does {\em not} do cycle-checks on class or
   8 type-synonym declarations; those cannot be done at this stage because
   9 they may be affected by renaming (which isn't fully worked out yet).
  10
  11 \begin{code}
  12 #include "HsVersions.h"
  13
  14 module RnBinds (
  15         rnTopBinds, rnTopMonoBinds,
  16         rnMethodBinds,
  17         rnBinds, rnMonoBinds
  18    ) where
  19
  20 IMP_Ubiq()
  21 IMPORT_DELOOPER(RnLoop)         -- break the RnPass/RnExpr/RnBinds loops
  22
  23 import HsSyn
  24 import HsPragmas        ( isNoGenPragmas, noGenPragmas )
  25 import RdrHsSyn
  26 import RnHsSyn
  27 import RnMonad
  28 import RnExpr           ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
  29 import RnEnv            ( bindLocatedLocalsRn, lookupRn, lookupOccRn, isUnboundName )
  30
  31 import CmdLineOpts      ( opt_SigsRequired )
  32 import Digraph          ( stronglyConnComp )
  33 import ErrUtils         ( addErrLoc, addShortErrLocLine )
  34 import Name             ( OccName(..), Provenance,
  35                           Name {- instance Eq -},
  36                           NameSet(..), emptyNameSet, mkNameSet, unionNameSets,
  37                           minusNameSet, unionManyNameSets, elemNameSet, unitNameSet, nameSetToList
  38                         )
  39 import Maybes           ( catMaybes )
  40 --import PprStyle--ToDo:rm
  41 import Pretty
  42 import Util             ( thenCmp, isIn, removeDups, panic, panic#, assertPanic )
  43 import UniqSet          ( SYN_IE(UniqSet) )
  44 import ListSetOps       ( minusList )
  45 import Bag              ( bagToList )
  46 import UniqFM           ( UniqFM )
  47 import ErrUtils         ( SYN_IE(Error) )
  48 \end{code}
  49
  50 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
  51 -- place and can be used when complaining.
  52
  53 The code tree received by the function @rnBinds@ contains definitions
  54 in where-clauses which are all apparently mutually recursive, but which may
  55 not really depend upon each other. For example, in the top level program
  56 \begin{verbatim}
  57 f x = y where a = x
  58               y = x
  59 \end{verbatim}
  60 the definitions of @a@ and @y@ do not depend on each other at all.
  61 Unfortunately, the typechecker cannot always check such definitions.
  62 \footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
  63 definitions. In Proceedings of the International Symposium on Programming,
  64 Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
  65 However, the typechecker usually can check definitions in which only the
  66 strongly connected components have been collected into recursive bindings.
  67 This is precisely what the function @rnBinds@ does.
  68
  69 ToDo: deal with case where a single monobinds binds the same variable
  70 twice.
  71
  72 The vertag tag is a unique @Int@; the tags only need to be unique
  73 within one @MonoBinds@, so that unique-Int plumbing is done explicitly
  74 (heavy monad machinery not needed).
  75
  76 \begin{code}
  77 type VertexTag  = Int
  78 type Cycle      = [VertexTag]
  79 type Edge       = (VertexTag, VertexTag)
  80 \end{code}
  81
  82 %************************************************************************
  83 %*                                                                      *
  84 %* naming conventions                                                   *
  85 %*                                                                      *
  86 %************************************************************************
  87
  88 \subsection[name-conventions]{Name conventions}
  89
  90 The basic algorithm involves walking over the tree and returning a tuple
  91 containing the new tree plus its free variables. Some functions, such
  92 as those walking polymorphic bindings (HsBinds) and qualifier lists in
  93 list comprehensions (@Quals@), return the variables bound in local
  94 environments. These are then used to calculate the free variables of the
  95 expression evaluated in these environments.
  96
  97 Conventions for variable names are as follows:
  98 \begin{itemize}
  99 \item
 100 new code is given a prime to distinguish it from the old.
 101
 102 \item
 103 a set of variables defined in @Exp@ is written @dvExp@
 104
 105 \item
 106 a set of variables free in @Exp@ is written @fvExp@
 107 \end{itemize}
 108
 109 %************************************************************************
 110 %*                                                                      *
 111 %* analysing polymorphic bindings (HsBinds, Bind, MonoBinds)            *
 112 %*                                                                      *
 113 %************************************************************************
 114
 115 \subsubsection[dep-HsBinds]{Polymorphic bindings}
 116
 117 Non-recursive expressions are reconstructed without any changes at top
 118 level, although their component expressions may have to be altered.
 119 However, non-recursive expressions are currently not expected as
 120 \Haskell{} programs, and this code should not be executed.
 121
 122 Monomorphic bindings contain information that is returned in a tuple
 123 (a @FlatMonoBindsInfo@) containing:
 124
 125 \begin{enumerate}
 126 \item
 127 a unique @Int@ that serves as the ``vertex tag'' for this binding.
 128
 129 \item
 130 the name of a function or the names in a pattern. These are a set
 131 referred to as @dvLhs@, the defined variables of the left hand side.
 132
 133 \item
 134 the free variables of the body. These are referred to as @fvBody@.
 135
 136 \item
 137 the definition's actual code. This is referred to as just @code@.
 138 \end{enumerate}
 139
 140 The function @nonRecDvFv@ returns two sets of variables. The first is
 141 the set of variables defined in the set of monomorphic bindings, while the
 142 second is the set of free variables in those bindings.
 143
 144 The set of variables defined in a non-recursive binding is just the
 145 union of all of them, as @union@ removes duplicates. However, the
 146 free variables in each successive set of cumulative bindings is the
 147 union of those in the previous set plus those of the newest binding after
 148 the defined variables of the previous set have been removed.
 149
 150 @rnMethodBinds@ deals only with the declarations in class and
 151 instance declarations.  It expects only to see @FunMonoBind@s, and
 152 it expects the global environment to contain bindings for the binders
 153 (which are all class operations).
 154
 155 %************************************************************************
 156 %*                                                                      *
 157 %*              Top-level bindings
 158 %*                                                                      *
 159 %************************************************************************
 160
 161 @rnTopBinds@ assumes that the environment already
 162 contains bindings for the binders of this particular binding.
 163
 164 \begin{code}
 165 rnTopBinds    :: RdrNameHsBinds -> RnMS s RenamedHsBinds
 166
 167 rnTopBinds EmptyBinds                     = returnRn EmptyBinds
 168 rnTopBinds (SingleBind (RecBind bind))    = rnTopMonoBinds bind []
 169 rnTopBinds (BindWith (RecBind bind) sigs) = rnTopMonoBinds bind sigs
 170   -- The parser doesn't produce other forms
 171
 172
 173 rnTopMonoBinds EmptyMonoBinds sigs
 174   = returnRn EmptyBinds
 175
 176 rnTopMonoBinds mbinds sigs
 177  =  mapRn lookupRn binder_rdr_names     `thenRn` \ binder_names ->
 178     let
 179         binder_set = mkNameSet binder_names
 180     in
 181     rn_mono_binds True {- top level -}
 182                   binder_set mbinds sigs                `thenRn` \ (new_binds, fv_set) ->
 183     returnRn new_binds
 184   where
 185     binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))
 186 \end{code}
 187
 188 %************************************************************************
 189 %*                                                                      *
 190 %*              Nested binds
 191 %*                                                                      *
 192 %************************************************************************
 193
 194 @rnMonoBinds@
 195         - collects up the binders for this declaration group,
 196         - checks that they form a set
 197         - extends the environment to bind them to new local names
 198         - calls @rnMonoBinds@ to do the real work
 199
 200 \begin{code}
 201 rnBinds       :: RdrNameHsBinds
 202               -> (RenamedHsBinds -> RnMS s (result, FreeVars))
 203               -> RnMS s (result, FreeVars)
 204
 205 rnBinds EmptyBinds                     thing_inside = thing_inside EmptyBinds
 206 rnBinds (SingleBind (RecBind bind))    thing_inside = rnMonoBinds bind []   thing_inside
 207 rnBinds (BindWith (RecBind bind) sigs) thing_inside = rnMonoBinds bind sigs thing_inside
 208   -- the parser doesn't produce other forms
 209
 210
 211 rnMonoBinds :: RdrNameMonoBinds -> [RdrNameSig]
 212             -> (RenamedHsBinds -> RnMS s (result, FreeVars))
 213             -> RnMS s (result, FreeVars)
 214
 215 rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds
 216
 217 rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
 218   =     -- Extract all the binders in this group,
 219         -- and extend current scope, inventing new names for the new binders
 220         -- This also checks that the names form a set
 221     bindLocatedLocalsRn "binding group" mbinders_w_srclocs              $ \ new_mbinders ->
 222     let
 223         binder_set = mkNameSet new_mbinders
 224     in
 225     rn_mono_binds False {- not top level -}
 226                   binder_set mbinds sigs        `thenRn` \ (binds,bind_fvs) ->
 227
 228         -- Now do the "thing inside", and deal with the free-variable calculations
 229     thing_inside binds                                  `thenRn` \ (result,result_fvs) ->
 230     returnRn (result, (result_fvs `unionNameSets` bind_fvs) `minusNameSet` binder_set)
 231   where
 232     mbinders_w_srclocs = bagToList (collectMonoBinders mbinds)
 233 \end{code}
 234
 235
 236 %************************************************************************
 237 %*                                                                      *
 238 %*              MonoBinds -- the main work is done here
 239 %*                                                                      *
 240 %************************************************************************
 241
 242 @rnMonoBinds@ is used by *both* top-level and nested bindings.  It
 243 assumes that all variables bound in this group are already in scope.
 244 This is done *either* by pass 3 (for the top-level bindings), *or* by
 245 @rnNestedMonoBinds@ (for the nested ones).
 246
 247 \begin{code}
 248 rn_mono_binds :: Bool                   -- True <=> top level
 249               -> NameSet                -- Binders of this group
 250               -> RdrNameMonoBinds
 251               -> [RdrNameSig]           -- Signatures attached to this group
 252               -> RnMS s (RenamedHsBinds,        --
 253                          FreeVars)      -- Free variables
 254
 255 rn_mono_binds is_top_lev binders mbinds sigs
 256   =
 257          -- Rename the bindings, returning a MonoBindsInfo
 258          -- which is a list of indivisible vertices so far as
 259          -- the strongly-connected-components (SCC) analysis is concerned
 260     rnBindSigs is_top_lev binders sigs  `thenRn` \ siglist ->
 261     flattenMonoBinds 0 siglist mbinds   `thenRn` \ (_, mbinds_info) ->
 262
 263          -- Do the SCC analysis
 264     let vertices    = mkVertices mbinds_info
 265         edges       = mkEdges     mbinds_info
 266         scc_result  = stronglyConnComp (==) edges vertices
 267         final_binds = foldr1 ThenBinds (map (reconstructCycle edges mbinds_info) scc_result)
 268
 269          -- Deal with bound and free-var calculation
 270         rhs_fvs = unionManyNameSets [fvs | (_,_,fvs,_,_) <- mbinds_info]
 271     in
 272     returnRn (final_binds, rhs_fvs)
 273 \end{code}
 274
 275 @flattenMonoBinds@ is ever-so-slightly magical in that it sticks
 276 unique ``vertex tags'' on its output; minor plumbing required.
 277
 278 \begin{code}
 279 flattenMonoBinds :: Int                         -- Next free vertex tag
 280                  -> [RenamedSig]                -- Signatures
 281                  -> RdrNameMonoBinds
 282                  -> RnMS s (Int, FlatMonoBindsInfo)
 283
 284 flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn (uniq, [])
 285
 286 flattenMonoBinds uniq sigs (AndMonoBinds bs1 bs2)
 287   = flattenMonoBinds uniq  sigs bs1     `thenRn` \ (uniq1, flat1) ->
 288     flattenMonoBinds uniq1 sigs bs2     `thenRn` \ (uniq2, flat2) ->
 289     returnRn (uniq2, flat1 ++ flat2)
 290
 291 flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
 292   = pushSrcLocRn locn                   $
 293     rnPat pat                           `thenRn` \ pat' ->
 294     rnGRHSsAndBinds grhss_and_binds     `thenRn` \ (grhss_and_binds', fvs) ->
 295
 296          -- Find which things are bound in this group
 297     let
 298         names_bound_here = mkNameSet (collectPatBinders pat')
 299         sigs_for_me      = filter ((`elemNameSet` names_bound_here) . sig_name) sigs
 300         sigs_fvs         = foldr sig_fv emptyNameSet sigs_for_me
 301     in
 302     returnRn (
 303         uniq + 1,
 304         [(uniq,
 305           names_bound_here,
 306           fvs `unionNameSets` sigs_fvs,
 307           PatMonoBind pat' grhss_and_binds' locn,
 308           sigs_for_me
 309          )]
 310     )
 311
 312 flattenMonoBinds uniq sigs (FunMonoBind name inf matches locn)
 313   = pushSrcLocRn locn                            $
 314     mapRn (checkPrecMatch inf name) matches     `thenRn_`
 315     lookupRn name                               `thenRn` \ name' ->
 316     mapAndUnzipRn rnMatch matches               `thenRn` \ (new_matches, fv_lists) ->
 317     let
 318         fvs         = unionManyNameSets fv_lists
 319         sigs_for_me = filter ((name' ==) . sig_name) sigs
 320         sigs_fvs    = foldr sig_fv emptyNameSet sigs_for_me
 321     in
 322     returnRn (
 323       uniq + 1,
 324       [(uniq,
 325         unitNameSet name',
 326         fvs `unionNameSets` sigs_fvs,
 327         FunMonoBind name' inf new_matches locn,
 328         sigs_for_me
 329         )]
 330     )
 331 \end{code}
 332
 333
 334 @rnMethodBinds@ is used for the method bindings of an instance
 335 declaration.   like @rnMonoBinds@ but without dependency analysis.
 336
 337 \begin{code}
 338 rnMethodBinds :: RdrNameMonoBinds -> RnMS s RenamedMonoBinds
 339
 340 rnMethodBinds EmptyMonoBinds = returnRn EmptyMonoBinds
 341
 342 rnMethodBinds (AndMonoBinds mb1 mb2)
 343   = andRn AndMonoBinds (rnMethodBinds mb1)
 344                        (rnMethodBinds mb2)
 345
 346 rnMethodBinds (FunMonoBind occname inf matches locn)
 347   = pushSrcLocRn locn                              $
 348     mapRn (checkPrecMatch inf occname) matches  `thenRn_`
 349     lookupRn occname                            `thenRn` \ op_name ->
 350     mapAndUnzipRn rnMatch matches               `thenRn` \ (new_matches, _) ->
 351     returnRn (FunMonoBind op_name inf new_matches locn)
 352
 353 rnMethodBinds (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
 354   = pushSrcLocRn locn                   $
 355     lookupRn  occname                   `thenRn` \ op_name ->
 356     rnGRHSsAndBinds grhss_and_binds     `thenRn` \ (grhss_and_binds', _) ->
 357     returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
 358
 359 -- Can't handle method pattern-bindings which bind multiple methods.
 360 rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
 361   = pushSrcLocRn locn   $
 362     failWithRn EmptyMonoBinds (methodBindErr mbind)
 363 \end{code}
 364
 365 \begin{code}
 366 -- If a SPECIALIZE pragma is of the "... = blah" form,
 367 -- then we'd better make sure "blah" is taken into
 368 -- acct in the dependency analysis (or we get an
 369 -- unexpected out-of-scope error)! WDP 95/07
 370
 371 sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionNameSets` (unitNameSet blah)
 372 sig_fv _                           acc = acc
 373 \end{code}
 374
 375 %************************************************************************
 376 %*                                                                      *
 377 \subsection[reconstruct-deps]{Reconstructing dependencies}
 378 %*                                                                      *
 379 %************************************************************************
 380
 381 This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
 382 as the two cases are similar.
 383
 384 \begin{code}
 385 reconstructCycle :: [Edge]      -- Original edges
 386                  -> FlatMonoBindsInfo
 387                  -> Cycle
 388                  -> RenamedHsBinds
 389
 390 reconstructCycle edges mbi cycle
 391   = mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle)
 392   where
 393     relevant_binds_and_sigs = [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi,
 394                                               vertex `is_elem` cycle]
 395     (binds, sig_lists) = unzip relevant_binds_and_sigs
 396     this_gp_binds      = foldr1 AndMonoBinds binds
 397     this_gp_sigs       = foldr1 (++) sig_lists
 398
 399     is_elem = isIn "reconstructRec"
 400
 401     mk_binds :: RenamedMonoBinds -> [RenamedSig] -> Bool -> RenamedHsBinds
 402     mk_binds bs [] True  = SingleBind (RecBind    bs)
 403     mk_binds bs ss True  = BindWith   (RecBind    bs) ss
 404     mk_binds bs [] False = SingleBind (NonRecBind bs)
 405     mk_binds bs ss False = BindWith   (NonRecBind bs) ss
 406
 407         -- moved from Digraph, as this is the only use here
 408         -- (avoid overloading cost).  We have to use elem
 409         -- (not FiniteMaps or whatever), because there may be
 410         -- many edges out of one vertex.  We give it its own
 411         -- "elem" just for speed.
 412
 413     isCyclic es []  = panic "isCyclic: empty component"
 414     isCyclic es [v] = (v,v) `elem` es
 415     isCyclic es vs  = True
 416
 417     elem _ []     = False
 418     elem x (y:ys) = x==y || elem x ys
 419 \end{code}
 420
 421 %************************************************************************
 422 %*                                                                      *
 423 %*      Manipulating FlatMonoBindInfo                                   *
 424 %*                                                                      *
 425 %************************************************************************
 426
 427 During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
 428 The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
 429 a function binding, and has itself been dependency-analysed and
 430 renamed.
 431
 432 \begin{code}
 433 type FlatMonoBindsInfo
 434   = [(VertexTag,                -- Identifies the vertex
 435       NameSet,                  -- Set of names defined in this vertex
 436       NameSet,                  -- Set of names used in this vertex
 437       RenamedMonoBinds,         -- Binding for this vertex (always just one binding, either fun or pat)
 438       [RenamedSig])             -- Signatures, if any, for this vertex
 439     ]
 440
 441 mkVertices :: FlatMonoBindsInfo -> [VertexTag]
 442 mkEdges    :: FlatMonoBindsInfo -> [Edge]
 443
 444 mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
 445
 446 mkEdges flat_info        -- An edge (v,v') indicates that v depends on v'
 447   = [ (source_vertex, target_vertex)
 448     | (source_vertex, _, used_names, _, _) <- flat_info,
 449       target_name   <- nameSetToList used_names,
 450       target_vertex <- vertices_defining target_name flat_info
 451     ]
 452     where
 453     -- If each name only has one binding in this group, then
 454     -- vertices_defining will always return the empty list, or a
 455     -- singleton.  The case when there is more than one binding (an
 456     -- error) needs more thought.
 457
 458     vertices_defining name flat_info2
 459      = [ vertex | (vertex, names_defined, _, _, _) <- flat_info2,
 460                   name `elemNameSet` names_defined
 461        ]
 462 \end{code}
 463
 464
 465 %************************************************************************
 466 %*                                                                      *
 467 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
 468 %*                                                                      *
 469 %************************************************************************
 470
 471 @rnBindSigs@ checks for: (a)~more than one sig for one thing;
 472 (b)~signatures given for things not bound here; (c)~with suitably
 473 flaggery, that all top-level things have type signatures.
 474
 475 \begin{code}
 476 rnBindSigs :: Bool                      -- True <=> top-level binders
 477             -> NameSet                  -- Set of names bound in this group
 478             -> [RdrNameSig]
 479             -> RnMS s [RenamedSig]               -- List of Sig constructors
 480
 481 rnBindSigs is_toplev binders sigs
 482   =      -- Rename the signatures
 483     mapRn renameSig sigs        `thenRn` \ sigs' ->
 484
 485         -- Check for (a) duplicate signatures
 486         --           (b) signatures for things not in this group
 487         --           (c) optionally, bindings with no signature
 488     let
 489         (goodies, dups) = removeDups cmp_sig (filter (not.isUnboundName.sig_name) sigs')
 490         not_this_group  = filter (\sig -> not (sig_name sig `elemNameSet` binders)) goodies
 491         type_sig_vars   = [n | Sig n _ _ <- goodies]
 492         un_sigd_binders
 493             | is_toplev && opt_SigsRequired = nameSetToList binders `minusList` type_sig_vars
 494             | otherwise                     = []
 495     in
 496     mapRn dupSigDeclErr dups                            `thenRn_`
 497     mapRn unknownSigErr not_this_group                  `thenRn_`
 498     mapRn (addErrRn.missingSigErr) un_sigd_binders      `thenRn_`
 499
 500     returnRn sigs' -- bad ones and all:
 501                    -- we need bindings of *some* sort for every name
 502
 503
 504 renameSig (Sig v ty src_loc)
 505   = pushSrcLocRn src_loc $
 506     lookupRn v                  `thenRn` \ new_v ->
 507     rnHsType ty                 `thenRn` \ new_ty ->
 508     returnRn (Sig new_v new_ty src_loc)
 509
 510 renameSig (SpecSig v ty using src_loc)
 511   = pushSrcLocRn src_loc $
 512     lookupRn v                  `thenRn` \ new_v ->
 513     rnHsType ty                 `thenRn` \ new_ty ->
 514     rn_using using              `thenRn` \ new_using ->
 515     returnRn (SpecSig new_v new_ty new_using src_loc)
 516   where
 517     rn_using Nothing  = returnRn Nothing
 518     rn_using (Just x) = lookupOccRn x `thenRn` \ new_x ->
 519                         returnRn (Just new_x)
 520
 521 renameSig (InlineSig v src_loc)
 522   = pushSrcLocRn src_loc $
 523     lookupRn v          `thenRn` \ new_v ->
 524     returnRn (InlineSig new_v src_loc)
 525
 526 renameSig (DeforestSig v src_loc)
 527   = pushSrcLocRn src_loc $
 528     lookupRn v        `thenRn` \ new_v ->
 529     returnRn (DeforestSig new_v src_loc)
 530
 531 renameSig (MagicUnfoldingSig v str src_loc)
 532   = pushSrcLocRn src_loc $
 533     lookupRn v          `thenRn` \ new_v ->
 534     returnRn (MagicUnfoldingSig new_v str src_loc)
 535 \end{code}
 536
 537 Checking for distinct signatures; oh, so boring
 538
 539 \begin{code}
 540 cmp_sig :: RenamedSig -> RenamedSig -> TAG_
 541 cmp_sig (Sig n1 _ _)               (Sig n2 _ _)           = n1 `cmp` n2
 542 cmp_sig (InlineSig n1 _)           (InlineSig n2 _)       = n1 `cmp` n2
 543 cmp_sig (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmp` n2
 544 cmp_sig (SpecSig n1 ty1 _ _)       (SpecSig n2 ty2 _ _)
 545   = -- may have many specialisations for one value;
 546         -- but not ones that are exactly the same...
 547         thenCmp (n1 `cmp` n2) (cmpHsType cmp ty1 ty2)
 548
 549 cmp_sig other_1 other_2                                 -- Tags *must* be different
 550   | (sig_tag other_1) _LT_ (sig_tag other_2) = LT_
 551   | otherwise                                = GT_
 552
 553 sig_tag (Sig n1 _ _)               = (ILIT(1) :: FAST_INT)
 554 sig_tag (SpecSig n1 _ _ _)         = ILIT(2)
 555 sig_tag (InlineSig n1 _)           = ILIT(3)
 556 sig_tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
 557 sig_tag (DeforestSig n1 _)         = ILIT(5)
 558 sig_tag _                          = panic# "tag(RnBinds)"
 559
 560 sig_name (Sig        n _ _)        = n
 561 sig_name (ClassOpSig n _ _ _)      = n
 562 sig_name (SpecSig    n _ _ _)      = n
 563 sig_name (InlineSig  n     _)      = n
 564 sig_name (MagicUnfoldingSig n _ _) = n
 565 \end{code}
 566
 567 %************************************************************************
 568 %*                                                                      *
 569 \subsection{Error messages}
 570 %*                                                                      *
 571 %************************************************************************
 572
 573 \begin{code}
 574 dupSigDeclErr (sig:sigs)
 575   = pushSrcLocRn loc $
 576     addErrRn (\sty -> ppSep [ppStr "more than one",
 577                             ppStr what_it_is, ppStr "given for",
 578                             ppQuote (ppr sty (sig_name sig))])
 579   where
 580     (what_it_is, loc) = sig_doc sig
 581
 582 unknownSigErr sig
 583   = pushSrcLocRn loc $
 584     addErrRn (\sty -> ppSep [ppStr flavour, ppStr "but no definition for",
 585                              ppQuote (ppr sty (sig_name sig))])
 586   where
 587     (flavour, loc) = sig_doc sig
 588
 589 sig_doc (Sig        _ _ loc)        = ("type signature",loc)
 590 sig_doc (ClassOpSig _ _ _ loc)      = ("class-method type signature", loc)
 591 sig_doc (SpecSig    _ _ _ loc)      = ("SPECIALIZE pragma",loc)
 592 sig_doc (InlineSig  _     loc)      = ("INLINE pragma",loc)
 593 sig_doc (MagicUnfoldingSig _ _ loc) = ("MAGIC_UNFOLDING pragma",loc)
 594
 595 missingSigErr var sty
 596   = ppSep [ppStr "a definition but no type signature for", ppQuote (ppr sty var)]
 597
 598 methodBindErr mbind sty
 599  =  ppHang (ppStr "Can't handle multiple methods defined by one pattern binding")
 600            4 (ppr sty mbind)
 601 \end{code}