IfaceSyn.hs 71.4 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-}
5

6
{-# LANGUAGE CPP #-}
Ian Lynagh's avatar
Ian Lynagh committed
7

8
module IfaceSyn (
dterei's avatar
dterei committed
9
        module IfaceType,
10

11
        IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..),
12
        IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec,
13
        IfaceExpr(..), IfaceAlt, IfaceLetBndr(..),
dterei's avatar
dterei committed
14 15 16
        IfaceBinding(..), IfaceConAlt(..),
        IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
        IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
17
        IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
18 19 20
        IfaceBang(..),
        IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..),
        IfaceAxBranch(..),
21
        IfaceTyConParent(..),
22

dterei's avatar
dterei committed
23
        -- Misc
24
        ifaceDeclImplicitBndrs, visibleIfConDecls,
25
        ifaceDeclFingerprints,
26

27
        -- Free Names
28
        freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
29

dterei's avatar
dterei committed
30
        -- Pretty printing
31 32 33
        pprIfaceExpr,
        pprIfaceDecl,
        ShowSub(..), ShowHowMuch(..)
34 35 36 37 38
    ) where

#include "HsVersions.h"

import IfaceType
39
import PprCore()            -- Printing DFunArgs
40
import Demand
Simon Marlow's avatar
Simon Marlow committed
41
import Class
dterei's avatar
dterei committed
42
import NameSet
43
import CoAxiom ( BranchIndex, Role )
Simon Marlow's avatar
Simon Marlow committed
44 45 46 47
import Name
import CostCentre
import Literal
import ForeignCall
48
import Annotations( AnnPayload, AnnTarget )
49
import BasicTypes
50 51
import Outputable
import FastString
52
import Module
Peter Wortmann's avatar
Peter Wortmann committed
53
import SrcLoc
54 55
import Fingerprint
import Binary
56
import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue )
57
import HsBinds
Jan Stolarek's avatar
Jan Stolarek committed
58
import TyCon ( Role (..), Injectivity(..) )
59
import StaticFlags (opt_PprStyle_Debug)
Jan Stolarek's avatar
Jan Stolarek committed
60
import Util( filterOut, filterByList )
61
import InstEnv
62
import DataCon (SrcStrictness(..), SrcUnpackedness(..))
63
import Lexeme (isLexSym)
64

65
import Control.Monad
66
import System.IO.Unsafe
67
import Data.Maybe (isJust)
68

69 70
infixl 3 &&&

Austin Seipp's avatar
Austin Seipp committed
71 72 73
{-
************************************************************************
*                                                                      *
74
                    Declarations
Austin Seipp's avatar
Austin Seipp committed
75 76 77
*                                                                      *
************************************************************************
-}
78

79 80 81 82
type IfaceTopBndr = OccName
  -- It's convenient to have an OccName in the IfaceSyn, altough in each
  -- case the namespace is implied by the context. However, having an
  -- OccNames makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints
83 84 85
  -- very convenient.
  --
  -- We don't serialise the namespace onto the disk though; rather we
86 87
  -- drop it when serialising and add it back in when deserialising.

dterei's avatar
dterei committed
88
data IfaceDecl
89
  = IfaceId { ifName      :: IfaceTopBndr,
dterei's avatar
dterei committed
90 91 92 93
              ifType      :: IfaceType,
              ifIdDetails :: IfaceIdDetails,
              ifIdInfo    :: IfaceIdInfo }

94
  | IfaceData { ifName       :: IfaceTopBndr,        -- Type constructor
95
                ifCType      :: Maybe CType,    -- C type for CAPI FFI
dterei's avatar
dterei committed
96
                ifTyVars     :: [IfaceTvBndr],  -- Type variables
97
                ifRoles      :: [Role],         -- Roles
dterei's avatar
dterei committed
98
                ifCtxt       :: IfaceContext,   -- The "stupid theta"
99
                ifCons       :: IfaceConDecls,  -- Includes new/data/data family info
dterei's avatar
dterei committed
100
                ifRec        :: RecFlag,        -- Recursive or not?
101
                ifPromotable :: Bool,           -- Promotable to kind level?
dterei's avatar
dterei committed
102 103
                ifGadtSyntax :: Bool,           -- True <=> declared using
                                                -- GADT syntax
104 105
                ifParent     :: IfaceTyConParent -- The axiom, for a newtype,
                                                 -- or data/newtype family instance
106
    }
107

108 109 110 111 112 113 114 115 116
  | IfaceSynonym { ifName    :: IfaceTopBndr,      -- Type constructor
                   ifTyVars  :: [IfaceTvBndr],     -- Type variables
                   ifRoles   :: [Role],            -- Roles
                   ifSynKind :: IfaceKind,         -- Kind of the *rhs* (not of
                                                   -- the tycon)
                   ifSynRhs  :: IfaceType }

  | IfaceFamily  { ifName    :: IfaceTopBndr,      -- Type constructor
                   ifTyVars  :: [IfaceTvBndr],     -- Type variables
Jan Stolarek's avatar
Jan Stolarek committed
117 118 119
                   ifResVar  :: Maybe IfLclName,   -- Result variable name, used
                                                   -- only for pretty-printing
                                                   -- with --show-iface
120 121
                   ifFamKind :: IfaceKind,         -- Kind of the *rhs* (not of
                                                   -- the tycon)
Jan Stolarek's avatar
Jan Stolarek committed
122 123
                   ifFamFlav :: IfaceFamTyConFlav,
                   ifFamInj  :: Injectivity }      -- injectivity information
