Move interpreter stuff under interpreter.hs

3 files changed, 245 insertions, 237 deletions

diff --git a/src/interpreter.hs b/src/interpreter.hs
new file mode 100644
index 0000000..6eb6697
--- /dev/null
+++ b/src/interpreter.hs
@@ -0,0 +1,214 @@
+module Interpreter where
+
+import Data.Char
+import Data.Map (Map, (!))
+import qualified Data.Map as M
+import LTypes
+import System.IO (BufferMode (NoBuffering), hSetBuffering, stdin)
+import Utils
+
+debugWaitForChar Config {configDebugMode = mode} =
+  if mode
+    then do
+      hSetBuffering stdin NoBuffering
+      c <- getChar
+      pure $ case c of
+        'q' -> ExecExit
+        _ -> ExecContinue
+    else pure ExecContinue
+
+debugPrint Config {configDebugMode = mode} message =
+  if mode
+    then putStrLn $ "[debug] " ++ message
+    else pure ()
+
+interpretSource :: Config -> LState -> IO ()
+interpretSource config LState {lSource = []} = pure ()
+interpretSource config state@LState {lSource = (word : rest)} = do
+  newState <- interpretWord state {lSource = rest} word
+  debugPrint config $ "processed " ++ show word ++ ", newState ="
+  debugState config newState
+  step <- debugWaitForChar config
+  case step of
+    ExecContinue -> interpretSource config newState
+    ExecExit -> pure ()
+
+interpretWord :: LState -> LWord -> IO LState
+-- non-nestable structures
+interpretWord state@LState {lStack = stack, lPhraseDepth = phraseDepth} word@(LSymbol "define") =
+  pure $
+    state
+      { lPhraseDepth = phraseDepth + 1,
+        lStack = word : stack
+      }
+interpretWord state@LState {lDefs = defs, lStack = stack, lPhraseDepth = phraseDepth} word@(LSymbol ";") =
+  let defineSpan = takeWhile (\word -> word /= LSymbol "define") stack
+      newStack = dropWhile (\word -> word /= LSymbol "define") stack $> tail
+      ((LSymbol identifier) : body) = reverse defineSpan
+      newDefs = M.insert identifier body defs
+   in pure $
+        state
+          { lPhraseDepth = phraseDepth - 1,
+            lDefs = newDefs,
+            lStack = newStack
+          }
+-- words that simply move from source to stack
+interpretWord state@LState {lStack = stack} word@(LInteger _) = pure $ state {lStack = word : stack}
+interpretWord state@LState {lStack = stack} word@(LFloat _) = pure $ state {lStack = word : stack}
+interpretWord state@LState {lStack = stack} word@(LBool _) = pure $ state {lStack = word : stack}
+interpretWord state@LState {lStack = stack} word@(LChar _) = pure $ state {lStack = word : stack}
+interpretWord state@LState {lStack = stack} word@(LLabel _) = pure $ state {lStack = word : stack}
+interpretWord state@LState {lStack = stack} word@(LPhrase _) = pure $ state {lStack = word : stack}
+-- string literals
+interpretWord state@LState {lSource = source, lStrLitRefMap = strLitRefMap} (LStringLitRef ref) =
+  let strLitP = strLitRefMap ! ref
+   in pure $ state {lSource = strLitP ++ source}
+-- phrase markers are always evaled
+interpretWord state@LState {lStack = stack, lPhraseDepth = phraseDepth} word@(LSymbol "[") =
+  pure $ state {lPhraseDepth = phraseDepth + 1, lStack = word : stack}
+interpretWord state@LState {lStack = stack, lPhraseDepth = phraseDepth} word@(LSymbol "]") =
+  let (phrase, stack') = break (== LSymbol "[") stack
+      newStack = LPhrase (reverse phrase) : tail stack'
+   in pure $ state {lPhraseDepth = phraseDepth - 1, lStack = newStack}
+-- definition lookup
+interpretWord state@LState {lDefs = defs, lDict = dict, lSource = source, lPhraseDepth = phraseDepth, lStack = stack} word@(LSymbol symbol)
+  | phraseDepth == 0 =
+    case M.lookup symbol defs of
+      Just body -> pure $ state {lSource = body ++ source}
+      Nothing ->
+        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}
+          "not" ->
+            let (LBool a : stack') = stack
+             in pure $ state {lStack = LBool (not a) : stack'}
+          "float" ->
+            let (LInteger a : stack') = stack
+             in pure $ state {lStack = LFloat (fromIntegral a) : stack'}
+          "round" ->
+            let (LFloat a : stack') = stack
+             in pure $ state {lStack = LInteger (round a) : stack'}
+          "!" ->
+            let (LLabel a : b : stack') = stack
+                newDict = M.insert a b dict
+             in pure $ state {lDict = newDict, lStack = stack'}
+          "@" ->
+            let (LLabel a : stack') = stack
+                lookupWord = dict ! a
+             in pure $ state {lStack = lookupWord : stack'}
+          "forget" ->
+            let (LLabel a : stack') = stack
+                newDict = M.delete a dict
+             in pure $ state {lStack = stack', lDict = newDict}
+          "." -> do
+            let (a : stack') = stack
+            putStrLn $ reprWord a
+            pure $ state {lStack = stack'}
+          "s." -> do
+            let (word@(LPhrase ws) : stack') = stack
+            let isLChar w = case w of LChar _ -> True; _ -> False
+            if not (all isLChar ws)
+              then error $ "[error] cannot string-print heterogenous phrase: " ++ reprWord word
+              else pure ()
+            let stringRepr = ws $> map (\(LChar c) -> c)
+            putStrLn stringRepr
+            pure $ state {lStack = stack'}
+          "?" -> do
+            let (LLabel a : stack') = stack
+            let lookupWord = dict ! a
+            putStrLn $ reprWord lookupWord
+            pure $ state {lStack = stack'}
+          "+" ->
+            let (a : b : stack') = stack
+                result = lAddNumbers b a
+             in pure $ state {lStack = result : stack'}
+          "-" ->
+            let (a : b : stack') = stack
+                result = lSubNumbers b a
+             in pure $ state {lStack = result : stack'}
+          "*" ->
+            let (a : b : stack') = stack
+                result = lMultiplyNumbers b a
+             in pure $ state {lStack = result : stack'}
+          "/" ->
+            let (a : b : stack') = stack
+                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
+             in pure $ state {lStack = LBool (a == b) : stack'}
+          "gt?" ->
+            let (a : b : stack') = stack
+             in pure $ state {lStack = lGreaterThan b a : stack'}
+          "lt?" ->
+            let (a : b : stack') = stack
+             in pure $ state {lStack = lLesserThan b a : stack'}
+          "unphrase" ->
+            let (LPhrase phrase : stack') = stack
+             in pure $ state {lSource = phrase ++ source, lStack = stack'}
+          "phrase" ->
+            let (LSymbol "]" : stack') = stack
+                (body, _ : newStack) = break (== LSymbol "[") stack'
+             in pure $ state {lStack = LPhrase (reverse body) : newStack}
+          "repr" ->
+            let (word : stack') = stack
+                reprStr = reprWord word $> map LChar .> LPhrase
+             in pure $ state {lStack = reprStr : stack'}
+          "pop" ->
+            let (LPhrase phrase : stack') = stack
+                (first : rest) = phrase
+             in pure $ state {lStack = first : LPhrase rest : stack'}
+          "stack-size" ->
+            let size = LInteger $ fromIntegral (length stack)
+             in pure $ state {lStack = size : 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
+                newSource = branch ++ source
+             in pure $ state {lStack = stack', lSource = newSource}
+          "loop" ->
+            let (bodyP@(LPhrase body) : condP@(LPhrase cond) : stack') = stack
+                ifWords = cond ++ [LPhrase (body ++ [condP, bodyP, LSymbol "loop"])] ++ [LPhrase [], LSymbol "cond"]
+                newSource = ifWords ++ source
+             in pure $ state {lStack = stack', lSource = newSource}
+          _ -> error $ "[error] not defined: " ++ symbol
+  | otherwise = pure $ state {lStack = word : stack}
+
+lAddNumbers (LInteger a) (LInteger b) = LInteger (a + b)
+lAddNumbers (LFloat a) (LFloat b) = LFloat (a + 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 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 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 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 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 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
diff --git a/src/ltypes.hs b/src/ltypes.hs
index bb7e0de..27fdd35 100644
--- a/src/ltypes.hs
+++ b/src/ltypes.hs
@@ -1,5 +1,7 @@
 module LTypes where
 
+import Data.Map (Map)
+import qualified Data.Map as M
 import Utils
 
 data LWord
@@ -22,3 +24,31 @@ reprWord (LChar a) = show a
 reprWord (LLabel a) = a
 reprWord (LStringLitRef a) = "StrLit(" ++ a ++ ")"
 reprWord (LPhrase a) = "P[ " ++ map reprWord a $> unwords ++ " ]"
+
+data LState = LState
+  { lDict :: Map String LWord,
+    lStack :: [LWord],
+    lPhraseDepth :: Int,
+    lDefs :: Map String [LWord],
+    lSource :: [LWord],
+    lStrLitRefMap :: Map String [LWord]
+  }
+  deriving (Show)
+
+data Config = Config
+  { configFileNameM :: Maybe String,
+    configDebugMode :: Bool
+  }
+
+data ExecStep = ExecContinue | ExecExit
+
+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 ()
diff --git a/src/main.hs b/src/main.hs
index c67cea0..6582b38 100644
--- a/src/main.hs
+++ b/src/main.hs
@@ -4,17 +4,12 @@ import Data.Char
 import Data.Map (Map, (!))
 import qualified Data.Map as M
 import Debug.Trace (trace, traceShow)
+import Interpreter
 import LTypes
 import Parser
 import System.Environment (getArgs)
-import System.IO (BufferMode (NoBuffering), hSetBuffering, stdin)
 import Utils
 
-data Config = Config
-  { configFileNameM :: Maybe String,
-    configDebugMode :: Bool
-  }
-
 getConfig config [] = config
 getConfig config ("--debug" : rest) =
   let newConfig = config {configDebugMode = True}
@@ -23,237 +18,6 @@ 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 LState = LState
-  { lDict :: Map String LWord,
-    lStack :: [LWord],
-    lPhraseDepth :: Int,
-    lDefs :: Map String [LWord],
-    lSource :: [LWord],
-    lStrLitRefMap :: Map String [LWord]
-  }
-  deriving (Show)
-
-evalMode state = lPhraseDepth state == 0
-
-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 ()
-
-data ExecStep = ExecContinue | ExecExit
-
-debugWaitForChar Config {configDebugMode = mode} =
-  if mode
-    then do
-      hSetBuffering stdin NoBuffering
-      c <- getChar
-      pure $ case c of
-        'q' -> ExecExit
-        _ -> ExecContinue
-    else pure ExecContinue
-
-interpretSource :: Config -> LState -> IO ()
-interpretSource config LState {lSource = []} = pure ()
-interpretSource config state@LState {lSource = (word : rest)} = do
-  newState <- interpretWord state {lSource = rest} word
-  debugPrint config $ "processed " ++ show word ++ ", newState ="
-  debugState config newState
-  step <- debugWaitForChar config
-  case step of
-    ExecContinue -> interpretSource config newState
-    ExecExit -> pure ()
-
-interpretWord :: LState -> LWord -> IO LState
--- non-nestable structures
-interpretWord state@LState {lStack = stack, lPhraseDepth = phraseDepth} word@(LSymbol "define") =
-  pure $
-    state
-      { lPhraseDepth = phraseDepth + 1,
-        lStack = word : stack
-      }
-interpretWord state@LState {lDefs = defs, lStack = stack, lPhraseDepth = phraseDepth} word@(LSymbol ";") =
-  let defineSpan = takeWhile (\word -> word /= LSymbol "define") stack
-      newStack = dropWhile (\word -> word /= LSymbol "define") stack $> tail
-      ((LSymbol identifier) : body) = reverse defineSpan
-      newDefs = M.insert identifier body defs
-   in pure $
-        state
-          { lPhraseDepth = phraseDepth - 1,
-            lDefs = newDefs,
-            lStack = newStack
-          }
--- words that simply move from source to stack
-interpretWord state@LState {lStack = stack} word@(LInteger _) = pure $ state {lStack = word : stack}
-interpretWord state@LState {lStack = stack} word@(LFloat _) = pure $ state {lStack = word : stack}
-interpretWord state@LState {lStack = stack} word@(LBool _) = pure $ state {lStack = word : stack}
-interpretWord state@LState {lStack = stack} word@(LChar _) = pure $ state {lStack = word : stack}
-interpretWord state@LState {lStack = stack} word@(LLabel _) = pure $ state {lStack = word : stack}
-interpretWord state@LState {lStack = stack} word@(LPhrase _) = pure $ state {lStack = word : stack}
--- string literals
-interpretWord state@LState {lSource = source, lStrLitRefMap = strLitRefMap} (LStringLitRef ref) =
-  let strLitP = strLitRefMap ! ref
-   in pure $ state {lSource = strLitP ++ source}
--- phrase markers are always evaled
-interpretWord state@LState {lStack = stack, lPhraseDepth = phraseDepth} word@(LSymbol "[") =
-  pure $ state {lPhraseDepth = phraseDepth + 1, lStack = word : stack}
-interpretWord state@LState {lStack = stack, lPhraseDepth = phraseDepth} word@(LSymbol "]") =
-  let (phrase, stack') = break (== LSymbol "[") stack
-      newStack = LPhrase (reverse phrase) : tail stack'
-   in pure $ state {lPhraseDepth = phraseDepth - 1, lStack = newStack}
--- definition lookup
-interpretWord state@LState {lDefs = defs, lDict = dict, lSource = source, lPhraseDepth = phraseDepth, lStack = stack} word@(LSymbol symbol)
-  | phraseDepth == 0 =
-    case M.lookup symbol defs of
-      Just body -> pure $ state {lSource = body ++ source}
-      Nothing ->
-        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}
-          "not" ->
-            let (LBool a : stack') = stack
-             in pure $ state {lStack = LBool (not a) : stack'}
-          "float" ->
-            let (LInteger a : stack') = stack
-             in pure $ state {lStack = LFloat (fromIntegral a) : stack'}
-          "round" ->
-            let (LFloat a : stack') = stack
-             in pure $ state {lStack = LInteger (round a) : stack'}
-          "!" ->
-            let (LLabel a : b : stack') = stack
-                newDict = M.insert a b dict
-             in pure $ state {lDict = newDict, lStack = stack'}
-          "@" ->
-            let (LLabel a : stack') = stack
-                lookupWord = dict ! a
-             in pure $ state {lStack = lookupWord : stack'}
-          "forget" ->
-            let (LLabel a : stack') = stack
-                newDict = M.delete a dict
-             in pure $ state {lStack = stack', lDict = newDict}
-          "." -> do
-            let (a : stack') = stack
-            putStrLn $ reprWord a
-            pure $ state {lStack = stack'}
-          "s." -> do
-            let (word@(LPhrase ws) : stack') = stack
-            let isLChar w = case w of LChar _ -> True; _ -> False
-            if not (all isLChar ws)
-              then error $ "[error] cannot string-print heterogenous phrase: " ++ reprWord word
-              else pure ()
-            let stringRepr = ws $> map (\(LChar c) -> c)
-            putStrLn stringRepr
-            pure $ state {lStack = stack'}
-          "?" -> do
-            let (LLabel a : stack') = stack
-            let lookupWord = dict ! a
-            putStrLn $ reprWord lookupWord
-            pure $ state {lStack = stack'}
-          "+" ->
-            let (a : b : stack') = stack
-                result = lAddNumbers b a
-             in pure $ state {lStack = result : stack'}
-          "-" ->
-            let (a : b : stack') = stack
-                result = lSubNumbers b a
-             in pure $ state {lStack = result : stack'}
-          "*" ->
-            let (a : b : stack') = stack
-                result = lMultiplyNumbers b a
-             in pure $ state {lStack = result : stack'}
-          "/" ->
-            let (a : b : stack') = stack
-                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
-             in pure $ state {lStack = LBool (a == b) : stack'}
-          "gt?" ->
-            let (a : b : stack') = stack
-             in pure $ state {lStack = lGreaterThan b a : stack'}
-          "lt?" ->
-            let (a : b : stack') = stack
-             in pure $ state {lStack = lLesserThan b a : stack'}
-          "unphrase" ->
-            let (LPhrase phrase : stack') = stack
-             in pure $ state {lSource = phrase ++ source, lStack = stack'}
-          "phrase" ->
-            let (LSymbol "]" : stack') = stack
-                (body, _ : newStack) = break (== LSymbol "[") stack'
-             in pure $ state {lStack = LPhrase (reverse body) : newStack}
-          "repr" ->
-            let (word : stack') = stack
-                reprStr = reprWord word $> map LChar .> LPhrase
-             in pure $ state {lStack = reprStr : stack'}
-          "pop" ->
-            let (LPhrase phrase : stack') = stack
-                (first : rest) = phrase
-             in pure $ state {lStack = first : LPhrase rest : stack'}
-          "stack-size" ->
-            let size = LInteger $ fromIntegral (length stack)
-             in pure $ state {lStack = size : 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
-                newSource = branch ++ source
-             in pure $ state {lStack = stack', lSource = newSource}
-          "loop" ->
-            let (bodyP@(LPhrase body) : condP@(LPhrase cond) : stack') = stack
-                ifWords = cond ++ [LPhrase (body ++ [condP, bodyP, LSymbol "loop"])] ++ [LPhrase [], LSymbol "cond"]
-                newSource = ifWords ++ source
-             in pure $ state {lStack = stack', lSource = newSource}
-          _ -> error $ "[error] not defined: " ++ symbol
-  | otherwise = pure $ state {lStack = word : stack}
-
-lAddNumbers (LInteger a) (LInteger b) = LInteger (a + b)
-lAddNumbers (LFloat a) (LFloat b) = LFloat (a + 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 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 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 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 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 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