[commit: nofib] master: spectral: revive lambda (5786292)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/5786292b9473b8db8880f13bc5b6b5e254339ec2/nofib

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

commit 5786292b9473b8db8880f13bc5b6b5e254339ec2
Author: Michal Terepeta <michal.terepeta at gmail.com>
Date:   Tue Feb 14 17:00:14 2017 -0500

    spectral: revive lambda
    
    Summary:
    Instead of using the hand rolled monads, this now uses monads from
    `transformers` (shouldn't complicate running the benchmark, since it's
    a boot library).
    
    Signed-off-by: Michal Terepeta <michal.terepeta at gmail.com>
    
    Test Plan: run nofib
    
    Reviewers: bgamari
    
    Reviewed By: bgamari
    
    Differential Revision: https://phabricator.haskell.org/D3079


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

5786292b9473b8db8880f13bc5b6b5e254339ec2
 spectral/Makefile        |  4 ++--
 spectral/lambda/Main.hs  | 50 ++++++++++++++++--------------------------------
 spectral/lambda/Makefile |  2 ++
 3 files changed, 21 insertions(+), 35 deletions(-)

diff --git a/spectral/Makefile b/spectral/Makefile
index 27d3d60..6187c33 100644
--- a/spectral/Makefile
+++ b/spectral/Makefile
@@ -3,13 +3,13 @@ include $(TOP)/mk/boilerplate.mk
 
 SUBDIRS = ansi atom awards banner boyer boyer2 calendar cichelli circsim \
           clausify constraints cryptarithm1 cryptarithm2 cse eliza expert \
-          fft2 fibheaps fish gcd hartel integer knights last-piece lcss life \
+          fft2 fibheaps fish gcd hartel integer knights lambda last-piece lcss life \
 	  mandel mandel2 minimax multiplier para power pretty primetest puzzle \
           rewrite scc simple sorting sphere treejoin
 
 # compreals	no suitable test data
 # salishan	no Haskell code!
-OTHER_SUBDIRS = compreals lambda mate salishan secretary triangle
+OTHER_SUBDIRS = compreals lambda last-piece mate salishan secretary triangle
 
 include $(TOP)/mk/target.mk
 
diff --git a/spectral/lambda/Main.hs b/spectral/lambda/Main.hs
index 59938d1..66bd517 100644
--- a/spectral/lambda/Main.hs
+++ b/spectral/lambda/Main.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Main( main ) where
 
 -- From Mark: marku at cs.waikato.ac.nz [Nov 2001]
@@ -38,6 +40,9 @@ module Main( main ) where
 
 import System.Environment
 
+import Control.Monad.Trans.State.Strict
+import Data.Functor.Identity
+
 main :: IO ()
 main = do { mainSimple ; mainMonad }
 
@@ -81,8 +86,7 @@ type Env = [(String,Term)]
 ----------------------------------------------------------------------
 ev :: Term -> IO (Env,Term)
 ev t =
-    do  let StateMonad2 m = traverseTerm t
-	let (env,t2) = m []
+    do  let (t2, env) = runState (traverseTerm t :: State Env Term) []
 	putStrLn (pp t2 ++ "  " ++ ppenv env)
 	return (env,t2)
 
@@ -102,32 +106,16 @@ class (Monad m) => EvalEnvMonad m where
     withEnv   :: Env -> m a -> m a  -- uses the given environment
     pushVar v t m = do env <- currEnv; withEnv ((v,t):env) m
 
-
--- Here is a monad that evaluates the term.
-newtype StateMonad2 a = StateMonad2 (Env -> (Env,a))
-
-instance (Show a) => Show (StateMonad2 a) where
-    show (StateMonad2 f) = show (f [])
-
-instance Monad StateMonad2  where
-    return a = StateMonad2 (\s -> (s,a))
-    fail msg = StateMonad2 (\s -> (s,error msg))
-    (StateMonad2 g) >>= h =
-	StateMonad2 (\a -> (let (s,a1) = g a in
-			    (let StateMonad2 h' = h a1 in
-			     h' s)))
-
-instance EvalEnvMonad StateMonad2 where
-    incr = StateMonad2 (\s -> (s,()))
+instance EvalEnvMonad (State Env) where
+    incr = return ()
     traverseTerm = eval
-    lookupVar v =
-	StateMonad2 (\env -> (env, lookup2 env))
+    lookupVar v = do
+          env <- get
+          return $ lookup2 env
 	where
-	lookup2 env = maybe (error ("undefined var: " ++ v)) id (lookup v env)
-    currEnv =
-	StateMonad2 (\env -> (env,env))
-    withEnv tmp (StateMonad2 m) =
-	StateMonad2 (\env -> let (_,t) = m tmp in (env,t))
+          lookup2 env = maybe (error ("undefined var: " ++ v)) id (lookup v env)
+    currEnv = get
+    withEnv tmp m = return (evalState m tmp)
 
 
 eval :: (EvalEnvMonad m) => Term -> m Term
@@ -171,15 +159,11 @@ apply a b         = fail ("bad application: " ++ pp a ++
 -- A directly recursive Eval, with explicit environment
 ----------------------------------------------------------------------
 -- A trivial monad so that we can use monad syntax.
-data Id a = Id a
-
-instance Monad Id where
-    return t = Id t
-    fail = error
-    (Id t) >>= f = f t
+newtype Id a = Id (Identity a)
+    deriving (Applicative, Functor, Monad)
 
 instance Show a => Show (Id a) where
-    show (Id t) = show t
+    show (Id i) = show (runIdentity i)
 
 simpleEval :: Env -> Term -> Id Term
 simpleEval env (Var v) =
diff --git a/spectral/lambda/Makefile b/spectral/lambda/Makefile
index 03dcddc..2b33f94 100644
--- a/spectral/lambda/Makefile
+++ b/spectral/lambda/Makefile
@@ -1,6 +1,8 @@
 TOP = ../..
 include $(TOP)/mk/boilerplate.mk
 
+SRC_HC_OPTS += -package transformers
+
 # Arguments for the test program
 PROG_ARGS = 1600