124

125
  | IfaceClass { ifCtxt    :: IfaceContext,             -- Superclasses
126 127 128 129
                 ifName    :: IfaceTopBndr,             -- Name of the class TyCon
                 ifTyVars  :: [IfaceTvBndr],            -- Type variables
                 ifRoles   :: [Role],                   -- Roles
                 ifFDs     :: [FunDep FastString],      -- Functional dependencies
130 131 132
                 ifATs     :: [IfaceAT],                -- Associated type families
                 ifSigs    :: [IfaceClassOp],           -- Method signatures
                 ifMinDef  :: BooleanFormula IfLclName, -- Minimal complete definition
133 134
                 ifRec     :: RecFlag                   -- Is newtype/datatype associated
                                                        --   with the class recursive?
135 136
    }

137
  | IfaceAxiom { ifName       :: IfaceTopBndr,        -- Axiom name
138
                 ifTyCon      :: IfaceTyCon,     -- LHS TyCon
139
                 ifRole       :: Role,           -- Role of axiom
140 141
                 ifAxBranches :: [IfaceAxBranch] -- Branches
    }
142

143
  | IfacePatSyn { ifName          :: IfaceTopBndr,           -- Name of the pattern synonym
Gergő Érdi's avatar
Gergő Érdi committed
144
                  ifPatIsInfix    :: Bool,
145 146
                  ifPatMatcher    :: (IfExtName, Bool),
                  ifPatBuilder    :: Maybe (IfExtName, Bool),
147 148
                  -- Everything below is redundant,
                  -- but needed to implement pprIfaceDecl
Gergő Érdi's avatar
Gergő Érdi committed
149 150 151 152
                  ifPatUnivTvs    :: [IfaceTvBndr],
                  ifPatExTvs      :: [IfaceTvBndr],
                  ifPatProvCtxt   :: IfaceContext,
                  ifPatReqCtxt    :: IfaceContext,
153
                  ifPatArgs       :: [IfaceType],
Gergő Érdi's avatar
Gergő Érdi committed
154 155 156
                  ifPatTy         :: IfaceType }


157 158 159 160 161
data IfaceTyConParent
  = IfNoParent
  | IfDataInstance IfExtName
                   IfaceTyCon
                   IfaceTcArgs
162

163
data IfaceFamTyConFlav
164
  = IfaceOpenSynFamilyTyCon
165 166 167
  | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch]))
    -- ^ Name of associated axiom and branches for pretty printing purposes,
    -- or 'Nothing' for an empty closed family without an axiom
168
  | IfaceAbstractClosedSynFamilyTyCon
169
  | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only
170

171
data IfaceClassOp = IfaceClassOp IfaceTopBndr DefMethSpec IfaceType
dterei's avatar
dterei committed
172 173 174
        -- Nothing    => no default method
        -- Just False => ordinary polymorphic default method
        -- Just True  => generic default method
175

176 177 178 179
data IfaceAT = IfaceAT  -- See Class.ClassATItem
                  IfaceDecl          -- The associated type declaration
                  (Maybe IfaceType)  -- Default associated type instance, if any

180

181
-- This is just like CoAxBranch
182
data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars  :: [IfaceTvBndr]
183
                                   , ifaxbLHS     :: IfaceTcArgs
184
                                   , ifaxbRoles   :: [Role]
185 186 187
                                   , ifaxbRHS     :: IfaceType
                                   , ifaxbIncomps :: [BranchIndex] }
                                     -- See Note [Storing compatibility] in CoAxiom
188

189
data IfaceConDecls
190
  = IfAbstractTyCon Bool        -- c.f TyCon.AbstractTyCon
191 192 193
  | IfDataFamTyCon              -- Data family
  | IfDataTyCon [IfaceConDecl]  -- Data type decls
  | IfNewTyCon  IfaceConDecl    -- Newtype decls
194

dterei's avatar
dterei committed
195
data IfaceConDecl
196
  = IfCon {
197
        ifConOcc     :: IfaceTopBndr,                -- Constructor name
dterei's avatar
dterei committed
198 199
        ifConWrapper :: Bool,                   -- True <=> has a wrapper
        ifConInfix   :: Bool,                   -- True <=> declared infix
200 201 202 203 204 205 206

        -- The universal type variables are precisely those
        -- of the type constructor of this data constructor
        -- This is *easy* to guarantee when creating the IfCon
        -- but it's not so easy for the original TyCon/DataCon
        -- So this guarantee holds for IfaceConDecl, but *not* for DataCon

207 208 209 210 211 212 213 214 215 216
        ifConExTvs   :: [IfaceTvBndr],      -- Existential tyvars
        ifConEqSpec  :: IfaceEqSpec,        -- Equality constraints
        ifConCtxt    :: IfaceContext,       -- Non-stupid context
        ifConArgTys  :: [IfaceType],        -- Arg types
        ifConFields  :: [IfaceTopBndr],     -- ...ditto... (field labels)
        ifConStricts :: [IfaceBang],
          -- Empty (meaning all lazy),
          -- or 1-1 corresp with arg tys
          -- See Note [Bangs on imported data constructors] in MkId
        ifConSrcStricts :: [IfaceSrcBang] } -- empty meaning no src stricts
