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