Find old Haskell implementation on backup diskHEADmaster

GHC 8.0.2 vintage, doesn't compile

11 files changed, 1277 insertions, 0 deletions

diff --git a/hs/.gitignore b/hs/.gitignore
new file mode 100644
index 0000000..619c2eb
--- /dev/null
+++ b/hs/.gitignore
@@ -0,0 +1,3 @@
+*.hi
+*.o
+Main
diff --git a/hs/AST.hs b/hs/AST.hs
new file mode 100644
index 0000000..a809d6e
--- /dev/null
+++ b/hs/AST.hs
@@ -0,0 +1,121 @@
+module AST where
+
+import Data.List
+import qualified GCStore as GCS (Id)
+
+
+type Name = String
+
+data Program = Program Block
+  deriving (Show)
+
+data Block = Block [Statement]
+  deriving (Show)
+
+data Statement
+    = Declaration Name Expression
+    | Assignment Name Expression
+    | Condition Expression Block Block
+    | Dive Name [Expression] Block
+    | Expr Expression
+  deriving (Show)
+
+data Expression
+    = EBin BinaryOp Expression Expression
+    | EUn UnaryOp Expression
+    | ELit Literal
+  deriving (Show)
+
+data Literal
+    = LNum Double
+    | LStr String
+    | LVar Name
+    | LBlock BlockType ArgList Block
+    | LGCSId GCS.Id
+    | LNil
+  deriving (Show)
+
+type ArgList = [Name]
+
+data BlockType = BT0 | BT1 | BT2  -- the number of ?'s
+  deriving (Show, Enum, Eq)
+
+data BinaryOp
+    = BOPlus | BOMinus | BOMul | BODiv | BOMod | BOPow
+    | BOLess | BOGreater | BOEqual | BOLEq | BOGEq
+    | BOBoolAnd | BOBoolOr
+  deriving (Show, Eq)
+
+data UnaryOp
+    = UONeg | UONot
+  deriving (Show, Eq)
+
+
+class ASTPretty a where
+    astPrettyI :: Int -> a -> String
+
+    astPretty :: a -> String
+    astPretty = astPrettyI 0
+
+
+indent :: Int -> String
+indent n = replicate (4*n) ' '
+
+instance ASTPretty Program where
+    astPrettyI i (Program (Block sts)) =
+        let pr = map (astPrettyI i) sts
+        in intercalate "\n" $ map (uncurry (++)) $ zip ("" : cycle [indent i]) pr
+
+instance ASTPretty Block where
+    astPrettyI _ (Block []) = "{}"
+    astPrettyI i (Block sts) =
+        let lns = map (('\n' : indent (i+1)) ++) $ map (astPrettyI (i+1)) sts
+        in "{" ++ concat lns ++ "\n" ++ indent i ++ "}"
+
+instance ASTPretty Statement where
+    astPrettyI i (Declaration n e) = n ++ " := " ++ astPrettyI i e ++ ";"
+    astPrettyI i (Assignment n e) = n ++ " = " ++ astPrettyI i e ++ ";"
+    astPrettyI i (Condition c b1 b2) =
+        "if " ++ astPrettyI i c ++ " " ++ astPrettyI i b1 ++ " else " ++ astPrettyI i b2
+    astPrettyI i (Dive n [] b) = n ++ " " ++ astPrettyI i b
+    astPrettyI i (Dive n al b) =
+        n ++ "(" ++ intercalate ", " (map (astPrettyI i) al) ++ ") " ++ astPrettyI i b
+    astPrettyI i (Expr e) = astPrettyI i e ++ ";"
+
+instance ASTPretty Expression where
+    astPrettyI i (EBin bo e1 e2) =
+        "(" ++ astPrettyI i e1 ++ ") " ++ astPrettyI i bo ++ " (" ++ astPrettyI i e2 ++ ")"
+    astPrettyI i (EUn uo e) =
+        astPrettyI i uo ++ "(" ++ astPrettyI i e ++ ")"
+    astPrettyI i (ELit l) = astPrettyI i l
+
+instance ASTPretty Literal where
+    astPrettyI _ (LNum m) = show m
+    astPrettyI _ (LStr s) = show s
+    astPrettyI _ (LVar n) = n
+    astPrettyI i (LBlock bt [] b) = replicate (fromEnum bt) '?' ++ astPrettyI i b
+    astPrettyI i (LBlock bt al b) =
+        replicate (fromEnum bt) '?' ++ "(" ++ intercalate ", " al ++ ")" ++ astPrettyI i b
+    astPrettyI _ (LGCSId d) = "<[" ++ show d ++ "]>"
+    astPrettyI _ LNil = "nil"
+
+instance ASTPretty BinaryOp where
+    astPrettyI _ bo = case bo of
+        BOPlus -> "+"
+        BOMinus -> "-"
+        BOMul -> "*"
+        BODiv -> "/"
+        BOMod -> "%"
+        BOPow -> "**"
+        BOLess -> "<"
+        BOGreater -> ">"
+        BOEqual -> "=="
+        BOLEq -> "<="
+        BOGEq -> ">="
+        BOBoolAnd -> "&&"
+        BOBoolOr -> "||"
+
+instance ASTPretty UnaryOp where
+    astPrettyI _ uo = case uo of
+        UONeg -> "-"
+        UONot -> "!"
diff --git a/hs/GCStore.hs b/hs/GCStore.hs
new file mode 100644
index 0000000..d1e550f
--- /dev/null
+++ b/hs/GCStore.hs
@@ -0,0 +1,49 @@
+-- Intended to be imported qualified.
+
+module GCStore(Store, Id, empty, store, retrieve, update, refcount, ref, deref) where
+
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+
+-- import Debug.Trace
+
+
+type Id = Int
+
+data Store a = Store (Map.Map Id (a, Int)) (Set.Set Id) (Set.Set Id)
+  deriving (Show)
+
+empty :: Store a
+empty = Store Map.empty Set.empty Set.empty
+
+store :: Show a => Store a -> a -> (Id, Store a)
+store (Store vm fs us) a =
+    let (i, fs') = if Set.null fs
+                       then (maybe 1 succ (Set.lookupMax us), fs)
+                       else Set.deleteFindMin fs
+    in (i, Store (Map.insert i (a, 1) vm) fs' (Set.insert i us))
+
+retrieve :: Store a -> Id -> Maybe a
+retrieve (Store vm _ _) i = fst <$> Map.lookup i vm
+
+update :: Show a => Store a -> Id -> a -> Store a
+update (Store vm fs us) i a =
+    maybe (error $ "GCStore.update on nonexistent id " ++ show i)
+          (\(_, rc) -> Store (Map.insert i (a, rc) vm) fs us)
+          (Map.lookup i vm)
+
+refcount :: Store a -> Id -> Int
+refcount (Store vm _ _) i = maybe 0 snd $ Map.lookup i vm
+
+ref :: Store a -> Id -> Store a
+ref (Store vm fs us) i = Store (Map.alter updf i vm) fs us
+  where updf Nothing = error $ "GCStore.ref on nonexistent id " ++ show i
+        updf (Just (a, rc)) = Just (a, rc + 1)
+
+deref :: Store a -> Id -> Store a
+deref (Store vm fs us) i =
+    maybe (error $ "GCStore.deref on nonexistent id " ++ show i)
+          (\(a, rc) -> if rc == 1
+              then Store (Map.delete i vm) (Set.insert i fs) (Set.delete i us)
+              else Store (Map.insert i (a, rc - 1) vm) fs us)
+          (Map.lookup i vm)
diff --git a/hs/Interpreter.hs b/hs/Interpreter.hs
new file mode 100644
index 0000000..46c7d8e
--- /dev/null
+++ b/hs/Interpreter.hs
@@ -0,0 +1,481 @@
+{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving, BangPatterns #-}
+module Interpreter(interpret) where
+
+import Control.Monad.Except
+import Control.Monad.State.Strict
+import Control.Monad.Writer.Strict
+import Data.List
+import Data.Maybe
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+
+-- import Debug.Trace
+
+import AST
+import qualified GCStore as GCS
+
+
+interpret :: Program -> (Maybe String, String, VM)  -- (Maybe error, output, vm)
+interpret prog =
+    let res = evaluateProgram prog >> liftM show get >>= tellLine :: ExMonad ()
+        m1 = unExMonad res :: ExceptT String (WriterT String (State VM)) ()
+        m2 = runExceptT m1 :: WriterT String (State VM) (Either String ())
+        m3 = runWriterT m2 :: State VM (Either String (), String)
+        m4 = runState m3 makeVM :: ((Either String (), String), VM)
+        vm = snd m4 :: VM
+        merr = either Just (const Nothing) (fst (fst m4))
+        output = snd (fst m4)
+    in (merr, output, vm)
+
+
+type Scope = Map.Map Name GCS.Id
+
+data Value
+    = VNum Double
+    | VStr String
+    | VBlock BlockType ArgList Block
+    | VNil
+  deriving (Show)
+
+type ObjectStore = GCS.Store Value
+
+data VM = VM {scopeStack :: [Scope],
+              objStore :: ObjectStore,
+              tempValue :: Int}
+  deriving (Show)
+
+newtype ExMonad a = ExContext {unExMonad :: ExceptT String (WriterT String (State VM)) a}
+  deriving (Functor, Applicative, Monad, MonadState VM, MonadWriter String, MonadError String)
+
+typeNameOf :: Value -> String
+typeNameOf (VNum _) = "Number"
+typeNameOf (VStr _) = "String"
+typeNameOf (VBlock _ _ _) = "Block"
+typeNameOf VNil = "Nil"
+
+niceThrowError :: String -> ExMonad a
+niceThrowError s = tellLine s >> throwError s
+
+getTopScope :: String -> ExMonad Scope
+getTopScope mname = get >>= \(VM stk _ _) -> case stk of
+    [] -> niceThrowError $ mname ++ " on empty scope stack"
+    (sc:_) -> return sc
+
+modifyScopeStack :: ([Scope] -> [Scope]) -> ExMonad ()
+modifyScopeStack f = modify $ \vm@(VM stk _ _) -> vm {scopeStack = f stk}
+
+putScopeStack :: [Scope] -> ExMonad ()
+putScopeStack = modifyScopeStack . const
+
+modifyObjStore :: (ObjectStore -> ObjectStore) -> ExMonad ()
+modifyObjStore f = modify $ \vm@(VM _ os _) -> vm {objStore = f os}
+
+putObjStore :: ObjectStore -> ExMonad ()
+putObjStore = modifyObjStore . const
+
+modifyTempValue :: (Int -> Int) -> ExMonad ()
+modifyTempValue func = modify $ \vm -> vm {tempValue = func (tempValue vm)}
+
+getTempValue :: ExMonad Int
+getTempValue = liftM tempValue get
+
+getRefCount :: GCS.Id -> ExMonad Int
+getRefCount gcsid = get >>= \vm -> return (GCS.refcount (objStore vm) gcsid)
+
+derefTell :: GCS.Id -> ExMonad ()
+derefTell gcsid = do
+    get >>= \vm -> return (GCS.deref (objStore vm) gcsid)
+        >>= putObjStore
+    rc <- getRefCount gcsid
+    tellLine $ "GCS deref " ++ show gcsid ++ " -> rc=" ++ show rc
+
+cleanupScope :: Scope -> ExMonad ()
+cleanupScope sc = do
+    tellLine $ "## cleanupScope: " ++ show sc
+    mapM_ cleanupGcsid (Map.elems sc)
+
+cleanupGcsid :: GCS.Id -> ExMonad ()
+cleanupGcsid gcsid = do
+    vm <- get
+    case GCS.retrieve (objStore vm) gcsid of
+         Nothing -> niceThrowError $ "cleanupScope: gcsid " ++ show gcsid ++ " doesn't exist"
+         Just (VBlock _ _ b) -> cleanupBlock b
+         _ -> return ()
+    derefTell gcsid
+
+cleanupBlock :: Block -> ExMonad ()
+cleanupBlock block = do
+    let idset = collectBlock block
+    mapM_ derefTell idset
+
+collectBlock :: Block -> Set.Set GCS.Id
+collectBlock (Block sts) = foldl Set.union $ map collectStatement sts
+
+collectStatement :: Statement -> Set.Set GCS.Id
+collectStatement (Declaration _ e) = collectExpression e
+collectStatement (Assignment _ e) = collectExpression e
+collectStatement (Condition e b1 b2) =
+    foldl Set.union [collectExpression e, collectBlock b1, collectBlock b2]
+collectStatement (Dive _ es b) =
+    Set.union (foldl Set.union (map collectExpression es)) (collectBlock b)
+collectStatement (Expr e) = collectExpression e
+
+collectExpression :: Expression -> Set.Set GCS.Id
+collectExpression (EBin _ e1 e2) = Set.union (collectExpression e1) (collectExpression e2)
+collectExpression (EUn _ e) = collectExpression e
+collectExpression (ELit li) = collectLiteral li
+
+collectLiteral :: Literal -> Set.Set GCS.Id
+collectLiteral (LBlock _ _ b) = collectBlock b
+collectLiteral (LGCSId gcsid') = cleanupGcsid gcsid'
+collectLiteral _ = return ()
+
+cleanupValue :: Value -> Set.Set GCS.Id
+cleanupValue (VBlock _ _ b) = cleanupBlock b
+cleanupValue _ = return ()
+
+pushScope :: ExMonad ()
+pushScope = tellLine "pushScope" >> modifyScopeStack (Map.empty :)
+
+popScope :: ExMonad ()
+popScope = do
+    vm <- get
+    case scopeStack vm of
+        [] -> niceThrowError $ "popScope on empty scope stack"
+        (sc:rest) -> do
+            cleanupScope sc
+            putScopeStack rest
+            tellLine "popScope"
+
+findVar :: Name -> ExMonad (Maybe (Int, GCS.Id, Value))
+findVar n = do
+    (VM stk os _) <- get
+    let mbs = map (\sc -> Map.lookup n sc) stk
+        dr = dropWhile isNothing mbs
+        gcsid = fromJust (head dr)  -- not evaluated if dr == []
+    if null dr
+        then return Nothing
+        else maybe (niceThrowError $ "findVar: gcsid " ++ show gcsid ++ " doesn't exist") return
+                   (GCS.retrieve os gcsid)
+                >>= \value -> return (Just (length mbs - length dr, gcsid, value))
+
+createVarInScope :: Scope -> ObjectStore -> Name -> Value -> ExMonad (Scope, ObjectStore)
+createVarInScope sc os n val =
+    let (gcsid, os') = GCS.store os val
+        sc' = Map.insert n gcsid sc
+    in tellLine ("GCS store in " ++ show gcsid ++ " value " ++ show val) >>
+           if isNothing (Map.lookup n sc)
+               then return (sc', os')
+               else error $ "Var " ++ n ++ " already exists in createVarInScope"
+
+updateVarInScope :: Scope -> ObjectStore -> Name -> Value -> ExMonad ObjectStore
+updateVarInScope sc os n val = do
+    let gcsid = maybe (error $ "Var " ++ n ++ " not found in updateVarInScope") id (Map.lookup n sc)
+        prev = maybe (error "Retrieve=Nothing in updateVarInScope") id (GCS.retrieve os gcsid)
+    cleanupValue prev
+    tellLine ("GCS update " ++ show gcsid ++ " to value " ++ show val)
+    return (GCS.update os gcsid val)
+
+createVarLocal :: Name -> Value -> ExMonad ()
+createVarLocal n val = do
+    vm <- get
+    let (VM (sc:rest) os _) = vm
+    (sc', os') <- createVarInScope sc os n val
+    put $ vm {scopeStack = sc' : rest, objStore = os'}
+
+updateVarAt :: Int -> Name -> Value -> ExMonad ()
+updateVarAt idx n val = do
+    vm <- get
+    let (VM stk os _) = vm
+    updateVarInScope (stk !! idx) os n val >>= putObjStore
+
+tellLine :: String -> ExMonad ()
+tellLine s = get >>= \vm ->
+    let lvl = length (scopeStack vm)
+        ind = if lvl >= 1 then take (4 * (lvl - 1)) (cycle "|   ") else error "ZERO LEVEL"
+    in tell $ ind ++ replace "\n" ('\n' : ind) s ++ "\n"
+
+tellLineStandout :: String -> ExMonad ()
+tellLineStandout s = tell $ "\x1B[1m" ++ s ++ "\x1B[0m\n"
+
+replace :: String -> String -> String -> String
+replace _ _ "" = ""
+replace a b subj =
+    if take (length a) subj == a
+        then b ++ replace a b (drop (length a) subj)
+        else head subj : replace a b (tail subj)
+
+
+makeVM :: VM
+makeVM = VM [Map.empty] GCS.empty 0 
+
+evaluateProgram :: Program -> ExMonad ()
+evaluateProgram (Program (Block sts)) = mapM_ evStatement sts
+
+evStatement :: Statement -> ExMonad ()
+-- evStatement a | traceShow a False = unreachable
+evStatement a = tellLine ("-# evStatement: " ++ astPretty a) >> evStatement' a
+
+evStatement' :: Statement -> ExMonad ()
+evStatement' (Declaration n e) =
+    getTopScope "evStatement" >>=
+        maybe (evExpression e >>= createVarLocal n)
+              (const $ niceThrowError $ "Variable " ++ n ++ " already exists in scope")
+          . Map.lookup n
+evStatement' (Assignment n e) =
+    findVar n >>= 
+        maybe (niceThrowError $ "Variable " ++ n ++ " assigned to but not found")
+              (\(idx, _, _) -> evExpression e >>= updateVarAt idx n)
+evStatement' (Condition cond b1 b2) =
+    evExpression cond >>= truthValue >>= \bool -> evBlock $ if bool then b1 else b2
+evStatement' (Dive "print" al b) = do
+    (show <$> mapM evExpression al) >>= tellLineStandout
+    evBlock b
+evStatement' (Dive n al b) =
+    findVar n >>=
+        maybe (niceThrowError $ "Variable " ++ n ++ " dived into but not found")
+              (\(_, _, value) -> case value of
+                  (VBlock BT2 val vb)
+                      | length al == length val -> do
+                          pushScope
+                          evBlockNoScope $ Block [Declaration dn de | (dn, de) <- zip val al]
+                          evBlockNoScope vb
+                          evBlockNoScope b
+                          popScope
+                      | otherwise ->
+                          niceThrowError $ "Invalid number of arguments to dived-in block " ++ n
+                  _ -> niceThrowError $ "Cannot dive into " ++ n ++ " of invalid type " ++ typeNameOf value)
+evStatement' (Expr e) = evExpression e >>= cleanupValue
+
+evExpression :: Expression -> ExMonad Value
+-- evExpression a | traceShow a False = unreachable
+evExpression a = tellLine ("-# evExpression: " ++ astPretty a) >> evExpression' a
+
+evExpression' :: Expression -> ExMonad Value
+evExpression' (EBin bo e1 e2) = evBO bo e1 e2
+evExpression' (EUn uo e) = evExpression e >>= evUO uo
+evExpression' (ELit li) = evLiteral li
+
+evBlock :: Block -> ExMonad ()
+-- evBlock a | traceShow a False = unreachable
+evBlock bl = do
+    pushScope
+    evBlockNoScope bl
+    popScope
+
+evBlockNoScope :: Block -> ExMonad ()
+evBlockNoScope a = tellLine ("-# evBlockNoScope: " ++ astPretty a) >> evBlockNoScope' a
+
+evBlockNoScope' :: Block -> ExMonad ()
+evBlockNoScope' (Block sts) = mapM_ evStatement sts
+
+evLiteral :: Literal -> ExMonad Value
+evLiteral (LNum m) = return $ VNum m
+evLiteral (LStr s) = return $ VStr s
+evLiteral (LVar n) =
+    findVar n >>= maybe (niceThrowError $ "Variable " ++ n ++ " referenced but not found") (return . thrd)
+evLiteral (LBlock BT0 al bl)
+    | length al == 0 = evBlock bl >> return VNil
+    | otherwise = niceThrowError $ "Immediately invoked block literal cannot have parameters"
+evLiteral (LBlock bt al bl) = liftM (VBlock bt al) $ processBlock bl
+evLiteral (LGCSId gcsid) = get >>= \(VM _ os _) -> maybe (niceThrowError $ "evLiteral: gcsid " ++ show gcsid ++ " doesn't exist") return (GCS.retrieve os gcsid)
+evLiteral LNil = return VNil
+
+evUO :: UnaryOp -> Value -> ExMonad Value
+evUO UONeg (VNum m) = return $ VNum (-m)
+evUO UONeg value = niceThrowError $ "Operator '(-)' does not take a value of type " ++ typeNameOf value
+evUO UONot value = (bool2VNum . not) <$> truthValue value
+
+classifyBO :: BinaryOp -> (Bool, Bool, Bool)
+classifyBO bo = case bo of
+    BOPlus -> (True, f, f)
+    BOMinus -> (True, f, f)
+    BOMul -> (True, f, f)
+    BODiv -> (True, f, f)
+    BOMod -> (True, f, f)
+    BOPow -> (True, f, f)
+    BOLess -> (f, True, f)
+    BOGreater -> (f, True, f)
+    BOEqual -> (f, True, f)
+    BOLEq -> (f, True, f)
+    BOGEq -> (f, True, f)
+    BOBoolAnd -> (f, f, True)
+    BOBoolOr -> (f, f, True)
+  where f = False
+
+isArithBO, isCompBO {-, isBoolBO-} :: BinaryOp -> Bool
+isArithBO bo = let (r, _, _) = classifyBO bo in r
+isCompBO bo = let (_, r, _) = classifyBO bo in r
+-- isBoolBO bo = let (_, _, r) = classifyBO bo in r
+
+evArithBO :: BinaryOp -> Double -> Double -> Double
+evArithBO BOPlus = (+)
+evArithBO BOMinus = (-)
+evArithBO BOMul = (*)
+evArithBO BODiv = (/)
+evArithBO BOMod = \a b -> a - fromIntegral (floor (a / b) :: Integer) * b
+evArithBO BOPow = (**)
+evArithBO _ = unreachable
+
+evOrderingBO :: Ord a => BinaryOp -> a -> a -> Value
+evOrderingBO bo a b =
+    let c = compare a b
+    in bool2VNum $ case bo of
+        BOLess -> c == LT
+        BOGreater -> c == GT
+        BOEqual -> c == EQ
+        BOLEq -> c == LT || c == EQ
+        BOGEq -> c == GT || c == EQ
+        _ -> unreachable
+
+evBO :: BinaryOp -> Expression -> Expression -> ExMonad Value
+evBO bo e1 e2
+    | isArithBO bo = evExpression e1 >>= \v1 -> evExpression e2 >>= \v2 -> case (v1, v2) of
+        (VNum m1, VNum m2) -> return $ VNum $ evArithBO bo m1 m2
+        (_, _) -> niceThrowError $ "Operator '" ++ astPretty bo ++ "' does not take types " ++
+                                   typeNameOf v1 ++ " and " ++ typeNameOf v2
+    | isCompBO bo = evExpression e1 >>= \v1 -> evExpression e2 >>= \v2 -> case (v1, v2) of
+        (VNum m1, VNum m2) -> return $ evOrderingBO bo m1 m2
+        (VStr s1, VStr s2) -> return $ evOrderingBO bo s1 s2
+        (_, _) -> niceThrowError $ "Operator '" ++ astPretty bo ++ "' does not take types " ++
+                                   typeNameOf v1 ++ " and " ++ typeNameOf v2
+    | bo == BOBoolAnd =
+        evExpression e1 >>= truthValue >>= \v1 ->
+            if not v1 then return (VNum 0)
+                      else evExpression e2 >>= truthValue >>= return . bool2VNum
+    | bo == BOBoolOr =
+        evExpression e1 >>= truthValue >>= \v1 ->
+            if v1 then return (VNum 1)
+                  else evExpression e2 >>= truthValue >>= return . bool2VNum
+    | otherwise = unreachable
+
+
+truthValue :: Value -> ExMonad Bool
+truthValue (VNum 0) = return False
+truthValue (VNum _) = return True
+truthValue (VStr "") = return False
+truthValue (VStr _) = return True
+truthValue (VBlock _ _ _) = niceThrowError "Block not valid as truth value"
+truthValue VNil = return False
+
+bool2VNum :: Bool -> Value
+bool2VNum True = VNum 1
+bool2VNum False = VNum 0
+
+
+data ProcessState = ProcessState {psStack :: [Set.Set Name], psSet :: Set.Set GCS.Id}
+
+newtype ProcessMonad a = ProcessMonad {unProcessMonad :: State ProcessState a}
+  deriving (Functor, Applicative, Monad, MonadState ProcessState)
+
+pmModifyStack :: ([Set.Set Name] -> [Set.Set Name]) -> ProcessMonad ()
+pmModifyStack f = modify $ \ps@(ProcessState s _) -> ps {psStack = f s}
+
+pmModifyStackTop :: (Set.Set Name -> Set.Set Name) -> ProcessMonad ()
+pmModifyStackTop f = modify $ \ps@(ProcessState (s:ss) _) -> ps {psStack = f s : ss}
+
+pmModifySet :: (Set.Set GCS.Id -> Set.Set GCS.Id) -> ProcessMonad ()
+pmModifySet f = modify $ \ps@(ProcessState _ s) -> ps {psSet = f s}
+
+processBlockCollect :: [Scope] -> Block -> ProcessMonad Block
+processBlockCollect gStack = goBlock
+  where
+    goBlock :: Block -> ProcessMonad Block
+    goBlock (Block sts) = do
+        pmModifyStack (Set.empty :)
+        b <- Block <$> mapM goStatement sts
+        pmModifyStack tail
+        return b
+
+    goStatement :: Statement -> ProcessMonad Statement
+    goStatement (Declaration n e) = do
+        d <- Declaration n <$> goExpression e
+        pmModifyStackTop (Set.insert n)
+        return d
+    goStatement (Assignment n e) = Assignment n <$> goExpression e
+    goStatement (Condition e b1 b2) = Condition <$> goExpression e <*> goBlock b1 <*> goBlock b2
+    goStatement (Dive n al b) = Dive n <$> mapM goExpression al <*> goBlock b
+    goStatement (Expr e) = Expr <$> goExpression e
+
+    goExpression :: Expression -> ProcessMonad Expression
+    goExpression (EBin bo e1 e2) = EBin bo <$> goExpression e1 <*> goExpression e2
+    goExpression (EUn uo e) = EUn uo <$> goExpression e
+    goExpression (ELit l) = ELit <$> goLiteral l
+
+    goLiteral :: Literal -> ProcessMonad Literal
+    goLiteral (LVar name) = do
+        (ProcessState st _) <- get
+        let midx1 = findIndex (Set.member name) st
+            midx2 = findIndex (Map.member name) gStack
+        case (midx1, midx2) of
+            (Nothing, Nothing) -> return (LVar name)
+            (Just _, _) -> return (LVar name)
+            (Nothing, Just idx) ->
+                let gcsid = fromJust $ Map.lookup name (gStack !! idx)
+                in pmModifySet (Set.insert gcsid) >> return (LGCSId gcsid)
+    goLiteral (LBlock bt al bl) = LBlock bt al <$> goBlock bl
+    goLiteral (LGCSId gcsid) = do
+        pmModifySet (Set.insert gcsid)
+        return (LGCSId gcsid)
+    goLiteral l = return l
+
+processBlock :: Block -> ExMonad Block
+processBlock block = do
+    tellLine ("## processBlock: " ++ astPretty block)
+    (VM stk os _) <- get
+    let (block', ProcessState _ psset) =
+            runState (unProcessMonad $ processBlockCollect stk block)
+                     (ProcessState [] Set.empty)
+    let refitems = Set.toList psset
+        os' = foldl GCS.ref os psset
+    mapM_ (\gcsid -> tellLine ("GCS ref " ++ show gcsid)) refitems
+    putObjStore os'
+    return block'
+
+-- processBlock :: Block -> ExMonad Block
+-- processBlock b = tellLine ("## processBlock: " ++ show b) >> modifyTempValue (const 0) >> goBlock b
+--   where
+--     goStatement :: Statement -> ExMonad Statement
+--     goStatement (Declaration n e) = do
+--         d <- Declaration n <$> goExpression e
+--         createVarLocal n VNil
+--         return d
+--     goStatement (Assignment n e) = Assignment n <$> goExpression e
+--     goStatement (Condition e b1 b2) = Condition <$> goExpression e <*> goBlock b1 <*> goBlock b2
+--     goStatement (Dive n al b') = Dive n <$> mapM goExpression al <*> goBlock b'
+--     goStatement (Expr e) = Expr <$> goExpression e
+
+--     goBlock :: Block -> ExMonad Block
+--     goBlock (Block sts) = do
+--         pushScope
+--         modifyTempValue succ
+--         b' <- Block <$> mapM goStatement sts
+--         modifyTempValue pred
+--         popScope
+--         return b'
+
+--     goExpression :: Expression -> ExMonad Expression
+--     goExpression (EBin bo e1 e2) = EBin bo <$> goExpression e1 <*> goExpression e2
+--     goExpression (EUn uo e) = EUn uo <$> goExpression e
+--     goExpression (ELit l) = ELit <$> goLiteral l
+
+--     goLiteral :: Literal -> ExMonad Literal
+--     goLiteral (LVar name) = do
+--         tv <- getTempValue
+--         findVar name >>=
+--             maybe (niceThrowError $ "Unknown variable " ++ name ++ " while processing block")
+--                   (\(idx, gcsid, _) ->
+--                       if idx >= tv
+--                           then modifyObjStore (\os -> GCS.ref os gcsid)
+--                                  >> tellLine ("GCS ref " ++ show gcsid)
+--                                  >> return (LGCSId gcsid)
+--                           else return (LVar name))
+--     goLiteral (LBlock bt al bl) = LBlock bt al <$> goBlock bl
+--     goLiteral l = return l
+
+
+thrd :: (a, b, c) -> c
+thrd (_, _, c) = c
+
+unreachable :: a
+unreachable = error "Unreachable"
diff --git a/hs/Main.hs b/hs/Main.hs
new file mode 100644
index 0000000..5db97ec
--- /dev/null
+++ b/hs/Main.hs
@@ -0,0 +1,26 @@
+module Main where
+
+import Control.Monad
+import System.Environment
+import System.Exit
+
+-- import AST
+import Interpreter
+import Parser
+
+
+main :: IO ()
+main = do
+    args <- getArgs
+    when (length args == 0) $ die "Pass source file as parameter"
+    let fname = head args
+    src <- readFile fname
+    let eprog = parseProgram (Just fname) src
+    prog <- either (die . show) return eprog
+    -- print prog
+    -- putStrLn $ astPretty prog
+    let (merr, output, _) = interpret prog
+
+    maybe (putStrLn "[No errors]") (putStrLn . ("ERROR: " ++)) merr
+    putStrLn "OUTPUT:"
+    putStrLn output
diff --git a/hs/Parser.hs b/hs/Parser.hs
new file mode 100644
index 0000000..d37f1cd
--- /dev/null
+++ b/hs/Parser.hs
@@ -0,0 +1,163 @@
+module Parser(parseProgram) where
+
+import Control.Monad
+import Data.Char
+import Text.Parsec
+import qualified Text.Parsec.Expr as E
+
+import AST
+
+
+type Parser = Parsec String ()
+
+
+(<<) :: (Monad m) => m a -> m b -> m a
+(<<) = (<*)
+
+parseProgram :: Maybe String -> String -> Either ParseError Program
+parseProgram fname src = parse pProgram (maybe "" id fname) src
+
+pProgram :: Parser Program
+pProgram = (pWhiteComment >> ((Program . Block) <$> pStatement `sepBy` pWhiteComment)) << eof
+
+pStatement :: Parser Statement
+pStatement = pCondition <|> pDeclarationAssignment <|> pDive <|> pExpressionStatement <?> "statement"
+
+pDeclarationAssignment :: Parser Statement
+pDeclarationAssignment = (do
+    (n, constr) <- try $ do  -- after we've seen the assignment operator, there's no turning back
+        n' <- pName
+        constr' <- (symbol ":=" >> return Declaration) <|> (symbol "=" >> return Assignment)
+        return (n', constr')
+
+    e <- pExpression
+    symbol ";" <|> void (lookAhead (char '}'))
+    return $ constr n e) <?> "variable declaration or assignment"
+
+pCondition :: Parser Statement
+pCondition = do
+    symbol "if"
+    cond <- pExpression
+    e1 <- pBlock
+    e2 <- (symbol "else" >> pBlock) <|> return (Block [])
+    return $ Condition cond e1 e2
+
+pExpressionStatement :: Parser Statement
+pExpressionStatement = (Expr <$> pExpression) << symbol ";"
+
+pDive :: Parser Statement
+pDive = do
+    n <- try $ do
+        n' <- pName
+        void $ lookAhead (oneOf "({")
+        return n'
+
+    al <- option [] $ between (symbol "(") (symbol ")") $ pExpression `sepBy` symbol ","
+    (symbol ";" >> return (Dive n al (Block []))) <|> (Dive n al <$> pBlock)
+
+
+pExpression :: Parser Expression
+pExpression = E.buildExpressionParser table pExpressionTerm
+  where
+    table = [[E.Prefix (symbol "-" >> return (EUn UONeg)),
+              E.Prefix (symbol "!" >> return (EUn UONot))],
+             [E.Infix (symbol "**" >> return (EBin BOPow)) E.AssocRight],
+             [E.Infix (symbol "*" >> return (EBin BOMul)) E.AssocLeft,
+              E.Infix (symbol "/" >> return (EBin BODiv)) E.AssocLeft,
+              E.Infix (symbol "%" >> return (EBin BOMod)) E.AssocLeft],
+             [E.Infix (symbol "+" >> return (EBin BOPlus)) E.AssocLeft,
+              E.Infix (symbol "-" >> return (EBin BOMinus)) E.AssocLeft],
+             [E.Infix (symbol "<=" >> return (EBin BOLEq)) E.AssocNone,
+              E.Infix (symbol ">=" >> return (EBin BOGEq)) E.AssocNone,
+              E.Infix (symbol "==" >> return (EBin BOEqual)) E.AssocNone,
+              E.Infix (symbol "<" >> return (EBin BOLess)) E.AssocNone,
+              E.Infix (symbol ">" >> return (EBin BOGreater)) E.AssocNone],
+             [E.Infix (symbol "&&" >> return (EBin BOBoolAnd)) E.AssocLeft,
+              E.Infix (symbol "||" >> return (EBin BOBoolOr)) E.AssocLeft]]
+
+    pExpressionTerm :: Parser Expression
+    pExpressionTerm = pParenExpression <|> (ELit <$> pLiteral)
+
+pBlock :: Parser Block
+pBlock = Block <$> between (symbol "{") (symbol "}") (many pStatement)
+
+pParenExpression :: Parser Expression
+pParenExpression = between (symbol "(") (symbol ")") pExpression
+
+pLiteral :: Parser Literal
+pLiteral = (pLNil <|> pLStr <|> pLNum <|> pLBlock <|> (LVar <$> pName)
+            <?> "literal") << pWhiteComment
+
+pLNil :: Parser Literal
+pLNil = symbol "nil" >> return LNil
+
+pLBlock :: Parser Literal
+pLBlock = (LBlock BT0 [] <$> pBlock) <|> do
+    symbol "??"
+    al <- option [] $ between (symbol "(") (symbol ")") $ pName `sepBy` symbol ","
+    b <- pBlock
+    return $ LBlock BT2 al b
+
+pLNum :: Parser Literal
+pLNum = pDecimal <|> pHexa
+  where
+    pDecimal = do
+        pre <- many1 digit <|> (lookAhead (char '.') >> return "")
+        post <- ((:) <$> char '.' <*> many1 digit) <|> return ""
+        ex <- pExponent <|> return ""
+        return $ LNum $ read $ pre ++ post ++ ex
+
+    pHexa = do
+        void $ string "0x"
+        pre <- many1 hexDigit
+        return $ LNum $ read $ "0x" ++ pre
+
+    pExponent = do
+        void $ char 'e'
+        sgn <- (char '+' >> return "") <|> string "-" <|> return ""
+        dig <- many1 digit
+        return $ 'e' : sgn ++ dig
+
+pLStr :: Parser Literal
+pLStr = LStr <$> between (char '"') (char '"') pStrContents
+  where
+    pStrContents = many pStrChar
+    pStrChar = (char '\\' >> pEscape) <|> noneOf "\""
+    pEscape = (char 'n' >> return '\n') <|>
+              (char 'r' >> return '\r') <|>
+              (char 't' >> return '\t') <|>
+              char '"' <|> char '\\'
+
+
+pName :: Parser Name
+pName = do
+    c <- satisfy (isAlpha .||. (== '_'))
+    rest <- many (satisfy (isAlphaNum .||. (== '_')))
+    pWhiteComment
+    return $ c : rest
+
+
+pWhiteComment :: Parser ()
+pWhiteComment = void $ pWhite `sepBy` pComment
+
+pWhite :: Parser ()
+pWhite = void $ many (oneOf " \t\n")
+
+pComment :: Parser ()
+pComment = pLineComment <|> pBlockComment
+
+pLineComment :: Parser ()
+pLineComment = void $ try (string "//") >> manyTill anyChar (void (char '\n') <|> eof)
+
+pBlockComment :: Parser ()
+pBlockComment = void $ try (string "/*") >> manyTill anyChar (try (string "*/"))
+
+symbol :: String -> Parser ()
+symbol s = do
+    void $ try (string s)
+    when (not (null s) && isAlphaNum (last s)) $ notFollowedBy alphaNum
+    pWhiteComment
+
+infixr 2 .||.
+(.||.) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
+f .||. g = \x -> f x || g x
diff --git a/hs/ding.txt b/hs/ding.txt
new file mode 100644
index 0000000..72ecd45
--- /dev/null
+++ b/hs/ding.txt
@@ -0,0 +1,237 @@
+VM
+{ scopeStack =
+    [ fromList
+        [ ( "list_get"
+          , VBlock
+              BT2
+              ["list", "idx"]
+              (Block
+                 [ Condition
+                     (EBin BOLess (ELit (LVar "idx")) (ELit (LNum 0.0)))
+                     (Block
+                        [ Dive
+                            "throw_error"
+                            [ELit (LStr "Negative index in 'list_get'")]
+                            (Block [])
+                        ])
+                     (Block [])
+                 , Declaration "y" (ELit LNil)
+                 , Dive
+                     "list"
+                     []
+                     (Block
+                        [ Dive
+                            "get_helper"
+                            [ELit (LVar "front"), ELit (LVar "idx")]
+                            (Block [Assignment "y" (ELit (LVar "x"))])
+                        ])
+                 , Declaration "x" (ELit (LVar "y"))
+                 ]))
+        , ( "list_new"
+          , VBlock
+              BT2
+              []
+              (Block
+                 [ Declaration
+                     "x"
+                     (ELit
+                        (LBlock
+                           BT0
+                           []
+                           (Block
+                              [ Declaration "front" (ELit LNil)
+                              , Declaration "back" (ELit LNil)
+                              ])))
+                 ]))
+        , ( "list_pop_back"
+          , VBlock
+              BT2
+              ["list"]
+              (Block
+                 [ Declaration "x" (ELit LNil)
+                 , Dive
+                     "list"
+                     []
+                     (Block
+                        [ Condition
+                            (EBin BOEqual (ELit (LVar "back")) (ELit LNil))
+                            (Block
+                               [ Dive
+                                   "throw_error"
+                                   [ ELit
+                                       (LStr
+                                          "Call to 'list_pop_back' on empty list")
+                                   ]
+                                   (Block [])
+                               ])
+                            (Block [])
+                        , Dive
+                            "back"
+                            []
+                            (Block
+                               [ Assignment "x" (ELit (LVar "value"))
+                               , Assignment "back" (ELit (LVar "prev"))
+                               ])
+                        , Condition
+                            (EBin BOEqual (ELit (LVar "back")) (ELit LNil))
+                            (Block [Assignment "front" (ELit LNil)])
+                            (Block [])
+                        ])
+                 ]))
+        , ( "list_pop_front"
+          , VBlock
+              BT2
+              ["list"]
+              (Block
+                 [ Declaration "x" (ELit LNil)
+                 , Dive
+                     "list"
+                     []
+                     (Block
+                        [ Condition
+                            (EBin BOEqual (ELit (LVar "front")) (ELit LNil))
+                            (Block
+                               [ Dive
+                                   "throw_error"
+                                   [ ELit
+                                       (LStr
+                                          "Call to 'list_pop_front' on empty list")
+                                   ]
+                                   (Block [])
+                               ])
+                            (Block [])
+                        , Dive
+                            "front"
+                            []
+                            (Block
+                               [ Assignment "x" (ELit (LVar "value"))
+                               , Assignment "front" (ELit (LVar "next"))
+                               ])
+                        , Condition
+                            (EBin BOEqual (ELit (LVar "front")) (ELit LNil))
+                            (Block [Assignment "back" (ELit LNil)])
+                            (Block [])
+                        ])
+                 ]))
+        , ( "list_push_back"
+          , VBlock
+              BT2
+              ["list", "item"]
+              (Block
+                 [ Dive
+                     "list"
+                     []
+                     (Block
+                        [ Condition
+                            (EBin BOEqual (ELit (LVar "back")) (ELit LNil))
+                            (Block
+                               [ Assignment
+                                   "front"
+                                   (ELit
+                                      (LBlock
+                                         BT0
+                                         []
+                                         (Block
+                                            [ Declaration
+                                                "value"
+                                                (ELit (LVar "item"))
+                                            , Declaration "next" (ELit LNil)
+                                            , Declaration "prev" (ELit LNil)
+                                            ])))
+                               , Assignment "back" (ELit (LVar "front"))
+                               ])
+                            (Block
+                               [ Assignment
+                                   "back"
+                                   (ELit
+                                      (LBlock
+                                         BT0
+                                         []
+                                         (Block
+                                            [ Declaration
+                                                "value"
+                                                (ELit (LVar "item"))
+                                            , Declaration "next" (ELit LNil)
+                                            , Declaration
+                                                "prev"
+                                                (ELit (LVar "back"))
+                                            ])))
+                               ])
+                        ])
+                 ]))
+        , ( "list_push_front"
+          , VBlock
+              BT2
+              ["list", "item"]
+              (Block
+                 [ Dive
+                     "list"
+                     []
+                     (Block
+                        [ Condition
+                            (EBin BOEqual (ELit (LVar "front")) (ELit LNil))
+                            (Block
+                               [ Assignment
+                                   "front"
+                                   (ELit
+                                      (LBlock
+                                         BT0
+                                         []
+                                         (Block
+                                            [ Declaration
+                                                "value"
+                                                (ELit (LVar "item"))
+                                            , Declaration "next" (ELit LNil)
+                                            , Declaration "prev" (ELit LNil)
+                                            ])))
+                               , Assignment "back" (ELit (LVar "front"))
+                               ])
+                            (Block
+                               [ Assignment
+                                   "front"
+                                   (ELit
+                                      (LBlock
+                                         BT0
+                                         []
+                                         (Block
+                                            [ Declaration
+                                                "value"
+                                                (ELit (LVar "item"))
+                                            , Declaration
+                                                "next"
+                                                (ELit (LVar "front"))
+                                            , Declaration "prev" (ELit LNil)
+                                            ])))
+                               ])
+                        ])
+                 ]))
+        , ( "list_set"
+          , VBlock
+              BT2
+              ["list", "idx", "val"]
+              (Block
+                 [ Condition
+                     (EBin BOLess (ELit (LVar "idx")) (ELit (LNum 0.0)))
+                     (Block
+                        [ Dive
+                            "throw_error"
+                            [ELit (LStr "Negative index in 'list_set'")]
+                            (Block [])
+                        ])
+                     (Block [])
+                 , Dive
+                     "list"
+                     []
+                     (Block
+                        [ Dive
+                            "set_helper"
+                            [ ELit (LVar "front")
+                            , ELit (LVar "idx")
+                            , ELit (LVar "val")
+                            ]
+                            (Block [])
+                        ])
+                 ]))
+        ]
+    ]
+}
diff --git a/hs/file.squig b/hs/file.squig
new file mode 100644
index 0000000..9de0d64
--- /dev/null
+++ b/hs/file.squig
@@ -0,0 +1,7 @@
+a := 2 * 3;
+b := 4 / 5;
+if a == 6 {
+	b = "yes";
+} else {
+	b = "no";
+}
diff --git a/hs/list.squig b/hs/list.squig
new file mode 100644
index 0000000..c5f468c
--- /dev/null
+++ b/hs/list.squig
@@ -0,0 +1,132 @@
+list_new := ??{
+	x := {
+		front := nil;
+		back := nil;
+	};
+};
+
+list_push_front := ??(list, item){
+	list {
+		if front == nil {
+			front = {
+				value := item;
+				next := nil;
+				prev := nil;
+			};
+			back = front;
+		} else {
+			front = {
+				value := item;
+				next := front;
+				prev := nil;
+			};
+		}
+	}
+};
+
+list_push_back := ??(list, item){
+	list {
+		if back == nil {
+			front = {
+				value := item;
+				next := nil;
+				prev := nil;
+			};
+			back = front;
+		} else {
+			back = {
+				value := item;
+				next := nil;
+				prev := back;
+			};
+		}
+	}
+};
+
+list_pop_front := ??(list){
+	x := nil;
+	list {
+		if front == nil {
+			throw_error("Call to 'list_pop_front' on empty list");
+		}
+		front {
+			x = value;
+			front = next;
+		}
+		if front == nil {
+			back = nil;
+		}
+	}
+};
+
+list_pop_back := ??(list){
+	x := nil;
+	list {
+		if back == nil {
+			throw_error("Call to 'list_pop_back' on empty list");
+		}
+		back {
+			x = value;
+			back = prev;
+		}
+		if back == nil {
+			front = nil;
+		}
+	}
+};
+
+list_get := nil;
+{
+	get_helper := ??(front, idx){
+		if front == nil {
+			throw_error("Index past end of list in 'list_get'");
+		}
+		y := nil;
+		if idx == 0 {
+			front {
+				y = value;
+			}
+		} else {
+			front {
+				get_helper(next, idx - 1) {y = x;}
+			}
+		}
+		x := y;
+	};
+	list_get = ??(list, idx){
+		if idx < 0 {
+			throw_error("Negative index in 'list_get'");
+		}
+		y := nil;
+		list {
+			get_helper(front, idx) {y = x;}
+		}
+		x := y;
+	};
+};
+
+list_set := nil;
+{
+	set_helper := ??(front, idx, val){
+		if front == nil {
+			throw_error("Index past end of list in 'list_set'");
+		}
+		if idx == 0 {
+			front {
+				value = val;
+			}
+		} else {
+			front {
+				set_helper(next, idx - 1, val);
+			}
+		}
+	};
+	list_set = ??(list, idx, val){
+		if idx < 0 {
+			throw_error("Negative index in 'list_set'");
+		}
+		list {
+			set_helper(front, idx, val);
+		}
+	};
+};
diff --git a/hs/notes.txt b/hs/notes.txt
new file mode 100644
index 0000000..e935e44
--- /dev/null
+++ b/hs/notes.txt
@@ -0,0 +1,47 @@
+// {
+//     f := nil;
+//     {
+//         a := 1;
+//         f = ??{
+//             print(a);
+//         };
+//         f();  // print 1
+//         a = 3;
+//         f();  // print 3
+//     };
+//     f();  // print 3
+//     a := 2;
+//     f();  // print 3
+// };  // deref and delete f and a
+// print("done");
+
+
+// -- new snippet
+
+
+// f := ??{
+//     print(a);  // error: undefined variable 'a'
+// };
+// a := 1;
+// f();
+
+
+// -- new snippet
+
+
+{
+    a := 10;  // 1
+    f := nil;  // 2
+    {
+        a := 20;  // 3
+        f = ??{
+            print(a);
+            g := ??{
+                print(a);
+            };
+            g();
+        };
+        f();  // -> 20 20    NOTE: the g is stored in 5 while 4 is available!
+    };
+    f();  // -> 20 20 of 20 10?
+};
diff --git a/hs/test.txt b/hs/test.txt
new file mode 100644
index 0000000..1a2f551
--- /dev/null
+++ b/hs/test.txt
@@ -0,0 +1,11 @@
+{
+	a := 10;
+	f := ??{
+		print(a);
+		g := ??{
+			print(a);
+		};
+		// g();
+	};
+	f();
+};