[commit: ghc] type-holes-branch: Store the SrcPos in the Hole. Use a map to map holes to their type. (19e38dd)
Simon Peyton Jones
simonpj at microsoft.com
Mon Sep 17 13:02:27 CEST 2012
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : type-holes-branch
http://hackage.haskell.org/trac/ghc/changeset/19e38dd828686bf0d88f3d4cc172a047acb14636
>---------------------------------------------------------------
commit 19e38dd828686bf0d88f3d4cc172a047acb14636
Author: Thijs Alkemade <thijsalkemade at gmail.com>
Date: Wed Dec 21 22:18:13 2011 +0100
Store the SrcPos in the Hole. Use a map to map holes to their type.
>---------------------------------------------------------------
compiler/hsSyn/HsExpr.lhs | 4 ++--
compiler/parser/Parser.y.pp | 2 +-
compiler/rename/RnExpr.lhs | 4 ++--
compiler/typecheck/TcExpr.lhs | 9 +++++----
compiler/typecheck/TcRnDriver.lhs | 11 ++++++-----
compiler/typecheck/TcRnMonad.lhs | 4 +++-
compiler/typecheck/TcRnTypes.lhs | 3 ++-
7 files changed, 21 insertions(+), 16 deletions(-)
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 121687c..a36cb6e 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -290,7 +290,7 @@ data HsExpr id
| HsWrap HsWrapper -- TRANSLATION
(HsExpr id)
- | HsHole
+ | HsHole SrcSpan
deriving (Data, Typeable)
-- HsTupArg is used for tuple sections
@@ -546,7 +546,7 @@ ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
ppr_expr (HsArrForm op _ args)
= hang (ptext (sLit "(|") <> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))
-ppr_expr HsHole
+ppr_expr (HsHole _)
= text "__"
pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 3b3bbd4..4a74731 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1459,7 +1459,7 @@ aexp2 :: { LHsExpr RdrName }
| '[' list ']' { LL (unLoc $2) }
| '[:' parr ':]' { LL (unLoc $2) }
| '_' { L1 EWildPat }
- | '__' { L1 HsHole }
+ | '__' { L1 (HsHole $ getLoc $1) }
-- Template Haskell Extension
| TH_ID_SPLICE { L1 $ HsSpliceE (mkHsSplice
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 6773ed4..7b73eab 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -294,8 +294,8 @@ rnExpr (PArrSeq _ seq)
= rnArithSeq seq `thenM` \ (new_seq, fvs) ->
return (PArrSeq noPostTcExpr new_seq, fvs)
-rnExpr HsHole
- = return (HsHole, emptyFVs)
+rnExpr (HsHole s)
+ = return (HsHole s, emptyFVs)
\end{code}
These three are pattern syntax appearing in expressions.
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 91926b6..950868b 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -66,6 +66,7 @@ import FastString
import Control.Monad
import TypeRep
+import qualified Data.Map as Map
\end{code}
%************************************************************************
@@ -220,16 +221,16 @@ tcExpr (HsType ty) _
-- so it's not enabled yet.
-- Can't eliminate it altogether from the parser, because the
-- same parser parses *patterns*.
-tcExpr HsHole res_ty
+tcExpr (HsHole s) res_ty
= do { liftIO $ putStrLn ("tcExpr.HsHole: " ++ (showSDoc $ ppr $ res_ty)) ;
printTy res_ty ;
(g, l) <- getEnvs ;
holes <- readTcRef $ tcl_holes l ;
- writeTcRef (tcl_holes l) (res_ty : holes) ;
- return HsHole }
+ writeTcRef (tcl_holes l) (Map.insert s res_ty holes) ;
+ return (HsHole s) }
where printTy (TyVarTy ty) = let (MetaTv _ io) = tcTyVarDetails ty in
do meta <- readTcRef io
- liftIO $ putStrLn ("tcExpr.HsHole: " ++ (showSDoc $ ppr $ meta))
+ liftIO $ putStrLn ("tcExpr.HsHole @(" ++ (showSDoc $ ppr s) ++ "): " ++ (showSDoc $ ppr meta))
printTy (ForAllTy _ _) = liftIO $ putStrLn ("tcExpr.HsHole: ForAllTy")
printTy (PredTy _) = liftIO $ putStrLn ("tcExpr.HsHole: ForAllTy")
printTy (AppTy _ _) = liftIO $ putStrLn ("tcExpr.HsHole: AppTy")
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 35cf176..0be8eae 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -109,6 +109,7 @@ import Control.Monad
import System.IO
import TypeRep
+import qualified Data.Map as Map
#include "HsVersions.h"
\end{code}
@@ -1428,12 +1429,12 @@ tcRnExpr hsc_env ictxt rdr_expr
lie ;
_ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings
- (g, l) <- getEnvs ;
+ (_, l) <- getEnvs ;
holes <- readTcRef $ tcl_holes l ;
- liftIO $ putStrLn ("tcRnExpr1.5: " ++ (showSDoc $ ppr $ holes)) ;
- zonked_holes <- zonkTcTypes $ map (\ty -> mkPiTypes dicts ty) $ holes ;
- liftIO $ putStrLn ("tcRnExpr2: " ++ (showSDoc $ ppr $ map (tidyType emptyTidyEnv) zonked_holes)) ;
- liftIO $ putStrLn ("tcRnExpr3: " ++ (showSDoc $ ppr $ dicts)) ;
+ zonked_holes <- mapM (\(s, ty) -> liftM (\t -> (s, tidyType emptyTidyEnv t)) $ zonkTcType ty)
+ $ Map.toList $ Map.map (\ty -> mkPiTypes dicts ty) $ holes ;
+ liftIO $ putStrLn ("tcRnExpr2: " ++ (showSDoc $ ppr $ zonked_holes)) ;
+
let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
zonkTcType all_expr_ty
}
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index de2e7b6..c320d94 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -53,6 +53,8 @@ import System.IO
import Data.IORef
import qualified Data.Set as Set
import Control.Monad
+
+import qualified Data.Map as Map
\end{code}
@@ -86,7 +88,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
infer_var <- newIORef True ;
lie_var <- newIORef emptyWC ;
dfun_n_var <- newIORef emptyOccSet ;
- holes_var <- newIORef [] ;
+ holes_var <- newIORef Map.empty ;
type_env_var <- case hsc_type_env_var hsc_env of {
Just (_mod, te_var) -> return te_var ;
Nothing -> newIORef emptyNameEnv } ;
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 2ef124e..f9271c9 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -122,6 +122,7 @@ import FastString
import Data.Set (Set)
import UniqSet
+import qualified Data.Map as Map
\end{code}
@@ -440,7 +441,7 @@ data TcLclEnv -- Changes as we move inside an expression
tcl_untch :: Unique, -- Any TcMetaTyVar with
-- unique >= tcl_untch is touchable
-- unique < tcl_untch is untouchable
- tcl_holes :: TcRef [Type]
+ tcl_holes :: TcRef (Map.Map SrcSpan Type)
}
type TcTypeEnv = NameEnv TcTyThing
More information about the Cvs-ghc
mailing list