[commit: ghc] type-holes-branch: The types of named holes is now printed at the end, if it was successful. (5681231)

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

On branch  : type-holes-branch

http://hackage.haskell.org/trac/ghc/changeset/5681231e58bf9e16d90431afe324d17a31133720

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

commit 5681231e58bf9e16d90431afe324d17a31133720
Author: Thijs Alkemade <[email protected]>
Date:   Thu Feb 23 19:30:14 2012 +0100

    The types of named holes is now printed at the end, if it was successful.
    
    This currently only works for tcRnExpr, modules still give an ambiguous type variable error.

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

 compiler/typecheck/Inst.lhs       |    1 +
 compiler/typecheck/TcRnDriver.lhs |   31 +++++++++++++++++++++----------
 compiler/typecheck/TcRnTypes.lhs  |    6 +++++-
 compiler/typecheck/TcSMonad.lhs   |    4 ++++
 4 files changed, 31 insertions(+), 11 deletions(-)

diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index 9656033..c4013b9 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -520,6 +520,7 @@ hasEqualities givens = any (has_eq . evVarPred) givens
     has_eq' (ClassPred cls _tys) = any has_eq (classSCTheta cls)
     has_eq' (TuplePred ts)       = any has_eq ts
     has_eq' (IrredPred _)        = True -- Might have equalities in it after reduction?
+    has_eq' (HolePred {})        = False
 
 ---------------- Getting free tyvars -------------------------
 
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index a8566e0..347693a 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -1458,30 +1458,41 @@ tcRnExpr hsc_env ictxt rdr_expr
     let { fresh_it  = itName uniq (getLoc rdr_expr) } ;
     ((_tc_expr, res_ty), lie)	<- captureConstraints (tcInferRho rn_expr) ;
     
-    (_, l) <- getEnvs ;
-    holes <- readTcRef $ tcl_holes l ;
     ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ 
                                       {-# SCC "simplifyInfer" #-}
                                       simplifyInfer True {- Free vars are closed -}
                                                     False {- No MR for now -}
-                                                    ([(fresh_it, res_ty)] ++ (map (\(name,(ty,_)) -> (name, ty)) $ Map.toList holes))
+                                                    [(fresh_it, res_ty)]
                                                     lie  ;
+	let { (holes, dicts') = splitEvs dicts [] [] } ;
+
     _ <- simplifyInteractive lie_top ;       -- Ignore the dicionary bindings
 
+    liftIO $ putStrLn ("tcRnExpr: " ++ (showSDoc $ ppr lie_top)) ;
 
-    let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
+    let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts' res_ty) } ;
     result <- zonkTcType all_expr_ty ;
 
-    zonked_holes <- mapM (\(s, ty) -> liftM (\t -> (s, t)) $ zonkTcType ty)
-				$ Map.toList $ Map.map (\(ty, _) -> mkForAllTys qtvs $ mkPiTypes dicts ty) $ holes ;
-    let { (env, tys) = foldr tidy (emptyTidyEnv, []) zonked_holes } ;
-    liftIO $ putStrLn ("tcRnExpr2: " ++ (showSDoc $ ppr $ map (\(s, t) -> (s, split t)) tys)) ;
-    liftIO $ putStrLn ("tcRnExpr3: " ++ (showSDoc $ ppr dicts)) ;
+
+    zonked_holes <- mapM (\(nm, ty) -> liftM (\t -> (nm, t)) $ zonkTcType ty) $ map2 (\ty -> mkForAllTys qtvs $ mkPiTypes dicts' ty) $ map (splitHole . varType) $ holes ;
+
+    let { (env, tys) = (\(e, tys) -> (e, map2 split tys)) $ foldr tidy (emptyTidyEnv, []) zonked_holes } ;
+
+    liftIO $ putStrLn $ showSDoc ((ptext $ sLit "Found the following holes: ") $+$ (vcat $ map (\(nm, ty) -> ppr nm <> colon <+> ppr ty) tys));
 
     return $ snd $ tidyOpenType env result
     }
-    where tidy (s, ty) (env, tys) = let (env', ty') = tidyOpenType env ty in (env', (s, ty') : tys)
+    where tidy (nm, ty) (env, tys) = let (env', ty') = tidyOpenType env ty in (env', (nm, ty') : tys)
           split t = let (_, ctxt, ty') = tcSplitSigmaTy $ tidyTopType t in mkPhiTy ctxt ty'
+          splitEvs [] hls dcts = (hls, dcts)
+          splitEvs (evvar:xs) hls dcts = case classifyPredType $ varType evvar of
+								    		HolePred {} -> splitEvs xs (evvar:hls) dcts
+								    		_ -> splitEvs xs hls (evvar:dcts)
+          splitHole (TyConApp nm [ty]) = (nm, ty)
+
+          map2 :: (b -> c) -> [(a, b)] -> [(a, c)]
+          map2 _ [] = []
+          map2 f ((a, b):xs) = ((a, f b):(map2 f xs))
 
 --------------------------
 tcRnImportDecls :: HscEnv
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 5b5ab30..6928801 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -54,7 +54,7 @@ module TcRnTypes(
         Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, 
         singleCt, extendCts, isEmptyCts, isCTyEqCan, 
         isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe,
-        isCHoleCan_Maybe,
+        isCHoleCan_Maybe, isCHoleCan,
         isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, 
         isGivenCt_maybe, isGivenOrSolvedCt,
         ctWantedLoc,
@@ -989,6 +989,10 @@ isCNonCanonical :: Ct -> Bool
 isCNonCanonical (CNonCanonical {}) = True 
 isCNonCanonical _ = False 
 
+isCHoleCan :: Ct -> Bool
+isCHoleCan (CHoleCan {}) = True
+isCHoleCan _ = False
+
 isCHoleCan_Maybe :: Ct -> Maybe Name
 isCHoleCan_Maybe (CHoleCan { cc_hole_nm = nm }) = Just nm
 isCHoleCan_Maybe _ = Nothing
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 8f9cd54..aac7d3d 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -565,6 +565,7 @@ extractUnsolved is@(IS {inert_eqs = eqs, inert_irreds = irreds})
                         , inert_irreds = solved_irreds
                         , inert_frozen = emptyCts
                         , inert_funeqs = solved_funeqs
+                        , inert_holes  = solved_holes
                         }
     in ((inert_frozen is, unsolved), is_solved)
 
@@ -578,8 +579,11 @@ extractUnsolved is@(IS {inert_eqs = eqs, inert_irreds = irreds})
 
         (unsolved_funeqs, solved_funeqs) = extractUnsolvedCtTypeMap (inert_funeqs is)
 
+        (unsolved_holes, solved_holes)   = extractUnsolvedCMap (inert_holes is)
+
         unsolved = unsolved_eqs `unionBags` unsolved_irreds `unionBags`
                    unsolved_ips `unionBags` unsolved_dicts `unionBags` unsolved_funeqs
+                   `unionBags` unsolved_holes
 
 extractUnsolvedCtTypeMap :: TypeMap Ct -> (Cts,TypeMap Ct)
 extractUnsolvedCtTypeMap