compiler/hsSyn/HsBinds.hs

   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
  10 {-# LANGUAGE DeriveDataTypeable #-}
  11 {-# LANGUAGE StandaloneDeriving #-}
  12 {-# LANGUAGE FlexibleContexts #-}
  13 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
  14                                       -- in module PlaceHolder
  15 {-# LANGUAGE ConstraintKinds #-}
  16 {-# LANGUAGE CPP #-}
  17 {-# LANGUAGE BangPatterns #-}
  18
  19 module HsBinds where
  20
  21 import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
  22                                MatchGroup, pprFunBind,
  23                                GRHSs, pprPatBind )
  24 import {-# SOURCE #-} HsPat  ( LPat )
  25
  26 import PlaceHolder ( PostTc,PostRn,DataId )
  27 import HsTypes
  28 import PprCore ()
  29 import CoreSyn
  30 import TcEvidence
  31 import Type
  32 import Name
  33 import NameSet
  34 import BasicTypes
  35 import Outputable
  36 import SrcLoc
  37 import Var
  38 import Bag
  39 import FastString
  40 import BooleanFormula (BooleanFormula)
  41
  42 import Data.Data hiding ( Fixity )
  43 import Data.List
  44 import Data.Ord
  45 import Data.Foldable ( Foldable(..) )
  46 #if __GLASGOW_HASKELL__ < 709
  47 import Data.Traversable ( Traversable(..) )
  48 import Data.Monoid ( mappend )
  49 import Control.Applicative hiding (empty)
  50 #else
  51 import Control.Applicative ((<$>))
  52 #endif
  53
  54 {-
  55 ************************************************************************
  56 *                                                                      *
  57 \subsection{Bindings: @BindGroup@}
  58 *                                                                      *
  59 ************************************************************************
  60
  61 Global bindings (where clauses)
  62 -}
  63
  64 -- During renaming, we need bindings where the left-hand sides
  65 -- have been renamed but the the right-hand sides have not.
  66 -- the ...LR datatypes are parametrized by two id types,
  67 -- one for the left and one for the right.
  68 -- Other than during renaming, these will be the same.
  69
  70 type HsLocalBinds id = HsLocalBindsLR id id
  71
  72 -- | Bindings in a 'let' expression
  73 -- or a 'where' clause
  74 data HsLocalBindsLR idL idR
  75   = HsValBinds (HsValBindsLR idL idR)
  76          -- There should be no pattern synonyms in the HsValBindsLR
  77          -- These are *local* (not top level) bindings
  78          -- The parser accepts them, however, leaving the the
  79          -- renamer to report them
  80
  81   | HsIPBinds  (HsIPBinds idR)
  82
  83   | EmptyLocalBinds
  84   deriving (Typeable)
  85
  86 deriving instance (DataId idL, DataId idR)
  87   => Data (HsLocalBindsLR idL idR)
  88
  89 type HsValBinds id = HsValBindsLR id id
  90
  91 -- | Value bindings (not implicit parameters)
  92 -- Used for both top level and nested bindings
  93 -- May contain pattern synonym bindings
  94 data HsValBindsLR idL idR
  95   = -- | Before renaming RHS; idR is always RdrName
  96     -- Not dependency analysed
  97     -- Recursive by default
  98     ValBindsIn
  99         (LHsBindsLR idL idR) [LSig idR]
 100
 101     -- | After renaming RHS; idR can be Name or Id
 102     --  Dependency analysed,
 103     -- later bindings in the list may depend on earlier
 104     -- ones.
 105   | ValBindsOut
 106         [(RecFlag, LHsBinds idL)]
 107         [LSig Name]
 108   deriving (Typeable)
 109
 110 deriving instance (DataId idL, DataId idR)
 111   => Data (HsValBindsLR idL idR)
 112
 113 type LHsBind  id = LHsBindLR  id id
 114 type LHsBinds id = LHsBindsLR id id
 115 type HsBind   id = HsBindLR   id id
 116
 117 type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
 118 type LHsBindLR  idL idR = Located (HsBindLR idL idR)
 119
 120 data HsBindLR idL idR
 121   = -- | FunBind is used for both functions   @f x = e@
 122     -- and variables                          @f = \x -> e@
 123     --
 124     -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'.
 125     --
 126     -- Reason 2: Instance decls can only have FunBinds, which is convenient.
 127     --           If you change this, you'll need to change e.g. rnMethodBinds
 128     --
 129     -- But note that the form                 @f :: a->a = ...@
 130     -- parses as a pattern binding, just like
 131     --                                        @(f :: a -> a) = ... @
 132     --
 133     --  'ApiAnnotation.AnnKeywordId's
 134     --
 135     --  - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches
 136     --
 137     --  - 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
 138     --    'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
 139
 140     -- For details on above see note [Api annotations] in ApiAnnotation
 141     FunBind {
 142
 143         fun_id :: Located idL, -- Note [fun_id in Match] in HsExpr
 144
 145         fun_infix :: Bool,      -- ^ True => infix declaration
 146
 147         fun_matches :: MatchGroup idR (LHsExpr idR),  -- ^ The payload
 148
 149         fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of
 150                                 -- the Id.  Example:
 151                                 --
 152                                 -- @
 153                                 --      f :: Int -> forall a. a -> a
 154                                 --      f x y = y
 155                                 -- @
 156                                 --
 157                                 -- Then the MatchGroup will have type (Int -> a' -> a')
 158                                 -- (with a free type variable a').  The coercion will take
 159                                 -- a CoreExpr of this type and convert it to a CoreExpr of
 160                                 -- type         Int -> forall a'. a' -> a'
 161                                 -- Notice that the coercion captures the free a'.
 162
 163         bind_fvs :: PostRn idL NameSet, -- ^ After the renamer, this contains
 164                                 --  the locally-bound
 165                                 -- free variables of this defn.
 166                                 -- See Note [Bind free vars]
 167
 168
 169         fun_tick :: [Tickish Id]  -- ^ Ticks to put on the rhs, if any
 170     }
 171
 172   -- | The pattern is never a simple variable;
 173   -- That case is done by FunBind
 174   --
 175   --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang',
 176   --       'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
 177   --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
 178
 179   -- For details on above see note [Api annotations] in ApiAnnotation
 180   | PatBind {
 181         pat_lhs    :: LPat idL,
 182         pat_rhs    :: GRHSs idR (LHsExpr idR),
 183         pat_rhs_ty :: PostTc idR Type,      -- ^ Type of the GRHSs
 184         bind_fvs   :: PostRn idL NameSet, -- ^ See Note [Bind free vars]
 185         pat_ticks  :: ([Tickish Id], [[Tickish Id]])
 186                -- ^ Ticks to put on the rhs, if any, and ticks to put on
 187                -- the bound variables.
 188     }
 189
 190   -- | Dictionary binding and suchlike.
 191   -- All VarBinds are introduced by the type checker
 192   | VarBind {
 193         var_id     :: idL,
 194         var_rhs    :: LHsExpr idR,   -- ^ Located only for consistency
 195         var_inline :: Bool           -- ^ True <=> inline this binding regardless
 196                                      -- (used for implication constraints only)
 197     }
 198
 199   | AbsBinds {                      -- Binds abstraction; TRANSLATION
 200         abs_tvs     :: [TyVar],
 201         abs_ev_vars :: [EvVar],  -- ^ Includes equality constraints
 202
 203        -- | AbsBinds only gets used when idL = idR after renaming,
 204        -- but these need to be idL's for the collect... code in HsUtil
 205        -- to have the right type
 206         abs_exports :: [ABExport idL],
 207
 208         -- | Evidence bindings
 209         -- Why a list? See TcInstDcls
 210         -- Note [Typechecking plan for instance declarations]
 211         abs_ev_binds :: [TcEvBinds],
 212
 213         -- | Typechecked user bindings
 214         abs_binds    :: LHsBinds idL
 215     }
 216
 217   | PatSynBind (PatSynBind idL idR)
 218         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
 219         --          'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual',
 220         --          'ApiAnnotation.AnnWhere'
 221         --          'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@
 222
 223         -- For details on above see note [Api annotations] in ApiAnnotation
 224
 225   deriving (Typeable)
 226 deriving instance (DataId idL, DataId idR)
 227   => Data (HsBindLR idL idR)
 228
 229         -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
 230         --
 231         -- Creates bindings for (polymorphic, overloaded) poly_f
 232         -- in terms of monomorphic, non-overloaded mono_f
 233         --
 234         -- Invariants:
 235         --      1. 'binds' binds mono_f
 236         --      2. ftvs is a subset of tvs
 237         --      3. ftvs includes all tyvars free in ds
 238         --
 239         -- See Note [AbsBinds]
 240
 241 data ABExport id
 242   = ABE { abe_poly  :: id           -- ^ Any INLINE pragmas is attached to this Id
 243         , abe_mono  :: id
 244         , abe_wrap  :: HsWrapper    -- ^ See Note [AbsBinds wrappers]
 245              -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
 246         , abe_prags :: TcSpecPrags  -- ^ SPECIALISE pragmas
 247   } deriving (Data, Typeable)
 248
 249 -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
 250 --             'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow'
 251 --             'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@,
 252 --             'ApiAnnotation.AnnClose' @'}'@,
 253
 254 -- For details on above see note [Api annotations] in ApiAnnotation
 255 data PatSynBind idL idR
 256   = PSB { psb_id   :: Located idL,             -- ^ Name of the pattern synonym
 257           psb_fvs  :: PostRn idR NameSet,      -- ^ See Note [Bind free vars]
 258           psb_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names
 259           psb_def  :: LPat idR,                      -- ^ Right-hand side
 260           psb_dir  :: HsPatSynDir idR                -- ^ Directionality
 261   } deriving (Typeable)
 262 deriving instance (DataId idL, DataId idR )
 263   => Data (PatSynBind idL idR)
 264
 265 {-
 266 Note [AbsBinds]
 267 ~~~~~~~~~~~~~~~
 268 The AbsBinds constructor is used in the output of the type checker, to record
 269 *typechecked* and *generalised* bindings.  Consider a module M, with this
 270 top-level binding
 271     M.reverse []     = []
 272     M.reverse (x:xs) = M.reverse xs ++ [x]
 273
 274 In Hindley-Milner, a recursive binding is typechecked with the *recursive* uses
 275 being *monomorphic*.  So after typechecking *and* desugaring we will get something
 276 like this
 277
 278     M.reverse :: forall a. [a] -> [a]
 279       = /\a. letrec
 280                 reverse :: [a] -> [a] = \xs -> case xs of
 281                                                 []     -> []
 282                                                 (x:xs) -> reverse xs ++ [x]
 283              in reverse
 284
 285 Notice that 'M.reverse' is polymorphic as expected, but there is a local
 286 definition for plain 'reverse' which is *monomorphic*.  The type variable
 287 'a' scopes over the entire letrec.
 288
 289 That's after desugaring.  What about after type checking but before desugaring?
 290 That's where AbsBinds comes in.  It looks like this:
 291
 292    AbsBinds { abs_tvs     = [a]
 293             , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a],
 294                                  , abe_mono = reverse :: a -> a}]
 295             , abs_binds = { reverse :: [a] -> [a]
 296                                = \xs -> case xs of
 297                                             []     -> []
 298                                             (x:xs) -> reverse xs ++ [x] } }
 299
 300 Here,
 301   * abs_tvs says what type variables are abstracted over the binding group,
 302     just 'a' in this case.
 303   * abs_binds is the *monomorphic* bindings of the group
 304   * abs_exports describes how to get the polymorphic Id 'M.reverse' from the
 305     monomorphic one 'reverse'
 306
 307 Notice that the *original* function (the polymorphic one you thought
 308 you were defining) appears in the abe_poly field of the
 309 abs_exports. The bindings in abs_binds are for fresh, local, Ids with
 310 a *monomorphic* Id.
 311
 312 If there is a group of mutually recursive functions without type
 313 signatures, we get one AbsBinds with the monomorphic versions of the
 314 bindings in abs_binds, and one element of abe_exports for each
 315 variable bound in the mutually recursive group.  This is true even for
 316 pattern bindings.  Example:
 317         (f,g) = (\x -> x, f)
 318 After type checking we get
 319    AbsBinds { abs_tvs     = [a]
 320             , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a
 321                                   , abe_mono = f :: a -> a }
 322                             , ABE { abe_poly = M.g :: forall a. a -> a
 323                                   , abe_mono = g :: a -> a }]
 324             , abs_binds = { (f,g) = (\x -> x, f) }
 325
 326 Note [AbsBinds wrappers]
 327 ~~~~~~~~~~~~~~~~~~~~~~~~
 328 Consider
 329    (f,g) = (\x.x, \y.y)
 330 This ultimately desugars to something like this:
 331    tup :: forall a b. (a->a, b->b)
 332    tup = /\a b. (\x:a.x, \y:b.y)
 333    f :: forall a. a -> a
 334    f = /\a. case tup a Any of
 335                (fm::a->a,gm:Any->Any) -> fm
 336    ...similarly for g...
 337
 338 The abe_wrap field deals with impedence-matching between
 339     (/\a b. case tup a b of { (f,g) -> f })
 340 and the thing we really want, which may have fewer type
 341 variables.  The action happens in TcBinds.mkExport.
 342
 343 Note [Bind free vars]
 344 ~~~~~~~~~~~~~~~~~~~~~
 345 The bind_fvs field of FunBind and PatBind records the free variables
 346 of the definition.  It is used for two purposes
 347
 348 a) Dependency analysis prior to type checking
 349     (see TcBinds.tc_group)
 350
 351 b) Deciding whether we can do generalisation of the binding
 352     (see TcBinds.decideGeneralisationPlan)
 353
 354 Specifically,
 355
 356   * bind_fvs includes all free vars that are defined in this module
 357     (including top-level things and lexically scoped type variables)
 358
 359   * bind_fvs excludes imported vars; this is just to keep the set smaller
 360
 361   * Before renaming, and after typechecking, the field is unused;
 362     it's just an error thunk
 363 -}
 364
 365 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where
 366   ppr (HsValBinds bs) = ppr bs
 367   ppr (HsIPBinds bs)  = ppr bs
 368   ppr EmptyLocalBinds = empty
 369
 370 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where
 371   ppr (ValBindsIn binds sigs)
 372    = pprDeclList (pprLHsBindsForUser binds sigs)
 373
 374   ppr (ValBindsOut sccs sigs)
 375     = getPprStyle $ \ sty ->
 376       if debugStyle sty then    -- Print with sccs showing
 377         vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
 378      else
 379         pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs)
 380    where
 381      ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
 382      pp_rec Recursive    = ptext (sLit "rec")
 383      pp_rec NonRecursive = ptext (sLit "nonrec")
 384
 385 pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
 386 pprLHsBinds binds
 387   | isEmptyLHsBinds binds = empty
 388   | otherwise = pprDeclList (map ppr (bagToList binds))
 389
 390 pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
 391                    => LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
 392 --  pprLHsBindsForUser is different to pprLHsBinds because
 393 --  a) No braces: 'let' and 'where' include a list of HsBindGroups
 394 --     and we don't want several groups of bindings each
 395 --     with braces around
 396 --  b) Sort by location before printing
 397 --  c) Include signatures
 398 pprLHsBindsForUser binds sigs
 399   = map snd (sort_by_loc decls)
 400   where
 401
 402     decls :: [(SrcSpan, SDoc)]
 403     decls = [(loc, ppr sig)  | L loc sig <- sigs] ++
 404             [(loc, ppr bind) | L loc bind <- bagToList binds]
 405
 406     sort_by_loc decls = sortBy (comparing fst) decls
 407
 408 pprDeclList :: [SDoc] -> SDoc   -- Braces with a space
 409 -- Print a bunch of declarations
 410 -- One could choose  { d1; d2; ... }, using 'sep'
 411 -- or      d1
 412 --         d2
 413 --         ..
 414 --    using vcat
 415 -- At the moment we chose the latter
 416 -- Also we do the 'pprDeeperList' thing.
 417 pprDeclList ds = pprDeeperList vcat ds
 418
 419 ------------
 420 emptyLocalBinds :: HsLocalBindsLR a b
 421 emptyLocalBinds = EmptyLocalBinds
 422
 423 isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
 424 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
 425 isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds
 426 isEmptyLocalBinds EmptyLocalBinds = True
 427
 428 isEmptyValBinds :: HsValBindsLR a b -> Bool
 429 isEmptyValBinds (ValBindsIn ds sigs)  = isEmptyLHsBinds ds && null sigs
 430 isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
 431
 432 emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
 433 emptyValBindsIn  = ValBindsIn emptyBag []
 434 emptyValBindsOut = ValBindsOut []      []
 435
 436 emptyLHsBinds :: LHsBindsLR idL idR
 437 emptyLHsBinds = emptyBag
 438
 439 isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
 440 isEmptyLHsBinds = isEmptyBag
 441
 442 ------------
 443 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
 444 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
 445   = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
 446 plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
 447   = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
 448 plusHsValBinds _ _
 449   = panic "HsBinds.plusHsValBinds"
 450
 451 getTypeSigNames :: HsValBinds a -> NameSet
 452 -- Get the names that have a user type sig
 453 getTypeSigNames (ValBindsOut _ sigs)
 454   = mkNameSet [unLoc n | L _ (TypeSig names _ _) <- sigs, n <- names]
 455 getTypeSigNames _
 456   = panic "HsBinds.getTypeSigNames"
 457
 458 {-
 459 What AbsBinds means
 460 ~~~~~~~~~~~~~~~~~~~
 461          AbsBinds tvs
 462                   [d1,d2]
 463                   [(tvs1, f1p, f1m),
 464                    (tvs2, f2p, f2m)]
 465                   BIND
 466 means
 467
 468         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 469                                      in fm
 470
 471         gp = ...same again, with gm instead of fm
 472
 473 This is a pretty bad translation, because it duplicates all the bindings.
 474 So the desugarer tries to do a better job:
 475
 476         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 477                                         (fm,gm) -> fm
 478         ..ditto for gp..
 479
 480         tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 481                                       in (fm,gm)
 482 -}
 483
 484 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where
 485     ppr mbind = ppr_monobind mbind
 486
 487 ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc
 488
 489 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
 490   = pprPatBind pat grhss
 491 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
 492   = sep [pprBndr CaseBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
 493 ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
 494                         fun_co_fn = wrap,
 495                         fun_matches = matches,
 496                         fun_tick = ticks })
 497   = pprTicks empty (if null ticks then empty
 498                     else text "-- ticks = " <> ppr ticks)
 499     $$  ifPprDebug (pprBndr LetBind (unLoc fun))
 500     $$  pprFunBind (unLoc fun) inf matches
 501     $$  ifPprDebug (ppr wrap)
 502 ppr_monobind (PatSynBind psb) = ppr psb
 503 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
 504                        , abs_exports = exports, abs_binds = val_binds
 505                        , abs_ev_binds = ev_binds })
 506   = hang (ptext (sLit "AbsBinds") <+> brackets (interpp'SP tyvars)
 507                                   <+> brackets (interpp'SP dictvars))
 508        2 $ braces $ vcat
 509     [ ptext (sLit "Exports:") <+> brackets (sep (punctuate comma (map ppr exports)))
 510     , ptext (sLit "Exported types:") <+> vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
 511     , ptext (sLit "Binds:") <+> pprLHsBinds val_binds
 512     , ifPprDebug (ptext (sLit "Evidence:") <+> ppr ev_binds) ]
 513
 514 instance (OutputableBndr id) => Outputable (ABExport id) where
 515   ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
 516     = vcat [ ppr gbl <+> ptext (sLit "<=") <+> ppr lcl
 517            , nest 2 (pprTcSpecPrags prags)
 518            , nest 2 (ppr wrap)]
 519
 520 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL idR) where
 521   ppr (PSB{ psb_id = L _ psyn, psb_args = details, psb_def = pat, psb_dir = dir })
 522       = ppr_lhs <+> ppr_rhs
 523     where
 524       ppr_lhs = ptext (sLit "pattern") <+> ppr_details
 525       ppr_simple syntax = syntax <+> ppr pat
 526
 527       (is_infix, ppr_details) = case details of
 528           InfixPatSyn v1 v2 -> (True, hsep [ppr v1, pprInfixOcc psyn, ppr v2])
 529           PrefixPatSyn vs   -> (False, hsep (pprPrefixOcc psyn : map ppr vs))
 530
 531       ppr_rhs = case dir of
 532           Unidirectional           -> ppr_simple (ptext (sLit "<-"))
 533           ImplicitBidirectional    -> ppr_simple equals
 534           ExplicitBidirectional mg -> ppr_simple (ptext (sLit "<-")) <+> ptext (sLit "where") $$
 535                                       (nest 2 $ pprFunBind psyn is_infix mg)
 536
 537 pprTicks :: SDoc -> SDoc -> SDoc
 538 -- Print stuff about ticks only when -dppr-debug is on, to avoid
 539 -- them appearing in error messages (from the desugarer); see Trac # 3263
 540 -- Also print ticks in dumpStyle, so that -ddump-hpc actually does
 541 -- something useful.
 542 pprTicks pp_no_debug pp_when_debug
 543   = getPprStyle (\ sty -> if debugStyle sty || dumpStyle sty
 544                              then pp_when_debug
 545                              else pp_no_debug)
 546
 547 {-
 548 ************************************************************************
 549 *                                                                      *
 550                 Implicit parameter bindings
 551 *                                                                      *
 552 ************************************************************************
 553 -}
 554
 555 data HsIPBinds id
 556   = IPBinds
 557         [LIPBind id]
 558         TcEvBinds       -- Only in typechecker output; binds
 559                         -- uses of the implicit parameters
 560   deriving (Typeable)
 561 deriving instance (DataId id) => Data (HsIPBinds id)
 562
 563 isEmptyIPBinds :: HsIPBinds id -> Bool
 564 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
 565
 566 type LIPBind id = Located (IPBind id)
 567 -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a
 568 --   list
 569
 570 -- For details on above see note [Api annotations] in ApiAnnotation
 571
 572 -- | Implicit parameter bindings.
 573 --
 574 -- These bindings start off as (Left "x") in the parser and stay
 575 -- that way until after type-checking when they are replaced with
 576 -- (Right d), where "d" is the name of the dictionary holding the
 577 -- evidence for the implicit parameter.
 578 --
 579 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
 580
 581 -- For details on above see note [Api annotations] in ApiAnnotation
 582 data IPBind id
 583   = IPBind (Either (Located HsIPName) id) (LHsExpr id)
 584   deriving (Typeable)
 585 deriving instance (DataId name) => Data (IPBind name)
 586
 587 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
 588   ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
 589                         $$ ifPprDebug (ppr ds)
 590
 591 instance (OutputableBndr id) => Outputable (IPBind id) where
 592   ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
 593     where name = case lr of
 594                    Left (L _ ip) -> pprBndr LetBind ip
 595                    Right     id  -> pprBndr LetBind id
 596
 597 {-
 598 ************************************************************************
 599 *                                                                      *
 600 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 601 *                                                                      *
 602 ************************************************************************
 603
 604 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 605 ``specialise this function to these four types...'') in with type
 606 signatures.  Then all the machinery to move them into place, etc.,
 607 serves for both.
 608 -}
 609
 610 type LSig name = Located (Sig name)
 611
 612 -- | Signatures and pragmas
 613 data Sig name
 614   =   -- | An ordinary type signature
 615       --
 616       -- > f :: Num a => a -> a
 617       --
 618       -- After renaming, this list of Names contains the named and unnamed
 619       -- wildcards brought into scope by this signature. For a signature
 620       -- @_ -> _a -> Bool@, the renamer will give the unnamed wildcard @_@
 621       -- a freshly generated name, e.g. @_w@. @_w@ and the named wildcard @_a@
 622       -- are then both replaced with fresh meta vars in the type. Their names
 623       -- are stored in the type signature that brought them into scope, in
 624       -- this third field to be more specific.
 625       --
 626       --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon',
 627       --          'ApiAnnotation.AnnComma'
 628
 629       -- For details on above see note [Api annotations] in ApiAnnotation
 630     TypeSig
 631        [Located name]         -- LHS of the signature; e.g.  f,g,h :: blah
 632        (LHsType name)         -- RHS of the signature
 633        (PostRn name [Name])   -- Wildcards (both named and anonymous) of the RHS
 634
 635       -- | A pattern synonym type signature
 636       --
 637       -- > pattern Single :: () => (Show a) => a -> [a]
 638       --
 639       --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
 640       --           'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnForall'
 641       --           'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
 642
 643       -- For details on above see note [Api annotations] in ApiAnnotation
 644   | PatSynSig (Located name)
 645               (HsExplicitFlag, LHsTyVarBndrs name)
 646               (LHsContext name) -- Provided context
 647               (LHsContext name) -- Required context
 648               (LHsType name)
 649
 650         -- | A type signature for a default method inside a class
 651         --
 652         -- > default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool
 653         --
 654         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
 655         --           'ApiAnnotation.AnnDcolon'
 656
 657         -- For details on above see note [Api annotations] in ApiAnnotation
 658   | GenericSig [Located name] (LHsType name)
 659
 660         -- | A type signature in generated code, notably the code
 661         -- generated for record selectors.  We simply record
 662         -- the desired Id itself, replete with its name, type
 663         -- and IdDetails.  Otherwise it's just like a type
 664         -- signature: there should be an accompanying binding
 665   | IdSig Id
 666
 667         -- | An ordinary fixity declaration
 668         --
 669         -- >     infixl 8 ***
 670         --
 671         --
 672         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInfix',
 673         --           'ApiAnnotation.AnnVal'
 674
 675         -- For details on above see note [Api annotations] in ApiAnnotation
 676   | FixSig (FixitySig name)
 677
 678         -- | An inline pragma
 679         --
 680         -- > {#- INLINE f #-}
 681         --
 682         --  - 'ApiAnnotation.AnnKeywordId' :
 683         --       'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@,
 684         --       'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen',
 685         --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde',
 686         --       'ApiAnnotation.AnnClose'
 687
 688         -- For details on above see note [Api annotations] in ApiAnnotation
 689   | InlineSig   (Located name)  -- Function name
 690                 InlinePragma    -- Never defaultInlinePragma
 691
 692         -- | A specialisation pragma
 693         --
 694         -- > {-# SPECIALISE f :: Int -> Int #-}
 695         --
 696         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
 697         --      'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@,
 698         --      'ApiAnnotation.AnnTilde',
 699         --      'ApiAnnotation.AnnVal',
 700         --      'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@,
 701         --      'ApiAnnotation.AnnDcolon'
 702
 703         -- For details on above see note [Api annotations] in ApiAnnotation
 704   | SpecSig     (Located name)  -- Specialise a function or datatype  ...
 705                 [LHsType name]  -- ... to these types
 706                 InlinePragma    -- The pragma on SPECIALISE_INLINE form.
 707                                 -- If it's just defaultInlinePragma, then we said
 708                                 --    SPECIALISE, not SPECIALISE_INLINE
 709
 710         -- | A specialisation pragma for instance declarations only
 711         --
 712         -- > {-# SPECIALISE instance Eq [Int] #-}
 713         --
 714         -- (Class tys); should be a specialisation of the
 715         -- current instance declaration
 716         --
 717         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
 718         --      'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose'
 719
 720         -- For details on above see note [Api annotations] in ApiAnnotation
 721   | SpecInstSig SourceText (LHsType name)
 722                   -- Note [Pragma source text] in BasicTypes
 723
 724         -- | A minimal complete definition pragma
 725         --
 726         -- > {-# MINIMAL a | (b, c | (d | e)) #-}
 727         --
 728         --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
 729         --      'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma',
 730         --      'ApiAnnotation.AnnClose'
 731
 732         -- For details on above see note [Api annotations] in ApiAnnotation
 733   | MinimalSig SourceText (BooleanFormula (Located name))
 734                -- Note [Pragma source text] in BasicTypes
 735
 736   deriving (Typeable)
 737 deriving instance (DataId name) => Data (Sig name)
 738
 739
 740 type LFixitySig name = Located (FixitySig name)
 741 data FixitySig name = FixitySig [Located name] Fixity
 742   deriving (Data, Typeable)
 743
 744 -- | TsSpecPrags conveys pragmas from the type checker to the desugarer
 745 data TcSpecPrags
 746   = IsDefaultMethod     -- ^ Super-specialised: a default method should
 747                         -- be macro-expanded at every call site
 748   | SpecPrags [LTcSpecPrag]
 749   deriving (Data, Typeable)
 750
 751 type LTcSpecPrag = Located TcSpecPrag
 752
 753 data TcSpecPrag
 754   = SpecPrag
 755         Id
 756         HsWrapper
 757         InlinePragma
 758   -- ^ The Id to be specialised, an wrapper that specialises the
 759   -- polymorphic function, and inlining spec for the specialised function
 760   deriving (Data, Typeable)
 761
 762 noSpecPrags :: TcSpecPrags
 763 noSpecPrags = SpecPrags []
 764
 765 hasSpecPrags :: TcSpecPrags -> Bool
 766 hasSpecPrags (SpecPrags ps) = not (null ps)
 767 hasSpecPrags IsDefaultMethod = False
 768
 769 isDefaultMethod :: TcSpecPrags -> Bool
 770 isDefaultMethod IsDefaultMethod = True
 771 isDefaultMethod (SpecPrags {})  = False
 772
 773
 774 isFixityLSig :: LSig name -> Bool
 775 isFixityLSig (L _ (FixSig {})) = True
 776 isFixityLSig _                 = False
 777
 778 isVanillaLSig :: LSig name -> Bool       -- User type signatures
 779 -- A badly-named function, but it's part of the GHCi (used
 780 -- by Haddock) so I don't want to change it gratuitously.
 781 isVanillaLSig (L _(TypeSig {})) = True
 782 isVanillaLSig _                 = False
 783
 784 isTypeLSig :: LSig name -> Bool  -- Type signatures
 785 isTypeLSig (L _(TypeSig {}))    = True
 786 isTypeLSig (L _(GenericSig {})) = True
 787 isTypeLSig (L _(IdSig {}))      = True
 788 isTypeLSig _                    = False
 789
 790 isSpecLSig :: LSig name -> Bool
 791 isSpecLSig (L _(SpecSig {})) = True
 792 isSpecLSig _                 = False
 793
 794 isSpecInstLSig :: LSig name -> Bool
 795 isSpecInstLSig (L _ (SpecInstSig {})) = True
 796 isSpecInstLSig _                      = False
 797
 798 isPragLSig :: LSig name -> Bool
 799 -- Identifies pragmas
 800 isPragLSig (L _ (SpecSig {}))   = True
 801 isPragLSig (L _ (InlineSig {})) = True
 802 isPragLSig _                    = False
 803
 804 isInlineLSig :: LSig name -> Bool
 805 -- Identifies inline pragmas
 806 isInlineLSig (L _ (InlineSig {})) = True
 807 isInlineLSig _                    = False
 808
 809 isMinimalLSig :: LSig name -> Bool
 810 isMinimalLSig (L _ (MinimalSig {})) = True
 811 isMinimalLSig _                    = False
 812
 813 hsSigDoc :: Sig name -> SDoc
 814 hsSigDoc (TypeSig {})           = ptext (sLit "type signature")
 815 hsSigDoc (PatSynSig {})         = ptext (sLit "pattern synonym signature")
 816 hsSigDoc (GenericSig {})        = ptext (sLit "default type signature")
 817 hsSigDoc (IdSig {})             = ptext (sLit "id signature")
 818 hsSigDoc (SpecSig {})           = ptext (sLit "SPECIALISE pragma")
 819 hsSigDoc (InlineSig _ prag)     = ppr (inlinePragmaSpec prag) <+> ptext (sLit "pragma")
 820 hsSigDoc (SpecInstSig {})       = ptext (sLit "SPECIALISE instance pragma")
 821 hsSigDoc (FixSig {})            = ptext (sLit "fixity declaration")
 822 hsSigDoc (MinimalSig {})        = ptext (sLit "MINIMAL pragma")
 823
 824 {-
 825 Check if signatures overlap; this is used when checking for duplicate
 826 signatures. Since some of the signatures contain a list of names, testing for
 827 equality is not enough -- we have to check if they overlap.
 828 -}
 829
 830 instance (OutputableBndr name) => Outputable (Sig name) where
 831     ppr sig = ppr_sig sig
 832
 833 ppr_sig :: OutputableBndr name => Sig name -> SDoc
 834 ppr_sig (TypeSig vars ty _wcs)    = pprVarSig (map unLoc vars) (ppr ty)
 835 ppr_sig (GenericSig vars ty)      = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty)
 836 ppr_sig (IdSig id)                = pprVarSig [id] (ppr (varType id))
 837 ppr_sig (FixSig fix_sig)          = ppr fix_sig
 838 ppr_sig (SpecSig var ty inl)
 839   = pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl)
 840 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
 841 ppr_sig (SpecInstSig _ ty)
 842   = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
 843 ppr_sig (MinimalSig _ bf)         = pragBrackets (pprMinimalSig bf)
 844 ppr_sig (PatSynSig name (flag, qtvs) (L _ prov) (L _ req) ty)
 845   = pprPatSynSig (unLoc name) False -- TODO: is_bindir
 846                  (pprHsForAll flag qtvs (noLoc []))
 847                  (pprHsContextMaybe prov) (pprHsContextMaybe req)
 848                  (ppr ty)
 849
 850 pprPatSynSig :: (OutputableBndr name)
 851              => name -> Bool -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc -> SDoc
 852 pprPatSynSig ident _is_bidir tvs prov req ty
 853   = ptext (sLit "pattern") <+> pprPrefixOcc ident <+> dcolon <+>
 854     tvs <+> context <+> ty
 855   where
 856     context = case (prov, req) of
 857         (Nothing, Nothing)    -> empty
 858         (Nothing, Just req)   -> parens empty <+> darrow <+> req <+> darrow
 859         (Just prov, Nothing)  -> prov <+> darrow
 860         (Just prov, Just req) -> prov <+> darrow <+> req <+> darrow
 861
 862 instance OutputableBndr name => Outputable (FixitySig name) where
 863   ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
 864     where
 865       pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
 866
 867 pragBrackets :: SDoc -> SDoc
 868 pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}")
 869
 870 pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc
 871 pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]
 872   where
 873     pprvars = hsep $ punctuate comma (map pprPrefixOcc vars)
 874
 875 pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc
 876 pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig [var] pp_ty
 877   where
 878     pp_inl | isDefaultInlinePragma inl = empty
 879            | otherwise = ppr inl
 880
 881 pprTcSpecPrags :: TcSpecPrags -> SDoc
 882 pprTcSpecPrags IsDefaultMethod = ptext (sLit "<default method>")
 883 pprTcSpecPrags (SpecPrags ps)  = vcat (map (ppr . unLoc) ps)
 884
 885 instance Outputable TcSpecPrag where
 886   ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "<type>")) inl
 887
 888 pprMinimalSig :: OutputableBndr name => BooleanFormula (Located name) -> SDoc
 889 pprMinimalSig bf = ptext (sLit "MINIMAL") <+> ppr (fmap unLoc bf)
 890
 891 {-
 892 ************************************************************************
 893 *                                                                      *
 894 \subsection[PatSynBind]{A pattern synonym definition}
 895 *                                                                      *
 896 ************************************************************************
 897 -}
 898
 899 data HsPatSynDetails a
 900   = InfixPatSyn a a
 901   | PrefixPatSyn [a]
 902   deriving (Data, Typeable)
 903
 904 instance Functor HsPatSynDetails where
 905     fmap f (InfixPatSyn left right) = InfixPatSyn (f left) (f right)
 906     fmap f (PrefixPatSyn args) = PrefixPatSyn (fmap f args)
 907
 908 instance Foldable HsPatSynDetails where
 909     foldMap f (InfixPatSyn left right) = f left `mappend` f right
 910     foldMap f (PrefixPatSyn args) = foldMap f args
 911
 912     foldl1 f (InfixPatSyn left right) = left `f` right
 913     foldl1 f (PrefixPatSyn args) = Data.List.foldl1 f args
 914
 915     foldr1 f (InfixPatSyn left right) = left `f` right
 916     foldr1 f (PrefixPatSyn args) = Data.List.foldr1 f args
 917
 918 -- TODO: After a few more versions, we should probably use these.
 919 #if __GLASGOW_HASKELL__ >= 709
 920     length (InfixPatSyn _ _) = 2
 921     length (PrefixPatSyn args) = Data.List.length args
 922
 923     null (InfixPatSyn _ _) = False
 924     null (PrefixPatSyn args) = Data.List.null args
 925
 926     toList (InfixPatSyn left right) = [left, right]
 927     toList (PrefixPatSyn args) = args
 928 #endif
 929
 930 instance Traversable HsPatSynDetails where
 931     traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right
 932     traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args
 933
 934 data HsPatSynDir id
 935   = Unidirectional
 936   | ImplicitBidirectional
 937   | ExplicitBidirectional (MatchGroup id (LHsExpr id))
 938   deriving (Typeable)
 939 deriving instance (DataId id) => Data (HsPatSynDir id)