Type.lhs 63.3 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2006
3
4
5
% (c) The GRASP/AQUA Project, Glasgow University, 1998
%

6
Type - public interface
7

8
\begin{code}
9
{-# LANGUAGE CPP #-}
10
{-# OPTIONS_GHC -fno-warn-orphans #-}
Ian Lynagh's avatar
Ian Lynagh committed
11

batterseapower's avatar
batterseapower committed
12
-- | Main functions for manipulating types and type-related things
13
module Type (
ian@well-typed.com's avatar
ian@well-typed.com committed
14
        -- Note some of this is just re-exports from TyCon..
15

batterseapower's avatar
batterseapower committed
16
        -- * Main data types representing Types
ian@well-typed.com's avatar
ian@well-typed.com committed
17
18
        -- $type_classification

batterseapower's avatar
batterseapower committed
19
        -- $representation_types
dreixel's avatar
dreixel committed
20
        TyThing(..), Type, KindOrType, PredType, ThetaType,
ian@well-typed.com's avatar
ian@well-typed.com committed
21
        Var, TyVar, isTyVar,
22

batterseapower's avatar
batterseapower committed
23
24
        -- ** Constructing and deconstructing types
        mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe,
25

26
        mkAppTy, mkAppTys, splitAppTy, splitAppTys,
ian@well-typed.com's avatar
ian@well-typed.com committed
27
        splitAppTy_maybe, repSplitAppTy_maybe,
28

ian@well-typed.com's avatar
ian@well-typed.com committed
29
30
31
        mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe,
        splitFunTys, splitFunTysN,
        funResultTy, funArgTy, zipFunTys,
32

ian@well-typed.com's avatar
ian@well-typed.com committed
33
34
35
        mkTyConApp, mkTyConTy,
        tyConAppTyCon_maybe, tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,
        splitTyConApp_maybe, splitTyConApp, tyConAppArgN,
36

ian@well-typed.com's avatar
ian@well-typed.com committed
37
        mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
38
        mkPiKinds, mkPiType, mkPiTypes,
ian@well-typed.com's avatar
ian@well-typed.com committed
39
        applyTy, applyTys, applyTysD, isForAllTy, dropForAlls,
40

41
42
        mkNumLitTy, isNumLitTy,
        mkStrLitTy, isStrLitTy,
43
44

        coAxNthLHS,
ian@well-typed.com's avatar
ian@well-typed.com committed
45
46
47
48
49

        -- (Newtypes)
        newTyConInstRhs,

        -- Pred types
batterseapower's avatar
batterseapower committed
50
        mkFamilyTyConApp,
ian@well-typed.com's avatar
ian@well-typed.com committed
51
        isDictLikeTy,
Joachim Breitner's avatar
Joachim Breitner committed
52
        mkEqPred, mkCoerciblePred, mkPrimEqPred, mkReprPrimEqPred,
53
        mkClassPred,
ian@well-typed.com's avatar
ian@well-typed.com committed
54
        noParenPred, isClassPred, isEqPred,
55
        isIPPred, isIPPred_maybe, isIPTyCon, isIPClass,
ian@well-typed.com's avatar
ian@well-typed.com committed
56

batterseapower's avatar
batterseapower committed
57
        -- Deconstructing predicate types
58
        PredTree(..), classifyPredType,
batterseapower's avatar
batterseapower committed
59
        getClassPredTys, getClassPredTys_maybe,
Joachim Breitner's avatar
Joachim Breitner committed
60
        getEqPredTys, getEqPredTys_maybe, getEqPredRole,
61

ian@well-typed.com's avatar
ian@well-typed.com committed
62
        -- ** Common type constructors
batterseapower's avatar
batterseapower committed
63
        funTyCon,
64

batterseapower's avatar
batterseapower committed
65
        -- ** Predicates on types
66
        isTypeVar, isKindVar,
67
        isTyVarTy, isFunTy, isDictTy, isPredTy, isVoidTy,
batterseapower's avatar
batterseapower committed
68

ian@well-typed.com's avatar
ian@well-typed.com committed
69
70
71
        -- (Lifting and boxity)
        isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType,
        isPrimitiveType, isStrictType,
72

ian@well-typed.com's avatar
ian@well-typed.com committed
73
74
        -- * Main data types representing Kinds
        -- $kind_subtyping
dreixel's avatar
dreixel committed
75
        Kind, SimpleKind, MetaKindVar,
batterseapower's avatar
batterseapower committed
76
77
78

        -- ** Finding the kind of a type
        typeKind,
ian@well-typed.com's avatar
ian@well-typed.com committed
79

batterseapower's avatar
batterseapower committed
80
        -- ** Common Kinds and SuperKinds
dreixel's avatar
dreixel committed
81
        anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind,
ian@well-typed.com's avatar
ian@well-typed.com committed
82
        constraintKind, superKind,
batterseapower's avatar
batterseapower committed
83
84
85

        -- ** Common Kind type constructors
        liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
86
        constraintKindTyCon, anyKindTyCon,
batterseapower's avatar
batterseapower committed
87

ian@well-typed.com's avatar
ian@well-typed.com committed
88
        -- * Type free variables
89
        tyVarsOfType, tyVarsOfTypes, closeOverKinds,
ian@well-typed.com's avatar
ian@well-typed.com committed
90
91
        expandTypeSynonyms,
        typeSize, varSetElemsKvsFirst,
92

ian@well-typed.com's avatar
ian@well-typed.com committed
93
94
95
        -- * Type comparison
        eqType, eqTypeX, eqTypes, cmpType, cmpTypes,
        eqPred, eqPredX, cmpPred, eqKind, eqTyVarBndrs,
96

ian@well-typed.com's avatar
ian@well-typed.com committed
97
        -- * Forcing evaluation of types
batterseapower's avatar
batterseapower committed
98
        seqType, seqTypes,
99

batterseapower's avatar
batterseapower committed
100
        -- * Other views onto Types
ian@well-typed.com's avatar
ian@well-typed.com committed
101
        coreView, tcView,
batterseapower's avatar
batterseapower committed
102

103
        UnaryType, RepType(..), flattenRepType, repType,
104
        tyConsOfType,
batterseapower's avatar
batterseapower committed
105

ian@well-typed.com's avatar
ian@well-typed.com committed
106
107
108
109
110
111
112
113
114
115
116
        -- * Type representation for the code generator
        typePrimRep, typeRepArity,

        -- * Main type substitution data types
        TvSubstEnv,     -- Representation widely visible
        TvSubst(..),    -- Representation visible to a few friends

        -- ** Manipulating type substitutions
        emptyTvSubstEnv, emptyTvSubst,

        mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
117
118
        getTvSubstEnv, setTvSubstEnv,
        zapTvSubstEnv, getTvInScope,
119
        extendTvInScope, extendTvInScopeList,
ian@well-typed.com's avatar
ian@well-typed.com committed
120
        extendTvSubst, extendTvSubstList,
121
        isInScope, composeTvSubst, zipTyEnv,
122
        isEmptyTvSubst, unionTvSubst,
123

ian@well-typed.com's avatar
ian@well-typed.com committed
124
125
        -- ** Performing substitution on types and kinds
        substTy, substTys, substTyWith, substTysWith, substTheta,
batterseapower's avatar
batterseapower committed
126
        substTyVar, substTyVars, substTyVarBndr,
dreixel's avatar
dreixel committed
127
128
        cloneTyVarBndr, deShadowTy, lookupTyVar,
        substKiWith, substKisWith,
129

ian@well-typed.com's avatar
ian@well-typed.com committed
130
131
        -- * Pretty-printing
        pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing,
132
        pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll, pprSigmaType,
ian@well-typed.com's avatar
ian@well-typed.com committed
133
        pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred,
dreixel's avatar
dreixel committed
134
        pprKind, pprParendKind, pprSourceTyCon,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
135
136
137
138
139
140
141
142
143

        -- * Tidying type related things up for printing
        tidyType,      tidyTypes,
        tidyOpenType,  tidyOpenTypes,
        tidyOpenKind,
        tidyTyVarBndr, tidyTyVarBndrs, tidyFreeTyVars,
        tidyOpenTyVar, tidyOpenTyVars,
        tidyTyVarOcc,
        tidyTopType,
ian@well-typed.com's avatar
ian@well-typed.com committed
144
        tidyKind,
145
    ) where
146

147
148
#include "HsVersions.h"

149
150
151
-- We import the representation and primitive functions from TypeRep.
-- Many things are reexported, but not the representation!

dreixel's avatar
dreixel committed
152
import Kind
153
154
import TypeRep

155
-- friends:
156
import Var
157
158
import VarEnv
import VarSet
159
import NameEnv
160

161
162
import Class
import TyCon
163
import TysPrim
Joachim Breitner's avatar
Joachim Breitner committed
164
import {-# SOURCE #-} TysWiredIn ( eqTyCon, coercibleTyCon, typeNatKind, typeSymbolKind )
Joachim Breitner's avatar
Joachim Breitner committed
165
166
import PrelNames ( eqTyConKey, coercibleTyConKey,
                   ipClassNameKey, openTypeKindTyConKey,
167
                   constraintKindTyConKey, liftedTypeKindTyConKey )
168
import CoAxiom
169

170
-- others
ian@well-typed.com's avatar
ian@well-typed.com committed
171
172
import Unique           ( Unique, hasKey )
import BasicTypes       ( Arity, RepArity )
173
import Util
174
import Outputable
175
import FastString
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
176

ian@well-typed.com's avatar
ian@well-typed.com committed
177
178
import Maybes           ( orElse )
import Data.Maybe       ( isJust )
179
import Control.Monad    ( guard )
180

ian@well-typed.com's avatar
ian@well-typed.com committed
181
infixr 3 `mkFunTy`      -- Associates to the right
182
183
\end{code}

batterseapower's avatar
batterseapower committed
184
185
186
\begin{code}
-- $type_classification
-- #type_classification#
ian@well-typed.com's avatar
ian@well-typed.com committed
187
--
batterseapower's avatar
batterseapower committed
188
-- Types are one of:
ian@well-typed.com's avatar
ian@well-typed.com committed
189
--
batterseapower's avatar
batterseapower committed
190
-- [Unboxed]            Iff its representation is other than a pointer
ian@well-typed.com's avatar
ian@well-typed.com committed
191
192
--                      Unboxed types are also unlifted.
--
batterseapower's avatar
batterseapower committed
193
-- [Lifted]             Iff it has bottom as an element.
ian@well-typed.com's avatar
ian@well-typed.com committed
194
195
196
197
198
199
--                      Closures always have lifted types: i.e. any
--                      let-bound identifier in Core must have a lifted
--                      type. Operationally, a lifted object is one that
--                      can be entered.
--                      Only lifted types may be unified with a type variable.
--
batterseapower's avatar
batterseapower committed
200
-- [Algebraic]          Iff it is a type with one or more constructors, whether
ian@well-typed.com's avatar
ian@well-typed.com committed
201
202
203
204
205
206
--                      declared with @data@ or @newtype@.
--                      An algebraic type is one that can be deconstructed
--                      with a case expression. This is /not/ the same as
--                      lifted types, because we also include unboxed
--                      tuples in this classification.
--
batterseapower's avatar
batterseapower committed
207
-- [Data]               Iff it is a type declared with @data@, or a boxed tuple.
ian@well-typed.com's avatar
ian@well-typed.com committed
208
--
batterseapower's avatar
batterseapower committed
209
-- [Primitive]          Iff it is a built-in type that can't be expressed in Haskell.
ian@well-typed.com's avatar
ian@well-typed.com committed
210
--
batterseapower's avatar
batterseapower committed
211
212
-- Currently, all primitive types are unlifted, but that's not necessarily
-- the case: for example, @Int@ could be primitive.
ian@well-typed.com's avatar
ian@well-typed.com committed
213
--
batterseapower's avatar
batterseapower committed
214
215
216
-- Some primitive types are unboxed, such as @Int#@, whereas some are boxed
-- but unlifted (such as @ByteArray#@).  The only primitive types that we
-- classify as algebraic are the unboxed tuples.
ian@well-typed.com's avatar
ian@well-typed.com committed
217
--
batterseapower's avatar
batterseapower committed
218
-- Some examples of type classifications that may make this a bit clearer are:
ian@well-typed.com's avatar
ian@well-typed.com committed
219
--
batterseapower's avatar
batterseapower committed
220
221
222
223
224
225
226
227
228
229
230
231
232
-- @
-- Type         primitive       boxed           lifted          algebraic
-- -----------------------------------------------------------------------------
-- Int#         Yes             No              No              No
-- ByteArray#   Yes             Yes             No              No
-- (\# a, b \#)   Yes             No              No              Yes
-- (  a, b  )   No              Yes             Yes             Yes
-- [a]          No              Yes             Yes             Yes
-- @

-- $representation_types
-- A /source type/ is a type that is a separate type as far as the type checker is
-- concerned, but which has a more low-level representation as far as Core-to-Core
batterseapower's avatar
batterseapower committed
233
-- passes and the rest of the back end is concerned.
batterseapower's avatar
batterseapower committed
234
235
236
237
238
239
--
-- You don't normally have to worry about this, as the utility functions in
-- this module will automatically convert a source into a representation type
-- if they are spotted, to the best of it's abilities. If you don't want this
-- to happen, use the equivalent functions from the "TcType" module.
\end{code}
240

241
%************************************************************************
ian@well-typed.com's avatar
ian@well-typed.com committed
242
243
244
%*                                                                      *
                Type representation
%*                                                                      *
245
246
247
248
249
%************************************************************************

\begin{code}
{-# INLINE coreView #-}
coreView :: Type -> Maybe Type
batterseapower's avatar
batterseapower committed
250
251
252
-- ^ In Core, we \"look through\" non-recursive newtypes and 'PredTypes': this
-- function tries to obtain a different view of the supplied type given this
--
ian@well-typed.com's avatar
ian@well-typed.com committed
253
254
-- Strips off the /top layer only/ of a type to give
-- its underlying representation type.
255
256
-- Returns Nothing if there is nothing to look through.
--
257
258
-- By being non-recursive and inlined, this case analysis gets efficiently
-- joined onto the case analysis that the caller is already doing
ian@well-typed.com's avatar
ian@well-typed.com committed
259
coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys
batterseapower's avatar
batterseapower committed
260
261
              = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
               -- Its important to use mkAppTys, rather than (foldl AppTy),
ian@well-typed.com's avatar
ian@well-typed.com committed
262
               -- because the function part might well return a
batterseapower's avatar
batterseapower committed
263
               -- partially-applied type constructor; indeed, usually will!
264
coreView _                 = Nothing
265
266
267
268

-----------------------------------------------
{-# INLINE tcView #-}
tcView :: Type -> Maybe Type
batterseapower's avatar
batterseapower committed
269
-- ^ Similar to 'coreView', but for the type checker, which just looks through synonyms
ian@well-typed.com's avatar
ian@well-typed.com committed
270
271
tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys
                         = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
272
tcView _                 = Nothing
273
274
275
  -- You might think that tcView belows in TcType rather than Type, but unfortunately
  -- it is needed by Unify, which is turn imported by Coercion (for MatchEnv and matchList).
  -- So we will leave it here to avoid module loops.
276

277
278
279
280
281
-----------------------------------------------
expandTypeSynonyms :: Type -> Type
-- ^ Expand out all type synonyms.  Actually, it'd suffice to expand out
-- just the ones that discard type variables (e.g.  type Funny a = Int)
-- But we don't know which those are currently, so we just expand all.
ian@well-typed.com's avatar
ian@well-typed.com committed
282
expandTypeSynonyms ty
283
284
285
  = go ty
  where
    go (TyConApp tc tys)
ian@well-typed.com's avatar
ian@well-typed.com committed
286
      | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys
287
288
289
      = go (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
      | otherwise
      = TyConApp tc (map go tys)
290
    go (LitTy l)       = LitTy l
291
    go (TyVarTy tv)    = TyVarTy tv
292
    go (AppTy t1 t2)   = mkAppTy (go t1) (go t2)
293
294
    go (FunTy t1 t2)   = FunTy (go t1) (go t2)
    go (ForAllTy tv t) = ForAllTy tv (go t)
295
296
297
\end{code}


298
%************************************************************************
ian@well-typed.com's avatar
ian@well-typed.com committed
299
%*                                                                      *
300
\subsection{Constructor-specific functions}
ian@well-typed.com's avatar
ian@well-typed.com committed
301
%*                                                                      *
302
%************************************************************************
sof's avatar
sof committed
303
304


305
---------------------------------------------------------------------
ian@well-typed.com's avatar
ian@well-typed.com committed
306
307
                                TyVarTy
                                ~~~~~~~
308
\begin{code}
batterseapower's avatar
batterseapower committed
309
310
-- | Attempts to obtain the type variable underlying a 'Type', and panics with the
-- given message if this is not a type variable type. See also 'getTyVar_maybe'
311
getTyVar :: String -> Type -> TyVar
312
getTyVar msg ty = case getTyVar_maybe ty of
ian@well-typed.com's avatar
ian@well-typed.com committed
313
314
                    Just tv -> tv
                    Nothing -> panic ("getTyVar: " ++ msg)
315

316
isTyVarTy :: Type -> Bool
317
318
isTyVarTy ty = isJust (getTyVar_maybe ty)

batterseapower's avatar
batterseapower committed
319
-- | Attempts to obtain the type variable underlying a 'Type'
320
getTyVar_maybe :: Type -> Maybe TyVar
321
getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty'
ian@well-typed.com's avatar
ian@well-typed.com committed
322
getTyVar_maybe (TyVarTy tv)                 = Just tv
323
getTyVar_maybe _                            = Nothing
324

325
326
327
\end{code}


328
---------------------------------------------------------------------
ian@well-typed.com's avatar
ian@well-typed.com committed
329
330
331
                                AppTy
                                ~~~~~
We need to be pretty careful with AppTy to make sure we obey the
332
333
invariant that a TyConApp is always visibly so.  mkAppTy maintains the
invariant: use it.
334

335
\begin{code}
batterseapower's avatar
batterseapower committed
336
-- | Applies a type to another, as in e.g. @k a@
337
mkAppTy :: Type -> Type -> Type
338
339
mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2])
mkAppTy ty1               ty2 = AppTy ty1 ty2
ian@well-typed.com's avatar
ian@well-typed.com committed
340
341
342
343
344
345
346
347
        -- Note that the TyConApp could be an
        -- under-saturated type synonym.  GHC allows that; e.g.
        --      type Foo k = k a -> k a
        --      type Id x = x
        --      foo :: Foo Id -> Foo Id
        --
        -- Here Id is partially applied in the type sig for Foo,
        -- but once the type synonyms are expanded all is well
348

349
mkAppTys :: Type -> [Type] -> Type
ian@well-typed.com's avatar
ian@well-typed.com committed
350
mkAppTys ty1                []   = ty1
351
352
353
mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2)
mkAppTys ty1                tys2 = foldl AppTy ty1 tys2

354
-------------
355
splitAppTy_maybe :: Type -> Maybe (Type, Type)
batterseapower's avatar
batterseapower committed
356
357
358
-- ^ Attempt to take a type application apart, whether it is a
-- function, type constructor, or plain type application. Note
-- that type family applications are NEVER unsaturated by this!
359
splitAppTy_maybe ty | Just ty' <- coreView ty
ian@well-typed.com's avatar
ian@well-typed.com committed
360
                    = splitAppTy_maybe ty'
361
splitAppTy_maybe ty = repSplitAppTy_maybe ty
362

363
364
-------------
repSplitAppTy_maybe :: Type -> Maybe (Type,Type)
ian@well-typed.com's avatar
ian@well-typed.com committed
365
-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that
batterseapower's avatar
batterseapower committed
366
-- any Core view stuff is already done
367
368
repSplitAppTy_maybe (FunTy ty1 ty2)   = Just (TyConApp funTyCon [ty1], ty2)
repSplitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
ian@well-typed.com's avatar
ian@well-typed.com committed
369
370
repSplitAppTy_maybe (TyConApp tc tys)
  | isDecomposableTyCon tc || tys `lengthExceeds` tyConArity tc
371
372
  , Just (tys', ty') <- snocView tys
  = Just (TyConApp tc tys', ty')    -- Never create unsaturated type family apps!
373
repSplitAppTy_maybe _other = Nothing
374
-------------
375
splitAppTy :: Type -> (Type, Type)
batterseapower's avatar
batterseapower committed
376
377
-- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe',
-- and panics if this is not possible
378
splitAppTy ty = case splitAppTy_maybe ty of
ian@well-typed.com's avatar
ian@well-typed.com committed
379
380
                Just pr -> pr
                Nothing -> panic "splitAppTy"
381

382
-------------
383
splitAppTys :: Type -> (Type, [Type])
batterseapower's avatar
batterseapower committed
384
385
386
-- ^ Recursively splits a type as far as is possible, leaving a residual
-- type being applied to and the type arguments applied to it. Never fails,
-- even if that means returning an empty list of type applications.
387
splitAppTys ty = split ty ty []
388
  where
389
    split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args
390
391
    split _       (AppTy ty arg)        args = split ty ty (arg:args)
    split _       (TyConApp tc tc_args) args
392
      = let -- keep type families saturated
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
393
394
            n | isDecomposableTyCon tc = 0
              | otherwise              = tyConArity tc
395
            (tc_args1, tc_args2) = splitAt n tc_args
396
397
        in
        (TyConApp tc tc_args1, tc_args2 ++ args)
398
    split _       (FunTy ty1 ty2)       args = ASSERT( null args )
ian@well-typed.com's avatar
ian@well-typed.com committed
399
                                               (TyConApp funTyCon [], [ty1,ty2])
400
    split orig_ty _                     args = (orig_ty, args)
401

402
403
\end{code}

404

405
                      LitTy
406
                      ~~~~~
407
408

\begin{code}
409
410
mkNumLitTy :: Integer -> Type
mkNumLitTy n = LitTy (NumTyLit n)
411

412
-- | Is this a numeric literal. We also look through type synonyms.
413
isNumLitTy :: Type -> Maybe Integer
414
isNumLitTy ty | Just ty1 <- tcView ty = isNumLitTy ty1
415
416
isNumLitTy (LitTy (NumTyLit n)) = Just n
isNumLitTy _                    = Nothing
417

418
419
420
mkStrLitTy :: FastString -> Type
mkStrLitTy s = LitTy (StrTyLit s)

421
-- | Is this a symbol literal. We also look through type synonyms.
422
isStrLitTy :: Type -> Maybe FastString
423
isStrLitTy ty | Just ty1 <- tcView ty = isStrLitTy ty1
424
425
isStrLitTy (LitTy (StrTyLit s)) = Just s
isStrLitTy _                    = Nothing
426
427
428
429

\end{code}


430
---------------------------------------------------------------------
ian@well-typed.com's avatar
ian@well-typed.com committed
431
432
                                FunTy
                                ~~~~~
433

434
\begin{code}
435
mkFunTy :: Type -> Type -> Type
batterseapower's avatar
batterseapower committed
436
-- ^ Creates a function type from the given argument and result type
437
mkFunTy arg res = FunTy arg res
438

439
mkFunTys :: [Type] -> Type -> Type
440
mkFunTys tys ty = foldr mkFunTy ty tys
441

ian@well-typed.com's avatar
ian@well-typed.com committed
442
isFunTy :: Type -> Bool
443
444
isFunTy ty = isJust (splitFunTy_maybe ty)

445
splitFunTy :: Type -> (Type, Type)
batterseapower's avatar
batterseapower committed
446
447
-- ^ Attempts to extract the argument and result types from a type, and
-- panics if that is not possible. See also 'splitFunTy_maybe'
448
splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty'
ian@well-typed.com's avatar
ian@well-typed.com committed
449
450
splitFunTy (FunTy arg res) = (arg, res)
splitFunTy other           = pprPanic "splitFunTy" (ppr other)
451

452
splitFunTy_maybe :: Type -> Maybe (Type, Type)
batterseapower's avatar
batterseapower committed
453
-- ^ Attempts to extract the argument and result types from a type
454
splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty'
455
splitFunTy_maybe (FunTy arg res)   = Just (arg, res)
456
splitFunTy_maybe _                 = Nothing
457

458
splitFunTys :: Type -> ([Type], Type)
459
splitFunTys ty = split [] ty ty
460
  where
461
    split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty'
462
463
    split args _       (FunTy arg res)   = split (arg:args) res res
    split args orig_ty _                 = (reverse args, orig_ty)
464

465
splitFunTysN :: Int -> Type -> ([Type], Type)
batterseapower's avatar
batterseapower committed
466
-- ^ Split off exactly the given number argument types, and panics if that is not possible
467
splitFunTysN 0 ty = ([], ty)
simonpj@microsoft.com's avatar
Assert    
simonpj@microsoft.com committed
468
469
splitFunTysN n ty = ASSERT2( isFunTy ty, int n <+> ppr ty )
                    case splitFunTy ty of { (arg, res) ->
ian@well-typed.com's avatar
ian@well-typed.com committed
470
471
                    case splitFunTysN (n-1) res of { (args, res) ->
                    (arg:args, res) }}
472

batterseapower's avatar
batterseapower committed
473
474
475
476
477
478
-- | Splits off argument types from the given type and associating
-- them with the things in the input list from left to right. The
-- final result type is returned, along with the resulting pairs of
-- objects and types, albeit with the list of pairs in reverse order.
-- Panics if there are not enough argument types for the input list.
zipFunTys :: Outputable a => [a] -> Type -> ([(a, Type)], Type)
479
480
zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
  where
481
    split acc []     nty _                 = (reverse acc, nty)
ian@well-typed.com's avatar
ian@well-typed.com committed
482
483
    split acc xs     nty ty
          | Just ty' <- coreView ty        = split acc xs nty ty'
484
485
    split acc (x:xs) _   (FunTy arg res)   = split ((x,arg):acc) xs res res
    split _   _      _   _                 = pprPanic "zipFunTys" (ppr orig_xs <+> ppr orig_ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
486

487
funResultTy :: Type -> Type
batterseapower's avatar
batterseapower committed
488
-- ^ Extract the function result type and panic if that is not possible
489
funResultTy ty | Just ty' <- coreView ty = funResultTy ty'
490
491
funResultTy (FunTy _arg res)  = res
funResultTy ty                = pprPanic "funResultTy" (ppr ty)
492
493

funArgTy :: Type -> Type
batterseapower's avatar
batterseapower committed
494
-- ^ Extract the function argument type and panic if that is not possible
495
funArgTy ty | Just ty' <- coreView ty = funArgTy ty'
496
497
funArgTy (FunTy arg _res)  = arg
funArgTy ty                = pprPanic "funArgTy" (ppr ty)
498
499
\end{code}

500
---------------------------------------------------------------------
ian@well-typed.com's avatar
ian@well-typed.com committed
501
502
                                TyConApp
                                ~~~~~~~~
503

504
\begin{code}
ian@well-typed.com's avatar
ian@well-typed.com committed
505
-- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to
506
507
508
509
510
511
512
513
514
-- its arguments.  Applies its arguments to the constructor from left to right.
mkTyConApp :: TyCon -> [Type] -> Type
mkTyConApp tycon tys
  | isFunTyCon tycon, [ty1,ty2] <- tys
  = FunTy ty1 ty2

  | otherwise
  = TyConApp tycon tys

515
516
517
518
-- splitTyConApp "looks through" synonyms, because they don't
-- mean a distinct type, but all other type-constructor applications
-- including functions are returned as Just ..

batterseapower's avatar
batterseapower committed
519
-- | The same as @fst . splitTyConApp@
520
521
522
523
524
525
tyConAppTyCon_maybe :: Type -> Maybe TyCon
tyConAppTyCon_maybe ty | Just ty' <- coreView ty = tyConAppTyCon_maybe ty'
tyConAppTyCon_maybe (TyConApp tc _) = Just tc
tyConAppTyCon_maybe (FunTy {})      = Just funTyCon
tyConAppTyCon_maybe _               = Nothing

526
tyConAppTyCon :: Type -> TyCon
527
tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty)
528

batterseapower's avatar
batterseapower committed
529
-- | The same as @snd . splitTyConApp@
530
531
532
533
534
535
536
tyConAppArgs_maybe :: Type -> Maybe [Type]
tyConAppArgs_maybe ty | Just ty' <- coreView ty = tyConAppArgs_maybe ty'
tyConAppArgs_maybe (TyConApp _ tys) = Just tys
tyConAppArgs_maybe (FunTy arg res)  = Just [arg,res]
tyConAppArgs_maybe _                = Nothing


537
tyConAppArgs :: Type -> [Type]
538
tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty)
539

540
541
tyConAppArgN :: Int -> Type -> Type
-- Executing Nth
ian@well-typed.com's avatar
ian@well-typed.com committed
542
tyConAppArgN n ty
543
544
545
546
  = case tyConAppArgs_maybe ty of
      Just tys -> ASSERT2( n < length tys, ppr n <+> ppr tys ) tys !! n
      Nothing  -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty)

batterseapower's avatar
batterseapower committed
547
548
549
-- | Attempts to tease a type apart into a type constructor and the application
-- of a number of arguments to that constructor. Panics if that is not possible.
-- See also 'splitTyConApp_maybe'
550
551
splitTyConApp :: Type -> (TyCon, [Type])
splitTyConApp ty = case splitTyConApp_maybe ty of
ian@well-typed.com's avatar
ian@well-typed.com committed
552
553
                   Just stuff -> stuff
                   Nothing    -> pprPanic "splitTyConApp" (ppr ty)
554

batterseapower's avatar
batterseapower committed
555
556
-- | Attempts to tease a type apart into a type constructor and the application
-- of a number of arguments to that constructor
557
splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
558
splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty'
559
splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
560
splitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
561
splitTyConApp_maybe _                 = Nothing
562

563
newTyConInstRhs :: TyCon -> [Type] -> Type
ian@well-typed.com's avatar
ian@well-typed.com committed
564
-- ^ Unwrap one 'layer' of newtype on a type constructor and its
565
566
-- arguments, using an eta-reduced version of the @newtype@ if possible.
-- This requires tys to have at least @newTyConInstArity tycon@ elements.
ian@well-typed.com's avatar
ian@well-typed.com committed
567
newTyConInstRhs tycon tys
568
569
570
571
572
    = ASSERT2( equalLength tvs tys1, ppr tycon $$ ppr tys $$ ppr tvs )
      mkAppTys (substTyWith tvs tys1 ty) tys2
  where
    (tvs, ty)    = newTyConEtadRhs tycon
    (tys1, tys2) = splitAtList tvs tys
sof's avatar
sof committed
573
\end{code}
574

575

576
---------------------------------------------------------------------
ian@well-typed.com's avatar
ian@well-typed.com committed
577
578
                                SynTy
                                ~~~~~
579
580
581
582

Notes on type synonyms
~~~~~~~~~~~~~~~~~~~~~~
The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
Krzysztof Gogolewski's avatar
Typos    
Krzysztof Gogolewski committed
583
to return type synonyms wherever possible. Thus
584

ian@well-typed.com's avatar
ian@well-typed.com committed
585
        type Foo a = a -> a
586

ian@well-typed.com's avatar
ian@well-typed.com committed
587
588
589
we want
        splitFunTys (a -> Foo a) = ([a], Foo a)
not                                ([a], a -> a)
590

ian@well-typed.com's avatar
ian@well-typed.com committed
591
The reason is that we then get better (shorter) type signatures in
592
interfaces.  Notably this plays a role in tcTySigs in TcBinds.lhs.
593
594


ian@well-typed.com's avatar
ian@well-typed.com committed
595
596
                Representation types
                ~~~~~~~~~~~~~~~~~~~~
597

598
599
Note [Nullary unboxed tuple]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
600
We represent the nullary unboxed tuple as the unary (but void) type
601
Void#.  The reason for this is that the ReprArity is never
602
603
604
605
606
607
less than the Arity (as it would otherwise be for a function type like
(# #) -> Int).

As a result, ReprArity is always strictly positive if Arity is. This
is important because it allows us to distinguish at runtime between a
thunk and a function takes a nullary unboxed tuple as an argument!
608

609
\begin{code}
610
611
612
613
614
615
616
617
618
type UnaryType = Type

data RepType = UbxTupleRep [UnaryType] -- INVARIANT: never an empty list (see Note [Nullary unboxed tuple])
             | UnaryRep UnaryType

flattenRepType :: RepType -> [UnaryType]
flattenRepType (UbxTupleRep tys) = tys
flattenRepType (UnaryRep ty)     = [ty]

batterseapower's avatar
batterseapower committed
619
620
-- | Looks through:
--
ian@well-typed.com's avatar
ian@well-typed.com committed
621
622
623
624
--      1. For-alls
--      2. Synonyms
--      3. Predicates
--      4. All newtypes, including recursive ones, but not newtype families
batterseapower's avatar
batterseapower committed
625
626
--
-- It's useful in the back end of the compiler.
627
repType :: Type -> RepType
628
repType ty
629
  = go initRecTc ty
630
  where
631
    go :: RecTcChecker -> Type -> RepType
ian@well-typed.com's avatar
ian@well-typed.com committed
632
    go rec_nts ty                       -- Expand predicates and synonyms
Simon Peyton Jones's avatar
Simon Peyton Jones committed
633
634
      | Just ty' <- coreView ty
      = go rec_nts ty'
635

ian@well-typed.com's avatar
ian@well-typed.com committed
636
637
    go rec_nts (ForAllTy _ ty)          -- Drop foralls
        = go rec_nts ty
638

ian@well-typed.com's avatar
ian@well-typed.com committed
639
    go rec_nts (TyConApp tc tys)        -- Expand newtypes
640
641
      | isNewTyCon tc
      , tys `lengthAtLeast` tyConArity tc
642
      , Just rec_nts' <- checkRecTc rec_nts tc   -- See Note [Expanding newtypes] in TyCon
643
      = go rec_nts' (newTyConInstRhs tc tys)
644

645
646
      | isUnboxedTupleTyCon tc
      = if null tys
647
         then UnaryRep voidPrimTy -- See Note [Nullary unboxed tuple]
648
         else UbxTupleRep (concatMap (flattenRepType . go rec_nts) tys)
649

650
    go _ ty = UnaryRep ty
651

652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671

-- | All type constructors occurring in the type; looking through type
--   synonyms, but not newtypes.
--  When it finds a Class, it returns the class TyCon.
tyConsOfType :: Type -> [TyCon]
tyConsOfType ty
  = nameEnvElts (go ty)
  where
     go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim
     go ty | Just ty' <- tcView ty = go ty'
     go (TyVarTy {})               = emptyNameEnv
     go (LitTy {})                 = emptyNameEnv
     go (TyConApp tc tys)          = go_tc tc tys
     go (AppTy a b)                = go a `plusNameEnv` go b
     go (FunTy a b)                = go a `plusNameEnv` go b
     go (ForAllTy _ ty)            = go ty

     go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
     go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys

672
673
-- ToDo: this could be moved to the code generator, using splitTyConApp instead
-- of inspecting the type directly.
batterseapower's avatar
batterseapower committed
674

675
676
677
678
679
680
681
682
-- | Discovers the primitive representation of a more abstract 'UnaryType'
typePrimRep :: UnaryType -> PrimRep
typePrimRep ty
  = case repType ty of
      UbxTupleRep _ -> pprPanic "typePrimRep: UbxTupleRep" (ppr ty)
      UnaryRep rep -> case rep of
        TyConApp tc _ -> tyConPrimRep tc
        FunTy _ _     -> PtrRep
ian@well-typed.com's avatar
ian@well-typed.com committed
683
        AppTy _ _     -> PtrRep      -- See Note [AppTy rep]
684
685
686
687
688
689
690
691
        TyVarTy _     -> PtrRep
        _             -> pprPanic "typePrimRep: UnaryRep" (ppr ty)

typeRepArity :: Arity -> Type -> RepArity
typeRepArity 0 _ = 0
typeRepArity n ty = case repType ty of
  UnaryRep (FunTy ty1 ty2) -> length (flattenRepType (repType ty1)) + typeRepArity (n - 1) ty2
  _                        -> pprPanic "typeRepArity: arity greater than type can handle" (ppr (n, ty))
692
693
694
695
696
697

isVoidTy :: Type -> Bool
-- True if the type has zero width
isVoidTy ty = case repType ty of
                UnaryRep (TyConApp tc _) -> isVoidRep (tyConPrimRep tc)
                _                        -> False
698
699
\end{code}

700
701
702
703
Note [AppTy rep]
~~~~~~~~~~~~~~~~
Types of the form 'f a' must be of kind *, not #, so we are guaranteed
that they are represented by pointers.  The reason is that f must have
ian@well-typed.com's avatar
ian@well-typed.com committed
704
kind (kk -> kk) and kk cannot be unlifted; see Note [The kind invariant]
705
in TypeRep.
706

707
---------------------------------------------------------------------
ian@well-typed.com's avatar
ian@well-typed.com committed
708
709
                                ForAllTy
                                ~~~~~~~~
710
711

\begin{code}
712
mkForAllTy :: TyVar -> Type -> Type
713
mkForAllTy tyvar ty
714
  = ForAllTy tyvar ty
715

batterseapower's avatar
batterseapower committed
716
-- | Wraps foralls over the type using the provided 'TyVar's from left to right
717
mkForAllTys :: [TyVar] -> Type -> Type
718
mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
719

720
721
mkPiKinds :: [TyVar] -> Kind -> Kind
-- mkPiKinds [k1, k2, (a:k1 -> *)] k2
dreixel's avatar
dreixel committed
722
-- returns forall k1 k2. (k1 -> *) -> k2
723
mkPiKinds [] res = res
ian@well-typed.com's avatar
ian@well-typed.com committed
724
mkPiKinds (tv:tvs) res
725
726
  | isKindVar tv = ForAllTy tv          (mkPiKinds tvs res)
  | otherwise    = FunTy (tyVarKind tv) (mkPiKinds tvs res)
727
728
729
730
731
732
733
734
735
736
737
738

mkPiType  :: Var -> Type -> Type
-- ^ Makes a @(->)@ type or a forall type, depending
-- on whether it is given a type variable or a term variable.
mkPiTypes :: [Var] -> Type -> Type
-- ^ 'mkPiType' for multiple type or value arguments

mkPiType v ty
   | isId v    = mkFunTy (varType v) ty
   | otherwise = mkForAllTy v ty

mkPiTypes vs ty = foldr mkPiType ty vs
dreixel's avatar
dreixel committed
739

740
741
isForAllTy :: Type -> Bool
isForAllTy (ForAllTy _ _) = True
742
isForAllTy _              = False
743

batterseapower's avatar
batterseapower committed
744
745
-- | Attempts to take a forall type apart, returning the bound type variable
-- and the remainder of the type
746
splitForAllTy_maybe :: Type -> Maybe (TyVar, Type)
747
splitForAllTy_maybe ty = splitFAT_m ty
748
  where
749
    splitFAT_m ty | Just ty' <- coreView ty = splitFAT_m ty'
ian@well-typed.com's avatar
ian@well-typed.com committed
750
751
    splitFAT_m (ForAllTy tyvar ty)          = Just(tyvar, ty)
    splitFAT_m _                            = Nothing
sof's avatar
sof committed
752

batterseapower's avatar
batterseapower committed
753
754
755
-- | Attempts to take a forall type apart, returning all the immediate such bound
-- type variables and the remainder of the type. Always suceeds, even if that means
-- returning an empty list of 'TyVar's
756
splitForAllTys :: Type -> ([TyVar], Type)
757
splitForAllTys ty = split ty ty []
758
   where
759
     split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs
760
761
     split _       (ForAllTy tv ty)  tvs = split ty ty (tv:tvs)
     split orig_ty _                 tvs = (reverse tvs, orig_ty)
762

batterseapower's avatar
batterseapower committed
763
-- | Equivalent to @snd . splitForAllTys@
764
765
dropForAlls :: Type -> Type
dropForAlls ty = snd (splitForAllTys ty)
766
767
\end{code}

768
-- (mkPiType now in CoreUtils)
769

770
771
applyTy, applyTys
~~~~~~~~~~~~~~~~~
772

773
\begin{code}
batterseapower's avatar
batterseapower committed
774
775
776
777
778
779
780
-- | Instantiate a forall type with one or more type arguments.
-- Used when we have a polymorphic function applied to type args:
--
-- > f t1 t2
--
-- We use @applyTys type-of-f [t1,t2]@ to compute the type of the expression.
-- Panics if no application is possible.
dreixel's avatar
dreixel committed
781
applyTy :: Type -> KindOrType -> Type
782
783
applyTy ty arg | Just ty' <- coreView ty = applyTy ty' arg
applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty
784
applyTy _                _   = panic "applyTy"
785

dreixel's avatar
dreixel committed
786
applyTys :: Type -> [KindOrType] -> Type
batterseapower's avatar
batterseapower committed
787
788
-- ^ This function is interesting because:
--
ian@well-typed.com's avatar
ian@well-typed.com committed
789
--      1. The function may have more for-alls than there are args
batterseapower's avatar
batterseapower committed
790
--
ian@well-typed.com's avatar
ian@well-typed.com committed
791
--      2. Less obviously, it may have fewer for-alls
batterseapower's avatar
batterseapower committed
792
793
794
795
796
--
-- For case 2. think of:
--
-- > applyTys (forall a.a) [forall b.b, Int]
--
dreixel's avatar
dreixel committed
797
798
799
-- This really can happen, but only (I think) in situations involving
-- undefined.  For example:
--       undefined :: forall a. a
ian@well-typed.com's avatar
ian@well-typed.com committed
800
-- Term: undefined @(forall b. b->b) @Int
dreixel's avatar
dreixel committed
801
802
-- This term should have type (Int -> Int), but notice that
-- there are more type args than foralls in 'undefined's type.
803

804
805
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism] in coreSyn/CoreLint.lhs
806
807
applyTys ty args = applyTysD empty ty args

ian@well-typed.com's avatar
ian@well-typed.com committed
808
applyTysD :: SDoc -> Type -> [Type] -> Type     -- Debug version
809
applyTysD _   orig_fun_ty []      = orig_fun_ty
ian@well-typed.com's avatar
ian@well-typed.com committed
810
811
applyTysD doc orig_fun_ty arg_tys
  | n_tvs == n_args     -- The vastly common case
812
  = substTyWith tvs arg_tys rho_ty
ian@well-typed.com's avatar
ian@well-typed.com committed
813
814
815
816
817
  | n_tvs > n_args      -- Too many for-alls
  = substTyWith (take n_args tvs) arg_tys
                (mkForAllTys (drop n_args tvs) rho_ty)
  | otherwise           -- Too many type args
  = ASSERT2( n_tvs > 0, doc $$ ppr orig_fun_ty )        -- Zero case gives infnite loop!
818
    applyTysD doc (substTyWith tvs (take n_tvs arg_tys) rho_ty)
ian@well-typed.com's avatar
ian@well-typed.com committed
819
                  (drop n_tvs arg_tys)
820
  where
ian@well-typed.com's avatar
ian@well-typed.com committed
821
    (tvs, rho_ty) = splitForAllTys orig_fun_ty
822
    n_tvs = length tvs
ian@well-typed.com's avatar
ian@well-typed.com committed
823
    n_args = length arg_tys
824
\end{code}
825

826

827
%************************************************************************
ian@well-typed.com's avatar
ian@well-typed.com committed
828
%*                                                                      *
829
                         Pred
ian@well-typed.com's avatar
ian@well-typed.com committed
830
%*                                                                      *
831
%************************************************************************
832

batterseapower's avatar
batterseapower committed
833
Predicates on PredType
834

835
\begin{code}
batterseapower's avatar
batterseapower committed
836
837
838
839
840
noParenPred :: PredType -> Bool
-- A predicate that can appear without parens before a "=>"
--       C a => a -> a
--       a~b => a -> b
-- But   (?x::Int) => Int -> Int
841
noParenPred p = not (isIPPred p) && isClassPred p || isEqPred p
batterseapower's avatar
batterseapower committed
842

843
isPredTy :: Type -> Bool
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
  -- NB: isPredTy is used when printing types, which can happen in debug printing
  --     during type checking of not-fully-zonked types.  So it's not cool to say
  --     isConstraintKind (typeKind ty) because absent zonking the type might 
  --     be ill-kinded, and typeKind crashes
  --     Hence the rather tiresome story here
isPredTy ty = go ty []
  where
    go :: Type -> [KindOrType] -> Bool
    go (AppTy ty1 ty2)   args = go ty1 (ty2 : args)
    go (TyConApp tc tys) args = go_k (tyConKind tc) (tys ++ args)
    go (TyVarTy tv)      args = go_k (tyVarKind tv) args
    go _                 _    = False

    go_k :: Kind -> [KindOrType] -> Bool
    -- True <=> kind is k1 -> .. -> kn -> Constraint
    go_k k                [] = isConstraintKind k
    go_k (FunTy _ k1)     (_ :args) = go_k k1 args
    go_k (ForAllTy kv k1) (k2:args) = go_k (substKiWith [kv] [k2] k1) args
    go_k _ _ = False                  -- Typeable * Int :: Constraint
dreixel's avatar
dreixel committed
863

batterseapower's avatar
batterseapower committed
864
865
866
867
868
869
870
isClassPred, isEqPred, isIPPred :: PredType -> Bool
isClassPred ty = case tyConAppTyCon_maybe ty of
    Just tyCon | isClassTyCon tyCon -> True
    _                               -> False
isEqPred ty = case tyConAppTyCon_maybe ty of
    Just tyCon -> tyCon `hasKey` eqTyConKey
    _          -> False
871

batterseapower's avatar
batterseapower committed
872
isIPPred ty = case tyConAppTyCon_maybe ty of
873
874
875
876
877
878
879
880
881
    Just tc -> isIPTyCon tc
    _       -> False

isIPTyCon :: TyCon -> Bool
isIPTyCon tc = tc `hasKey` ipClassNameKey

isIPClass :: Class -> Bool
isIPClass cls = cls `hasKey` ipClassNameKey
  -- Class and it corresponding TyCon have the same Unique
882
883
884
885

isIPPred_maybe :: Type -> Maybe (FastString, Type)
isIPPred_maybe ty =
  do (tc,[t1,t2]) <- splitTyConApp_maybe ty
886
     guard (isIPTyCon tc)
887
888
     x <- isStrLitTy t1
     return (x,t2)
889
890
891
\end{code}

Make PredTypes
892

893
894
895
--------------------- Equality types ---------------------------------
\begin{code}
-- | Creates a type equality predicate
896
897
mkEqPred :: Type -> Type -> PredType
mkEqPred ty1 ty2
898
  = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 $$ ppr k $$ ppr (typeKind ty2) )
dreixel's avatar
dreixel committed
899
    TyConApp eqTyCon [k, ty1, ty2]
ian@well-typed.com's avatar
ian@well-typed.com committed
900
  where
901
    k = typeKind ty1
batterseapower's avatar
batterseapower committed
902

Joachim Breitner's avatar
Joachim Breitner committed
903
904
905
906
907
908
909
mkCoerciblePred :: Type -> Type -> PredType
mkCoerciblePred ty1 ty2
  = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 $$ ppr k $$ ppr (typeKind ty2) )
    TyConApp coercibleTyCon [k, ty1, ty2]
  where
    k = typeKind ty1