From: Mart Lubbers <mart@martlubbers.net>
Date: Thu, 26 Aug 2021 08:04:12 +0000 (+0200)
Subject: add datatype generation DSL stuff
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=de9656d30475c64e1a52017821e04393c9904a16;p=clean-tests.git

add datatype generation DSL stuff
---

diff --git a/.gitignore b/.gitignore
index df867ba..af28e48 100644
--- a/.gitignore
+++ b/.gitignore
@@ -15,3 +15,7 @@ afp/a[0-9]/a[0-9]
 afp/a1[0-9]/a1[0-9]
 
 struct
+
+*.hi
+*.dyn_hi
+*.dyn_o
diff --git a/datatype/Compiler.hs b/datatype/Compiler.hs
new file mode 100644
index 0000000..1070ecb
--- /dev/null
+++ b/datatype/Compiler.hs
@@ -0,0 +1,268 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Compiler where
+
+import Language
+import Serialise
+
+import qualified Data.Map as DM
+import Control.Monad.Writer
+import Control.Monad.State
+import Control.Monad.ST
+import Debug.Trace
+import Data.Array
+import Data.Array.ST
+import Data.Function
+
+newtype Compiler a = Compiler { unCompiler :: StateT CS (WriterT [Instr] (Either String)) a }
+  deriving
+        ( Functor
+        , Applicative
+        , Monad
+        , MonadWriter [Instr]
+        , MonadState CS
+        )
+instance MonadFail Compiler where fail s = Compiler $ lift $ lift $ Left s
+data CS = CS
+    { fresh :: [Int]
+    , functions :: DM.Map Int [Instr]
+    }
+
+runCompiler :: Compiler a -> Either String [Instr]
+runCompiler c = execWriterT
+    $ evalStateT (unCompiler (c >> instr [Halt] >> writeFunctions))
+    $ CS {fresh=[0..], functions=DM.empty}
+  where
+    writeFunctions :: Compiler ()
+    writeFunctions = gets (DM.elems . functions) >>= tell . concat
+
+instr :: [Instr] -> Compiler a
+instr i = tell i >> pure undefined
+
+freshLabel :: Compiler Int
+freshLabel = get >>= \cs->put (cs { fresh=tail (fresh cs) }) >> pure (head $ fresh cs)
+
+binop :: Instr -> Compiler a1 -> Compiler a2 -> Compiler b
+binop i l r = l >> r >> instr [i]
+
+unop :: Instr -> Compiler a -> Compiler b
+unop i l = l >> instr [i]
+
+instance Expression Compiler where
+    lit v = instr $ map Push $ serialise v []
+    (+.) = binop Add
+    (-.) = binop Sub
+    (/.) = binop Div
+    (*.) = binop Mul
+    (^.) = binop Pow
+--    (^.) l r = freshLabel >>= \lblstart->freshLabel >>= \lblend->
+--        l >> r >> instr -- pow (x, y) {
+--            [ Str 1
+--            , Str 0
+--            , Push 1        -- res = 1
+--            , Lbl lblstart  -- while
+--            , Ldr 1         -- (y == 0)
+--            , Push 0        --
+--            , Neq           --
+--            , Brf lblend    --
+--            , Ldr 0         -- res *= x
+--            , Mul           --
+--            , Ldr 1         -- y -= 1
+--            , Push 1        --
+--            , Sub           --
+--            , Str 1         --
+--            , Bra lblstart  --
+--            , Lbl lblend    --
+--            ]
+    neg = unop Neg
+    (&.) = binop And
+    (|.) = binop Or
+    not = unop Not
+    (==.) = binop Eq
+    (/=.) = binop Neq
+    (<.) = binop Le
+    (>.) = binop Ge
+    (<=.) = binop Leq
+    (>=.) = binop Geq
+    if' p t e = freshLabel >>= \elselabel-> freshLabel >>= \endiflabel->
+        p >> instr [Brf elselabel] >>
+        t >> instr [Bra endiflabel, Lbl elselabel] >>
+        e >> instr [Lbl endiflabel]
+
+instance Function () Compiler where
+    fun def = Main $
+        freshLabel >>= \funlabel->
+        let g :- m = def (\()->instr [Jsr funlabel])
+        in  liftFunction funlabel 0 (g ()) >> unmain m
+
+instance Function (Compiler a) Compiler where
+    fun def = Main $
+        freshLabel >>= \funlabel->
+        let g :- m = def (\a->a >> instr [Jsr funlabel])
+        in  liftFunction funlabel 1 (g (instr [Arg 0])) >> unmain m
+
+instance Function (Compiler a, Compiler b) Compiler where
+    fun def = Main $
+        freshLabel >>= \funlabel->
+        let g :- m = def (\(a, b)->a >> b >> instr [Jsr funlabel])
+        in  liftFunction funlabel 2 (g (instr [Arg 1], instr [Arg 0])) >> unmain m
+
+instance Function (Compiler a, Compiler b, Compiler c) Compiler where
+    fun def = Main $
+        freshLabel >>= \funlabel->
+        let g :- m = def (\(a, b, c)->a >> b >> c >> instr [Jsr funlabel])
+        in  liftFunction funlabel 3 (g (instr [Arg 2], instr [Arg 1], instr [Arg 0])) >> unmain m
+
+liftFunction :: Int -> Int -> Compiler a -> Compiler ()
+liftFunction lbl nargs body = do
+    is <- snd <$> censor (\_->[]) (listen body)
+    let instructions = Lbl lbl : is ++ [Ret nargs]
+    modify (\s->s { functions=DM.insert lbl instructions $ functions s })
+
+data Instr
+    = Push Int | Pop Int | Dup | Roll Int Int
+    | Add | Sub | Mul | Div | Neg | Pow
+    | And | Or | Not
+    | Eq | Neq | Le | Ge | Leq | Geq
+    | Lbl Int | Bra Int | Brf Int
+    | Str Int | Ldr Int
+    | Sth Int | Ldh Int
+    | Jsr Int | Ret Int | Arg Int
+    | Halt
+  deriving Show
+
+data Registers = Registers
+    { pc :: Int
+    , hp :: Int
+    , sp :: Int
+    , mp :: Int
+    , gp :: DM.Map Int Int
+    }
+  deriving Show
+
+interpret :: Int -> [Instr] -> Array Int Int
+interpret memsize prog = runSTArray $ do
+    program <- newListArray (0, length prog) prog
+    mem <- newArray (0, memsize-1) 0
+    int program mem (Registers {pc=0, sp=memsize-1, mp=0, hp=0, gp=DM.empty})
+  where
+    pushh :: STArray s Int Int -> Int -> Registers -> ST s Registers
+    pushh memory value reg = do
+        writeArray memory (hp reg) value
+        pure (reg { hp = hp reg + 1} )
+
+    loadh :: STArray s Int Int -> Int -> Registers -> ST s Registers
+    loadh memory hptr registers = readArray memory hptr >>= flip (push memory) registers
+
+    push :: STArray s Int Int -> Int -> Registers -> ST s Registers
+    push memory value reg = do
+        writeArray memory (sp reg) value
+        pure (reg { sp = sp reg - 1} )
+
+    pop :: STArray s Int Int -> Registers -> ST s (Registers, Int)
+    pop memory reg = do
+        v <- readArray memory (sp reg + 1)
+        pure (reg { sp = sp reg + 1}, v)
+
+    popn :: STArray s Int Int -> Int -> Registers -> ST s (Registers, [Int])
+    popn _ 0 reg = pure (reg, [])
+    popn memory n reg = do
+        (reg', v) <- pop memory reg 
+        (reg'', vs) <- popn memory (n - 1) reg'
+        pure (reg'', v:vs)
+
+    bop :: (Int -> Int -> Int) -> STArray s Int Int -> Registers -> ST s Registers
+    bop op memory reg = do
+        (reg1, r) <- pop memory reg
+        uop (flip op r) memory reg1
+
+    uop :: (Int -> Int) -> STArray s Int Int -> Registers -> ST s Registers
+    uop op memory reg = do
+        (reg1, r) <- pop memory reg
+        push memory (op r) reg1
+
+    int :: STArray s Int Instr -> STArray s Int Int -> Registers -> ST s (STArray s Int Int)
+    int program memory registers = do
+        instruction <- readArray program $ pc registers
+        stack <- getElems memory
+        let reg = registers { pc = pc registers + 1 }
+        case trace ("Interpret: " ++ show instruction ++ " with registers: " ++ show registers ++ " and stack: " ++ show stack) instruction of
+--        case instruction of
+            Str r -> do
+                (reg', v) <- pop memory reg
+                int program memory $ reg' { gp = DM.insert r v (gp reg')}
+            Ldr r -> push memory (DM.findWithDefault 0 r $ gp reg) reg >>= int program memory
+            Roll 0 _ -> int program memory reg
+            Roll 1 _ -> int program memory reg
+            Roll _ 0 -> int program memory reg
+            Roll depth num -> do
+                (reg', vs) <- popn memory depth reg
+                foldM (flip $ push memory) reg' (roll num [] $ reverse vs) >>= int program memory
+              where
+                roll 0 acc vs = vs ++ reverse acc
+                roll n acc [] = roll n [] $ reverse acc
+                roll n acc (v:vs) = roll (n-1) (v:acc) vs
+            Pop n -> popn memory n reg >>= int program memory . fst
+            Push v -> push memory v reg >>= int program memory
+            Dup -> pop memory reg >>= \(r', v)->push memory v r' >>= push memory v >>= int program memory
+            Add -> bop (+) memory reg >>= int program memory
+            Sub -> bop (-) memory reg >>= int program memory
+            Mul -> bop (*) memory reg >>= int program memory
+            Div -> bop div memory reg >>= int program memory
+            Neg -> uop negate memory reg >>= int program memory
+            Pow -> bop (^) memory reg >>= int program memory
+            And -> bop ((b2i .) . on (&&) i2b) memory reg >>= int program memory
+            Or -> bop ((b2i .) . on (||) i2b) memory reg >>= int program memory
+            Not -> uop (b2i . Prelude.not . i2b) memory reg >>= int program memory
+            Eq -> bop ((b2i .) . (==)) memory reg >>= int program memory
+            Neq -> bop ((b2i .) . (/=)) memory reg >>= int program memory
+            Le -> bop ((b2i .) . (<)) memory reg >>= int program memory
+            Ge -> bop ((b2i .) . (>)) memory reg >>= int program memory
+            Leq -> bop ((b2i .) . (<=)) memory reg >>= int program memory
+            Geq -> bop ((b2i .) . (>=)) memory reg >>= int program memory
+            Lbl _ -> int program memory reg
+            Bra l -> branch l program reg >>= int program memory
+            Brf l -> do
+                (reg', v) <- pop memory reg
+                reg'' <- if i2b v then pure reg' else branch l program reg'
+                int program memory reg''
+            Sth n ->
+                    popn memory n reg
+                >>= uncurry (foldM $ flip $ pushh memory)
+                >>= push memory (hp reg + n - 1)
+                >>= int program memory
+            Ldh n -> pop memory reg >>= \(reg', hptr)->loadh memory (hptr - n - 1) reg'
+                >>= int program memory
+            Jsr i -> push memory (pc reg) reg
+                >>= push memory (mp reg)
+                >>= branch i program
+                >>= \r->int program memory (r { mp = sp r})
+            Ret n -> do
+                (reg1, rval) <- pop memory reg
+                (reg2, omp) <- pop memory reg1
+                (reg3, ra) <- pop memory reg2
+                (reg4, _) <- popn memory n reg3
+                reg5 <- push memory rval reg4
+                int program memory $ reg5 { pc=ra, mp=omp }
+            Arg n -> do
+                v <- readArray memory (mp reg + 3 + n)
+                push memory v reg >>= int program memory
+            Halt -> pure memory
+
+    branch :: Int -> STArray s Int Instr -> Registers -> ST s Registers
+    branch label program reg = case pc reg of
+        -1 -> getBounds program >>= \(_, m)->branch label program $ reg { pc = m - 1}
+        _ -> readArray program (pc reg) >>= \case
+            Lbl l | label == l -> pure $ reg
+            _ -> branch label program $ reg { pc = pc reg - 1 }
+
+b2i :: Bool -> Int
+b2i True = 1
+b2i False = 0
+
+i2b :: Int -> Bool
+i2b 0 = False
+i2b _ = True
diff --git a/datatype/Language.hs b/datatype/Language.hs
new file mode 100644
index 0000000..64c5ea8
--- /dev/null
+++ b/datatype/Language.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Language where
+
+import Serialise
+
+newtype Main a = Main {unmain :: a}
+data In a b = a :- b
+infix 1 :-
+
+class Expression v where
+    lit :: (Serialise a, Show a) => a -> v a
+    (+.) :: Num a => v a -> v a -> v a
+    (-.) :: Num a => v a -> v a -> v a
+    (/.) :: Fractional a => v a -> v a -> v a
+    (*.) :: Num a => v a -> v a -> v a
+    (^.) :: Num a => v a -> v a -> v a
+    neg :: Num a => v a -> v a
+    (&.) :: v Bool -> v Bool -> v Bool
+    (|.) :: v Bool -> v Bool -> v Bool
+    not :: v Bool -> v Bool
+    (==.) :: Eq a => v a -> v a -> v Bool
+    (/=.) :: Eq a => v a -> v a -> v Bool
+    (<.) :: Ord a => v a -> v a -> v Bool
+    (>.) :: Ord a => v a -> v a -> v Bool
+    (<=.) :: Ord a => v a -> v a -> v Bool
+    (>=.) :: Ord a => v a -> v a -> v Bool
+    if' :: v Bool -> v a -> v a -> v a
+
+class Function a v where
+    fun :: ( (a -> v s) -> In (a -> v s) (Main (v u)) ) -> Main (v u)
+
+infixr 2 |.
+infixr 3 &.
+infix 4 ==., /=., <., >., <=., >=.
+infixl 6 +., -.
+infixl 7 *., /.
+infixl 8 ^.
diff --git a/datatype/Main.hs b/datatype/Main.hs
new file mode 100644
index 0000000..3b8c1f4
--- /dev/null
+++ b/datatype/Main.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Main where
+
+import Language
+
+import Compiler
+import Printer
+
+import Tuple
+
+main :: IO ()
+main
+--    = putStrLn (runPrint e0)
+--    >> putStrLn (runPrint e1)
+--    >> putStrLn (runPrint e2)
+--    >> putStrLn (runPrint e3)
+--    >> putStrLn (show $ runCompiler e0)
+--  = putStrLn (show $ interpret 10 <$> runCompiler e0)
+--  = putStrLn (show $ interpret 10 <$> runCompiler e1'')
+  = putStrLn (show $ interpret 10 <$> runCompiler (e1))
+  >> putStrLn (show $ interpret 10 <$> runCompiler (tuplef0' e1))
+  >> putStrLn (show $ interpret 10 <$> runCompiler (tuplef1' e1))
+  >> putStrLn (show $ interpret 10 <$> runCompiler (tuplef1' $ second' e3))
+  >> putStrLn (runPrint $ lit (42 :: Int) `cons` (lit (10 :: Int) `cons` nil))
+  >> putStrLn (show $ interpret 20 <$> runCompiler (lit (42 :: Int) `cons` (lit (10 :: Int) `cons` nil)))
+  >> putStrLn (runPrint $ unmain $ f0)
+  >> putStrLn (show $ runCompiler (unmain f0))
+  >> putStrLn (show $ interpret 20 <$> runCompiler (unmain f0))
+  >> putStrLn (show $ runCompiler (unmain f1))
+  >> putStrLn (show $ interpret 20 <$> runCompiler (unmain f1))
+  >> putStrLn (show $ runCompiler (unmain f2))
+  >> putStrLn (show $ interpret 20 <$> runCompiler (unmain f2))
+  >> putStrLn (show $ runCompiler (unmain f3))
+  >> putStrLn (show $ interpret 20 <$> runCompiler (unmain f3))
+--    >> putStrLn (show $ interpret <$> runCompiler e1)
+--    >> putStrLn (show $ interpret <$> runCompiler e1')
+--    >> putStrLn (show $ interpret <$> runCompiler e1'')
+
+e0 :: Expression v => v Int
+e0 = lit 2 ^. lit 8
+
+e1 :: (Expression v, Tuple' v) => v (Tuple Char Int)
+e1 = tuple (lit 'c') (lit 42)
+
+e1' :: (Expression v, Tuple' v) => v Char
+e1' = tuplef0' e1
+
+e1'' :: (Expression v, Tuple' v) => v Int
+e1'' = tuplef1' e1
+
+e2 :: (Expression v, TupleR' v) => v (TupleR Char Bool)
+e2 = tupler (lit 'c') (lit True)
+
+e3 :: (Expression v, Tuple' v, TupleR' v) => v (TupleR Char (Tuple Int Bool))
+e3 = tupler (lit 'c') (tuple (lit 42) (lit True))
+
+f0 :: (Expression v, Function () v) => Main (v Int)
+f0
+    =  fun ( \c42->(\()->lit 42)
+    :- Main {unmain=c42 () +. lit 38}
+    )
+
+f1 :: (Expression v, Function (v Int) v, Function () v) => Main (v Int)
+f1
+    =  fun ( \c42->(\()->lit 42)
+    :- fun ( \inc->(\i->i +. lit 1)
+    :- Main {unmain=c42 () +. inc (lit 41)}
+    ))
+
+f2 :: (Expression v, Function (v Int, v Int) v) => Main (v Int)
+f2
+    =  fun ( \sub->(\(x, y)->x -. y)
+    :- Main {unmain=sub (lit 2, lit 8)}
+    )
+
+f3 :: (Expression v, Tuple' v, Function (v Int) v) => Main (v (Tuple Int Int))
+f3
+    =  fun ( \idfun->(\x->x)
+    :- Main {unmain=tuple (idfun (lit 42)) (idfun (lit 4)) }
+    )
+
+f4 :: (Expression v, Function (v Int) v) => Main (v Int)
+f4
+    =  fun ( \fac->(\x->x)
+    :- Main {unmain=tuple (idfun (lit 42)) (idfun (lit 4)) }
+    )
diff --git a/datatype/MkCons.hs b/datatype/MkCons.hs
new file mode 100644
index 0000000..57b14c6
--- /dev/null
+++ b/datatype/MkCons.hs
@@ -0,0 +1,173 @@
+{-# LANGUAGE TemplateHaskell #-}
+module MkCons where
+
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH
+import Data.Char
+import Control.Monad
+
+className :: Name -> Name
+className = mkName . (++"'") . stringName
+constructorName :: Name -> Name
+constructorName = mkName . map toLower . stringName
+selectorName :: Name -> Name
+selectorName = mkName . map toLower . (++"'") . stringName
+stringName :: Name -> String
+stringName (Name occ _) = occString occ
+
+numberedArgs :: [a] -> [String]
+numberedArgs = zipWith (\i _->"f" ++ show i) [0 :: Int ..]
+
+mkConsClass :: Name -> DecsQ
+mkConsClass typename = reify typename >>= \info->case info of
+    TyConI dec
+        -> case dec of
+        DataD _ _ tyvars _ constructors _
+            -> sequence 
+                [ mkDerivation tyvars
+                , mkConstructorClasses tyvars constructors
+                , mkPrinterInstances tyvars constructors
+                , mkCompilerInstances tyvars constructors
+                ]
+        _
+            -> fail "mkConsClass only supports data types"
+    _
+        -> fail "mkConsClass only supports types"
+  where
+    mkDerivation :: [TyVarBndr] -> DecQ
+    mkDerivation tyvars = let names = (map (VarT . getNameTyVarBndr) tyvars) in pure $
+        InstanceD Nothing
+            [ConT (mkName "Serialise") `AppT` t | t <- names]
+            (ConT (mkName "Serialise") `AppT` foldl AppT (ConT typename) names)
+            []
+
+    mkConstructorClasses :: [TyVarBndr] -> [Con] -> DecQ
+    mkConstructorClasses tyvars constructors = do
+        cclasses <- mapM mkConstructorClassMember constructors
+        sclasses <- concat <$> mapM mkSelectorClassMember constructors
+        pure $ ClassD [] (className typename) [PlainTV view] [] (cclasses ++ sclasses)
+      where
+        view = mkName "m"
+
+        mkConstructorClassMember :: Con -> DecQ
+        mkConstructorClassMember (NormalC consname fs)
+            = mkConstructorClassMemberForName consname [t | (_, t)<-fs]
+        mkConstructorClassMember (RecC consname fs)
+            = mkConstructorClassMemberForName consname [t | (_, _, t)<-fs]
+        mkConstructorClassMember t
+            = fail $ "mkConsClass not supported for types such as: " ++ show t
+
+        mkConstructorClassMemberForName :: Name -> [Type] -> DecQ
+        mkConstructorClassMemberForName consname fs
+            = pure $ SigD (constructorName consname)
+                $ foldr (AppT . AppT ArrowT) resultT
+                $ map (AppT $ VarT view) fs
+
+        mkSelectorClassMember :: Con -> DecsQ
+        mkSelectorClassMember (NormalC _ fs)
+            = mapM (uncurry mkSelectorClassMemberForField)
+            $ zipWith (\(_, t) i->(mkName $ map toLower (stringName typename) ++ "f" ++ show i, t)) fs [0 :: Int ..]
+        mkSelectorClassMember (RecC _ fs)
+            = mapM (uncurry mkSelectorClassMemberForField) [(n, t)|(n, _, t)<-fs]
+        mkSelectorClassMember t
+            = fail $ "mkConsClass not supported for types such as: " ++ show t
+
+        mkSelectorClassMemberForField :: Name -> Type -> DecQ
+        mkSelectorClassMemberForField n t = pure
+            $ SigD (className n)
+            $ ForallT [] [ConT (mkName "Serialise") `AppT` VarT (getNameTyVarBndr ty) | ty <- tyvars]
+            $ ArrowT `AppT` resultT `AppT` (VarT view `AppT` t)
+
+        resultT = VarT view `AppT` (foldl AppT (ConT typename) $ map (VarT . getNameTyVarBndr) $ tyvars)
+
+    mkPrinterInstances :: [TyVarBndr] -> [Con] -> DecQ
+    mkPrinterInstances _ constructors
+        =   InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Printer")) . concat
+        <$> mapM mkPrinterInstance constructors
+      where
+        mkPrinterInstance :: Con -> DecsQ
+        mkPrinterInstance (NormalC name fs)
+            | null fs = pure [FunD (constructorName name)
+                    [Clause [] (NormalB $ VarE (mkName "printLit") `AppE` LitE (StringL $ stringName name)) [] ]]
+            | otherwise =
+                let args = map mkName $ numberedArgs fs
+                in (:) <$> pure (FunD (constructorName name)
+                    [Clause
+                        (map VarP args)
+                        (NormalB $
+                            (AppE (VarE (mkName "printCons") `AppE` LitE (StringL $ stringName name))
+                                (foldl (\x y->x `pc` pl " " `pc` y) (pl "") $ map VarE args)
+                            )
+                        )
+                        []
+                    ])
+                <*> mapM mkPrinterSelector
+                    (zipWith (\_ i->map toLower (stringName typename) ++ "f" ++ show i) fs [0 :: Int ..])
+        mkPrinterInstance (RecC name fs)
+            = let args = map mkName $ numberedArgs fs
+            in (:) <$> pure (FunD (constructorName name)
+                [Clause
+                    (map VarP args)
+                    (NormalB $
+                        (AppE (VarE (mkName "printRec") `AppE` LitE (StringL $ stringName typename))
+                            (foldl1 (\x y->x `pc` pl ", " `pc` y)
+                                $ zipWith (\x ((Name occ'' _), _, _)->pl (occString occ'') `pc` pl "=" `pc` VarE x) args fs)
+                        )
+                    )
+                    []
+                ])
+            <*> mapM mkPrinterSelector [occString occ | (Name occ _, _, _)<-fs]
+        mkPrinterInstance t = fail $ "mkConsClass not supported for types such as: " ++ show t
+
+        mkPrinterSelector :: String -> Q Dec
+        mkPrinterSelector n' = do
+            body <- [|\d->d >> printLit $(pure $ LitE $ StringL ('.':n'))|]
+            pure $ FunD (selectorName $ mkName n') [Clause [] (NormalB body) []]
+
+    mkCompilerInstances :: [TyVarBndr] -> [Con] -> DecQ
+    mkCompilerInstances _ constructors
+        =   InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Compiler")) . concat
+        <$> mapM (uncurry mkCompilerInstance) (zip constructors [0..])
+      where
+        mkCompilerInstance :: Con -> Int -> DecsQ
+        mkCompilerInstance (NormalC name fs) consnum = (:)
+            <$> mkCompilerInstanceForName name consnum (numberedArgs fs)
+            <*> mapM (uncurry mkCompilerSelector) (zip [0..] [map toLower (stringName typename) ++ f | f<-numberedArgs fs])
+        mkCompilerInstance (RecC name fs) consnum = (:)
+            <$> mkCompilerInstanceForName name consnum [occString occ | (Name occ _, _, _) <- fs]
+            <*> mapM (uncurry mkCompilerSelector) (zip [0..] [occString occ | (Name occ _, _, _) <- fs])
+        mkCompilerInstance t _ = fail $ "mkConsClass not supported for types such as: " ++ show t
+
+        mkCompilerInstanceForName :: Name -> Int -> [String] -> DecQ
+        mkCompilerInstanceForName name consnum fs =
+            let args = map mkName $ numberedArgs fs
+            in do
+                body <- [|instr [Push $(pure $ LitE $ IntegerL $ toInteger $ consnum)] *> $(mkBody $ map VarE args) <* instr [Sth $ $(pure $ LitE $ IntegerL $ toInteger $ length fs) + 1] |]
+                pure $ FunD (constructorName name)
+                    [Clause (map VarP args) (NormalB body) [] ]
+          where
+            mkBody :: [Exp] -> Q Exp
+            mkBody [] = pure $ VarE (mkName "pure") `AppE` ConE name
+            mkBody (a:as) = foldM (\x y->pure $ ifx "<*>" x y) (ifx "<$>" (ConE name) a) as
+
+        mkCompilerSelector :: Int -> String -> DecQ
+        mkCompilerSelector idx n' = do
+            body <- [|\d->d >> instr [Ldh $(pure $ LitE (IntegerL (toInteger idx)))] |]
+            pure $ FunD (selectorName $ mkName n')
+                [Clause [] (NormalB body) [] ]
+
+instrE :: Exp -> Exp
+instrE e = VarE (mkName "instr") `AppE` ListE [e]
+
+ifx :: String -> Exp -> Exp -> Exp
+ifx op a b = InfixE (Just a) (VarE $ mkName op) (Just b)
+
+pc :: Exp -> Exp -> Exp
+pc l r = VarE (mkName ">>>") `AppE` l `AppE` r
+
+pl :: String -> Exp
+pl s = VarE (mkName "printLit") `AppE` LitE (StringL s)
+
+getNameTyVarBndr :: TyVarBndr -> Name
+getNameTyVarBndr (PlainTV name) = name
+getNameTyVarBndr (KindedTV name _) = name
diff --git a/datatype/Printer.hs b/datatype/Printer.hs
new file mode 100644
index 0000000..8668b91
--- /dev/null
+++ b/datatype/Printer.hs
@@ -0,0 +1,136 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Printer where
+
+import Control.Monad.RWS
+import Language
+
+newtype Printer a = P { runPrinter :: RWS Ctx [String] PS a }
+  deriving
+    ( Functor
+    , Applicative
+    , Monad
+    , MonadWriter [String]
+    , MonadState PS
+    , MonadReader Ctx
+    )
+data PS = PS {fresh :: [Int]}
+data Ctx = CtxNo | CtxNullary | CtxNonfix | CtxInfix {assoc :: CtxAssoc, prio :: Int, branch :: CtxAssoc}
+  deriving Eq
+
+leftctx,rightctx,nonectx :: Int -> Ctx
+leftctx p = CtxInfix {assoc=CtxLeft, prio=p, branch=CtxNone}
+rightctx p = CtxInfix {assoc=CtxRight, prio=p, branch=CtxNone}
+nonectx p = CtxInfix {assoc=CtxNone, prio=p, branch=CtxNone}
+
+setBranch :: Ctx -> CtxAssoc -> Ctx
+setBranch ctx@(CtxInfix _ _ _) b = ctx { branch=b }
+setBranch ctx _ = ctx
+
+data CtxAssoc = CtxLeft | CtxRight | CtxNone
+  deriving Eq
+
+runPrint :: Printer a -> String
+runPrint p = concat $ snd $ execRWS (runPrinter p) CtxNo $ PS {fresh=[0..]}
+
+--printString :: Show a => a -> Printer a
+--printString = pure . shows
+--
+printLit :: String -> Printer a
+printLit a = tell [a] *> pure undefined
+--
+--printcc :: Printer a -> Printer b -> Printer c
+--printcc a b = a >>= bkkkkkkkkkkP $ \ps->runPrinter a ps . runPrinter b ps
+--
+--printcs :: Printer a -> Printer b -> Printer c
+--printcs a b = P $ \ps->runPrinter a ps . (' ':) . runPrinter b ps
+
+paren :: Printer a -> Printer a
+paren p = printLit "(" *> p <* printLit ")"
+
+accol :: Printer a -> Printer a
+accol p = printLit "{" *> p <* printLit "}"
+
+paren' :: Ctx -> Printer a -> Printer a
+paren' this p = ask >>= \outer->if needsParen this outer then paren p else p
+
+needsParen :: Ctx -> Ctx -> Bool
+needsParen CtxNo _ = False
+needsParen CtxNullary _ = False
+needsParen CtxNonfix CtxNo = False
+needsParen CtxNonfix CtxNonfix = True
+needsParen CtxNonfix (CtxInfix _ _ _) = False
+needsParen (CtxInfix _ _ _) CtxNo = False
+needsParen (CtxInfix _ _ _) CtxNonfix = True
+needsParen (CtxInfix thisassoc thisprio _) (CtxInfix outerassoc outerprio outerbranch)
+    | outerprio > thisprio = True
+    | outerprio == thisprio
+        = thisassoc /= outerassoc || thisassoc /= outerbranch
+    | otherwise = False
+needsParen _ CtxNullary = error "shouldn't occur"
+
+instance Expression Printer where
+    lit = printLit . show
+    (+.) = printBinOp (leftctx 6) "+"
+    (-.) = printBinOp (leftctx 6) "-"
+    (*.) = printBinOp (leftctx 7) "*"
+    (/.) = printBinOp (leftctx 7) "/"
+    (^.) = printBinOp (rightctx 8) "^"
+    neg = printUnOp (nonectx 7) "!"
+    (&.) = printBinOp (rightctx 3) "&"
+    (|.) = printBinOp (rightctx 2) "|"
+    not = printUnOp (nonectx 7) "!"
+    (==.) = printBinOp (nonectx 4) "=="
+    (/=.) = printBinOp (nonectx 4) "/="
+    (<.) = printBinOp (nonectx 4) "<"
+    (>.) = printBinOp (nonectx 4) ">"
+    (<=.) = printBinOp (nonectx 4) "<"
+    (>=.) = printBinOp (nonectx 4) ">"
+    if' p t e = printLit "if" >> p >> printLit "then" >> t >> printLit "else" >> e
+
+freshLabel :: MonadState PS m => String -> m String
+freshLabel prefix = gets fresh >>= \(f:fs)->modify (\s->s {fresh=fs}) >> pure (prefix ++ show f)
+
+instance Function () Printer where
+    fun def = Main $ freshLabel "f" >>= \f->
+        let g :- m = def (\()->printLit (f ++ " ()"))
+        in  printLit ("let " ++ f ++ " () = ") >> g () >> printLit "\n in " >> unmain m
+instance Function (Printer a) Printer where
+    fun def = Main $ freshLabel "f" >>= \f->freshLabel "a" >>= \a->
+        let g :- m = def (\arg->printLit (f ++ " ") >>> arg)
+        in  printLit (concat ["let ", f, " ", a, " = "]) >> g (printLit a) >> printLit " in\n" >> unmain m
+instance Function (Printer a, Printer b) Printer where
+    fun def = Main $ freshLabel "f" >>= \f->freshLabel "a" >>= \a1->freshLabel "a" >>= \a2->
+        let g :- m = def (\(arg1, arg2)->printLit (f ++ " ") >> arg1 >> printLit " " >>> arg2)
+        in  printLit (concat ["let ", f, " ", a1, " ", a2, " = "]) >> g (printLit a1, printLit a2) >> printLit " in\n" >> unmain m
+instance Function (Printer a, Printer b, Printer c) Printer where
+    fun def = Main $
+        freshLabel "f" >>= \f->
+        freshLabel "a" >>= \a1->
+        freshLabel "a" >>= \a2->
+        freshLabel "a" >>= \a3->
+        let g :- m = def (\(arg1, arg2, arg3)->printLit (f ++ " ") >> arg1 >> printLit " " >> arg2 >> printLit " " >>> arg3)
+        in  printLit (concat ["let ", f, " ", a1, " ", a2, " ", a3, " = "]) >> g (printLit a1, printLit a2, printLit a3) >> printLit " in\n" >> unmain m
+
+(>>>) :: Printer a1 -> Printer a2 -> Printer a3
+l >>> r = l >> r >> pure undefined
+
+printBinOp :: Ctx -> String -> Printer a1 -> Printer a2 -> Printer a3
+printBinOp thisctx op l r = paren' thisctx $
+       local (\_->setBranch thisctx CtxLeft) l
+    >> printLit op
+    >> local (\_->setBranch thisctx CtxRight) r
+    >> pure undefined
+
+printUnOp :: Ctx -> String -> Printer a -> Printer a
+printUnOp thisctx op l = paren' thisctx $
+       printLit op
+    >> local (\_->setBranch thisctx CtxRight) l
+
+printCons :: String -> Printer a -> Printer a
+printCons = printUnOp CtxNonfix . (++" ")
+
+printRec :: String -> Printer a -> Printer a
+printRec op l = printUnOp CtxNo (op++" ") (accol l)
diff --git a/datatype/Serialise.hs b/datatype/Serialise.hs
new file mode 100644
index 0000000..524cdb3
--- /dev/null
+++ b/datatype/Serialise.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE DefaultSignatures, FlexibleContexts, TypeOperators #-}
+module Serialise where
+
+import Data.Char
+
+import GHC.Generics
+
+class Serialise a where
+    serialise :: a -> [Int] -> [Int]
+    default serialise :: (Generic a, GSerialise (Rep a)) => a -> [Int] -> [Int]
+    serialise = gserialise . from
+
+class GSerialise f where
+    gserialise :: f a -> [Int] -> [Int]
+
+--Void
+instance GSerialise V1 where
+    gserialise _ = id
+--Unit
+instance GSerialise U1 where
+    gserialise _ = id
+--Pair
+instance (GSerialise a, GSerialise b) => GSerialise (a :*: b) where
+    gserialise (l :*: r) = gserialise l . gserialise r
+--Constants, additional parameters and recursion of kind *
+instance Serialise a => GSerialise (K1 i a) where
+    gserialise (K1 a) = serialise a
+--Either not supported because we don't support sumtypes in our stack machine
+instance (GSerialise a, GSerialise b) => GSerialise (a :+: b) where
+    gserialise (L1 l) = (0:) . gserialise l
+    gserialise (R1 r) = (1:) . gserialise r
+--Datatype, Constructor or Selector
+instance (GSerialise a) => GSerialise (M1 i c a) where
+    gserialise (M1 l) = gserialise l
+
+instance Serialise Int where
+    serialise i = (i:)
+instance Serialise Bool where
+    serialise b = ((if b then 1 else 0):)
+instance Serialise Char where
+    serialise c = (ord c:)
diff --git a/datatype/Tuple.hs b/datatype/Tuple.hs
new file mode 100644
index 0000000..6c6a3d7
--- /dev/null
+++ b/datatype/Tuple.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveGeneric #-}
+module Tuple where
+
+import GHC.Generics
+
+import Printer
+import Compiler
+import Serialise
+import MkCons
+
+data Tuple a b = Tuple a b
+  deriving Generic
+$(mkConsClass ''Tuple)
+
+data Tuple3 a c = Tuple3 a Int c
+  deriving Generic
+$(mkConsClass ''Tuple3)
+
+data TupleR a b = TupleR {first :: a, second :: b}
+  deriving Generic
+$(mkConsClass ''TupleR)
+
+data List a = Nil | Cons a (List a)
+  deriving Generic
+$(mkConsClass ''List)
diff --git a/gopt.icl b/gopt.icl
new file mode 100644
index 0000000..09089ab
--- /dev/null
+++ b/gopt.icl
@@ -0,0 +1,166 @@
+module gopt
+
+import StdEnv, StdGeneric
+
+import Data.List
+import Data.Error
+import Data.Func
+import Data.Functor
+import Data.Tuple
+import Data.Maybe
+import Control.Applicative
+import Control.Monad => qualified join
+import System.CommandLine
+import Text
+
+:: Opt a
+	= BinaryFlag (a -> a) (a -> a)
+	| Flags [(String, ([String] a -> (MaybeError [String] (a, [String]))))]
+	| Positionals [(String, String a -> (MaybeError [String] a))]
+	| SubParsers [(String, Opt a)]
+
+class bifmap m :: (a -> b) (b -> a) (m b) -> m a
+instance bifmap Opt
+where
+	bifmap fr to (BinaryFlag set unset) = BinaryFlag (to o set o fr) (to o unset o fr)
+	bifmap fr to (Flags fs) = Flags $ map (appSnd $ (\f s->fm (appFst to) o f s o fr)) fs
+	bifmap fr to (Positionals fs) = Positionals $ map (appSnd $ fmap $ \f->fm to o f o fr) fs
+	bifmap fr to (SubParsers sp) = SubParsers $ map (appSnd (bifmap fr to)) sp
+
+fm f (Ok a) = Ok (f a)
+fm f (Error e) = Error e
+
+combine sel app p s t = p s (sel t) >>= \l->pure (app (const l) t)
+combine` sel app p s t = p s (sel t) >>= \(l, as)->pure ((app (const l) t), as)
+
+ar0 s f as = Ok o flip tuple as o f
+
+generic gopt a *! :: Opt a
+//generic gopt a :: Opt a
+gopt{|Bool|} = BinaryFlag (const True) (const False)
+gopt{|Int|} = Positionals [("INT", \s _->if (and [isDigit c\\c<-:s]) (Ok $ toInt s) (Error ["Not an integer"]))]
+gopt{|Char|} = Positionals [("CHAR", \s _->if (size s == 1) (Ok s.[0]) (Error ["Not a single character"]))]
+gopt{|String|} = Positionals [("STRING", \s _->Ok s)]
+gopt{|RECORD|} f = bifmap (\(RECORD a)->a) (\x->RECORD x) f
+gopt{|OBJECT|} f = bifmap (\(OBJECT a)->a) (\x->OBJECT x) f
+gopt{|FIELD of {gfd_name}|} f = case f of
+	//Child is a boolean
+	BinaryFlag set unset = mapF $ Flags [(gfd_name, ar0 gfd_name set), ("no-" +++ gfd_name, ar0 ("no-" +++ gfd_name) unset)]
+	//Child is a basic value or a tuple
+	Positionals ps = mapF $ Flags [(gfd_name, ptoarg ps)]
+	//Child is another record, make the arguments ddstyle TODO
+	Flags x = mapF (Flags x)
+	//Child is a subparser
+	SubParsers ps = mapF (Flags [(gfd_name, pOpts (SubParsers ps))])
+	x = abort "Subparsers not supported"
+where
+	mapF :: ((m a) -> m (FIELD a)) | bifmap m
+	mapF = bifmap (\(FIELD a)->a) (\x->FIELD x)
+
+	ptoarg [p] [] i = Error ["Not enough arguments for " +++ gfd_name]
+	ptoarg [(_, p):ps] [a:as] i = p a i >>= ptoarg ps as
+	ptoarg [] as i = Ok (i, as)
+gopt{|PAIR|} l r = case (l, r) of
+	(Positionals pl, Positionals pr)
+		= Positionals
+			$  map (appSnd $ combine PFst appPFst) pl
+			++ map (appSnd $ combine PSnd appPSnd) pr
+	(Flags fl, Flags fr)
+		= Flags
+			$  map (appSnd $ combine` PFst appPFst) fl
+			++ map (appSnd $ combine` PSnd appPSnd) fr
+	(x, y) = abort $ "gopt{|PAIR|}: " +++ consPrint x +++ " " +++ consPrint y
+where
+	appPFst f (PAIR x y) = PAIR (f x) y
+	appPSnd f (PAIR x y) = PAIR x (f y)
+	PFst (PAIR x y) = x
+	PSnd (PAIR x y) = y
+gopt{|UNIT|} = Positionals []
+gopt{|CONS of {gcd_name}|} c = bifmap (\(CONS a)->a) CONS $ SubParsers [(gcd_name, c)]
+gopt{|EITHER|} l r = case (l, r) of
+	(SubParsers sl, SubParsers sr)
+		= SubParsers
+			$  map (appSnd $ bifmap (\(LEFT a)->a) LEFT) sl
+			++ map (appSnd $ bifmap (\(RIGHT a)->a) RIGHT) sr
+gopt{|(,)|} l r = case (l, r) of
+	(Positionals pl, Positionals pr)
+		= Positionals
+			$  map (appSnd $ combine fst appFst) pl
+			++ map (appSnd $ combine snd appSnd) pr
+gopt{|(,,)|} f s t = case (f, s, t) of
+	(Positionals pf, Positionals ps, Positionals pt)
+		= Positionals
+			$  map (appSnd $ combine fst3 appFst3) pf
+			++ map (appSnd $ combine snd3 appSnd3) ps
+			++ map (appSnd $ combine thd3 appThd3) pt
+
+consPrint (Positionals x) = "Positionals"
+consPrint (BinaryFlag x _) = "BinaryFlag"
+consPrint (Flags x) = "Flags"
+consPrint (SubParsers x) = "SubParsers"
+
+parseOpts :: [String] a -> MaybeError [String] (a, [String]) | gopt{|*|} a
+parseOpts args a = pOpts gopt{|*|} args a
+
+pOpts :: (Opt a) [String] a -> MaybeError [String] (a, [String])
+pOpts (Positionals [p:ps]) [] a = Error [toString (length [p:ps]) +++ " positional arguments required"]
+pOpts (Positionals [p:ps]) [arg:args] a = (snd p) arg a >>= pOpts (Positionals ps) args
+pOpts (SubParsers ps) [arg:args] a = case find (\(l,p)->l==arg) ps of
+	Nothing = Error ["Unrecognized subcommand"]
+	Just (l, p) = pOpts p args a
+pOpts (SubParsers ps) [] a = Error ["One of these subcommands required: " +++ join ", " (map fst ps)]
+pOpts (Flags fs) [arg:args] a
+	| not (startsWith "--" arg) = Ok (a, [arg:args])
+	= case find (\(l,p)->"--" +++ l == arg) fs of
+		Nothing = Error ["Unrecognized option: " +++ arg]
+		Just (l, p) = p args a >>= \(a, args)->pOpts (Flags fs) args a
+pOpts (BinaryFlag yes no) args a
+	= pOpts (Positionals [("BOOL", \s v->
+		if (s == "True")
+			(Ok (yes v))
+			(if (s == "False")
+				(Ok (no v))
+				(Error ["Not True or False"])
+			)
+	)]) args a
+pOpts t args a = Ok (a, args)
+
+pHelp :: (Opt a) -> [String]
+pHelp (Positionals []) = []
+pHelp (Positionals [(i, _):ps]) = [i, " ":pHelp $ Positionals ps]
+pHelp (SubParsers ps) =
+	flatten
+	[[n, " ":pHelp opt] ++ ["\n"]
+	\\(n, opt)<-ps
+	]
+pHelp (Flags fs) =
+	["Flags\n"
+	:
+		flatten
+		[["--",f, "\n"]
+		\\(f, p)<-fs
+		]
+	]
+
+:: T =
+	{ field  :: (Int,Int)
+	, field2 :: String
+	, t2 :: C
+	}
+:: T2 = {f :: Int, f2 :: Bool}
+:: C = A Int | B | C Bool
+
+:: ADT
+	= ADT1
+	| ADT2 Int String
+
+derive binumap Opt, [], (,), MaybeError
+derive gopt T, T2, ADT, C
+
+Start w
+# ([argv0:args], w) = getCommandLine w
+//= pHelp opt
+= parseOpts args {field=(0, 0),field2="",t2=A 4}
+
+opt :: Opt T
+opt = gopt{|*|}
diff --git a/slave/cloudiTasks/cloudiTasks.icl b/slave/cloudiTasks/cloudiTasks.icl
deleted file mode 100644
index 09d6fde..0000000
--- a/slave/cloudiTasks/cloudiTasks.icl
+++ /dev/null
@@ -1,149 +0,0 @@
-module cloudiTasks
-
-import Data.Functor
-import Data.Queue
-import iTasks.Internal.Serialization
-import iTasks.Internal.TaskEval
-import iTasks.UI.Editor.Common
-import StdEnv
-import Data.Func
-import Data.Tuple
-import Data.Map.GenJSON
-import iTasks
-import iTasks.Extensions.DateTime
-import iTasks.Internal.Distributed.RemoteTask
-import qualified Data.Map
-import System.Time
-
-:: CloudTaskType = ExistingNode String Int
-
-//mapReadWrite :: !(!r -> r`,!w` r -> Maybe w) !(Maybe (SDSReducer p w w`)) !(sds p r w) -> SDSLens p r` w` | gText{|*|} p & TC p & TC r & TC w & RWShared sds
-
-asyncTask :: CloudTaskType (Task a) -> Task a | iTask a
-asyncTask (ExistingNode host port) t
-	= upd (\tid->(tid, TaskWrapper t)) (remoteShare cloudITasksQueue {domain=host, port=port})
-	>>- \(tid, _)->let rvalue = remoteShare (sdsFocus tid cloudITasksValues) {domain=host,port=port}
-		in Task (proxy NoValue rvalue rvalue)
-where
-	proxy ::
-		//The old task value
-		(TaskValue a)
-		//The original value queue
-		(sds1 () (Queue (TaskValue a, UIChange)) (Queue (TaskValue a, UIChange)))
-		//The temporary value queue
-		(sds2 () (Queue (TaskValue a, UIChange)) (Queue (TaskValue a, UIChange)))
-		Event
-		TaskEvalOpts
-		!*IWorld
-		-> *(TaskResult a, *IWorld) | RWShared sds1 & Readable, Registrable sds2 & iTask a
-	proxy lastVal valueShare tValueShare event {TaskEvalOpts|taskId,lastEval} iworld
-		= case readRegister taskId tValueShare iworld of
-			(Ok (ReadingDone queue), iworld)
-				= case dequeue queue of
-					(Nothing, queue)
-						= (ValueResult
-							lastVal
-							{lastEvent=lastEval, removedTasks=[]}
-							NoChange
-							(Task (proxy lastVal valueShare tValueShare))
-						, iworld)
-					(Just (tv, ui), queue)
-						= case write queue valueShare (TaskContext taskId) iworld of
-							(Ok _, iworld)
-								= (ValueResult
-									tv
-									{lastEvent=lastEval, removedTasks=[]}
-									ui
-									(Task (proxy tv valueShare valueShare))
-								, iworld)
-							(Error e, iworld) = (ExceptionResult e, iworld)
-			(Ok (Reading tValueShare), iworld)
-				= (ValueResult
-					lastVal
-					{lastEvent=lastEval, removedTasks=[]}
-					NoChange
-					(Task (proxy lastVal valueShare tValueShare))
-				, iworld)
-			(Error e, iworld) = (ExceptionResult e, iworld)
-
-Start w = flip doTasksWithOptions w \args eo
-	# (eo, s) = case args of
-		[argv0,"--slave",p] = ({eo & sdsPort=toInt p}, onStartup o slave)
-		_ = (eo, onRequest "/" o master)
-	= Ok (s args, {eo & distributed=True})
-
-JSONEncode{|TaskWrapper|} _ t = [dynamicJSONEncode t]
-JSONDecode{|TaskWrapper|} _ [t:c] = (dynamicJSONDecode t, c)
-JSONDecode{|TaskWrapper|} _ c = (Nothing, c)
-gEq{|TaskWrapper|} _ _ = False
-gEditor{|TaskWrapper|} = emptyEditor
-gText{|TaskWrapper|} tf ma = maybe [] (\_->["TaskWrapper"]) ma
-
-slave :: [String] -> Task ()
-slave args
-	=   get applicationOptions
-	>>- \eo->traceValue ("Slave started on port " +++ toString eo.sdsPort)
-	>-| parallel
-		[(Embedded, \stl->flip (@!) () $ forever $
-			    watch cloudITasksQueueInt
-			>>* [OnValue $ ifValue (not o isEmpty) \[(tid, TaskWrapper task):xs]->
-				    set xs cloudITasksQueueInt
-				>-| appendTask Embedded (\_->wrapTask tid task) stl
-			]
-		)] []
-	@? const NoValue
-where
-	wrapTask :: TaskId (Task a) -> Task () | iTask a
-	wrapTask taskId (Task teval) = Task \event opts iworld->
-		case teval event {TaskEvalOpts|opts & taskId=taskId} iworld of
-			(ValueResult tv tei uic newtask, iworld)
-				= case modify (enqueue (tv, uic)) (sdsFocus taskId cloudITasksValues) EmptyContext iworld of
-					(Ok (ModifyingDone _), iworld)
-						= (ValueResult (() <$ tv) tei uic $ wrapTask taskId newtask, iworld)
-					(Ok _, iworld) = (ExceptionResult $ exception "wrapTask async share????", iworld)
-					(Error e, iworld) = (ExceptionResult e, iworld)
-			(ExceptionResult e, iworld) = (ExceptionResult e, iworld)
-			(DestroyedResult, iworld) = (DestroyedResult, iworld)
-
-derive JSONEncode Queue, Event, Set
-derive JSONDecode Queue, Event, Set
-cloudITasksValues :: SDSLens TaskId (Queue (TaskValue a, UIChange)) (Queue (TaskValue a, UIChange)) | TC, JSONEncode{|*|}, JSONDecode{|*|} a
-cloudITasksValues = sdsTranslate "" toString
-	$ memoryStore "cloudITasks-values" $ Just newQueue
-
-cloudITasksEvents :: SDSLens TaskId (Queue Event) (Queue Event)
-cloudITasksEvents = sdsTranslate "" toString
-	$ memoryStore "cloudITasks-events" $ Just newQueue
-
-nextTaskIdShare :: SDSSource () TaskId ()
-nextTaskIdShare = SDSSource
-	{ SDSSourceOptions
-	| name  = "nextTaskIdShare"
-	, read  = \_->appFst Ok o getNextTaskId
-	, write = \_ _->tuple $ Ok (\_ _->True)
-	}
-
-cloudITasksQueue :: SDSLens () TaskId (TaskId, TaskWrapper)
-cloudITasksQueue =
-	mapReadWrite
-		( \(nextTaskId, _)->nextTaskId
-		, \newTask (nextTaskId, tasks)->Just ((), [newTask:tasks])
-		) Nothing (nextTaskIdShare >*< cloudITasksQueueInt)
-
-cloudITasksQueueInt :: SimpleSDSLens [(TaskId, TaskWrapper)]
-cloudITasksQueueInt = sdsFocus "queue" $ memoryStore "cloudITasks" (Just [])
-
-master :: [String] -> Task ()
-master args
-	= get applicationOptions
-	>>- \eo->traceValue ("Master started on port " +++ toString eo.serverPort)
-	>-| asyncTask (ExistingNode "localhost" 9099) (traceValue "boink")
-	@! ()
-
-blockWait :: Int -> Task Int
-blockWait i = accWorld (sleep i)
-where
-	sleep :: !Int !*e -> (!Int, !*e)
-	sleep _ _ = code {
-			ccall sleep "I:I:A"
-		}
diff --git a/test.icl b/test.icl
index ed64bbc..0093bb4 100644
--- a/test.icl
+++ b/test.icl
@@ -1,19 +1,18 @@
 module test
 
+//import Data.Func
 import iTasks
-import Data.Func
 
-Start w = doTasks t w
+Start w = doTasks (onStartup par) w
 where
-	t = parallel
-		[(Embedded, \stl->tune (Title "New Task") $ addTask stl
-			>>* [OnAction (Action "Close") (always (return ()))])
-		] [] <<@ ArrangeWithTabs True
-
-	addTask :: (SharedTaskList ()) -> Task ()
-	addTask stl
-		=   (enterInformation [] <<@ Label "Title") -&&- updateInformation [] "text"
-		>>! \(title, text)->appendTask Embedded
-			(\_->tune (Title title) $ viewInformation [] text @? const NoValue)
-			stl
-		>-| addTask stl
+	par :: Task [(Int, TaskValue ())]
+	par = parallel [] []
+//Start w = doTasks (onStartup $ m >>- traceValue) w
+//
+//m = parallel
+//	[(Embedded, \stl->return 42)]
+//	[]
+//	[OnValue $ \tv->case tv of
+//		NoValue = ?None
+//		_ = ?None
+//	]