IfaceSyn.hs 68.8 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
        IfaceBang(..), IfaceAxBranch(..),
19
        IfaceTyConParent(..),
20

dterei's avatar
dterei committed
21
        -- Misc
22
        ifaceDeclImplicitBndrs, visibleIfConDecls,
23
        ifaceDeclFingerprints,
24

25
        -- Free Names
26
        freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
27

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

#include "HsVersions.h"

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

61
import Control.Monad
62
import System.IO.Unsafe
63
import Data.Maybe (isJust)
64

65 66
infixl 3 &&&

Austin Seipp's avatar
Austin Seipp committed
67 68 69
{-
************************************************************************
*                                                                      *
70
                    Declarations
Austin Seipp's avatar
Austin Seipp committed
71 72 73
*                                                                      *
************************************************************************
-}
74

75 76 77 78
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
79 80 81
  -- very convenient.
  --
  -- We don't serialise the namespace onto the disk though; rather we
82 83
  -- drop it when serialising and add it back in when deserialising.

dterei's avatar
dterei committed
84
data IfaceDecl
85
  = IfaceId { ifName      :: IfaceTopBndr,
dterei's avatar
dterei committed
86 87 88 89
              ifType      :: IfaceType,
              ifIdDetails :: IfaceIdDetails,
              ifIdInfo    :: IfaceIdInfo }

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

104 105 106 107 108 109 110 111 112 113 114 115
  | 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
                   ifFamKind :: IfaceKind,         -- Kind of the *rhs* (not of
                                                   -- the tycon)
                   ifFamFlav :: IfaceFamTyConFlav }
116

117
  | IfaceClass { ifCtxt    :: IfaceContext,             -- Superclasses
118 119 120 121
                 ifName    :: IfaceTopBndr,             -- Name of the class TyCon
                 ifTyVars  :: [IfaceTvBndr],            -- Type variables
                 ifRoles   :: [Role],                   -- Roles
                 ifFDs     :: [FunDep FastString],      -- Functional dependencies
122 123 124
                 ifATs     :: [IfaceAT],                -- Associated type families
                 ifSigs    :: [IfaceClassOp],           -- Method signatures
                 ifMinDef  :: BooleanFormula IfLclName, -- Minimal complete definition
125 126
                 ifRec     :: RecFlag                   -- Is newtype/datatype associated
                                                        --   with the class recursive?
127 128
    }

129
  | IfaceAxiom { ifName       :: IfaceTopBndr,        -- Axiom name
130
                 ifTyCon      :: IfaceTyCon,     -- LHS TyCon
131
                 ifRole       :: Role,           -- Role of axiom
132 133
                 ifAxBranches :: [IfaceAxBranch] -- Branches
    }
134

135
  | IfacePatSyn { ifName          :: IfaceTopBndr,           -- Name of the pattern synonym
Gergő Érdi's avatar
Gergő Érdi committed
136
                  ifPatIsInfix    :: Bool,
137 138
                  ifPatMatcher    :: (IfExtName, Bool),
                  ifPatBuilder    :: Maybe (IfExtName, Bool),
139 140
                  -- Everything below is redundant,
                  -- but needed to implement pprIfaceDecl
Gergő Érdi's avatar
Gergő Érdi committed
141 142 143 144
                  ifPatUnivTvs    :: [IfaceTvBndr],
                  ifPatExTvs      :: [IfaceTvBndr],
                  ifPatProvCtxt   :: IfaceContext,
                  ifPatReqCtxt    :: IfaceContext,
145
                  ifPatArgs       :: [IfaceType],
Gergő Érdi's avatar
Gergő Érdi committed
146 147 148
                  ifPatTy         :: IfaceType }


149 150 151 152 153
data IfaceTyConParent
  = IfNoParent
  | IfDataInstance IfExtName
                   IfaceTyCon
                   IfaceTcArgs
154

155
data IfaceFamTyConFlav
156
  = IfaceOpenSynFamilyTyCon
157 158
  | IfaceClosedSynFamilyTyCon IfExtName       -- name of associated axiom
                              [IfaceAxBranch] -- for pretty printing purposes only
159
  | IfaceAbstractClosedSynFamilyTyCon
160
  | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only
161

