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 import Ubiq
  23 import RnLoop           -- break the RnPass4/RnExpr4/RnBinds4 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 )
  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 matches locn)
 175   = pushSrcLocRn locn                   $
 176     lookupClassOp class_name occname    `thenRn` \ op_name ->
 177     mapAndUnzipRn rnMatch matches       `thenRn` \ (new_matches, _) ->
 178     returnRn (FunMonoBind op_name new_matches locn)
 179
 180 rnMethodBinds class_name (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
 181   = pushSrcLocRn locn                   $
 182     lookupClassOp class_name occname    `thenRn` \ op_name ->
 183     rnGRHSsAndBinds grhss_and_binds     `thenRn` \ (grhss_and_binds', _) ->
 184     returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
 185
 186 -- Can't handle method pattern-bindings which bind multiple methods.
 187 rnMethodBinds _ mbind@(PatMonoBind other_pat _ locn)
 188   = failButContinueRn EmptyMonoBinds (methodBindErr mbind locn)
 189
 190 -- ********************************************************************
 191
 192 rnBinds EmptyBinds                      = returnRn (EmptyBinds,emptyUniqSet,[])
 193 rnBinds (SingleBind (RecBind bind))     = rnNestedMonoBinds bind []
 194 rnBinds (BindWith (RecBind bind) sigs) = rnNestedMonoBinds bind sigs
 195   -- the parser doesn't produce other forms
 196 \end{code}
 197
 198 @rnNestedMonoBinds@
 199         - collects up the binders for this declaration group,
 200         - checkes that they form a set
 201         - extends the environment to bind them to new local names
 202         - calls @rnMonoBinds@ to do the real work
 203
 204 In contrast, @rnTopMonoBinds@ doesn't extend the environment, because that's
 205 already done in pass3.  All it does is call @rnMonoBinds@ and discards
 206 the free var info.
 207
 208 \begin{code}
 209 rnTopMonoBinds :: RdrNameMonoBinds -> [RdrNameSig] -> RnM_Fixes s RenamedHsBinds
 210
 211 rnTopMonoBinds EmptyMonoBinds sigs = returnRn EmptyBinds
 212
 213 rnTopMonoBinds mbs sigs
 214  = rnBindSigs True{-top-level-} (collectMonoBinders mbs) sigs `thenRn` \ siglist ->
 215    rnMonoBinds mbs siglist `thenRn` \ (new_binds, fv_set) ->
 216    returnRn new_binds
 217
 218
 219 rnNestedMonoBinds :: RdrNameMonoBinds -> [RdrNameSig]
 220                   -> RnM_Fixes s (RenamedHsBinds, FreeVars, [RnName])
 221
 222 rnNestedMonoBinds EmptyMonoBinds sigs
 223   = returnRn (EmptyBinds, emptyUniqSet, [])
 224
 225 rnNestedMonoBinds mbinds sigs   -- Non-empty monobinds
 226   =
 227         -- Extract all the binders in this group,
 228         -- and extend current scope, inventing new names for the new binders
 229         -- This also checks that the names form a set
 230     let
 231         mbinders_w_srclocs = collectMonoBindersAndLocs mbinds
 232         mbinders           = map fst mbinders_w_srclocs
 233     in
 234     newLocalNames "variable"
 235                   mbinders_w_srclocs    `thenRn` \ new_mbinders ->
 236
 237     extendSS2 new_mbinders (
 238          rnBindSigs False{-not top- level-} mbinders sigs `thenRn` \ siglist ->
 239          rnMonoBinds mbinds  siglist
 240     )                                   `thenRn` \ (new_binds, fv_set) ->
 241     returnRn (new_binds, fv_set, new_mbinders)
 242 \end{code}
 243
 244 @rnMonoBinds@ is used by *both* top-level and nested bindings.  It
 245 assumes that all variables bound in this group are already in scope.
 246 This is done *either* by pass 3 (for the top-level bindings),
 247 *or* by @rnNestedMonoBinds@ (for the nested ones).
 248
 249 \begin{code}
 250 rnMonoBinds :: RdrNameMonoBinds
 251             -> [RenamedSig]     -- Signatures attached to this group
 252             -> RnM_Fixes s (RenamedHsBinds, FreeVars)
 253
 254 rnMonoBinds mbinds siglist
 255   =
 256          -- Rename the bindings, returning a MonoBindsInfo
 257          -- which is a list of indivisible vertices so far as
 258          -- the strongly-connected-components (SCC) analysis is concerned
 259     flattenMonoBinds 0 siglist mbinds   `thenRn` \ (_, mbinds_info) ->
 260
 261          -- Do the SCC analysis
 262     let vertices = mkVertices mbinds_info
 263         edges   = mkEdges vertices mbinds_info
 264
 265         scc_result = stronglyConnComp (==) edges vertices
 266
 267          -- Deal with bound and free-var calculation
 268         rhs_free_vars = foldr f emptyUniqSet mbinds_info
 269
 270         final_binds = reconstructRec scc_result edges mbinds_info
 271
 272         happy_answer = returnRn (final_binds, rhs_free_vars)
 273     in
 274     case (inline_sigs_in_recursive_binds final_binds) of
 275       Nothing -> happy_answer
 276       Just names_n_locns ->
 277 -- SLPJ: sometimes want recursive INLINE for worker wrapper style stuff
 278 --      addErrRn (inlineInRecursiveBindsErr names_n_locns) `thenRn_`
 279         {-not so-}happy_answer
 280   where
 281     f :: (a,b, FreeVars, c,d) -> FreeVars -> FreeVars
 282
 283     f (_, _, fvs_body, _, _) fvs_sofar = fvs_sofar `unionUniqSets` fvs_body
 284
 285     inline_sigs_in_recursive_binds (BindWith (RecBind _) sigs)
 286       = case [(n, locn) | (InlineSig n locn) <- sigs ] of
 287           []   -> Nothing
 288           sigh ->
 289 #if OMIT_DEFORESTER
 290                 Just sigh
 291 #else
 292                 -- Allow INLINEd recursive functions if they are
 293                 -- designated DEFORESTable too.
 294                 case [(n, locn) | (DeforestSig n locn) <- sigs ] of
 295                         []   -> Just sigh
 296                         sigh -> Nothing
 297 #endif
 298
 299     inline_sigs_in_recursive_binds (ThenBinds b1 b2)
 300       = case (inline_sigs_in_recursive_binds b1) of
 301           Nothing -> inline_sigs_in_recursive_binds b2
 302           Just  x -> Just x -- NB: won't report error(s) in b2
 303
 304     inline_sigs_in_recursive_binds anything_else = Nothing
 305 \end{code}
 306
 307 @flattenMonoBinds@ is ever-so-slightly magical in that it sticks
 308 unique ``vertex tags'' on its output; minor plumbing required.
 309
 310 \begin{code}
 311 flattenMonoBinds :: Int                         -- Next free vertex tag
 312                  -> [RenamedSig]                -- Signatures
 313                  -> RdrNameMonoBinds
 314                  -> RnM_Fixes s (Int, FlatMonoBindsInfo)
 315
 316 flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn (uniq, [])
 317
 318 flattenMonoBinds uniq sigs (AndMonoBinds mB1 mB2)
 319   = flattenMonoBinds uniq sigs mB1      `thenRn` \ (uniq1, flat1) ->
 320     flattenMonoBinds uniq1 sigs mB2     `thenRn` \ (uniq2, flat2) ->
 321     returnRn (uniq2, flat1 ++ flat2)
 322
 323 flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
 324   = pushSrcLocRn locn                   $
 325     rnPat pat                           `thenRn` \ pat' ->
 326     rnGRHSsAndBinds grhss_and_binds     `thenRn` \ (grhss_and_binds', fvs) ->
 327
 328          -- Find which things are bound in this group
 329     let
 330         names_bound_here = collectPatBinders pat'
 331
 332         sigs_etc_for_here = foldl (sig_for_here (\ n -> n `is_elem` names_bound_here))
 333                                   [] sigs
 334
 335         sigs_fvs = foldr sig_fv emptyUniqSet sigs_etc_for_here
 336
 337         is_elem = isIn "flattenMonoBinds"
 338     in
 339     returnRn (
 340         uniq + 1,
 341         [(uniq,
 342           mkUniqSet names_bound_here,
 343            fvs `unionUniqSets` sigs_fvs,
 344            PatMonoBind pat' grhss_and_binds' locn,
 345            sigs_etc_for_here
 346          )]
 347     )
 348
 349 flattenMonoBinds uniq sigs (FunMonoBind name matches locn)
 350   = pushSrcLocRn locn                   $
 351     lookupValue name                    `thenRn` \ name' ->
 352     mapAndUnzipRn rnMatch matches       `thenRn` \ (new_matches, fv_lists) ->
 353     let
 354         fvs = unionManyUniqSets fv_lists
 355
 356         sigs_for_me = foldl (sig_for_here (\ n -> n == name')) [] sigs
 357
 358         sigs_fvs = foldr sig_fv emptyUniqSet sigs_for_me
 359     in
 360     returnRn (
 361       uniq + 1,
 362       [(uniq,
 363         unitUniqSet name',
 364         fvs `unionUniqSets` sigs_fvs,
 365         FunMonoBind name' new_matches locn,
 366         sigs_for_me
 367         )]
 368     )
 369 \end{code}
 370
 371 Grab type-signatures/user-pragmas of interest:
 372 \begin{code}
 373 sig_for_here want_me acc s@(Sig n _ _ _)     | want_me n = s:acc
 374 sig_for_here want_me acc s@(InlineSig n _)   | want_me n = s:acc
 375 sig_for_here want_me acc s@(DeforestSig n _) | want_me n = s:acc
 376 sig_for_here want_me acc s@(SpecSig n _ _ _) | want_me n = s:acc
 377 sig_for_here want_me acc s@(MagicUnfoldingSig n _ _)
 378                                              | want_me n = s:acc
 379 sig_for_here want_me acc other_wise                      = acc
 380
 381 -- If a SPECIALIZE pragma is of the "... = blah" form,
 382 -- then we'd better make sure "blah" is taken into
 383 -- acct in the dependency analysis (or we get an
 384 -- unexpected out-of-scope error)! WDP 95/07
 385
 386 sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionUniqSets` unitUniqSet blah
 387 sig_fv _                           acc = acc
 388 \end{code}
 389
 390 %************************************************************************
 391 %*                                                                      *
 392 \subsection[reconstruct-deps]{Reconstructing dependencies}
 393 %*                                                                      *
 394 %************************************************************************
 395
 396 This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
 397 as the two cases are similar.
 398
 399 \begin{code}
 400 reconstructRec  :: [Cycle]      -- Result of SCC analysis; at least one
 401                 -> [Edge]       -- Original edges
 402                 -> FlatMonoBindsInfo
 403                 -> RenamedHsBinds
 404
 405 reconstructRec cycles edges mbi
 406   = foldr1 ThenBinds (map (reconstructCycle mbi) cycles)
 407   where
 408     reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedHsBinds
 409
 410     reconstructCycle mbi2 cycle
 411       = BIND [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle]
 412                   _TO_ relevant_binds_and_sigs ->
 413
 414         BIND (unzip relevant_binds_and_sigs) _TO_ (binds, sig_lists) ->
 415
 416         BIND (foldr AndMonoBinds EmptyMonoBinds binds) _TO_ this_gp_binds ->
 417         let
 418             this_gp_sigs        = foldr1 (++) sig_lists
 419             have_sigs           = not (null sig_lists)
 420                 -- ToDo: this might not be the right
 421                 -- thing to call this predicate;
 422                 -- e.g. "have_sigs [[], [], []]" ???????????
 423         in
 424         mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle) have_sigs
 425         BEND BEND BEND
 426       where
 427         is_elem = isIn "reconstructRec"
 428
 429         mk_binds :: RenamedMonoBinds -> [RenamedSig]
 430                  -> Bool -> Bool -> RenamedHsBinds
 431
 432         mk_binds bs ss True  False              = SingleBind (RecBind    bs)
 433         mk_binds bs ss True  True{-have sigs-}  = BindWith   (RecBind    bs) ss
 434         mk_binds bs ss False False              = SingleBind (NonRecBind bs)
 435         mk_binds bs ss False True{-have sigs-}  = BindWith   (NonRecBind bs) ss
 436
 437         -- moved from Digraph, as this is the only use here
 438         -- (avoid overloading cost).  We have to use elem
 439         -- (not FiniteMaps or whatever), because there may be
 440         -- many edges out of one vertex.  We give it its own
 441         -- "elem" just for speed.
 442
 443         isCyclic es []  = panic "isCyclic: empty component"
 444         isCyclic es [v] = (v,v) `elem` es
 445         isCyclic es vs  = True
 446
 447         elem _ []       = False
 448         elem x (y:ys)   = x==y || elem x ys
 449 \end{code}
 450
 451 %************************************************************************
 452 %*                                                                      *
 453 %*      Manipulating FlatMonoBindInfo                                   *
 454 %*                                                                      *
 455 %************************************************************************
 456
 457 During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
 458 The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
 459 a function binding, and has itself been dependency-analysed and
 460 renamed.
 461
 462 \begin{code}
 463 type FlatMonoBindsInfo
 464   = [(VertexTag,                -- Identifies the vertex
 465       UniqSet RnName,           -- Set of names defined in this vertex
 466       UniqSet RnName,           -- Set of names used in this vertex
 467       RenamedMonoBinds,         -- Binding for this vertex (always just one binding, either fun or pat)
 468       [RenamedSig])             -- Signatures, if any, for this vertex
 469     ]
 470
 471 mkVertices :: FlatMonoBindsInfo -> [VertexTag]
 472 mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
 473
 474 mkEdges :: [VertexTag] -> FlatMonoBindsInfo -> [Edge]
 475
 476 mkEdges vertices flat_info
 477  -- An edge (v,v') indicates that v depends on v'
 478  = [ (source_vertex, target_vertex)
 479    | (source_vertex, _, used_names, _, _) <- flat_info,
 480      target_name   <- uniqSetToList used_names,
 481      target_vertex <- vertices_defining target_name flat_info
 482    ]
 483    where
 484    -- If each name only has one binding in this group, then
 485    -- vertices_defining will always return the empty list, or a
 486    -- singleton.  The case when there is more than one binding (an
 487    -- error) needs more thought.
 488
 489    vertices_defining name flat_info2
 490     = [ vertex |  (vertex, names_defined, _, _, _) <- flat_info2,
 491                 name `elementOfUniqSet` names_defined
 492       ]
 493 \end{code}
 494
 495
 496 %************************************************************************
 497 %*                                                                      *
 498 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
 499 %*                                                                      *
 500 %************************************************************************
 501
 502 @rnBindSigs@ checks for: (a)~more than one sig for one thing;
 503 (b)~signatures given for things not bound here; (c)~with suitably
 504 flaggery, that all top-level things have type signatures.
 505
 506 \begin{code}
 507 rnBindSigs :: Bool                      -- True <=> top-level binders
 508             -> [RdrName]                -- Binders for this decl group
 509             -> [RdrNameSig]
 510             -> RnM_Fixes s [RenamedSig] -- List of Sig constructors
 511
 512 rnBindSigs is_toplev binder_occnames sigs
 513   =
 514          -- Rename the signatures
 515          -- Will complain about sigs for variables not in this group
 516     mapRn rename_sig sigs       `thenRn` \ sigs_maybe ->
 517     let
 518         sigs' = catMaybes sigs_maybe
 519
 520          -- Discard unbound ones we've already complained about, so we
 521          -- complain about duplicate ones.
 522
 523         (goodies, dups) = removeDups compare (filter not_unbound sigs')
 524     in
 525     mapRn (addErrRn . dupSigDeclErr) dups `thenRn_`
 526
 527     getSrcLocRn                 `thenRn` \ locn ->
 528
 529     (if (is_toplev && opt_SigsRequired) then
 530         let
 531             sig_frees = catMaybes (map (sig_free sigs) binder_occnames)
 532         in
 533         mapRn (addErrRn . missingSigErr locn) sig_frees
 534      else
 535         returnRn []
 536     )                           `thenRn_`
 537
 538     returnRn sigs' -- bad ones and all:
 539                    -- we need bindings of *some* sort for every name
 540   where
 541     rename_sig (Sig v ty pragmas src_loc)
 542       = pushSrcLocRn src_loc $
 543         if not (v `elem` binder_occnames) then
 544            addErrRn (unknownSigDeclErr "type signature" v src_loc) `thenRn_`
 545            returnRn Nothing
 546         else
 547            lookupValue v                        `thenRn` \ new_v ->
 548            rnPolyType nullTyVarNamesEnv ty      `thenRn` \ new_ty ->
 549
 550            ASSERT(isNoGenPragmas pragmas)
 551            returnRn (Just (Sig new_v new_ty noGenPragmas src_loc))
 552
 553     -- and now, the various flavours of value-modifying user-pragmas:
 554
 555     rename_sig (SpecSig v ty using src_loc)
 556       = pushSrcLocRn src_loc $
 557         if not (v `elem` binder_occnames) then
 558            addErrRn (unknownSigDeclErr "SPECIALIZE pragma" v src_loc) `thenRn_`
 559            returnRn Nothing
 560         else
 561            lookupValue v                        `thenRn` \ new_v ->
 562            rnPolyType nullTyVarNamesEnv ty      `thenRn` \ new_ty ->
 563            rn_using using                       `thenRn` \ new_using ->
 564            returnRn (Just (SpecSig new_v new_ty new_using src_loc))
 565       where
 566         rn_using Nothing  = returnRn Nothing
 567         rn_using (Just x) = lookupValue x `thenRn` \ new_x ->
 568                             returnRn (Just new_x)
 569
 570     rename_sig (InlineSig v src_loc)
 571       = pushSrcLocRn src_loc $
 572         if not (v `elem` binder_occnames) then
 573            addErrRn (unknownSigDeclErr "INLINE pragma" v src_loc) `thenRn_`
 574            returnRn Nothing
 575         else
 576            lookupValue v        `thenRn` \ new_v ->
 577            returnRn (Just (InlineSig new_v src_loc))
 578
 579     rename_sig (DeforestSig v src_loc)
 580       = pushSrcLocRn src_loc $
 581         if not (v `elem` binder_occnames) then
 582            addErrRn (unknownSigDeclErr "DEFOREST pragma" v src_loc) `thenRn_`
 583            returnRn Nothing
 584         else
 585            lookupValue v        `thenRn` \ new_v ->
 586            returnRn (Just (DeforestSig new_v src_loc))
 587
 588     rename_sig (MagicUnfoldingSig v str src_loc)
 589       = pushSrcLocRn src_loc $
 590         if not (v `elem` binder_occnames) then
 591            addErrRn (unknownSigDeclErr "MAGIC_UNFOLDING pragma" v src_loc) `thenRn_`
 592            returnRn Nothing
 593         else
 594            lookupValue v        `thenRn` \ new_v ->
 595            returnRn (Just (MagicUnfoldingSig new_v str src_loc))
 596
 597     not_unbound :: RenamedSig -> Bool
 598
 599     not_unbound (Sig n _ _ _)             = not (isRnUnbound n)
 600     not_unbound (SpecSig n _ _ _)         = not (isRnUnbound n)
 601     not_unbound (InlineSig n _)           = not (isRnUnbound n)
 602     not_unbound (DeforestSig n _)         = not (isRnUnbound n)
 603     not_unbound (MagicUnfoldingSig n _ _) = not (isRnUnbound n)
 604
 605     -------------------------------------
 606     sig_free :: [RdrNameSig] -> RdrName -> Maybe RdrName
 607         -- Return "Just x" if "x" has no type signature in
 608         -- sigs.  Nothing, otherwise.
 609
 610     sig_free [] ny = Just ny
 611     sig_free (Sig nx _ _ _ : rest) ny
 612       = if (nx == ny) then Nothing else sig_free rest ny
 613     sig_free (_ : rest) ny = sig_free rest ny
 614
 615     -------------------------------------
 616     compare :: RenamedSig -> RenamedSig -> TAG_
 617     compare (Sig n1 _ _ _)             (Sig n2 _ _ _)             = n1 `cmp` n2
 618     compare (InlineSig n1 _)           (InlineSig n2 _)           = n1 `cmp` n2
 619     compare (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmp` n2
 620     compare (SpecSig n1 ty1 _ _)       (SpecSig n2 ty2 _ _)
 621       = -- may have many specialisations for one value;
 622         -- but not ones that are exactly the same...
 623         thenCmp (n1 `cmp` n2) (cmpPolyType cmp ty1 ty2)
 624
 625     compare other_1 other_2     -- tags *must* be different
 626       = let tag1 = tag other_1
 627             tag2 = tag other_2
 628         in
 629         if tag1 _LT_ tag2 then LT_ else GT_
 630
 631     tag (Sig n1 _ _ _)             = (ILIT(1) :: FAST_INT)
 632     tag (SpecSig n1 _ _ _)         = ILIT(2)
 633     tag (InlineSig n1 _)           = ILIT(3)
 634     tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
 635     tag (DeforestSig n1 _)         = ILIT(5)
 636     tag _ = panic# "tag(RnBinds)"
 637 \end{code}
 638
 639 %************************************************************************
 640 %*                                                                      *
 641 \subsection{Error messages}
 642 %*                                                                      *
 643 %************************************************************************
 644
 645 \begin{code}
 646 dupSigDeclErr sigs
 647   = let
 648         undup_sigs = fst (removeDups cmp_sig sigs)
 649     in
 650     addErrLoc locn1
 651         ("more than one "++what_it_is++"\n\thas been given for these variables") ( \ sty ->
 652     ppAboves (map (ppr sty) undup_sigs) )
 653   where
 654     (what_it_is, locn1)
 655       = case (head sigs) of
 656           Sig        _ _ _ loc -> ("type signature",loc)
 657           ClassOpSig _ _ _ loc -> ("class-method type signature", loc)
 658           SpecSig    _ _ _ loc -> ("SPECIALIZE pragma",loc)
 659           InlineSig  _     loc -> ("INLINE pragma",loc)
 660           MagicUnfoldingSig _ _ loc -> ("MAGIC_UNFOLDING pragma",loc)
 661
 662     cmp_sig a b = get_name a `cmp` get_name b
 663
 664     get_name (Sig        n _ _ _) = n
 665     get_name (ClassOpSig n _ _ _) = n
 666     get_name (SpecSig    n _ _ _) = n
 667     get_name (InlineSig  n     _) = n
 668     get_name (MagicUnfoldingSig n _ _) = n
 669
 670 ------------------------
 671 methodBindErr mbind locn
 672  = addErrLoc locn "Can't handle multiple methods defined by one pattern binding"
 673         (\ sty -> ppr sty mbind)
 674
 675 --------------------------
 676 missingSigErr locn var
 677   = addShortErrLocLine locn ( \ sty ->
 678     ppBesides [ppStr "a definition but no type signature for `",
 679                ppr sty var,
 680                ppStr "'."])
 681
 682 --------------------------------
 683 unknownSigDeclErr flavor var locn
 684   = addShortErrLocLine locn ( \ sty ->
 685     ppBesides [ppStr flavor, ppStr " but no definition for `",
 686                ppr sty var,
 687                ppStr "'."])
 688 \end{code}