liftedTypeKind, openTypeKind, defaultKind, superKind,
superBoxity, liftedBoxity, typeKind,
tyVarsOfType, tyVarsOfTypes,
- eqKind, isTypeKind,
+ eqKind, isTypeKind, isAnyTypeKind,
isFFIArgumentTy, isFFIImportResultTy
)
+import qualified Type ( splitFunTys )
import Subst ( Subst, mkTopTyVarSubst, substTy )
import Class ( Class, classArity, className )
import TyCon ( TyCon, mkPrimTyCon, isSynTyCon, isUnboxedTupleTyCon,
- tyConArity, tyConName )
+ tyConArity, tyConName, tyConKind )
import PrimRep ( PrimRep(VoidRep) )
import Var ( TyVar, tyVarKind, tyVarName, isTyVar, mkTyVar, isMutTyVar )
-- others:
import TcMonad -- TcType, amongst others
-import TysWiredIn ( voidTy )
+import TysWiredIn ( voidTy, listTyCon, tupleTyCon )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
import ForeignCall ( Safety(..) )
import FunDeps ( grow )
mkLocalName, mkDerivedTyConOcc
)
import VarSet
+import BasicTypes ( Boxity(Boxed) )
import CmdLineOpts ( dopt, DynFlag(..) )
import Unique ( Uniquable(..) )
import SrcLoc ( noSrcLoc )
zonkTcTypeToType :: TcType -> NF_TcM Type
zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty
where
- -- Zonk a mutable but unbound type variable to
- -- Void if it has kind Lifted
- -- :Void otherwise
+ -- Zonk a mutable but unbound type variable to an arbitrary type
-- We know it's unbound even though we don't carry an environment,
-- because at the binding site for a type variable we bind the
-- mutable tyvar to a fresh immutable one. So the mutable store
-- plays the role of an environment. If we come across a mutable
-- type variable that isn't so bound, it must be completely free.
- zonk_unbound_tyvar tv
- | kind `eqKind` liftedTypeKind || kind `eqKind` openTypeKind
- = putTcTyVar tv voidTy -- Just to avoid creating a new tycon in
- -- this vastly common case
- | otherwise
- = putTcTyVar tv (TyConApp (mk_void_tycon tv kind) [])
- where
- kind = tyVarKind tv
-
- mk_void_tycon tv kind -- Make a new TyCon with the same kind as the
- -- type variable tv. Same name too, apart from
- -- making it start with a colon (sigh)
+ zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv)
+
+
+-- When the type checker finds a type variable with no binding,
+-- which means it can be instantiated with an arbitrary type, it
+-- usually instantiates it to Void. Eg.
+--
+-- length []
+-- ===>
+-- length Void (Nil Void)
+--
+-- But in really obscure programs, the type variable might have
+-- a kind other than *, so we need to invent a suitably-kinded type.
+--
+-- This commit uses
+-- Void for kind *
+-- List for kind *->*
+-- Tuple for kind *->...*->*
+--
+-- which deals with most cases. (Previously, it only dealt with
+-- kind *.)
+--
+-- In the other cases, it just makes up a TyCon with a suitable
+-- kind. If this gets into an interface file, anyone reading that
+-- file won't understand it. This is fixable (by making the client
+-- of the interface file make up a TyCon too) but it is tiresome and
+-- never happens, so I am leaving it
+
+mkArbitraryType :: TcTyVar -> Type
+-- Make up an arbitrary type whose kind is the same as the tyvar.
+-- We'll use this to instantiate the (unbound) tyvar.
+mkArbitraryType tv
+ | isAnyTypeKind kind = voidTy -- The vastly common case
+ | otherwise = TyConApp tycon []
+ where
+ kind = tyVarKind tv
+ (args,res) = Type.splitFunTys kind -- Kinds are simple; use Type.splitFunTys
+
+ tycon | kind `eqKind` tyConKind listTyCon -- *->*
+ = listTyCon -- No tuples this size
+
+ | all isTypeKind args && isTypeKind res
+ = tupleTyCon Boxed (length args) -- *-> ... ->*->*
+
+ | otherwise
+ = pprTrace "Urk! Inventing strangely-kinded void TyCon" (ppr tc_name) $
+ mkPrimTyCon tc_name kind 0 [] VoidRep
+ -- Same name as the tyvar, apart from making it start with a colon (sigh)
-- I dread to think what will happen if this gets out into an
-- interface file. Catastrophe likely. Major sigh.
- = pprTrace "Urk! Inventing strangely-kinded void TyCon" (ppr tc_name) $
- mkPrimTyCon tc_name kind 0 [] VoidRep
- where
- tc_name = mkLocalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
+
+ tc_name = mkLocalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
-- zonkTcTyVarToTyVar is applied to the *binding* occurrence
-- of a type variable, at the *end* of type checking. It changes
Kind, -- Stuff to do with kinds is insensitive to pre/post Tc
unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
superBoxity, liftedBoxity, hasMoreBoxityInfo, defaultKind, superKind,
- isTypeKind,
+ isTypeKind, isAnyTypeKind,
Type, SourceType(..), PredType, ThetaType,
mkForAllTy, mkForAllTys,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
Kind, Type, SourceType(..), PredType, ThetaType,
unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
- mkForAllTy, mkForAllTys, defaultKind, isTypeKind,
+ mkForAllTy, mkForAllTys, defaultKind, isTypeKind, isAnyTypeKind,
mkFunTy, mkFunTys, zipFunTys,
mkTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
projects / ghc-hetmet.git / commitdiff