Move interpreter stuff under interpreter.hs

1 files changed, 214 insertions, 0 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