IfaceType.hs 49.2 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

Simon Marlow's avatar
Simon Marlow committed
6
This module defines interface types and binders
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

9 10 11
{-# LANGUAGE CPP, FlexibleInstances #-}
    -- FlexibleInstances for Binary (DefMethSpec IfaceType)

12
module IfaceType (
13
        IfExtName, IfLclName,
14

15
        IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),
16
        IfaceUnivCoProv(..),
17
        IfaceTyCon(..), IfaceTyConInfo(..),
18
        IfaceTyLit(..), IfaceTcArgs(..),
19 20 21
        IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,
        IfaceTvBndr, IfaceIdBndr,
        IfaceForAllBndr(..), VisibilityFlag(..),
22

23 24
        -- Equality testing
        IfRnEnv2, emptyIfRnEnv2, eqIfaceType, eqIfaceTypes,
25
        eqIfaceTcArgs, eqIfaceTvBndrs,
26

27
        -- Conversion from Type -> IfaceType
28
        toIfaceType, toIfaceTypes, toIfaceKind, toIfaceTyVar,
29
        toIfaceContext, toIfaceBndr, toIfaceIdBndr,
30 31
        toIfaceTyCon, toIfaceTyCon_name,
        toIfaceTcArgs, toIfaceTvBndrs,
32 33 34

        -- Conversion from IfaceTcArgs -> IfaceType
        tcArgsIfaceTypes,
35

36 37
        -- Conversion from Coercion -> IfaceCoercion
        toIfaceCoercion,
38

39
        -- Printing
40 41
        pprIfaceType, pprParendIfaceType,
        pprIfaceContext, pprIfaceContextArr, pprIfaceContextMaybe,
42
        pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTvBndrs,
43 44 45 46 47
        pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs,
        pprIfaceForAllPart, pprIfaceForAll, pprIfaceSigmaType,
        pprIfaceCoercion, pprParendIfaceCoercion,
        splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll,

48 49 50 51 52
        suppressIfaceInvisibles,
        stripIfaceInvisVars,
        stripInvisArgs,
        substIfaceType, substIfaceTyVar, substIfaceTcArgs, mkIfaceTySubst,
        eqIfaceTvBndr
53 54
    ) where

55 56
#include "HsVersions.h"

57
import Coercion
58
import DataCon ( isTupleDataCon )
59 60
import TcType
import DynFlags
61
import TyCoRep  -- needs to convert core types to iface types
62
import Unique( hasKey )
63
import TyCon hiding ( pprPromotionQuote )
64
import CoAxiom
65
import Id
Simon Marlow's avatar
Simon Marlow committed
66
import Var
67
-- import RnEnv( FastStringEnv, mkFsEnv, lookupFsEnv )
Simon Marlow's avatar
Simon Marlow committed
68
import TysWiredIn
69
import TysPrim
70
import PrelNames( funTyConKey, ipClassKey )
Simon Marlow's avatar
Simon Marlow committed
71 72
import Name
import BasicTypes
73
import Binary
74 75
import Outputable
import FastString
76
import UniqSet
77 78
import VarEnv
import Data.Maybe
79 80
import UniqFM
import Util
81

Austin Seipp's avatar
Austin Seipp committed
82 83 84
{-
************************************************************************
*                                                                      *
85
                Local (nested) binders
Austin Seipp's avatar
Austin Seipp committed
86 87 88
*                                                                      *
************************************************************************
-}
89

90
type IfLclName = FastString     -- A local name in iface syntax
91

92 93
type IfExtName = Name   -- An External or WiredIn Name can appear in IfaceSyn
                        -- (However Internal or System Names never should)
94

95
data IfaceBndr          -- Local (non-top-level) binders
96 97
  = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr
  | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr
98

99 100
type IfaceIdBndr  = (IfLclName, IfaceType)
type IfaceTvBndr  = (IfLclName, IfaceKind)
101

102

103 104
data IfaceOneShot    -- See Note [Preserve OneShotInfo] in CoreTicy
  = IfaceNoOneShot   -- and Note [The oneShot function] in MkId
105 106 107 108 109
  | IfaceOneShot

type IfaceLamBndr
  = (IfaceBndr, IfaceOneShot)

110 111 112 113 114 115 116 117
{-
%************************************************************************
%*                                                                      *
                IfaceType
%*                                                                      *
%************************************************************************
-}

118
-------------------------------
119
type IfaceKind     = IfaceType
120

121
data IfaceType     -- A kind of universal type, used for types and kinds
122
  = IfaceTyVar    IfLclName               -- Type/coercion variable only, not tycon
123
  | IfaceLitTy    IfaceTyLit
124
  | IfaceAppTy    IfaceType IfaceType
125
  | IfaceFunTy    IfaceType IfaceType
126
  | IfaceDFunTy   IfaceType IfaceType
127
  | IfaceForAllTy IfaceForAllBndr IfaceType
128
  | IfaceTyConApp IfaceTyCon IfaceTcArgs  -- Not necessarily saturated
129 130 131
                                          -- Includes newtypes, synonyms, tuples
  | IfaceCastTy     IfaceType IfaceCoercion
  | IfaceCoercionTy IfaceCoercion
132 133 134 135
  | IfaceTupleTy                  -- Saturated tuples (unsaturated ones use IfaceTyConApp)
       TupleSort IfaceTyConInfo   -- A bit like IfaceTyCon
       IfaceTcArgs                -- arity = length args
          -- For promoted data cons, the kind args are omitted
136

batterseapower's avatar
batterseapower committed
137
type IfacePredType = IfaceType
138 139
type IfaceContext = [IfacePredType]

140
data IfaceTyLit
141 142
  = IfaceNumTyLit Integer
  | IfaceStrTyLit FastString
143
  deriving (Eq)
144

145 146 147 148
data IfaceForAllBndr
  = IfaceTv IfaceTvBndr VisibilityFlag

