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