Add debug flag, phrase handling words

7 files changed, 131 insertions, 34 deletions

diff --git a/samples/comparisons.sample b/samples/comparisons.sample
new file mode 100644
index 0000000..aea6387
--- /dev/null
+++ b/samples/comparisons.sample
@@ -0,0 +1,2 @@
+define gte?     lt? not ;
+define lte?     gt? not ;
diff --git a/samples/eval.sample b/samples/eval.sample
new file mode 100644
index 0000000..927621b
--- /dev/null
+++ b/samples/eval.sample
@@ -0,0 +1,14 @@
+define update
+    $update_var !
+    $update_phrase !
+    $update_var @ @ $update_phrase @ unphrase
+    $update_var @ !
+    $update_var forget $update_phrase forget
+    ;
+
+10 $num !
+[ 1 + ] $num update
+$num ?
+
+[ 5 / ] $num update
+$num ?
\ No newline at end of file
diff --git a/samples/list.sample b/samples/list.sample
new file mode 100644
index 0000000..914522f
--- /dev/null
+++ b/samples/list.sample
@@ -0,0 +1,17 @@
+define prepend
+    $prepend_val !
+    $prepend_phrase !
+    '[ $prepend_val @ $prepend_phrase @ unphrase '] phrase
+    $prepend_val forget $prepend_phrase forget
+    ;
+
+define append
+    $append_val !
+    $append_phrase !
+    '[ $append_phrase @ unphrase $append_val @ '] phrase
+    $append_val forget $append_phrase forget
+    ;
+
+[ 2 3 ] 1 prepend .
+[ 2 3 ] 4 append .
+[ 1 2 3 ] pop . .
\ No newline at end of file
diff --git a/samples/modulo.sample b/samples/modulo.sample
new file mode 100644
index 0000000..235d135
--- /dev/null
+++ b/samples/modulo.sample
@@ -0,0 +1,5 @@
+10 $idx !
+[ $idx @ dup 0 gt? ]
+    [ 2 mod 0 eq? .
+      $idx @ 1 - $idx ! ] loop
+drop
\ No newline at end of file
diff --git a/samples/recursion.sample b/samples/recursion.sample
new file mode 100644
index 0000000..7dc833b
--- /dev/null
+++ b/samples/recursion.sample
@@ -0,0 +1,7 @@
+define factorial
+--  Integer -> Integer
+    dup 0 eq? not
+        [ dup 1 - factorial * ]
+        [ drop 1 ] cond ;
+
+5 factorial .
diff --git a/src/main.hs b/src/main.hs
index 6cb8fc0..551714b 100644
--- a/src/main.hs
+++ b/src/main.hs
@@ -8,8 +8,23 @@ import Debug.Trace (trace, traceShow)
 import System.Environment (getArgs)
 import Utils
 
-getFilename [] = error "empty argument list"
-getFilename (f : fs) = f
+data Config = Config
+  { configFileNameM :: Maybe String,
+    configDebugMode :: Bool
+  }
+
+getConfig config [] = config
+getConfig config ("--debug" : rest) =
+  let newConfig = config {configDebugMode = True}
+   in getConfig newConfig rest
+getConfig config (fileName : rest) =
+  let newConfig = config {configFileNameM = Just fileName}
+   in getConfig newConfig rest
+
+debugPrint Config {configDebugMode = mode} message =
+  if mode
+    then putStrLn $ "[debug] " ++ message
+    else pure ()
 
 data LWord
   = LSymbol String
@@ -25,7 +40,7 @@ reprWord (LInteger a) = show a
 reprWord (LFloat a) = show a
 reprWord (LBool a) = show a
 reprWord (LVariable a) = a
