ghc/compiler/rename/RnBinds4.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnBinds4]{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 RnBinds4 (
  15         rnTopBinds, rnMethodBinds,
  16         rnBinds,
  17         FreeVars(..), DefinedVars(..)
  18
  19         -- and to make the interface self-sufficient...
  20    ) where
  21
  22 import Ubiq{-uitous-}
  23 import RnLoop   -- break the RnPass4/RnExpr4/RnBinds4 loops
  24
  25 import HsSyn
  26 import RdrHsSyn
  27 import RnHsSyn
  28 import HsPragmas        ( noGenPragmas )
  29 import RnMonad4
  30
  31 -- others:
  32 import CmdLineOpts      ( opt_SigsRequired )
  33 import Digraph          ( stronglyConnComp )
  34 import ErrUtils         ( addErrLoc, addShortErrLocLine )
  35 import Maybes           ( catMaybes )
  36 import Name             ( isUnboundName, Name{-instances-} )
  37 import Pretty
  38 import ProtoName        ( elemByLocalNames, eqByLocalName, ProtoName{-instances-} )
  39 import RnExpr4          -- OK to look here; but not the other way 'round
  40 import UniqSet          ( emptyUniqSet, singletonUniqSet, mkUniqSet,
  41                           unionUniqSets, unionManyUniqSets,
  42                           elementOfUniqSet,
  43                           uniqSetToList,
  44                           UniqSet(..)
  45                         )
  46 import Util             ( isIn, removeDups, panic, panic# )
  47 \end{code}
  48
  49 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
  50 -- place and can be used when complaining.
  51
  52 The code tree received by the function @rnBinds@ contains definitions
  53 in where-clauses which are all apparently mutually recursive, but which may
  54 not really depend upon each other. For example, in the top level program
  55 \begin{verbatim}
  56 f x = y where a = x
  57               y = x
  58 \end{verbatim}
  59 the definitions of @a@ and @y@ do not depend on each other at all.
  60 Unfortunately, the typechecker cannot always check such definitions.
  61 \footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
  62 definitions. In Proceedings of the International Symposium on Programming,
  63 Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
  64 However, the typechecker usually can check definitions in which only the
  65 strongly connected components have been collected into recursive bindings.
  66 This is precisely what the function @rnBinds@ does.
  67
  68 ToDo: deal with case where a single monobinds binds the same variable
  69 twice.
  70
  71 Sets of variable names are represented as sets explicitly, rather than lists.
  72
  73 \begin{code}
  74 type DefinedVars = UniqSet Name
  75 type FreeVars    = UniqSet Name
  76 \end{code}
  77
  78 i.e., binders.
  79
  80 The vertag tag is a unique @Int@; the tags only need to be unique
  81 within one @MonoBinds@, so that unique-Int plumbing is done explicitly
  82 (heavy monad machinery not needed).
  83
  84 \begin{code}
  85 type VertexTag  = Int
  86 type Cycle      = [VertexTag]
  87 type Edge       = (VertexTag, VertexTag)
  88 \end{code}
  89
  90 %************************************************************************
  91 %*                                                                      *
  92 %* naming conventions                                                   *
  93 %*                                                                      *
  94 %************************************************************************
  95 \subsection[name-conventions]{Name conventions}
  96
  97 The basic algorithm involves walking over the tree and returning a tuple
  98 containing the new tree plus its free variables. Some functions, such
  99 as those walking polymorphic bindings (HsBinds) and qualifier lists in
 100 list comprehensions (@Quals@), return the variables bound in local
 101 environments. These are then used to calculate the free variables of the
 102 expression evaluated in these environments.
 103
 104 Conventions for variable names are as follows:
 105 \begin{itemize}
 106 \item
 107 new code is given a prime to distinguish it from the old.
 108
 109 \item
 110 a set of variables defined in @Exp@ is written @dvExp@
 111
 112 \item
 113 a set of variables free in @Exp@ is written @fvExp@
 114 \end{itemize}
 115
 116 %************************************************************************
 117 %*                                                                      *
 118 %* analysing polymorphic bindings (HsBinds, Bind, MonoBinds)            *
 119 %*                                                                      *
 120 %************************************************************************
 121 \subsubsection[dep-HsBinds]{Polymorphic bindings}
 122
 123 Non-recursive expressions are reconstructed without any changes at top
 124 level, although their component expressions may have to be altered.
 125 However, non-recursive expressions are currently not expected as
 126 \Haskell{} programs, and this code should not be executed.
 127
 128 Monomorphic bindings contain information that is returned in a tuple
 129 (a @FlatMonoBindsInfo@) containing:
 130
 131 \begin{enumerate}
 132 \item
 133 a unique @Int@ that serves as the ``vertex tag'' for this binding.
 134
 135 \item
 136 the name of a function or the names in a pattern. These are a set
 137 referred to as @dvLhs@, the defined variables of the left hand side.
 138
 139 \item
 140 the free variables of the body. These are referred to as @fvBody@.
 141
 142 \item
 143 the definition's actual code. This is referred to as just @code@.
 144 \end{enumerate}
 145
 146 The function @nonRecDvFv@ returns two sets of variables. The first is
 147 the set of variables defined in the set of monomorphic bindings, while the
 148 second is the set of free variables in those bindings.
 149
 150 The set of variables defined in a non-recursive binding is just the
 151 union of all of them, as @union@ removes duplicates. However, the
 152 free variables in each successive set of cumulative bindings is the
 153 union of those in the previous set plus those of the newest binding after
 154 the defined variables of the previous set have been removed.
 155
 156 @rnMethodBinds@ deals only with the declarations in class and
 157 instance declarations.  It expects only to see @FunMonoBind@s, and
 158 it expects the global environment to contain bindings for the binders
 159 (which are all class operations).
 160
 161 \begin{code}
 162 rnTopBinds      :: ProtoNameHsBinds -> Rn4M RenamedHsBinds
 163 rnMethodBinds  :: Name{-class-} -> ProtoNameMonoBinds -> Rn4M RenamedMonoBinds
 164 rnBinds :: ProtoNameHsBinds -> Rn4M (RenamedHsBinds, FreeVars, [Name])
 165
 166 rnTopBinds EmptyBinds                      = returnRn4 EmptyBinds
 167 rnTopBinds (SingleBind (RecBind bind))    = rnTopMonoBinds bind []
 168 rnTopBinds (BindWith (RecBind bind) sigs) = rnTopMonoBinds bind sigs
 169   -- the parser doesn't produce other forms
 170
 171 -- ********************************************************************
 172
 173 rnMethodBinds class_name EmptyMonoBinds = returnRn4 EmptyMonoBinds
 174
 175 rnMethodBinds class_name (AndMonoBinds mb1 mb2)
 176   = andRn4 AndMonoBinds (rnMethodBinds class_name mb1)
 177                         (rnMethodBinds class_name mb2)
 178
 179 rnMethodBinds class_name (FunMonoBind pname matches locn)
 180   = pushSrcLocRn4 locn                            (
 181     lookupClassOp class_name pname      `thenRn4` \ op_name ->
 182     mapAndUnzipRn4 rnMatch matches      `thenRn4` \ (new_matches, _) ->
 183     returnRn4 (FunMonoBind op_name new_matches locn)
 184     )
 185
 186 rnMethodBinds class_name (PatMonoBind (VarPatIn pname) grhss_and_binds locn)
 187   = pushSrcLocRn4 locn                            (
 188     lookupClassOp class_name pname      `thenRn4` \ op_name ->
 189     rnGRHSsAndBinds grhss_and_binds     `thenRn4` \ (grhss_and_binds', _) ->
 190     returnRn4 (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
 191     )
 192
 193 -- Can't handle method pattern-bindings which bind multiple methods.
 194 rnMethodBinds _ mbind@(PatMonoBind other_pat _ locn)
 195   = failButContinueRn4 EmptyMonoBinds (methodBindErr mbind locn)
 196
 197 -- ********************************************************************
 198
 199 rnBinds EmptyBinds                      = returnRn4 (EmptyBinds,emptyUniqSet,[])
 200 rnBinds (SingleBind (RecBind bind))     = rnNestedMonoBinds bind []
 201 rnBinds (BindWith (RecBind bind) sigs) = rnNestedMonoBinds bind sigs
 202   -- the parser doesn't produce other forms
 203 \end{code}
 204
 205 @rnNestedMonoBinds@
 206         - collects up the binders for this declaration group,
 207         - checkes that they form a set
 208         - extends the environment to bind them to new local names
 209         - calls @rnMonoBinds@ to do the real work
 210
 211 In contrast, @rnTopMonoBinds@ doesn't extend the environment, because that's
 212 already done in pass3.  All it does is call @rnMonoBinds@ and discards
 213 the free var info.
 214
 215 \begin{code}
 216 rnTopMonoBinds :: ProtoNameMonoBinds -> [ProtoNameSig] -> Rn4M RenamedHsBinds
 217
 218 rnTopMonoBinds EmptyMonoBinds sigs = returnRn4 EmptyBinds
 219
 220 rnTopMonoBinds mbs sigs
 221  = rnBindSigs True{-top-level-} (collectMonoBinders mbs) sigs `thenRn4` \ siglist ->
 222    rnMonoBinds mbs siglist `thenRn4` \ (new_binds, fv_set) ->
 223    returnRn4 new_binds
 224
 225
 226 rnNestedMonoBinds :: ProtoNameMonoBinds -> [ProtoNameSig]
 227                       -> Rn4M (RenamedHsBinds, FreeVars, [Name])
 228
 229 rnNestedMonoBinds EmptyMonoBinds sigs
 230   = returnRn4 (EmptyBinds, emptyUniqSet, [])
 231
 232 rnNestedMonoBinds mbinds sigs   -- Non-empty monobinds
 233   =
 234         -- Extract all the binders in this group,
 235         -- and extend current scope, inventing new names for the new binders
 236         -- This also checks that the names form a set
 237     let
 238         mbinders_w_srclocs = collectMonoBindersAndLocs mbinds
 239         mbinders           = map fst mbinders_w_srclocs
 240     in
 241     namesFromProtoNames
 242         "variable" -- in binding group
 243         mbinders_w_srclocs              `thenRn4` \ new_mbinders ->
 244
 245     extendSS2 new_mbinders (
 246          rnBindSigs False{-not top- level-} mbinders sigs `thenRn4` \ siglist ->
 247          rnMonoBinds mbinds  siglist
 248     )                                   `thenRn4` \ (new_binds, fv_set) ->
 249     returnRn4 (new_binds, fv_set, new_mbinders)
 250 \end{code}
 251
 252 @rnMonoBinds@ is used by *both* top-level and nested bindings.  It
 253 assumes that all variables bound in this group are already in scope.
 254 This is done *either* by pass 3 (for the top-level bindings),
 255 *or* by @rnNestedMonoBinds@ (for the nested ones).
 256
 257 \begin{code}
 258 rnMonoBinds :: ProtoNameMonoBinds
 259              -> [RenamedSig]    -- Signatures attached to this group
 260              -> Rn4M (RenamedHsBinds, FreeVars)
 261
 262 rnMonoBinds mbinds siglist
 263   =
 264          -- Rename the bindings, returning a MonoBindsInfo
 265          -- which is a list of indivisible vertices so far as
 266          -- the strongly-connected-components (SCC) analysis is concerned
 267     flattenMonoBinds 0 siglist mbinds   `thenRn4` \ (_, mbinds_info) ->
 268
 269          -- Do the SCC analysis
 270     let vertices = mkVertices mbinds_info
 271         edges   = mkEdges vertices mbinds_info
 272
 273         scc_result = stronglyConnComp (==) edges vertices
 274
 275          -- Deal with bound and free-var calculation
 276         rhs_free_vars = foldr f emptyUniqSet mbinds_info
 277
 278         final_binds = reconstructRec scc_result edges mbinds_info
 279
 280         happy_answer = returnRn4 (final_binds, rhs_free_vars)
 281     in
 282     case (inline_sigs_in_recursive_binds final_binds) of
 283       Nothing -> happy_answer
 284       Just names_n_locns ->
 285 -- SLPJ: sometimes want recursive INLINE for worker wrapper style stuff
 286 --      addErrRn4 (inlineInRecursiveBindsErr names_n_locns) `thenRn4_`
 287         {-not so-}happy_answer
 288   where
 289     f :: (a,b, FreeVars, c,d) -> FreeVars -> FreeVars
 290
 291     f (_, _, fvs_body, _, _) fvs_sofar = fvs_sofar `unionUniqSets` fvs_body
 292
 293     inline_sigs_in_recursive_binds (BindWith (RecBind _) sigs)
 294       = case [(n, locn) | (InlineSig n locn) <- sigs ] of
 295           []   -> Nothing
 296           sigh ->
 297 #if OMIT_DEFORESTER
 298                 Just sigh
 299 #else
 300                 -- Allow INLINEd recursive functions if they are
 301                 -- designated DEFORESTable too.
 302                 case [(n, locn) | (DeforestSig n locn) <- sigs ] of
 303                         []   -> Just sigh
 304                         sigh -> Nothing
 305 #endif
 306
 307     inline_sigs_in_recursive_binds (ThenBinds b1 b2)
 308       = case (inline_sigs_in_recursive_binds b1) of
 309           Nothing -> inline_sigs_in_recursive_binds b2
 310           Just  x -> Just x -- NB: won't report error(s) in b2
 311
 312     inline_sigs_in_recursive_binds anything_else = Nothing
 313 \end{code}
 314
 315 @flattenMonoBinds@ is ever-so-slightly magical in that it sticks
 316 unique ``vertex tags'' on its output; minor plumbing required.
 317
 318 \begin{code}
 319 flattenMonoBinds :: Int                         -- Next free vertex tag
 320                  -> [RenamedSig]                -- Signatures
 321                  -> ProtoNameMonoBinds
 322                  -> Rn4M (Int, FlatMonoBindsInfo)
 323
 324 flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn4 (uniq, [])
 325
 326 flattenMonoBinds uniq sigs (AndMonoBinds mB1 mB2)
 327   = flattenMonoBinds uniq sigs mB1      `thenRn4` \ (uniq1, flat1) ->
 328     flattenMonoBinds uniq1 sigs mB2     `thenRn4` \ (uniq2, flat2) ->
 329     returnRn4 (uniq2, flat1 ++ flat2)
 330
 331 flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
 332   = pushSrcLocRn4 locn                            (
 333     rnPat pat                           `thenRn4` \ pat' ->
 334     rnGRHSsAndBinds grhss_and_binds     `thenRn4` \ (grhss_and_binds', fvs) ->
 335
 336          -- Find which things are bound in this group
 337     let
 338         names_bound_here = collectPatBinders pat'
 339
 340         sigs_etc_for_here = foldl (sig_for_here (\ n -> n `is_elem` names_bound_here))
 341                                   [] sigs
 342
 343         sigs_fvs = foldr sig_fv emptyUniqSet sigs_etc_for_here
 344
 345         is_elem = isIn "flattenMonoBinds"
 346     in
 347     returnRn4 (
 348         uniq + 1,
 349         [(uniq,
 350           mkUniqSet names_bound_here,
 351            fvs `unionUniqSets` sigs_fvs,
 352            PatMonoBind pat' grhss_and_binds' locn,
 353            sigs_etc_for_here
 354          )]
 355     ))
 356
 357 flattenMonoBinds uniq sigs (FunMonoBind name matches locn)
 358   = pushSrcLocRn4 locn                            (
 359     lookupValue name                    `thenRn4` \ name' ->
 360     mapAndUnzipRn4 rnMatch matches      `thenRn4` \ (new_matches, fv_lists) ->
 361     let
 362         fvs = unionManyUniqSets fv_lists
 363
 364         sigs_for_me = foldl (sig_for_here (\ n -> n == name')) [] sigs
 365
 366         sigs_fvs = foldr sig_fv emptyUniqSet sigs_for_me
 367     in
 368     returnRn4 (
 369       uniq + 1,
 370       [(uniq,
 371         singletonUniqSet name',
 372         fvs `unionUniqSets` sigs_fvs,
 373         FunMonoBind name' new_matches locn,
 374         sigs_for_me
 375         )]
 376     ))
 377 \end{code}
 378
 379 Grab type-signatures/user-pragmas of interest:
 380 \begin{code}
 381 sig_for_here want_me acc s@(Sig n _ _ _)     | want_me n = s:acc
 382 sig_for_here want_me acc s@(InlineSig n _)   | want_me n = s:acc
 383 sig_for_here want_me acc s@(DeforestSig n _) | want_me n = s:acc
 384 sig_for_here want_me acc s@(SpecSig n _ _ _) | want_me n = s:acc
 385 sig_for_here want_me acc s@(MagicUnfoldingSig n _ _)
 386                                              | want_me n = s:acc
 387 sig_for_here want_me acc other_wise                      = acc
 388
 389 -- If a SPECIALIZE pragma is of the "... = blah" form,
 390 -- then we'd better make sure "blah" is taken into
 391 -- acct in the dependency analysis (or we get an
 392 -- unexpected out-of-scope error)! WDP 95/07
 393
 394 sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionUniqSets` singletonUniqSet blah
 395 sig_fv _                           acc = acc
 396 \end{code}
 397
 398 %************************************************************************
 399 %*                                                                      *
 400 \subsection[reconstruct-deps]{Reconstructing dependencies}
 401 %*                                                                      *
 402 %************************************************************************
 403
 404 This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
 405 as the two cases are similar.
 406
 407 \begin{code}
 408 reconstructRec  :: [Cycle]      -- Result of SCC analysis; at least one
 409                 -> [Edge]       -- Original edges
 410                 -> FlatMonoBindsInfo
 411                 -> RenamedHsBinds
 412
 413 reconstructRec cycles edges mbi
 414   = foldr1 ThenBinds (map (reconstructCycle mbi) cycles)
 415   where
 416     reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedHsBinds
 417
 418     reconstructCycle mbi2 cycle
 419       = BIND [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle]
 420                   _TO_ relevant_binds_and_sigs ->
 421
 422         BIND (unzip relevant_binds_and_sigs) _TO_ (binds, sig_lists) ->
 423
 424         BIND (foldr AndMonoBinds EmptyMonoBinds binds) _TO_ this_gp_binds ->
 425         let
 426             this_gp_sigs        = foldr1 (++) sig_lists
 427             have_sigs           = not (null sig_lists)
 428                 -- ToDo: this might not be the right
 429                 -- thing to call this predicate;
 430                 -- e.g. "have_sigs [[], [], []]" ???????????
 431         in
 432         mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle) have_sigs
 433         BEND BEND BEND
 434       where
 435         is_elem = isIn "reconstructRec"
 436
 437         mk_binds :: RenamedMonoBinds -> [RenamedSig]
 438                  -> Bool -> Bool -> RenamedHsBinds
 439
 440         mk_binds bs ss True  False              = SingleBind (RecBind    bs)
 441         mk_binds bs ss True  True{-have sigs-}  = BindWith   (RecBind    bs) ss
 442         mk_binds bs ss False False              = SingleBind (NonRecBind bs)
 443         mk_binds bs ss False True{-have sigs-}  = BindWith   (NonRecBind bs) ss
 444
 445         -- moved from Digraph, as this is the only use here
 446         -- (avoid overloading cost).  We have to use elem
 447         -- (not FiniteMaps or whatever), because there may be
 448         -- many edges out of one vertex.  We give it its own
 449         -- "elem" just for speed.
 450
 451         isCyclic es []  = panic "isCyclic: empty component"
 452         isCyclic es [v] = (v,v) `elem` es
 453         isCyclic es vs  = True
 454
 455         elem _ []       = False
 456         elem x (y:ys)   = x==y || elem x ys
 457 \end{code}
 458
 459 %************************************************************************
 460 %*                                                                      *
 461 %*      Manipulating FlatMonoBindInfo                                   *
 462 %*                                                                      *
 463 %************************************************************************
 464
 465 During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
 466 The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
 467 a function binding, and has itself been dependency-analysed and
 468 renamed.
 469
 470 \begin{code}
 471 type FlatMonoBindsInfo
 472   = [(VertexTag,                -- Identifies the vertex
 473       UniqSet Name,             -- Set of names defined in this vertex
 474       UniqSet Name,             -- Set of names used in this vertex
 475       RenamedMonoBinds,         -- Binding for this vertex (always just one binding, either fun or pat)
 476       [RenamedSig])             -- Signatures, if any, for this vertex
 477     ]
 478
 479 mkVertices :: FlatMonoBindsInfo -> [VertexTag]
 480 mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
 481
 482 mkEdges :: [VertexTag] -> FlatMonoBindsInfo -> [Edge]
 483
 484 mkEdges vertices flat_info
 485  -- An edge (v,v') indicates that v depends on v'
 486  = [ (source_vertex, target_vertex)
 487    | (source_vertex, _, used_names, _, _) <- flat_info,
 488      target_name   <- uniqSetToList used_names,
 489      target_vertex <- vertices_defining target_name flat_info
 490    ]
 491    where
 492    -- If each name only has one binding in this group, then
 493    -- vertices_defining will always return the empty list, or a
 494    -- singleton.  The case when there is more than one binding (an
 495    -- error) needs more thought.
 496
 497    vertices_defining name flat_info2
 498     = [ vertex |  (vertex, names_defined, _, _, _) <- flat_info2,
 499                 name `elementOfUniqSet` names_defined
 500       ]
 501 \end{code}
 502
 503
 504 %************************************************************************
 505 %*                                                                      *
 506 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
 507 %*                                                                      *
 508 %************************************************************************
 509
 510 @rnBindSigs@ checks for: (a)~more than one sig for one thing;
 511 (b)~signatures given for things not bound here; (c)~with suitably
 512 flaggery, that all top-level things have type signatures.
 513
 514 \begin{code}
 515 rnBindSigs :: Bool                  -- True <=> top-level binders
 516             -> [ProtoName]          -- Binders for this decl group
 517             -> [ProtoNameSig]
 518             -> Rn4M [RenamedSig]    -- List of Sig constructors
 519
 520 rnBindSigs is_toplev binder_pnames sigs
 521   =
 522          -- Rename the signatures
 523          -- Will complain about sigs for variables not in this group
 524     mapRn4 rename_sig sigs   `thenRn4` \ sigs_maybe ->
 525     let
 526         sigs' = catMaybes sigs_maybe
 527
 528          -- Discard unbound ones we've already complained about, so we
 529          -- complain about duplicate ones.
 530
 531         (goodies, dups) = removeDups compare (filter not_unbound sigs')
 532     in
 533     mapRn4 (addErrRn4 . dupSigDeclErr) dups `thenRn4_`
 534
 535     getSrcLocRn4                `thenRn4` \ locn ->
 536
 537     (if (is_toplev && opt_SigsRequired) then
 538         let
 539             sig_frees = catMaybes (map (sig_free sigs) binder_pnames)
 540         in
 541         mapRn4 (addErrRn4 . missingSigErr locn) sig_frees
 542      else
 543         returnRn4 []
 544     )                                       `thenRn4_`
 545
 546     returnRn4 sigs' -- bad ones and all:
 547                     -- we need bindings of *some* sort for every name
 548   where
 549     rename_sig (Sig v ty pragma src_loc)
 550       = pushSrcLocRn4 src_loc   (
 551
 552         if not (v `elemByLocalNames` binder_pnames) then
 553            addErrRn4 (unknownSigDeclErr "type signature" v src_loc) `thenRn4_`
 554            returnRn4 Nothing
 555         else
 556            lookupValue v                                `thenRn4` \ new_v ->
 557            rnPolyType False nullTyVarNamesEnv ty        `thenRn4` \ new_ty ->
 558            recoverQuietlyRn4 noGenPragmas (
 559                 rnGenPragmas pragma
 560            )                                        `thenRn4` \ new_pragma ->
 561            returnRn4 (Just (Sig new_v new_ty new_pragma src_loc))
 562         )
 563
 564     -- and now, the various flavours of value-modifying user-pragmas:
 565
 566     rename_sig (SpecSig v ty using src_loc)
 567       = pushSrcLocRn4 src_loc   (
 568
 569         if not (v `elemByLocalNames` binder_pnames) then
 570            addErrRn4 (unknownSigDeclErr "SPECIALIZE pragma" v src_loc) `thenRn4_`
 571            returnRn4 Nothing
 572         else
 573            lookupValue v                                `thenRn4` \ new_v ->
 574            rnPolyType False nullTyVarNamesEnv ty        `thenRn4` \ new_ty ->
 575            rn_using using                               `thenRn4` \ new_using ->
 576            returnRn4 (Just (SpecSig new_v new_ty new_using src_loc))
 577         )
 578       where
 579         rn_using Nothing  = returnRn4 Nothing
 580         rn_using (Just x) = lookupValue x `thenRn4` \ new_x ->
 581                             returnRn4 (Just new_x)
 582
 583     rename_sig (InlineSig v src_loc)
 584       = pushSrcLocRn4 src_loc   (
 585
 586         if not (v `elemByLocalNames` binder_pnames) then
 587            addErrRn4 (unknownSigDeclErr "INLINE pragma" v src_loc) `thenRn4_`
 588            returnRn4 Nothing
 589         else
 590            lookupValue v        `thenRn4` \ new_v ->
 591            returnRn4 (Just (InlineSig new_v src_loc))
 592         )
 593
 594     rename_sig (DeforestSig v src_loc)
 595       = pushSrcLocRn4 src_loc   (
 596
 597         if not (v `elemByLocalNames` binder_pnames) then
 598            addErrRn4 (unknownSigDeclErr "DEFOREST pragma" v src_loc) `thenRn4_`
 599            returnRn4 Nothing
 600         else
 601            lookupValue v        `thenRn4` \ new_v ->
 602            returnRn4 (Just (DeforestSig new_v src_loc))
 603         )
 604
 605     rename_sig (MagicUnfoldingSig v str src_loc)
 606       = pushSrcLocRn4 src_loc   (
 607
 608         if not (v `elemByLocalNames` binder_pnames) then
 609            addErrRn4 (unknownSigDeclErr "MAGIC_UNFOLDING pragma" v src_loc) `thenRn4_`
 610            returnRn4 Nothing
 611         else
 612            lookupValue v        `thenRn4` \ new_v ->
 613            returnRn4 (Just (MagicUnfoldingSig new_v str src_loc))
 614         )
 615
 616     not_unbound :: RenamedSig -> Bool
 617
 618     not_unbound (Sig n _ _ _)             = not (isUnboundName n)
 619     not_unbound (SpecSig n _ _ _)         = not (isUnboundName n)
 620     not_unbound (InlineSig n _)           = not (isUnboundName n)
 621     not_unbound (DeforestSig n _)         = not (isUnboundName n)
 622     not_unbound (MagicUnfoldingSig n _ _) = not (isUnboundName n)
 623
 624     -------------------------------------
 625     sig_free :: [ProtoNameSig] -> ProtoName -> Maybe ProtoName
 626         -- Return "Just x" if "x" has no type signature in
 627         -- sigs.  Nothing, otherwise.
 628
 629     sig_free [] ny = Just ny
 630     sig_free (Sig nx _ _ _ : rest) ny
 631       = if (nx `eqByLocalName` ny) then Nothing else sig_free rest ny
 632     sig_free (_ : rest) ny = sig_free rest ny
 633
 634     -------------------------------------
 635     compare :: RenamedSig -> RenamedSig -> TAG_
 636     compare x y = c x y
 637
 638     c (Sig n1 _ _ _)             (Sig n2 _ _ _)             = n1 `cmp` n2
 639     c (InlineSig n1 _)           (InlineSig n2 _)           = n1 `cmp` n2
 640     c (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmp` n2
 641     c (SpecSig n1 ty1 _ _)       (SpecSig n2 ty2 _ _)
 642       = -- may have many specialisations for one value;
 643         -- but not ones that are exactly the same...
 644         case (n1 `cmp` n2) of
 645           EQ_   -> cmpPolyType cmp ty1 ty2
 646           other -> other
 647
 648     c other_1 other_2   -- tags *must* be different
 649       = let tag1 = tag other_1
 650             tag2 = tag other_2
 651         in
 652         if tag1 _LT_ tag2 then LT_ else GT_
 653
 654     tag (Sig n1 _ _ _)             = (ILIT(1) :: FAST_INT)
 655     tag (SpecSig n1 _ _ _)         = ILIT(2)
 656     tag (InlineSig n1 _)           = ILIT(3)
 657     tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
 658     tag (DeforestSig n1 _)         = ILIT(5)
 659     tag _ = panic# "tag(RnBinds4)"
 660 \end{code}
 661
 662 %************************************************************************
 663 %*                                                                      *
 664 \subsection{Error messages}
 665 %*                                                                      *
 666 %************************************************************************
 667
 668 \begin{code}
 669 dupSigDeclErr sigs
 670   = let
 671         undup_sigs = fst (removeDups cmp_sig sigs)
 672     in
 673     addErrLoc locn1
 674         ("more than one "++what_it_is++"\n\thas been given for these variables") ( \ sty ->
 675     ppAboves (map (ppr sty) undup_sigs) )
 676   where
 677     (what_it_is, locn1)
 678       = case (head sigs) of
 679           Sig        _ _ _ loc -> ("type signature",loc)
 680           ClassOpSig _ _ _ loc -> ("class-method type signature", loc)
 681           SpecSig    _ _ _ loc -> ("SPECIALIZE pragma",loc)
 682           InlineSig  _     loc -> ("INLINE pragma",loc)
 683           MagicUnfoldingSig _ _ loc -> ("MAGIC_UNFOLDING pragma",loc)
 684
 685     cmp_sig a b = get_name a `cmp` get_name b
 686
 687     get_name (Sig        n _ _ _) = n
 688     get_name (ClassOpSig n _ _ _) = n
 689     get_name (SpecSig    n _ _ _) = n
 690     get_name (InlineSig  n     _) = n
 691     get_name (MagicUnfoldingSig n _ _) = n
 692
 693 ------------------------
 694 methodBindErr mbind locn
 695  = addErrLoc locn "Can't handle multiple methods defined by one pattern binding"
 696         (\ sty -> ppr sty mbind)
 697
 698 --------------------------
 699 missingSigErr locn var
 700   = addShortErrLocLine locn ( \ sty ->
 701     ppBesides [ppStr "a definition but no type signature for `",
 702                ppr sty var,
 703                ppStr "'."])
 704
 705 --------------------------------
 706 unknownSigDeclErr flavor var locn
 707   = addShortErrLocLine locn ( \ sty ->
 708     ppBesides [ppStr flavor, ppStr " but no definition for `",
 709                ppr sty var,
 710                ppStr "'."])
 711 \end{code}