162
data IfaceClassOp = IfaceClassOp IfaceTopBndr DefMethSpec IfaceType
dterei's avatar
dterei committed
163 164 165
        -- Nothing    => no default method
        -- Just False => ordinary polymorphic default method
        -- Just True  => generic default method
166

167 168 169 170
data IfaceAT = IfaceAT  -- See Class.ClassATItem
                  IfaceDecl          -- The associated type declaration
                  (Maybe IfaceType)  -- Default associated type instance, if any

171

172
-- This is just like CoAxBranch
173
data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars  :: [IfaceTvBndr]
174
                                   , ifaxbLHS     :: IfaceTcArgs
175
                                   , ifaxbRoles   :: [Role]
176 177 178
                                   , ifaxbRHS     :: IfaceType
                                   , ifaxbIncomps :: [BranchIndex] }
                                     -- See Note [Storing compatibility] in CoAxiom
179

180
data IfaceConDecls
181
  = IfAbstractTyCon Bool        -- c.f TyCon.AbstractTyCon
182 183 184
  | IfDataFamTyCon              -- Data family
  | IfDataTyCon [IfaceConDecl]  -- Data type decls
  | IfNewTyCon  IfaceConDecl    -- Newtype decls
185

dterei's avatar
dterei committed
186
data IfaceConDecl
187
  = IfCon {
188
        ifConOcc     :: IfaceTopBndr,                -- Constructor name
dterei's avatar
dterei committed
189 190
        ifConWrapper :: Bool,                   -- True <=> has a wrapper
        ifConInfix   :: Bool,                   -- True <=> declared infix
191 192 193 194 195 196 197

        -- 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

dterei's avatar
dterei committed
198
        ifConExTvs   :: [IfaceTvBndr],          -- Existential tyvars
199
        ifConEqSpec  :: IfaceEqSpec,            -- Equality constraints
dterei's avatar
dterei committed
200 201
        ifConCtxt    :: IfaceContext,           -- Non-stupid context
        ifConArgTys  :: [IfaceType],            -- Arg types
202
        ifConFields  :: [IfaceTopBndr],         -- ...ditto... (field labels)
203
        ifConStricts :: [IfaceBang]}            -- Empty (meaning all lazy),
dterei's avatar
dterei committed
204 205
                                                -- or 1-1 corresp with arg tys

206
type IfaceEqSpec = [(IfLclName,IfaceType)]
207

Simon Peyton Jones's avatar
Simon Peyton Jones committed
208 209
data IfaceBang  -- This corresponds to an HsImplBang; that is, the final
                -- implementation decision about the data constructor arg
210 211
  = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion

212 213 214 215 216
data IfaceClsInst
  = IfaceClsInst { ifInstCls  :: IfExtName,                -- See comments with
                   ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of ClsInst
                   ifDFun     :: IfExtName,                -- The dfun
                   ifOFlag    :: OverlapFlag,              -- Overlap flag
217
                   ifInstOrph :: IsOrphan }                -- See Note [Orphans] in InstEnv
dterei's avatar
dterei committed
218 219 220 221 222 223
        -- 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
224

225
-- The ifFamInstTys field of IfaceFamInst contains a list of the rough
226
-- match types
227
data IfaceFamInst
228
  = IfaceFamInst { ifFamInstFam      :: IfExtName            -- Family name
229
                 , ifFamInstTys      :: [Maybe IfaceTyCon]   -- See above
230
                 , ifFamInstAxiom    :: IfExtName            -- The axiom
231
                 , ifFamInstOrph     :: IsOrphan             -- Just like IfaceClsInst
dterei's avatar
dterei committed
232
                 }
233

234
data IfaceRule
dterei's avatar
dterei committed
235 236 237 238 239 240 241 242
  = 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,
243
        ifRuleOrph   :: IsOrphan   -- Just like IfaceClsInst
244 245
    }

246 247 248
data IfaceAnnotation
  = IfaceAnnotation {
        ifAnnotatedTarget :: IfaceAnnTarget,
249
        ifAnnotatedValue  :: AnnPayload
250 251 252 253
  }

type IfaceAnnTarget = AnnTarget OccName