dterei's avatar
dterei committed
217

218
type IfaceEqSpec = [(IfLclName,IfaceType)]
219

220 221 222
-- | This corresponds to an HsImplBang; that is, the final
-- implementation decision about the data constructor arg
data IfaceBang
223 224
  = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion

225 226 227 228
-- | This corresponds to HsSrcBang
data IfaceSrcBang
  = IfSrcBang SrcUnpackedness SrcStrictness

229 230 231 232 233
data IfaceClsInst
  = IfaceClsInst { ifInstCls  :: IfExtName,                -- See comments with
                   ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of ClsInst
                   ifDFun     :: IfExtName,                -- The dfun
                   ifOFlag    :: OverlapFlag,              -- Overlap flag
234
                   ifInstOrph :: IsOrphan }                -- See Note [Orphans] in InstEnv
dterei's avatar
dterei committed
235 236 237 238 239 240
        -- There's always a separate IfaceDecl for the DFun, which gives
        -- its IdInfo with its full type and version number.
        -- The instance declarations taken together have a version number,
        -- and we don't want that to wobble gratuitously
        -- If this instance decl is *used*, we'll record a usage on the dfun;
        -- and if the head does not change it won't be used if it wasn't before
241

242
-- The ifFamInstTys field of IfaceFamInst contains a list of the rough
243
-- match types
244
data IfaceFamInst
245
  = IfaceFamInst { ifFamInstFam      :: IfExtName            -- Family name
246
                 , ifFamInstTys      :: [Maybe IfaceTyCon]   -- See above
247
                 , ifFamInstAxiom    :: IfExtName            -- The axiom
248
                 , ifFamInstOrph     :: IsOrphan             -- Just like IfaceClsInst
dterei's avatar
dterei committed
249
                 }
250

251
data IfaceRule
dterei's avatar
dterei committed
252 253 254 255 256 257 258 259
  = IfaceRule {
        ifRuleName   :: RuleName,
        ifActivation :: Activation,
        ifRuleBndrs  :: [IfaceBndr],    -- Tyvars and term vars
        ifRuleHead   :: IfExtName,      -- Head of lhs
        ifRuleArgs   :: [IfaceExpr],    -- Args of LHS
        ifRuleRhs    :: IfaceExpr,
        ifRuleAuto   :: Bool,
260
        ifRuleOrph   :: IsOrphan   -- Just like IfaceClsInst
261 262
    }

263 264 265
data IfaceAnnotation
  = IfaceAnnotation {
        ifAnnotatedTarget :: IfaceAnnTarget,
266
        ifAnnotatedValue  :: AnnPayload
267 268 269 270
  }

type IfaceAnnTarget = AnnTarget OccName

271
-- Here's a tricky case:
272 273
--   * Compile with -O module A, and B which imports A.f
--   * Change function f in A, and recompile without -O
274
--   * When we read in old A.hi we read in its IdInfo (as a thunk)
dterei's avatar
dterei committed
275 276 277
--      (In earlier GHCs we used to drop IdInfo immediately on reading,
--       but we do not do that now.  Instead it's discarded when the
--       ModIface is read into the various decl pools.)
Gabor Greif's avatar
typo  
Gabor Greif committed
278
--   * The version comparison sees that new (=NoInfo) differs from old (=HasInfo *)
dterei's avatar
dterei committed
279
--      and so gives a new version.
280

281 282 283 284
data IfaceIdInfo
  = NoInfo                      -- When writing interface file without -O
  | HasInfo [IfaceInfoItem]     -- Has info, and here it is

285
data IfaceInfoItem
286 287 288 289 290
  = HsArity         Arity
  | HsStrictness    StrictSig
  | HsInline        InlinePragma
  | HsUnfold        Bool             -- True <=> isStrongLoopBreaker is true
                    IfaceUnfolding   -- See Note [Expose recursive functions]
291
  | HsNoCafRefs
292

293 294 295
-- NB: Specialisations and rules come in separately and are
-- only later attached to the Id.  Partial reason: some are orphans.

dterei's avatar
dterei committed
296
data IfaceUnfolding
297
  = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding
298 299
                                -- Possibly could eliminate the Bool here, the information
                                -- is also in the InlinePragma.
300

dterei's avatar
dterei committed
301
  | IfCompulsory IfaceExpr      -- Only used for default methods, in fact
302

303
  | IfInlineRule Arity          -- INLINE pragmas
dterei's avatar
dterei committed
304 305 306
                 Bool           -- OK to inline even if *un*-saturated
                 Bool           -- OK to inline even if context is boring
                 IfaceExpr
307

308
  | IfDFunUnfold [IfaceBndr] [IfaceExpr]
309

310

311 312 313 314
-- We only serialise the IdDetails of top-level Ids, and even then
-- we only need a very limited selection.  Notably, none of the
-- implicit ones are needed here, because they are not put it
-- interface files
315

316 317 318
data IfaceIdDetails
  = IfVanillaId
  | IfRecSelId IfaceTyCon Bool
319
  | IfDFunId
320