-- See Note [Suppressing invisible arguments]
149 150 151 152 153 154
-- We use a new list type (rather than [(IfaceType,Bool)], because
-- it'll be more compact and faster to parse in interface
-- files. Rather than two bytes and two decisions (nil/cons, and
-- type/kind) there'll just be one.
data IfaceTcArgs
  = ITC_Nil
155 156
  | ITC_Vis   IfaceType IfaceTcArgs
  | ITC_Invis IfaceKind IfaceTcArgs
157 158 159 160 161

-- Encodes type constructors, kind constructors,
-- coercion constructors, the lot.
-- We have to tag them in order to pretty print them
-- properly.
162 163
data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName
                             , ifaceTyConInfo :: IfaceTyConInfo }
164
    deriving (Eq)
165 166 167 168 169

data IfaceTyConInfo   -- Used to guide pretty-printing
                      -- and to disambiguate D from 'D (they share a name)
  = NoIfaceTyConInfo
  | IfacePromotedDataCon
170
    deriving (Eq)
171

172
data IfaceCoercion
173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195
  = IfaceReflCo       Role IfaceType
  | IfaceFunCo        Role IfaceCoercion IfaceCoercion
  | IfaceTyConAppCo   Role IfaceTyCon [IfaceCoercion]
  | IfaceAppCo        IfaceCoercion IfaceCoercion
  | IfaceForAllCo     IfaceTvBndr IfaceCoercion IfaceCoercion
  | IfaceCoVarCo      IfLclName
  | IfaceAxiomInstCo  IfExtName BranchIndex [IfaceCoercion]
  | IfaceUnivCo       IfaceUnivCoProv Role IfaceType IfaceType
  | IfaceSymCo        IfaceCoercion
  | IfaceTransCo      IfaceCoercion IfaceCoercion
  | IfaceNthCo        Int IfaceCoercion
  | IfaceLRCo         LeftOrRight IfaceCoercion
  | IfaceInstCo       IfaceCoercion IfaceCoercion
  | IfaceCoherenceCo  IfaceCoercion IfaceCoercion
  | IfaceKindCo       IfaceCoercion
  | IfaceSubCo        IfaceCoercion
  | IfaceAxiomRuleCo  IfLclName [IfaceCoercion]

data IfaceUnivCoProv
  = IfaceUnsafeCoerceProv
  | IfacePhantomProv IfaceCoercion
  | IfaceProofIrrelProv IfaceCoercion
  | IfacePluginProv String
196

Austin Seipp's avatar
Austin Seipp committed
197
{-
198 199
%************************************************************************
%*                                                                      *
200
                Functions over IFaceTypes
Austin Seipp's avatar
Austin Seipp committed
201 202 203
*                                                                      *
************************************************************************
-}
204

205 206 207 208
eqIfaceTvBndr :: IfaceTvBndr -> IfaceTvBndr -> Bool
eqIfaceTvBndr (occ1, _) (occ2, _) = occ1 == occ2

splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType)
209 210
-- Mainly for printing purposes
splitIfaceSigmaTy ty
211
  = (bndrs, theta, tau)
212
  where
213
    (bndrs, rho)   = split_foralls ty
batterseapower's avatar
batterseapower committed
214
    (theta, tau)   = split_rho rho
215

216 217
    split_foralls (IfaceForAllTy bndr ty)
        = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) }
218 219
    split_foralls rho = ([], rho)

220 221
    split_rho (IfaceDFunTy ty1 ty2)
        = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) }
222
    split_rho tau = ([], tau)
223

224 225
suppressIfaceInvisibles :: DynFlags -> [IfaceForAllBndr] -> [a] -> [a]
suppressIfaceInvisibles dflags tys xs
226 227 228 229 230 231
  | gopt Opt_PrintExplicitKinds dflags = xs
  | otherwise = suppress tys xs
    where
      suppress _       []      = []
      suppress []      a       = a
      suppress (k:ks) a@(_:xs)
232 233
        | isIfaceInvisBndr k = suppress ks xs
        | otherwise          = a
234

235 236
stripIfaceInvisVars :: DynFlags -> [IfaceForAllBndr] -> [IfaceForAllBndr]
stripIfaceInvisVars dflags tyvars
237
  | gopt Opt_PrintExplicitKinds dflags = tyvars
238
  | otherwise = filterOut isIfaceInvisBndr tyvars
239

240 241 242
isIfaceInvisBndr :: IfaceForAllBndr -> Bool
isIfaceInvisBndr (IfaceTv _ Visible) = False
isIfaceInvisBndr _                   = True
243 244 245 246 247 248 249 250 251 252 253

ifTyVarsOfType :: IfaceType -> UniqSet IfLclName
ifTyVarsOfType ty
  = case ty of
      IfaceTyVar v -> unitUniqSet v
      IfaceAppTy fun arg
        -> ifTyVarsOfType fun `unionUniqSets` ifTyVarsOfType arg
      IfaceFunTy arg res
        -> ifTyVarsOfType arg `unionUniqSets` ifTyVarsOfType res
      IfaceDFunTy arg res
        -> ifTyVarsOfType arg `unionUniqSets` ifTyVarsOfType res
254 255 256 257 258 259 260 261
      IfaceForAllTy bndr ty
        -> let (free, bound) = ifTyVarsOfForAllBndr bndr in
           delListFromUniqSet (ifTyVarsOfType ty) bound `unionUniqSets` free
      IfaceTyConApp _ args -> ifTyVarsOfArgs args
      IfaceLitTy    _      -> emptyUniqSet
      IfaceCastTy ty co
        -> ifTyVarsOfType ty `unionUniqSets` ifTyVarsOfCoercion co
      IfaceCoercionTy co    -> ifTyVarsOfCoercion co
262
      IfaceTupleTy _ _ args -> ifTyVarsOfArgs args
263 264 265 266 267

ifTyVarsOfForAllBndr :: IfaceForAllBndr
                     -> ( UniqSet IfLclName   -- names used free in the binder
                        , [IfLclName] )       -- names bound by this binder
ifTyVarsOfForAllBndr (IfaceTv (name, kind) _) = (ifTyVarsOfType kind, [name])
268 269 270 271

ifTyVarsOfArgs :: IfaceTcArgs -> UniqSet IfLclName
ifTyVarsOfArgs args = argv emptyUniqSet args
   where
