Fix scoped type variables for expression type signatures

[ghc-hetmet.git] / compiler / typecheck / Inst.lhs

diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index 63b5f26..3bfde1c 100644 (file)
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -28,7 +28,7 @@ module Inst (
        tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
 
        isDict, isClassDict, isMethod, 
-       isLinearInst, linearInstType, isIPDict, isInheritableInst,
+       isIPDict, isInheritableInst,
        isTyVarDict, isMethodFor, 
 
        zonkInst, zonkInsts,
@@ -43,7 +43,7 @@ import {-# SOURCE #-} TcExpr( tcPolyExpr )
 import {-# SOURCE #-}  TcUnify( unifyType )
 
 import HsSyn   ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
-                 ExprCoFn(..), (<.>), mkCoTyApps, idCoercion,
+                 HsWrapper(..), (<.>), mkWpTyApps, idHsWrapper,
                  nlHsLit, nlHsVar )
 import TcHsSyn ( zonkId )
 import TcRnMonad
@@ -63,7 +63,7 @@ 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, 
@@ -189,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}
 
 
@@ -230,18 +219,18 @@ newDictBndr inst_loc pred
        ; 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 ()
@@ -253,17 +242,17 @@ instStupidTheta orig theta
        ; 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
 
@@ -272,7 +261,7 @@ instCallDicts loc (pred : preds)
        ; 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
@@ -620,8 +609,8 @@ lookupInst :: Inst -> TcM LookupInstResult
 
 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
 
@@ -698,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 (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))
     }}}}
 
 ---------------