diff options
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} - - |