-reprWord (LPhrase a) = "P[ " ++ unwords (map reprWord a) ++ " ]"
+reprWord (LPhrase a) = "P[ " ++ map reprWord a $> reverse .> unwords ++ " ]"
 
 data LState = LState
   { lDict :: Map String LWord,
@@ -38,13 +53,16 @@ data LState = LState
 
 evalMode state = lPhraseDepth state == 0
 
-debugState state = do
-  putStrLn $ "stack:         " ++ unwords (map reprWord (lStack state))
-  putStrLn $ "source:        " ++ unwords (map reprWord (lSource state))
-  putStrLn $ "defs:          " ++ unwords (M.keys (lDefs state))
-  putStrLn $ "dict:          " ++ unwords (M.keys (lDict state))
-  putStrLn $ "lPhraseDepth:  " ++ show (lPhraseDepth state)
-  putStrLn ""
+debugState Config {configDebugMode = mode} state =
+  if mode
+    then do
+      putStrLn $ "stack:         " ++ unwords (map reprWord (lStack state))
+      putStrLn $ "source:        " ++ unwords (map reprWord (lSource state))
+      putStrLn $ "defs:          " ++ unwords (M.keys (lDefs state))
+      putStrLn $ "dict:          " ++ unwords (M.keys (lDict state))
+      putStrLn $ "lPhraseDepth:  " ++ show (lPhraseDepth state)
+      putStrLn ""
+    else pure ()
 
 parseWord rawStr
   | isIntStr rawStr = LInteger (read rawStr)
@@ -54,13 +72,13 @@ parseWord rawStr
 
 parseSource source = source $> words .> map parseWord
 
-interpretSource :: LState -> IO ()
-interpretSource LState {lSource = []} = pure ()
-interpretSource state@LState {lSource = (word : rest)} = do
+interpretSource :: Config -> LState -> IO ()
+interpretSource config LState {lSource = []} = pure ()
+interpretSource config state@LState {lSource = (word : rest)} = do
   newState <- interpretWord state {lSource = rest} word
-  -- putStrLn $ "[debug] processed " ++ show word ++ ", newState ="
-  -- debugState newState
-  interpretSource newState
+  debugPrint config $ "processed " ++ show word ++ ", newState ="
+  debugState config newState
+  interpretSource config newState
 
 interpretWord :: LState -> LWord -> IO LState
 -- non-nestable structures
@@ -103,6 +121,7 @@ interpretWord state@LState {lDefs = defs, lDict = dict, lSource = source, lPhras
         case symbol of
           "dup" -> pure $ state {lStack = head stack : stack}
           "drop" -> pure $ state {lStack = tail stack}
+          "clear" -> pure $ state {lStack = []}
           "noop" -> pure state
           "true" -> pure $ state {lStack = LBool True : stack}
           "false" -> pure $ state {lStack = LBool False : stack}
@@ -123,6 +142,10 @@ interpretWord state@LState {lDefs = defs, lDict = dict, lSource = source, lPhras
             let (LVariable a : stack') = stack
                 lookupWord = dict ! a
              in pure $ state {lStack = lookupWord : stack'}
+          "forget" ->
+            let (LVariable a : stack') = stack
+                newDict = M.delete a dict
+             in pure $ state {lStack = stack', lDict = newDict}
           "." -> do
             let (a : stack') = stack
             putStrLn $ reprWord a
@@ -142,11 +165,15 @@ interpretWord state@LState {lDefs = defs, lDict = dict, lSource = source, lPhras
              in pure $ state {lStack = result : stack'}
           "*" ->
             let (a : b : stack') = stack
-                result = lMultiplyNumbers a b
+                result = lMultiplyNumbers b a
              in pure $ state {lStack = result : stack'}
           "/" ->
             let (a : b : stack') = stack
-                result = lDivideNumbers a b
+                result = lDivideNumbers b a
+             in pure $ state {lStack = result : stack'}
+          "mod" ->
+            let (a : b : stack') = stack
+                result = lModNumbers b a
              in pure $ state {lStack = result : stack'}
           "eq?" ->
             let (a : b : stack') = stack
@@ -157,6 +184,21 @@ interpretWord state@LState {lDefs = defs, lDict = dict, lSource = source, lPhras
           "lt?" ->
             let (a : b : stack') = stack
              in pure $ state {lStack = lLesserThan b a : stack'}
+          "unphrase" ->
+            let (LPhrase phrase : stack') = stack
+             in pure $ state {lSource = reverse phrase ++ source, lStack = stack'}
+          "phrase" ->
+            let (LSymbol "]" : stack') = stack
+                (body, _ : newStack) = break (== LSymbol "[") stack'
+             in pure $ state {lStack = LPhrase body : newStack}
+          "pop" ->
+            let (LPhrase phrase : stack') = stack
+                (first : rest) = reverse phrase
+             in pure $ state {lStack = first : LPhrase (reverse rest) : stack'}
+          "']" ->
+            pure $ state {lStack = LSymbol "]" : stack}
+          "'[" ->
+            pure $ state {lStack = LSymbol "[" : stack}
           "cond" ->
             let (fb : tb : (LBool cond) : stack') = stack
                 LPhrase branch = if cond then tb else fb
@@ -170,44 +212,53 @@ interpretWord state@LState {lDefs = defs, lDict = dict, lSource = source, lPhras
           _ -> error $ "[error] not defined: " ++ symbol
   | otherwise = pure $ state {lStack = word : stack}
 
--- error
--- interpretWord state other = error $ "[error] runtime error at " ++ show other ++ "\ninterpreter state at time of error:\n" ++ show state
-
 lAddNumbers (LInteger a) (LInteger b) = LInteger (a + b)
 lAddNumbers (LFloat a) (LFloat b) = LFloat (a + b)
-lAddNumbers a b = error $ "[error] sum it not defined for " ++ show a ++ ", " ++ show b
+lAddNumbers a b = error $ "[error] sum is not defined for " ++ show a ++ ", " ++ show b
 
 lSubNumbers (LInteger a) (LInteger b) = LInteger (a - b)
 lSubNumbers (LFloat a) (LFloat b) = LFloat (a - b)
-lSubNumbers a b = error $ "[error] difference it not defined for " ++ show a ++ ", " ++ show b
+lSubNumbers a b = error $ "[error] difference is not defined for " ++ show a ++ ", " ++ show b
 
 lMultiplyNumbers (LInteger a) (LInteger b) = LInteger (a * b)
 lMultiplyNumbers (LFloat a) (LFloat b) = LFloat (a * b)
-lMultiplyNumbers a b = error $ "[error] product it not defined for " ++ show a ++ ", " ++ show b
+lMultiplyNumbers a b = error $ "[error] product is not defined for " ++ show a ++ ", " ++ show b
 
 lDivideNumbers (LInteger a) (LInteger b) = LInteger (a `div` b)
 lDivideNumbers (LFloat a) (LFloat b) = LFloat (a / b)
-lDivideNumbers a b = error $ "[error] product it not defined for " ++ show a ++ ", " ++ show b
+lDivideNumbers a b = error $ "[error] product is not defined for " ++ show a ++ ", " ++ show b
 
 lGreaterThan (LInteger a) (LInteger b) = LBool (a > b)
 lGreaterThan (LFloat a) (LFloat b) = LBool (a > b)
-lGreaterThan a b = error $ "[error] greater-than it not defined for " ++ show a ++ ", " ++ show b
+lGreaterThan a b = error $ "[error] greater-than is not defined for " ++ show a ++ ", " ++ show b
 
 lLesserThan (LInteger a) (LInteger b) = LBool (a < b)
 lLesserThan (LFloat a) (LFloat b) = LBool (a < b)
-lLesserThan a b = error $ "[error] lesser-than it not defined for " ++ show a ++ ", " ++ show b
+lLesserThan a b = error $ "[error] lesser-than is not defined for " ++ show a ++ ", " ++ show b
+
+lModNumbers (LInteger a) (LInteger b) = LInteger (a `mod` b)
+lModNumbers a b = error $ "[error] modulo is not defined for " ++ show a ++ ", " ++ show b
 
 main :: IO ()
 main = do
   args <- getArgs
-  let filename = getFilename args
-  putStrLn $ "[info] executing file " ++ filename
-  source <- readFile filename
-  -- putStrLn source
+  let initialConfig =
+        Config
+          { configFileNameM = Nothing,
+            configDebugMode = False
+          }
+  let config = getConfig initialConfig args
+  let fileName = case configFileNameM config of
+        Just x -> x
+        Nothing -> error "[error] no file name specified"
+
+  debugPrint config $ "executing file " ++ fileName
+  source <- readFile fileName
+
   let sourceWoComments = source $> lines .> filter (\line -> not ("--" `isPrefixOf` line)) .> unlines
   let parsed = parseSource sourceWoComments
-  -- putStrLn $ "[info] parsed words:\n" ++ show parsed
-  putStrLn "[info] interpreter output:"
+  debugPrint config $ "parsed words:\n" ++ show parsed
+  debugPrint config "interpreter output:"
   let initialState =
         LState
           { lDict = M.empty,
@@ -216,4 +267,4 @@ main = do
             lDefs = M.empty,
             lSource = parsed
           }
-  interpretSource initialState
+  interpretSource config initialState
diff --git a/src/utils.hs b/src/utils.hs
index e3c0150..7618f5b 100644
--- a/src/utils.hs
+++ b/src/utils.hs
@@ -1,4 +1,5 @@
 module Utils where
+
 import qualified Data.Bifunctor as B
 
 (.>) = flip (.)