254
-- Here's a tricky case:
255 256
--   * Compile with -O module A, and B which imports A.f
--   * Change function f in A, and recompile without -O
257
--   * When we read in old A.hi we read in its IdInfo (as a thunk)
dterei's avatar
dterei committed
258 259 260
--      (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
261
--   * The version comparison sees that new (=NoInfo) differs from old (=HasInfo *)
dterei's avatar
dterei committed
262
--      and so gives a new version.
263

264 265 266 267
data IfaceIdInfo
  = NoInfo                      -- When writing interface file without -O
  | HasInfo [IfaceInfoItem]     -- Has info, and here it is

268
data IfaceInfoItem
269 270 271 272 273
  = HsArity         Arity
  | HsStrictness    StrictSig
  | HsInline        InlinePragma
  | HsUnfold        Bool             -- True <=> isStrongLoopBreaker is true
                    IfaceUnfolding   -- See Note [Expose recursive functions]
274
  | HsNoCafRefs
275

276 277 278
-- 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
279
data IfaceUnfolding
280
  = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding
281 282
                                -- Possibly could eliminate the Bool here, the information
                                -- is also in the InlinePragma.
283

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

286
  | IfInlineRule Arity          -- INLINE pragmas
dterei's avatar
dterei committed
287 288 289
                 Bool           -- OK to inline even if *un*-saturated
                 Bool           -- OK to inline even if context is boring
                 IfaceExpr
290

291
  | IfDFunUnfold [IfaceBndr] [IfaceExpr]
292

293

294 295 296 297
-- 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
298

299 300 301
data IfaceIdDetails
  = IfVanillaId
  | IfRecSelId IfaceTyCon Bool
302
  | IfDFunId
303

Austin Seipp's avatar
Austin Seipp committed
304
{-
305 306
Note [Versioning of instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
307
See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance#Instances]
308

309

Austin Seipp's avatar
Austin Seipp committed
310 311
************************************************************************
*                                                                      *
312
                Functions over declarations
Austin Seipp's avatar
Austin Seipp committed
313 314 315
*                                                                      *
************************************************************************
-}
316 317 318 319 320 321

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

323
ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName]
324 325 326
--  *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
327
-- See Note [Implicit TyThings] in HscTypes
328

329 330 331 332 333
-- 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.
334
ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}}  = []
335 336

-- Newtype
337
ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ,
338
                              ifCons = IfNewTyCon (
339 340 341
                                        IfCon { ifConOcc = con_occ })})
  =   -- implicit newtype coercion
    (mkNewTyCoOcc tc_occ) : -- JPM: newtype coercions shouldn't be implicit
342
      -- data constructor and worker (newtypes don't have a wrapper)
343 344
    [con_occ, mkDataConWorkerOcc con_occ]

345

346 347 348 349 350
ifaceDeclImplicitBndrs (IfaceData {ifName = _tc_occ,
                              ifCons = IfDataTyCon cons })
  = -- for each data constructor in order,
    --    data constructor, worker, and (possibly) wrapper
    concatMap dc_occs cons
351 352
  where
    dc_occs con_decl
dterei's avatar
dterei committed
353 354 355 356 357 358 359 360 361
        | 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!

362
ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
dterei's avatar
dterei committed
363
                               ifSigs = sigs, ifATs = ats })
batterseapower's avatar
batterseapower committed
364
  = --   (possibly) newtype coercion
365 366 367 368 369 370
    co_occs ++
    --    data constructor (DataCon namespace)
    --    data worker (Id namespace)
    --    no wrapper (class dictionaries never have a wrapper)
    [dc_occ, dcww_occ] ++
    -- associated types
371
    [ifName at | IfaceAT at _ <- ats ] ++
372
    -- superclass selectors
batterseapower's avatar
batterseapower committed
373
    [mkSuperDictSelOcc n cls_tc_occ | n <- [1..n_ctxt]] ++
374 375 376 377 378
    -- operation selectors
    [op | IfaceClassOp op  _ _ <- sigs]
  where
    n_ctxt = length sc_ctxt
    n_sigs = length sigs
batterseapower's avatar
batterseapower committed
379
    co_occs | is_newtype = [mkNewTyCoOcc cls_tc_occ]
dterei's avatar
dterei committed
380
            | otherwise  = []
