From 861e836ed0cc1aa45932ecb3470967964440a0ef Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Thu, 28 Sep 2000 13:04:18 +0000
Subject: [PATCH] [project @ 2000-09-28 13:04:14 by simonpj]
------------------------------------ Mainly PredTypes (28 Sept 00)
------------------------------------
Three things in this commit:
1. Main thing: tidy up PredTypes
2. Move all Keys into PrelNames
3. Check for unboxed tuples in function args
1. Tidy up PredTypes
~~~~~~~~~~~~~~~~~~~~
The main thing in this commit is to modify the representation of Types
so that they are a (much) better for the qualified-type world. This
should simplify Jeff's life as he proceeds with implicit parameters
and functional dependencies. In particular, PredType, introduced by
Jeff, is now blessed and dignified with a place in TypeRep.lhs:
data PredType = Class Class [Type]
| IParam Name Type
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*, and are represented by a PredType. (We don't support
TREX records yet, but the setup is designed to expand to allow them.)
In addition, Type gains an extra constructor:
data Type = .... | PredTy PredType
so that PredType is injected directly into Type. So the type
p => t
is represented by
PredType p `FunTy` t
I have deleted the hackish IPNote stuff; predicates are dealt with entirely
through PredTys, not through NoteTy at all.
2. Move Keys into PrelNames
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This is just a housekeeping operation. I've moved all the pre-assigned Uniques
(aka Keys) from Unique.lhs into PrelNames.lhs. I've also moved knowKeyRdrNames
from PrelInfo down into PrelNames. This localises in PrelNames lots of stuff
about predefined names. Previously one had to alter three files to add one,
now only one.
3. Unboxed tuples
~~~~~~~~~~~~~~~~~~
Add a static check for unboxed tuple arguments. E.g.
data T = T (# Int, Int #)
is illegal
---
ghc/compiler/DEPEND-NOTES | 7 +-
ghc/compiler/basicTypes/MkId.lhs | 2 +-
ghc/compiler/basicTypes/Name.lhs | 3 +-
ghc/compiler/basicTypes/Unique.lhs | 362 +--------------
ghc/compiler/coreSyn/CoreUnfold.lhs | 2 +-
ghc/compiler/coreSyn/Subst.lhs | 8 +-
ghc/compiler/deSugar/Check.lhs | 2 +-
ghc/compiler/deSugar/DsCCall.lhs | 2 +-
ghc/compiler/deSugar/DsExpr.lhs | 2 +-
ghc/compiler/deSugar/DsForeign.lhs | 4 +-
ghc/compiler/deSugar/DsGRHSs.lhs | 2 +-
ghc/compiler/deSugar/DsListComp.lhs | 2 +-
ghc/compiler/deSugar/DsUtils.lhs | 2 +-
ghc/compiler/hsSyn/HsBinds.lhs | 1 +
ghc/compiler/hsSyn/HsTypes.lhs | 8 +-
ghc/compiler/parser/ParseUtil.lhs | 7 +-
ghc/compiler/prelude/PrelInfo.lhs | 247 +---------
ghc/compiler/prelude/PrelNames.lhs | 593 ++++++++++++++++++++++--
ghc/compiler/prelude/PrelRules.lhs | 3 +-
ghc/compiler/prelude/TysPrim.lhs | 4 +-
ghc/compiler/prelude/TysWiredIn.lhs | 3 +-
ghc/compiler/rename/Rename.lhs | 6 +-
ghc/compiler/rename/RnExpr.lhs | 11 +-
ghc/compiler/rename/RnNames.lhs | 2 +-
ghc/compiler/rename/RnSource.lhs | 4 +-
ghc/compiler/simplCore/OccurAnal.lhs | 3 +-
ghc/compiler/typecheck/Inst.lhs | 2 +-
ghc/compiler/typecheck/TcBinds.lhs | 2 +-
ghc/compiler/typecheck/TcDefaults.lhs | 2 +-
ghc/compiler/typecheck/TcDeriv.lhs | 2 +-
ghc/compiler/typecheck/TcExpr.lhs | 8 +-
ghc/compiler/typecheck/TcForeign.lhs | 2 +-
ghc/compiler/typecheck/TcInstDcls.lhs | 2 +-
ghc/compiler/typecheck/TcModule.lhs | 3 +-
ghc/compiler/typecheck/TcMonoType.lhs | 29 +-
ghc/compiler/typecheck/TcPat.lhs | 2 +-
ghc/compiler/typecheck/TcTyClsDecls.lhs | 12 +-
ghc/compiler/typecheck/TcTyDecls.lhs | 6 +-
ghc/compiler/typecheck/TcType.lhs | 10 +-
ghc/compiler/typecheck/TcUnify.lhs | 12 +-
ghc/compiler/types/PprType.lhs | 11 +-
ghc/compiler/types/TyCon.lhs | 2 +-
ghc/compiler/types/Type.lhs | 334 ++++++++-----
ghc/compiler/types/TypeRep.lhs | 128 +++--
ghc/compiler/usageSP/UsageSPUtils.lhs | 3 +-
45 files changed, 938 insertions(+), 926 deletions(-)
diff --git a/ghc/compiler/DEPEND-NOTES b/ghc/compiler/DEPEND-NOTES
index c67fa9761196..8efc3694e6bd 100644
--- a/ghc/compiler/DEPEND-NOTES
+++ b/ghc/compiler/DEPEND-NOTES
@@ -5,9 +5,11 @@ The Name/Var/Type group is a bit complicated. Here's the deal
Things in brackets are what the module *uses*.
A 'loop' indicates a use from a module compiled later
+ PrelNames
+then
Name, PrimRep, FieldLabel (loop Type.Type)
then
- Var (loop CoreSyn.CoreExpr, loop IdInfo.IdInfo,
+ Var (Name, loop CoreSyn.CoreExpr, loop IdInfo.IdInfo,
loop Type.GenType, loop Type.Kind)
then
VarEnv, VarSet, ThinAir
@@ -46,5 +48,6 @@ then
Rules (Unfolding), Subst (Unfolding, CoreFVs), CoreTidy (noUnfolding)
then
MkId (CoreUnfold.mkUnfolding, Subst)
-
+then
+ PrelInfo (MkId)
diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index 87b49efda8a4..13effb93cfe4 100644
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -89,7 +89,7 @@ import FieldLabel ( FieldLabel, FieldLabelTag, mkFieldLabel, fieldLabelName,
)
import CoreSyn
import Maybes
-import Unique
+import PrelNames
import Maybe ( isJust )
import Outputable
import Util ( assoc )
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index d066626d8f82..bc3ded6b0a19 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -58,7 +58,8 @@ import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule )
import CmdLineOpts ( opt_Static, opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC )
import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc )
-import Unique ( pprUnique, Unique, Uniquable(..), hasKey, unboundKey, u2i )
+import Unique ( Unique, Uniquable(..), u2i, hasKey, pprUnique )
+import PrelNames ( unboundKey )
import Maybes ( expectJust )
import UniqFM
import Outputable
diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index 1282995229f5..3d13ce54465f 100644
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -37,165 +37,12 @@ module Unique (
-- [the Oh-So-Wonderful Haskell module system wins again...]
mkAlphaTyVarUnique,
mkPrimOpIdUnique,
- mkTupleDataConUnique,
- mkTupleTyConUnique,
+ mkTupleTyConUnique, mkTupleDataConUnique,
+ mkPreludeMiscIdUnique, mkPreludeDataConUnique,
+ mkPreludeTyConUnique, mkPreludeClassUnique,
getBuiltinUniques, mkBuiltinUnique,
- mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
-
- absentErrorIdKey, -- alphabetical...
- addrDataConKey,
- addrPrimTyConKey,
- addrTyConKey,
- appendIdKey,
- arrayPrimTyConKey,
- assertIdKey,
- augmentIdKey,
- bcoPrimTyConKey,
- bindIOIdKey,
- boolTyConKey,
- boundedClassKey,
- boxedConKey,
- buildIdKey,
- byteArrayPrimTyConKey,
- byteArrayTyConKey,
- cCallableClassKey,
- cReturnableClassKey,
- charDataConKey,
- charPrimTyConKey,
- charTyConKey,
- concatIdKey,
- consDataConKey,
- deRefStablePtrIdKey,
- doubleDataConKey,
- doublePrimTyConKey,
- doubleTyConKey,
- enumClassKey,
- enumFromClassOpKey,
- enumFromThenClassOpKey,
- enumFromThenToClassOpKey,
- enumFromToClassOpKey,
- eqClassKey,
- eqClassOpKey,
- eqStringIdKey,
- errorIdKey,
- falseDataConKey,
- failMClassOpKey,
- filterIdKey,
- floatDataConKey,
- floatPrimTyConKey,
- floatTyConKey,
- floatingClassKey,
- foldlIdKey,
- foldrIdKey,
- foreignObjDataConKey,
- foreignObjPrimTyConKey,
- foreignObjTyConKey,
- fractionalClassKey,
- fromEnumClassOpKey,
- fromIntClassOpKey,
- fromIntegerClassOpKey,
- fromRationalClassOpKey,
- funTyConKey,
- functorClassKey,
- geClassOpKey,
- getTagIdKey,
- intDataConKey,
- intPrimTyConKey,
- intTyConKey,
- int8TyConKey,
- int16TyConKey,
- int32TyConKey,
- int64PrimTyConKey,
- int64TyConKey,
- smallIntegerDataConKey,
- largeIntegerDataConKey,
- integerMinusOneIdKey,
- integerPlusOneIdKey,
- integerPlusTwoIdKey,
- int2IntegerIdKey,
- integerTyConKey,
- integerZeroIdKey,
- integralClassKey,
- irrefutPatErrorIdKey,
- ixClassKey,
- listTyConKey,
- mainKey,
- makeStablePtrIdKey,
- mapIdKey,
- minusClassOpKey,
- monadClassKey,
- monadPlusClassKey,
- mutableArrayPrimTyConKey,
- mutableByteArrayPrimTyConKey,
- mutableByteArrayTyConKey,
- mutVarPrimTyConKey,
- nilDataConKey,
- noMethodBindingErrorIdKey,
- nonExhaustiveGuardsErrorIdKey,
- numClassKey,
- anyBoxConKey,
- ordClassKey,
- orderingTyConKey,
- otherwiseIdKey,
- parErrorIdKey,
- parIdKey,
- patErrorIdKey,
- plusIntegerIdKey,
- ratioDataConKey,
- ratioTyConKey,
- rationalTyConKey,
- readClassKey,
- realClassKey,
- realFloatClassKey,
- realFracClassKey,
- realWorldPrimIdKey,
- realWorldTyConKey,
- recConErrorIdKey,
- recSelErrIdKey,
- recUpdErrorIdKey,
- returnIOIdKey,
- returnMClassOpKey,
- runSTRepIdKey,
- showClassKey,
- ioTyConKey,
- ioDataConKey,
- stablePtrDataConKey,
- stablePtrPrimTyConKey,
- stablePtrTyConKey,
- stableNameDataConKey,
- stableNamePrimTyConKey,
- stableNameTyConKey,
-
- statePrimTyConKey,
- timesIntegerIdKey,
- typeConKey,
- kindConKey,
- boxityConKey,
- mVarPrimTyConKey,
- thenMClassOpKey,
- threadIdPrimTyConKey,
- toEnumClassOpKey,
- traceIdKey,
- trueDataConKey,
- unboundKey,
- unboxedConKey,
- unpackCStringUtf8IdKey,
- unpackCStringAppendIdKey,
- unpackCStringFoldrIdKey,
- unpackCStringIdKey,
- unsafeCoerceIdKey,
- ushowListIdKey,
- weakPrimTyConKey,
- wordDataConKey,
- wordPrimTyConKey,
- wordTyConKey,
- word8TyConKey,
- word16TyConKey,
- word32TyConKey,
- word64PrimTyConKey,
- word64TyConKey,
- zipIdKey
+ mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3
) where
#include "HsVersions.h"
@@ -484,204 +331,3 @@ getBuiltinUniques :: Int -> [Unique]
getBuiltinUniques n = map (mkUnique 'B') [1 .. n]
\end{code}
-%************************************************************************
-%* *
-\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@}
-%* *
-%************************************************************************
-
-\begin{code}
-boundedClassKey = mkPreludeClassUnique 1
-enumClassKey = mkPreludeClassUnique 2
-eqClassKey = mkPreludeClassUnique 3
-floatingClassKey = mkPreludeClassUnique 5
-fractionalClassKey = mkPreludeClassUnique 6
-integralClassKey = mkPreludeClassUnique 7
-monadClassKey = mkPreludeClassUnique 8
-monadPlusClassKey = mkPreludeClassUnique 9
-functorClassKey = mkPreludeClassUnique 10
-numClassKey = mkPreludeClassUnique 11
-ordClassKey = mkPreludeClassUnique 12
-readClassKey = mkPreludeClassUnique 13
-realClassKey = mkPreludeClassUnique 14
-realFloatClassKey = mkPreludeClassUnique 15
-realFracClassKey = mkPreludeClassUnique 16
-showClassKey = mkPreludeClassUnique 17
-
-cCallableClassKey = mkPreludeClassUnique 18
-cReturnableClassKey = mkPreludeClassUnique 19
-
-ixClassKey = mkPreludeClassUnique 20
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@}
-%* *
-%************************************************************************
-
-\begin{code}
-addrPrimTyConKey = mkPreludeTyConUnique 1
-addrTyConKey = mkPreludeTyConUnique 2
-arrayPrimTyConKey = mkPreludeTyConUnique 3
-boolTyConKey = mkPreludeTyConUnique 4
-byteArrayPrimTyConKey = mkPreludeTyConUnique 5
-charPrimTyConKey = mkPreludeTyConUnique 7
-charTyConKey = mkPreludeTyConUnique 8
-doublePrimTyConKey = mkPreludeTyConUnique 9
-doubleTyConKey = mkPreludeTyConUnique 10
-floatPrimTyConKey = mkPreludeTyConUnique 11
-floatTyConKey = mkPreludeTyConUnique 12
-funTyConKey = mkPreludeTyConUnique 13
-intPrimTyConKey = mkPreludeTyConUnique 14
-intTyConKey = mkPreludeTyConUnique 15
-int8TyConKey = mkPreludeTyConUnique 16
-int16TyConKey = mkPreludeTyConUnique 17
-int32TyConKey = mkPreludeTyConUnique 18
-int64PrimTyConKey = mkPreludeTyConUnique 19
-int64TyConKey = mkPreludeTyConUnique 20
-integerTyConKey = mkPreludeTyConUnique 21
-listTyConKey = mkPreludeTyConUnique 22
-foreignObjPrimTyConKey = mkPreludeTyConUnique 23
-foreignObjTyConKey = mkPreludeTyConUnique 24
-weakPrimTyConKey = mkPreludeTyConUnique 25
-mutableArrayPrimTyConKey = mkPreludeTyConUnique 26
-mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 27
-orderingTyConKey = mkPreludeTyConUnique 28
-mVarPrimTyConKey = mkPreludeTyConUnique 29
-ratioTyConKey = mkPreludeTyConUnique 30
-rationalTyConKey = mkPreludeTyConUnique 31
-realWorldTyConKey = mkPreludeTyConUnique 32
-stablePtrPrimTyConKey = mkPreludeTyConUnique 33
-stablePtrTyConKey = mkPreludeTyConUnique 34
-statePrimTyConKey = mkPreludeTyConUnique 35
-stableNamePrimTyConKey = mkPreludeTyConUnique 50
-stableNameTyConKey = mkPreludeTyConUnique 51
-mutableByteArrayTyConKey = mkPreludeTyConUnique 52
-mutVarPrimTyConKey = mkPreludeTyConUnique 53
-ioTyConKey = mkPreludeTyConUnique 55
-byteArrayTyConKey = mkPreludeTyConUnique 56
-wordPrimTyConKey = mkPreludeTyConUnique 57
-wordTyConKey = mkPreludeTyConUnique 58
-word8TyConKey = mkPreludeTyConUnique 59
-word16TyConKey = mkPreludeTyConUnique 60
-word32TyConKey = mkPreludeTyConUnique 61
-word64PrimTyConKey = mkPreludeTyConUnique 62
-word64TyConKey = mkPreludeTyConUnique 63
-boxedConKey = mkPreludeTyConUnique 64
-unboxedConKey = mkPreludeTyConUnique 65
-anyBoxConKey = mkPreludeTyConUnique 66
-kindConKey = mkPreludeTyConUnique 67
-boxityConKey = mkPreludeTyConUnique 68
-typeConKey = mkPreludeTyConUnique 69
-threadIdPrimTyConKey = mkPreludeTyConUnique 70
-bcoPrimTyConKey = mkPreludeTyConUnique 71
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@}
-%* *
-%************************************************************************
-
-\begin{code}
-addrDataConKey = mkPreludeDataConUnique 0
-charDataConKey = mkPreludeDataConUnique 1
-consDataConKey = mkPreludeDataConUnique 2
-doubleDataConKey = mkPreludeDataConUnique 3
-falseDataConKey = mkPreludeDataConUnique 4
-floatDataConKey = mkPreludeDataConUnique 5
-intDataConKey = mkPreludeDataConUnique 6
-smallIntegerDataConKey = mkPreludeDataConUnique 7
-largeIntegerDataConKey = mkPreludeDataConUnique 8
-foreignObjDataConKey = mkPreludeDataConUnique 9
-nilDataConKey = mkPreludeDataConUnique 10
-ratioDataConKey = mkPreludeDataConUnique 11
-stablePtrDataConKey = mkPreludeDataConUnique 12
-stableNameDataConKey = mkPreludeDataConUnique 13
-trueDataConKey = mkPreludeDataConUnique 14
-wordDataConKey = mkPreludeDataConUnique 15
-ioDataConKey = mkPreludeDataConUnique 16
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)}
-%* *
-%************************************************************************
-
-\begin{code}
-absentErrorIdKey = mkPreludeMiscIdUnique 1
-appendIdKey = mkPreludeMiscIdUnique 2
-augmentIdKey = mkPreludeMiscIdUnique 3
-buildIdKey = mkPreludeMiscIdUnique 4
-errorIdKey = mkPreludeMiscIdUnique 5
-foldlIdKey = mkPreludeMiscIdUnique 6
-foldrIdKey = mkPreludeMiscIdUnique 7
-recSelErrIdKey = mkPreludeMiscIdUnique 8
-integerMinusOneIdKey = mkPreludeMiscIdUnique 9
-integerPlusOneIdKey = mkPreludeMiscIdUnique 10
-integerPlusTwoIdKey = mkPreludeMiscIdUnique 11
-integerZeroIdKey = mkPreludeMiscIdUnique 12
-int2IntegerIdKey = mkPreludeMiscIdUnique 13
-irrefutPatErrorIdKey = mkPreludeMiscIdUnique 15
-eqStringIdKey = mkPreludeMiscIdUnique 16
-noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 17
-nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 18
-parErrorIdKey = mkPreludeMiscIdUnique 20
-parIdKey = mkPreludeMiscIdUnique 21
-patErrorIdKey = mkPreludeMiscIdUnique 22
-realWorldPrimIdKey = mkPreludeMiscIdUnique 23
-recConErrorIdKey = mkPreludeMiscIdUnique 24
-recUpdErrorIdKey = mkPreludeMiscIdUnique 25
-traceIdKey = mkPreludeMiscIdUnique 26
-unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 27
-unpackCStringAppendIdKey = mkPreludeMiscIdUnique 28
-unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 29
-unpackCStringIdKey = mkPreludeMiscIdUnique 30
-ushowListIdKey = mkPreludeMiscIdUnique 31
-unsafeCoerceIdKey = mkPreludeMiscIdUnique 32
-concatIdKey = mkPreludeMiscIdUnique 33
-filterIdKey = mkPreludeMiscIdUnique 34
-zipIdKey = mkPreludeMiscIdUnique 35
-bindIOIdKey = mkPreludeMiscIdUnique 36
-returnIOIdKey = mkPreludeMiscIdUnique 37
-deRefStablePtrIdKey = mkPreludeMiscIdUnique 38
-makeStablePtrIdKey = mkPreludeMiscIdUnique 39
-getTagIdKey = mkPreludeMiscIdUnique 40
-plusIntegerIdKey = mkPreludeMiscIdUnique 41
-timesIntegerIdKey = mkPreludeMiscIdUnique 42
-\end{code}
-
-Certain class operations from Prelude classes. They get their own
-uniques so we can look them up easily when we want to conjure them up
-during type checking.
-
-\begin{code}
-fromIntClassOpKey = mkPreludeMiscIdUnique 101
-fromIntegerClassOpKey = mkPreludeMiscIdUnique 102
-minusClassOpKey = mkPreludeMiscIdUnique 103
-fromRationalClassOpKey = mkPreludeMiscIdUnique 104
-enumFromClassOpKey = mkPreludeMiscIdUnique 105
-enumFromThenClassOpKey = mkPreludeMiscIdUnique 106
-enumFromToClassOpKey = mkPreludeMiscIdUnique 107
-enumFromThenToClassOpKey = mkPreludeMiscIdUnique 108
-eqClassOpKey = mkPreludeMiscIdUnique 109
-geClassOpKey = mkPreludeMiscIdUnique 110
-failMClassOpKey = mkPreludeMiscIdUnique 112
-thenMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=)
- -- Just a place holder for unbound variables produced by the renamer:
-unboundKey = mkPreludeMiscIdUnique 114
-fromEnumClassOpKey = mkPreludeMiscIdUnique 115
-
-mainKey = mkPreludeMiscIdUnique 116
-returnMClassOpKey = mkPreludeMiscIdUnique 117
-otherwiseIdKey = mkPreludeMiscIdUnique 118
-toEnumClassOpKey = mkPreludeMiscIdUnique 119
-mapIdKey = mkPreludeMiscIdUnique 120
-\end{code}
-
-\begin{code}
-assertIdKey = mkPreludeMiscIdUnique 121
-runSTRepIdKey = mkPreludeMiscIdUnique 122
-\end{code}
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 7f7f20ac7754..42db228ab835 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -54,7 +54,7 @@ import IdInfo ( ArityInfo(..), InlinePragInfo(..), OccInfo(..), IdFlavour(..),
insideLam, workerExists, isNeverInlinePrag
)
import Type ( splitFunTy_maybe, isUnLiftedType )
-import Unique ( Unique, buildIdKey, augmentIdKey, hasKey )
+import PrelNames ( hasKey, buildIdKey, augmentIdKey )
import Bag
import Outputable
diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs
index 94c40da6dcab..7564892588ac 100644
--- a/ghc/compiler/coreSyn/Subst.lhs
+++ b/ghc/compiler/coreSyn/Subst.lhs
@@ -404,11 +404,13 @@ subst_ty subst ty
where
go (TyConApp tc tys) = let args = map go tys
in args `seqList` TyConApp tc args
+
+ go (PredTy p) = PredTy $! (substPred subst p)
+
go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
- go (NoteTy (UsgNote usg) ty2) = (NoteTy $! UsgNote usg) $! go ty2 -- Keep usage annot
- go (NoteTy (UsgForAll uv) ty2) = (NoteTy $! UsgForAll uv) $! go ty2 -- Keep uvar bdr
- go (NoteTy (IPNote nm) ty2) = (NoteTy $! IPNote nm) $! go ty2 -- Keep ip note
+ go (NoteTy (UsgNote usg) ty2) = (NoteTy $! UsgNote usg) $! go ty2 -- Keep usage annot
+ go (NoteTy (UsgForAll uv) ty2) = (NoteTy $! UsgForAll uv) $! go ty2 -- Keep uvar bdr
go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs
index c9c978158b68..a86a832d1062 100644
--- a/ghc/compiler/deSugar/Check.lhs
+++ b/ghc/compiler/deSugar/Check.lhs
@@ -24,7 +24,7 @@ import Type ( splitAlgTyConApp, mkTyVarTys, splitTyConApp_maybe )
import TysWiredIn ( nilDataCon, consDataCon,
mkListTy, mkTupleTy, tupleCon
)
-import Unique ( unboundKey )
+import PrelNames ( unboundKey )
import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
import BasicTypes ( Boxity(..) )
import SrcLoc ( noSrcLoc )
diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index b10a0fa1772d..51a22bae19df 100644
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -41,7 +41,7 @@ import TysWiredIn ( unitDataConId,
)
import Literal ( mkMachInt )
import CStrings ( CLabelString )
-import Unique ( Unique, hasKey, ioTyConKey )
+import PrelNames ( Unique, hasKey, ioTyConKey )
import VarSet ( varSetElems )
import Outputable
\end{code}
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 6e2efa07885d..da86ba8e1469 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -44,7 +44,7 @@ import Type ( splitFunTys,
import TysWiredIn ( tupleCon, listTyCon, charDataCon, intDataCon, isIntegerTy )
import BasicTypes ( RecFlag(..), Boxity(..) )
import Maybes ( maybeToBool )
-import Unique ( hasKey, ratioTyConKey )
+import PrelNames ( hasKey, ratioTyConKey )
import Util ( zipEqual, zipWithEqual )
import Outputable
diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index 7959282d7497..3497cf215a44 100644
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -40,10 +40,10 @@ import TysWiredIn ( unitTy, addrTy, stablePtrTyCon,
addrDataCon
)
import TysPrim ( addrPrimTy )
-import Unique ( Uniquable(..), hasKey,
+import PrelNames ( Uniquable(..), hasKey,
ioTyConKey, deRefStablePtrIdKey, returnIOIdKey,
bindIOIdKey, makeStablePtrIdKey
- )
+ )
import Outputable
import Maybe ( fromJust )
diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs
index 31e442887181..b14e264d4005 100644
--- a/ghc/compiler/deSugar/DsGRHSs.lhs
+++ b/ghc/compiler/deSugar/DsGRHSs.lhs
@@ -19,7 +19,7 @@ import Type ( Type )
import DsMonad
import DsUtils
import PrelInfo ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
-import Unique ( otherwiseIdKey, trueDataConKey, hasKey )
+import PrelNames ( otherwiseIdKey, trueDataConKey, hasKey )
\end{code}
@dsGuarded@ is used for both @case@ expressions and pattern bindings.
diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs
index 9931da8ca271..a7cec0cc11a6 100644
--- a/ghc/compiler/deSugar/DsListComp.lhs
+++ b/ghc/compiler/deSugar/DsListComp.lhs
@@ -26,7 +26,7 @@ import Type ( mkTyVarTy, mkFunTys, mkFunTy, Type )
import TysPrim ( alphaTyVar )
import TysWiredIn ( nilDataCon, consDataCon )
import Match ( matchSimply )
-import Unique ( foldrIdKey, buildIdKey )
+import PrelNames ( foldrIdKey, buildIdKey )
\end{code}
List comprehensions may be desugared in one of two ways: ``ordinary''
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 28a739c37658..7446c2272095 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -63,7 +63,7 @@ import TysWiredIn ( nilDataCon, consDataCon,
)
import BasicTypes ( Boxity(..) )
import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
-import Unique ( unpackCStringIdKey, unpackCStringUtf8IdKey,
+import PrelNames ( unpackCStringIdKey, unpackCStringUtf8IdKey,
plusIntegerIdKey, timesIntegerIdKey )
import Outputable
import UnicodeUtil ( stringToUtf8 )
diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index 2d72e038b803..894a6321ab96 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -16,6 +16,7 @@ import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs )
-- friends:
import HsTypes ( HsType )
import CoreSyn ( CoreExpr )
+import PprCore ( {- Instances -} )
--others:
import Name ( Name, isUnboundName )
diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index 86a14675f770..06ba30d5f992 100644
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -31,14 +31,13 @@ import Type ( Type, Kind, PredType(..), UsageAnn(..), ClassContext,
)
import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation
import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity, tyConClass_maybe )
-import PrelInfo ( mkTupConRdrName )
import RdrName ( RdrName )
import Name ( toRdrName )
import OccName ( NameSpace )
import Var ( TyVar, tyVarKind )
import PprType ( {- instance Outputable Kind -}, pprParendKind )
import BasicTypes ( Arity, Boxity(..), tupleParens )
-import Unique ( hasKey, listTyConKey, Uniquable(..) )
+import PrelNames ( mkTupConRdrName, listTyConKey, hasKey, Uniquable(..) )
import Maybes ( maybeToBool )
import FiniteMap
import Outputable
@@ -289,16 +288,15 @@ toHsType' (AppTy fun arg) = HsAppTy (toHsType fun) (toHsType arg)
toHsType' (NoteTy (SynNote ty) _) = toHsType ty -- Use synonyms if possible!!
toHsType' (NoteTy _ ty) = toHsType ty
+toHsType' (PredTy p) = HsPredTy (toHsPred p)
+
toHsType' ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind *
| not saturated = generic_case
| isTupleTyCon tc = HsTupleTy (HsTupCon (toRdrName tc) (tupleTyConBoxity tc)) tys'
| tc `hasKey` listTyConKey = HsListTy (head tys')
- | maybeToBool maybe_class = HsPredTy (HsPClass (toRdrName clas) tys')
| otherwise = generic_case
where
generic_case = foldl HsAppTy (HsTyVar (toRdrName tc)) tys'
- maybe_class = tyConClass_maybe tc
- Just clas = maybe_class
tys' = map toHsType tys
saturated = length tys == tyConArity tc
diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index eaaf83d41e6f..006456cff249 100644
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -198,8 +198,11 @@ checkPat e [] = case e of
HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn)
ExplicitList es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
returnP (ListPatIn ps)
- ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
- returnP (TuplePatIn ps b)
+
+ ExplicitTuple es Boxed -> mapP (\e -> checkPat e []) es `thenP` \ps ->
+ returnP (TuplePatIn ps Boxed)
+ -- Unboxed tuples are illegal in patterns
+
RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
returnP (RecPatIn c fs)
_ -> patFail
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index cfe7a82b7c9b..728cb90d20c0 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -13,9 +13,6 @@ module PrelInfo (
-- if it's used at all then it's Name will be just as
-- it is here, unique and all. Includes all the
- derivingOccurrences, -- For a given class C, this tells what other
- derivableClassKeys, -- things are needed as a result of a
- -- deriving(C) clause
@@ -27,9 +24,10 @@ module PrelInfo (
-- Random other things
maybeCharLikeCon, maybeIntLikeCon,
- needsDataDeclCtxtClassKeys, cCallishClassKeys, cCallishTyKeys,
- isNoDictClass, isNumericClass, isStandardClass, isCcallishClass,
- isCreturnableClass, numericTyKeys, fractionalClassKeys,
+
+ -- Class categories
+ isCcallishClass, isCreturnableClass, isNoDictClass,
+ isNumericClass, isStandardClass
) where
@@ -47,13 +45,11 @@ import TysWiredIn
-- others:
import RdrName ( RdrName )
import Name ( Name, mkKnownKeyGlobal, getName )
-import Class ( Class, classKey )
import TyCon ( tyConDataConsIfAvailable, TyCon )
+import Class ( Class, classKey )
import Type ( funTyCon )
import Bag
import BasicTypes ( Boxity(..) )
-import Unique -- *Key stuff
-import UniqFM ( UniqFM, listToUFM )
import Util ( isIn )
\end{code}
@@ -80,7 +76,7 @@ builtinNames
, listToBag (map (getName . mkPrimOpId) allThePrimOps)
-- Other names with magic keys
- , listToBag knownKeyNames
+ , listToBag (map mkKnownKeyGlobal knownKeyRdrNames)
]
\end{code}
@@ -191,108 +187,6 @@ data_tycons
%* *
%************************************************************************
-Ids, Synonyms, Classes and ClassOps with builtin keys.
-
-\begin{code}
-knownKeyNames :: [Name]
-knownKeyNames
- = map mkKnownKeyGlobal
- [
- -- Type constructors (synonyms especially)
- (ioTyCon_RDR, ioTyConKey)
- , (main_RDR, mainKey)
- , (orderingTyCon_RDR, orderingTyConKey)
- , (rationalTyCon_RDR, rationalTyConKey)
- , (ratioDataCon_RDR, ratioDataConKey)
- , (ratioTyCon_RDR, ratioTyConKey)
- , (byteArrayTyCon_RDR, byteArrayTyConKey)
- , (mutableByteArrayTyCon_RDR, mutableByteArrayTyConKey)
- , (foreignObjTyCon_RDR, foreignObjTyConKey)
- , (bcoPrimTyCon_RDR, bcoPrimTyConKey)
- , (stablePtrTyCon_RDR, stablePtrTyConKey)
- , (stablePtrDataCon_RDR, stablePtrDataConKey)
-
- -- Classes. *Must* include:
- -- classes that are grabbed by key (e.g., eqClassKey)
- -- classes in "Class.standardClassKeys" (quite a few)
- , (eqClass_RDR, eqClassKey) -- mentioned, derivable
- , (ordClass_RDR, ordClassKey) -- derivable
- , (boundedClass_RDR, boundedClassKey) -- derivable
- , (numClass_RDR, numClassKey) -- mentioned, numeric
- , (enumClass_RDR, enumClassKey) -- derivable
- , (monadClass_RDR, monadClassKey)
- , (monadPlusClass_RDR, monadPlusClassKey)
- , (functorClass_RDR, functorClassKey)
- , (showClass_RDR, showClassKey) -- derivable
- , (realClass_RDR, realClassKey) -- numeric
- , (integralClass_RDR, integralClassKey) -- numeric
- , (fractionalClass_RDR, fractionalClassKey) -- numeric
- , (floatingClass_RDR, floatingClassKey) -- numeric
- , (realFracClass_RDR, realFracClassKey) -- numeric
- , (realFloatClass_RDR, realFloatClassKey) -- numeric
- , (readClass_RDR, readClassKey) -- derivable
- , (ixClass_RDR, ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm)
- , (ccallableClass_RDR, cCallableClassKey) -- mentioned, ccallish
- , (creturnableClass_RDR, cReturnableClassKey) -- mentioned, ccallish
-
- -- ClassOps
- , (fromInt_RDR, fromIntClassOpKey)
- , (fromInteger_RDR, fromIntegerClassOpKey)
- , (ge_RDR, geClassOpKey)
- , (minus_RDR, minusClassOpKey)
- , (enumFrom_RDR, enumFromClassOpKey)
- , (enumFromThen_RDR, enumFromThenClassOpKey)
- , (enumFromTo_RDR, enumFromToClassOpKey)
- , (enumFromThenTo_RDR, enumFromThenToClassOpKey)
- , (fromEnum_RDR, fromEnumClassOpKey)
- , (toEnum_RDR, toEnumClassOpKey)
- , (eq_RDR, eqClassOpKey)
- , (thenM_RDR, thenMClassOpKey)
- , (returnM_RDR, returnMClassOpKey)
- , (failM_RDR, failMClassOpKey)
- , (fromRational_RDR, fromRationalClassOpKey)
-
- , (deRefStablePtr_RDR, deRefStablePtrIdKey)
- , (makeStablePtr_RDR, makeStablePtrIdKey)
- , (bindIO_RDR, bindIOIdKey)
- , (returnIO_RDR, returnIOIdKey)
-
- -- Strings and lists
- , (map_RDR, mapIdKey)
- , (append_RDR, appendIdKey)
- , (unpackCString_RDR, unpackCStringIdKey)
- , (unpackCStringAppend_RDR, unpackCStringAppendIdKey)
- , (unpackCStringFoldr_RDR, unpackCStringFoldrIdKey)
- , (unpackCStringUtf8_RDR, unpackCStringUtf8IdKey)
-
- -- List operations
- , (concat_RDR, concatIdKey)
- , (filter_RDR, filterIdKey)
- , (zip_RDR, zipIdKey)
- , (foldr_RDR, foldrIdKey)
- , (build_RDR, buildIdKey)
- , (augment_RDR, augmentIdKey)
-
- -- FFI primitive types that are not wired-in.
- , (int8TyCon_RDR, int8TyConKey)
- , (int16TyCon_RDR, int16TyConKey)
- , (int32TyCon_RDR, int32TyConKey)
- , (int64TyCon_RDR, int64TyConKey)
- , (word8TyCon_RDR, word8TyConKey)
- , (word16TyCon_RDR, word16TyConKey)
- , (word32TyCon_RDR, word32TyConKey)
- , (word64TyCon_RDR, word64TyConKey)
-
- -- Others
- , (otherwiseId_RDR, otherwiseIdKey)
- , (plusInteger_RDR, plusIntegerIdKey)
- , (timesInteger_RDR, timesIntegerIdKey)
- , (eqString_RDR, eqStringIdKey)
- , (assert_RDR, assertIdKey)
- , (runSTRep_RDR, runSTRepIdKey)
- ]
-\end{code}
-
ToDo: make it do the ``like'' part properly (as in 0.26 and before).
\begin{code}
@@ -301,70 +195,13 @@ maybeCharLikeCon con = con `hasKey` charDataConKey
maybeIntLikeCon con = con `hasKey` intDataConKey
\end{code}
+
%************************************************************************
%* *
-\subsection[Class-std-groups]{Standard groups of Prelude classes}
+\subsection{Class predicates}
%* *
%************************************************************************
-@derivableClassKeys@ is also used in checking \tr{deriving} constructs
-(@TcDeriv@).
-
-@derivingOccurrences@ maps a class name to a list of the (qualified) occurrences
-that will be mentioned by the derived code for the class when it is later generated.
-We don't need to put in things that are WiredIn (because they are already mapped to their
-correct name by the @NameSupply@. The class itself, and all its class ops, is
-already flagged as an occurrence so we don't need to mention that either.
-
-@derivingOccurrences@ has an item for every derivable class, even if that item is empty,
-because we treat lookup failure as indicating that the class is illegal in a deriving clause.
-
-\begin{code}
-derivingOccurrences :: UniqFM [RdrName]
-derivingOccurrences = listToUFM deriving_occ_info
-
-derivableClassKeys = map fst deriving_occ_info
-
-deriving_occ_info
- = [ (eqClassKey, [intTyCon_RDR, and_RDR, not_RDR])
- , (ordClassKey, [intTyCon_RDR, compose_RDR, eqTag_RDR])
- -- EQ (from Ordering) is needed to force in the constructors
- -- as well as the type constructor.
- , (enumClassKey, [intTyCon_RDR, eq_RDR, ge_RDR, and_RDR, map_RDR, plus_RDR, showsPrec_RDR, append_RDR])
- -- The last two Enum deps are only used to produce better
- -- error msgs for derived toEnum methods.
- , (boundedClassKey, [intTyCon_RDR])
- , (showClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, compose_RDR, showString_RDR,
- showParen_RDR, showSpace_RDR, showList___RDR])
- , (readClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, append_RDR,
- foldr_RDR, build_RDR,
- -- foldr and build required for list comprehension
- -- KSW 2000-06
- lex_RDR, readParen_RDR, readList___RDR, thenM_RDR])
- -- returnM (and the rest of the Monad class decl)
- -- will be forced in as result of depending
- -- on thenM. -- SOF 1/99
- , (ixClassKey, [intTyCon_RDR, numClass_RDR, and_RDR, map_RDR, enumFromTo_RDR,
- foldr_RDR, build_RDR,
- -- foldr and build required for list comprehension used
- -- with single constructor types -- KSW 2000-06
- returnM_RDR, failM_RDR])
- -- the last two are needed to force returnM, thenM and failM
- -- in before typechecking the list(monad) comprehension
- -- generated for derived Ix instances (range method)
- -- of single constructor types. -- SOF 8/97
- ]
- -- intTyCon: Practically any deriving needs Int, either for index calculations,
- -- or for taggery.
- -- ordClass: really it's the methods that are actually used.
- -- numClass: for Int literals
-\end{code}
-
-
-NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@
-even though every numeric class has these two as a superclass,
-because the list of ambiguous dictionaries hasn't been simplified.
-
\begin{code}
isCcallishClass, isCreturnableClass, isNoDictClass,
isNumericClass, isStandardClass :: Class -> Bool
@@ -375,72 +212,4 @@ isCcallishClass clas = classKey clas `is_elem` cCallishClassKeys
isCreturnableClass clas = classKey clas == cReturnableClassKey
isNoDictClass clas = classKey clas `is_elem` noDictClassKeys
is_elem = isIn "is_X_Class"
-
-numericClassKeys =
- [ numClassKey
- , realClassKey
- , integralClassKey
- ]
- ++ fractionalClassKeys
-
-fractionalClassKeys =
- [ fractionalClassKey
- , floatingClassKey
- , realFracClassKey
- , realFloatClassKey
- ]
-
- -- the strictness analyser needs to know about numeric types
- -- (see SaAbsInt.lhs)
-numericTyKeys =
- [ addrTyConKey
- , wordTyConKey
- , intTyConKey
- , integerTyConKey
- , doubleTyConKey
- , floatTyConKey
- ]
-
-needsDataDeclCtxtClassKeys = -- see comments in TcDeriv
- [ readClassKey
- ]
-
-cCallishClassKeys =
- [ cCallableClassKey
- , cReturnableClassKey
- ]
-
- -- Renamer always imports these data decls replete with constructors
- -- so that desugarer can always see their constructors. Ugh!
-cCallishTyKeys =
- [ addrTyConKey
- , wordTyConKey
- , byteArrayTyConKey
- , mutableByteArrayTyConKey
- , foreignObjTyConKey
- , stablePtrTyConKey
- , int8TyConKey
- , int16TyConKey
- , int32TyConKey
- , int64TyConKey
- , word8TyConKey
- , word16TyConKey
- , word32TyConKey
- , word64TyConKey
- ]
-
-standardClassKeys
- = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys
- --
- -- We have to have "CCallable" and "CReturnable" in the standard
- -- classes, so that if you go...
- --
- -- _ccall_ foo ... 93{-numeric literal-} ...
- --
- -- ... it can do The Right Thing on the 93.
-
-noDictClassKeys -- These classes are used only for type annotations;
- -- they are not implemented by dictionaries, ever.
- = cCallishClassKeys
\end{code}
-
diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs
index 073bfae1f90e..b72f143138c5 100644
--- a/ghc/compiler/prelude/PrelNames.lhs
+++ b/ghc/compiler/prelude/PrelNames.lhs
@@ -10,76 +10,230 @@ defined here so as to avod
and gobbled whoever was writing the above :-) -- SOF ]
\begin{code}
-module PrelNames
- (
+module PrelNames (
+
+ Unique, Uniquable(..), hasKey, -- Re-exported for convenience
+ knownKeyRdrNames,
+ mkTupNameStr, mkTupConRdrName,
+
+ ------------------------------------------------------------
-- Prelude modules
pREL_GHC, pREL_BASE, pREL_ADDR, pREL_STABLE,
pREL_IO_BASE, pREL_PACK, pREL_ERR, pREL_NUM, pREL_FLOAT, pREL_REAL,
+ ------------------------------------------------------------
-- Module names (both Prelude and otherwise)
- pREL_GHC_Name, pRELUDE_Name,
- mAIN_Name, pREL_MAIN_Name, pREL_ERR_Name,
- pREL_BASE_Name, pREL_NUM_Name, pREL_LIST_Name,
- pREL_TUP_Name, pREL_ADDR_Name, pREL_READ_Name,
- pREL_PACK_Name, pREL_CONC_Name, pREL_IO_BASE_Name,
- pREL_ST_Name, pREL_ARR_Name, pREL_BYTEARR_Name, pREL_FOREIGN_Name,
- pREL_STABLE_Name, pREL_SHOW_Name, pREL_ENUM_Name, iNT_Name, wORD_Name,
- pREL_REAL_Name, pREL_FLOAT_Name,
-
- -- RdrNames for lots of things, mainly used in derivings
- eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR,
- compare_RDR, minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR,
- enumFromThen_RDR, enumFromThenTo_RDR, succ_RDR, pred_RDR, fromEnum_RDR, toEnum_RDR,
- ratioDataCon_RDR, range_RDR, index_RDR, inRange_RDR, readsPrec_RDR,
- readList_RDR, showsPrec_RDR, showList_RDR, plus_RDR, times_RDR,
- ltTag_RDR, eqTag_RDR, gtTag_RDR, false_RDR, true_RDR,
- and_RDR, not_RDR, append_RDR, map_RDR, compose_RDR, mkInt_RDR,
- error_RDR, assertErr_RDR,
- showString_RDR, showParen_RDR, readParen_RDR, lex_RDR,
- showSpace_RDR, showList___RDR, readList___RDR, negate_RDR,
- ioTyCon_RDR, foldr_RDR, build_RDR, getTag_RDR, plusInteger_RDR, timesInteger_RDR, eqString_RDR,
-
- orderingTyCon_RDR, rationalTyCon_RDR, ratioTyCon_RDR, byteArrayTyCon_RDR,
- mutableByteArrayTyCon_RDR, foreignObjTyCon_RDR,
- bcoPrimTyCon_RDR,
- intTyCon_RDR, stablePtrTyCon_RDR, stablePtrDataCon_RDR,
- int8TyCon_RDR, int16TyCon_RDR, int32TyCon_RDR, int64TyCon_RDR,
- word8TyCon_RDR, word16TyCon_RDR, word32TyCon_RDR, word64TyCon_RDR,
-
- boundedClass_RDR, monadPlusClass_RDR, functorClass_RDR, showClass_RDR,
- realClass_RDR, integralClass_RDR, floatingClass_RDR, realFracClass_RDR,
- realFloatClass_RDR, readClass_RDR, ixClass_RDR,
- fromInt_RDR, fromInteger_RDR, minus_RDR, fromRational_RDR,
-
- bindIO_RDR, returnIO_RDR, thenM_RDR, returnM_RDR, failM_RDR,
+ pREL_GHC_Name, pRELUDE_Name, pREL_MAIN_Name, mAIN_Name,
+ ------------------------------------------------------------
+ -- Original RdrNames for a few things
+ main_RDR,
deRefStablePtr_RDR, makeStablePtr_RDR,
- concat_RDR, filter_RDR, zip_RDR, augment_RDR,
- otherwiseId_RDR, assert_RDR, runSTRep_RDR,
-
- unpackCString_RDR, unpackCStringAppend_RDR, unpackCStringFoldr_RDR,
- unpackCStringUtf8_RDR,
- numClass_RDR, fractionalClass_RDR, eqClass_RDR,
- ccallableClass_RDR, creturnableClass_RDR,
+ ioTyCon_RDR, ioDataCon_RDR, bindIO_RDR, returnIO_RDR,
+ unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
+ eqClass_RDR, foldr_RDR, build_RDR,
+ ccallableClass_RDR, creturnableClass_RDR,
monadClass_RDR, enumClass_RDR, ordClass_RDR,
- ioDataCon_RDR,
-
- main_RDR,
-
- mkTupNameStr, mkTupConRdrName
-
- ) where
+ ratioDataCon_RDR, negate_RDR, assertErr_RDR,
+ plusInteger_RDR, timesInteger_RDR, eqString_RDR,
+
+ -- Plus a whole lot more needed only in TcGenDeriv
+ eq_RDR, ne_RDR, not_RDR, compare_RDR, ge_RDR, le_RDR, gt_RDR,
+ ltTag_RDR, eqTag_RDR, gtTag_RDR, getTag_RDR,
+ and_RDR, true_RDR, false_RDR,
+ succ_RDR, pred_RDR, toEnum_RDR, fromEnum_RDR,
+ minBound_RDR, maxBound_RDR,
+ enumFrom_RDR, enumFromThen_RDR, enumFromTo_RDR, enumFromThenTo_RDR,
+ map_RDR, append_RDR, compose_RDR,
+ plus_RDR, times_RDR, mkInt_RDR,
+ error_RDR,
+ range_RDR, inRange_RDR, index_RDR,
+ readList___RDR, readList_RDR, readsPrec_RDR, lex_RDR, readParen_RDR,
+ showList_RDR, showList___RDR, showsPrec_RDR, showString_RDR, showSpace_RDR, showParen_RDR,
+
+ ------------------------------------------------------------
+ -- Goups of classes and types
+ needsDataDeclCtxtClassKeys, cCallishClassKeys, noDictClassKeys,
+ fractionalClassKeys, numericClassKeys, standardClassKeys,
+ derivingOccurrences, -- For a given class C, this tells what other
+ derivableClassKeys, -- things are needed as a result of a
+ -- deriving(C) clause
+ numericTyKeys, cCallishTyKeys,
+
+ ------------------------------------------------------------
+ -- Keys
+ absentErrorIdKey, addrDataConKey, addrPrimTyConKey, addrTyConKey,
+ appendIdKey, arrayPrimTyConKey, assertIdKey, augmentIdKey,
+ bcoPrimTyConKey, bindIOIdKey, boolTyConKey, boundedClassKey,
+ boxedConKey, buildIdKey, byteArrayPrimTyConKey, byteArrayTyConKey,
+ cCallableClassKey, cReturnableClassKey, charDataConKey,
+ charPrimTyConKey, charTyConKey, concatIdKey, consDataConKey,
+ deRefStablePtrIdKey, doubleDataConKey, doublePrimTyConKey,
+ doubleTyConKey, enumClassKey, enumFromClassOpKey,
+ enumFromThenClassOpKey, enumFromThenToClassOpKey,
+ enumFromToClassOpKey, eqClassKey, eqClassOpKey, eqStringIdKey,
+ errorIdKey, falseDataConKey, failMClassOpKey, filterIdKey,
+ floatDataConKey, floatPrimTyConKey, floatTyConKey, floatingClassKey,
+ foldlIdKey, foldrIdKey, foreignObjDataConKey, foreignObjPrimTyConKey,
+ foreignObjTyConKey, fractionalClassKey, fromEnumClassOpKey,
+ fromIntClassOpKey, fromIntegerClassOpKey, fromRationalClassOpKey,
+ funTyConKey, functorClassKey, geClassOpKey, getTagIdKey,
+ intDataConKey, intPrimTyConKey, intTyConKey, int8TyConKey,
+ int16TyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey,
+ smallIntegerDataConKey, largeIntegerDataConKey, integerMinusOneIdKey,
+ integerPlusOneIdKey, integerPlusTwoIdKey, int2IntegerIdKey,
+ integerTyConKey, integerZeroIdKey, integralClassKey,
+ irrefutPatErrorIdKey, ixClassKey, listTyConKey, mainKey,
+ makeStablePtrIdKey, mapIdKey, minusClassOpKey, monadClassKey,
+ monadPlusClassKey, mutableArrayPrimTyConKey,
+ mutableByteArrayPrimTyConKey, mutableByteArrayTyConKey,
+ mutVarPrimTyConKey, nilDataConKey, noMethodBindingErrorIdKey,
+ nonExhaustiveGuardsErrorIdKey, numClassKey, anyBoxConKey, ordClassKey,
+ orderingTyConKey, otherwiseIdKey, parErrorIdKey, parIdKey,
+ patErrorIdKey, plusIntegerIdKey, ratioDataConKey, ratioTyConKey,
+ rationalTyConKey, readClassKey, realClassKey, realFloatClassKey,
+ realFracClassKey, realWorldPrimIdKey, realWorldTyConKey,
+ recConErrorIdKey, recSelErrIdKey, recUpdErrorIdKey, returnIOIdKey,
+ returnMClassOpKey, runSTRepIdKey, showClassKey, ioTyConKey,
+ ioDataConKey, stablePtrDataConKey, stablePtrPrimTyConKey,
+ stablePtrTyConKey, stableNameDataConKey, stableNamePrimTyConKey,
+ stableNameTyConKey, statePrimTyConKey, timesIntegerIdKey, typeConKey,
+ kindConKey, boxityConKey, mVarPrimTyConKey, thenMClassOpKey,
+ threadIdPrimTyConKey, toEnumClassOpKey, traceIdKey, trueDataConKey,
+ unboundKey, unboxedConKey, unpackCStringUtf8IdKey,
+ unpackCStringAppendIdKey, unpackCStringFoldrIdKey, unpackCStringIdKey,
+ unsafeCoerceIdKey, ushowListIdKey, weakPrimTyConKey, wordDataConKey,
+ wordPrimTyConKey, wordTyConKey, word8TyConKey, word16TyConKey,
+ word32TyConKey, word64PrimTyConKey, word64TyConKey, zipIdKey
+
+ ) where
#include "HsVersions.h"
import Module ( ModuleName, mkPrelModule, mkSrcModule )
import OccName ( NameSpace, varName, dataName, tcName, clsName )
import RdrName ( RdrName, mkPreludeQual )
+import UniqFM
+import Unique ( Unique, Uniquable(..), hasKey,
+ mkPreludeMiscIdUnique, mkPreludeDataConUnique,
+ mkPreludeTyConUnique, mkPreludeClassUnique
+ )
import BasicTypes ( Boxity(..), Arity )
+import UniqFM ( UniqFM, listToUFM )
import Util ( nOfThem )
import Panic ( panic )
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Known key RdrNames}
+%* *
+%************************************************************************
+
+This section tells what the compiler knows about the
+assocation of names with uniques
+
+\begin{code}
+knownKeyRdrNames :: [(RdrName, Unique)]
+knownKeyRdrNames
+ = [
+ -- Type constructors (synonyms especially)
+ (ioTyCon_RDR, ioTyConKey)
+ , (main_RDR, mainKey)
+ , (orderingTyCon_RDR, orderingTyConKey)
+ , (rationalTyCon_RDR, rationalTyConKey)
+ , (ratioDataCon_RDR, ratioDataConKey)
+ , (ratioTyCon_RDR, ratioTyConKey)
+ , (byteArrayTyCon_RDR, byteArrayTyConKey)
+ , (mutableByteArrayTyCon_RDR, mutableByteArrayTyConKey)
+ , (foreignObjTyCon_RDR, foreignObjTyConKey)
+ , (bcoPrimTyCon_RDR, bcoPrimTyConKey)
+ , (stablePtrTyCon_RDR, stablePtrTyConKey)
+ , (stablePtrDataCon_RDR, stablePtrDataConKey)
+
+ -- Classes. *Must* include:
+ -- classes that are grabbed by key (e.g., eqClassKey)
+ -- classes in "Class.standardClassKeys" (quite a few)
+ , (eqClass_RDR, eqClassKey) -- mentioned, derivable
+ , (ordClass_RDR, ordClassKey) -- derivable
+ , (boundedClass_RDR, boundedClassKey) -- derivable
+ , (numClass_RDR, numClassKey) -- mentioned, numeric
+ , (enumClass_RDR, enumClassKey) -- derivable
+ , (monadClass_RDR, monadClassKey)
+ , (monadPlusClass_RDR, monadPlusClassKey)
+ , (functorClass_RDR, functorClassKey)
+ , (showClass_RDR, showClassKey) -- derivable
+ , (realClass_RDR, realClassKey) -- numeric
+ , (integralClass_RDR, integralClassKey) -- numeric
+ , (fractionalClass_RDR, fractionalClassKey) -- numeric
+ , (floatingClass_RDR, floatingClassKey) -- numeric
+ , (realFracClass_RDR, realFracClassKey) -- numeric
+ , (realFloatClass_RDR, realFloatClassKey) -- numeric
+ , (readClass_RDR, readClassKey) -- derivable
+ , (ixClass_RDR, ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm)
+ , (ccallableClass_RDR, cCallableClassKey) -- mentioned, ccallish
+ , (creturnableClass_RDR, cReturnableClassKey) -- mentioned, ccallish
+
+ -- ClassOps
+ , (fromInt_RDR, fromIntClassOpKey)
+ , (fromInteger_RDR, fromIntegerClassOpKey)
+ , (ge_RDR, geClassOpKey)
+ , (minus_RDR, minusClassOpKey)
+ , (enumFrom_RDR, enumFromClassOpKey)
+ , (enumFromThen_RDR, enumFromThenClassOpKey)
+ , (enumFromTo_RDR, enumFromToClassOpKey)
+ , (enumFromThenTo_RDR, enumFromThenToClassOpKey)
+ , (fromEnum_RDR, fromEnumClassOpKey)
+ , (toEnum_RDR, toEnumClassOpKey)
+ , (eq_RDR, eqClassOpKey)
+ , (thenM_RDR, thenMClassOpKey)
+ , (returnM_RDR, returnMClassOpKey)
+ , (failM_RDR, failMClassOpKey)
+ , (fromRational_RDR, fromRationalClassOpKey)
+
+ , (deRefStablePtr_RDR, deRefStablePtrIdKey)
+ , (makeStablePtr_RDR, makeStablePtrIdKey)
+ , (bindIO_RDR, bindIOIdKey)
+ , (returnIO_RDR, returnIOIdKey)
+
+ -- Strings and lists
+ , (map_RDR, mapIdKey)
+ , (append_RDR, appendIdKey)
+ , (unpackCString_RDR, unpackCStringIdKey)
+ , (unpackCStringAppend_RDR, unpackCStringAppendIdKey)
+ , (unpackCStringFoldr_RDR, unpackCStringFoldrIdKey)
+ , (unpackCStringUtf8_RDR, unpackCStringUtf8IdKey)
+
+ -- List operations
+ , (concat_RDR, concatIdKey)
+ , (filter_RDR, filterIdKey)
+ , (zip_RDR, zipIdKey)
+ , (foldr_RDR, foldrIdKey)
+ , (build_RDR, buildIdKey)
+ , (augment_RDR, augmentIdKey)
+
+ -- FFI primitive types that are not wired-in.
+ , (int8TyCon_RDR, int8TyConKey)
+ , (int16TyCon_RDR, int16TyConKey)
+ , (int32TyCon_RDR, int32TyConKey)
+ , (int64TyCon_RDR, int64TyConKey)
+ , (word8TyCon_RDR, word8TyConKey)
+ , (word16TyCon_RDR, word16TyConKey)
+ , (word32TyCon_RDR, word32TyConKey)
+ , (word64TyCon_RDR, word64TyConKey)
+
+ -- Others
+ , (otherwiseId_RDR, otherwiseIdKey)
+ , (plusInteger_RDR, plusIntegerIdKey)
+ , (timesInteger_RDR, timesIntegerIdKey)
+ , (eqString_RDR, eqStringIdKey)
+ , (assert_RDR, assertIdKey)
+ , (runSTRep_RDR, runSTRepIdKey)
+ ]
+\end{code}
+
+
%************************************************************************
%* *
\subsection{Module names}
@@ -343,3 +497,340 @@ tcQual = mkPreludeQual tcName
clsQual = mkPreludeQual clsName
\end{code}
+
+%************************************************************************
+%* *
+\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@}
+%* *
+%************************************************************************
+
+\begin{code}
+boundedClassKey = mkPreludeClassUnique 1
+enumClassKey = mkPreludeClassUnique 2
+eqClassKey = mkPreludeClassUnique 3
+floatingClassKey = mkPreludeClassUnique 5
+fractionalClassKey = mkPreludeClassUnique 6
+integralClassKey = mkPreludeClassUnique 7
+monadClassKey = mkPreludeClassUnique 8
+monadPlusClassKey = mkPreludeClassUnique 9
+functorClassKey = mkPreludeClassUnique 10
+numClassKey = mkPreludeClassUnique 11
+ordClassKey = mkPreludeClassUnique 12
+readClassKey = mkPreludeClassUnique 13
+realClassKey = mkPreludeClassUnique 14
+realFloatClassKey = mkPreludeClassUnique 15
+realFracClassKey = mkPreludeClassUnique 16
+showClassKey = mkPreludeClassUnique 17
+
+cCallableClassKey = mkPreludeClassUnique 18
+cReturnableClassKey = mkPreludeClassUnique 19
+
+ixClassKey = mkPreludeClassUnique 20
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@}
+%* *
+%************************************************************************
+
+\begin{code}
+addrPrimTyConKey = mkPreludeTyConUnique 1
+addrTyConKey = mkPreludeTyConUnique 2
+arrayPrimTyConKey = mkPreludeTyConUnique 3
+boolTyConKey = mkPreludeTyConUnique 4
+byteArrayPrimTyConKey = mkPreludeTyConUnique 5
+charPrimTyConKey = mkPreludeTyConUnique 7
+charTyConKey = mkPreludeTyConUnique 8
+doublePrimTyConKey = mkPreludeTyConUnique 9
+doubleTyConKey = mkPreludeTyConUnique 10
+floatPrimTyConKey = mkPreludeTyConUnique 11
+floatTyConKey = mkPreludeTyConUnique 12
+funTyConKey = mkPreludeTyConUnique 13
+intPrimTyConKey = mkPreludeTyConUnique 14
+intTyConKey = mkPreludeTyConUnique 15
+int8TyConKey = mkPreludeTyConUnique 16
+int16TyConKey = mkPreludeTyConUnique 17
+int32TyConKey = mkPreludeTyConUnique 18
+int64PrimTyConKey = mkPreludeTyConUnique 19
+int64TyConKey = mkPreludeTyConUnique 20
+integerTyConKey = mkPreludeTyConUnique 21
+listTyConKey = mkPreludeTyConUnique 22
+foreignObjPrimTyConKey = mkPreludeTyConUnique 23
+foreignObjTyConKey = mkPreludeTyConUnique 24
+weakPrimTyConKey = mkPreludeTyConUnique 25
+mutableArrayPrimTyConKey = mkPreludeTyConUnique 26
+mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 27
+orderingTyConKey = mkPreludeTyConUnique 28
+mVarPrimTyConKey = mkPreludeTyConUnique 29
+ratioTyConKey = mkPreludeTyConUnique 30
+rationalTyConKey = mkPreludeTyConUnique 31
+realWorldTyConKey = mkPreludeTyConUnique 32
+stablePtrPrimTyConKey = mkPreludeTyConUnique 33
+stablePtrTyConKey = mkPreludeTyConUnique 34
+statePrimTyConKey = mkPreludeTyConUnique 35
+stableNamePrimTyConKey = mkPreludeTyConUnique 50
+stableNameTyConKey = mkPreludeTyConUnique 51
+mutableByteArrayTyConKey = mkPreludeTyConUnique 52
+mutVarPrimTyConKey = mkPreludeTyConUnique 53
+ioTyConKey = mkPreludeTyConUnique 55
+byteArrayTyConKey = mkPreludeTyConUnique 56
+wordPrimTyConKey = mkPreludeTyConUnique 57
+wordTyConKey = mkPreludeTyConUnique 58
+word8TyConKey = mkPreludeTyConUnique 59
+word16TyConKey = mkPreludeTyConUnique 60
+word32TyConKey = mkPreludeTyConUnique 61
+word64PrimTyConKey = mkPreludeTyConUnique 62
+word64TyConKey = mkPreludeTyConUnique 63
+boxedConKey = mkPreludeTyConUnique 64
+unboxedConKey = mkPreludeTyConUnique 65
+anyBoxConKey = mkPreludeTyConUnique 66
+kindConKey = mkPreludeTyConUnique 67
+boxityConKey = mkPreludeTyConUnique 68
+typeConKey = mkPreludeTyConUnique 69
+threadIdPrimTyConKey = mkPreludeTyConUnique 70
+bcoPrimTyConKey = mkPreludeTyConUnique 71
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@}
+%* *
+%************************************************************************
+
+\begin{code}
+addrDataConKey = mkPreludeDataConUnique 0
+charDataConKey = mkPreludeDataConUnique 1
+consDataConKey = mkPreludeDataConUnique 2
+doubleDataConKey = mkPreludeDataConUnique 3
+falseDataConKey = mkPreludeDataConUnique 4
+floatDataConKey = mkPreludeDataConUnique 5
+intDataConKey = mkPreludeDataConUnique 6
+smallIntegerDataConKey = mkPreludeDataConUnique 7
+largeIntegerDataConKey = mkPreludeDataConUnique 8
+foreignObjDataConKey = mkPreludeDataConUnique 9
+nilDataConKey = mkPreludeDataConUnique 10
+ratioDataConKey = mkPreludeDataConUnique 11
+stablePtrDataConKey = mkPreludeDataConUnique 12
+stableNameDataConKey = mkPreludeDataConUnique 13
+trueDataConKey = mkPreludeDataConUnique 14
+wordDataConKey = mkPreludeDataConUnique 15
+ioDataConKey = mkPreludeDataConUnique 16
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)}
+%* *
+%************************************************************************
+
+\begin{code}
+absentErrorIdKey = mkPreludeMiscIdUnique 1
+appendIdKey = mkPreludeMiscIdUnique 2
+augmentIdKey = mkPreludeMiscIdUnique 3
+buildIdKey = mkPreludeMiscIdUnique 4
+errorIdKey = mkPreludeMiscIdUnique 5
+foldlIdKey = mkPreludeMiscIdUnique 6
+foldrIdKey = mkPreludeMiscIdUnique 7
+recSelErrIdKey = mkPreludeMiscIdUnique 8
+integerMinusOneIdKey = mkPreludeMiscIdUnique 9
+integerPlusOneIdKey = mkPreludeMiscIdUnique 10
+integerPlusTwoIdKey = mkPreludeMiscIdUnique 11
+integerZeroIdKey = mkPreludeMiscIdUnique 12
+int2IntegerIdKey = mkPreludeMiscIdUnique 13
+irrefutPatErrorIdKey = mkPreludeMiscIdUnique 15
+eqStringIdKey = mkPreludeMiscIdUnique 16
+noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 17
+nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 18
+parErrorIdKey = mkPreludeMiscIdUnique 20
+parIdKey = mkPreludeMiscIdUnique 21
+patErrorIdKey = mkPreludeMiscIdUnique 22
+realWorldPrimIdKey = mkPreludeMiscIdUnique 23
+recConErrorIdKey = mkPreludeMiscIdUnique 24
+recUpdErrorIdKey = mkPreludeMiscIdUnique 25
+traceIdKey = mkPreludeMiscIdUnique 26
+unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 27
+unpackCStringAppendIdKey = mkPreludeMiscIdUnique 28
+unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 29
+unpackCStringIdKey = mkPreludeMiscIdUnique 30
+ushowListIdKey = mkPreludeMiscIdUnique 31
+unsafeCoerceIdKey = mkPreludeMiscIdUnique 32
+concatIdKey = mkPreludeMiscIdUnique 33
+filterIdKey = mkPreludeMiscIdUnique 34
+zipIdKey = mkPreludeMiscIdUnique 35
+bindIOIdKey = mkPreludeMiscIdUnique 36
+returnIOIdKey = mkPreludeMiscIdUnique 37
+deRefStablePtrIdKey = mkPreludeMiscIdUnique 38
+makeStablePtrIdKey = mkPreludeMiscIdUnique 39
+getTagIdKey = mkPreludeMiscIdUnique 40
+plusIntegerIdKey = mkPreludeMiscIdUnique 41
+timesIntegerIdKey = mkPreludeMiscIdUnique 42
+\end{code}
+
+Certain class operations from Prelude classes. They get their own
+uniques so we can look them up easily when we want to conjure them up
+during type checking.
+
+\begin{code}
+fromIntClassOpKey = mkPreludeMiscIdUnique 101
+fromIntegerClassOpKey = mkPreludeMiscIdUnique 102
+minusClassOpKey = mkPreludeMiscIdUnique 103
+fromRationalClassOpKey = mkPreludeMiscIdUnique 104
+enumFromClassOpKey = mkPreludeMiscIdUnique 105
+enumFromThenClassOpKey = mkPreludeMiscIdUnique 106
+enumFromToClassOpKey = mkPreludeMiscIdUnique 107
+enumFromThenToClassOpKey = mkPreludeMiscIdUnique 108
+eqClassOpKey = mkPreludeMiscIdUnique 109
+geClassOpKey = mkPreludeMiscIdUnique 110
+failMClassOpKey = mkPreludeMiscIdUnique 112
+thenMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=)
+ -- Just a place holder for unbound variables produced by the renamer:
+unboundKey = mkPreludeMiscIdUnique 114
+fromEnumClassOpKey = mkPreludeMiscIdUnique 115
+
+mainKey = mkPreludeMiscIdUnique 116
+returnMClassOpKey = mkPreludeMiscIdUnique 117
+otherwiseIdKey = mkPreludeMiscIdUnique 118
+toEnumClassOpKey = mkPreludeMiscIdUnique 119
+mapIdKey = mkPreludeMiscIdUnique 120
+\end{code}
+
+\begin{code}
+assertIdKey = mkPreludeMiscIdUnique 121
+runSTRepIdKey = mkPreludeMiscIdUnique 122
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[Class-std-groups]{Standard groups of Prelude classes}
+%* *
+%************************************************************************
+
+@derivableClassKeys@ is also used in checking \tr{deriving} constructs
+(@TcDeriv@).
+
+@derivingOccurrences@ maps a class name to a list of the (qualified) occurrences
+that will be mentioned by the derived code for the class when it is later generated.
+We don't need to put in things that are WiredIn (because they are already mapped to their
+correct name by the @NameSupply@. The class itself, and all its class ops, is
+already flagged as an occurrence so we don't need to mention that either.
+
+@derivingOccurrences@ has an item for every derivable class, even if that item is empty,
+because we treat lookup failure as indicating that the class is illegal in a deriving clause.
+
+\begin{code}
+derivingOccurrences :: UniqFM [RdrName]
+derivingOccurrences = listToUFM deriving_occ_info
+
+derivableClassKeys = map fst deriving_occ_info
+
+deriving_occ_info
+ = [ (eqClassKey, [intTyCon_RDR, and_RDR, not_RDR])
+ , (ordClassKey, [intTyCon_RDR, compose_RDR, eqTag_RDR])
+ -- EQ (from Ordering) is needed to force in the constructors
+ -- as well as the type constructor.
+ , (enumClassKey, [intTyCon_RDR, eq_RDR, ge_RDR, and_RDR, map_RDR, plus_RDR, showsPrec_RDR, append_RDR])
+ -- The last two Enum deps are only used to produce better
+ -- error msgs for derived toEnum methods.
+ , (boundedClassKey, [intTyCon_RDR])
+ , (showClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, compose_RDR, showString_RDR,
+ showParen_RDR, showSpace_RDR, showList___RDR])
+ , (readClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, append_RDR,
+ foldr_RDR, build_RDR,
+ -- foldr and build required for list comprehension
+ -- KSW 2000-06
+ lex_RDR, readParen_RDR, readList___RDR, thenM_RDR])
+ -- returnM (and the rest of the Monad class decl)
+ -- will be forced in as result of depending
+ -- on thenM. -- SOF 1/99
+ , (ixClassKey, [intTyCon_RDR, numClass_RDR, and_RDR, map_RDR, enumFromTo_RDR,
+ foldr_RDR, build_RDR,
+ -- foldr and build required for list comprehension used
+ -- with single constructor types -- KSW 2000-06
+ returnM_RDR, failM_RDR])
+ -- the last two are needed to force returnM, thenM and failM
+ -- in before typechecking the list(monad) comprehension
+ -- generated for derived Ix instances (range method)
+ -- of single constructor types. -- SOF 8/97
+ ]
+ -- intTyCon: Practically any deriving needs Int, either for index calculations,
+ -- or for taggery.
+ -- ordClass: really it's the methods that are actually used.
+ -- numClass: for Int literals
+\end{code}
+
+
+NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@
+even though every numeric class has these two as a superclass,
+because the list of ambiguous dictionaries hasn't been simplified.
+
+\begin{code}
+numericClassKeys =
+ [ numClassKey
+ , realClassKey
+ , integralClassKey
+ ]
+ ++ fractionalClassKeys
+
+fractionalClassKeys =
+ [ fractionalClassKey
+ , floatingClassKey
+ , realFracClassKey
+ , realFloatClassKey
+ ]
+
+ -- the strictness analyser needs to know about numeric types
+ -- (see SaAbsInt.lhs)
+numericTyKeys =
+ [ addrTyConKey
+ , wordTyConKey
+ , intTyConKey
+ , integerTyConKey
+ , doubleTyConKey
+ , floatTyConKey
+ ]
+
+needsDataDeclCtxtClassKeys = -- see comments in TcDeriv
+ [ readClassKey
+ ]
+
+cCallishClassKeys =
+ [ cCallableClassKey
+ , cReturnableClassKey
+ ]
+
+ -- Renamer always imports these data decls replete with constructors
+ -- so that desugarer can always see their constructors. Ugh!
+cCallishTyKeys =
+ [ addrTyConKey
+ , wordTyConKey
+ , byteArrayTyConKey
+ , mutableByteArrayTyConKey
+ , foreignObjTyConKey
+ , stablePtrTyConKey
+ , int8TyConKey
+ , int16TyConKey
+ , int32TyConKey
+ , int64TyConKey
+ , word8TyConKey
+ , word16TyConKey
+ , word32TyConKey
+ , word64TyConKey
+ ]
+
+standardClassKeys
+ = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys
+ --
+ -- We have to have "CCallable" and "CReturnable" in the standard
+ -- classes, so that if you go...
+ --
+ -- _ccall_ foo ... 93{-numeric literal-} ...
+ --
+ -- ... it can do The Right Thing on the 93.
+
+noDictClassKeys -- These classes are used only for type annotations;
+ -- they are not implemented by dictionaries, ever.
+ = cCallishClassKeys
+\end{code}
+
diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs
index 2b6ccf98aca0..d13ee7f9b600 100644
--- a/ghc/compiler/prelude/PrelRules.lhs
+++ b/ghc/compiler/prelude/PrelRules.lhs
@@ -32,8 +32,7 @@ import DataCon ( dataConTag, dataConTyCon, dataConId, fIRST_TAG )
import CoreUtils ( exprIsValue, cheapEqExpr, exprIsConApp_maybe )
import Type ( splitTyConApp_maybe )
import OccName ( occNameUserString)
-import PrelNames ( unpackCStringFoldr_RDR )
-import Unique ( unpackCStringFoldrIdKey, hasKey )
+import PrelNames ( unpackCStringFoldr_RDR, unpackCStringFoldrIdKey, hasKey )
import Bits ( Bits(..) )
import Word ( Word64 )
import Outputable
diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs
index 918b8c3e34ce..45a1620afc1b 100644
--- a/ghc/compiler/prelude/TysPrim.lhs
+++ b/ghc/compiler/prelude/TysPrim.lhs
@@ -54,9 +54,9 @@ import Type ( Type,
mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy,
unboxedTypeKind, boxedTypeKind, openTypeKind, mkArrowKinds
)
-import PrelNames ( pREL_GHC )
+import Unique ( mkAlphaTyVarUnique )
+import PrelNames
import Outputable
-import Unique
\end{code}
\begin{code}
diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index d9b7e9d7766e..dcad4321909f 100644
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -96,7 +96,8 @@ import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys,
mkFunTy, mkFunTys,
splitTyConApp_maybe, repType,
TauType, ClassContext )
-import Unique
+import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique )
+import PrelNames
import CmdLineOpts ( opt_GlasgowExts )
import Array
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 1ffe1f78baf4..dcb715375b86 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -48,10 +48,10 @@ import TyCon ( isSynTyCon, getSynTyConDefn )
import NameSet
import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon )
import PrelRules ( builtinRules )
-import PrelInfo ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
- ioTyCon_RDR, unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
- fractionalClassKeys, derivingOccurrences
+import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
+ ioTyCon_RDR, unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR
)
+import PrelInfo ( fractionalClassKeys, derivingOccurrences )
import Type ( namesOfType, funTyCon )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet, ghcExit )
import BasicTypes ( Version, initialVersion )
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 5a8361058223..6e71a32bb909 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -29,12 +29,12 @@ import RnIfaces ( lookupFixityRn )
import CmdLineOpts ( opt_GlasgowExts, opt_IgnoreAsserts )
import Literal ( inIntRange )
import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
-import PrelInfo ( eqClass_RDR,
+import PrelNames ( hasKey, assertIdKey,
+ eqClass_RDR, foldr_RDR, build_RDR, eqString_RDR,
ccallableClass_RDR, creturnableClass_RDR,
monadClass_RDR, enumClass_RDR, ordClass_RDR,
ratioDataCon_RDR, negate_RDR, assertErr_RDR,
- ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR,
- foldr_RDR, build_RDR
+ ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR
)
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
floatPrimTyCon, doublePrimTyCon
@@ -45,7 +45,6 @@ import NameSet
import UniqFM ( isNullUFM )
import FiniteMap ( elemFM )
import UniqSet ( emptyUniqSet )
-import Unique ( hasKey, assertIdKey )
import Util ( removeDups )
import ListSetOps ( unionLists )
import Maybes ( maybeToBool )
@@ -80,6 +79,10 @@ rnPat (SigPatIn pat ty)
where
doc = text "a pattern type-signature"
+rnPat (LitPatIn s@(HsString _))
+ = lookupOrigName eqString_RDR `thenRn` \ eq ->
+ returnRn (LitPatIn s, unitFV eq)
+
rnPat (LitPatIn lit)
= litFVs lit `thenRn` \ fvs ->
returnRn (LitPatIn lit, fvs)
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 5988b32c5195..c0e9ad51129b 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -25,7 +25,7 @@ import RnEnv
import RnMonad
import FiniteMap
-import PrelInfo ( pRELUDE_Name, mAIN_Name, main_RDR )
+import PrelNames ( pRELUDE_Name, mAIN_Name, main_RDR )
import UniqFM ( lookupUFM )
import Bag ( bagToList )
import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) )
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 15ad4fd94b84..86a4f255bc5e 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -37,8 +37,8 @@ import Class ( FunDep )
import Name ( Name, OccName, nameOccName, NamedThing(..) )
import NameSet
import FiniteMap ( elemFM )
-import PrelInfo ( derivableClassKeys, cCallishClassKeys,
- deRefStablePtr_RDR, makeStablePtr_RDR,
+import PrelInfo ( derivableClassKeys, cCallishClassKeys )
+import PrelNames ( deRefStablePtr_RDR, makeStablePtr_RDR,
bindIO_RDR, returnIO_RDR
)
import Bag ( bagToList )
diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index afe7ac0993db..2d48bd12b26f 100644
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -36,7 +36,8 @@ import Name ( isLocallyDefined )
import Type ( splitFunTy_maybe, splitForAllTys )
import Maybes ( maybeToBool )
import Digraph ( stronglyConnCompR, SCC(..) )
-import Unique ( u2i, buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
+import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
+import Unique ( u2i )
import UniqFM ( keysUFM )
import Util ( zipWithEqual, mapAndUnzip )
import Outputable
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index e4995fe6f643..d69f4b47a550 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -75,7 +75,7 @@ import TysWiredIn ( isIntTy,
doubleDataCon, isDoubleTy,
isIntegerTy, voidTy
)
-import Unique ( Unique, hasKey, fromIntClassOpKey, fromIntegerClassOpKey )
+import PrelNames( Unique, hasKey, fromIntClassOpKey, fromIntegerClassOpKey )
import Maybe ( catMaybes )
import Util ( thenCmp, zipWithEqual, mapAccumL )
import Outputable
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 93f43261f783..eea1f86f0dcf 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -58,7 +58,7 @@ import Util ( isIn )
import Maybes ( maybeToBool )
import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNotTopLevel )
import FiniteMap ( listToFM, lookupFM )
-import Unique ( ioTyConKey, mainKey, hasKey )
+import PrelNames ( ioTyConKey, mainKey, hasKey )
import Outputable
\end{code}
diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs
index aaed7c2221a0..0d58fb5242e2 100644
--- a/ghc/compiler/typecheck/TcDefaults.lhs
+++ b/ghc/compiler/typecheck/TcDefaults.lhs
@@ -18,7 +18,7 @@ import TcSimplify ( tcSimplifyCheckThetas )
import TysWiredIn ( integerTy, doubleTy )
import Type ( Type )
-import Unique ( numClassKey )
+import PrelNames ( numClassKey )
import Outputable
\end{code}
diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 8ffabd0bf9b6..4d21acebb185 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -49,7 +49,7 @@ import Type ( TauType, mkTyVarTys, mkTyConApp,
)
import TysWiredIn ( voidTy )
import Var ( TyVar )
-import Unique -- Keys stuff
+import PrelNames
import Bag ( bagToList )
import Util ( zipWithEqual, sortLt, removeDups, assoc, thenCmp )
import Outputable
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index da6a5bef681a..802620b79b67 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -62,7 +62,7 @@ import UsageSPUtils ( unannotTy )
import VarSet ( elemVarSet, mkVarSet )
import TysWiredIn ( boolTy )
import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy )
-import Unique ( cCallableClassKey, cReturnableClassKey,
+import PrelNames ( cCallableClassKey, cReturnableClassKey,
enumFromClassOpKey, enumFromThenClassOpKey,
enumFromToClassOpKey, enumFromThenToClassOpKey,
thenMClassOpKey, failMClassOpKey, returnMClassOpKey, ioTyConKey
@@ -88,7 +88,7 @@ tcExpr :: RenamedHsExpr -- Expession to type check
tcExpr expr ty | isSigmaTy ty = -- Polymorphic case
tcPolyExpr expr ty `thenTc` \ (expr', lie, _, _, _) ->
- returnTc (expr', lie)
+ returnTc (expr', lie)
| otherwise = -- Monomorphic case
tcMonoExpr expr ty
@@ -740,7 +740,7 @@ tcApp fun args res_ty
-- Check that the result type doesn't have any nested for-alls.
-- For example, a "build" on its own is no good; it must be applied to something.
checkTc (isTauTy actual_result_ty)
- (lurkingRank2Err fun fun_ty) `thenTc_`
+ (lurkingRank2Err fun actual_result_ty) `thenTc_`
returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
@@ -1081,7 +1081,7 @@ appCtxt fun args
lurkingRank2Err fun fun_ty
= hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)])
4 (vcat [ptext SLIT("It is applied to too few arguments"),
- ptext SLIT("so that the result type has for-alls in it")])
+ ptext SLIT("so that the result type has for-alls in it:") <+> ppr fun_ty])
badFieldsUpd rbinds
= hang (ptext SLIT("No constructor has all these fields:"))
diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs
index 62f68c17131c..65da5c58ec5f 100644
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -45,7 +45,7 @@ import TysWiredIn ( isFFIArgumentTy, isFFIResultTy,
isFFILabelTy
)
import Type ( Type )
-import Unique
+import PrelNames ( hasKey, ioTyConKey )
import Outputable
\end{code}
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index baf3b54dd625..5db09d1f7059 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -54,7 +54,7 @@ import Type ( mkTyVarTys, splitSigmaTy, isTyVarTy,
import Subst ( mkTopTyVarSubst, substClasses )
import VarSet ( mkVarSet, varSetElems )
import TysWiredIn ( isFFIArgumentTy, isFFIResultTy )
-import Unique ( cCallableClassKey, cReturnableClassKey, hasKey )
+import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
import Outputable
\end{code}
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 382984fc8d02..03f4fce6eb4f 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -50,8 +50,7 @@ import Name ( nameOccName, isLocallyDefined, isGlobalName,
import OccName ( isSysOcc )
import TyCon ( TyCon, tyConClass_maybe )
import Class ( Class )
-import PrelInfo ( mAIN_Name )
-import Unique ( mainKey )
+import PrelNames ( mAIN_Name, mainKey )
import UniqSupply ( UniqSupply )
import Maybes ( maybeToBool )
import Util
diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 621649c3f4cf..51f8de5dec4d 100644
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -5,7 +5,7 @@
\begin{code}
module TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType,
- tcContext, tcClassContext,
+ tcHsConSigType, tcContext, tcClassContext,
-- Kind checking
kcHsTyVar, kcHsTyVars, mkTyClTyVars,
@@ -46,7 +46,7 @@ import Type ( Type, Kind, PredType(..), ThetaType, UsageAnn(..),
mkArrowKinds, getTyVar_maybe, getTyVar, splitFunTy_maybe,
tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars,
tyVarsOfType, tyVarsOfPred, mkForAllTys,
- classesOfPreds
+ classesOfPreds, isUnboxedTupleType
)
import PprType ( pprType, pprPred )
import Subst ( mkTopTyVarSubst, substTy )
@@ -265,6 +265,7 @@ tcHsSigType and tcHsBoxedSigType are used for type signatures written by the pro
* Notice that we kind-check first, because the type-check assumes
that the kinds are already checked.
+
* They are only called when there are no kind vars in the environment
so the kind returned is indeed a Kind not a TcKind
@@ -280,6 +281,14 @@ tcHsBoxedSigType ty
= kcBoxedType ty `thenTc_`
tcHsType ty `thenTc` \ ty' ->
returnTc (hoistForAllTys ty')
+
+tcHsConSigType :: RenamedHsType -> TcM s Type
+-- Used for constructor arguments, which must not
+-- be unboxed tuples
+tcHsConSigType ty
+ = kcTypeType ty `thenTc_`
+ tcHsArgType ty `thenTc` \ ty' ->
+ returnTc (hoistForAllTys ty')
\end{code}
@@ -287,6 +296,17 @@ tcHsType, the main work horse
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
+tcHsArgType :: RenamedHsType -> TcM s TcType
+-- Used the for function and constructor arguments,
+-- which are not allowed to be unboxed tuples
+-- This is a bit ad hoc; we don't have a separate kind
+-- for unboxed tuples
+tcHsArgType ty
+ = tcHsType ty `thenTc` \ tau_ty ->
+ checkTc (not (isUnboxedTupleType tau_ty))
+ (unboxedTupleErr ty) `thenTc_`
+ returnTc tau_ty
+
tcHsType :: RenamedHsType -> TcM s Type
tcHsType ty@(HsTyVar name)
= tc_app ty []
@@ -300,7 +320,7 @@ tcHsType (HsTupleTy (HsTupCon _ boxity) tys)
returnTc (mkTupleTy boxity (length tys) tau_tys)
tcHsType (HsFunTy ty1 ty2)
- = tcHsType ty1 `thenTc` \ tau_ty1 ->
+ = tcHsArgType ty1 `thenTc` \ tau_ty1 ->
tcHsType ty2 `thenTc` \ tau_ty2 ->
returnTc (mkFunTy tau_ty1 tau_ty2)
@@ -869,4 +889,7 @@ freeErr pred ty
ptext SLIT("does not mention any of the universally quantified type variables"),
nest 4 (ptext SLIT("in the type") <+> quotes (ppr ty))
]
+
+unboxedTupleErr ty
+ = sep [ptext (SLIT("Illegal unboxed tuple as a function or contructor argument:")), nest 4 (ppr ty)]
\end{code}
diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 3ffa6c9dbfcd..9a44d8d8713e 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -37,7 +37,7 @@ import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
doublePrimTy, addrPrimTy
)
import TysWiredIn ( charTy, stringTy, intTy, integerTy )
-import Unique ( eqClassOpKey, geClassOpKey,
+import PrelNames ( eqClassOpKey, geClassOpKey,
cCallableClassKey, eqStringIdKey,
)
import BasicTypes ( isBoxed )
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 23b336ae881c..a16fb0ffe1df 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -159,8 +159,11 @@ tcGroup unf_env scc
tcTyClDecl1 :: ValueEnv -> RenamedTyClDecl -> TcM s (Name, TyThingDetails)
tcTyClDecl1 unf_env decl
- | isClassDecl decl = tcClassDecl1 unf_env decl
- | otherwise = tcTyDecl1 decl
+ = tcAddDeclCtxt decl $
+ if isClassDecl decl then
+ tcClassDecl1 unf_env decl
+ else
+ tcTyDecl1 decl
\end{code}
@@ -473,8 +476,8 @@ tcAddDeclCtxt decl thing_inside
= case decl of
(ClassDecl _ name _ _ _ _ _ _ _ _ _ loc) -> (name, loc, "class")
(TySynonym name _ _ loc) -> (name, loc, "type synonym")
- (TyData NewType _ name _ _ _ _ _ loc) -> (name, loc, "data type")
- (TyData DataType _ name _ _ _ _ _ loc) -> (name, loc, "newtype")
+ (TyData NewType _ name _ _ _ _ _ loc) -> (name, loc, "newtype")
+ (TyData DataType _ name _ _ _ _ _ loc) -> (name, loc, "data type")
ctxt = hsep [ptext SLIT("In the"), text thing,
ptext SLIT("declaration for"), quotes (ppr name)]
@@ -497,4 +500,5 @@ pp_cycle str decls
= hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
where
name = tyClDeclName decl
+
\end{code}
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 6ef01c048cfb..8e9a9ee1cc07 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -20,7 +20,7 @@ import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext )
import TcHsSyn ( TcMonoBinds, idsToMonoBinds )
import BasicTypes ( NewOrData(..) )
-import TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, kcTyVarScope, tcClassContext,
+import TcMonoType ( tcHsType, tcHsConSigType, tcHsBoxedSigType, kcTyVarScope, tcClassContext,
kcHsContext, kcHsSigType, mkImmutTyVars
)
import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcLookupValueByKey, TyThing(..), TyThingDetails(..) )
@@ -45,7 +45,7 @@ import Type ( tyVarsOfTypes, splitFunTy, applyTys,
)
import TysWiredIn ( unitTy )
import VarSet ( intersectVarSet, isEmptyVarSet )
-import Unique ( unpackCStringIdKey, unpackCStringUtf8IdKey )
+import PrelNames ( unpackCStringIdKey, unpackCStringUtf8IdKey )
import Util ( equivClasses )
\end{code}
@@ -154,7 +154,7 @@ tcConDecl new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt de
RecCon fields -> tc_rec_con ex_tyvars ex_theta fields
where
tc_sig_type = case new_or_data of
- DataType -> tcHsSigType
+ DataType -> tcHsConSigType
NewType -> tcHsBoxedSigType
-- Can't allow an unboxed type here, because we're effectively
-- going to remove the constructor while coercing it to a boxed type.
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 509bea6f6cc1..02585beba84c 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -44,7 +44,7 @@ module TcType (
-- friends:
import TypeRep ( Type(..), Kind, TyNote(..) ) -- friend
import Type ( ThetaType, PredType(..),
- getTyVar, mkAppTy, mkTyConApp,
+ getTyVar, mkAppTy, mkTyConApp, mkPredTy,
splitPredTy_maybe, splitForAllTys, isNotUsgTy,
isTyVarTy, mkTyVarTy, mkTyVarTys,
openTypeKind, boxedTypeKind,
@@ -407,8 +407,8 @@ zonkType unbound_var_fn ty
go (NoteTy (UsgForAll uv) ty2)= go ty2 `thenNF_Tc` \ ty2' ->
returnNF_Tc (NoteTy (UsgForAll uv) ty2')
- go (NoteTy (IPNote nm) ty2) = go ty2 `thenNF_Tc` \ ty2' ->
- returnNF_Tc (NoteTy (IPNote nm) ty2')
+ go (PredTy p) = go_pred p `thenNF_Tc` \ p' ->
+ returnNF_Tc (PredTy p')
go (FunTy arg res) = go arg `thenNF_Tc` \ arg' ->
go res `thenNF_Tc` \ res' ->
@@ -425,6 +425,10 @@ zonkType unbound_var_fn ty
go ty `thenNF_Tc` \ ty' ->
returnNF_Tc (ForAllTy tyvar' ty')
+ go_pred (Class c tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' ->
+ returnNF_Tc (Class c tys')
+ go_pred (IParam n ty) = go ty `thenNF_Tc` \ ty' ->
+ returnNF_Tc (IParam n ty')
zonkTyVar :: (TcTyVar -> NF_TcM s Type) -- What to do for an unbound mutable variable
-> TcTyVar -> NF_TcM s TcType
diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs
index a9aa01ef41b5..e431580a112a 100644
--- a/ghc/compiler/typecheck/TcUnify.lhs
+++ b/ghc/compiler/typecheck/TcUnify.lhs
@@ -16,7 +16,7 @@ module TcUnify ( unifyTauTy, unifyTauTyList, unifyTauTyLists,
-- friends:
import TcMonad
-import TypeRep ( Type(..) ) -- friend
+import TypeRep ( Type(..), PredType(..) ) -- friend
import Type ( funTyCon, Kind, unboxedTypeKind, boxedTypeKind, openTypeKind,
superBoxity, typeCon, openKindCon, hasMoreBoxityInfo,
tyVarsOfType, typeKind,
@@ -157,6 +157,12 @@ uTys ps_ty1 (TyVarTy tyvar1) ps_ty2 ty2 = uVar False tyvar1 ps_ty2 ty2
uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar True tyvar2 ps_ty1 ty1
-- "True" means args swapped
+ -- Predicates
+uTys _ (PredTy (IParam n1 t1)) _ (PredTy (IParam n2 t2))
+ | n1 == n2 = uTys t1 t1 t2 t2
+uTys _ (PredTy (Class c1 tys1)) _ (PredTy (Class c2 tys2))
+ | c1 == c2 = unifyTauTyLists tys1 tys2
+
-- Functions; just check the two parts
uTys _ (FunTy fun1 arg1) _ (FunTy fun2 arg2)
= uTys fun1 fun1 fun2 fun2 `thenTc_` uTys arg1 arg1 arg2 arg2
@@ -172,10 +178,6 @@ uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2)
-- (CCallable Int) and (CCallable Int#) are both OK
= unifyOpenTypeKind ps_ty2
- | otherwise
- = unifyMisMatch ps_ty1 ps_ty2
-
-
-- Applications need a bit of care!
-- They can match FunTy and TyConApp, so use splitAppTy_maybe
-- NB: we've already dealt with type variables and Notes,
diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
index 00ff1e872010..7b7b55a6730f 100644
--- a/ghc/compiler/types/PprType.lhs
+++ b/ghc/compiler/types/PprType.lhs
@@ -25,7 +25,7 @@ import Type ( PredType(..), ThetaType,
splitPredTy_maybe,
splitForAllTys, splitSigmaTy, splitRhoTy,
isDictTy, splitTyConApp_maybe, splitFunTy_maybe,
- splitUsForAllTys
+ splitUsForAllTys, predRepTy
)
import Var ( TyVar, tyVarKind,
tyVarName, setTyVarName
@@ -42,7 +42,7 @@ import Name ( getOccString, NamedThing(..) )
import Outputable
import PprEnv
import Unique ( Uniquable(..) )
-import Unique -- quite a few *Keys
+import PrelNames -- quite a few *Keys
\end{code}
%************************************************************************
@@ -78,6 +78,9 @@ pprTheta theta = parens (hsep (punctuate comma (map pprPred theta)))
instance Outputable Type where
ppr ty = pprType ty
+
+instance Outputable PredType where
+ ppr = pprPred
\end{code}
@@ -212,8 +215,7 @@ ppr_ty env ctxt_prec (NoteTy (UsgNote u) ty)
= maybeParen ctxt_prec tYCON_PREC $
ptext SLIT("__u") <+> ppr u <+> ppr_ty env tYCON_PREC ty
-ppr_ty env ctxt_prec (NoteTy (IPNote nm) ty)
- = braces (ppr_pred env (IParam nm ty))
+ppr_ty env ctxt_prec (PredTy p) = braces (ppr_pred env p)
ppr_theta env [] = empty
ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_pred env) theta)))
@@ -284,6 +286,7 @@ getTyDescription ty
NoteTy (FTVNote _) ty -> getTyDescription ty
NoteTy (SynNote ty1) _ -> getTyDescription ty1
NoteTy (UsgNote _) ty -> getTyDescription ty
+ PredTy p -> getTyDescription (predRepTy p)
ForAllTy _ ty -> getTyDescription ty
}
where
diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index ada8cefba8f1..9692a9a7560b 100644
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -54,7 +54,7 @@ import Class ( Class, ClassContext )
import Var ( TyVar )
import BasicTypes ( Arity, NewOrData(..), RecFlag(..), Boxity(..), isBoxed )
import Name ( Name, nameUnique, NamedThing(getName) )
-import Unique ( Unique, Uniquable(..), anyBoxConKey )
+import PrelNames ( Unique, Uniquable(..), anyBoxConKey )
import PrimRep ( PrimRep(..), isFollowableRep )
import Outputable
\end{code}
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 9c3e3bf56570..1b8d996e0eaf 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -30,7 +30,10 @@ module Type (
mkTyConApp, mkTyConTy, splitTyConApp_maybe,
splitAlgTyConApp_maybe, splitAlgTyConApp,
- mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe, splitDictTy_maybe, isDictTy,
+
+ -- Predicates and the like
+ mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe,
+ splitDictTy_maybe, isDictTy, predRepTy,
mkSynTy, isSynTy, deNoteType,
@@ -77,7 +80,7 @@ import TypeRep
-- Other imports:
import {-# SOURCE #-} DataCon( DataCon, dataConRepType )
-import {-# SOURCE #-} PprType( pprType, pprPred ) -- Only called in debug messages
+import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages
import {-# SOURCE #-} Subst ( mkTyVarSubst, substTy )
-- friends:
@@ -103,7 +106,7 @@ import SrcLoc ( noSrcLoc )
import Maybes ( maybeToBool )
import PrimRep ( PrimRep(..), isFollowableRep )
import Unique ( Uniquable(..) )
-import Util ( mapAccumL, seqList )
+import Util ( mapAccumL, seqList, thenCmp )
import Outputable
import UniqSet ( sizeUniqSet ) -- Should come via VarSet
\end{code}
@@ -147,17 +150,20 @@ mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
getTyVar :: String -> Type -> TyVar
getTyVar msg (TyVarTy tv) = tv
+getTyVar msg (PredTy p) = getTyVar msg (predRepTy p)
getTyVar msg (NoteTy _ t) = getTyVar msg t
getTyVar msg other = panic ("getTyVar: " ++ msg)
getTyVar_maybe :: Type -> Maybe TyVar
getTyVar_maybe (TyVarTy tv) = Just tv
getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t
+getTyVar_maybe (PredTy p) = getTyVar_maybe (predRepTy p)
getTyVar_maybe other = Nothing
isTyVarTy :: Type -> Bool
isTyVarTy (TyVarTy tv) = True
isTyVarTy (NoteTy _ ty) = isTyVarTy ty
+isTyVarTy (PredTy p) = isTyVarTy (predRepTy p)
isTyVarTy other = False
\end{code}
@@ -170,8 +176,10 @@ invariant that a TyConApp is always visibly so. mkAppTy maintains the
invariant: use it.
\begin{code}
-mkAppTy orig_ty1 orig_ty2 = ASSERT2( isNotUsgTy orig_ty1 && isNotUsgTy orig_ty2, pprType orig_ty1 <+> text "to" <+> pprType orig_ty2 )
- mk_app orig_ty1
+mkAppTy orig_ty1 orig_ty2
+ = ASSERT2( isNotUsgTy orig_ty1 && isNotUsgTy orig_ty2, pprType orig_ty1 <+> text "to" <+> pprType orig_ty2 )
+ ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind *
+ mk_app orig_ty1
where
mk_app (NoteTy _ ty1) = mk_app ty1
mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
@@ -184,8 +192,10 @@ mkAppTys orig_ty1 [] = orig_ty1
-- For example: mkAppTys Rational []
-- returns to (Ratio Integer), which has needlessly lost
-- the Rational part.
-mkAppTys orig_ty1 orig_tys2 = ASSERT2( isNotUsgTy orig_ty1, pprType orig_ty1 )
- mk_app orig_ty1
+mkAppTys orig_ty1 orig_tys2
+ = ASSERT2( isNotUsgTy orig_ty1, pprType orig_ty1 )
+ ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind *
+ mk_app orig_ty1
where
mk_app (NoteTy _ ty1) = mk_app ty1
mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
@@ -196,6 +206,7 @@ splitAppTy_maybe :: Type -> Maybe (Type, Type)
splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty
+splitAppTy_maybe (PredTy p) = splitAppTy_maybe (predRepTy p)
splitAppTy_maybe (TyConApp tc []) = Nothing
splitAppTy_maybe (TyConApp tc tys) = split tys []
where
@@ -214,6 +225,7 @@ splitAppTys ty = split ty ty []
where
split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
split orig_ty (NoteTy _ ty) args = split orig_ty ty args
+ split orig_ty (PredTy p) args = split orig_ty (predRepTy p) args
split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
(TyConApp funTyCon [], [ty1,ty2])
split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
@@ -235,20 +247,20 @@ mkFunTys tys ty = foldr FunTy ty tys
splitFunTy :: Type -> (Type, Type)
splitFunTy (FunTy arg res) = (arg, res)
splitFunTy (NoteTy _ ty) = splitFunTy ty
+splitFunTy (PredTy p) = splitFunTy (predRepTy p)
splitFunTy_maybe :: Type -> Maybe (Type, Type)
-splitFunTy_maybe (FunTy arg res) = Just (arg, res)
-splitFunTy_maybe (NoteTy (IPNote _) ty) = Nothing
-splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
-splitFunTy_maybe other = Nothing
+splitFunTy_maybe (FunTy arg res) = Just (arg, res)
+splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
+splitFunTy_maybe (PredTy p) = splitFunTy_maybe (predRepTy p)
+splitFunTy_maybe other = Nothing
splitFunTys :: Type -> ([Type], Type)
splitFunTys ty = split [] ty ty
where
split args orig_ty (FunTy arg res) = split (arg:args) res res
- split args orig_ty (NoteTy (IPNote _) ty)
- = (reverse args, orig_ty)
split args orig_ty (NoteTy _ ty) = split args orig_ty ty
+ split args orig_ty (PredTy p) = split args orig_ty (predRepTy p)
split args orig_ty ty = (reverse args, orig_ty)
splitFunTysN :: String -> Int -> Type -> ([Type], Type)
@@ -257,6 +269,7 @@ splitFunTysN msg orig_n orig_ty = split orig_n [] orig_ty orig_ty
split 0 args syn_ty ty = (reverse args, syn_ty)
split n args syn_ty (FunTy arg res) = split (n-1) (arg:args) res res
split n args syn_ty (NoteTy _ ty) = split n args syn_ty ty
+ split n args syn_ty (PredTy p) = split n args syn_ty (predRepTy p)
split n args syn_ty ty = pprPanic ("splitFunTysN: " ++ msg) (int orig_n <+> pprType orig_ty)
zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type)
@@ -265,16 +278,19 @@ zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty
split acc [] nty ty = (reverse acc, nty)
split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res
split acc xs nty (NoteTy _ ty) = split acc xs nty ty
+ split acc xs nty (PredTy p) = split acc xs nty (predRepTy p)
split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty)
funResultTy :: Type -> Type
funResultTy (FunTy arg res) = res
funResultTy (NoteTy _ ty) = funResultTy ty
+funResultTy (PredTy p) = funResultTy (predRepTy p)
funResultTy ty = pprPanic "funResultTy" (pprType ty)
funArgTy :: Type -> Type
funArgTy (FunTy arg res) = arg
funArgTy (NoteTy _ ty) = funArgTy ty
+funArgTy (PredTy p) = funArgTy (predRepTy p)
funArgTy ty = pprPanic "funArgTy" (pprType ty)
\end{code}
@@ -303,10 +319,11 @@ mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
-- including functions are returned as Just ..
splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
-splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
-splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
-splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
-splitTyConApp_maybe other = Nothing
+splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
+splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
+splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
+splitTyConApp_maybe (PredTy p) = splitTyConApp_maybe (predRepTy p)
+splitTyConApp_maybe other = Nothing
-- splitAlgTyConApp_maybe looks for
-- *saturated* applications of *algebraic* data types
@@ -317,9 +334,8 @@ splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
splitAlgTyConApp_maybe (TyConApp tc tys)
| isAlgTyCon tc &&
tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
-splitAlgTyConApp_maybe (NoteTy (IPNote _) ty)
- = Nothing
splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
+splitAlgTyConApp_maybe (PredTy p) = splitAlgTyConApp_maybe (predRepTy p)
splitAlgTyConApp_maybe other = Nothing
splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon])
@@ -327,53 +343,12 @@ splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon])
splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
(tc, tys, tyConDataCons tc)
splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty
+splitAlgTyConApp (PredTy p) = splitAlgTyConApp (predRepTy p)
#ifdef DEBUG
splitAlgTyConApp ty = pprPanic "splitAlgTyConApp" (pprType ty)
#endif
\end{code}
-"Dictionary" types are just ordinary data types, but you can
-tell from the type constructor whether it's a dictionary or not.
-
-\begin{code}
-mkDictTy :: Class -> [Type] -> Type
-mkDictTy clas tys = TyConApp (classTyCon clas) tys
-
-mkDictTys :: ClassContext -> [Type]
-mkDictTys cxt = [mkDictTy cls tys | (cls,tys) <- cxt]
-
-mkPredTy :: PredType -> Type
-mkPredTy (Class clas tys) = TyConApp (classTyCon clas) tys
-mkPredTy (IParam n ty) = NoteTy (IPNote n) ty
-
-splitPredTy_maybe :: Type -> Maybe PredType
-splitPredTy_maybe (TyConApp tc tys)
- | maybeToBool maybe_class
- && tyConArity tc == length tys = Just (Class clas tys)
- where
- maybe_class = tyConClass_maybe tc
- Just clas = maybe_class
-
-splitPredTy_maybe (NoteTy (IPNote n) ty)
- = Just (IParam n ty)
-splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty
-splitPredTy_maybe other = Nothing
-
-splitDictTy_maybe :: Type -> Maybe (Class, [Type])
-splitDictTy_maybe ty
- = case splitPredTy_maybe ty of
- Just p -> getClassTys_maybe p
- Nothing -> Nothing
-
-isDictTy :: Type -> Bool
- -- This version is slightly more efficient than (maybeToBool . splitDictTy)
-isDictTy (TyConApp tc tys)
- | maybeToBool (tyConClass_maybe tc)
- && tyConArity tc == length tys
- = True
-isDictTy (NoteTy _ ty) = isDictTy ty
-isDictTy other = False
-\end{code}
---------------------------------------------------------------------
SynTy
@@ -393,9 +368,10 @@ isSynTy (NoteTy (SynNote _) _) = True
isSynTy other = False
deNoteType :: Type -> Type
- -- Sorry for the cute name
+ -- Remove synonyms, but not Preds
deNoteType ty@(TyVarTy tyvar) = ty
deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
+deNoteType (PredTy p) = PredTy p
deNoteType (NoteTy _ ty) = deNoteType ty
deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg)
deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg)
@@ -424,6 +400,7 @@ repType looks through
(a) for-alls, and
(b) newtypes
(c) synonyms
+ (d) predicates
It's useful in the back end where we're not
interested in newtypes anymore.
@@ -431,6 +408,7 @@ interested in newtypes anymore.
repType :: Type -> Type
repType (ForAllTy _ ty) = repType ty
repType (NoteTy _ ty) = repType ty
+repType (PredTy p) = repType (predRepTy p)
repType ty = case splitNewType_maybe ty of
Just ty' -> repType ty' -- Still re-apply repType in case of for-all
Nothing -> ty
@@ -452,9 +430,8 @@ typePrimRep ty = case repType ty of
splitNewType_maybe :: Type -> Maybe Type
-- Find the representation of a newtype, if it is one
-- Looks through multiple levels of newtype, but does not look through for-alls
-splitNewType_maybe (NoteTy (IPNote _) ty)
- = Nothing
splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty
+splitNewType_maybe (PredTy p) = splitNewType_maybe (predRepTy p)
splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of
Just rep_ty -> ASSERT( length tys == tyConArity tc )
-- The assert should hold because repType should
@@ -550,23 +527,21 @@ splitUsForAllTys ty = split ty []
substUsTy :: VarEnv UsageAnn -> Type -> Type
-- assumes range is fresh uvars, so no conflicts
-substUsTy ve (NoteTy note@(UsgNote (UsVar u))
- ty ) = NoteTy (case lookupVarEnv ve u of
- Just ua -> UsgNote ua
- Nothing -> note)
- (substUsTy ve ty)
-substUsTy ve (NoteTy note@(UsgNote _) ty ) = NoteTy note (substUsTy ve ty)
-substUsTy ve (NoteTy note@(UsgForAll _) ty ) = NoteTy note (substUsTy ve ty)
-substUsTy ve (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote (substUsTy ve ty1))
- (substUsTy ve ty2)
-substUsTy ve (NoteTy note@(FTVNote _) ty ) = NoteTy note (substUsTy ve ty)
-substUsTy ve ty@(TyVarTy _ ) = ty
-substUsTy ve (AppTy ty1 ty2) = AppTy (substUsTy ve ty1)
- (substUsTy ve ty2)
-substUsTy ve (FunTy ty1 ty2) = FunTy (substUsTy ve ty1)
- (substUsTy ve ty2)
-substUsTy ve (TyConApp tyc tys) = TyConApp tyc (map (substUsTy ve) tys)
-substUsTy ve (ForAllTy yv ty ) = ForAllTy yv (substUsTy ve ty)
+substUsTy ve (NoteTy note@(UsgNote (UsVar u))
+ ty ) = NoteTy (case lookupVarEnv ve u of
+ Just ua -> UsgNote ua
+ Nothing -> note)
+ (substUsTy ve ty)
+substUsTy ve (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote (substUsTy ve ty1)) (substUsTy ve ty2)
+substUsTy ve (NoteTy note ty) = NoteTy note (substUsTy ve ty)
+
+substUsTy ve (PredTy (Class c tys)) = PredTy (Class c (map (substUsTy ve) tys))
+substUsTy ve (PredTy (IParam n ty)) = PredTy (IParam n (substUsTy ve ty))
+substUsTy ve (TyVarTy tv) = TyVarTy tv
+substUsTy ve (AppTy ty1 ty2) = AppTy (substUsTy ve ty1) (substUsTy ve ty2)
+substUsTy ve (FunTy ty1 ty2) = FunTy (substUsTy ve ty1) (substUsTy ve ty2)
+substUsTy ve (TyConApp tyc tys) = TyConApp tyc (map (substUsTy ve) tys)
+substUsTy ve (ForAllTy yv ty ) = ForAllTy yv (substUsTy ve ty)
\end{code}
@@ -596,8 +571,8 @@ splitForAllTy_maybe ty = case splitUsgTy_maybe ty of
return (tyvar, NoteTy (UsgNote usg) ty'')
Nothing -> splitFAT_m ty
where
- splitFAT_m (NoteTy (IPNote _) ty) = Nothing
splitFAT_m (NoteTy _ ty) = splitFAT_m ty
+ splitFAT_m (PredTy p) = splitFAT_m (predRepTy p)
splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
splitFAT_m _ = Nothing
@@ -608,8 +583,8 @@ splitForAllTys ty = case splitUsgTy_maybe ty of
Nothing -> split ty ty []
where
split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
- split orig_ty (NoteTy (IPNote _) ty) tvs = (reverse tvs, orig_ty)
split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
+ split orig_ty (PredTy p) tvs = split orig_ty (predRepTy p) tvs
split orig_ty t tvs = (reverse tvs, orig_ty)
\end{code}
@@ -621,6 +596,7 @@ Applying a for-all to its arguments
applyTy :: Type -> Type -> Type
applyTy (NoteTy note@(UsgNote _) fun) arg = NoteTy note (applyTy fun arg)
applyTy (NoteTy note@(UsgForAll _) fun) arg = NoteTy note (applyTy fun arg)
+applyTy (PredTy p) arg = applyTy (predRepTy p) arg
applyTy (NoteTy _ fun) arg = applyTy fun arg
applyTy (ForAllTy tv ty) arg = ASSERT( isNotUsgTy arg )
substTy (mkTyVarSubst [tv] [arg]) ty
@@ -640,6 +616,7 @@ applyTys fun_ty arg_tys
args = case split fun_ty args of
(tvs, ty) -> (tvs, NoteTy note ty)
split (NoteTy _ fun_ty) args = split fun_ty args
+ split (PredTy p) args = split (predRepTy p) args
split (ForAllTy tv fun_ty) (arg:args) = ASSERT2( isNotUsgTy arg, vcat (map pprType arg_tys) $$
text "in application of" <+> pprType fun_ty)
case split fun_ty args of
@@ -677,27 +654,47 @@ ClassPred and ClassContext are used in class and instance declarations.
%* *
%************************************************************************
-\begin{code}
--- f :: (C a, ?x :: Int -> Int) => a -> Int
--- Here the "C a" and "?x :: Int -> Int" are Preds
-data PredType = Class Class [Type]
- | IParam Name Type
- deriving( Eq, Ord )
-
-type ThetaType = [PredType]
-type RhoType = Type
-type TauType = Type
-type SigmaType = Type
-\end{code}
-
-\begin{code}
-instance Outputable PredType where
- ppr = pprPred
-\end{code}
+"Dictionary" types are just ordinary data types, but you can
+tell from the type constructor whether it's a dictionary or not.
\begin{code}
mkClassPred clas tys = Class clas tys
+mkDictTy :: Class -> [Type] -> Type
+mkDictTy clas tys = mkPredTy (Class clas tys)
+
+mkDictTys :: ClassContext -> [Type]
+mkDictTys cxt = [mkDictTy cls tys | (cls,tys) <- cxt]
+
+mkPredTy :: PredType -> Type
+mkPredTy pred = PredTy pred
+
+predRepTy :: PredType -> Type
+-- Convert a predicate to its "representation type";
+-- the type of evidence for that predicate, which is actually passed at runtime
+predRepTy (Class clas tys) = TyConApp (classTyCon clas) tys
+predRepTy (IParam n ty) = ty
+
+isPredTy :: Type -> Bool
+isPredTy (NoteTy _ ty) = isPredTy ty
+isPredTy (PredTy _) = True
+isPredTy _ = False
+
+isDictTy :: Type -> Bool
+isDictTy (NoteTy _ ty) = isDictTy ty
+isDictTy (PredTy (Class _ _)) = True
+isDictTy other = False
+
+splitPredTy_maybe :: Type -> Maybe PredType
+splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty
+splitPredTy_maybe (PredTy p) = Just p
+splitPredTy_maybe other = Nothing
+
+splitDictTy_maybe :: Type -> Maybe (Class, [Type])
+splitDictTy_maybe ty = case splitPredTy_maybe ty of
+ Just p -> getClassTys_maybe p
+ Nothing -> Nothing
+
getClassTys_maybe :: PredType -> Maybe ClassPred
getClassTys_maybe (Class clas tys) = Just (clas, tys)
getClassTys_maybe _ = Nothing
@@ -706,6 +703,7 @@ ipName_maybe :: PredType -> Maybe Name
ipName_maybe (IParam n _) = Just n
ipName_maybe _ = Nothing
+classesToPreds :: ClassContext -> ThetaType
classesToPreds cts = map (uncurry Class) cts
classesOfPreds :: ThetaType -> ClassContext
@@ -716,13 +714,13 @@ classesOfPreds theta = [(clas,tys) | Class clas tys <- theta]
\begin{code}
isTauTy :: Type -> Bool
-isTauTy (TyVarTy v) = True
-isTauTy (TyConApp _ tys) = all isTauTy tys
-isTauTy (AppTy a b) = isTauTy a && isTauTy b
-isTauTy (FunTy a b) = isTauTy a && isTauTy b
-isTauTy (NoteTy (IPNote _) ty) = False
-isTauTy (NoteTy _ ty) = isTauTy ty
-isTauTy other = False
+isTauTy (TyVarTy v) = True
+isTauTy (TyConApp _ tys) = all isTauTy tys
+isTauTy (AppTy a b) = isTauTy a && isTauTy b
+isTauTy (FunTy a b) = isTauTy a && isTauTy b
+isTauTy (PredTy p) = isTauTy (predRepTy p)
+isTauTy (NoteTy _ ty) = isTauTy ty
+isTauTy other = False
\end{code}
\begin{code}
@@ -733,27 +731,23 @@ splitRhoTy :: Type -> ([PredType], Type)
splitRhoTy ty = split ty ty []
where
split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of
- Just p -> split res res (p:ts)
- Nothing -> (reverse ts, orig_ty)
- split orig_ty (NoteTy (IPNote _) ty) ts = (reverse ts, orig_ty)
- split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
- split orig_ty ty ts = (reverse ts, orig_ty)
+ Just p -> split res res (p:ts)
+ Nothing -> (reverse ts, orig_ty)
+ split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
+ split orig_ty ty ts = (reverse ts, orig_ty)
\end{code}
-
+isSigmaType returns true of any qualified type. It doesn't *necessarily* have
+any foralls. E.g.
+ f :: (?x::Int) => Int -> Int
\begin{code}
mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
isSigmaTy :: Type -> Bool
+isSigmaTy (ForAllTy tyvar ty) = True
isSigmaTy (FunTy a b) = isPredTy a
- where isPredTy (NoteTy (IPNote _) _) = True
- -- JRL could be a dict ty, but that would be polymorphic,
- -- and thus there would have been an outer ForAllTy
- isPredTy _ = False
-isSigmaTy (NoteTy (IPNote _) _) = False
isSigmaTy (NoteTy _ ty) = isSigmaTy ty
-isSigmaTy (ForAllTy tyvar ty) = True
isSigmaTy _ = False
splitSigmaTy :: Type -> ([TyVar], [PredType], Type)
@@ -773,6 +767,7 @@ getDFunTyKey (AppTy fun _) = getDFunTyKey fun
getDFunTyKey (NoteTy _ t) = getDFunTyKey t
getDFunTyKey (FunTy arg _) = getOccName funTyCon
getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
+-- PredTy shouldn't happen
\end{code}
@@ -791,6 +786,8 @@ typeKind :: Type -> Kind
typeKind (TyVarTy tyvar) = tyVarKind tyvar
typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys
typeKind (NoteTy _ ty) = typeKind ty
+typeKind (PredTy _) = boxedTypeKind -- Predicates are always
+ -- represented by boxed types
typeKind (AppTy fun arg) = funResultTy (typeKind fun)
typeKind (FunTy arg res) = fix_up (typeKind res)
@@ -822,7 +819,7 @@ tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs
tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1
tyVarsOfType (NoteTy (UsgNote _) ty) = tyVarsOfType ty
tyVarsOfType (NoteTy (UsgForAll _) ty) = tyVarsOfType ty
-tyVarsOfType (NoteTy (IPNote _) ty) = tyVarsOfType ty
+tyVarsOfType (PredTy p) = tyVarsOfPred p
tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar
@@ -852,6 +849,7 @@ namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets`
namesOfTypes tys
namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1
namesOfType (NoteTy other_note ty2) = namesOfType ty2
+namesOfType (PredTy p) = namesOfType (predRepTy p)
namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res
namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
@@ -905,6 +903,7 @@ tidyType env@(tidy_env, subst) ty
go (TyConApp tycon tys) = let args = map go tys
in args `seqList` TyConApp tycon args
go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
+ go (PredTy p) = PredTy (go_pred p)
go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty)
@@ -915,9 +914,11 @@ tidyType env@(tidy_env, subst) ty
go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
go_note note@(UsgNote _) = note -- Usage annotation is already tidy
go_note note@(UsgForAll _) = note -- Uvar binder is already tidy
- go_note (IPNote n) = IPNote (tidyIPName n)
-tidyTypes env tys = map (tidyType env) tys
+ go_pred (Class c tys) = Class c (tidyTypes env tys)
+ go_pred (IParam n ty) = IParam n (go ty)
+
+tidyTypes env tys = map (tidyType env) tys
\end{code}
@@ -939,11 +940,6 @@ tidyTopType :: Type -> Type
tidyTopType ty = tidyType emptyTidyEnv ty
\end{code}
-\begin{code}
-tidyIPName :: Name -> Name
-tidyIPName name
- = mkLocalName (getUnique name) (getOccName name) noSrcLoc
-\end{code}
%************************************************************************
@@ -1007,6 +1003,7 @@ seqType (TyVarTy tv) = tv `seq` ()
seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
seqType (NoteTy note t2) = seqNote note `seq` seqType t2
+seqType (PredTy p) = seqPred p
seqType (TyConApp tc tys) = tc `seq` seqTypes tys
seqType (ForAllTy tv ty) = tv `seq` seqType ty
@@ -1018,5 +1015,86 @@ seqNote :: TyNote -> ()
seqNote (SynNote ty) = seqType ty
seqNote (FTVNote set) = sizeUniqSet set `seq` ()
seqNote (UsgNote usg) = usg `seq` ()
-seqNote (IPNote nm) = nm `seq` ()
+
+seqPred :: PredType -> ()
+seqPred (Class c tys) = c `seq` seqTypes tys
+seqPred (IParam n ty) = n `seq` seqType ty
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Equality on types}
+%* *
+%************************************************************************
+
+
+For the moment at least, type comparisons don't work if
+there are embedded for-alls.
+
+\begin{code}
+instance Eq Type where
+ ty1 == ty2 = case ty1 `compare` ty2 of { EQ -> True; other -> False }
+
+instance Ord Type where
+ compare ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
+
+cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
+ -- The "env" maps type variables in ty1 to type variables in ty2
+ -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
+ -- we in effect substitute tv2 for tv1 in t1 before continuing
+
+ -- Get rid of NoteTy
+cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
+cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
+
+ -- Get rid of PredTy
+cmpTy env (PredTy p1) (PredTy p2) = cmpPred env p1 p2
+cmpTy env (PredTy p1) ty2 = cmpTy env (predRepTy p1) ty2
+cmpTy env ty1 (PredTy p2) = cmpTy env ty1 (predRepTy p2)
+
+ -- Deal with equal constructors
+cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
+ Just tv1a -> tv1a `compare` tv2
+ Nothing -> tv1 `compare` tv2
+
+cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
+cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
+cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
+cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2
+
+ -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
+cmpTy env (AppTy _ _) (TyVarTy _) = GT
+
+cmpTy env (FunTy _ _) (TyVarTy _) = GT
+cmpTy env (FunTy _ _) (AppTy _ _) = GT
+
+cmpTy env (TyConApp _ _) (TyVarTy _) = GT
+cmpTy env (TyConApp _ _) (AppTy _ _) = GT
+cmpTy env (TyConApp _ _) (FunTy _ _) = GT
+
+cmpTy env (ForAllTy _ _) other = GT
+
+cmpTy env _ _ = LT
+
+
+cmpTys env [] [] = EQ
+cmpTys env (t:ts) [] = GT
+cmpTys env [] (t:ts) = LT
+cmpTys env (t1:t1s) (t2:t2s) = cmpTy env t1 t2 `thenCmp` cmpTys env t1s t2s
+\end{code}
+
+\begin{code}
+instance Eq PredType where
+ p1 == p2 = case p1 `compare` p2 of { EQ -> True; other -> False }
+
+instance Ord PredType where
+ compare p1 p2 = cmpPred emptyVarEnv p1 p2
+
+cmpPred :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
+cmpPred env (IParam n1 t) (IParam n2 t2) = n1 `compare` n2
+ -- Just compare the names!
+cmpPred env (Class c1 tys1) (Class c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
+cmpPred env (IParam _ _) (Class _ _) = LT
+cmpPred env (Class _ _) (IParam _ _) = GT
\end{code}
diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs
index 26e507839403..193f8fc974cf 100644
--- a/ghc/compiler/types/TypeRep.lhs
+++ b/ghc/compiler/types/TypeRep.lhs
@@ -5,8 +5,10 @@
\begin{code}
module TypeRep (
- Type(..), TyNote(..), UsageAnn(..), -- Representation visible to friends
- Kind, TyVarSubst,
+ Type(..), TyNote(..), PredType(..), UsageAnn(..), -- Representation visible to friends
+
+ Kind, ThetaType, RhoType, TauType, SigmaType, -- Synonyms
+ TyVarSubst,
superKind, superBoxity, -- KX and BX respectively
boxedBoxity, unboxedBoxity, -- :: BX
@@ -31,12 +33,13 @@ import Name ( Name, Provenance(..), ExportFlag(..),
import TyCon ( TyCon, KindCon,
mkFunTyCon, mkKindCon, mkSuperKindCon,
)
+import Class ( Class )
-- others
import SrcLoc ( mkBuiltinSrcLoc )
-import PrelNames ( pREL_GHC )
-import Unique -- quite a few *Keys
-import Util ( thenCmp )
+import PrelNames ( pREL_GHC, kindConKey, boxityConKey, boxedConKey, unboxedConKey,
+ typeConKey, anyBoxConKey, funTyConKey
+ )
\end{code}
%************************************************************************
@@ -107,36 +110,73 @@ data Type
Type -- Function is *not* a TyConApp
Type
- | TyConApp -- Application of a TyCon
- TyCon -- *Invariant* saturated appliations of FunTyCon and
- -- synonyms have their own constructors, below.
+ | TyConApp -- Application of a TyCon
+ TyCon -- *Invariant* saturated appliations of FunTyCon and
+ -- synonyms have their own constructors, below.
[Type] -- Might not be saturated.
- | FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2]
+ | FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2]
Type
Type
- | NoteTy -- Saturated application of a type synonym
+ | ForAllTy -- A polymorphic type
+ TyVar
+ Type
+
+ | PredTy -- A Haskell predicate
+ PredType
+
+ | NoteTy -- A type with a note attached
TyNote
Type -- The expanded version
- | ForAllTy
- TyVar
- Type -- TypeKind
-
data TyNote
= SynNote Type -- The unexpanded version of the type synonym; always a TyConApp
| FTVNote TyVarSet -- The free type variables of the noted expression
| UsgNote UsageAnn -- The usage annotation at this node
| UsgForAll UVar -- Annotation variable binder
- | IPNote Name -- It's an implicit parameter
data UsageAnn
= UsOnce -- Used at most once
| UsMany -- Used possibly many times (no info; this annotation can be omitted)
| UsVar UVar -- Annotation is variable (unbound OK only inside analysis)
+
+
+type ThetaType = [PredType]
+type RhoType = Type
+type TauType = Type
+type SigmaType = Type
+\end{code}
+
+
+-------------------------------------
+ Predicates
+
+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*
+Predicates are represented inside GHC by PredType:
+
+\begin{code}
+data PredType = Class Class [Type]
+ | IParam Name Type
\end{code}
+(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
+ * with a PredTy as the function argument
+
+The predicate really does turn into a real extra argument to the
+function. If the argument has type (PredTy p) then the predicate p is
+represented by evidence (a dictionary, for example, of type (predRepTy p).
+
%************************************************************************
%* *
@@ -262,61 +302,3 @@ funTyCon = mkFunTyCon funTyConName (mkArrowKinds [boxedTypeKind, boxedTypeKind]
\end{code}
-%************************************************************************
-%* *
-\subsection{Equality on types}
-%* *
-%************************************************************************
-
-For the moment at least, type comparisons don't work if
-there are embedded for-alls.
-
-\begin{code}
-instance Eq Type where
- ty1 == ty2 = case ty1 `cmpTy` ty2 of { EQ -> True; other -> False }
-
-instance Ord Type where
- compare ty1 ty2 = cmpTy ty1 ty2
-
-cmpTy :: Type -> Type -> Ordering
-cmpTy ty1 ty2
- = cmp emptyVarEnv ty1 ty2
- where
- -- The "env" maps type variables in ty1 to type variables in ty2
- -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
- -- we in effect substitute tv2 for tv1 in t1 before continuing
- lookup env tv1 = case lookupVarEnv env tv1 of
- Just tv2 -> tv2
- Nothing -> tv1
-
- -- Get rid of NoteTy
- cmp env (NoteTy _ ty1) ty2 = cmp env ty1 ty2
- cmp env ty1 (NoteTy _ ty2) = cmp env ty1 ty2
-
- -- Deal with equal constructors
- cmp env (TyVarTy tv1) (TyVarTy tv2) = lookup env tv1 `compare` tv2
- cmp env (AppTy f1 a1) (AppTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
- cmp env (FunTy f1 a1) (FunTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
- cmp env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmps env tys1 tys2)
- cmp env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmp (extendVarEnv env tv1 tv2) t1 t2
-
- -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
- cmp env (AppTy _ _) (TyVarTy _) = GT
-
- cmp env (FunTy _ _) (TyVarTy _) = GT
- cmp env (FunTy _ _) (AppTy _ _) = GT
-
- cmp env (TyConApp _ _) (TyVarTy _) = GT
- cmp env (TyConApp _ _) (AppTy _ _) = GT
- cmp env (TyConApp _ _) (FunTy _ _) = GT
-
- cmp env (ForAllTy _ _) other = GT
-
- cmp env _ _ = LT
-
- cmps env [] [] = EQ
- cmps env (t:ts) [] = GT
- cmps env [] (t:ts) = LT
- cmps env (t1:t1s) (t2:t2s) = cmp env t1 t2 `thenCmp` cmps env t1s t2s
-\end{code}
-
diff --git a/ghc/compiler/usageSP/UsageSPUtils.lhs b/ghc/compiler/usageSP/UsageSPUtils.lhs
index 96cd0028fb69..cd3a9566f5dd 100644
--- a/ghc/compiler/usageSP/UsageSPUtils.lhs
+++ b/ghc/compiler/usageSP/UsageSPUtils.lhs
@@ -459,8 +459,7 @@ unannotTy (NoteTy (UsgForAll uv) ty) = unannotTy ty
unannotTy (NoteTy (UsgNote _ ) ty) = unannotTy ty
unannotTy (NoteTy (SynNote sty) ty) = NoteTy (SynNote (unannotTy sty)) (unannotTy ty)
unannotTy (NoteTy note@(FTVNote _ ) ty) = NoteTy note (unannotTy ty)
--- IP notes need to be preserved
-unannotTy ty@(NoteTy (IPNote _) _) = ty
+unannotTy ty@(PredTy _) = ty -- PredTys need to be preserved
unannotTy ty@(TyVarTy _) = ty
unannotTy (AppTy ty1 ty2) = AppTy (unannotTy ty1) (unannotTy ty2)
unannotTy (TyConApp tc tys) = TyConApp tc (map unannotTy tys)
--
GitLab