diff --git a/ghc/compiler/DEPEND-NOTES b/ghc/compiler/DEPEND-NOTES
index c67fa9761196f3f4626628358e77a7cbb7dddf92..8efc3694e6bd5b68127b19a81bf9344d49e571b2 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 87b49efda8a41ca420b833bc3a3a777fb7631604..13effb93cfe49673146b8e010758332c10138d6e 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 d066626d8f8218cdd7bb08bf987a5aac8ad630fe..bc3ded6b0a19b9098dbc7ece584d07546a1a475c 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 1282995229f5750cb6d6cccc9c39e048bf626c8d..3d13ce54465fee964d18dd9b121a3dfc83058499 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 7f7f20ac77546d145ac88c2bc9b4df966530acf9..42db228ab8355896592bbc3e3dbb24c6b161d31e 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 94c40da6dcab448916674c039e4ea2a406f3926c..7564892588ac4304ef5996be5be26930143ab678 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 c9c978158b6855c25101aabb8b46674182783953..a86a832d106244747a71760d29b4352ba7c4e102 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 b10a0fa1772dd4b57f19d42b4abd38a6b74aef19..51a22bae19dfc0af377e008354b4e488a02eafcc 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 6e2efa07885d70a15a91c22379a3e99e3910c602..da86ba8e14695158205efbadcd0db52ffbbf6aac 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 7959282d7497a337bcd52b6c5f42c152bfaf618f..3497cf215a44109e5c5b1e8e13a4825973c1edc7 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 31e4428871819641bb8fbb749c096faac64d702d..b14e264d4005231425a57a4204085ef9a0fa54f6 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 9931da8ca271cff3b13dde263259f2859eb8a446..a7cec0cc11a61dfbdfaddb3b11944b5141d86ba3 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 28a739c37658f38256db06ce40cc66ae3acfaa6c..7446c22720957bf412428678add46c44b3313e60 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 2d72e038b803574300a78998d5d6f8ae7cb83aed..894a6321ab96f08eb2c6767896373e54ce002364 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 86a14675f7702fbd882db08b5c6af36167b714bb..06ba30d5f99253f87147dcdfd7818707324d3f15 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 eaaf83d41e6fc22c9e0e0a66e798ff6436c6094a..006456cff249d894dbfee596e6911579843b5c94 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 cfe7a82b7c9be50e15e16270e1bfae2c966498f2..728cb90d20c00d885a18451e8ef12cd171962d53 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 073bfae1f90ee41ac07d8c4a85f0d60ff60f41d9..b72f143138c54a1b7379cbf65efd5ebdfdc2f906 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 2b6ccf98aca02971aede945d130b67818cf767d9..d13ee7f9b600cdf95813f264886f0a5f2f2342f7 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 918b8c3e34ce7575d7a1f2a8e70ad334e83883bd..45a1620afc1b1e2d1566f133f87f7b04c183b2a3 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 d9b7e9d7766ef2cfe6f6b33a06bfce401b7329bc..dcad4321909fcddf9c30a66376f2ef0ca515f65c 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 1ffe1f78baf4579c85bee100a5eb17d5f8c66103..dcb715375b86a78096aa7eaf74d516caef9fda5e 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 5a8361058223d12d0201a442889cf12c5be8bd2d..6e71a32bb9093fd342e19985ff5e46be1498469d 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 5988b32c5195e6530d49c578a023ced3cd0adcbb..c0e9ad51129b652bd2649debd2d27e0f33e2d6d1 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 15ad4fd94b84f83e1b0ef11fae6311a54142a687..86a4f255bc5e588e38ec706f190d6408ca14d25b 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 afe7ac0993db47ee4e8f753a368ae520e7647e9d..2d48bd12b26f418150c64480a29c281d93af32d6 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 e4995fe6f643538dd9fe7dc9181eba18cd74c7fe..d69f4b47a550bf9b3b9b133fb1d20cb08fab5213 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 93f43261f783ff301a295384ae2de1fb40a9d392..eea1f86f0dcf5eb66f68a4383f6119cf4bed98ea 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 aaed7c2221a0bd0fbdd81e8a3878d877f785ee7d..0d58fb5242e28105597a0dcb975e2566af579fc1 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 8ffabd0bf9b6936701aa6c750b91762d3df2031b..4d21acebb185d2d30aac9dff3d04f38f326b99f9 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 da6a5bef681a61173da5017b164a6c43a9b1cf2f..802620b79b6763437a8a0ad8be3021aa2f1c4f84 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 62f68c17131c21b42307b5a807b28ae3197b9ca2..65da5c58ec5f3e3057ab1415ce43a9ef4d2197db 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 baf3b54dd625f6f6da15a6a63b04a5b08e8dad3b..5db09d1f70596ad4aad2236e5ab9da5ce9387c22 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 382984fc8d02218452357949441b90397c7ad8c5..03f4fce6eb4f0f3cc66e120563fc53c4fc3d5834 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 621649c3f4cf8cdcdc3442794524e63561701ec4..51f8de5dec4d4be5f32d485784df8dc1b91f8655 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 3ffa6c9dbfcd4f9ff0c4e5bf9c4f26d2a9dc1779..9a44d8d8713e4ca2882d11be6a72450793150b02 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 23b336ae881c8e14f58e60b18f427876def13998..a16fb0ffe1dfd941ca18b089560ec8857d4af85d 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 6ef01c048cfb91fa37a536bbaa0b1bfd9aec8a34..8e9a9ee1cc074bf098250eb8aa7564db71e5b620 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 509bea6f6cc10d11f4816f3b2fdd03ac286d0b9c..02585beba84c89b9874d5041c6f005b718748728 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 a9aa01ef41b5048ccded3c3f8cb6bd76efc911c0..e431580a112ab014e43b8124aac51374cb82f83f 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 00ff1e872010de91294b2e5aaeee1195ea72f8a6..7b7b55a6730f418f03f21fed258c72d3c7b1336e 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 ada8cefba8f1ab43765a3c66d38d9edef964fc75..9692a9a7560bfe3f09c7ab03957fe4399590018d 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 9c3e3bf56570a488f47451e900ca3cee5d4044b4..1b8d996e0eafae5bba1b4dd822598d27f4e08635 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 26e507839403b096c9f9b110e3cdbc91f8c5cba6..193f8fc974cff08624c0a929b9f6e1e7fea742da 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 96cd0028fb69f55abc4c12fd7ed2772bc4ec3bde..cd3a9566f5ddd43d493c8bd59b72d94843194804 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)