diff --git a/DirectIO.hs b/DirectIO.hs
new file mode 100644
index 0000000..400a451
--- /dev/null
+++ b/DirectIO.hs
@@ -0,0 +1,414 @@
+{-# LANGUAGE GADTs, ExistentialQuantification, NoImplicitPrelude, Rank2Types #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MagicHash, BangPatterns #-}
+module DirectIO where
+
+import Prelude (Show(..), Monad(..), undefined, String, (++), Int, seq, (+), (-) )
+
+import qualified Data.IORef as Prelude
+import qualified Prelude
+import qualified System.IO.Unsafe as Prelude
+import GHC.Prim (unsafeCoerce#)
+
+data ThreadId = ThreadId (IORef ThreadStatus)
+data ThreadStatus = ThreadFinished | ThreadRunning (ThreadList -> SomeException -> Prelude.IO ())
+
+throwTo :: ThreadId -> SomeException -> IO ()
+throwTo (ThreadId ref) e = do
+  status <- readIORef ref
+  case status of
+    ThreadFinished -> Prelude.error "throwTo: Thread finished."
+    ThreadRunning signal ->
+      -- IO (\tid ts exc cont -> cheat (signal ts))
+      IO (\tid ts exc cont -> cheat (signal (pushThread (\ts' -> cheat (cont ts' ())) ts) e) )
+
+--newtype ThreadList = ThreadList [ThreadList -> Prelude.IO ()]
+type Thread = ThreadList -> Prelude.IO ()
+data ThreadList
+  = Nil
+  | OnePlus !Thread !ThreadList
+  | TwoPlus !Thread !Thread !ThreadList
+  | ThreePlus !Thread !Thread !Thread !ThreadList
+  | FourPlus !Thread !Thread !Thread !Thread !ThreadList
+  | FivePlus !Thread !Thread !Thread !Thread !Thread !ThreadList
+
+emptyThreadList :: ThreadList
+emptyThreadList = Nil
+
+pushThread :: Thread -> ThreadList -> ThreadList
+pushThread elt (OnePlus a ts) = TwoPlus elt a ts
+pushThread elt (TwoPlus a b ts) = ThreePlus elt a b ts
+pushThread elt (ThreePlus a b c ts) = FourPlus elt a b c ts
+pushThread elt (FourPlus a b c d ts) = FivePlus elt a b c d ts
+pushThread elt lst = OnePlus elt lst
+--pushThread elt (ThreadList lst) = ThreadList (elt : lst)
+
+popThread :: ThreadList -> Prelude.IO ()
+popThread ts =
+  case ts of
+    Nil                 -> Prelude.error "No more threads to run."
+    OnePlus thread ts'  -> thread ts'
+    TwoPlus a b ts'     -> a (OnePlus b ts')
+    ThreePlus a b c ts' -> a (TwoPlus b c ts')
+    FourPlus a b c d ts' -> a (ThreePlus b c d ts')
+    FivePlus a b c d e ts' -> a (FourPlus b c d e ts')
+
+{-
+pushThread :: IOPrim a -> Prelude.IO ()
+pushThread prim = Prelude.modifyIORef threadList (\lst -> AnyIOPrim prim : lst)
+
+popThread :: Prelude.IO AnyIOPrim
+popThread = do
+  threads <- Prelude.readIORef threadList
+  case threads of
+    [] -> Prelude.error "No more threads."
+    (x:xs) -> do
+      Prelude.writeIORef threadList xs
+      return x
+-}
+data Bool = True | False
+  deriving (Show)
+
+myThreadId :: IO ThreadId
+myThreadId = IO (\tid ts exc cont -> cont ts tid)
+
+execIO :: IO a -> Prelude.IO a
+execIO io = do
+    status <- Prelude.newIORef (ThreadRunning (Prelude.error "no error handler associated with thread."))
+    let mainThreadId = ThreadId status
+    runIO io mainThreadId emptyThreadList missingExceptionHandler (\_ -> return)
+  where
+    missingExceptionHandler = undefined
+
+data SomeException = SomeException String
+
+newtype IO a = IO { runIO :: forall r. ThreadId -> ThreadList
+                          -> (ThreadList -> SomeException -> Prelude.IO r)
+                          -> (ThreadList -> a -> Prelude.IO r)
+                          -> Prelude.IO r }
+
+instance Monad IO where
+  return a = IO (\tid ts _exc cont -> cont ts a)
+  (>>=) f g = IO (\tid !ts exc cont -> runIO f tid ts exc (\ts' a -> runIO (g a) tid ts' exc cont))
+
+liftIO :: Prelude.IO a -> IO a
+liftIO action = IO (\tid ts exc cont -> action >>= cont ts)
+
+{-
+terminate :: Bool -> IO ()
+terminate False = return ()
+terminate True  = IO (\_ _ -> Terminate)
+
+data AnyIOPrim = forall r. AnyIOPrim { anyIOPrim :: !(IOPrim r) }
+
+data IOPrim a where
+  Unit       :: a -> IOPrim a
+  Terminate  :: IOPrim a
+  NewIORef   :: a -> IOPrim (IORef a)
+  ReadIORef  :: IORef a -> IOPrim a
+  WriteIORef :: IORef a -> a -> IOPrim ()
+  Bind       :: IOPrim a -> (a -> IOPrim b) -> IOPrim b
+  --CFFI :: String -> [PrimType] -> IO PrimType
+  -- BlockingFFI
+  -- NonBlockingFFI
+
+  -- Basic I/O
+  PutStrLn   :: String -> IOPrim ()
+
+  ASyncSpawn :: forall a. IOPrim a -> IOPrim ()
+  Yield      :: IOPrim a
+
+  -- Exception handling
+  --ThrowIO :: SomeException -> IOPrim a
+  --ThrowTo :: ThreadId -> SomeException -> IOPrim a
+  --Catch :: (SomeException -> IOPrim a) -> IOPrim a -> IOPrim a
+
+runIOPrim :: IOPrim a -> Prelude.IO a
+runIOPrim prim =
+  case prim of
+    Unit a           -> return a
+    Terminate        -> Prelude.error "Terminate"
+    NewIORef a       -> Prelude.newIORef a
+    ReadIORef ref    -> Prelude.readIORef ref
+    WriteIORef ref a -> Prelude.writeIORef ref a
+    Bind f g         -> do
+      a <- runIOPrim f
+      runIOPrim (g a)
+
+    PutStrLn str -> Prelude.putStrLn str
+
+    ASyncSpawn prim -> do
+      --Prelude.putStrLn "Spawn"
+      pushThread prim
+    Yield -> do
+      thread <- popThread
+      --Prelude.putStrLn "Yield"
+      case thread of
+        AnyIOPrim prim -> runIOPrim prim >> runIOPrim Yield
+
+
+
+-}
+putStrLn :: String -> IO ()
+putStrLn str = liftIO (Prelude.putStrLn str)
+
+-- Assume IORefs
+type IORef a = Prelude.IORef a
+
+newIORef :: a -> IO (IORef a)
+newIORef a = liftIO (Prelude.newIORef a)
+
+readIORef :: IORef a -> IO a
+readIORef ref = liftIO (Prelude.readIORef ref)
+
+writeIORef :: IORef a -> a -> IO ()
+writeIORef ref a = liftIO (Prelude.writeIORef ref a)
+
+
+newtype MVar a = MVar (IORef (MVarContent a))
+data MVarContent a =
+  MVarEmpty |
+  MVarSingleReader !(a -> ThreadList -> Prelude.IO ())  |
+  --MVarReaders [a -> ThreadList -> Prelude.IO ()] |
+  MVarFull a
+  --MVarWriters a [(a, ThreadList -> Prelude.IO ())]
+
+newEmptyMVar :: IO (MVar a)
+newEmptyMVar = do
+  ref <- newIORef MVarEmpty
+  return (MVar ref)
+
+takeMVar :: MVar a -> IO a
+takeMVar (MVar ref) = IO (\tid ts exc cont -> do
+  content <- Prelude.readIORef ref
+  case content of
+    MVarEmpty -> do
+      let elt = (\a ts -> cheat (cont ts a) )
+      Prelude.writeIORef ref (MVarSingleReader elt)
+      yieldIO ts
+    {-MVarSingleReader elt -> do
+      let lst' = (\a ts -> cheat (cont ts a) ) : [elt]
+      Prelude.writeIORef ref (MVarReaders lst')
+      yieldIO ts-}
+    {-MVarReaders lst -> do
+      let lst' = (\a ts -> cheat (cont ts a) ) : lst
+      Prelude.writeIORef ref (MVarReaders lst')
+      yieldIO ts-}
+    MVarFull a -> do
+      Prelude.writeIORef ref MVarEmpty
+      cont ts a
+    {-MVarWriters a [] -> do
+      Prelude.writeIORef ref MVarEmpty 
+      cont ts a
+    MVarWriters a [(a',x)] -> do
+      Prelude.writeIORef ref (MVarFull a')
+      cont ts a
+    MVarWriters a ((a',x):xs) -> do
+      Prelude.writeIORef ref (MVarWriters a' xs)
+      cont ts a-}
+  )
+
+putMVar :: MVar a -> a -> IO ()
+putMVar (MVar ref) a = IO (\tid ts exc cont -> do
+  content <- Prelude.readIORef ref
+  case content of
+    MVarEmpty -> do
+      Prelude.writeIORef ref (MVarFull a)
+      cont ts ()
+    {-MVarReaders [] -> do
+      Prelude.writeIORef ref (MVarFull a)
+      cont ts ()-}
+    MVarSingleReader x -> do
+      Prelude.writeIORef ref MVarEmpty
+      cont (pushThread (x a) ts) ()
+    {-MVarReaders (x:xs) -> do
+      Prelude.writeIORef ref (MVarReaders xs) 
+      cont (pushThread (x a) ts) ()-}
+    {-MVarFull orig -> do
+      Prelude.writeIORef ref (MVarWriters orig [(a, \ts -> cheat (cont ts ()) ) ]) 
+      yieldIO ts-}
+    {-MVarWriters orig lst -> do
+      Prelude.writeIORef ref (MVarWriters orig ((a, \ts -> cheat (cont ts ()) ) : lst))
+      yieldIO ts-}
+  )
+
+cheat :: Prelude.IO a -> Prelude.IO b
+cheat = unsafeCoerce#
+
+spawn :: IO () -> IO ()
+spawn io = IO (\tid ts exc cont -> cont (pushThread (\ts -> runIO io (ThreadId undefined) ts undefined (\ts () -> yieldIO ts)) ts) ())
+--spawn io = IO (\exc cont -> ASyncSpawn ((runIO io missingExceptionHandler Unit))
+--                            `Bind` cont)
+
+--yield :: IO a
+--yield = IO (\ts exc cont -> yieldIO ts)
+
+yieldIO :: ThreadList -> Prelude.IO a
+yieldIO ts = cheat (popThread ts)
+--yieldIO (ThreadList [])     = Prelude.error "All threads have finished."
+--yieldIO (ThreadList (x:xs)) = do
+--    cheat (x (ThreadList xs))
+{-
+
+missingExceptionHandler :: SomeException -> IOPrim a
+missingExceptionHandler (SomeException val) =
+  PutStrLn ("Exception reached top-level without being catched: " ++ show val)
+  `Bind` \() -> Terminate
+-}
+
+testProgram :: IO ()
+testProgram = do
+  ref <- newEmptyMVar
+  spawn (putMVar ref True)
+  val <- takeMVar ref
+  putStrLn ("Boolean: " ++ show val)
+{-
+testException :: IO String
+testException = do
+  throwIO (SomeException True)
+    `catch` \_ -> return "Caught exception."
+-}
+
+testThrowTo :: IO ()
+testThrowTo = do
+  tid <- myThreadId
+  handle (\(SomeException e) -> putStrLn ("E: " ++ show e))
+    (do putStrLn "Inside exception handler."
+        throwTo tid (SomeException "Catch me!")
+        putStrLn "This should not be seen."
+    )
+  putStrLn "This should be seen."
+
+testUserThread :: Int -> IO ()
+testUserThread n = do
+  e <- newEmptyMVar
+  o <- createMany n e
+  putMVar e 0
+  l <- takeMVar o
+  putStrLn ("Out: " ++ show l)
+
+createMany :: Int -> MVar Int -> IO (MVar Int)
+createMany 0 v = return v
+createMany n v = do
+  o <- newEmptyMVar
+  spawn (copy v o)
+  createMany (n-1) o
+
+copy :: MVar Int -> MVar Int -> IO ()
+copy i o = do
+  n <- takeMVar i
+  let n'  = n+1
+  seq n' (putMVar o n')
+  copy i o
+{-
+testYield :: IO Bool
+testYield = IO (\ext cont -> Yield)
+
+testReturn :: IO Bool
+testReturn = return True
+
+
+{-
+
+fn = do
+  v <- store ...
+  a <- fnA v
+  b <- fnB v
+  return a+b
+
+fn = \cont ->
+  store ... (\v ->
+    fnA v (\a ->
+      fnB v (\b ->
+        cont (a+b)
+      )
+    )
+  )
+
+fn = \cont ->
+  store_fn ... cont
+
+store_fn ... cont =
+  if no heap
+    mark_root cont
+    do_gc
+
+  let v = ...
+  fn_fnA v cont
+
+fn_fnA v cont =
+  let a = ...
+  fn_fnB v a cont
+
+fn_fnB v a cont =
+  let b = ...
+  cont (a+b)
+
+gc_alloc :: (Ptr -> IO a) -> Int -> IO a
+
+
+
+foreign import "prim cont" unsafePerformIO :: IO a -> a
+
+mkContinuation :: ((a -> IOPrim r) -> IOPrim r) -> a
+
+unsafePerformIO :: IO a -> a
+unsafePerformIO io = mkContinuation $ \cont ->
+  runIO io cont
+
+
+
+-}
+
+
+unsafeCoerce :: a -> b
+unsafeCoerce = undefined
+
+data Any
+
+data SomeException = forall x. Show x => SomeException x
+
+-}
+throwIO :: SomeException -> IO a
+throwIO e = IO (\tid ts exc _ -> exc ts e)
+
+--throw :: SomeException -> a
+--throw e = mkContinuation (\exc _ -> exc e)
+
+handle :: (SomeException -> IO a) -> IO a -> IO a
+handle = Prelude.flip catch
+
+catch :: IO a -> (SomeException -> IO a) -> IO a
+catch action handler = IO (\tid@(ThreadId ref) ts exc cont -> do
+    status <- Prelude.readIORef ref
+    let restore = Prelude.writeIORef ref status
+    Prelude.writeIORef ref (ThreadRunning (\ts' e -> restore >> cheat (runIO (handler e) tid ts' exc cont)))
+    runIO action tid ts (\ts' e -> restore >> runIO (handler e) tid ts' exc cont ) (\ts val -> restore >> cont ts val)
+  )
+
+-- Primitive.
+--foreign import ccall mkContinuation :: ((a -> IOPrim r) -> IOPrim r) -> a
+--mkContinuation :: ( (SomeException -> IOPrim r) ->
+--                    (a -> IOPrim r) ->
+--                    IOPrim r)
+--               -> a
+--mkContinuation = undefined
+
+
+--unsafePerformIO :: IO a -> a
+--unsafePerformIO io = mkContinuation (\exc cont -> runIO io exc cont)
+
+{-
+
+{-
+ioFromPure cont = runIO getLine cont
+-}
+data Addr = Addr
+gc_alloc :: (Addr -> IOPrim a) -> IOPrim a
+gc_alloc cont = undefined
+
+-}
+
+
+
+
diff --git a/bedrock/LICENSE b/bedrock/LICENSE
new file mode 100644
index 0000000..e69de29
diff --git a/bedrock/Setup.hs b/bedrock/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/bedrock/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/bedrock/TODO b/bedrock/TODO
new file mode 100644
index 0000000..e69de29
diff --git a/bedrock/bedrock.cabal b/bedrock/bedrock.cabal
new file mode 100644
index 0000000..395d331
--- /dev/null
+++ b/bedrock/bedrock.cabal
@@ -0,0 +1,25 @@
+-- Initial bedrock.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                bedrock
+version:             0.1.0.0
+-- synopsis:            
+-- description:         
+license:             PublicDomain
+license-file:        LICENSE
+-- author:              
+-- maintainer:          
+-- copyright:           
+-- category:            
+build-type:          Simple
+cabal-version:       >=1.8
+
+library
+  Hs-source-dirs:      src
+  exposed-modules:     Data.Bedrock,
+                       Data.Bedrock.Exceptions,
+                       Data.Bedrock.TypeCheck,
+                       Data.Bedrock.Evaluate
+  -- other-modules:       
+  build-depends:       base ==4.6.*, ansi-wl-pprint,
+                       parsec, containers, mtl
\ No newline at end of file
diff --git a/bedrock/examples/HOF.rock b/bedrock/examples/HOF.rock
new file mode 100644
index 0000000..e69de29
diff --git a/bedrock/examples/HelloException.rock b/bedrock/examples/HelloException.rock
new file mode 100644
index 0000000..428b5f6
--- /dev/null
+++ b/bedrock/examples/HelloException.rock
@@ -0,0 +1,22 @@
+main =
+    value, n := @withExceptionHandler exceptionHandler() throwException( (False) );
+    @print value;
+    @print n;
+	
+    value, n := @withExceptionHandler exceptionHandler() throwException( (True) );
+    @print value;
+    @print n;
+
+    @return()
+
+exceptionHandler exception =
+    @return (exception, 1)
+
+throwException input =
+	case input of
+		True ->
+			@throw (Exception)
+		| False ->
+			@return( (NoException), 0 )
+
+
diff --git a/bedrock/examples/HelloWorld.rock b/bedrock/examples/HelloWorld.rock
new file mode 100644
index 0000000..c90960c
--- /dev/null
+++ b/bedrock/examples/HelloWorld.rock
@@ -0,0 +1,4 @@
+main =
+	ptr := @store (HelloWorld);
+	@print ptr;
+	@exit
\ No newline at end of file
diff --git a/bedrock/examples/example.rock b/bedrock/examples/example.rock
new file mode 100644
index 0000000..8bc45dd
--- /dev/null
+++ b/bedrock/examples/example.rock
@@ -0,0 +1,69 @@
+getHead ptr =
+	list := @fetch ptr;
+	case list of
+		  Nil ->
+		  	@alloc 2;
+			e := @store (Error 1);
+			@throw e
+	  	| Cons head tail ->
+			@unit head
+
+getHeadCps ptr exh cont =
+	list := @fetch ptr;
+	case list of
+		  Nil ->
+		  	@alloc 2;
+		  	e := @store (Error 1);
+			@tail apply exh, e
+	  	| Cons head tail ->
+			@tail apply cont, head
+
+storeLength exh cont = 
+	@alloc 3;
+	p := @store (lengthCps);
+	@tail apply cont, Just p
+
+length listPtr =
+	list := @fetch listPtr;
+	case list of
+		Nil ->
+			@unit 0
+		| Cons head tail ->
+			v := length tail;
+			l := @add v 1;
+			@unit l
+
+lengthCps listPtr cont =
+	list := @fetch listPtr;
+	case list of
+		Nil ->
+			@tail apply cont, 0
+		| Cons head tail ->
+			@alloc 2;
+			newCont := @store (lengthCps cont);
+			@tail lengthCps tail, newCont
+
+lengthCps cont n =
+	l := @add v 1;
+	@tail apply cont, l
+
+apply partial arg =
+	fn := @fetch partial;
+	case fn of
+		lengthCps cont _ ->
+			@tail lengthCps cont, arg
+		| printResult _ ->
+			@tail printResult arg
+
+throw e cont =
+	case cont of
+		lengthCps cont2 _ ->
+			@tail throw e, cont2
+		| ExceptionHandler handler cont ->
+			@tail handler e,cont
+
+withExceptionHandler cont handler partial =
+	exh := @store (ExceptionHandler handler, cont);
+	@tail apply partial, exh
+
+
diff --git a/bedrock/examples/exceptions.rock b/bedrock/examples/exceptions.rock
new file mode 100644
index 0000000..e26f9f0
--- /dev/null
+++ b/bedrock/examples/exceptions.rock
@@ -0,0 +1,24 @@
+unsafeHead listPtr =
+    list := @fetch listPtr;
+    case listPtr of
+        Nil ->
+            e := @store (EmptyListException);
+            @throw e
+        | Cons head tail ->
+            @unit(head)
+
+safeHead onEmpty listPtr =
+    val := @withExceptionHandler safeHeadHandler(onEmpty) unsafeHead(listPtr);
+    @unit(val)
+
+safeHeadHandler onEmpty exception =
+    @unit(onEmpty)
+
+
+plus a b =
+    @unit()
+
+suspendedFunction =
+    ptr := @store (plus 10 _);
+    unsafeHead(ptr);
+    @unit()
\ No newline at end of file
diff --git a/bedrock/src/Data/Bedrock.hs b/bedrock/src/Data/Bedrock.hs
new file mode 100644
index 0000000..d2b83bf
--- /dev/null
+++ b/bedrock/src/Data/Bedrock.hs
@@ -0,0 +1,75 @@
+module Data.Bedrock where
+
+data Name = Name
+	{ nameModule     :: [String]
+	, nameIdentifier :: String
+	, nameUnique     :: Int
+	} deriving (Show, Eq, Ord)
+data Type = NodePtr | RawNode | Primitive | MissingType
+	deriving (Show, Eq, Ord)
+data Variable = Variable
+	{ variableName :: Name
+	, variableType :: Type
+	} deriving (Show, Eq, Ord)
+
+data Module = Module
+	{ nodes     ::     [Node]
+	, functions :: [Function]
+	-- CAFs?
+	}
+
+data NodeName
+	= ConstructorName Name
+	| FunctionName Name Int
+		-- ^ name of the function and the number of missing arguments.
+	deriving (Show, Eq)
+
+data Node = Node
+	deriving (Show)
+
+data Function = Function
+	{ fnName      :: Name
+	, fnArguments :: [Variable]
+	, fnBody      :: Expression
+	} deriving (Show)
+
+data Pattern
+	= NodePat NodeName [Variable]
+	| LitPat Literal
+	deriving (Show)
+data Alternative = Alternative Pattern Expression
+	deriving (Show)
+
+data Literal
+	= LiteralInt Integer -- compile error if Integer to too large
+	deriving (Show, Eq)
+
+data Argument
+	= RefArg Variable
+	| LitArg Literal
+	| NodeArg NodeName [Argument]
+	deriving (Show)
+
+data SimpleExpression
+	= Literal Literal
+	| Application Name [Argument]
+	| WithExceptionHandler Name [Argument] Name [Argument]
+	-- Built-in
+	| Alloc Int
+	| Store NodeName [Argument]
+	| Fetch Variable
+	| Load Variable Int
+	| Add Argument Argument
+	| Print Variable
+	deriving (Show)
+
+data Expression
+	= Case Variable [Alternative] (Maybe Expression)
+	| Bind [Variable] SimpleExpression Expression
+	| Return [Argument]
+	| Throw Argument
+	| TailCall Name [Argument]
+	| Invoke Variable [Argument]
+	| Exit
+	deriving (Show)
+
diff --git a/bedrock/src/Data/Bedrock/Evaluate.hs b/bedrock/src/Data/Bedrock/Evaluate.hs
new file mode 100644
index 0000000..88f7042
--- /dev/null
+++ b/bedrock/src/Data/Bedrock/Evaluate.hs
@@ -0,0 +1,213 @@
+module Data.Bedrock.Evaluate where
+
+import           Control.Applicative           ((<$>))
+import           Control.Monad.RWS
+import           Data.Map                      (Map)
+import qualified Data.Map                      as Map
+import           Text.ParserCombinators.Parsec (parseFromFile)
+import qualified Text.PrettyPrint.ANSI.Leijen  as Doc
+import Data.List
+
+import           Data.Bedrock
+import           Data.Bedrock.Exceptions
+import           Data.Bedrock.Parse
+import           Data.Bedrock.PrettyPrint
+
+type HeapPtr = Int
+data Value
+    = LitValue Literal
+    | NodeValue NodeName [Value]
+    | HeapPtrValue HeapPtr
+    deriving (Show)
+data Env = Env
+    { envFunctions :: Map Name Function
+    , envHeap      :: Map HeapPtr Value
+    , envHeapPtr   :: HeapPtr
+    }
+type Scope = Map Variable Value
+type Eval a = RWST Scope () Env IO a
+
+-- FIXME: Enforce that only nodes are written to the heap.
+pushHeapValue :: Value -> Eval HeapPtr
+pushHeapValue val = do
+    ptr <- gets envHeapPtr
+    modify $ \st -> st{ envHeapPtr = ptr+1
+                      , envHeap = Map.insert ptr val (envHeap st) }
+    return ptr
+
+fetchHeapValue :: HeapPtr -> Eval Value
+fetchHeapValue ptr = do
+    mbValue <- gets (Map.lookup ptr . envHeap)
+    case mbValue of
+        Nothing  -> error "Broken heap ptr"
+        Just val -> return val
+
+queryScope :: Variable -> Eval Value
+queryScope var = do
+    mbValue <- asks (Map.lookup var)
+    case mbValue of
+        Nothing -> error $ "Not in scope: " ++ show var
+        Just val -> return val
+
+lookupFunction :: Name -> Eval Function
+lookupFunction name = do
+    mbFn <- gets (Map.lookup name . envFunctions)
+    case mbFn of
+        Nothing -> error $ "Missing function: " ++ show (ppName name)
+        Just fn -> return fn
+
+
+
+evaluateFromFile :: FilePath -> Name -> IO ()
+evaluateFromFile path entryPoint = do
+    ret <- parseFromFile parseModule path
+    case ret of
+        Left err -> print err
+        Right m  -> do
+            let m' = runGen m $ cpsTransformation m
+            print (ppModule m')
+            evaluate m' entryPoint
+
+
+evaluate :: Module -> Name -> IO ()
+evaluate m entryPoint = do
+    _ <- evalRWST entry Map.empty env
+    return ()
+  where
+    env = Env
+        { envFunctions = Map.fromList [ (fnName fn, fn) | fn <- functions m ]
+        , envHeap      = Map.empty
+        , envHeapPtr   = 0 }
+    entry = evalFunction entryPoint [LitValue $ LiteralInt 0]
+
+evalFunction :: Name -> [Value] -> Eval [Value]
+evalFunction name args = do
+    fn <- lookupFunction name
+    let newScope = Map.fromList $ zip (fnArguments fn) args
+    local (Map.union newScope)
+        (evalExpression (fnBody fn))
+
+evalExpression :: Expression -> Eval [Value]
+evalExpression expression =
+    case expression of
+        Case scrut alternatives _defaultBranch -> do
+            value <- queryScope scrut
+            evalAlternative value alternatives
+        Bind binds simple rest -> do
+            values <- evalSimple simple
+            let newScope = Map.fromList $ zip binds values
+            local (Map.union newScope) $
+                evalExpression rest
+        TailCall fn args ->
+            evalFunction fn =<< mapM evalArgument args
+        Exit ->
+            return []
+        Invoke cont args ->
+            evalApply cont args
+        other -> error $ "Unhandled code: " ++ show other
+
+evalAlternative :: Value -> [Alternative] -> Eval [Value]
+evalAlternative _value [] = error "No matching branches"
+evalAlternative value (Alternative pattern branch:alts) =
+    case (value, pattern) of
+        (LitValue lit, LitPat litBranch) | lit == litBranch ->
+            evalExpression branch
+        (NodeValue name values, NodePat nameBranch binds) | name == nameBranch ->
+            let newScope = Map.fromList $ zip binds values in
+            local (Map.union newScope)
+                (evalExpression branch)
+        _ -> evalAlternative value alts
+
+evalSimple :: SimpleExpression -> Eval [Value]
+evalSimple simple =
+    case simple of
+        Literal lit -> return [LitValue lit]
+        --Application fn args -> undefined
+        Store name args -> do
+            argValues <- mapM evalArgument args
+            ptr <- pushHeapValue (NodeValue name argValues)
+            return [HeapPtrValue ptr]
+        Fetch var -> do
+            HeapPtrValue ptr <- queryScope var
+            value <- fetchHeapValue ptr
+            return [value]
+        Print var -> do
+            value <- queryScope var
+            liftIO $ putStr (show (ppVariable var) ++ " = ")
+            trace <- traceValue value
+            liftIO $ putStrLn trace
+            return []
+        _ -> error $ "Unhandled expr: " ++ show simple
+
+evalArgument :: Argument -> Eval Value
+evalArgument argument =
+    case argument of
+        RefArg var -> queryScope var
+        LitArg lit -> return (LitValue lit)
+        NodeArg name args -> NodeValue name <$> mapM evalArgument args
+
+traceValue :: Value -> Eval String
+traceValue value =
+    case value of
+        LitValue lit        -> return $ show lit
+        NodeValue name args -> do
+            args' <- mapM traceValue args
+            return $ show $ ppNode name (map Doc.text args')
+        HeapPtrValue ptr    -> do
+            trace <- traceValue =<< fetchHeapValue ptr
+            return $ "Heap (" ++ trace ++ ")"
+
+evalApply :: Variable -> [Argument] -> Eval [Value]
+evalApply continuationVar args = do
+    args' <- mapM evalArgument args
+    continuation <- queryScope continuationVar
+    activateFunctionFrame continuation args'
+
+
+data FrameDescription
+    = FunctionFrame
+    | ExceptionHandlerFrame Value
+unpackFrame :: Value -> Eval (FrameDescription, (Name, Int, [Value]))
+unpackFrame = loop
+  where
+    loop (HeapPtrValue ptr) = loop =<< fetchHeapValue ptr
+    loop (NodeValue
+            (ConstructorName name)
+            [continuation, NodeValue (FunctionName handlerName blanks) args])
+        | name == exhFrameName =
+        return ( ExceptionHandlerFrame continuation
+               , (handlerName, blanks, args))
+    loop (NodeValue (FunctionName name blanks) args) =
+        return (FunctionFrame, (name, blanks, args))
+
+skipFrame :: (Name, Int, [Value]) -> Eval Value
+skipFrame (name, _blanks, partialArgs) = do
+    fn <- lookupFunction name
+    case elemIndex stdContinuation (fnArguments fn) of
+        Just index -> do
+            liftIO $ putStrLn $ "Found normal frame: " ++ show (ppName name)
+            return (partialArgs!!index)
+        Nothing    -> do
+            error "Invalid frame"
+
+activateFrame :: (Name, Int, [Value]) -> [Value] -> Eval [Value]
+activateFrame (name, blanks, partialArgs) args = do
+    unless (blanks == length args) $ error "arity mismatch"
+    evalFunction name (partialArgs ++ args)
+
+activateFunctionFrame :: Value -> [Value] -> Eval [Value]
+activateFunctionFrame frame args = do
+    (descr, info) <- unpackFrame frame
+    case descr of
+        FunctionFrame -> activateFrame info args
+        ExceptionHandlerFrame continuation ->
+            activateFunctionFrame continuation args
+
+activateExceptionFrame :: Value -> [Value] -> Eval [Value]
+activateExceptionFrame frame args = do
+    (descr, info) <- unpackFrame frame
+    case descr of
+        FunctionFrame ->
+            flip activateExceptionFrame args =<< skipFrame info
+        ExceptionHandlerFrame continuation ->
+            activateFrame info (args ++ [continuation])
diff --git a/bedrock/src/Data/Bedrock/Exceptions.hs b/bedrock/src/Data/Bedrock/Exceptions.hs
new file mode 100644
index 0000000..774d4d0
--- /dev/null
+++ b/bedrock/src/Data/Bedrock/Exceptions.hs
@@ -0,0 +1,252 @@
+module Data.Bedrock.Exceptions
+    ( runGen
+    , cpsTransformation
+    , loadFile
+    , stdContinuation
+    , exhFrameName
+    ) where
+
+import           Control.Applicative           (pure, (<$>), (<*>))
+import           Control.Monad.State
+import           Data.List                     ((\\), elemIndices)
+import           Data.Set                      (Set)
+import qualified Data.Set                      as Set
+import           Data.Map                     (Map)
+import qualified Data.Map                      as Map
+import           Text.ParserCombinators.Parsec (parseFromFile)
+
+import           Data.Bedrock
+import           Data.Bedrock.Parse
+import           Data.Bedrock.PrettyPrint
+
+
+data Env = Env
+    { envModule    :: Module
+    , envUnique    :: Int
+    , envFunctions :: Map Name Function }
+type Gen a = State Env a
+
+modifyModule :: (Module -> Module) -> Gen ()
+modifyModule fn = modify $ \st -> st{envModule = fn (envModule st)}
+
+pushFunction :: Function -> Gen ()
+pushFunction fn = modifyModule $ \m -> m{functions = functions m ++ [fn]}
+
+newUnique :: Gen Int
+newUnique = do
+    u <- gets envUnique
+    modify $ \st -> st{envUnique = u+1}
+    return u
+
+-- FIXME: This is O(n)
+--lookupFunction :: Name -> Gen Function
+--lookupFunction name = do
+--    funcs <- gets envFunctions
+--    case Map.lookup name funcs of
+--        Just fn -> return fn
+--        Nothing -> error $ "Missing function: " ++ show name
+
+runGen :: Module -> Gen a -> Module
+runGen initModule gen =
+    envModule (execState gen m)
+  where
+    m = Env
+        { envModule = Module [] []
+        , envUnique = 0
+        , envFunctions = Map.fromList
+            [ (fnName fn, fn) | fn <- functions initModule]
+        }
+
+
+cpsTransformation :: Module -> Gen ()
+cpsTransformation m = do
+    mapM_ cpsFunction (functions m)
+    mkThrowTo
+
+mkThrowTo :: Gen ()
+mkThrowTo = do
+    fns <- gets (functions . envModule)
+
+    let thisContinuationPtr = Variable (Name [] "thisContPtr" 0) NodePtr
+        thisContinuation = Variable (Name [] "thisCont" 0) RawNode
+        exception = Variable (Name [] "exception" 0) NodePtr
+        handler = Variable (Name [] "handler" 0) RawNode
+        body =
+            Bind [thisContinuation] (Fetch thisContinuationPtr) $
+            Case thisContinuation (exhAlternative:alternatives) Nothing 
+        exhAlternative =
+            Alternative
+                (NodePat
+                    (ConstructorName exhFrameName)
+                    [thisContinuationPtr, handler])
+                (Invoke handler [RefArg exception, RefArg thisContinuationPtr])
+        alternatives =
+            [ Alternative
+                (NodePat
+                    (FunctionName (fnName fn) blanks)
+                    (reverse . drop blanks . reverse $ fnArguments fn))
+                (TailCall throwToName
+                    (map RefArg [fnArguments fn !! idx, exception]))
+            | fn <- fns
+            , idx <- elemIndices stdContinuation (fnArguments fn)
+            , blanks <- [0 .. length (fnArguments fn) - 1 - idx] ]
+    pushFunction Function
+        { fnName = throwToName
+        , fnArguments = [thisContinuationPtr, exception]
+        , fnBody = body }
+
+throwToName :: Name
+throwToName = Name [] "throwTo" 0
+
+cpsFunction :: Function -> Gen ()
+cpsFunction fn = do
+    body <- cpsExpression fn (fnBody fn)
+    let fn' = fn{fnArguments = fnArguments fn ++ [stdContinuation]
+                ,fnBody = body}
+    pushFunction fn'
+
+cpsExpression :: Function -> Expression -> Gen Expression
+cpsExpression origin expression =
+    case expression of
+        Bind binds simple rest ->
+            cpsSimpleExpresion origin binds simple =<<
+                cpsExpression origin rest
+        Return args ->
+            return $ Invoke stdContinuation args
+        Case scrut alternatives defaultBranch ->
+            Case scrut
+                <$> mapM (cpsAlternative origin) alternatives
+                <*> pure defaultBranch
+        Throw exception ->
+            --return $ ThrowTo stdContinuation exception
+            return $ TailCall throwToName [RefArg stdContinuation, exception]
+        other -> return other
+
+tagName :: String -> Name -> Gen Name
+tagName tag name = do
+    u <- newUnique
+    return $ name{ nameIdentifier = nameIdentifier name ++ "_" ++ tag
+                 , nameUnique = u}
+
+exhFrameName :: Name
+exhFrameName = Name [] "ExceptionFrame" 0
+
+cpsSimpleExpresion :: Function -> [Variable]
+                   -> SimpleExpression -> Expression -> Gen Expression
+cpsSimpleExpresion origin binds simple rest =
+    case simple of
+        WithExceptionHandler exh exhArgs fn fnArgs -> do
+            exFrameName <- tagName ("exception_frame") (fnName origin)
+            let exceptionFrame = Variable
+                    { variableName = exFrameName
+                    , variableType = NodePtr }
+
+            -- We have to create an indirection to shuffle
+            -- around the arguments to the exception handler.
+            -- This indirection can be removed later.
+            --indirectName <- tagName "indirect" exh
+            --exhFn <- lookupFunction exh
+            --pushFunction Function
+            --    { fnName      = indirectName
+            --    , fnArguments = init (fnArguments exhFn) ++
+            --                    [stdContinuation, last (fnArguments exhFn)]
+            --    , fnBody      = TailCall exh
+            --        (map RefArg $ fnArguments exhFn ++ [stdContinuation])
+            --    }
+            mkContinuation $ \continuationFrame ->
+                Bind [exceptionFrame]
+                    (Store (ConstructorName exhFrameName)
+                        [ continuationFrame
+                        , NodeArg (FunctionName exh 2) exhArgs ]) $
+                TailCall fn (fnArgs ++ [RefArg exceptionFrame])
+        Application fn fnArgs ->
+            mkContinuation $ \continuationFrame ->
+                TailCall fn (fnArgs ++ [continuationFrame])
+        Store (FunctionName fn blanks) args ->
+            return $ Bind binds (Store (FunctionName fn (blanks+1)) args) rest
+        other -> return $ Bind binds other rest
+  where    
+    mkContinuation use = do
+        cFrameName <- tagName ("frame") (fnName origin)
+        let stdContinuationFrame = Variable
+                { variableName = cFrameName
+                , variableType = NodePtr }
+    
+        let continuationArgs = (Set.toList (freeVariables rest) \\ binds)
+        contFnName <- tagName "continuation" (fnName origin)
+        pushFunction $
+            Function { fnName      = contFnName
+                     , fnArguments = continuationArgs ++ binds
+                     , fnBody      = rest }
+        return $
+            Bind [stdContinuationFrame]
+                (Store (FunctionName contFnName (length binds))
+                    (map RefArg continuationArgs)) $
+            use (RefArg stdContinuationFrame)
+
+cpsAlternative :: Function -> Alternative -> Gen Alternative
+cpsAlternative origin alternative =
+    case alternative of
+        Alternative pattern expr ->
+            Alternative pattern <$> cpsExpression origin expr
+
+freeVariables :: Expression -> Set Variable
+freeVariables expr = freeVariables' expr Set.empty
+
+freeVariables' :: Expression -> Set Variable -> Set Variable
+freeVariables' expression =
+    case expression of
+        Case scrut alternatives _defaultBranch ->
+            foldr (.) (Set.insert scrut)
+            [ freeVariables' branch
+            | Alternative _pattern branch <- alternatives ]
+        Bind binds simple rest ->
+            freeVariablesSimple simple .
+            flip Set.difference (Set.fromList binds) .
+            freeVariables' rest
+        Return args ->
+            freeVariablesArguments args
+        Throw name ->
+            freeVariablesArguments [name]
+        Invoke cont args ->
+            Set.insert cont . freeVariablesArguments args
+        TailCall _name args ->
+            freeVariablesArguments args
+        Exit ->
+            id
+
+freeVariablesSimple :: SimpleExpression -> Set Variable -> Set Variable
+freeVariablesSimple simple =
+    case simple of
+        Literal{} ->
+            id
+        Application _fn args ->
+            freeVariablesArguments args
+        WithExceptionHandler _exh exhArgs _fn fnArgs ->
+            freeVariablesArguments exhArgs . freeVariablesArguments fnArgs
+        Alloc{} ->
+            id
+        Store _constructor args ->
+            freeVariablesArguments args
+        Fetch ptr ->
+            Set.insert ptr
+        Load ptr _idx ->
+            Set.insert ptr
+        Add lhs rhs ->
+            freeVariablesArguments [lhs,rhs]
+        Print var ->
+            Set.insert var
+
+freeVariablesArguments :: [Argument] -> Set Variable -> Set Variable
+freeVariablesArguments args =
+    Set.union (Set.fromList [ name | RefArg name <- args ])
+
+stdContinuation :: Variable
+stdContinuation = Variable (Name [] "cont" 0) NodePtr
+
+loadFile :: FilePath -> IO ()
+loadFile path = do
+    ret <- parseFromFile parseModule path
+    case ret of
+        Left err -> print err
+        Right m  -> print (ppModule $ runGen m $ cpsTransformation m)
diff --git a/bedrock/src/Data/Bedrock/Parse.hs b/bedrock/src/Data/Bedrock/Parse.hs
new file mode 100644
index 0000000..68711a8
--- /dev/null
+++ b/bedrock/src/Data/Bedrock/Parse.hs
@@ -0,0 +1,185 @@
+module Data.Bedrock.Parse where
+
+import           Control.Applicative           (pure, (*>), (<$>), (<*), (<*>))
+import           Control.Monad                 (guard)
+import           Data.Char
+import           Text.ParserCombinators.Parsec
+
+import Data.Bedrock
+
+-------------------------------------------------------------------------------
+-- Parsing
+
+parseName :: Parser Name
+parseName = Name <$> pure [] <*> many1 alphaNum <*> pure 0
+
+parseType :: Parser Type
+parseType = choice (map try
+	[ string "ptr" >> return NodePtr
+	, string "node" >> return RawNode
+	, string "prim" >> return Primitive ])
+	<?> "type"
+
+parseVariable :: Parser Variable
+parseVariable = do
+	name <- parseName
+	guard (isLower (head (nameIdentifier name)))
+	ty <- (char ':' *> parseType) <|> return NodePtr
+	return Variable{ variableName = name, variableType = ty }
+
+parseFunction :: Parser Function
+parseFunction = do
+	name <- parseName <* spaces
+	args <- parseVariable `endBy` spaces
+	char '='; spaces
+	body <- parseExpression
+	return (Function name args body)
+
+-- FIXME: Parse nodes
+parseArgument :: Parser Argument
+parseArgument =
+	RefArg <$> try parseVariable <|>
+	LitArg <$> parseLiteral <|>
+	(parens $ do
+		constructor <- parseConstructor <* spaces
+		binds <- many (spaces *> parseArgument <* spaces)
+		return $ NodeArg (ConstructorName constructor) binds) <|>
+	(parens $ do
+		fn <- parseName <* spaces
+		binds <- many (spaces *> parseArgument <* spaces)
+		blanks <- many (spaces *> char '_' <* spaces)
+		return $ NodeArg (FunctionName fn (length blanks)) binds)
+	<?> "argument"
+
+parseArguments :: Parser [Argument]
+parseArguments = (spaces *> parseArgument <* spaces) `sepBy` char ','
+
+parseNames :: Parser [Name]
+parseNames = (spaces *> parseName <* spaces) `sepBy` char ','
+
+parseVariables :: Parser [Variable]
+parseVariables = (spaces *> parseVariable <* spaces) `sepBy` char ','
+
+parseConstructor :: Parser Name
+parseConstructor = try (do
+	name <- parseName
+	guard (isUpper (head (nameIdentifier name)))
+	return name)
+	<?> "constructor"
+
+parseLiteral :: Parser Literal
+parseLiteral =
+	LiteralInt . read <$> many1 digit
+	<?> "literal"
+
+parsePattern :: Parser Pattern
+parsePattern = choice (map try
+	[ do
+		constructor <- parseConstructor <* spaces
+		binds <- many (spaces *> parseVariable <* spaces)
+		return $ NodePat (ConstructorName constructor) binds
+	, do
+		fn <- parseName <* spaces
+		binds <- many (spaces *> parseVariable <* spaces)
+		blanks <- many (spaces *> char '_' <* spaces)
+		return $ NodePat (FunctionName fn (length blanks)) binds
+	, LitPat <$> parseLiteral
+	])
+
+parseAlternative :: Parser Alternative
+parseAlternative = do
+	pat <- parsePattern <* spaces
+	string "->"; spaces
+	expression <- parseExpression
+	return $ Alternative pat expression
+
+parens :: Parser a -> Parser a
+parens = between (char '(') (char ')')
+
+parseSimpleExpression :: Parser SimpleExpression
+parseSimpleExpression = choice
+	[ do
+		try (string "@alloc"); spaces
+		n <- many1 digit
+		return $ Alloc (read n)
+	, do
+		try (string "@store"); spaces
+		parens $ do
+			constructor <- parseConstructor <* spaces
+			args <- parseArguments
+			return $ Store (ConstructorName constructor) args
+		  <|> do
+		  	fn <- parseName <* spaces
+		  	args <- parseArguments
+		  	blanks <- many (spaces *> char '_' <* spaces)
+		  	return $ Store (FunctionName fn (length blanks)) args
+	, do
+		try (string "@fetch"); spaces
+		ptr <- parseVariable <* spaces
+		return $ Fetch ptr
+	, do
+		try (string "@print"); spaces
+		var <- parseVariable <* spaces
+		return $ Print var
+	, do
+		fn <- parseName <* spaces
+		args <- parens parseArguments
+		return $ Application fn args
+	, do
+		try (string "@withExceptionHandler"); spaces
+		exh <- parseName <* spaces
+		exhArgs <- parens parseArguments <* spaces
+		fn <- parseName <* spaces
+		args <- parens parseArguments
+		return $ WithExceptionHandler exh exhArgs fn args
+	, do
+		try (string "@add"); spaces
+		lhs <- parseArgument <* spaces
+		rhs <- parseArgument <* spaces
+		return $ Add lhs rhs
+	]
+
+parseExpression :: Parser Expression
+parseExpression = spaces *> choice (map try
+	[ do
+		try (string "@return"); spaces
+		args <- parens parseArguments; spaces
+		return $ Return args
+	, do
+		try (string "case"); spaces
+		scrut <- parseVariable <* spaces
+		string "of"; spaces
+		alts <- (spaces *> parseAlternative <* spaces) `sepBy` char '|'
+		return $ Case scrut alts Nothing
+	, do
+		names <- parseVariables
+		guard (not (null names))
+		string ":="; spaces
+		simple <- parseSimpleExpression
+		char ';'
+		rest <- parseExpression
+		return $ Bind names simple rest
+	, do
+		simple <- parseSimpleExpression
+		char ';'
+		rest <- parseExpression
+		return $ Bind [] simple rest
+	, do
+		try (string "@throw"); spaces
+		e <- parseArgument
+		return $ Throw e
+	, do
+		try (string "@exit"); spaces
+		return $ Exit
+	, do
+		try (string "@tail"); space
+		fn <- parseName <* spaces
+		args <- parens parseArguments
+		return $ TailCall fn args
+	]) <?> "expression"
+
+parseModule :: Parser Module
+parseModule = do
+	fns <- many parseFunction
+	eof
+	return $ Module [] fns
diff --git a/bedrock/src/Data/Bedrock/PrettyPrint.hs b/bedrock/src/Data/Bedrock/PrettyPrint.hs
new file mode 100644
index 0000000..78c645e
--- /dev/null
+++ b/bedrock/src/Data/Bedrock/PrettyPrint.hs
@@ -0,0 +1,123 @@
+module Data.Bedrock.PrettyPrint where
+
+import           Text.PrettyPrint.ANSI.Leijen (Doc, char, int, text, (<+>),
+                                               (<>))
+import qualified Text.PrettyPrint.ANSI.Leijen as Doc
+
+import           Data.Bedrock
+
+-------------------------------------------------------------------------------
+-- Pretty print
+
+ppName :: Name -> Doc
+ppName name =
+	if nameUnique name == 0
+		then text (nameIdentifier name)
+		else text (nameIdentifier name) <> char '^' <> int (nameUnique name)
+
+ppType :: Type -> Doc
+ppType NodePtr   = text ""
+ppType RawNode   = Doc.char ':' <> ppSyntax "node"
+ppType Primitive = Doc.char ':' <> ppSyntax "prim"
+
+ppVariable :: Variable -> Doc
+ppVariable Variable{ variableName = name, variableType = ty } =
+	ppName name <> ppType ty
+
+ppArgument :: Argument -> Doc
+ppArgument arg =
+	case arg of
+		RefArg name       -> ppVariable name
+		LitArg lit        -> ppLiteral lit
+		NodeArg name args -> Doc.parens (ppNode name (map ppArgument args))
+
+ppLiteral :: Literal -> Doc
+ppLiteral literal =
+	case literal of
+		LiteralInt i -> Doc.integer i
+
+ppNode :: NodeName -> [Doc] -> Doc
+ppNode (ConstructorName constructor) args =
+	Doc.hsep (ppName constructor : args)
+ppNode (FunctionName fn blanks) args =
+	Doc.hsep (ppName fn : args ++ replicate blanks (Doc.char '_'))
+
+ppPattern :: Pattern -> Doc
+ppPattern pattern =
+	case pattern of
+		NodePat name binds -> ppNode name (map ppVariable binds)
+		LitPat lit         -> ppLiteral lit
+
+ppList :: [Doc] -> Doc
+ppList = Doc.hsep . Doc.punctuate (Doc.char ',')
+
+ppAlternative :: Alternative -> Doc
+ppAlternative (Alternative pattern expression) =
+	ppPattern pattern <+> text "→" Doc.<$$>
+	Doc.indent 2 (ppExpression expression)
+
+ppSimpleExpression :: SimpleExpression -> Doc
+ppSimpleExpression simple =
+	case simple of
+		Alloc n ->
+			ppSyntax "@alloc" <+> Doc.int n
+		Store node args ->
+			ppSyntax "@store" <+>
+			Doc.parens (ppNode node (map ppArgument args))
+		Fetch ptr ->
+			ppSyntax "@fetch" <+> ppVariable ptr
+		Print var ->
+			ppSyntax "@print" <+> ppVariable var
+		Add lhs rhs ->
+			ppSyntax "@add" <+> ppArgument lhs <+> ppArgument rhs
+		Application fn args ->
+			ppName fn <> Doc.parens (ppList $ map ppArgument args)
+		WithExceptionHandler exh exhArgs fn args ->
+			ppSyntax "@withExceptionHandler" <+>
+			ppName exh <> Doc.parens (ppList $ map ppArgument exhArgs) <+>
+			ppName fn <> Doc.parens (ppList $ map ppArgument args)
+
+ppExpression :: Expression -> Doc
+ppExpression expression =
+	case expression of
+		Return args ->
+			ppSyntax "@return" <+>
+			ppList (map ppArgument args)
+		Bind [] simple rest ->
+			ppSimpleExpression simple <> Doc.char ';' Doc.<$$>
+			ppExpression rest
+		Bind names simple rest ->
+			ppList (map ppVariable names) <+>
+			text ":=" <+>
+			ppSimpleExpression simple <> Doc.char ';' Doc.<$$>
+			ppExpression rest
+		Case scrut alts _defaultBranch ->
+			ppSyntax "case" <+> ppVariable scrut <+> ppSyntax "of" Doc.<$$>
+			Doc.indent 2 (Doc.vsep $ map ppAlternative alts)
+		Throw obj ->
+			ppSyntax "@throw" <+> ppArgument obj
+		TailCall fn args ->
+			ppSyntax "@tail" <+>
+			ppName fn <> Doc.parens (ppList (map ppArgument args))
+		Invoke cont args ->
+			ppSyntax "@invoke" <>
+			Doc.parens (ppList (ppVariable cont : map ppArgument args))
+		Exit ->
+			ppSyntax "@exit"
+
+ppSyntax :: String -> Doc
+ppSyntax = Doc.green . text
+
+ppFnName :: Name -> Doc
+ppFnName = Doc.blue . ppName
+
+ppFunction :: Function -> Doc
+ppFunction fn =
+	ppFnName (fnName fn) <+> Doc.hsep (map ppVariable (fnArguments fn)) <+>
+	Doc.char '=' Doc.<$$>
+	Doc.indent 2 (ppExpression (fnBody fn))
+
+ppModule :: Module -> Doc
+ppModule m = Doc.vsep (map ppFunction (functions m))
+
+
diff --git a/bedrock/src/Data/Bedrock/TypeCheck.hs b/bedrock/src/Data/Bedrock/TypeCheck.hs
new file mode 100644
index 0000000..55ec01e
--- /dev/null
+++ b/bedrock/src/Data/Bedrock/TypeCheck.hs
@@ -0,0 +1,2 @@
+module Data.Bedrock.TypeCheck where
+