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