Fiddling with a different abstract machine for nonstrict evaluation

nonstrictvm.hs

module Main where

import Debug.Trace

data Runtime
  = Prim !Int
  | Await !Strictness !(Runtime -> Runtime)
  | App !Runtime !Runtime

whnf :: Runtime -> Runtime
whnf i@(Prim _) = i
whnf a@(Await _ _) = a
whnf (App f x) = case whnf f of
  Await Strict body -> case whnf x of x -> whnf (body x)
  Await Nonstrict body -> whnf (body x)
  _ -> error "cannot apply a non-function"

instance Show Runtime where
  show r = case r of
    Prim n -> show n
    App f x -> show f ++ " " ++ show x
    Await _ _ -> "<await>"

data Strictness = Strict | Nonstrict

nil :: Runtime
nil = Await Strict (\z -> Await Nonstrict (\_ -> z))

int :: Int -> Runtime
int = Prim

cons :: Runtime -> Runtime -> Runtime
cons h t = Await Nonstrict (\_ -> Await Strict (\f -> f `App` h `App` t))

-- Skip over an argument
skip :: Runtime -> Runtime
skip r = Await Nonstrict (\_ -> r)

-- foldl :: ![] -> !(s b -> s2 a -> s b) -> s b -> !b
-- foldl [] !f z = z
-- foldl (h:t) !f z = foldl t f (f z h)

-- Gak, this is pretty ugly
foldlRuntime :: Runtime
foldlRuntime = Await Strict $ \list ->
  list `App` (Await Strict (\_ -> Await Strict id))
       `App` (Await Nonstrict (\h -> Await Nonstrict (\t ->
         Await Strict (\f@(Await strictness _) ->
           Await strictness (\z -> ("z: " ++ show z) `trace`
             foldlRuntime `App` t
                          `App` f
                          `App` (f `App` z `App` h))))))

plus :: Runtime
plus = Await Strict (\x -> case x of
  Prim x -> Await Strict (\y -> case y of
    Prim y -> Prim (x+y)
    _ -> error "second argument to `plus` not a Prim")
  App f x -> error "first argument to `plus` is an `App`"
  _ -> error "first argument to `plus` not a Prim")

nums :: Runtime
nums = foldr cons nil (map int [0..1000])

incr :: Runtime
incr = plus `App` (Await Strict id) `App` int 1

sumExample :: Runtime -- Int
sumExample = foldlRuntime `App` nums `App` plus `App` int 0

add :: Int -> Int -> Int
add x y = x + y

main = case whnf (incr `App` int 41) of
  Prim n -> putStrLn (show n)
  _ -> error "failed"