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 VarEnv
  36 import Var
  37 import Bag
  38 import Unique
  39 import FastString
  40
  41 import Data.IORef( IORef )
  42 import Data.Data hiding ( Fixity )
  43 \end{code}
  44
  45 %************************************************************************
  46 %*                                                                      *
  47 \subsection{Bindings: @BindGroup@}
  48 %*                                                                      *
  49 %************************************************************************
  50
  51 Global bindings (where clauses)
  52
  53 \begin{code}
  54 -- During renaming, we need bindings where the left-hand sides
  55 -- have been renamed but the the right-hand sides have not.
  56 -- the ...LR datatypes are parametrized by two id types,
  57 -- one for the left and one for the right.
  58 -- Other than during renaming, these will be the same.
  59
  60 type HsLocalBinds id = HsLocalBindsLR id id
  61
  62 data HsLocalBindsLR idL idR     -- Bindings in a 'let' expression
  63                                -- or a 'where' clause
  64   = HsValBinds (HsValBindsLR idL idR)
  65   | HsIPBinds  (HsIPBinds idR)
  66   | EmptyLocalBinds
  67   deriving (Data, Typeable)
  68
  69 type HsValBinds id = HsValBindsLR id id
  70
  71 data HsValBindsLR idL idR  -- Value bindings (not implicit parameters)
  72   = ValBindsIn             -- Before renaming RHS; idR is always RdrName
  73         (LHsBindsLR idL idR) [LSig idR] -- Not dependency analysed
  74                                         -- Recursive by default
  75
  76   | ValBindsOut            -- After renaming RHS; idR can be Name or Id
  77         [(RecFlag, LHsBinds idL)]       -- Dependency analysed, later bindings
  78                                         -- in the list may depend on earlier
  79                                         -- ones.
  80         [LSig Name]
  81   deriving (Data, Typeable)
  82
  83 type LHsBind  id = LHsBindLR  id id
  84 type LHsBinds id = LHsBindsLR id id
  85 type HsBind   id = HsBindLR   id id
  86
  87 type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
  88 type LHsBindLR  idL idR = Located (HsBindLR idL idR)
  89
  90 data HsBindLR idL idR
  91   = -- | FunBind is used for both functions   @f x = e@
  92     -- and variables                          @f = \x -> e@
  93     --
  94     -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'.
  95     --
  96     -- Reason 2: Instance decls can only have FunBinds, which is convenient.
  97     --           If you change this, you'll need to change e.g. rnMethodBinds
  98     --
  99     -- But note that the form                 @f :: a->a = ...@
 100     -- parses as a pattern binding, just like
 101     --                                        @(f :: a -> a) = ... @
 102     FunBind {
 103
 104         fun_id :: Located idL,
 105
 106         fun_infix :: Bool,      -- ^ True => infix declaration
 107
 108         fun_matches :: MatchGroup idR,  -- ^ The payload
 109
 110         fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of
 111                                 -- the Id.  Example:
 112                                 -- @
 113                                 --      f :: Int -> forall a. a -> a
 114                                 --      f x y = y
 115                                 -- @
 116                                 -- Then the MatchGroup will have type (Int -> a' -> a')
 117                                 -- (with a free type variable a').  The coercion will take
 118                                 -- a CoreExpr of this type and convert it to a CoreExpr of
 119                                 -- type         Int -> forall a'. a' -> a'
 120                                 -- Notice that the coercion captures the free a'.
 121
 122         bind_fvs :: NameSet,    -- ^ After the renamer, this contains a superset of the
 123                                 -- Names of the other binders in this binding group that
 124                                 -- are free in the RHS of the defn
 125                                 -- Before renaming, and after typechecking,
 126                                 -- the field is unused; it's just an error thunk
 127
 128         fun_tick :: Maybe (Int,[Id])   -- ^ This is the (optional) module-local tick number.
 129     }
 130
 131   | PatBind {   -- The pattern is never a simple variable;
 132                 -- That case is done by FunBind
 133         pat_lhs    :: LPat idL,
 134         pat_rhs    :: GRHSs idR,
 135         pat_rhs_ty :: PostTcType,       -- Type of the GRHSs
 136         bind_fvs   :: NameSet           -- Same as for FunBind
 137     }
 138
 139   | VarBind {   -- Dictionary binding and suchlike
 140         var_id     :: idL,           -- All VarBinds are introduced by the type checker
 141         var_rhs    :: LHsExpr idR,   -- Located only for consistency
 142         var_inline :: Bool           -- True <=> inline this binding regardless
 143                                      -- (used for implication constraints only)
 144     }
 145
 146   | AbsBinds {                          -- Binds abstraction; TRANSLATION
 147         abs_tvs     :: [TyVar],
 148         abs_ev_vars :: [EvVar],  -- Includes equality constraints
 149
 150        -- AbsBinds only gets used when idL = idR after renaming,
 151        -- but these need to be idL's for the collect... code in HsUtil to have
 152        -- the right type
 153         abs_exports :: [([TyVar], idL, idL, TcSpecPrags)],      -- (tvs, poly_id, mono_id, prags)
 154
 155         abs_ev_binds :: TcEvBinds,     -- Evidence bindings
 156         abs_binds    :: LHsBinds idL   -- Typechecked user bindings
 157     }
 158
 159   deriving (Data, Typeable)
 160         -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
 161         --
 162         -- Creates bindings for (polymorphic, overloaded) poly_f
 163         -- in terms of monomorphic, non-overloaded mono_f
 164         --
 165         -- Invariants:
 166         --      1. 'binds' binds mono_f
 167         --      2. ftvs is a subset of tvs
 168         --      3. ftvs includes all tyvars free in ds
 169         --
 170         -- See section 9 of static semantics paper for more details.
 171         -- (You can get a PhD for explaining the True Meaning
 172         --  of this last construct.)
 173
 174 placeHolderNames :: NameSet
 175 -- Used for the NameSet in FunBind and PatBind prior to the renamer
 176 placeHolderNames = panic "placeHolderNames"
 177
 178 ------------
 179 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where
 180   ppr (HsValBinds bs) = ppr bs
 181   ppr (HsIPBinds bs)  = ppr bs
 182   ppr EmptyLocalBinds = empty
 183
 184 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where
 185   ppr (ValBindsIn binds sigs)
 186    = pprValBindsForUser binds sigs
 187
 188   ppr (ValBindsOut sccs sigs)
 189     = getPprStyle $ \ sty ->
 190       if debugStyle sty then    -- Print with sccs showing
 191         vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
 192      else
 193         pprValBindsForUser (unionManyBags (map snd sccs)) sigs
 194    where
 195      ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
 196      pp_rec Recursive    = ptext (sLit "rec")
 197      pp_rec NonRecursive = ptext (sLit "nonrec")
 198
 199 --  *not* pprLHsBinds because we don't want braces; 'let' and
 200 -- 'where' include a list of HsBindGroups and we don't want
 201 -- several groups of bindings each with braces around.
 202 -- Sort by location before printing
 203 pprValBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
 204                    => LHsBindsLR idL idR -> [LSig id2] -> SDoc
 205 pprValBindsForUser binds sigs
 206   = pprDeeperList vcat (map snd (sort_by_loc decls))
 207   where
 208
 209     decls :: [(SrcSpan, SDoc)]
 210     decls = [(loc, ppr sig)  | L loc sig <- sigs] ++
 211              [(loc, ppr bind) | L loc bind <- bagToList binds]
 212
 213     sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls
 214
 215 pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
 216 pprLHsBinds binds
 217   | isEmptyLHsBinds binds = empty
 218   | otherwise = lbrace <+> pprDeeperList vcat (map ppr (bagToList binds)) <+> rbrace
 219
 220 ------------
 221 emptyLocalBinds :: HsLocalBindsLR a b
 222 emptyLocalBinds = EmptyLocalBinds
 223
 224 isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
 225 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
 226 isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds
 227 isEmptyLocalBinds EmptyLocalBinds = True
 228
 229 isEmptyValBinds :: HsValBindsLR a b -> Bool
 230 isEmptyValBinds (ValBindsIn ds sigs)  = isEmptyLHsBinds ds && null sigs
 231 isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
 232
 233 emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
 234 emptyValBindsIn  = ValBindsIn emptyBag []
 235 emptyValBindsOut = ValBindsOut []      []
 236
 237 emptyLHsBinds :: LHsBindsLR idL idR
 238 emptyLHsBinds = emptyBag
 239
 240 isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
 241 isEmptyLHsBinds = isEmptyBag
 242
 243 ------------
 244 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
 245 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
 246   = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
 247 plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
 248   = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
 249
 250 getTypeSigNames :: HsValBinds a -> NameSet
 251 -- Get the names that have a user type sig
 252 getTypeSigNames (ValBindsIn {})
 253   = panic "getTypeSigNames"
 254 getTypeSigNames (ValBindsOut _ sigs)
 255   = mkNameSet [unLoc n | L _ (TypeSig n _) <- sigs]
 256 \end{code}
 257
 258 What AbsBinds means
 259 ~~~~~~~~~~~~~~~~~~~
 260          AbsBinds tvs
 261                   [d1,d2]
 262                   [(tvs1, f1p, f1m),
 263                    (tvs2, f2p, f2m)]
 264                   BIND
 265 means
 266
 267         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 268                                       in fm
 269
 270         gp = ...same again, with gm instead of fm
 271
 272 This is a pretty bad translation, because it duplicates all the bindings.
 273 So the desugarer tries to do a better job:
 274
 275         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 276                                         (fm,gm) -> fm
 277         ..ditto for gp..
 278
 279         tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 280                                        in (fm,gm)
 281
 282 \begin{code}
 283 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where
 284     ppr mbind = ppr_monobind mbind
 285
 286 ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc
 287
 288 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
 289   = pprPatBind pat grhss
 290 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
 291   = sep [pprBndr CaseBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
 292 ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
 293                         fun_co_fn = wrap,
 294                         fun_matches = matches,
 295                         fun_tick = tick })
 296   = pprTicks empty (case tick of
 297                         Nothing -> empty
 298                         Just t  -> text "-- tick id = " <> ppr t)
 299     $$  ifPprDebug (pprBndr LetBind (unLoc fun))
 300     $$  pprFunBind (unLoc fun) inf matches
 301     $$  ifPprDebug (ppr wrap)
 302
 303 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
 304                        , abs_exports = exports, abs_binds = val_binds
 305                        , abs_ev_binds = ev_binds })
 306   = sep [ptext (sLit "AbsBinds"),
 307          brackets (interpp'SP tyvars),
 308          brackets (interpp'SP dictvars),
 309          brackets (sep (punctuate comma (map ppr_exp exports)))]
 310     $$
 311     nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
 312                         -- Print type signatures
 313              $$ pprLHsBinds val_binds )
 314     $$
 315     ifPprDebug (ppr ev_binds)
 316   where
 317     ppr_exp (tvs, gbl, lcl, prags)
 318         = vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl,
 319                 nest 2 (pprTcSpecPrags prags)]
 320 \end{code}
 321
 322
 323 \begin{code}
 324 pprTicks :: SDoc -> SDoc -> SDoc
 325 -- Print stuff about ticks only when -dppr-debug is on, to avoid
 326 -- them appearing in error messages (from the desugarer); see Trac # 3263
 327 pprTicks pp_no_debug pp_when_debug
 328   = getPprStyle (\ sty -> if debugStyle sty then pp_when_debug
 329                                             else pp_no_debug)
 330 \end{code}
 331
 332 %************************************************************************
 333 %*                                                                      *
 334                 Implicit parameter bindings
 335 %*                                                                      *
 336 %************************************************************************
 337
 338 \begin{code}
 339 data HsIPBinds id
 340   = IPBinds
 341         [LIPBind id]
 342         TcEvBinds       -- Only in typechecker output; binds
 343                         -- uses of the implicit parameters
 344   deriving (Data, Typeable)
 345
 346 isEmptyIPBinds :: HsIPBinds id -> Bool
 347 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
 348
 349 type LIPBind id = Located (IPBind id)
 350
 351 -- | Implicit parameter bindings.
 352 data IPBind id
 353   = IPBind
 354         (IPName id)
 355         (LHsExpr id)
 356   deriving (Data, Typeable)
 357
 358 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
 359   ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
 360                         $$ ifPprDebug (ppr ds)
 361
 362 instance (OutputableBndr id) => Outputable (IPBind id) where
 363   ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
 364 \end{code}
 365
 366
 367 %************************************************************************
 368 %*                                                                      *
 369 \subsection{Coercion functions}
 370 %*                                                                      *
 371 %************************************************************************
 372
 373 \begin{code}
 374 -- A HsWrapper is an expression with a hole in it
 375 -- We need coercions to have concrete form so that we can zonk them
 376
 377 data HsWrapper
 378   = WpHole                      -- The identity coercion
 379
 380   | WpCompose HsWrapper HsWrapper
 381        -- (wrap1 `WpCompse` wrap2)[e] = wrap1[ wrap2[ e ]]
 382        --
 383        -- Hence  (\a. []) `WpCompose` (\b. []) = (\a b. [])
 384        -- But    ([] a)   `WpCompose` ([] b)   = ([] b a)
 385
 386   | WpCast Coercion             -- A cast:  [] `cast` co
 387                                 -- Guaranteed not the identity coercion
 388
 389         -- Evidence abstraction and application
 390         -- (both dictionaries and coercions)
 391   | WpEvLam EvVar               -- \d. []       the 'd' is an evidence variable
 392   | WpEvApp EvTerm              -- [] d         the 'd' is evidence for a constraint
 393
 394         -- Type abstraction and application
 395   | WpTyLam TyVar               -- \a. []       the 'a' is a type variable (not coercion var)
 396   | WpTyApp Type                -- [] t         the 't' is a type (not coercion)
 397
 398
 399   | WpLet TcEvBinds             -- Non-empty (or possibly non-empty) evidence bindings,
 400                                 -- so that the identity coercion is always exactly WpHole
 401   deriving (Data, Typeable)
 402
 403
 404 data TcEvBinds
 405   = TcEvBinds           -- Mutable evidence bindings
 406        EvBindsVar       -- Mutable because they are updated "later"
 407                         --    when an implication constraint is solved
 408
 409   | EvBinds             -- Immutable after zonking
 410        (Bag EvBind)
 411
 412   deriving( Typeable )
 413
 414 data EvBindsVar = EvBindsVar (IORef EvBindMap) Unique
 415      -- The Unique is only for debug printing
 416
 417 -----------------
 418 type EvBindMap = VarEnv EvBind
 419
 420 emptyEvBindMap :: EvBindMap
 421 emptyEvBindMap = emptyVarEnv
 422
 423 extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap
 424 extendEvBinds bs v t = extendVarEnv bs v (EvBind v t)
 425
 426 lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind
 427 lookupEvBind = lookupVarEnv
 428
 429 evBindMapBinds :: EvBindMap -> Bag EvBind
 430 evBindMapBinds = foldVarEnv consBag emptyBag
 431
 432 -----------------
 433 instance Data TcEvBinds where
 434   -- Placeholder; we can't travers into TcEvBinds
 435   toConstr _   = abstractConstr "TcEvBinds"
 436   gunfold _ _  = error "gunfold"
 437   dataTypeOf _ = mkNoRepType "TcEvBinds"
 438
 439 -- All evidence is bound by EvBinds; no side effects
 440 data EvBind = EvBind EvVar EvTerm
 441
 442 data EvTerm
 443   = EvId EvId                  -- Term-level variable-to-variable bindings
 444                                -- (no coercion variables! they come via EvCoercion)
 445
 446   | EvCoercion Coercion        -- Coercion bindings
 447
 448   | EvCast EvVar Coercion      -- d |> co
 449
 450   | EvDFunApp DFunId           -- Dictionary instance application
 451        [Type] [EvVar]
 452
 453   | EvSuperClass DictId Int    -- n'th superclass. Used for both equalities and
 454                                -- dictionaries, even though the former have no
 455                                -- selector Id.  We count up from _0_
 456
 457   deriving( Data, Typeable)
 458
 459 evVarTerm :: EvVar -> EvTerm
 460 evVarTerm v | isCoVar v = EvCoercion (mkCoVarCo v)
 461             | otherwise = EvId v
 462 \end{code}
 463
 464 Note [EvBinds/EvTerm]
 465 ~~~~~~~~~~~~~~~~~~~~~
 466 How evidence is created and updated. Bindings for dictionaries,
 467 and coercions and implicit parameters are carried around in TcEvBinds
 468 which during constraint generation and simplification is always of the
 469 form (TcEvBinds ref). After constraint simplification is finished it
 470 will be transformed to t an (EvBinds ev_bag).
 471
 472 Evidence for coercions *SHOULD* be filled in using the TcEvBinds
 473 However, all EvVars that correspond to *wanted* coercion terms in
 474 an EvBind must be mutable variables so that they can be readily
 475 inlined (by zonking) after constraint simplification is finished.
 476
 477 Conclusion: a new wanted coercion variable should be made mutable.
 478 [Notice though that evidence variables that bind coercion terms
 479  from super classes will be "given" and hence rigid]
 480
 481
 482 \begin{code}
 483 emptyTcEvBinds :: TcEvBinds
 484 emptyTcEvBinds = EvBinds emptyBag
 485
 486 isEmptyTcEvBinds :: TcEvBinds -> Bool
 487 isEmptyTcEvBinds (EvBinds b)    = isEmptyBag b
 488 isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds"
 489
 490 (<.>) :: HsWrapper -> HsWrapper -> HsWrapper
 491 WpHole <.> c = c
 492 c <.> WpHole = c
 493 c1 <.> c2    = c1 `WpCompose` c2
 494
 495 mkWpTyApps :: [Type] -> HsWrapper
 496 mkWpTyApps tys = mk_co_app_fn WpTyApp tys
 497
 498 mkWpEvApps :: [EvTerm] -> HsWrapper
 499 mkWpEvApps args = mk_co_app_fn WpEvApp args
 500
 501 mkWpEvVarApps :: [EvVar] -> HsWrapper
 502 mkWpEvVarApps vs = mkWpEvApps (map evVarTerm vs)
 503
 504 mkWpTyLams :: [TyVar] -> HsWrapper
 505 mkWpTyLams ids = mk_co_lam_fn WpTyLam ids
 506
 507 mkWpLams :: [Var] -> HsWrapper
 508 mkWpLams ids = mk_co_lam_fn WpEvLam ids
 509
 510 mkWpLet :: TcEvBinds -> HsWrapper
 511 -- This no-op is a quite a common case
 512 mkWpLet (EvBinds b) | isEmptyBag b = WpHole
 513 mkWpLet ev_binds                   = WpLet ev_binds
 514
 515 mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
 516 mk_co_lam_fn f as = foldr (\x wrap -> f x `WpCompose` wrap) WpHole as
 517
 518 mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
 519 -- For applications, the *first* argument must
 520 -- come *last* in the composition sequence
 521 mk_co_app_fn f as = foldr (\x wrap -> wrap `WpCompose` f x) WpHole as
 522
 523 idHsWrapper :: HsWrapper
 524 idHsWrapper = WpHole
 525
 526 isIdHsWrapper :: HsWrapper -> Bool
 527 isIdHsWrapper WpHole = True
 528 isIdHsWrapper _      = False
 529 \end{code}
 530
 531 Pretty printing
 532
 533 \begin{code}
 534 instance Outputable HsWrapper where
 535   ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn
 536
 537 pprHsWrapper :: SDoc -> HsWrapper -> SDoc
 538 -- In debug mode, print the wrapper
 539 -- otherwise just print what's inside
 540 pprHsWrapper doc wrap
 541   = getPprStyle (\ s -> if debugStyle s then (help (add_parens doc) wrap False) else doc)
 542   where
 543     help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc
 544     -- True  <=> appears in function application position
 545     -- False <=> appears as body of let or lambda
 546     help it WpHole             = it
 547     help it (WpCompose f1 f2)  = help (help it f2) f1
 548     help it (WpCast co)   = add_parens $ sep [it False, nest 2 (ptext (sLit "|>")
 549                                               <+> pprParendCo co)]
 550     help it (WpEvApp id)  = no_parens  $ sep [it True, nest 2 (ppr id)]
 551     help it (WpTyApp ty)  = no_parens  $ sep [it True, ptext (sLit "@") <+> pprParendType ty]
 552     help it (WpEvLam id)  = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False]
 553     help it (WpTyLam tv)  = add_parens $ sep [ptext (sLit "/\\") <> pp_bndr tv, it False]
 554     help it (WpLet binds) = add_parens $ sep [ptext (sLit "let") <+> braces (ppr binds), it False]
 555
 556     pp_bndr v = pprBndr LambdaBind v <> dot
 557
 558     add_parens, no_parens :: SDoc -> Bool -> SDoc
 559     add_parens d True  = parens d
 560     add_parens d False = d
 561     no_parens d _ = d
 562
 563 instance Outputable TcEvBinds where
 564   ppr (TcEvBinds v) = ppr v
 565   ppr (EvBinds bs)  = ptext (sLit "EvBinds") <> braces (ppr bs)
 566
 567 instance Outputable EvBindsVar where
 568   ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u)
 569
 570 instance Outputable EvBind where
 571   ppr (EvBind v e)   = ppr v <+> equals <+> ppr e
 572
 573 instance Outputable EvTerm where
 574   ppr (EvId v)           = ppr v
 575   ppr (EvCast v co)      = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendCo co
 576   ppr (EvCoercion co)    = ptext (sLit "CO") <+> ppr co
 577   ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
 578   ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
 579 \end{code}
 580
 581 %************************************************************************
 582 %*                                                                      *
 583 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 584 %*                                                                      *
 585 %************************************************************************
 586
 587 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 588 ``specialise this function to these four types...'') in with type
 589 signatures.  Then all the machinery to move them into place, etc.,
 590 serves for both.
 591
 592 \begin{code}
 593 type LSig name = Located (Sig name)
 594
 595 data Sig name   -- Signatures and pragmas
 596   =     -- An ordinary type signature
 597         -- f :: Num a => a -> a
 598     TypeSig (Located name) (LHsType name)
 599
 600         -- A type signature in generated code, notably the code
 601         -- generated for record selectors.  We simply record
 602         -- the desired Id itself, replete with its name, type
 603         -- and IdDetails.  Otherwise it's just like a type
 604         -- signature: there should be an accompanying binding
 605   | IdSig Id
 606
 607         -- An ordinary fixity declaration
 608         --      infixl *** 8
 609   | FixSig (FixitySig name)
 610
 611         -- An inline pragma
 612         -- {#- INLINE f #-}
 613   | InlineSig   (Located name)  -- Function name
 614                 InlinePragma    -- Never defaultInlinePragma
 615
 616         -- A specialisation pragma
 617         -- {-# SPECIALISE f :: Int -> Int #-}
 618   | SpecSig     (Located name)  -- Specialise a function or datatype ...
 619                 (LHsType name)  -- ... to these types
 620                 InlinePragma    -- The pragma on SPECIALISE_INLINE form
 621                                 -- If it's just defaultInlinePragma, then we said
 622                                 --    SPECIALISE, not SPECIALISE_INLINE
 623
 624         -- A specialisation pragma for instance declarations only
 625         -- {-# SPECIALISE instance Eq [Int] #-}
 626   | SpecInstSig (LHsType name)  -- (Class tys); should be a specialisation of the
 627                                 -- current instance decl
 628   deriving (Data, Typeable)
 629
 630
 631 type LFixitySig name = Located (FixitySig name)
 632 data FixitySig name = FixitySig (Located name) Fixity
 633   deriving (Data, Typeable)
 634
 635 -- TsSpecPrags conveys pragmas from the type checker to the desugarer
 636 data TcSpecPrags
 637   = IsDefaultMethod     -- Super-specialised: a default method should
 638                         -- be macro-expanded at every call site
 639   | SpecPrags [LTcSpecPrag]
 640   deriving (Data, Typeable)
 641
 642 type LTcSpecPrag = Located TcSpecPrag
 643
 644 data TcSpecPrag
 645   = SpecPrag
 646         Id              -- The Id to be specialised
 647         HsWrapper       -- An wrapper, that specialises the polymorphic function
 648         InlinePragma    -- Inlining spec for the specialised function
 649   deriving (Data, Typeable)
 650
 651 noSpecPrags :: TcSpecPrags
 652 noSpecPrags = SpecPrags []
 653
 654 hasSpecPrags :: TcSpecPrags -> Bool
 655 hasSpecPrags (SpecPrags ps) = not (null ps)
 656 hasSpecPrags IsDefaultMethod = False
 657
 658 isDefaultMethod :: TcSpecPrags -> Bool
 659 isDefaultMethod IsDefaultMethod = True
 660 isDefaultMethod (SpecPrags {})  = False
 661
 662 \end{code}
 663
 664 \begin{code}
 665 okBindSig :: Sig a -> Bool
 666 okBindSig _ = True
 667
 668 okHsBootSig :: Sig a -> Bool
 669 okHsBootSig (TypeSig  _ _) = True
 670 okHsBootSig (FixSig _)     = True
 671 okHsBootSig _              = False
 672
 673 okClsDclSig :: Sig a -> Bool
 674 okClsDclSig (SpecInstSig _) = False
 675 okClsDclSig _               = True        -- All others OK
 676
 677 okInstDclSig :: Sig a -> Bool
 678 okInstDclSig (TypeSig _ _)   = False
 679 okInstDclSig (FixSig _)      = False
 680 okInstDclSig _               = True
 681
 682 sigName :: LSig name -> Maybe name
 683 -- Used only in Haddock
 684 sigName (L _ sig) = sigNameNoLoc sig
 685
 686 sigNameNoLoc :: Sig name -> Maybe name
 687 -- Used only in Haddock
 688 sigNameNoLoc (TypeSig   n _)          = Just (unLoc n)
 689 sigNameNoLoc (SpecSig   n _ _)        = Just (unLoc n)
 690 sigNameNoLoc (InlineSig n _)          = Just (unLoc n)
 691 sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n)
 692 sigNameNoLoc _                        = Nothing
 693
 694 isFixityLSig :: LSig name -> Bool
 695 isFixityLSig (L _ (FixSig {})) = True
 696 isFixityLSig _                 = False
 697
 698 isVanillaLSig :: LSig name -> Bool       -- User type signatures
 699 -- A badly-named function, but it's part of the GHCi (used
 700 -- by Haddock) so I don't want to change it gratuitously.
 701 isVanillaLSig (L _(TypeSig {})) = True
 702 isVanillaLSig _                 = False
 703
 704 isTypeLSig :: LSig name -> Bool  -- Type signatures
 705 isTypeLSig (L _(TypeSig {})) = True
 706 isTypeLSig (L _(IdSig {}))   = True
 707 isTypeLSig _                 = False
 708
 709 isSpecLSig :: LSig name -> Bool
 710 isSpecLSig (L _(SpecSig {})) = True
 711 isSpecLSig _                 = False
 712
 713 isSpecInstLSig :: LSig name -> Bool
 714 isSpecInstLSig (L _ (SpecInstSig {})) = True
 715 isSpecInstLSig _                      = False
 716
 717 isPragLSig :: LSig name -> Bool
 718         -- Identifies pragmas
 719 isPragLSig (L _ (SpecSig {}))   = True
 720 isPragLSig (L _ (InlineSig {})) = True
 721 isPragLSig _                    = False
 722
 723 isInlineLSig :: LSig name -> Bool
 724         -- Identifies inline pragmas
 725 isInlineLSig (L _ (InlineSig {})) = True
 726 isInlineLSig _                    = False
 727
 728 hsSigDoc :: Sig name -> SDoc
 729 hsSigDoc (TypeSig {})           = ptext (sLit "type signature")
 730 hsSigDoc (IdSig {})             = ptext (sLit "id signature")
 731 hsSigDoc (SpecSig {})           = ptext (sLit "SPECIALISE pragma")
 732 hsSigDoc (InlineSig {})         = ptext (sLit "INLINE pragma")
 733 hsSigDoc (SpecInstSig {})       = ptext (sLit "SPECIALISE instance pragma")
 734 hsSigDoc (FixSig {})            = ptext (sLit "fixity declaration")
 735 \end{code}
 736
 737 Signature equality is used when checking for duplicate signatures
 738
 739 \begin{code}
 740 eqHsSig :: Eq a => LSig a -> LSig a -> Bool
 741 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
 742 eqHsSig (L _ (IdSig n1))                (L _ (IdSig n2))                = n1 == n2
 743 eqHsSig (L _ (TypeSig n1 _))            (L _ (TypeSig n2 _))            = unLoc n1 == unLoc n2
 744 eqHsSig (L _ (InlineSig n1 _))          (L _ (InlineSig n2 _))          = unLoc n1 == unLoc n2
 745         -- For specialisations, we don't have equality over
 746         -- HsType, so it's not convenient to spot duplicate
 747         -- specialisations here.  Check for this later, when we're in Type land
 748 eqHsSig _other1 _other2 = False
 749 \end{code}
 750
 751 \begin{code}
 752 instance (OutputableBndr name) => Outputable (Sig name) where
 753     ppr sig = ppr_sig sig
 754
 755 ppr_sig :: OutputableBndr name => Sig name -> SDoc
 756 ppr_sig (TypeSig var ty)          = pprVarSig (unLoc var) (ppr ty)
 757 ppr_sig (IdSig id)                = pprVarSig id (ppr (varType id))
 758 ppr_sig (FixSig fix_sig)          = ppr fix_sig
 759 ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec var (ppr ty) inl)
 760 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var)
 761 ppr_sig (SpecInstSig ty)          = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
 762
 763 instance Outputable name => Outputable (FixitySig name) where
 764   ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
 765
 766 pragBrackets :: SDoc -> SDoc
 767 pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}")
 768
 769 pprVarSig :: (Outputable id) => id -> SDoc -> SDoc
 770 pprVarSig var pp_ty = sep [ppr var <+> dcolon, nest 2 pp_ty]
 771
 772 pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc
 773 pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var pp_ty
 774   where
 775     pp_inl | isDefaultInlinePragma inl = empty
 776            | otherwise = ppr inl
 777
 778 pprTcSpecPrags :: TcSpecPrags -> SDoc
 779 pprTcSpecPrags IsDefaultMethod = ptext (sLit "<default method>")
 780 pprTcSpecPrags (SpecPrags ps)  = vcat (map (ppr . unLoc) ps)
 781
 782 instance Outputable TcSpecPrag where
 783   ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "<type>")) inl
 784 \end{code}
 785