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