381
    dcww_occ = mkDataConWorkerOcc dc_occ
batterseapower's avatar
batterseapower committed
382
    dc_occ = mkClassDataConOcc cls_tc_occ
dterei's avatar
dterei committed
383
    is_newtype = n_sigs + n_ctxt == 1 -- Sigh
384

385
ifaceDeclImplicitBndrs _ = []
386

387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402
-- -----------------------------------------------------------------------------
-- 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")
403

Austin Seipp's avatar
Austin Seipp committed
404 405 406
{-
************************************************************************
*                                                                      *
407
                Expressions
Austin Seipp's avatar
Austin Seipp committed
408 409 410
*                                                                      *
************************************************************************
-}
411 412 413 414 415 416

data IfaceExpr
  = IfaceLcl    IfLclName
  | IfaceExt    IfExtName
  | IfaceType   IfaceType
  | IfaceCo     IfaceCoercion
417
  | IfaceTuple  TupleSort [IfaceExpr]   -- Saturated; type arguments omitted
418
  | IfaceLam    IfaceLamBndr IfaceExpr
419 420
  | IfaceApp    IfaceExpr IfaceExpr
  | IfaceCase   IfaceExpr IfLclName [IfaceAlt]
421
  | IfaceECase  IfaceExpr IfaceType     -- See Note [Empty case alternatives]
422
  | IfaceLet    IfaceBinding  IfaceExpr
423 424 425 426 427 428 429 430
  | 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
431
  | IfaceSource  RealSrcSpan String        -- from SourceNote
432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451
  -- 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
452
{-
453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476
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
477 478
************************************************************************
*                                                                      *
479
              Printing IfaceDecl
Austin Seipp's avatar
Austin Seipp committed
480 481 482
*                                                                      *
************************************************************************
-}
483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505

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
506

507 508
instance HasOccName IfaceConDecl where
  occName = ifConOcc
509

510 511 512
instance HasOccName IfaceDecl where
  occName = ifName

513
instance Outputable IfaceDecl where
514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534
  ppr = pprIfaceDecl showAll

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
535
ppShowIface _                                     _   = Outputable.empty
536 537

ppShowRhs :: ShowSub -> SDoc -> SDoc
538
ppShowRhs (ShowSub { ss_how_much = ShowHeader }) _   = Outputable.empty
539 540 541 542 543 544
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
545

Austin Seipp's avatar
Austin Seipp committed
546
{-
547 548 549 550 551 552 553
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.
554

555 556
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
557
-}
558 559 560 561 562 563 564 565 566 567 568 569 570 571 572

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
573 574
-- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi
--     See Note [Pretty-printing TyThings] in PprTyThing
575
pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
576
                             ifCtxt = context, ifTyVars = tc_tyvars,
577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597
                             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
598
               IfNoParent -> pprIfaceDeclHead context ss tycon tc_tyvars
599 600 601
               _          -> ptext (sLit "instance") <+> pprIfaceTyConParent parent

    pp_roles
602
      | is_data_instance = Outputable.empty
603
      | otherwise        = pprRoles (== Representational) (pprPrefixIfDeclBndr ss tycon)
604
                                    tc_tyvars roles
605 606 607
            -- Don't display roles for data family instances (yet)
            -- See discussion on Trac #8672.

608
    add_bars []     = Outputable.empty
609 610 611 612 613 614 615
    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
616

617 618 619 620 621 622 623
    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))
624
      where
625 626 627
        gadt_subst = mkFsEnv eq_spec
        done_univ_tv (tv,_) = isJust (lookupFsEnv gadt_subst tv)
        con_univ_tvs = filterOut done_univ_tv tc_tyvars
628

629 630 631 632
    ppr_tc_app gadt_subst dflags
       = pprPrefixIfDeclBndr ss tycon
         <+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv)
                 | (tv,_kind) <- stripIfaceKindVars dflags tc_tyvars ]
633 634 635 636 637 638

    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")
639

640 641 642
    pp_extra = vcat [pprCType ctype, pprRec isrec, pp_prom]

    pp_prom | is_prom   = ptext (sLit "Promotable")
643
            | otherwise = Outputable.empty
644 645 646 647 648 649


pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
                            , ifCtxt   = context, ifName  = clas
                            , ifTyVars = tyvars,  ifRoles = roles
                            , ifFDs    = fds })
650
  = vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) tyvars roles
651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670
         , ptext (sLit "class") <+> pprIfaceDeclHead context ss clas tyvars
                                <+> pprFundeps fds <+> pp_where
         , nest 2 (vcat [vcat asocs, vcat dsigs, pprec])]
    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

671 672 673
pprIfaceDecl ss (IfaceSynonym { ifName   = tc
                              , ifTyVars = tv
                              , ifSynRhs = mono_ty })
674 675
  = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] ss tc tv <+> equals)
       2 (sep [pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau])
676
  where
677
    (tvs, theta, tau) = splitIfaceSigmaTy mono_ty
678

679 680
pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
                             , ifFamFlav = rhs, ifFamKind = kind })
681 682 683
  = vcat [ hang (text "type family" <+> pprIfaceDeclHead [] ss tycon tyvars <+> dcolon)
              2 (ppr kind <+> ppShowRhs ss (pp_rhs rhs))
         , ppShowRhs ss (nest 2 (pp_branches rhs)) ]
684
  where
685 686 687
    pp_rhs IfaceOpenSynFamilyTyCon             = ppShowIface ss (ptext (sLit "open"))
    pp_rhs IfaceAbstractClosedSynFamilyTyCon   = ppShowIface ss (ptext (sLit "closed, abstract"))
    pp_rhs (IfaceClosedSynFamilyTyCon _ (_:_)) = ptext (sLit "where")
688
    pp_rhs IfaceBuiltInSynFamTyCon = ppShowIface ss (ptext (sLit "built-in"))
689 690 691
    pp_rhs _ = panic "pprIfaceDecl syn"

    pp_branches (IfaceClosedSynFamilyTyCon ax brs)
692
      = vcat (map (pprAxBranch (pprPrefixIfDeclBndr ss tycon)) brs)
693
        $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax)
694
    pp_branches _ = Outputable.empty
695

696
pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatBuilder = builder,
697
                              ifPatUnivTvs = univ_tvs, ifPatExTvs = ex_tvs,
698
                              ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
699 700 701 702 703 704 705
                              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
706
  where
707
    is_bidirectional = isJust builder
708 709
    tvs = univ_tvs ++ ex_tvs
    ty = foldr IfaceFunTy pat_ty arg_tys
Gergő Érdi's avatar
Gergő Érdi committed
710

711 712
pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty,
                              ifIdDetails = details, ifIdInfo = info })
713
  = vcat [ hang (pprPrefixIfDeclBndr ss var <+> dcolon)
714 715
              2 (pprIfaceSigmaType ty)
         , ppShowIface ss (ppr details)
716
         , ppShowIface ss (ppr info) ]
717 718 719 720 721 722 723

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


724
pprCType :: Maybe CType -> SDoc
725
pprCType Nothing      = Outputable.empty
726 727
pprCType (Just cType) = ptext (sLit "C type:") <+> ppr cType

728 729 730 731 732 733 734 735
-- 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)
736

Ian Lynagh's avatar
Ian Lynagh committed
737
pprRec :: RecFlag -> SDoc
738
pprRec NonRecursive = Outputable.empty
739
pprRec Recursive    = ptext (sLit "RecFlag: Recursive")
Ian Lynagh's avatar
Ian Lynagh committed
740

741
pprInfixIfDeclBndr, pprPrefixIfDeclBndr :: ShowSub -> OccName -> SDoc
742
pprInfixIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) occ
743 744 745
  = pprInfixVar (isSymOcc occ) (ppr_bndr occ)
pprPrefixIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) occ
  = parenSymOcc occ (ppr_bndr occ)
746

747
instance Outputable IfaceClassOp where
748 749 750 751
   ppr = pprIfaceClassOp showAll

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

755
instance Outputable IfaceAT where
756 757 758
   ppr = pprIfaceAT showAll

pprIfaceAT :: ShowSub -> IfaceAT -> SDoc
759
pprIfaceAT ss (IfaceAT d mb_def)
760
  = vcat [ pprIfaceDecl ss d
761
         , case mb_def of
762
              Nothing  -> Outputable.empty
763 764
              Just rhs -> nest 2 $
                          ptext (sLit "Default:") <+> ppr rhs ]
