TypeRep.lhs 27.8 KB
Newer Older
1
 | %
2
% (c) The University of Glasgow 2006
3 4 5 6
% (c) The GRASP/AQUA Project, Glasgow University, 1998
%
\section[TypeRep]{Type - friends' interface}

7 8 9 10 11 12 13 14 15 16
Note [The Type-related module hierarchy]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  Class
  TyCon    imports Class
  TypeRep 
  TysPrim  imports TypeRep ( including mkTyConTy )
  Kind     imports TysPrim ( mainly for primitive kinds )
  Type     imports Kind
  Coercion imports Type

17
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
18 19 20 21 22 23 24
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

25 26
-- We expose the relevant stuff from this module via the Type module
{-# OPTIONS_HADDOCK hide #-}
27
{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
28
module TypeRep (
batterseapower's avatar
batterseapower committed
29
	TyThing(..),
30
	Type(..),
31
        TyLit(..),
dreixel's avatar
dreixel committed
32
        KindOrType, Kind, SuperKind,
33
        PredType, ThetaType,      -- Synonyms
34

35
        -- Functions over types
36
        mkNakedTyConApp, mkTyConTy, mkTyVarTy, mkTyVarTys,
37
        isLiftedTypeKind, isSuperKind, isTypeVar, isKindVar,
batterseapower's avatar
batterseapower committed
38
        
39
        -- Pretty-printing
40
	pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs,
41
	pprTyThing, pprTyThingCategory, pprSigmaType,
batterseapower's avatar
batterseapower committed
42
	pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred,
43
        pprKind, pprParendKind, pprTyLit,
44
	Prec(..), maybeParen, pprTcApp, pprTypeNameApp, 
45
        pprPrefixApp, pprArrowChain, ppr_type,
46 47 48 49

        -- Free variables
        tyVarsOfType, tyVarsOfTypes,

Simon Peyton Jones's avatar
Simon Peyton Jones committed
50 51 52 53 54 55 56 57 58 59
        -- * Tidying type related things up for printing
        tidyType,      tidyTypes,
        tidyOpenType,  tidyOpenTypes,
        tidyOpenKind,
        tidyTyVarBndr, tidyTyVarBndrs, tidyFreeTyVars,
        tidyOpenTyVar, tidyOpenTyVars,
        tidyTyVarOcc,
        tidyTopType,
        tidyKind, 

60 61
        -- Substitutions
        TvSubst(..), TvSubstEnv
62 63 64 65
    ) where

#include "HsVersions.h"

66
import {-# SOURCE #-} DataCon( DataCon, dataConTyCon, dataConName )
batterseapower's avatar
batterseapower committed
67
import {-# SOURCE #-} Type( noParenPred, isPredTy ) -- Transitively pulls in a LOT of stuff, better to break the loop
68

69 70
-- friends:
import Var
71 72
import VarEnv
import VarSet
73 74 75 76
import Name
import BasicTypes
import TyCon
import Class
77
import CoAxiom
78 79

-- others
80
import PrelNames
81
import Outputable
twanvl's avatar
twanvl committed
82
import FastString
83
import Pair
84
import StaticFlags( opt_PprStyle_Debug )
85
import Util
86 87

-- libraries
Simon Peyton Jones's avatar
Simon Peyton Jones committed
88
import Data.List( mapAccumL )
89
import qualified Data.Data        as Data hiding ( TyCon )
90 91
\end{code}

92

93 94 95 96 97 98 99 100
%************************************************************************
%*									*
\subsection{The data type}
%*									*
%************************************************************************


\begin{code}
101
-- | The key representation of types within the compiler
102 103 104

-- If you edit this type, you may need to update the GHC formalism
-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs
105
data Type
dreixel's avatar
dreixel committed
106
  = TyVarTy Var	-- ^ Vanilla type or kind variable (*never* a coercion variable)
107

108
  | AppTy         -- See Note [AppTy invariant]
109
	Type
110 111
	Type		-- ^ Type application to something other than a 'TyCon'. Parameters:
	                --
112 113
                        --  1) Function: must /not/ be a 'TyConApp',
                        --     must be another 'AppTy', or 'TyVarTy'
114 115 116
	                --
	                --  2) Argument type

117
  | TyConApp      -- See Note [AppTy invariant]
118
	TyCon
dreixel's avatar
dreixel committed
119
	[KindOrType]	-- ^ Application of a 'TyCon', including newtypes /and/ synonyms.
120 121
	                -- Invariant: saturated appliations of 'FunTyCon' must
	                -- use 'FunTy' and saturated synonyms must use their own
122 123
                        -- constructors. However, /unsaturated/ 'FunTyCon's
                        -- do appear as 'TyConApp's.
124 125 126 127
	                -- Parameters:
	                --
	                -- 1) Type constructor being applied to.
	                --
128 129 130 131 132
                        -- 2) Type arguments. Might not have enough type arguments
                        --    here to saturate the constructor.
                        --    Even type synonyms are not necessarily saturated;
                        --    for example unsaturated type synonyms
	                --    can appear as the right hand side of a type synonym.
133 134

  | FunTy
135
	Type		
136
	Type		-- ^ Special case of 'TyConApp': @TyConApp FunTyCon [t1, t2]@
137
			-- See Note [Equality-constrained types]
138

139
  | ForAllTy
dreixel's avatar
dreixel committed
140
	Var         -- Type or kind variable
141 142
	Type	        -- ^ A polymorphic type

143
  | LitTy TyLit     -- ^ Type literals are simillar to type constructors.
144

145
  deriving (Data.Data, Data.Typeable)
146

147 148 149 150

-- NOTE:  Other parts of the code assume that type literals do not contain
-- types or type variables.
data TyLit
151 152
  = NumTyLit Integer
  | StrTyLit FastString
153 154
  deriving (Eq, Ord, Data.Data, Data.Typeable)

dreixel's avatar
dreixel committed
155 156
type KindOrType = Type -- See Note [Arguments to type constructors]

157 158 159 160 161 162 163 164 165 166 167 168 169 170
-- | The key type representing kinds in the compiler.
-- Invariant: a kind is always in one of these forms:
--
-- > FunTy k1 k2
-- > TyConApp PrimTyCon [...]
-- > TyVar kv   -- (during inference only)
-- > ForAll ... -- (for top-level coercions)
type Kind = Type

-- | "Super kinds", used to help encode 'Kind's as types.
-- Invariant: a super kind is always of this form:
--
-- > TyConApp SuperKindTyCon ...
type SuperKind = Type
171 172
\end{code}

173 174 175 176
Note [The kind invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~
The kinds
   #          UnliftedTypeKind
177
   OpenKind   super-kind of *, #
178 179 180 181 182 183 184 185 186 187 188 189 190 191

can never appear under an arrow or type constructor in a kind; they
can only be at the top level of a kind.  It follows that primitive TyCons,
which have a naughty pseudo-kind
   State# :: * -> #
must always be saturated, so that we can never get a type whose kind
has a UnliftedTypeKind or ArgTypeKind underneath an arrow.

Nor can we abstract over a type variable with any of these kinds.

    k :: = kk | # | ArgKind | (#) | OpenKind 
    kk :: = * | kk -> kk | T kk1 ... kkn

So a type variable can only be abstracted kk.
dreixel's avatar
dreixel committed
192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215

Note [Arguments to type constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Because of kind polymorphism, in addition to type application we now
have kind instantiation. We reuse the same notations to do so.

For example:

  Just (* -> *) Maybe
  Right * Nat Zero

are represented by:

  TyConApp (PromotedDataCon Just) [* -> *, Maybe]
  TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)]

Important note: Nat is used as a *kind* and not as a type. This can be
confusing, since type-level Nat and kind-level Nat are identical. We
use the kind of (PromotedDataCon Right) to know if its arguments are
kinds or types.

This kind instantiation only happens in TyConApp currently.


216 217 218 219 220 221
Note [Equality-constrained types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The type   forall ab. (a ~ [b]) => blah
is encoded like this:

   ForAllTy (a:*) $ ForAllTy (b:*) $
batterseapower's avatar
batterseapower committed
222
   FunTy (TyConApp (~) [a, [b]]) $
223 224
   blah

225
-------------------------------------
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
226
 		Note [PredTy]
227

228
\begin{code}
batterseapower's avatar
batterseapower committed
229
-- | A type of the form @p@ of kind @Constraint@ represents a value whose type is
230 231
-- the Haskell predicate @p@, where a predicate is what occurs before 
-- the @=>@ in a Haskell type.
batterseapower's avatar
batterseapower committed
232 233 234 235
--
-- We use 'PredType' as documentation to mark those types that we guarantee to have
-- this kind.
--
236 237 238 239 240 241 242 243 244 245 246 247 248
-- It can be expanded into its representation, but: 
--
-- * The type checker must treat it as opaque
--
-- * The rest of the compiler treats it as transparent
--
-- Consider these examples:
--
-- > f :: (Eq a) => a -> Int
-- > g :: (?x :: Int -> Int) => a -> Int
-- > h :: (r\l) => {r} => {l::Int | r}
--
-- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\"
batterseapower's avatar
batterseapower committed
249
type PredType = Type
250

251
-- | A collection of 'PredType's
252
type ThetaType = [PredType]
253 254
\end{code}

255 256 257 258 259 260
(We don't support TREX records yet, but the setup is designed
to expand to allow them.)

A Haskell qualified type, such as that for f,g,h above, is
represented using 
	* a FunTy for the double arrow
batterseapower's avatar
batterseapower committed
261
	* with a type of kind Constraint as the function argument
262 263

The predicate really does turn into a real extra argument to the
batterseapower's avatar
batterseapower committed
264 265
function.  If the argument has type (p :: Constraint) then the predicate p is
represented by evidence of type p.
266

267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282
%************************************************************************
%*									*
            Simple constructors
%*									*
%************************************************************************

These functions are here so that they can be used by TysPrim,
which in turn is imported by Type

\begin{code}
mkTyVarTy  :: TyVar   -> Type
mkTyVarTy  = TyVarTy

mkTyVarTys :: [TyVar] -> [Type]
mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy

283 284 285 286 287 288 289
mkNakedTyConApp :: TyCon -> [Type] -> Type
-- Builds a TyConApp 
--   * without being strict in TyCon,
--   * the TyCon should never be a saturated FunTyCon 
-- Type.mkTyConApp is the usual one
mkNakedTyConApp tc tys
  = TyConApp (ASSERT( not (isFunTyCon tc && length tys == 2) ) tc) tys
290 291 292

-- | Create the plain type constructor type which has been applied to no type arguments at all.
mkTyConTy :: TyCon -> Type
293
mkTyConTy tycon = TyConApp tycon []
294
\end{code}
295

296
Some basic functions, put here to break loops eg with the pretty printer
297

298
\begin{code}
299 300 301
isLiftedTypeKind :: Kind -> Bool
isLiftedTypeKind (TyConApp tc []) = tc `hasKey` liftedTypeKindTyConKey
isLiftedTypeKind _                = False
302 303 304 305 306 307 308 309 310 311 312

-- | Is this a super-kind (i.e. a type-of-kinds)?
isSuperKind :: Type -> Bool
isSuperKind (TyConApp skc []) = skc `hasKey` superKindTyConKey
isSuperKind _                 = False

isTypeVar :: Var -> Bool
isTypeVar v = isTKVar v && not (isSuperKind (varType v))

isKindVar :: Var -> Bool 
isKindVar v = isTKVar v && isSuperKind (varType v)
313 314 315 316 317 318 319 320 321
\end{code}


%************************************************************************
%*									*
			Free variables of types and coercions
%*									*
%************************************************************************

322
\begin{code}
323 324
tyVarsOfType :: Type -> VarSet
-- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym
325
-- tyVarsOfType returns only the free variables of a type
dreixel's avatar
dreixel committed
326 327
-- For example, tyVarsOfType (a::k) returns {a}, not including the
-- kind variable {k}
328 329
tyVarsOfType (TyVarTy v)         = unitVarSet v
tyVarsOfType (TyConApp _ tys)    = tyVarsOfTypes tys
330
tyVarsOfType (LitTy {})          = emptyVarSet
331 332 333
tyVarsOfType (FunTy arg res)     = tyVarsOfType arg `unionVarSet` tyVarsOfType res
tyVarsOfType (AppTy fun arg)     = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar
334
                                   `unionVarSet` tyVarsOfType (tyVarKind tyvar)
335 336 337 338 339

tyVarsOfTypes :: [Type] -> TyVarSet
tyVarsOfTypes tys = foldr (unionVarSet . tyVarsOfType) emptyVarSet tys
\end{code}

340 341 342 343 344 345 346 347 348
%************************************************************************
%*									*
			TyThing
%*									*
%************************************************************************

Despite the fact that DataCon has to be imported via a hi-boot route, 
this module seems the right place for TyThing, because it's needed for
funTyCon and all the types in TysPrim.
349

dreixel's avatar
dreixel committed
350 351 352 353 354 355 356 357
Note [ATyCon for classes]
~~~~~~~~~~~~~~~~~~~~~~~~~
Both classes and type constructors are represented in the type environment
as ATyCon.  You can tell the difference, and get to the class, with
   isClassTyCon :: TyCon -> Bool
   tyConClass_maybe :: TyCon -> Maybe Class
The Class and its associated TyCon have the same Name.

358
\begin{code}
359
-- | A typecheckable-thing, essentially anything that has a name
dreixel's avatar
dreixel committed
360 361 362 363
data TyThing 
  = AnId     Id
  | ADataCon DataCon
  | ATyCon   TyCon       -- TyCons and classes; see Note [ATyCon for classes]
364
  | ACoAxiom (CoAxiom Branched)
dreixel's avatar
dreixel committed
365
  deriving (Eq, Ord)
366

367 368 369 370 371
instance Outputable TyThing where 
  ppr = pprTyThing

pprTyThing :: TyThing -> SDoc
pprTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing))
372 373

