tidyInsts, tidyMoreInsts,
- newDicts, newDictAtLoc, newDictsAtLoc, cloneDict,
+ newDictBndr, newDictBndrs, newDictBndrsO,
+ instCall, instStupidTheta,
+ cloneDict,
shortCutFracLit, shortCutIntLit, newIPDict,
newMethod, newMethodFromName, newMethodWithGivenTy,
- tcInstClassOp, tcInstStupidTheta,
+ tcInstClassOp,
tcSyntaxName, isHsVar,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
isTyVarDict, isMethodFor,
zonkInst, zonkInsts,
- instToId, instName,
+ instToId, instToVar, instName,
InstOrigin(..), InstLoc(..), pprInstLoc
) where
#include "HsVersions.h"
import {-# SOURCE #-} TcExpr( tcPolyExpr )
+import {-# SOURCE #-} TcUnify( unifyType )
import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
+ ExprCoFn(..), (<.>), mkCoTyApps, idCoercion,
nlHsLit, nlHsVar )
-import TcHsSyn ( mkHsTyApp, mkHsDictApp, zonkId )
+import TcHsSyn ( zonkId )
import TcRnMonad
import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
import InstEnv ( DFunId, InstEnv, Instance(..), OverlapFlag(..),
tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
pprPred, pprParendType, pprTheta
)
-import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst,
+import Type ( TvSubst, substTy, substTyVar, substTyWith,
notElemTvSubst, extendTvSubstList )
import Unify ( tcMatchTys )
import Module ( modulePackageId )
-import Kind ( isSubKind )
+import {- Kind parts of -} Type ( isSubKind )
+import Coercion ( isEqPred )
import HscTypes ( ExternalPackageState(..), HscEnv(..) )
import CoreFVs ( idFreeTyVars )
-import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName, dataConWrapId )
-import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
+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 ( TyVar, tyVarKind, setIdType )
+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 UniqSupply( uniqsFromSupply )
import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
import DynFlags ( DynFlag(..), DynFlags(..), dopt )
import Maybes ( isJust )
instName inst = idName (instToId inst)
instToId :: Inst -> TcId
-instToId (LitInst nm _ ty _) = mkLocalId nm ty
-instToId (Dict nm pred _) = mkLocalId nm (mkPredTy pred)
-instToId (Method id _ _ _ _) = id
+instToId inst = ASSERT2( isId id, ppr inst ) id
+ where
+ id = instToVar inst
+
+instToVar :: Inst -> Var
+instToVar (LitInst nm _ ty _) = mkLocalId nm ty
+instToVar (Method id _ _ _ _) = id
+instToVar (Dict nm pred _)
+ | isEqPred pred = mkTyVar nm (mkPredTy pred)
+ | otherwise = mkLocalId nm (mkPredTy pred)
instLoc (Dict _ _ loc) = loc
instLoc (Method _ _ _ _ loc) = loc
%* *
%************************************************************************
+-- newDictBndrs makes a dictionary at a binding site
+-- instCall makes a dictionary at an occurrence site
+-- and throws it into the LIE
+
\begin{code}
-newDicts :: InstOrigin
- -> TcThetaType
- -> TcM [Inst]
-newDicts orig theta
- = getInstLoc orig `thenM` \ loc ->
- newDictsAtLoc loc theta
+----------------
+newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
+newDictBndrsO orig theta = do { loc <- getInstLoc orig
+ ; newDictBndrs loc theta }
+
+newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
+newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
+
+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 ExprCoFn
+-- 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)
+
+instCall orig tys theta
+ = do { loc <- getInstLoc orig
+ ; (dicts, dict_app) <- instCallDicts loc theta
+ ; extendLIEs dicts
+ ; return (dict_app <.> mkCoTyApps 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], ExprCoFn)
+-- This is the key place where equality predicates
+-- are unleashed into the world
+instCallDicts loc [] = return ([], idCoercion)
+
+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 <.> CoTyApp 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 <.> CoApp (instToId dict)) }
-cloneDict :: Inst -> TcM Inst
+-------------
+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)
-newDictAtLoc :: InstLoc -> TcPredType -> TcM Inst
-newDictAtLoc inst_loc pred
- = do { uniq <- newUnique
- ; return (mkDict inst_loc uniq pred) }
-
-newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
-newDictsAtLoc inst_loc theta
- = newUniqueSupply `thenM` \ us ->
- returnM (zipWith (mkDict inst_loc) (uniqsFromSupply us) theta)
-
-mkDict inst_loc uniq pred
- = Dict name pred inst_loc
- where
- name = mkPredName uniq (instLocSrcLoc inst_loc) pred
-
-- 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
--- scope, so we make up a new name.
+-- scope, so we make up a new namea.
newIPDict :: InstOrigin -> IPName Name -> Type
-> TcM (IPName Id, Inst)
newIPDict orig ip_name ty
\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 (dataConTyVars data_con) inst_tys
-
newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
newMethodFromName origin ty name
= tcLookupId name `thenM` \ id ->
-- Methods
lookupInst inst@(Method _ id tys theta loc)
- = newDictsAtLoc loc theta `thenM` \ dicts ->
- returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
+ = do { (dicts, dict_app) <- instCallDicts loc theta
+ ; let co_fn = dict_app <.> mkCoTyApps tys
+ ; return (GenInst dicts (L span $ HsCoerce co_fn (HsVar id))) }
where
span = instLocSrcSpan loc
-- any nested for-alls in rho. So the in-scope set is unchanged
dfun_rho = substTy tenv' rho
(theta, _) = tcSplitPhiTy dfun_rho
- ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id))
- (map (substTyVar tenv') tyvars)
+ src_loc = instLocSrcSpan loc
+ dfun = HsVar dfun_id
+ tys = map (substTyVar tenv') tyvars
; if null theta then
- returnM (SimpleInst ty_app)
+ returnM (SimpleInst (L src_loc $ HsCoerce (mkCoTyApps tys) dfun))
else do
- { dicts <- newDictsAtLoc loc theta
- ; let rhs = mkHsDictApp ty_app (map instToId dicts)
- ; returnM (GenInst dicts rhs)
+ { (dicts, dict_app) <- instCallDicts loc theta
+ ; let co_fn = dict_app <.> mkCoTyApps tys
+ ; returnM (GenInst dicts (L src_loc $ HsCoerce co_fn dfun))
}}}}
---------------