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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