pprTyThingCategory :: TyThing -> SDoc
batterseapower's avatar
batterseapower committed
374 375 376
pprTyThingCategory (ATyCon tc)
  | isClassTyCon tc = ptext (sLit "Class")
  | otherwise       = ptext (sLit "Type constructor")
377
pprTyThingCategory (ACoAxiom _) = ptext (sLit "Coercion axiom")
Ian Lynagh's avatar
Ian Lynagh committed
378 379
pprTyThingCategory (AnId   _)   = ptext (sLit "Identifier")
pprTyThingCategory (ADataCon _) = ptext (sLit "Data constructor")
380

381

382 383 384
instance NamedThing TyThing where	-- Can't put this with the type
  getName (AnId id)     = getName id	-- decl, because the DataCon instance
  getName (ATyCon tc)   = getName tc	-- isn't visible there
385
  getName (ACoAxiom cc) = getName cc
386
  getName (ADataCon dc) = dataConName dc
batterseapower's avatar
batterseapower committed
387

388
\end{code}
389

390

391 392
%************************************************************************
%*									*
393 394
			Substitutions
      Data type defined here to avoid unnecessary mutual recursion
395 396 397 398
%*									*
%************************************************************************

\begin{code}
399 400 401 402 403 404 405 406 407 408 409 410 411 412
-- | Type substitution
--
-- #tvsubst_invariant#
-- The following invariants must hold of a 'TvSubst':
-- 
-- 1. The in-scope set is needed /only/ to
-- guide the generation of fresh uniques
--
-- 2. In particular, the /kind/ of the type variables in 
-- the in-scope set is not relevant
--
-- 3. The substition is only applied ONCE! This is because
-- in general such application will not reached a fixed point.
data TvSubst 		
dreixel's avatar
dreixel committed
413 414
  = TvSubst InScopeSet 	-- The in-scope type and kind variables
	    TvSubstEnv  -- Substitutes both type and kind variables
