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,
recordSelectorFieldLabel,
-- Modifying an Id
- setIdName, setIdUnique, setIdType, setIdLocalExported, setGlobalIdDetails,
+ setIdName, setIdUnique, Id.setIdType, setIdLocalExported, setGlobalIdDetails,
setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
zapLamIdInfo, zapDemandIdInfo,
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
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}
\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)
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,
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]
-> 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)
-- The Name type
Name, -- Abstract
mkInternalName, mkSystemName,
- mkSystemNameEncoded, mkSystemTvNameEncoded, mkFCallName,
- mkIPName,
+ mkSystemNameEncoded, mkSysTvName,
+ mkFCallName, mkIPName,
mkExternalName, mkWiredInName,
nameUnique, setNameUnique,
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
#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 )
\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}
\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
\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}
\begin{code}
type TyVar = Var
-\end{code}
-\begin{code}
tyVarName = varName
-tyVarKind = varType
setTyVarUnique = setVarUnique
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}
\begin{code}
idName = varName
-idType = varType
idUnique = varUnique
-idInfo = varInfo
setIdUnique :: Id -> Unique -> Id
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}
%************************************************************************
%************************************************************************
\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
-- 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}
extendModuleEnvList, extendModuleEnv,
moduleNameUserString,
ModLocation(..) )
-import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv )
import GetImports
import UniqFM
import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
import HscMain ( hscThing, hscStmt, hscTcExpr )
import TcRnDriver ( mkExportEnv, getModuleContents )
import IfaceSyn ( IfaceDecl )
+import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv )
import Name ( Name )
import NameEnv
import Id ( idType )
splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
isUnLiftedType, typeKind,
isUnboxedTupleType,
- hasMoreBoxityInfo
+ isSubKind
)
import TyCon ( isPrimTyCon )
import BasicTypes ( RecFlag(..), isNonRec )
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
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 (
import Var
import IdInfo
import Id ( idUnfolding )
+import Kind
import CoreTidy ( tidyExpr )
import VarEnv ( emptyTidyEnv )
import Literal
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
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"
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. -}
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
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 )
import {-# SOURCE #-} Match ( matchSinglePat )
import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..),
- HsMatchContext(..), Pat(..), LStmt )
+ HsMatchContext(..), Pat(..) )
import CoreSyn ( CoreExpr )
import Type ( Type )
import Var ( Id )
#include "HsVersions.h"
-import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLet )
+import {-# SOURCE #-} DsExpr ( dsLExpr, dsLet )
import BasicTypes ( Boxity(..) )
import HsSyn
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}
-- 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.
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 )
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)
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
_ -> 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
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,
\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,
#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 )
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
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)
\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
\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
| 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)
\begin{code}
module TcIface (
tcImportDecl, typecheckIface,
- tcIfaceKind, loadImportedInsts, loadImportedRules,
+ loadImportedInsts, loadImportedRules,
tcExtCoreBindings
) where
#include "HsVersions.h"
%************************************************************************
\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') }
where
(occs,kinds) = unzip bndrs
-mk_iface_tyvar name kind = mkTyVar name (tcIfaceKind kind)
+mk_iface_tyvar name kind = mkTyVar name kind
\end{code}
#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,
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
-- 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
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})
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)
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(..),
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
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)
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)
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
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
-- 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
lift cExpr@(Var id) =
do
lVar@(Var lId) <- liftVar id
- return (lVar, varType lId)
+ return (lVar, idType lId)
lift cExpr@(Lit lit) =
do
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)
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))
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
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
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
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)
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
-- 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
-- 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)
-- 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
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
| 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] }
| 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
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
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(..),
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])]
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
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
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
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(..)
)
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,
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
)
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 )
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 )
import Outputable
import Maybes ( orElse )
-import List ( partition )
\end{code}
%************************************************************************
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
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
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 )
-- 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
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 )
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
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
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 )
-- 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'))
-- 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
-- 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
-- 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' ->
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 )
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
\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
(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
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
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 }
(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]
%************************************************************************
\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"
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 )
-- 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)
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 `*'")
getInGlobalScope,
-- Local environment
- tcExtendTyVarKindEnv,
+ tcExtendKindEnv,
tcExtendTyVarEnv, tcExtendTyVarEnv2,
tcExtendLocalValEnv, tcExtendLocalValEnv2,
tcLookup, tcLookupLocated, tcLookupLocalIds,
tcLookupId, tcLookupTyVar,
lclEnvElts, getInLocalScope, findGlobals,
+ wrongThingErr,
tcExtendRecEnv, -- For knot-tying
#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 )
import NameEnv
import OccName ( mkDFunOcc, occNameString )
import HscTypes ( DFunId, extendTypeEnvList, lookupType,
- TyThing(..), tyThingId, tyThingTyCon, tyThingClass, tyThingDataCon,
+ TyThing(..), tyThingId, tyThingDataCon,
ExternalPackageState(..) )
import SrcLoc ( SrcLoc, Located(..) )
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
\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}
\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
\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}
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,
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 )
-- 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 ->
\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')
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
= 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' ->
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')
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)
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,
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)
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 )
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 )
-- 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
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 )
---------------------------
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
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)
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)
---------------------------
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}
%************************************************************************
%* *
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}
-> 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
| 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}
newTyVar, newSigTyVar,
newTyVarTy, -- Kind -> TcM TcType
newTyVarTys, -- Int -> Kind -> TcM [TcType]
- newKindVar, newKindVars, newOpenTypeKind,
+ newKindVar, newKindVars,
putTcTyVar, getTcTyVar,
newMutTyVar, readMutTyVar, writeMutTyVar,
zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV,
zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType,
zonkTcPredType, zonkTcTyVarToTyVar,
- zonkTcKindToKind
+ zonkTcKindToKind, zonkTcKind,
+
+ readKindVar, writeKindVar
) where
)
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 )
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
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}
\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}
\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' ->
short_out :: TcType -> TcM TcType
short_out ty@(TyVarTy tyvar)
- | not (isMutTyVar tyvar)
+ | not (isTcTyVar tyvar)
= returnM ty
| otherwise
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.
= 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
%************************************************************************
\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
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
%************************************************************************
%* *
+ 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}
%* *
%************************************************************************
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
= 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
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 )
[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')
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
-- 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,
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
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(..) )
-- 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*
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
\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
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 )
; (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
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 )
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 ;
= 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}
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 )
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 )
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 )
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 )
-- 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)
-- 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 $
import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..),
ConDecl(..), Sig(..), BangType(..), HsBang(..),
- tyClDeclTyVars, getBangType, getBangStrictness,
+ tyClDeclTyVars, getBangType, getBangStrictness, isSynDecl,
LTyClDecl, tcdName, LHsTyVarBndr
)
import BasicTypes ( RecFlag(..), NewOrData(..), StrictnessMark(..) )
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(..) )
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}
-- 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
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}
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' ->
-- 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
%************************************************************************
\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,
\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
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")
\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 )
import NameSet
import Digraph ( SCC(..), stronglyConnComp, stronglyConnCompR )
import BasicTypes ( RecFlag(..) )
-import SrcLoc ( Located(..) )
+import SrcLoc ( Located(..), unLoc )
import Outputable
\end{code}
---------------------------------------- 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}
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
-- 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,
tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars,
- typeKind, eqKind,
+ typeKind,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
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,
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
-- 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
type TcSigmaType = TcType
type TcRhoType = TcType
type TcTauType = TcType
-type TcKind = TcType
+
+type TcKind = Kind
\end{code}
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
| 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")
details VanillaTv = ptext SLIT("//vanilla//") -- Ditto
\end{code}
+\begin{code}
+type TcTyVarSet = TyVarSet
+\end{code}
%************************************************************************
%* *
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))
| 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
-- Various unifications
unifyTauTy, unifyTauTyList, unifyTauTyLists,
unifyKind, unifyKinds, unifyFunKind,
+ checkExpectedKind,
--------------------------------
-- Holes
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,
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 )
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
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
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)
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}
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)
| 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,
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
-- 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_`
-- 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
-- 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)
%************************************************************************
%* *
-\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}
%************************************************************************
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
(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
\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}
%************************************************************************
%* *
(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
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}
--- /dev/null
+%
+% (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:<any>. String -> a
+ (->) :: ?? -> ? -> *
+ (\(x::t) -> ...) Here t::<any> (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}
+
+
+
\begin{code}
module TyCon(
- TyCon, KindCon, SuperKindCon, ArgVrcs,
+ TyCon, ArgVrcs,
AlgTyConFlavour(..),
DataConDetails(..), visibleDataCons,
mkLiftedPrimTyCon,
mkTupleTyCon,
mkSynTyCon,
- mkKindCon,
- mkSuperKindCon,
tyConName,
tyConKind,
tyConUnique,
tyConTyVars,
- tyConArgVrcs_maybe, tyConArgVrcs,
+ tyConArgVrcs,
tyConDataConDetails, tyConDataCons, tyConDataCons_maybe, tyConFamilySize,
tyConSelIds,
tyConTheta,
#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.
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}
%************************************************************************
\begin{code}
-type KindCon = TyCon
-type SuperKindCon = TyCon
-
data TyCon
= FunTyCon {
tyConUnique :: Unique,
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"
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 {
\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}
\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,
tidyTopType, tidyPred,
-- Comparison
- eqType, eqKind,
+ eqType,
-- Seq
seqType, seqTypes,
-- Pretty-printing
- pprKind, pprParendKind,
pprType, pprParendType,
pprPred, pprTheta, pprThetaArrow, pprClassPred
) where
import {-# SOURCE #-} Subst ( substTyWith )
-- friends:
+import Kind
import Var ( TyVar, tyVarKind, tyVarName, setTyVarName )
import VarEnv
import VarSet
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
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}
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'
\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
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"
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}
\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
%************************************************************************
%* *
-\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
%* *
%************************************************************************
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
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
| 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}