diff options
| author | simonpj <unknown> | 2001-06-25 08:10:03 +0000 |
|---|---|---|
| committer | simonpj <unknown> | 2001-06-25 08:10:03 +0000 |
| commit | d069cec2bd92d4156aeab80f7eb1f222a82e4103 (patch) | |
| tree | f50bd239110777d3e9effa526df25b667fdb176e | |
| parent | 3622a7de695b4cb795171c8cb59bfe41c7f4d85f (diff) | |
| download | haskell-d069cec2bd92d4156aeab80f7eb1f222a82e4103.tar.gz | |
[project @ 2001-06-25 08:09:57 by simonpj]
----------------
Squash newtypes
----------------
This commit squashes newtypes and their coerces, from the typechecker
onwards. The original idea was that the coerces would not get in the
way of optimising transformations, but despite much effort they continue
to do so. There's no very good reason to retain newtype information
beyond the typechecker, so now we don't.
Main points:
* The post-typechecker suite of Type-manipulating functions is in
types/Type.lhs, as before. But now there's a new suite in types/TcType.lhs.
The difference is that in the former, newtype are transparent, while in
the latter they are opaque. The typechecker should only import TcType,
not Type.
* The operations in TcType are all non-monadic, and most of them start with
"tc" (e.g. tcSplitTyConApp). All the monadic operations (used exclusively
by the typechecker) are in a new module, typecheck/TcMType.lhs
* I've grouped newtypes with predicate types, thus:
data Type = TyVarTy Tyvar | ....
| SourceTy SourceType
data SourceType = NType TyCon [Type]
| ClassP Class [Type]
| IParam Type
[SourceType was called PredType.] This is a little wierd in some ways,
because NTypes can't occur in qualified types. However, the idea is that
a SourceType is a type that is opaque to the type checker, but transparent
to the rest of the compiler, and newtypes fit that as do implicit parameters
and dictionaries.
* Recursive newtypes still retain their coreces, exactly as before. If
they were transparent we'd get a recursive type, and that would make
various bits of the compiler diverge (e.g. things which do type comparison).
* I've removed types/Unify.lhs (non-monadic type unifier and matcher),
merging it into TcType.
Ditto typecheck/TcUnify.lhs (monadic unifier), merging it into TcMType.
75 files changed, 2720 insertions, 2550 deletions
diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index e9563f4fd3..195c192747 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -25,12 +25,12 @@ module DataCon ( import {-# SOURCE #-} Subst( substTy, mkTyVarSubst ) import CmdLineOpts ( opt_DictsStrict ) -import Type ( Type, TauType, ThetaType, +import Type ( Type, TauType, ThetaType, mkForAllTys, mkFunTys, mkTyConApp, - mkTyVarTys, mkPredTys, getClassPredTys_maybe, - splitTyConApp_maybe, repType + mkTyVarTys, splitTyConApp_maybe, repType ) -import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isDataTyCon, isProductTyCon, +import TcType ( isStrictPred, mkPredTys ) +import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon ) import Class ( Class, classTyCon ) import Name ( Name, NamedThing(..), nameUnique ) @@ -254,11 +254,8 @@ mkDataCon name arg_stricts fields result_ty = mkTyConApp tycon (mkTyVarTys tyvars) -mk_dict_strict_mark pred - | opt_DictsStrict, -- Don't mark newtype things as strict! - Just (clas,_) <- getClassPredTys_maybe pred, - isDataTyCon (classTyCon clas) = MarkedStrict - | otherwise = NotMarkedStrict +mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict + | otherwise = NotMarkedStrict \end{code} \begin{code} diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs index 17d13dc162..f42e1d7b63 100644 --- a/ghc/compiler/basicTypes/Demand.lhs +++ b/ghc/compiler/basicTypes/Demand.lhs @@ -7,7 +7,7 @@ module Demand( Demand(..), - wwLazy, wwStrict, wwUnpackData, wwUnpackNew, wwPrim, wwEnum, + wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum, isStrict, isLazy, isPrim, pprDemands, seqDemand, seqDemands, @@ -23,7 +23,6 @@ module Demand( #include "HsVersions.h" -import BasicTypes ( NewOrData(..) ) import Outputable \end{code} @@ -47,7 +46,6 @@ data Demand -- calling-convention magic) | WwUnpack -- Argument is strict & a single-constructor type - NewOrData Bool -- True <=> wrapper unpacks it; False <=> doesn't [Demand] -- Its constituent parts (whose StrictInfos -- are in the list) should be passed @@ -67,16 +65,14 @@ type MaybeAbsent = Bool -- True <=> not even used -- versions that don't worry about Absence: wwLazy = WwLazy False wwStrict = WwStrict -wwUnpackData xs = WwUnpack DataType False xs -wwUnpackNew x = ASSERT( isStrict x) -- Invariant - WwUnpack NewType False [x] +wwUnpack xs = WwUnpack False xs wwPrim = WwPrim wwEnum = WwEnum seqDemand :: Demand -> () -seqDemand (WwLazy a) = a `seq` () -seqDemand (WwUnpack nd b ds) = nd `seq` b `seq` seqDemands ds -seqDemand other = () +seqDemand (WwLazy a) = a `seq` () +seqDemand (WwUnpack b ds) = b `seq` seqDemands ds +seqDemand other = () seqDemands [] = () seqDemands (d:ds) = seqDemand d `seq` seqDemands ds @@ -91,8 +87,6 @@ seqDemands (d:ds) = seqDemand d `seq` seqDemands ds \begin{code} isLazy :: Demand -> Bool - -- Even a demand of (WwUnpack NewType _ _) is strict - -- We don't create such a thing unless the demand inside is strict isLazy (WwLazy _) = True isLazy _ = False @@ -124,13 +118,9 @@ pprDemand (WwLazy True) = char 'A' pprDemand WwStrict = char 'S' pprDemand WwPrim = char 'P' pprDemand WwEnum = char 'E' -pprDemand (WwUnpack nd wu args) = char ch <> parens (hcat (map pprDemand args)) +pprDemand (WwUnpack wu args) = char ch <> parens (hcat (map pprDemand args)) where - ch = case nd of - DataType | wu -> 'U' - | otherwise -> 'u' - NewType | wu -> 'N' - | otherwise -> 'n' + ch = if wu then 'U' else 'u' instance Outputable Demand where ppr (WwLazy False) = empty diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index ee5ddf62e4..34f769daa6 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -84,7 +84,7 @@ import Var ( Id, DictId, ) import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId ) import Type ( Type, typePrimRep, addFreeTyVars, - usOnce, seqType, splitTyConApp_maybe ) + usOnce, eqUsage, seqType, splitTyConApp_maybe ) import IdInfo @@ -431,7 +431,7 @@ idLBVarInfo id = lbvarInfo (idInfo id) isOneShotLambda :: Id -> Bool isOneShotLambda id = analysis || hack where analysis = case idLBVarInfo id of - LBVarInfo u | u == usOnce -> True + LBVarInfo u | u `eqUsage` usOnce -> True other -> False hack = case splitTyConApp_maybe (idType id) of Just (tycon,_) | tycon == statePrimTyCon -> True diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index c3ca29b456..29e644d73c 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -77,7 +77,7 @@ module IdInfo ( import CoreSyn -import Type ( Type, usOnce ) +import Type ( Type, usOnce, eqUsage ) import PrimOp ( PrimOp ) import NameEnv ( NameEnv, lookupNameEnv ) import Name ( Name ) @@ -395,8 +395,6 @@ data TyGenInfo -- preserve specified usage annotations | TyGenNever -- never generalise the type of this Id - - deriving ( Eq ) \end{code} For TyGenUInfo, the list has one entry for each usage annotation on @@ -428,9 +426,9 @@ ppTyGenInfo (TyGenUInfo us) = ptext SLIT("__G") <+> text (tyGenInfoString us) ppTyGenInfo TyGenNever = ptext SLIT("__G N") tyGenInfoString us = map go us - where go Nothing = 'x' -- for legibility, choose - go (Just u) | u == usOnce = '1' -- chars with identity - | u == usMany = 'M' -- Z-encoding. + where go Nothing = 'x' -- for legibility, choose + go (Just u) | u `eqUsage` usOnce = '1' -- chars with identity + | u `eqUsage` usMany = 'M' -- Z-encoding. go other = pprPanic "IdInfo.tyGenInfoString: unexpected annotation" (ppr other) instance Outputable TyGenInfo where @@ -670,7 +668,7 @@ noLBVarInfo = NoLBVarInfo -- not safe to print or parse LBVarInfo because it is not really a -- property of the definition, but a property of the context. pprLBVarInfo NoLBVarInfo = empty -pprLBVarInfo (LBVarInfo u) | u == usOnce +pprLBVarInfo (LBVarInfo u) | u `eqUsage` usOnce = getPprStyle $ \ sty -> if ifaceStyle sty then empty diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index 206df954e2..f233d58620 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -28,7 +28,8 @@ import TysPrim ( charPrimTy, addrPrimTy, floatPrimTy, doublePrimTy, intPrimTy, wordPrimTy, int64PrimTy, word64PrimTy ) import PrimRep ( PrimRep(..) ) -import Type ( Type, typePrimRep ) +import TcType ( Type, tcCmpType ) +import Type ( typePrimRep ) import PprType ( pprParendType ) import CStrings ( pprFSInCStyle ) @@ -268,7 +269,7 @@ cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b cmpLit (MachFloat a) (MachFloat b) = a `compare` b cmpLit (MachDouble a) (MachDouble b) = a `compare` b cmpLit (MachLabel a) (MachLabel b) = a `compare` b -cmpLit (MachLitLit a b) (MachLitLit c d) = (a `compare` c) `thenCmp` (b `compare` d) +cmpLit (MachLitLit a b) (MachLitLit c d) = (a `compare` c) `thenCmp` (b `tcCmpType` d) cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT | otherwise = GT diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 5e1165c2ec..477d63c541 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -39,18 +39,18 @@ import TysWiredIn ( charTy, mkListTy ) import PrelNames ( pREL_ERR, pREL_GHC ) import PrelRules ( primOpRule ) import Rules ( addRule ) -import Type ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp, - mkTyVarTys, repType, isNewType, - mkFunTys, mkFunTy, mkSigmaTy, splitSigmaTy, +import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp, + mkTyVarTys, mkClassPred, tcEqPred, + mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, - splitFunTys, splitForAllTys, mkPredTy + tcSplitFunTys, tcSplitForAllTys, mkPredTy ) import Module ( Module ) import CoreUtils ( exprType, mkInlineMe ) import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon ) import Literal ( Literal(..) ) import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, - tyConTheta, isProductTyCon, isDataTyCon ) + tyConTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon ) import Class ( Class, classTyCon, classTyVars, classSelIds ) import Var ( Id, TyVar ) import VarSet ( isEmptyVarSet ) @@ -70,7 +70,7 @@ import DataCon ( DataCon, ) import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, mkTemplateLocals, mkTemplateLocalsNum, - mkTemplateLocal, idCprInfo + mkTemplateLocal, idCprInfo, idName ) import IdInfo ( IdInfo, noCafNoTyGenIdInfo, exactArity, setUnfoldingInfo, setCprInfo, @@ -157,7 +157,7 @@ mkDataConId work_name data_con arity <= mAX_CPR_SIZE = ReturnsCPR | otherwise = NoCPRInfo -- ReturnsCPR is only true for products that are real data types; - -- that is, not unboxed tuples or newtypes + -- that is, not unboxed tuples or [non-recursive] newtypes mAX_CPR_SIZE :: Arity mAX_CPR_SIZE = 10 @@ -236,9 +236,8 @@ mkDataConWrapId data_con = ASSERT( null ex_tyvars && null ex_dict_args && length orig_arg_tys == 1 ) -- No existentials on a newtype, but it can have a context -- e.g. newtype Eq a => T a = MkT (...) - - mkLams tyvars $ mkLams dict_args $ Lam id_arg1 $ - Note (Coerce result_ty (head orig_arg_tys)) (Var id_arg1) + mkLams tyvars $ mkLams dict_args $ Lam id_arg1 $ + mkNewTypeBody tycon result_ty id_arg1 | null dict_args && not (any isMarkedStrict strict_marks) = Var work_id -- The common case. Not only is this efficient, @@ -303,24 +302,12 @@ mkDataConWrapId data_con Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))] MarkedUnboxed - | isNewType arg_ty -> - Let (NonRec coerced_arg - (Note (Coerce rep_ty arg_ty) (Var arg))) - (do_unbox coerced_arg rep_ty i') - | otherwise -> - do_unbox arg arg_ty i - where - ([coerced_arg],i') = mkLocals i [rep_ty] - arg_ty = idType arg - rep_ty = repType arg_ty - - do_unbox arg ty i = - case splitProductType "do_unbox" ty of + -> case splitProductType "do_unbox" (idType arg) of (tycon, tycon_args, con, tys) -> Case (Var arg) arg [(DataAlt con, con_args, body i' (reverse con_args ++ rep_args))] where - (con_args, i') = mkLocals i tys + (con_args, i') = mkLocals i tys \end{code} @@ -388,11 +375,11 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id -- eg data (Eq a, Ord b) => T a b = ... dict_tys = [mkPredTy pred | pred <- tycon_theta, needed_dict pred] - needed_dict pred = or [ pred `elem` (dataConTheta dc) - | (DataAlt dc, _, _) <- the_alts] + needed_dict pred = or [ tcEqPred pred p + | (DataAlt dc, _, _) <- the_alts, p <- dataConTheta dc] n_dict_tys = length dict_tys - (field_tyvars,field_theta,field_tau) = splitSigmaTy field_ty + (field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty field_dict_tys = map mkPredTy field_theta n_field_dict_tys = length field_dict_tys -- If the field has a universally quantified type we have to @@ -457,8 +444,8 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id mkLams dict_ids $ mkLams field_dict_ids $ Lam data_id $ sel_body - sel_body | isNewTyCon tycon = Note (Coerce field_tau data_ty) (Var data_id) - | otherwise = Case (Var data_id) data_id (the_alts ++ default_alt) + sel_body | isNewTyCon tycon = mkNewTypeBody tycon field_tau data_id + | otherwise = Case (Var data_id) data_id (default_alt ++ the_alts) mk_maybe_alt data_con = case maybe_the_arg_id of @@ -519,24 +506,15 @@ rebuildConArgs (arg:args) (str:stricts) us | isMarkedUnboxed str = let arg_ty = idType arg - prod_ty | isNewType arg_ty = repType arg_ty - | otherwise = arg_ty (_, tycon_args, pack_con, con_arg_tys) - = splitProductType "rebuildConArgs" prod_ty + = splitProductType "rebuildConArgs" arg_ty unpacked_args = zipWith (mkSysLocal SLIT("rb")) us con_arg_tys - - (binds, args') = rebuildConArgs args stricts - (drop (length con_arg_tys) us) - - coerce | isNewType arg_ty = Note (Coerce arg_ty prod_ty) con_app - | otherwise = con_app - - con_app = mkConApp pack_con (map Type tycon_args ++ - map Var unpacked_args) + (binds, args') = rebuildConArgs args stricts (drop (length con_arg_tys) us) + con_app = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args) in - (NonRec arg coerce : binds, unpacked_args ++ args') + (NonRec arg con_app : binds, unpacked_args ++ args') | otherwise = let (binds, args') = rebuildConArgs args stricts us @@ -558,12 +536,17 @@ ToDo: unify with mkRecordSelId. \begin{code} mkDictSelId :: Name -> Class -> Id mkDictSelId name clas - = sel_id + = mkGlobalId (RecordSelId field_lbl) name sel_ty info where - ty = exprType rhs - sel_id = mkGlobalId (RecordSelId field_lbl) name ty info - field_lbl = mkFieldLabel name tycon ty tag - tag = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id + sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id)) + -- We can't just say (exprType rhs), because that would give a type + -- C a -> C a + -- for a single-op class (after all, the selector is the identity) + -- But it's type must expose the representation of the dictionary + -- to gat (say) C a -> (a -> a) + + field_lbl = mkFieldLabel name tycon sel_ty tag + tag = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name info = noCafNoTyGenIdInfo `setCgArity` 1 @@ -583,14 +566,20 @@ mkDictSelId name clas arg_tys = dataConArgTys data_con tyvar_tys the_arg_id = arg_ids !! (tag - firstFieldLabelTag) - dict_ty = mkDictTy clas tyvar_tys - (dict_id:arg_ids) = mkTemplateLocals (dict_ty : arg_tys) + pred = mkClassPred clas tyvar_tys + (dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys) - rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $ - Note (Coerce (head arg_tys) dict_ty) (Var dict_id) + rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $ + mkNewTypeBody tycon (head arg_tys) dict_id | otherwise = mkLams tyvars $ Lam dict_id $ Case (Var dict_id) dict_id [(DataAlt data_con, arg_ids, Var the_arg_id)] + +mkNewTypeBody tycon result_ty result_id + | isRecursiveTyCon tycon -- Recursive case; use a coerce + = Note (Coerce result_ty (idType result_id)) (Var result_id) + | otherwise -- Normal case + = Var result_id \end{code} @@ -647,8 +636,8 @@ mkFCallId uniq fcall ty `setArityInfo` exactArity arity `setStrictnessInfo` strict_info - (_, tau) = splitForAllTys ty - (arg_tys, _) = splitFunTys tau + (_, tau) = tcSplitForAllTys ty + (arg_tys, _) = tcSplitFunTys tau arity = length arg_tys strict_info = mkStrictnessInfo (take arity (repeat wwPrim), False) \end{code} diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index ad25384b6c..1c3021738b 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -27,7 +27,8 @@ import Id ( Id, idType, idSpecialisation ) import NameSet import VarSet import Var ( Var, isId, isLocalVar, varName ) -import Type ( tyVarsOfType, namesOfType ) +import Type ( tyVarsOfType ) +import TcType ( namesOfType ) import Util ( mapAndUnzip ) import Outputable \end{code} diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 2fb0bd3b84..e5744e1b17 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -17,7 +17,7 @@ import IO ( hPutStr, hPutStrLn, stdout ) import CoreSyn import Rules ( RuleBase, pprRuleBase ) import CoreFVs ( idFreeVars ) -import CoreUtils ( exprOkForSpeculation, coreBindsSize, mkPiType ) +import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType ) import Bag import Literal ( literalType ) @@ -31,7 +31,7 @@ import ErrUtils ( doIfSet, dumpIfSet_core, ghcExit, Message, showPass, ErrMsg, addErrLocHdrLine, pprBagOfErrors, WarnMsg, pprBagOfWarnings) import SrcLoc ( SrcLoc, noSrcLoc ) -import Type ( Type, tyVarsOfType, +import Type ( Type, tyVarsOfType, eqType, splitFunTy_maybe, mkTyVarTy, splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp, isUnLiftedType, typeKind, @@ -304,7 +304,7 @@ lintCoreExpr e@(Case scrut var alts) addInScopeVars [var] ( -- Check the alternatives - checkAllCasesCovered e scrut_ty alts `seqL` + checkCaseAlts e scrut_ty alts `seqL` mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) -> mapL (check alt_ty) alt_tys `seqL` @@ -396,46 +396,30 @@ lintTyApps fun_ty (arg_ty : arg_tys) %************************************************************************ \begin{code} -checkAllCasesCovered :: CoreExpr -> Type -> [CoreAlt] -> LintM () - -checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e) - -checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL - -checkAllCasesCovered e scrut_ty alts - = case splitTyConApp_maybe scrut_ty of { - Nothing -> addErrL (badAltsMsg e); - Just (tycon, tycon_arg_tys) -> - - if isPrimTyCon tycon then - checkL (hasDefault alts) (nonExhaustiveAltsMsg e) - else -{- No longer needed -#ifdef DEBUG - -- Algebraic cases are not necessarily exhaustive, because - -- the simplifer correctly eliminates case that can't - -- possibly match. - -- This code just emits a message to say so - let - missing_cons = filter not_in_alts (tyConDataCons tycon) - not_in_alts con = all (not_in_alt con) alts - not_in_alt con (DataCon con', _, _) = con /= con' - not_in_alt con other = True +checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM () +-- a) Check that the alts are non-empty +-- b) Check that the DEFAULT comes first, if it exists +-- c) Check that there's a default for infinite types +-- NB: Algebraic cases are not necessarily exhaustive, because +-- the simplifer correctly eliminates case that can't +-- possibly match. + +checkCaseAlts e ty [] + = addErrL (mkNullAltsMsg e) + +checkCaseAlts e ty alts + = checkL (all non_deflt con_alts) (mkNonDefltMsg e) `seqL` + checkL (isJust maybe_deflt || not is_infinite_ty) + (nonExhaustiveAltsMsg e) + where + (con_alts, maybe_deflt) = findDefault alts - case_bndr = case e of { Case _ bndr alts -> bndr } - in - if not (hasDefault alts || null missing_cons) then - pprTrace "Exciting (but not a problem)! Non-exhaustive case:" - (ppr case_bndr <+> ppr missing_cons) - nopL - else -#endif --} - nopL } - -hasDefault [] = False -hasDefault ((DEFAULT,_,_) : alts) = True -hasDefault (alt : alts) = hasDefault alts + non_deflt (DEFAULT, _, _) = False + non_deflt alt = True + + is_infinite_ty = case splitTyConApp_maybe ty of + Nothing -> False + Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon \end{code} \begin{code} @@ -611,8 +595,8 @@ checkTys :: Type -> Type -> Message -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage -- annotations need only be consistent, not equal) checkTys ty1 ty2 msg - | ty1 == ty2 = nopL - | otherwise = addErrL msg + | ty1 `eqType` ty2 = nopL + | otherwise = addErrL msg \end{code} @@ -677,15 +661,13 @@ mkScrutMsg var scrut_ty text "Result binder type:" <+> ppr (idType var), text "Scrutinee type:" <+> ppr scrut_ty] -badAltsMsg :: CoreExpr -> Message -badAltsMsg e - = hang (text "Case statement scrutinee is not a data type:") - 4 (ppr e) + +mkNonDefltMsg e + = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e) nonExhaustiveAltsMsg :: CoreExpr -> Message nonExhaustiveAltsMsg e - = hang (text "Case expression with non-exhaustive alternatives") - 4 (ppr e) + = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) mkBadPatMsg :: Type -> Type -> Message mkBadPatMsg con_result_ty scrut_ty diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index dda8468333..f61c2d0342 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -16,7 +16,7 @@ import CoreLint ( endPass ) import CoreSyn import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy, isUnLiftedType, isUnboxedTupleType, repType, - uaUTy, usOnce, usMany, seqType ) + uaUTy, usOnce, usMany, eqUsage, seqType ) import Demand ( Demand, isStrict, wwLazy, StrictnessInfo(..) ) import PrimOp ( PrimOp(..) ) import Var ( Var, Id, setVarUnique ) @@ -493,14 +493,13 @@ rhs is strict --- but that would defeat the purpose of seq and par. \begin{code} -mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts +mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts@(deflt_alt@(DEFAULT,_,rhs) : con_alts) + -- DEFAULT alt is always first = case isPrimOpId_maybe fn of Just ParOp -> Case scrut bndr [deflt_alt] Just SeqOp -> Case arg new_bndr [deflt_alt] other -> Case scrut bndr alts where - (deflt_alt@(_,_,rhs) : _) = [alt | alt@(DEFAULT,_,_) <- alts] - -- The binder shouldn't be used in the expression! new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr ) setIdType bndr (exprType arg) @@ -539,9 +538,9 @@ isOnceTy ty once where u = uaUTy ty - once | u == usOnce = True - | u == usMany = False - | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany + once | u `eqUsage` usOnce = True + | u `eqUsage` usMany = False + | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany bdrDem :: Id -> RhsDemand bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id)) diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs index e5f5f4f604..933bd1724a 100644 --- a/ghc/compiler/coreSyn/MkExternalCore.lhs +++ b/ghc/compiler/coreSyn/MkExternalCore.lhs @@ -90,14 +90,16 @@ collect_exports tyenv (AvailTC n ns) (tcons,dcons,vars) = collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef] -collect_tdefs tcon tdefs | isAlgTyCon tcon = tdef:tdefs - where - tdef = - case newTyConRep tcon of - Just rep -> - C.Newtype (make_con_id (tyConName tcon)) (map make_tbind (tyConTyVars tcon)) (make_ty rep) - Nothing -> - C.Data (make_con_id (tyConName tcon)) (map make_tbind (tyConTyVars tcon)) (map make_cdef (tyConDataCons tcon)) +collect_tdefs tcon tdefs + | isAlgTyCon tcon = tdef : tdefs + where + tdef | isNewTyCon tcon + = C.Newtype (make_con_id (tyConName tcon)) (map make_tbind tyvars) (make_ty rep) + | otherwise + = C.Data (make_con_id (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon)) + (_, rep) = newTyConRep tcon + tyvars = tyConTyVars tcon + collect_tdefs _ tdefs = tdefs @@ -173,16 +175,16 @@ make_ty (AppTy t1 t2) = C.Tapp (make_ty t1) (make_ty t2) make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) (map make_ty ts) make_ty (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2]) make_ty (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t) -make_ty (PredTy p) = make_ty (predRepTy p) +make_ty (SourceTy p) = make_ty (sourceTypeRep p) make_ty (UsageTy _ t) = make_ty t make_ty (NoteTy _ t) = make_ty t make_kind :: Kind -> C.Kind make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2) -make_kind k | k == liftedTypeKind = C.Klifted -make_kind k | k == unliftedTypeKind = C.Kunlifted -make_kind k | k == openTypeKind = C.Kopen +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 _ = error "MkExternalCore died: make_kind" {- Id generation. -} diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index ec86225e18..0b88ea00d7 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -43,8 +43,9 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, ) import CoreFVs ( exprFreeVars ) import TypeRep ( Type(..), TyNote(..) ) -- friend -import Type ( ThetaType, PredType(..), - tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy +import Type ( ThetaType, SourceType(..), PredType, + tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy, + getTyVar_maybe ) import VarSet import VarEnv @@ -381,8 +382,11 @@ mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zip_ty_env tyvars tys emptySubstEnv) zip_ty_env [] [] env = env -zip_ty_env (tv:tvs) (ty:tys) env = UASSERT( not (isUTy ty) ) - zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty)) +zip_ty_env (tv:tvs) (ty:tys) env + | Just tv' <- getTyVar_maybe ty, tv==tv' = zip_ty_env tvs tys env + -- Shortcut for the (I think not uncommon) case where we are + -- making an identity substitution + | otherwise = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty)) \end{code} substTy works with general Substs, so that it can be called from substExpr too. @@ -398,8 +402,11 @@ substTheta subst theta | otherwise = map (substPred subst) theta substPred :: TyVarSubst -> PredType -> PredType -substPred subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys) -substPred subst (IParam n ty) = IParam n (subst_ty subst ty) +substPred = substSourceType + +substSourceType subst (IParam n ty) = IParam n (subst_ty subst ty) +substSourceType subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys) +substSourceType subst (NType tc tys) = NType tc (map (subst_ty subst) tys) subst_ty subst ty = go ty @@ -407,7 +414,7 @@ subst_ty subst ty go (TyConApp tc tys) = let args = map go tys in args `seqList` TyConApp tc args - go (PredTy p) = PredTy $! (substPred subst p) + go (SourceTy p) = SourceTy $! (substSourceType subst p) go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2) go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index dd4c9ae97d..c777de51ff 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -12,6 +12,7 @@ module Check ( check , ExhaustivePat ) where import HsSyn import TcHsSyn ( TypecheckedPat ) +import TcType ( tcTyConAppTyCon, tcTyConAppArgs ) import DsHsSyn ( outPatType ) import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet, CanItFail(..), tidyLitPat, tidyNPat, @@ -20,7 +21,7 @@ import Id ( idType ) import DataCon ( DataCon, dataConTyCon, dataConArgTys, dataConSourceArity, dataConFieldLabels ) import Name ( Name, mkLocalName, getOccName, isDataSymOcc, getName, mkVarOcc ) -import Type ( splitAlgTyConApp, mkTyVarTys, splitTyConApp_maybe ) +import TcType ( mkTyVarTys ) import TysPrim ( charPrimTy ) import TysWiredIn import PrelNames ( unboundKey ) @@ -413,17 +414,12 @@ get_unused_cons :: [TypecheckedPat] -> [DataCon] get_unused_cons used_cons = unused_cons where (ConPat _ ty _ _ _) = head used_cons - Just (ty_con,_) = sTyConApp_maybe used_cons ty + ty_con = tcTyConAppTyCon ty -- Newtype observable all_cons = tyConDataCons ty_con used_cons_as_id = map (\ (ConPat d _ _ _ _) -> d) used_cons unused_cons = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id) -sTyConApp_maybe used_cons ty = - case splitTyConApp_maybe ty of - Just x -> Just x - Nothing -> pprTrace "splitTyConApp_maybe" (ppr (used_cons, ty)) $ Nothing - all_vars :: [TypecheckedPat] -> Bool all_vars [] = True all_vars (WildPat _:ps) = all_vars ps @@ -592,9 +588,9 @@ simplify_pat (RecPat dc ty ex_tvs dicts []) where all_wild_pats = map WildPat con_arg_tys - -- identical to machinations in Match.tidy1: - (_, inst_tys, _) = splitAlgTyConApp ty - con_arg_tys = dataConArgTys dc (inst_tys ++ mkTyVarTys ex_tvs) + -- Identical to machinations in Match.tidy1: + inst_tys = tcTyConAppArgs ty -- Newtype is observable + con_arg_tys = dataConArgTys dc (inst_tys ++ mkTyVarTys ex_tvs) simplify_pat (RecPat dc ty ex_tvs dicts idps) = ConPat dc ty ex_tvs dicts pats diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index f045619bac..fce09c1bc4 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -29,7 +29,7 @@ import CostCentre ( mkAutoCC, IsCafCC(..) ) import Id ( idType, idName, isExportedId, isSpecPragmaId, Id ) import NameSet import VarSet -import Type ( mkTyVarTy ) +import TcType ( mkTyVarTy ) import Subst ( mkTyVarSubst, substTy ) import TysWiredIn ( voidTy ) import Outputable diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 3758d614d2..e9f3dd554f 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -25,21 +25,24 @@ import Maybes ( maybeToBool ) import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety, CCallConv(..) ) import DataCon ( splitProductType_maybe, dataConSourceArity, dataConWrapId ) import ForeignCall ( ForeignCall, CCallTarget(..) ) -import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys, - splitTyConApp_maybe, tyVarsOfType, mkForAllTys, isPrimitiveType, - isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp, +import TcType ( isUnLiftedType, mkFunTys, + tcSplitTyConApp_maybe, tyVarsOfType, mkForAllTys, isPrimitiveType, + isUnLiftedType, mkFunTy, mkTyConApp, + tcEqType, isBoolTy, isUnitTy, Type ) +import Type ( repType ) import PrimOp ( PrimOp(TouchOp) ) import TysPrim ( realWorldStatePrimTy, byteArrayPrimTyCon, mutableByteArrayPrimTyCon, intPrimTy, foreignObjPrimTy ) +import TyCon ( tyConDataCons ) import TysWiredIn ( unitDataConId, unboxedSingletonDataCon, unboxedPairDataCon, unboxedSingletonTyCon, unboxedPairTyCon, - boolTy, trueDataCon, falseDataCon, - trueDataConId, falseDataConId, unitTy + trueDataCon, falseDataCon, + trueDataConId, falseDataConId ) import Literal ( mkMachInt ) import CStrings ( CLabelString ) @@ -140,12 +143,8 @@ unboxArg arg | isPrimitiveType arg_ty = returnDs (arg, \body -> body) - -- Newtypes - | isNewType arg_ty - = unboxArg (mkCoerce (repType arg_ty) arg_ty arg) - -- Booleans - | arg_ty == boolTy + | isBoolTy arg_ty = newSysLocalDs intPrimTy `thenDs` \ prim_arg -> returnDs (Var prim_arg, \ body -> Case (Case arg (mkWildId arg_ty) @@ -189,7 +188,7 @@ unboxArg arg (data_con_arg_ty1 : _) = data_con_arg_tys (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys - maybe_arg3_tycon = splitTyConApp_maybe data_con_arg_ty3 + maybe_arg3_tycon = tcSplitTyConApp_maybe data_con_arg_ty3 Just (arg3_tycon,_) = maybe_arg3_tycon \end{code} @@ -214,14 +213,15 @@ boxResult :: [Id] -> Type -> DsM (Type, CoreExpr -> CoreExpr) -- the call. The arg_ids passed in are the Ids passed to the actual ccall. boxResult arg_ids result_ty - = case splitAlgTyConApp_maybe result_ty of + = case tcSplitTyConApp_maybe result_ty of -- The result is IO t, so wrap the result in an IO constructor - Just (io_tycon, [io_res_ty], [io_data_con]) | io_tycon `hasKey` ioTyConKey + Just (io_tycon, [io_res_ty]) | io_tycon `hasKey` ioTyConKey -> mk_alt return_result (resultWrapper io_res_ty) `thenDs` \ (ccall_res_ty, the_alt) -> newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id -> let + io_data_con = head (tyConDataCons io_tycon) wrap = \ the_call -> mkApps (Var (dataConWrapId io_data_con)) [ Type io_res_ty, @@ -283,7 +283,7 @@ touchzh = mkPrimOpId TouchOp mkTouches [] s cont = returnDs (cont s) mkTouches (v:vs) s cont - | idType v /= foreignObjPrimTy = mkTouches vs s cont + | not (idType v `tcEqType` foreignObjPrimTy) = mkTouches vs s cont | otherwise = newSysLocalDs realWorldStatePrimTy `thenDs` \s' -> mkTouches vs s' cont `thenDs` \ rest -> returnDs (Case (mkApps (Var touchzh) [Type foreignObjPrimTy, @@ -299,13 +299,13 @@ resultWrapper result_ty = (Just result_ty, \e -> e) -- Base case 1: the unit type () - | result_ty == unitTy + | isUnitTy result_ty = (Nothing, \e -> Var unitDataConId) - | result_ty == boolTy + | isBoolTy result_ty = (Just intPrimTy, \e -> Case e (mkWildId intPrimTy) - [(LitAlt (mkMachInt 0),[],Var falseDataConId), - (DEFAULT ,[],Var trueDataConId )]) + [(DEFAULT ,[],Var trueDataConId ), + (LitAlt (mkMachInt 0),[],Var falseDataConId)]) -- Data types with a single constructor, which has a single arg | is_product_type && data_con_arity == 1 @@ -316,14 +316,6 @@ resultWrapper result_ty (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con)) (map Type tycon_arg_tys ++ [wrapper e])) - -- newtypes - | isNewType result_ty - = let - rep_ty = repType result_ty - (maybe_ty, wrapper) = resultWrapper rep_ty - in - (maybe_ty, \e -> mkCoerce result_ty rep_ty (wrapper e)) - | otherwise = pprPanic "resultWrapper" (ppr result_ty) where diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index c435500670..2ce9440ec8 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -18,6 +18,8 @@ import HsSyn ( failureFreePat, import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt, TypecheckedMatchContext ) +import TcType ( tcSplitAppTy, tcSplitFunTys, tcSplitTyConApp_maybe, tcTyConAppArgs, + isIntegerTy, tcSplitTyConApp, isUnLiftedType, Type ) import CoreSyn import CoreUtils ( exprType, mkIfThenElse, bindNonRec ) @@ -39,11 +41,7 @@ import DataCon ( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArg import DataCon ( isExistentialDataCon ) import Literal ( Literal(..) ) import TyCon ( tyConDataCons ) -import Type ( splitFunTys, - splitAlgTyConApp, splitTyConApp_maybe, tyConAppArgs, - splitAppTy, isUnLiftedType, Type - ) -import TysWiredIn ( tupleCon, listTyCon, charDataCon, intDataCon, isIntegerTy ) +import TysWiredIn ( tupleCon, listTyCon, charDataCon, intDataCon ) import BasicTypes ( RecFlag(..), Boxity(..) ) import Maybes ( maybeToBool ) import PrelNames ( hasKey, ratioTyConKey ) @@ -165,7 +163,7 @@ dsExpr (SectionL expr op) = dsExpr op `thenDs` \ core_op -> -- for the type of y, we need the type of op's 2nd argument let - (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) + (x_ty:y_ty:_, _) = tcSplitFunTys (exprType core_op) in dsExpr expr `thenDs` \ x_core -> newSysLocalDs x_ty `thenDs` \ x_id -> @@ -179,7 +177,7 @@ dsExpr (SectionR op expr) = dsExpr op `thenDs` \ core_op -> -- for the type of x, we need the type of op's 2nd argument let - (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) + (x_ty:y_ty:_, _) = tcSplitFunTys (exprType core_op) in dsExpr expr `thenDs` \ y_core -> newSysLocalDs x_ty `thenDs` \ x_id -> @@ -242,7 +240,7 @@ dsExpr (HsDoOut do_or_lc stmts return_id then_id fail_id result_ty src_loc) dsDo do_or_lc stmts return_id then_id fail_id result_ty where maybe_list_comp - = case (do_or_lc, splitTyConApp_maybe result_ty) of + = case (do_or_lc, tcSplitTyConApp_maybe result_ty) of (ListComp, Just (tycon, [elt_ty])) | tycon == listTyCon -> Just elt_ty @@ -343,7 +341,7 @@ constructor @C@, setting all of @C@'s fields to bottom. dsExpr (RecordConOut data_con con_expr rbinds) = dsExpr con_expr `thenDs` \ con_expr' -> let - (arg_tys, _) = splitFunTys (exprType con_expr') + (arg_tys, _) = tcSplitFunTys (exprType con_expr') mk_arg (arg_ty, lbl) = case [rhs | (sel_id,rhs,_) <- rbinds, @@ -398,8 +396,8 @@ dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds) let record_in_ty = exprType record_expr' - in_inst_tys = tyConAppArgs record_in_ty - out_inst_tys = tyConAppArgs record_out_ty + in_inst_tys = tcTyConAppArgs record_in_ty + out_inst_tys = tcTyConAppArgs record_out_ty mk_val_arg field old_arg_id = case [rhs | (sel_id, rhs, _) <- rbinds, @@ -500,7 +498,7 @@ dsDo :: HsDoContext dsDo do_or_lc stmts return_id then_id fail_id result_ty = let - (_, b_ty) = splitAppTy result_ty -- result_ty must be of the form (m b) + (_, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b) is_do = case do_or_lc of DoExpr -> True ListComp -> False @@ -520,7 +518,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty = do_expr expr locn `thenDs` \ expr2 -> go stmts `thenDs` \ rest -> let - (_, a_ty) = splitAppTy (exprType expr2) -- Must be of form (m a) + (_, a_ty) = tcSplitAppTy (exprType expr2) -- Must be of form (m a) in newSysLocalDs a_ty `thenDs` \ ignored_result_id -> returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2, @@ -544,7 +542,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty = putSrcLocDs locn $ dsExpr expr `thenDs` \ expr2 -> let - (_, a_ty) = splitAppTy (exprType expr2) -- Must be of form (m a) + (_, a_ty) = tcSplitAppTy (exprType expr2) -- Must be of form (m a) fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty]) (HsLit (HsString (_PK_ msg))) msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn) @@ -612,11 +610,10 @@ dsLit (HsRat r ty) mkIntegerLit (denominator r) `thenDs` \ denom -> returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom]) where - (ratio_data_con, integer_ty) - = case splitAlgTyConApp ty of - (tycon, [i_ty], [con]) - -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) - (con, i_ty) + (ratio_data_con, integer_ty) + = case tcSplitTyConApp ty of + (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) + (head (tyConDataCons tycon), i_ty) \end{code} diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index af2e270515..2d4d53903b 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -27,18 +27,19 @@ import Name ( mkGlobalName, nameModule, nameOccName, getOccString, mkForeignExportOcc, isLocalName, NamedThing(..), ) -import Type ( repType, splitTyConApp_maybe, - splitFunTys, splitForAllTys, +import TcType ( tcSplitTyConApp_maybe, tcFunResultTy, + tcSplitFunTys, tcSplitForAllTys, Type, mkFunTys, mkForAllTys, mkTyConApp, - mkFunTy, splitAppTy, applyTy, funResultTy + mkFunTy, tcSplitAppTy, applyTy, tcEqType, isUnitTy ) +import Type ( repType ) import ForeignCall ( ForeignCall(..), CCallSpec(..), Safety(..), playSafe, CExportSpec(..), CCallConv(..), ccallConvToInt ) import CStrings ( CLabelString ) -import TysWiredIn ( unitTy, addrTy, stablePtrTyCon ) +import TysWiredIn ( addrTy, stablePtrTyCon ) import TysPrim ( addrPrimTy ) import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName, bindIOName, returnIOName @@ -119,7 +120,7 @@ dsFImport :: Module -> FoImport -> DsM ([Binding], SDoc, SDoc) dsFImport mod_name lbl_id (LblImport ext_nm) - = ASSERT(fromJust res_ty == addrPrimTy) -- typechecker ensures this + = ASSERT(fromJust res_ty `tcEqType` addrPrimTy) -- typechecker ensures this returnDs ([(lbl_id, rhs)], empty, empty) where (res_ty, fo_rhs) = resultWrapper (idType lbl_id) @@ -141,8 +142,8 @@ dsFImport mod_name fn_id (CDynImport cconv) = dsFExportDynamic mod_name fn_id cc dsFCall mod_Name fn_id fcall = let ty = idType fn_id - (tvs, fun_ty) = splitForAllTys ty - (arg_tys, io_res_ty) = splitFunTys fun_ty + (tvs, fun_ty) = tcSplitForAllTys ty + (arg_tys, io_res_ty) = tcSplitFunTys fun_ty in newSysLocalsDs arg_tys `thenDs` \ args -> mapAndUnzipDs unboxArg (map Var args) `thenDs` \ (val_args, arg_wrappers) -> @@ -216,7 +217,7 @@ dsFExport mod_name fn_id ty ext_name cconv isDyn -- Look at the result type of the exported function, orig_res_ty -- If it's IO t, return (\x.x, IO t, t) -- If it's plain t, return (\x.returnIO x, IO t, t) - (case splitTyConApp_maybe orig_res_ty of + (case tcSplitTyConApp_maybe orig_res_ty of Just (ioTyCon, [res_ty]) -> ASSERT( ioTyCon `hasKey` ioTyConKey ) -- The function already returns IO t @@ -225,7 +226,7 @@ dsFExport mod_name fn_id ty ext_name cconv isDyn other -> -- The function returns t, so wrap the call in returnIO dsLookupGlobalValue returnIOName `thenDs` \ retIOId -> returnDs (\body -> mkApps (Var retIOId) [Type orig_res_ty, body], - funResultTy (applyTy (idType retIOId) orig_res_ty), + tcFunResultTy (applyTy (idType retIOId) orig_res_ty), -- We don't have ioTyCon conveniently to hand orig_res_ty) @@ -293,11 +294,11 @@ dsFExport mod_name fn_id ty ext_name cconv isDyn returnDs (f_helper_glob, (f_helper_glob, the_body), h_stub, c_stub) where - (tvs,sans_foralls) = splitForAllTys ty - (fe_arg_tys', orig_res_ty) = splitFunTys sans_foralls + (tvs,sans_foralls) = tcSplitForAllTys ty + (fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls - (_, stbl_ptr_ty') = splitForAllTys stbl_ptr_ty - (_, stbl_ptr_to_ty) = splitAppTy stbl_ptr_ty' + (_, stbl_ptr_ty') = tcSplitForAllTys stbl_ptr_ty + (_, stbl_ptr_to_ty) = tcSplitAppTy stbl_ptr_ty' fe_arg_tys | isDyn = tail fe_arg_tys' | otherwise = fe_arg_tys' @@ -388,9 +389,9 @@ dsFExportDynamic mod_name id cconv where ty = idType id - (tvs,sans_foralls) = splitForAllTys ty - ([arg_ty], io_res_ty) = splitFunTys sans_foralls - Just (ioTyCon, [res_ty]) = splitTyConApp_maybe io_res_ty + (tvs,sans_foralls) = tcSplitForAllTys ty + ([arg_ty], io_res_ty) = tcSplitFunTys sans_foralls + Just (ioTyCon, [res_ty]) = tcSplitTyConApp_maybe io_res_ty export_ty = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty toCName :: Id -> String @@ -447,7 +448,7 @@ fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits) cParamTypes = map showStgType real_args - res_ty_is_unit = res_ty == unitTy + res_ty_is_unit = isUnitTy res_ty cResType | res_ty_is_unit = text "void" | otherwise = showStgType res_ty @@ -495,7 +496,7 @@ showStgType t = text "Hs" <> text (showFFIType t) showFFIType :: Type -> String showFFIType t = getOccString (getName tc) where - tc = case splitTyConApp_maybe (repType t) of + tc = case tcSplitTyConApp_maybe (repType t) of Just (tc,_) -> tc Nothing -> pprPanic "showFFIType" (ppr t) \end{code} diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index 57ef74f569..3f79cf801e 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -14,7 +14,7 @@ import {-# SOURCE #-} Match ( matchSinglePat ) import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..), HsMatchContext(..) ) import TcHsSyn ( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt, TypecheckedMatchContext ) import CoreSyn ( CoreExpr ) -import Type ( Type ) +import TcType ( Type ) import DsMonad import DsUtils diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs index 65911987f7..43bb8c7d49 100644 --- a/ghc/compiler/deSugar/DsHsSyn.lhs +++ b/ghc/compiler/deSugar/DsHsSyn.lhs @@ -13,7 +13,7 @@ import TcHsSyn ( TypecheckedPat, TypecheckedMonoBinds ) import Id ( idType, Id ) -import Type ( Type ) +import TcType ( Type ) import TysWiredIn ( mkListTy, mkTupleTy, unitTy ) import BasicTypes ( Boxity(..) ) \end{code} diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 929dd3e4b3..2216ae04dd 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -23,7 +23,7 @@ import CmdLineOpts ( opt_FoldrBuildOn ) import CoreUtils ( exprType, mkIfThenElse ) import Id ( idType ) import Var ( Id ) -import Type ( mkTyVarTy, mkFunTys, mkFunTy, Type ) +import TcType ( mkTyVarTy, mkFunTys, mkFunTy, Type ) import TysPrim ( alphaTyVar ) import TysWiredIn ( nilDataCon, consDataCon, unitDataConId, mkListTy, mkTupleTy ) import Match ( matchSimply ) diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 6fc4aa7494..9868a3771e 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -33,7 +33,7 @@ import Module ( Module ) import Var ( TyVar, setTyVarUnique ) import Outputable import SrcLoc ( noSrcLoc, SrcLoc ) -import Type ( Type ) +import TcType ( Type ) import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply, UniqSM, UniqSupply ) import Unique ( Unique ) diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 12ea7df333..270c896471 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -44,20 +44,18 @@ import PrelInfo ( iRREFUT_PAT_ERROR_ID ) import MkId ( rebuildConArgs ) import Id ( idType, Id, mkWildId ) import Literal ( Literal(..), inIntRange, tARGET_MAX_INT ) -import TyCon ( isNewTyCon, tyConDataCons ) +import TyCon ( isNewTyCon, tyConDataCons, isRecursiveTyCon ) import DataCon ( DataCon, dataConStrictMarks, dataConId ) -import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp, - Type - ) +import TcType ( mkFunTy, isUnLiftedType, Type ) +import TcType ( tcSplitTyConApp, isIntTy, isFloatTy, isDoubleTy ) import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy ) import TysWiredIn ( nilDataCon, consDataCon, tupleCon, - stringTy, unitDataConId, unitTy, charTy, charDataCon, - intTy, intDataCon, smallIntegerDataCon, - floatTy, floatDataCon, - doubleTy, doubleDataCon, + intDataCon, smallIntegerDataCon, + floatDataCon, + doubleDataCon, stringTy ) import BasicTypes ( Boxity(..) ) @@ -92,9 +90,9 @@ tidyNPat (HsString s) _ pat mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy] tidyNPat lit lit_ty default_pat - | lit_ty == intTy = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy] - | lit_ty == floatTy = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy] - | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy] + | isIntTy lit_ty = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy] + | isFloatTy lit_ty = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy] + | isDoubleTy lit_ty = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy] | otherwise = default_pat where @@ -252,7 +250,7 @@ mkCoPrimCaseMatchResult var match_alts where mk_case fail = mapDs (mk_alt fail) match_alts `thenDs` \ alts -> - returnDs (Case (Var var) var (alts ++ [(DEFAULT, [], fail)])) + returnDs (Case (Var var) var ((DEFAULT, [], fail) : alts)) mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body -> returnDs (LitAlt lit, [], body) @@ -264,24 +262,25 @@ mkCoAlgCaseMatchResult :: Id -- Scrutinee mkCoAlgCaseMatchResult var match_alts | isNewTyCon tycon -- Newtype case; use a let - = ASSERT( newtype_sanity ) - mkCoLetsMatchResult [coercion_bind] match_result + = ASSERT( null (tail match_alts) && null (tail arg_ids) ) + mkCoLetsMatchResult [NonRec arg_id newtype_rhs] match_result | otherwise -- Datatype case; use a case = MatchResult fail_flag mk_case where -- Common stuff - scrut_ty = idType var - (tycon, _, _) = splitAlgTyConApp scrut_ty + scrut_ty = idType var + (tycon, _) = tcSplitTyConApp scrut_ty -- Newtypes must be opaque here -- Stuff for newtype (_, arg_ids, match_result) = head match_alts - arg_id = head arg_ids - coercion_bind = NonRec arg_id (Note (Coerce (idType arg_id) - scrut_ty) - (Var var)) - newtype_sanity = null (tail match_alts) && null (tail arg_ids) + arg_id = head arg_ids + newtype_rhs | isRecursiveTyCon tycon -- Recursive case; need a case + = Note (Coerce (idType arg_id) scrut_ty) (Var var) + | otherwise -- Normal case (newtype is transparent) + = Var var + -- Stuff for data types data_cons = tyConDataCons tycon @@ -294,7 +293,7 @@ mkCoAlgCaseMatchResult var match_alts wild_var = mkWildId (idType var) mk_case fail = mapDs (mk_alt fail) match_alts `thenDs` \ alts -> - returnDs (Case (Var var) wild_var (alts ++ mk_default fail)) + returnDs (Case (Var var) wild_var (mk_default fail ++ alts)) mk_alt fail (con, args, MatchResult _ body_fn) = body_fn fail `thenDs` \ body -> diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 92dae2227f..5aa3fdceef 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -23,7 +23,7 @@ import DataCon ( dataConFieldLabels, dataConInstOrigArgTys ) import MatchCon ( matchConFamily ) import MatchLit ( matchLiterals ) import PrelInfo ( pAT_ERROR_ID ) -import Type ( splitAlgTyConApp, mkTyVarTys, Type ) +import TcType ( mkTyVarTys, Type, tcSplitTyConApp, tcEqType ) import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, tupleCon ) import BasicTypes ( Boxity(..) ) import UniqSet @@ -416,7 +416,7 @@ tidy1 v (RecPat data_con pat_ty ex_tvs dicts rpats) match_result pats = map mk_pat tagged_arg_tys -- Boring stuff to find the arg-tys of the constructor - (_, inst_tys, _) = splitAlgTyConApp pat_ty + (_, inst_tys) = tcSplitTyConApp pat_ty con_arg_tys' = dataConInstOrigArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs) tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con) @@ -735,7 +735,7 @@ flattenMatches kind matches let result_ty = head result_tys in - ASSERT( all (== result_ty) result_tys ) + ASSERT( all (tcEqType result_ty) result_tys ) returnDs (result_ty, eqn_infos) where flatten_match (Match _ pats _ grhss, n) diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs index 40943427e0..4795fdba9d 100644 --- a/ghc/compiler/deSugar/MatchCon.lhs +++ b/ghc/compiler/deSugar/MatchCon.lhs @@ -17,7 +17,7 @@ import DsUtils import Id ( Id ) import CoreSyn -import Type ( mkTyVarTys ) +import TcType ( mkTyVarTys ) import ListSetOps ( equivClassesByUniq ) import Unique ( Uniquable(..) ) \end{code} diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index 308ca8fe98..2bea1064ce 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -21,7 +21,7 @@ import DsUtils import Literal ( mkMachInt, Literal(..) ) import Maybes ( catMaybes ) -import Type ( isUnLiftedType ) +import TcType ( isUnLiftedType ) import Panic ( panic, assertPanic ) \end{code} diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index d13e802692..eb5613c91e 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -490,8 +490,7 @@ schemeT d s p app = case splitTyConApp_maybe ty of (Just (tyc, [])) | isDataTyCon tyc -> map getName (tyConDataCons tyc) - other - -> panic "maybe_is_tagToEnum_call.extract_constr_Ids" + other -> panic "maybe_is_tagToEnum_call.extract_constr_Ids" in case app of (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg) diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 66d2bf562b..dd1d718db3 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -44,7 +44,7 @@ import Literal ( Literal, maybeLitLit ) import ForeignCall ( ForeignCall ) import DataCon ( dataConTyCon, dataConSourceArity ) import TyCon ( isTupleTyCon, tupleTyConBoxity ) -import Type ( Kind ) +import Type ( Kind, eqKind ) import BasicTypes ( Arity ) import FiniteMap ( lookupFM ) import CostCentre @@ -300,7 +300,7 @@ instance (NamedThing name, Ord name) => Eq (UfExpr name) where eq_ufBinder env (UfValBinder n1 t1) (UfValBinder n2 t2) k = eq_hsType env t1 t2 && k (extendEqHsEnv env n1 n2) eq_ufBinder env (UfTyBinder n1 k1) (UfTyBinder n2 k2) k - = k1==k2 && k (extendEqHsEnv env n1 n2) + = k1 `eqKind` k2 && k (extendEqHsEnv env n1 n2) eq_ufBinder _ _ _ _ = False ----------------- diff --git a/ghc/compiler/hsSyn/HsLit.lhs b/ghc/compiler/hsSyn/HsLit.lhs index 7111cbde2b..2e33073152 100644 --- a/ghc/compiler/hsSyn/HsLit.lhs +++ b/ghc/compiler/hsSyn/HsLit.lhs @@ -39,7 +39,20 @@ data HsLit -- must resolve to boxed-primitive! -- The Type in HsLitLit is needed when desuaring; -- before the typechecker it's just an error value - deriving( Eq ) + +instance Eq HsLit where + (HsChar x1) == (HsChar x2) = x1==x2 + (HsCharPrim x1) == (HsCharPrim x2) = x1==x2 + (HsString x1) == (HsString x2) = x1==x2 + (HsStringPrim x1) == (HsStringPrim x2) = x1==x2 + (HsInt x1) == (HsInt x2) = x1==x2 + (HsIntPrim x1) == (HsIntPrim x2) = x1==x2 + (HsInteger x1) == (HsInteger x2) = x1==x2 + (HsRat x1 _) == (HsRat x2 _) = x1==x2 + (HsFloatPrim x1) == (HsFloatPrim x2) = x1==x2 + (HsDoublePrim x1) == (HsDoublePrim x2) = x1==x2 + (HsLitLit x1 _) == (HsLitLit x2 _) = x1==x2 + lit1 == lit2 = False data HsOverLit -- An overloaded literal = HsIntegral Integer -- Integer-looking literals; diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index a37e27db72..04a6192553 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -27,11 +27,11 @@ module HsTypes ( #include "HsVersions.h" import Class ( FunDep ) -import Type ( Type, Kind, ThetaType, PredType(..), - splitSigmaTy, liftedTypeKind +import TcType ( Type, Kind, ThetaType, SourceType(..), PredType, + tcSplitSigmaTy, liftedTypeKind, eqKind, tcEqType ) import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation -import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity, getSynTyConDefn ) +import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity, isNewTyCon, getSynTyConDefn ) import RdrName ( RdrName, mkUnqual ) import Name ( Name, getName ) import OccName ( NameSpace, tvName ) @@ -166,8 +166,8 @@ instance Outputable name => Outputable (HsPred name) where ppr (HsIParam n ty) = hsep [char '?' <> ppr n, text "::", ppr ty] pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc -pprHsTyVarBndr name kind | kind == liftedTypeKind = ppr name - | otherwise = hsep [ppr name, dcolon, pprParendKind kind] +pprHsTyVarBndr name kind | kind `eqKind` liftedTypeKind = ppr name + | otherwise = hsep [ppr name, dcolon, pprParendKind kind] pprHsForAll [] [] = empty pprHsForAll tvs cxt @@ -274,19 +274,18 @@ toHsType (TyVarTy tv) = HsTyVar (getName tv) toHsType (FunTy arg res) = HsFunTy (toHsType arg) (toHsType res) toHsType (AppTy fun arg) = HsAppTy (toHsType fun) (toHsType arg) -toHsType (NoteTy (SynNote syn_ty) real_ty) - | syn_matches = toHsType syn_ty -- Use synonyms if possible!! - | otherwise = +toHsType (NoteTy (SynNote ty@(TyConApp tycon tyargs)) real_ty) + | isNewTyCon tycon = toHsType ty + | syn_matches = toHsType ty -- Use synonyms if possible!! + | otherwise = #ifdef DEBUG - pprTrace "WARNING: synonym info lost in .hi file for " (ppr syn_ty) $ + pprTrace "WARNING: synonym info lost in .hi file for " (ppr syn_ty) $ #endif - toHsType real_ty -- but drop it if not. + toHsType real_ty -- but drop it if not. where - syn_matches = ty_from_syn == real_ty - - TyConApp syn_tycon tyargs = syn_ty - (tyvars,ty) = getSynTyConDefn syn_tycon - ty_from_syn = substTy (mkTyVarSubst tyvars tyargs) ty + syn_matches = ty_from_syn `tcEqType` real_ty + (tyvars,syn_ty) = getSynTyConDefn tycon + ty_from_syn = substTy (mkTyVarSubst tyvars tyargs) syn_ty -- We only use the type synonym in the file if this doesn't cause -- us to lose important information. This matters for usage @@ -299,9 +298,10 @@ toHsType (NoteTy (SynNote syn_ty) real_ty) -- error messages, but it's too much work for right now. -- KSW 2000-07. -toHsType (NoteTy _ ty) = toHsType ty +toHsType (NoteTy _ ty) = toHsType ty -toHsType (PredTy p) = HsPredTy (toHsPred p) +toHsType (SourceTy (NType tc tys)) = foldl HsAppTy (HsTyVar (getName tc)) (map toHsType tys) +toHsType (SourceTy pred) = HsPredTy (toHsPred pred) toHsType ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind * | not saturated = generic_case @@ -315,7 +315,7 @@ toHsType ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of tys' = map toHsType tys saturated = length tys == tyConArity tc -toHsType ty@(ForAllTy _ _) = case splitSigmaTy ty of +toHsType ty@(ForAllTy _ _) = case tcSplitSigmaTy ty of (tvs, preds, tau) -> HsForAllTy (Just (map toHsTyVar tvs)) (map toHsPred preds) (toHsType tau) @@ -384,7 +384,7 @@ eq_hsTyVars env (tv1:tvs1) (tv2:tvs2) k = eq_hsTyVar env tv1 tv2 $ \ env -> eq_hsTyVars env _ _ _ = False eq_hsTyVar env (UserTyVar v1) (UserTyVar v2) k = k (extendEqHsEnv env v1 v2) -eq_hsTyVar env (IfaceTyVar v1 k1) (IfaceTyVar v2 k2) k = k1 == k2 && k (extendEqHsEnv env v1 v2) +eq_hsTyVar env (IfaceTyVar v1 k1) (IfaceTyVar v2 k2) k = k1 `eqKind` k2 && k (extendEqHsEnv env v1 v2) eq_hsTyVar env _ _ _ = False eq_hsVars env [] [] k = k env diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs index efd213befd..0bca6b3ea3 100644 --- a/ghc/compiler/ilxGen/IlxGen.lhs +++ b/ghc/compiler/ilxGen/IlxGen.lhs @@ -13,11 +13,11 @@ import IdInfo ( arityLowerBound ) import Var ( Var, Id, TyVar, isId, isTyVar, tyVarKind, tyVarName ) import VarEnv import TyCon ( TyCon, tyConPrimRep, isUnboxedTupleTyCon, tyConDataCons, - newTyConRep, tyConTyVars, isDataTyCon, isAlgTyCon, tyConArity + tyConTyVars, isDataTyCon, isAlgTyCon, tyConArity ) import Type ( liftedTypeKind, openTypeKind, unliftedTypeKind, - isUnLiftedType, isTyVarTy, mkTyVarTy, predRepTy, - splitForAllTys, splitFunTys, applyTy, applyTys + isUnLiftedType, isTyVarTy, mkTyVarTy, sourceTypeRep, + splitForAllTys, splitFunTys, applyTy, applyTys, eqKind ) import TypeRep ( Type(..) ) import DataCon ( isUnboxedTupleCon, dataConTyCon, dataConRepType, dataConRepArgTys ) @@ -1115,11 +1115,7 @@ pprIlxTopVar env v isVoidIlxRepType (NoteTy _ ty) = isVoidIlxRepType ty isVoidIlxRepType (TyConApp tc _) | (tyConPrimRep tc == VoidRep) = True isVoidIlxRepType (TyConApp tc tys) - = case newTyConRep tc of - Just rep_ty -> isVoidIlxRepType (applyTys rep_ty tys) - Nothing -> - isUnboxedTupleTyCon tc && - null (filter (not. isVoidIlxRepType) tys) + = isUnboxedTupleTyCon tc && null (filter (not. isVoidIlxRepType) tys) isVoidIlxRepType _ = False isVoidIlxRepId id = isVoidIlxRepType (idType id) @@ -1132,15 +1128,7 @@ deepIlxRepType (FunTy l r) = FunTy (deepIlxRepType l) (deepIlxRepType r) deepIlxRepType ty@(TyConApp tc tys) - = case newTyConRep tc of - Just rep_ty -> - let res = deepIlxRepType (applyTys rep_ty tys) in - if not (length tys == tyConArity tc ) then - --pprTrace "deepIlxRepType" (text "length tys <> tyConArity tc, ty = " <+> pprType ty <+> text ", length tys = " <+> ppr (length tys) <+> text ", tyConArity = " <+> ppr (tyConArity tc)) - res - else res - Nothing -> - -- collapse UnboxedTupleTyCon down when it contains VoidRep types. + = -- collapse UnboxedTupleTyCon down when it contains VoidRep types. -- e.g. (# State#, Int#, Int# #) ===> (# Int#, Int# #) if isUnboxedTupleTyCon tc then let tys' = map deepIlxRepType (filter (not. isVoidIlxRepType) tys) in @@ -1149,10 +1137,10 @@ deepIlxRepType ty@(TyConApp tc tys) _ -> mkTupleTy Unboxed (length tys') tys' else TyConApp tc (map deepIlxRepType tys) -deepIlxRepType (AppTy f x) = AppTy (deepIlxRepType f) (deepIlxRepType x) +deepIlxRepType (AppTy f x) = AppTy (deepIlxRepType f) (deepIlxRepType x) deepIlxRepType (ForAllTy b ty) = ForAllTy b (deepIlxRepType ty) deepIlxRepType (NoteTy _ ty) = deepIlxRepType ty -deepIlxRepType (PredTy p) = deepIlxRepType (predRepTy p) +deepIlxRepType (SourceTy p) = deepIlxRepType (sourceTypeRep p) deepIlxRepType ty@(TyVarTy tv) = ty idIlxRepType id = deepIlxRepType (idType id) @@ -1254,9 +1242,9 @@ pprTyVarBinder_aux env tv = -- Only a subset of Haskell types can be generalized using the type quantification -- of ILX isIlxForAllKind h = - ( h == liftedTypeKind) || - ( h == unliftedTypeKind) || - ( h == openTypeKind) + ( h `eqKind` liftedTypeKind) || + ( h `eqKind` unliftedTypeKind) || + ( h `eqKind` openTypeKind) isIlxTyVar v = isTyVar v && isIlxForAllKind (tyVarKind v) diff --git a/ghc/compiler/javaGen/JavaGen.lhs b/ghc/compiler/javaGen/JavaGen.lhs index 716492991e..58d8808b3e 100644 --- a/ghc/compiler/javaGen/JavaGen.lhs +++ b/ghc/compiler/javaGen/JavaGen.lhs @@ -286,37 +286,34 @@ javaCase r e x [(DataAlt d,bs,rhs)] | length bs > 0 ] javaCase r e x alts - | isIfThenElse && isPrimCmp = - javaIfThenElse r (fromJust maybePrim) tExpr fExpr - | otherwise = - java_expr PushExpr e ++ + | isIfThenElse && isPrimCmp + = javaIfThenElse r (fromJust maybePrim) tExpr fExpr + | otherwise + = java_expr PushExpr e ++ [ var [Final] (javaName x) (whnf primRep (vmPOP (primRepToType primRep))) - , mkIfThenElse (map mk_alt alts) + , IfThenElse (map mk_alt con_alts) (Just default_code) ] where - isIfThenElse = CoreUtils.exprType e == boolTy + isIfThenElse = CoreUtils.exprType e `Type.eqType` boolTy -- also need to check that x is not free in -- any of the branches. maybePrim = findCmpPrim e [] isPrimCmp = isJust maybePrim - tExpr = matches trueDataCon alts - fExpr = matches falseDataCon alts - - matches con [] = error "no match for true or false branch of if/then/else" - matches con ((DataAlt d,[],rhs):rest) | con == d = rhs - matches con ((DEFAULT,[],rhs):_) = rhs - matches con (other:rest) = matches con rest + (_,_,tExpr) = CoreUtils.findAlt (DataAlt trueDataCon) alts + (_,_,fExpr) = CoreUtils.findAlt (DataAlt falseDataCon) alts primRep = idPrimRep x whnf PtrRep = vmWHNF -- needs evaluation whnf _ = id - mk_alt (DEFAULT, [], rhs) = (true, Block (javaExpr r rhs)) - mk_alt (DataAlt d, bs, rhs) = (instanceOf x d, Block (bind_args d bs ++ javaExpr r rhs)) - mk_alt alt@(LitAlt lit, [], rhs) - = (eqLit lit , Block (javaExpr r rhs)) - mk_alt alt@(LitAlt _, _, _) = pprPanic "mk_alt" (ppr alt) + (con_alts, maybe_default) = CoreUtils.findDefault alts + default_code = case maybe_default of + Nothing -> ExprStatement (Raise excName [Literal (StringLit "case failure")]) + Just rhs -> Block (javaExpr r rhs) + + mk_alt (DataAlt d, bs, rhs) = (instanceOf x d, Block (bind_args d bs ++ javaExpr r rhs)) + mk_alt (LitAlt lit, bs, rhs) = (eqLit lit , Block (javaExpr r rhs)) eqLit (MachInt n) = Op (Literal (IntLit n)) @@ -336,14 +333,6 @@ javaCase r e x alts , not (isDeadBinder b) ] - -mkIfThenElse [(Var (Name "true" _),code)] = code -mkIfThenElse other = IfThenElse other - (Just (ExprStatement - (Raise excName [Literal (StringLit "case failure")]) - ) - ) - javaIfThenElse r cmp tExpr fExpr {- - Now what we need to do is generate code for the if/then/else. diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 8cbf4843ed..508ec26d1c 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -50,7 +50,7 @@ import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyCo ) import Class ( classExtraBigSig, classTyCon, DefMeth(..) ) import FieldLabel ( fieldLabelType ) -import Type ( splitSigmaTy, tidyTopType, deNoteType, namesOfDFunHead ) +import TcType ( tcSplitSigmaTy, tidyTopType, deNoteType, namesOfDFunHead ) import SrcLoc ( noSrcLoc ) import Outputable import Module ( ModuleName ) @@ -160,7 +160,7 @@ ifaceTyCls (AClass clas) so_far = ASSERT(sel_tyvars == clas_tyvars) ClassOpSig (getName sel_id) def_meth' (toHsType op_ty) noSrcLoc where - (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id) + (sel_tyvars, _, op_ty) = tcSplitSigmaTy (idType sel_id) def_meth' = case def_meth of NoDefMeth -> NoDefMeth GenDefMeth -> GenDefMeth diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index daeabfb754..7cd811d0d9 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -831,15 +831,13 @@ lex_demand cont buf = 'P'# -> read_em (WwPrim : acc) (stepOn buf) 'E'# -> read_em (WwEnum : acc) (stepOn buf) ')'# -> (reverse acc, stepOn buf) - 'U'# -> do_unpack DataType True acc (stepOnBy# buf 2#) - 'u'# -> do_unpack DataType False acc (stepOnBy# buf 2#) - 'N'# -> do_unpack NewType True acc (stepOnBy# buf 2#) - 'n'# -> do_unpack NewType False acc (stepOnBy# buf 2#) + 'U'# -> do_unpack True acc (stepOnBy# buf 2#) + 'u'# -> do_unpack False acc (stepOnBy# buf 2#) _ -> (reverse acc, buf) - do_unpack new_or_data wrapper_unpacks acc buf + do_unpack wrapper_unpacks acc buf = case read_em [] buf of - (stuff, rest) -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest + (stuff, rest) -> read_em (WwUnpack wrapper_unpacks stuff : acc) rest ------------------ diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index b6e0e756b8..bf3549e296 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -32,7 +32,7 @@ import TysWiredIn ( trueDataConId, falseDataConId ) import TyCon ( tyConDataConsIfAvailable, isEnumerationTyCon, isNewTyCon ) import DataCon ( dataConTag, dataConTyCon, dataConId, fIRST_TAG ) import CoreUtils ( exprIsValue, cheapEqExpr, exprIsConApp_maybe ) -import Type ( tyConAppTyCon ) +import Type ( tyConAppTyCon, eqType ) import OccName ( occNameUserString) import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey ) import Name ( Name ) @@ -284,8 +284,8 @@ litEq is_eq name other = Nothing do_lit_eq is_eq name lit expr = Just (name, Case expr (mkWildId (literalType lit)) - [(LitAlt lit, [], val_if_eq), - (DEFAULT, [], val_if_neq)]) + [(DEFAULT, [], val_if_neq), + (LitAlt lit, [], val_if_eq)]) where val_if_eq | is_eq = trueVal | otherwise = falseVal @@ -476,7 +476,7 @@ match_append_lit_str [Type ty1, ] | unpk `hasKey` unpackCStringFoldrIdKey && c1 `cheapEqExpr` c2 - = ASSERT( ty1 == ty2 ) + = ASSERT( ty1 `eqType` ty2 ) Just (SLIT("AppendLitString"), Var unpk `App` Type ty1 `App` Lit (MachStr (s1 _APPEND_ s2)) diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 66d0035a38..4075028d49 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -31,7 +31,7 @@ import RdrName ( RdrName, mkRdrOrig ) import OccName ( OccName, pprOccName, mkVarOcc ) import TyCon ( TyCon ) import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, typePrimRep, - splitFunTy_maybe, splitAlgTyConApp_maybe, splitTyConApp, + splitFunTy_maybe, tyConAppTyCon, splitTyConApp, mkUTy, usOnce, usMany ) import Unique ( mkPrimOpIdUnique ) @@ -518,14 +518,9 @@ getPrimOpResultInfo op Dyadic _ ty -> ReturnsPrim (typePrimRep ty) Monadic _ ty -> ReturnsPrim (typePrimRep ty) Compare _ ty -> ReturnsAlg boolTyCon - GenPrimOp _ _ _ ty -> - let rep = typePrimRep ty in - case rep of - PtrRep -> case splitAlgTyConApp_maybe ty of - Nothing -> pprPanic "getPrimOpResultInfo" - (ppr ty <+> ppr op) - Just (tc,_,_) -> ReturnsAlg tc - other -> ReturnsPrim other + GenPrimOp _ _ _ ty -> case typePrimRep ty of + PtrRep -> ReturnsAlg (tyConAppTyCon ty) + rep -> ReturnsPrim rep \end{code} The commutable ops are those for which we will try to move constants diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 7e046be245..a76d6508dd 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -30,24 +30,20 @@ module TysWiredIn ( consDataCon, doubleDataCon, doubleTy, - isDoubleTy, doubleTyCon, falseDataCon, falseDataConId, floatDataCon, floatTy, - isFloatTy, floatTyCon, intDataCon, intTy, intTyCon, - isIntTy, integerTy, integerTyCon, smallIntegerDataCon, largeIntegerDataCon, - isIntegerTy, listTyCon, @@ -82,9 +78,6 @@ module TysWiredIn ( isFFIDynArgumentTy, -- :: Type -> Bool isFFIDynResultTy, -- :: Type -> Bool isFFILabelTy, -- :: Type -> Bool - isAddrTy, -- :: Type -> Bool - isForeignPtrTy -- :: Type -> Bool - ) where #include "HsVersions.h" @@ -115,7 +108,7 @@ import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTys, mkArrowKinds, liftedTypeKind, unliftedTypeKind, - splitTyConApp_maybe, repType, + splitTyConApp_maybe, TauType, ThetaType ) import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique ) import PrelNames @@ -319,13 +312,9 @@ intTy = mkTyConTy intTyCon intTyCon = pcNonRecDataTyCon intTyConName [] [] [intDataCon] intDataCon = pcDataCon intDataConName [] [] [intPrimTy] intTyCon - -isIntTy :: Type -> Bool -isIntTy = isTyCon intTyConKey \end{code} \begin{code} - wordTy = mkTyConTy wordTyCon wordTyCon = pcNonRecDataTyCon wordTyConName [] [] [wordDataCon] @@ -337,9 +326,6 @@ addrTy = mkTyConTy addrTyCon addrTyCon = pcNonRecDataTyCon addrTyConName [] [] [addrDataCon] addrDataCon = pcDataCon addrDataConName [] [] [addrPrimTy] addrTyCon - -isAddrTy :: Type -> Bool -isAddrTy = isTyCon addrTyConKey \end{code} \begin{code} @@ -361,17 +347,11 @@ floatTy = mkTyConTy floatTyCon floatTyCon = pcNonRecDataTyCon floatTyConName [] [] [floatDataCon] floatDataCon = pcDataCon floatDataConName [] [] [floatPrimTy] floatTyCon - -isFloatTy :: Type -> Bool -isFloatTy = isTyCon floatTyConKey \end{code} \begin{code} doubleTy = mkTyConTy doubleTyCon -isDoubleTy :: Type -> Bool -isDoubleTy = isTyCon doubleTyConKey - doubleTyCon = pcNonRecDataTyCon doubleTyConName [] [] [doubleDataCon] doubleDataCon = pcDataCon doubleDataConName [] [] [doublePrimTy] doubleTyCon \end{code} @@ -404,9 +384,6 @@ foreignPtrTyCon foreignPtrDataCon = pcDataCon foreignPtrDataConName alpha_tyvar [] [foreignObjPrimTy] foreignPtrTyCon - -isForeignPtrTy :: Type -> Bool -isForeignPtrTy = isTyCon foreignPtrTyConKey \end{code} %************************************************************************ @@ -427,10 +404,6 @@ smallIntegerDataCon = pcDataCon smallIntegerDataConName [] [] [intPrimTy] integerTyCon largeIntegerDataCon = pcDataCon largeIntegerDataConName [] [] [intPrimTy, byteArrayPrimTy] integerTyCon - - -isIntegerTy :: Type -> Bool -isIntegerTy = isTyCon integerTyConKey \end{code} @@ -477,16 +450,10 @@ isFFILabelTy :: Type -> Bool isFFILabelTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon) checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool - -- look through newtypes -checkRepTyCon check_tc ty = checkTyCon check_tc (repType ty) - -checkTyCon :: (TyCon -> Bool) -> Type -> Bool -checkTyCon check_tc ty = case splitTyConApp_maybe ty of + -- Look through newtypes +checkRepTyCon check_tc ty = case splitTyConApp_maybe ty of Just (tycon, _) -> check_tc tycon Nothing -> False - -isTyCon :: Unique -> Type -> Bool -isTyCon uniq ty = checkTyCon (\tc -> uniq == getUnique tc) ty \end{code} ---------------------------------------------- diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 31a90eb12d..e71a2ffe42 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -322,9 +322,7 @@ boxHigherOrderArgs almost_expr args isFunType var_type = case splitForAllTys var_type of - (_, ty) -> case splitTyConApp_maybe ty of - Just (tycon,_) | isFunTyCon tycon -> True - _ -> False + (_, ty) -> maybeToBool (splitFunTy_Maybe ty) #endif \end{code} diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index f60ae46059..443c6429cf 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -36,7 +36,7 @@ import RnEnv import RnMonad import Id ( idType, idName, globalIdDetails ) import IdInfo ( GlobalIdDetails(..) ) -import Type ( namesOfType ) +import TcType ( namesOfType ) import FieldLabel ( fieldLabelTyCon ) import DataCon ( dataConTyCon ) import TyCon ( isSynTyCon, getSynTyConDefn, tyConClass_maybe, tyConName ) diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index d28523f0b0..1dc5ab07d8 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -53,7 +53,7 @@ import Rules ( lookupRule ) import CostCentre ( currentCCS ) import Type ( mkTyVarTys, isUnLiftedType, seqType, mkFunTy, splitTyConApp_maybe, tyConAppArgs, - funResultTy, splitFunTy_maybe, splitFunTy + funResultTy, splitFunTy_maybe, splitFunTy, eqType ) import Subst ( mkSubst, substTy, substEnv, substExpr, isInScope, lookupIdSubst, simplIdInfo @@ -359,8 +359,8 @@ simplNote (Coerce to from) body cont -- we may find (coerce T (coerce S (\x.e))) y -- and we'd like it to simplify to e[y/x] in one round -- of simplification - | t1 == k1 = cont -- The coerces cancel out - | otherwise = CoerceIt t1 cont -- They don't cancel, but + | t1 `eqType` k1 = cont -- The coerces cancel out + | otherwise = CoerceIt t1 cont -- They don't cancel, but -- the inner one is redundant addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont) @@ -1424,7 +1424,8 @@ simplAlts zap_occ_info scrut_cons case_bndr' alts cont' -- handled_cons is all the constructors that are dealt -- with, either by being impossible, or by there being an alternative - handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT] + (con_alts,_) = findDefault alts + handled_cons = scrut_cons ++ [con | (con,_,_) <- con_alts] simpl_alt (DEFAULT, _, rhs) = -- In the default case we record the constructors that the diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 68cdeb7e59..591e4dbccc 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -29,8 +29,9 @@ import Id ( Id, idUnfolding, idSpecialisation, setIdSpecialisation ) import Var ( isId ) import VarSet import VarEnv -import Type ( mkTyVarTy ) -import qualified Unify ( match ) +import TcType ( mkTyVarTy ) +import qualified TcType ( match ) +import TypeRep ( Type(..) ) -- Can see type representation for matching import Outputable import Maybe ( isJust, isNothing, fromMaybe ) @@ -237,10 +238,10 @@ match (Var v1) e2 tpl_vars kont subst kont (extendSubst subst v1 (DoneEx e2)) - | eqExpr (Var v1) e2 -> kont subst + | eqExpr (Var v1) e2 -> kont subst -- v1 is not a template variable, so it must be a global constant - Just (DoneEx e2') | eqExpr e2' e2 -> kont subst + Just (DoneEx e2') | eqExpr e2' e2 -> kont subst other -> match_fail @@ -359,12 +360,6 @@ bind vs1 vs2 matcher tpl_vars kont subst bug_msg = sep [ppr vs1, ppr vs2] ---------------------------------------- -match_ty ty1 ty2 tpl_vars kont subst - = case Unify.match False {- for now: KSW 2000-10 -} ty1 ty2 tpl_vars Just (substEnv subst) of - Nothing -> match_fail - Just senv' -> kont (setSubstEnv subst senv') - ----------------------------------------- matches [] [] tpl_vars kont subst = kont subst matches (e:es) (e':es') tpl_vars kont subst @@ -378,6 +373,22 @@ mkVarArg v | isId v = Var v | otherwise = Type (mkTyVarTy v) \end{code} +Matching Core types: use the matcher in TcType. +Notice that we treat newtypes as opaque. For example, suppose +we have a specialised version of a function at a newtype, say + newtype T = MkT Int +We only want to replace (f T) with f', not (f Int). + +\begin{code} +---------------------------------------- +match_ty ty1 ty2 tpl_vars kont subst + = TcType.match ty1 ty2 tpl_vars kont' (substEnv subst) + where + kont' senv = kont (setSubstEnv subst senv) +\end{code} + + + %************************************************************************ %* * \subsection{Adding a new rule} diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index da60b7f57c..52eae0436b 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -12,9 +12,9 @@ import CmdLineOpts ( DynFlags, DynFlag(..) ) import Id ( Id, idName, idType, mkUserLocal, idSpecialisation, modifyIdInfo ) -import Type ( Type, mkTyVarTy, splitSigmaTy, +import TcType ( Type, mkTyVarTy, tcSplitSigmaTy, tyVarsOfTypes, tyVarsOfTheta, - mkForAllTys + mkForAllTys, tcCmpType ) import Subst ( Subst, mkSubst, substTy, mkSubst, extendSubstList, mkInScopeSet, simplBndr, simplBndrs, @@ -42,7 +42,7 @@ import Maybes ( catMaybes, maybeToBool ) import ErrUtils ( dumpIfSet_dyn ) import Bag import List ( partition ) -import Util ( zipEqual, zipWithEqual ) +import Util ( zipEqual, zipWithEqual, cmpList ) import Outputable @@ -818,7 +818,7 @@ specDefn subst calls (fn, rhs) -- But it might be alive for some other reason by now. fn_type = idType fn - (tyvars, theta, _) = splitSigmaTy fn_type + (tyvars, theta, _) = tcSplitSigmaTy fn_type n_tyvars = length tyvars n_dicts = length theta @@ -834,11 +834,11 @@ specDefn subst calls (fn, rhs) ---------------------------------------------------------- -- Specialise to one particular call pattern - spec_call :: ([Maybe Type], ([DictExpr], VarSet)) -- Call instance + spec_call :: (CallKey, ([DictExpr], VarSet)) -- Call instance -> SpecM ((Id,CoreExpr), -- Specialised definition UsageDetails, -- Usage details from specialised body CoreRule) -- Info for the Id's SpecEnv - spec_call (call_ts, (call_ds, call_fvs)) + spec_call (CallKey call_ts, (call_ds, call_fvs)) = ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts ) -- Calls are only recorded for properly-saturated applications @@ -924,12 +924,13 @@ type DictExpr = CoreExpr emptyUDs = MkUD { dict_binds = emptyBag, calls = emptyFM } type ProtoUsageDetails = ([DictBind], - [(Id, [Maybe Type], ([DictExpr], VarSet))] + [(Id, CallKey, ([DictExpr], VarSet))] ) ------------------------------------------------------------ type CallDetails = FiniteMap Id CallInfo -type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type argument +newtype CallKey = CallKey [Maybe Type] -- Nothing => unconstrained type argument +type CallInfo = FiniteMap CallKey ([DictExpr], VarSet) -- Dict args and the vars of the whole -- call (including tyvars) -- [*not* include the main id itself, of course] @@ -937,12 +938,25 @@ type CallInfo = FiniteMap [Maybe Type] -- Nothing => unconstrained type ar -- The list of types and dictionaries is guaranteed to -- match the type of f +-- Type isn't an instance of Ord, so that we can control which +-- instance we use. That's tiresome here. Oh well +instance Eq CallKey where + k1 == k2 = case k1 `compare` k2 of { EQ -> True; other -> False } + +instance Ord CallKey where + compare (CallKey k1) (CallKey k2) = cmpList cmp k1 k2 + where + cmp Nothing Nothing = EQ + cmp Nothing (Just t2) = LT + cmp (Just t1) Nothing = GT + cmp (Just t1) (Just t2) = tcCmpType t1 t2 + unionCalls :: CallDetails -> CallDetails -> CallDetails unionCalls c1 c2 = plusFM_C plusFM c1 c2 singleCall :: Id -> [Maybe Type] -> [DictExpr] -> CallDetails singleCall id tys dicts - = unitFM id (unitFM tys (dicts, call_fvs)) + = unitFM id (unitFM (CallKey tys) (dicts, call_fvs)) where call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs tys_fvs = tyVarsOfTypes (catMaybes tys) @@ -964,7 +978,7 @@ listToCallDetails calls callDetailsToList calls = [ (id,tys,dicts) | (id,fm) <- fmToList calls, - (tys,dicts) <- fmToList fm + (tys, dicts) <- fmToList fm ] mkCallUDs subst f args @@ -983,7 +997,7 @@ mkCallUDs subst f args calls = singleCall f spec_tys dicts } where - (tyvars, theta, _) = splitSigmaTy (idType f) + (tyvars, theta, _) = tcSplitSigmaTy (idType f) constrained_tyvars = tyVarsOfTheta theta n_tyvars = length tyvars n_dicts = length theta diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 72a1ffb56c..3692e06e42 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -19,10 +19,10 @@ import Literal ( literalType, Literal ) import Maybes ( catMaybes ) import Name ( getSrcLoc ) import ErrUtils ( ErrMsg, Message, addErrLocHdrLine, pprBagOfErrors, dontAddErrLoc ) -import Type ( mkFunTys, splitFunTys, splitAlgTyConApp_maybe, splitTyConApp_maybe, +import Type ( mkFunTys, splitFunTys, splitTyConApp_maybe, isUnLiftedType, isTyVarTy, splitForAllTys, Type ) -import TyCon ( TyCon ) +import TyCon ( TyCon, isDataTyCon, tyConDataCons ) import Util ( zipEqual ) import Outputable @@ -253,11 +253,10 @@ lintStgAlts alts scrut_ty check ty = checkTys first_ty ty (mkCaseAltMsg alts) lintAlgAlt scrut_ty (con, args, _, rhs) - = (case splitAlgTyConApp_maybe scrut_ty of - Nothing -> - addErrL (mkAlgAltMsg1 scrut_ty) - Just (tycon, tys_applied, cons) -> + = (case splitTyConApp_maybe scrut_ty of + Just (tycon, tys_applied) | isDataTyCon tycon -> let + cons = tyConDataCons tycon arg_tys = dataConArgTys con tys_applied -- This almost certainly does not work for existential constructors in @@ -266,6 +265,8 @@ lintAlgAlt scrut_ty (con, args, _, rhs) `thenL_` mapL check (zipEqual "lintAlgAlt:stg" arg_tys args) `thenL_` returnL () + other -> + addErrL (mkAlgAltMsg1 scrut_ty) ) `thenL_` addInScopeVars args ( lintStgExpr rhs @@ -425,7 +426,7 @@ checkFunApp :: Type -- The function type checkFunApp fun_ty arg_tys msg loc scope errs = cfa res_ty expected_arg_tys arg_tys where - (_, de_forall_ty) = splitForAllTys fun_ty + (_, de_forall_ty) = splitForAllTys fun_ty (expected_arg_tys, res_ty) = splitFunTys de_forall_ty cfa res_ty expected [] -- Args have run out; that's fine diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index 4cef8c959c..faa23467d6 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -21,11 +21,11 @@ import CoreUnfold ( maybeUnfoldingTemplate ) import Id ( Id, idType, idStrictness, idUnfolding, isDataConId_maybe ) import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys ) import IdInfo ( StrictnessInfo(..) ) -import Demand ( Demand(..), wwPrim, wwStrict, wwUnpackData, wwLazy, wwUnpackNew, +import Demand ( Demand(..), wwPrim, wwStrict, wwUnpack, wwLazy, mkStrictnessInfo, isLazy ) import SaLib -import TyCon ( isProductTyCon, isRecursiveTyCon, isNewTyCon ) +import TyCon ( isProductTyCon, isRecursiveTyCon ) import BasicTypes ( NewOrData(..) ) import Type ( splitTyConApp_maybe, isUnLiftedType, Type ) @@ -285,10 +285,7 @@ evalStrictness (WwLazy _) _ = False evalStrictness WwStrict val = isBot val evalStrictness WwEnum val = isBot val -evalStrictness (WwUnpack NewType _ (demand:_)) val - = evalStrictness demand val - -evalStrictness (WwUnpack DataType _ demand_info) val +evalStrictness (WwUnpack _ demand_info) val = case val of AbsTop -> False AbsBot -> True @@ -313,10 +310,7 @@ possibly} hit poison. evalAbsence (WwLazy True) _ = False -- Can't possibly hit poison -- with Absent demand -evalAbsence (WwUnpack NewType _ (demand:_)) val - = evalAbsence demand val - -evalAbsence (WwUnpack DataType _ demand_info) val +evalAbsence (WwUnpack _ demand_info) val = case val of AbsTop -> False -- No poison in here AbsBot -> True -- Pure poison @@ -633,8 +627,8 @@ find_strictness id orig_str_ds orig_str_res orig_abs_ds -- to be strict in it. Unless the function diverges. WwLazy True -- Best of all - mk_dmd (WwUnpack nd u str_ds) - (WwUnpack _ _ abs_ds) = WwUnpack nd u (go str_ds abs_ds) + mk_dmd (WwUnpack u str_ds) + (WwUnpack _ abs_ds) = WwUnpack u (go str_ds abs_ds) mk_dmd str_dmd abs_dmd = str_dmd \end{code} @@ -717,18 +711,11 @@ findRecDemand str_fn abs_fn ty -> wwStrict -- (this applies to newtypes too: -- e.g. data Void = MkVoid Void) - | isNewTyCon tycon -- A newtype! - -> ASSERT( null (tail cmpnt_tys) ) - let - demand = findRecDemand str_fn abs_fn (head cmpnt_tys) - in - wwUnpackNew demand - | null compt_strict_infos -- A nullary data type -> wwStrict | otherwise -- Some other data type - -> wwUnpackData compt_strict_infos + -> wwUnpack compt_strict_infos where prod_len = length cmpnt_tys diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 639bfdb954..58e294d04d 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -15,7 +15,7 @@ import CoreUtils ( exprType ) import Id ( Id, idType, idStrictness, idArity, isOneShotLambda, setIdStrictness, idInlinePragma, mkWorkerId, setIdWorkerInfo, idCprInfo, setInlinePragma ) -import Type ( Type, isNewType, splitForAllTys, splitFunTys ) +import Type ( Type, splitForAllTys, splitFunTys ) import IdInfo ( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..), CprInfo(..), InlinePragInfo(..), isNeverInlinePrag, WorkerInfo(..) @@ -204,20 +204,6 @@ tryWW non_rec fn_id rhs -- inside its __inline wrapper. Death! Disaster! -- -- OUT OF DATE NOTE: - -- [There used to be "&& not do_coerce_ww" in the above test. - -- No longer necessary because SimplUtils.tryEtaExpansion - -- now deals with coerces.] - -- The do_coerce_ww test is so that - -- a function with a coerce should w/w to get rid - -- of the coerces, which can significantly improve its arity. - -- Example: f [] = return [] :: IO [Int] - -- f (x:xs) = return (x:xs) - -- If we aren't careful we end up with - -- f = \ x -> case x of { - -- x:xs -> __coerce (IO [Int]) (\ s -> (# s, x:xs #) - -- [] -> lvl_sJ8 - -- - -- OUT OF DATE NOTE: -- [Out of date because the size calculation in CoreUnfold now -- makes wrappers look very cheap even when they are inlined.] -- In this case we add an INLINE pragma to the RHS. Why? @@ -229,7 +215,7 @@ tryWW non_rec fn_id rhs -- So f doesn't get inlined, but it is strict and we have failed to w/w it. = returnUs [ (fn_id, rhs) ] - | not (do_strict_ww || do_cpr_ww || do_coerce_ww) + | not (do_strict_ww || do_cpr_ww) = returnUs [ (fn_id, rhs) ] | otherwise -- Do w/w split @@ -292,32 +278,8 @@ tryWW non_rec fn_id rhs other -> False ------------------------------------------------------------- - do_coerce_ww = check_for_coerce arity fun_ty - -- We are willing to do a w/w even if the arity is zero. - -- x = coerce t E - -- ==> - -- x' = E - -- x = coerce t x' - - ------------------------------------------------------------- one_shots = get_one_shots rhs --- See if there's a Coerce before we run out of arity; --- if so, it's worth trying a w/w split. Reason: we find --- functions like f = coerce (\s -> e) --- and g = \x -> coerce (\s -> e) --- and they may have no useful strictness or cpr info, but if we --- do the w/w thing we get rid of the coerces. - -check_for_coerce arity ty - = length arg_tys <= arity && isNewType res_ty - -- Don't look further than arity args, - -- but if there are arity or fewer, see if there's - -- a newtype in the corner - where - (_, tau) = splitForAllTys ty - (arg_tys, res_ty) = splitFunTys tau - -- If the original function has one-shot arguments, it is important to -- make the wrapper and worker have corresponding one-shot arguments too. -- Otherwise we spuriously float stuff out of case-expression join points, diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 1bcf59bef6..96ba8f3e43 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -23,9 +23,8 @@ import Demand ( Demand(..), wwLazy, wwPrim ) import PrelInfo ( realWorldPrimId, aBSENT_ERROR_ID ) import TysPrim ( realWorldStatePrimTy ) import TysWiredIn ( tupleCon ) -import Type ( Type, isUnLiftedType, - splitForAllTys, splitFunTys, isAlgType, - splitNewType_maybe, mkFunTys +import Type ( Type, isUnLiftedType, mkFunTys, + splitForAllTys, splitFunTys, isAlgType ) import BasicTypes ( NewOrData(..), Arity, Boxity(..) ) import Var ( Var, isId ) @@ -157,10 +156,10 @@ setUnpackStrategy ds -> [Demand] -> (Int, [Demand]) -- Args remaining after subcomponents of [Demand] are unpacked - go n (WwUnpack nd _ cs : ds) | n' >= 0 - = WwUnpack nd True cs' `cons` go n'' ds - | otherwise - = WwUnpack nd False cs `cons` go n ds + go n (WwUnpack _ cs : ds) | n' >= 0 + = WwUnpack True cs' `cons` go n'' ds + | otherwise + = WwUnpack False cs `cons` go n ds where n' = n + 1 - nonAbsentArgs cs -- Add one because we don't pass the top-level arg any more @@ -191,17 +190,17 @@ worthSplitting ds result_bot = any worth_it ds -- The re-boxing code won't go away unless error_fn gets a wrapper too. where - worth_it (WwLazy True) = True -- Absent arg - worth_it (WwUnpack _ True _) = True -- Arg to unpack - worth_it WwStrict = False -- Don't w/w just because of strictness - worth_it other = False + worth_it (WwLazy True) = True -- Absent arg + worth_it (WwUnpack True _) = True -- Arg to unpack + worth_it WwStrict = False -- Don't w/w just because of strictness + worth_it other = False allAbsent :: [Demand] -> Bool allAbsent ds = all absent ds where - absent (WwLazy is_absent) = is_absent - absent (WwUnpack _ True cs) = allAbsent cs - absent other = False + absent (WwLazy is_absent) = is_absent + absent (WwUnpack True cs) = allAbsent cs + absent other = False \end{code} @@ -333,14 +332,7 @@ mkWWargs fun_ty arity demands res_bot one_shots | otherwise = mkFunTys (drop n_args arg_tys) body_ty mkWWargs fun_ty arity demands res_bot one_shots - = case splitNewType_maybe fun_ty of - Nothing -> returnUs ([], id, id, fun_ty) - Just rep_ty -> mkWWargs rep_ty arity demands res_bot one_shots `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) -> - returnUs (wrap_args, - Note (Coerce fun_ty rep_ty) . wrap_fn_args, - work_fn_args . Note (Coerce rep_ty fun_ty), - res_ty) - + = returnUs ([], id, id, fun_ty) applyToVars :: [Var] -> CoreExpr -> CoreExpr applyToVars vars fn = mkVarApps fn vars @@ -420,7 +412,7 @@ mk_ww_str (arg : ds) returnUs (worker_args, wrap_fn, mk_absent_let arg . work_fn) -- Unpack case - WwUnpack new_or_data True cs -> + WwUnpack True cs -> getUniquesUs `thenUs` \ uniqs -> let unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys @@ -428,8 +420,8 @@ mk_ww_str (arg : ds) in mk_ww_str (unpk_args_w_ds ++ ds) `thenUs` \ (worker_args, wrap_fn, work_fn) -> returnUs (worker_args, - mk_unpk_case new_or_data arg unpk_args data_con arg_tycon . wrap_fn, - work_fn . mk_pk_let new_or_data arg data_con tycon_arg_tys unpk_args) + mk_unpk_case arg unpk_args data_con arg_tycon . wrap_fn, + work_fn . mk_pk_let arg data_con tycon_arg_tys unpk_args) where (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys) = splitProductType "mk_ww_str" (idType arg) @@ -540,16 +532,7 @@ mk_absent_let arg body where arg_ty = idType arg -mk_unpk_case NewType arg unpk_args boxing_con boxing_tycon body - -- A newtype! Use a coercion not a case - = ASSERT( null other_args ) - Case (Note (Coerce (idType unpk_arg) (idType arg)) (Var arg)) - (sanitiseCaseBndr unpk_arg) - [(DEFAULT,[],body)] - where - (unpk_arg:other_args) = unpk_args - -mk_unpk_case DataType arg unpk_args boxing_con boxing_tycon body +mk_unpk_case arg unpk_args boxing_con boxing_tycon body -- A data type = Case (Var arg) (sanitiseCaseBndr arg) @@ -566,13 +549,7 @@ sanitiseCaseBndr :: Id -> Id -- like (x+y) `seq` .... sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo -mk_pk_let NewType arg boxing_con con_tys unpk_args body - = ASSERT( null other_args ) - Let (NonRec arg (Note (Coerce (idType arg) (idType unpk_arg)) (Var unpk_arg))) body - where - (unpk_arg:other_args) = unpk_args - -mk_pk_let DataType arg boxing_con con_tys unpk_args body +mk_pk_let arg boxing_con con_tys unpk_args body = Let (NonRec arg (mkConApp boxing_con con_args)) body where con_args = map Type con_tys ++ map Var unpk_args diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 3cdbf52f29..554037264b 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -41,10 +41,20 @@ import TcHsSyn ( TcExpr, TcId, import TcMonad import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupSyntaxId ) import InstEnv ( InstLookupResult(..), lookupInstEnv ) -import TcType ( TcThetaType, - TcType, TcTauType, TcTyVarSet, - zonkTcType, zonkTcTypes, zonkTcPredType, - zonkTcThetaType, tcInstTyVar, tcInstType +import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, + zonkTcThetaType, tcInstTyVar, tcInstType, + ) +import TcType ( Type, + SourceType(..), PredType, ThetaType, + tcSplitForAllTys, tcSplitForAllTys, + tcSplitMethodTy, tcSplitRhoTy, tcFunArgTy, + isIntTy,isFloatTy, isIntegerTy, isDoubleTy, + tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys, + tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred, + predMentionsIPs, isClassPred, isTyVarClassPred, + getClassPredTys, getClassPredTys_maybe, mkPredName, + tidyType, tidyTypes, tidyFreeTyVars, + tcCmpType, tcCmpTypes, tcCmpPred ) import CoreFVs ( idFreeTyVars ) import Class ( Class ) @@ -53,26 +63,13 @@ import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) import Name ( Name, mkMethodOcc, getOccName ) import NameSet ( NameSet ) import PprType ( pprPred ) -import Type ( Type, PredType(..), ThetaType, - isTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys, - splitForAllTys, splitSigmaTy, funArgTy, - splitMethodTy, splitRhoTy, - tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred, - predMentionsIPs, isClassPred, isTyVarClassPred, - getClassPredTys, getClassPredTys_maybe, mkPredName, - tidyType, tidyTypes, tidyFreeTyVars - ) import Subst ( emptyInScopeSet, mkSubst, substTy, substTheta, mkTyVarSubst, mkTopTyVarSubst ) import Literal ( inIntRange ) import VarEnv ( TidyEnv, lookupSubstEnv, SubstResult(..) ) import VarSet ( elemVarSet, emptyVarSet, unionVarSet ) -import TysWiredIn ( isIntTy, - floatDataCon, isFloatTy, - doubleDataCon, isDoubleTy, - isIntegerTy - ) +import TysWiredIn ( floatDataCon, doubleDataCon ) import PrelNames( fromIntegerName, fromRationalName ) import Util ( thenCmp ) import Bag @@ -178,14 +175,14 @@ instance Eq Inst where EQ -> True other -> False -cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = (pred1 `compare` pred2) +cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = pred1 `tcCmpPred` pred2 cmpInst (Dict _ _ _) other = LT cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT -cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2) +cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `tcCmpTypes` tys2) cmpInst (Method _ _ _ _ _ _) other = LT -cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit2) `thenCmp` (ty1 `compare` ty2) +cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit2) `thenCmp` (ty1 `tcCmpType` ty2) cmpInst (LitInst _ _ _ _) other = GT -- and they can only have HsInt or HsFracs in them. @@ -266,7 +263,7 @@ instMentionsIPs (Method _ _ _ theta _ _) ip_names = any (`predMentionsIPs` ip_na instMentionsIPs other ip_names = False isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of - Just (clas, [ty]) -> isStandardClass clas && isTyVarTy ty + Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty other -> False \end{code} @@ -393,9 +390,9 @@ newMethod :: InstOrigin newMethod orig id tys = -- Get the Id type and instantiate it at the specified types let - (tyvars, rho) = splitForAllTys (idType id) + (tyvars, rho) = tcSplitForAllTys (idType id) rho_ty = substTy (mkTyVarSubst tyvars tys) rho - (pred, tau) = splitMethodTy rho_ty + (pred, tau) = tcSplitMethodTy rho_ty in newMethodWithGivenTy orig id tys [pred] tau @@ -417,10 +414,10 @@ newMethodAtLoc inst_loc real_id tys -- This actually builds the Inst = -- Get the Id type and instantiate it at the specified types let - (tyvars,rho) = splitForAllTys (idType real_id) + (tyvars,rho) = tcSplitForAllTys (idType real_id) rho_ty = ASSERT( length tyvars == length tys ) substTy (mkTopTyVarSubst tyvars tys) rho - (theta, tau) = splitRhoTy rho_ty + (theta, tau) = tcSplitRhoTy rho_ty in newMethodWith inst_loc real_id tys theta tau `thenNF_Tc` \ meth_inst -> returnNF_Tc (meth_inst, instToId meth_inst) @@ -559,7 +556,7 @@ lookupInst dict@(Dict _ (ClassP clas tys) loc) FoundInst tenv dfun_id -> let - (tyvars, rho) = splitForAllTys (idType dfun_id) + (tyvars, rho) = tcSplitForAllTys (idType dfun_id) mk_ty_arg tv = case lookupSubstEnv tenv tv of Just (DoneTy ty) -> returnNF_Tc ty Nothing -> tcInstTyVar tv `thenNF_Tc` \ tc_tv -> @@ -569,7 +566,7 @@ lookupInst dict@(Dict _ (ClassP clas tys) loc) let subst = mkTyVarSubst tyvars ty_args dfun_rho = substTy subst rho - (theta, _) = splitRhoTy dfun_rho + (theta, _) = tcSplitRhoTy dfun_rho ty_app = mkHsTyApp (HsVar dfun_id) ty_args in if null theta then @@ -622,7 +619,7 @@ lookupInst inst@(LitInst u (HsFractional f) ty loc) = tcLookupSyntaxId fromRationalName `thenNF_Tc` \ from_rational -> newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) -> let - rational_ty = funArgTy (idType method_id) + rational_ty = tcFunArgTy (idType method_id) rational_lit = HsLit (HsRat f rational_ty) in returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit)) @@ -641,7 +638,7 @@ ambiguous dictionaries. \begin{code} lookupSimpleInst :: Class - -> [Type] -- Look up (c,t) + -> [Type] -- Look up (c,t) -> NF_TcM (Maybe ThetaType) -- Here are the needed (c,t)s lookupSimpleInst clas tys @@ -650,7 +647,8 @@ lookupSimpleInst clas tys FoundInst tenv dfun -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta)) where - (_, theta, _) = splitSigmaTy (idType dfun) + (_, rho) = tcSplitForAllTys (idType dfun) + (theta,_) = tcSplitRhoTy rho other -> returnNF_Tc Nothing \end{code} diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 70ee5bd85f..7f630a3fe9 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -33,10 +33,14 @@ import TcMonoType ( tcHsSigType, checkSigTyVars, ) import TcPat ( tcPat ) import TcSimplify ( bindInstsOfLocalFuns ) -import TcType ( newTyVarTy, newTyVar, - zonkTcTyVarToTyVar +import TcMType ( newTyVarTy, newTyVar, + zonkTcTyVarToTyVar, + unifyTauTy, unifyTauTyLists + ) +import TcType ( mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, + mkPredTy, mkForAllTy, isUnLiftedType, + unliftedTypeKind, liftedTypeKind, openTypeKind, eqKind ) -import TcUnify ( unifyTauTy, unifyTauTyLists ) import CoreFVs ( idFreeTyVars ) import Id ( mkLocalId, setInlinePragma ) @@ -44,10 +48,6 @@ import Var ( idType, idName ) import IdInfo ( InlinePragInfo(..) ) import Name ( Name, getOccName, getSrcLoc ) import NameSet -import Type ( mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, - mkPredTy, mkForAllTy, isUnLiftedType, - unliftedTypeKind, liftedTypeKind, openTypeKind - ) import Var ( tyVarKind ) import VarSet import Bag @@ -223,7 +223,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec -- TYPECHECK THE BINDINGS tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) -> let - tau_tvs = varSetElems (foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids) + tau_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids in -- GENERALISE @@ -309,7 +309,7 @@ attachNoInlinePrag no_inlines bndr Nothing -> bndr checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind zonked_mono_ids - = ASSERT( not (any ((== unliftedTypeKind) . tyVarKind) real_tyvars_to_gen) ) + = ASSERT( not (any ((eqKind unliftedTypeKind) . 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 @@ -433,7 +433,7 @@ generalise binder_names mbind tau_tvs lie_req sigs = -- CHECKING CASE: Unrestricted group, there are type signatures -- Check signature contexts are empty checkSigsCtxts sigs `thenTc` \ (sig_avails, sig_dicts) -> - + -- Check that the needed dicts can be -- expressed in terms of the signature ones tcSimplifyInferCheck doc tau_tvs sig_avails lie_req `thenTc` \ (forall_tvs, lie_free, dict_binds) -> diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 43e833407c..d852d485f7 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -33,7 +33,8 @@ import TcEnv ( RecTcEnv, TyThingDetails(..), tcAddImportedIdInfo, import TcBinds ( tcBindWithSigs, tcSpecSigs ) import TcMonoType ( tcHsRecType, tcRecTheta, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig ) import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns ) -import TcType ( TcType, TcTyVar, tcInstTyVars ) +import TcMType ( tcInstTyVars ) +import TcType ( Type, ThetaType, mkTyVarTys, mkPredTys, mkClassPred, tcIsTyVarTy, tcSplitTyConApp_maybe ) import TcMonad import Generics ( mkGenericRhs, validGenericMethodType ) import PrelInfo ( nO_METHOD_BINDING_ERROR_ID ) @@ -48,9 +49,6 @@ import Name ( Name, NamedThing(..) ) import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts ) import NameSet ( emptyNameSet ) import Outputable -import Type ( Type, ThetaType, mkTyVarTys, mkPredTys, mkClassPred, - splitTyConApp_maybe, isTyVarTy - ) import Var ( TyVar ) import VarSet ( mkVarSet, emptyVarSet ) import CmdLineOpts @@ -597,9 +595,9 @@ mkDefMethRhs is_inst_decl clas inst_tys sel_id loc GenDefMeth clas_tyvar = head (classTyVars clas) Just tycon = maybe_tycon maybe_tycon = case inst_tys of - [ty] -> case splitTyConApp_maybe ty of - Just (tycon, arg_tys) | all isTyVarTy arg_tys -> Just tycon - other -> Nothing + [ty] -> case tcSplitTyConApp_maybe ty of + Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon + other -> Nothing other -> Nothing \end{code} diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs index c0330d4ae6..66e56ef745 100644 --- a/ghc/compiler/typecheck/TcDefaults.lhs +++ b/ghc/compiler/typecheck/TcDefaults.lhs @@ -17,7 +17,7 @@ import TcMonoType ( tcHsType ) import TcSimplify ( tcSimplifyCheckThetas ) import TysWiredIn ( integerTy, doubleTy ) -import Type ( Type, mkClassPred ) +import TcType ( Type, mkClassPred ) import PrelNames ( numClassName ) import Outputable import HscTypes ( TyThing(..) ) diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 95d9695992..54a8e720d5 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -44,7 +44,7 @@ import TyCon ( tyConTyVars, tyConDataCons, tyConTheta, maybeTyConSingleCon, isDataTyCon, isEnumerationTyCon, TyCon ) -import Type ( ThetaType, mkTyVarTys, mkTyConApp, +import TcType ( ThetaType, mkTyVarTys, mkTyConApp, isUnLiftedType, mkClassPred ) import Var ( TyVar ) import PrelNames diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index cbc20ffc1a..bb1bf42286 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -41,17 +41,15 @@ module TcEnv( import RnHsSyn ( RenamedMonoBinds, RenamedSig ) import TcMonad -import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, - zonkTcTyVarsAndFV +import TcMType ( zonkTcTyVarsAndFV ) +import TcType ( Type, ThetaType, + tyVarsOfTypes, tcSplitDFunTy, + getDFunTyKey, tcTyConAppTyCon ) import Id ( idName, mkSpecPragmaId, mkUserLocal, isDataConWrapId_maybe ) import IdInfo ( vanillaIdInfo ) import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo ) import VarSet -import Type ( Type, ThetaType, - tyVarsOfTypes, splitDFunTy, - getDFunTyKey, tyConAppTyCon - ) import DataCon ( DataCon ) import TyCon ( TyCon ) import Class ( Class, ClassOpItem ) @@ -541,13 +539,13 @@ pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)) nest 4 (ppr (iBinds info))] simpleInstInfoTy :: InstInfo -> Type -simpleInstInfoTy info = case splitDFunTy (idType (iDFunId info)) of +simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of (_, _, _, [ty]) -> ty simpleInstInfoTyCon :: InstInfo -> TyCon -- Gets the type constructor for a simple instance declaration, -- i.e. one of the form instance (...) => C (T a b c) where ... -simpleInstInfoTyCon inst = tyConAppTyCon (simpleInstInfoTy inst) +simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 793abd1550..e50f0d8227 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -32,10 +32,19 @@ import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts ) import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt ) import TcPat ( badFieldCon, simpleHsLitTy ) import TcSimplify ( tcSimplifyCheck, tcSimplifyIPs ) -import TcType ( TcType, TcTauType, - tcInstTyVars, tcInstType, - newTyVarTy, newTyVarTys, zonkTcType ) - +import TcMType ( tcInstTyVars, tcInstType, + newTyVarTy, newTyVarTys, zonkTcType, + unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy + ) +import TcType ( tcSplitFunTys, tcSplitTyConApp, + isQualifiedTy, + mkFunTy, mkAppTy, mkTyConTy, + mkTyConApp, mkClassPred, tcFunArgTy, + isTauTy, tyVarsOfType, tyVarsOfTypes, + liftedTypeKind, openTypeKind, mkArrowKind, + tcSplitSigmaTy, tcTyConAppTyCon, + tidyOpenType + ) import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon ) import Id ( idType, recordSelectorFieldLabel, isRecordSelector ) import DataCon ( dataConFieldLabels, dataConSig, @@ -43,19 +52,10 @@ import DataCon ( dataConFieldLabels, dataConSig, ) import Demand ( isMarkedStrict ) import Name ( Name ) -import Type ( mkFunTy, mkAppTy, mkTyConTy, - splitFunTy_maybe, splitFunTys, - mkTyConApp, splitSigmaTy, mkClassPred, - isTauTy, tyVarsOfType, tyVarsOfTypes, - isSigmaTy, splitAlgTyConApp, splitAlgTyConApp_maybe, - liftedTypeKind, openTypeKind, mkArrowKind, - tidyOpenType - ) -import TyCon ( TyCon, tyConTyVars ) +import TyCon ( TyCon, tyConTyVars, isAlgTyCon, tyConDataCons ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) import VarSet ( elemVarSet ) import TysWiredIn ( boolTy, mkListTy, listTyCon ) -import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy ) import PrelNames ( cCallableClassName, cReturnableClassName, enumFromName, enumFromThenName, negateName, @@ -82,12 +82,12 @@ tcExpr :: RenamedHsExpr -- Expession to type check -> TcType -- Expected type (could be a polytpye) -> TcM (TcExpr, LIE) -tcExpr expr ty | isSigmaTy ty = -- Polymorphic case - tcPolyExpr expr ty `thenTc` \ (expr', lie, _, _, _) -> - returnTc (expr', lie) +tcExpr expr ty | isQualifiedTy ty = -- Polymorphic case + tcPolyExpr expr ty `thenTc` \ (expr', lie, _, _, _) -> + returnTc (expr', lie) - | otherwise = -- Monomorphic case - tcMonoExpr expr ty + | otherwise = -- Monomorphic case + tcMonoExpr expr ty \end{code} @@ -380,10 +380,10 @@ tcMonoExpr expr@(RecordCon con_name rbinds) res_ty = tcAddErrCtxt (recordConCtxt expr) $ tcId con_name `thenNF_Tc` \ (con_expr, con_lie, con_tau) -> let - (_, record_ty) = splitFunTys con_tau - (tycon, ty_args, _) = splitAlgTyConApp record_ty + (_, record_ty) = tcSplitFunTys con_tau + (tycon, ty_args) = tcSplitTyConApp record_ty in - ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) ) + ASSERT( isAlgTyCon tycon ) unifyTauTy res_ty record_ty `thenTc_` -- Check that the record bindings match the constructor @@ -462,11 +462,13 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty -- STEP 1 -- Figure out the tycon and data cons from the first field name let - (Just (AnId sel_id) : _) = maybe_sel_ids - (_, _, tau) = splitSigmaTy (idType sel_id) -- Selectors can be overloaded + -- It's OK to use the non-tc splitters here (for a selector) + (Just (AnId sel_id) : _) = maybe_sel_ids + (_, _, tau) = tcSplitSigmaTy (idType sel_id) -- Selectors can be overloaded -- when the data type has a context - Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector - (tycon, _, data_cons) = splitAlgTyConApp data_ty + data_ty = tcFunArgTy tau -- Must succeed since sel_id is a selector + tycon = tcTyConAppTyCon data_ty + data_cons = tyConDataCons tycon (con_tyvars, _, _, _, _, _) = dataConSig (head data_cons) in tcInstTyVars con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) -> @@ -598,7 +600,7 @@ tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty = tcAddErrCtxt (exprSigCtxt in_expr) $ tcHsSigType poly_ty `thenTc` \ sig_tc_ty -> - if not (isSigmaTy sig_tc_ty) then + if not (isQualifiedTy sig_tc_ty) then -- Easy case unifyTauTy sig_tc_ty res_ty `thenTc_` tcMonoExpr expr sig_tc_ty @@ -693,8 +695,8 @@ checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty' (env2, act_ty'') = tidyOpenType env1 act_ty' - (exp_args, _) = splitFunTys exp_ty'' - (act_args, _) = splitFunTys act_ty'' + (exp_args, _) = tcSplitFunTys exp_ty'' + (act_args, _) = tcSplitFunTys act_ty'' message | length exp_args < length act_args = wrongArgsCtxt "too few" fun args | length exp_args > length act_args = wrongArgsCtxt "too many" fun args diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index fff6722662..761fd10e76 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -35,16 +35,12 @@ import Inst ( emptyLIE, LIE, plusLIE ) import ErrUtils ( Message ) import Id ( Id, mkLocalId ) import Name ( nameOccName ) -import Type ( splitFunTys - , splitTyConApp_maybe - , splitForAllTys - ) import TysWiredIn ( isFFIArgumentTy, isFFIImportResultTy, isFFIExportResultTy, isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy, isFFILabelTy ) -import Type ( Type ) +import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, tcSplitForAllTys ) import ForeignCall ( CCallSpec(..), CExportSpec(..), CCallTarget(..), isDynamicTarget, isCasmTarget ) import CStrings ( CLabelString, isCLabelString ) import PrelNames ( hasKey, ioTyConKey ) @@ -84,8 +80,8 @@ tcFImport fo@(ForeignImport nm hs_ty imp_decl src_loc) let -- drop the foralls before inspecting the structure -- of the foreign type. - (_, t_ty) = splitForAllTys sig_ty - (arg_tys, res_ty) = splitFunTys t_ty + (_, t_ty) = tcSplitForAllTys sig_ty + (arg_tys, res_ty) = tcSplitFunTys t_ty id = mkLocalId nm sig_ty in tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenNF_Tc_` @@ -112,7 +108,7 @@ tcCheckFIType sig_ty arg_tys res_ty (CDynImport _) checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenNF_Tc_` checkForeignRes mustBeIO isFFIDynResultTy res_ty where - (arg1_tys, res1_ty) = splitFunTys arg1_ty + (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty other -> addErrTc (illegalForeignTyErr empty sig_ty) tcCheckFIType sig_ty arg_tys res_ty (CImport (CCallSpec target _ safety)) @@ -192,8 +188,8 @@ tcCheckFEType sig_ty (CExport (CExportStatic str _)) where -- Drop the foralls before inspecting n -- the structure of the foreign type. - (_, t_ty) = splitForAllTys sig_ty - (arg_tys, res_ty) = splitFunTys t_ty + (_, t_ty) = tcSplitForAllTys sig_ty + (arg_tys, res_ty) = tcSplitFunTys t_ty \end{code} @@ -222,12 +218,12 @@ checkForeignRes :: Bool -> (Type -> Bool) -> Type -> NF_TcM () nonIOok = True mustBeIO = False -checkForeignRes non_io_result_ok pred_res_ty ty = - case (splitTyConApp_maybe ty) of - Just (io, [res_ty]) +checkForeignRes non_io_result_ok pred_res_ty ty + = case tcSplitTyConApp_maybe ty of + Just (io, [res_ty]) | io `hasKey` ioTyConKey && pred_res_ty res_ty -> returnNF_Tc () - _ + _ -> check (non_io_result_ok && pred_res_ty ty) (illegalForeignTyErr result ty) \end{code} diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 1c840a1bb0..2ddc307168 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -53,7 +53,7 @@ import SrcLoc ( generatedSrcLoc, SrcLoc ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon, tyConFamilySize ) -import Type ( isUnLiftedType, Type ) +import TcType ( isUnLiftedType, tcEqType, Type ) import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy ) @@ -1238,7 +1238,7 @@ assoc_ty_id tyids ty = if null res then panic "assoc_ty" else head res where - res = [id | (ty',id) <- tyids, ty == ty'] + res = [id | (ty',id) <- tyids, ty `tcEqType` ty'] eq_op_tbl = [(charPrimTy, eqH_Char_RDR) diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index ab8f3ad1b8..01266c668c 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -41,13 +41,10 @@ import HsSyn -- oodles of it -- others: import Id ( idName, idType, setIdType, Id ) import DataCon ( dataConWrapId ) -import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, - TcEnv, TcId - ) +import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId ) import TcMonad -import TcType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars - ) +import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars ) import CoreSyn ( Expr ) import BasicTypes ( RecFlag(..) ) import Bag diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index f710e45ab7..ad444e5970 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -29,8 +29,9 @@ import Id ( Id, mkVanillaGlobal, mkLocalId, idName, isDataConWrapId_maybe ) import Module ( Module ) import MkId ( mkFCallId ) import IdInfo +import TyCon ( tyConDataCons ) import DataCon ( DataCon, dataConId, dataConSig, dataConArgTys ) -import Type ( mkTyVarTys, splitAlgTyConApp_maybe ) +import Type ( mkTyVarTys, splitTyConApp ) import TysWiredIn ( tupleCon ) import Var ( mkTyVar, tyVarKind ) import Name ( Name, nameIsLocalOrFrom ) @@ -339,9 +340,8 @@ tcCoreAlt scrut_ty alt@(con, names, rhs) let (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con - (_, inst_tys, cons) = case splitAlgTyConApp_maybe scrut_ty of - Just stuff -> stuff - Nothing -> pprPanic "tcCoreAlt" (ppr alt) + (tycon, inst_tys) = splitTyConApp scrut_ty -- NB: not tcSplitTyConApp + -- We are looking at Core here ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars] ex_tys' = mkTyVarTys ex_tyvars' arg_tys = dataConArgTys con (inst_tys ++ ex_tys') @@ -356,7 +356,7 @@ tcCoreAlt scrut_ty alt@(con, names, rhs) #endif = zipWithEqual "tcCoreAlts" mkLocalId id_names arg_tys in - ASSERT( con `elem` cons && length inst_tys == length main_tyvars ) + ASSERT( con `elem` tyConDataCons tycon && length inst_tys == length main_tyvars ) tcExtendTyVarEnv ex_tyvars' $ tcExtendGlobalValEnv arg_ids $ tcCoreExpr rhs `thenTc` \ rhs' -> diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index d2132a5aca..b30e4fcf7e 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -23,7 +23,11 @@ import TcHsSyn ( TcMonoBinds, mkHsConApp ) import TcBinds ( tcSpecSigs ) import TcClassDcl ( tcMethodBind, badMethodErr ) import TcMonad -import TcType ( tcInstType ) +import TcMType ( tcInstType, tcInstTyVars ) +import TcType ( tcSplitDFunTy, tcIsTyVarTy, tcSplitTyConApp_maybe, + tyVarsOfTypes, mkClassPred, mkTyVarTy, + isTyVarClassPred, inheritablePred + ) import Inst ( InstOrigin(..), newDicts, instToId, LIE, mkLIE, emptyLIE, plusLIE, plusLIEs ) @@ -42,6 +46,7 @@ import HscTypes ( HomeSymbolTable, DFunId, ModDetails(..), PackageInstEnv, PersistentRenamerState ) +import Subst ( substTy, substTheta ) import DataCon ( classDataCon ) import Class ( Class, DefMeth(..), classBigSig ) import Var ( idName, idType ) @@ -56,12 +61,6 @@ import NameSet ( unitNameSet, nameSetToList ) import PrelInfo ( eRROR_ID ) import PprType ( pprClassPred, pprPred ) import TyCon ( TyCon, isSynTyCon ) -import Type ( splitDFunTy, isTyVarTy, - splitTyConApp_maybe, splitDictTy, - splitForAllTys, - tyVarsOfTypes, mkClassPred, mkTyVarTy, - isTyVarClassPred, inheritablePred - ) import Subst ( mkTopTyVarSubst, substTheta ) import VarSet ( varSetElems ) import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIImportResultTy ) @@ -223,13 +222,16 @@ addInstInfos :: InstEnv -> [InstInfo] -> NF_TcM InstEnv addInstInfos inst_env infos = addInstDFuns inst_env (map iDFunId infos) addInstDFuns :: InstEnv -> [DFunId] -> NF_TcM InstEnv -addInstDFuns dfuns infos +addInstDFuns inst_env dfuns = getDOptsTc `thenTc` \ dflags -> let - (inst_env', errs) = extendInstEnv dflags dfuns infos + (inst_env', errs) = extendInstEnv dflags inst_env dfuns in addErrsTc errs `thenNF_Tc_` + traceTc (text "Adding instances:" <+> vcat (map pp dfuns)) `thenTc_` returnTc inst_env' + where + pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun) \end{code} \begin{code} @@ -241,13 +243,15 @@ tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc) tcAddSrcLoc src_loc $ -- Type-check all the stuff before the "where" + traceTc (text "Starting inst" <+> ppr poly_ty) `thenTc_` tcAddErrCtxt (instDeclCtxt poly_ty) ( tcHsSigType poly_ty ) `thenTc` \ poly_ty' -> let - (tyvars, theta, clas, inst_tys) = splitDFunTy poly_ty' + (tyvars, theta, clas, inst_tys) = tcSplitDFunTy poly_ty' in + traceTc (text "Check validity") `thenTc_` (case maybe_dfun_name of Nothing -> -- A source-file instance declaration @@ -260,6 +264,7 @@ tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc) checkInstValidity dflags theta clas inst_tys `thenTc_` -- Make the dfun id and return it + traceTc (text "new name") `thenTc_` newDFunName clas inst_tys src_loc `thenNF_Tc` \ dfun_name -> returnNF_Tc (True, dfun_name) @@ -268,6 +273,7 @@ tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc) returnNF_Tc (False, dfun_name) ) `thenNF_Tc` \ (is_local, dfun_name) -> + traceTc (text "Name" <+> ppr dfun_name) `thenTc_` let dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta in @@ -519,10 +525,14 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, tcAddErrCtxt (instDeclCtxt (toHsType (idType dfun_id))) $ -- Instantiate the instance decl with tc-style type variables - tcInstType (idType dfun_id) `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') -> let - (clas, inst_tys') = splitDictTy dict_ty' - origin = InstanceDeclOrigin + (inst_tyvars, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id) + in + tcInstTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) -> + let + inst_tys' = map (substTy tenv) inst_tys + dfun_theta' = substTheta tenv dfun_theta + origin = InstanceDeclOrigin (class_tyvars, sc_theta, _, op_items) = classBigSig clas @@ -534,11 +544,6 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, -- Find any definitions in monobinds that aren't from the class bad_bndrs = collectMonoBinders monobinds `minusList` sel_names - - -- The type variable from the dict fun actually scope - -- over the bindings. They were gotten from - -- the original instance declaration - (inst_tyvars, _) = splitForAllTys (idType dfun_id) in -- Check that all the method bindings come from this class mapTc (addErrTc . badMethodErr clas) bad_bndrs `thenNF_Tc_` @@ -549,6 +554,9 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, newDicts origin [mkClassPred clas inst_tys'] `thenNF_Tc` \ [this_dict] -> tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' ( + -- The type variable from the dict fun actually scope + -- over the bindings. They were gotten from + -- the original instance declaration tcExtendGlobalValEnv dm_ids ( -- Default-method Ids may be mentioned in synthesised RHSs @@ -795,9 +803,9 @@ checkInstHead dflags theta clas inst_taus -- WITH HASKELL 1.4, MUST HAVE C (T a b c) | not (length inst_taus == 1 && - maybeToBool maybe_tycon_app && -- Yes, there's a type constuctor + maybeToBool maybe_tycon_app && -- Yes, there's a type constuctor not (isSynTyCon tycon) && -- ...but not a synonym - all isTyVarTy arg_tys && -- Applied to type variables + all tcIsTyVarTy arg_tys && -- Applied to type variables length (varSetElems (tyVarsOfTypes arg_tys)) == length arg_tys -- This last condition checks that all the type variables are distinct ) @@ -812,7 +820,7 @@ checkInstHead dflags theta clas inst_taus (first_inst_tau : _) = inst_taus -- Stuff for algebraic or -> type - maybe_tycon_app = splitTyConApp_maybe first_inst_tau + maybe_tycon_app = tcSplitTyConApp_maybe first_inst_tau Just (tycon, arg_tys) = maybe_tycon_app ccallable_type dflags ty = isFFIArgumentTy dflags PlayRisky ty @@ -822,7 +830,7 @@ check_tyvars dflags clas inst_taus -- Check that at least one isn't a type variable -- unless -fallow-undecideable-instances | dopt Opt_AllowUndecidableInstances dflags = [] - | not (all isTyVarTy inst_taus) = [] + | not (all tcIsTyVarTy inst_taus) = [] | otherwise = [the_err] where the_err = instTypeErr clas inst_taus msg diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs new file mode 100644 index 0000000000..7b279fb4e6 --- /dev/null +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -0,0 +1,988 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section{Monadic type operations} + +This module contains monadic operations over types that contain mutable type variables + +\begin{code} +module TcMType ( + TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcRhoType, TcTyVarSet, + + -------------------------------- + -- Find the type to which a type variable is bound + tcPutTyVar, -- :: TcTyVar -> TcType -> NF_TcM TcType + tcGetTyVar, -- :: TcTyVar -> NF_TcM (Maybe TcType) does shorting out + + -------------------------------- + -- Creating new mutable type variables + newTyVar, + newTyVarTy, -- Kind -> NF_TcM TcType + newTyVarTys, -- Int -> Kind -> NF_TcM [TcType] + newKindVar, newKindVars, newBoxityVar, + + -------------------------------- + -- Instantiation + tcInstTyVar, tcInstTyVars, + tcInstSigVars, tcInstType, + tcSplitRhoTyM, + + -------------------------------- + -- Unification + unifyTauTy, unifyTauTyList, unifyTauTyLists, + unifyFunTy, unifyListTy, unifyTupleTy, + unifyKind, unifyKinds, unifyOpenTypeKind, + + -------------------------------- + -- Zonking + zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcSigTyVars, + zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType, + zonkTcPredType, zonkTcTypeToType, zonkTcTyVarToTyVar, zonkKindEnv, + + ) where + +#include "HsVersions.h" + + +-- friends: +import TypeRep ( Type(..), Kind, TyNote(..) ) -- friend +import Type -- Lots and lots +import TcType ( SigmaType, RhoType, tcEqType, + tcSplitRhoTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, + tcSplitTyConApp_maybe, tcSplitFunTy_maybe + ) +import PprType ( pprType ) +import Subst ( Subst, mkTopTyVarSubst, substTy ) +import TyCon ( TyCon, mkPrimTyCon, isNewTyCon, isSynTyCon, isTupleTyCon, + tyConArity, tupleTyConBoxity + ) +import PrimRep ( PrimRep(VoidRep) ) +import Var ( TyVar, varName, tyVarKind, tyVarName, isTyVar, mkTyVar, + isMutTyVar, isSigTyVar ) + +-- others: +import TcMonad -- TcType, amongst others +import TysWiredIn ( voidTy, listTyCon, mkListTy, mkTupleTy ) + +import Name ( Name, NamedThing(..), setNameUnique, mkSysLocalName, + mkLocalName, mkDerivedTyConOcc, isSystemName + ) +import PrelNames ( floatTyConKey, doubleTyConKey, foreignPtrTyConKey, + integerTyConKey, intTyConKey, addrTyConKey ) +import VarSet +import BasicTypes ( Boxity, Arity, isBoxed ) +import Unique ( Unique, Uniquable(..) ) +import SrcLoc ( noSrcLoc ) +import Util ( nOfThem ) +import Outputable +\end{code} + + +%************************************************************************ +%* * +\subsection{New type variables} +%* * +%************************************************************************ + +\begin{code} +newTyVar :: Kind -> NF_TcM TcTyVar +newTyVar kind + = tcGetUnique `thenNF_Tc` \ uniq -> + tcNewMutTyVar (mkSysLocalName uniq SLIT("t")) kind + +newTyVarTy :: Kind -> NF_TcM TcType +newTyVarTy kind + = newTyVar kind `thenNF_Tc` \ tc_tyvar -> + returnNF_Tc (TyVarTy tc_tyvar) + +newTyVarTys :: Int -> Kind -> NF_TcM [TcType] +newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind) + +newKindVar :: NF_TcM TcKind +newKindVar + = tcGetUnique `thenNF_Tc` \ uniq -> + tcNewMutTyVar (mkSysLocalName uniq SLIT("k")) superKind `thenNF_Tc` \ kv -> + returnNF_Tc (TyVarTy kv) + +newKindVars :: Int -> NF_TcM [TcKind] +newKindVars n = mapNF_Tc (\ _ -> newKindVar) (nOfThem n ()) + +newBoxityVar :: NF_TcM TcKind +newBoxityVar + = tcGetUnique `thenNF_Tc` \ uniq -> + tcNewMutTyVar (mkSysLocalName uniq SLIT("bx")) superBoxity `thenNF_Tc` \ kv -> + returnNF_Tc (TyVarTy kv) +\end{code} + + +%************************************************************************ +%* * +\subsection{Type instantiation} +%* * +%************************************************************************ + +I don't understand why this is needed +An old comments says "No need for tcSplitForAllTyM because a type + variable can't be instantiated to a for-all type" +But the same is true of rho types! + +\begin{code} +tcSplitRhoTyM :: TcType -> NF_TcM (TcThetaType, TcType) +tcSplitRhoTyM t + = go t t [] + where + -- A type variable is never instantiated to a dictionary type, + -- so we don't need to do a tcReadVar on the "arg". + go syn_t (FunTy arg res) ts = case tcSplitPredTy_maybe arg of + Just pair -> go res res (pair:ts) + Nothing -> returnNF_Tc (reverse ts, syn_t) + go syn_t (NoteTy n t) ts = go syn_t t ts + go syn_t (TyVarTy tv) ts = tcGetTyVar tv `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + Just ty | not (isTyVarTy ty) -> go syn_t ty ts + other -> returnNF_Tc (reverse ts, syn_t) + go syn_t (UsageTy _ t) ts = go syn_t t ts + go syn_t t ts = returnNF_Tc (reverse ts, syn_t) +\end{code} + + +%************************************************************************ +%* * +\subsection{Type instantiation} +%* * +%************************************************************************ + +Instantiating a bunch of type variables + +\begin{code} +tcInstTyVars :: [TyVar] + -> NF_TcM ([TcTyVar], [TcType], Subst) + +tcInstTyVars tyvars + = mapNF_Tc tcInstTyVar tyvars `thenNF_Tc` \ tc_tyvars -> + let + tys = mkTyVarTys tc_tyvars + in + returnNF_Tc (tc_tyvars, tys, mkTopTyVarSubst tyvars tys) + -- Since the tyvars are freshly made, + -- they cannot possibly be captured by + -- any existing for-alls. Hence mkTopTyVarSubst + +tcInstTyVar tyvar + = tcGetUnique `thenNF_Tc` \ uniq -> + let + name = setNameUnique (tyVarName tyvar) uniq + -- Note that we don't change the print-name + -- This won't confuse the type checker but there's a chance + -- that two different tyvars will print the same way + -- in an error message. -dppr-debug will show up the difference + -- Better watch out for this. If worst comes to worst, just + -- use mkSysLocalName. + in + tcNewMutTyVar name (tyVarKind tyvar) + +tcInstSigVars tyvars -- Very similar to tcInstTyVar + = tcGetUniques `thenNF_Tc` \ uniqs -> + listTc [ ASSERT( not (kind `eqKind` openTypeKind) ) -- Shouldn't happen + tcNewSigTyVar name kind + | (tyvar, uniq) <- tyvars `zip` uniqs, + let name = setNameUnique (tyVarName tyvar) uniq, + let kind = tyVarKind tyvar + ] +\end{code} + +@tcInstType@ instantiates the outer-level for-alls of a TcType with +fresh type variables, splits off the dictionary part, and returns the results. + +\begin{code} +tcInstType :: TcType -> NF_TcM ([TcTyVar], TcThetaType, TcType) +tcInstType ty + = case splitForAllTys ty of + ([], rho) -> -- There may be overloading but no type variables; + -- (?x :: Int) => Int -> Int + let + (theta, tau) = tcSplitRhoTy rho -- Used to be tcSplitRhoTyM + in + returnNF_Tc ([], theta, tau) + + (tyvars, rho) -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) -> + let + (theta, tau) = tcSplitRhoTy (substTy tenv rho) -- Used to be tcSplitRhoTyM + in + returnNF_Tc (tyvars', theta, tau) +\end{code} + + + +%************************************************************************ +%* * +\subsection{Putting and getting mutable type variables} +%* * +%************************************************************************ + +\begin{code} +tcPutTyVar :: TcTyVar -> TcType -> NF_TcM TcType +tcGetTyVar :: TcTyVar -> NF_TcM (Maybe TcType) +\end{code} + +Putting is easy: + +\begin{code} +tcPutTyVar tyvar ty + | not (isMutTyVar tyvar) + = pprTrace "tcPutTyVar" (ppr tyvar) $ + returnNF_Tc ty + + | otherwise + = ASSERT( isMutTyVar tyvar ) + UASSERT2( not (isUTy ty), ppr tyvar <+> ppr ty ) + tcWriteMutTyVar tyvar (Just ty) `thenNF_Tc_` + returnNF_Tc ty +\end{code} + +Getting is more interesting. The easy thing to do is just to read, thus: + +\begin{verbatim} +tcGetTyVar tyvar = tcReadMutTyVar tyvar +\end{verbatim} + +But it's more fun to short out indirections on the way: If this +version returns a TyVar, then that TyVar is unbound. If it returns +any other type, then there might be bound TyVars embedded inside it. + +We return Nothing iff the original box was unbound. + +\begin{code} +tcGetTyVar tyvar + | not (isMutTyVar tyvar) + = pprTrace "tcGetTyVar" (ppr tyvar) $ + returnNF_Tc (Just (mkTyVarTy tyvar)) + + | otherwise + = ASSERT2( isMutTyVar tyvar, ppr tyvar ) + tcReadMutTyVar tyvar `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + Just ty -> short_out ty `thenNF_Tc` \ ty' -> + tcWriteMutTyVar tyvar (Just ty') `thenNF_Tc_` + returnNF_Tc (Just ty') + + Nothing -> returnNF_Tc Nothing + +short_out :: TcType -> NF_TcM TcType +short_out ty@(TyVarTy tyvar) + | not (isMutTyVar tyvar) + = returnNF_Tc ty + + | otherwise + = tcReadMutTyVar tyvar `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + Just ty' -> short_out ty' `thenNF_Tc` \ ty' -> + tcWriteMutTyVar tyvar (Just ty') `thenNF_Tc_` + returnNF_Tc ty' + + other -> returnNF_Tc ty + +short_out other_ty = returnNF_Tc other_ty +\end{code} + + +%************************************************************************ +%* * +\subsection{Zonking -- the exernal interfaces} +%* * +%************************************************************************ + +----------------- Type variables + +\begin{code} +zonkTcTyVars :: [TcTyVar] -> NF_TcM [TcType] +zonkTcTyVars tyvars = mapNF_Tc zonkTcTyVar tyvars + +zonkTcTyVarsAndFV :: [TcTyVar] -> NF_TcM TcTyVarSet +zonkTcTyVarsAndFV tyvars = mapNF_Tc zonkTcTyVar tyvars `thenNF_Tc` \ tys -> + returnNF_Tc (tyVarsOfTypes tys) + +zonkTcTyVar :: TcTyVar -> NF_TcM TcType +zonkTcTyVar tyvar = zonkTyVar (\ tv -> returnNF_Tc (TyVarTy tv)) tyvar + +zonkTcSigTyVars :: [TcTyVar] -> NF_TcM [TcTyVar] +-- This guy is to zonk the tyvars we're about to feed into tcSimplify +-- Usually this job is done by checkSigTyVars, but in a couple of places +-- that is overkill, so we use this simpler chap +zonkTcSigTyVars tyvars + = zonkTcTyVars tyvars `thenNF_Tc` \ tys -> + returnNF_Tc (map (getTyVar "zonkTcSigTyVars") tys) +\end{code} + +----------------- Types + +\begin{code} +zonkTcType :: TcType -> NF_TcM TcType +zonkTcType ty = zonkType (\ tv -> returnNF_Tc (TyVarTy tv)) ty + +zonkTcTypes :: [TcType] -> NF_TcM [TcType] +zonkTcTypes tys = mapNF_Tc zonkTcType tys + +zonkTcClassConstraints cts = mapNF_Tc zonk cts + where zonk (clas, tys) + = zonkTcTypes tys `thenNF_Tc` \ new_tys -> + returnNF_Tc (clas, new_tys) + +zonkTcThetaType :: TcThetaType -> NF_TcM TcThetaType +zonkTcThetaType theta = mapNF_Tc zonkTcPredType theta + +zonkTcPredType :: TcPredType -> NF_TcM TcPredType +zonkTcPredType (ClassP c ts) = + zonkTcTypes ts `thenNF_Tc` \ new_ts -> + returnNF_Tc (ClassP c new_ts) +zonkTcPredType (IParam n t) = + zonkTcType t `thenNF_Tc` \ new_t -> + returnNF_Tc (IParam n new_t) +\end{code} + +------------------- These ...ToType, ...ToKind versions + are used at the end of type checking + +\begin{code} +zonkKindEnv :: [(Name, TcKind)] -> NF_TcM [(Name, Kind)] +zonkKindEnv pairs + = mapNF_Tc zonk_it pairs + where + zonk_it (name, tc_kind) = zonkType zonk_unbound_kind_var tc_kind `thenNF_Tc` \ kind -> + returnNF_Tc (name, kind) + + -- 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 = tcPutTyVar kv liftedTypeKind + | tyVarKind kv `eqKind` superBoxity = tcPutTyVar kv liftedBoxity + | otherwise = pprPanic "zonkKindEnv" (ppr kv) + +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_unbound_tyvar tv + | kind `eqKind` liftedTypeKind || kind `eqKind` openTypeKind + = tcPutTyVar tv voidTy -- Just to avoid creating a new tycon in + -- this vastly common case + | otherwise + = tcPutTyVar 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) + -- 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 + +-- 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. +-- +-- It does this by making an immutable version of tv and binds tv to it. +-- Now any bound occurences of the original type variable will get +-- zonked to the immutable version. + +zonkTcTyVarToTyVar :: TcTyVar -> NF_TcM TyVar +zonkTcTyVarToTyVar tv + = let + -- Make an immutable version, defaulting + -- the kind to lifted if necessary + immut_tv = mkTyVar (tyVarName tv) (defaultKind (tyVarKind tv)) + immut_tv_ty = mkTyVarTy immut_tv + + zap tv = tcPutTyVar tv immut_tv_ty + -- Bind the mutable version to the immutable one + in + -- If the type variable is mutable, then bind it to immut_tv_ty + -- so that all other occurrences of the tyvar will get zapped too + zonkTyVar zap tv `thenNF_Tc` \ ty2 -> + + WARN( not (immut_tv_ty `tcEqType` ty2), ppr tv $$ ppr immut_tv $$ ppr ty2 ) + + returnNF_Tc immut_tv +\end{code} + + +%************************************************************************ +%* * +\subsection{Zonking -- the main work-horses: zonkType, zonkTyVar} +%* * +%* For internal use only! * +%* * +%************************************************************************ + +\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 + +zonkType :: (TcTyVar -> NF_TcM Type) -- What to do with unbound mutable type variables + -- see zonkTcType, and zonkTcTypeToType + -> TcType + -> NF_TcM Type +zonkType unbound_var_fn ty + = go ty + where + go (TyConApp tycon tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' -> + returnNF_Tc (TyConApp tycon tys') + + go (NoteTy (SynNote ty1) ty2) = go ty1 `thenNF_Tc` \ ty1' -> + go ty2 `thenNF_Tc` \ ty2' -> + returnNF_Tc (NoteTy (SynNote ty1') ty2') + + go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard free-tyvar annotations + + go (SourceTy p) = go_pred p `thenNF_Tc` \ p' -> + returnNF_Tc (SourceTy p') + + go (FunTy arg res) = go arg `thenNF_Tc` \ arg' -> + go res `thenNF_Tc` \ res' -> + returnNF_Tc (FunTy arg' res') + + go (AppTy fun arg) = go fun `thenNF_Tc` \ fun' -> + go arg `thenNF_Tc` \ arg' -> + returnNF_Tc (mkAppTy fun' arg') + + go (UsageTy u ty) = go u `thenNF_Tc` \ u' -> + go ty `thenNF_Tc` \ ty' -> + returnNF_Tc (mkUTy u' ty') + + -- The two interesting cases! + go (TyVarTy tyvar) = zonkTyVar unbound_var_fn tyvar + + go (ForAllTy tyvar ty) = zonkTcTyVarToTyVar tyvar `thenNF_Tc` \ tyvar' -> + go ty `thenNF_Tc` \ ty' -> + returnNF_Tc (ForAllTy tyvar' ty') + + go_pred (ClassP c tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' -> + returnNF_Tc (ClassP c tys') + go_pred (NType tc tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' -> + returnNF_Tc (NType tc tys') + go_pred (IParam n ty) = go ty `thenNF_Tc` \ ty' -> + returnNF_Tc (IParam n ty') + +zonkTyVar :: (TcTyVar -> NF_TcM Type) -- What to do for an unbound mutable variable + -> TcTyVar -> NF_TcM TcType +zonkTyVar unbound_var_fn tyvar + | not (isMutTyVar 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 + returnNF_Tc (TyVarTy tyvar) + + | otherwise + = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + Nothing -> unbound_var_fn tyvar -- Mutable and unbound + Just other_ty -> zonkType unbound_var_fn other_ty -- Bound +\end{code} + + + +%************************************************************************ +%* * +\subsection{The Kind variants} +%* * +%************************************************************************ + +\begin{code} +unifyKind :: TcKind -- Expected + -> TcKind -- Actual + -> TcM () +unifyKind k1 k2 + = tcAddErrCtxtM (unifyCtxt "kind" k1 k2) $ + uTys k1 k1 k2 k2 + +unifyKinds :: [TcKind] -> [TcKind] -> TcM () +unifyKinds [] [] = returnTc () +unifyKinds (k1:ks1) (k2:ks2) = unifyKind k1 k2 `thenTc_` + unifyKinds ks1 ks2 +unifyKinds _ _ = panic "unifyKinds: length mis-match" +\end{code} + +\begin{code} +unifyOpenTypeKind :: TcKind -> TcM () +-- Ensures that the argument kind is of the form (Type bx) +-- for some boxity bx + +unifyOpenTypeKind ty@(TyVarTy tyvar) + = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + Just ty' -> unifyOpenTypeKind ty' + other -> unify_open_kind_help ty + +unifyOpenTypeKind ty + = case tcSplitTyConApp_maybe ty of + Just (tycon, [_]) | tycon == typeCon -> returnTc () + other -> unify_open_kind_help ty + +unify_open_kind_help ty -- Revert to ordinary unification + = newBoxityVar `thenNF_Tc` \ boxity -> + unifyKind ty (mkTyConApp typeCon [boxity]) +\end{code} + + +%************************************************************************ +%* * +\subsection[Unify-exported]{Exported unification functions} +%* * +%************************************************************************ + +The exported functions are all defined as versions of some +non-exported generic functions. + +Unify two @TauType@s. Dead straightforward. + +\begin{code} +unifyTauTy :: TcTauType -> TcTauType -> TcM () +unifyTauTy ty1 ty2 -- ty1 expected, ty2 inferred + = tcAddErrCtxtM (unifyCtxt "type" ty1 ty2) $ + uTys ty1 ty1 ty2 ty2 +\end{code} + +@unifyTauTyList@ unifies corresponding elements of two lists of +@TauType@s. It uses @uTys@ to do the real work. The lists should be +of equal length. We charge down the list explicitly so that we can +complain if their lengths differ. + +\begin{code} +unifyTauTyLists :: [TcTauType] -> [TcTauType] -> TcM () +unifyTauTyLists [] [] = returnTc () +unifyTauTyLists (ty1:tys1) (ty2:tys2) = uTys ty1 ty1 ty2 ty2 `thenTc_` + unifyTauTyLists tys1 tys2 +unifyTauTyLists ty1s ty2s = panic "Unify.unifyTauTyLists: mismatched type lists!" +\end{code} + +@unifyTauTyList@ takes a single list of @TauType@s and unifies them +all together. It is used, for example, when typechecking explicit +lists, when all the elts should be of the same type. + +\begin{code} +unifyTauTyList :: [TcTauType] -> TcM () +unifyTauTyList [] = returnTc () +unifyTauTyList [ty] = returnTc () +unifyTauTyList (ty1:tys@(ty2:_)) = unifyTauTy ty1 ty2 `thenTc_` + unifyTauTyList tys +\end{code} + +%************************************************************************ +%* * +\subsection[Unify-uTys]{@uTys@: getting down to business} +%* * +%************************************************************************ + +@uTys@ is the heart of the unifier. Each arg happens twice, because +we want to report errors in terms of synomyms if poss. The first of +the pair is used in error messages only; it is always the same as the +second, except that if the first is a synonym then the second may be a +de-synonym'd version. This way we get better error messages. + +We call the first one \tr{ps_ty1}, \tr{ps_ty2} for ``possible synomym''. + +\begin{code} +uTys :: TcTauType -> TcTauType -- Error reporting ty1 and real ty1 + -- ty1 is the *expected* type + + -> TcTauType -> TcTauType -- Error reporting ty2 and real ty2 + -- ty2 is the *actual* type + -> TcM () + + -- Always expand synonyms (see notes at end) + -- (this also throws away FTVs) +uTys ps_ty1 (NoteTy n1 ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2 +uTys ps_ty1 ty1 ps_ty2 (NoteTy n2 ty2) = uTys ps_ty1 ty1 ps_ty2 ty2 + + -- Ignore usage annotations inside typechecker +uTys ps_ty1 (UsageTy _ ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2 +uTys ps_ty1 ty1 ps_ty2 (UsageTy _ ty2) = uTys ps_ty1 ty1 ps_ty2 ty2 + + -- Variables; go for uVar +uTys ps_ty1 (TyVarTy tyvar1) ps_ty2 ty2 = uVar False tyvar1 ps_ty2 ty2 +uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar True tyvar2 ps_ty1 ty1 + -- "True" means args swapped + + -- Predicates +uTys _ (SourceTy (IParam n1 t1)) _ (SourceTy (IParam n2 t2)) + | n1 == n2 = uTys t1 t1 t2 t2 +uTys _ (SourceTy (ClassP c1 tys1)) _ (SourceTy (ClassP c2 tys2)) + | c1 == c2 = unifyTauTyLists tys1 tys2 +uTys _ (SourceTy (NType tc1 tys1)) _ (SourceTy (NType tc2 tys2)) + | tc1 == tc2 = unifyTauTyLists tys1 tys2 + + -- Functions; just check the two parts +uTys _ (FunTy fun1 arg1) _ (FunTy fun2 arg2) + = uTys fun1 fun1 fun2 fun2 `thenTc_` uTys arg1 arg1 arg2 arg2 + + -- Type constructors must match +uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2) + | con1 == con2 && length tys1 == length 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 + = unifyOpenTypeKind 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, + -- so if one type is an App the other one jolly well better be too +uTys ps_ty1 (AppTy s1 t1) ps_ty2 ty2 + = case tcSplitAppTy_maybe ty2 of + Just (s2,t2) -> uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2 + Nothing -> unifyMisMatch ps_ty1 ps_ty2 + + -- Now the same, but the other way round + -- Don't swap the types, because the error messages get worse +uTys ps_ty1 ty1 ps_ty2 (AppTy s2 t2) + = case tcSplitAppTy_maybe ty1 of + Just (s1,t1) -> uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2 + Nothing -> unifyMisMatch ps_ty1 ps_ty2 + + -- Not expecting for-alls in unification + -- ... but the error message from the unifyMisMatch more informative + -- than a panic message! + + -- Anything else fails +uTys ps_ty1 ty1 ps_ty2 ty2 = unifyMisMatch ps_ty1 ps_ty2 +\end{code} + + +Notes on synonyms +~~~~~~~~~~~~~~~~~ +If you are tempted to make a short cut on synonyms, as in this +pseudocode... + +\begin{verbatim} +-- NO uTys (SynTy con1 args1 ty1) (SynTy con2 args2 ty2) +-- NO = if (con1 == con2) then +-- NO -- Good news! Same synonym constructors, so we can shortcut +-- NO -- by unifying their arguments and ignoring their expansions. +-- NO unifyTauTypeLists args1 args2 +-- NO else +-- NO -- Never mind. Just expand them and try again +-- NO uTys ty1 ty2 +\end{verbatim} + +then THINK AGAIN. Here is the whole story, as detected and reported +by Chris Okasaki \tr{<Chris_Okasaki@loch.mess.cs.cmu.edu>}: +\begin{quotation} +Here's a test program that should detect the problem: + +\begin{verbatim} + type Bogus a = Int + x = (1 :: Bogus Char) :: Bogus Bool +\end{verbatim} + +The problem with [the attempted shortcut code] is that +\begin{verbatim} + con1 == con2 +\end{verbatim} +is not a sufficient condition to be able to use the shortcut! +You also need to know that the type synonym actually USES all +its arguments. For example, consider the following type synonym +which does not use all its arguments. +\begin{verbatim} + type Bogus a = Int +\end{verbatim} + +If you ever tried unifying, say, \tr{Bogus Char} with \tr{Bogus Bool}, +the unifier would blithely try to unify \tr{Char} with \tr{Bool} and +would fail, even though the expanded forms (both \tr{Int}) should +match. + +Similarly, unifying \tr{Bogus Char} with \tr{Bogus t} would +unnecessarily bind \tr{t} to \tr{Char}. + +... You could explicitly test for the problem synonyms and mark them +somehow as needing expansion, perhaps also issuing a warning to the +user. +\end{quotation} + + +%************************************************************************ +%* * +\subsection[Unify-uVar]{@uVar@: unifying with a type variable} +%* * +%************************************************************************ + +@uVar@ is called when at least one of the types being unified is a +variable. It does {\em not} assume that the variable is a fixed point +of the substitution; rather, notice that @uVar@ (defined below) nips +back into @uTys@ if it turns out that the variable is already bound. + +\begin{code} +uVar :: Bool -- False => tyvar is the "expected" + -- True => ty is the "expected" thing + -> TcTyVar + -> TcTauType -> TcTauType -- printing and real versions + -> TcM () + +uVar swapped tv1 ps_ty2 ty2 + = tcGetTyVar tv1 `thenNF_Tc` \ maybe_ty1 -> + 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 + + -- Expand synonyms; ignore FTVs +uUnboundVar swapped tv1 maybe_ty1 ps_ty2 (NoteTy n2 ty2) + = uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2 + + + -- The both-type-variable case +uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2) + + -- Same type variable => no-op + | tv1 == tv2 + = returnTc () + + -- Distinct type variables + -- ASSERT maybe_ty1 /= Just + | otherwise + = tcGetTyVar tv2 `thenNF_Tc` \ maybe_ty2 -> + case maybe_ty2 of + Just ty2' -> uUnboundVar swapped tv1 maybe_ty1 ty2' ty2' + + Nothing | update_tv2 + + -> WARN( not (k1 `hasMoreBoxityInfo` k2), (ppr tv1 <+> ppr k1) $$ (ppr tv2 <+> ppr k2) ) + tcPutTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` + returnTc () + | otherwise + + -> WARN( not (k2 `hasMoreBoxityInfo` k1), (ppr tv2 <+> ppr k2) $$ (ppr tv1 <+> ppr k1) ) + (tcPutTyVar tv1 ps_ty2 `thenNF_Tc_` + returnTc ()) + 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 + + nicer_to_update_tv2 = isSigTyVar tv1 + -- Don't unify a signature type variable if poss + || isSystemName (varName tv2) + -- Try to update sys-y type variables in preference to sig-y ones + + -- Second one isn't a type variable +uUnboundVar swapped tv1 maybe_ty1 ps_ty2 non_var_ty2 + = -- Check that the kinds match + checkKinds swapped tv1 non_var_ty2 `thenTc_` + + -- Check that tv1 isn't a type-signature type variable + checkTcM (not (isSigTyVar tv1)) + (failWithTcM (unifyWithSigErr tv1 ps_ty2)) `thenTc_` + + -- Check that we aren't losing boxity info (shouldn't happen) + warnTc (not (typeKind non_var_ty2 `hasMoreBoxityInfo` tyVarKind tv1)) + ((ppr tv1 <+> ppr (tyVarKind tv1)) $$ + (ppr non_var_ty2 <+> ppr (typeKind non_var_ty2))) `thenNF_Tc_` + + -- Occurs check + -- Basically we want to update tv1 := ps_ty2 + -- because ps_ty2 has type-synonym info, which improves later error messages + -- + -- But consider + -- type A a = () + -- + -- f :: (A a -> a -> ()) -> () + -- f = \ _ -> () + -- + -- x :: () + -- x = f (\ x p -> p x) + -- + -- In the application (p x), we try to match "t" with "A t". If we go + -- ahead and bind t to A t (= ps_ty2), we'll lead the type checker into + -- an infinite loop later. + -- But we should not reject the program, because A t = (). + -- Rather, we should bind t to () (= non_var_ty2). + -- + -- That's why we have this two-state occurs-check + zonkTcType ps_ty2 `thenNF_Tc` \ ps_ty2' -> + if not (tv1 `elemVarSet` tyVarsOfType ps_ty2') then + tcPutTyVar tv1 ps_ty2' `thenNF_Tc_` + returnTc () + else + zonkTcType non_var_ty2 `thenNF_Tc` \ non_var_ty2' -> + if not (tv1 `elemVarSet` tyVarsOfType non_var_ty2') then + -- This branch rarely succeeds, except in strange cases + -- like that in the example above + tcPutTyVar tv1 non_var_ty2' `thenNF_Tc_` + returnTc () + else + failWithTcM (unifyOccurCheck tv1 ps_ty2') + + +checkKinds swapped tv1 ty2 +-- We're about to unify a type variable tv1 with a non-tyvar-type ty2. +-- We need to check that we don't unify a lifted type variable with an +-- unlifted type: e.g. (id 3#) is illegal + | tk1 `eqKind` liftedTypeKind && tk2 `eqKind` unliftedTypeKind + = tcAddErrCtxtM (unifyKindCtxt swapped tv1 ty2) $ + unifyMisMatch k1 k2 + | otherwise + = returnTc () + where + (k1,k2) | swapped = (tk2,tk1) + | otherwise = (tk1,tk2) + tk1 = tyVarKind tv1 + tk2 = typeKind ty2 +\end{code} + + +%************************************************************************ +%* * +\subsection[Unify-fun]{@unifyFunTy@} +%* * +%************************************************************************ + +@unifyFunTy@ is used to avoid the fruitless creation of type variables. + +\begin{code} +unifyFunTy :: TcType -- Fail if ty isn't a function type + -> TcM (TcType, TcType) -- otherwise return arg and result types + +unifyFunTy ty@(TyVarTy tyvar) + = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + Just ty' -> unifyFunTy ty' + other -> unify_fun_ty_help ty + +unifyFunTy ty + = case tcSplitFunTy_maybe ty of + Just arg_and_res -> returnTc arg_and_res + Nothing -> unify_fun_ty_help ty + +unify_fun_ty_help ty -- Special cases failed, so revert to ordinary unification + = newTyVarTy openTypeKind `thenNF_Tc` \ arg -> + newTyVarTy openTypeKind `thenNF_Tc` \ res -> + unifyTauTy ty (mkFunTy arg res) `thenTc_` + returnTc (arg,res) +\end{code} + +\begin{code} +unifyListTy :: TcType -- expected list type + -> TcM TcType -- list element type + +unifyListTy ty@(TyVarTy tyvar) + = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + Just ty' -> unifyListTy ty' + other -> unify_list_ty_help ty + +unifyListTy ty + = case tcSplitTyConApp_maybe ty of + Just (tycon, [arg_ty]) | tycon == listTyCon -> returnTc arg_ty + other -> unify_list_ty_help ty + +unify_list_ty_help ty -- Revert to ordinary unification + = newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty -> + unifyTauTy ty (mkListTy elt_ty) `thenTc_` + returnTc elt_ty +\end{code} + +\begin{code} +unifyTupleTy :: Boxity -> Arity -> TcType -> TcM [TcType] +unifyTupleTy boxity arity ty@(TyVarTy tyvar) + = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + Just ty' -> unifyTupleTy boxity arity ty' + other -> unify_tuple_ty_help boxity arity ty + +unifyTupleTy boxity arity ty + = case tcSplitTyConApp_maybe ty of + Just (tycon, arg_tys) + | isTupleTyCon tycon + && tyConArity tycon == arity + && tupleTyConBoxity tycon == boxity + -> returnTc arg_tys + other -> unify_tuple_ty_help boxity arity ty + +unify_tuple_ty_help boxity arity ty + = newTyVarTys arity kind `thenNF_Tc` \ arg_tys -> + unifyTauTy ty (mkTupleTy boxity arity arg_tys) `thenTc_` + returnTc arg_tys + where + kind | isBoxed boxity = liftedTypeKind + | otherwise = openTypeKind +\end{code} + + +%************************************************************************ +%* * +\subsection[Unify-context]{Errors and contexts} +%* * +%************************************************************************ + +Errors +~~~~~~ + +\begin{code} +unifyCtxt s ty1 ty2 tidy_env -- ty1 expected, ty2 inferred + = zonkTcType ty1 `thenNF_Tc` \ ty1' -> + zonkTcType ty2 `thenNF_Tc` \ ty2' -> + returnNF_Tc (err ty1' ty2') + where + err ty1 ty2 = (env1, + nest 4 + (vcat [ + text "Expected" <+> text s <> colon <+> ppr tidy_ty1, + text "Inferred" <+> text s <> colon <+> ppr tidy_ty2 + ])) + where + (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 `thenNF_Tc` \ ty2' -> + returnNF_Tc (err ty2') + 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') = tidyTyVar tidy_env tv1 + (env2, ty2') = tidyOpenType env1 ty2 + pp1 = ppr tv1' + pp2 = ppr ty2' + +unifyMisMatch ty1 ty2 + = zonkTcType ty1 `thenNF_Tc` \ ty1' -> + zonkTcType ty2 `thenNF_Tc` \ ty2' -> + let + (env, [tidy_ty1, tidy_ty2]) = tidyOpenTypes emptyTidyEnv [ty1',ty2'] + msg = hang (ptext SLIT("Couldn't match")) + 4 (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))) + where + (env1, tidy_tyvar) = tidyTyVar emptyTidyEnv tyvar + (env2, tidy_ty) = tidyOpenType env1 ty + +unifyOccurCheck tyvar ty + = (env2, hang (ptext SLIT("Occurs check: cannot construct the infinite type:")) + 4 (sep [ppr tidy_tyvar, char '=', ppr tidy_ty])) + where + (env1, tidy_tyvar) = tidyTyVar emptyTidyEnv tyvar + (env2, tidy_ty) = tidyOpenType env1 ty +\end{code} diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 20c2a44a49..d63110a81a 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -27,16 +27,15 @@ import Inst ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList ) import TcEnv ( TcId, tcLookupLocalIds, tcExtendLocalValEnv, tcExtendGlobalTyVars, tcInLocalScope ) import TcPat ( tcPat, tcMonoPatBndr, polyPatSig ) -import TcType ( TcType, newTyVarTy ) +import TcMType ( newTyVarTy, unifyFunTy, unifyTauTy ) +import TcType ( tyVarsOfType, isTauTy, mkFunTy, isOverloadedTy, + liftedTypeKind, openTypeKind ) import TcBinds ( tcBindsAndThen ) import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns ) -import TcUnify ( unifyFunTy, unifyTauTy ) import Name ( Name ) import TysWiredIn ( boolTy ) import Id ( idType ) import BasicTypes ( RecFlag(..) ) -import Type ( tyVarsOfType, isTauTy, mkFunTy, - liftedTypeKind, openTypeKind, splitSigmaTy ) import NameSet import VarSet import Var ( Id ) @@ -283,8 +282,7 @@ tcCheckExistentialPat ids ex_tvs lie_avail lie_req result_ty where doc = text ("the existential context of a data constructor") tv_list = bagToList ex_tvs - not_overloaded id = case splitSigmaTy (idType id) of - (_, theta, _) -> null theta + not_overloaded id = not (isOverloadedTy (idType id)) tc_match_pats [] expected_ty = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE) diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 6b7d0c44ff..cdcd01d57c 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -32,9 +32,12 @@ import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr, import MkIface ( pprModDetails ) import TcExpr ( tcMonoExpr ) import TcMonad -import TcType ( newTyVarTy, zonkTcType, tcInstType ) +import TcMType ( unifyTauTy, newTyVarTy, zonkTcType, tcInstType ) +import TcType ( Type, liftedTypeKind, openTypeKind, + tyVarsOfType, tidyType, tcFunResultTy, + mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys + ) import TcMatches ( tcStmtsAndThen ) -import TcUnify ( unifyTauTy ) import Inst ( emptyLIE, plusLIE ) import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2 ) @@ -50,10 +53,8 @@ import TcIfaceSig ( tcInterfaceSigs ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) import TcSimplify ( tcSimplifyTop, tcSimplifyInfer ) import TcTyClsDecls ( tcTyAndClassDecls ) - import CoreUnfold ( unfoldingTemplate, hasUnfolding ) import TysWiredIn ( mkListTy, unitTy ) -import Type import ErrUtils ( printErrorsAndWarnings, errorsFound, dumpIfSet_dyn, dumpIfSet_dyn_or, showPass ) import Id ( Id, idType, idUnfolding ) @@ -261,8 +262,8 @@ typecheckExpr dflags pcs hst ic_type_env unqual this_mod (syn_map, expr, decls) newTyVarTy openTypeKind `thenTc` \ ty -> tcMonoExpr expr ty `thenTc` \ (e', lie) -> - tcSimplifyInfer smpl_doc (varSetElems (tyVarsOfType ty)) lie - `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) -> + tcSimplifyInfer smpl_doc (tyVarsOfType ty) lie + `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) -> tcSimplifyTop lie_free `thenTc` \ const_binds -> let all_expr = mkHsLet const_binds $ @@ -400,6 +401,7 @@ tcModule pcs hst get_fixity this_mod decls lie_rules in tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds -> + traceTc (text "endsimpltop") `thenTc_` -- Backsubstitution. This must be done last. -- Even tcSimplifyTop may do some unification. @@ -719,11 +721,10 @@ ppr_gen_tycon tycon | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable") ppr_ep (EP from to) - = vcat [ ptext SLIT("Rep type:") <+> ppr (funResultTy from_tau), + = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau), ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)), ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to)) ] where - (_,from_tau) = splitForAllTys (idType from) - + (_,from_tau) = tcSplitForAllTys (idType from) \end{code} diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index f2d7791de0..552b097e26 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -1,9 +1,7 @@ \begin{code} module TcMonad( - TcType, - TcTauType, TcPredType, TcThetaType, TcRhoType, - TcTyVar, TcTyVarSet, - TcKind, + TcType, TcTauType, TcPredType, TcThetaType, TcRhoType, + TcTyVar, TcTyVarSet, TcKind, TcM, NF_TcM, TcDown, TcEnv, @@ -47,10 +45,9 @@ module TcMonad( import {-# SOURCE #-} TcEnv ( TcEnv ) -import HsSyn ( HsOverLit ) +import HsLit ( HsOverLit ) import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr ) -import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType, - ) +import TcType ( Type, Kind, PredType, ThetaType, TauType, RhoType ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg ) import Bag ( Bag, emptyBag, isEmptyBag, diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index bc42127e2f..bb404c0712 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -30,25 +30,25 @@ import TcEnv ( tcExtendTyVarEnv, tcLookup, tcLookupGlobal, tcGetGlobalTyVars, tcEnvTcIds, tcEnvTyVars, TyThing(..), TcTyThing(..), tcExtendKindEnv ) -import TcType ( TcKind, TcTyVar, TcThetaType, TcTauType, - newKindVar, tcInstSigVars, - zonkKindEnv, zonkTcType, zonkTcTyVars, zonkTcTyVar +import TcMType ( newKindVar, tcInstSigVars, + zonkKindEnv, zonkTcType, zonkTcTyVars, zonkTcTyVar, + unifyKind, unifyOpenTypeKind ) -import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToId ) -import FunDeps ( grow ) -import TcUnify ( unifyKind, unifyOpenTypeKind ) -import Unify ( allDistinctTyVars ) -import Type ( Type, Kind, PredType(..), ThetaType, SigmaType, TauType, +import TcType ( Type, Kind, SourceType(..), ThetaType, SigmaType, TauType, mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, - zipFunTys, hoistForAllTys, + tcSplitForAllTys, tcSplitRhoTy, + hoistForAllTys, allDistinctTyVars, + zipFunTys, mkSigmaTy, mkPredTy, mkTyConApp, - mkAppTys, splitForAllTys, splitRhoTy, mkRhoTy, + mkAppTys, mkRhoTy, liftedTypeKind, unliftedTypeKind, mkArrowKind, - mkArrowKinds, getTyVar_maybe, getTyVar, splitFunTy_maybe, + mkArrowKinds, tcGetTyVar_maybe, tcGetTyVar, tcSplitFunTy_maybe, tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars, tyVarsOfType, tyVarsOfPred, mkForAllTys, - isUnboxedTupleType, isForAllTy, isIPPred + isUnboxedTupleType, tcIsForAllTy, isIPPred ) +import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToId ) +import FunDeps ( grow ) import PprType ( pprType, pprTheta, pprPred ) import Subst ( mkTopTyVarSubst, substTy ) import CoreFVs ( idFreeTyVars ) @@ -239,7 +239,7 @@ kcHsType (HsForAllTy (Just tv_names) context ty) --------------------------- kcAppKind fun_kind arg_kind - = case splitFunTy_maybe fun_kind of + = case tcSplitFunTy_maybe fun_kind of Just (arg_kind', res_kind) -> unifyKind arg_kind arg_kind' `thenTc_` returnTc res_kind @@ -302,7 +302,12 @@ tcHsSigType and tcHsLiftedSigType are used for type signatures written by the pr \begin{code} tcHsSigType, tcHsLiftedSigType :: RenamedHsType -> TcM Type -- Do kind checking, and hoist for-alls to the top -tcHsSigType ty = kcTypeType ty `thenTc_` tcHsType ty +tcHsSigType ty = traceTc (text "tcHsSig1:" <+> ppr ty) `thenTc_` + kcTypeType ty `thenTc_` + traceTc (text "tcHsSig2:" <+> ppr ty) `thenTc_` + tcHsType ty `thenTc` \ sig_ty -> + traceTc (text "tcHsSig3:" <+> ppr sig_ty) `thenTc_` + returnTc sig_ty tcHsLiftedSigType ty = kcLiftedType ty `thenTc_` tcHsType ty tcHsType :: RenamedHsType -> TcM Type @@ -449,7 +454,7 @@ tc_arg_type wimp_out arg_ty | otherwise = tc_type wimp_out arg_ty `thenTc` \ arg_ty' -> - checkTc (isRec wimp_out || not (isForAllTy arg_ty')) (polyArgTyErr arg_ty) `thenTc_` + checkTc (isRec wimp_out || not (tcIsForAllTy arg_ty')) (polyArgTyErr arg_ty) `thenTc_` checkTc (isRec wimp_out || not (isUnboxedTupleType arg_ty')) (ubxArgTyErr arg_ty) `thenTc_` returnTc arg_ty' @@ -692,7 +697,7 @@ mkTcSig poly_id src_loc -- typechecking the rest of the program with the function bound -- to a pristine type, namely sigma_tc_ty let - (tyvars, rho) = splitForAllTys (idType poly_id) + (tyvars, rho) = tcSplitForAllTys (idType poly_id) in tcInstSigVars tyvars `thenNF_Tc` \ tyvars' -> -- Make *signature* type variables @@ -701,7 +706,8 @@ mkTcSig poly_id src_loc tyvar_tys' = mkTyVarTys tyvars' rho' = substTy (mkTopTyVarSubst tyvars tyvar_tys') rho -- mkTopTyVarSubst because the tyvars' are fresh - (theta', tau') = splitRhoTy rho' + + (theta', tau') = tcSplitRhoTy rho' -- This splitRhoTy tries hard to make sure that tau' is a type synonym -- wherever possible, which can improve interface files. in @@ -796,7 +802,7 @@ checkSigTyVars sig_tyvars free_tyvars checkTcM (allDistinctTyVars sig_tys globals) (complain sig_tys globals) `thenTc_` - returnTc (map (getTyVar "checkSigTyVars") sig_tys) + returnTc (map (tcGetTyVar "checkSigTyVars") sig_tys) where complain sig_tys globals @@ -812,7 +818,7 @@ checkSigTyVars sig_tyvars free_tyvars let in_scope_assoc = [ (zonked_tv, in_scope_tv) | (z_ty, in_scope_tv) <- in_scope_tys `zip` in_scope_tvs, - Just zonked_tv <- [getTyVar_maybe z_ty] + Just zonked_tv <- [tcGetTyVar_maybe z_ty] ] in_scope_env = mkVarEnv in_scope_assoc in @@ -834,7 +840,7 @@ checkSigTyVars sig_tyvars free_tyvars -- ty is what you get if you zonk sig_tyvar and then tidy it -- -- acc maps a zonked type variable back to a signature type variable - = case getTyVar_maybe ty of { + = case tcGetTyVar_maybe ty of { Nothing -> -- Error (a)! returnNF_Tc (tidy_env, acc, unify_msg sig_tyvar (quotes (ppr ty)) : msgs) ; diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 4d1a49d73d..d26b121280 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -21,15 +21,14 @@ import Id ( mkLocalId ) import Name ( Name ) import FieldLabel ( fieldLabelName ) import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupSyntaxId ) -import TcType ( TcType, TcTyVar, tcInstTyVars, newTyVarTy ) +import TcMType ( tcInstTyVars, newTyVarTy, unifyTauTy, unifyListTy, unifyTupleTy ) +import TcType ( isTauTy, mkTyConApp, mkClassPred, liftedTypeKind ) import TcMonoType ( tcHsSigType ) -import TcUnify ( unifyTauTy, unifyListTy, unifyTupleTy ) import CmdLineOpts ( opt_IrrefutableTuples ) import DataCon ( dataConSig, dataConFieldLabels, dataConSourceArity ) -import Type ( isTauTy, mkTyConApp, mkClassPred, liftedTypeKind ) import Subst ( substTy, substTheta ) import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index c7e77a9484..a87a66160c 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -15,7 +15,8 @@ import HscTypes ( PackageRuleBase ) import TcHsSyn ( TypecheckedRuleDecl, mkHsLet ) import TcMonad import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck ) -import TcType ( newTyVarTy ) +import TcMType ( newTyVarTy ) +import TcType ( tyVarsOfTypes, openTypeKind ) import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar ) import TcMonoType ( kcHsSigTypes, tcHsSigType, tcScopedTyVars, checkSigTyVars ) import TcExpr ( tcExpr ) @@ -25,7 +26,6 @@ import Inst ( LIE, plusLIEs, instToId ) import Id ( idName, idType, mkLocalId ) import Module ( Module ) import VarSet -import Type ( tyVarsOfTypes, openTypeKind ) import List ( partition ) import Outputable \end{code} @@ -115,7 +115,7 @@ tcSourceRule (HsRule name sig_tvs vars lhs rhs src_loc) -- in the LHS, but not in the type of the lhs, nor in the binders. -- They'll get zapped to (), but that's over-constraining really. -- Let's see if we get a problem. - forall_tvs = varSetElems (tyVarsOfTypes (rule_ty : map idType tpl_ids)) + forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids) in -- RHS can be a bit more lenient. In particular, diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 0044d67910..fcf1636b09 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -23,24 +23,28 @@ import HscTypes ( implicitTyThingIds ) import TcMonad import TcEnv ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..), tcExtendKindEnv, tcLookup, tcExtendGlobalEnv, tcExtendGlobalValEnv ) -import TcTyDecls ( tcTyDecl1, kcConDetails, mkNewTyConRep ) +import TcTyDecls ( tcTyDecl1, kcConDetails ) import TcClassDcl ( tcClassDecl1 ) -import TcMonoType ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars ) -import TcType ( TcKind, newKindVar, zonkKindEnv ) - -import TcUnify ( unifyKind ) import TcInstDcls ( tcAddDeclCtxt ) -import Type ( Kind, mkArrowKind, liftedTypeKind, zipFunTys ) +import TcMonoType ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars ) +import TcMType ( unifyKind, newKindVar, zonkKindEnv ) +import TcType ( tcSplitTyConApp_maybe, + Type, Kind, mkArrowKind, liftedTypeKind, zipFunTys + ) +import Subst ( mkTyVarSubst, substTy ) import Variance ( calcTyConArgVrcs ) import Class ( Class, mkClass, classTyCon ) -import TyCon ( TyCon, tyConKind, ArgVrcs, AlgTyConFlavour(..), - mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon ) -import DataCon ( isNullaryDataCon ) -import Var ( varName ) +import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..), + tyConName, tyConKind, tyConTyVars, tyConArity, tyConDataCons, + mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon, isNewTyCon, + isRecursiveTyCon ) +import TysWiredIn ( unitTy ) +import DataCon ( isNullaryDataCon, dataConOrigArgTys ) +import Var ( varName, varType ) import FiniteMap import Digraph ( stronglyConnComp, SCC(..) ) import Name ( Name, getSrcLoc, isTyVarName ) -import NameEnv ( NameEnv, mkNameEnv, lookupNameEnv_NF ) +import NameEnv import NameSet import Outputable import Maybes ( mapMaybe ) @@ -323,10 +327,17 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details tyvars = mkTyClTyVars tycon_kind tyvar_names argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon + -- Watch out! mkTyConApp asks whether the tycon is a NewType, + -- so flavour has to be able to answer this question without consulting rec_details flavour = case data_or_new of - NewType -> NewTyCon (mkNewTyConRep tycon) - DataType | all isNullaryDataCon data_cons -> EnumTyCon - | otherwise -> DataTyCon + NewType -> NewTyCon (mkNewTyConRep tycon) + DataType | all (null . dataConOrigArgTys) data_cons -> EnumTyCon + | otherwise -> DataTyCon + -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon + -- but that looks at the *representation* arity, and that in turn + -- depends on deciding whether to unpack the args, and that + -- depends on whether it's a data type or a newtype --- so + -- in the recursive case we can get a loop. This version is simple! buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name}) @@ -346,16 +357,25 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details argvrcs dict_con clas -- Yes! It's a dictionary flavour + is_rec + -- A class can be recursive, and in the case of newtypes + -- this matters. For example + -- class C a where { op :: C b => a -> b -> Int } + -- Because C has only one operation, it is represented by + -- a newtype, and it should be a *recursive* newtype. + -- [If we don't make it a recursive newtype, we'll expand the + -- newtype like a synonym, but that will lead toan inifinite type ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name class_kind = lookupNameEnv_NF kenv class_name tyvars = mkTyClTyVars class_kind tyvar_names argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon - n_fields = length sc_sel_ids + length op_items - flavour | n_fields == 1 = NewTyCon (mkNewTyConRep tycon) - | otherwise = DataTyCon + flavour = case dataConOrigArgTys dict_con of + -- The tyvars in the datacon are the same as in the class + [rep_ty] -> NewTyCon rep_ty + other -> DataTyCon -- We can find the functional dependencies right away, -- and it is vital to do so. Why? Because in the next pass @@ -368,6 +388,19 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details bogusVrcs = panic "Bogus tycon arg variances" \end{code} +\begin{code} +mkNewTyConRep :: TyCon -- The original type constructor + -> Type -- Chosen representation type +-- Find the representation type for this newtype TyCon +-- For a recursive type constructor we give an error thunk, +-- because we never look at the rep in that case +-- (see notes on newypes in types/TypeRep + +mkNewTyConRep tc + | isRecursiveTyCon tc = pprPanic "Attempt to get the rep of newtype" (ppr tc) + | otherwise = head (dataConOrigArgTys (head (tyConDataCons tc))) +\end{code} + %************************************************************************ %* * diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index ebfa3a8f95..dfd86edcd1 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -4,9 +4,7 @@ \section[TcTyDecls]{Typecheck type declarations} \begin{code} -module TcTyDecls ( - tcTyDecl1, kcConDetails, mkNewTyConRep - ) where +module TcTyDecls ( tcTyDecl1, kcConDetails ) where #include "HsVersions.h" @@ -23,20 +21,21 @@ import TcEnv ( tcExtendTyVarEnv, tcLookupTyCon, tcLookupRecId, TyThingDetails(..), RecTcEnv ) +import TcType ( tcSplitTyConApp_maybe, tcEqType, + tyVarsOfTypes, tyVarsOfPred, + mkTyConApp, mkTyVarTys, mkForAllTys, + Type, ThetaType + ) import TcMonad -import DataCon ( DataCon, mkDataCon, dataConFieldLabels, dataConRepType ) +import DataCon ( DataCon, mkDataCon, dataConFieldLabels, dataConRepType, + isNullaryDataCon, dataConOrigArgTys ) import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId ) import FieldLabel import Var ( TyVar ) import Name ( Name, NamedThing(..) ) import Outputable -import TyCon ( TyCon, isNewTyCon, tyConTyVars ) -import Type ( tyVarsOfTypes, tyVarsOfPred, splitFunTy, applyTys, - mkTyConApp, mkTyVarTys, mkForAllTys, - splitAlgTyConApp_maybe, Type, ThetaType - ) -import TysWiredIn ( unitTy ) +import TyCon ( TyCon, AlgTyConFlavour(..), tyConTyVars ) import VarSet ( intersectVarSet, isEmptyVarSet ) import PrelNames ( unpackCStringName, unpackCStringUtf8Name ) import ListSetOps ( equivClasses ) @@ -86,27 +85,6 @@ tcTyDecl1 is_rec unf_env (ForeignType {tcdName = tycon_name}) = returnTc (tycon_name, ForeignTyDetails) \end{code} -\begin{code} -mkNewTyConRep :: TyCon -> Type --- Find the representation type for this newtype TyCon --- The trick is to to deal correctly with recursive newtypes --- such as newtype T = MkT T - -mkNewTyConRep tc - = mkForAllTys tvs (loop [] (mkTyConApp tc (mkTyVarTys tvs))) - where - tvs = tyConTyVars tc - loop tcs ty = case splitAlgTyConApp_maybe ty of { - Nothing -> ty ; - Just (tc, tys, data_cons) | not (isNewTyCon tc) -> ty - | tc `elem` tcs -> unitTy - | otherwise -> - - case splitFunTy (applyTys (dataConRepType (head data_cons)) tys) of - (rep_ty, _) -> loop (tc:tcs) rep_ty - } -\end{code} - %************************************************************************ %* * @@ -218,7 +196,7 @@ tcRecordSelectors is_rec unf_env tycon data_cons = -- Check that all the fields in the group have the same type -- NB: this check assumes that all the constructors of a given -- data type use the same type variables - checkTc (all (== field_ty) other_tys) (fieldTypeMisMatch field_name) + checkTc (all (tcEqType field_ty) other_tys) (fieldTypeMisMatch field_name) where field_ty = fieldLabelType first_field_label field_name = fieldLabelName first_field_label diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 3f6831bb9a..d6420b27b8 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -3,472 +3,915 @@ % \section[TcType]{Types used in the typechecker} -\begin{code} -module TcType ( - - TcTyVar, - TcTyVarSet, - newTyVar, - newTyVarTy, -- Kind -> NF_TcM TcType - newTyVarTys, -- Int -> Kind -> NF_TcM [TcType] - - ----------------------------------------- - TcType, TcTauType, TcThetaType, TcRhoType, - - -- Find the type to which a type variable is bound - tcPutTyVar, -- :: TcTyVar -> TcType -> NF_TcM TcType - tcGetTyVar, -- :: TcTyVar -> NF_TcM (Maybe TcType) does shorting out +This module provides the Type interface for front-end parts of the +compiler. These parts + * treat "source types" as opaque: + newtypes, and predicates are meaningful. + * look through usage types - tcSplitRhoTy, - - tcInstTyVar, tcInstTyVars, - tcInstSigVars, - tcInstType, +The "tc" prefix is for "typechechecker", because the type checker +is the principal client. +\begin{code} +module TcType ( -------------------------------- - TcKind, - newKindVar, newKindVars, newBoxityVar, + -- Types + TauType, RhoType, SigmaType, -------------------------------- - zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcSigTyVars, - zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType, - zonkTcPredType, + -- Builders + mkRhoTy, mkSigmaTy, - zonkTcTypeToType, zonkTcTyVarToTyVar, zonkKindEnv + -------------------------------- + -- Splitters + -- These are important because they do not look through newtypes + tcSplitForAllTys, tcSplitRhoTy, + tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, + tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs, + tcSplitAppTy_maybe, tcSplitAppTy, tcSplitSigmaTy, + tcSplitMethodTy, tcGetTyVar_maybe, tcGetTyVar, + + --------------------------------- + -- Predicates. + -- Again, newtypes are opaque + tcEqType, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, + isQualifiedTy, isOverloadedTy, isStrictType, isStrictPred, + isDoubleTy, isFloatTy, isIntTy, + isIntegerTy, isAddrTy, isBoolTy, isUnitTy, isForeignPtrTy, isPrimitiveType, + isTauTy, tcIsTyVarTy, tcIsForAllTy, + + --------------------------------- + -- Misc type manipulators + hoistForAllTys, deNoteType, + namesOfType, namesOfDFunHead, + getDFunTyKey, + + --------------------------------- + -- Predicate types + PredType, mkPredTy, mkPredTys, getClassPredTys_maybe, getClassPredTys, + isPredTy, isClassPred, isTyVarClassPred, predHasFDs, + mkDictTy, tcSplitPredTy_maybe, predTyUnique, + isDictTy, tcSplitDFunTy, + mkClassPred, predMentionsIPs, inheritablePred, isIPPred, mkPredName, + + --------------------------------- + -- Unifier and matcher + unifyTysX, unifyTyListsX, unifyExtendTysX, + allDistinctTyVars, + matchTy, matchTys, match, + -------------------------------- + -- Rexported from Type + Kind, Type, SourceType(..), PredType, ThetaType, + unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, + mkForAllTy, mkForAllTys, + mkFunTy, mkFunTys, zipFunTys, + mkTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys, + mkTyVarTy, mkTyVarTys, mkTyConTy, + predTyUnique, mkClassPred, + isUnLiftedType, -- Source types are always lifted + isUnboxedTupleType, -- Ditto + tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes, + tidyTyVar, tidyTyVars, + eqKind, eqUsage, + + -- Reexported ??? + tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta ) where #include "HsVersions.h" +import {-# SOURCE #-} PprType( pprType ) + -- friends: -import TypeRep ( Type(..), Kind, TyNote(..) ) -- friend -import Type ( PredType(..), - getTyVar, mkAppTy, mkUTy, - splitPredTy_maybe, splitForAllTys, - isTyVarTy, mkTyVarTy, mkTyVarTys, - openTypeKind, liftedTypeKind, - superKind, superBoxity, tyVarsOfTypes, - defaultKind, liftedBoxity - ) -import Subst ( Subst, mkTopTyVarSubst, substTy ) -import TyCon ( mkPrimTyCon ) -import PrimRep ( PrimRep(VoidRep) ) -import Var ( TyVar, tyVarKind, tyVarName, isTyVar, isMutTyVar, mkTyVar ) +import TypeRep ( Type(..), TyNote(..) ) -- friend +import Type -- Lots and lots +import TyCon ( TyCon, isPrimTyCon, tyConArity, isNewTyCon ) +import Class ( classTyCon, classHasFDs, Class ) +import Var ( TyVar, tyVarName, isTyVar, tyVarKind, mkTyVar ) +import VarEnv +import VarSet -- others: -import TcMonad -- TcType, amongst others -import TysWiredIn ( voidTy ) - +import CmdLineOpts ( opt_DictsStrict ) import Name ( Name, NamedThing(..), setNameUnique, mkSysLocalName, mkLocalName, mkDerivedTyConOcc ) -import Unique ( Uniquable(..) ) -import SrcLoc ( noSrcLoc ) -import Util ( nOfThem ) +import OccName ( OccName, mkDictOcc ) +import NameSet +import PrelNames ( floatTyConKey, doubleTyConKey, foreignPtrTyConKey, + integerTyConKey, intTyConKey, addrTyConKey, boolTyConKey ) +import Unique ( Unique, Uniquable(..), mkTupleTyConUnique ) +import SrcLoc ( SrcLoc, noSrcLoc ) +import Util ( nOfThem, cmpList, thenCmp ) +import Maybes ( maybeToBool, expectJust ) +import BasicTypes ( Boxity(..) ) import Outputable \end{code} -Utility functions -~~~~~~~~~~~~~~~~~ -These tcSplit functions are like their non-Tc analogues, but they -follow through bound type variables. +%************************************************************************ +%* * +\subsection{Tau, sigma and rho} +%* * +%************************************************************************ + +\begin{code} +type SigmaType = Type +type RhoType = Type + +mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau) -No need for tcSplitForAllTy because a type variable can't be instantiated -to a for-all type. +mkRhoTy :: [SourceType] -> Type -> Type +mkRhoTy theta ty = UASSERT2( not (isUTy ty), pprType ty ) + foldr (\p r -> FunTy (mkUTyM (mkPredTy p)) (mkUTyM r)) ty theta + +\end{code} + + +@isTauTy@ tests for nested for-alls. \begin{code} -tcSplitRhoTy :: TcType -> NF_TcM (TcThetaType, TcType) -tcSplitRhoTy t - = go t t [] - where - -- A type variable is never instantiated to a dictionary type, - -- so we don't need to do a tcReadVar on the "arg". - go syn_t (FunTy arg res) ts = case splitPredTy_maybe arg of - Just pair -> go res res (pair:ts) - Nothing -> returnNF_Tc (reverse ts, syn_t) - go syn_t (NoteTy _ t) ts = go syn_t t ts - go syn_t (TyVarTy tv) ts = tcGetTyVar tv `thenNF_Tc` \ maybe_ty -> - case maybe_ty of - Just ty | not (isTyVarTy ty) -> go syn_t ty ts - other -> returnNF_Tc (reverse ts, syn_t) - go syn_t (UsageTy _ t) ts = go syn_t t ts - go syn_t t ts = returnNF_Tc (reverse ts, syn_t) +isTauTy :: Type -> Bool +isTauTy (TyVarTy v) = True +isTauTy (TyConApp _ tys) = all isTauTy tys +isTauTy (AppTy a b) = isTauTy a && isTauTy b +isTauTy (FunTy a b) = isTauTy a && isTauTy b +isTauTy (SourceTy p) = isTauTy (sourceTypeRep p) +isTauTy (NoteTy _ ty) = isTauTy ty +isTauTy (UsageTy _ ty) = isTauTy ty +isTauTy other = False +\end{code} + +\begin{code} +getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to + -- construct a dictionary function name +getDFunTyKey (TyVarTy tv) = getOccName tv +getDFunTyKey (TyConApp tc _) = getOccName tc +getDFunTyKey (AppTy fun _) = getDFunTyKey fun +getDFunTyKey (NoteTy _ t) = getDFunTyKey t +getDFunTyKey (FunTy arg _) = getOccName funTyCon +getDFunTyKey (ForAllTy _ t) = getDFunTyKey t +getDFunTyKey (UsageTy _ t) = getDFunTyKey t +getDFunTyKey (SourceTy (NType tc _)) = getOccName tc -- Newtypes are quite reasonable +getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty) +-- SourceTy shouldn't happen \end{code} %************************************************************************ %* * -\subsection{New type variables} +\subsection{Expanding and splitting} %* * %************************************************************************ +These tcSplit functions are like their non-Tc analogues, but + a) they do not look through newtypes + b) they do not look through PredTys + c) [future] they ignore usage-type annotations + +However, they are non-monadic and do not follow through mutable type +variables. It's up to you to make sure this doesn't matter. + \begin{code} -newTyVar :: Kind -> NF_TcM TcTyVar -newTyVar kind - = tcGetUnique `thenNF_Tc` \ uniq -> - tcNewMutTyVar (mkSysLocalName uniq SLIT("t")) kind - -newTyVarTy :: Kind -> NF_TcM TcType -newTyVarTy kind - = newTyVar kind `thenNF_Tc` \ tc_tyvar -> - returnNF_Tc (TyVarTy tc_tyvar) - -newTyVarTys :: Int -> Kind -> NF_TcM [TcType] -newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind) - -newKindVar :: NF_TcM TcKind -newKindVar - = tcGetUnique `thenNF_Tc` \ uniq -> - tcNewMutTyVar (mkSysLocalName uniq SLIT("k")) superKind `thenNF_Tc` \ kv -> - returnNF_Tc (TyVarTy kv) - -newKindVars :: Int -> NF_TcM [TcKind] -newKindVars n = mapNF_Tc (\ _ -> newKindVar) (nOfThem n ()) - -newBoxityVar :: NF_TcM TcKind -newBoxityVar - = tcGetUnique `thenNF_Tc` \ uniq -> - tcNewMutTyVar (mkSysLocalName uniq SLIT("bx")) superBoxity `thenNF_Tc` \ kv -> - returnNF_Tc (TyVarTy kv) +tcSplitForAllTys :: Type -> ([TyVar], Type) +tcSplitForAllTys ty = split ty ty [] + where + split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) + split orig_ty (NoteTy n ty) tvs = split orig_ty ty tvs + split orig_ty (UsageTy _ ty) tvs = split orig_ty ty tvs + split orig_ty t tvs = (reverse tvs, orig_ty) + +tcIsForAllTy (ForAllTy tv ty) = True +tcIsForAllTy (NoteTy n ty) = tcIsForAllTy ty +tcIsForAllTy (UsageTy n ty) = tcIsForAllTy ty +tcIsForAllTy t = False + +tcSplitRhoTy :: Type -> ([PredType], Type) +tcSplitRhoTy ty = split ty ty [] + where + split orig_ty (FunTy arg res) ts = case tcSplitPredTy_maybe arg of + Just p -> split res res (p:ts) + Nothing -> (reverse ts, orig_ty) + split orig_ty (NoteTy n ty) ts = split orig_ty ty ts + split orig_ty (UsageTy _ ty) ts = split orig_ty ty ts + split orig_ty ty ts = (reverse ts, orig_ty) + +tcSplitSigmaTy ty = case tcSplitForAllTys ty of + (tvs, rho) -> case tcSplitRhoTy rho of + (theta, tau) -> (tvs, theta, tau) + +tcTyConAppTyCon :: Type -> TyCon +tcTyConAppTyCon ty = fst (tcSplitTyConApp ty) + +tcTyConAppArgs :: Type -> [Type] +tcTyConAppArgs ty = snd (tcSplitTyConApp ty) + +tcSplitTyConApp :: Type -> (TyCon, [Type]) +tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic "tcSplitTyConApp" (pprType ty) + +tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) +-- Newtypes are opaque, so they may be split +tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [unUTy arg,unUTy res]) +tcSplitTyConApp_maybe (NoteTy n ty) = tcSplitTyConApp_maybe ty +tcSplitTyConApp_maybe (UsageTy _ ty) = tcSplitTyConApp_maybe ty +tcSplitTyConApp_maybe (SourceTy (NType tc tys)) = Just (tc,tys) + -- However, predicates are not treated + -- as tycon applications by the type checker +tcSplitTyConApp_maybe other = Nothing + +tcSplitFunTys :: Type -> ([Type], Type) +tcSplitFunTys ty = case tcSplitFunTy_maybe ty of + Nothing -> ([], ty) + Just (arg,res) -> (arg:args, res') + where + (args,res') = tcSplitFunTys res + +tcSplitFunTy_maybe :: Type -> Maybe (Type, Type) +tcSplitFunTy_maybe (FunTy arg res) = Just (arg, res) +tcSplitFunTy_maybe (NoteTy n ty) = tcSplitFunTy_maybe ty +tcSplitFunTy_maybe (UsageTy _ ty) = tcSplitFunTy_maybe ty +tcSplitFunTy_maybe other = Nothing + +tcFunArgTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> arg } +tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res } + + +tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) +tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [unUTy ty1], unUTy ty2) +tcSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) +tcSplitAppTy_maybe (NoteTy n ty) = tcSplitAppTy_maybe ty +tcSplitAppTy_maybe (UsageTy _ ty) = tcSplitAppTy_maybe ty +tcSplitAppTy_maybe (SourceTy (NType tc tys)) = tc_split_app tc tys + --- Don't forget that newtype! +tcSplitAppTy_maybe (TyConApp tc tys) = tc_split_app tc tys +tcSplitAppTy_maybe other = Nothing + +tc_split_app tc [] = Nothing +tc_split_app tc tys = split tys [] + where + split [ty2] acc = Just (TyConApp tc (reverse acc), ty2) + split (ty:tys) acc = split tys (ty:acc) + +tcSplitAppTy ty = case tcSplitAppTy_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic "tcSplitAppTy" (pprType ty) + +tcGetTyVar_maybe :: Type -> Maybe TyVar +tcGetTyVar_maybe (TyVarTy tv) = Just tv +tcGetTyVar_maybe (NoteTy _ t) = tcGetTyVar_maybe t +tcGetTyVar_maybe ty@(UsageTy _ _) = pprPanic "tcGetTyVar_maybe: UTy:" (pprType ty) +tcGetTyVar_maybe other = Nothing + +tcGetTyVar :: String -> Type -> TyVar +tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty) + +tcIsTyVarTy :: Type -> Bool +tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty) +\end{code} + +The type of a method for class C is always of the form: + Forall a1..an. C a1..an => sig_ty +where sig_ty is the type given by the method's signature, and thus in general +is a ForallTy. At the point that splitMethodTy is called, it is expected +that the outer Forall has already been stripped off. splitMethodTy then +returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes or +Usages stripped off. + +\begin{code} +tcSplitMethodTy :: Type -> (PredType, Type) +tcSplitMethodTy ty = split ty + where + split (FunTy arg res) = case tcSplitPredTy_maybe arg of + Just p -> (p, res) + Nothing -> panic "splitMethodTy" + split (NoteTy n ty) = split ty + split (UsageTy _ ty) = split ty + split _ = panic "splitMethodTy" + +tcSplitDFunTy :: Type -> ([TyVar], [SourceType], Class, [Type]) +-- Split the type of a dictionary function +tcSplitDFunTy ty + = case tcSplitSigmaTy ty of { (tvs, theta, tau) -> + case tcSplitPredTy_maybe tau of { Just (ClassP clas tys) -> + (tvs, theta, clas, tys) }} \end{code} %************************************************************************ %* * -\subsection{Type instantiation} +\subsection{Predicate types} %* * %************************************************************************ -Instantiating a bunch of type variables +"Predicates" are particular source types, namelyClassP or IParams \begin{code} -tcInstTyVars :: [TyVar] - -> NF_TcM ([TcTyVar], [TcType], Subst) - -tcInstTyVars tyvars - = mapNF_Tc tcInstTyVar tyvars `thenNF_Tc` \ tc_tyvars -> - let - tys = mkTyVarTys tc_tyvars - in - returnNF_Tc (tc_tyvars, tys, mkTopTyVarSubst tyvars tys) - -- Since the tyvars are freshly made, - -- they cannot possibly be captured by - -- any existing for-alls. Hence mkTopTyVarSubst - -tcInstTyVar tyvar - = tcGetUnique `thenNF_Tc` \ uniq -> - let - name = setNameUnique (tyVarName tyvar) uniq - -- Note that we don't change the print-name - -- This won't confuse the type checker but there's a chance - -- that two different tyvars will print the same way - -- in an error message. -dppr-debug will show up the difference - -- Better watch out for this. If worst comes to worst, just - -- use mkSysLocalName. - in - tcNewMutTyVar name (tyVarKind tyvar) - -tcInstSigVars tyvars -- Very similar to tcInstTyVar - = tcGetUniques `thenNF_Tc` \ uniqs -> - listTc [ ASSERT( not (kind == openTypeKind) ) -- Shouldn't happen - tcNewSigTyVar name kind - | (tyvar, uniq) <- tyvars `zip` uniqs, - let name = setNameUnique (tyVarName tyvar) uniq, - let kind = tyVarKind tyvar - ] +isPred :: SourceType -> Bool +isPred (ClassP _ _) = True +isPred (IParam _ _) = True +isPred (NType _ __) = False + +isPredTy :: Type -> Bool +isPredTy (NoteTy _ ty) = isPredTy ty +isPredTy (UsageTy _ ty) = isPredTy ty +isPredTy (SourceTy sty) = isPred sty +isPredTy _ = False + +tcSplitPredTy_maybe :: Type -> Maybe PredType + -- Returns Just for predicates only +tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty +tcSplitPredTy_maybe (UsageTy _ ty) = tcSplitPredTy_maybe ty +tcSplitPredTy_maybe (SourceTy p) | isPred p = Just p +tcSplitPredTy_maybe other = Nothing + +mkPredTy :: PredType -> Type +mkPredTy pred = SourceTy pred + +mkPredTys :: ThetaType -> [Type] +mkPredTys preds = map SourceTy preds + +predTyUnique :: PredType -> Unique +predTyUnique (IParam n _) = getUnique n +predTyUnique (ClassP clas tys) = getUnique clas + +predHasFDs :: PredType -> Bool +-- True if the predicate has functional depenencies; +-- I.e. should participate in improvement +predHasFDs (IParam _ _) = True +predHasFDs (ClassP cls _) = classHasFDs cls + +mkPredName :: Unique -> SrcLoc -> SourceType -> Name +mkPredName uniq loc (ClassP cls tys) = mkLocalName uniq (mkDictOcc (getOccName cls)) loc +mkPredName uniq loc (IParam name ty) = name \end{code} -@tcInstType@ instantiates the outer-level for-alls of a TcType with -fresh type variables, splits off the dictionary part, and returns the results. + +--------------------- Dictionary types --------------------------------- \begin{code} -tcInstType :: TcType -> NF_TcM ([TcTyVar], TcThetaType, TcType) -tcInstType ty - = case splitForAllTys ty of - ([], rho) -> -- There may be overloading but no type variables; - -- (?x :: Int) => Int -> Int - tcSplitRhoTy rho `thenNF_Tc` \ (theta, tau) -> - returnNF_Tc ([], theta, tau) - - (tyvars, rho) -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) -> - tcSplitRhoTy (substTy tenv rho) `thenNF_Tc` \ (theta, tau) -> - returnNF_Tc (tyvars', theta, tau) +mkClassPred clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) ) + ClassP clas tys + +isClassPred :: SourceType -> Bool +isClassPred (ClassP clas tys) = True +isClassPred other = False + +isTyVarClassPred (ClassP clas tys) = all isTyVarTy tys +isTyVarClassPred other = False + +getClassPredTys_maybe :: SourceType -> Maybe (Class, [Type]) +getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys) +getClassPredTys_maybe _ = Nothing + +getClassPredTys :: PredType -> (Class, [Type]) +getClassPredTys (ClassP clas tys) = (clas, tys) + +mkDictTy :: Class -> [Type] -> Type +mkDictTy clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) ) + mkPredTy (ClassP clas tys) + +isDictTy :: Type -> Bool +isDictTy (SourceTy p) = isClassPred p +isDictTy (NoteTy _ ty) = isDictTy ty +isDictTy (UsageTy _ ty) = isDictTy ty +isDictTy other = False \end{code} +--------------------- Implicit parameters --------------------------------- + +\begin{code} +isIPPred :: SourceType -> Bool +isIPPred (IParam _ _) = True +isIPPred other = False + +inheritablePred :: PredType -> Bool +-- Can be inherited by a context. For example, consider +-- f x = let g y = (?v, y+x) +-- in (g 3 with ?v = 8, +-- g 4 with ?v = 9) +-- The point is that g's type must be quantifed over ?v: +-- g :: (?v :: a) => a -> a +-- but it doesn't need to be quantified over the Num a dictionary +-- which can be free in g's rhs, and shared by both calls to g +inheritablePred (ClassP _ _) = True +inheritablePred other = False + +predMentionsIPs :: SourceType -> NameSet -> Bool +predMentionsIPs (IParam n _) ns = n `elemNameSet` ns +predMentionsIPs other ns = False +\end{code} %************************************************************************ %* * -\subsection{Putting and getting mutable type variables} +\subsection{Comparison} %* * %************************************************************************ +Comparison, taking note of newtypes, predicates, etc, +But ignoring usage types + \begin{code} -tcPutTyVar :: TcTyVar -> TcType -> NF_TcM TcType -tcGetTyVar :: TcTyVar -> NF_TcM (Maybe TcType) +tcEqType :: Type -> Type -> Bool +tcEqType ty1 ty2 = case ty1 `tcCmpType` ty2 of { EQ -> True; other -> False } + +tcEqPred :: PredType -> PredType -> Bool +tcEqPred p1 p2 = case p1 `tcCmpPred` p2 of { EQ -> True; other -> False } + +------------- +tcCmpType :: Type -> Type -> Ordering +tcCmpType ty1 ty2 = cmpTy emptyVarEnv ty1 ty2 + +tcCmpTypes tys1 tys2 = cmpTys emptyVarEnv tys1 tys2 + +tcCmpPred p1 p2 = cmpSourceTy emptyVarEnv p1 p2 +------------- +cmpTys env tys1 tys2 = cmpList (cmpTy env) tys1 tys2 + +------------- +cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering + -- The "env" maps type variables in ty1 to type variables in ty2 + -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2) + -- we in effect substitute tv2 for tv1 in t1 before continuing + + -- Look through NoteTy and UsageTy +cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2 +cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2 +cmpTy env (UsageTy _ ty1) ty2 = cmpTy env ty1 ty2 +cmpTy env ty1 (UsageTy _ ty2) = cmpTy env ty1 ty2 + + -- Deal with equal constructors +cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of + Just tv1a -> tv1a `compare` tv2 + Nothing -> tv1 `compare` tv2 + +cmpTy env (SourceTy p1) (SourceTy p2) = cmpSourceTy env p1 p2 +cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2 +cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2 +cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2) +cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2 + + -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < SourceTy +cmpTy env (AppTy _ _) (TyVarTy _) = GT + +cmpTy env (FunTy _ _) (TyVarTy _) = GT +cmpTy env (FunTy _ _) (AppTy _ _) = GT + +cmpTy env (TyConApp _ _) (TyVarTy _) = GT +cmpTy env (TyConApp _ _) (AppTy _ _) = GT +cmpTy env (TyConApp _ _) (FunTy _ _) = GT + +cmpTy env (ForAllTy _ _) (TyVarTy _) = GT +cmpTy env (ForAllTy _ _) (AppTy _ _) = GT +cmpTy env (ForAllTy _ _) (FunTy _ _) = GT +cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT + +cmpTy env (SourceTy _) t2 = GT + +cmpTy env _ _ = LT \end{code} -Putting is easy: - \begin{code} -tcPutTyVar tyvar ty - | not (isMutTyVar tyvar) - = pprTrace "tcPutTyVar" (ppr tyvar) $ - returnNF_Tc ty +cmpSourceTy :: TyVarEnv TyVar -> SourceType -> SourceType -> Ordering +cmpSourceTy env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2) + -- Compare types as well as names for implicit parameters + -- This comparison is used exclusively (I think) for the + -- finite map built in TcSimplify +cmpSourceTy env (IParam _ _) sty = LT + +cmpSourceTy env (ClassP _ _) (IParam _ _) = GT +cmpSourceTy env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2) +cmpSourceTy env (ClassP _ _) (NType _ _) = LT + +cmpSourceTy env (NType tc1 tys1) (NType tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2) +cmpSourceTy env (NType _ _) sty = GT +\end{code} - | otherwise - = ASSERT( isMutTyVar tyvar ) - UASSERT2( not (isUTy ty), ppr tyvar <+> ppr ty ) - tcWriteMutTyVar tyvar (Just ty) `thenNF_Tc_` - returnNF_Tc ty +PredTypes are used as a FM key in TcSimplify, +so we take the easy path and make them an instance of Ord + +\begin{code} +instance Eq SourceType where { (==) = tcEqPred } +instance Ord SourceType where { compare = tcCmpPred } \end{code} -Getting is more interesting. The easy thing to do is just to read, thus: -\begin{verbatim} -tcGetTyVar tyvar = tcReadMutTyVar tyvar -\end{verbatim} +%************************************************************************ +%* * +\subsection{Predicates} +%* * +%************************************************************************ -But it's more fun to short out indirections on the way: If this -version returns a TyVar, then that TyVar is unbound. If it returns -any other type, then there might be bound TyVars embedded inside it. +isQualifiedTy returns true of any qualified type. It doesn't *necessarily* have +any foralls. E.g. + f :: (?x::Int) => Int -> Int -We return Nothing iff the original box was unbound. +\begin{code} +isQualifiedTy :: Type -> Bool +isQualifiedTy (ForAllTy tyvar ty) = True +isQualifiedTy (FunTy a b) = isPredTy a +isQualifiedTy (NoteTy n ty) = isQualifiedTy ty +isQualifiedTy (UsageTy _ ty) = isQualifiedTy ty +isQualifiedTy _ = False + +isOverloadedTy :: Type -> Bool +isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty +isOverloadedTy (FunTy a b) = isPredTy a +isOverloadedTy (NoteTy n ty) = isOverloadedTy ty +isOverloadedTy (UsageTy _ ty) = isOverloadedTy ty +isOverloadedTy _ = False +\end{code} \begin{code} -tcGetTyVar tyvar - | not (isMutTyVar tyvar) - = pprTrace "tcGetTyVar" (ppr tyvar) $ - returnNF_Tc (Just (mkTyVarTy tyvar)) +isFloatTy = is_tc floatTyConKey +isDoubleTy = is_tc doubleTyConKey +isForeignPtrTy = is_tc foreignPtrTyConKey +isIntegerTy = is_tc integerTyConKey +isIntTy = is_tc intTyConKey +isAddrTy = is_tc addrTyConKey +isBoolTy = is_tc boolTyConKey +isUnitTy = is_tc (mkTupleTyConUnique Boxed 0) + +is_tc :: Unique -> Type -> Bool +-- Newtypes are opaque to this +is_tc uniq ty = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> uniq == getUnique tc + Nothing -> False +\end{code} - | otherwise - = ASSERT2( isMutTyVar tyvar, ppr tyvar ) - tcReadMutTyVar tyvar `thenNF_Tc` \ maybe_ty -> - case maybe_ty of - Just ty -> short_out ty `thenNF_Tc` \ ty' -> - tcWriteMutTyVar tyvar (Just ty') `thenNF_Tc_` - returnNF_Tc (Just ty') +\begin{code} +isPrimitiveType :: Type -> Bool +-- Returns types that are opaque to Haskell. +-- Most of these are unlifted, but now that we interact with .NET, we +-- may have primtive (foreign-imported) types that are lifted +isPrimitiveType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) + isPrimTyCon tc + other -> False +\end{code} - Nothing -> returnNF_Tc Nothing +@isStrictType@ computes whether an argument (or let RHS) should +be computed strictly or lazily, based only on its type -short_out :: TcType -> NF_TcM TcType -short_out ty@(TyVarTy tyvar) - | not (isMutTyVar tyvar) - = returnNF_Tc ty +\begin{code} +isStrictType :: Type -> Bool +isStrictType ty + | isUnLiftedType ty = True + | Just pred <- tcSplitPredTy_maybe ty = isStrictPred pred + | otherwise = False + +isStrictPred (ClassP clas _) = opt_DictsStrict + && not (isNewTyCon (classTyCon clas)) +isStrictPred pred = False + -- We may be strict in dictionary types, but only if it + -- has more than one component. + -- [Being strict in a single-component dictionary risks + -- poking the dictionary component, which is wrong.] +\end{code} - | otherwise - = tcReadMutTyVar tyvar `thenNF_Tc` \ maybe_ty -> - case maybe_ty of - Just ty' -> short_out ty' `thenNF_Tc` \ ty' -> - tcWriteMutTyVar tyvar (Just ty') `thenNF_Tc_` - returnNF_Tc ty' - other -> returnNF_Tc ty +%************************************************************************ +%* * +\subsection{Misc} +%* * +%************************************************************************ + +\begin{code} +hoistForAllTys :: Type -> Type + -- Move all the foralls to the top + -- e.g. T -> forall a. a ==> forall a. T -> a + -- Careful: LOSES USAGE ANNOTATIONS! +hoistForAllTys ty + = case hoist ty of { (tvs, body) -> mkForAllTys tvs body } + where + hoist :: Type -> ([TyVar], Type) + hoist ty = case tcSplitFunTys ty of { (args, res) -> + case tcSplitForAllTys res of { + ([], body) -> ([], ty) ; + (tvs1, body1) -> case hoist body1 of { (tvs2,body2) -> + (tvs1 ++ tvs2, mkFunTys args body2) + }}} +\end{code} + + +\begin{code} +deNoteType :: Type -> Type + -- Remove synonyms, but not source types +deNoteType ty@(TyVarTy tyvar) = ty +deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys) +deNoteType (SourceTy p) = SourceTy (deNoteSourceType p) +deNoteType (NoteTy _ ty) = deNoteType ty +deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg) +deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg) +deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty) +deNoteType (UsageTy u ty) = UsageTy u (deNoteType ty) + +deNoteSourceType :: SourceType -> SourceType +deNoteSourceType (ClassP c tys) = ClassP c (map deNoteType tys) +deNoteSourceType (IParam n ty) = IParam n (deNoteType ty) +deNoteSourceType (NType tc tys) = NType tc (map deNoteType tys) +\end{code} + +Find the free names of a type, including the type constructors and classes it mentions +This is used in the front end of the compiler -short_out other_ty = returnNF_Tc other_ty +\begin{code} +namesOfType :: Type -> NameSet +namesOfType (TyVarTy tv) = unitNameSet (getName tv) +namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` namesOfTypes tys +namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1 +namesOfType (NoteTy other_note ty2) = namesOfType ty2 +namesOfType (SourceTy (IParam n ty)) = namesOfType ty +namesOfType (SourceTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` namesOfTypes tys +namesOfType (SourceTy (NType tc tys)) = unitNameSet (getName tc) `unionNameSets` namesOfTypes tys +namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res +namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg +namesOfType (ForAllTy tyvar ty) = namesOfType ty `delFromNameSet` getName tyvar +namesOfType (UsageTy u ty) = namesOfType u `unionNameSets` namesOfType ty + +namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys + +namesOfDFunHead :: Type -> NameSet +-- Find the free type constructors and classes +-- of the head of the dfun instance type +-- The 'dfun_head_type' is because of +-- instance Foo a => Baz T where ... +-- The decl is an orphan if Baz and T are both not locally defined, +-- even if Foo *is* locally defined +namesOfDFunHead dfun_ty = case tcSplitSigmaTy dfun_ty of + (tvs,_,head_ty) -> delListFromNameSet (namesOfType head_ty) + (map getName tvs) \end{code} %************************************************************************ %* * -\subsection{Zonking -- the exernal interfaces} +\subsection{Unification with an explicit substitution} %* * %************************************************************************ ------------------ Type variables +(allDistinctTyVars tys tvs) = True + iff +all the types tys are type variables, +distinct from each other and from tvs. + +This is useful when checking that unification hasn't unified signature +type variables. For example, if the type sig is + f :: forall a b. a -> b -> b +we want to check that 'a' and 'b' havn't + (a) been unified with a non-tyvar type + (b) been unified with each other (all distinct) + (c) been unified with a variable free in the environment \begin{code} -zonkTcTyVars :: [TcTyVar] -> NF_TcM [TcType] -zonkTcTyVars tyvars = mapNF_Tc zonkTcTyVar tyvars - -zonkTcTyVarsAndFV :: [TcTyVar] -> NF_TcM TcTyVarSet -zonkTcTyVarsAndFV tyvars = mapNF_Tc zonkTcTyVar tyvars `thenNF_Tc` \ tys -> - returnNF_Tc (tyVarsOfTypes tys) - -zonkTcTyVar :: TcTyVar -> NF_TcM TcType -zonkTcTyVar tyvar = zonkTyVar (\ tv -> returnNF_Tc (TyVarTy tv)) tyvar - -zonkTcSigTyVars :: [TcTyVar] -> NF_TcM [TcTyVar] --- This guy is to zonk the tyvars we're about to feed into tcSimplify --- Usually this job is done by checkSigTyVars, but in a couple of places --- that is overkill, so we use this simpler chap -zonkTcSigTyVars tyvars - = zonkTcTyVars tyvars `thenNF_Tc` \ tys -> - returnNF_Tc (map (getTyVar "zonkTcSigTyVars") tys) -\end{code} +allDistinctTyVars :: [Type] -> TyVarSet -> Bool ------------------ Types +allDistinctTyVars [] acc + = True +allDistinctTyVars (ty:tys) acc + = case tcGetTyVar_maybe ty of + Nothing -> False -- (a) + Just tv | tv `elemVarSet` acc -> False -- (b) or (c) + | otherwise -> allDistinctTyVars tys (acc `extendVarSet` tv) +\end{code} + + +%************************************************************************ +%* * +\subsection{Unification with an explicit substitution} +%* * +%************************************************************************ + +Unify types with an explicit substitution and no monad. +Ignore usage annotations. \begin{code} -zonkTcType :: TcType -> NF_TcM TcType -zonkTcType ty = zonkType (\ tv -> returnNF_Tc (TyVarTy tv)) ty - -zonkTcTypes :: [TcType] -> NF_TcM [TcType] -zonkTcTypes tys = mapNF_Tc zonkTcType tys - -zonkTcClassConstraints cts = mapNF_Tc zonk cts - where zonk (clas, tys) - = zonkTcTypes tys `thenNF_Tc` \ new_tys -> - returnNF_Tc (clas, new_tys) - -zonkTcThetaType :: TcThetaType -> NF_TcM TcThetaType -zonkTcThetaType theta = mapNF_Tc zonkTcPredType theta - -zonkTcPredType :: TcPredType -> NF_TcM TcPredType -zonkTcPredType (ClassP c ts) = - zonkTcTypes ts `thenNF_Tc` \ new_ts -> - returnNF_Tc (ClassP c new_ts) -zonkTcPredType (IParam n t) = - zonkTcType t `thenNF_Tc` \ new_t -> - returnNF_Tc (IParam n new_t) +type MySubst + = (TyVarSet, -- Set of template tyvars + TyVarSubstEnv) -- Not necessarily idempotent + +unifyTysX :: TyVarSet -- Template tyvars + -> Type + -> Type + -> Maybe TyVarSubstEnv +unifyTysX tmpl_tyvars ty1 ty2 + = uTysX ty1 ty2 (\(_,s) -> Just s) (tmpl_tyvars, emptySubstEnv) + +unifyExtendTysX :: TyVarSet -- Template tyvars + -> TyVarSubstEnv -- Substitution to start with + -> Type + -> Type + -> Maybe TyVarSubstEnv -- Extended substitution +unifyExtendTysX tmpl_tyvars subst ty1 ty2 + = uTysX ty1 ty2 (\(_,s) -> Just s) (tmpl_tyvars, subst) + +unifyTyListsX :: TyVarSet -> [Type] -> [Type] + -> Maybe TyVarSubstEnv +unifyTyListsX tmpl_tyvars tys1 tys2 + = uTyListsX tys1 tys2 (\(_,s) -> Just s) (tmpl_tyvars, emptySubstEnv) + + +uTysX :: Type + -> Type + -> (MySubst -> Maybe result) + -> MySubst + -> Maybe result + +uTysX (NoteTy _ ty1) ty2 k subst = uTysX ty1 ty2 k subst +uTysX ty1 (NoteTy _ ty2) k subst = uTysX ty1 ty2 k subst + + -- Variables; go for uVar +uTysX (TyVarTy tyvar1) (TyVarTy tyvar2) k subst + | tyvar1 == tyvar2 + = k subst +uTysX (TyVarTy tyvar1) ty2 k subst@(tmpls,_) + | tyvar1 `elemVarSet` tmpls + = uVarX tyvar1 ty2 k subst +uTysX ty1 (TyVarTy tyvar2) k subst@(tmpls,_) + | tyvar2 `elemVarSet` tmpls + = uVarX tyvar2 ty1 k subst + + -- Functions; just check the two parts +uTysX (FunTy fun1 arg1) (FunTy fun2 arg2) k subst + = uTysX fun1 fun2 (uTysX arg1 arg2 k) subst + + -- Type constructors must match +uTysX (TyConApp con1 tys1) (TyConApp con2 tys2) k subst + | (con1 == con2 && length tys1 == length tys2) + = uTyListsX tys1 tys2 k subst + + -- 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, + -- so if one type is an App the other one jolly well better be too +uTysX (AppTy s1 t1) ty2 k subst + = case tcSplitAppTy_maybe ty2 of + Just (s2, t2) -> uTysX s1 s2 (uTysX t1 t2 k) subst + Nothing -> Nothing -- Fail + +uTysX ty1 (AppTy s2 t2) k subst + = case tcSplitAppTy_maybe ty1 of + Just (s1, t1) -> uTysX s1 s2 (uTysX t1 t2 k) subst + Nothing -> Nothing -- Fail + + -- Not expecting for-alls in unification +#ifdef DEBUG +uTysX (ForAllTy _ _) ty2 k subst = panic "Unify.uTysX subst:ForAllTy (1st arg)" +uTysX ty1 (ForAllTy _ _) k subst = panic "Unify.uTysX subst:ForAllTy (2nd arg)" +#endif + + -- Ignore usages +uTysX (UsageTy _ t1) t2 k subst = uTysX t1 t2 k subst +uTysX t1 (UsageTy _ t2) k subst = uTysX t1 t2 k subst + + -- Anything else fails +uTysX ty1 ty2 k subst = Nothing + + +uTyListsX [] [] k subst = k subst +uTyListsX (ty1:tys1) (ty2:tys2) k subst = uTysX ty1 ty2 (uTyListsX tys1 tys2 k) subst +uTyListsX tys1 tys2 k subst = Nothing -- Fail if the lists are different lengths \end{code} -------------------- These ...ToType, ...ToKind versions - are used at the end of type checking - \begin{code} -zonkKindEnv :: [(Name, TcKind)] -> NF_TcM [(Name, Kind)] -zonkKindEnv pairs - = mapNF_Tc zonk_it pairs - where - zonk_it (name, tc_kind) = zonkType zonk_unbound_kind_var tc_kind `thenNF_Tc` \ kind -> - returnNF_Tc (name, kind) - - -- 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 == superKind = tcPutTyVar kv liftedTypeKind - | tyVarKind kv == superBoxity = tcPutTyVar kv liftedBoxity - | otherwise = pprPanic "zonkKindEnv" (ppr kv) - -zonkTcTypeToType :: TcType -> NF_TcM Type -zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty +-- Invariant: tv1 is a unifiable variable +uVarX tv1 ty2 k subst@(tmpls, env) + = case lookupSubstEnv env tv1 of + Just (DoneTy ty1) -> -- Already bound + uTysX ty1 ty2 k subst + + Nothing -- Not already bound + | typeKind ty2 `eqKind` tyVarKind tv1 + && occur_check_ok ty2 + -> -- No kind mismatch nor occur check + UASSERT( not (isUTy ty2) ) + k (tmpls, extendSubstEnv env tv1 (DoneTy ty2)) + + | otherwise -> Nothing -- Fail if kind mis-match or occur check where - -- Zonk a mutable but unbound type variable to - -- Void if it has kind Lifted - -- :Void otherwise - zonk_unbound_tyvar tv - | kind == liftedTypeKind || kind == openTypeKind - = tcPutTyVar tv voidTy -- Just to avoid creating a new tycon in - -- this vastly common case - | otherwise - = tcPutTyVar 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) - -- 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 - --- 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. --- --- It does this by making an immutable version of tv and binds tv to it. --- Now any bound occurences of the original type variable will get --- zonked to the immutable version. - -zonkTcTyVarToTyVar :: TcTyVar -> NF_TcM TyVar -zonkTcTyVarToTyVar tv - = let - -- Make an immutable version, defaulting - -- the kind to lifted if necessary - immut_tv = mkTyVar (tyVarName tv) (defaultKind (tyVarKind tv)) - immut_tv_ty = mkTyVarTy immut_tv - - zap tv = tcPutTyVar tv immut_tv_ty - -- Bind the mutable version to the immutable one - in - -- If the type variable is mutable, then bind it to immut_tv_ty - -- so that all other occurrences of the tyvar will get zapped too - zonkTyVar zap tv `thenNF_Tc` \ ty2 -> - - WARN( immut_tv_ty /= ty2, ppr tv $$ ppr immut_tv $$ ppr ty2 ) - - returnNF_Tc immut_tv + occur_check_ok ty = all occur_check_ok_tv (varSetElems (tyVarsOfType ty)) + occur_check_ok_tv tv | tv1 == tv = False + | otherwise = case lookupSubstEnv env tv of + Nothing -> True + Just (DoneTy ty) -> occur_check_ok ty \end{code} + %************************************************************************ %* * -\subsection{Zonking -- the main work-horses: zonkType, zonkTyVar} -%* * -%* For internal use only! * +\subsection{Matching on types} %* * %************************************************************************ +Matching is a {\em unidirectional} process, matching a type against a +template (which is just a type with type variables in it). The +matcher assumes that there are no repeated type variables in the +template, so that it simply returns a mapping of type variables to +types. It also fails on nested foralls. + +@matchTys@ matches corresponding elements of a list of templates and +types. It and @matchTy@ both ignore usage annotations, unlike the +main function @match@. + \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 - -zonkType :: (TcTyVar -> NF_TcM Type) -- What to do with unbound mutable type variables - -- see zonkTcType, and zonkTcTypeToType - -> TcType - -> NF_TcM Type -zonkType unbound_var_fn ty - = go ty - where - go (TyConApp tycon tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' -> - returnNF_Tc (TyConApp tycon tys') - - go (NoteTy (SynNote ty1) ty2) = go ty1 `thenNF_Tc` \ ty1' -> - go ty2 `thenNF_Tc` \ ty2' -> - returnNF_Tc (NoteTy (SynNote ty1') ty2') - - go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard free-tyvar annotations - - go (PredTy p) = go_pred p `thenNF_Tc` \ p' -> - returnNF_Tc (PredTy p') - - go (FunTy arg res) = go arg `thenNF_Tc` \ arg' -> - go res `thenNF_Tc` \ res' -> - returnNF_Tc (FunTy arg' res') - - go (AppTy fun arg) = go fun `thenNF_Tc` \ fun' -> - go arg `thenNF_Tc` \ arg' -> - returnNF_Tc (mkAppTy fun' arg') - - go (UsageTy u ty) = go u `thenNF_Tc` \ u' -> - go ty `thenNF_Tc` \ ty' -> - returnNF_Tc (mkUTy u' ty') - - -- The two interesting cases! - go (TyVarTy tyvar) = zonkTyVar unbound_var_fn tyvar - - go (ForAllTy tyvar ty) = zonkTcTyVarToTyVar tyvar `thenNF_Tc` \ tyvar' -> - go ty `thenNF_Tc` \ ty' -> - returnNF_Tc (ForAllTy tyvar' ty') - - go_pred (ClassP c tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' -> - returnNF_Tc (ClassP c tys') - go_pred (IParam n ty) = go ty `thenNF_Tc` \ ty' -> - returnNF_Tc (IParam n ty') - -zonkTyVar :: (TcTyVar -> NF_TcM Type) -- What to do for an unbound mutable variable - -> TcTyVar -> NF_TcM TcType -zonkTyVar unbound_var_fn tyvar - | not (isMutTyVar 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 - returnNF_Tc (TyVarTy tyvar) +matchTy :: TyVarSet -- Template tyvars + -> Type -- Template + -> Type -- Proposed instance of template + -> Maybe TyVarSubstEnv -- Matching substitution + + +matchTys :: TyVarSet -- Template tyvars + -> [Type] -- Templates + -> [Type] -- Proposed instance of template + -> Maybe (TyVarSubstEnv, -- Matching substitution + [Type]) -- Left over instance types + +matchTy tmpls ty1 ty2 = match ty1 ty2 tmpls (\ senv -> Just senv) emptySubstEnv + +matchTys tmpls tys1 tys2 = match_list tys1 tys2 tmpls + (\ (senv,tys) -> Just (senv,tys)) + emptySubstEnv +\end{code} + +@match@ is the main function. It takes a flag indicating whether +usage annotations are to be respected. + +\begin{code} +match :: Type -> Type -- Current match pair + -> TyVarSet -- Template vars + -> (TyVarSubstEnv -> Maybe result) -- Continuation + -> TyVarSubstEnv -- Current subst + -> Maybe result + +-- When matching against a type variable, see if the variable +-- has already been bound. If so, check that what it's bound to +-- is the same as ty; if not, bind it and carry on. + +match (TyVarTy v) ty tmpls k senv + | v `elemVarSet` tmpls + = -- v is a template variable + case lookupSubstEnv senv v of + Nothing -> UASSERT( not (isUTy ty) ) + k (extendSubstEnv senv v (DoneTy ty)) + Just (DoneTy ty') | ty' `tcEqType` ty -> k senv -- Succeeds + | otherwise -> Nothing -- Fails | otherwise - = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> - case maybe_ty of - Nothing -> unbound_var_fn tyvar -- Mutable and unbound - Just other_ty -> zonkType unbound_var_fn other_ty -- Bound -\end{code} + = -- v is not a template variable; ty had better match + -- Can't use (==) because types differ + case tcGetTyVar_maybe ty of + Just v' | v == v' -> k senv -- Success + other -> Nothing -- Failure + -- This tcGetTyVar_maybe is *required* because it must strip Notes. + -- I guess the reason the Note-stripping case is *last* rather than first + -- is to preserve type synonyms etc., so I'm not moving it to the + -- top; but this means that (without the deNotetype) a type + -- variable may not match the pattern (TyVarTy v') as one would + -- expect, due to an intervening Note. KSW 2000-06. + +match (FunTy arg1 res1) (FunTy arg2 res2) tmpls k senv + = match arg1 arg2 tmpls (match res1 res2 tmpls k) senv + +match (AppTy fun1 arg1) ty2 tmpls k senv + = case tcSplitAppTy_maybe ty2 of + Just (fun2,arg2) -> match fun1 fun2 tmpls (match arg1 arg2 tmpls k) senv + Nothing -> Nothing -- Fail + +match (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv + | tc1 == tc2 = match_tc_app tys1 tys2 tmpls k senv + +-- Newtypes are opaque; other source types should not happen +match (SourceTy (NType tc1 tys1)) (SourceTy (NType tc2 tys2)) tmpls k senv + | tc1 == tc2 = match_tc_app tys1 tys2 tmpls k senv + +match (UsageTy _ ty1) ty2 tmpls k senv = match ty1 ty2 tmpls k senv +match ty1 (UsageTy _ ty2) tmpls k senv = match ty1 ty2 tmpls k senv + + -- With type synonyms, we have to be careful for the exact + -- same reasons as in the unifier. Please see the + -- considerable commentary there before changing anything + -- here! (WDP 95/05) +match (NoteTy n1 ty1) ty2 tmpls k senv = match ty1 ty2 tmpls k senv +match ty1 (NoteTy n2 ty2) tmpls k senv = match ty1 ty2 tmpls k senv + +-- Catch-all fails +match _ _ _ _ _ = Nothing + +match_tc_app tys1 tys2 tmpls k senv + = match_list tys1 tys2 tmpls k' senv + where + k' (senv', tys2') | null tys2' = k senv' -- Succeed + | otherwise = Nothing -- Fail +match_list [] tys2 tmpls k senv = k (senv, tys2) +match_list (ty1:tys1) [] tmpls k senv = Nothing -- Not enough arg tys => failure +match_list (ty1:tys1) (ty2:tys2) tmpls k senv + = match ty1 ty2 tmpls (match_list tys1 tys2 tmpls k) senv +\end{code} diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs deleted file mode 100644 index b502b16a36..0000000000 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ /dev/null @@ -1,535 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[Unify]{Unifier} - -The unifier is now squarely in the typechecker monad (because of the -updatable substitution). - -\begin{code} -module TcUnify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, - unifyFunTy, unifyListTy, unifyTupleTy, - unifyKind, unifyKinds, unifyOpenTypeKind - ) where - -#include "HsVersions.h" - --- friends: -import TcMonad -import TypeRep ( Type(..), PredType(..) ) -- friend -import Type ( unliftedTypeKind, liftedTypeKind, openTypeKind, - typeCon, openKindCon, hasMoreBoxityInfo, - tyVarsOfType, typeKind, - mkFunTy, splitFunTy_maybe, splitTyConApp_maybe, - splitAppTy_maybe, mkTyConApp, - tidyOpenType, tidyOpenTypes, tidyTyVar - ) -import TyCon ( TyCon, isTupleTyCon, tupleTyConBoxity, tyConArity ) -import Var ( tyVarKind, varName, isSigTyVar ) -import VarSet ( elemVarSet ) -import TcType ( TcType, TcTauType, TcTyVar, TcKind, newBoxityVar, - newTyVarTy, newTyVarTys, tcGetTyVar, tcPutTyVar, zonkTcType - ) -import Name ( isSystemName ) - --- others: -import BasicTypes ( Arity, Boxity, isBoxed ) -import TysWiredIn ( listTyCon, mkListTy, mkTupleTy ) -import Outputable -\end{code} - - -%************************************************************************ -%* * -\subsection{The Kind variants} -%* * -%************************************************************************ - -\begin{code} -unifyKind :: TcKind -- Expected - -> TcKind -- Actual - -> TcM () -unifyKind k1 k2 - = tcAddErrCtxtM (unifyCtxt "kind" k1 k2) $ - uTys k1 k1 k2 k2 - -unifyKinds :: [TcKind] -> [TcKind] -> TcM () -unifyKinds [] [] = returnTc () -unifyKinds (k1:ks1) (k2:ks2) = unifyKind k1 k2 `thenTc_` - unifyKinds ks1 ks2 -unifyKinds _ _ = panic "unifyKinds: length mis-match" -\end{code} - -\begin{code} -unifyOpenTypeKind :: TcKind -> TcM () --- Ensures that the argument kind is of the form (Type bx) --- for some boxity bx - -unifyOpenTypeKind ty@(TyVarTy tyvar) - = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> - case maybe_ty of - Just ty' -> unifyOpenTypeKind ty' - other -> unify_open_kind_help ty - -unifyOpenTypeKind ty - = case splitTyConApp_maybe ty of - Just (tycon, [_]) | tycon == typeCon -> returnTc () - other -> unify_open_kind_help ty - -unify_open_kind_help ty -- Revert to ordinary unification - = newBoxityVar `thenNF_Tc` \ boxity -> - unifyKind ty (mkTyConApp typeCon [boxity]) -\end{code} - - -%************************************************************************ -%* * -\subsection[Unify-exported]{Exported unification functions} -%* * -%************************************************************************ - -The exported functions are all defined as versions of some -non-exported generic functions. - -Unify two @TauType@s. Dead straightforward. - -\begin{code} -unifyTauTy :: TcTauType -> TcTauType -> TcM () -unifyTauTy ty1 ty2 -- ty1 expected, ty2 inferred - = tcAddErrCtxtM (unifyCtxt "type" ty1 ty2) $ - uTys ty1 ty1 ty2 ty2 -\end{code} - -@unifyTauTyList@ unifies corresponding elements of two lists of -@TauType@s. It uses @uTys@ to do the real work. The lists should be -of equal length. We charge down the list explicitly so that we can -complain if their lengths differ. - -\begin{code} -unifyTauTyLists :: [TcTauType] -> [TcTauType] -> TcM () -unifyTauTyLists [] [] = returnTc () -unifyTauTyLists (ty1:tys1) (ty2:tys2) = uTys ty1 ty1 ty2 ty2 `thenTc_` - unifyTauTyLists tys1 tys2 -unifyTauTyLists ty1s ty2s = panic "Unify.unifyTauTyLists: mismatched type lists!" -\end{code} - -@unifyTauTyList@ takes a single list of @TauType@s and unifies them -all together. It is used, for example, when typechecking explicit -lists, when all the elts should be of the same type. - -\begin{code} -unifyTauTyList :: [TcTauType] -> TcM () -unifyTauTyList [] = returnTc () -unifyTauTyList [ty] = returnTc () -unifyTauTyList (ty1:tys@(ty2:_)) = unifyTauTy ty1 ty2 `thenTc_` - unifyTauTyList tys -\end{code} - -%************************************************************************ -%* * -\subsection[Unify-uTys]{@uTys@: getting down to business} -%* * -%************************************************************************ - -@uTys@ is the heart of the unifier. Each arg happens twice, because -we want to report errors in terms of synomyms if poss. The first of -the pair is used in error messages only; it is always the same as the -second, except that if the first is a synonym then the second may be a -de-synonym'd version. This way we get better error messages. - -We call the first one \tr{ps_ty1}, \tr{ps_ty2} for ``possible synomym''. - -\begin{code} -uTys :: TcTauType -> TcTauType -- Error reporting ty1 and real ty1 - -- ty1 is the *expected* type - - -> TcTauType -> TcTauType -- Error reporting ty2 and real ty2 - -- ty2 is the *actual* type - -> TcM () - - -- Always expand synonyms (see notes at end) - -- (this also throws away FTVs) -uTys ps_ty1 (NoteTy _ ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2 -uTys ps_ty1 ty1 ps_ty2 (NoteTy _ ty2) = uTys ps_ty1 ty1 ps_ty2 ty2 - - -- Ignore usage annotations inside typechecker -uTys ps_ty1 (UsageTy _ ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2 -uTys ps_ty1 ty1 ps_ty2 (UsageTy _ ty2) = uTys ps_ty1 ty1 ps_ty2 ty2 - - -- Variables; go for uVar -uTys ps_ty1 (TyVarTy tyvar1) ps_ty2 ty2 = uVar False tyvar1 ps_ty2 ty2 -uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar True tyvar2 ps_ty1 ty1 - -- "True" means args swapped - - -- Predicates -uTys _ (PredTy (IParam n1 t1)) _ (PredTy (IParam n2 t2)) - | n1 == n2 = uTys t1 t1 t2 t2 -uTys _ (PredTy (ClassP c1 tys1)) _ (PredTy (ClassP c2 tys2)) - | c1 == c2 = unifyTauTyLists tys1 tys2 - - -- Functions; just check the two parts -uTys _ (FunTy fun1 arg1) _ (FunTy fun2 arg2) - = uTys fun1 fun1 fun2 fun2 `thenTc_` uTys arg1 arg1 arg2 arg2 - - -- Type constructors must match -uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2) - | con1 == con2 && length tys1 == length 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 - = unifyOpenTypeKind 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, - -- so if one type is an App the other one jolly well better be too -uTys ps_ty1 (AppTy s1 t1) ps_ty2 ty2 - = case splitAppTy_maybe ty2 of - Just (s2,t2) -> uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2 - Nothing -> unifyMisMatch ps_ty1 ps_ty2 - - -- Now the same, but the other way round - -- Don't swap the types, because the error messages get worse -uTys ps_ty1 ty1 ps_ty2 (AppTy s2 t2) - = case splitAppTy_maybe ty1 of - Just (s1,t1) -> uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2 - Nothing -> unifyMisMatch ps_ty1 ps_ty2 - - -- Not expecting for-alls in unification - -- ... but the error message from the unifyMisMatch more informative - -- than a panic message! - - -- Anything else fails -uTys ps_ty1 ty1 ps_ty2 ty2 = unifyMisMatch ps_ty1 ps_ty2 -\end{code} - -Notes on synonyms -~~~~~~~~~~~~~~~~~ -If you are tempted to make a short cut on synonyms, as in this -pseudocode... - -\begin{verbatim} -uTys (SynTy con1 args1 ty1) (SynTy con2 args2 ty2) - = if (con1 == con2) then - -- Good news! Same synonym constructors, so we can shortcut - -- by unifying their arguments and ignoring their expansions. - unifyTauTypeLists args1 args2 - else - -- Never mind. Just expand them and try again - uTys ty1 ty2 -\end{verbatim} - -then THINK AGAIN. Here is the whole story, as detected and reported -by Chris Okasaki \tr{<Chris_Okasaki@loch.mess.cs.cmu.edu>}: -\begin{quotation} -Here's a test program that should detect the problem: - -\begin{verbatim} - type Bogus a = Int - x = (1 :: Bogus Char) :: Bogus Bool -\end{verbatim} - -The problem with [the attempted shortcut code] is that -\begin{verbatim} - con1 == con2 -\end{verbatim} -is not a sufficient condition to be able to use the shortcut! -You also need to know that the type synonym actually USES all -its arguments. For example, consider the following type synonym -which does not use all its arguments. -\begin{verbatim} - type Bogus a = Int -\end{verbatim} - -If you ever tried unifying, say, \tr{Bogus Char} with \tr{Bogus Bool}, -the unifier would blithely try to unify \tr{Char} with \tr{Bool} and -would fail, even though the expanded forms (both \tr{Int}) should -match. - -Similarly, unifying \tr{Bogus Char} with \tr{Bogus t} would -unnecessarily bind \tr{t} to \tr{Char}. - -... You could explicitly test for the problem synonyms and mark them -somehow as needing expansion, perhaps also issuing a warning to the -user. -\end{quotation} - - -%************************************************************************ -%* * -\subsection[Unify-uVar]{@uVar@: unifying with a type variable} -%* * -%************************************************************************ - -@uVar@ is called when at least one of the types being unified is a -variable. It does {\em not} assume that the variable is a fixed point -of the substitution; rather, notice that @uVar@ (defined below) nips -back into @uTys@ if it turns out that the variable is already bound. - -\begin{code} -uVar :: Bool -- False => tyvar is the "expected" - -- True => ty is the "expected" thing - -> TcTyVar - -> TcTauType -> TcTauType -- printing and real versions - -> TcM () - -uVar swapped tv1 ps_ty2 ty2 - = tcGetTyVar tv1 `thenNF_Tc` \ maybe_ty1 -> - 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 - - -- Expand synonyms; ignore FTVs -uUnboundVar swapped tv1 maybe_ty1 ps_ty2 (NoteTy _ ty2) - = uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2 - - - -- The both-type-variable case -uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2) - - -- Same type variable => no-op - | tv1 == tv2 - = returnTc () - - -- Distinct type variables - -- ASSERT maybe_ty1 /= Just - | otherwise - = tcGetTyVar tv2 `thenNF_Tc` \ maybe_ty2 -> - case maybe_ty2 of - Just ty2' -> uUnboundVar swapped tv1 maybe_ty1 ty2' ty2' - - Nothing | update_tv2 - - -> WARN( not (k1 `hasMoreBoxityInfo` k2), (ppr tv1 <+> ppr k1) $$ (ppr tv2 <+> ppr k2) ) - tcPutTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` - returnTc () - | otherwise - - -> WARN( not (k2 `hasMoreBoxityInfo` k1), (ppr tv2 <+> ppr k2) $$ (ppr tv1 <+> ppr k1) ) - (tcPutTyVar tv1 ps_ty2 `thenNF_Tc_` - returnTc ()) - where - k1 = tyVarKind tv1 - k2 = tyVarKind tv2 - update_tv2 = (k2 == openTypeKind) || (k1 /= openTypeKind && nicer_to_update_tv2) - -- Try to get rid of open type variables as soon as poss - - nicer_to_update_tv2 = isSigTyVar tv1 - -- Don't unify a signature type variable if poss - || isSystemName (varName tv2) - -- Try to update sys-y type variables in preference to sig-y ones - - -- Second one isn't a type variable -uUnboundVar swapped tv1 maybe_ty1 ps_ty2 non_var_ty2 - = -- Check that the kinds match - checkKinds swapped tv1 non_var_ty2 `thenTc_` - - -- Check that tv1 isn't a type-signature type variable - checkTcM (not (isSigTyVar tv1)) - (failWithTcM (unifyWithSigErr tv1 ps_ty2)) `thenTc_` - - -- Check that we aren't losing boxity info (shouldn't happen) - warnTc (not (typeKind non_var_ty2 `hasMoreBoxityInfo` tyVarKind tv1)) - ((ppr tv1 <+> ppr (tyVarKind tv1)) $$ - (ppr non_var_ty2 <+> ppr (typeKind non_var_ty2))) `thenNF_Tc_` - - -- Occurs check - -- Basically we want to update tv1 := ps_ty2 - -- because ps_ty2 has type-synonym info, which improves later error messages - -- - -- But consider - -- type A a = () - -- - -- f :: (A a -> a -> ()) -> () - -- f = \ _ -> () - -- - -- x :: () - -- x = f (\ x p -> p x) - -- - -- In the application (p x), we try to match "t" with "A t". If we go - -- ahead and bind t to A t (= ps_ty2), we'll lead the type checker into - -- an infinite loop later. - -- But we should not reject the program, because A t = (). - -- Rather, we should bind t to () (= non_var_ty2). - -- - -- That's why we have this two-state occurs-check - zonkTcType ps_ty2 `thenNF_Tc` \ ps_ty2' -> - if not (tv1 `elemVarSet` tyVarsOfType ps_ty2') then - tcPutTyVar tv1 ps_ty2' `thenNF_Tc_` - returnTc () - else - zonkTcType non_var_ty2 `thenNF_Tc` \ non_var_ty2' -> - if not (tv1 `elemVarSet` tyVarsOfType non_var_ty2') then - -- This branch rarely succeeds, except in strange cases - -- like that in the example above - tcPutTyVar tv1 non_var_ty2' `thenNF_Tc_` - returnTc () - else - failWithTcM (unifyOccurCheck tv1 ps_ty2') - - -checkKinds swapped tv1 ty2 --- We're about to unify a type variable tv1 with a non-tyvar-type ty2. --- We need to check that we don't unify a lifted type variable with an --- unlifted type: e.g. (id 3#) is illegal - | tk1 == liftedTypeKind && tk2 == unliftedTypeKind - = tcAddErrCtxtM (unifyKindCtxt swapped tv1 ty2) $ - unifyMisMatch k1 k2 - | otherwise - = returnTc () - where - (k1,k2) | swapped = (tk2,tk1) - | otherwise = (tk1,tk2) - tk1 = tyVarKind tv1 - tk2 = typeKind ty2 -\end{code} - - -%************************************************************************ -%* * -\subsection[Unify-fun]{@unifyFunTy@} -%* * -%************************************************************************ - -@unifyFunTy@ is used to avoid the fruitless creation of type variables. - -\begin{code} -unifyFunTy :: TcType -- Fail if ty isn't a function type - -> TcM (TcType, TcType) -- otherwise return arg and result types - -unifyFunTy ty@(TyVarTy tyvar) - = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> - case maybe_ty of - Just ty' -> unifyFunTy ty' - other -> unify_fun_ty_help ty - -unifyFunTy ty - = case splitFunTy_maybe ty of - Just arg_and_res -> returnTc arg_and_res - Nothing -> unify_fun_ty_help ty - -unify_fun_ty_help ty -- Special cases failed, so revert to ordinary unification - = newTyVarTy openTypeKind `thenNF_Tc` \ arg -> - newTyVarTy openTypeKind `thenNF_Tc` \ res -> - unifyTauTy ty (mkFunTy arg res) `thenTc_` - returnTc (arg,res) -\end{code} - -\begin{code} -unifyListTy :: TcType -- expected list type - -> TcM TcType -- list element type - -unifyListTy ty@(TyVarTy tyvar) - = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> - case maybe_ty of - Just ty' -> unifyListTy ty' - other -> unify_list_ty_help ty - -unifyListTy ty - = case splitTyConApp_maybe ty of - Just (tycon, [arg_ty]) | tycon == listTyCon -> returnTc arg_ty - other -> unify_list_ty_help ty - -unify_list_ty_help ty -- Revert to ordinary unification - = newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty -> - unifyTauTy ty (mkListTy elt_ty) `thenTc_` - returnTc elt_ty -\end{code} - -\begin{code} -unifyTupleTy :: Boxity -> Arity -> TcType -> TcM [TcType] -unifyTupleTy boxity arity ty@(TyVarTy tyvar) - = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> - case maybe_ty of - Just ty' -> unifyTupleTy boxity arity ty' - other -> unify_tuple_ty_help boxity arity ty - -unifyTupleTy boxity arity ty - = case splitTyConApp_maybe ty of - Just (tycon, arg_tys) - | isTupleTyCon tycon - && tyConArity tycon == arity - && tupleTyConBoxity tycon == boxity - -> returnTc arg_tys - other -> unify_tuple_ty_help boxity arity ty - -unify_tuple_ty_help boxity arity ty - = newTyVarTys arity kind `thenNF_Tc` \ arg_tys -> - unifyTauTy ty (mkTupleTy boxity arity arg_tys) `thenTc_` - returnTc arg_tys - where - kind | isBoxed boxity = liftedTypeKind - | otherwise = openTypeKind -\end{code} - - -%************************************************************************ -%* * -\subsection[Unify-context]{Errors and contexts} -%* * -%************************************************************************ - -Errors -~~~~~~ - -\begin{code} -unifyCtxt s ty1 ty2 tidy_env -- ty1 expected, ty2 inferred - = zonkTcType ty1 `thenNF_Tc` \ ty1' -> - zonkTcType ty2 `thenNF_Tc` \ ty2' -> - returnNF_Tc (err ty1' ty2') - where - err ty1 ty2 = (env1, - nest 4 - (vcat [ - text "Expected" <+> text s <> colon <+> ppr tidy_ty1, - text "Inferred" <+> text s <> colon <+> ppr tidy_ty2 - ])) - where - (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 `thenNF_Tc` \ ty2' -> - returnNF_Tc (err ty2') - 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') = tidyTyVar tidy_env tv1 - (env2, ty2') = tidyOpenType env1 ty2 - pp1 = ppr tv1' - pp2 = ppr ty2' - -unifyMisMatch ty1 ty2 - = zonkTcType ty1 `thenNF_Tc` \ ty1' -> - zonkTcType ty2 `thenNF_Tc` \ ty2' -> - let - (env, [tidy_ty1, tidy_ty2]) = tidyOpenTypes emptyTidyEnv [ty1',ty2'] - msg = hang (ptext SLIT("Couldn't match")) - 4 (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))) - where - (env1, tidy_tyvar) = tidyTyVar emptyTidyEnv tyvar - (env2, tidy_ty) = tidyOpenType env1 ty - -unifyOccurCheck tyvar ty - = (env2, hang (ptext SLIT("Occurs check: cannot construct the infinite type:")) - 4 (sep [ppr tidy_tyvar, char '=', ppr tidy_ty])) - where - (env1, tidy_tyvar) = tidyTyVar emptyTidyEnv tyvar - (env2, tidy_ty) = tidyOpenType env1 ty -\end{code} - diff --git a/ghc/compiler/types/FunDeps.lhs b/ghc/compiler/types/FunDeps.lhs index efbd8d6492..4854e0ca8a 100644 --- a/ghc/compiler/types/FunDeps.lhs +++ b/ghc/compiler/types/FunDeps.lhs @@ -15,9 +15,11 @@ module FunDeps ( import Name ( getSrcLoc ) import Var ( Id, TyVar ) import Class ( Class, FunDep, classTvsFds ) -import Type ( Type, ThetaType, PredType(..), predTyUnique, mkClassPred, tyVarsOfTypes, tyVarsOfPred ) import Subst ( mkSubst, emptyInScopeSet, substTy ) -import Unify ( unifyTyListsX, unifyExtendTysX ) +import TcType ( Type, ThetaType, SourceType(..), PredType, + predTyUnique, mkClassPred, tyVarsOfTypes, tyVarsOfPred, + unifyTyListsX, unifyExtendTysX, tcEqType + ) import VarSet import VarEnv import Outputable @@ -211,7 +213,8 @@ checkGroup :: InstEnv Id -> [(PredType,SDoc)] -> [(Equation, SDoc)] checkGroup inst_env (p1@(IParam _ ty, _) : ips) = -- For implicit parameters, all the types must match - [((emptyVarSet, ty, ty'), mkEqnMsg p1 p2) | p2@(IParam _ ty', _) <- ips, ty /= ty'] + [ ((emptyVarSet, ty, ty'), mkEqnMsg p1 p2) + | p2@(IParam _ ty', _) <- ips, not (ty `tcEqType` ty')] checkGroup inst_env clss@((ClassP cls _, _) : _) = -- For classes life is more complicated diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 537be155d4..b14ad1bba2 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -10,9 +10,9 @@ import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch ) import Type ( Type, isUnLiftedType, applyTys, tyVarsOfType, tyVarsOfTypes, mkTyVarTys, mkForAllTys, mkTyConApp, mkFunTy, isTyVarTy, getTyVar_maybe, - splitSigmaTy, splitTyConApp_maybe, funTyCon + funTyCon ) - +import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy ) import DataCon ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId, isExistentialDataCon ) import TyCon ( TyCon, tyConTyVars, tyConDataConsIfAvailable, @@ -187,7 +187,7 @@ validGenericInstanceType :: Type -> Bool -- f {| a + Int |} validGenericInstanceType inst_ty - = case splitTyConApp_maybe inst_ty of + = case tcSplitTyConApp_maybe inst_ty of Just (tycon, tys) -> all isTyVarTy tys && tycon `elem` genericTyCons Nothing -> False @@ -202,12 +202,12 @@ validGenericMethodType :: Type -> Bool validGenericMethodType ty = valid tau where - (local_tvs, _, tau) = splitSigmaTy ty + (local_tvs, _, tau) = tcSplitSigmaTy ty valid ty | isTyVarTy ty = True | no_tyvars_in_ty = True - | otherwise = case splitTyConApp_maybe ty of + | otherwise = case tcSplitTyConApp_maybe ty of Just (tc,tys) -> valid_tycon tc && all valid tys Nothing -> False where @@ -266,7 +266,7 @@ mkTyConGenInfo tycon [from_name, to_name] (from_fn, to_fn, rep_ty) | isNewTyCon tycon - = ( mkLams tyvars $ Lam x $ Note (Coerce newrep_ty tycon_ty) (Var x), + = ( mkLams tyvars $ Lam x $ Var x, Var (dataConWrapId the_datacon), newrep_ty ) @@ -281,7 +281,7 @@ mkTyConGenInfo tycon [from_name, to_name] ---------------------- -- Newtypes only [the_datacon] = datacons - newrep_ty = applyTys (expectJust "mkGenTyConInfo" (newTyConRep tycon)) tyvar_tys + (_, newrep_ty) = newTyConRep tycon ---------------------- -- Non-newtypes only @@ -463,11 +463,11 @@ mkGenericRhs sel_id tyvar tycon -- Takes out the ForAll and the Class restrictions -- in front of the type of the method. - (_,_,op_ty) = splitSigmaTy (idType sel_id) + (_,_,op_ty) = tcSplitSigmaTy (idType sel_id) -- Do it again! This deals with the case where the method type -- is polymorphic -- see notes above - (local_tvs,_,final_ty) = splitSigmaTy op_ty + (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty -- Now we probably have a tycon in front -- of us, quite probably a FunTyCon. @@ -488,7 +488,7 @@ generate_bimap env@(tv,ep,local_tvs) ty Just tv1 | tv == tv1 -> ep -- The class tyvar | otherwise -> ASSERT( tv1 `elem` local_tvs) -- One of the polymorphic tyvars of the method idEP - Nothing -> bimapApp env (splitTyConApp_maybe ty) + Nothing -> bimapApp env (tcSplitTyConApp_maybe ty) ------------------- bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index a3bb8d4746..d660fc6b72 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -22,14 +22,14 @@ import VarSet import VarEnv import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool ) import Name ( getSrcLoc ) -import Type ( Type, tyConAppTyCon, mkTyVarTy, - splitDFunTy, tyVarsOfTypes +import TcType ( Type, tcTyConAppTyCon, mkTyVarTy, + tcSplitDFunTy, tyVarsOfTypes, + matchTys, unifyTyListsX, allDistinctTyVars ) import PprType ( pprClassPred ) import FunDeps ( checkClsFD ) import TyCon ( TyCon ) import Outputable -import Unify ( matchTys, unifyTyListsX, allDistinctTyVars ) import UniqFM ( UniqFM, lookupWithDefaultUFM, addToUFM, emptyUFM, eltsUFM ) import Id ( idType ) import ErrUtils ( Message ) @@ -52,8 +52,8 @@ simpleDFunClassTyCon :: DFunId -> (Class, TyCon) simpleDFunClassTyCon dfun = (clas, tycon) where - (_,_,clas,[ty]) = splitDFunTy (idType dfun) - tycon = tyConAppTyCon ty + (_,_,clas,[ty]) = tcSplitDFunTy (idType dfun) + tycon = tcTyConAppTyCon ty pprInstEnv :: InstEnv -> SDoc pprInstEnv env @@ -319,7 +319,7 @@ addToInstEnv dflags (inst_env, errs) dfun_id where cls_inst_env = classInstEnv inst_env clas - (ins_tvs, _, clas, ins_tys) = splitDFunTy (idType dfun_id) + (ins_tvs, _, clas, ins_tys) = tcSplitDFunTy (idType dfun_id) bad_fundeps = badFunDeps cls_inst_env clas ins_tv_set ins_tys fundep_err = fundepErr dfun_id (head bad_fundeps) @@ -427,5 +427,5 @@ addInstErr what dfun1 dfun2 where ppr_dfun dfun = ppr (getSrcLoc dfun) <> colon <+> pprClassPred clas tys where - (_,_,clas,tys) = splitDFunTy (idType dfun) + (_,_,clas,tys) = tcSplitDFunTy (idType dfun) \end{code} diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 36ebf46564..6c663034c0 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -19,12 +19,11 @@ module PprType( -- friends: -- (PprType can see all the representations it's trying to print) import TypeRep ( Type(..), TyNote(..), Kind, liftedTypeKind ) -- friend -import Type ( PredType(..), ThetaType, - splitPredTy_maybe, - splitForAllTys, splitSigmaTy, splitRhoTy, - isPredTy, isDictTy, splitTyConApp_maybe, splitFunTy_maybe, - predRepTy, isUTyVar - ) +import Type ( SourceType(..), isUTyVar, eqKind ) +import TcType ( ThetaType, PredType, tcSplitPredTy_maybe, + tcSplitSigmaTy, isPredTy, isDictTy, + tcSplitTyConApp_maybe, tcSplitFunTy_maybe + ) import Var ( TyVar, tyVarKind ) import Class ( Class ) import TyCon ( TyCon, isPrimTyCon, isTupleTyCon, tupleTyConBoxity, @@ -115,51 +114,36 @@ ppr_ty ctxt_prec (TyVarTy tyvar) ppr_ty ctxt_prec ty@(TyConApp tycon tys) -- KIND CASE; it's of the form (Type x) - | tycon `hasKey` typeConKey && n_tys == 1 + | tycon `hasKey` typeConKey, + [ty] <- tys = -- For kinds, print (Type x) as just x if x is a -- type constructor (must be Boxed, Unboxed, AnyBox) -- Otherwise print as (Type x) - case ty1 of + case ty of TyConApp bx [] -> ppr (getOccName bx) -- Always unqualified other -> maybeParen ctxt_prec tYCON_PREC - (sep [ppr tycon, nest 4 tys_w_spaces]) + (ppr tycon <+> ppr_ty tYCON_PREC ty) -- USAGE CASE - | (tycon `hasKey` usOnceTyConKey || tycon `hasKey` usManyTyConKey) && n_tys == 0 + | (tycon `hasKey` usOnceTyConKey || tycon `hasKey` usManyTyConKey), + null tys = -- For usages (! and .), always print bare OccName, without pkg/mod/uniq ppr (getOccName (tyConName tycon)) -- TUPLE CASE (boxed and unboxed) - | isTupleTyCon tycon - && length tys == tyConArity tycon -- no magic if partially applied - = tupleParens (tupleTyConBoxity tycon) tys_w_commas + | isTupleTyCon tycon, + length tys == tyConArity tycon -- No magic if partially applied + = tupleParens (tupleTyConBoxity tycon) + (sep (punctuate comma (map (ppr_ty tOP_PREC) tys))) -- LIST CASE - | tycon `hasKey` listTyConKey && n_tys == 1 - = brackets (ppr_ty tOP_PREC ty1) - - -- DICTIONARY CASE, prints {C a} - -- This means that instance decls come out looking right in interfaces - -- and that in turn means they get "gated" correctly when being slurped in - | maybeToBool maybe_pred - = braces (pprPred pred) - - -- NO-ARGUMENT CASE (=> no parens) - | null tys - = ppr tycon + | tycon `hasKey` listTyConKey, + [ty] <- tys + = brackets (ppr_ty tOP_PREC ty) -- GENERAL CASE | otherwise - = maybeParen ctxt_prec tYCON_PREC (sep [ppr tycon, nest 4 tys_w_spaces]) - - where - n_tys = length tys - (ty1:_) = tys - Just pred = maybe_pred - maybe_pred = splitPredTy_maybe ty -- Checks class and arity - tys_w_commas = sep (punctuate comma (map (ppr_ty tOP_PREC) tys)) - tys_w_spaces = sep (map (ppr_ty tYCON_PREC) tys) - + = ppr_tc_app ctxt_prec tycon tys ppr_ty ctxt_prec ty@(ForAllTy _ _) @@ -170,10 +154,9 @@ ppr_ty ctxt_prec ty@(ForAllTy _ _) ppr_ty tOP_PREC tau ] where - (tyvars, rho) = splitForAllTys ty - (theta, tau) = splitRhoTy rho + (tyvars, theta, tau) = tcSplitSigmaTy ty - pp_tyvars sty = hsep (map pprTyVarBndr some_tyvars) + pp_tyvars sty = sep (map pprTyVarBndr some_tyvars) where some_tyvars | userStyle sty && not opt_PprStyle_RawTypes = filter (not . isUTyVar) tyvars -- hide uvars from user @@ -210,7 +193,14 @@ ppr_ty ctxt_prec (NoteTy (SynNote ty) expansion) ppr_ty ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty ctxt_prec ty -ppr_ty ctxt_prec (PredTy p) = braces (pprPred p) +ppr_ty ctxt_prec (SourceTy (NType tc tys)) + = ppr_tc_app ctxt_prec tc tys + +ppr_ty ctxt_prec (SourceTy pred) = braces (pprPred pred) + +ppr_tc_app ctxt_prec tc [] = ppr tc +ppr_tc_app ctxt_prec tc tys = maybeParen ctxt_prec tYCON_PREC + (sep [ppr tc, nest 4 (sep (map (ppr_ty tYCON_PREC) tys))]) \end{code} @@ -227,7 +217,7 @@ and when in debug mode. pprTyVarBndr :: TyVar -> SDoc pprTyVarBndr tyvar = getPprStyle $ \ sty -> - if (ifaceStyle sty && kind /= liftedTypeKind) || debugStyle sty then + if (ifaceStyle sty && not (kind `eqKind` liftedTypeKind)) || debugStyle sty then hsep [ppr tyvar, dcolon, pprParendKind kind] -- See comments with ppDcolon in PprCore.lhs else @@ -252,20 +242,24 @@ description for profiling. getTyDescription :: Type -> String getTyDescription ty - = case (splitSigmaTy ty) of { (_, _, tau_ty) -> + = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) -> case tau_ty of - TyVarTy _ -> "*" - AppTy fun _ -> getTyDescription fun - FunTy _ res -> '-' : '>' : fun_result res - TyConApp tycon _ -> getOccString tycon + TyVarTy _ -> "*" + AppTy fun _ -> getTyDescription fun + FunTy _ res -> '-' : '>' : fun_result res + TyConApp tycon _ -> getOccString tycon NoteTy (FTVNote _) ty -> getTyDescription ty NoteTy (SynNote ty1) _ -> getTyDescription ty1 - PredTy p -> getTyDescription (predRepTy p) - ForAllTy _ ty -> getTyDescription ty + SourceTy sty -> getSourceTyDescription sty + ForAllTy _ ty -> getTyDescription ty } where fun_result (FunTy _ res) = '>' : fun_result res fun_result other = getTyDescription other + +getSourceTyDescription (ClassP cl tys) = getOccString cl +getSourceTyDescription (NType tc tys) = getOccString tc +getSourceTyDescription (IParam id ty) = getOccString id \end{code} @@ -294,8 +288,8 @@ showTypeCategory ty = if isDictTy ty then '+' else - case splitTyConApp_maybe ty of - Nothing -> if maybeToBool (splitFunTy_maybe ty) + case tcSplitTyConApp_maybe ty of + Nothing -> if maybeToBool (tcSplitFunTy_maybe ty) then '>' else '.' diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 4fc0348773..faa3b3fcfd 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -182,15 +182,17 @@ type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)] data AlgTyConFlavour = DataTyCon -- Data type + | EnumTyCon -- Special sort of enumeration type + | NewTyCon Type -- Newtype, with its *ultimate* representation type -- By 'ultimate' I mean that the rep type is not itself -- a newtype or type synonym. - -- The rep type has explicit for-alls for the tyvars of - -- the TyCon. Thus: + -- The rep type has free type variables the tyConTyVars + -- Thus: -- newtype T a = MkT [(a,Int)] - -- The rep type is forall a. [(a,Int)] + -- The rep type is [(a,Int)] -- -- The rep type isn't entirely simple: -- for a recursive newtype we pick () as the rep type @@ -267,7 +269,7 @@ mkAlgTyCon name kind tyvars theta argvrcs cons ncons sels flavour rec genInfo = gen_info } -mkClassTyCon name kind tyvars argvrcs con clas flavour +mkClassTyCon name kind tyvars argvrcs con clas flavour rec = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -281,7 +283,7 @@ mkClassTyCon name kind tyvars argvrcs con clas flavour noOfDataCons = 1, algTyConClass = Just clas, algTyConFlavour = flavour, - algTyConRec = NonRecursive, + algTyConRec = rec, genInfo = Nothing } @@ -365,18 +367,26 @@ isAlgTyCon (AlgTyCon {}) = True isAlgTyCon (TupleTyCon {}) = True isAlgTyCon other = False --- isDataTyCon returns False for @newtype@ and for unboxed tuples -isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data}) = case new_or_data of - NewTyCon _ -> False - other -> True +-- isDataTyCon returns True for data types that are represented by +-- heap-allocated constructors. +-- These are srcutinised by Core-level @case@ expressions, and they +-- get info tables allocated for them. +-- True for all @data@ types +-- False for newtypes +-- unboxed tuples +isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data, algTyConRec = is_rec}) + = case new_or_data of + NewTyCon _ -> False + other -> True + isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isDataTyCon other = False isNewTyCon (AlgTyCon {algTyConFlavour = NewTyCon _}) = True isNewTyCon other = False -newTyConRep (AlgTyCon {algTyConFlavour = NewTyCon rep}) = Just rep -newTyConRep other = Nothing +newTyConRep :: TyCon -> ([TyVar], Type) +newTyConRep (AlgTyCon {tyConTyVars = tvs, algTyConFlavour = NewTyCon rep}) = (tvs, rep) -- A "product" tycon -- has *one* constructor, diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 2b1a149f94..b782b198e3 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -6,7 +6,7 @@ \begin{code} module Type ( -- re-exports from TypeRep: - Type, + Type, PredType, TauType, ThetaType, Kind, TyVarSubst, superKind, superBoxity, -- KX and BX respectively @@ -30,46 +30,36 @@ module Type ( mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe, - mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, splitFunTysN, + mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, funResultTy, funArgTy, zipFunTys, mkTyConApp, mkTyConTy, tyConAppTyCon, tyConAppArgs, splitTyConApp_maybe, splitTyConApp, - splitAlgTyConApp_maybe, splitAlgTyConApp, mkUTy, splitUTy, splitUTy_maybe, isUTy, uaUTy, unUTy, liftUTy, mkUTyM, isUsageKind, isUsage, isUTyVar, - mkSynTy, deNoteType, + mkSynTy, - repType, splitRepFunTys, splitNewType_maybe, typePrimRep, + repType, splitRepFunTys, typePrimRep, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, - applyTy, applyTys, hoistForAllTys, isForAllTy, + applyTy, applyTys, isForAllTy, - -- Predicates and the like - PredType(..), getClassPredTys_maybe, getClassPredTys, - isPredTy, isClassPred, isTyVarClassPred, predHasFDs, - mkDictTy, mkPredTy, mkPredTys, splitPredTy_maybe, predTyUnique, - splitDictTy, splitDictTy_maybe, isDictTy, predRepTy, splitDFunTy, - mkClassPred, predMentionsIPs, inheritablePred, isIPPred, mkPredName, + -- Source types + SourceType(..), sourceTypeRep, - -- Tau, Rho, Sigma - TauType, RhoType, SigmaType, ThetaType, - isTauTy, mkRhoTy, splitRhoTy, splitMethodTy, - mkSigmaTy, isSigmaTy, splitSigmaTy, - getDFunTyKey, + -- Newtypes + mkNewTyConApp, -- Lifting and boxity - isUnLiftedType, isUnboxedTupleType, isAlgType, - isDataType, isNewType, isPrimitiveType, + isUnLiftedType, isUnboxedTupleType, isAlgType, -- Free variables tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, - namesOfType, usageAnnOfType, typeKind, addFreeTyVars, - namesOfDFunHead, + usageAnnOfType, typeKind, addFreeTyVars, -- Tidying up for printing tidyType, tidyTypes, @@ -77,6 +67,9 @@ module Type ( tidyTyVar, tidyTyVars, tidyFreeTyVars, tidyTopType, tidyPred, + -- Comparison + eqType, eqKind, eqUsage, + -- Seq seqType, seqTypes @@ -103,11 +96,11 @@ import VarSet import OccName ( mkDictOcc ) import Name ( Name, NamedThing(..), OccName, mkLocalName, tidyOccName ) import NameSet -import Class ( classTyCon, classHasFDs, Class ) -import TyCon ( TyCon, +import Class ( classTyCon ) +import TyCon ( TyCon, isRecursiveTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon, - isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep, - isAlgTyCon, isSynTyCon, tyConArity, + isFunTyCon, isNewTyCon, newTyConRep, + isAlgTyCon, isSynTyCon, tyConArity, tyConTyVars, tyConKind, tyConDataCons, getSynTyConDefn, tyConPrimRep, isPrimTyCon ) @@ -132,13 +125,13 @@ import UniqSet ( sizeUniqSet ) -- Should come via VarSet \begin{code} hasMoreBoxityInfo :: Kind -> Kind -> Bool hasMoreBoxityInfo k1 k2 - | k2 == openTypeKind = True - | otherwise = k1 == k2 + | k2 `eqKind` openTypeKind = True + | otherwise = k1 `eqType` k2 defaultKind :: Kind -> Kind -- Used when generalising: default kind '?' to '*' -defaultKind kind | kind == openTypeKind = liftedTypeKind - | otherwise = kind +defaultKind kind | kind `eqKind` openTypeKind = liftedTypeKind + | otherwise = kind \end{code} @@ -160,25 +153,25 @@ mkTyVarTys :: [TyVar] -> [Type] mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy getTyVar :: String -> Type -> TyVar -getTyVar msg (TyVarTy tv) = tv -getTyVar msg (PredTy p) = getTyVar msg (predRepTy p) -getTyVar msg (NoteTy _ t) = getTyVar msg t +getTyVar msg (TyVarTy tv) = tv +getTyVar msg (SourceTy p) = getTyVar msg (sourceTypeRep p) +getTyVar msg (NoteTy _ t) = getTyVar msg t getTyVar msg ty@(UsageTy _ _) = pprPanic "getTyVar: UTy:" (text msg $$ pprType ty) -getTyVar msg other = panic ("getTyVar: " ++ msg) +getTyVar msg other = panic ("getTyVar: " ++ msg) getTyVar_maybe :: Type -> Maybe TyVar -getTyVar_maybe (TyVarTy tv) = Just tv -getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t -getTyVar_maybe (PredTy p) = getTyVar_maybe (predRepTy p) +getTyVar_maybe (TyVarTy tv) = Just tv +getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t +getTyVar_maybe (SourceTy p) = getTyVar_maybe (sourceTypeRep p) getTyVar_maybe ty@(UsageTy _ _) = pprPanic "getTyVar_maybe: UTy:" (pprType ty) -getTyVar_maybe other = Nothing +getTyVar_maybe other = Nothing isTyVarTy :: Type -> Bool -isTyVarTy (TyVarTy tv) = True -isTyVarTy (NoteTy _ ty) = isTyVarTy ty -isTyVarTy (PredTy p) = isTyVarTy (predRepTy p) +isTyVarTy (TyVarTy tv) = True +isTyVarTy (NoteTy _ ty) = isTyVarTy ty +isTyVarTy (SourceTy p) = isTyVarTy (sourceTypeRep p) isTyVarTy ty@(UsageTy _ _) = pprPanic "isTyVarTy: UTy:" (pprType ty) -isTyVarTy other = False +isTyVarTy other = False \end{code} @@ -191,7 +184,7 @@ invariant: use it. \begin{code} mkAppTy orig_ty1 orig_ty2 - = ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind * + = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind * UASSERT2( not (isUTy orig_ty2), pprType orig_ty1 <+> pprType orig_ty2 ) -- argument must be unannotated mk_app orig_ty1 @@ -209,7 +202,7 @@ mkAppTys orig_ty1 [] = orig_ty1 -- returns to (Ratio Integer), which has needlessly lost -- the Rational part. mkAppTys orig_ty1 orig_tys2 - = ASSERT( not (isPredTy orig_ty1) ) -- Predicates are of kind * + = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind * UASSERT2( not (any isUTy orig_tys2), pprType orig_ty1 <+> fsep (map pprType orig_tys2) ) -- arguments must be unannotated mk_app orig_ty1 @@ -223,7 +216,7 @@ splitAppTy_maybe :: Type -> Maybe (Type, Type) splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [unUTy ty1], unUTy ty2) splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty -splitAppTy_maybe (PredTy p) = splitAppTy_maybe (predRepTy p) +splitAppTy_maybe (SourceTy p) = splitAppTy_maybe (sourceTypeRep p) splitAppTy_maybe (TyConApp tc []) = Nothing splitAppTy_maybe (TyConApp tc tys) = split tys [] where @@ -243,7 +236,7 @@ splitAppTys ty = split ty ty [] where split orig_ty (AppTy ty arg) args = split ty ty (arg:args) split orig_ty (NoteTy _ ty) args = split orig_ty ty args - split orig_ty (PredTy p) args = split orig_ty (predRepTy p) args + split orig_ty (SourceTy p) args = split orig_ty (sourceTypeRep p) args split orig_ty (FunTy ty1 ty2) args = ASSERT( null args ) (TyConApp funTyCon [], [unUTy ty1,unUTy ty2]) split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args) @@ -268,13 +261,13 @@ mkFunTys tys ty = UASSERT2( all isUTy (ty:tys), fsep (map pprType (tys++[ty])) ) splitFunTy :: Type -> (Type, Type) splitFunTy (FunTy arg res) = (arg, res) splitFunTy (NoteTy _ ty) = splitFunTy ty -splitFunTy (PredTy p) = splitFunTy (predRepTy p) +splitFunTy (SourceTy p) = splitFunTy (sourceTypeRep p) splitFunTy ty@(UsageTy _ _) = pprPanic "splitFunTy: UTy:" (pprType ty) splitFunTy_maybe :: Type -> Maybe (Type, Type) splitFunTy_maybe (FunTy arg res) = Just (arg, res) splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty -splitFunTy_maybe (PredTy p) = splitFunTy_maybe (predRepTy p) +splitFunTy_maybe (SourceTy p) = splitFunTy_maybe (sourceTypeRep p) splitFunTy_maybe ty@(UsageTy _ _) = pprPanic "splitFunTy_maybe: UTy:" (pprType ty) splitFunTy_maybe other = Nothing @@ -283,41 +276,31 @@ splitFunTys ty = split [] ty ty where split args orig_ty (FunTy arg res) = split (arg:args) res res split args orig_ty (NoteTy _ ty) = split args orig_ty ty - split args orig_ty (PredTy p) = split args orig_ty (predRepTy p) + split args orig_ty (SourceTy p) = split args orig_ty (sourceTypeRep p) split args orig_ty (UsageTy _ _) = pprPanic "splitFunTys: UTy:" (pprType orig_ty) split args orig_ty ty = (reverse args, orig_ty) -splitFunTysN :: String -> Int -> Type -> ([Type], Type) -splitFunTysN msg orig_n orig_ty = split orig_n [] orig_ty orig_ty - where - split 0 args syn_ty ty = (reverse args, syn_ty) - split n args syn_ty (FunTy arg res) = split (n-1) (arg:args) res res - split n args syn_ty (NoteTy _ ty) = split n args syn_ty ty - split n args syn_ty (PredTy p) = split n args syn_ty (predRepTy p) - split n args syn_ty (UsageTy _ _) = pprPanic "splitFunTysN: UTy:" (pprType orig_ty) - split n args syn_ty ty = pprPanic ("splitFunTysN: " ++ msg) (int orig_n <+> pprType orig_ty) - zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type) zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty where split acc [] nty ty = (reverse acc, nty) split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res split acc xs nty (NoteTy _ ty) = split acc xs nty ty - split acc xs nty (PredTy p) = split acc xs nty (predRepTy p) + split acc xs nty (SourceTy p) = split acc xs nty (sourceTypeRep p) split acc xs nty (UsageTy _ _) = pprPanic "zipFunTys: UTy:" (ppr orig_xs <+> pprType orig_ty) split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty) funResultTy :: Type -> Type funResultTy (FunTy arg res) = res funResultTy (NoteTy _ ty) = funResultTy ty -funResultTy (PredTy p) = funResultTy (predRepTy p) +funResultTy (SourceTy p) = funResultTy (sourceTypeRep p) funResultTy (UsageTy _ ty) = funResultTy ty funResultTy ty = pprPanic "funResultTy" (pprType ty) funArgTy :: Type -> Type funArgTy (FunTy arg res) = arg funArgTy (NoteTy _ ty) = funArgTy ty -funArgTy (PredTy p) = funArgTy (predRepTy p) +funArgTy (SourceTy p) = funArgTy (sourceTypeRep p) funArgTy (UsageTy _ ty) = funArgTy ty funArgTy ty = pprPanic "funArgTy" (pprType ty) \end{code} @@ -326,13 +309,19 @@ funArgTy ty = pprPanic "funArgTy" (pprType ty) --------------------------------------------------------------------- TyConApp ~~~~~~~~ +@mkTyConApp@ is a key function, because it builds a TyConApp, FunTy or SourceTy, +as apppropriate. \begin{code} mkTyConApp :: TyCon -> [Type] -> Type mkTyConApp tycon tys - | isFunTyCon tycon && length tys == 2 - = case tys of - (ty1:ty2:_) -> FunTy (mkUTyM ty1) (mkUTyM ty2) + | isFunTyCon tycon, [ty1,ty2] <- tys + = FunTy (mkUTyM ty1) (mkUTyM ty2) + + | isNewTyCon tycon, -- A saturated newtype application; + not (isRecursiveTyCon tycon), -- Not recursive (we don't use SourceTypes for them) + length tys == tyConArity tycon -- use the SourceType form + = SourceTy (NType tycon tys) | otherwise = ASSERT(not (isSynTyCon tycon)) @@ -348,14 +337,10 @@ mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) ) -- including functions are returned as Just .. tyConAppTyCon :: Type -> TyCon -tyConAppTyCon ty = case splitTyConApp_maybe ty of - Just (tc,_) -> tc - Nothing -> pprPanic "tyConAppTyCon" (pprType ty) +tyConAppTyCon ty = fst (splitTyConApp ty) tyConAppArgs :: Type -> [Type] -tyConAppArgs ty = case splitTyConApp_maybe ty of - Just (_,args) -> args - Nothing -> pprPanic "tyConAppArgs" (pprType ty) +tyConAppArgs ty = snd (splitTyConApp ty) splitTyConApp :: Type -> (TyCon, [Type]) splitTyConApp ty = case splitTyConApp_maybe ty of @@ -366,34 +351,9 @@ splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [unUTy arg,unUTy res]) splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty -splitTyConApp_maybe (PredTy p) = splitTyConApp_maybe (predRepTy p) +splitTyConApp_maybe (SourceTy p) = splitTyConApp_maybe (sourceTypeRep p) splitTyConApp_maybe (UsageTy _ ty) = splitTyConApp_maybe ty splitTyConApp_maybe other = Nothing - --- splitAlgTyConApp_maybe looks for --- *saturated* applications of *algebraic* data types --- "Algebraic" => newtype, data type, or dictionary (not function types) --- We return the constructors too, so there had better be some. - -splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon]) -splitAlgTyConApp_maybe (TyConApp tc tys) - | isAlgTyCon tc && - tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc) -splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty -splitAlgTyConApp_maybe (PredTy p) = splitAlgTyConApp_maybe (predRepTy p) -splitAlgTyConApp_maybe (UsageTy _ ty)= splitAlgTyConApp_maybe ty -splitAlgTyConApp_maybe other = Nothing - -splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon]) - -- Here the "algebraic" property is an *assertion* -splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys ) - (tc, tys, tyConDataCons tc) -splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty -splitAlgTyConApp (PredTy p) = splitAlgTyConApp (predRepTy p) -splitAlgTyConApp (UsageTy _ ty) = splitAlgTyConApp ty -#ifdef DEBUG -splitAlgTyConApp ty = pprPanic "splitAlgTyConApp" (pprType ty) -#endif \end{code} @@ -409,21 +369,6 @@ mkSynTy syn_tycon tys (substTy (mkTyVarSubst tyvars tys) body) where (tyvars, body) = getSynTyConDefn syn_tycon - -deNoteType :: Type -> Type - -- Remove synonyms, but not Preds -deNoteType ty@(TyVarTy tyvar) = ty -deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys) -deNoteType (PredTy p) = PredTy (deNotePred p) -deNoteType (NoteTy _ ty) = deNoteType ty -deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg) -deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg) -deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty) -deNoteType (UsageTy u ty) = UsageTy u (deNoteType ty) - -deNotePred :: PredType -> PredType -deNotePred (ClassP c tys) = ClassP c (map deNoteType tys) -deNotePred (IParam n ty) = IParam n (deNoteType ty) \end{code} Notes on type synonyms @@ -446,22 +391,18 @@ interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. repType looks through (a) for-alls, and - (b) newtypes - (c) synonyms - (d) predicates - (e) usage annotations -It's useful in the back end where we're not -interested in newtypes anymore. + (b) synonyms + (c) predicates + (d) usage annotations +It's useful in the back end. \begin{code} repType :: Type -> Type repType (ForAllTy _ ty) = repType ty repType (NoteTy _ ty) = repType ty -repType (PredTy p) = repType (predRepTy p) +repType (SourceTy p) = repType (sourceTypeRep p) repType (UsageTy _ ty) = repType ty -repType ty = case splitNewType_maybe ty of - Just ty' -> repType ty' -- Still re-apply repType in case of for-all - Nothing -> ty +repType ty = ty splitRepFunTys :: Type -> ([Type], Type) -- Like splitFunTys, but looks through newtypes and for-alls @@ -476,20 +417,6 @@ typePrimRep ty = case repType ty of FunTy _ _ -> PtrRep AppTy _ _ -> PtrRep -- ?? TyVarTy _ -> PtrRep - -splitNewType_maybe :: Type -> Maybe Type --- Find the representation of a newtype, if it is one --- Looks through multiple levels of newtype, but does not look through for-alls -splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty -splitNewType_maybe (PredTy p) = splitNewType_maybe (predRepTy p) -splitNewType_maybe (UsageTy _ ty) = splitNewType_maybe ty -splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of - Just rep_ty -> ASSERT( length tys == tyConArity tc ) - -- The assert should hold because repType should - -- only be applied to *types* (of kind *) - Just (applyTys rep_ty tys) - Nothing -> Nothing -splitNewType_maybe other = Nothing \end{code} @@ -522,7 +449,7 @@ splitForAllTy_maybe :: Type -> Maybe (TyVar, Type) splitForAllTy_maybe ty = splitFAT_m ty where splitFAT_m (NoteTy _ ty) = splitFAT_m ty - splitFAT_m (PredTy p) = splitFAT_m (predRepTy p) + splitFAT_m (SourceTy p) = splitFAT_m (sourceTypeRep p) splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty) splitFAT_m (UsageTy _ ty) = splitFAT_m ty splitFAT_m _ = Nothing @@ -532,7 +459,7 @@ splitForAllTys ty = split ty ty [] where split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs - split orig_ty (PredTy p) tvs = split orig_ty (predRepTy p) tvs + split orig_ty (SourceTy p) tvs = split orig_ty (sourceTypeRep p) tvs split orig_ty (UsageTy _ ty) tvs = split orig_ty ty tvs split orig_ty t tvs = (reverse tvs, orig_ty) \end{code} @@ -543,7 +470,7 @@ Applying a for-all to its arguments. Lift usage annotation as required. \begin{code} applyTy :: Type -> Type -> Type -applyTy (PredTy p) arg = applyTy (predRepTy p) arg +applyTy (SourceTy p) arg = applyTy (sourceTypeRep p) arg applyTy (NoteTy _ fun) arg = applyTy fun arg applyTy (ForAllTy tv ty) arg = UASSERT2( not (isUTy arg), ptext SLIT("applyTy") @@ -564,7 +491,7 @@ applyTys fun_ty arg_tys split fun_ty [] = (Nothing, [], fun_ty) split (NoteTy _ fun_ty) args = split fun_ty args - split (PredTy p) args = split (predRepTy p) args + split (SourceTy p) args = split (sourceTypeRep p) args split (ForAllTy tv fun_ty) (arg:args) = case split fun_ty args of (mu, tvs, ty) -> (mu, tv:tvs, ty) split (UsageTy u ty) args = case split ty args of @@ -574,23 +501,6 @@ applyTys fun_ty arg_tys split other_ty args = panic "applyTys" \end{code} -\begin{code} -hoistForAllTys :: Type -> Type - -- Move all the foralls to the top - -- e.g. T -> forall a. a ==> forall a. T -> a - -- Careful: LOSES USAGE ANNOTATIONS! -hoistForAllTys ty - = case hoist ty of { (tvs, body) -> mkForAllTys tvs body } - where - hoist :: Type -> ([TyVar], Type) - hoist ty = case splitFunTys ty of { (args, res) -> - case splitForAllTys res of { - ([], body) -> ([], ty) ; - (tvs1, body1) -> case hoist body1 of { (tvs2,body2) -> - (tvs1 ++ tvs2, mkFunTys args body2) - }}} -\end{code} - --------------------------------------------------------------------- UsageTy @@ -601,7 +511,8 @@ Constructing and taking apart usage types. \begin{code} mkUTy :: Type -> Type -> Type mkUTy u ty - = ASSERT2( typeKind u == usageTypeKind, ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty ) + = ASSERT2( typeKind u `eqKind` usageTypeKind, + ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty ) UASSERT2( not (isUTy ty), ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty ) -- if u == usMany then ty else : ToDo? KSW 2000-10 #ifdef DO_USAGES @@ -657,8 +568,8 @@ mkUTyM ty = mkUTy usMany ty \begin{code} isUsageKind :: Kind -> Bool isUsageKind k - = ASSERT( typeKind k == superKind ) - k == usageTypeKind + = ASSERT( typeKind k `eqKind` superKind ) + k `eqKind` usageTypeKind isUsage :: Type -> Bool isUsage ty @@ -672,215 +583,36 @@ isUTyVar v %************************************************************************ %* * -\subsection{Predicates} +\subsection{Source types} %* * %************************************************************************ -"Dictionary" types are just ordinary data types, but you can -tell from the type constructor whether it's a dictionary or not. +A "source type" is a type that is a separate type as far as the type checker is +concerned, but which has low-level representation as far as the back end is concerned. -\begin{code} -mkClassPred clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) ) - ClassP clas tys - -isClassPred (ClassP clas tys) = True -isClassPred other = False - -isIPPred (IParam _ _) = True -isIPPred other = False - -isTyVarClassPred (ClassP clas tys) = all isTyVarTy tys -isTyVarClassPred other = False - -getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) -getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys) -getClassPredTys_maybe _ = Nothing - -getClassPredTys :: PredType -> (Class, [Type]) -getClassPredTys (ClassP clas tys) = (clas, tys) - -inheritablePred :: PredType -> Bool --- Can be inherited by a context. For example, consider --- f x = let g y = (?v, y+x) --- in (g 3 with ?v = 8, --- g 4 with ?v = 9) --- The point is that g's type must be quantifed over ?v: --- g :: (?v :: a) => a -> a --- but it doesn't need to be quantified over the Num a dictionary --- which can be free in g's rhs, and shared by both calls to g -inheritablePred (ClassP _ _) = True -inheritablePred other = False - -predMentionsIPs :: PredType -> NameSet -> Bool -predMentionsIPs (IParam n _) ns = n `elemNameSet` ns -predMentionsIPs other ns = False - -predHasFDs :: PredType -> Bool --- True if the predicate has functional depenencies; --- I.e. should participate in improvement -predHasFDs (IParam _ _) = True -predHasFDs (ClassP cls _) = classHasFDs cls - -mkDictTy :: Class -> [Type] -> Type -mkDictTy clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) ) - mkPredTy (ClassP clas tys) - -mkPredTy :: PredType -> Type -mkPredTy pred = PredTy pred - -mkPredTys :: ThetaType -> [Type] -mkPredTys preds = map PredTy preds - -predTyUnique :: PredType -> Unique -predTyUnique (IParam n _) = getUnique n -predTyUnique (ClassP clas tys) = getUnique clas - -predRepTy :: PredType -> Type --- Convert a predicate to its "representation type"; --- the type of evidence for that predicate, which is actually passed at runtime -predRepTy (ClassP clas tys) = TyConApp (classTyCon clas) tys -predRepTy (IParam n ty) = ty - -isPredTy :: Type -> Bool -isPredTy (NoteTy _ ty) = isPredTy ty -isPredTy (PredTy _) = True -isPredTy (UsageTy _ ty)= isPredTy ty -isPredTy _ = False - -isDictTy :: Type -> Bool -isDictTy (NoteTy _ ty) = isDictTy ty -isDictTy (PredTy (ClassP _ _)) = True -isDictTy (UsageTy _ ty) = isDictTy ty -isDictTy other = False - -splitPredTy_maybe :: Type -> Maybe PredType -splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty -splitPredTy_maybe (PredTy p) = Just p -splitPredTy_maybe (UsageTy _ ty)= splitPredTy_maybe ty -splitPredTy_maybe other = Nothing - -splitDictTy :: Type -> (Class, [Type]) -splitDictTy (NoteTy _ ty) = splitDictTy ty -splitDictTy (PredTy (ClassP clas tys)) = (clas, tys) - -splitDictTy_maybe :: Type -> Maybe (Class, [Type]) -splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty -splitDictTy_maybe (PredTy (ClassP clas tys)) = Just (clas, tys) -splitDictTy_maybe other = Nothing - -splitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type]) --- Split the type of a dictionary function -splitDFunTy ty - = case splitSigmaTy ty of { (tvs, theta, tau) -> - case splitDictTy tau of { (clas, tys) -> - (tvs, theta, clas, tys) }} - -namesOfDFunHead :: Type -> NameSet --- Find the free type constructors and classes --- of the head of the dfun instance type --- The 'dfun_head_type' is because of --- instance Foo a => Baz T where ... --- The decl is an orphan if Baz and T are both not locally defined, --- even if Foo *is* locally defined -namesOfDFunHead dfun_ty = case splitSigmaTy dfun_ty of - (tvs,_,head_ty) -> delListFromNameSet (namesOfType head_ty) - (map getName tvs) - -mkPredName :: Unique -> SrcLoc -> PredType -> Name -mkPredName uniq loc (ClassP cls tys) = mkLocalName uniq (mkDictOcc (getOccName cls)) loc -mkPredName uniq loc (IParam name ty) = name -\end{code} +Source types are always lifted. -%************************************************************************ -%* * -\subsection{Tau, sigma and rho} -%* * -%************************************************************************ - -@isTauTy@ tests for nested for-alls. - -\begin{code} -isTauTy :: Type -> Bool -isTauTy (TyVarTy v) = True -isTauTy (TyConApp _ tys) = all isTauTy tys -isTauTy (AppTy a b) = isTauTy a && isTauTy b -isTauTy (FunTy a b) = isTauTy a && isTauTy b -isTauTy (PredTy p) = isTauTy (predRepTy p) -isTauTy (NoteTy _ ty) = isTauTy ty -isTauTy (UsageTy _ ty) = isTauTy ty -isTauTy other = False -\end{code} - -\begin{code} -mkRhoTy :: [PredType] -> Type -> Type -mkRhoTy theta ty = UASSERT2( not (isUTy ty), pprType ty ) - foldr (\p r -> FunTy (mkUTyM (mkPredTy p)) (mkUTyM r)) ty theta - -splitRhoTy :: Type -> ([PredType], Type) -splitRhoTy ty = split ty ty [] - where - split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of - Just p -> split res res (p:ts) - Nothing -> (reverse ts, orig_ty) - split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts - split orig_ty (UsageTy _ ty) ts = split orig_ty ty ts - split orig_ty ty ts = (reverse ts, orig_ty) -\end{code} - -The type of a method for class C is always of the form: - Forall a1..an. C a1..an => sig_ty -where sig_ty is the type given by the method's signature, and thus in general -is a ForallTy. At the point that splitMethodTy is called, it is expected -that the outer Forall has already been stripped off. splitMethodTy then -returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes or -Usages stripped off. +The key function is sourceTypeRep which gives the representation of a source type: \begin{code} -splitMethodTy :: Type -> (PredType, Type) -splitMethodTy ty = split ty - where - split (FunTy arg res) = case splitPredTy_maybe arg of - Just p -> (p, res) - Nothing -> panic "splitMethodTy" - split (NoteTy _ ty) = split ty - split (UsageTy _ ty) = split ty - split _ = panic "splitMethodTy" -\end{code} - - -isSigmaType returns true of any qualified type. It doesn't *necessarily* have -any foralls. E.g. - f :: (?x::Int) => Int -> Int - -\begin{code} -mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau) - -isSigmaTy :: Type -> Bool -isSigmaTy (ForAllTy tyvar ty) = True -isSigmaTy (FunTy a b) = isPredTy a -isSigmaTy (NoteTy _ ty) = isSigmaTy ty -isSigmaTy (UsageTy _ ty) = isSigmaTy ty -isSigmaTy _ = False - -splitSigmaTy :: Type -> ([TyVar], [PredType], Type) -splitSigmaTy ty = - (tyvars, theta, tau) - where - (tyvars,rho) = splitForAllTys ty - (theta,tau) = splitRhoTy rho -\end{code} - -\begin{code} -getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to - -- construct a dictionary function name -getDFunTyKey (TyVarTy tv) = getOccName tv -getDFunTyKey (TyConApp tc _) = getOccName tc -getDFunTyKey (AppTy fun _) = getDFunTyKey fun -getDFunTyKey (NoteTy _ t) = getDFunTyKey t -getDFunTyKey (FunTy arg _) = getOccName funTyCon -getDFunTyKey (ForAllTy _ t) = getDFunTyKey t -getDFunTyKey (UsageTy _ t) = getDFunTyKey t --- PredTy shouldn't happen +sourceTypeRep :: SourceType -> Type +-- Convert a predicate to its "representation type"; +-- the type of evidence for that predicate, which is actually passed at runtime +sourceTypeRep (IParam n ty) = ty +sourceTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys + -- Note the mkTyConApp; the classTyCon might be a newtype! +sourceTypeRep (NType tc tys) = case newTyConRep tc of + (tvs, rep_ty) -> substTy (mkTyVarSubst tvs tys) rep_ty + -- ToDo: Consider caching this substitution in a NType + +mkNewTyConApp :: TyCon -> [Type] -> SourceType +mkNewTyConApp tc tys = NType tc tys -- Here is where we might cache the substitution + +isSourceTy :: Type -> Bool +isSourceTy (NoteTy _ ty) = isSourceTy ty +isSourceTy (UsageTy _ ty) = isSourceTy ty +isSourceTy (SourceTy sty) = True +isSourceTy _ = False \end{code} @@ -899,7 +631,7 @@ typeKind :: Type -> Kind typeKind (TyVarTy tyvar) = tyVarKind tyvar typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys typeKind (NoteTy _ ty) = typeKind ty -typeKind (PredTy _) = liftedTypeKind -- Predicates are always +typeKind (SourceTy _) = liftedTypeKind -- Predicates are always -- represented by lifted types typeKind (AppTy fun arg) = funResultTy (typeKind fun) @@ -931,7 +663,7 @@ tyVarsOfType (TyVarTy tv) = unitVarSet tv tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty1 -tyVarsOfType (PredTy p) = tyVarsOfPred p +tyVarsOfType (SourceTy sty) = tyVarsOfSourceType sty tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar @@ -941,31 +673,20 @@ tyVarsOfTypes :: [Type] -> TyVarSet tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys tyVarsOfPred :: PredType -> TyVarSet -tyVarsOfPred (ClassP clas tys) = tyVarsOfTypes tys -tyVarsOfPred (IParam n ty) = tyVarsOfType ty +tyVarsOfPred = tyVarsOfSourceType -- Just a subtype + +tyVarsOfSourceType :: SourceType -> TyVarSet +tyVarsOfSourceType (IParam n ty) = tyVarsOfType ty +tyVarsOfSourceType (ClassP clas tys) = tyVarsOfTypes tys +tyVarsOfSourceType (NType tc tys) = tyVarsOfTypes tys tyVarsOfTheta :: ThetaType -> TyVarSet -tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet +tyVarsOfTheta = foldr (unionVarSet . tyVarsOfSourceType) emptyVarSet -- Add a Note with the free tyvars to the top of the type addFreeTyVars :: Type -> Type addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty - --- Find the free names of a type, including the type constructors and classes it mentions -namesOfType :: Type -> NameSet -namesOfType (TyVarTy tv) = unitNameSet (getName tv) -namesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` - namesOfTypes tys -namesOfType (NoteTy (SynNote ty1) ty2) = namesOfType ty1 -namesOfType (NoteTy other_note ty2) = namesOfType ty2 -namesOfType (PredTy p) = namesOfType (predRepTy p) -namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res -namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg -namesOfType (ForAllTy tyvar ty) = namesOfType ty `delFromNameSet` getName tyvar -namesOfType (UsageTy u ty) = namesOfType u `unionNameSets` namesOfType ty - -namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys \end{code} Usage annotations of a type @@ -983,7 +704,7 @@ usageAnnOfType ty goT (TyConApp tc tys) = concatMap goT tys goT (FunTy sty1 sty2) = goS sty1 ++ goS sty2 goT (ForAllTy mv ty) = goT ty - goT (PredTy p) = goT (predRepTy p) + goT (SourceTy p) = goT (sourceTypeRep p) goT ty@(UsageTy _ _) = pprPanic "usageAnnOfType: unexpected usage:" (pprType ty) goT (NoteTy note ty) = goT ty @@ -1045,7 +766,7 @@ tidyType env@(tidy_env, subst) ty go (TyConApp tycon tys) = let args = map go tys in args `seqList` TyConApp tycon args go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty) - go (PredTy p) = PredTy (tidyPred env p) + go (SourceTy sty) = SourceTy (tidySourceType env sty) go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg) go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg) go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty) @@ -1058,9 +779,13 @@ tidyType env@(tidy_env, subst) ty tidyTypes env tys = map (tidyType env) tys -tidyPred :: TidyEnv -> PredType -> PredType -tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys) -tidyPred env (IParam n ty) = IParam n (tidyType env ty) +tidyPred :: TidyEnv -> SourceType -> SourceType +tidyPred = tidySourceType + +tidySourceType :: TidyEnv -> SourceType -> SourceType +tidySourceType env (IParam n ty) = IParam n (tidyType env ty) +tidySourceType env (ClassP clas tys) = ClassP clas (tidyTypes env tys) +tidySourceType env (NType tc tys) = NType tc (tidyTypes env tys) \end{code} @@ -1101,7 +826,8 @@ isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc isUnLiftedType (UsageTy _ ty) = isUnLiftedType ty -isUnLiftedType other = False +isUnLiftedType (SourceTy _) = False -- All source types are lifted +isUnLiftedType other = False isUnboxedTupleType :: Type -> Bool isUnboxedTupleType ty = case splitTyConApp_maybe ty of @@ -1114,28 +840,6 @@ isAlgType ty = case splitTyConApp_maybe ty of Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) isAlgTyCon tc other -> False - --- Should only be applied to *types*; hence the assert -isDataType :: Type -> Bool -isDataType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) - isDataTyCon tc - other -> False - -isNewType :: Type -> Bool -isNewType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) - isNewTyCon tc - other -> False - -isPrimitiveType :: Type -> Bool --- Returns types that are opaque to Haskell. --- Most of these are unlifted, but now that we interact with .NET, we --- may have primtive (foreign-imported) types that are lifted -isPrimitiveType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) - isPrimTyCon tc - other -> False \end{code} @@ -1151,7 +855,7 @@ seqType (TyVarTy tv) = tv `seq` () seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 seqType (NoteTy note t2) = seqNote note `seq` seqType t2 -seqType (PredTy p) = seqPred p +seqType (SourceTy p) = seqPred p seqType (TyConApp tc tys) = tc `seq` seqTypes tys seqType (ForAllTy tv ty) = tv `seq` seqType ty seqType (UsageTy u ty) = seqType u `seq` seqType ty @@ -1164,9 +868,10 @@ seqNote :: TyNote -> () seqNote (SynNote ty) = seqType ty seqNote (FTVNote set) = sizeUniqSet set `seq` () -seqPred :: PredType -> () -seqPred (ClassP c tys) = c `seq` seqTypes tys -seqPred (IParam n ty) = n `seq` seqType ty +seqPred :: SourceType -> () +seqPred (ClassP c tys) = c `seq` seqTypes tys +seqPred (NType tc tys) = tc `seq` seqTypes tys +seqPred (IParam n ty) = n `seq` seqType ty \end{code} @@ -1176,78 +881,37 @@ seqPred (IParam n ty) = n `seq` seqType ty %* * %************************************************************************ +Comparison; don't use instances so that we know where it happens. +Look through newtypes but not usage types. \begin{code} -instance Eq Type where - ty1 == ty2 = case ty1 `compare` ty2 of { EQ -> True; other -> False } - -instance Ord Type where - compare ty1 ty2 = cmpTy emptyVarEnv ty1 ty2 - -cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering - -- The "env" maps type variables in ty1 to type variables in ty2 - -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2) - -- we in effect substitute tv2 for tv1 in t1 before continuing - - -- Get rid of NoteTy -cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2 -cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2 - - -- Get rid of PredTy -cmpTy env (PredTy p1) (PredTy p2) = cmpPred env p1 p2 -cmpTy env (PredTy p1) ty2 = cmpTy env (predRepTy p1) ty2 -cmpTy env ty1 (PredTy p2) = cmpTy env ty1 (predRepTy p2) - - -- Deal with equal constructors -cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of - Just tv1a -> tv1a `compare` tv2 - Nothing -> tv1 `compare` tv2 - -cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2 -cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2 -cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2) -cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2 -cmpTy env (UsageTy u1 t1) (UsageTy u2 t2) = cmpTy env u1 u2 `thenCmp` cmpTy env t1 t2 - - -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < UsageTy -cmpTy env (AppTy _ _) (TyVarTy _) = GT - -cmpTy env (FunTy _ _) (TyVarTy _) = GT -cmpTy env (FunTy _ _) (AppTy _ _) = GT - -cmpTy env (TyConApp _ _) (TyVarTy _) = GT -cmpTy env (TyConApp _ _) (AppTy _ _) = GT -cmpTy env (TyConApp _ _) (FunTy _ _) = GT - -cmpTy env (ForAllTy _ _) (TyVarTy _) = GT -cmpTy env (ForAllTy _ _) (AppTy _ _) = GT -cmpTy env (ForAllTy _ _) (FunTy _ _) = GT -cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT - -cmpTy env (UsageTy _ _) other = GT - -cmpTy env _ _ = LT - - -cmpTys env [] [] = EQ -cmpTys env (t:ts) [] = GT -cmpTys env [] (t:ts) = LT -cmpTys env (t1:t1s) (t2:t2s) = cmpTy env t1 t2 `thenCmp` cmpTys env t1s t2s +eqType t1 t2 = eq_ty emptyVarEnv t1 t2 +eqKind = eqType -- No worries about looking +eqUsage = eqType -- through source types for these two + +-- Look through Notes +eq_ty env (NoteTy _ t1) t2 = eq_ty env t1 t2 +eq_ty env t1 (NoteTy _ t2) = eq_ty env t1 t2 + +-- Look through SourceTy. This is where the looping danger comes from +eq_ty env (SourceTy sty1) t2 = eq_ty env (sourceTypeRep sty1) t2 +eq_ty env t1 (SourceTy sty2) = eq_ty env t1 (sourceTypeRep sty2) + +-- The rest is plain sailing +eq_ty env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of + Just tv1a -> tv1a == tv2 + Nothing -> tv1 == tv2 +eq_ty env (ForAllTy tv1 t1) (ForAllTy tv2 t2) + | tv1 == tv2 = eq_ty env t1 t2 + | otherwise = eq_ty (extendVarEnv env tv1 tv2) t1 t2 +eq_ty env (AppTy s1 t1) (AppTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2) +eq_ty env (FunTy s1 t1) (FunTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2) +eq_ty env (UsageTy _ t1) (UsageTy _ t2) = eq_ty env t1 t2 +eq_ty env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 == tc2) && (eq_tys env tys1 tys2) +eq_ty env t1 t2 = False + +eq_tys env [] [] = True +eq_tys env (t1:tys1) (t2:tys2) = (eq_ty env t1 t2) && (eq_tys env tys2 tys2) +eq_tys env tys1 tys2 = False \end{code} -\begin{code} -instance Eq PredType where - p1 == p2 = case p1 `compare` p2 of { EQ -> True; other -> False } - -instance Ord PredType where - compare p1 p2 = cmpPred emptyVarEnv p1 p2 - -cmpPred :: TyVarEnv TyVar -> PredType -> PredType -> Ordering -cmpPred env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2) - -- Compare types as well as names for implicit parameters - -- This comparison is used exclusively (I think) for the - -- finite map built in TcSimplify -cmpPred env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2) -cmpPred env (IParam _ _) (ClassP _ _) = LT -cmpPred env (ClassP _ _) (IParam _ _) = GT -\end{code} diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index d48bcaca92..a00b86f628 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -5,9 +5,9 @@ \begin{code} module TypeRep ( - Type(..), TyNote(..), PredType(..), -- Representation visible to friends + Type(..), TyNote(..), SourceType(..), -- Representation visible to friends - Kind, ThetaType, RhoType, TauType, SigmaType, -- Synonyms + Kind, TauType, PredType, ThetaType, -- Synonyms TyVarSubst, superKind, superBoxity, -- KX and BX respectively @@ -92,6 +92,36 @@ ByteArray# Yes Yes No No ( a, b ) No Yes Yes Yes [a] No Yes Yes Yes + + + ---------------------- + A note about newtypes + ---------------------- + +Consider + newtype N = MkN Int + +Then we want N to be represented as an Int, and that's what we arrange. +The front end of the compiler [TcType.lhs] treats N as opaque, +the back end treats it as transparent [Type.lhs]. + +There's a bit of a problem with recursive newtypes + newtype P = MkP P + newtype Q = MkQ (Q->Q) + +Here the 'implicit expansion' we get from treating P and Q as transparent +would give rise to infinite types, which in turn makes eqType diverge. +Similarly splitForAllTys and splitFunTys can get into a loop. + +Solution: for recursive newtypes use a coerce, and treat the newtype +and its representation as distinct right through the compiler. That's +what you get if you use recursive newtypes. (They are rare, so who +cares if they are a tiny bit less efficient.) + +The TyCon still says "I'm a newtype", but we do not represent the +newtype application as a SourceType; instead as a TyConApp. + + %************************************************************************ %* * \subsection{The data type} @@ -102,6 +132,7 @@ ByteArray# Yes Yes No No \begin{code} type SuperKind = Type type Kind = Type +type TauType = Type type TyVarSubst = TyVarEnv Type @@ -125,8 +156,8 @@ data Type TyVar Type - | PredTy -- A Haskell predicate - PredType + | SourceTy -- A high level source type + SourceType -- ...can be expanded to a representation type... | UsageTy -- A usage-annotated type Type -- - Annotation of kind $ (i.e., usage annotation) @@ -137,13 +168,11 @@ data Type Type -- The expanded version data TyNote - = SynNote Type -- The unexpanded version of the type synonym; always a TyConApp - | FTVNote TyVarSet -- The free type variables of the noted expression + = FTVNote TyVarSet -- The free type variables of the noted expression -type ThetaType = [PredType] -type RhoType = Type -type TauType = Type -type SigmaType = Type + | SynNote Type -- Used for type synonyms + -- The Type is always a TyConApp, and is the un-expanded form. + -- The type to which the note is attached is the expanded form. \end{code} INVARIANT: UsageTys are optional, but may *only* appear immediately @@ -152,7 +181,19 @@ to be annotated (such as the type of an Id). NoteTys are transparent for the purposes of this rule. ------------------------------------- - Predicates + Source types + +A type of the form + SourceTy sty +represents a value whose type is the Haskell source type sty. +It can be expanded into its representation, but: + + * The type checker must treat it as opaque + * The rest of the compiler treats it as transparent + +There are two main uses + a) Haskell predicates + b) newtypes Consider these examples: f :: (Eq a) => a -> Int @@ -163,8 +204,13 @@ Here the "Eq a" and "?x :: Int -> Int" and "r\l" are all called *predicates* Predicates are represented inside GHC by PredType: \begin{code} -data PredType = ClassP Class [Type] - | IParam Name Type +data SourceType = ClassP Class [Type] -- Class predicate + | IParam Name Type -- Implicit parameter + | NType TyCon [Type] -- A *saturated*, *non-recursive* newtype application + -- [See notes at top about newtypes] + +type PredType = SourceType -- A subtype for predicates +type ThetaType = [PredType] \end{code} (We don't support TREX records yet, but the setup is designed diff --git a/ghc/compiler/types/Unify.lhs b/ghc/compiler/types/Unify.lhs deleted file mode 100644 index b284a6f3a7..0000000000 --- a/ghc/compiler/types/Unify.lhs +++ /dev/null @@ -1,303 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section{Unify} - -This module contains a unifier and a matcher, both of which -use an explicit substitution - -\begin{code} -module Unify ( unifyTysX, unifyTyListsX, unifyExtendTysX, - allDistinctTyVars, - match, matchTy, matchTys, - ) where - -#include "HsVersions.h" - -import TypeRep ( Type(..) ) -- friend -import Type ( typeKind, tyVarsOfType, splitAppTy_maybe, getTyVar_maybe, - splitUTy, isUTy, deNoteType - ) - -import PprType () -- Instances - -- This import isn't strictly necessary, but it makes sure that - -- PprType is below Unify in the hierarchy, which in turn makes - -- fewer modules boot-import PprType - -import Var ( tyVarKind ) -import VarSet -import VarEnv ( TyVarSubstEnv, emptySubstEnv, lookupSubstEnv, extendSubstEnv, - SubstResult(..) - ) - -import Outputable -\end{code} - -%************************************************************************ -%* * -\subsection{Unification with an explicit substitution} -%* * -%************************************************************************ - -(allDistinctTyVars tys tvs) = True - iff -all the types tys are type variables, -distinct from each other and from tvs. - -This is useful when checking that unification hasn't unified signature -type variables. For example, if the type sig is - f :: forall a b. a -> b -> b -we want to check that 'a' and 'b' havn't - (a) been unified with a non-tyvar type - (b) been unified with each other (all distinct) - (c) been unified with a variable free in the environment - -\begin{code} -allDistinctTyVars :: [Type] -> TyVarSet -> Bool - -allDistinctTyVars [] acc - = True -allDistinctTyVars (ty:tys) acc - = case getTyVar_maybe ty of - Nothing -> False -- (a) - Just tv | tv `elemVarSet` acc -> False -- (b) or (c) - | otherwise -> allDistinctTyVars tys (acc `extendVarSet` tv) -\end{code} - -%************************************************************************ -%* * -\subsection{Unification with an explicit substitution} -%* * -%************************************************************************ - -Unify types with an explicit substitution and no monad. -Ignore usage annotations. - -\begin{code} -type MySubst - = (TyVarSet, -- Set of template tyvars - TyVarSubstEnv) -- Not necessarily idempotent - -unifyTysX :: TyVarSet -- Template tyvars - -> Type - -> Type - -> Maybe TyVarSubstEnv -unifyTysX tmpl_tyvars ty1 ty2 - = uTysX ty1 ty2 (\(_,s) -> Just s) (tmpl_tyvars, emptySubstEnv) - -unifyExtendTysX :: TyVarSet -- Template tyvars - -> TyVarSubstEnv -- Substitution to start with - -> Type - -> Type - -> Maybe TyVarSubstEnv -- Extended substitution -unifyExtendTysX tmpl_tyvars subst ty1 ty2 - = uTysX ty1 ty2 (\(_,s) -> Just s) (tmpl_tyvars, subst) - -unifyTyListsX :: TyVarSet -> [Type] -> [Type] - -> Maybe TyVarSubstEnv -unifyTyListsX tmpl_tyvars tys1 tys2 - = uTyListsX tys1 tys2 (\(_,s) -> Just s) (tmpl_tyvars, emptySubstEnv) - - -uTysX :: Type - -> Type - -> (MySubst -> Maybe result) - -> MySubst - -> Maybe result - -uTysX (NoteTy _ ty1) ty2 k subst = uTysX ty1 ty2 k subst -uTysX ty1 (NoteTy _ ty2) k subst = uTysX ty1 ty2 k subst - - -- Variables; go for uVar -uTysX (TyVarTy tyvar1) (TyVarTy tyvar2) k subst - | tyvar1 == tyvar2 - = k subst -uTysX (TyVarTy tyvar1) ty2 k subst@(tmpls,_) - | tyvar1 `elemVarSet` tmpls - = uVarX tyvar1 ty2 k subst -uTysX ty1 (TyVarTy tyvar2) k subst@(tmpls,_) - | tyvar2 `elemVarSet` tmpls - = uVarX tyvar2 ty1 k subst - - -- Functions; just check the two parts -uTysX (FunTy fun1 arg1) (FunTy fun2 arg2) k subst - = uTysX fun1 fun2 (uTysX arg1 arg2 k) subst - - -- Type constructors must match -uTysX (TyConApp con1 tys1) (TyConApp con2 tys2) k subst - | (con1 == con2 && length tys1 == length tys2) - = uTyListsX tys1 tys2 k subst - - -- 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, - -- so if one type is an App the other one jolly well better be too -uTysX (AppTy s1 t1) ty2 k subst - = case splitAppTy_maybe ty2 of - Just (s2, t2) -> uTysX s1 s2 (uTysX t1 t2 k) subst - Nothing -> Nothing -- Fail - -uTysX ty1 (AppTy s2 t2) k subst - = case splitAppTy_maybe ty1 of - Just (s1, t1) -> uTysX s1 s2 (uTysX t1 t2 k) subst - Nothing -> Nothing -- Fail - - -- Not expecting for-alls in unification -#ifdef DEBUG -uTysX (ForAllTy _ _) ty2 k subst = panic "Unify.uTysX subst:ForAllTy (1st arg)" -uTysX ty1 (ForAllTy _ _) k subst = panic "Unify.uTysX subst:ForAllTy (2nd arg)" -#endif - - -- Ignore usages -uTysX (UsageTy _ t1) t2 k subst = uTysX t1 t2 k subst -uTysX t1 (UsageTy _ t2) k subst = uTysX t1 t2 k subst - - -- Anything else fails -uTysX ty1 ty2 k subst = Nothing - - -uTyListsX [] [] k subst = k subst -uTyListsX (ty1:tys1) (ty2:tys2) k subst = uTysX ty1 ty2 (uTyListsX tys1 tys2 k) subst -uTyListsX tys1 tys2 k subst = Nothing -- Fail if the lists are different lengths -\end{code} - -\begin{code} --- Invariant: tv1 is a unifiable variable -uVarX tv1 ty2 k subst@(tmpls, env) - = case lookupSubstEnv env tv1 of - Just (DoneTy ty1) -> -- Already bound - uTysX ty1 ty2 k subst - - Nothing -- Not already bound - | typeKind ty2 == tyVarKind tv1 - && occur_check_ok ty2 - -> -- No kind mismatch nor occur check - UASSERT( not (isUTy ty2) ) - k (tmpls, extendSubstEnv env tv1 (DoneTy ty2)) - - | otherwise -> Nothing -- Fail if kind mis-match or occur check - where - occur_check_ok ty = all occur_check_ok_tv (varSetElems (tyVarsOfType ty)) - occur_check_ok_tv tv | tv1 == tv = False - | otherwise = case lookupSubstEnv env tv of - Nothing -> True - Just (DoneTy ty) -> occur_check_ok ty -\end{code} - - - -%************************************************************************ -%* * -\subsection{Matching on types} -%* * -%************************************************************************ - -Matching is a {\em unidirectional} process, matching a type against a -template (which is just a type with type variables in it). The -matcher assumes that there are no repeated type variables in the -template, so that it simply returns a mapping of type variables to -types. It also fails on nested foralls. - -@matchTys@ matches corresponding elements of a list of templates and -types. It and @matchTy@ both ignore usage annotations, unlike the -main function @match@. - -\begin{code} -matchTy :: TyVarSet -- Template tyvars - -> Type -- Template - -> Type -- Proposed instance of template - -> Maybe TyVarSubstEnv -- Matching substitution - - -matchTys :: TyVarSet -- Template tyvars - -> [Type] -- Templates - -> [Type] -- Proposed instance of template - -> Maybe (TyVarSubstEnv, -- Matching substitution - [Type]) -- Left over instance types - -matchTy tmpls ty1 ty2 = match False ty1 ty2 tmpls (\ senv -> Just senv) emptySubstEnv - -matchTys tmpls tys1 tys2 = match_list False tys1 tys2 tmpls - (\ (senv,tys) -> Just (senv,tys)) - emptySubstEnv -\end{code} - -@match@ is the main function. It takes a flag indicating whether -usage annotations are to be respected. - -\begin{code} -match :: Bool -- Respect usages? - -> Type -> Type -- Current match pair - -> TyVarSet -- Template vars - -> (TyVarSubstEnv -> Maybe result) -- Continuation - -> TyVarSubstEnv -- Current subst - -> Maybe result - --- When matching against a type variable, see if the variable --- has already been bound. If so, check that what it's bound to --- is the same as ty; if not, bind it and carry on. - -match uflag (TyVarTy v) ty tmpls k senv - | v `elemVarSet` tmpls - = -- v is a template variable - case lookupSubstEnv senv v of - Nothing -> UASSERT( not (isUTy ty) ) - k (extendSubstEnv senv v (DoneTy ty)) - Just (DoneTy ty') | ty' == ty -> k senv -- Succeeds - | otherwise -> Nothing -- Fails - - | otherwise - = -- v is not a template variable; ty had better match - -- Can't use (==) because types differ - case deNoteType ty of - TyVarTy v' | v == v' -> k senv -- Success - other -> Nothing -- Failure - -- This deNoteType is *required* and cost me much pain. I guess - -- the reason the Note-stripping case is *last* rather than first - -- is to preserve type synonyms etc., so I'm not moving it to the - -- top; but this means that (without the deNotetype) a type - -- variable may not match the pattern (TyVarTy v') as one would - -- expect, due to an intervening Note. KSW 2000-06. - -match uflag (FunTy arg1 res1) (FunTy arg2 res2) tmpls k senv - = match uflag arg1 arg2 tmpls (match uflag res1 res2 tmpls k) senv - -match uflag (AppTy fun1 arg1) ty2 tmpls k senv - = case splitAppTy_maybe ty2 of - Just (fun2,arg2) -> match uflag fun1 fun2 tmpls (match uflag arg1 arg2 tmpls k) senv - Nothing -> Nothing -- Fail - -match uflag (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv - | tc1 == tc2 - = match_list uflag tys1 tys2 tmpls k' senv - where - k' (senv', tys2') | null tys2' = k senv' -- Succeed - | otherwise = Nothing -- Fail - -match False (UsageTy _ ty1) ty2 tmpls k senv = match False ty1 ty2 tmpls k senv -match False ty1 (UsageTy _ ty2) tmpls k senv = match False ty1 ty2 tmpls k senv - -match True (UsageTy u1 ty1) (UsageTy u2 ty2) tmpls k senv - = match True u1 u2 tmpls (match True ty1 ty2 tmpls k) senv -match True ty1@(UsageTy _ _) ty2 tmpls k senv - = case splitUTy ty2 of { (u,ty2') -> match True ty1 ty2' tmpls k senv } -match True ty1 ty2@(UsageTy _ _) tmpls k senv - = case splitUTy ty1 of { (u,ty1') -> match True ty1' ty2 tmpls k senv } - - -- With type synonyms, we have to be careful for the exact - -- same reasons as in the unifier. Please see the - -- considerable commentary there before changing anything - -- here! (WDP 95/05) -match uflag (NoteTy _ ty1) ty2 tmpls k senv = match uflag ty1 ty2 tmpls k senv -match uflag ty1 (NoteTy _ ty2) tmpls k senv = match uflag ty1 ty2 tmpls k senv - --- Catch-all fails -match _ _ _ _ _ _ = Nothing - -match_list uflag [] tys2 tmpls k senv = k (senv, tys2) -match_list uflag (ty1:tys1) [] tmpls k senv = Nothing -- Not enough arg tys => failure -match_list uflag (ty1:tys1) (ty2:tys2) tmpls k senv - = match uflag ty1 ty2 tmpls (match_list uflag tys1 tys2 tmpls k) senv -\end{code} - - |