765 766 767 768 769 770

instance Outputable IfaceTyConParent where
  ppr p = pprIfaceTyConParent p

pprIfaceTyConParent :: IfaceTyConParent -> SDoc
pprIfaceTyConParent IfNoParent
771
  = Outputable.empty
772 773 774 775 776 777
pprIfaceTyConParent (IfDataInstance _ tc tys)
  = sdocWithDynFlags $ \dflags ->
    let ftys = stripKindArgs dflags tys
    in pprIfaceTypeApp tc ftys

pprIfaceDeclHead :: IfaceContext -> ShowSub -> OccName -> [IfaceTvBndr] -> SDoc
778
pprIfaceDeclHead context ss tc_occ tv_bndrs
779
  = sdocWithDynFlags $ \ dflags ->
780 781 782
    sep [ pprIfaceContextArr context
        , pprPrefixIfDeclBndr ss tc_occ
          <+> pprIfaceTvBndrs (stripIfaceKindVars dflags tv_bndrs) ]
783 784 785 786 787 788 789 790

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

pprIfaceConDecl :: ShowSub -> Bool
791
                -> (IfaceEqSpec -> ([IfaceTvBndr], SDoc))
792 793 794
                -> IfaceConDecl -> SDoc
pprIfaceConDecl ss gadt_style mk_user_con_res_ty
        (IfCon { ifConOcc = name, ifConInfix = is_infix,
795
                 ifConExTvs = ex_tvs,
dterei's avatar
dterei committed
796
                 ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
797
                 ifConStricts = stricts, ifConFields = labels })
798
  | gadt_style = pp_prefix_con <+> dcolon <+> ppr_ty
799
  | otherwise  = ppr_fields tys_w_strs
800
  where
801 802
    tys_w_strs :: [(IfaceBang, IfaceType)]
    tys_w_strs = zip stricts arg_tys
803
    pp_prefix_con = pprPrefixIfDeclBndr ss name
804

805 806
    (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
807 808 809

        -- 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
810
    pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of
dterei's avatar
dterei committed
811 812
                (t:ts) -> fsep (t : map (arrow <+>) ts)
                []     -> panic "pp_con_taus"
813

814 815 816 817 818 819 820 821 822 823
    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)
824
      | showSub ss lbl = Just (pprPrefixIfDeclBndr ss lbl <+> dcolon <+> pprBangTy bty)
825 826 827 828
      | otherwise      = Nothing

    ppr_fields [ty1, ty2]
      | is_infix && null labels
829
      = sep [pprParendBangTy ty1, pprInfixIfDeclBndr ss name, pprParendBangTy ty2]
830
    ppr_fields fields
831 832
      | null labels = pp_prefix_con <+> sep (map pprParendBangTy fields)
      | otherwise   = pp_prefix_con <+> (braces $ sep $ punctuate comma $ ppr_trim $
833
                                    map maybe_show_label (zip labels fields))
834

835
instance Outputable IfaceRule where
836
  ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
dterei's avatar
dterei committed
837
                   ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
838
    = sep [hsep [doubleQuotes (ftext name), ppr act,
dterei's avatar
dterei committed
839 840 841
                 ptext (sLit "forall") <+> pprIfaceBndrs bndrs],
           nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
                        ptext (sLit "=") <+> ppr rhs])
842 843
      ]

844
instance Outputable IfaceClsInst where
845 846
  ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag
                    , ifInstCls = cls, ifInstTys = mb_tcs})
dterei's avatar
dterei committed
847 848
    = hang (ptext (sLit "instance") <+> ppr flag
                <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
849
         2 (equals <+> ppr dfun_id)
850 851

instance Outputable IfaceFamInst where
852 853
  ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
                    , ifFamInstAxiom = tycon_ax})
dterei's avatar
dterei committed
854
    = hang (ptext (sLit "family instance") <+>
855
            ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs)
856
         2 (equals <+> ppr tycon_ax)
857 858 859 860

ppr_rough :: Maybe IfaceTyCon -> SDoc
ppr_rough Nothing   = dot
ppr_rough (Just tc) = ppr tc