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
 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        [EvVar]  -- The dependencies, which is generally a bigger list than
 453                 -- the arguments of the dfun.
 454                 -- See Note [Dependencies in self dictionaries] in TcSimplify
 455
 456   | EvSuperClass DictId Int    -- n'th superclass. Used for both equalities and
 457                                -- dictionaries, even though the former have no
 458                                -- selector Id.  We count up from _0_
 459
 460   deriving( Data, Typeable)
 461
 462 evVarTerm :: EvVar -> EvTerm
 463 evVarTerm v | isCoVar v = EvCoercion (mkCoVarCoercion v)
 464             | otherwise = EvId v
 465 \end{code}
 466
 467 Note [EvBinds/EvTerm]
 468 ~~~~~~~~~~~~~~~~~~~~~
 469 How evidence is created and updated. Bindings for dictionaries,
 470 and coercions and implicit parameters are carried around in TcEvBinds
 471 which during constraint generation and simplification is always of the
 472 form (TcEvBinds ref). After constraint simplification is finished it
 473 will be transformed to t an (EvBinds ev_bag).
 474
 475 Evidence for coercions *SHOULD* be filled in using the TcEvBinds
 476 However, all EvVars that correspond to *wanted* coercion terms in
 477 an EvBind must be mutable variables so that they can be readily
 478 inlined (by zonking) after constraint simplification is finished.
 479
 480 Conclusion: a new wanted coercion variable should be made mutable.
 481 [Notice though that evidence variables that bind coercion terms
 482  from super classes will be "given" and hence rigid]
 483
 484
 485 \begin{code}
 486 emptyTcEvBinds :: TcEvBinds
 487 emptyTcEvBinds = EvBinds emptyBag
 488
 489 isEmptyTcEvBinds :: TcEvBinds -> Bool
 490 isEmptyTcEvBinds (EvBinds b)    = isEmptyBag b
 491 isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds"
 492
 493 (<.>) :: HsWrapper -> HsWrapper -> HsWrapper
 494 WpHole <.> c = c
 495 c <.> WpHole = c
 496 c1 <.> c2    = c1 `WpCompose` c2
 497
 498 mkWpTyApps :: [Type] -> HsWrapper
 499 mkWpTyApps tys = mk_co_app_fn WpTyApp tys
 500
 501 mkWpEvApps :: [EvTerm] -> HsWrapper
 502 mkWpEvApps args = mk_co_app_fn WpEvApp args
 503
 504 mkWpEvVarApps :: [EvVar] -> HsWrapper
 505 mkWpEvVarApps vs = mkWpEvApps (map evVarTerm vs)
 506
 507 mkWpTyLams :: [TyVar] -> HsWrapper
 508 mkWpTyLams ids = mk_co_lam_fn WpTyLam ids
 509
 510 mkWpLams :: [Var] -> HsWrapper
 511 mkWpLams ids = mk_co_lam_fn WpEvLam ids
 512
 513 mkWpLet :: TcEvBinds -> HsWrapper
 514 -- This no-op is a quite a common case
 515 mkWpLet (EvBinds b) | isEmptyBag b = WpHole
 516 mkWpLet ev_binds                   = WpLet ev_binds
 517
 518 mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
 519 mk_co_lam_fn f as = foldr (\x wrap -> f x `WpCompose` wrap) WpHole as
 520
 521 mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
 522 -- For applications, the *first* argument must
 523 -- come *last* in the composition sequence
 524 mk_co_app_fn f as = foldr (\x wrap -> wrap `WpCompose` f x) WpHole as
 525
 526 idHsWrapper :: HsWrapper
 527 idHsWrapper = WpHole
 528
 529 isIdHsWrapper :: HsWrapper -> Bool
 530 isIdHsWrapper WpHole = True
 531 isIdHsWrapper _      = False
 532 \end{code}
 533
 534 Pretty printing
 535
 536 \begin{code}
 537 instance Outputable HsWrapper where
 538   ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn
 539
 540 pprHsWrapper :: SDoc -> HsWrapper -> SDoc
 541 -- In debug mode, print the wrapper
 542 -- otherwise just print what's inside
 543 pprHsWrapper doc wrap
 544   = getPprStyle (\ s -> if debugStyle s then (help (add_parens doc) wrap False) else doc)
 545   where
 546     help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc
 547     -- True  <=> appears in function application position
 548     -- False <=> appears as body of let or lambda
 549     help it WpHole             = it
 550     help it (WpCompose f1 f2)  = help (help it f2) f1
 551     help it (WpCast co)   = add_parens $ sep [it False, nest 2 (ptext (sLit "|>")
 552                                                  <+> pprParendType co)]
 553     help it (WpEvApp id)  = no_parens  $ sep [it True, nest 2 (ppr id)]
 554     help it (WpTyApp ty)  = no_parens  $ sep [it True, ptext (sLit "@") <+> pprParendType ty]
 555     help it (WpEvLam id)  = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False]
 556     help it (WpTyLam tv)  = add_parens $ sep [ptext (sLit "/\\") <> pp_bndr tv, it False]
 557     help it (WpLet binds) = add_parens $ sep [ptext (sLit "let") <+> braces (ppr binds), it False]
 558
 559     pp_bndr v = pprBndr LambdaBind v <> dot
 560
 561     add_parens, no_parens :: SDoc -> Bool -> SDoc
 562     add_parens d True  = parens d
 563     add_parens d False = d
 564     no_parens d _ = d
 565
 566 instance Outputable TcEvBinds where
 567   ppr (TcEvBinds v) = ppr v
 568   ppr (EvBinds bs)  = ptext (sLit "EvBinds") <> braces (ppr bs)
 569
 570 instance Outputable EvBindsVar where
 571   ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u)
 572
 573 instance Outputable EvBind where
 574   ppr (EvBind v e)   = ppr v <+> equals <+> ppr e
 575
 576 instance Outputable EvTerm where
 577   ppr (EvId v)           = ppr v
 578   ppr (EvCast v co)      = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co
 579   ppr (EvCoercion co)    = ppr co
 580   ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
 581   ppr (EvDFunApp df tys ts deps) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts, ppr deps ]
 582 \end{code}
 583
 584 %************************************************************************
 585 %*                                                                      *
 586 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 587 %*                                                                      *
 588 %************************************************************************
 589
 590 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 591 ``specialise this function to these four types...'') in with type
 592 signatures.  Then all the machinery to move them into place, etc.,
 593 serves for both.
 594
 595 \begin{code}
 596 type LSig name = Located (Sig name)
 597
 598 data Sig name   -- Signatures and pragmas
 599   =     -- An ordinary type signature
 600         -- f :: Num a => a -> a
 601     TypeSig (Located name) (LHsType name)
 602
 603         -- A type signature in generated code, notably the code
 604         -- generated for record selectors.  We simply record
 605         -- the desired Id itself, replete with its name, type
 606         -- and IdDetails.  Otherwise it's just like a type
 607         -- signature: there should be an accompanying binding
 608   | IdSig Id
 609
 610         -- An ordinary fixity declaration
 611         --      infixl *** 8
 612   | FixSig (FixitySig name)
 613
 614         -- An inline pragma
 615         -- {#- INLINE f #-}
 616   | InlineSig   (Located name)  -- Function name
 617                 InlinePragma    -- Never defaultInlinePragma
 618
 619         -- A specialisation pragma
 620         -- {-# SPECIALISE f :: Int -> Int #-}
 621   | SpecSig     (Located name)  -- Specialise a function or datatype ...
 622                 (LHsType name)  -- ... to these types
 623                 InlinePragma    -- The pragma on SPECIALISE_INLINE form
 624                                 -- If it's just defaultInlinePragma, then we said
 625                                 --    SPECIALISE, not SPECIALISE_INLINE
 626
 627         -- A specialisation pragma for instance declarations only
 628         -- {-# SPECIALISE instance Eq [Int] #-}
 629   | SpecInstSig (LHsType name)  -- (Class tys); should be a specialisation of the
 630                                 -- current instance decl
 631   deriving (Data, Typeable)
 632
 633
 634 type LFixitySig name = Located (FixitySig name)
 635 data FixitySig name = FixitySig (Located name) Fixity
 636   deriving (Data, Typeable)
 637
 638 -- TsSpecPrags conveys pragmas from the type checker to the desugarer
 639 data TcSpecPrags
 640   = IsDefaultMethod     -- Super-specialised: a default method should
 641                         -- be macro-expanded at every call site
 642   | SpecPrags [LTcSpecPrag]
 643   deriving (Data, Typeable)
 644
 645 type LTcSpecPrag = Located TcSpecPrag
 646
 647 data TcSpecPrag
 648   = SpecPrag
 649         Id              -- The Id to be specialised
 650         HsWrapper       -- An wrapper, that specialises the polymorphic function
 651         InlinePragma    -- Inlining spec for the specialised function
 652   deriving (Data, Typeable)
 653
 654 noSpecPrags :: TcSpecPrags
 655 noSpecPrags = SpecPrags []
 656
 657 hasSpecPrags :: TcSpecPrags -> Bool
 658 hasSpecPrags (SpecPrags ps) = not (null ps)
 659 hasSpecPrags IsDefaultMethod = False
 660
 661 isDefaultMethod :: TcSpecPrags -> Bool
 662 isDefaultMethod IsDefaultMethod = True
 663 isDefaultMethod (SpecPrags {})  = False
 664
 665 \end{code}
 666
 667 \begin{code}
 668 okBindSig :: Sig a -> Bool
 669 okBindSig _ = True
 670
 671 okHsBootSig :: Sig a -> Bool
 672 okHsBootSig (TypeSig  _ _) = True
 673 okHsBootSig (FixSig _)     = True
 674 okHsBootSig _              = False
 675
 676 okClsDclSig :: Sig a -> Bool
 677 okClsDclSig (SpecInstSig _) = False
 678 okClsDclSig _               = True        -- All others OK
 679
 680 okInstDclSig :: Sig a -> Bool
 681 okInstDclSig (TypeSig _ _)   = False
 682 okInstDclSig (FixSig _)      = False
 683 okInstDclSig _               = True
 684
 685 sigForThisGroup :: NameSet -> LSig Name -> Bool
 686 sigForThisGroup ns sig
 687   = case sigName sig of
 688         Nothing -> False
 689         Just n  -> n `elemNameSet` ns
 690
 691 sigName :: LSig name -> Maybe name
 692 sigName (L _ sig) = sigNameNoLoc sig
 693
 694 sigNameNoLoc :: Sig name -> Maybe name
 695 sigNameNoLoc (TypeSig   n _)          = Just (unLoc n)
 696 sigNameNoLoc (SpecSig   n _ _)        = Just (unLoc n)
 697 sigNameNoLoc (InlineSig n _)          = Just (unLoc n)
 698 sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n)
 699 sigNameNoLoc _                        = Nothing
 700
 701 isFixityLSig :: LSig name -> Bool
 702 isFixityLSig (L _ (FixSig {})) = True
 703 isFixityLSig _                 = False
 704
 705 isVanillaLSig :: LSig name -> Bool       -- User type signatures
 706 -- A badly-named function, but it's part of the GHCi (used
 707 -- by Haddock) so I don't want to change it gratuitously.
 708 isVanillaLSig (L _(TypeSig {})) = True
 709 isVanillaLSig _                 = False
 710
 711 isTypeLSig :: LSig name -> Bool  -- Type signatures
 712 isTypeLSig (L _(TypeSig {})) = True
 713 isTypeLSig (L _(IdSig {}))   = True
 714 isTypeLSig _                 = False
 715
 716 isSpecLSig :: LSig name -> Bool
 717 isSpecLSig (L _(SpecSig {})) = True
 718 isSpecLSig _                 = False
 719
 720 isSpecInstLSig :: LSig name -> Bool
 721 isSpecInstLSig (L _ (SpecInstSig {})) = True
 722 isSpecInstLSig _                      = False
 723
 724 isPragLSig :: LSig name -> Bool
 725         -- Identifies pragmas
 726 isPragLSig (L _ (SpecSig {}))   = True
 727 isPragLSig (L _ (InlineSig {})) = True
 728 isPragLSig _                    = False
 729
 730 isInlineLSig :: LSig name -> Bool
 731         -- Identifies inline pragmas
 732 isInlineLSig (L _ (InlineSig {})) = True
 733 isInlineLSig _                    = False
 734
 735 hsSigDoc :: Sig name -> SDoc
 736 hsSigDoc (TypeSig {})           = ptext (sLit "type signature")
 737 hsSigDoc (IdSig {})             = ptext (sLit "id signature")
 738 hsSigDoc (SpecSig {})           = ptext (sLit "SPECIALISE pragma")
 739 hsSigDoc (InlineSig {})         = ptext (sLit "INLINE pragma")
 740 hsSigDoc (SpecInstSig {})       = ptext (sLit "SPECIALISE instance pragma")
 741 hsSigDoc (FixSig {})            = ptext (sLit "fixity declaration")
 742 \end{code}
 743
 744 Signature equality is used when checking for duplicate signatures
 745
 746 \begin{code}
 747 eqHsSig :: Eq a => LSig a -> LSig a -> Bool
 748 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
 749 eqHsSig (L _ (IdSig n1))                (L _ (IdSig n2))                = n1 == n2
 750 eqHsSig (L _ (TypeSig n1 _))            (L _ (TypeSig n2 _))            = unLoc n1 == unLoc n2
 751 eqHsSig (L _ (InlineSig n1 _))          (L _ (InlineSig n2 _))          = unLoc n1 == unLoc n2
 752         -- For specialisations, we don't have equality over
 753         -- HsType, so it's not convenient to spot duplicate
 754         -- specialisations here.  Check for this later, when we're in Type land
 755 eqHsSig _other1 _other2 = False
 756 \end{code}
 757
 758 \begin{code}
 759 instance (OutputableBndr name) => Outputable (Sig name) where
 760     ppr sig = ppr_sig sig
 761
 762 ppr_sig :: OutputableBndr name => Sig name -> SDoc
 763 ppr_sig (TypeSig var ty)          = pprVarSig (unLoc var) (ppr ty)
 764 ppr_sig (IdSig id)                = pprVarSig id (ppr (varType id))
 765 ppr_sig (FixSig fix_sig)          = ppr fix_sig
 766 ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec var (ppr ty) inl)
 767 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var)
 768 ppr_sig (SpecInstSig ty)          = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
 769
 770 instance Outputable name => Outputable (FixitySig name) where
 771   ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
 772
 773 pragBrackets :: SDoc -> SDoc
 774 pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}")
 775
 776 pprVarSig :: (Outputable id) => id -> SDoc -> SDoc
 777 pprVarSig var pp_ty = sep [ppr var <+> dcolon, nest 2 pp_ty]
 778
 779 pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc
 780 pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var pp_ty
 781   where
 782     pp_inl | isDefaultInlinePragma inl = empty
 783            | otherwise = ppr inl
 784
 785 pprTcSpecPrags :: TcSpecPrags -> SDoc
 786 pprTcSpecPrags IsDefaultMethod = ptext (sLit "<default method>")
 787 pprTcSpecPrags (SpecPrags ps)  = vcat (map (ppr . unLoc) ps)
 788
 789 instance Outputable TcSpecPrag where
 790   ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "<type>")) inl
 791 \end{code}
 792