415 416 417 418
	-- See Note [Apply Once]
	-- and Note [Extending the TvSubstEnv]

-- | A substitition of 'Type's for 'TyVar's
dreixel's avatar
dreixel committed
419
--                 and 'Kind's for 'KindVar's
420 421 422 423 424 425 426
type TvSubstEnv = TyVarEnv Type
	-- A TvSubstEnv is used both inside a TvSubst (with the apply-once
	-- invariant discussed in Note [Apply Once]), and also independently
	-- in the middle of matching, and unification (see Types.Unify)
	-- So you have to look at the context to know if it's idempotent or
	-- apply-once or whatever
\end{code}
427

428 429 430 431 432 433 434 435 436 437 438
Note [Apply Once]
~~~~~~~~~~~~~~~~~
We use TvSubsts to instantiate things, and we might instantiate
	forall a b. ty
\with the types
	[a, b], or [b, a].
So the substition might go [a->b, b->a].  A similar situation arises in Core
when we find a beta redex like
	(/\ a /\ b -> e) b a
Then we also end up with a substition that permutes type variables. Other
variations happen to; for example [a -> (a, b)].  
439

440 441 442
	***************************************************
	*** So a TvSubst must be applied precisely once ***
	***************************************************
443

444 445
A TvSubst is not idempotent, but, unlike the non-idempotent substitution
we use during unifications, it must not be repeatedly applied.
446

