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