Austin Seipp's avatar
Austin Seipp committed
321
{-
322 323
Note [Versioning of instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
324
See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance#Instances]
325

326

Austin Seipp's avatar
Austin Seipp committed
327 328
************************************************************************
*                                                                      *
329
                Functions over declarations
Austin Seipp's avatar
Austin Seipp committed
330 331 332
*                                                                      *
************************************************************************
-}
333 334 335 336 337 338

visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls (IfAbstractTyCon {}) = []
visibleIfConDecls IfDataFamTyCon       = []
visibleIfConDecls (IfDataTyCon cs)     = cs
visibleIfConDecls (IfNewTyCon c)       = [c]
339

340
ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName]
341 342 343
--  *Excludes* the 'main' name, but *includes* the implicitly-bound names
-- Deeply revolting, because it has to predict what gets bound,
-- especially the question of whether there's a wrapper for a datacon
344
-- See Note [Implicit TyThings] in HscTypes
345

346 347 348 349 350
-- N.B. the set of names returned here *must* match the set of
-- TyThings returned by HscTypes.implicitTyThings, in the sense that
-- TyThing.getOccName should define a bijection between the two lists.
-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
-- The order of the list does not matter.
351
ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}}  = []
352 353

-- Newtype
354
ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ,
355
                              ifCons = IfNewTyCon (
356 357 358
                                        IfCon { ifConOcc = con_occ })})
  =   -- implicit newtype coercion
    (mkNewTyCoOcc tc_occ) : -- JPM: newtype coercions shouldn't be implicit
359
      -- data constructor and worker (newtypes don't have a wrapper)
360 361
    [con_occ, mkDataConWorkerOcc con_occ]

362

363 364 365 366 367
ifaceDeclImplicitBndrs (IfaceData {ifName = _tc_occ,
                              ifCons = IfDataTyCon cons })
  = -- for each data constructor in order,
    --    data constructor, worker, and (possibly) wrapper
    concatMap dc_occs cons
368 369
  where
    dc_occs con_decl
dterei's avatar
dterei committed
370 371 372 373 374 375 376 377 378
        | has_wrapper = [con_occ, work_occ, wrap_occ]
        | otherwise   = [con_occ, work_occ]
        where
          con_occ  = ifConOcc con_decl            -- DataCon namespace
          wrap_occ = mkDataConWrapperOcc con_occ  -- Id namespace
          work_occ = mkDataConWorkerOcc con_occ   -- Id namespace
          has_wrapper = ifConWrapper con_decl     -- This is the reason for
                                                  -- having the ifConWrapper field!

379
ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
dterei's avatar
dterei committed
380
                               ifSigs = sigs, ifATs = ats })
batterseapower's avatar
batterseapower committed
381
  = --   (possibly) newtype coercion
382 383 384 385 386 387
    co_occs ++
    --    data constructor (DataCon namespace)
    --    data worker (Id namespace)
    --    no wrapper (class dictionaries never have a wrapper)
    [dc_occ, dcww_occ] ++
    -- associated types
388
    [ifName at | IfaceAT at _ <- ats ] ++
389
    -- superclass selectors
batterseapower's avatar
batterseapower committed
390
    [mkSuperDictSelOcc n cls_tc_occ | n <- [1..n_ctxt]] ++
391 392 393 394 395
    -- operation selectors
    [op | IfaceClassOp op  _ _ <- sigs]
  where
    n_ctxt = length sc_ctxt
    n_sigs = length sigs
batterseapower's avatar
batterseapower committed
396
    co_occs | is_newtype = [mkNewTyCoOcc cls_tc_occ]
dterei's avatar
dterei committed
397
            | otherwise  = []
398
    dcww_occ = mkDataConWorkerOcc dc_occ
batterseapower's avatar
batterseapower committed
399
    dc_occ = mkClassDataConOcc cls_tc_occ
dterei's avatar
dterei committed
400
    is_newtype = n_sigs + n_ctxt == 1 -- Sigh
401

402
ifaceDeclImplicitBndrs _ = []
403

404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419
-- -----------------------------------------------------------------------------
-- The fingerprints of an IfaceDecl

       -- We better give each name bound by the declaration a
       -- different fingerprint!  So we calculate the fingerprint of
       -- each binder by combining the fingerprint of the whole
       -- declaration with the name of the binder. (#5614, #7215)
ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)]
ifaceDeclFingerprints hash decl
  = (ifName decl, hash) :
    [ (occ, computeFingerprint' (hash,occ))
    | occ <- ifaceDeclImplicitBndrs decl ]
  where
     computeFingerprint' =
       unsafeDupablePerformIO
        . computeFingerprint (panic "ifaceDeclFingerprints")
420

Austin Seipp's avatar
Austin Seipp committed
421 422 423
{-
************************************************************************
*                                                                      *
424
                Expressions
Austin Seipp's avatar
Austin Seipp committed
425 426 427
*                                                                      *
************************************************************************
-}
428 429 430 431 432 433

data IfaceExpr
  = IfaceLcl    IfLclName
  | IfaceExt    IfExtName
  | IfaceType   IfaceType
  | IfaceCo     IfaceCoercion
434
  | IfaceTuple  TupleSort [IfaceExpr]   -- Saturated; type arguments omitted
435
  | IfaceLam    IfaceLamBndr IfaceExpr
436 437
  | IfaceApp    IfaceExpr IfaceExpr
  | IfaceCase   IfaceExpr IfLclName [IfaceAlt]
438
  | IfaceECase  IfaceExpr IfaceType     -- See Note [Empty case alternatives]
439
  | IfaceLet    IfaceBinding  IfaceExpr
440 441 442 443 444 445 446 447
  | IfaceCast   IfaceExpr IfaceCoercion
  | IfaceLit    Literal
  | IfaceFCall  ForeignCall IfaceType
  | IfaceTick   IfaceTickish IfaceExpr    -- from Tick tickish E

data IfaceTickish
  = IfaceHpcTick Module Int                -- from HpcTick x
  | IfaceSCC     CostCentre Bool Bool      -- from ProfNote
Peter Wortmann's avatar
Peter Wortmann committed
448
  | IfaceSource  RealSrcSpan String        -- from SourceNote
449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468
  -- no breakpoints: we never export these into interface files

type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr)
        -- Note: IfLclName, not IfaceBndr (and same with the case binder)
        -- We reconstruct the kind/type of the thing from the context
        -- thus saving bulk in interface files

