1 files changed, 118 insertions, 0 deletions
diff --git a/Smurf.icl b/Smurf.icl
new file mode 100644
index 0000000..f00ef65
--- /dev/null
+++ b/Smurf.icl
@@ -0,0 +1,118 @@
+implementation module Smurf
+
+from StdFunc import o, flip
+import StdArray
+import StdList
+import StdString
+import StdTuple
+import StdFile
+
+from Data.Func import $
+import Control.Applicative
+import Control.Monad
+import Data.Maybe
+
+import SmurfParse
+
+instance zero [a] where zero = []
+
+instance toString Stm
+where
+    toString (Push s) = "\"" +++ s +++ "\""
+    toString Input = "i"
+    toString Output = "o"
+    toString Cat = "+"
+    toString Head = "h"
+    toString Tail = "t"
+    toString Quotify = "q"
+    toString Put = "p"
+    toString Get = "g"
+    toString Exec = "x"
+
+instance zero State where zero = { stack = zero, store = zero }
+
+instance toString State
+where
+    toString {stack, store}
+        = "Stack:\n"
+            +++ foldl (+++) "" ["  " +++ val +++ "\n" \\ val <- stack]
+            +++ "Store:\n"
+            +++ foldl (+++) "" ["  " +++ var +++ " : " +++ val +++ "\n"
+                                    \\ (var, val) <- store]
+
+run :: !Program State *File -> *(Maybe State, *File)
+run prog st io
+    # (mbProgSt, io) = step prog st io
+    | isNothing mbProgSt = (Nothing, io)
+    # (prog, st) = fromJust mbProgSt
+    = if (isEmpty prog) (Just st, io) (run prog st io)
+
+step :: !Program State !*File -> *(Maybe (!Program, State), *File)
+step [] st io
+    = (pure ([], st), io)
+step [Push s:p] st io
+    = (pure (p, { st & stack = push s st.stack }), io)
+step [Input:p] st io
+    # (ip, io) = freadline io
+    # ip = ip % (0, size ip - 2)
+    = (pure (p, { st & stack = push ip st.stack }), io)
+step [Output:p] st io
+    # mbSStk = pop st.stack
+    | isNothing mbSStk = (empty, io)
+    # (s, stk) = fromJust mbSStk
+    = (pure (p, { st & stack = stk }), io <<< s)
+step [Cat:p] st io
+    = (pop st.stack >>= \(x,stk) -> pop stk >>= \(y,stk`) ->
+        pure (p, { st & stack = push (y +++ x) stk` }), io)
+step [Head:p] st io
+    = (pop st.stack >>= \(x,stk) -> head x >>= \x` ->
+        pure (p, { st & stack = push x` stk }), io)
+step [Tail:p] st io
+    = (pop st.stack >>= \(x,stk) -> tail x >>= \x` ->
+        pure (p, { st & stack = push x` stk }), io)
+step [Quotify:p] st io
+    = (pop st.stack >>= \(x,stk) ->
+        pure (p, { st & stack = push (quotify x) stk }), io)
+step [Put:p] st io
+    = (pop st.stack >>= \(var,stk) -> pop stk >>= \(val,stk`) ->
+        pure (p, { st & stack = stk`, store = put var val st.store }), io)
+step [Get:p] st io
+    = (pop st.stack >>= \(var,stk) ->
+        pure (p, { st & stack = push (get var st.store) stk }), io)
+step [Exec:p] st io
+    = (pop st.stack >>= parse o fromString o fst >>= \p ->
+        pure (p, zero), io)
+
+push :: String Stack -> Stack
+push s st = [s:st]
+
+pop :: Stack -> Maybe (String, Stack)
+pop [] = empty
+pop [s:ss] = pure (s, ss)
+
+head :: String -> Maybe String
+head "" = empty
+head s = pure $ s % (0,0)
+
+tail :: String -> Maybe String
+tail "" = empty
+tail s = pure $ s % (1, size s - 1)
+
+put :: String String Store -> Store
+put var val store = [(var,val) : filter ((<>)var o fst) store]
+
+get :: String Store -> String
+get var store = case filter ((==)var o fst) store of [] = ""; [(_,val):_] = val
+
+quotify :: (String -> String)
+quotify = (flip (+++) "\"") o ((+++)"\"") o toString o quot o fromString
+where
+    quot :: [Char] -> [Char]
+    quot []        = []
+    quot ['\\':cs] = ['\\':'\\':quot cs]
+    quot ['\n':cs] = ['\\':'n':quot cs]
+    quot ['\r':cs] = ['\\':'r':quot cs]
+    quot ['\t':cs] = ['\\':'t':quot cs]
+    quot ['"':cs]  = ['\\':'"':quot cs]
+    quot [c:cs]    = [c:quot cs]
+