272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309
     argv vs (ITC_Vis   t ts) = argv (vs `unionUniqSets` (ifTyVarsOfType t)) ts
     argv vs (ITC_Invis k ks) = argv (vs `unionUniqSets` (ifTyVarsOfType k)) ks
     argv vs ITC_Nil          = vs

ifTyVarsOfCoercion :: IfaceCoercion -> UniqSet IfLclName
ifTyVarsOfCoercion = go
  where
    go (IfaceReflCo _ ty)         = ifTyVarsOfType ty
    go (IfaceFunCo _ c1 c2)       = go c1 `unionUniqSets` go c2
    go (IfaceTyConAppCo _ _ cos)  = ifTyVarsOfCoercions cos
    go (IfaceAppCo c1 c2)         = go c1 `unionUniqSets` go c2
    go (IfaceForAllCo (bound, _) kind_co co)
     = go co `delOneFromUniqSet` bound `unionUniqSets` go kind_co
    go (IfaceCoVarCo cv)          = unitUniqSet cv
    go (IfaceAxiomInstCo _ _ cos) = ifTyVarsOfCoercions cos
    go (IfaceUnivCo p _ ty1 ty2)  = go_prov p `unionUniqSets`
                                    ifTyVarsOfType ty1 `unionUniqSets`
                                    ifTyVarsOfType ty2
    go (IfaceSymCo co)            = go co
    go (IfaceTransCo c1 c2)       = go c1 `unionUniqSets` go c2
    go (IfaceNthCo _ co)          = go co
    go (IfaceLRCo _ co)           = go co
    go (IfaceInstCo c1 c2)        = go c1 `unionUniqSets` go c2
    go (IfaceCoherenceCo c1 c2)   = go c1 `unionUniqSets` go c2
    go (IfaceKindCo co)           = go co
    go (IfaceSubCo co)            = go co
    go (IfaceAxiomRuleCo rule cos)
      = unionManyUniqSets
          [ unitUniqSet rule
          , ifTyVarsOfCoercions cos ]

    go_prov IfaceUnsafeCoerceProv    = emptyUniqSet
    go_prov (IfacePhantomProv co)    = go co
    go_prov (IfaceProofIrrelProv co) = go co
    go_prov (IfacePluginProv _)      = emptyUniqSet

ifTyVarsOfCoercions :: [IfaceCoercion] -> UniqSet IfLclName
ifTyVarsOfCoercions = foldr (unionUniqSets . ifTyVarsOfCoercion) emptyUniqSet
310

Austin Seipp's avatar
Austin Seipp committed
311
{-
312 313 314
Substitutions on IfaceType. This is only used during pretty-printing to construct
the result type of a GADT, and does not deal with binders (eg IfaceForAll), so
it doesn't need fancy capture stuff.
Austin Seipp's avatar
Austin Seipp committed
315
-}
316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331

type IfaceTySubst = FastStringEnv IfaceType

mkIfaceTySubst :: [IfaceTvBndr] -> [IfaceType] -> IfaceTySubst
mkIfaceTySubst tvs tys = mkFsEnv $ zipWithEqual "mkIfaceTySubst" (\(fs,_) ty -> (fs,ty)) tvs tys

substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType
substIfaceType env ty
  = go ty
  where
    go (IfaceTyVar tv)        = substIfaceTyVar env tv
    go (IfaceAppTy  t1 t2)    = IfaceAppTy  (go t1) (go t2)
    go (IfaceFunTy  t1 t2)    = IfaceFunTy  (go t1) (go t2)
    go (IfaceDFunTy t1 t2)    = IfaceDFunTy (go t1) (go t2)
    go ty@(IfaceLitTy {})     = ty
    go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceTcArgs env tys)
332
    go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceTcArgs env tys)
333
    go (IfaceForAllTy {})     = pprPanic "substIfaceType" (ppr ty)
334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360
    go (IfaceCastTy ty co)    = IfaceCastTy (go ty) (go_co co)
    go (IfaceCoercionTy co)   = IfaceCoercionTy (go_co co)

    go_co (IfaceReflCo r ty)     = IfaceReflCo r (go ty)
    go_co (IfaceFunCo r c1 c2)   = IfaceFunCo r (go_co c1) (go_co c2)
    go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos)
    go_co (IfaceAppCo c1 c2)         = IfaceAppCo (go_co c1) (go_co c2)
    go_co (IfaceForAllCo {})         = pprPanic "substIfaceCoercion" (ppr ty)
    go_co (IfaceCoVarCo cv)          = IfaceCoVarCo cv
    go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos)
    go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2)
    go_co (IfaceSymCo co)            = IfaceSymCo (go_co co)
    go_co (IfaceTransCo co1 co2)     = IfaceTransCo (go_co co1) (go_co co2)
    go_co (IfaceNthCo n co)          = IfaceNthCo n (go_co co)
    go_co (IfaceLRCo lr co)          = IfaceLRCo lr (go_co co)
    go_co (IfaceInstCo c1 c2)        = IfaceInstCo (go_co c1) (go_co c2)
    go_co (IfaceCoherenceCo c1 c2)   = IfaceCoherenceCo (go_co c1) (go_co c2)
    go_co (IfaceKindCo co)           = IfaceKindCo (go_co co)
    go_co (IfaceSubCo co)            = IfaceSubCo (go_co co)
    go_co (IfaceAxiomRuleCo n cos)   = IfaceAxiomRuleCo n (go_cos cos)

    go_cos = map go_co

    go_prov IfaceUnsafeCoerceProv    = IfaceUnsafeCoerceProv
    go_prov (IfacePhantomProv co)    = IfacePhantomProv (go_co co)
    go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co)
    go_prov (IfacePluginProv str)    = IfacePluginProv str
361 362 363 364 365

substIfaceTcArgs :: IfaceTySubst -> IfaceTcArgs -> IfaceTcArgs
substIfaceTcArgs env args
  = go args
  where
366 367 368
    go ITC_Nil            = ITC_Nil
    go (ITC_Vis ty tys)   = ITC_Vis   (substIfaceType env ty) (go tys)
    go (ITC_Invis ty tys) = ITC_Invis (substIfaceType env ty) (go tys)
