X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FInst.lhs;h=3bfde1c830bfbbfe3301314689d8fbbd8f058384;hp=98fe3e9872d191370c582d0e3452e34bfaad886d;hb=bf40e268d916947786c56ec38db86190854a2d2c;hpb=c94408e522e5af3b79a5beadc7e6d15cee553ee7 diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 98fe3e9..3bfde1c 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -12,22 +12,23 @@ 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, @@ -39,9 +40,11 @@ module Inst ( #include "HsVersions.h" import {-# SOURCE #-} TcExpr( tcPolyExpr ) +import {-# SOURCE #-} TcUnify( unifyType ) import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp, - ExprCoFn(..), (<.>), nlHsLit, nlHsVar ) + HsWrapper(..), (<.>), mkWpTyApps, idHsWrapper, + nlHsLit, nlHsVar ) import TcHsSyn ( zonkId ) import TcRnMonad import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy ) @@ -60,13 +63,13 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcPredType, isIntTy,isFloatTy, isIntegerTy, isDoubleTy, mkPredTy, mkTyVarTys, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred, - isClassPred, isTyVarClassPred, isLinearPred, + isClassPred, isTyVarClassPred, getClassPredTys, mkPredName, isInheritablePred, isIPPred, 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 ) @@ -74,20 +77,18 @@ import {- Kind parts of -} Type ( isSubKind ) import Coercion ( isEqPred ) import HscTypes ( ExternalPackageState(..), HscEnv(..) ) import CoreFVs ( idFreeTyVars ) -import DataCon ( DataCon, dataConStupidTheta, dataConName, - dataConWrapId, dataConUnivTyVars ) -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 ( Var, TyVar, tyVarKind, setIdType, mkTyVar ) +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 ) @@ -98,9 +99,6 @@ import Outputable Selection ~~~~~~~~~ \begin{code} -mkInstCoFn :: [TcType] -> [Inst] -> ExprCoFn -mkInstCoFn tys dicts = CoApps (map instToId dicts) <.> CoTyApps tys - instName :: Inst -> Name instName inst = idName (instToId inst) @@ -191,17 +189,6 @@ isMethod other = False 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} @@ -212,32 +199,75 @@ linearInstType (Dict _ (IParam _ ty) _) = ty %* * %************************************************************************ -\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 @@ -265,20 +295,6 @@ 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 (dataConUnivTyVars data_con) inst_tys - newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId newMethodFromName origin ty name = tcLookupId name `thenM` \ id -> @@ -592,9 +608,9 @@ lookupInst :: Inst -> TcM LookupInstResult -- 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 @@ -671,11 +687,11 @@ lookupInst (Dict _ pred 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)) }}}} ---------------