[commit: ghc] imp-param-class: Report errors in definitions of implicit parameters properly. (2d5bac9)

[Iavor Diatchki]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : imp-param-class

http://hackage.haskell.org/trac/ghc/changeset/2d5bac977b5b9fb4033b89005247303fe889fefe

>---------------------------------------------------------------

commit 2d5bac977b5b9fb4033b89005247303fe889fefe
Author: Iavor S. Diatchki <iavor.diatchki at gmail.com>
Date:   Sun May 27 20:33:35 2012 -0700

    Report errors in definitions of implicit parameters properly.
    
    Using the "ipDef" function showed up in errors, which was confusing
    because it was not in the source.  The only thing it did was to
    coerce to the `IPValue` newtype, so we just put the coercion
    on the value after we type check it.

>---------------------------------------------------------------

 compiler/prelude/PrelNames.lhs |    8 +++-----
 compiler/typecheck/TcBinds.lhs |   16 +++++++++++-----
 2 files changed, 14 insertions(+), 10 deletions(-)

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index aa6a9c4..cbf184f 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -283,7 +283,7 @@ basicKnownKeyNames
         typeNatExpTyFamName,
 
         -- Implicit parameters
-        ipClassName, ipUseName, ipDefName,
+        ipClassName, ipUseName,
         ipNameTyConName, ipNameDataConName, ipValueTyConName,
 
         -- Annotation type checking
@@ -1077,12 +1077,11 @@ typeNatMulTyFamName = tcQual  gHC_TYPELITS (fsLit "*")   typeNatMulTyFamNameKey
 typeNatExpTyFamName = tcQual  gHC_TYPELITS (fsLit "^")   typeNatExpTyFamNameKey
 
 -- Implicit parameters
-ipClassName, ipUseName, ipDefName,
+ipClassName, ipUseName,
   ipNameTyConName, ipNameDataConName,
   ipValueTyConName :: Name
 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
 ipNameDataConName   = conName gHC_IP (fsLit "IPName")  ipNameDataConKey
 ipValueTyConName    = tcQual  gHC_IP (fsLit "IPValue") ipValueTyConKey
@@ -1693,9 +1692,8 @@ ghciStepIoMClassOpKey :: Unique
 ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197
 
 -- Implicit parameters
-ipUseKey, ipDefKey :: Unique
+ipUseKey :: Unique
 ipUseKey = mkPreludeMiscIdUnique 198
-ipDefKey = mkPreludeMiscIdUnique 199
 
 
 ---------------- Template Haskell -------------------
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index ad8f3c3..cf41ad7 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,ipDefName)
+import PrelNames(ipClassName,ipValueTyConName)
 
 import Control.Monad
 
@@ -232,12 +232,18 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
        = do { ty <- newFlexiTyVarTy argTypeKind
             ; let p = mkStrLitTy $ hsIPNameFS ip
             ; ip_id <- newDict ipClass [ p, ty ]
-            ; let e = mkHsApp (L (getLoc expr) $ HsVar ipDefName) expr
-            ; expr' <- tcMonoExpr e (mkTyConApp ipVal [ p, ty ])
-            ; let d = toDict ipClass p ty `fmap` expr'
+            ; expr' <- tcMonoExpr expr ty
+            ; let d = (toDict ipClass p ty . toIPVal ipVal p ty) `fmap` expr'
             ; return (ip_id, (IPBind (Right ip_id) d)) }
 
-    -- Coerces the definition into a dictionry for `IP`.
+    -- 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
     toDict ipClass x ty =
       case unwrapNewTyCon_maybe (classTyCon ipClass) of