369 370 371 372 373

substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType
substIfaceTyVar env tv
  | Just ty <- lookupFsEnv env tv = ty
  | otherwise                     = IfaceTyVar tv
374

375 376 377 378 379 380
{-
************************************************************************
*                                                                      *
                Equality over IfaceTypes
*                                                                      *
************************************************************************
381 382 383 384 385 386 387 388

Note [No kind check in ifaces]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We check iface types for equality only when checking the consistency
between two user-written signatures. In these cases, there is no possibility
for a kind mismatch. So we omit the kind check (which would be impossible to
write, anyway.)

389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419
-}

-- Like an RnEnv2, but mapping from FastString to deBruijn index
-- DeBruijn; see eqTypeX
type BoundVar = Int
data IfRnEnv2
  = IRV2 { ifenvL :: UniqFM BoundVar -- from FastString
         , ifenvR :: UniqFM BoundVar
         , ifenv_next :: BoundVar
         }

emptyIfRnEnv2 :: IfRnEnv2
emptyIfRnEnv2 = IRV2 { ifenvL = emptyUFM
                     , ifenvR = emptyUFM
                     , ifenv_next = 0 }

rnIfOccL :: IfRnEnv2 -> IfLclName -> Maybe BoundVar
rnIfOccL env = lookupUFM (ifenvL env)

rnIfOccR :: IfRnEnv2 -> IfLclName -> Maybe BoundVar
rnIfOccR env = lookupUFM (ifenvR env)

extendIfRnEnv2 :: IfRnEnv2 -> IfLclName -> IfLclName -> IfRnEnv2
extendIfRnEnv2 IRV2 { ifenvL = lenv
                    , ifenvR = renv
                    , ifenv_next = n } tv1 tv2
             = IRV2 { ifenvL = addToUFM lenv tv1 n
                    , ifenvR = addToUFM renv tv2 n
                    , ifenv_next = n + 1
                    }

420
-- See Note [No kind check in ifaces]
421 422 423 424 425 426 427 428 429 430 431 432 433
eqIfaceType :: IfRnEnv2 -> IfaceType -> IfaceType -> Bool
eqIfaceType env (IfaceTyVar tv1) (IfaceTyVar tv2) =
    case (rnIfOccL env tv1, rnIfOccR env tv2) of
        (Just v1, Just v2) -> v1 == v2
        (Nothing, Nothing) -> tv1 == tv2
        _ -> False
eqIfaceType _   (IfaceLitTy l1) (IfaceLitTy l2) = l1 == l2
eqIfaceType env (IfaceAppTy t11 t12) (IfaceAppTy t21 t22)
    = eqIfaceType env t11 t21 && eqIfaceType env t12 t22
eqIfaceType env (IfaceFunTy t11 t12) (IfaceFunTy t21 t22)
    = eqIfaceType env t11 t21 && eqIfaceType env t12 t22
eqIfaceType env (IfaceDFunTy t11 t12) (IfaceDFunTy t21 t22)
    = eqIfaceType env t11 t21 && eqIfaceType env t12 t22
434 435
eqIfaceType env (IfaceForAllTy bndr1 t1) (IfaceForAllTy bndr2 t2)
    = eqIfaceForAllBndr env bndr1 bndr2 (\env' -> eqIfaceType env' t1 t2)
436 437 438 439
eqIfaceType env (IfaceTyConApp tc1 tys1) (IfaceTyConApp tc2 tys2)
    = tc1 == tc2 && eqIfaceTcArgs env tys1 tys2
eqIfaceType env (IfaceTupleTy s1 tc1 tys1) (IfaceTupleTy s2 tc2 tys2)
    = s1 == s2 && tc1 == tc2 && eqIfaceTcArgs env tys1 tys2
440 441 442 443
eqIfaceType env (IfaceCastTy t1 _) (IfaceCastTy t2 _)
    = eqIfaceType env t1 t2
eqIfaceType _   (IfaceCoercionTy {}) (IfaceCoercionTy {})
    = True
444 445 446 447 448
eqIfaceType _ _ _ = False

eqIfaceTypes :: IfRnEnv2 -> [IfaceType] -> [IfaceType] -> Bool
eqIfaceTypes env tys1 tys2 = and (zipWith (eqIfaceType env) tys1 tys2)

449 450 451 452 453 454 455
eqIfaceForAllBndr :: IfRnEnv2 -> IfaceForAllBndr -> IfaceForAllBndr
                  -> (IfRnEnv2 -> Bool)  -- continuation
                  -> Bool
eqIfaceForAllBndr env (IfaceTv (tv1, k1) vis1) (IfaceTv (tv2, k2) vis2) k
  = eqIfaceType env k1 k2 && vis1 == vis2 &&
    k (extendIfRnEnv2 env tv1 tv2)

456 457
eqIfaceTcArgs :: IfRnEnv2 -> IfaceTcArgs -> IfaceTcArgs -> Bool
eqIfaceTcArgs _ ITC_Nil ITC_Nil = True
458
eqIfaceTcArgs env (ITC_Vis ty1 tys1) (ITC_Vis ty2 tys2)
459
    = eqIfaceType env ty1 ty2 && eqIfaceTcArgs env tys1 tys2
460
eqIfaceTcArgs env (ITC_Invis ty1 tys1) (ITC_Invis ty2 tys2)
461 462 463 464 465 466 467 468 469 470 471 472 473
    = eqIfaceType env ty1 ty2 && eqIfaceTcArgs env tys1 tys2
eqIfaceTcArgs _ _ _ = False

-- | Similar to 'eqTyVarBndrs', checks that tyvar lists
-- are the same length and have matching kinds; if so, extend the
-- 'IfRnEnv2'.  Returns 'Nothing' if they don't match.
eqIfaceTvBndrs :: IfRnEnv2 -> [IfaceTvBndr] -> [IfaceTvBndr] -> Maybe IfRnEnv2
eqIfaceTvBndrs env [] [] = Just env
eqIfaceTvBndrs env ((tv1, k1):tvs1) ((tv2, k2):tvs2)
  | eqIfaceType env k1 k2
  = eqIfaceTvBndrs (extendIfRnEnv2 env tv1 tv2) tvs1 tvs2
