interpreter.hs

{-# language BangPatterns #-}
module Main where

import Criterion.Main
import System.Random

data Expr = Literal Int 
          | Add Expr Expr 
          | Var String
          deriving (Eq, Show)

type Env = Int

testExpr = 
  Add
  (Add
    (Add (Literal 1) (Var "a"))
    (Add (Literal 4) (Var "a")))
  (Add
    (Add (Literal 1) (Var "a"))
    (Add (Literal 4) (Var "a")))

testEnv :: Int -> Env
testEnv n = n

eval :: Expr -> Env -> Int
eval (Literal i) _ = i
eval (Var _) env = env
eval (Add e1 e2) env = (eval e1 env) + (eval e2 env)

eval' :: Expr -> Env -> Int
eval' (Literal i) = lit i
eval' (Var v) = var v
eval' (Add e1 e2) = add (eval' e1) (eval' e2) 

final :: Env -> Int
final env = 
  add
    (add
      (add (lit 1) (var "a")) 
      (add (lit 4) (var "a"))) 
    (add
      (add (lit 1) (var "a")) 
      (add (lit 4) (var "a"))) 
    env

add e1 e2 env = (e1 env) + (e2 env)
lit n _ = n
var _ env = env

setupEnv = do
  gen <- newStdGen
  let rs = randoms gen
  return $ map testEnv (take 100000 rs)

main = defaultMain [
  env setupEnv $ \ ~(es) ->
    bgroup "all" [
      bench "eval'" $ whnf (sum . map (eval' testExpr)) es
    , bench "eval" $ whnf (sum . map (eval testExpr)) es
    , bench "final" $ whnf (sum . map final) es
    ]
  ]