diff options
Diffstat (limited to 'Smurf.icl')
| -rw-r--r-- | Smurf.icl | 94 |
1 files changed, 68 insertions, 26 deletions
@@ -11,12 +11,19 @@ from Data.Func import $ import Control.Applicative import Control.Monad import Data.Maybe +import Data.List +from Text import class Text(concat), instance Text String import GenEq +import GenPrint import SmurfParse derive gEq Stm +derive gPrint (,) + +(<+) infixr 5 :: a b -> String | toString a & toString b +(<+) a b = toString a +++ toString b instance == Stm where == a b = a === b @@ -52,55 +59,67 @@ where instance zero State where zero = { stack = zero, store = zero } +instance zero ListIO where zero = {input=[], output=[]} + 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 + toString {stack,store} = "(" <+ printToString stack <+ "," <+ printToString store <+ ")" + +instance toString Transition +where + toString ((p1, ip1, st1) --> (ip2, op, st2)) + = "<" <+ simple 2 p1 <+ "," <+ st1 <+ "," <+ printToString ip1 <+ "> -> (" + <+ printToString ip2 <+ "," <+ printToString op <+ "," <+ st2 <+ ")" + where + simple :: !Int !Program -> String + simple _ [] = "λ" + simple i pgm + | i <= length pgm = concat $ intersperse ":" $ map toString pgm + = concat $ intersperse ":" $ map toString (take i pgm) + +instance toString DerivationTree +where + toString ts = concat $ intersperse "\n" $ map toString $ reverse ts + +run :: !Program State io (IO io) -> (Maybe State, io) +run prog st io iofuncs + # (mbProgSt, io) = step prog st io iofuncs | isNothing mbProgSt = (Nothing, io) # (prog, st) = fromJust mbProgSt - = if (isEmpty prog) (Just st, io) (run prog st io) + = if (isEmpty prog) (Just st, io) (run prog st io iofuncs) -step :: !Program State !*File -> *(Maybe (!Program, State), *File) -step [] st io +step :: !Program State u:io u:(IO u:io) -> u:(Maybe (!Program, State), u:io) +step [] st io _ = (pure ([], st), io) -step [Push s:p] 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) +step [Input:p] st io (IO input _) + # (ip, io) = input io = (pure (p, { st & stack = push ip st.stack }), io) -step [Output:p] st io +step [Output:p] st io (IO _ output) # mbSStk = pop st.stack | isNothing mbSStk = (empty, io) # (s, stk) = fromJust mbSStk - = (pure (p, { st & stack = stk }), io <<< s) -step [Cat:p] st io + = (pure (p, { st & stack = stk }), output s io) +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 +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 +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 +step [Quotify:p] st io _ = (pop st.stack >>= \(x,stk) -> pure (p, { st & stack = push (quotify x) stk }), io) -step [Put:p] st 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 +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 +step [Exec:p] st io _ = (pop st.stack >>= parse o fromString o fst >>= \p -> pure (p, zero), io) @@ -137,3 +156,26 @@ where quot ['"':cs] = ['\\':'"':quot cs] quot [c:cs] = [c:quot cs] +listIO :: IO ListIO +listIO = IO read write +where + read :: ListIO -> (String, ListIO) + read io=:{input} = (hd input, { io & input=tl input }) + + write :: String ListIO -> ListIO + write s io=:{output} = { io & output=output ++ [s] } + +tree :: !Program !State !ListIO (IO ListIO) -> Maybe DerivationTree +tree pgm st io iof + # init = (pgm, io.input, st) + # (mbPgmSt, io) = step pgm st io iof + | isNothing mbPgmSt = empty + # (pgm, st) = fromJust mbPgmSt + | isEmpty pgm = pure [ init --> (io.input, io.output, st) + , ([],io.input,st) --> (io.input,[],st) + ] + # mbTree = tree pgm st io iof + | isNothing mbTree = empty + # tree = fromJust mbTree + # [child=:(_ --> final):children] = fromJust mbTree + = pure [init --> final:child:children] |