447 448 449
Note [Extending the TvSubst]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See #tvsubst_invariant# for the invariants that must hold.
450

451 452 453
This invariant allows a short-cut when the TvSubstEnv is empty:
if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt subst) holds ---
then (substTy subst ty) does nothing.
454

455 456 457 458
For example, consider:
	(/\a. /\b:(a~Int). ...b..) Int
We substitute Int for 'a'.  The Unique of 'b' does not change, but
nevertheless we add 'b' to the TvSubstEnv, because b's kind does change
459

460
This invariant has several crucial consequences:
461

462 463 464
* In substTyVarBndr, we need extend the TvSubstEnv 
	- if the unique has changed
	- or if the kind has changed
465

466 467
* In substTyVar, we do not need to consult the in-scope set;
  the TvSubstEnv is enough
468

469
* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty
470 471 472
\end{code}


473

474 475
%************************************************************************
%*									*
476 477 478 479
                   Pretty-printing types

       Defined very early because of debug printing in assertions
%*                                                                      *
480 481
%************************************************************************

482 483 484 485 486
@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is
defined to use this.  @pprParendType@ is the same, except it puts
parens around the type, except for the atomic cases.  @pprParendType@
works just by setting the initial context precedence very high.

487
\begin{code}
488 489 490 491 492 493 494 495 496 497 498 499
data Prec = TopPrec 	-- No parens
	  | FunPrec 	-- Function args; no parens for tycon apps
	  | TyConPrec 	-- Tycon args; no parens for atomic
	  deriving( Eq, Ord )