data IfaceConAlt = IfaceDefault
                 | IfaceDataAlt IfExtName
                 | IfaceLitAlt Literal

data IfaceBinding
  = IfaceNonRec IfaceLetBndr IfaceExpr
  | IfaceRec    [(IfaceLetBndr, IfaceExpr)]

-- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too
-- It's used for *non-top-level* let/rec binders
-- See Note [IdInfo on nested let-bindings]
data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo

Austin Seipp's avatar
Austin Seipp committed
469
{-
470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493
Note [Empty case alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In IfaceSyn an IfaceCase does not record the types of the alternatives,
unlike CorSyn Case.  But we need this type if the alternatives are empty.
Hence IfaceECase.  See Note [Empty case alternatives] in CoreSyn.

Note [Expose recursive functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For supercompilation we want to put *all* unfoldings in the interface
file, even for functions that are recursive (or big).  So we need to
know when an unfolding belongs to a loop-breaker so that we can refrain
from inlining it (except during supercompilation).

Note [IdInfo on nested let-bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Occasionally we want to preserve IdInfo on nested let bindings. The one
that came up was a NOINLINE pragma on a let-binding inside an INLINE
function.  The user (Duncan Coutts) really wanted the NOINLINE control
to cross the separate compilation boundary.

In general we retain all info that is left by CoreTidy.tidyLetBndr, since
that is what is seen by importing module with --make


Austin Seipp's avatar
Austin Seipp committed
494 495
************************************************************************
*                                                                      *
496
              Printing IfaceDecl
Austin Seipp's avatar
Austin Seipp committed
497 498 499
*                                                                      *
************************************************************************
-}
500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522

pprAxBranch :: SDoc -> IfaceAxBranch -> SDoc
-- The TyCon might be local (just an OccName), or this might
-- be a branch for an imported TyCon, so it would be an ExtName
-- So it's easier to take an SDoc here
pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs
                                  , ifaxbLHS = pat_tys
                                  , ifaxbRHS = rhs
                                  , ifaxbIncomps = incomps })
  = hang (pprUserIfaceForAll tvs)
       2 (hang pp_lhs 2 (equals <+> ppr rhs))
    $+$
    nest 2 maybe_incomps
  where
    pp_lhs = hang pp_tc 2 (pprParendIfaceTcArgs pat_tys)
    maybe_incomps = ppUnless (null incomps) $ parens $
                    ptext (sLit "incompatible indices:") <+> ppr incomps

instance Outputable IfaceAnnotation where
  ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value

instance HasOccName IfaceClassOp where
  occName (IfaceClassOp n _ _) = n
523

524 525
instance HasOccName IfaceConDecl where
  occName = ifConOcc
526

527 528 529
instance HasOccName IfaceDecl where
  occName = ifName

530
instance Outputable IfaceDecl where
531 532
  ppr = pprIfaceDecl showAll

533 534 535 536 537 538 539 540 541
{-
Note [Minimal complete definition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The minimal complete definition should only be included if a complete
class definition is shown. Since the minimal complete definition is
anonymous we can't reuse the same mechanism that is used for the
filtering of method signatures. Instead we just check if anything at all is
filtered and hide it in that case.
-}

542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560
data ShowSub
  = ShowSub
      { ss_ppr_bndr :: OccName -> SDoc  -- Pretty-printer for binders in IfaceDecl
                                        -- See Note [Printing IfaceDecl binders]
      , ss_how_much :: ShowHowMuch }

data ShowHowMuch
  = ShowHeader   -- Header information only, not rhs
  | ShowSome [OccName]    -- []     <=> Print all sub-components
                          -- (n:ns) <=> print sub-component 'n' with ShowSub=ns
                          --            elide other sub-components to "..."
                          -- May 14: the list is max 1 element long at the moment
  | ShowIface    -- Everything including GHC-internal information (used in --show-iface)

showAll :: ShowSub
showAll = ShowSub { ss_how_much = ShowIface, ss_ppr_bndr = ppr }

ppShowIface :: ShowSub -> SDoc -> SDoc
ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc
561
ppShowIface _                                     _   = Outputable.empty
562

563 564 565 566 567 568
-- show if all sub-components or the complete interface is shown
ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- Note [Minimal complete definition]
ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] }) doc = doc
ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc
ppShowAllSubs _                                      _   = Outputable.empty

569
ppShowRhs :: ShowSub -> SDoc -> SDoc
570
ppShowRhs (ShowSub { ss_how_much = ShowHeader }) _   = Outputable.empty
571 572 573 574 575 576
ppShowRhs _                                      doc = doc

