[commit: nofib] master: Make lambda fit for MFP (7cbfbbe)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/nofib

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/7cbfbbed8b6d985187030dc5153aafb1ec1728a6/nofib

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

commit 7cbfbbed8b6d985187030dc5153aafb1ec1728a6
Author: Sebastian Graf <sgraf1337 at gmail.com>
Date:   Wed Aug 22 13:15:24 2018 -0400

    Make lambda fit for MFP
    
    Summary:
    The next step of the MonadFail Proposal broke nofib's lambda benchmark.
    This commit fixes that in an unintrusive way.
    
    Reviewers: O26 nofib, RyanGlScott, bgamari
    
    Reviewed By: RyanGlScott
    
    Subscribers: monoidal
    
    Differential Revision: https://phabricator.haskell.org/D5058


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

7cbfbbed8b6d985187030dc5153aafb1ec1728a6
 spectral/lambda/Main.hs | 29 +++++++++++++++++++++--------
 1 file changed, 21 insertions(+), 8 deletions(-)

diff --git a/spectral/lambda/Main.hs b/spectral/lambda/Main.hs
index f97a64c..b5f5959 100644
--- a/spectral/lambda/Main.hs
+++ b/spectral/lambda/Main.hs
@@ -117,6 +117,12 @@ instance EvalEnvMonad (State Env) where
     currEnv = get
     withEnv tmp m = return (evalState m tmp)
 
+traverseCon :: (EvalEnvMonad m) => Term -> m Int
+traverseCon t =
+    do t' <- traverseTerm t
+       case t' of
+           Con c -> return c
+           _ -> error ("Not a Con: " ++ show t')
 
 eval :: (EvalEnvMonad m) => Term -> m Term
 eval (Var x)   =
@@ -124,8 +130,8 @@ eval (Var x)   =
        t <- lookupVar x
        traverseTerm t
 eval (Add u v) =
-    do {Con u' <- traverseTerm u;
-	Con v' <- traverseTerm v;
+    do {u' <- traverseCon u;
+	v' <- traverseCon v;
 	return (Con (u'+v'))}
 eval (Thunk t e) =
     withEnv e (traverseTerm t)
@@ -149,7 +155,7 @@ eval (Incr)    = incr >> return (Con 0)
 apply (Thunk (Lam x b) e) a =
     do  orig <- currEnv
 	withEnv e (pushVar x (Thunk a orig) (traverseTerm b))
-apply a b         = fail ("bad application: " ++ pp a ++
+apply a b         = error ("bad application: " ++ pp a ++
 			      "  [ " ++ pp b ++ " ].")
 
 
@@ -165,6 +171,13 @@ newtype Id a = Id (Identity a)
 instance Show a => Show (Id a) where
     show (Id i) = show (runIdentity i)
 
+simpleEvalCon :: Env -> Term -> Id Int
+simpleEvalCon env e =
+    do e' <- simpleEval env e
+       case e' of
+           Con c -> return c
+           _ -> error ("Not a Con: " ++ show e')
+
 simpleEval :: Env -> Term -> Id Term
 simpleEval env (Var v) =
     simpleEval env (maybe (error ("undefined var: " ++ v)) id (lookup v env))
@@ -173,13 +186,13 @@ simpleEval env e@(Con _) =
 simpleEval env e at Incr =
     return (Con 0)
 simpleEval env (Add u v) =
-    do {Con u' <- simpleEval env u;
-	Con v' <- simpleEval env v;
+    do {u' <- simpleEvalCon env u;
+	v' <- simpleEvalCon env v;
 	return (Con (u' + v'))}
     where
     addCons (Con a) (Con b) = return (Con (a+b))
-    addCons (Con _) b = fail ("type error in second arg of Add: " ++ pp b)
-    addCons a (Con _) = fail ("type error in first arg of Add: " ++ pp a)
+    addCons (Con _) b = error ("type error in second arg of Add: " ++ pp b)
+    addCons a (Con _) = error ("type error in first arg of Add: " ++ pp a)
 simpleEval env f@(Lam x b) =
     return (Thunk f env)  -- return a closure!
 simpleEval env (App u v) =
@@ -200,7 +213,7 @@ simpleApply env (Thunk (Lam x b) e) a =
     simpleEval env2 b
     where
     env2 = (x, Thunk a env) : e
-simpleApply env a b         = fail ("bad application: " ++ pp a ++
+simpleApply env a b         = error ("bad application: " ++ pp a ++
 			      "  [ " ++ pp b ++ " ].")
 
 ------------------------------------------------------------