Cacher is the code snippet organizer for pro developers

{-# LANGUAGE BangPatterns #-}

module Main (main) where

import Data.List.Stream hiding (insert, lookup)
import Prelude hiding (lookup, length, foldl, foldl1)
--import Prelude hiding (lookup)
import Control.Monad.State.Strict
import Data.Array.IO
import Data.Map hiding (map)
import Data.IORef

data Expression = EInteger Int | EBoolean Bool | ESymbol String | EDefine String Expression | EPrimitive ([Value] -> RuntimeResult) | EIf Expression Expression Expression | ELambda [String] Expression | EBlock [Expression] | EApplication Expression [Expression]
data Value = VInteger {-# UNPACK #-} !Int | VBoolean {-# UNPACK #-} !Bool | VSymbol {-# UNPACK #-} !(Int, Int) | VFunction {-# UNPACK #-} !([Value] -> RuntimeResult)
type CompileContext = (Map String (Int, Int), Map String Int, Int, IOArray Int Int)
type CompileResult = StateT CompileContext IO RuntimeResult
type RuntimeContext = IOArray Int (IOArray Int Value)
type RuntimeResult = IO Value

instance Show Value where
	show (VInteger x) = show x
	show (VBoolean x) = show x
	show (VSymbol x) = show x
	show (VFunction _) = "<function>"

primitive_lt [VInteger x, VInteger y] = return $! if x < y then VBoolean True else VBoolean False
primitive_add [VInteger x, VInteger y] = return $! VInteger $ x + y
primitive_sub [VInteger x, VInteger y] = return $! VInteger $ x - y

runtimeLookup !context (frame, position) = do
	f <- readArray context frame
	r <- readArray f position
	return $! r

runtimeSet context (frame, position) val = do
	f <- readArray context frame
	writeArray f position val
	return $ VBoolean False

runtimeDefine env r pos = r >>= runtimeSet env (0, pos)

runtimeIf !cond expr1 expr2 = do
	r <- cond
	case r of
		VBoolean True -> expr1
		_ -> expr2

runtimeLambda depth !la env r = return $! VFunction $ \ar -> do
	f <- readArray env depth
	u <- newListArray (0, la) ar
	writeArray env depth u
	x <- r
	writeArray env depth f
	return x

runtimeApplication f args = do
	(VFunction g) <- f
	sequence args >>= g

compileLookup sym = do
	(locals, globals, _, _) <- get
	return $! case lookup sym locals of
		Just value -> value
		Nothing -> case lookup sym globals of
			Just value -> (0, value)

compile :: Expression -> RuntimeContext -> CompileResult
compile (EInteger x) _ = return $ return $! VInteger x
compile (EBoolean x) _ = return $ return $! VBoolean x
compile (ESymbol sym) env = liftM (runtimeLookup env) $ compileLookup sym
compile (EDefine sym val) env = do
	(locals, globals, depth, lengths) <- get
	globalLength <- liftIO $ readArray lengths 0
	liftIO $ writeArray lengths 0 $ globalLength + 1
	put (locals, insert sym globalLength globals, depth, lengths)
	r <- compile val env
	return $ runtimeDefine env r globalLength
compile (EPrimitive f) _ = return $ return $! VFunction f
compile (EIf cond expr1 expr2) env = do
	ccond <- compile cond env
	cexpr1 <- compile expr1 env
	cexpr2 <- compile expr2 env
	return $ runtimeIf ccond cexpr1 cexpr2
compile (ELambda args value) env = do
	(locals, globals, depth, lengths) <- get
	let (newLocals, _) = foldl (\(l, c) s -> (insert s (depth + 1, c) l, c + 1)) (locals, 0) args
	liftIO $ writeArray lengths (depth + 1) (length args)
	put (newLocals, globals, depth + 1, lengths)
	r <- compile value env
	put (locals, globals, depth, lengths)
	return $ runtimeLambda (depth + 1) (length args) env r
compile (EBlock exprs) env = liftM (foldl1 (>>)) $ mapM (\e -> compile e env) exprs
compile (EApplication f args) env = liftM2 runtimeApplication (compile f env) (mapM (\e -> compile e env) args)

main = do
	context <- newArray_ (0, 40)
	lengths <- newArray (0, 40) 0
	mapM_ (aux context) [0..40]
	ctx <- newIORef context
	env <- readIORef ctx
	c <- evalStateT (compile test env) (empty, empty, 0, lengths)
	c >>= print

test = EBlock
	[
		EDefine "+" (EPrimitive primitive_add),
		EDefine "-" (EPrimitive primitive_sub),
		EDefine "<" (EPrimitive primitive_lt),
		EDefine "fib" $ ELambda ["n"] $ EIf
			(EApplication (ESymbol "<") [EInteger 1, ESymbol "n"])
			(EApplication (ESymbol "+")
			[
				EApplication (ESymbol "fib") [EApplication (ESymbol "-") [ESymbol "n", EInteger 1]],
				EApplication (ESymbol "fib") [EApplication (ESymbol "-") [ESymbol "n", EInteger 2]]
			])
			(ESymbol "n"),
		EApplication (ESymbol "fib") [EInteger 25]
	]

aux context k = newArray (0, 35) (VBoolean False) >>= writeArray context k

rem ghc -O2 -auto-all -prof --make slowsilver && slowsilver +RTS -p -hc && hp2ps slowsilver
ghc -O2 -auto-all -prof --make slowsilver && slowsilver +RTS -p