2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[RnBinds]{Renaming and dependency analysis of bindings}
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).
12 #include "HsVersions.h"
23 IMPORT_DELOOPER(RnLoop) -- break the RnPass/RnExpr/RnBinds loops
26 import HsPragmas ( isNoGenPragmas, noGenPragmas )
30 import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
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
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-} )
45 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
46 -- place and can be used when complaining.
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
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.
64 ToDo: deal with case where a single monobinds binds the same variable
67 Sets of variable names are represented as sets explicitly, rather than lists.
70 type DefinedVars = UniqSet RnName
71 type FreeVars = UniqSet RnName
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).
82 type Cycle = [VertexTag]
83 type Edge = (VertexTag, VertexTag)
86 %************************************************************************
88 %* naming conventions *
90 %************************************************************************
91 \subsection[name-conventions]{Name conventions}
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.
100 Conventions for variable names are as follows:
103 new code is given a prime to distinguish it from the old.
106 a set of variables defined in @Exp@ is written @dvExp@
109 a set of variables free in @Exp@ is written @fvExp@
112 %************************************************************************
114 %* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) *
116 %************************************************************************
117 \subsubsection[dep-HsBinds]{Polymorphic bindings}
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.
124 Monomorphic bindings contain information that is returned in a tuple
125 (a @FlatMonoBindsInfo@) containing:
129 a unique @Int@ that serves as the ``vertex tag'' for this binding.
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.
136 the free variables of the body. These are referred to as @fvBody@.
139 the definition's actual code. This is referred to as just @code@.
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.
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.
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).
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])
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
167 -- ********************************************************************
169 rnMethodBinds class_name EmptyMonoBinds = returnRn EmptyMonoBinds
171 rnMethodBinds class_name (AndMonoBinds mb1 mb2)
172 = andRn AndMonoBinds (rnMethodBinds class_name mb1)
173 (rnMethodBinds class_name mb2)
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)
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)
188 -- Can't handle method pattern-bindings which bind multiple methods.
189 rnMethodBinds _ mbind@(PatMonoBind other_pat _ locn)
190 = failButContinueRn EmptyMonoBinds (methodBindErr mbind locn)
192 -- ********************************************************************
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
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
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
211 rnTopMonoBinds :: RdrNameMonoBinds -> [RdrNameSig] -> RnM_Fixes s RenamedHsBinds
213 rnTopMonoBinds EmptyMonoBinds sigs = returnRn EmptyBinds
215 rnTopMonoBinds mbs sigs
216 = rnBindSigs True{-top-level-} (collectMonoBinders mbs) sigs `thenRn` \ siglist ->
217 rnMonoBinds mbs siglist `thenRn` \ (new_binds, fv_set) ->
221 rnNestedMonoBinds :: RdrNameMonoBinds -> [RdrNameSig]
222 -> RnM_Fixes s (RenamedHsBinds, FreeVars, [RnName])
224 rnNestedMonoBinds EmptyMonoBinds sigs
225 = returnRn (EmptyBinds, emptyUniqSet, [])
227 rnNestedMonoBinds mbinds sigs -- Non-empty monobinds
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
233 mbinders_w_srclocs = collectMonoBindersAndLocs mbinds
234 mbinders = map fst mbinders_w_srclocs
236 newLocalNames "variable"
237 mbinders_w_srclocs `thenRn` \ new_mbinders ->
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)
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).
252 rnMonoBinds :: RdrNameMonoBinds
253 -> [RenamedSig] -- Signatures attached to this group
254 -> RnM_Fixes s (RenamedHsBinds, FreeVars)
256 rnMonoBinds mbinds siglist
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) ->
263 -- Do the SCC analysis
264 let vertices = mkVertices mbinds_info
265 edges = mkEdges mbinds_info
267 scc_result = stronglyConnComp (==) edges vertices
269 -- Deal with bound and free-var calculation
270 rhs_free_vars = foldr f emptyUniqSet mbinds_info
272 final_binds = reconstructRec scc_result edges mbinds_info
274 happy_answer = returnRn (final_binds, rhs_free_vars)
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
283 f :: (a,b, FreeVars, c,d) -> FreeVars -> FreeVars
285 f (_, _, fvs_body, _, _) fvs_sofar = fvs_sofar `unionUniqSets` fvs_body
287 inline_sigs_in_recursive_binds (BindWith (RecBind _) sigs)
288 = case [(n, locn) | (InlineSig n locn) <- sigs ] of
294 -- Allow INLINEd recursive functions if they are
295 -- designated DEFORESTable too.
296 case [(n, locn) | (DeforestSig n locn) <- sigs ] of
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
306 inline_sigs_in_recursive_binds anything_else = Nothing
309 @flattenMonoBinds@ is ever-so-slightly magical in that it sticks
310 unique ``vertex tags'' on its output; minor plumbing required.
313 flattenMonoBinds :: Int -- Next free vertex tag
314 -> [RenamedSig] -- Signatures
316 -> RnM_Fixes s (Int, FlatMonoBindsInfo)
318 flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn (uniq, [])
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)
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) ->
330 -- Find which things are bound in this group
332 names_bound_here = collectPatBinders pat'
334 sigs_etc_for_here = foldl (sig_for_here (\ n -> n `is_elem` names_bound_here))
337 sigs_fvs = foldr sig_fv emptyUniqSet sigs_etc_for_here
339 is_elem = isIn "flattenMonoBinds"
344 mkUniqSet names_bound_here,
345 fvs `unionUniqSets` sigs_fvs,
346 PatMonoBind pat' grhss_and_binds' locn,
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_`
357 fvs = unionManyUniqSets fv_lists
359 sigs_for_me = foldl (sig_for_here (\ n -> n == name')) [] sigs
361 sigs_fvs = foldr sig_fv emptyUniqSet sigs_for_me
367 fvs `unionUniqSets` sigs_fvs,
368 FunMonoBind name' inf new_matches locn,
374 Grab type-signatures/user-pragmas of interest:
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 _ _)
382 sig_for_here want_me acc other_wise = acc
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
389 sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionUniqSets` unitUniqSet blah
393 %************************************************************************
395 \subsection[reconstruct-deps]{Reconstructing dependencies}
397 %************************************************************************
399 This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
400 as the two cases are similar.
403 reconstructRec :: [Cycle] -- Result of SCC analysis; at least one
404 -> [Edge] -- Original edges
408 reconstructRec cycles edges mbi
409 = foldr1 ThenBinds (map (reconstructCycle mbi) cycles)
411 reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedHsBinds
413 reconstructCycle mbi2 cycle
414 = case [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle]
415 of { relevant_binds_and_sigs ->
417 case (unzip relevant_binds_and_sigs) of { (binds, sig_lists) ->
419 case (foldr AndMonoBinds EmptyMonoBinds binds) of { this_gp_binds ->
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 [[], [], []]" ???????????
427 mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle) have_sigs
430 is_elem = isIn "reconstructRec"
432 mk_binds :: RenamedMonoBinds -> [RenamedSig]
433 -> Bool -> Bool -> RenamedHsBinds
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
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.
446 isCyclic es [] = panic "isCyclic: empty component"
447 isCyclic es [v] = (v,v) `elem` es
448 isCyclic es vs = True
451 elem x (y:ys) = x==y || elem x ys
454 %************************************************************************
456 %* Manipulating FlatMonoBindInfo *
458 %************************************************************************
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
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
474 mkVertices :: FlatMonoBindsInfo -> [VertexTag]
475 mkEdges :: FlatMonoBindsInfo -> [Edge]
477 mkVertices info = [ vertex | (vertex,_,_,_,_) <- 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
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.
493 vertices_defining name flat_info2
494 = [ vertex | (vertex, names_defined, _, _, _) <- flat_info2,
495 name `elementOfUniqSet` names_defined
500 %************************************************************************
502 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
504 %************************************************************************
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.
511 rnBindSigs :: Bool -- True <=> top-level binders
512 -> [RdrName] -- Binders for this decl group
514 -> RnM_Fixes s [RenamedSig] -- List of Sig constructors
516 rnBindSigs is_toplev binder_occnames sigs
518 -- Rename the signatures
519 -- Will complain about sigs for variables not in this group
520 mapRn rename_sig sigs `thenRn` \ sigs_maybe ->
522 sigs' = catMaybes sigs_maybe
524 -- Discard unbound ones we've already complained about, so we
525 -- complain about duplicate ones.
527 (goodies, dups) = removeDups compare (filter (\ x -> not_unbound x && not_main x) sigs')
529 mapRn (addErrRn . dupSigDeclErr) dups `thenRn_`
531 getSrcLocRn `thenRn` \ locn ->
533 (if (is_toplev && opt_SigsRequired) then
535 sig_frees = catMaybes (map (sig_free sigs) binder_occnames)
537 mapRn (addErrRn . missingSigErr locn) sig_frees
542 returnRn sigs' -- bad ones and all:
543 -- we need bindings of *some* sort for every name
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_`
551 lookupValue v `thenRn` \ new_v ->
552 rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
554 ASSERT(isNoGenPragmas pragmas)
555 returnRn (Just (Sig new_v new_ty noGenPragmas src_loc))
557 -- and now, the various flavours of value-modifying user-pragmas:
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_`
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))
570 rn_using Nothing = returnRn Nothing
571 rn_using (Just x) = lookupValue x `thenRn` \ new_x ->
572 returnRn (Just new_x)
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_`
580 lookupValue v `thenRn` \ new_v ->
581 returnRn (Just (InlineSig new_v src_loc))
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_`
589 lookupValue v `thenRn` \ new_v ->
590 returnRn (Just (DeforestSig new_v src_loc))
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_`
598 lookupValue v `thenRn` \ new_v ->
599 returnRn (Just (MagicUnfoldingSig new_v str src_loc))
601 not_unbound, not_main :: RenamedSig -> Bool
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)
609 not_main (Sig n _ _ _) = let str = getLocalName n in
610 not (str == SLIT("main") || str == SLIT("mainPrimIO"))
613 -------------------------------------
614 sig_free :: [RdrNameSig] -> RdrName -> Maybe RdrName
615 -- Return "Just x" if "x" has no type signature in
616 -- sigs. Nothing, otherwise.
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
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)
633 compare other_1 other_2 -- tags *must* be different
634 = let tag1 = tag other_1
637 if tag1 _LT_ tag2 then LT_ else GT_
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)"
647 %************************************************************************
649 \subsection{Error messages}
651 %************************************************************************
656 undup_sigs = fst (removeDups cmp_sig sigs)
659 ("more than one "++what_it_is++"\n\thas been given for these variables") ( \ sty ->
660 ppAboves (map (ppr sty) undup_sigs) )
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)
670 cmp_sig a b = get_name a `cmp` get_name b
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
678 ------------------------
679 methodBindErr mbind locn
680 = addErrLoc locn "Can't handle multiple methods defined by one pattern binding"
681 (\ sty -> ppr sty mbind)
683 --------------------------
684 missingSigErr locn var
685 = addShortErrLocLine locn ( \ sty ->
686 ppBesides [ppStr "a definition but no type signature for `",
690 --------------------------------
691 unknownSigDeclErr flavor var locn
692 = addShortErrLocLine locn ( \ sty ->
693 ppBesides [ppStr flavor, ppStr " but no definition for `",