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 )
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}
module Demand(
Demand(..),
- wwLazy, wwStrict, wwUnpackData, wwUnpackNew, wwPrim, wwEnum,
+ wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum,
isStrict, isLazy, isPrim,
pprDemands, seqDemand, seqDemands,
#include "HsVersions.h"
-import BasicTypes ( NewOrData(..) )
import Outputable
\end{code}
-- 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
-- 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
\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
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
)
import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId )
import Type ( Type, typePrimRep, addFreeTyVars,
- usOnce, seqType, splitTyConApp_maybe )
+ usOnce, eqUsage, seqType, splitTyConApp_maybe )
import IdInfo
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
import CoreSyn
-import Type ( Type, usOnce )
+import Type ( Type, usOnce, eqUsage )
import PrimOp ( PrimOp )
import NameEnv ( NameEnv, lookupNameEnv )
import Name ( Name )
-- 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
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
-- 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
intPrimTy, wordPrimTy, int64PrimTy, word64PrimTy
)
import PrimRep ( PrimRep(..) )
-import Type ( Type, typePrimRep )
+import TcType ( Type, tcCmpType )
+import Type ( typePrimRep )
import PprType ( pprParendType )
import CStrings ( pprFSInCStyle )
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
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 )
)
import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
mkTemplateLocals, mkTemplateLocalsNum,
- mkTemplateLocal, idCprInfo
+ mkTemplateLocal, idCprInfo, idName
)
import IdInfo ( IdInfo, noCafNoTyGenIdInfo,
exactArity, setUnfoldingInfo, setCprInfo,
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
= 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,
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}
-- 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
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
| 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
\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
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}
`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}
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}
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 )
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,
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`
%************************************************************************
\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}
-- 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}
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
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 )
\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)
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))
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
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. -}
)
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
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.
| 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
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
import HsSyn
import TcHsSyn ( TypecheckedPat )
+import TcType ( tcTyConAppTyCon, tcTyConAppArgs )
import DsHsSyn ( outPatType )
import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet,
CanItFail(..), tidyLitPat, tidyNPat,
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 )
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
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
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
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 )
| 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)
(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}
-- 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,
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,
= (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
(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
import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds,
TypecheckedStmt, TypecheckedMatchContext
)
+import TcType ( tcSplitAppTy, tcSplitFunTys, tcSplitTyConApp_maybe, tcTyConAppArgs,
+ isIntegerTy, tcSplitTyConApp, isUnLiftedType, Type )
import CoreSyn
import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
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 )
= 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 ->
= 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 ->
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
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,
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,
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
= 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,
= 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)
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}
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
-> 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)
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) ->
-- 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
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)
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'
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
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
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}
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
TypecheckedMonoBinds )
import Id ( idType, Id )
-import Type ( Type )
+import TcType ( Type )
import TysWiredIn ( mkListTy, mkTupleTy, unitTy )
import BasicTypes ( Boxity(..) )
\end{code}
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 )
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 )
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(..) )
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
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)
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
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 ->
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
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)
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)
import Id ( Id )
import CoreSyn
-import Type ( mkTyVarTys )
+import TcType ( mkTyVarTys )
import ListSetOps ( equivClassesByUniq )
import Unique ( Uniquable(..) )
\end{code}
import Literal ( mkMachInt, Literal(..) )
import Maybes ( catMaybes )
-import Type ( isUnLiftedType )
+import TcType ( isUnLiftedType )
import Panic ( panic, assertPanic )
\end{code}
= 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)
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
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
-----------------
-- 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;
#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 )
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
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
-- 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
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)
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
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 )
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)
= 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
_ -> 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)
-- 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)
]
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))
, 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.
)
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 )
= 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
'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
------------------
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 )
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
]
| 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))
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 )
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
consDataCon,
doubleDataCon,
doubleTy,
- isDoubleTy,
doubleTyCon,
falseDataCon, falseDataConId,
floatDataCon,
floatTy,
- isFloatTy,
floatTyCon,
intDataCon,
intTy,
intTyCon,
- isIntTy,
integerTy,
integerTyCon,
smallIntegerDataCon,
largeIntegerDataCon,
- isIntegerTy,
listTyCon,
isFFIDynArgumentTy, -- :: Type -> Bool
isFFIDynResultTy, -- :: Type -> Bool
isFFILabelTy, -- :: Type -> Bool
- isAddrTy, -- :: Type -> Bool
- isForeignPtrTy -- :: Type -> Bool
-
) where
#include "HsVersions.h"
import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTys,
mkArrowKinds, liftedTypeKind, unliftedTypeKind,
- splitTyConApp_maybe, repType,
+ splitTyConApp_maybe,
TauType, ThetaType )
import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique )
import PrelNames
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]
addrTyCon = pcNonRecDataTyCon addrTyConName [] [] [addrDataCon]
addrDataCon = pcDataCon addrDataConName [] [] [addrPrimTy] addrTyCon
-
-isAddrTy :: Type -> Bool
-isAddrTy = isTyCon addrTyConKey
\end{code}
\begin{code}
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}
foreignPtrDataCon
= pcDataCon foreignPtrDataConName
alpha_tyvar [] [foreignObjPrimTy] foreignPtrTyCon
-
-isForeignPtrTy :: Type -> Bool
-isForeignPtrTy = isTyCon foreignPtrTyConKey
\end{code}
%************************************************************************
[] [] [intPrimTy] integerTyCon
largeIntegerDataCon = pcDataCon largeIntegerDataConName
[] [] [intPrimTy, byteArrayPrimTy] integerTyCon
-
-
-isIntegerTy :: Type -> Bool
-isIntegerTy = isTyCon integerTyConKey
\end{code}
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}
----------------------------------------------
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}
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 )
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
-- 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)
-- 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
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 )
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
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
| 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}
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,
import ErrUtils ( dumpIfSet_dyn )
import Bag
import List ( partition )
-import Util ( zipEqual, zipWithEqual )
+import Util ( zipEqual, zipWithEqual, cmpList )
import Outputable
-- 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
----------------------------------------------------------
-- 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
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]
-- 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)
callDetailsToList calls = [ (id,tys,dicts)
| (id,fm) <- fmToList calls,
- (tys,dicts) <- fmToList fm
+ (tys, dicts) <- fmToList fm
]
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
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
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
`thenL_`
mapL check (zipEqual "lintAlgAlt:stg" arg_tys args) `thenL_`
returnL ()
+ other ->
+ addErrL (mkAlgAltMsg1 scrut_ty)
) `thenL_`
addInScopeVars args (
lintStgExpr rhs
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
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 )
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
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
-- 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}
-> 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
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(..)
-- 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?
-- 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
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,
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 )
-> [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
-- 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}
| 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
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
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)
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)
-- 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
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 )
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
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.
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}
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
-- 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)
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 ->
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
= 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))
\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
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}
)
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 )
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
-- 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
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
= -- 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) ->
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 )
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
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}
import TcSimplify ( tcSimplifyCheckThetas )
import TysWiredIn ( integerTy, doubleTy )
-import Type ( Type, mkClassPred )
+import TcType ( Type, mkClassPred )
import PrelNames ( numClassName )
import Outputable
import HscTypes ( TyThing(..) )
tyConTheta, maybeTyConSingleCon, isDataTyCon,
isEnumerationTyCon, TyCon
)
-import Type ( ThetaType, mkTyVarTys, mkTyConApp,
+import TcType ( ThetaType, mkTyVarTys, mkTyConApp,
isUnLiftedType, mkClassPred )
import Var ( TyVar )
import PrelNames
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 )
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}
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,
)
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,
-> 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}
= 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
-- 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, _) ->
= 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
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
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 )
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_`
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))
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}
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}
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
)
= 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)
-- 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
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 )
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')
#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' ->
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 )
ModDetails(..), PackageInstEnv, PersistentRenamerState
)
+import Subst ( substTy, substTheta )
import DataCon ( classDataCon )
import Class ( Class, DefMeth(..), classBigSig )
import Var ( idName, idType )
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 )
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}
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
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)
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
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
-- 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_`
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
-- 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
)
(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
-- 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
--- /dev/null
+%
+% (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}
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 )
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)
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 )
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 )
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 $
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.
| 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}
\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,
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,
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 )
---------------------------
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
\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
| 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'
-- 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
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
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
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
-- 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) ;
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
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 )
import Id ( idName, idType, mkLocalId )
import Module ( Module )
import VarSet
-import Type ( tyVarsOfTypes, openTypeKind )
import List ( partition )
import Outputable
\end{code}
-- 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,
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 )
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})
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
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}
+
%************************************************************************
%* *
\section[TcTyDecls]{Typecheck type declarations}
\begin{code}
-module TcTyDecls (
- tcTyDecl1, kcConDetails, mkNewTyConRep
- ) where
+module TcTyDecls ( tcTyDecl1, kcConDetails ) where
#include "HsVersions.h"
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 )
= 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}
-
%************************************************************************
%* *
= -- 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
%
\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}
+++ /dev/null
-%
-% (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}
-
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
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
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,
-- 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
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
(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 )
----------------------
-- Newtypes only
[the_datacon] = datacons
- newrep_ty = applyTys (expectJust "mkGenTyConInfo" (newTyConRep tycon)) tyvar_tys
+ (_, newrep_ty) = newTyConRep tycon
----------------------
-- Non-newtypes only
-- 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.
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
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 )
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
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)
where
ppr_dfun dfun = ppr (getSrcLoc dfun) <> colon <+> pprClassPred clas tys
where
- (_,_,clas,tys) = splitDFunTy (idType dfun)
+ (_,_,clas,tys) = tcSplitDFunTy (idType dfun)
\end{code}
-- 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,
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 _ _)
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
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}
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
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}
= 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 '.'
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
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,
noOfDataCons = 1,
algTyConClass = Just clas,
algTyConFlavour = flavour,
- algTyConRec = NonRecursive,
+ algTyConRec = rec,
genInfo = Nothing
}
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,
\begin{code}
module Type (
-- re-exports from TypeRep:
- Type,
+ Type, PredType, TauType, ThetaType,
Kind, TyVarSubst,
superKind, superBoxity, -- KX and BX respectively
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,
tidyTyVar, tidyTyVars, tidyFreeTyVars,
tidyTopType, tidyPred,
+ -- Comparison
+ eqType, eqKind, eqUsage,
+
-- Seq
seqType, seqTypes
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
)
\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}
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}
\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
-- 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
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
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)
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
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}
---------------------------------------------------------------------
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))
-- 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
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}
(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
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
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}
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
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}
\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")
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
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
\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
\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
%************************************************************************
%* *
-\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}
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)
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
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
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
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)
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}
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
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}
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
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}
%* *
%************************************************************************
+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}
\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
( 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}
\begin{code}
type SuperKind = Type
type Kind = Type
+type TauType = Type
type TyVarSubst = TyVarEnv 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)
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
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
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
+++ /dev/null
-%
-% (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}
-
-
projects / ghc-hetmet.git / commitdiff