showSub :: HasOccName n => ShowSub -> n -> Bool
showSub (ShowSub { ss_how_much = ShowHeader })     _     = False
showSub (ShowSub { ss_how_much = ShowSome (n:_) }) thing = n == occName thing
showSub (ShowSub { ss_how_much = _ })              _     = True
577

Austin Seipp's avatar
Austin Seipp committed
578
{-
579 580 581 582 583 584 585
Note [Printing IfaceDecl binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The binders in an IfaceDecl are just OccNames, so we don't know what module they
come from.  But when we pretty-print a TyThing by converting to an IfaceDecl
(see PprTyThing), the TyThing may come from some other module so we really need
the module qualifier.  We solve this by passing in a pretty-printer for the
binders.
586

587 588
When printing an interface file (--show-iface), we want to print
everything unqualified, so we can just print the OccName directly.
Austin Seipp's avatar
Austin Seipp committed
589
-}
590 591 592 593 594 595 596 597 598 599 600 601 602 603 604

ppr_trim :: [Maybe SDoc] -> [SDoc]
-- Collapse a group of Nothings to a single "..."
ppr_trim xs
  = snd (foldr go (False, []) xs)
  where
    go (Just doc) (_,     so_far) = (False, doc : so_far)
    go Nothing    (True,  so_far) = (True, so_far)
    go Nothing    (False, so_far) = (True, ptext (sLit "...") : so_far)

isIfaceDataInstance :: IfaceTyConParent -> Bool
isIfaceDataInstance IfNoParent = False
isIfaceDataInstance _          = True

pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc
605 606
-- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi
--     See Note [Pretty-printing TyThings] in PprTyThing
607
pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
608
                             ifCtxt = context, ifTyVars = tc_tyvars,
609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629
                             ifRoles = roles, ifCons = condecls,
                             ifParent = parent, ifRec = isrec,
                             ifGadtSyntax = gadt,
                             ifPromotable = is_prom })

  | gadt_style = vcat [ pp_roles
                      , pp_nd <+> pp_lhs <+> pp_where
                      , nest 2 (vcat pp_cons)
                      , nest 2 $ ppShowIface ss pp_extra ]
  | otherwise  = vcat [ pp_roles
                      , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons)
                      , nest 2 $ ppShowIface ss pp_extra ]
  where
    is_data_instance = isIfaceDataInstance parent

    gadt_style = gadt || any (not . isVanillaIfaceConDecl) cons
    cons       = visibleIfConDecls condecls
    pp_where   = ppWhen (gadt_style && not (null cons)) $ ptext (sLit "where")
    pp_cons    = ppr_trim (map show_con cons) :: [SDoc]

    pp_lhs = case parent of
630
               IfNoParent -> pprIfaceDeclHead context ss tycon tc_tyvars
631 632 633
               _          -> ptext (sLit "instance") <+> pprIfaceTyConParent parent

    pp_roles
634
      | is_data_instance = Outputable.empty
635
      | otherwise        = pprRoles (== Representational) (pprPrefixIfDeclBndr ss tycon)
636
                                    tc_tyvars roles
637 638 639
            -- Don't display roles for data family instances (yet)
            -- See discussion on Trac #8672.

640
    add_bars []     = Outputable.empty
641 642 643 644 645 646 647
    add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs)

    ok_con dc = showSub ss dc || any (showSub ss) (ifConFields dc)

    show_con dc
      | ok_con dc = Just $ pprIfaceConDecl ss gadt_style mk_user_con_res_ty dc
      | otherwise = Nothing
648

649 650 651 652 653 654 655
    mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc)
    -- See Note [Result type of a data family GADT]
    mk_user_con_res_ty eq_spec
      | IfDataInstance _ tc tys <- parent
      = (con_univ_tvs, pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys)))
      | otherwise
      = (con_univ_tvs, sdocWithDynFlags (ppr_tc_app gadt_subst))
656
      where
657 658 659
        gadt_subst = mkFsEnv eq_spec
        done_univ_tv (tv,_) = isJust (lookupFsEnv gadt_subst tv)
        con_univ_tvs = filterOut done_univ_tv tc_tyvars
660

661 662 663 664
    ppr_tc_app gadt_subst dflags
       = pprPrefixIfDeclBndr ss tycon
         <+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv)
                 | (tv,_kind) <- stripIfaceKindVars dflags tc_tyvars ]
665 666 667 668 669 670

    pp_nd = case condecls of
              IfAbstractTyCon d -> ptext (sLit "abstract") <> ppShowIface ss (parens (ppr d))
              IfDataFamTyCon    -> ptext (sLit "data family")
              IfDataTyCon _     -> ptext (sLit "data")
              IfNewTyCon _      -> ptext (sLit "newtype")
671

672 673 674
    pp_extra = vcat [pprCType ctype, pprRec isrec, pp_prom]

    pp_prom | is_prom   = ptext (sLit "Promotable")
675
            | otherwise = Outputable.empty
676 677 678 679 680


pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
                            , ifCtxt   = context, ifName  = clas
                            , ifTyVars = tyvars,  ifRoles = roles
681
                            , ifFDs    = fds, ifMinDef = minDef })
682
  = vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) tyvars roles
683 684
         , ptext (sLit "class") <+> pprIfaceDeclHead context ss clas tyvars
                                <+> pprFundeps fds <+> pp_where
