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