eqIfaceTvBndrs _ _ _ = Nothing

Austin Seipp's avatar
Austin Seipp committed
474 475 476
{-
************************************************************************
*                                                                      *
477
                Functions over IFaceTcArgs
Austin Seipp's avatar
Austin Seipp committed
478 479 480
*                                                                      *
************************************************************************
-}
481

482 483
stripInvisArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs
stripInvisArgs dflags tys
484
  | gopt Opt_PrintExplicitKinds dflags = tys
485
  | otherwise = suppress_invis tys
486
    where
487
      suppress_invis c
488
        = case c of
489
            ITC_Invis _ ts -> suppress_invis ts
490 491 492
            _ -> c

toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs
493
-- See Note [Suppressing invisible arguments]
494
toIfaceTcArgs tc ty_args
495
  = go (mkEmptyTCvSubst in_scope) (tyConKind tc) ty_args
496
  where
497 498 499 500 501 502 503 504 505 506 507
    in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)

    go _   _                   []     = ITC_Nil
    go env ty                  ts
      | Just ty' <- coreView ty
      = go env ty' ts
    go env (ForAllTy bndr res) (t:ts)
      | isVisibleBinder bndr = ITC_Vis   t' ts'
      | otherwise            = ITC_Invis t' ts'
      where
        t'  = toIfaceType t
508
        ts' = go (extendTvSubstBinder env bndr t) res ts
509 510 511 512 513

    go env (TyVarTy tv) ts
      | Just ki <- lookupTyVar env tv = go env ki ts
    go env kind (t:ts) = WARN( True, ppr tc $$ ppr (tyConKind tc) $$ ppr ty_args )
                         ITC_Vis (toIfaceType t) (go env kind ts) -- Ill-kinded
514 515 516

tcArgsIfaceTypes :: IfaceTcArgs -> [IfaceType]
tcArgsIfaceTypes ITC_Nil = []
517 518
tcArgsIfaceTypes (ITC_Invis t ts) = t : tcArgsIfaceTypes ts
tcArgsIfaceTypes (ITC_Vis   t ts) = t : tcArgsIfaceTypes ts
519

Austin Seipp's avatar
Austin Seipp committed
520
{-
521 522
Note [Suppressing invisible arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
523
We use the IfaceTcArgs to specify which of the arguments to a type
524 525 526 527
constructor should be visible.
This in turn used to control suppression when printing types,
under the control of -fprint-explicit-kinds.
See also Type.filterOutInvisibleTypes.
528 529 530 531 532 533 534 535
For example, given
    T :: forall k. (k->*) -> k -> *    -- Ordinary kind polymorphism
    'Just :: forall k. k -> 'Maybe k   -- Promoted
we want
  T * Tree Int    prints as    T Tree Int
  'Just *         prints as    Just *


Austin Seipp's avatar
Austin Seipp committed
536 537
************************************************************************
*                                                                      *
538
                Pretty-printing
Austin Seipp's avatar
Austin Seipp committed
539 540 541
*                                                                      *
************************************************************************
-}
542

543 544 545 546 547 548 549 550 551 552
pprIfaceInfixApp :: (TyPrec -> a -> SDoc) -> TyPrec -> SDoc -> a -> a -> SDoc
pprIfaceInfixApp pp p pp_tc ty1 ty2
  = maybeParen p FunPrec $
    sep [pp FunPrec ty1, pprInfixVar True pp_tc <+> pp FunPrec ty2]

pprIfacePrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc
pprIfacePrefixApp p pp_fun pp_tys
  | null pp_tys = pp_fun
  | otherwise   = maybeParen p TyConPrec $
                  hang pp_fun 2 (sep pp_tys)
553

Austin Seipp's avatar
Austin Seipp committed
554
-- ----------------------------- Printing binders ------------------------------------
555 556 557 558 559 560 561 562

instance Outputable IfaceBndr where
    ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr
    ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr bndr

pprIfaceBndrs :: [IfaceBndr] -> SDoc
pprIfaceBndrs bs = sep (map ppr bs)

563 564 565 566
pprIfaceLamBndr :: IfaceLamBndr -> SDoc
pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b
pprIfaceLamBndr (b, IfaceOneShot)   = ppr b <> text "[OneShot]"

567
pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc
568
pprIfaceIdBndr (name, ty) = parens (ppr name <+> dcolon <+> ppr ty)
569 570

pprIfaceTvBndr :: IfaceTvBndr -> SDoc
571
pprIfaceTvBndr (tv, IfaceTyConApp tc ITC_Nil)
572 573 574 575 576
  | isLiftedTypeKindTyConName (ifaceTyConName tc) = ppr tv
pprIfaceTvBndr (tv, IfaceTyConApp tc (ITC_Vis (IfaceTyConApp lifted ITC_Nil) ITC_Nil))
  | ifaceTyConName tc     == tYPETyConName
  , ifaceTyConName lifted == liftedDataConName
  = ppr tv
577
pprIfaceTvBndr (tv, kind) = parens (ppr tv <+> dcolon <+> ppr kind)
578

579
pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc
Simon Peyton Jones's avatar
Simon Peyton Jones committed
580
pprIfaceTvBndrs tyvars = sep (map pprIfaceTvBndr tyvars)
581 582 583 584 585 586 587 588 589 590 591 592 593 594 595

instance Binary IfaceBndr where
    put_ bh (IfaceIdBndr aa) = do
            putByte bh 0
            put_ bh aa
    put_ bh (IfaceTvBndr ab) = do
            putByte bh 1
            put_ bh ab
    get bh = do
            h <- getByte bh
            case h of
              0 -> do aa <- get bh
                      return (IfaceIdBndr aa)
              _ -> do ab <- get bh
                      return (IfaceTvBndr ab)
596 597 598 599 600 601 602 603 604 605 606

instance Binary IfaceOneShot where
    put_ bh IfaceNoOneShot = do
            putByte bh 0
    put_ bh IfaceOneShot = do
            putByte bh 1
    get bh = do
            h <- getByte bh
            case h of
              0 -> do return IfaceNoOneShot
              _ -> do return IfaceOneShot
607

Austin Seipp's avatar
Austin Seipp committed
608
-- ----------------------------- Printing IfaceType ------------------------------------
609 610 611

---------------------------------
instance Outputable IfaceType where
612
  ppr ty = pprIfaceType ty
613

614
pprIfaceType, pprParendIfaceType ::IfaceType -> SDoc
615 616
pprIfaceType       = ppr_ty TopPrec
pprParendIfaceType = ppr_ty TyConPrec
617

618
ppr_ty :: TyPrec -> IfaceType -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
619
ppr_ty _         (IfaceTyVar tyvar)     = ppr tyvar
620
ppr_ty ctxt_prec (IfaceTyConApp tc tys) = sdocWithDynFlags (pprTyTcApp ctxt_prec tc tys)
621
ppr_ty _         (IfaceTupleTy s i tys) = pprTuple s i tys
622
ppr_ty _         (IfaceLitTy n)         = ppr_tylit n
623
        -- Function types
624
ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
625
  = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
626 627
    maybeParen ctxt_prec FunPrec $
    sep [ppr_ty FunPrec ty1, sep (ppr_fun_tail ty2)]
628
  where
629
    ppr_fun_tail (IfaceFunTy ty1 ty2)
630
      = (arrow <+> ppr_ty FunPrec ty1) : ppr_fun_tail ty2
631
    ppr_fun_tail other_ty
632
      = [arrow <+> pprIfaceType other_ty]
633

634
ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)
635 636
  = maybeParen ctxt_prec TyConPrec $
    ppr_ty FunPrec ty1 <+> pprParendIfaceType ty2