maybeParen :: Prec -> Prec -> SDoc -> SDoc
maybeParen ctxt_prec inner_prec pretty
  | ctxt_prec < inner_prec = pretty
  | otherwise		   = parens pretty

------------------
pprType, pprParendType :: Type -> SDoc
500
pprType       ty = ppr_type TopPrec ty
501 502
pprParendType ty = ppr_type TyConPrec ty

503 504 505
pprTyLit :: TyLit -> SDoc
pprTyLit = ppr_tylit TopPrec

506 507 508
pprKind, pprParendKind :: Kind -> SDoc
pprKind       = pprType
pprParendKind = pprParendType
509

510
------------------
511
pprEqPred :: Pair Type -> SDoc
512 513 514 515 516 517 518 519 520
-- NB: Maybe move to Coercion? It's only called after coercionKind anyway. 
pprEqPred (Pair ty1 ty2) 
  = sep [ ppr_type FunPrec ty1
        , nest 2 (ptext (sLit "~#"))
        , ppr_type FunPrec ty2]
    -- Precedence looks like (->) so that we get
    --    Maybe a ~ Bool
    --    (a->a) ~ Bool
    -- Note parens on the latter!
521

522
------------
523
pprClassPred :: Class -> [Type] -> SDoc
524
pprClassPred = ppr_class_pred ppr_type
525

526 527 528 529
ppr_class_pred :: (Prec -> a -> SDoc) -> Class -> [a] -> SDoc
ppr_class_pred pp clas tys = pprTypeNameApp TopPrec pp (getName clas) tys

------------
530
pprTheta :: ThetaType -> SDoc
simonpj@microsoft.com's avatar
Wibble  
simonpj@microsoft.com committed
531
-- pprTheta [pred] = pprPred pred	 -- I'm in two minds about this
batterseapower's avatar
batterseapower committed
532
pprTheta theta  = parens (sep (punctuate comma (map (ppr_type TopPrec) theta)))
533 534

pprThetaArrowTy :: ThetaType -> SDoc
batterseapower's avatar
batterseapower committed
535 536 537 538
pprThetaArrowTy []      = empty
pprThetaArrowTy [pred]
      | noParenPred pred = ppr_type TopPrec pred <+> darrow
pprThetaArrowTy preds   = parens (fsep (punctuate comma (map (ppr_type TopPrec) preds)))
539
                            <+> darrow
540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560
    -- Notice 'fsep' here rather that 'sep', so that
    -- type contexts don't get displayed in a giant column
    -- Rather than
    --  instance (Eq a,
    --            Eq b,
    --            Eq c,
    --            Eq d,
    --            Eq e,
    --            Eq f,
    --            Eq g,
    --            Eq h,
    --            Eq i,
    --            Eq j,
    --            Eq k,
    --            Eq l) =>
    --           Eq (a, b, c, d, e, f, g, h, i, j, k, l)
    -- we get
    --
    --  instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i,
    --            Eq j, Eq k, Eq l) =>
    --           Eq (a, b, c, d, e, f, g, h, i, j, k, l)
