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]