[commit: ghc] supercompiler: Make type MSG unfailing (81555a5)

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

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/81555a5b08d51046413902bac836a8ee7b7516be

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

commit 81555a5b08d51046413902bac836a8ee7b7516be
Author: Max Bolingbroke <[email protected]>
Date:   Thu Apr 19 16:44:56 2012 +0100

    Make type MSG unfailing

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

 compiler/supercompile/Supercompile/Drive/MSG.hs |   37 +++++++++++++---------
 1 files changed, 22 insertions(+), 15 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs b/compiler/supercompile/Supercompile/Drive/MSG.hs
index b471566..e8fa13c 100644
--- a/compiler/supercompile/Supercompile/Drive/MSG.hs
+++ b/compiler/supercompile/Supercompile/Drive/MSG.hs
@@ -183,9 +183,10 @@ runMSG' (Right x)   = Just x
 runMSG' (Left _msg) = {- trace ("msg " ++ _msg) -} Nothing
 --runMSG = unMSG
 
--- instance MonadPlus MSG where
---     mzero = fail "mzero"
---     mx1 `mplus` mx2 = MSG $ unMSG mx1 `mplus` unMSG mx2
+instance MonadPlus MSG where
+    mzero = fail "mzero"
+    mx1 `mplus` mx2 = MSG $ \e s -> case unMSG mx1 e s of Right res -> Right res
+                                                          Left _    -> unMSG mx2 e s
 
 
 {-
@@ -266,18 +267,18 @@ msgKind = msgType
 -- NB: we don't do anything stupid like introduce a TyVar due to
 -- generalisation at the superkind level because the only term
 -- at the superkind level is Box, which always MSGes into itself.
-msgType :: RnEnv2 -> Type -> Type -> MSG Type
-msgType rn2 (TyVarTy x_l)         (TyVarTy x_r)         = liftM TyVarTy $ msgVar rn2 x_l x_r
-msgType rn2 (AppTy ty1_l ty2_l)   (AppTy ty1_r ty2_r)   = liftM2 mkAppTy (msgType rn2 ty1_l ty1_r) (msgType rn2 ty2_l ty2_r)
-msgType _   (TyConApp tc_l [])    (TyConApp tc_r [])    = guard "msgType: TyConApp" (tc_l == tc_r) >> return (TyConApp tc_r [])
-msgType rn2 (TyConApp tc_l tys_l) (TyConApp tc_r tys_r) = msgType rn2 (foldl AppTy (TyConApp tc_l []) tys_l) (foldl AppTy (TyConApp tc_r []) tys_r)
-msgType rn2 (FunTy ty1_l ty2_l)   (FunTy ty1_r ty2_r)   = msgType rn2 ((TyConApp funTyCon [] `AppTy` ty1_l) `AppTy` ty2_l) ((TyConApp funTyCon [] `AppTy` ty1_r) `AppTy` ty2_r)
-msgType rn2 (ForAllTy a_l ty_l)   (ForAllTy a_r ty_r)   = msgTyVarBndr ForAllTy rn2 a_l a_r $ \rn2 -> msgType rn2 ty_l ty_r
-msgType rn2 ty_l ty_r | canFloatType (rnOccL_maybe rn2) ty_l, canFloatType (rnOccR_maybe rn2) ty_r = liftM TyVarTy $ msgGeneraliseType ty_l ty_r
-msgType _ _ _ = fail "msgType" -- FIXME: succeed in all cases, even with trivial gen?
-
-canFloatType :: (TyVar -> Maybe a) -> Type -> Bool
-canFloatType lkup = foldVarSet (\a rest_ok -> maybe rest_ok (const False) (lkup a)) True . tyVarsOfType
+msgType, msgType' :: RnEnv2 -> Type -> Type -> MSG Type
+msgType rn2 ty_l ty_r = msgType' rn2 ty_l ty_r `mplus` do
+    guard "msgType: unfloatable" (canFloatType (rnOccL_maybe rn2) ty_l && canFloatType (rnOccR_maybe rn2) ty_r)
+    liftM TyVarTy $ msgGeneraliseType ty_l ty_r
+
+msgType' rn2 (TyVarTy x_l)         (TyVarTy x_r)         = liftM TyVarTy $ msgVar rn2 x_l x_r
+msgType' rn2 (AppTy ty1_l ty2_l)   (AppTy ty1_r ty2_r)   = liftM2 mkAppTy (msgType rn2 ty1_l ty1_r) (msgType rn2 ty2_l ty2_r)
+msgType' _   (TyConApp tc_l [])    (TyConApp tc_r [])    = guard "msgType: TyConApp" (tc_l == tc_r) >> return (TyConApp tc_r [])
+msgType' rn2 (TyConApp tc_l tys_l) (TyConApp tc_r tys_r) = msgType rn2 (foldl AppTy (TyConApp tc_l []) tys_l) (foldl AppTy (TyConApp tc_r []) tys_r)
+msgType' rn2 (FunTy ty1_l ty2_l)   (FunTy ty1_r ty2_r)   = msgType rn2 ((TyConApp funTyCon [] `AppTy` ty1_l) `AppTy` ty2_l) ((TyConApp funTyCon [] `AppTy` ty1_r) `AppTy` ty2_r)
+msgType' rn2 (ForAllTy a_l ty_l)   (ForAllTy a_r ty_r)   = msgTyVarBndr ForAllTy rn2 a_l a_r $ \rn2 -> msgType rn2 ty_l ty_r
+msgType' _ _ _ = fail "msgType"
 
 -- TODO: msg coercion instantiation?
 msgCoercion :: RnEnv2 -> Coercion -> Coercion -> MSG Coercion
@@ -629,3 +630,9 @@ msgPureHeap {- mm -} rn2 msg_s init_h_l init_h_r (k_bvs_l, k_fvs_l) (k_bvs_r, k_
 prod :: MSG' [MSG' a] -> [MSG' a]
 prod (Left msg)  = [Left msg]
 prod (Right mxs) = mxs
+
+canFloatType :: (TyVar -> Maybe a) -> Type -> Bool
+canFloatType = canFloat tyVarsOfType
+
+canFloat :: (b -> FreeVars) -> (Var -> Maybe a) -> b -> Bool
+canFloat fvs lkup = foldVarSet (\a rest_ok -> maybe rest_ok (const False) (lkup a)) True . fvs