Switch back to the simpler `IP` class, no extra newtypes.

XXX: This reveals a bug that for some reason was not showing up before.
The issue has to do with shadowing of implicit parameters.  For example,
consider the following definition:

f :: (?x :: Int) => Int
f = let ?x = (5 :: Int) in ?x

By the time we check the body of the let (i.e., the ?x) we have two pieces of
evidence for "?x :: Int": one that is a parameter to the function,
and one from the local definition.  Presumably, the intention here is
that the local definition should "shadow" the external one, but we
need some code to do this.  Note that this is not a problem for ordinary
classes because even we have multiple dictionaries for the same
constraint are guaranteed to be the same.

My current plan is to try to solve this by adding a special case
in the handling of nested implication constraints, where implicit
parameters in the inner implication should shadow (i.e, replace) the
outer implications (temporarily, for the duration of the implication).

I believe that in the previous implementation of
implicit parameters this was handled automatically, because we had
a separate map for the evidence for the implicit parameters.

5 files changed, 26 insertions, 52 deletions

diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index d2c2a0bc79..17ad6cf108 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -106,7 +106,7 @@ noSyntaxTable = []
 -- | A Haskell expression.
 data HsExpr id
   = HsVar     id                        -- ^ variable
-  | HsIPVar   (Located HsIPName)        -- ^ implicit parameter
+  | HsIPVar   HsIPName                  -- ^ implicit parameter
   | HsOverLit (HsOverLit id)            -- ^ Overloaded literals
 
   | HsLit     HsLit                     -- ^ Simple (non-overloaded) literals
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 785346949e..21f8782f6f 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1451,7 +1451,7 @@ aexp1   :: { LHsExpr RdrName }
         | aexp2                 { $1 }
 
 aexp2   :: { LHsExpr RdrName }
-        : ipvar                         { L1 (HsIPVar $! $1) }
+        : ipvar                         { L1 (HsIPVar $! unLoc $1) }
         | qcname                        { L1 (HsVar   $! unLoc $1) }
         | literal                       { L1 (HsLit   $! unLoc $1) }
 -- This will enable overloaded strings permanently.  Normally the renamer turns HsString
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index cbf184f610..2ee188bb03 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -283,8 +283,7 @@ basicKnownKeyNames
         typeNatExpTyFamName,
 
         -- Implicit parameters
-        ipClassName, ipUseName,
-        ipNameTyConName, ipNameDataConName, ipValueTyConName,
+        ipClassName,
 
         -- Annotation type checking
         toAnnotationWrapperName
@@ -1077,15 +1076,8 @@ typeNatMulTyFamName = tcQual  gHC_TYPELITS (fsLit "*")   typeNatMulTyFamNameKey
 typeNatExpTyFamName = tcQual  gHC_TYPELITS (fsLit "^")   typeNatExpTyFamNameKey
 
 -- Implicit parameters
-ipClassName, ipUseName,
-  ipNameTyConName, ipNameDataConName,
-  ipValueTyConName :: Name
+ipClassName :: Name
 ipClassName         = clsQual gHC_IP (fsLit "IP")      ipClassNameKey
-ipUseName           = varQual gHC_IP (fsLit "ipUse")   ipUseKey
-ipNameTyConName     = tcQual  gHC_IP (fsLit "IPName")  ipNameTyConKey
-ipNameDataConName   = conName gHC_IP (fsLit "IPName")  ipNameDataConKey
-ipValueTyConName    = tcQual  gHC_IP (fsLit "IPValue") ipValueTyConKey
-
 
 
 
@@ -1404,10 +1396,6 @@ typeNatAddTyFamNameKey    = mkPreludeTyConUnique 162
 typeNatMulTyFamNameKey    = mkPreludeTyConUnique 163
 typeNatExpTyFamNameKey    = mkPreludeTyConUnique 164
 
-ipNameTyConKey, ipValueTyConKey :: Unique
-ipNameTyConKey  = mkPreludeTyConUnique 165
-ipValueTyConKey = mkPreludeTyConUnique 166
-
 ---------------- Template Haskell -------------------
 --      USES TyConUniques 200-299
 -----------------------------------------------------
@@ -1466,9 +1454,6 @@ gtDataConKey                            = mkPreludeDataConUnique 29
 integerGmpSDataConKey, integerGmpJDataConKey :: Unique
 integerGmpSDataConKey                   = mkPreludeDataConUnique 30
 integerGmpJDataConKey                   = mkPreludeDataConUnique 31
-
-ipNameDataConKey :: Unique
-ipNameDataConKey                        = mkPreludeDataConUnique 32
 \end{code}
 
 %************************************************************************
@@ -1691,10 +1676,6 @@ mzipIdKey       = mkPreludeMiscIdUnique 196
 ghciStepIoMClassOpKey :: Unique
 ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197
 
--- Implicit parameters
-ipUseKey :: Unique
-ipUseKey = mkPreludeMiscIdUnique 198
-
 
 ---------------- Template Haskell -------------------
 --      USES IdUniques 200-499
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index cf41ad71d0..be4c4ce81f 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -47,7 +47,7 @@ import Outputable
 import FastString
 import Type(mkStrLitTy)
 import Class(classTyCon)
