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