561 562 563 564 565

------------------
instance Outputable Type where
    ppr ty = pprType ty

566 567 568
instance Outputable TyLit where
   ppr = pprTyLit

569 570 571 572
------------------
	-- OK, here's the main printer

ppr_type :: Prec -> Type -> SDoc
573
ppr_type _ (TyVarTy tv)	      = ppr_tvar tv
574 575 576 577 578

ppr_type _ (TyConApp tc [LitTy (StrTyLit n),ty])
  | tc `hasKey` ipClassNameKey
  = char '?' <> ftext n <> ptext (sLit "::") <> ppr_type TopPrec ty

579
ppr_type p (TyConApp tc tys)  = pprTcApp p ppr_type tc tys
580

581
ppr_type p (LitTy l)          = ppr_tylit p l
582
ppr_type p ty@(ForAllTy {})   = ppr_forall_type p ty
583 584 585 586

ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
			   pprType t1 <+> ppr_type TyConPrec t2

batterseapower's avatar
batterseapower committed
587 588 589 590
ppr_type p fun_ty@(FunTy ty1 ty2)
  | isPredTy ty1
  = ppr_forall_type p fun_ty
  | otherwise
591
  = pprArrowChain p (ppr_type FunPrec ty1 : ppr_fun_tail ty2)
592
  where
593 594
    -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
    ppr_fun_tail (FunTy ty1 ty2)
batterseapower's avatar
batterseapower committed
595
      | not (isPredTy ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2
596 597
    ppr_fun_tail other_ty = [ppr_type TopPrec other_ty]

598

599 600
ppr_forall_type :: Prec -> Type -> SDoc
ppr_forall_type p ty
601
  = maybeParen p FunPrec $ (ppr_sigma_type True ty)
602

603 604
ppr_tvar :: TyVar -> SDoc
ppr_tvar tv  -- Note [Infix type variables]
605
  = parenSymOcc (getOccName tv) (ppr tv)
606

607
ppr_tylit :: Prec -> TyLit -> SDoc
608 609 610 611
ppr_tylit _ tl =
  case tl of
    NumTyLit n -> integer n
    StrTyLit s -> text (show s)
612

613
-------------------
614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633
ppr_sigma_type :: Bool -> Type -> SDoc
-- Bool <=> Show the foralls
ppr_sigma_type show_foralls ty
  =  sep [ if show_foralls then pprForAll tvs else empty
        , pprThetaArrowTy ctxt
        , pprType tau ]
  where
    (tvs,  rho) = split1 [] ty
    (ctxt, tau) = split2 [] rho

    split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
    split1 tvs ty          = (reverse tvs, ty)
 
    split2 ps (ty1 `FunTy` ty2) | isPredTy ty1 = split2 (ty1:ps) ty2
    split2 ps ty                               = (reverse ps, ty)


pprSigmaType :: Type -> SDoc
pprSigmaType ty = ppr_sigma_type opt_PprStyle_Debug ty

twanvl's avatar
twanvl committed
634
pprForAll :: [TyVar] -> SDoc
635
pprForAll []  = empty
636 637 638 639
pprForAll tvs = ptext (sLit "forall") <+> pprTvBndrs tvs <> dot

pprTvBndrs :: [TyVar] -> SDoc
pprTvBndrs tvs = sep (map pprTvBndr tvs)
640

twanvl's avatar
twanvl committed
641
pprTvBndr :: TyVar -> SDoc
642
pprTvBndr tv 
643
  | isLiftedTypeKind kind = ppr_tvar tv
644
  | otherwise	          = parens (ppr_tvar tv <+> dcolon <+> pprKind kind)
645 646 647 648
	     where
	       kind = tyVarKind tv
\end{code}

649 650
Note [Infix type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Ian Lynagh's avatar
Ian Lynagh committed
651
With TypeOperators you can say
652 653 654 655 656 657 658 659 660 661 662 663 664 665 666

   f :: (a ~> b) -> b

and the (~>) is considered a type variable.  However, the type
pretty-printer in this module will just see (a ~> b) as

   App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b")

So it'll print the type in prefix form.  To avoid confusion we must
remember to parenthesise the operator, thus

   (~>) a b -> b

See Trac #2766.

667 668 669 670 671 672 673 674 675 676 677
\begin{code}
pprTcApp :: Prec -> (Prec -> a -> SDoc) -> TyCon -> [a] -> SDoc
pprTcApp _ _ tc []      -- No brackets for SymOcc
  = pp_nt_debug <> ppr tc
  where
   pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc 
				             then ptext (sLit "<recnt>")
					     else ptext (sLit "<nt>"))
	       | otherwise     = empty

pprTcApp _ pp tc [ty]
678 679
  | tc `hasKey` listTyConKey   = pprPromotionQuote tc <> brackets   (pp TopPrec ty)
  | tc `hasKey` parrTyConKey   = pprPromotionQuote tc <> paBrackets (pp TopPrec ty)
680 681 682

pprTcApp p pp tc tys
  | isTupleTyCon tc && tyConArity tc == length tys
683 684 685
  = pprPromotionQuote tc <>
    tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys)))

