compiler/hsSyn/HsBinds.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
   6
   7 Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
   8
   9 \begin{code}
  10 {-# OPTIONS -fno-warn-incomplete-patterns #-}
  11 -- The above warning supression flag is a temporary kludge.
  12 -- While working on this module you are encouraged to remove it and fix
  13 -- any warnings in the module. See
  14 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  15 -- for details
  16
  17 module HsBinds where
  18
  19 #include "HsVersions.h"
  20
  21 import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr,
  22                                MatchGroup, pprFunBind,
  23                                GRHSs, pprPatBind )
  24 import {-# SOURCE #-} HsPat  ( LPat )
  25
  26 import HsTypes
  27 import PprCore ()
  28 import Coercion
  29 import Type
  30 import Name
  31 import NameSet
  32 import BasicTypes
  33 import Outputable
  34 import SrcLoc
  35 import Util
  36 import Var
  37 import Bag
  38 import FastString
  39 \end{code}
  40
  41 %************************************************************************
  42 %*                                                                      *
  43 \subsection{Bindings: @BindGroup@}
  44 %*                                                                      *
  45 %************************************************************************
  46
  47 Global bindings (where clauses)
  48
  49 \begin{code}
  50 -- During renaming, we need bindings where the left-hand sides
  51 -- have been renamed but the the right-hand sides have not.
  52 -- the ...LR datatypes are parametrized by two id types,
  53 -- one for the left and one for the right.
  54 -- Other than during renaming, these will be the same.
  55
  56 type HsLocalBinds id = HsLocalBindsLR id id
  57
  58 data HsLocalBindsLR idL idR     -- Bindings in a 'let' expression
  59                                -- or a 'where' clause
  60   = HsValBinds (HsValBindsLR idL idR)
  61   | HsIPBinds  (HsIPBinds idR)
  62   | EmptyLocalBinds
  63
  64 type HsValBinds id = HsValBindsLR id id
  65
  66 data HsValBindsLR idL idR  -- Value bindings (not implicit parameters)
  67   = ValBindsIn             -- Before typechecking
  68         (LHsBindsLR idL idR) [LSig idR] -- Not dependency analysed
  69                                         -- Recursive by default
  70
  71   | ValBindsOut                -- After renaming
  72         [(RecFlag, LHsBinds idL)]       -- Dependency analysed, later bindings
  73                                         -- in the list may depend on earlier
  74                                         -- ones.
  75         [LSig Name]
  76
  77 type LHsBinds id  = Bag (LHsBind id)
  78 type DictBinds id = LHsBinds id         -- Used for dictionary or method bindings
  79 type LHsBind  id  = Located (HsBind id)
  80 type HsBind id = HsBindLR id id
  81
  82 type LHsBindLR idL idR = Located (HsBindLR idL idR)
  83 type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
  84
  85 data HsBindLR idL idR
  86   = FunBind {   -- FunBind is used for both functions   f x = e
  87                 -- and variables                        f = \x -> e
  88 -- Reason 1: Special case for type inference: see TcBinds.tcMonoBinds
  89 --
  90 -- Reason 2: instance decls can only have FunBinds, which is convenient
  91 --           If you change this, you'll need tochange e.g. rnMethodBinds
  92
  93 -- But note that the form       f :: a->a = ...
  94 -- parses as a pattern binding, just like
  95 --                      (f :: a -> a) = ...
  96
  97         fun_id :: Located idL,
  98
  99         fun_infix :: Bool,      -- True => infix declaration
 100
 101         fun_matches :: MatchGroup idR,  -- The payload
 102
 103         fun_co_fn :: HsWrapper, -- Coercion from the type of the MatchGroup to the type of
 104                                 -- the Id.  Example:
 105                                 --      f :: Int -> forall a. a -> a
 106                                 --      f x y = y
 107                                 -- Then the MatchGroup will have type (Int -> a' -> a')
 108                                 -- (with a free type variable a').  The coercion will take
 109                                 -- a CoreExpr of this type and convert it to a CoreExpr of
 110                                 -- type         Int -> forall a'. a' -> a'
 111                                 -- Notice that the coercion captures the free a'.
 112
 113         bind_fvs :: NameSet,    -- After the renamer, this contains a superset of the
 114                                 -- Names of the other binders in this binding group that
 115                                 -- are free in the RHS of the defn
 116                                 -- Before renaming, and after typechecking,
 117                                 -- the field is unused; it's just an error thunk
 118
 119         fun_tick :: Maybe (Int,[idR])   -- This is the (optional) module-local tick number.
 120     }
 121
 122   | PatBind {   -- The pattern is never a simple variable;
 123                 -- That case is done by FunBind
 124         pat_lhs    :: LPat idL,
 125         pat_rhs    :: GRHSs idR,
 126         pat_rhs_ty :: PostTcType,       -- Type of the GRHSs
 127         bind_fvs   :: NameSet           -- Same as for FunBind
 128     }
 129
 130   | VarBind {   -- Dictionary binding and suchlike
 131         var_id :: idL,          -- All VarBinds are introduced by the type checker
 132         var_rhs :: LHsExpr idR  -- Located only for consistency
 133     }
 134
 135   | AbsBinds {                                  -- Binds abstraction; TRANSLATION
 136        abs_tvs     :: [TyVar],
 137         abs_dicts   :: [DictId],
 138        -- AbsBinds only gets used when idL = idR after renaming,
 139        -- but these need to be idL's for the collect... code in HsUtil to have
 140        -- the right type
 141         abs_exports :: [([TyVar], idL, idL, [LPrag])],  -- (tvs, poly_id, mono_id, prags)
 142         abs_binds   :: LHsBinds idL             -- The dictionary bindings and typechecked user bindings
 143                                                 -- mixed up together; you can tell the dict bindings because
 144                                                 -- they are all VarBinds
 145     }
 146         -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
 147         --
 148         -- Creates bindings for (polymorphic, overloaded) poly_f
 149         -- in terms of monomorphic, non-overloaded mono_f
 150         --
 151         -- Invariants:
 152         --      1. 'binds' binds mono_f
 153         --      2. ftvs is a subset of tvs
 154         --      3. ftvs includes all tyvars free in ds
 155         --
 156         -- See section 9 of static semantics paper for more details.
 157         -- (You can get a PhD for explaining the True Meaning
 158         --  of this last construct.)
 159
 160 placeHolderNames :: NameSet
 161 -- Used for the NameSet in FunBind and PatBind prior to the renamer
 162 placeHolderNames = panic "placeHolderNames"
 163
 164 ------------
 165 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where
 166   ppr (HsValBinds bs) = ppr bs
 167   ppr (HsIPBinds bs)  = ppr bs
 168   ppr EmptyLocalBinds = empty
 169
 170 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where
 171   ppr (ValBindsIn binds sigs)
 172    = pprValBindsForUser binds sigs
 173
 174   ppr (ValBindsOut sccs sigs)
 175     = getPprStyle $ \ sty ->
 176       if debugStyle sty then    -- Print with sccs showing
 177         vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
 178      else
 179         pprValBindsForUser (unionManyBags (map snd sccs)) sigs
 180    where
 181      ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
 182      pp_rec Recursive    = ptext SLIT("rec")
 183      pp_rec NonRecursive = ptext SLIT("nonrec")
 184
 185 --  *not* pprLHsBinds because we don't want braces; 'let' and
 186 -- 'where' include a list of HsBindGroups and we don't want
 187 -- several groups of bindings each with braces around.
 188 -- Sort by location before printing
 189 pprValBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
 190                    => LHsBindsLR idL idR -> [LSig id2] -> SDoc
 191 pprValBindsForUser binds sigs
 192   = pprDeeperList vcat (map snd (sort_by_loc decls))
 193   where
 194
 195     decls :: [(SrcSpan, SDoc)]
 196     decls = [(loc, ppr sig)  | L loc sig <- sigs] ++
 197              [(loc, ppr bind) | L loc bind <- bagToList binds]
 198
 199     sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls
 200
 201 pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
 202 pprLHsBinds binds
 203   | isEmptyLHsBinds binds = empty
 204   | otherwise = lbrace <+> pprDeeperList vcat (map ppr (bagToList binds)) <+> rbrace
 205
 206 ------------
 207 emptyLocalBinds :: HsLocalBindsLR a b
 208 emptyLocalBinds = EmptyLocalBinds
 209
 210 isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
 211 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
 212 isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds
 213 isEmptyLocalBinds EmptyLocalBinds = True
 214
 215 isEmptyValBinds :: HsValBindsLR a b -> Bool
 216 isEmptyValBinds (ValBindsIn ds sigs)  = isEmptyLHsBinds ds && null sigs
 217 isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
 218
 219 emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
 220 emptyValBindsIn  = ValBindsIn emptyBag []
 221 emptyValBindsOut = ValBindsOut []      []
 222
 223 emptyLHsBinds :: LHsBindsLR idL idR
 224 emptyLHsBinds = emptyBag
 225
 226 isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
 227 isEmptyLHsBinds = isEmptyBag
 228
 229 ------------
 230 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
 231 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
 232   = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
 233 plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
 234   = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
 235 \end{code}
 236
 237 What AbsBinds means
 238 ~~~~~~~~~~~~~~~~~~~
 239          AbsBinds tvs
 240                   [d1,d2]
 241                   [(tvs1, f1p, f1m),
 242                    (tvs2, f2p, f2m)]
 243                   BIND
 244 means
 245
 246         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 247                                       in fm
 248
 249         gp = ...same again, with gm instead of fm
 250
 251 This is a pretty bad translation, because it duplicates all the bindings.
 252 So the desugarer tries to do a better job:
 253
 254         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 255                                         (fm,gm) -> fm
 256         ..ditto for gp..
 257
 258         tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 259                                        in (fm,gm)
 260
 261 \begin{code}
 262 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where
 263     ppr mbind = ppr_monobind mbind
 264
 265 ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc
 266
 267 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })      = pprPatBind pat grhss
 268 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })         = pprBndr CaseBind var <+> equals <+> pprExpr (unLoc rhs)
 269 ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
 270                         fun_matches = matches,
 271                         fun_tick = tick }) =
 272                            (case tick of
 273                               Nothing -> empty
 274                               Just t  -> text "-- tick id = " <> ppr t
 275                            ) $$ pprFunBind (unLoc fun) inf matches
 276
 277 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars,
 278                          abs_exports = exports, abs_binds = val_binds })
 279      = sep [ptext SLIT("AbsBinds"),
 280             brackets (interpp'SP tyvars),
 281             brackets (interpp'SP dictvars),
 282             brackets (sep (punctuate comma (map ppr_exp exports)))]
 283        $$
 284        nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
 285                         -- Print type signatures
 286                 $$ pprLHsBinds val_binds )
 287   where
 288     ppr_exp (tvs, gbl, lcl, prags)
 289         = vcat [ppr gbl <+> ptext SLIT("<=") <+> ppr tvs <+> ppr lcl,
 290                 nest 2 (vcat (map (pprPrag gbl) prags))]
 291 \end{code}
 292
 293 %************************************************************************
 294 %*                                                                      *
 295                 Implicit parameter bindings
 296 %*                                                                      *
 297 %************************************************************************
 298
 299 \begin{code}
 300 data HsIPBinds id
 301   = IPBinds
 302         [LIPBind id]
 303         (DictBinds id)  -- Only in typechecker output; binds
 304                         -- uses of the implicit parameters
 305
 306 isEmptyIPBinds :: HsIPBinds id -> Bool
 307 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyBag ds
 308
 309 type LIPBind id = Located (IPBind id)
 310
 311 -- | Implicit parameter bindings.
 312 data IPBind id
 313   = IPBind
 314         (IPName id)
 315         (LHsExpr id)
 316
 317 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
 318   ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
 319                         $$ pprLHsBinds ds
 320
 321 instance (OutputableBndr id) => Outputable (IPBind id) where
 322   ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
 323 \end{code}
 324
 325
 326 %************************************************************************
 327 %*                                                                      *
 328 \subsection{Coercion functions}
 329 %*                                                                      *
 330 %************************************************************************
 331
 332 \begin{code}
 333 -- A HsWrapper is an expression with a hole in it
 334 -- We need coercions to have concrete form so that we can zonk them
 335
 336 data HsWrapper
 337   = WpHole                      -- The identity coercion
 338
 339   | WpCompose HsWrapper HsWrapper       -- (\a1..an. []) `WpCompose` (\x1..xn. [])
 340                                 --      = (\a1..an \x1..xn. [])
 341
 342   | WpCo Coercion               -- A cast:  [] `cast` co
 343                                 -- Guaranteedn not the identity coercion
 344
 345   | WpApp Var                   -- [] d         the 'd' is a type-class dictionary
 346   | WpTyApp Type                -- [] t         the 't' is a type or corecion
 347   | WpLam Var                   -- \d. []       the 'd' is a type-class dictionary or coercion variable
 348   | WpTyLam TyVar               -- \a. []       the 'a' is a type variable (not coercion var)
 349   | WpInline                    -- inline_me []   Wrap inline around the thing
 350
 351         -- Non-empty bindings, so that the identity coercion
 352         -- is always exactly WpHole
 353   | WpLet (LHsBinds Id)         -- let binds in []
 354                                 -- (would be nicer to be core bindings)
 355
 356 instance Outputable HsWrapper where
 357   ppr co_fn = pprHsWrapper (ptext SLIT("<>")) co_fn
 358
 359 pprHsWrapper :: SDoc -> HsWrapper -> SDoc
 360 pprHsWrapper it wrap =
 361     let
 362         help it WpHole            = it
 363         help it (WpCompose f1 f2) = help (help it f2) f1
 364         help it (WpCo co)     = sep [it, nest 2 (ptext SLIT("`cast`") <+> pprParendType co)]
 365         help it (WpApp id)    = sep [it, nest 2 (ppr id)]
 366         help it (WpTyApp ty)  = sep [it, ptext SLIT("@") <+> pprParendType ty]
 367         help it (WpLam id)    = sep [ptext SLIT("\\") <> pprBndr LambdaBind id <> dot, it]
 368         help it (WpTyLam tv)  = sep [ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot, it]
 369         help it (WpLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it]
 370         help it WpInline      = sep [ptext SLIT("_inline_me_"), it]
 371     in
 372       -- in debug mode, print the wrapper
 373       -- otherwise just print what's inside
 374       getPprStyle (\ s -> if debugStyle s then (help it wrap) else it)
 375
 376 (<.>) :: HsWrapper -> HsWrapper -> HsWrapper
 377 WpHole <.> c = c
 378 c <.> WpHole = c
 379 c1 <.> c2    = c1 `WpCompose` c2
 380
 381 mkWpTyApps :: [Type] -> HsWrapper
 382 mkWpTyApps tys = mk_co_fn WpTyApp (reverse tys)
 383
 384 mkWpApps :: [Id] -> HsWrapper
 385 mkWpApps ids = mk_co_fn WpApp (reverse ids)
 386
 387 mkWpTyLams :: [TyVar] -> HsWrapper
 388 mkWpTyLams ids = mk_co_fn WpTyLam ids
 389
 390 mkWpLams :: [Id] -> HsWrapper
 391 mkWpLams ids = mk_co_fn WpLam ids
 392
 393 mk_co_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
 394 mk_co_fn f as = foldr (WpCompose . f) WpHole as
 395
 396 idHsWrapper :: HsWrapper
 397 idHsWrapper = WpHole
 398
 399 isIdHsWrapper :: HsWrapper -> Bool
 400 isIdHsWrapper WpHole = True
 401 isIdHsWrapper _      = False
 402 \end{code}
 403
 404
 405 %************************************************************************
 406 %*                                                                      *
 407 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 408 %*                                                                      *
 409 %************************************************************************
 410
 411 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 412 ``specialise this function to these four types...'') in with type
 413 signatures.  Then all the machinery to move them into place, etc.,
 414 serves for both.
 415
 416 \begin{code}
 417 type LSig name = Located (Sig name)
 418
 419 data Sig name   -- Signatures and pragmas
 420   =     -- An ordinary type signature
 421         -- f :: Num a => a -> a
 422     TypeSig     (Located name)  -- A bog-std type signature
 423                 (LHsType name)
 424
 425         -- An ordinary fixity declaration
 426         --      infixl *** 8
 427   | FixSig      (FixitySig name)        -- Fixity declaration
 428
 429         -- An inline pragma
 430         -- {#- INLINE f #-}
 431   | InlineSig   (Located name)  -- Function name
 432                 InlineSpec
 433
 434         -- A specialisation pragma
 435         -- {-# SPECIALISE f :: Int -> Int #-}
 436   | SpecSig     (Located name)  -- Specialise a function or datatype ...
 437                 (LHsType name)  -- ... to these types
 438                 InlineSpec
 439
 440         -- A specialisation pragma for instance declarations only
 441         -- {-# SPECIALISE instance Eq [Int] #-}
 442   | SpecInstSig (LHsType name)  -- (Class tys); should be a specialisation of the
 443                                 -- current instance decl
 444
 445
 446 type LFixitySig name = Located (FixitySig name)
 447 data FixitySig name = FixitySig (Located name) Fixity
 448
 449 -- A Prag conveys pragmas from the type checker to the desugarer
 450 type LPrag = Located Prag
 451 data Prag
 452   = InlinePrag
 453         InlineSpec
 454
 455   | SpecPrag
 456         (HsExpr Id)     -- An expression, of the given specialised type, which
 457         PostTcType      -- specialises the polymorphic function
 458         InlineSpec      -- Inlining spec for the specialised function
 459
 460 isInlinePrag :: Prag -> Bool
 461 isInlinePrag (InlinePrag _) = True
 462 isInlinePrag _              = False
 463
 464 isSpecPrag :: Prag -> Bool
 465 isSpecPrag (SpecPrag {}) = True
 466 isSpecPrag _             = False
 467 \end{code}
 468
 469 \begin{code}
 470 okBindSig :: NameSet -> LSig Name -> Bool
 471 okBindSig ns sig = sigForThisGroup ns sig
 472
 473 okHsBootSig :: LSig Name -> Bool
 474 okHsBootSig (L _ (TypeSig  _ _)) = True
 475 okHsBootSig (L _ (FixSig _))     = True
 476 okHsBootSig _                    = False
 477
 478 okClsDclSig :: LSig Name -> Bool
 479 okClsDclSig (L _ (SpecInstSig _)) = False
 480 okClsDclSig _                     = True        -- All others OK
 481
 482 okInstDclSig :: NameSet -> LSig Name -> Bool
 483 okInstDclSig ns lsig@(L _ sig) = ok ns sig
 484   where
 485     ok _  (TypeSig _ _)   = False
 486     ok _  (FixSig _)      = False
 487     ok _  (SpecInstSig _) = True
 488     ok ns _               = sigForThisGroup ns lsig
 489
 490 sigForThisGroup :: NameSet -> LSig Name -> Bool
 491 sigForThisGroup ns sig
 492   = case sigName sig of
 493         Nothing -> False
 494         Just n  -> n `elemNameSet` ns
 495
 496 sigName :: LSig name -> Maybe name
 497 sigName (L _ sig) = sigNameNoLoc sig
 498
 499 sigNameNoLoc :: Sig name -> Maybe name
 500 sigNameNoLoc (TypeSig   n _)          = Just (unLoc n)
 501 sigNameNoLoc (SpecSig   n _ _)        = Just (unLoc n)
 502 sigNameNoLoc (InlineSig n _)          = Just (unLoc n)
 503 sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n)
 504 sigNameNoLoc _                        = Nothing
 505
 506 isFixityLSig :: LSig name -> Bool
 507 isFixityLSig (L _ (FixSig {})) = True
 508 isFixityLSig _                 = False
 509
 510 isVanillaLSig :: LSig name -> Bool
 511 isVanillaLSig (L _(TypeSig {})) = True
 512 isVanillaLSig _                 = False
 513
 514 isSpecLSig :: LSig name -> Bool
 515 isSpecLSig (L _(SpecSig {})) = True
 516 isSpecLSig _                 = False
 517
 518 isSpecInstLSig :: LSig name -> Bool
 519 isSpecInstLSig (L _ (SpecInstSig {})) = True
 520 isSpecInstLSig _                      = False
 521
 522 isPragLSig :: LSig name -> Bool
 523         -- Identifies pragmas
 524 isPragLSig (L _ (SpecSig {}))   = True
 525 isPragLSig (L _ (InlineSig {})) = True
 526 isPragLSig _                    = False
 527
 528 isInlineLSig :: LSig name -> Bool
 529         -- Identifies inline pragmas
 530 isInlineLSig (L _ (InlineSig {})) = True
 531 isInlineLSig _                    = False
 532
 533 hsSigDoc :: Sig name -> SDoc
 534 hsSigDoc (TypeSig {})           = ptext SLIT("type signature")
 535 hsSigDoc (SpecSig {})           = ptext SLIT("SPECIALISE pragma")
 536 hsSigDoc (InlineSig {})         = ptext SLIT("INLINE pragma")
 537 hsSigDoc (SpecInstSig {})       = ptext SLIT("SPECIALISE instance pragma")
 538 hsSigDoc (FixSig {})            = ptext SLIT("fixity declaration")
 539 \end{code}
 540
 541 Signature equality is used when checking for duplicate signatures
 542
 543 \begin{code}
 544 eqHsSig :: LSig Name -> LSig Name -> Bool
 545 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
 546 eqHsSig (L _ (TypeSig n1 _))            (L _ (TypeSig n2 _))            = unLoc n1 == unLoc n2
 547 eqHsSig (L _ (InlineSig n1 _))          (L _ (InlineSig n2 _))          = unLoc n1 == unLoc n2
 548         -- For specialisations, we don't have equality over
 549         -- HsType, so it's not convenient to spot duplicate
 550         -- specialisations here.  Check for this later, when we're in Type land
 551 eqHsSig _other1 _other2 = False
 552 \end{code}
 553
 554 \begin{code}
 555 instance (OutputableBndr name) => Outputable (Sig name) where
 556     ppr sig = ppr_sig sig
 557
 558 ppr_sig :: OutputableBndr name => Sig name -> SDoc
 559 ppr_sig (TypeSig var ty)          = pprVarSig (unLoc var) ty
 560 ppr_sig (FixSig fix_sig)          = ppr fix_sig
 561 ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec var ty inl)
 562 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var)
 563 ppr_sig (SpecInstSig ty)          = pragBrackets (ptext SLIT("SPECIALIZE instance") <+> ppr ty)
 564
 565 instance Outputable name => Outputable (FixitySig name) where
 566   ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
 567
 568 pragBrackets :: SDoc -> SDoc
 569 pragBrackets doc = ptext SLIT("{-#") <+> doc <+> ptext SLIT("#-}")
 570
 571 pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc
 572 pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)]
 573
 574 pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc
 575 pprSpec var ty inl = sep [ptext SLIT("SPECIALIZE") <+> ppr inl <+> pprVarSig var ty]
 576
 577 pprPrag :: Outputable id => id -> LPrag -> SDoc
 578 pprPrag var (L _ (InlinePrag inl))        = ppr inl <+> ppr var
 579 pprPrag var (L _ (SpecPrag _expr ty inl)) = pprSpec var ty inl
 580 \end{code}
 581