Move implicit parameter syntactic sugar to HsUtils.

Also, insert the appropriate use of "ipDef" in module TcBinds.

4 files changed, 44 insertions, 23 deletions

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 32fe487609..db9f27bab5 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -31,6 +31,8 @@ module HsUtils(
   mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
   mkLHsPar, 
 
+  mkIPUse, mkIPDef,
+
   nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, 
   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
   mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, 
@@ -95,6 +97,7 @@ import Util
 import Bag
 import Outputable
 import Data.Either
+import PrelNames(ipNameTyConName, ipNameDataConName, ipUseName, ipDefName)
 \end{code}
 
 
@@ -171,6 +174,27 @@ mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp)
                       | otherwise          = lp
 
 
+
+------ Implicit parameters --------------------
+
+-- Construct `IPName :: IPName "x"`
+mkIPName :: IPName Name -> LHsExpr Name
+mkIPName x' = p $ ExprWithTySig (p $ HsVar ipNameDataConName) ty
+  where p   = L (nameSrcSpan x)
+        x   = ipNameName x'
+        ty  = mkHsAppTy (p $ HsTyVar ipNameTyConName)
+                        (p $ HsTyLit $ HsStrTy $ occNameFS $ occName x)
+
+-- Constructs `ipUse (IPName :: IPName "x")`
+mkIPUse :: IPName Name -> LHsExpr Name
+mkIPUse x = mkHsApp (L (getLoc n) $ HsVar ipUseName) n
+  where n = mkIPName x
+
+-- Constructs `ipDef (IPName :: IPName "x") e`
+mkIPDef :: IPName Name -> LHsExpr Name -> LHsExpr Name
+mkIPDef x e = mkHsApp (mkHsApp (L (getLoc n) $ HsVar ipDefName) n) e
+  where n = mkIPName x
+
 -------------------------------
 -- These are the bits of syntax that contain rebindable names
 -- See RnEnv.lookupSyntaxName
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 155b04561c..8500c4d151 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -283,7 +283,8 @@ basicKnownKeyNames
         typeNatExpTyFamName,
 
         -- Implicit parameters
-        ipClassName, ipUseName, ipDefName, ipNameTyConName, ipNameDataConName,
+        ipClassName, ipUseName, ipDefName,
+        ipNameTyConName, ipNameDataConName, ipValueTyConName,
 
         -- Annotation type checking
         toAnnotationWrapperName
@@ -1081,6 +1082,7 @@ ipClassName       = clsQual gHC_IP (fsLit "IP") ipClassNameKey
 ipUseName         = varQual gHC_IP (fsLit "ipUse") ipUseKey
 ipDefName         = varQual gHC_IP (fsLit "ipDef") ipDefKey
 ipNameTyConName   = tcQual  gHC_IP (fsLit "IPName") ipNameTyConKey
+ipValueTyConName  = tcQual  gHC_IP (fsLit "IPValue") ipValueTyConKey
 ipNameDataConName = conName gHC_IP (fsLit "IPName") ipNameDataConKey
 
 
@@ -1401,8 +1403,9 @@ typeNatAddTyFamNameKey    = mkPreludeTyConUnique 162
 typeNatMulTyFamNameKey    = mkPreludeTyConUnique 163
 typeNatExpTyFamNameKey    = mkPreludeTyConUnique 164
 
-ipNameTyConKey :: Unique
-ipNameTyConKey = mkPreludeTyConUnique 165
+ipNameTyConKey, ipValueTyConKey :: Unique
+ipNameTyConKey  = mkPreludeTyConUnique 165
+ipValueTyConKey = mkPreludeTyConUnique 166
 
 ---------------- Template Haskell -------------------
 --      USES TyConUniques 200-299
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 6148fe37aa..4de961ff05 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -46,7 +46,7 @@ import BasicTypes
 import Outputable
 import FastString
 import Type(mkStrLitTy)
-import PrelNames(ipClassName)
+import PrelNames(ipClassName,ipValueTyConName)
 
 import Control.Monad
 
@@ -210,8 +210,9 @@ tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds"
 
 tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
   = do  { ipClass <- tcLookupClass ipClassName
-        ; (given_ips, ip_binds') <- mapAndUnzipM
-                                    (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
+        ; ipValue <- tcLookupTyCon ipValueTyConName
+        ; (given_ips, ip_binds') <-
+            mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass ipValue)) ip_binds
 
         -- If the binding binds ?x = E, we  must now 
         -- discharge any ?x constraints in expr_lie
@@ -226,13 +227,16 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
         -- I wonder if we should do these one at at time
         -- Consider     ?x = 4
         --              ?y = ?x + 1
-    tc_ip_bind ipClass (IPBind ip expr) 
+    tc_ip_bind ipClass ipVal (IPBind ip expr) 
        = do { ty <- newFlexiTyVarTy argTypeKind
-              -- XXX: Just switch to string in the bind
-            ; let param = mkStrLitTy $ occNameFS $ nameOccName $ ipNameName ip
-            ; ip_id <- newDict ipClass [ param, ty ]
-            ; expr' <- tcMonoExpr expr ty
+            ; let p = mkStrLitTy $ occNameFS $ nameOccName $ ipNameName ip
+            ; ip_id <- newDict ipClass [ p, ty ]
+            ; expr' <- tcMonoExpr (mkIPDef ip expr) (mkTyConApp ipVal [ p, ty ])
             ; return (ip_id, (IPBind (IPName ip_id) expr')) }
+
+
+
+
 \end{code}
 
 Note [Implicit parameter untouchables]
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 4cf198afd0..7b3c88d0a5 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -178,18 +178,8 @@ tcExpr (NegApp expr neg_expr) res_ty
 	; expr' <- tcMonoExpr expr res_ty
 	; return (NegApp expr' neg_expr') }
 
-tcExpr (HsIPVar x) res_ty = tcExpr expr res_ty
-
-  where
-  name = ipNameName x
-
-  -- We desugar ?x into: ipUse (IPName :: IPName "x")
-  here = L (nameSrcSpan name)
-  str  = here $ HsTyLit $ HsStrTy $ occNameFS $ nameOccName name  -- "x"
-  ty   = mkHsAppTy (here $ HsTyVar ipNameTyConName) str           -- IPName "x"
-  expr = HsApp (here $ HsVar ipUseName)
-               (here $ ExprWithTySig (here $ HsVar ipNameDataConName) ty)
-
+-- We desugar ?x into: ipUse (IPName :: IPName "x")
+tcExpr (HsIPVar x) res_ty = tcExpr (unLoc $ mkIPUse x) res_ty
 
 tcExpr (HsLam match) res_ty
   = do	{ (co_fn, match') <- tcMatchLambda match res_ty