637

638 639
ppr_ty ctxt_prec (IfaceCastTy ty co)
  = maybeParen ctxt_prec FunPrec $
640
    sep [ppr_ty FunPrec ty, text "`cast`", ppr_co FunPrec co]
641 642 643 644

ppr_ty ctxt_prec (IfaceCoercionTy co)
  = ppr_co ctxt_prec co

645 646 647 648 649 650 651 652 653 654 655 656 657 658
ppr_ty ctxt_prec ty
  = maybeParen ctxt_prec FunPrec (ppr_iface_sigma_type True ty)

instance Outputable IfaceTcArgs where
  ppr tca = pprIfaceTcArgs tca

pprIfaceTcArgs, pprParendIfaceTcArgs :: IfaceTcArgs -> SDoc
pprIfaceTcArgs  = ppr_tc_args TopPrec
pprParendIfaceTcArgs = ppr_tc_args TyConPrec

ppr_tc_args :: TyPrec -> IfaceTcArgs -> SDoc
ppr_tc_args ctx_prec args
 = let pprTys t ts = ppr_ty ctx_prec t <+> ppr_tc_args ctx_prec ts
   in case args of
659 660 661
        ITC_Nil        -> empty
        ITC_Vis   t ts -> pprTys t ts
        ITC_Invis t ts -> pprTys t ts
662

663
-------------------
664 665 666
ppr_iface_sigma_type :: Bool -> IfaceType -> SDoc
ppr_iface_sigma_type show_foralls_unconditionally ty
  = ppr_iface_forall_part show_foralls_unconditionally tvs theta (ppr tau)
667
  where
668
    (tvs, theta, tau) = splitIfaceSigmaTy ty
669

670 671 672 673 674
-------------------
instance Outputable IfaceForAllBndr where
  ppr = pprIfaceForAllBndr

pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfaceType] -> SDoc -> SDoc
675 676
pprIfaceForAllPart tvs ctxt sdoc = ppr_iface_forall_part False tvs ctxt sdoc

677 678 679 680
pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc
pprIfaceForAllCoPart tvs sdoc = sep [ pprIfaceForAllCo tvs
                                    , sdoc ]

681
ppr_iface_forall_part :: Outputable a
682
                      => Bool -> [IfaceForAllBndr] -> [a] -> SDoc -> SDoc
683 684 685 686 687 688 689
ppr_iface_forall_part show_foralls_unconditionally tvs ctxt sdoc
  = sep [ if show_foralls_unconditionally
          then pprIfaceForAll tvs
          else pprUserIfaceForAll tvs
        , pprIfaceContextArr ctxt
        , sdoc]

