[commit: ghc] type-holes-branch: Store TyVars instead of Types. Tidy types before printing. (63d7ee2)
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/63d7ee2342a4e376c4a4e1eb699297c15b790d92 >--------------------------------------------------------------- commit 63d7ee2342a4e376c4a4e1eb699297c15b790d92 Author: Thijs Alkemade <[email protected]> Date: Wed Dec 21 17:38:59 2011 +0100 Store TyVars instead of Types. Tidy types before printing. TyVars are Names, so store their src position, however, it seems to not be used here. >--------------------------------------------------------------- compiler/typecheck/TcExpr.lhs | 8 ++++---- compiler/typecheck/TcRnDriver.lhs | 8 +++++--- compiler/typecheck/TcRnTypes.lhs | 2 +- 3 files changed, 10 insertions(+), 8 deletions(-) diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index d337c33..def1d57 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -222,13 +222,13 @@ tcExpr (HsType ty) _ -- same parser parses *patterns*. tcExpr HsHole res_ty = do { liftIO $ putStrLn ("tcExpr.HsHole: " ++ (showSDoc $ ppr $ res_ty)) ; - (g, l) <- getEnvs ; - holes <- readTcRef $ tcl_holes l ; - writeTcRef (tcl_holes l) (res_ty : holes) ; printTy res_ty ; return HsHole } where printTy (TyVarTy ty) = let (MetaTv _ io) = tcTyVarDetails ty in - do meta <- readTcRef io + do (g, l) <- getEnvs ; + holes <- readTcRef $ tcl_holes l ; + writeTcRef (tcl_holes l) (ty : holes) ; + meta <- readTcRef io liftIO $ putStrLn ("tcExpr.HsHole: " ++ (showSDoc $ ppr $ meta)) printTy (ForAllTy _ _) = liftIO $ putStrLn ("tcExpr.HsHole: ForAllTy") printTy (PredTy _) = liftIO $ putStrLn ("tcExpr.HsHole: ForAllTy") diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 86e3963..2003ff6 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -47,7 +47,7 @@ import FamInstEnv import TcAnnotations import TcBinds import HeaderInfo ( mkPrelImports ) -import TcType ( tidyTopType ) +import TcType ( tidyTopType, tidyType ) import TcDefaults import TcEnv import TcRules @@ -108,6 +108,7 @@ import Bag import Control.Monad import System.IO +import TypeRep #include "HsVersions.h" \end{code} @@ -1429,8 +1430,9 @@ tcRnExpr hsc_env ictxt rdr_expr (g, l) <- getEnvs ; holes <- readTcRef $ tcl_holes l ; - zonked_holes <- mapM (\ty -> zonkTcType $ mkForAllTys qtvs (mkPiTypes dicts ty)) $ holes ; - liftIO $ putStrLn ("tcRnExpr2: " ++ (showSDoc $ ppr $ zonked_holes)) ; + zonked_holes <- zonkTcTypes $ map (\ty -> mkForAllTys qtvs (mkPiTypes dicts (TyVarTy ty))) $ holes ; + liftIO $ putStrLn ("tcRnExpr2: " ++ (showSDoc $ ppr $ zip holes (map (tidyType emptyTidyEnv) zonked_holes))) ; + liftIO $ putStrLn ("tcRnExpr3: " ++ (showSDoc $ ppr $ dicts)) ; let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ; zonkTcType all_expr_ty } diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 2ef124e..21536bb 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -440,7 +440,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 [TyVar] } type TcTypeEnv = NameEnv TcTyThing