[commit: ghc] type-holes-branch: Store the SrcPos in the Hole. Use a map to map holes to their type. (19e38dd)
Simon Peyton Jones <[email protected]>
| Newsgroups | gmane.comp.lang.haskell.cvs.ghc |
|---|---|
| Message-ID | <[email protected]> |
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 <[email protected]> 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