690 691 692 693 694 695 696 697 698 699
-- | Render the "forall ... ." or "forall ... ->" bit of a type.
pprIfaceForAll :: [IfaceForAllBndr] -> SDoc
pprIfaceForAll [] = empty
pprIfaceForAll bndrs@(IfaceTv _ vis : _)
  = add_separator (text "forall" <+> doc) <+> pprIfaceForAll bndrs'
  where
    (bndrs', doc) = ppr_itv_bndrs bndrs vis

    add_separator stuff = case vis of
                            Visible   -> stuff <+> arrow
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
700 701
                            _inv      -> stuff <>  dot

702 703 704 705 706 707 708

-- | Render the ... in @(forall ... .)@ or @(forall ... ->)@.
-- Returns both the list of not-yet-rendered binders and the doc.
-- No anonymous binders here!
ppr_itv_bndrs :: [IfaceForAllBndr]
             -> VisibilityFlag  -- ^ visibility of the first binder in the list
             -> ([IfaceForAllBndr], SDoc)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
709 710 711
ppr_itv_bndrs all_bndrs@(bndr@(IfaceTv _ vis) : bndrs) vis1
  | vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in
                         (bndrs', pprIfaceForAllBndr bndr <+> doc)
712 713 714 715 716 717 718 719 720 721 722
  | otherwise   = (all_bndrs, empty)
ppr_itv_bndrs [] _ = ([], empty)

pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc
pprIfaceForAllCo []  = empty
pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot

pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc
pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs

pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
723 724 725 726 727
pprIfaceForAllBndr (IfaceTv tv Invisible) = sdocWithDynFlags $ \dflags ->
                                            if gopt Opt_PrintExplicitForalls dflags
                                            then braces $ pprIfaceTvBndr tv
                                            else pprIfaceTvBndr tv
pprIfaceForAllBndr (IfaceTv tv _)         = pprIfaceTvBndr tv
728 729 730 731

pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc
pprIfaceForAllCoBndr (tv, kind_co)
  = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co)
732 733 734 735

pprIfaceSigmaType :: IfaceType -> SDoc
pprIfaceSigmaType ty = ppr_iface_sigma_type False ty

736
pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc
737 738 739 740 741
pprUserIfaceForAll tvs
   = sdocWithDynFlags $ \dflags ->
     ppWhen (any tv_has_kind_var tvs || gopt Opt_PrintExplicitForalls dflags) $
     pprIfaceForAll tvs
   where
742 743 744
     tv_has_kind_var bndr
       = not (isEmptyUniqSet (fst (ifTyVarsOfForAllBndr bndr)))

745
-------------------
746

747
-- See equivalent function in TyCoRep.hs
748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765
pprIfaceTyList :: TyPrec -> IfaceType -> IfaceType -> SDoc
-- Given a type-level list (t1 ': t2), see if we can print
-- it in list notation [t1, ...].
-- Precondition: Opt_PrintExplicitKinds is off
pprIfaceTyList ctxt_prec ty1 ty2
  = case gather ty2 of
      (arg_tys, Nothing)
        -> char '\'' <> brackets (fsep (punctuate comma
                        (map (ppr_ty TopPrec) (ty1:arg_tys))))
      (arg_tys, Just tl)
        -> maybeParen ctxt_prec FunPrec $ hang (ppr_ty FunPrec ty1)
           2 (fsep [ colon <+> ppr_ty FunPrec ty | ty <- arg_tys ++ [tl]])
  where
    gather :: IfaceType -> ([IfaceType], Maybe IfaceType)
     -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn]
     --             = (tys, Just tl) means ty is of form t1:t2:...tn:tl
    gather (IfaceTyConApp tc tys)
      | tcname == consDataConName
766
      , (ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil))) <- tys
767 768 769 770 771 772 773 774 775 776 777 778
      , (args, tl) <- gather ty2
      = (ty1:args, tl)
      | tcname == nilDataConName
      = ([], Nothing)
      where tcname = ifaceTyConName tc
    gather ty = ([], Just ty)

pprIfaceTypeApp :: IfaceTyCon -> IfaceTcArgs -> SDoc
pprIfaceTypeApp tc args = sdocWithDynFlags (pprTyTcApp TopPrec tc args)

pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> DynFlags -> SDoc
pprTyTcApp ctxt_prec tc tys dflags
779
  | ifaceTyConName tc `hasKey` ipClassKey
780
  , ITC_Vis (IfaceLitTy (IfaceStrTyLit n)) (ITC_Vis ty ITC_Nil) <- tys
781
  = char '?' <> ftext n <> text "::" <> ppr_ty TopPrec ty
782 783 784

  | ifaceTyConName tc == consDataConName
  , not (gopt Opt_PrintExplicitKinds dflags)
785
  , ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil)) <- tys
786 787
  = pprIfaceTyList ctxt_prec ty1 ty2

788 789 790 791 792 793 794
  | ifaceTyConName tc == tYPETyConName
  , ITC_Vis (IfaceTyConApp lev_tc ITC_Nil) ITC_Nil <- tys
  = let n = ifaceTyConName lev_tc in
    if n == liftedDataConName then char '*'
    else if n == unliftedDataConName then char '#'
         else pprPanic "IfaceType.pprTyTcApp" (ppr lev_tc)

795 796 797
  | otherwise
  = ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds
  where
798
    tys_wo_kinds = tcArgsIfaceTypes $ stripInvisArgs dflags tys
799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817

pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc
pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys

ppr_iface_tc_app :: (TyPrec -> a -> SDoc) -> TyPrec -> IfaceTyCon -> [a] -> SDoc
ppr_iface_tc_app pp _ tc [ty]
  | n == listTyConName = pprPromotionQuote tc <> brackets (pp TopPrec ty)
  | n == parrTyConName = pprPromotionQuote tc <> paBrackets (pp TopPrec ty)
  where
    n = ifaceTyConName tc

ppr_iface_tc_app pp ctxt_prec tc tys
  | not (isSymOcc (nameOccName tc_name))
  = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp TyConPrec) tys)

  | [ty1,ty2] <- tys  -- Infix, two arguments;
                      -- we know nothing of precedence though
  = pprIfaceInfixApp pp ctxt_prec (ppr tc) ty1 ty2

818 819
  |  tc_name == starKindTyConName || tc_name == unliftedTypeKindTyConName
  || tc_name == unicodeStarKindTyConName
820 821 822 823
  = ppr tc   -- Do not wrap *, # in parens

  | otherwise
  = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp TyConPrec) tys)
824
  where
825 826
    tc_name = ifaceTyConName tc

827 828
pprTuple :: TupleSort -> IfaceTyConInfo -> IfaceTcArgs -> SDoc
pprTuple sort info args
829 830 831 832 833 834 835 836 837
  =   -- drop the levity vars.
      -- See Note [Unboxed tuple levity vars] in TyCon
    let tys   = tcArgsIfaceTypes args
        args' = case sort of
                  UnboxedTuple -> drop (length tys `div` 2) tys
                  _            -> tys
    in
    pprPromotionQuoteI info <>
    tupleParens sort (pprWithCommas pprIfaceType args')
838

839
ppr_tylit :: IfaceTyLit -> SDoc
840 841
ppr_tylit (IfaceNumTyLit n) = integer n
ppr_tylit (IfaceStrTyLit n) = text (show n)
842

843
pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc
844 845
pprIfaceCoercion = ppr_co TopPrec
pprParendIfaceCoercion = ppr_co TyConPrec
846

847
ppr_co :: TyPrec -> IfaceCoercion -> SDoc
848 849
ppr_co _         (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r
ppr_co ctxt_prec (IfaceFunCo r co1 co2)
850 851
  = maybeParen ctxt_prec FunPrec $
    sep (ppr_co FunPrec co1 : ppr_fun_tail co2)
852 853
  where
    ppr_fun_tail (IfaceFunCo r co1 co2)
854
      = (arrow <> ppr_role r <+> ppr_co FunPrec co1) : ppr_fun_tail co2
855 856 857 858
    ppr_fun_tail other_co
      = [arrow <> ppr_role r <+> pprIfaceCoercion other_co]

ppr_co _         (IfaceTyConAppCo r tc cos)
859
  = parens (pprIfaceCoTcApp TopPrec tc cos) <> ppr_role r
860
ppr_co ctxt_prec (IfaceAppCo co1 co2)
861 862
  = maybeParen ctxt_prec TyConPrec $
    ppr_co FunPrec co1 <+> pprParendIfaceCoercion co2
863 864
ppr_co ctxt_prec co@(IfaceForAllCo {})
  = maybeParen ctxt_prec FunPrec (pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co))
865 866 867
  where
    (tvs, inner_co) = split_co co

868 869
    split_co (IfaceForAllCo (name, _) kind_co co')
      = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'')
870 871 872 873
    split_co co' = ([], co')