685 686
         , nest 2 (vcat [ vcat asocs, vcat dsigs, pprec
                        , ppShowAllSubs ss (pprMinDef minDef)])]
687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703
    where
      pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (ptext (sLit "where"))

      asocs = ppr_trim $ map maybeShowAssoc ats
      dsigs = ppr_trim $ map maybeShowSig sigs
      pprec = ppShowIface ss (pprRec isrec)

      maybeShowAssoc :: IfaceAT -> Maybe SDoc
      maybeShowAssoc asc@(IfaceAT d _)
        | showSub ss d = Just $ pprIfaceAT ss asc
        | otherwise    = Nothing

      maybeShowSig :: IfaceClassOp -> Maybe SDoc
      maybeShowSig sg
        | showSub ss sg = Just $  pprIfaceClassOp ss sg
        | otherwise     = Nothing

704 705 706 707 708 709 710
      pprMinDef :: BooleanFormula IfLclName -> SDoc
      pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions
        ptext (sLit "{-# MINIMAL") <+>
        pprBooleanFormula
          (\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+>
        ptext (sLit "#-}")

711 712 713
pprIfaceDecl ss (IfaceSynonym { ifName   = tc
                              , ifTyVars = tv
                              , ifSynRhs = mono_ty })
714 715
  = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] ss tc tv <+> equals)
       2 (sep [pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau])
716
  where
717
    (tvs, theta, tau) = splitIfaceSigmaTy mono_ty
718

719
pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
Jan Stolarek's avatar
Jan Stolarek committed
720 721 722 723
                             , ifFamFlav = rhs, ifFamKind = kind
                             , ifResVar = res_var, ifFamInj = inj })
  = vcat [ hang (text "type family" <+> pprIfaceDeclHead [] ss tycon tyvars)
              2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs))
724
         , ppShowRhs ss (nest 2 (pp_branches rhs)) ]
725
  where
Jan Stolarek's avatar
Jan Stolarek committed
726 727 728 729 730 731 732 733 734 735
    pp_inj Nothing    _   = dcolon <+> ppr kind
    pp_inj (Just res) inj
       | Injective injectivity <- inj = hsep [ equals, ppr res, dcolon, ppr kind
                                             , pp_inj_cond res injectivity]
       | otherwise = hsep [ equals, ppr res, dcolon, ppr kind ]

    pp_inj_cond res inj = case filterByList inj tyvars of
       []  -> empty
       tvs -> hsep [text "|", ppr res, text "->", interppSP (map fst tvs)]

736 737 738 739 740 741 742 743 744 745
    pp_rhs IfaceOpenSynFamilyTyCon
      = ppShowIface ss (ptext (sLit "open"))
    pp_rhs IfaceAbstractClosedSynFamilyTyCon
      = ppShowIface ss (ptext (sLit "closed, abstract"))
    pp_rhs (IfaceClosedSynFamilyTyCon _)
      = ptext (sLit "where")
    pp_rhs IfaceBuiltInSynFamTyCon
      = ppShowIface ss (ptext (sLit "built-in"))

    pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs)))
746
      = vcat (map (pprAxBranch (pprPrefixIfDeclBndr ss tycon)) brs)
747
        $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax)
748
    pp_branches _ = Outputable.empty
749

750
pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatBuilder = builder,
751
                              ifPatUnivTvs = univ_tvs, ifPatExTvs = ex_tvs,
752
                              ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
753 754 755 756 757 758 759
                              ifPatArgs = arg_tys,
                              ifPatTy = pat_ty} )
  = pprPatSynSig name is_bidirectional
                 (pprUserIfaceForAll tvs)
                 (pprIfaceContextMaybe prov_ctxt)
                 (pprIfaceContextMaybe req_ctxt)
                 (pprIfaceType ty)
Gergő Érdi's avatar
Gergő Érdi committed
760
  where
761
    is_bidirectional = isJust builder
762 763
    tvs = univ_tvs ++ ex_tvs
    ty = foldr IfaceFunTy pat_ty arg_tys
Gergő Érdi's avatar
Gergő Érdi committed
764

765 766
pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty,
                              ifIdDetails = details, ifIdInfo = info })
767
  = vcat [ hang (pprPrefixIfDeclBndr ss var <+> dcolon)
768 769
              2 (pprIfaceSigmaType ty)
         , ppShowIface ss (ppr details)
770
         , ppShowIface ss (ppr info) ]
771 772 773 774 775 776 777

pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon
                           , ifAxBranches = branches })
  = hang (ptext (sLit "axiom") <+> ppr name <> dcolon)
       2 (vcat $ map (pprAxBranch (ppr tycon)) branches)


778
pprCType :: Maybe CType -> SDoc
779
pprCType Nothing      = Outputable.empty
780 781
pprCType (Just cType) = ptext (sLit "C type:") <+> ppr cType

782 783 784 785 786 787 788 789
-- if, for each role, suppress_if role is True, then suppress the role
-- output
pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTvBndr] -> [Role] -> SDoc
pprRoles suppress_if tyCon tyvars roles
  = sdocWithDynFlags $ \dflags ->
      let froles = suppressIfaceKinds dflags tyvars roles
      in ppUnless (all suppress_if roles || null froles) $
         ptext (sLit "type role") <+> tyCon <+> hsep (map ppr froles)
790