686 687 688 689 690 691 692 693 694 695
  | Just dc <- isPromotedDataCon_maybe tc
  , let dc_tc = dataConTyCon dc
  , isTupleTyCon dc_tc 
  , let arity = tyConArity dc_tc    -- E.g. 3 for (,,) k1 k2 k3 t1 t2 t3
        ty_args = drop arity tys    -- Drop the kind args
  , ty_args `lengthIs` arity        -- Result is saturated
  = pprPromotionQuote tc <>
    (tupleParens (tupleTyConSort dc_tc) $
     sep (punctuate comma (map (pp TopPrec) ty_args)))

696
  | not opt_PprStyle_Debug
697 698
  , getUnique tc `elem` [eqTyConKey, eqPrimTyConKey] 
                           -- We need to special case the type equality TyCons because
699
  , [_, ty1,ty2] <- tys    -- with kind polymorphism it has 3 args, so won't get printed infix
700
                           -- With -dppr-debug switch this off so we can see the kind
701 702
  = pprInfixApp p pp (ppr tc) ty1 ty2

703
  | otherwise
704
  = ppr_type_name_app p pp (ppr tc) (isSymOcc (getOccName tc)) tys
705 706 707 708 709

----------------
pprTypeApp :: NamedThing a => a -> [Type] -> SDoc
-- The first arg is the tycon, or sometimes class
-- Print infix if the tycon/class looks like an operator
710 711
pprTypeApp tc tys 
  = pprTypeNameApp TopPrec ppr_type (getName tc) tys
712

713 714
pprTypeNameApp :: Prec -> (Prec -> a -> SDoc) -> Name -> [a] -> SDoc
-- Used for classes and coercions as well as types; that's why it's separate from pprTcApp
715 716 717 718 719
pprTypeNameApp p pp name tys
  = ppr_type_name_app p pp (ppr name) (isSymOcc (getOccName name)) tys

ppr_type_name_app :: Prec -> (Prec -> a -> SDoc) -> SDoc -> Bool -> [a] -> SDoc
ppr_type_name_app p pp pp_tc is_sym_occ tys
720 721
  | is_sym_occ           -- Print infix if possible
  , [ty1,ty2] <- tys  -- We know nothing of precedence though
722
  = pprInfixApp p pp pp_tc ty1 ty2
723
  | otherwise
724
  = pprPrefixApp p (pprPrefixVar is_sym_occ pp_tc) (map (pp TyConPrec) tys)
725

726
----------------
727 728
pprInfixApp :: Prec -> (Prec -> a -> SDoc) -> SDoc -> a -> a -> SDoc
pprInfixApp p pp pp_tc ty1 ty2
batterseapower's avatar
batterseapower committed
729
  = maybeParen p FunPrec $
730
    sep [pp FunPrec ty1, pprInfixVar True pp_tc <+> pp FunPrec ty2]
batterseapower's avatar
batterseapower committed
731

732 733 734 735 736 737 738 739 740 741 742
pprPrefixApp :: Prec -> SDoc -> [SDoc] -> SDoc
pprPrefixApp p pp_fun pp_tys = maybeParen p TyConPrec $
                               hang pp_fun 2 (sep pp_tys)

----------------
pprArrowChain :: Prec -> [SDoc] -> SDoc
-- pprArrowChain p [a,b,c]  generates   a -> b -> c
pprArrowChain _ []         = empty
pprArrowChain p (arg:args) = maybeParen p FunPrec $
                             sep [arg, sep (map (arrow <+>) args)]
