%
+% (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 (
tidyInsts, tidyMoreInsts,
- newDicts, newDictsAtLoc, cloneDict,
+ newDictBndr, newDictBndrs, newDictBndrsO,
+ instCall, instStupidTheta,
+ cloneDict,
shortCutFracLit, shortCutIntLit, newIPDict,
newMethod, newMethodFromName, newMethodWithGivenTy,
- tcInstClassOp, tcInstStupidTheta,
+ tcInstClassOp,
tcSyntaxName, isHsVar,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
instLoc, getDictClassTys, dictPred,
- mkInstCoFn,
lookupInst, LookupInstResult(..), lookupPred,
tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
isDict, isClassDict, isMethod,
- isLinearInst, linearInstType, isIPDict, isInheritableInst,
+ isIPDict, isInheritableInst,
isTyVarDict, isMethodFor,
zonkInst, zonkInsts,
#include "HsVersions.h"
import {-# SOURCE #-} TcExpr( tcPolyExpr )
+import {-# SOURCE #-} TcUnify( unifyType )
-import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
- ExprCoFn(..), (<.>), 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, substTheta, zipTopTvSubst,
- notElemTvSubst, extendTvSubstList )
-import Unify ( tcMatchTys )
-import Module ( modulePackageId )
-import {- Kind parts of -} Type ( isSubKind )
-import HscTypes ( ExternalPackageState(..), HscEnv(..) )
-import CoreFVs ( idFreeTyVars )
-import DataCon ( DataCon, dataConStupidTheta, dataConName,
- dataConWrapId, dataConUnivTyVars )
-import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
-import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
- isInternalName, setNameUnique )
-import NameSet ( addOneToNameSet )
-import Literal ( inIntRange )
-import Var ( TyVar, tyVarKind, setIdType )
-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 UniqSupply( uniqsFromSupply )
-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}
Selection
~~~~~~~~~
\begin{code}
-mkInstCoFn :: [TcType] -> [Inst] -> ExprCoFn
-mkInstCoFn tys dicts = CoApps (map instToId dicts) <.> CoTyApps tys
-
instName :: Inst -> Name
instName inst = idName (instToId inst)
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}
%* *
%************************************************************************
-\begin{code}
-newDicts :: InstOrigin
- -> TcThetaType
- -> TcM [Inst]
-newDicts orig theta
- = getInstLoc orig `thenM` \ loc ->
- newDictsAtLoc loc theta
+-- newDictBndrs makes a dictionary at a binding site
+-- instCall makes a dictionary at an occurrence site
+-- and throws it into the LIE
-cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
-cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
- returnM (Dict (setNameUnique nm uniq) ty loc)
+\begin{code}
+----------------
+newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
+newDictBndrsO orig theta = do { loc <- getInstLoc orig
+ ; newDictBndrs loc theta }
-newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
-newDictsAtLoc inst_loc theta = mapM (newDictAtLoc inst_loc) theta
+newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
+newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
-{-
-newDictOcc :: InstLoc -> TcPredType -> TcM Inst
-newDictOcc inst_loc (EqPred ty1 ty2)
- = do { unifyType ty1 ty2 -- We insist that they unify right away
- ; return ty1 } -- And return the relexive coercion
--}
-newDictAtLoc inst_loc pred
+newDictBndr :: InstLoc -> TcPredType -> TcM Inst
+newDictBndr inst_loc pred
= do { uniq <- newUnique
; let name = mkPredName uniq (instLocSrcLoc inst_loc) pred
; return (Dict name pred inst_loc) }
+----------------
+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 HsWrapper ([.] tys dicts)
+
+instCall orig tys theta
+ = do { loc <- getInstLoc orig
+ ; (dicts, dict_app) <- instCallDicts loc theta
+ ; extendLIEs dicts
+ ; return (dict_app <.> mkWpTyApps tys) }
+
+----------------
+instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
+-- Similar to instCall, but only emit the constraints in the LIE
+-- Used exclusively for the 'stupid theta' of a data constructor
+instStupidTheta orig theta
+ = do { loc <- getInstLoc orig
+ ; (dicts, _) <- instCallDicts loc theta
+ ; extendLIEs dicts }
+
+----------------
+instCallDicts :: InstLoc -> TcThetaType -> TcM ([Inst], HsWrapper)
+-- This is the key place where equality predicates
+-- are unleashed into the world
+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 :: Type -> Type -> TcM ([Inst], Coercion)
+ ; (dicts, co_fn) <- instCallDicts loc preds
+ ; return (dicts, co_fn <.> WpTyApp ty1) }
+ -- We use type application to apply the function to the
+ -- coercion; here ty1 *is* the appropriate identity coercion
+
+instCallDicts loc (pred : preds)
+ = do { uniq <- newUnique
+ ; let name = mkPredName uniq (instLocSrcLoc loc) pred
+ dict = Dict name pred loc
+ ; (dicts, co_fn) <- instCallDicts loc preds
+ ; return (dict:dicts, co_fn <.> WpApp (instToId dict)) }
+
+-------------
+cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
+cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
+ returnM (Dict (setNameUnique nm uniq) ty loc)
+
-- For vanilla implicit parameters, there is only one in scope
-- at any time, so we used to use the name of the implicit parameter itself
-- But with splittable implicit parameters there may be many in
\begin{code}
-tcInstStupidTheta :: DataCon -> [TcType] -> TcM ()
--- Instantiate the "stupid theta" of the data con, and throw
--- the constraints into the constraint set
-tcInstStupidTheta data_con inst_tys
- | null stupid_theta
- = return ()
- | otherwise
- = do { stupid_dicts <- newDicts (OccurrenceOf (dataConName data_con))
- (substTheta tenv stupid_theta)
- ; extendLIEs stupid_dicts }
- where
- stupid_theta = dataConStupidTheta data_con
- tenv = zipTopTvSubst (dataConUnivTyVars data_con) inst_tys
-
newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
newMethodFromName origin ty name
= tcLookupId name `thenM` \ id ->
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
-- Methods
lookupInst inst@(Method _ id tys theta loc)
- = do { dicts <- newDictsAtLoc loc theta
- ; let co_fn = mkInstCoFn tys dicts
- ; return (GenInst dicts (L span $ HsCoerce co_fn (HsVar id))) }
+ = do { (dicts, dict_app) <- instCallDicts loc theta
+ ; 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 (CoTyApps tys) dfun))
+ returnM (SimpleInst (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
else do
- { dicts <- newDictsAtLoc loc theta
- ; let co_fn = mkInstCoFn tys dicts
- ; returnM (GenInst dicts (L src_loc $ HsCoerce co_fn dfun))
+ { (dicts, dict_app) <- instCallDicts loc theta
+ ; let co_fn = dict_app <.> mkWpTyApps tys
+ ; returnM (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
}}}}
---------------
projects / ghc-hetmet.git / blobdiff