%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[Inst]{The @Inst@ type: dictionaries or method instances}
+
+The @Inst@ type: dictionaries or method instances
\begin{code}
module Inst (
tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
isDict, isClassDict, isMethod,
- isLinearInst, linearInstType, isIPDict, isInheritableInst,
+ isIPDict, isInheritableInst,
isTyVarDict, isMethodFor,
zonkInst, zonkInsts,
import {-# SOURCE #-} TcExpr( tcPolyExpr )
import {-# SOURCE #-} TcUnify( unifyType )
-import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
- ExprCoFn(..), (<.>), mkCoTyApps, idCoercion,
- nlHsLit, nlHsVar )
-import TcHsSyn ( zonkId )
+import HsSyn
+import TcHsSyn
import TcRnMonad
-import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
-import InstEnv ( DFunId, InstEnv, Instance(..), OverlapFlag(..),
- lookupInstEnv, extendInstEnv, pprInstances,
- instanceHead, instanceDFunId, setInstanceDFunId )
-import FunDeps ( checkFunDeps )
-import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType,
- tcInstTyVar, tcInstSkolType
- )
-import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcPredType,
- BoxyRhoType,
- PredType(..), SkolemInfo(..), typeKind, mkSigmaTy,
- tcSplitForAllTys, applyTys,
- tcSplitPhiTy, tcSplitDFunHead,
- isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
- mkPredTy, mkTyVarTys,
- tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
- isClassPred, isTyVarClassPred, isLinearPred,
- getClassPredTys, mkPredName,
- isInheritablePred, isIPPred,
- tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
- pprPred, pprParendType, pprTheta
- )
-import Type ( TvSubst, substTy, substTyVar, substTyWith,
- notElemTvSubst, extendTvSubstList )
-import Unify ( tcMatchTys )
-import Module ( modulePackageId )
-import {- Kind parts of -} Type ( isSubKind )
-import Coercion ( isEqPred )
-import HscTypes ( ExternalPackageState(..), HscEnv(..) )
-import CoreFVs ( idFreeTyVars )
-import DataCon ( dataConWrapId )
-import Id ( Id, idName, idType, mkUserLocal, mkLocalId, isId )
-import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
- isInternalName, setNameUnique )
-import NameSet ( addOneToNameSet )
-import Literal ( inIntRange )
-import Var ( Var, TyVar, tyVarKind, setIdType, isId, mkTyVar )
-import VarEnv ( TidyEnv, emptyTidyEnv )
-import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
-import TysWiredIn ( floatDataCon, doubleDataCon )
-import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
-import BasicTypes( IPName(..), mapIPName, ipNameName )
-import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
-import DynFlags ( DynFlag(..), DynFlags(..), dopt )
-import Maybes ( isJust )
+import TcEnv
+import InstEnv
+import FunDeps
+import TcMType
+import TcType
+import Type
+import Unify
+import Module
+import Coercion
+import HscTypes
+import CoreFVs
+import DataCon
+import Id
+import Name
+import NameSet
+import Literal
+import Var ( Var, TyVar )
+import qualified Var
+import VarEnv
+import VarSet
+import TysWiredIn
+import PrelNames
+import BasicTypes
+import SrcLoc
+import DynFlags
+import Maybes
import Outputable
\end{code}
instToVar (LitInst nm _ ty _) = mkLocalId nm ty
instToVar (Method id _ _ _ _) = id
instToVar (Dict nm pred _)
- | isEqPred pred = mkTyVar nm (mkPredTy pred)
+ | isEqPred pred = Var.mkTyVar nm (mkPredTy pred)
| otherwise = mkLocalId nm (mkPredTy pred)
instLoc (Dict _ _ loc) = loc
isMethodFor :: TcIdSet -> Inst -> Bool
isMethodFor ids (Method uniq id tys _ loc) = id `elemVarSet` ids
isMethodFor ids inst = False
-
-isLinearInst :: Inst -> Bool
-isLinearInst (Dict _ pred _) = isLinearPred pred
-isLinearInst other = False
- -- We never build Method Insts that have
- -- linear implicit paramters in them.
- -- Hence no need to look for Methods
- -- See TcExpr.tcId
-
-linearInstType :: Inst -> TcType -- %x::t --> t
-linearInstType (Dict _ (IParam _ ty) _) = ty
\end{code}
; return (Dict name pred inst_loc) }
----------------
-instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM ExprCoFn
+instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
-- Instantiate the constraints of a call
-- (instCall o tys theta)
-- (a) Makes fresh dictionaries as necessary for the constraints (theta)
-- (b) Throws these dictionaries into the LIE
--- (c) Eeturns an ExprCoFn ([.] tys dicts)
+-- (c) Eeturns an HsWrapper ([.] tys dicts)
instCall orig tys theta
= do { loc <- getInstLoc orig
; (dicts, dict_app) <- instCallDicts loc theta
; extendLIEs dicts
- ; return (dict_app <.> mkCoTyApps tys) }
+ ; return (dict_app <.> mkWpTyApps tys) }
----------------
instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
; extendLIEs dicts }
----------------
-instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], ExprCoFn)
+instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], HsWrapper)
-- This is the key place where equality predicates
-- are unleashed into the world
-instCallDicts loc [] = return ([], idCoercion)
+instCallDicts loc [] = return ([], idHsWrapper)
instCallDicts loc (EqPred ty1 ty2 : preds)
= do { unifyType ty1 ty2 -- For now, we insist that they unify right away
-- Later on, when we do associated types,
- -- unifyType might return a coercion
+ -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
; (dicts, co_fn) <- instCallDicts loc preds
- ; return (dicts, co_fn <.> CoTyApp ty1) }
+ ; return (dicts, co_fn <.> WpTyApp ty1) }
-- We use type application to apply the function to the
-- coercion; here ty1 *is* the appropriate identity coercion
; let name = mkPredName uniq (instLocSrcLoc loc) pred
dict = Dict name pred loc
; (dicts, co_fn) <- instCallDicts loc preds
- ; return (dict:dicts, co_fn <.> CoApp (instToId dict)) }
+ ; return (dict:dicts, co_fn <.> WpApp (instToId dict)) }
-------------
cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
checkKind tv ty
= do { let ty1 = ty
-- ty1 <- zonkTcType ty
- ; if typeKind ty1 `isSubKind` tyVarKind tv
+ ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
then return ()
else
pprPanic "checkKind: adding kind constraint"
- (vcat [ppr tv <+> ppr (tyVarKind tv),
+ (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
}
-- do { tv1 <- tcInstTyVar tv
lookupInst inst@(Method _ id tys theta loc)
= do { (dicts, dict_app) <- instCallDicts loc theta
- ; let co_fn = dict_app <.> mkCoTyApps tys
- ; return (GenInst dicts (L span $ HsCoerce co_fn (HsVar id))) }
+ ; let co_fn = dict_app <.> mkWpTyApps tys
+ ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
where
span = instLocSrcSpan loc
dfun = HsVar dfun_id
tys = map (substTyVar tenv') tyvars
; if null theta then
- returnM (SimpleInst (L src_loc $ HsCoerce (mkCoTyApps tys) dfun))
+ returnM (SimpleInst (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
else do
{ (dicts, dict_app) <- instCallDicts loc theta
- ; let co_fn = dict_app <.> mkCoTyApps tys
- ; returnM (GenInst dicts (L src_loc $ HsCoerce co_fn dfun))
+ ; let co_fn = dict_app <.> mkWpTyApps tys
+ ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
}}}}
---------------
projects / ghc-hetmet.git / blobdiff