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 ( 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     }
 136
 137   | AbsBinds {                                  -- Binds abstraction; TRANSLATION
 138         abs_tvs     :: [TyVar],
 139         abs_dicts   :: [DictId],                -- Includes equality constraints
 140
 141        -- AbsBinds only gets used when idL = idR after renaming,
 142        -- but these need to be idL's for the collect... code in HsUtil to have
 143        -- the right type
 144         abs_exports :: [([TyVar], idL, idL, [LPrag])],  -- (tvs, poly_id, mono_id, prags)
 145         abs_binds   :: LHsBinds idL             -- The dictionary bindings and typechecked user bindings
 146                                                 -- mixed up together; you can tell the dict bindings because
 147                                                 -- they are all VarBinds
 148     }
 149         -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
 150         --
 151         -- Creates bindings for (polymorphic, overloaded) poly_f
 152         -- in terms of monomorphic, non-overloaded mono_f
 153         --
 154         -- Invariants:
 155         --      1. 'binds' binds mono_f
 156         --      2. ftvs is a subset of tvs
 157         --      3. ftvs includes all tyvars free in ds
 158         --
 159         -- See section 9 of static semantics paper for more details.
 160         -- (You can get a PhD for explaining the True Meaning
 161         --  of this last construct.)
 162
 163 placeHolderNames :: NameSet
 164 -- Used for the NameSet in FunBind and PatBind prior to the renamer
 165 placeHolderNames = panic "placeHolderNames"
 166
 167 ------------
 168 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where
 169   ppr (HsValBinds bs) = ppr bs
 170   ppr (HsIPBinds bs)  = ppr bs
 171   ppr EmptyLocalBinds = empty
 172
 173 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where
 174   ppr (ValBindsIn binds sigs)
 175    = pprValBindsForUser binds sigs
 176
 177   ppr (ValBindsOut sccs sigs)
 178     = getPprStyle $ \ sty ->
 179       if debugStyle sty then    -- Print with sccs showing
 180         vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
 181      else
 182         pprValBindsForUser (unionManyBags (map snd sccs)) sigs
 183    where
 184      ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
 185      pp_rec Recursive    = ptext (sLit "rec")
 186      pp_rec NonRecursive = ptext (sLit "nonrec")
 187
 188 --  *not* pprLHsBinds because we don't want braces; 'let' and
 189 -- 'where' include a list of HsBindGroups and we don't want
 190 -- several groups of bindings each with braces around.
 191 -- Sort by location before printing
 192 pprValBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
 193                    => LHsBindsLR idL idR -> [LSig id2] -> SDoc
 194 pprValBindsForUser binds sigs
 195   = pprDeeperList vcat (map snd (sort_by_loc decls))
 196   where
 197
 198     decls :: [(SrcSpan, SDoc)]
 199     decls = [(loc, ppr sig)  | L loc sig <- sigs] ++
 200              [(loc, ppr bind) | L loc bind <- bagToList binds]
 201
 202     sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls
 203
 204 pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
 205 pprLHsBinds binds
 206   | isEmptyLHsBinds binds = empty
 207   | otherwise = lbrace <+> pprDeeperList vcat (map ppr (bagToList binds)) <+> rbrace
 208
 209 ------------
 210 emptyLocalBinds :: HsLocalBindsLR a b
 211 emptyLocalBinds = EmptyLocalBinds
 212
 213 isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
 214 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
 215 isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds
 216 isEmptyLocalBinds EmptyLocalBinds = True
 217
 218 isEmptyValBinds :: HsValBindsLR a b -> Bool
 219 isEmptyValBinds (ValBindsIn ds sigs)  = isEmptyLHsBinds ds && null sigs
 220 isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
 221
 222 emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
 223 emptyValBindsIn  = ValBindsIn emptyBag []
 224 emptyValBindsOut = ValBindsOut []      []
 225
 226 emptyLHsBinds :: LHsBindsLR idL idR
 227 emptyLHsBinds = emptyBag
 228
 229 isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
 230 isEmptyLHsBinds = isEmptyBag
 231
 232 ------------
 233 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
 234 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
 235   = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
 236 plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
 237   = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
 238 \end{code}
 239
 240 What AbsBinds means
 241 ~~~~~~~~~~~~~~~~~~~
 242          AbsBinds tvs
 243                   [d1,d2]
 244                   [(tvs1, f1p, f1m),
 245                    (tvs2, f2p, f2m)]
 246                   BIND
 247 means
 248
 249         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 250                                       in fm
 251
 252         gp = ...same again, with gm instead of fm
 253
 254 This is a pretty bad translation, because it duplicates all the bindings.
 255 So the desugarer tries to do a better job:
 256
 257         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 258                                         (fm,gm) -> fm
 259         ..ditto for gp..
 260
 261         tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 262                                        in (fm,gm)
 263
 264 \begin{code}
 265 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where
 266     ppr mbind = ppr_monobind mbind
 267
 268 ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc
 269
 270 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })      = pprPatBind pat grhss
 271 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })         = pprBndr CaseBind var <+> equals <+> pprExpr (unLoc rhs)
 272 ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
 273                         fun_matches = matches,
 274                         fun_tick = tick })
 275   = pprTicks empty (case tick of
 276                         Nothing -> empty
 277                         Just t  -> text "-- tick id = " <> ppr t)
 278     $$  pprFunBind (unLoc fun) inf matches
 279
 280 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars,
 281                          abs_exports = exports, abs_binds = val_binds })
 282   = sep [ptext (sLit "AbsBinds"),
 283          brackets (interpp'SP tyvars),
 284          brackets (interpp'SP dictvars),
 285          brackets (sep (punctuate comma (map ppr_exp exports)))]
 286     $$
 287     nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
 288                         -- Print type signatures
 289              $$ pprLHsBinds val_binds )
 290   where
 291     ppr_exp (tvs, gbl, lcl, prags)
 292         = vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl,
 293                 nest 2 (vcat (map (pprPrag gbl) prags))]
 294 \end{code}
 295
 296
 297 \begin{code}
 298 pprTicks :: SDoc -> SDoc -> SDoc
 299 -- Print stuff about ticks only when -dppr-debug is on, to avoid
 300 -- them appearing in error messages (from the desugarer); see Trac # 3263
 301 pprTicks pp_no_debug pp_when_debug
 302   = getPprStyle (\ sty -> if debugStyle sty then pp_when_debug
 303                                             else pp_no_debug)
 304 \end{code}
 305
 306 %************************************************************************
 307 %*                                                                      *
 308                 Implicit parameter bindings
 309 %*                                                                      *
 310 %************************************************************************
 311
 312 \begin{code}
 313 data HsIPBinds id
 314   = IPBinds
 315         [LIPBind id]
 316         (DictBinds id)  -- Only in typechecker output; binds
 317                         -- uses of the implicit parameters
 318
 319 isEmptyIPBinds :: HsIPBinds id -> Bool
 320 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyBag ds
 321
 322 type LIPBind id = Located (IPBind id)
 323
 324 -- | Implicit parameter bindings.
 325 data IPBind id
 326   = IPBind
 327         (IPName id)
 328         (LHsExpr id)
 329
 330 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
 331   ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
 332                         $$ pprLHsBinds ds
 333
 334 instance (OutputableBndr id) => Outputable (IPBind id) where
 335   ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
 336 \end{code}
 337
 338
 339 %************************************************************************
 340 %*                                                                      *
 341 \subsection{Coercion functions}
 342 %*                                                                      *
 343 %************************************************************************
 344
 345 \begin{code}
 346 -- A HsWrapper is an expression with a hole in it
 347 -- We need coercions to have concrete form so that we can zonk them
 348
 349 data HsWrapper
 350   = WpHole                      -- The identity coercion
 351
 352   | WpCompose HsWrapper HsWrapper       -- (\a1..an. []) `WpCompose` (\x1..xn. [])
 353                                 --      = (\a1..an \x1..xn. [])
 354
 355   | WpCast Coercion             -- A cast:  [] `cast` co
 356                                 -- Guaranteed not the identity coercion
 357
 358   | WpApp Var                   -- [] d         the 'd' is a type-class dictionary or coercion variable
 359
 360   | WpTyApp Type                -- [] t         the 't' is a type or corecion
 361                                 --      ToDo: it'd be tidier if 't' was always a type (not coercion),
 362                                 --            but that is inconvenient in Inst.instCallDicts
 363
 364   | WpLam Var                   -- \d. []       the 'd' is a type-class dictionary or coercion variable
 365   | WpTyLam TyVar               -- \a. []       the 'a' is a type variable (not coercion var)
 366   | WpInline                    -- inline_me []   Wrap inline around the thing
 367
 368         -- Non-empty bindings, so that the identity coercion
 369         -- is always exactly WpHole
 370   | WpLet (LHsBinds Id)         -- let binds in []
 371                                 -- (would be nicer to be core bindings)
 372
 373 instance Outputable HsWrapper where
 374   ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn
 375
 376 pprHsWrapper :: SDoc -> HsWrapper -> SDoc
 377 pprHsWrapper it wrap =
 378     let
 379         help it WpHole            = it
 380         help it (WpCompose f1 f2) = help (help it f2) f1
 381         help it (WpCast co)   = sep [it, nest 2 (ptext (sLit "`cast`") <+> pprParendType co)]
 382         help it (WpApp id)    = sep [it, nest 2 (ppr id)]
 383         help it (WpTyApp ty)  = sep [it, ptext (sLit "@") <+> pprParendType ty]
 384         help it (WpLam id)    = sep [ptext (sLit "\\") <> pprBndr LambdaBind id <> dot, it]
 385         help it (WpTyLam tv)  = sep [ptext (sLit "/\\") <> pprBndr LambdaBind tv <> dot, it]
 386         help it (WpLet binds) = sep [ptext (sLit "let") <+> braces (ppr binds), it]
 387         help it WpInline      = sep [ptext (sLit "_inline_me_"), 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                 InlineSpec
 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                 InlineSpec
 462
 463         -- A specialisation pragma for instance declarations only
 464         -- {-# SPECIALISE instance Eq [Int] #-}
 465   | SpecInstSig (LHsType name)  -- (Class tys); should be a specialisation of the
 466                                 -- current instance decl
 467
 468
 469 type LFixitySig name = Located (FixitySig name)
 470 data FixitySig name = FixitySig (Located name) Fixity
 471
 472 -- A Prag conveys pragmas from the type checker to the desugarer
 473 type LPrag = Located Prag
 474 data Prag
 475   = InlinePrag
 476         InlineSpec
 477
 478   | SpecPrag
 479         (HsExpr Id)     -- An expression, of the given specialised type, which
 480         PostTcType      -- specialises the polymorphic function
 481         InlineSpec      -- Inlining spec for the specialised function
 482
 483 isInlinePrag :: Prag -> Bool
 484 isInlinePrag (InlinePrag _) = True
 485 isInlinePrag _              = False
 486
 487 isSpecPrag :: Prag -> Bool
 488 isSpecPrag (SpecPrag {}) = True
 489 isSpecPrag _             = False
 490 \end{code}
 491
 492 \begin{code}
 493 okBindSig :: Sig a -> Bool
 494 okBindSig _ = True
 495
 496 okHsBootSig :: Sig a -> Bool
 497 okHsBootSig (TypeSig  _ _) = True
 498 okHsBootSig (FixSig _)     = True
 499 okHsBootSig _              = False
 500
 501 okClsDclSig :: Sig a -> Bool
 502 okClsDclSig (SpecInstSig _) = False
 503 okClsDclSig _               = True        -- All others OK
 504
 505 okInstDclSig :: Sig a -> Bool
 506 okInstDclSig (TypeSig _ _)   = False
 507 okInstDclSig (FixSig _)      = False
 508 okInstDclSig _               = True
 509
 510 sigForThisGroup :: NameSet -> LSig Name -> Bool
 511 sigForThisGroup ns sig
 512   = case sigName sig of
 513         Nothing -> False
 514         Just n  -> n `elemNameSet` ns
 515
 516 sigName :: LSig name -> Maybe name
 517 sigName (L _ sig) = sigNameNoLoc sig
 518
 519 sigNameNoLoc :: Sig name -> Maybe name
 520 sigNameNoLoc (TypeSig   n _)          = Just (unLoc n)
 521 sigNameNoLoc (SpecSig   n _ _)        = Just (unLoc n)
 522 sigNameNoLoc (InlineSig n _)          = Just (unLoc n)
 523 sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n)
 524 sigNameNoLoc _                        = Nothing
 525
 526 isFixityLSig :: LSig name -> Bool
 527 isFixityLSig (L _ (FixSig {})) = True
 528 isFixityLSig _                 = False
 529
 530 isVanillaLSig :: LSig name -> Bool       -- User type signatures
 531 -- A badly-named function, but it's part of the GHCi (used
 532 -- by Haddock) so I don't want to change it gratuitously.
 533 isVanillaLSig (L _(TypeSig {})) = True
 534 isVanillaLSig _                 = False
 535
 536 isTypeLSig :: LSig name -> Bool  -- Type signatures
 537 isTypeLSig (L _(TypeSig {})) = True
 538 isTypeLSig (L _(IdSig {}))   = True
 539 isTypeLSig _                 = False
 540
 541 isSpecLSig :: LSig name -> Bool
 542 isSpecLSig (L _(SpecSig {})) = True
 543 isSpecLSig _                 = False
 544
 545 isSpecInstLSig :: LSig name -> Bool
 546 isSpecInstLSig (L _ (SpecInstSig {})) = True
 547 isSpecInstLSig _                      = False
 548
 549 isPragLSig :: LSig name -> Bool
 550         -- Identifies pragmas
 551 isPragLSig (L _ (SpecSig {}))   = True
 552 isPragLSig (L _ (InlineSig {})) = True
 553 isPragLSig _                    = False
 554
 555 isInlineLSig :: LSig name -> Bool
 556         -- Identifies inline pragmas
 557 isInlineLSig (L _ (InlineSig {})) = True
 558 isInlineLSig _                    = False
 559
 560 hsSigDoc :: Sig name -> SDoc
 561 hsSigDoc (TypeSig {})           = ptext (sLit "type signature")
 562 hsSigDoc (IdSig {})             = ptext (sLit "id signature")
 563 hsSigDoc (SpecSig {})           = ptext (sLit "SPECIALISE pragma")
 564 hsSigDoc (InlineSig {})         = ptext (sLit "INLINE pragma")
 565 hsSigDoc (SpecInstSig {})       = ptext (sLit "SPECIALISE instance pragma")
 566 hsSigDoc (FixSig {})            = ptext (sLit "fixity declaration")
 567 \end{code}
 568
 569 Signature equality is used when checking for duplicate signatures
 570
 571 \begin{code}
 572 eqHsSig :: Eq a => LSig a -> LSig a -> Bool
 573 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
 574 eqHsSig (L _ (IdSig n1))                (L _ (IdSig n2))                = n1 == n2
 575 eqHsSig (L _ (TypeSig n1 _))            (L _ (TypeSig n2 _))            = unLoc n1 == unLoc n2
 576 eqHsSig (L _ (InlineSig n1 _))          (L _ (InlineSig n2 _))          = unLoc n1 == unLoc n2
 577         -- For specialisations, we don't have equality over
 578         -- HsType, so it's not convenient to spot duplicate
 579         -- specialisations here.  Check for this later, when we're in Type land
 580 eqHsSig _other1 _other2 = False
 581 \end{code}
 582
 583 \begin{code}
 584 instance (OutputableBndr name) => Outputable (Sig name) where
 585     ppr sig = ppr_sig sig
 586
 587 ppr_sig :: OutputableBndr name => Sig name -> SDoc
 588 ppr_sig (TypeSig var ty)          = pprVarSig (unLoc var) ty
 589 ppr_sig (IdSig id)                = pprVarSig id (varType id)
 590 ppr_sig (FixSig fix_sig)          = ppr fix_sig
 591 ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec var ty inl)
 592 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var)
 593 ppr_sig (SpecInstSig ty)          = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
 594
 595 instance Outputable name => Outputable (FixitySig name) where
 596   ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
 597
 598 pragBrackets :: SDoc -> SDoc
 599 pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}")
 600
 601 pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc
 602 pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)]
 603
 604 pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc
 605 pprSpec var ty inl = sep [ptext (sLit "SPECIALIZE") <+> ppr inl <+> pprVarSig var ty]
 606
 607 pprPrag :: Outputable id => id -> LPrag -> SDoc
 608 pprPrag var (L _ (InlinePrag inl))        = ppr inl <+> ppr var
 609 pprPrag var (L _ (SpecPrag _expr ty inl)) = pprSpec var ty inl
 610 \end{code}
 611