\end{code}
743

Simon Peyton Jones's avatar
Simon Peyton Jones committed
744 745 746 747 748 749
%************************************************************************
%*									*
\subsection{TidyType}
%*									*
%************************************************************************

Gabor Greif's avatar
typos  
Gabor Greif committed
750
Tidying is here because it has a special case for FlatSkol
Simon Peyton Jones's avatar
Simon Peyton Jones committed
751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851

\begin{code}
-- | This tidies up a type for printing in an error message, or in
-- an interface file.
-- 
-- It doesn't change the uniques at all, just the print names.
tidyTyVarBndrs :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
tidyTyVarBndrs env tvs = mapAccumL tidyTyVarBndr env tvs

tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
tidyTyVarBndr tidy_env@(occ_env, subst) tyvar
  = case tidyOccName occ_env occ1 of
      (tidy', occ') -> ((tidy', subst'), tyvar')
	where
          subst' = extendVarEnv subst tyvar tyvar'
          tyvar' = setTyVarKind (setTyVarName tyvar name') kind'
          name'  = tidyNameOcc name occ'
          kind'  = tidyKind tidy_env (tyVarKind tyvar)
  where
    name = tyVarName tyvar
    occ  = getOccName name
    -- System Names are for unification variables;
    -- when we tidy them we give them a trailing "0" (or 1 etc)
    -- so that they don't take precedence for the un-modified name
    occ1 | isSystemName name = mkTyVarOcc (occNameString occ ++ "0")
         | otherwise         = occ


---------------
tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
-- ^ Add the free 'TyVar's to the env in tidy form,
-- so that we can tidy the type they are free in
tidyFreeTyVars (full_occ_env, var_env) tyvars 
  = fst (tidyOpenTyVars (full_occ_env, var_env) (varSetElems tyvars))

        ---------------
tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars

---------------
tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
-- ^ Treat a new 'TyVar' as a binder, and give it a fresh tidy name
-- using the environment if one has not already been allocated. See
-- also 'tidyTyVarBndr'
tidyOpenTyVar env@(_, subst) tyvar
  = case lookupVarEnv subst tyvar of
	Just tyvar' -> (env, tyvar')		-- Already substituted
	Nothing	    -> tidyTyVarBndr env tyvar	-- Treat it as a binder

---------------
tidyTyVarOcc :: TidyEnv -> TyVar -> TyVar
tidyTyVarOcc (_, subst) tv
  = case lookupVarEnv subst tv of
	Nothing  -> tv
	Just tv' -> tv'

---------------
tidyTypes :: TidyEnv -> [Type] -> [Type]
tidyTypes env tys = map (tidyType env) tys

---------------
tidyType :: TidyEnv -> Type -> Type
tidyType _   (LitTy n)            = LitTy n
tidyType env (TyVarTy tv)	  = TyVarTy (tidyTyVarOcc env tv)
tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys
 		                    in args `seqList` TyConApp tycon args
tidyType env (AppTy fun arg)	  = (AppTy $! (tidyType env fun)) $! (tidyType env arg)
tidyType env (FunTy fun arg)	  = (FunTy $! (tidyType env fun)) $! (tidyType env arg)
tidyType env (ForAllTy tv ty)	  = ForAllTy tvp $! (tidyType envp ty)
			          where
			            (envp, tvp) = tidyTyVarBndr env tv

---------------
-- | Grabs the free type variables, tidies them
-- and then uses 'tidyType' to work over the type itself
tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
tidyOpenType env ty
  = (env', tidyType (trimmed_occ_env, var_env) ty)
  where
    (env'@(_, var_env), tvs') = tidyOpenTyVars env (varSetElems (tyVarsOfType ty))
    trimmed_occ_env = initTidyOccEnv (map getOccName tvs')
      -- The idea here was that we restrict the new TidyEnv to the 
      -- _free_ vars of the type, so that we don't gratuitously rename
      -- the _bound_ variables of the type.

---------------
tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
tidyOpenTypes env tys = mapAccumL tidyOpenType env tys

---------------
-- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment)
tidyTopType :: Type -> Type
tidyTopType ty = tidyType emptyTidyEnv ty

---------------
tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind)
tidyOpenKind = tidyOpenType

tidyKind :: TidyEnv -> Kind -> Kind
tidyKind = tidyType
\end{code}