Overloading IO functions in step; POC derivation tree generation

8 files changed, 181 insertions, 31 deletions

diff --git a/.gitignore b/.gitignore
index 528d3f4..1eabc20 100644
--- a/.gitignore
+++ b/.gitignore
@@ -2,6 +2,7 @@
 *.exe
 *.out
 run
+tree
 
 # Directory used to store object files, abc files and assembly files
 Clean System Files/
diff --git a/Makefile b/Makefile
index 4adbd65..a32c219 100644
--- a/Makefile
+++ b/Makefile
@@ -1,5 +1,5 @@
 CPM=cpm
-OBJ=run
+OBJ=run tree
 DEPS=Smurf.dcl Smurf.icl SmurfParse.dcl SmurfParse.icl
 
 all: $(OBJ)
diff --git a/Smurf.dcl b/Smurf.dcl
index 7d75a6d..25ea30b 100644
--- a/Smurf.dcl
+++ b/Smurf.dcl
@@ -24,6 +24,15 @@ from Data.Maybe import ::Maybe
            , store :: Store
            }
 
+:: IO io = IO (io -> .(String, io)) (String io -> io)
+
+:: ListIO = { input  :: [String]
+            , output :: [String]
+            }
+
+:: Transition = (-->) infix 1 (Program, [String], State) ([String], [String], State)
+:: DerivationTree :== [Transition]
+
 derive gEq Stm
 
 instance == Stm
@@ -34,6 +43,13 @@ instance fromChar Stm
 instance zero State
 instance toString State
 
-step :: !Program State !*File -> *(Maybe (!Program, State), *File)
-run :: !Program State *File -> *(Maybe State, *File)
+instance zero ListIO
+
+instance toString Transition
+instance toString DerivationTree
+
+step :: !Program State u:io u:(IO u:io) -> u:(Maybe (!Program, State), u:io)
+run :: !Program State io (IO io) -> (Maybe State, io)
 
+listIO :: IO ListIO
+tree :: !Program !State !ListIO (IO ListIO) -> Maybe DerivationTree
diff --git a/Smurf.icl b/Smurf.icl
index 4c7e0c2..7223ce7 100644
--- a/Smurf.icl
+++ b/Smurf.icl
@@ -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]
diff --git a/run.icl b/run.icl
index fd90027..64ef079 100644
--- a/run.icl
+++ b/run.icl
@@ -45,10 +45,12 @@ where
     loop :: Bool ![Stm] !Program !State !*File -> *File
     loop v brk p st f
 	# p = if v (trace (foldl (+++) "" (map toString p) +++ "\n") p) p
-    # (mbProgSt, f) = step p st f
+    # (mbProgSt, f) = step p st f iofunc
     | isNothing mbProgSt = f <<< "NOTHING!!!\n"
     # (prog, st) = fromJust mbProgSt
-    | isEmpty prog = f <<< "\n---------------------------\n" <<< toString st
+    | isEmpty prog
+		| v = f <<< "\n---------------------------\n" <<< toString st
+		= f
 	| not (isBrk prog) = loop v brk prog st f
     # f = f <<< "---> " <<< toString (hd prog) <<< " ? "
     # (cmd, f) = freadline f
@@ -62,6 +64,17 @@ where
 		isBrk [(Push _):_] = isMember (Push "") brk
 		isBrk [stm:_] = isMember stm brk
 
+		iofunc :: *IO *File
+		iofunc = IO read show
+		where
+			read :: *File -> *(String, *File)
+			read f
+				# (s, f) = freadline f
+				= (s % (0, size s - 2), f)
+
+			show :: String *File -> *File
+			show s f = f <<< s
+
 	options = [ Option ['i'] ["infile"]
 	              (ReqArg IFile "FILE")            "Smurf file"
 	          , Option ['b'] ["break"]
diff --git a/run.prj b/run.prj
index b6fa407..f9c3681 100644
--- a/run.prj
+++ b/run.prj
@@ -40,6 +40,7 @@ Global
 	Paths
 		Path:	{Project}/
 		Path:	{Application}/lib/Generics/
+		Path:	{Application}/lib/StdLib/
 		Path:	{Application}/lib/clean-platform/OS-Independent/
 		Path:	{Application}/lib/clean-platform/OS-Linux-64/
 	Precompile:	
diff --git a/tree.icl b/tree.icl
new file mode 100644
index 0000000..82e0ae9
--- /dev/null
+++ b/tree.icl
@@ -0,0 +1,16 @@
+module tree
+
+import StdEnv
+
+import Data.Maybe, Data.List
+from Data.Func import $
+
+import System.CommandLine, System.GetOpt
+
+import Smurf
+import SmurfParse
+
+Start = toString devtree
+where
+	(Just devtree) = tree pgm zero zero listIO
+	(Just pgm) = parse ['"abc""123"+o']
diff --git a/tree.prj b/tree.prj
new file mode 100644
index 0000000..3859aa8
--- /dev/null
+++ b/tree.prj
@@ -0,0 +1,61 @@
+Version: 1.4
+Global
+	ProjectRoot:	.
+	Target:	StdEnv
+	Exec:	{Project}/tree
+	CodeGen
+		CheckStacks:	False
+		CheckIndexes:	True
+	Application
+		HeapSize:	2097152
+		StackSize:	512000
+		ExtraMemory:	8192
+		IntialHeapSize:	204800
+		HeapSizeMultiplier:	4096
+		ShowExecutionTime:	False
+		ShowGC:	False
+		ShowStackSize:	False
+		MarkingCollector:	False
+		DisableRTSFlags:	False
+		StandardRuntimeEnv:	True
+		Profile
+			Memory:	False
+			MemoryMinimumHeapSize:	0
+			Time:	False
+			Stack:	False
+		Output
+			Output:	BasicValuesOnly
+			Font:	Monaco
+			FontSize:	9
+			WriteStdErr:	False
+	Link
+		LinkMethod:	Static
+		GenerateRelocations:	False
+		GenerateSymbolTable:	False
+		GenerateLinkMap:	False
+		LinkResources:	False
+		ResourceSource:	
+		GenerateDLL:	False
+		ExportedNames:	
+	Paths
+		Path:	{Project}/
+		Path:	{Application}/lib/Generics/
+		Path:	{Application}/lib/StdLib/
+		Path:	{Application}/lib/clean-platform/OS-Independent/
+		Path:	{Application}/lib/clean-platform/OS-Linux-64/
+	Precompile:	
+	Postlink:	
+MainModule
+	Name:	tree
+	Dir:	{Project}
+	Compiler
+		NeverMemoryProfile:	False
+		NeverTimeProfile:	False
+		StrictnessAnalysis:	True
+		ListTypes:	StrictExportTypes
+		ListAttributes:	True
+		Warnings:	True
+		Verbose:	True
+		ReadableABC:	False
+		ReuseUniqueNodes:	True
+		Fusion:	False