ppr_co _         (IfaceCoVarCo covar)       = ppr covar

874
ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2)
875
  = maybeParen ctxt_prec TyConPrec $
876
    text "UnsafeCo" <+> ppr r <+>
877 878
    pprParendIfaceType ty1 <+> pprParendIfaceType ty2

879 880 881
ppr_co _         (IfaceUnivCo _ _ ty1 ty2)
  = angleBrackets ( ppr ty1 <> comma <+> ppr ty2 )

882
ppr_co ctxt_prec (IfaceInstCo co ty)
883
  = maybeParen ctxt_prec TyConPrec $
884
    text "Inst" <+> pprParendIfaceCoercion co
885
                        <+> pprParendIfaceCoercion ty
886

887 888
ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos)
  = maybeParen ctxt_prec TyConPrec $ ppr tc <+> parens (interpp'SP cos)
889

890 891 892 893
ppr_co ctxt_prec co
  = ppr_special_co ctxt_prec doc cos
  where (doc, cos) = case co of
                     { IfaceAxiomInstCo n i cos -> (ppr n <> brackets (ppr i), cos)
894 895 896
                     ; IfaceSymCo co            -> (text "Sym", [co])
                     ; IfaceTransCo co1 co2     -> (text "Trans", [co1,co2])
                     ; IfaceNthCo d co          -> (text "Nth:" <> int d,
897 898
                                                    [co])
                     ; IfaceLRCo lr co          -> (ppr lr, [co])
899
                     ; IfaceSubCo co            -> (text "Sub", [co])
900 901
                     ; _                        -> panic "pprIfaceCo" }

902
ppr_special_co :: TyPrec -> SDoc -> [IfaceCoercion] -> SDoc
903
ppr_special_co ctxt_prec doc cos
904
  = maybeParen ctxt_prec TyConPrec
905 906 907
               (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))])

ppr_role :: Role -> SDoc
908 909 910 911 912
ppr_role r = underscore <> pp_role
  where pp_role = case r of
                    Nominal          -> char 'N'
                    Representational -> char 'R'
                    Phantom          -> char 'P'
913

914 915
-------------------
instance Outputable IfaceTyCon where
916 917 918
  ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)

pprPromotionQuote :: IfaceTyCon -> SDoc
919 920 921 922 923
pprPromotionQuote tc = pprPromotionQuoteI (ifaceTyConInfo tc)

pprPromotionQuoteI  :: IfaceTyConInfo -> SDoc
pprPromotionQuoteI NoIfaceTyConInfo     = empty
pprPromotionQuoteI IfacePromotedDataCon = char '\''
924

925 926 927
instance Outputable IfaceCoercion where
  ppr = pprIfaceCoercion

928
instance Binary IfaceTyCon where
929 930 931 932 933 934 935 936 937
   put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i

   get bh = do n <- get bh
               i <- get bh
               return (IfaceTyCon n i)

instance Binary IfaceTyConInfo where
   put_ bh NoIfaceTyConInfo     = putByte bh 0
   put_ bh IfacePromotedDataCon = putByte bh 1
938 939

   get bh =
940 941 942
     do i <- getByte bh
        case i of
          0 -> return NoIfaceTyConInfo
943
          _ -> return IfacePromotedDataCon
944

945 946 947
instance Outputable IfaceTyLit where
  ppr = ppr_tylit

948 949 950 951 952 953 954 955 956 957 958 959 960
instance Binary IfaceTyLit where
  put_ bh (IfaceNumTyLit n)  = putByte bh 1 >> put_ bh n
  put_ bh (IfaceStrTyLit n)  = putByte bh 2 >> put_ bh n

  get bh =
    do tag <- getByte bh
       case tag of
         1 -> do { n <- get bh
                 ; return (IfaceNumTyLit n) }
         2 -> do { n <- get bh
                 ; return (IfaceStrTyLit n) }
         _ -> panic ("get IfaceTyLit " ++ show tag)

961 962 963 964 965 966 967 968 969 970
instance Binary IfaceForAllBndr where
   put_ bh (IfaceTv tv vis) = do
     put_ bh tv
     put_ bh vis

   get bh = do
     tv <- get bh
     vis <- get bh
     return (IfaceTv tv vis)

971 972 973
instance Binary IfaceTcArgs where
  put_ bh tk =
    case tk of
974 975 976
      ITC_Vis   t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts
      ITC_Invis t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts
      ITC_Nil        -> putByte bh 2
977 978 979 980 981 982 983

  get bh =
    do c <- getByte bh
       case c of
         0 -> do
           t  <- get bh
           ts <- get bh
984
           return $! ITC_Vis t ts
985 986 987
         1 -> do
           t  <- get bh
           ts <- get bh
988
           return $! ITC_Invis t ts
989 990 991
         2 -> return ITC_Nil
         _ -> panic ("get IfaceTcArgs " ++ show c)

992
-------------------
993
pprIfaceContextArr :: Outputable a => [a] -> SDoc
994
-- Prints "(C a, D b) =>", including the arrow
995
pprIfaceContextArr = maybe empty (<+> darrow) . pprIfaceContextMaybe
996

997
pprIfaceContext :: Outputable a => [a] ->