[commit: ghc] imp-param-class: Move implicit parameter syntactic sugar to HsUtils. (028bc9d)
Iavor Diatchki
diatchki at galois.com
Sun May 27 01:53:33 CEST 2012
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : imp-param-class
http://hackage.haskell.org/trac/ghc/changeset/028bc9d5aa4d41af8dc887badaea1205a683d47e
>---------------------------------------------------------------
commit 028bc9d5aa4d41af8dc887badaea1205a683d47e
Author: Iavor S. Diatchki <iavor.diatchki at gmail.com>
Date: Sat May 26 16:51:23 2012 -0700
Move implicit parameter syntactic sugar to HsUtils.
Also, insert the appropriate use of "ipDef" in module TcBinds.
>---------------------------------------------------------------
compiler/hsSyn/HsUtils.lhs | 24 ++++++++++++++++++++++++
compiler/prelude/PrelNames.lhs | 9 ++++++---
compiler/typecheck/TcBinds.lhs | 20 ++++++++++++--------
compiler/typecheck/TcExpr.lhs | 14 ++------------
4 files changed, 44 insertions(+), 23 deletions(-)
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 32fe487..db9f27b 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 155b045..8500c4d 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 6148fe3..4de961f 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 4cf198a..7b3c88d 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
More information about the Cvs-ghc
mailing list