-import PrelNames(ipClassName,ipValueTyConName)
+import PrelNames(ipClassName)
 
 import Control.Monad
 
@@ -211,9 +211,8 @@ tcLocalBinds (HsValBinds (ValBindsIn {})) _ = panic "tcLocalBinds"
 
 tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
   = do  { ipClass <- tcLookupClass ipClassName
-        ; ipValue <- tcLookupTyCon ipValueTyConName
         ; (given_ips, ip_binds') <-
-            mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass ipValue)) ip_binds
+            mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
 
         -- If the binding binds ?x = E, we  must now 
         -- discharge any ?x constraints in expr_lie
@@ -228,23 +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 ipVal (IPBind ~(Left ip) expr)
+    tc_ip_bind ipClass (IPBind ~(Left ip) expr)
        = do { ty <- newFlexiTyVarTy argTypeKind
             ; let p = mkStrLitTy $ hsIPNameFS ip
             ; ip_id <- newDict ipClass [ p, ty ]
             ; expr' <- tcMonoExpr expr ty
-            ; let d = (toDict ipClass p ty . toIPVal ipVal p ty) `fmap` expr'
+            ; let d = toDict ipClass p ty `fmap` expr'
             ; return (ip_id, (IPBind (Right ip_id) d)) }
 
-    -- Coerce the definition of the implcit parameter into an `IPValue`
-    -- co : t -> IPValue "x" t
-    toIPVal ipVal x ty =
-      case unwrapNewTyCon_maybe ipVal of
-        Just (_,_,ax) -> HsWrap $ WpCast $ mkTcSymCo $ mkTcAxInstCo ax [x,ty]
-        Nothing       -> panic "`IPValue` is not a newtype?"
-
-    -- Coerces an `IPValue` into a dictionry for `IP`.
-    -- co : IPValue "x" t -> IP "x" t
+    -- Coerces a `t` into a dictionry for `IP "x" t`.
+    -- co : t -> IP "x" t
     toDict ipClass x ty =
       case unwrapNewTyCon_maybe (classTyCon ipClass) of
         Just (_,_,ax) -> HsWrap $ WpCast $ mkTcSymCo $ mkTcAxInstCo ax [x,ty]
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 794af421d4..9e8864dc6a 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -63,7 +63,7 @@ import ErrUtils
 import Outputable
 import FastString
 import Control.Monad
-import Bag(mapBag)
+import Class(classTyCon)
 \end{code}
 
 %************************************************************************
@@ -179,23 +179,24 @@ tcExpr (NegApp expr neg_expr) res_ty
 	; expr' <- tcMonoExpr expr res_ty
 	; return (NegApp expr' neg_expr') }
 
--- We desugar ?x into: ipUse (IPName :: IPName "x")
 tcExpr (HsIPVar x) res_ty =
-  do (r,cs) <- captureConstraints $ tcExpr (unLoc expr) res_ty
+  do let origin = IPOccOrigin x
+     ipClass <- tcLookupClass ipClassName
+     {- Implicit parameters must have a *tau-type* not a.
+        type scheme.  We enforce this by creating a fresh
+        type variable as its type.  (Because res_ty may not
+        be a tau-type.) -}
+     ip_ty <- newFlexiTyVarTy argTypeKind
+     let ip_name = mkStrLitTy (hsIPNameFS x)
+     ip_var <- emitWanted origin (mkClassPred ipClass [ip_name, ip_ty])
+     tcWrapResult (fromDict ipClass ip_name ip_ty (HsVar ip_var)) ip_ty res_ty
 
-     -- There should be just a single flat wnated `IP` constaint.
-     emitConstraints $ cs { wc_flat = mapBag setOrigin (wc_flat cs) }
-     return r
   where
-  p        = L (getLoc x)
-  expr     = mkHsApp (p $ HsVar ipUseName) mkIPName
-  mkIPName = p $ ExprWithTySig (p $ HsVar ipNameDataConName) ty
-  ty       = mkHsAppTy (p $ HsTyVar ipNameTyConName)
-                       (p $ HsTyLit $ HsStrTy $ hsIPNameFS $ unLoc x)
-
-  origin         = IPOccOrigin (unLoc x)
-  updOriginEv ev = ev { ctev_wloc = ctev_wloc ev `setCtLocOrigin` origin }
-  setOrigin w    = w { cc_ev = updOriginEv (cc_ev w) }
+  -- Coerces a dictionry for `IP "x" t` into `t`.
+  fromDict ipClass x ty =
+    case unwrapNewTyCon_maybe (classTyCon ipClass) of
+      Just (_,_,ax) -> HsWrap $ WpCast $ mkTcAxInstCo ax [x,ty]
+      Nothing       -> panic "The dictionary for `IP` is not a newtype?"
 
 tcExpr (HsLam match) res_ty
   = do	{ (co_fn, match') <- tcMatchLambda match res_ty