Ian Lynagh's avatar
Ian Lynagh committed
791
pprRec :: RecFlag -> SDoc
792
pprRec NonRecursive = Outputable.empty
793
pprRec Recursive    = ptext (sLit "RecFlag: Recursive")
Ian Lynagh's avatar
Ian Lynagh committed
794

795
pprInfixIfDeclBndr, pprPrefixIfDeclBndr :: ShowSub -> OccName -> SDoc
796
pprInfixIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) occ
797 798 799
  = pprInfixVar (isSymOcc occ) (ppr_bndr occ)
pprPrefixIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) occ
  = parenSymOcc occ (ppr_bndr occ)
800

801
instance Outputable IfaceClassOp where
802 803 804 805
   ppr = pprIfaceClassOp showAll

pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc
pprIfaceClassOp ss (IfaceClassOp n dm ty) = hang opHdr 2 (pprIfaceSigmaType ty)
806 807
  where opHdr = pprPrefixIfDeclBndr ss n
                <+> ppShowIface ss (ppr dm) <+> dcolon
808

809
instance Outputable IfaceAT where
810 811 812
   ppr = pprIfaceAT showAll

pprIfaceAT :: ShowSub -> IfaceAT -> SDoc
813
pprIfaceAT ss (IfaceAT d mb_def)
814
  = vcat [ pprIfaceDecl ss d
815
         , case mb_def of
816
              Nothing  -> Outputable.empty
817 818
              Just rhs -> nest 2 $
                          ptext (sLit "Default:") <+> ppr rhs ]
819 820 821 822 823 824

instance Outputable IfaceTyConParent where
  ppr p = pprIfaceTyConParent p

pprIfaceTyConParent :: IfaceTyConParent -> SDoc
pprIfaceTyConParent IfNoParent
825
  = Outputable.empty
826 827 828 829 830 831
pprIfaceTyConParent (IfDataInstance _ tc tys)
  = sdocWithDynFlags $ \dflags ->
    let ftys = stripKindArgs dflags tys
    in pprIfaceTypeApp tc ftys

pprIfaceDeclHead :: IfaceContext -> ShowSub -> OccName -> [IfaceTvBndr] -> SDoc
832
pprIfaceDeclHead context ss tc_occ tv_bndrs
833
  = sdocWithDynFlags $ \ dflags ->
834 835 836
    sep [ pprIfaceContextArr context
        , pprPrefixIfDeclBndr ss tc_occ
          <+> pprIfaceTvBndrs (stripIfaceKindVars dflags tv_bndrs) ]
837 838 839 840 841 842 843 844

isVanillaIfaceConDecl :: IfaceConDecl -> Bool
isVanillaIfaceConDecl (IfCon { ifConExTvs  = ex_tvs
                             , ifConEqSpec = eq_spec
                             , ifConCtxt   = ctxt })
  = (null ex_tvs) && (null eq_spec) && (null ctxt)

pprIfaceConDecl :: ShowSub -> Bool
845
                -> (IfaceEqSpec -> ([IfaceTvBndr], SDoc))
846 847 848
                -> IfaceConDecl -> SDoc
pprIfaceConDecl ss gadt_style mk_user_con_res_ty
        (IfCon { ifConOcc = name, ifConInfix = is_infix,
849
                 ifConExTvs = ex_tvs,
dterei's avatar
dterei committed
850
                 ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
851
                 ifConStricts = stricts, ifConFields = labels })
852
  | gadt_style = pp_prefix_con <+> dcolon <+> ppr_ty
853
  | otherwise  = ppr_fields tys_w_strs
854
  where
855 856
    tys_w_strs :: [(IfaceBang, IfaceType)]
    tys_w_strs = zip stricts arg_tys
857
    pp_prefix_con = pprPrefixIfDeclBndr ss name
858

859 860
    (univ_tvs, pp_res_ty) = mk_user_con_res_ty eq_spec
    ppr_ty = pprIfaceForAllPart (univ_tvs ++ ex_tvs) ctxt pp_tau
dterei's avatar
dterei committed
861 862 863

        -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
        -- because we don't have a Name for the tycon, only an OccName
864
    pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of
dterei's avatar
dterei committed
865 866
                (t:ts) -> fsep (t : map (arrow <+>) ts)
                []     -> panic "pp_con_taus"
867

868 869 870 871 872 873 874 875 876 877
    ppr_bang IfNoBang = ppWhen opt_PprStyle_Debug $ char '_'
    ppr_bang IfStrict = char '!'
    ppr_bang IfUnpack = ptext (sLit "{-# UNPACK #-}")
    ppr_bang (IfUnpackCo co) = ptext (sLit "! {-# UNPACK #-}") <>
                               pprParendIfaceCoercion co

    pprParendBangTy (bang, ty) = ppr_bang bang <> pprParendIfaceType ty
    pprBangTy       (bang, ty) = ppr_bang bang <> ppr ty

    maybe_show_label (lbl,bty)
878
      | showSub ss lbl = Just (pprPrefixIfDeclBndr ss lbl <+> dcolon <+> pprBangTy bty)
879 880 881 882
      | otherwise      = Nothing

    ppr_fields [ty1, ty2]
      | is_infix && null labels
883
      = sep [pprParendBangTy ty1, pprInfixIfDeclBndr ss name, pprParendBangTy ty2]
884
    ppr_fields fields
885 886
      | n