diff options
| -rw-r--r-- | src/interpreter.hs | 214 | ||||
| -rw-r--r-- | src/ltypes.hs | 30 | ||||
| -rw-r--r-- | src/main.hs | 238 |
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 |