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