From f714e6b642fd614a9971717045ae47c3d871275e Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 30 Dec 2003 16:29:27 +0000 Subject: [PATCH] [project @ 2003-12-30 16:29:17 by simonpj] ---------------------------- Re-do kind inference (again) ---------------------------- [WARNING: interface file binary representation has (as usual) changed slightly; recompile your libraries!] Inspired by the lambda-cube, for some time GHC has used type Kind = Type That is, kinds were represented by the same data type as types. But GHC also supports unboxed types and unboxed tuples, and these complicate the kind system by requiring a sub-kind relationship. Notably, an unboxed tuple is acceptable as the *result* of a function but not as an *argument*. So we have the following setup: ? / \ / \ ?? (#) / \ * # where * [LiftedTypeKind] means a lifted type # [UnliftedTypeKind] means an unlifted type (#) [UbxTupleKind] means unboxed tuple ?? [ArgTypeKind] is the lub of *,# ? [OpenTypeKind] means any type at all In particular: error :: forall a:?. String -> a (->) :: ?? -> ? -> * (\(x::t) -> ...) Here t::?? (i.e. not unboxed tuple) All this has beome rather difficult to accommodate with Kind=Type, so this commit splits the two. * Kind is a distinct type, defined in types/Kind.lhs * IfaceType.IfaceKind disappears: we just re-use Kind.Kind * TcUnify.unifyKind is a distinct unifier for kinds * TyCon no longer needs KindCon and SuperKindCon variants * TcUnify.zapExpectedType takes an expected Kind now, so that in TcPat.tcMonoPatBndr we can express that the bound variable must have an argTypeKind (??). The big change is really that kind inference is much more systematic and well behaved. In particular, a kind variable can unify only with a "simple kind", which is built from * and (->). This deals neatly with awkward questions about how we can combine sub-kinding with type inference. Lots of small consequential changes, especially to the kind-checking plumbing in TcTyClsDecls. (We played a bit fast and loose before, and now we have to be more honest, in particular about how kind inference works for type synonyms. They can have kinds like (* -> #), so This cures two long-standing SourceForge bugs * 753777 (tcfail115.hs), which used erroneously to pass, but crashed in the code generator type T a = Int -> (# Int, Int #) f :: T a -> T a f t = \x -> case t x of r -> r * 753780 (tc167.hs), which used erroneously to fail f :: (->) Int# Int# Still, the result is not entirely satisfactory. In particular * The error message from tcfail115 is pretty obscure * SourceForge bug 807249 (Instance match failure on openTypeKind) is not fixed. Alas. --- ghc/compiler/basicTypes/Id.lhs | 15 +- ghc/compiler/basicTypes/MkId.lhs | 9 +- ghc/compiler/basicTypes/Name.lhs | 12 +- ghc/compiler/basicTypes/RdrName.lhs | 12 +- ghc/compiler/basicTypes/Var.lhs | 265 ++++++++++++-------------- ghc/compiler/compMan/CompManager.lhs | 2 +- ghc/compiler/coreSyn/CoreLint.lhs | 8 +- ghc/compiler/coreSyn/MkExternalCore.lhs | 15 +- ghc/compiler/deSugar/Check.lhs | 2 +- ghc/compiler/deSugar/Desugar.lhs | 1 - ghc/compiler/deSugar/DsGRHSs.lhs | 2 +- ghc/compiler/deSugar/DsListComp.lhs | 4 +- ghc/compiler/hsSyn/HsSyn.lhs | 3 +- ghc/compiler/hsSyn/HsTypes.lhs | 9 +- ghc/compiler/iface/BinIface.hs | 28 +-- ghc/compiler/iface/IfaceEnv.lhs | 2 +- ghc/compiler/iface/IfaceType.lhs | 47 +---- ghc/compiler/iface/TcIface.lhs | 11 +- ghc/compiler/nativeGen/MachCode.lhs | 4 +- ghc/compiler/ndpFlatten/FlattenMonad.hs | 8 +- ghc/compiler/ndpFlatten/Flattening.hs | 62 +++--- ghc/compiler/parser/ParserCore.y | 14 +- ghc/compiler/parser/RdrHsSyn.lhs | 7 +- ghc/compiler/prelude/TysWiredIn.lhs | 4 +- ghc/compiler/rename/RnNames.lhs | 4 +- ghc/compiler/rename/RnTypes.lhs | 9 +- ghc/compiler/simplCore/SimplCore.lhs | 14 +- ghc/compiler/simplCore/SimplUtils.lhs | 5 +- ghc/compiler/stgSyn/CoreToStg.lhs | 4 +- ghc/compiler/stgSyn/StgSyn.lhs | 4 +- ghc/compiler/typecheck/Inst.lhs | 4 +- ghc/compiler/typecheck/TcBinds.lhs | 116 ++++-------- ghc/compiler/typecheck/TcClassDcl.lhs | 25 ++- ghc/compiler/typecheck/TcDeriv.lhs | 8 +- ghc/compiler/typecheck/TcEnv.lhs | 57 +++--- ghc/compiler/typecheck/TcExpr.lhs | 24 ++- ghc/compiler/typecheck/TcForeign.lhs | 4 +- ghc/compiler/typecheck/TcHsSyn.lhs | 15 +- ghc/compiler/typecheck/TcHsType.lhs | 151 ++++----------- ghc/compiler/typecheck/TcMType.lhs | 130 +++++++------ ghc/compiler/typecheck/TcMatches.lhs | 14 +- ghc/compiler/typecheck/TcPat.lhs | 25 ++- ghc/compiler/typecheck/TcRnDriver.lhs | 4 +- ghc/compiler/typecheck/TcRnMonad.lhs | 9 +- ghc/compiler/typecheck/TcRnTypes.lhs | 7 +- ghc/compiler/typecheck/TcSplice.lhs | 14 +- ghc/compiler/typecheck/TcTyClsDecls.lhs | 260 +++++++++++++++----------- ghc/compiler/typecheck/TcTyDecls.lhs | 39 ++-- ghc/compiler/typecheck/TcType.lhs | 56 +++--- ghc/compiler/typecheck/TcUnify.lhs | 311 ++++++++++++++++++++++--------- ghc/compiler/types/Kind.lhs | 201 ++++++++++++++++++++ ghc/compiler/types/TyCon.lhs | 59 ++---- ghc/compiler/types/Type.lhs | 81 ++------ ghc/compiler/types/TypeRep.lhs | 187 ++----------------- 54 files changed, 1174 insertions(+), 1213 deletions(-) create mode 100644 ghc/compiler/types/Kind.lhs diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 3d2b4f6..1a2cb50 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -8,10 +8,10 @@ module Id ( Id, DictId, -- Simple construction - mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo, + mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo, mkSysLocal, mkSysLocalUnencoded, mkUserLocal, mkVanillaGlobal, mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal, - mkWorkerId, + mkWorkerId, mkExportedLocalId, -- Taking an Id apart idName, idType, idUnique, idInfo, @@ -19,7 +19,7 @@ module Id ( recordSelectorFieldLabel, -- Modifying an Id - setIdName, setIdUnique, setIdType, setIdLocalExported, setGlobalIdDetails, + setIdName, setIdUnique, Id.setIdType, setIdLocalExported, setGlobalIdDetails, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, zapLamIdInfo, zapDemandIdInfo, @@ -83,12 +83,12 @@ import BasicTypes ( Arity ) import Var ( Id, DictId, isId, isExportedId, isSpecPragmaId, isLocalId, idName, idType, idUnique, idInfo, isGlobalId, - setIdName, setVarType, setIdUnique, setIdLocalExported, + setIdName, setIdType, setIdUnique, setIdLocalExported, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, globalIdDetails, setGlobalIdDetails ) -import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId ) +import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId, mkExportedLocalId ) import Type ( Type, typePrimRep, addFreeTyVars, seqType) import IdInfo @@ -146,6 +146,9 @@ mkLocalIdWithInfo name ty info = Var.mkLocalId name (addFreeTyVars ty) info mkSpecPragmaId :: Name -> Type -> Id mkSpecPragmaId name ty = Var.mkSpecPragmaId name (addFreeTyVars ty) vanillaIdInfo +mkExportedLocalId :: Name -> Type -> Id +mkExportedLocalId name ty = Var.mkExportedLocalId name (addFreeTyVars ty) vanillaIdInfo + mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id mkGlobalId details name ty info = Var.mkGlobalId details name (addFreeTyVars ty) info \end{code} @@ -209,7 +212,7 @@ mkTemplateLocal i ty = mkSysLocal FSLIT("tpl") (mkBuiltinUnique i) ty \begin{code} setIdType :: Id -> Type -> Id -- Add free tyvar info to the type -setIdType id ty = seqType ty `seq` setVarType id (addFreeTyVars ty) +setIdType id ty = seqType ty `seq` Var.setIdType id (addFreeTyVars ty) idPrimRep :: Id -> PrimRep idPrimRep id = typePrimRep (idType id) diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index b629f37..cbbe8ec 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -69,8 +69,8 @@ import DataCon ( DataCon, DataConIds(..), dataConSig, dataConStrictMarks, dataConExStricts, splitProductType ) -import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, mkLocalId, - mkTemplateLocals, mkTemplateLocalsNum, setIdLocalExported, +import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, + mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId, mkTemplateLocal, idName ) import IdInfo ( IdInfo, noCafIdInfo, setUnfoldingInfo, @@ -740,8 +740,7 @@ BUT make sure they are *exported* LocalIds (setIdLocalExported) so that they aren't discarded by the occurrence analyser. \begin{code} -mkDefaultMethodId dm_name ty - = setIdLocalExported (mkLocalId dm_name ty) +mkDefaultMethodId dm_name ty = mkExportedLocalId dm_name ty mkDictFunId :: Name -- Name to use for the dict fun; -> [TyVar] @@ -751,7 +750,7 @@ mkDictFunId :: Name -- Name to use for the dict fun; -> Id mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys - = setIdLocalExported (mkLocalId dfun_name dfun_ty) + = mkExportedLocalId dfun_name dfun_ty where dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index b98a491..2b55d01 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -11,8 +11,8 @@ module Name ( -- The Name type Name, -- Abstract mkInternalName, mkSystemName, - mkSystemNameEncoded, mkSystemTvNameEncoded, mkFCallName, - mkIPName, + mkSystemNameEncoded, mkSysTvName, + mkFCallName, mkIPName, mkExternalName, mkWiredInName, nameUnique, setNameUnique, @@ -212,10 +212,10 @@ mkSystemNameEncoded uniq fs = Name { n_uniq = uniq, n_sort = System, n_occ = mkSysOccFS varName fs, n_loc = noSrcLoc } -mkSystemTvNameEncoded :: Unique -> EncodedFS -> Name -mkSystemTvNameEncoded uniq fs = Name { n_uniq = uniq, n_sort = System, - n_occ = mkSysOccFS tvName fs, - n_loc = noSrcLoc } +mkSysTvName :: Unique -> EncodedFS -> Name +mkSysTvName uniq fs = Name { n_uniq = uniq, n_sort = System, + n_occ = mkSysOccFS tvName fs, + n_loc = noSrcLoc } mkFCallName :: Unique -> EncodedString -> Name -- The encoded string completely describes the ccall diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index 7557145..62132c3 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -38,20 +38,20 @@ module RdrName ( #include "HsVersions.h" -import OccName ( NameSpace, tcName, varName, - OccName, UserFS, EncodedFS, - mkSysOccFS, setOccNameSpace, - mkOccFS, mkVarOcc, occNameFlavour, +import OccName ( NameSpace, varName, + OccName, UserFS, + setOccNameSpace, + mkOccFS, occNameFlavour, isDataOcc, isTvOcc, isTcOcc, OccEnv, emptyOccEnv, extendOccEnvList, lookupOccEnv, elemOccEnv, plusOccEnv_C, extendOccEnv_C, foldOccEnv, occEnvElts ) -import Module ( ModuleName, mkSysModuleNameFS, mkModuleNameFS ) +import Module ( ModuleName, mkModuleNameFS ) import Name ( Name, NamedThing(getName), nameModuleName, nameParent_maybe, nameOccName, isExternalName, nameSrcLoc ) import Maybes ( seqMaybe ) -import SrcLoc ( SrcLoc, isGoodSrcLoc, SrcSpan ) +import SrcLoc ( isGoodSrcLoc, SrcSpan ) import BasicTypes( DeprecTxt ) import Outputable import Util ( thenCmp ) diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index d2c22f3..df030e2 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -5,49 +5,47 @@ \begin{code} module Var ( - Var, VarDetails, -- Abstract - varName, varUnique, varInfo, varType, - setVarName, setVarUnique, setVarType, setVarOcc, + Var, + varName, varUnique, + setVarName, setVarUnique, setVarOcc, -- TyVars - TyVar, + TyVar, mkTyVar, mkTcTyVar, tyVarName, tyVarKind, setTyVarName, setTyVarUnique, - mkTyVar, mkSysTyVar, - mkMutTyVar, mutTyVarRef, makeTyVarImmutable, + tcTyVarRef, tcTyVarDetails, -- Ids Id, DictId, idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo, - setIdName, setIdUnique, setIdInfo, lazySetIdInfo, + setIdName, setIdUnique, setIdType, setIdInfo, lazySetIdInfo, setIdLocalExported, zapSpecPragmaId, globalIdDetails, setGlobalIdDetails, - mkLocalId, mkGlobalId, mkSpecPragmaId, + mkLocalId, mkExportedLocalId, mkSpecPragmaId, + mkGlobalId, - isTyVar, isMutTyVar, mutTyVarDetails, - isId, isLocalVar, isLocalId, + isTyVar, isTcTyVar, isId, isLocalVar, isLocalId, isGlobalId, isExportedId, isSpecPragmaId, mustHaveLocalBinding ) where #include "HsVersions.h" -import {-# SOURCE #-} TypeRep( Type, Kind ) +import {-# SOURCE #-} TypeRep( Type ) import {-# SOURCE #-} TcType( TyVarDetails ) import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId, IdInfo, seqIdInfo ) import Name ( Name, OccName, NamedThing(..), - setNameUnique, setNameOcc, nameUnique, - mkSystemTvNameEncoded, + setNameUnique, setNameOcc, nameUnique ) +import Kind ( Kind ) import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey# ) import FastTypes import Outputable - -import DATA_IOREF ( IORef ) +import DATA_IOREF \end{code} @@ -65,34 +63,33 @@ in its @VarDetails@. \begin{code} data Var - = Var { + = TyVar { varName :: !Name, realUnique :: FastInt, -- Key for fast comparison -- Identical to the Unique in the name, -- cached here for speed - varType :: Type, - varDetails :: VarDetails, - varInfo :: IdInfo -- Only used for Ids at the moment - } - -data VarDetails - = LocalId -- Used for locally-defined Ids (see NOTE below) - LocalIdDetails - - | GlobalId -- Used for imported Ids, dict selectors etc - GlobalIdDetails - - | TyVar - | MutTyVar (IORef (Maybe Type)) -- Used during unification; - TyVarDetails - -- TODO: the IORef should be unboxed here, but we don't want to unbox - -- the Name above. - - -- For a long time I tried to keep mutable Vars statically - -- type-distinct from immutable Vars, but I've finally given - -- up. It's just too painful. After type checking there are - -- no MutTyVars left, but there's no static check of that - -- fact. + tyVarKind :: Kind } + + | TcTyVar { -- Used only during type inference + varName :: !Name, -- Could we get away without a Name? + realUnique :: FastInt, + tyVarKind :: Kind, + tcTyVarRef :: IORef (Maybe Type), + tcTyVarDetails :: TyVarDetails } + + | GlobalId { -- Used for imported Ids, dict selectors etc + varName :: !Name, + realUnique :: FastInt, + idType :: Type, + idInfo :: IdInfo, + gblDetails :: GlobalIdDetails } + + | LocalId { -- Used for locally-defined Ids (see NOTE below) + varName :: !Name, + realUnique :: FastInt, + idType :: Type, + idInfo :: IdInfo, + lclDetails :: LocalIdDetails } data LocalIdDetails = NotExported -- Not exported @@ -143,23 +140,21 @@ instance Ord Var where \begin{code} varUnique :: Var -> Unique -varUnique (Var {realUnique = uniq}) = mkUniqueGrimily (iBox uniq) +varUnique var = mkUniqueGrimily (iBox (realUnique var)) setVarUnique :: Var -> Unique -> Var -setVarUnique var@(Var {varName = name}) uniq - = var {realUnique = getKey# uniq, - varName = setNameUnique name uniq} +setVarUnique var uniq + = var { realUnique = getKey# uniq, + varName = setNameUnique (varName var) uniq } setVarName :: Var -> Name -> Var setVarName var new_name - = var { realUnique = getKey# (getUnique new_name), varName = new_name } + = var { realUnique = getKey# (getUnique new_name), + varName = new_name } setVarOcc :: Var -> OccName -> Var setVarOcc var new_occ = var { varName = setNameOcc (varName var) new_occ } - -setVarType :: Var -> Type -> Var -setVarType var ty = var {varType = ty} \end{code} @@ -171,11 +166,8 @@ setVarType var ty = var {varType = ty} \begin{code} type TyVar = Var -\end{code} -\begin{code} tyVarName = varName -tyVarKind = varType setTyVarUnique = setVarUnique setTyVarName = setVarName @@ -183,40 +175,19 @@ setTyVarName = setVarName \begin{code} mkTyVar :: Name -> Kind -> TyVar -mkTyVar name kind = Var { varName = name - , realUnique = getKey# (nameUnique name) - , varType = kind - , varDetails = TyVar - , varInfo = pprPanic "mkTyVar" (ppr name) +mkTyVar name kind = TyVar { varName = name + , realUnique = getKey# (nameUnique name) + , tyVarKind = kind } -mkSysTyVar :: Unique -> Kind -> TyVar -mkSysTyVar uniq kind = Var { varName = name - , realUnique = getKey# uniq - , varType = kind - , varDetails = TyVar - , varInfo = pprPanic "mkSysTyVar" (ppr name) - } - where - name = mkSystemTvNameEncoded uniq FSLIT("t") - -mkMutTyVar :: Name -> Kind -> TyVarDetails -> IORef (Maybe Type) -> TyVar -mkMutTyVar name kind details ref - = Var { varName = name - , realUnique = getKey# (nameUnique name) - , varType = kind - , varDetails = MutTyVar ref details - , varInfo = pprPanic "newMutTyVar" (ppr name) +mkTcTyVar :: Name -> Kind -> TyVarDetails -> IORef (Maybe Type) -> TyVar +mkTcTyVar name kind details ref + = TcTyVar { varName = name, + realUnique = getKey# (nameUnique name), + tyVarKind = kind, + tcTyVarRef = ref, + tcTyVarDetails = details } - -mutTyVarRef :: TyVar -> IORef (Maybe Type) -mutTyVarRef (Var {varDetails = MutTyVar loc _}) = loc - -makeTyVarImmutable :: TyVar -> TyVar -makeTyVarImmutable tyvar = tyvar { varDetails = TyVar} - -mutTyVarDetails :: TyVar -> TyVarDetails -mutTyVarDetails (Var {varDetails = MutTyVar _ details}) = details \end{code} @@ -235,9 +206,7 @@ type DictId = Id \begin{code} idName = varName -idType = varType idUnique = varUnique -idInfo = varInfo setIdUnique :: Id -> Unique -> Id setIdUnique = setVarUnique @@ -245,33 +214,41 @@ setIdUnique = setVarUnique setIdName :: Id -> Name -> Id setIdName = setVarName +setIdType :: Id -> Type -> Id +setIdType id ty = id {idType = ty} + setIdLocalExported :: Id -> Id -setIdLocalExported id = id { varDetails = LocalId Exported } +-- It had better be a LocalId already +setIdLocalExported id = id { lclDetails = Exported } + +setGlobalIdDetails :: Id -> GlobalIdDetails -> Id +-- It had better be a GlobalId already +setGlobalIdDetails id details = id { gblDetails = details } zapSpecPragmaId :: Id -> Id -zapSpecPragmaId id - = case varDetails id of - LocalId SpecPragma -> id { varDetails = LocalId NotExported } - other -> id +zapSpecPragmaId id + | isSpecPragmaId id = id {lclDetails = NotExported} + | otherwise = id lazySetIdInfo :: Id -> IdInfo -> Id -lazySetIdInfo var info = var {varInfo = info} +lazySetIdInfo id info = id {idInfo = info} setIdInfo :: Id -> IdInfo -> Id -setIdInfo var info = seqIdInfo info `seq` var {varInfo = info} +setIdInfo id info = seqIdInfo info `seq` id {idInfo = info} -- Try to avoid spack leaks by seq'ing modifyIdInfo :: (IdInfo -> IdInfo) -> Id -> Id -modifyIdInfo fn var@(Var {varInfo = info}) - = seqIdInfo new_info `seq` var {varInfo = new_info} +modifyIdInfo fn id + = seqIdInfo new_info `seq` id {idInfo = new_info} where - new_info = fn info + new_info = fn (idInfo id) -- maybeModifyIdInfo tries to avoid unnecesary thrashing maybeModifyIdInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id -maybeModifyIdInfo fn var@(Var {varInfo = info}) = case fn info of - Nothing -> var - Just new_info -> var {varInfo = new_info} +maybeModifyIdInfo fn id + = case fn (idInfo id) of + Nothing -> id + Just new_info -> id {idInfo = new_info} \end{code} %************************************************************************ @@ -281,56 +258,57 @@ maybeModifyIdInfo fn var@(Var {varInfo = info}) = case fn info of %************************************************************************ \begin{code} -mkId :: Name -> Type -> VarDetails -> IdInfo -> Id -mkId name ty details info - = Var { varName = name, - realUnique = getKey# (nameUnique name), -- Cache the unique - varType = ty, - varDetails = details, - varInfo = info } +mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalId details name ty info + = GlobalId { varName = name, + realUnique = getKey# (nameUnique name), -- Cache the unique + idType = ty, + gblDetails = details, + idInfo = info } + +mk_local_id :: Name -> Type -> LocalIdDetails -> IdInfo -> Id +mk_local_id name ty details info + = LocalId { varName = name, + realUnique = getKey# (nameUnique name), -- Cache the unique + idType = ty, + lclDetails = details, + idInfo = info } mkLocalId :: Name -> Type -> IdInfo -> Id -mkLocalId name ty info = mkId name ty (LocalId NotExported) info +mkLocalId name ty info = mk_local_id name ty NotExported info -mkSpecPragmaId :: Name -> Type -> IdInfo -> Id -mkSpecPragmaId name ty info = mkId name ty (LocalId SpecPragma) info +mkExportedLocalId :: Name -> Type -> IdInfo -> Id +mkExportedLocalId name ty info = mk_local_id name ty Exported info -mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id -mkGlobalId details name ty info = mkId name ty (GlobalId details) info +mkSpecPragmaId :: Name -> Type -> IdInfo -> Id +mkSpecPragmaId name ty info = mk_local_id name ty SpecPragma info \end{code} \begin{code} -isTyVar, isMutTyVar :: Var -> Bool +isTyVar, isTcTyVar :: Var -> Bool isId, isLocalVar, isLocalId :: Var -> Bool isGlobalId, isExportedId, isSpecPragmaId :: Var -> Bool mustHaveLocalBinding :: Var -> Bool -isTyVar var = case varDetails var of - TyVar -> True - MutTyVar _ _ -> True - other -> False +isTyVar (TyVar {}) = True +isTyVar (TcTyVar {}) = True +isTyVar other = False -isMutTyVar (Var {varDetails = MutTyVar _ _}) = True -isMutTyVar other = False +isTcTyVar (TcTyVar {}) = True +isTcTyVar other = False +isId (LocalId {}) = True +isId (GlobalId {}) = True +isId other = False -isId var = case varDetails var of - LocalId _ -> True - GlobalId _ -> True - other -> False - -isLocalId var = case varDetails var of - LocalId _ -> True - other -> False +isLocalId (LocalId {}) = True +isLocalId other = False -- isLocalVar returns True for type variables as well as local Ids -- These are the variables that we need to pay attention to when finding free -- variables, or doing dependency analysis. -isLocalVar var = case varDetails var of - LocalId _ -> True - TyVar -> True - MutTyVar _ _ -> True - other -> False +isLocalVar (GlobalId {}) = False +isLocalVar other = True -- mustHaveLocalBinding returns True of Ids and TyVars -- that must have a binding in this module. The converse @@ -339,29 +317,26 @@ isLocalVar var = case varDetails var of -- because it's only used for assertions mustHaveLocalBinding var = isLocalVar var -isGlobalId var = case varDetails var of - GlobalId _ -> True - other -> False +isGlobalId (GlobalId {}) = True +isGlobalId other = False -- isExportedId means "don't throw this away" -isExportedId var = case varDetails var of - LocalId Exported -> True - LocalId SpecPragma -> True - GlobalId _ -> True - other -> False - -isSpecPragmaId var = case varDetails var of - LocalId SpecPragma -> True - other -> False +isExportedId (GlobalId {}) = True +isExportedId (LocalId {lclDetails = details}) + = case details of + Exported -> True + SpecPragma -> True + other -> False +isExportedId other = False + +isSpecPragmaId (LocalId {lclDetails = SpecPragma}) = True +isSpecPragmaId other = False \end{code} \begin{code} globalIdDetails :: Var -> GlobalIdDetails -- Works OK on local Ids too, returning notGlobalId -globalIdDetails var = case varDetails var of - GlobalId details -> details - other -> notGlobalId -setGlobalIdDetails :: Id -> GlobalIdDetails -> Id -setGlobalIdDetails id details = id { varDetails = GlobalId details } +globalIdDetails (GlobalId {gblDetails = details}) = details +globalIdDetails other = notGlobalId \end{code} diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 221ba31..2917879 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -66,7 +66,6 @@ import Module ( Module, ModuleName, moduleName, mkModuleName, isHomeModule, extendModuleEnvList, extendModuleEnv, moduleNameUserString, ModLocation(..) ) -import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv ) import GetImports import UniqFM import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs ) @@ -85,6 +84,7 @@ import DATA_IOREF ( readIORef ) import HscMain ( hscThing, hscStmt, hscTcExpr ) import TcRnDriver ( mkExportEnv, getModuleContents ) import IfaceSyn ( IfaceDecl ) +import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv ) import Name ( Name ) import NameEnv import Id ( idType ) diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index ce57470..52b330c 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -32,7 +32,7 @@ import Type ( Type, tyVarsOfType, eqType, splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp, isUnLiftedType, typeKind, isUnboxedTupleType, - hasMoreBoxityInfo + isSubKind ) import TyCon ( isPrimTyCon ) import BasicTypes ( RecFlag(..), isNonRec ) @@ -333,7 +333,7 @@ lintTyApp ty arg_ty tyvar_kind = tyVarKind tyvar argty_kind = typeKind arg_ty in - if argty_kind `hasMoreBoxityInfo` tyvar_kind + if argty_kind `isSubKind` tyvar_kind -- Arg type might be boxed for a function with an uncommitted -- tyvar; notably this is used so that we can give -- error :: forall a:*. String -> a @@ -406,8 +406,8 @@ lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs) lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs) = addLoc (CaseAlt alt) ( - mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg))) - (mkUnboxedTupleMsg arg)) args `seqL` + mapL (\arg -> checkL (not (isId arg && isUnboxedTupleType (idType arg))) + (mkUnboxedTupleMsg arg)) args `seqL` addInScopeVars args ( diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs index 8ad5c7f..6b21f18 100644 --- a/ghc/compiler/coreSyn/MkExternalCore.lhs +++ b/ghc/compiler/coreSyn/MkExternalCore.lhs @@ -25,6 +25,7 @@ import CoreSyn import Var import IdInfo import Id ( idUnfolding ) +import Kind import CoreTidy ( tidyExpr ) import VarEnv ( emptyTidyEnv ) import Literal @@ -118,14 +119,14 @@ make_tbind :: TyVar -> C.Tbind make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv)) make_vbind :: Var -> C.Vbind -make_vbind v = (make_var_id (Var.varName v), make_ty (varType v)) +make_vbind v = (make_var_id (Var.varName v), make_ty (idType v)) make_vdef :: CoreBind -> C.Vdefg make_vdef b = case b of NonRec v e -> C.Nonrec (f (v,e)) Rec ves -> C.Rec (map f ves) - where f (v,e) = (make_var_id (Var.varName v), make_ty (varType v),make_exp e) + where f (v,e) = (make_var_id (Var.varName v), make_ty (idType v),make_exp e) -- Top level bindings are unqualified now make_exp :: CoreExpr -> C.Exp @@ -133,7 +134,7 @@ make_exp (Var v) = case globalIdDetails v of -- a DataConId represents the Id of a worker, which is a varName. -- sof 4/02 -- DataConId _ -> C.Dcon (make_con_qid (Var.varName v)) - FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (unpackFS nm) (make_ty (varType v)) + FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (unpackFS nm) (make_ty (idType v)) FCallId _ -> error "MkExternalCore died: can't handle non-static-C foreign call" _ -> C.Var (make_var_qid (Var.varName v)) make_exp (Lit (l@(MachLabel s _))) = error "MkExternalCore died: can't handle \"foreign label\" declarations" @@ -205,10 +206,10 @@ make_ty (NoteTy _ t) = make_ty t make_kind :: Kind -> C.Kind -make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2) -make_kind k | k `eqKind` liftedTypeKind = C.Klifted -make_kind k | k `eqKind` unliftedTypeKind = C.Kunlifted -make_kind k | k `eqKind` openTypeKind = C.Kopen +make_kind (FunKind k1 k2) = C.Karrow (make_kind k1) (make_kind k2) +make_kind LiftedTypeKind = C.Klifted +make_kind UnliftedTypeKind = C.Kunlifted +make_kind OpenTypeKind = C.Kopen make_kind _ = error "MkExternalCore died: make_kind" {- Id generation. -} diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index d1ae572..4885b13 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -23,7 +23,7 @@ import TysWiredIn import PrelNames ( unboundKey ) import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon ) import BasicTypes ( Boxity(..) ) -import SrcLoc ( noSrcLoc, Located(..), getLoc, unLoc, noLoc ) +import SrcLoc ( noSrcLoc, Located(..), unLoc, noLoc ) import UniqSet import Util ( takeList, splitAtList, notNull ) import Outputable diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 879058e..ac50a01 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -39,7 +39,6 @@ import CoreFVs ( ruleRhsFreeVars ) import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, mkWarnMsg, errorsFound, WarnMsg ) import Outputable -import qualified Pretty import UniqSupply ( mkSplitUniqSupply ) import SrcLoc ( Located(..), SrcSpan, unLoc ) import DATA_IOREF ( readIORef ) diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index 60c67bc..b366326 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -12,7 +12,7 @@ import {-# SOURCE #-} DsExpr ( dsLExpr, dsLet ) import {-# SOURCE #-} Match ( matchSinglePat ) import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..), - HsMatchContext(..), Pat(..), LStmt ) + HsMatchContext(..), Pat(..) ) import CoreSyn ( CoreExpr ) import Type ( Type ) import Var ( Id ) diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 41bb4d7..d6b0065 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -8,7 +8,7 @@ module DsListComp ( dsListComp, dsPArrComp ) where #include "HsVersions.h" -import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLet ) +import {-# SOURCE #-} DsExpr ( dsLExpr, dsLet ) import BasicTypes ( Boxity(..) ) import HsSyn @@ -31,7 +31,7 @@ import Match ( matchSimply ) import PrelNames ( foldrName, buildName, replicatePName, mapPName, filterPName, zipPName, crossPName ) import PrelInfo ( pAT_ERROR_ID ) -import SrcLoc ( noLoc, Located(..), unLoc ) +import SrcLoc ( noLoc, unLoc ) import Panic ( panic ) \end{code} diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 96379a5..ed04dff 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -39,9 +39,8 @@ import HsUtils -- others: import IfaceSyn ( IfaceBinding ) import Outputable -import SrcLoc ( Located(..), unLoc, noLoc ) +import SrcLoc ( Located(..) ) import Module ( Module ) -import Bag ( Bag, foldrBag ) \end{code} All we actually declare here is the top-level structure for a module. diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index c659297..9325d27 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -30,8 +30,9 @@ module HsTypes ( import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) -import TcType ( Type, Kind, liftedTypeKind, eqKind ) -import Type ( {- instance Outputable Kind -}, pprParendKind, pprKind ) +import Type ( Type ) +import Kind ( {- instance Outputable Kind -}, Kind, + pprParendKind, pprKind, isLiftedTypeKind ) import Name ( Name, mkInternalName ) import OccName ( mkVarOcc ) import BasicTypes ( IPName, Boxity, tupleParens ) @@ -262,8 +263,8 @@ instance OutputableBndr name => Outputable (HsPred name) where ppr (HsIParam n ty) = hsep [ppr n, dcolon, ppr ty] pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc -pprHsTyVarBndr name kind | kind `eqKind` liftedTypeKind = ppr name - | otherwise = hsep [ppr name, dcolon, pprParendKind kind] +pprHsTyVarBndr name kind | isLiftedTypeKind kind = ppr name + | otherwise = hsep [ppr name, dcolon, pprParendKind kind] pprHsForAll exp tvs cxt | show_forall = forall_part <+> pprHsContext (unLoc cxt) diff --git a/ghc/compiler/iface/BinIface.hs b/ghc/compiler/iface/BinIface.hs index 256033b..315f35e 100644 --- a/ghc/compiler/iface/BinIface.hs +++ b/ghc/compiler/iface/BinIface.hs @@ -18,9 +18,9 @@ import TyCon ( DataConDetails(..) ) import Class ( DefMeth(..) ) import CostCentre import Module ( moduleName, mkModule ) -import OccName ( OccName ) import DriverState ( v_Build_tag ) import CmdLineOpts ( opt_HiVersion ) +import Kind ( Kind(..) ) import Panic import Binary import Util @@ -570,23 +570,29 @@ instance Binary IfaceBndr where _ -> do ab <- get bh return (IfaceTvBndr ab) -instance Binary IfaceKind where - put_ bh IfaceLiftedTypeKind = putByte bh 0 - put_ bh IfaceUnliftedTypeKind = putByte bh 1 - put_ bh IfaceOpenTypeKind = putByte bh 2 - put_ bh (IfaceFunKind k1 k2) = do - putByte bh 3 +instance Binary Kind where + put_ bh LiftedTypeKind = putByte bh 0 + put_ bh UnliftedTypeKind = putByte bh 1 + put_ bh OpenTypeKind = putByte bh 2 + put_ bh ArgTypeKind = putByte bh 3 + put_ bh UbxTupleKind = putByte bh 4 + put_ bh (FunKind k1 k2) = do + putByte bh 5 put_ bh k1 put_ bh k2 + put_ bh (KindVar kv) = pprPanic "BinIface.put_: kind var" (ppr kv) + get bh = do h <- getByte bh case h of - 0 -> return IfaceLiftedTypeKind - 1 -> return IfaceUnliftedTypeKind - 2 -> return IfaceOpenTypeKind + 0 -> return LiftedTypeKind + 1 -> return UnliftedTypeKind + 2 -> return OpenTypeKind + 3 -> return ArgTypeKind + 4 -> return UbxTupleKind _ -> do k1 <- get bh k2 <- get bh - return (IfaceFunKind k1 k2) + return (FunKind k1 k2) instance Binary IfaceType where put_ bh (IfaceForAllTy aa ab) = do diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs index 8cfaf66..e987637 100644 --- a/ghc/compiler/iface/IfaceEnv.lhs +++ b/ghc/compiler/iface/IfaceEnv.lhs @@ -27,7 +27,7 @@ import TyCon ( TyCon, tyConName ) import Class ( Class ) import DataCon ( DataCon, dataConWorkId, dataConName ) import Var ( TyVar, Id, varName ) -import Name ( Name, nameUnique, nameModule, nameModuleName, +import Name ( Name, nameUnique, nameModule, nameOccName, nameSrcLoc, getOccName, nameParent_maybe, isWiredInName, nameIsLocalOrFrom, mkIPName, diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs index 47f0478..1c1412a 100644 --- a/ghc/compiler/iface/IfaceType.lhs +++ b/ghc/compiler/iface/IfaceType.lhs @@ -6,17 +6,16 @@ \begin{code} module IfaceType ( - IfaceType(..), IfaceKind(..), IfacePredType(..), IfaceTyCon(..), + IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..), IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceExtName(..), mkIfaceExtName, ifaceTyConName, -- Conversion from Type -> IfaceType - toIfaceType, toIfaceKind, toIfacePred, toIfaceContext, + toIfaceType, toIfacePred, toIfaceContext, toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, -- Printing - pprIfaceKind, pprParendIfaceKind, pprIfaceType, pprParendIfaceType, pprIfaceContext, pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceBndrs, getIfaceExt, @@ -26,8 +25,7 @@ module IfaceType ( #include "HsVersions.h" -import Type ( openTypeKind, liftedTypeKind, unliftedTypeKind, - splitFunTy_maybe, eqKind, pprType ) +import Kind ( Kind(..) ) import TypeRep ( Type(..), TyNote(..), PredType(..), Kind, ThetaType ) import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity ) import Var ( isId, tyVarKind, idType ) @@ -85,14 +83,8 @@ type IfaceIdBndr = (OccName, IfaceType) -- OccName, because always local type IfaceTvBndr = (OccName, IfaceKind) ------------------------------- -data IfaceKind - = IfaceLiftedTypeKind - | IfaceOpenTypeKind - | IfaceUnliftedTypeKind - | IfaceFunKind IfaceKind IfaceKind - deriving( Eq ) +type IfaceKind = Kind -- Re-use the Kind type, but no KindVars in it -------------------------------- data IfaceType = IfaceTyVar OccName -- Type variable only, not tycon | IfaceAppTy IfaceType IfaceType @@ -216,8 +208,8 @@ pprIfaceBndrs bs = sep (map ppr bs) pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty] pprIfaceTvBndr :: IfaceTvBndr -> SDoc -pprIfaceTvBndr (tv, IfaceLiftedTypeKind) = ppr tv -pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind) +pprIfaceTvBndr (tv, LiftedTypeKind) = ppr tv +pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind) pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc pprIfaceTvBndrs tyvars = hsep (map pprIfaceTvBndr tyvars) @@ -227,19 +219,6 @@ pprIfaceTvBndrs tyvars = hsep (map pprIfaceTvBndr tyvars) \begin{code} --------------------------------- -instance Outputable IfaceKind where - ppr k = pprIfaceKind tOP_PREC k - -pprParendIfaceKind :: IfaceKind -> SDoc -pprParendIfaceKind k = pprIfaceKind tYCON_PREC k - -pprIfaceKind prec IfaceLiftedTypeKind = ptext SLIT("*") -pprIfaceKind prec IfaceUnliftedTypeKind = ptext SLIT("#") -pprIfaceKind prec IfaceOpenTypeKind = ptext SLIT("?") -pprIfaceKind prec (IfaceFunKind k1 k2) = maybeParen prec fUN_PREC $ - sep [ pprIfaceKind fUN_PREC k1, arrow <+> ppr k2] - ---------------------------------- instance Outputable IfaceType where ppr ty = ppr_ty ty @@ -321,7 +300,7 @@ pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \begin{code} ---------------- -toIfaceTvBndr tyvar = (getOccName tyvar, toIfaceKind (tyVarKind tyvar)) +toIfaceTvBndr tyvar = (getOccName tyvar, tyVarKind tyvar) toIfaceIdBndr ext id = (getOccName id, toIfaceType ext (idType id)) toIfaceTvBndrs tyvars = map toIfaceTvBndr tyvars @@ -330,18 +309,6 @@ toIfaceBndr ext var | otherwise = IfaceTvBndr (toIfaceTvBndr var) --------------------- -toIfaceKind :: Kind -> IfaceKind -toIfaceKind k - | k `eqKind` openTypeKind = IfaceOpenTypeKind - | k `eqKind` liftedTypeKind = IfaceLiftedTypeKind - | k `eqKind` unliftedTypeKind = IfaceUnliftedTypeKind - | Just (arg,res) <- splitFunTy_maybe k - = IfaceFunKind (toIfaceKind arg) (toIfaceKind res) -#ifdef DEBUG - | otherwise = pprTrace "toIfaceKind" (pprType k) IfaceOpenTypeKind -#endif - ---------------------- toIfaceType :: (Name -> IfaceExtName) -> Type -> IfaceType toIfaceType ext (TyVarTy tv) = IfaceTyVar (getOccName tv) toIfaceType ext (AppTy t1 t2) = IfaceAppTy (toIfaceType ext t1) (toIfaceType ext t2) diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 39eadfb..1eb7982 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -6,7 +6,7 @@ \begin{code} module TcIface ( tcImportDecl, typecheckIface, - tcIfaceKind, loadImportedInsts, loadImportedRules, + loadImportedInsts, loadImportedRules, tcExtCoreBindings ) where #include "HsVersions.h" @@ -612,13 +612,6 @@ tcIfaceRule (IfaceBuiltinRule fn_rdr core_rule) %************************************************************************ \begin{code} -tcIfaceKind :: IfaceKind -> Kind -tcIfaceKind IfaceOpenTypeKind = openTypeKind -tcIfaceKind IfaceLiftedTypeKind = liftedTypeKind -tcIfaceKind IfaceUnliftedTypeKind = unliftedTypeKind -tcIfaceKind (IfaceFunKind k1 k2) = mkArrowKind (tcIfaceKind k1) (tcIfaceKind k2) - ------------------------------------------ tcIfaceType :: IfaceType -> IfL Type tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) } tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') } @@ -969,5 +962,5 @@ bindIfaceTyVars bndrs thing_inside where (occs,kinds) = unzip bndrs -mk_iface_tyvar name kind = mkTyVar name (tcIfaceKind kind) +mk_iface_tyvar name kind = mkTyVar name kind \end{code} diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 7ec09a1..2876efd 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -14,7 +14,6 @@ module MachCode ( stmtsToInstrs, InstrBlock ) where #include "HsVersions.h" #include "nativeGen/NCG.h" -import Unique ( Unique ) import MachMisc -- may differ per-platform import MachRegs import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL, @@ -37,10 +36,9 @@ import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..), StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..), DestInfo, hasDestInfo, pprStixExpr, repOfStixExpr, - liftStrings, NatM, thenNat, returnNat, mapNat, mapAndUnzipNat, mapAccumLNat, - getDeltaNat, setDeltaNat, getUniqueNat, + getDeltaNat, setDeltaNat, IF_ARCH_powerpc(addImportNat COMMA,) ncgPrimopMoan, ncg_target_is_32bit diff --git a/ghc/compiler/ndpFlatten/FlattenMonad.hs b/ghc/compiler/ndpFlatten/FlattenMonad.hs index a408eca..cbdc206 100644 --- a/ghc/compiler/ndpFlatten/FlattenMonad.hs +++ b/ghc/compiler/ndpFlatten/FlattenMonad.hs @@ -274,7 +274,7 @@ packContext perm m = Flatten $ \state -> -- generate a binding for the packed variant of a context variable -- mkCoreBind var = let - rhs = fst $ unFlatten (mk'bpermuteP (varType var) + rhs = fst $ unFlatten (mk'bpermuteP (idType var) (Var perm) (Var var) ) state @@ -301,9 +301,9 @@ liftVar :: Var -> Flatten CoreExpr liftVar var = Flatten $ \s -> let v = ctxtVarErr s - v'elemType = parrElemTy . varType $ v + v'elemType = parrElemTy . idType $ v len = fst $ unFlatten (mk'lengthP v'elemType (Var v)) s - replicated = fst $ unFlatten (mk'replicateP (varType var) len (Var var)) s + replicated = fst $ unFlatten (mk'replicateP (idType var) len (Var var)) s in case lookupVarEnv (ctxtEnv s) var of Just liftedVar -> (Var liftedVar, s {usedVars = usedVars s `extendVarSet` var}) @@ -318,7 +318,7 @@ liftConst :: CoreExpr -> Flatten CoreExpr liftConst e = Flatten $ \s -> let v = ctxtVarErr s - v'elemType = parrElemTy . varType $ v + v'elemType = parrElemTy . idType $ v len = fst $ unFlatten (mk'lengthP v'elemType (Var v)) s in (fst $ unFlatten (mk'replicateP (exprType e) len e ) s, s) diff --git a/ghc/compiler/ndpFlatten/Flattening.hs b/ghc/compiler/ndpFlatten/Flattening.hs index 14b68d1..ccced5a 100644 --- a/ghc/compiler/ndpFlatten/Flattening.hs +++ b/ghc/compiler/ndpFlatten/Flattening.hs @@ -69,10 +69,10 @@ import ErrUtils (dumpIfSet_dyn) import UniqSupply (mkSplitUniqSupply) import CmdLineOpts (DynFlag(..)) import Literal (Literal, literalType) -import Var (Var(..)) +import Var (Var(..), idType, isTyVar) +import Id (setIdType) import DataCon (DataCon, dataConTag) import TypeRep (Type(..)) -import Type (isTypeKind) import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), hscEPS ) import CoreFVs (exprFreeVars) import CoreSyn (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..), @@ -192,7 +192,7 @@ vectoriseBind (Rec bindings) = vectoriseOne (b, expr) = do (vexpr, ty) <- vectorise expr - return (b{varType = ty}, vexpr) + return (setIdType b ty, vexpr) -- Searches for function definitions and creates a lifted version for @@ -217,9 +217,9 @@ vectoriseBind (Rec bindings) = vectorise:: CoreExpr -> Flatten (CoreExpr, Type) vectorise (Var id) = do - let varTy = varType id + let varTy = idType id let vecTy = vectoriseTy varTy - return ((Var id{varType = vecTy}), vecTy) + return (Var (setIdType id vecTy), vecTy) vectorise (Lit lit) = return ((Lit lit), literalType lit) @@ -234,7 +234,7 @@ vectorise (App (Lam b expr) arg) = do (varg, argTy) <- vectorise arg (vexpr, vexprTy) <- vectorise expr - let vb = b{varType = argTy} + let vb = setIdType b argTy return ((App (Lam vb vexpr) varg), applyTypeToArg (mkPiType vb vexprTy) varg) @@ -265,14 +265,14 @@ vectorise (App expr arg) = vectorise e@(Lam b expr) - | isTypeKind (varType b) = - do + | isTyVar b + = do (vexpr, vexprTy) <- vectorise expr -- don't vectorise 'b'! return ((Lam b vexpr), mkPiType b vexprTy) | otherwise = do (vexpr, vexprTy) <- vectorise expr - let vb = b{varType = vectoriseTy (varType b)} + let vb = setIdType b (vectoriseTy (idType b)) let ve = Lam vb vexpr (lexpr, lexprTy) <- lift e let veTy = mkPiType vb vexprTy @@ -289,7 +289,7 @@ vectorise (Case expr b alts) = do (vexpr, vexprTy) <- vectorise expr valts <- mapM vectorise' alts - return (Case vexpr b{varType = vexprTy} (map fst valts), snd (head valts)) + return (Case vexpr (setIdType b vexprTy) (map fst valts), snd (head valts)) where vectorise' (con, bs, expr) = do (vexpr, vexprTy) <- vectorise expr @@ -353,7 +353,7 @@ liftTy t = mkPArrTy t -- lift type, don't change name (incl unique) nor IdInfo. IdInfo looks ok, -- but I'm not entirely sure about some fields (e.g., strictness info) liftBinderType:: CoreBndr -> Flatten CoreBndr -liftBinderType bndr = return $ bndr {varType = liftTy (varType bndr)} +liftBinderType bndr = return $ setIdType bndr (liftTy (idType bndr)) -- lift: lifts an expression (a -> [:a:]) -- If the expression is a simple expression, it is treated like a constant @@ -364,7 +364,7 @@ lift:: CoreExpr -> Flatten (CoreExpr, Type) lift cExpr@(Var id) = do lVar@(Var lId) <- liftVar id - return (lVar, varType lId) + return (lVar, idType lId) lift cExpr@(Lit lit) = do @@ -374,7 +374,7 @@ lift cExpr@(Lit lit) = lift (Lam b expr) | isSimpleExpr expr = liftSimpleFun b expr - | isTypeKind (varType b) = + | isTyVar b = do (lexpr, lexprTy) <- lift expr -- don't lift b! return (Lam b lexpr, mkPiType b lexprTy) @@ -502,7 +502,7 @@ liftSingleDataCon:: CoreBndr -> DataCon -> [CoreBndr] -> CoreExpr -> liftSingleDataCon b dcon bnds expr = do let dconId = dataConTag dcon - indexExpr <- mkIndexOfExprDCon (varType b) b dconId + indexExpr <- mkIndexOfExprDCon (idType b) b dconId (bb, bbind) <- mkBind FSLIT("is") indexExpr lbnds <- mapM liftBinderType bnds ((lExpr, _), bnds') <- packContext bb (extendContext lbnds (lift expr)) @@ -518,7 +518,7 @@ liftCaseDataConDefault:: CoreBndr -> (Alt CoreBndr) -> [Alt CoreBndr] liftCaseDataConDefault b (_, _, def) alts = do let dconIds = map (\(DataAlt d, _, _) -> dataConTag d) alts - indexExpr <- mkIndexOfExprDConDft (varType b) b dconIds + indexExpr <- mkIndexOfExprDConDft (idType b) b dconIds (bb, bbind) <- mkBind FSLIT("is") indexExpr ((lDef, _), bnds) <- packContext bb (lift def) (_, vbind) <- mkBind FSLIT("r") lDef @@ -549,7 +549,7 @@ liftCaseLitDefault:: CoreBndr -> (Alt CoreBndr) -> [Alt CoreBndr] liftCaseLitDefault b (_, _, def) alts = do let lits = map (\(LitAlt l, _, _) -> l) alts - indexExpr <- mkIndexOfExprDft (varType b) b lits + indexExpr <- mkIndexOfExprDft (idType b) b lits (bb, bbind) <- mkBind FSLIT("is") indexExpr ((lDef, _), bnds) <- packContext bb (lift def) (_, vbind) <- mkBind FSLIT("r") lDef @@ -588,7 +588,7 @@ liftSingleCaseLit:: CoreBndr -> Literal -> CoreExpr -> Flatten (CoreBind, CoreBind, [CoreBind]) liftSingleCaseLit b lit expr = do - indexExpr <- mkIndexOfExpr (varType b) b lit -- (a) + indexExpr <- mkIndexOfExpr (idType b) b lit -- (a) (bb, bbind) <- mkBind FSLIT("is") indexExpr ((lExpr, t), bnds) <- packContext bb (lift expr) -- (b) (_, vbind) <- mkBind FSLIT("r") lExpr @@ -645,7 +645,7 @@ dftbpBinders indexBnds exprBnds = let iVar = getVarOfBind i let eVar = getVarOfBind e let cVar = getVarOfBind cBind - let ty = varType eVar + let ty = idType eVar newBnd <- mkDftBackpermute ty iVar eVar cVar ((fBnd, restBnds), _) <- dftbpBinders' is es newBnd return ((fBnd, (newBnd:restBnds)), liftTy ty) @@ -676,7 +676,7 @@ liftSimpleFun b expr = do bndVars <- collectBoundVars expr let bndVars' = b:bndVars - bndVarsTuple = mkTuple (map varType bndVars') (map Var bndVars') + bndVarsTuple = mkTuple (map idType bndVars') (map Var bndVars') lamExpr = mkLams (b:bndVars) expr -- FIXME: should be tuple -- here let (t1, t2) = funTyArgs . exprType $ lamExpr @@ -697,11 +697,11 @@ collectBoundVars expr = -- indexOf (mapP (\x -> x == lit) b) b -- mkIndexOfExpr:: Type -> CoreBndr -> Literal -> Flatten CoreExpr -mkIndexOfExpr varType b lit = +mkIndexOfExpr idType b lit = do - eqExpr <- mk'eq varType (Var b) (Lit lit) + eqExpr <- mk'eq idType (Var b) (Lit lit) let lambdaExpr = (Lam b eqExpr) - mk'indexOfP varType lambdaExpr (Var b) + mk'indexOfP idType lambdaExpr (Var b) -- there is FlattenMonad.mk'indexOfP as well as -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here @@ -715,12 +715,12 @@ mkIndexOfExpr varType b lit = -- indexOfP (\x -> x == dconId) b) -- mkIndexOfExprDCon::Type -> CoreBndr -> Int -> Flatten CoreExpr -mkIndexOfExprDCon varType b dId = +mkIndexOfExprDCon idType b dId = do let intExpr = mkIntLitInt dId - eqExpr <- mk'eq varType (Var b) intExpr + eqExpr <- mk'eq idType (Var b) intExpr let lambdaExpr = (Lam b intExpr) - mk'indexOfP varType lambdaExpr (Var b) + mk'indexOfP idType lambdaExpr (Var b) @@ -733,23 +733,23 @@ mkIndexOfExprDCon varType b dId = -- indexOfP (\x -> x != dconId_1 && ....) b) -- mkIndexOfExprDConDft:: Type -> CoreBndr -> [Int] -> Flatten CoreExpr -mkIndexOfExprDConDft varType b dId = +mkIndexOfExprDConDft idType b dId = do let intExprs = map mkIntLitInt dId - bExpr <- foldM (mk'neq varType) (head intExprs) (tail intExprs) + bExpr <- foldM (mk'neq idType) (head intExprs) (tail intExprs) let lambdaExpr = (Lam b bExpr) - mk'indexOfP varType (Var b) bExpr + mk'indexOfP idType (Var b) bExpr -- mkIndexOfExprDef b [lit1, lit2,...] -> -- indexOf (\x -> not (x == lit1 || x == lit2 ....) b mkIndexOfExprDft:: Type -> CoreBndr -> [Literal] -> Flatten CoreExpr -mkIndexOfExprDft varType b lits = +mkIndexOfExprDft idType b lits = do let litExprs = map (\l-> Lit l) lits - bExpr <- foldM (mk'neq varType) (head litExprs) (tail litExprs) + bExpr <- foldM (mk'neq idType) (head litExprs) (tail litExprs) let lambdaExpr = (Lam b bExpr) - mk'indexOfP varType bExpr (Var b) + mk'indexOfP idType bExpr (Var b) -- create a back-permute binder diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y index 95abaf4..757d5e3 100644 --- a/ghc/compiler/parser/ParserCore.y +++ b/ghc/compiler/parser/ParserCore.y @@ -4,10 +4,10 @@ module ParserCore ( parseCore ) where import IfaceSyn import ForeignCall import RdrHsSyn -import TcIface ( tcIfaceKind ) import HsSyn import RdrName import OccName +import Kind( Kind(..) ) import Name( nameOccName, nameModuleName ) import Module import ParserCoreUtils @@ -183,7 +183,7 @@ id_bndrs :: { [IfaceIdBndr] } | id_bndr id_bndrs { $1:$2 } tv_bndr :: { IfaceTvBndr } - : tv_occ { ($1, IfaceLiftedTypeKind) } + : tv_occ { ($1, LiftedTypeKind) } | '(' tv_occ '::' akind ')' { ($2, $4) } tv_bndrs :: { [IfaceTvBndr] } @@ -191,14 +191,14 @@ tv_bndrs :: { [IfaceTvBndr] } | tv_bndr tv_bndrs { $1:$2 } akind :: { IfaceKind } - : '*' { IfaceLiftedTypeKind } - | '#' { IfaceUnliftedTypeKind } - | '?' { IfaceOpenTypeKind } + : '*' { LiftedTypeKind } + | '#' { UnliftedTypeKind } + | '?' { OpenTypeKind } | '(' kind ')' { $2 } kind :: { IfaceKind } : akind { $1 } - | akind '->' kind { IfaceFunKind $1 $3 } + | akind '->' kind { FunKind $1 $3 } ----------------------------------------- -- Expressions @@ -314,7 +314,7 @@ toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifa toHsType (IfaceForAllTy tv t) = add_forall (toHsTvBndr tv) (toHsType t) toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName -toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual tv) (tcIfaceKind k) +toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual tv) k ifaceExtRdrName :: IfaceExtName -> RdrName ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index ef047ba..656fc34 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -57,6 +57,7 @@ import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, setRdrNameSpace, rdrNameModule ) import BasicTypes ( RecFlag(..), mapIPName, maxPrecedence, initialVersion ) import Lexer ( P, failSpanMsgP ) +import Kind ( liftedTypeKind ) import HscTypes ( GenAvailInfo(..) ) import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), @@ -318,8 +319,8 @@ hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs ----------- -hsIfaceTv (UserTyVar n) = (rdrNameOcc n, IfaceLiftedTypeKind) -hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, toIfaceKind k) +hsIfaceTv (UserTyVar n) = (rdrNameOcc n, liftedTypeKind) +hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, k) ----------- hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])] @@ -716,8 +717,6 @@ checkAPat loc e = case e of HsType ty -> return (TypePat ty) _ -> patFail loc -checkAPat loc _ = patFail loc - checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName) checkPatField (n,e) = do p <- checkLPat e diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 4d8de98..c8ffc3b 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -72,8 +72,8 @@ import TyCon ( TyCon, AlgTyConFlavour(..), DataConDetails(..), tyConDataCons, import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..) ) import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys, - mkArrowKinds, liftedTypeKind, unliftedTypeKind, ThetaType, TyThing(..) ) +import Kind ( mkArrowKinds, liftedTypeKind, ubxTupleKind ) import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique, mkPArrDataConUnique ) import PrelNames @@ -240,7 +240,7 @@ mk_tuple boxity arity = (tycon, tuple_con) Nothing (ATyCon tycon) tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind res_kind | isBoxed boxity = liftedTypeKind - | otherwise = unliftedTypeKind + | otherwise = ubxTupleKind tyvars | isBoxed boxity = take arity alphaTyVars | otherwise = take arity openAlphaTyVars diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 38b3597..d7eaf76 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -32,10 +32,10 @@ import Name ( Name, nameSrcLoc, nameOccName, nameModuleName, nameParent, nameParent_maybe, isExternalName ) import NameSet import NameEnv -import OccName ( OccName, srcDataName, isTcOcc, OccEnv, elemOccEnv, +import OccName ( srcDataName, isTcOcc, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOccEnv ) import HscTypes ( GenAvailInfo(..), AvailInfo, Avails, GhciMode(..), - IsBootInterface, IfaceExport, + IfaceExport, availName, availNames, availsToNameSet, unQualInScope, Deprecs(..), ModIface(..), Dependencies(..) ) diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index c5c541b..7ec84e0 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -16,7 +16,7 @@ import CmdLineOpts ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) ) import HsSyn import RdrHsSyn ( extractHsRhoRdrTyVars ) import RnHsSyn ( extractHsTyNames, parrTyCon_name, tupleTyCon_name, - listTyCon_name, charTyCon_name + listTyCon_name ) import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, lookupLocatedOccRn, lookupLocatedBndrRn, @@ -25,15 +25,12 @@ import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV ) import TcRnMonad import RdrName ( RdrName, elemLocalRdrEnv ) -import PrelNames ( eqStringName, eqClassName, integralClassName, +import PrelNames ( eqClassName, integralClassName, negateName, minusName, lengthPName, indexPName, plusIntegerName, fromIntegerName, timesIntegerName, ratioDataConName, fromRationalName ) import Constants ( mAX_TUPLE_SIZE ) -import TysWiredIn ( intTyCon ) -import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, - floatPrimTyCon, doublePrimTyCon ) -import Name ( Name, NamedThing(..) ) +import Name ( Name ) import SrcLoc ( Located(..), unLoc ) import NameSet diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 8843455..541f38a 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -14,18 +14,13 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), ) import CoreSyn import TcIface ( loadImportedRules ) -import HscTypes ( HscEnv(..), GhciMode(..), - ModGuts(..), ModGuts, Avails, - ModDetails(..), - HomeModInfo(..), ExternalPackageState(..), hscEPS - ) +import HscTypes ( HscEnv(..), ModGuts(..), ModGuts, + ModDetails(..), HomeModInfo(..) ) import CSE ( cseProgram ) -import Rules ( RuleBase, emptyRuleBase, ruleBaseIds, +import Rules ( RuleBase, ruleBaseIds, extendRuleBaseList, pprRuleBase, getLocalRules, ruleCheckProgram ) import Module ( moduleEnvElts ) -import Name ( Name, isExternalName ) -import NameSet ( elemNameSet ) import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules ) import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr ) import CoreUtils ( coreBindsSize ) @@ -36,7 +31,7 @@ import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass ) import CoreLint ( endPass ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) -import Id ( idName, idIsFrom, idSpecialisation, setIdSpecialisation ) +import Id ( idIsFrom, idSpecialisation, setIdSpecialisation ) import VarSet import LiberateCase ( liberateCase ) import SAT ( doStaticArgs ) @@ -54,7 +49,6 @@ import IO ( hPutStr, stderr ) import Outputable import Maybes ( orElse ) -import List ( partition ) \end{code} %************************************************************************ diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 83384cf..bb9deaa 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -39,10 +39,11 @@ import Type ( Type, seqType, splitFunTys, dropForAlls, isStrictType, splitTyConApp_maybe, tyConAppArgs, mkTyVarTys ) import TcType ( isDictTy ) +import Name ( mkSysTvName ) import OccName ( EncodedFS ) import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon ) import DataCon ( dataConRepArity, dataConExistentialTyVars, dataConArgTys ) -import Var ( mkSysTyVar, tyVarKind ) +import Var ( tyVarKind, mkTyVar ) import VarSet import Util ( lengthExceeds, mapAccumL ) import Outputable @@ -907,7 +908,7 @@ mk_args missing_con inst_tys let ex_tyvars = dataConExistentialTyVars missing_con ex_tyvars' = zipWith mk tv_uniqs ex_tyvars - mk uniq tv = mkSysTyVar uniq (tyVarKind tv) + mk uniq tv = mkTyVar (mkSysTvName uniq FSLIT("t")) (tyVarKind tv) arg_tys = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars') arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys in diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 3291c0d..02258a9 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -18,7 +18,7 @@ import StgSyn import Type import TyCon ( isAlgTyCon ) import Id -import Var ( Var, globalIdDetails, varType ) +import Var ( Var, globalIdDetails, idType ) import TyCon ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon ) #ifdef ILX import MkId ( unsafeCoerceId ) @@ -445,7 +445,7 @@ coreToStgApp maybe_thunk_body f args -- Here the free variables are "f", "x" AND the type variable "a" -- coreToStgArgs will deal with the arguments recursively if opt_RuntimeTypes then - fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (varType f)) + fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (idType f)) else fvs -- Mostly, the arity info of a function is in the fn's IdInfo diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index c4f08bc..a6f1868 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -49,10 +49,10 @@ module StgSyn ( import CostCentre ( CostCentreStack, CostCentre ) import VarSet ( IdSet, isEmptyVarSet ) import Var ( isId ) -import Id ( Id, idName, idPrimRep, idType, idCafInfo ) +import Id ( Id, idName, idType, idCafInfo ) import IdInfo ( mayHaveCafRefs ) import Name ( isDllName ) -import Literal ( Literal, literalType, literalPrimRep ) +import Literal ( Literal, literalType ) import ForeignCall ( ForeignCall ) import DataCon ( DataCon, dataConName ) import CoreSyn ( AltCon ) diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 2eaac28..0c1bff0 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -39,7 +39,7 @@ module Inst ( import {-# SOURCE #-} TcExpr( tcCheckSigma ) -import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, nlHsVar, mkHsApp ) +import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp ) import TcHsSyn ( TcId, TcIdSet, mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId, mkCoercion, ExprCoFn @@ -80,7 +80,7 @@ import TysWiredIn ( floatDataCon, doubleDataCon ) import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName ) import BasicTypes( IPName(..), mapIPName, ipNameName ) import UniqSupply( uniqsFromSupply ) -import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) ) +import SrcLoc ( mkSrcSpan, noLoc, Located(..) ) import CmdLineOpts( DynFlags, DynFlag( Opt_AllowUndecidableInstances ), dopt ) import Maybes ( isJust ) import Outputable diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 6a66814..b0607e3 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -31,9 +31,8 @@ import TcPat ( tcPat, tcSubPat, tcMonoPatBndr ) import TcSimplify ( bindInstsOfLocalFuns ) import TcMType ( newTyVar, newTyVarTy, zonkTcTyVarToTyVar ) import TcType ( TcTyVar, mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, - mkPredTy, mkForAllTy, isUnLiftedType, - unliftedTypeKind, liftedTypeKind, openTypeKind, eqKind - ) + mkPredTy, mkForAllTy, isUnLiftedType ) +import Kind ( liftedTypeKind, argTypeKind, isUnliftedTypeKind ) import CoreFVs ( idFreeTyVars ) import Id ( mkLocalId, mkSpecPragmaId, setInlinePragma ) @@ -128,7 +127,7 @@ tc_bind_and_then top_lvl combiner (HsIPBinds binds) do_next -- Consider ?x = 4 -- ?y = ?x + 1 tc_ip_bind (IPBind ip expr) - = newTyVarTy openTypeKind `thenM` \ ty -> + = newTyVarTy argTypeKind `thenM` \ ty -> newIPDict (IPBindOrigin ip) ip ty `thenM` \ (ip', ip_inst) -> tcCheckRho expr ty `thenM` \ expr' -> returnM (ip_inst, (IPBind ip' expr')) @@ -143,105 +142,58 @@ tc_bind_and_then top_lvl combiner (HsBindGroup binds sigs is_rec) do_next -- b) the bindings in the group -- c) the scope of the binding group (the "in" part) tcAddScopedTyVars (collectSigTysFromHsBinds (bagToList binds)) $ - tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) -> case top_lvl of TopLevel -- For the top level don't bother will all this -- bindInstsOfLocalFuns stuff. All the top level -- things are rec'd together anyway, so it's fine to -- leave them to the tcSimplifyTop, and quite a bit faster too - -- - -- Subtle (and ugly) point: furthermore at top level we - -- return the TcLclEnv, which contains the LIE var; we - -- don't want to return the wrong one! - -> tc_body poly_ids `thenM` \ (prag_binds, thing) -> + -> tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) -> + tc_body poly_ids `thenM` \ (prag_binds, thing) -> returnM (combiner (HsBindGroup (poly_binds `unionBags` prag_binds) [] -- no sigs Recursive) thing) - NotTopLevel -- For nested bindings we must do the - -- bindInstsOfLocalFuns thing. We must include - -- the LIE from the RHSs too -- polymorphic recursion! - -> getLIE (tc_body poly_ids) `thenM` \ ((prag_binds, thing), lie) -> + NotTopLevel -- For nested bindings we must do the bindInstsOfLocalFuns thing. + | not (isRec is_rec) -- Non-recursive group + -> -- We want to keep non-recursive things non-recursive + -- so that we desugar unlifted bindings correctly + tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) -> + getLIE (tc_body poly_ids) `thenM` \ ((prag_binds, thing), lie) -> -- Create specialisations of functions bound here - bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds -> + bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds -> - -- We want to keep non-recursive things non-recursive - -- so that we desugar unlifted bindings correctly - if isRec is_rec then - returnM ( - combiner (HsBindGroup - (poly_binds `unionBags` - lie_binds `unionBags` - prag_binds) - [] Recursive) thing - ) - else - returnM ( + returnM ( combiner (HsBindGroup poly_binds [] NonRecursive) $ combiner (HsBindGroup prag_binds [] NonRecursive) $ combiner (HsBindGroup lie_binds [] Recursive) $ -- NB: the binds returned by tcSimplify and -- bindInstsOfLocalFuns aren't guaranteed in - -- dependency order (though we could change - -- that); hence the Recursive marker. + -- dependency order (though we could change that); + -- hence the Recursive marker. thing) -{- - = -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE - -- Notice that they scope over - -- a) the type signatures in the binding group - -- b) the bindings in the group - -- c) the scope of the binding group (the "in" part) - tcAddScopedTyVars (collectSigTysFromHsBinds (bagToList binds)) $ + | otherwise + -> -- NB: polymorphic recursion means that a function + -- may use an instance of itself, we must look at the LIE arising + -- from the function's own right hand side. Hence the getLIE + -- encloses the tcBindWithSigs. + + getLIE ( + tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) -> + tc_body poly_ids `thenM` \ (prag_binds, thing) -> + returnM (poly_ids, poly_binds `unionBags` prag_binds, thing) + ) `thenM` \ ((poly_ids, extra_binds, thing), lie) -> + + bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds -> - tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) -> - - case top_lvl of - TopLevel -- For the top level don't bother will all this - -- bindInstsOfLocalFuns stuff. All the top level - -- things are rec'd together anyway, so it's fine to - -- leave them to the tcSimplifyTop, and quite a bit faster too - -- - -- Subtle (and ugly) point: furthermore at top level we - -- return the TcLclEnv, which contains the LIE var; we - -- don't want to return the wrong one! - -> tc_body poly_ids `thenM` \ (prag_binds, thing) -> - returnM (combiner (HsBindGroup - (poly_binds `unionBags` prag_binds) - [] -- no sigs - Recursive) - thing) - - NotTopLevel -- For nested bindings we must do teh bindInstsOfLocalFuns thing - -> getLIE (tc_body poly_ids) `thenM` \ ((prag_binds, thing), lie) -> - - -- Create specialisations of functions bound here - bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds -> - - -- We want to keep non-recursive things non-recursive - -- so that we desugar unlifted bindings correctly - if isRec is_rec then - returnM ( - combiner (HsBindGroup ( - poly_binds `unionBags` - lie_binds `unionBags` - prag_binds) - [] Recursive) thing - ) - else - returnM ( - combiner (HsBindGroup poly_binds [] NonRecursive) $ - combiner (HsBindGroup prag_binds [] NonRecursive) $ - combiner (HsBindGroup lie_binds [] Recursive) $ - -- NB: the binds returned by tcSimplify and bindInstsOfLocalFuns - -- aren't guaranteed in dependency order (though we could change - -- that); hence the Recursive marker. - thing) --} + returnM (combiner (HsBindGroup + (extra_binds `unionBags` lie_binds) + [] Recursive) thing + ) where tc_body poly_ids -- Type check the pragmas and "thing inside" = -- Extend the environment to bind the new polymorphic Ids @@ -420,7 +372,7 @@ attachInlinePhase inline_phases bndr -- d) not a multiple-binding group (more or less implied by (a)) checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind - = ASSERT( not (any ((eqKind unliftedTypeKind) . tyVarKind) real_tyvars_to_gen) ) + = ASSERT( not (any (isUnliftedTypeKind . tyVarKind) real_tyvars_to_gen) ) -- The instCantBeGeneralised stuff in tcSimplify should have -- already raised an error if we're trying to generalise an -- unboxed tyvar (NB: unboxed tyvars are always introduced @@ -741,7 +693,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec -- So we must use an ordinary H-M type variable -- which means the variable gets an inferred tau-type newLocalName name `thenM` \ mono_name -> - newTyVarTy openTypeKind `thenM` \ mono_ty -> + newTyVarTy argTypeKind `thenM` \ mono_ty -> let mono_id = mkLocalId mono_name mono_ty complete_it = tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' -> diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 251dc8a..9ae343b 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -45,8 +45,7 @@ import Subst ( substTyWith ) import MkId ( mkDefaultMethodId, mkDictFunId ) import Id ( Id, idType, idName, mkUserLocal, setInlinePragma ) import Name ( Name, NamedThing(..) ) -import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, - plusNameEnv, mkNameEnv ) +import NameEnv ( NameEnv, lookupNameEnv, mkNameEnv ) import NameSet ( emptyNameSet, unitNameSet, nameSetToList ) import OccName ( reportIfUnused, mkDefaultMethodOcc ) import RdrName ( RdrName, mkDerivedRdrName ) @@ -59,7 +58,7 @@ import ErrUtils ( dumpIfSet_dyn ) import Util ( count, lengthIs, isSingleton, lengthExceeds ) import Unique ( Uniquable(..) ) import ListSetOps ( equivClassesByUniq, minusList ) -import SrcLoc ( SrcLoc, Located(..), srcSpanStart, unLoc, noLoc ) +import SrcLoc ( Located(..), srcSpanStart, unLoc, noLoc ) import Maybes ( seqMaybe, isJust, mapCatMaybes ) import List ( partition ) import Bag @@ -611,7 +610,7 @@ gives rise to the instance declarations \begin{code} getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo] getGenericInstances class_decls - = do { gen_inst_infos <- mappM get_generics class_decls + = do { gen_inst_infos <- mappM (addLocM get_generics) class_decls ; let { gen_inst_info = concat gen_inst_infos } -- Return right away if there is no generic stuff @@ -624,7 +623,7 @@ getGenericInstances class_decls (vcat (map pprInstInfoDetails gen_inst_info))) ; returnM gen_inst_info }} -get_generics decl@(L loc (ClassDecl {tcdLName = class_name, tcdMeths = def_methods})) +get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods}) | null generic_binds = returnM [] -- The comon case: no generic default methods @@ -638,8 +637,7 @@ get_generics decl@(L loc (ClassDecl {tcdLName = class_name, tcdMeths = def_metho let groups = groupWith listToBag generic_binds in - mappM (mkGenericInstance clas (srcSpanStart loc)) groups - `thenM` \ inst_infos -> + mappM (mkGenericInstance clas) groups `thenM` \ inst_infos -> -- Check that there is only one InstInfo for each type constructor -- The main way this can fail is if you write @@ -704,11 +702,11 @@ eqPatType t1 (HsParTy t2) = t1 `eqPatType` unLoc t2 eqPatType _ _ = False --------------------------------- -mkGenericInstance :: Class -> SrcLoc +mkGenericInstance :: Class -> (HsType Name, LHsBinds Name) -> TcM InstInfo -mkGenericInstance clas loc (hs_ty, binds) +mkGenericInstance clas (hs_ty, binds) -- Make a generic instance declaration -- For example: instance (C a, C b) => C (a+b) where { binds } @@ -728,7 +726,8 @@ mkGenericInstance clas loc (hs_ty, binds) (badGenericInstanceType binds) `thenM_` -- Make the dictionary function. - newDFunName clas [inst_ty] loc `thenM` \ dfun_name -> + getSrcSpanM `thenM` \ span -> + newDFunName clas [inst_ty] (srcSpanStart span) `thenM` \ dfun_name -> let inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars] dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty] @@ -745,10 +744,8 @@ mkGenericInstance clas loc (hs_ty, binds) %************************************************************************ \begin{code} -tcAddDeclCtxt (L loc decl) thing_inside - = addSrcSpan loc $ - addErrCtxt ctxt $ - thing_inside +tcAddDeclCtxt decl thing_inside + = addErrCtxt ctxt thing_inside where thing = case decl of ClassDecl {} -> "class" diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index da42749..38567e6 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -40,14 +40,14 @@ import RdrName ( RdrName ) import Name ( Name, getSrcLoc ) import NameSet ( NameSet, emptyNameSet, duDefs ) import Unique ( Unique, getUnique ) - +import Kind ( splitKindFunTys ) import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics, tyConTheta, isProductTyCon, isDataTyCon, isEnumerationTyCon, isRecursiveTyCon, TyCon ) import TcType ( TcType, ThetaType, mkTyVarTy, mkTyVarTys, mkTyConApp, getClassPredTys_maybe, tcTyConAppTyCon, - isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys, isTypeKind, + isUnLiftedType, mkClassPred, tyVarsOfTypes, isArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys, tcSplitDFunTy ) import Var ( TyVar, tyVarKind, idType, varName ) import VarSet ( mkVarSet, subVarSet ) @@ -391,7 +391,7 @@ makeDerivEqns tycl_decls -- Kind of the thing we want to instance -- e.g. argument kind of Monad, *->* - (arg_kinds, _) = tcSplitFunTys kind + (arg_kinds, _) = splitKindFunTys kind n_args_to_drop = length arg_kinds -- Want to drop 1 arg from (T s a) and (ST s a) -- to get instance Monad (ST s) => Monad (T s) @@ -600,7 +600,7 @@ cond_isProduct (gla_exts, tycon) cond_allTypeKind :: Condition cond_allTypeKind (gla_exts, tycon) - | all (isTypeKind . tyVarKind) (tyConTyVars tycon) = Nothing + | all (isArgTypeKind . tyVarKind) (tyConTyVars tycon) = Nothing | otherwise = Just why where why = quotes (ppr tycon) <+> ptext SLIT("is parameterised over arguments of kind other than `*'") diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 5b760ac..cf86e56 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -18,12 +18,13 @@ module TcEnv( getInGlobalScope, -- Local environment - tcExtendTyVarKindEnv, + tcExtendKindEnv, tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendLocalValEnv, tcExtendLocalValEnv2, tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupId, tcLookupTyVar, lclEnvElts, getInLocalScope, findGlobals, + wrongThingErr, tcExtendRecEnv, -- For knot-tying @@ -46,19 +47,18 @@ module TcEnv( #include "HsVersions.h" -import HsSyn ( LRuleDecl, , HsTyVarBndr(..), LHsTyVarBndr, LHsBinds, - LSig ) +import HsSyn ( LRuleDecl, LHsBinds, LSig ) import TcIface ( tcImportDecl ) import TcRnMonad import TcMType ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV ) -import TcType ( Type, TcTyVar, TcTyVarSet, +import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp, getDFunTyKey, tcTyConAppTyCon, tyVarBindingInfo, tidyOpenType, tidyOpenTyVar ) import qualified Type ( getTyVar_maybe ) import Id ( idName, isLocalId ) -import Var ( TyVar, Id, mkTyVar, idType ) +import Var ( TyVar, Id, idType ) import VarSet import VarEnv import RdrName ( extendLocalRdrEnv ) @@ -69,7 +69,7 @@ import Name ( Name, NamedThing(..), getSrcLoc, mkInternalName, nameIsLocalOrFro import NameEnv import OccName ( mkDFunOcc, occNameString ) import HscTypes ( DFunId, extendTypeEnvList, lookupType, - TyThing(..), tyThingId, tyThingTyCon, tyThingClass, tyThingDataCon, + TyThing(..), tyThingId, tyThingDataCon, ExternalPackageState(..) ) import SrcLoc ( SrcLoc, Located(..) ) @@ -129,12 +129,16 @@ tcLookupDataCon con_name tcLookupClass :: Name -> TcM Class tcLookupClass name = tcLookupGlobal name `thenM` \ thing -> - return (tyThingClass thing) + case thing of + AClass cls -> return cls + other -> wrongThingErr "class" (AGlobal thing) name tcLookupTyCon :: Name -> TcM TyCon tcLookupTyCon name = tcLookupGlobal name `thenM` \ thing -> - return (tyThingTyCon thing) + case thing of + ATyCon tc -> return tc + other -> wrongThingErr "type constructor" (AGlobal thing) name tcLookupLocatedGlobalId :: Located Name -> TcM Id tcLookupLocatedGlobalId = addLocM tcLookupId @@ -188,16 +192,13 @@ getInGlobalScope \begin{code} -tcExtendRecEnv :: [(Name,TyThing)] -- Global bindings - -> [(Name,TcTyThing)] -- Local bindings - -> TcM r -> TcM r --- Extend both local and global environments for the type/class knot tying game -tcExtendRecEnv gbl_stuff lcl_stuff thing_inside - = do { (gbl_env, lcl_env) <- getEnvs - ; let { ge' = extendNameEnvList (tcg_type_env gbl_env) gbl_stuff - ; le' = extendNameEnvList (tcl_env lcl_env) lcl_stuff } - ; setEnvs (gbl_env {tcg_type_env = ge'}, lcl_env {tcl_env = le'}) - thing_inside } +tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r +-- Extend the global environments for the type/class knot tying game +tcExtendRecEnv gbl_stuff thing_inside + = updGblEnv upd thing_inside + where + upd env = env { tcg_type_env = extend (tcg_type_env env) } + extend env = extendNameEnvList env gbl_stuff \end{code} @@ -261,15 +262,12 @@ getInLocalScope = getLclEnv `thenM` \ env -> \end{code} \begin{code} -tcExtendTyVarKindEnv :: [LHsTyVarBndr Name] -> TcM r -> TcM r --- The tyvars are all kinded -tcExtendTyVarKindEnv tvs thing_inside +tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r +tcExtendKindEnv things thing_inside = updLclEnv upd thing_inside where upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } - extend env = extendNameEnvList env [(n, ATyVar (mkTyVar n k)) - | L _ (KindedTyVar n k) <- tvs] - -- No need to extend global tyvars for kind checking + extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things] tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r tcExtendTyVarEnv tvs thing_inside @@ -626,4 +624,15 @@ simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) \begin{code} notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+> ptext SLIT("is not in scope")) + +wrongThingErr expected thing name + = failWithTc (pp_thing thing <+> quotes (ppr name) <+> + ptext SLIT("used as a") <+> text expected) + where + pp_thing (AGlobal (ATyCon _)) = ptext SLIT("Type constructor") + pp_thing (AGlobal (AClass _)) = ptext SLIT("Class") + pp_thing (AGlobal (AnId _)) = ptext SLIT("Identifier") + pp_thing (AGlobal (ADataCon _)) = ptext SLIT("Data constructor") + pp_thing (ATyVar _) = ptext SLIT("Type variable") + pp_thing (ATcId _ _ _) = ptext SLIT("Local identifier") \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 151a62a..9ea7a52 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -13,12 +13,12 @@ import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) import Id ( Id ) import TcType ( isTauTy ) import TcEnv ( checkWellStaged ) +imoprt HsSyn ( nlHsApp ) import qualified DsMeta #endif import HsSyn ( HsExpr(..), LHsExpr, HsLit(..), ArithSeqInfo(..), recBindFields, - HsMatchContext(..), HsRecordBinds, mkHsApp, nlHsVar, - nlHsApp ) + HsMatchContext(..), HsRecordBinds, mkHsApp, nlHsVar ) import TcHsSyn ( hsLitType, mkHsDictApp, mkHsTyApp, (<$>) ) import TcRnMonad import TcUnify ( Expected(..), newHole, zapExpectedType, zapExpectedTo, tcSubExp, tcGen, @@ -42,9 +42,10 @@ import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv), tcSplitFunTys, tcSplitTyConApp, mkTyVarTys, isSigmaTy, mkFunTy, mkFunTys, mkTyConApp, tyVarsOfTypes, isLinearPred, - liftedTypeKind, openTypeKind, tcSplitSigmaTy, tidyOpenType ) +import Kind ( openTypeKind, liftedTypeKind, argTypeKind ) + import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon ) import Id ( idType, recordSelectorFieldLabel, isRecordSelector ) import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConWrapId ) @@ -145,7 +146,8 @@ tc_expr (HsIPVar ip) res_ty -- type scheme. We enforce this by creating a fresh -- type variable as its type. (Because res_ty may not -- be a tau-type.) - newTyVarTy openTypeKind `thenM` \ ip_ty -> + newTyVarTy argTypeKind `thenM` \ ip_ty -> + -- argTypeKind: it can't be an unboxed tuple newIPDict (IPOccOrigin ip) ip ip_ty `thenM` \ (ip', inst) -> extendLIE inst `thenM_` tcSubExp res_ty ip_ty `thenM` \ co_fn -> @@ -161,7 +163,7 @@ tc_expr (HsIPVar ip) res_ty \begin{code} tc_expr in_expr@(ExprWithTySig expr poly_ty) res_ty - = addErrCtxt (exprSigCtxt in_expr) $ + = addErrCtxt (exprCtxt in_expr) $ tcHsSigType ExprSigCtxt poly_ty `thenM` \ sig_tc_ty -> tcThingWithSig sig_tc_ty (tcCheckRho expr) res_ty `thenM` \ (co_fn, expr') -> returnM (co_fn <$> unLoc expr') @@ -194,7 +196,7 @@ tc_expr (HsCoreAnn lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> tc_expr (HsLit lit) res_ty = tcLit lit res_ty tc_expr (HsOverLit lit) res_ty - = zapExpectedType res_ty `thenM` \ res_ty' -> + = zapExpectedType res_ty liftedTypeKind `thenM` \ res_ty' -> newOverloadedLit (LiteralOrigin lit) lit res_ty' `thenM` \ lit_expr -> returnM (unLoc lit_expr) -- ToDo: nasty unLoc @@ -286,7 +288,7 @@ tc_expr (HsIf pred b1 b2) res_ty = addErrCtxt (predCtxt pred) ( tcCheckRho pred boolTy ) `thenM` \ pred' -> - zapExpectedType res_ty `thenM` \ res_ty' -> + zapExpectedType res_ty openTypeKind `thenM` \ res_ty' -> -- C.f. the call to zapToType in TcMatches.tcMatches tcCheckRho b1 res_ty' `thenM` \ b1' -> @@ -294,8 +296,8 @@ tc_expr (HsIf pred b1 b2) res_ty returnM (HsIf pred' b1' b2') tc_expr (HsDo do_or_lc stmts method_names _) res_ty - = zapExpectedType res_ty `thenM` \ res_ty' -> - -- All comprehensions yield a monotype + = zapExpectedType res_ty liftedTypeKind `thenM` \ res_ty' -> + -- All comprehensions yield a monotype of kind * tcDoStmts do_or_lc stmts method_names res_ty' `thenM` \ (stmts', methods') -> returnM (HsDo do_or_lc stmts' methods' res_ty') @@ -989,10 +991,6 @@ caseCtxt expr caseScrutCtxt expr = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr) -exprSigCtxt expr - = hang (ptext SLIT("In the type signature of the expression:")) - 4 (ppr expr) - exprCtxt expr = hang (ptext SLIT("In the expression:")) 4 (ppr expr) diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index b5b08f3..e18a485 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -27,7 +27,7 @@ import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) import TcExpr ( tcCheckSigma ) import ErrUtils ( Message ) -import Id ( Id, mkLocalId, setIdLocalExported ) +import Id ( Id, mkLocalId, mkExportedLocalId ) import OccName ( mkForeignExportOcc ) import Name ( Name, NamedThing(..), mkExternalName ) import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, @@ -220,7 +220,7 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty spec isDeprec) = let gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) Nothing (srcSpanStart loc) - id = setIdLocalExported (mkLocalId gnm sig_ty) + id = mkExportedLocalId gnm sig_ty bind = L loc (VarBind id rhs) in returnM (bind, ForeignExport (L loc id) undefined spec isDeprec) diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 5e3c774..df44a06 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -37,8 +37,8 @@ import Id ( idType, setIdType, Id ) import TcRnMonad import Type ( Type ) -import TcType ( TcType, TcTyVar, eqKind, isTypeKind, mkTyVarTy, - tcGetTyVar, isAnyTypeKind, mkTyConApp ) +import TcType ( TcType, TcTyVar, mkTyVarTy, tcGetTyVar, mkTyConApp ) +import Kind ( isLiftedTypeKind, liftedTypeKind, isSubKind ) import qualified Type import TcMType ( zonkTcTyVarToTyVar, zonkType, zonkTcType, zonkTcTyVars, putTcTyVar ) @@ -49,6 +49,7 @@ import TysWiredIn ( charTy, stringTy, intTy, mkListTy, mkPArrTy, mkTupleTy, unitTy, voidTy, listTyCon, tupleTyCon ) import TyCon ( mkPrimTyCon, tyConKind ) +import Kind ( splitKindFunTys ) import PrimRep ( PrimRep(VoidRep) ) import Name ( getOccName, mkInternalName, mkDerivedTyConOcc ) import Var ( Var, isId, isLocalVar, tyVarKind ) @@ -914,16 +915,16 @@ mkArbitraryType :: TcTyVar -> Type -- Make up an arbitrary type whose kind is the same as the tyvar. -- We'll use this to instantiate the (unbound) tyvar. mkArbitraryType tv - | isAnyTypeKind kind = voidTy -- The vastly common case - | otherwise = mkTyConApp tycon [] + | liftedTypeKind `isSubKind` kind = voidTy -- The vastly common case + | otherwise = mkTyConApp tycon [] where kind = tyVarKind tv - (args,res) = Type.splitFunTys kind -- Kinds are simple; use Type.splitFunTys + (args,res) = splitKindFunTys kind - tycon | kind `eqKind` tyConKind listTyCon -- *->* + tycon | kind == tyConKind listTyCon -- *->* = listTyCon -- No tuples this size - | all isTypeKind args && isTypeKind res + | all isLiftedTypeKind args && isLiftedTypeKind res = tupleTyCon Boxed (length args) -- *-> ... ->*->* | otherwise diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs index 757097c..3ed5555 100644 --- a/ghc/compiler/typecheck/TcHsType.lhs +++ b/ghc/compiler/typecheck/TcHsType.lhs @@ -28,24 +28,23 @@ import RnHsSyn ( extractHsTyVars ) import TcHsSyn ( TcId ) import TcRnMonad -import TcEnv ( tcExtendTyVarEnv, tcExtendTyVarKindEnv, +import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv, tcLookup, tcLookupClass, tcLookupTyCon, TyThing(..), TcTyThing(..), - getInLocalScope + getInLocalScope, wrongThingErr ) -import TcMType ( newKindVar, newOpenTypeKind, tcInstType, newMutTyVar, - zonkTcType, zonkTcKindToKind, +import TcMType ( newKindVar, tcInstType, newMutTyVar, + zonkTcKindToKind, checkValidType, UserTypeCtxt(..), pprHsSigCtxt ) -import TcUnify ( unifyKind, unifyFunKind ) +import TcUnify ( unifyFunKind, checkExpectedKind ) import TcType ( Type, PredType(..), ThetaType, TyVarDetails(..), TcTyVar, TcKind, TcThetaType, TcTauType, - mkTyVarTy, mkTyVarTys, mkFunTy, isTypeKind, + mkTyVarTy, mkTyVarTys, mkFunTy, mkForAllTys, mkFunTys, tcEqType, isPredTy, mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys, - liftedTypeKind, unliftedTypeKind, eqKind, - tcSplitFunTy_maybe, tcSplitForAllTys, pprKind ) -import qualified Type ( splitFunTys ) + tcSplitFunTy_maybe, tcSplitForAllTys ) +import Kind ( liftedTypeKind, ubxTupleKind, openTypeKind, argTypeKind ) import Inst ( Inst, InstOrigin(..), newMethod, instToId ) import Id ( mkLocalId, idName, idType ) @@ -207,26 +206,20 @@ kcLiftedType ty = kcCheckHsType ty liftedTypeKind --------------------------- kcTypeType :: LHsType Name -> TcM (LHsType Name) --- The type ty must be a *type*, but it can be lifted or unlifted --- Be sure to use checkExpectedKind, rather than simply unifying --- with (Type bx), because it gives better error messages -kcTypeType ty - = kcHsType ty `thenM` \ (ty', kind) -> - if isTypeKind kind then - return ty' - else - newOpenTypeKind `thenM` \ type_kind -> - traceTc (text "kcTypeType" $$ nest 2 (ppr ty $$ ppr ty' $$ ppr kind $$ ppr type_kind)) `thenM_` - checkExpectedKind ty kind type_kind `thenM_` - returnM ty' +-- The type ty must be a *type*, but it can be lifted or +-- unlifted or an unboxed tuple. +kcTypeType ty = kcCheckHsType ty openTypeKind --------------------------- kcCheckHsType :: LHsType Name -> TcKind -> TcM (LHsType Name) -- Check that the type has the specified kind -kcCheckHsType ty exp_kind - = kcHsType ty `thenM` \ (ty', act_kind) -> +-- Be sure to use checkExpectedKind, rather than simply unifying +-- with OpenTypeKind, because it gives better error messages +kcCheckHsType (L span ty) exp_kind + = addSrcSpan span $ + kc_hs_type ty `thenM` \ (ty', act_kind) -> checkExpectedKind ty act_kind exp_kind `thenM_` - returnM ty' + returnM (L span ty') \end{code} Here comes the main function @@ -276,11 +269,11 @@ kc_hs_type (HsTupleTy Boxed tys) kc_hs_type (HsTupleTy Unboxed tys) = mappM kcTypeType tys `thenM` \ tys' -> - returnM (HsTupleTy Unboxed tys', unliftedTypeKind) + returnM (HsTupleTy Unboxed tys', ubxTupleKind) kc_hs_type (HsFunTy ty1 ty2) - = kcTypeType ty1 `thenM` \ ty1' -> - kcTypeType ty2 `thenM` \ ty2' -> + = kcCheckHsType ty1 argTypeKind `thenM` \ ty1' -> + kcTypeType ty2 `thenM` \ ty2' -> returnM (HsFunTy ty1' ty2', liftedTypeKind) kc_hs_type ty@(HsOpTy ty1 op ty2) @@ -345,10 +338,11 @@ kcApps fun_kind ppr_fun args kcHsContext :: LHsContext Name -> TcM (LHsContext Name) kcHsContext ctxt = wrapLocM (mappM kcHsPred) ctxt -kcHsPred pred -- Checks that the result is of kind liftedType - = wrapLocFstM kc_pred pred `thenM` \ (pred', kind) -> +kcHsPred (L span pred) -- Checks that the result is of kind liftedType + = addSrcSpan span $ + kc_pred pred `thenM` \ (pred', kind) -> checkExpectedKind pred kind liftedTypeKind `thenM_` - returnM pred' + returnM (L span pred') --------------------------- kc_pred :: HsPred Name -> TcM (HsPred Name, TcKind) @@ -366,81 +360,24 @@ kc_pred pred@(HsClassP cls tys) --------------------------- kcTyVar :: Name -> TcM TcKind kcTyVar name -- Could be a tyvar or a tycon - = tcLookup name `thenM` \ thing -> + = traceTc (text "lk1" <+> ppr name) `thenM_` + tcLookup name `thenM` \ thing -> + traceTc (text "lk2" <+> ppr name <+> ppr thing) `thenM_` case thing of ATyVar tv -> returnM (tyVarKind tv) - ARecTyCon kind -> returnM kind + AThing kind -> returnM kind AGlobal (ATyCon tc) -> returnM (tyConKind tc) - other -> failWithTc (wrongThingErr "type" thing name) + other -> wrongThingErr "type" thing name kcClass :: Name -> TcM TcKind kcClass cls -- Must be a class = tcLookup cls `thenM` \ thing -> case thing of - ARecClass kind -> returnM kind + AThing kind -> returnM kind AGlobal (AClass cls) -> returnM (tyConKind (classTyCon cls)) - other -> failWithTc (wrongThingErr "class" thing cls) + other -> wrongThingErr "class" thing cls \end{code} - Helper functions - - -\begin{code} ---------------------------- --- We would like to get a decent error message from --- (a) Under-applied type constructors --- f :: (Maybe, Maybe) --- (b) Over-applied type constructors --- f :: Int x -> Int x --- - - -checkExpectedKind :: Outputable a => Located a -> TcKind -> TcKind -> TcM TcKind --- A fancy wrapper for 'unifyKind', which tries to give --- decent error messages. --- Returns the same kind that it is passed, exp_kind -checkExpectedKind (L span ty) act_kind exp_kind - | act_kind `eqKind` exp_kind -- Short cut for a very common case - = returnM exp_kind - | otherwise - = tryTc (unifyKind exp_kind act_kind) `thenM` \ (errs, mb_r) -> - case mb_r of { - Just _ -> returnM exp_kind ; -- Unification succeeded - Nothing -> - - -- So there's definitely an error - -- Now to find out what sort - addSrcSpan span $ - zonkTcType exp_kind `thenM` \ exp_kind -> - zonkTcType act_kind `thenM` \ act_kind -> - - let (exp_as, _) = Type.splitFunTys exp_kind - (act_as, _) = Type.splitFunTys act_kind - -- Use the Type versions for kinds - n_exp_as = length exp_as - n_act_as = length act_as - - err | n_exp_as < n_act_as -- E.g. [Maybe] - = quotes (ppr ty) <+> ptext SLIT("is not applied to enough type arguments") - - -- Now n_exp_as >= n_act_as. In the next two cases, - -- n_exp_as == 0, and hence so is n_act_as - | exp_kind `eqKind` liftedTypeKind && act_kind `eqKind` unliftedTypeKind - = ptext SLIT("Expecting a lifted type, but") <+> quotes (ppr ty) - <+> ptext SLIT("is unlifted") - - | exp_kind `eqKind` unliftedTypeKind && act_kind `eqKind` liftedTypeKind - = ptext SLIT("Expecting an unlifted type, but") <+> quotes (ppr ty) - <+> ptext SLIT("is lifted") - - | otherwise -- E.g. Monad [Int] - = sep [ ptext SLIT("Expecting kind") <+> quotes (pprKind exp_kind) <> comma, - ptext SLIT("but") <+> quotes (ppr ty) <+> - ptext SLIT("has kind") <+> quotes (pprKind act_kind)] - in - failWithTc (ptext SLIT("Kind error:") <+> err) - } -\end{code} %************************************************************************ %* * @@ -533,7 +470,7 @@ ds_var_app name arg_tys case thing of ATyVar tv -> returnM (mkAppTys (mkTyVarTy tv) arg_tys) AGlobal (ATyCon tc) -> returnM (mkGenTyConApp tc arg_tys) - ARecTyCon _ -> tcLookupTyCon name `thenM` \ tc -> + AThing _ -> tcLookupTyCon name `thenM` \ tc -> returnM (mkGenTyConApp tc arg_tys) other -> pprPanic "ds_app_type" (ppr name <+> ppr arg_tys) \end{code} @@ -570,8 +507,8 @@ kcHsTyVars :: [LHsTyVarBndr Name] -> TcM r kcHsTyVars tvs thing_inside = mappM (wrapLocM kcHsTyVar) tvs `thenM` \ bndrs -> - tcExtendTyVarKindEnv bndrs $ - thing_inside bndrs + tcExtendKindEnv [(n,k) | L _ (KindedTyVar n k) <- bndrs] + (thing_inside bndrs) kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name) -- Return a *kind-annotated* binder, and a tyvar with a mutable kind in it @@ -823,23 +760,3 @@ hoistForAllTys ty | otherwise = ([], [], ty) \end{code} - -%************************************************************************ -%* * -\subsection{Errors and contexts} -%* * -%************************************************************************ - -\begin{code} -wrongThingErr expected thing name - = pp_thing thing <+> quotes (ppr name) <+> ptext SLIT("used as a") <+> text expected - where - pp_thing (AGlobal (ATyCon _)) = ptext SLIT("Type constructor") - pp_thing (AGlobal (AClass _)) = ptext SLIT("Class") - pp_thing (AGlobal (AnId _)) = ptext SLIT("Identifier") - pp_thing (AGlobal (ADataCon _)) = ptext SLIT("Data constructor") - pp_thing (ATyVar _) = ptext SLIT("Type variable") - pp_thing (ATcId _ _ _) = ptext SLIT("Local identifier") - pp_thing (ARecTyCon _) = ptext SLIT("Rec tycon") - pp_thing (ARecClass _) = ptext SLIT("Rec class") -\end{code} diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index 174f965..da54294 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -14,7 +14,7 @@ module TcMType ( newTyVar, newSigTyVar, newTyVarTy, -- Kind -> TcM TcType newTyVarTys, -- Int -> Kind -> TcM [TcType] - newKindVar, newKindVars, newOpenTypeKind, + newKindVar, newKindVars, putTcTyVar, getTcTyVar, newMutTyVar, readMutTyVar, writeMutTyVar, @@ -35,7 +35,9 @@ module TcMType ( zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType, zonkTcPredType, zonkTcTyVarToTyVar, - zonkTcKindToKind + zonkTcKindToKind, zonkTcKind, + + readKindVar, writeKindVar ) where @@ -49,31 +51,31 @@ import TypeRep ( Type(..), PredType(..), TyNote(..), -- Friend; can see repres ) import TcType ( TcType, TcThetaType, TcTauType, TcPredType, TcTyVarSet, TcKind, TcTyVar, TyVarDetails(..), - tcEqType, tcCmpPred, isClassPred, mkTyConApp, typeCon, + tcEqType, tcCmpPred, isClassPred, tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, tcSplitTyConApp_maybe, tcSplitForAllTys, tcIsTyVarTy, tcSplitSigmaTy, tcIsTyVarTy, isUnLiftedType, isIPPred, - + typeKind, mkAppTy, mkTyVarTy, mkTyVarTys, tyVarsOfPred, getClassPredTys_maybe, - - liftedTypeKind, defaultKind, superKind, - superBoxity, liftedBoxity, typeKind, tyVarsOfType, tyVarsOfTypes, - eqKind, isTypeKind, pprPred, pprTheta, pprClassPred ) +import Kind ( Kind(..), KindVar(..), mkKindVar, + isLiftedTypeKind, isArgTypeKind, isOpenTypeKind, + liftedTypeKind + ) import Subst ( Subst, mkTopTyVarSubst, substTy ) import Class ( Class, classArity, className ) import TyCon ( TyCon, isSynTyCon, isUnboxedTupleTyCon, tyConArity, tyConName ) import Var ( TyVar, tyVarKind, tyVarName, isTyVar, - mkTyVar, mkMutTyVar, isMutTyVar, mutTyVarRef ) + mkTyVar, mkTcTyVar, tcTyVarRef, isTcTyVar ) -- others: import TcRnMonad -- TcType, amongst others import FunDeps ( grow ) -import Name ( Name, setNameUnique, mkSystemTvNameEncoded ) +import Name ( Name, setNameUnique, mkSysTvName ) import VarSet import CmdLineOpts ( dopt, DynFlag(..) ) import Util ( nOfThem, isSingleton, equalLength, notNull ) @@ -93,23 +95,23 @@ import Outputable newMutTyVar :: Name -> Kind -> TyVarDetails -> TcM TyVar newMutTyVar name kind details = do { ref <- newMutVar Nothing ; - return (mkMutTyVar name kind details ref) } + return (mkTcTyVar name kind details ref) } readMutTyVar :: TyVar -> TcM (Maybe Type) -readMutTyVar tyvar = readMutVar (mutTyVarRef tyvar) +readMutTyVar tyvar = readMutVar (tcTyVarRef tyvar) writeMutTyVar :: TyVar -> Maybe Type -> TcM () -writeMutTyVar tyvar val = writeMutVar (mutTyVarRef tyvar) val +writeMutTyVar tyvar val = writeMutVar (tcTyVarRef tyvar) val newTyVar :: Kind -> TcM TcTyVar newTyVar kind = newUnique `thenM` \ uniq -> - newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("t")) kind VanillaTv + newMutTyVar (mkSysTvName uniq FSLIT("t")) kind VanillaTv newSigTyVar :: Kind -> TcM TcTyVar newSigTyVar kind = newUnique `thenM` \ uniq -> - newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("s")) kind SigTv + newMutTyVar (mkSysTvName uniq FSLIT("s")) kind SigTv newTyVarTy :: Kind -> TcM TcType newTyVarTy kind @@ -120,23 +122,12 @@ newTyVarTys :: Int -> Kind -> TcM [TcType] newTyVarTys n kind = mappM newTyVarTy (nOfThem n kind) newKindVar :: TcM TcKind -newKindVar - = newUnique `thenM` \ uniq -> - newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("k")) superKind VanillaTv `thenM` \ kv -> - returnM (TyVarTy kv) +newKindVar = do { uniq <- newUnique + ; ref <- newMutVar Nothing + ; return (KindVar (mkKindVar uniq ref)) } newKindVars :: Int -> TcM [TcKind] newKindVars n = mappM (\ _ -> newKindVar) (nOfThem n ()) - -newBoxityVar :: TcM TcKind -- Really TcBoxity - = newUnique `thenM` \ uniq -> - newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("bx")) - superBoxity VanillaTv `thenM` \ kv -> - returnM (TyVarTy kv) - -newOpenTypeKind :: TcM TcKind -newOpenTypeKind = newBoxityVar `thenM` \ bx_var -> - returnM (mkTyConApp typeCon [bx_var]) \end{code} @@ -211,12 +202,12 @@ Putting is easy: \begin{code} putTcTyVar tyvar ty - | not (isMutTyVar tyvar) + | not (isTcTyVar tyvar) = pprTrace "putTcTyVar" (ppr tyvar) $ returnM ty | otherwise - = ASSERT( isMutTyVar tyvar ) + = ASSERT( isTcTyVar tyvar ) writeMutTyVar tyvar (Just ty) `thenM_` returnM ty \end{code} @@ -235,12 +226,12 @@ We return Nothing iff the original box was unbound. \begin{code} getTcTyVar tyvar - | not (isMutTyVar tyvar) + | not (isTcTyVar tyvar) = pprTrace "getTcTyVar" (ppr tyvar) $ returnM (Just (mkTyVarTy tyvar)) | otherwise - = ASSERT2( isMutTyVar tyvar, ppr tyvar ) + = ASSERT2( isTcTyVar tyvar, ppr tyvar ) readMutTyVar tyvar `thenM` \ maybe_ty -> case maybe_ty of Just ty -> short_out ty `thenM` \ ty' -> @@ -251,7 +242,7 @@ getTcTyVar tyvar short_out :: TcType -> TcM TcType short_out ty@(TyVarTy tyvar) - | not (isMutTyVar tyvar) + | not (isTcTyVar tyvar) = returnM ty | otherwise @@ -317,18 +308,6 @@ zonkTcPredType (IParam n t) are used at the end of type checking \begin{code} -zonkTcKindToKind :: TcKind -> TcM Kind -zonkTcKindToKind tc_kind - = zonkType zonk_unbound_kind_var tc_kind - where - -- When zonking a kind, we want to - -- zonk a *kind* variable to (Type *) - -- zonk a *boxity* variable to * - zonk_unbound_kind_var kv - | tyVarKind kv `eqKind` superKind = putTcTyVar kv liftedTypeKind - | tyVarKind kv `eqKind` superBoxity = putTcTyVar kv liftedBoxity - | otherwise = pprPanic "zonkKindEnv" (ppr kv) - -- zonkTcTyVarToTyVar is applied to the *binding* occurrence -- of a type variable, at the *end* of type checking. It changes -- the *mutable* type variable into an *immutable* one. @@ -342,7 +321,8 @@ zonkTcTyVarToTyVar tv = let -- Make an immutable version, defaulting -- the kind to lifted if necessary - immut_tv = mkTyVar (tyVarName tv) (defaultKind (tyVarKind tv)) + immut_tv = mkTyVar (tyVarName tv) (tyVarKind tv) + -- was: defaultKind (tyVarKind tv), but I don't immut_tv_ty = mkTyVarTy immut_tv zap tv = putTcTyVar tv immut_tv_ty @@ -401,8 +381,6 @@ All very silly. I think its harmless to ignore the problem. %************************************************************************ \begin{code} --- zonkType is used for Kinds as well - -- For unbound, mutable tyvars, zonkType uses the function given to it -- For tyvars bound at a for-all, zonkType zonks them to an immutable -- type variable and zonks the kind too @@ -455,7 +433,7 @@ zonkType unbound_var_fn ty zonkTyVar :: (TcTyVar -> TcM Type) -- What to do for an unbound mutable variable -> TcTyVar -> TcM TcType zonkTyVar unbound_var_fn tyvar - | not (isMutTyVar tyvar) -- Not a mutable tyvar. This can happen when + | not (isTcTyVar tyvar) -- Not a mutable tyvar. This can happen when -- zonking a forall type, when the bound type variable -- needn't be mutable = ASSERT( isTyVar tyvar ) -- Should not be any immutable kind vars @@ -472,6 +450,44 @@ zonkTyVar unbound_var_fn tyvar %************************************************************************ %* * + Zonking kinds +%* * +%************************************************************************ + +\begin{code} +readKindVar :: KindVar -> TcM (Maybe TcKind) +writeKindVar :: KindVar -> TcKind -> TcM () +readKindVar (KVar _ ref) = readMutVar ref +writeKindVar (KVar _ ref) val = writeMutVar ref (Just val) + +------------- +zonkTcKind :: TcKind -> TcM TcKind +zonkTcKind (FunKind k1 k2) = do { k1' <- zonkTcKind k1 + ; k2' <- zonkTcKind k2 + ; returnM (FunKind k1' k2') } +zonkTcKind k@(KindVar kv) = do { mb_kind <- readKindVar kv + ; case mb_kind of + Nothing -> returnM k + Just k -> zonkTcKind k } +zonkTcKind other_kind = returnM other_kind + +------------- +zonkTcKindToKind :: TcKind -> TcM Kind +zonkTcKindToKind (FunKind k1 k2) = do { k1' <- zonkTcKindToKind k1 + ; k2' <- zonkTcKindToKind k2 + ; returnM (FunKind k1' k2') } + +zonkTcKindToKind (KindVar kv) = do { mb_kind <- readKindVar kv + ; case mb_kind of + Nothing -> return liftedTypeKind + Just k -> zonkTcKindToKind k } + +zonkTcKindToKind OpenTypeKind = returnM liftedTypeKind -- An "Open" kind defaults to * +zonkTcKindToKind other_kind = returnM other_kind +\end{code} + +%************************************************************************ +%* * \subsection{Checking a user type} %* * %************************************************************************ @@ -573,13 +589,13 @@ checkValidType ctxt ty actual_kind = typeKind ty - actual_kind_is_lifted = actual_kind `eqKind` liftedTypeKind - kind_ok = case ctxt of TySynCtxt _ -> True -- Any kind will do - GenPatCtxt -> actual_kind_is_lifted - ForSigCtxt _ -> actual_kind_is_lifted - other -> isTypeKind actual_kind + ResSigCtxt -> isOpenTypeKind actual_kind + ExprSigCtxt -> isOpenTypeKind actual_kind + GenPatCtxt -> isLiftedTypeKind actual_kind + ForSigCtxt _ -> isLiftedTypeKind actual_kind + other -> isArgTypeKind actual_kind ubx_tup | not gla_exts = UT_NotOk | otherwise = case ctxt of @@ -706,8 +722,8 @@ check_tau_type rank ubx_tup ty@(TyConApp tc tys) = doptM Opt_GlasgowExts `thenM` \ gla_exts -> checkTc (ubx_tup_ok gla_exts) ubx_tup_msg `thenM_` mappM_ (check_tau_type (Rank 0) UT_Ok) tys - -- Args are allowed to be unlifted, or - -- more unboxed tuples, so can't use check_arg_ty + -- Args are allowed to be unlifted, or + -- more unboxed tuples, so can't use check_arg_ty | otherwise = mappM_ check_arg_type tys diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 12a59d7..05797f5 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -32,7 +32,7 @@ import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendLocalValEnv, tcExten import TcPat ( tcPat, tcMonoPatBndr ) import TcMType ( newTyVarTy, newTyVarTys, zonkTcType ) import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType, - tyVarsOfTypes, tidyOpenTypes, isSigmaTy, + tyVarsOfTypes, tidyOpenTypes, isSigmaTy, typeKind, mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind, mkArrowKind, mkAppTy ) import TcBinds ( tcBindsAndThen ) @@ -103,10 +103,8 @@ tcMatchesCase :: TcMatchCtxt -- Case context [LMatch TcId]) -- Translated alternatives tcMatchesCase ctxt matches (Check expr_ty) - = -- This case is a bit yukky, because it prevents the - -- scrutinee being higher-ranked, which might just possible - -- matter if we were seq'ing on it. But it's awkward to fix. - newTyVarTy openTypeKind `thenM` \ scrut_ty -> + = newTyVarTy openTypeKind `thenM` \ scrut_ty -> + -- openTypeKind because the scrutinee can be an unboxed type tcMatches ctxt matches (Check (mkFunTy scrut_ty expr_ty)) `thenM` \ matches' -> returnM (scrut_ty, matches') @@ -231,7 +229,7 @@ tcGRHSs ctxt (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs)])] binds _) exp_ty tcGRHSs ctxt (GRHSs grhss binds _) exp_ty = tcBindsAndThen glueBindsOnGRHSs binds $ - zapExpectedType exp_ty `thenM` \ exp_ty' -> + zapExpectedType exp_ty openTypeKind `thenM` \ exp_ty' -> -- Even if there is only one guard, we zap the RHS type to -- a monotype. Reason: it makes tcStmts much easier, -- and even a one-armed guard has a notional second arm @@ -333,6 +331,8 @@ tc_match_pats ((pat,pat_ty):pats) thing_inside -- of the existential Ids used in checkExistentialPat in tcExtendLocalValEnv2 xve $ + traceTc (text "tc_match_pats" <+> (ppr xve $$ ppr (map (idType . snd) xve) $$ + ppr (map (typeKind . idType . snd) xve))) `thenM_` tc_match_pats pats thing_inside `thenM` \ (pats', exs_tvs, exs_ids, exs_lie, answer) -> returnM ( pat':pats', ex_tvs `unionBags` exs_tvs, @@ -521,7 +521,7 @@ tcStmtAndThen combine ctxt (L src_loc stmt@(ExprStmt exp _)) thing_inside addErrCtxt (stmtCtxt ctxt stmt) $ if isDoExpr (sc_what ctxt) then -- do or mdo; the expression is a computation - newTyVarTy openTypeKind `thenM` \ any_ty -> + newTyVarTy liftedTypeKind `thenM` \ any_ty -> sc_rhs ctxt exp any_ty `thenM` \ exp' -> returnM (L src_loc (ExprStmt exp' any_ty)) else -- List comprehensions, pattern guards; expression is a boolean diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index cf0ec11..24cc1de 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -26,8 +26,8 @@ import Name ( Name ) import FieldLabel ( fieldLabelName ) import TcEnv ( tcLookupClass, tcLookupLocatedDataCon, tcLookupId ) import TcMType ( newTyVarTy, arityErr ) -import TcType ( TcType, TcTyVar, TcSigmaType, - mkClassPred, liftedTypeKind ) +import TcType ( TcType, TcTyVar, TcSigmaType, mkClassPred ) +import Kind ( argTypeKind, liftedTypeKind ) import TcUnify ( tcSubOff, Expected(..), readExpectedType, zapExpectedType, unifyTauTy, zapToListTy, zapToPArrTy, zapToTupleTy ) import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) @@ -69,7 +69,7 @@ tcMonoPatBndr :: BinderChecker -- so there's no polymorphic guy to worry about tcMonoPatBndr binder_name pat_ty - = zapExpectedType pat_ty `thenM` \ pat_ty' -> + = zapExpectedType pat_ty argTypeKind `thenM` \ pat_ty' -> -- If there are *no constraints* on the pattern type, we -- revert to good old H-M typechecking, making -- the type of the binder into an *ordinary* @@ -146,9 +146,16 @@ tc_pat tc_bndr pat_in@(AsPat (L nm_loc name) pat) pat_ty tvs, (name, bndr_id) `consBag` ids, lie_avail) tc_pat tc_bndr (WildPat _) pat_ty - = zapExpectedType pat_ty `thenM` \ pat_ty' -> + = zapExpectedType pat_ty argTypeKind `thenM` \ pat_ty' -> -- We might have an incoming 'hole' type variable; no annotation -- so zap it to a type. Rather like tcMonoPatBndr. + -- Note argTypeKind, so that + -- f _ = 3 + -- is rejected when f applied to an unboxed tuple + -- However, this means that + -- (case g x of _ -> ...) + -- is rejected g returns an unboxed tuple, which is perhpas + -- annoying. I suppose we could pass the context into tc_pat... returnM (WildPat pat_ty', emptyBag, emptyBag, []) tc_pat tc_bndr (ParPat parend_pat) pat_ty @@ -248,19 +255,19 @@ tc_pat tc_bndr pat_in@(ConPatIn con_name arg_pats) pat_ty \begin{code} tc_pat tc_bndr pat@(LitPat lit@(HsString _)) pat_ty - = zapExpectedType pat_ty `thenM` \ pat_ty' -> - unifyTauTy pat_ty' stringTy `thenM_` - tcLookupId eqStringName `thenM` \ eq_id -> + = zapExpectedType pat_ty liftedTypeKind `thenM` \ pat_ty' -> + unifyTauTy pat_ty' stringTy `thenM_` + tcLookupId eqStringName `thenM` \ eq_id -> returnM (NPatOut lit stringTy (nlHsVar eq_id `HsApp` nlHsLit lit), emptyBag, emptyBag, []) tc_pat tc_bndr (LitPat simple_lit) pat_ty - = zapExpectedType pat_ty `thenM` \ pat_ty' -> + = zapExpectedType pat_ty argTypeKind `thenM` \ pat_ty' -> unifyTauTy pat_ty' (hsLitType simple_lit) `thenM_` returnM (LitPat simple_lit, emptyBag, emptyBag, []) tc_pat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty - = zapExpectedType pat_ty `thenM` \ pat_ty' -> + = zapExpectedType pat_ty liftedTypeKind `thenM` \ pat_ty' -> newOverloadedLit origin over_lit pat_ty' `thenM` \ pos_lit_expr -> newMethodFromName origin pat_ty' eqName `thenM` \ eq -> (case mb_neg of diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 7b0a63d..d0e45d5 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -50,7 +50,7 @@ import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec ) import PprCore ( pprIdRules, pprCoreBindings ) import CoreSyn ( IdCoreRule, bindersOfBinds ) import ErrUtils ( mkDumpDoc, showPass ) -import Id ( mkLocalId, isLocalId, idName, idType, setIdLocalExported ) +import Id ( mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) import Module ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts ) import OccName ( mkVarOcc ) @@ -933,7 +933,7 @@ check_main ghci_mode tcg_env main_mod main_fn ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $ tcInferRho rhs - ; let { root_main_id = setIdLocalExported (mkLocalId rootMainName ty) ; + ; let { root_main_id = mkExportedLocalId rootMainName ty ; main_bind = noLoc (VarBind root_main_id main_expr) } ; return (tcg_env { tcg_binds = tcg_binds tcg_env diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 52cb3a7..54b4550 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -27,7 +27,7 @@ import InstEnv ( InstEnv, emptyInstEnv, extendInstEnv ) import VarSet ( emptyVarSet ) import VarEnv ( TidyEnv, emptyTidyEnv ) import ErrUtils ( Message, Messages, emptyMessages, errorsFound, - mkErrMsg, mkWarnMsg, printErrorsAndWarnings ) + mkErrMsg, mkWarnMsg, printErrorsAndWarnings, mkLocMessage ) import SrcLoc ( mkGeneralSrcSpan, SrcSpan, Located(..) ) import NameEnv ( emptyNameEnv ) import NameSet ( emptyDUs, emptyNameSet ) @@ -309,7 +309,12 @@ dumpOptIf flag doc = ifOptM flag $ ioToIOEnv (printForUser stderr alwaysQualify doc) dumpOptTcRn :: DynFlag -> SDoc -> TcRn () -dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) +dumpOptTcRn flag doc = ifOptM flag $ do + { ctxt <- getErrCtxt + ; loc <- getSrcSpanM + ; ctxt_msgs <- do_ctxt emptyTidyEnv ctxt + ; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs)) + ; dumpTcRn real_doc } dumpTcRn :: SDoc -> TcRn () dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 14eae9b..9237f8b 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -353,15 +353,14 @@ data TcTyThing = AGlobal TyThing -- Used only in the return type of a lookup | ATcId TcId ThLevel ProcLevel -- Ids defined in this module; may not be fully zonked | ATyVar TyVar -- Type variables - | ARecTyCon TcKind -- Used temporarily, during kind checking, for the - | ARecClass TcKind -- tycons and clases in this recursive group + | AThing TcKind -- Used temporarily, during kind checking, for the + -- tycons and clases in this recursive group instance Outputable TcTyThing where -- Debugging only ppr (AGlobal g) = text "AGlobal" <+> ppr g ppr (ATcId g tl pl) = text "ATcId" <+> ppr g <+> ppr tl <+> ppr pl ppr (ATyVar t) = text "ATyVar" <+> ppr t - ppr (ARecTyCon k) = text "ARecTyCon" <+> ppr k - ppr (ARecClass k) = text "ARecClass" <+> ppr k + ppr (AThing k) = text "AThing" <+> ppr k \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 36a7220..5b901b7 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -17,7 +17,6 @@ import qualified Language.Haskell.TH.THSyntax as TH import qualified Language.Haskell.TH.THLib as TH -- THSyntax gives access to internal functions and data types -import HscTypes ( HscEnv(..) ) import HsSyn ( HsBracket(..), HsExpr(..), HsSplice(..), LHsExpr, LHsDecl, HsType, LHsType ) import Convert ( convertToHsExpr, convertToHsDecls, convertToHsType ) @@ -29,7 +28,7 @@ import TcExpr ( tcCheckRho, tcMonoExpr ) import TcHsSyn ( mkHsLet, zonkTopLExpr ) import TcSimplify ( tcSimplifyTop, tcSimplifyBracket ) import TcUnify ( Expected, zapExpectedTo, zapExpectedType ) -import TcType ( TcType, TcKind, openTypeKind, mkAppTy, tcSplitSigmaTy ) +import TcType ( TcType, TcKind, liftedTypeKind, mkAppTy, tcSplitSigmaTy ) import TcEnv ( spliceOK, tcMetaTy, bracketOK, tcLookup ) import TcMType ( newTyVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar ) import TcHsType ( tcHsSigType, kcHsType ) @@ -37,7 +36,6 @@ import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName, mkInternalName ) import OccName import Var ( Id, TyVar, idType ) -import RdrName ( RdrName ) import Module ( moduleUserString, mkModuleName ) import TcRnMonad import IfaceEnv ( lookupOrig ) @@ -54,12 +52,10 @@ import ErrUtils ( Message ) import SrcLoc ( noLoc, unLoc, getLoc, noSrcLoc ) import Outputable import Unique ( Unique, Uniquable(..), getKey, mkUniqueGrimily ) -import IOEnv ( IOEnv ) + import BasicTypes ( StrictnessMark(..), Fixity(..), FixityDirection(..) ) -import Module ( moduleUserString ) import Panic ( showException ) -import FastString ( LitString, mkFastString ) -import FastTypes ( iBox ) +import FastString ( LitString ) import GHC.Base ( unsafeCoerce#, Int#, Int(..) ) -- Should have a better home in the module hierarchy import Monad ( liftM ) @@ -122,7 +118,7 @@ tc_bracket (VarBr v) -- Result type is Var (not Q-monadic) tc_bracket (ExpBr expr) - = newTyVarTy openTypeKind `thenM` \ any_ty -> + = newTyVarTy liftedTypeKind `thenM` \ any_ty -> tcCheckRho expr any_ty `thenM_` tcMetaTy expQTyConName -- Result type is Expr (= Q Exp) @@ -169,7 +165,7 @@ tcSpliceExpr (HsSplice name expr) res_ty -- Here (h 4) :: Q Exp -- but $(h 4) :: forall a.a i.e. anything! - zapExpectedType res_ty `thenM_` + zapExpectedType res_ty liftedTypeKind `thenM_` tcMetaTy expQTyConName `thenM` \ meta_exp_ty -> setStage (Splice next_level) ( setLIEVar lie_var $ diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 0d29681..5acb6a0 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -12,7 +12,7 @@ module TcTyClsDecls ( import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), ConDecl(..), Sig(..), BangType(..), HsBang(..), - tyClDeclTyVars, getBangType, getBangStrictness, + tyClDeclTyVars, getBangType, getBangStrictness, isSynDecl, LTyClDecl, tcdName, LHsTyVarBndr ) import BasicTypes ( RecFlag(..), NewOrData(..), StrictnessMark(..) ) @@ -21,11 +21,11 @@ import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon ) import TcRnMonad import TcEnv ( TcTyThing(..), TyThing(..), tcLookupLocated, tcLookupLocatedGlobal, - tcExtendGlobalEnv, + tcExtendGlobalEnv, tcExtendKindEnv, tcExtendRecEnv, tcLookupTyVar ) -import TcTyDecls ( calcTyConArgVrcs, calcRecFlags, calcCycleErrs ) +import TcTyDecls ( calcTyConArgVrcs, calcRecFlags, calcClassCycles, calcSynCycles ) import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) -import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsSigType, kcCheckHsType, +import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsSigType, kcHsType, kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext ) import TcMType ( newKindVar, checkValidTheta, checkValidType, checkFreeness, UserTypeCtxt(..), SourceTyCtxt(..) ) @@ -43,11 +43,13 @@ import TyCon ( TyCon, ArgVrcs, DataConDetails(..), import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels ) import Var ( TyVar, idType, idName ) import VarSet ( elemVarSet ) -import Name ( Name, getSrcLoc ) +import Name ( Name ) import Outputable import Util ( zipLazy, isSingleton, notNull ) -import SrcLoc ( srcLocSpan, Located(..), unLoc ) +import List ( partition ) +import SrcLoc ( Located(..), unLoc, getLoc ) import ListSetOps ( equivClasses ) +import Digraph ( SCC(..) ) import CmdLineOpts ( DynFlag( Opt_GlasgowExts, Opt_Generics, Opt_UnboxStrictFields ) ) \end{code} @@ -110,51 +112,51 @@ tcTyAndClassDecls decls -- See notes with checkCycleErrs checkCycleErrs decls - ; let { udecls = map unLoc decls } - ; tyclss <- fixM (\ rec_tyclss -> - do { lcl_things <- mappM getInitialKind udecls - -- Extend the local env with kinds, and - -- the global env with the knot-tied results - ; let { gbl_things = mkGlobalThings udecls rec_tyclss } - ; tcExtendRecEnv gbl_things lcl_things $ do - - -- The local type environment is populated with - -- {"T" -> ARecTyCon k, ...} - -- and the global type envt with - -- {"T" -> ATyCon T, ...} - -- where k is T's (unzonked) kind - -- T is the loop-tied TyCon itself - -- We must populate the environment with the loop-tied T's right - -- away, because the kind checker may "fault in" some type - -- constructors that recursively mention T - - -- Kind-check the declarations, returning kind-annotated decls - { kc_decls <- mappM kcTyClDecl decls - - -- Calculate variances and rec-flag - ; let { calc_vrcs = calcTyConArgVrcs rec_tyclss - ; calc_rec = calcRecFlags rec_tyclss } - - ; mappM (tcTyClDecl calc_vrcs calc_rec) kc_decls - }}) + ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) -> + do { let { -- Calculate variances and rec-flag + ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls } + + -- Extend the global env with the knot-tied results + -- for data types and classes + -- + -- We must populate the environment with the loop-tied T's right + -- away, because the kind checker may "fault in" some type + -- constructors that recursively mention T + ; let { gbl_things = mkGlobalThings alg_decls rec_alg_tyclss } + ; tcExtendRecEnv gbl_things $ do + + -- Kind-check the declarations + { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls + + ; let { calc_vrcs = calcTyConArgVrcs (rec_syn_tycons ++ rec_alg_tyclss) + ; calc_rec = calcRecFlags rec_alg_tyclss + ; tc_decl = addLocM (tcTyClDecl calc_vrcs calc_rec) } + -- Type-check the type synonyms, and extend the envt + ; syn_tycons <- tcSynDecls calc_vrcs kc_syn_decls + ; tcExtendGlobalEnv syn_tycons $ do + + -- Type-check the data types and classes + { alg_tyclss <- mappM tc_decl kc_alg_decls + ; return (syn_tycons, alg_tyclss) + }}}) -- Finished with knot-tying now -- Extend the environment with the finished things - ; tcExtendGlobalEnv tyclss $ do + ; tcExtendGlobalEnv (syn_tycons ++ alg_tyclss) $ do -- Perform the validity check { traceTc (text "ready for validity check") - ; mappM_ checkValidTyCl decls + ; mappM_ (addLocM checkValidTyCl) decls ; traceTc (text "done") -- Add the implicit things; -- we want them in the environment because -- they may be mentioned in interface files - ; let { implicit_things = concatMap implicitTyThings tyclss } - ; traceTc ((text "Adding" <+> ppr tyclss) $$ (text "and" <+> ppr implicit_things)) + ; let { implicit_things = concatMap implicitTyThings alg_tyclss } + ; traceTc ((text "Adding" <+> ppr alg_tyclss) $$ (text "and" <+> ppr implicit_things)) ; tcExtendGlobalEnv implicit_things getGblEnv }} -mkGlobalThings :: [TyClDecl Name] -- The decls +mkGlobalThings :: [LTyClDecl Name] -- The decls -> [TyThing] -- Knot-tied, in 1-1 correspondence with the decls -> [(Name,TyThing)] -- Driven by the Decls, and treating the TyThings lazily @@ -162,9 +164,9 @@ mkGlobalThings :: [TyClDecl Name] -- The decls mkGlobalThings decls things = map mk_thing (decls `zipLazy` things) where - mk_thing (ClassDecl {tcdLName = L _ name}, ~(AClass cl)) + mk_thing (L _ (ClassDecl {tcdLName = L _ name}), ~(AClass cl)) = (name, AClass cl) - mk_thing (decl, ~(ATyCon tc)) + mk_thing (L _ decl, ~(ATyCon tc)) = (tcdName decl, ATyCon tc) \end{code} @@ -188,40 +190,83 @@ Here, the kind of the locally-polymorphic type variable "b" depends on *all the uses of class D*. For example, the use of Monad c in bop's type signature means that D must have kind Type->Type. -\begin{code} ------------------------------------------------------------------------- -getInitialKind :: TyClDecl Name -> TcM (Name, TcTyThing) - --- Note the lazy pattern match on the ATyCon etc --- Exactly the same reason as the zipLay above - -getInitialKind (TyData {tcdLName = L _ name}) - = newKindVar `thenM` \ kind -> - returnM (name, ARecTyCon kind) - -getInitialKind (TySynonym {tcdLName = L _ name}) - = newKindVar `thenM` \ kind -> - returnM (name, ARecTyCon kind) - -getInitialKind (ClassDecl {tcdLName = L _ name}) - = newKindVar `thenM` \ kind -> - returnM (name, ARecClass kind) +However type synonyms work differently. They can have kinds which don't +just involve (->) and *: + type R = Int# -- Kind # + type S a = Array# a -- Kind * -> # + type T a b = (# a,b #) -- Kind * -> * -> (# a,b #) +So we must infer their kinds from their right-hand sides *first* and then +use them, whereas for the mutually recursive data types D we bring into +scope kind bindings D -> k, where k is a kind variable, and do inference. +\begin{code} +kcTyClDecls syn_decls alg_decls + = do { -- First extend the kind env with each data + -- type and class, mapping them to a type variable + alg_kinds <- mappM getInitialKind alg_decls + ; tcExtendKindEnv alg_kinds $ do + + -- Now kind-check the type synonyms, in dependency order + -- We do these differently to data type and classes, + -- because a type synonym can be an unboxed type + -- type Foo = Int# + -- and a kind variable can't unify with UnboxedTypeKind + -- So we infer their kinds in dependency order + { (kc_syn_decls, syn_kinds) <- kcSynDecls (calcSynCycles syn_decls) + ; tcExtendKindEnv syn_kinds $ do + + -- Now kind-check the data type and class declarations, + -- returning kind-annotated decls + { kc_alg_decls <- mappM (wrapLocM kcTyClDecl) alg_decls + + ; return (kc_syn_decls, kc_alg_decls) }}} ------------------------------------------------------------------------ -kcTyClDecl :: LTyClDecl Name -> TcM (LTyClDecl Name) +getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind) + +getInitialKind decl + = newKindVar `thenM` \ kind -> + returnM (unLoc (tcdLName (unLoc decl)), kind) + +---------------- +kcSynDecls :: [SCC (LTyClDecl Name)] + -> TcM ([LTyClDecl Name], -- Kind-annotated decls + [(Name,TcKind)]) -- Kind bindings +kcSynDecls [] + = return ([], []) +kcSynDecls (group : groups) + = do { (decl, nk) <- kcSynDecl group + ; (decls, nks) <- tcExtendKindEnv [nk] (kcSynDecls groups) + ; return (decl:decls, nk:nks) } + +---------------- +kcSynDecl :: SCC (LTyClDecl Name) + -> TcM (LTyClDecl Name, -- Kind-annotated decls + (Name,TcKind)) -- Kind bindings +kcSynDecl (AcyclicSCC ldecl@(L loc decl)) + = tcAddDeclCtxt decl $ + kcHsTyVars (tcdTyVars decl) (\ k_tvs -> + do { traceTc (text "kcd1" <+> ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl)) + <+> brackets (ppr k_tvs)) + ; (k_rhs, rhs_kind) <- kcHsType (tcdSynRhs decl) + ; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl))) + ; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs + ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }), + (unLoc (tcdLName decl), tc_kind)) }) + +kcSynDecl (CyclicSCC decls) + = do { recSynErr decls; failM } -- Fail here to avoid error cascade + -- of out-of-scope tycons -kcTyClDecl decl@(L loc d@(TySynonym {tcdSynRhs = rhs})) - = do { res_kind <- newKindVar - ; kcTyClDeclBody decl res_kind $ \ tvs' -> - do { rhs' <- kcCheckHsType rhs res_kind - ; return (L loc d{tcdTyVars = tvs', tcdSynRhs = rhs'}) } } +------------------------------------------------------------------------ +kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name) + -- Not used for type synonyms (see kcSynDecl) -kcTyClDecl decl@(L loc d@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})) - = kcTyClDeclBody decl liftedTypeKind $ \ tvs' -> +kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) + = kcTyClDeclBody decl $ \ tvs' -> do { ctxt' <- kcHsContext ctxt ; cons' <- mappM (wrapLocM kc_con_decl) cons - ; return (L loc d{tcdTyVars = tvs', tcdCtxt = ctxt', tcdCons = cons'}) } + ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdCons = cons'}) } where kc_con_decl (ConDecl name ex_tvs ex_ctxt details) = kcHsTyVars ex_tvs $ \ ex_tvs' -> @@ -247,35 +292,32 @@ kcTyClDecl decl@(L loc d@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = -- Can't allow an unlifted type for newtypes, because we're effectively -- going to remove the constructor while coercing it to a lifted type. -kcTyClDecl decl@(L loc d@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs})) - = kcTyClDeclBody decl liftedTypeKind $ \ tvs' -> +kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs}) + = kcTyClDeclBody decl $ \ tvs' -> do { ctxt' <- kcHsContext ctxt ; sigs' <- mappM (wrapLocM kc_sig) sigs - ; return (L loc d{tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) } + ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) } where kc_sig (Sig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty ; return (Sig nm op_ty') } kc_sig other_sig = return other_sig -kcTyClDecl decl@(L _ (ForeignType {})) +kcTyClDecl decl@(ForeignType {}) = return decl -kcTyClDeclBody :: LTyClDecl Name -> TcKind +kcTyClDeclBody :: TyClDecl Name -> ([LHsTyVarBndr Name] -> TcM a) -> TcM a -- Extend the env with bindings for the tyvars, taken from -- the kind of the tycon/class. Give it to the thing inside, and -- check the result kind matches -kcTyClDeclBody decl res_kind thing_inside +kcTyClDeclBody decl thing_inside = tcAddDeclCtxt decl $ - kcHsTyVars (tyClDeclTyVars (unLoc decl)) $ \ kinded_tvs -> - do { tc_ty_thing <- tcLookupLocated (tcdLName (unLoc decl)) - ; let { tc_kind = case tc_ty_thing of - ARecClass k -> k - ARecTyCon k -> k - } + kcHsTyVars (tyClDeclTyVars decl) $ \ kinded_tvs -> + do { tc_ty_thing <- tcLookupLocated (tcdLName decl) + ; let tc_kind = case tc_ty_thing of { AThing k -> k } ; unifyKind tc_kind (foldr (mkArrowKind . kindedTyVarKind) - res_kind kinded_tvs) + liftedTypeKind kinded_tvs) ; thing_inside kinded_tvs } kindedTyVarKind (L _ (KindedTyVar _ k)) = k @@ -289,19 +331,26 @@ kindedTyVarKind (L _ (KindedTyVar _ k)) = k %************************************************************************ \begin{code} +tcSynDecls :: (Name -> ArgVrcs) -> [LTyClDecl Name] -> TcM [TyThing] +tcSynDecls calc_vrcs [] = return [] +tcSynDecls calc_vrcs (decl : decls) + = do { syn_tc <- addLocM (tcSynDecl calc_vrcs) decl + ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls calc_vrcs decls) + ; return (syn_tc : syn_tcs) } + +tcSynDecl calc_vrcs + (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) + = tcTyVarBndrs tvs $ \ tvs' -> do + { traceTc (text "tcd1" <+> ppr tc_name) + ; rhs_ty' <- tcHsKindedType rhs_ty + ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' (calc_vrcs tc_name))) } + +-------------------- tcTyClDecl :: (Name -> ArgVrcs) -> (Name -> RecFlag) - -> LTyClDecl Name -> TcM TyThing + -> TyClDecl Name -> TcM TyThing tcTyClDecl calc_vrcs calc_isrec decl - = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec (unLoc decl)) - -tcTyClDecl1 calc_vrcs calc_isrec - (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) - = tcTyVarBndrs tvs $ \ tvs' -> do - { rhs_ty' <- tcHsKindedType rhs_ty - ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' arg_vrcs)) } - where - arg_vrcs = calc_vrcs tc_name + = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec decl) tcTyClDecl1 calc_vrcs calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, @@ -413,22 +462,21 @@ tied, so we can look at things freely. \begin{code} checkCycleErrs :: [LTyClDecl Name] -> TcM () checkCycleErrs tyclss - | null syn_cycles && null cls_cycles + | null cls_cycles = return () | otherwise - = do { mappM_ recSynErr syn_cycles - ; mappM_ recClsErr cls_cycles + = do { mappM_ recClsErr cls_cycles ; failM } -- Give up now, because later checkValidTyCl -- will loop if the synonym is recursive where - (syn_cycles, cls_cycles) = calcCycleErrs tyclss + cls_cycles = calcClassCycles tyclss -checkValidTyCl :: LTyClDecl Name -> TcM () +checkValidTyCl :: TyClDecl Name -> TcM () -- We do the validity check over declarations, rather than TyThings -- only so that we can add a nice context with tcAddDeclCtxt checkValidTyCl decl = tcAddDeclCtxt decl $ - do { thing <- tcLookupLocatedGlobal (tcdLName (unLoc decl)) + do { thing <- tcLookupLocatedGlobal (tcdLName decl) ; traceTc (text "Validity of" <+> ppr thing) ; case thing of ATyCon tc -> checkValidTyCon tc @@ -581,19 +629,19 @@ badGenericMethodType op op_ty 4 (vcat [ppr op <+> dcolon <+> ppr op_ty, ptext SLIT("You can only use type variables, arrows, and tuples")]) -recSynErr tcs - = addSrcSpan (srcLocSpan (getSrcLoc (head tcs))) $ +recSynErr syn_decls + = addSrcSpan (getLoc (head syn_decls)) $ addErr (sep [ptext SLIT("Cycle in type synonym declarations:"), - nest 2 (vcat (map ppr_thing tcs))]) + nest 2 (vcat (map ppr_decl syn_decls))]) + where + ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl -recClsErr clss - = addSrcSpan (srcLocSpan (getSrcLoc (head clss))) $ +recClsErr cls_decls + = addSrcSpan (getLoc (head cls_decls)) $ addErr (sep [ptext SLIT("Cycle in class declarations (via superclasses):"), - nest 2 (vcat (map ppr_thing clss))]) - -ppr_thing :: Name -> SDoc -ppr_thing n = ppr n <+> parens (ppr (getSrcLoc n)) - + nest 2 (vcat (map ppr_decl cls_decls))]) + where + ppr_decl (L loc decl) = ppr loc <> colon <+> ppr (decl { tcdSigs = [] }) exRecConErr name = ptext SLIT("Can't combine named fields with locally-quantified type variables") diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 824e95c..586974b 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -13,14 +13,15 @@ files for imported data types. \begin{code} module TcTyDecls( calcTyConArgVrcs, - calcRecFlags, calcCycleErrs, + calcRecFlags, + calcClassCycles, calcSynCycles, newTyConRhs ) where #include "HsVersions.h" import TypeRep ( Type(..), TyNote(..), PredType(..) ) -- friend -import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl ) +import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl ) import RnHsSyn ( extractHsTyNames ) import Type ( predTypeRep ) import BuildTyCl ( newTyConRhs ) @@ -37,7 +38,7 @@ import NameEnv import NameSet import Digraph ( SCC(..), stronglyConnComp, stronglyConnCompR ) import BasicTypes ( RecFlag(..) ) -import SrcLoc ( Located(..) ) +import SrcLoc ( Located(..), unLoc ) import Outputable \end{code} @@ -107,23 +108,25 @@ synTyConsOfType ty ---------------------------------------- END NOTE ] \begin{code} -calcCycleErrs :: [LTyClDecl Name] -> ([[Name]], -- Recursive type synonym groups - [[Name]]) -- Ditto classes -calcCycleErrs decls - = (findCyclics syn_edges, findCyclics cls_edges) +calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)] +calcSynCycles decls + = stronglyConnComp syn_edges where - --------------- Type synonyms ---------------------- - syn_edges = [ (name, mk_syn_edges rhs) | - L _ (TySynonym { tcdLName = L _ name, - tcdSynRhs = rhs }) <- decls ] + syn_edges = [ (ldecl, unLoc (tcdLName decl), + mk_syn_edges (tcdSynRhs decl)) + | ldecl@(L _ decl) <- decls ] mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs), not (isTyVarName tc) ] - --------------- Classes ---------------------- - cls_edges = [ (name, mk_cls_edges ctxt) | - L _ (ClassDecl { tcdLName = L _ name, - tcdCtxt = L _ ctxt }) <- decls ] + +calcClassCycles :: [LTyClDecl Name] -> [[LTyClDecl Name]] +calcClassCycles decls + = [decls | CyclicSCC decls <- stronglyConnComp cls_edges] + where + cls_edges = [ (ldecl, unLoc (tcdLName decl), + mk_cls_edges (unLoc (tcdCtxt decl))) + | ldecl@(L _ decl) <- decls, isClassDecl decl ] mk_cls_edges ctxt = [ cls | L _ (HsClassP cls _) <- ctxt ] \end{code} @@ -262,12 +265,6 @@ findLoopBreakers deps go edges = [ name | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges, name <- tyConName tc : go edges'] - -findCyclics :: [(Name,[Name])] -> [[Name]] -findCyclics deps - = [names | CyclicSCC names <- stronglyConnComp edges] - where - edges = [(name,name,ds) | (name,ds) <- deps] \end{code} These two functions know about type representations, so they could be diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 8815cf5..ffcf392 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -85,9 +85,9 @@ module TcType ( -- Rexported from Type Kind, -- Stuff to do with kinds is insensitive to pre/post Tc unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, - isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, isSuperKind, - superBoxity, liftedBoxity, hasMoreBoxityInfo, defaultKind, superKind, - isTypeKind, isAnyTypeKind, typeCon, + isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, + isSubKind, defaultKind, + isArgTypeKind, isOpenTypeKind, Type, PredType(..), ThetaType, mkForAllTy, mkForAllTys, @@ -101,7 +101,7 @@ module TcType ( tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes, tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, - typeKind, eqKind, + typeKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, @@ -119,12 +119,12 @@ import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend import Type ( -- Re-exports tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, Kind, Type, PredType(..), - ThetaType, unliftedTypeKind, typeCon, + ThetaType, unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, isLiftedTypeKind, isUnliftedTypeKind, - isOpenTypeKind, isSuperKind, + isOpenTypeKind, mkArrowKinds, mkForAllTy, mkForAllTys, - defaultKind, isTypeKind, isAnyTypeKind, + defaultKind, isArgTypeKind, isOpenTypeKind, mkFunTy, mkFunTys, zipFunTys, mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys, @@ -135,19 +135,17 @@ import Type ( -- Re-exports tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes, tidyTyVarBndr, tidyOpenTyVar, - tidyOpenTyVars, eqKind, - hasMoreBoxityInfo, liftedBoxity, - superBoxity, typeKind, superKind, repType, + tidyOpenTyVars, + isSubKind, + typeKind, repType, pprKind, pprParendKind, pprType, pprParendType, pprPred, pprTheta, pprThetaArrow, pprClassPred ) import TyCon ( TyCon, isUnLiftedTyCon, tyConUnique ) import Class ( Class ) -import Var ( TyVar, tyVarKind, isMutTyVar, mutTyVarDetails ) -import ForeignCall ( Safety, playSafe - , DNType(..) - ) +import Var ( TyVar, tyVarKind, tcTyVarDetails ) +import ForeignCall ( Safety, playSafe, DNType(..) ) import VarEnv import VarSet @@ -203,9 +201,6 @@ tau ::= tyvar -- provided it expands to the required form. \begin{code} -type TcTyVar = TyVar -- Might be a mutable tyvar -type TcTyVarSet = TyVarSet - type TcType = Type -- A TcType can have mutable type variables -- Invariant on ForAllTy in TcTypes: -- forall a. T @@ -217,7 +212,8 @@ type TcThetaType = ThetaType type TcSigmaType = TcType type TcRhoType = TcType type TcTauType = TcType -type TcKind = TcType + +type TcKind = Kind \end{code} @@ -233,11 +229,12 @@ It's knot-tied back to Var.lhs. There is no reason in principle why Var.lhs shouldn't actually have the definition, but it "belongs" here. \begin{code} +type TcTyVar = TyVar -- Used only during type inference + data TyVarDetails = SigTv -- Introduced when instantiating a type signature, -- prior to checking that the defn of a fn does -- have the expected type. Should not be instantiated. - -- -- f :: forall a. a -> a -- f = e -- When checking e, with expected type (a->a), we @@ -249,30 +246,26 @@ data TyVarDetails | InstTv -- Ditto, but instance decl | PatSigTv -- Scoped type variable, introduced by a pattern - -- type signature - -- \ x::a -> e + -- type signature \ x::a -> e | VanillaTv -- Everything else isUserTyVar :: TcTyVar -> Bool -- Avoid unifying these if possible -isUserTyVar tv = case mutTyVarDetails tv of +isUserTyVar tv = case tcTyVarDetails tv of VanillaTv -> False other -> True isSkolemTyVar :: TcTyVar -> Bool -isSkolemTyVar tv = case mutTyVarDetails tv of +isSkolemTyVar tv = case tcTyVarDetails tv of SigTv -> True ClsTv -> True InstTv -> True oteher -> False -tyVarBindingInfo :: TyVar -> SDoc -- Used in checkSigTyVars +tyVarBindingInfo :: TcTyVar -> SDoc -- Used in checkSigTyVars tyVarBindingInfo tv - | isMutTyVar tv - = sep [ptext SLIT("is bound by the") <+> details (mutTyVarDetails tv), + = sep [ptext SLIT("is bound by the") <+> details (tcTyVarDetails tv), ptext SLIT("at") <+> ppr (getSrcLoc tv)] - | otherwise - = empty where details SigTv = ptext SLIT("type signature") details ClsTv = ptext SLIT("class declaration") @@ -281,6 +274,9 @@ tyVarBindingInfo tv details VanillaTv = ptext SLIT("//vanilla//") -- Ditto \end{code} +\begin{code} +type TcTyVarSet = TyVarSet +\end{code} %************************************************************************ %* * @@ -1046,7 +1042,7 @@ uVarX tv1 ty2 k subst@(tmpls, env) uTysX ty1 ty2 k subst Nothing -- Not already bound - | typeKind ty2 `eqKind` tyVarKind tv1 + | typeKind ty2 == tyVarKind tv1 && occur_check_ok ty2 -> -- No kind mismatch nor occur check k (tmpls, extendSubstEnv env tv1 (DoneTy ty2)) @@ -1116,7 +1112,7 @@ match (TyVarTy v) ty tmpls k senv | v `elemVarSet` tmpls = -- v is a template variable case lookupSubstEnv senv v of - Nothing | typeKind ty `eqKind` tyVarKind v + Nothing | typeKind ty == tyVarKind v -- We do a kind check, just as in the uVarX above -- The kind check is needed to avoid bogus matches -- of (a b) with (c d), where the kinds don't match diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index 1234910..d4e3edd 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -12,6 +12,7 @@ module TcUnify ( -- Various unifications unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyKind, unifyKinds, unifyFunKind, + checkExpectedKind, -------------------------------- -- Holes @@ -30,7 +31,7 @@ module TcUnify ( import HsSyn ( HsExpr(..) ) import TcHsSyn ( mkHsLet, mkHsDictLam, ExprCoFn, idCoercion, isIdCoercion, mkCoercion, (<.>), (<$>) ) -import TypeRep ( Type(..), PredType(..), TyNote(..), openKindCon, isSuperKind ) +import TypeRep ( Type(..), PredType(..), TyNote(..) ) import TcRnMonad -- TcType, amongst others import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType, @@ -42,12 +43,16 @@ import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType, typeKind, tcSplitFunTy_maybe, mkForAllTys, isSkolemTyVar, isUserTyVar, tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars, - eqKind, openTypeKind, liftedTypeKind, isTypeKind, mkArrowKind, - hasMoreBoxityInfo, allDistinctTyVars, pprType, pprKind ) + allDistinctTyVars, pprType ) +import Kind ( Kind(..), SimpleKind, KindVar, isArgTypeKind, + openTypeKind, liftedTypeKind, mkArrowKind, + isOpenTypeKind, argTypeKind, isLiftedTypeKind, isUnliftedTypeKind, + isSubKind, pprKind, splitKindFunTys ) import Inst ( newDicts, instToId, tcInstCall ) import TcMType ( getTcTyVar, putTcTyVar, tcInstType, newKindVar, - newTyVarTy, newTyVarTys, newOpenTypeKind, - zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV ) + newTyVarTy, newTyVarTys, zonkTcKind, + zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV, + readKindVar,writeKindVar ) import TcSimplify ( tcSimplifyCheck ) import TysWiredIn ( listTyCon, parrTyCon, tupleTyCon ) import TcEnv ( tcGetGlobalTyVars, findGlobals ) @@ -85,14 +90,22 @@ readExpectedType :: Expected ty -> TcM ty readExpectedType (Infer hole) = readMutVar hole readExpectedType (Check ty) = returnM ty -zapExpectedType :: Expected TcType -> TcM TcTauType +zapExpectedType :: Expected TcType -> Kind -> TcM TcTauType -- In the inference case, ensure we have a monotype -zapExpectedType (Infer hole) - = do { ty <- newTyVarTy openTypeKind ; +-- (including an unboxed tuple) +zapExpectedType (Infer hole) kind + = do { ty <- newTyVarTy kind ; writeMutVar hole ty ; return ty } -zapExpectedType (Check ty) = return ty +zapExpectedType (Check ty) kind + | typeKind ty `isSubKind` kind = return ty + | otherwise = do { ty1 <- newTyVarTy kind + ; unifyTauTy ty1 ty + ; return ty } + -- The unify is to ensure that 'ty' has the desired kind + -- For example, in (case e of r -> b) we push an OpenTypeKind + -- type variable zapExpectedTo :: Expected TcType -> TcTauType -> TcM () zapExpectedTo (Infer hole) ty2 = writeMutVar hole ty2 @@ -101,7 +114,7 @@ zapExpectedTo (Check ty1) ty2 = unifyTauTy ty1 ty2 zapExpectedBranches :: [a] -> Expected TcType -> TcM (Expected TcType) -- Zap the expected type to a monotype if there is more than one branch zapExpectedBranches branches exp_ty - | lengthExceeds branches 1 = zapExpectedType exp_ty `thenM` \ exp_ty' -> + | lengthExceeds branches 1 = zapExpectedType exp_ty openTypeKind `thenM` \ exp_ty' -> return (Check exp_ty') | otherwise = returnM exp_ty @@ -177,7 +190,7 @@ unifyFunTy ty Nothing -> unify_fun_ty_help ty unify_fun_ty_help ty -- Special cases failed, so revert to ordinary unification - = newTyVarTy openTypeKind `thenM` \ arg -> + = newTyVarTy argTypeKind `thenM` \ arg -> newTyVarTy openTypeKind `thenM` \ res -> unifyTauTy ty (mkFunTy arg res) `thenM_` returnM (arg,res) @@ -256,7 +269,8 @@ new_tuple_ty boxity arity where tup_tc = tupleTyCon boxity arity kind | isBoxed boxity = liftedTypeKind - | otherwise = openTypeKind + | otherwise = argTypeKind -- Components of an unboxed tuple + -- can be unboxed, but not unboxed tuples \end{code} @@ -461,7 +475,7 @@ imitateFun tv ty checkM (not (isSkolemTyVar tv)) (failWithTcM (unifyWithSigErr tv ty)) `thenM_` - newTyVarTy openTypeKind `thenM` \ arg -> + newTyVarTy argTypeKind `thenM` \ arg -> newTyVarTy openTypeKind `thenM` \ res -> putTcTyVar tv (mkFunTy arg res) `thenM_` returnM (arg,res) @@ -630,12 +644,6 @@ uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2) | con1 == con2 && equalLength tys1 tys2 = unifyTauTyLists tys1 tys2 - | con1 == openKindCon - -- When we are doing kind checking, we might match a kind '?' - -- against a kind '*' or '#'. Notably, CCallable :: ? -> *, and - -- (CCallable Int) and (CCallable Int#) are both OK - = unifyTypeKind 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, @@ -737,42 +745,46 @@ uVar swapped tv1 ps_ty2 ty2 case maybe_ty1 of Just ty1 | swapped -> uTys ps_ty2 ty2 ty1 ty1 -- Swap back | otherwise -> uTys ty1 ty1 ps_ty2 ty2 -- Same order - other -> uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2 + other -> uUnboundVar swapped tv1 ps_ty2 ty2 -- Expand synonyms; ignore FTVs -uUnboundVar swapped tv1 maybe_ty1 ps_ty2 (NoteTy n2 ty2) - = uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2 +uUnboundVar swapped tv1 ps_ty2 (NoteTy n2 ty2) + = uUnboundVar swapped tv1 ps_ty2 ty2 -- The both-type-variable case -uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2) +uUnboundVar swapped tv1 ps_ty2 ty2@(TyVarTy tv2) -- Same type variable => no-op | tv1 == tv2 = returnM () -- Distinct type variables - -- ASSERT maybe_ty1 /= Just | otherwise = getTcTyVar tv2 `thenM` \ maybe_ty2 -> case maybe_ty2 of - Just ty2' -> uUnboundVar swapped tv1 maybe_ty1 ty2' ty2' + Just ty2' -> uUnboundVar swapped tv1 ty2' ty2' Nothing | update_tv2 + -- It should always be the case that either k1 <: k2 or k2 <: k1 + -- Reason: a type variable never gets the kinds (#) or # - -> WARN( not (k1 `hasMoreBoxityInfo` k2), (ppr tv1 <+> ppr k1) $$ (ppr tv2 <+> ppr k2) ) + -> ASSERT2( k1 `isSubKind` k2, (ppr tv1 <+> ppr k1) $$ (ppr tv2 <+> ppr k2) ) putTcTyVar tv2 (TyVarTy tv1) `thenM_` returnM () - | otherwise - -> WARN( not (k2 `hasMoreBoxityInfo` k1), (ppr tv2 <+> ppr k2) $$ (ppr tv1 <+> ppr k1) ) + | otherwise + -> ASSERT2( k2 `isSubKind` k1, (ppr tv2 <+> ppr k2) $$ (ppr tv1 <+> ppr k1) ) putTcTyVar tv1 ps_ty2 `thenM_` returnM () where k1 = tyVarKind tv1 k2 = tyVarKind tv2 - update_tv2 = (k2 `eqKind` openTypeKind) || (not (k1 `eqKind` openTypeKind) && nicer_to_update_tv2) - -- Try to get rid of open type variables as soon as poss + update_tv2 = k1 `isSubKind` k2 && (k1 /= k2 || nicer_to_update_tv2) + -- Update the variable with least kind info + -- See notes on type inference in Kind.lhs + -- The "nicer to" part only applies if the two kinds are the same, + -- so we can choose which to do. nicer_to_update_tv2 = isUserTyVar tv1 -- Don't unify a signature type variable if poss @@ -780,7 +792,7 @@ uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2) -- Try to update sys-y type variables in preference to sig-y ones -- Second one isn't a type variable -uUnboundVar swapped tv1 maybe_ty1 ps_ty2 non_var_ty2 +uUnboundVar swapped tv1 ps_ty2 non_var_ty2 = -- Check that tv1 isn't a type-signature type variable checkM (not (isSkolemTyVar tv1)) (failWithTcM (unifyWithSigErr tv1 ps_ty2)) `thenM_` @@ -803,7 +815,7 @@ checkKinds swapped tv1 ty2 -- We're about to unify a type variable tv1 with a non-tyvar-type ty2. -- ty2 has been zonked at this stage, which ensures that -- its kind has as much boxity information visible as possible. - | tk2 `hasMoreBoxityInfo` tk1 = returnM () + | tk2 `isSubKind` tk1 = returnM () | otherwise -- Either the kinds aren't compatible @@ -811,7 +823,7 @@ checkKinds swapped tv1 ty2 -- or we are unifying a lifted type variable with an -- unlifted type: e.g. (id 3#) is illegal = addErrCtxtM (unifyKindCtxt swapped tv1 ty2) $ - unifyMisMatch k1 k2 + unifyKindMisMatch k1 k2 where (k1,k2) | swapped = (tk2,tk1) @@ -894,59 +906,130 @@ okToUnifyWith tv ty %************************************************************************ %* * -\subsection{Kind unification} + Kind unification %* * %************************************************************************ +Unifying kinds is much, much simpler than unifying types. + \begin{code} unifyKind :: TcKind -- Expected -> TcKind -- Actual -> TcM () -unifyKind k1 k2 = uTys k1 k1 k2 k2 +unifyKind LiftedTypeKind LiftedTypeKind = returnM () +unifyKind UnliftedTypeKind UnliftedTypeKind = returnM () + +unifyKind OpenTypeKind k2 | isOpenTypeKind k2 = returnM () +unifyKind ArgTypeKind k2 | isArgTypeKind k2 = returnM () + -- Respect sub-kinding + +unifyKind (FunKind a1 r1) (FunKind a2 r2) + = do { unifyKind a2 a1; unifyKind r1 r2 } + -- Notice the flip in the argument, + -- so that the sub-kinding works right + +unifyKind (KindVar kv1) k2 = uKVar False kv1 k2 +unifyKind k1 (KindVar kv2) = uKVar True kv2 k1 +unifyKind k1 k2 = unifyKindMisMatch k1 k2 unifyKinds :: [TcKind] -> [TcKind] -> TcM () unifyKinds [] [] = returnM () unifyKinds (k1:ks1) (k2:ks2) = unifyKind k1 k2 `thenM_` unifyKinds ks1 ks2 -unifyKinds _ _ = panic "unifyKinds: length mis-match" -\end{code} - -\begin{code} -unifyTypeKind :: TcKind -> TcM () --- Ensures that the argument kind is a liftedTypeKind or unliftedTypeKind --- If it's a kind variable, make it (Type bx), for a fresh boxity variable bx - -unifyTypeKind ty@(TyVarTy tyvar) - = getTcTyVar tyvar `thenM` \ maybe_ty -> - case maybe_ty of - Just ty' -> unifyTypeKind ty' - Nothing -> newOpenTypeKind `thenM` \ kind -> - putTcTyVar tyvar kind `thenM_` - returnM () - -unifyTypeKind ty - | isTypeKind ty = returnM () - | otherwise -- Failure - = zonkTcType ty `thenM` \ ty1 -> - failWithTc (ptext SLIT("Type expected but") <+> quotes (ppr ty1) <+> ptext SLIT("found")) +unifyKinds _ _ = panic "unifyKinds: length mis-match" + +---------------- +uKVar :: Bool -> KindVar -> TcKind -> TcM () +uKVar swapped kv1 k2 + = do { mb_k1 <- readKindVar kv1 + ; case mb_k1 of + Nothing -> uUnboundKVar swapped kv1 k2 + Just k1 | swapped -> unifyKind k2 k1 + | otherwise -> unifyKind k1 k2 } + +---------------- +uUnboundKVar :: Bool -> KindVar -> TcKind -> TcM () +uUnboundKVar swapped kv1 k2@(KindVar kv2) + | kv1 == kv2 = returnM () + | otherwise -- Distinct kind variables + = do { mb_k2 <- readKindVar kv2 + ; case mb_k2 of + Just k2 -> uUnboundKVar swapped kv1 k2 + Nothing -> writeKindVar kv1 k2 } + +uUnboundKVar swapped kv1 non_var_k2 + = do { k2' <- zonkTcKind non_var_k2 + ; kindOccurCheck kv1 k2' + ; k2'' <- kindSimpleKind swapped k2' + -- KindVars must be bound only to simple kinds + -- Polarities: (kindSimpleKind True ?) succeeds + -- returning *, corresponding to unifying + -- expected: ? + -- actual: kind-ver + ; writeKindVar kv1 k2'' } + +---------------- +kindOccurCheck kv1 k2 -- k2 is zonked + = checkTc (not_in k2) (kindOccurCheckErr kv1 k2) + where + not_in (KindVar kv2) = kv1 /= kv2 + not_in (FunKind a2 r2) = not_in a2 && not_in r2 + not_in other = True + +kindSimpleKind :: Bool -> Kind -> TcM SimpleKind +-- (kindSimpleKind True k) returns a simple kind sk such that sk <: k +-- If the flag is False, it requires k <: sk +-- E.g. kindSimpleKind False ?? = * +-- What about (kv -> *) :=: ?? -> * +kindSimpleKind orig_swapped orig_kind + = go orig_swapped orig_kind + where + go sw (FunKind k1 k2) = do { k1' <- go (not sw) k1 + ; k2' <- go sw k2 + ; return (FunKind k1' k2') } + go True OpenTypeKind = return liftedTypeKind + go True ArgTypeKind = return liftedTypeKind + go sw LiftedTypeKind = return liftedTypeKind + go sw k@(KindVar _) = return k -- KindVars are always simple + go swapped kind = failWithTc (ptext SLIT("Unexpected kind unification failure:") + <+> ppr orig_swapped <+> ppr orig_kind) + -- I think this can't actually happen + +-- T v = MkT v v must be a type +-- T v w = MkT (v -> w) v must not be an umboxed tuple + +---------------- +kindOccurCheckErr tyvar ty + = hang (ptext SLIT("Occurs check: cannot construct the infinite kind:")) + 2 (sep [ppr tyvar, char '=', ppr ty]) + +unifyKindMisMatch ty1 ty2 + = zonkTcKind ty1 `thenM` \ ty1' -> + zonkTcKind ty2 `thenM` \ ty2' -> + let + msg = hang (ptext SLIT("Couldn't match kind")) + 2 (sep [quotes (ppr ty1'), + ptext SLIT("against"), + quotes (ppr ty2')]) + in + failWithTc msg \end{code} \begin{code} unifyFunKind :: TcKind -> TcM (Maybe (TcKind, TcKind)) -- Like unifyFunTy, but does not fail; instead just returns Nothing -unifyFunKind (TyVarTy tyvar) - = getTcTyVar tyvar `thenM` \ maybe_ty -> - case maybe_ty of +unifyFunKind (KindVar kvar) + = readKindVar kvar `thenM` \ maybe_kind -> + case maybe_kind of Just fun_kind -> unifyFunKind fun_kind - Nothing -> newKindVar `thenM` \ arg_kind -> - newKindVar `thenM` \ res_kind -> - putTcTyVar tyvar (mkArrowKind arg_kind res_kind) `thenM_` - returnM (Just (arg_kind,res_kind)) + Nothing -> do { arg_kind <- newKindVar + ; res_kind <- newKindVar + ; writeKindVar kvar (mkArrowKind arg_kind res_kind) + ; returnM (Just (arg_kind,res_kind)) } -unifyFunKind (FunTy arg_kind res_kind) = returnM (Just (arg_kind,res_kind)) -unifyFunKind (NoteTy _ ty) = unifyFunKind ty -unifyFunKind other = returnM Nothing +unifyFunKind (FunKind arg_kind res_kind) = returnM (Just (arg_kind,res_kind)) +unifyFunKind other = returnM Nothing \end{code} %************************************************************************ @@ -965,7 +1048,7 @@ unifyCtxt s ty1 ty2 tidy_env -- ty1 expected, ty2 inferred returnM (err ty1' ty2') where err ty1 ty2 = (env1, - nest 4 + nest 2 (vcat [ text "Expected" <+> text s <> colon <+> ppr tidy_ty1, text "Inferred" <+> text s <> colon <+> ppr tidy_ty2 @@ -974,44 +1057,42 @@ unifyCtxt s ty1 ty2 tidy_env -- ty1 expected, ty2 inferred (env1, [tidy_ty1,tidy_ty2]) = tidyOpenTypes tidy_env [ty1,ty2] unifyKindCtxt swapped tv1 ty2 tidy_env -- not swapped => tv1 expected, ty2 inferred - -- tv1 is zonked already - = zonkTcType ty2 `thenM` \ ty2' -> - returnM (err ty2') + -- tv1 and ty2 are zonked already + = returnM msg where - err ty2 = (env2, ptext SLIT("When matching types") <+> - sep [quotes pp_expected, ptext SLIT("and"), quotes pp_actual]) - where - (pp_expected, pp_actual) | swapped = (pp2, pp1) - | otherwise = (pp1, pp2) - (env1, tv1') = tidyOpenTyVar tidy_env tv1 - (env2, ty2') = tidyOpenType env1 ty2 - pp1 = ppr tv1' - pp2 = ppr ty2' + msg = (env2, ptext SLIT("When matching types") <+> + sep [quotes pp_expected <+> ptext SLIT("and"), quotes pp_actual]) + + (pp_expected, pp_actual) | swapped = (pp2, pp1) + | otherwise = (pp1, pp2) + (env1, tv1') = tidyOpenTyVar tidy_env tv1 + (env2, ty2') = tidyOpenType env1 ty2 + pp1 = ppr tv1' <+> dcolon <+> ppr (tyVarKind tv1) + pp2 = ppr ty2' <+> dcolon <+> ppr (typeKind ty2) unifyMisMatch ty1 ty2 = zonkTcType ty1 `thenM` \ ty1' -> zonkTcType ty2 `thenM` \ ty2' -> let (env, [tidy_ty1, tidy_ty2]) = tidyOpenTypes emptyTidyEnv [ty1',ty2'] - ppr | isSuperKind (typeKind ty1) = pprKind - | otherwise = pprType msg = hang (ptext SLIT("Couldn't match")) - 4 (sep [quotes (ppr tidy_ty1), + 2 (sep [quotes (ppr tidy_ty1), ptext SLIT("against"), quotes (ppr tidy_ty2)]) in failWithTcM (env, msg) + unifyWithSigErr tyvar ty = (env2, hang (ptext SLIT("Cannot unify the type-signature variable") <+> quotes (ppr tidy_tyvar)) - 4 (ptext SLIT("with the type") <+> quotes (ppr tidy_ty))) + 2 (ptext SLIT("with the type") <+> quotes (ppr tidy_ty))) where (env1, tidy_tyvar) = tidyOpenTyVar emptyTidyEnv tyvar (env2, tidy_ty) = tidyOpenType env1 ty unifyCheck problem tyvar ty = (env2, hang msg - 4 (sep [ppr tidy_tyvar, char '=', ppr tidy_ty])) + 2 (sep [ppr tidy_tyvar, char '=', ppr tidy_ty])) where (env1, tidy_tyvar) = tidyOpenTyVar emptyTidyEnv tyvar (env2, tidy_ty) = tidyOpenType env1 ty @@ -1022,6 +1103,64 @@ unifyCheck problem tyvar ty \end{code} +%************************************************************************ +%* * + Checking kinds +%* * +%************************************************************************ + +--------------------------- +-- We would like to get a decent error message from +-- (a) Under-applied type constructors +-- f :: (Maybe, Maybe) +-- (b) Over-applied type constructors +-- f :: Int x -> Int x +-- + +\begin{code} +checkExpectedKind :: Outputable a => a -> TcKind -> TcKind -> TcM () +-- A fancy wrapper for 'unifyKind', which tries +-- to give decent error messages. +checkExpectedKind ty act_kind exp_kind + | act_kind `isSubKind` exp_kind -- Short cut for a very common case + = returnM () + | otherwise + = tryTc (unifyKind exp_kind act_kind) `thenM` \ (errs, mb_r) -> + case mb_r of { + Just _ -> returnM () ; -- Unification succeeded + Nothing -> + + -- So there's definitely an error + -- Now to find out what sort + zonkTcKind exp_kind `thenM` \ exp_kind -> + zonkTcKind act_kind `thenM` \ act_kind -> + + let (exp_as, _) = splitKindFunTys exp_kind + (act_as, _) = splitKindFunTys act_kind + n_exp_as = length exp_as + n_act_as = length act_as + + err | n_exp_as < n_act_as -- E.g. [Maybe] + = quotes (ppr ty) <+> ptext SLIT("is not applied to enough type arguments") + + -- Now n_exp_as >= n_act_as. In the next two cases, + -- n_exp_as == 0, and hence so is n_act_as + | isLiftedTypeKind exp_kind && isUnliftedTypeKind act_kind + = ptext SLIT("Expecting a lifted type, but") <+> quotes (ppr ty) + <+> ptext SLIT("is unlifted") + + | isUnliftedTypeKind exp_kind && isLiftedTypeKind act_kind + = ptext SLIT("Expecting an unlifted type, but") <+> quotes (ppr ty) + <+> ptext SLIT("is lifted") + + | otherwise -- E.g. Monad [Int] + = sep [ ptext SLIT("Expecting kind") <+> quotes (pprKind exp_kind) <> comma, + ptext SLIT("but") <+> quotes (ppr ty) <+> + ptext SLIT("has kind") <+> quotes (pprKind act_kind)] + in + failWithTc (ptext SLIT("Kind error:") <+> err) + } +\end{code} %************************************************************************ %* * @@ -1126,7 +1265,7 @@ check_sig_tyvars extra_tvs sig_tvs (env2, emptyVarEnv, []) (tidy_tvs `zip` tidy_tys) `thenM` \ (env3, _, msgs) -> - failWithTcM (env3, main_msg $$ nest 4 (vcat msgs)) + failWithTcM (env3, main_msg $$ nest 2 (vcat msgs)) where (env1, tidy_tvs) = tidyOpenTyVars emptyTidyEnv sig_tvs (env2, tidy_tys) = tidyOpenTypes env1 sig_tys @@ -1201,7 +1340,7 @@ sigCtxt id sig_tvs sig_theta sig_tau tidy_env ptext SLIT("Type to generalise:") <+> pprType tidy_actual_tau ] msg = vcat [ptext SLIT("When trying to generalise the type inferred for") <+> quotes (ppr id), - nest 4 sub_msg] + nest 2 sub_msg] in returnM (env3, msg) \end{code} diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs new file mode 100644 index 0000000..a65ec1b --- /dev/null +++ b/ghc/compiler/types/Kind.lhs @@ -0,0 +1,201 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1998 +% + +\begin{code} +module Kind ( + Kind(..), KindVar(..), SimpleKind, + openTypeKind, liftedTypeKind, unliftedTypeKind, + argTypeKind, ubxTupleKind, + + isLiftedTypeKind, isUnliftedTypeKind, + isArgTypeKind, isOpenTypeKind, + mkArrowKind, mkArrowKinds, + + isSubKind, defaultKind, + kindFunResult, splitKindFunTys, mkKindVar, + + pprKind, pprParendKind + ) where + +#include "HsVersions.h" + +import Unique ( Unique ) +import Outputable +import DATA_IOREF +\end{code} + +Kinds +~~~~~ +There's a little subtyping at the kind level: + + ? + / \ + / \ + ?? (#) + / \ + * # + +where * [LiftedTypeKind] means boxed type + # [UnliftedTypeKind] means unboxed type + (#) [UbxTupleKind] means unboxed tuple + ?? [ArgTypeKind] is the lub of *,# + ? [OpenTypeKind] means any type at all + +In particular: + + error :: forall a:. String -> a + (->) :: ?? -> ? -> * + (\(x::t) -> ...) Here t:: (i.e. not unboxed tuple) + +\begin{code} +data Kind + = LiftedTypeKind -- * + | OpenTypeKind -- ? + | UnliftedTypeKind -- # + | UbxTupleKind -- (##) + | ArgTypeKind -- ?? + | FunKind Kind Kind -- k1 -> k2 + | KindVar KindVar + deriving( Eq ) + +data KindVar = KVar Unique (IORef (Maybe SimpleKind)) + -- INVARIANT: a KindVar can only be instantaited by a SimpleKind + +type SimpleKind = Kind + -- A SimpleKind has no ? or # kinds in it: + -- sk ::= * | sk1 -> sk2 | kvar + +instance Eq KindVar where + (KVar u1 _) == (KVar u2 _) = u1 == u2 + +mkKindVar :: Unique -> IORef (Maybe Kind) -> KindVar +mkKindVar = KVar +\end{code} + +Kind inference +~~~~~~~~~~~~~~ +During kind inference, a kind variable unifies only with +a "simple kind", sk + sk ::= * | sk1 -> sk2 +For example + data T a = MkT a (T Int#) +fails. We give T the kind (k -> *), and the kind variable k won't unify +with # (the kind of Int#). + +Type inference +~~~~~~~~~~~~~~ +When creating a fresh internal type variable, we give it a kind to express +constraints on it. E.g. in (\x->e) we make up a fresh type variable for x, +with kind ??. + +During unification we only bind an internal type variable to a type +whose kind is lower in the sub-kind hierarchy than the kind of the tyvar. + +When unifying two internal type variables, we collect their kind constraints by +finding the GLB of the two. Since the partial order is a tree, they only +have a glb if one is a sub-kind of the other. In that case, we bind the +less-informative one to the more informative one. Neat, eh? + +In the olden days, when we generalise, we make generic type variables +whose kind is simple. So generic type variables (other than built-in +constants like 'error') always have simple kinds. But I don't see any +reason to do that any more (TcMType.zapTcTyVarToTyVar). + + +\begin{code} +liftedTypeKind = LiftedTypeKind +unliftedTypeKind = UnliftedTypeKind +openTypeKind = OpenTypeKind +argTypeKind = ArgTypeKind +ubxTupleKind = UbxTupleKind + +mkArrowKind :: Kind -> Kind -> Kind +mkArrowKind k1 k2 = k1 `FunKind` k2 + +mkArrowKinds :: [Kind] -> Kind -> Kind +mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds +\end{code} + +%************************************************************************ +%* * + Functions over Kinds +%* * +%************************************************************************ + +\begin{code} +kindFunResult :: Kind -> Kind +kindFunResult (FunKind _ k) = k +kindFunResult k = pprPanic "kindFunResult" (ppr k) + +splitKindFunTys :: Kind -> ([Kind],Kind) +splitKindFunTys (FunKind k1 k2) = case splitKindFunTys k2 of + (as, r) -> (k1:as, r) +splitKindFunTys k = ([], k) + +isLiftedTypeKind, isUnliftedTypeKind :: Kind -> Bool +isLiftedTypeKind LiftedTypeKind = True +isLiftedTypeKind other = False + +isUnliftedTypeKind UnliftedTypeKind = True +isUnliftedTypeKind other = False + +isArgTypeKind :: Kind -> Bool +-- True of any sub-kind of ArgTypeKind +isArgTypeKind LiftedTypeKind = True +isArgTypeKind UnliftedTypeKind = True +isArgTypeKind ArgTypeKind = True +isArgTypeKind other = False + +isOpenTypeKind :: Kind -> Bool +-- True of any sub-kind of OpenTypeKind (i.e. anything except arrow) +isOpenTypeKind (FunKind _ _) = False +isOpenTypeKind other = True + +isSubKind :: Kind -> Kind -> Bool +-- (k1 `isSubKind` k2) checks that k1 <: k2 +isSubKind LiftedTypeKind LiftedTypeKind = True +isSubKind UnliftedTypeKind UnliftedTypeKind = True +isSubKind UbxTupleKind UbxTupleKind = True +isSubKind k1 OpenTypeKind = isOpenTypeKind k1 +isSubKind k1 ArgTypeKind = isArgTypeKind k1 +isSubKind (FunKind a1 r1) (FunKind a2 r2) + = (a2 `isSubKind` a1) && (r1 `isSubKind` r2) +isSubKind k1 k2 = False + +defaultKind :: Kind -> Kind +-- Used when generalising: default kind '?' and '??' to '*' +defaultKind OpenTypeKind = LiftedTypeKind +defaultKind ArgTypeKind = LiftedTypeKind +defaultKind kind = kind +\end{code} + + +%************************************************************************ +%* * + Pretty printing +%* * +%************************************************************************ + +\begin{code} +instance Outputable KindVar where + ppr (KVar uniq _) = text "k_" <> ppr uniq + +instance Outputable Kind where + ppr k = pprKind k + +pprParendKind :: Kind -> SDoc +pprParendKind k@(FunKind _ _) = parens (pprKind k) +pprParendKind k = pprKind k + +pprKind (KindVar v) = ppr v +pprKind LiftedTypeKind = ptext SLIT("*") +pprKind UnliftedTypeKind = ptext SLIT("#") +pprKind OpenTypeKind = ptext SLIT("?") +pprKind ArgTypeKind = ptext SLIT("??") +pprKind UbxTupleKind = ptext SLIT("(#)") +pprKind (FunKind k1 k2) = sep [ pprKind k1, arrow <+> pprParendKind k2] +\end{code} + + + diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index e81a2a3..681d6e3 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -5,7 +5,7 @@ \begin{code} module TyCon( - TyCon, KindCon, SuperKindCon, ArgVrcs, + TyCon, ArgVrcs, AlgTyConFlavour(..), DataConDetails(..), visibleDataCons, @@ -25,14 +25,12 @@ module TyCon( mkLiftedPrimTyCon, mkTupleTyCon, mkSynTyCon, - mkKindCon, - mkSuperKindCon, tyConName, tyConKind, tyConUnique, tyConTyVars, - tyConArgVrcs_maybe, tyConArgVrcs, + tyConArgVrcs, tyConDataConDetails, tyConDataCons, tyConDataCons_maybe, tyConFamilySize, tyConSelIds, tyConTheta, @@ -50,7 +48,7 @@ module TyCon( #include "HsVersions.h" -import {-# SOURCE #-} TypeRep ( Type, PredType, Kind, SuperKind ) +import {-# SOURCE #-} TypeRep ( Type, PredType ) -- Should just be Type(Type), but this fails due to bug present up to -- and including 4.02 involving slurping of hi-boot files. Bug is now fixed. @@ -59,11 +57,12 @@ import {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon ) import Var ( TyVar, Id ) import Class ( Class ) +import Kind ( Kind ) import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) import Name ( Name, nameUnique, NamedThing(getName) ) -import PrelNames ( Unique, Uniquable(..), anyBoxConKey ) -import PrimRep ( PrimRep(..), isFollowableRep ) -import Maybes ( orElse, expectJust ) +import PrelNames ( Unique, Uniquable(..) ) +import PrimRep ( PrimRep(..) ) +import Maybes ( orElse ) import Outputable import FastString \end{code} @@ -75,9 +74,6 @@ import FastString %************************************************************************ \begin{code} -type KindCon = TyCon -type SuperKindCon = TyCon - data TyCon = FunTyCon { tyConUnique :: Unique, @@ -153,18 +149,6 @@ data TyCon argVrcs :: ArgVrcs } - | KindCon { -- Type constructor at the kind level - tyConUnique :: Unique, - tyConName :: Name, - tyConKind :: SuperKind, - tyConArity :: Arity - } - - | SuperKindCon { -- The type of kind variables or boxity variables, - tyConUnique :: Unique, - tyConName :: Name - } - type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)] -- [] means "no information, assume the worst" @@ -212,21 +196,6 @@ module mutual-recursion. And they aren't called from many places. So we compromise, and move their Kind calculation to the call site. \begin{code} -mkSuperKindCon :: Name -> SuperKindCon -mkSuperKindCon name = SuperKindCon { - tyConUnique = nameUnique name, - tyConName = name - } - -mkKindCon :: Name -> SuperKind -> KindCon -mkKindCon name kind - = KindCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConArity = 0, - tyConKind = kind - } - mkFunTyCon :: Name -> Kind -> TyCon mkFunTyCon name kind = FunTyCon { @@ -496,15 +465,11 @@ actually computed (in another file). \begin{code} tyConArgVrcs :: TyCon -> ArgVrcs -tyConArgVrcs tc = expectJust "tyConArgVrcs" (tyConArgVrcs_maybe tc) - -tyConArgVrcs_maybe :: TyCon -> Maybe ArgVrcs -tyConArgVrcs_maybe (FunTyCon {}) = Just [(False,True),(True,False)] -tyConArgVrcs_maybe (AlgTyCon {argVrcs = oi}) = Just oi -tyConArgVrcs_maybe (PrimTyCon {argVrcs = oi}) = Just oi -tyConArgVrcs_maybe (TupleTyCon {tyConArity = arity}) = Just (replicate arity (True,False)) -tyConArgVrcs_maybe (SynTyCon {argVrcs = oi}) = Just oi -tyConArgVrcs_maybe _ = Nothing +tyConArgVrcs (FunTyCon {}) = [(False,True),(True,False)] +tyConArgVrcs (AlgTyCon {argVrcs = oi}) = oi +tyConArgVrcs (PrimTyCon {argVrcs = oi}) = oi +tyConArgVrcs (TupleTyCon {tyConArity = arity}) = (replicate arity (True,False)) +tyConArgVrcs (SynTyCon {argVrcs = oi}) = oi \end{code} \begin{code} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 20dbb00..5cf242c 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -5,23 +5,13 @@ \begin{code} module Type ( - -- re-exports from TypeRep: - TyThing(..), - Type, PredType(..), ThetaType, - Kind, TyVarSubst, - - superKind, superBoxity, -- KX and BX respectively - liftedBoxity, unliftedBoxity, -- :: BX - openKindCon, -- :: KX - typeCon, -- :: BX -> KX - liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX - isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, isSuperKind, - mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX - isTypeKind, isAnyTypeKind, + -- re-exports from TypeRep + TyThing(..), Type, PredType(..), ThetaType, TyVarSubst, funTyCon, - -- exports from this module: - hasMoreBoxityInfo, defaultKind, + -- Re-exports from Kind + module Kind, + mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy, @@ -63,13 +53,12 @@ module Type ( tidyTopType, tidyPred, -- Comparison - eqType, eqKind, + eqType, -- Seq seqType, seqTypes, -- Pretty-printing - pprKind, pprParendKind, pprType, pprParendType, pprPred, pprTheta, pprThetaArrow, pprClassPred ) where @@ -86,6 +75,7 @@ import TypeRep import {-# SOURCE #-} Subst ( substTyWith ) -- friends: +import Kind import Var ( TyVar, tyVarKind, tyVarName, setTyVarName ) import VarEnv import VarSet @@ -114,38 +104,6 @@ import Maybe ( isJust ) %************************************************************************ %* * -\subsection{Stuff to do with kinds.} -%* * -%************************************************************************ - -\begin{code} -hasMoreBoxityInfo :: Kind -> Kind -> Bool --- (k1 `hasMoreBoxityInfo` k2) checks that k1 <: k2 -hasMoreBoxityInfo k1 k2 - | k2 `eqKind` openTypeKind = isAnyTypeKind k1 - | otherwise = k1 `eqKind` k2 - -isAnyTypeKind :: Kind -> Bool --- True of kind * and *# and ? -isAnyTypeKind (TyConApp tc _) = tc == typeCon || tc == openKindCon -isAnyTypeKind (NoteTy _ k) = isAnyTypeKind k -isAnyTypeKind other = False - -isTypeKind :: Kind -> Bool --- True of kind * and *# -isTypeKind (TyConApp tc _) = tc == typeCon -isTypeKind (NoteTy _ k) = isTypeKind k -isTypeKind other = False - -defaultKind :: Kind -> Kind --- Used when generalising: default kind '?' to '*' -defaultKind kind | kind `eqKind` openTypeKind = liftedTypeKind - | otherwise = kind -\end{code} - - -%************************************************************************ -%* * \subsection{Constructor-specific functions} %* * %************************************************************************ @@ -622,26 +580,13 @@ new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon ) typeKind :: Type -> Kind typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys -typeKind (NewTcApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys +typeKind (TyConApp tycon tys) = foldr (\_ k -> kindFunResult k) (tyConKind tycon) tys +typeKind (NewTcApp tycon tys) = foldr (\_ k -> kindFunResult k) (tyConKind tycon) tys typeKind (NoteTy _ ty) = typeKind ty typeKind (PredTy _) = liftedTypeKind -- Predicates are always -- represented by lifted types -typeKind (AppTy fun arg) = funResultTy (typeKind fun) - -typeKind (FunTy arg res) = fix_up (typeKind res) - where - fix_up (TyConApp tycon _) | tycon == typeCon - || tycon == openKindCon = liftedTypeKind - fix_up (NoteTy _ kind) = fix_up kind - fix_up kind = kind - -- The basic story is - -- typeKind (FunTy arg res) = typeKind res - -- But a function is lifted regardless of its result type - -- Hence the strange fix-up. - -- Note that 'res', being the result of a FunTy, can't have - -- a strange kind like (*->*). - +typeKind (AppTy fun arg) = kindFunResult (typeKind fun) +typeKind (FunTy arg res) = liftedTypeKind typeKind (ForAllTy tv ty) = typeKind ty \end{code} @@ -707,8 +652,7 @@ It doesn't change the uniques at all, just the print names. tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) tidyTyVarBndr (tidy_env, subst) tyvar = case tidyOccName tidy_env (getOccName name) of - (tidy', occ') -> -- New occname reqd - ((tidy', subst'), tyvar') + (tidy', occ') -> ((tidy', subst'), tyvar') where subst' = extendVarEnv subst tyvar tyvar' tyvar' = setTyVarName tyvar name' @@ -903,7 +847,6 @@ I don't think this is harmful, but it's soemthing to watch out for. \begin{code} eqType t1 t2 = eq_ty emptyVarEnv t1 t2 -eqKind = eqType -- No worries about looking -- Look through Notes eq_ty env (NoteTy _ t1) t2 = eq_ty env t1 t2 diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index 90fb9a3..5b527a0 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -12,20 +12,17 @@ module TypeRep ( Kind, ThetaType, -- Synonyms TyVarSubst, - superKind, superBoxity, -- KX and BX respectively - liftedBoxity, unliftedBoxity, -- :: BX - openKindCon, -- :: KX - typeCon, -- :: BX -> KX - liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX - isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, isSuperKind, - mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX - funTyCon, -- Pretty-printing - pprKind, pprParendKind, pprType, pprParendType, - pprPred, pprTheta, pprThetaArrow, pprClassPred + pprPred, pprTheta, pprThetaArrow, pprClassPred, + + -- Re-export fromKind + liftedTypeKind, unliftedTypeKind, openTypeKind, + isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, + mkArrowKind, mkArrowKinds, + pprKind, pprParendKind ) where #include "HsVersions.h" @@ -33,23 +30,18 @@ module TypeRep ( import {-# SOURCE #-} DataCon( DataCon, dataConName ) -- friends: +import Kind import Var ( Id, TyVar, tyVarKind ) import VarEnv ( TyVarEnv ) import VarSet ( TyVarSet ) -import Name ( Name, NamedThing(..), mkWiredInName, mkInternalName ) -import OccName ( mkOccFS, mkKindOccFS, tcName ) +import Name ( Name, NamedThing(..), mkWiredInName ) +import OccName ( mkOccFS, tcName ) import BasicTypes ( IPName, tupleParens ) -import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon, isNewTyCon, - tyConArity, tupleTyConBoxity, isTupleTyCon, tyConName ) +import TyCon ( TyCon, mkFunTyCon, tyConArity, tupleTyConBoxity, isTupleTyCon ) import Class ( Class ) -- others -import PrelNames ( gHC_PRIM, kindConKey, boxityConKey, liftedConKey, - unliftedConKey, typeConKey, anyBoxConKey, - funTyConKey, listTyConKey, parrTyConKey, - hasKey - ) -import SrcLoc ( noSrcLoc ) +import PrelNames ( gHC_PRIM, funTyConKey, listTyConKey, parrTyConKey, hasKey ) import Outputable \end{code} @@ -154,13 +146,10 @@ to cut all loops. The other members of the loop may be marked 'non-recursive'. \begin{code} -type SuperKind = Type -type Kind = Type - type TyVarSubst = TyVarEnv Type data Type - = TyVarTy TyVar + = TyVarTy TyVar | AppTy Type -- Function is *not* a TyConApp @@ -250,135 +239,6 @@ represented by evidence (a dictionary, for example, of type (predRepTy p). %************************************************************************ %* * -\subsection{Kinds} -%* * -%************************************************************************ - -Kinds -~~~~~ -kind :: KX = kind -> kind - - | Type liftedness -- (Type *) is printed as just * - -- (Type #) is printed as just # - - | OpenKind -- Can be lifted or unlifted - -- Printed '?' - - | kv -- A kind variable; *only* happens during kind checking - -boxity :: BX = * -- Lifted - | # -- Unlifted - | bv -- A boxity variable; *only* happens during kind checking - -There's a little subtyping at the kind level: - forall b. Type b <: OpenKind - -That is, a type of kind (Type b) is OK in a context requiring an OpenKind - -OpenKind, written '?', is used as the kind for certain type variables, -in two situations: - -1. The universally quantified type variable(s) for special built-in - things like error :: forall (a::?). String -> a. - Here, the 'a' can be instantiated to a lifted or unlifted type. - -2. Kind '?' is also used when the typechecker needs to create a fresh - type variable, one that may very well later be unified with a type. - For example, suppose f::a, and we see an application (f x). Then a - must be a function type, so we unify a with (b->c). But what kind - are b and c? They can be lifted or unlifted types, or indeed type schemes, - so we give them kind '?'. - - When the type checker generalises over a bunch of type variables, it - makes any that still have kind '?' into kind '*'. So kind '?' is never - present in an inferred type. - - ------------------------------------------- -Define KX, the type of a kind - BX, the type of a boxity - -\begin{code} -superKindName = kindQual FSLIT("KX") kindConKey -superBoxityName = kindQual FSLIT("BX") boxityConKey -liftedConName = kindQual FSLIT("*") liftedConKey -unliftedConName = kindQual FSLIT("#") unliftedConKey -openKindConName = kindQual FSLIT("?") anyBoxConKey -typeConName = kindQual FSLIT("Type") typeConKey - -kindQual str uq = mkInternalName uq (mkKindOccFS tcName str) noSrcLoc - -- Kinds are not z-encoded in interface file, hence mkKindOccFS - -- And they don't come from any particular module; indeed we always - -- want to print them unqualified. Hence the InternalName. -\end{code} - -\begin{code} -superKind :: SuperKind -- KX, the type of all kinds -superKind = TyConApp (mkSuperKindCon superKindName) [] - -superBoxity :: SuperKind -- BX, the type of all boxities -superBoxity = TyConApp (mkSuperKindCon superBoxityName) [] -\end{code} - ------------------------------------------- -Define boxities: @*@ and @#@ - -\begin{code} -liftedBoxity, unliftedBoxity :: Kind -- :: BX -liftedBoxity = TyConApp liftedBoxityCon [] -unliftedBoxity = TyConApp unliftedBoxityCon [] - -liftedBoxityCon = mkKindCon liftedConName superBoxity -unliftedBoxityCon = mkKindCon unliftedConName superBoxity -\end{code} - ------------------------------------------- -Define kinds: Type, Type *, Type #, OpenKind - -\begin{code} -typeCon :: KindCon -- :: BX -> KX -typeCon = mkKindCon typeConName (superBoxity `FunTy` superKind) - -liftedTypeKind, unliftedTypeKind, openTypeKind :: Kind -- Of superkind superKind - -liftedTypeKind = TyConApp typeCon [liftedBoxity] -unliftedTypeKind = TyConApp typeCon [unliftedBoxity] - -openKindCon = mkKindCon openKindConName superKind -openTypeKind = TyConApp openKindCon [] -\end{code} - -\begin{code} -isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind :: Kind -> Bool -isLiftedTypeKind (TyConApp tc [TyConApp bc []]) = tyConName tc == typeConName && - tyConName bc == liftedConName -isLiftedTypeKind other = False - -isUnliftedTypeKind (TyConApp tc [TyConApp bc []]) = tyConName tc == typeConName && - tyConName bc == unliftedConName -isUnliftedTypeKind other = False - -isOpenTypeKind (TyConApp tc []) = tyConName tc == openKindConName -isOpenTypeKind other = False - -isSuperKind (TyConApp tc []) = tyConName tc == superKindName -isSuperKind other = False -\end{code} - ------------------------------------------- -Define arrow kinds - -\begin{code} -mkArrowKind :: Kind -> Kind -> Kind -mkArrowKind k1 k2 = k1 `FunTy` k2 - -mkArrowKinds :: [Kind] -> Kind -> Kind -mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds -\end{code} - - -%************************************************************************ -%* * TyThing %* * %************************************************************************ @@ -416,8 +276,8 @@ instance NamedThing TyThing where -- Can't put this with the type We define a few wired-in type constructors here to avoid module knots \begin{code} -funTyCon = mkFunTyCon funTyConName (mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind) - -- You might think that (->) should have type (? -> ? -> *), and you'd be right +funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) + -- You might think that (->) should have type (?? -> ? -> *), and you'd be right -- But if we do that we get kind errors when saying -- instance Control.Arrow (->) -- becuase the expected kind is (*->*->*). The trouble is that the @@ -461,11 +321,6 @@ pprType ty = ppr_type TopPrec ty pprParendType ty = ppr_type TyConPrec ty ------------------ -pprKind, pprParendKind :: Kind -> SDoc -pprKind k = ppr_kind TopPrec k -pprParendKind k = ppr_kind TyConPrec k - ------------------- pprPred :: PredType -> SDoc pprPred (ClassP cls tys) = pprClassPred cls tys pprPred (IParam ip ty) = ppr ip <> dcolon <> pprType ty @@ -552,17 +407,5 @@ pprTvBndr tv | isLiftedTypeKind kind = ppr tv | otherwise = parens (ppr tv <+> dcolon <+> pprKind kind) where kind = tyVarKind tv - - -------------------- -ppr_kind :: Prec -> Kind -> SDoc -ppr_kind p k - | isOpenTypeKind k = ptext SLIT("?") - | isLiftedTypeKind k = ptext SLIT("*") - | isUnliftedTypeKind k = ptext SLIT("#") -ppr_kind p (TyVarTy tv) = ppr tv -ppr_kind p (FunTy k1 k2) = maybeParen p FunPrec $ - sep [ ppr_kind FunPrec k1, arrow <+> pprKind k2] -ppr_kind p other = ptext SLIT("STRANGE KIND:") <+> ppr_type p other \end{code} -- 1.7.10.4