diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/main.hs | 141 | ||||
| -rw-r--r-- | src/utils.hs | 4 |
2 files changed, 96 insertions, 49 deletions
diff --git a/src/main.hs b/src/main.hs index 44f3419..2659cff 100644 --- a/src/main.hs +++ b/src/main.hs @@ -15,23 +15,37 @@ data LWord = LSymbol String | LInteger Integer | LFloat Double + | LBool Bool | LVariable String + | LPhrase [LWord] deriving (Show, Eq) reprWord (LSymbol a) = a 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) ++ " ]" data LState = LState { lDict :: Map String LWord, lStack :: [LWord], - lEvalMode :: Bool, + lPhraseDepth :: Int, lDefs :: Map String [LWord], lSource :: [LWord] } deriving (Show) +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 "" + parseWord rawStr | isIntStr rawStr = LInteger (read rawStr) | isFloatStr rawStr = LFloat $ read rawStr @@ -44,69 +58,98 @@ interpretSource :: LState -> IO () interpretSource LState {lSource = []} = putStrLn "done" interpretSource state@LState {lSource = (word : rest)} = do newState <- interpretWord state {lSource = rest} word - -- putStrLn $ "[debug] processed " ++ show word ++ ", newState = " ++ show newState + -- putStrLn $ "[debug] processed " ++ show word ++ ", newState =" + -- debugState newState interpretSource newState --- basics interpretWord :: LState -> LWord -> IO LState -interpretWord state@LState {lStack = stack} word@(LSymbol "define") = +-- non-nestable structures +interpretWord state@LState {lStack = stack, lPhraseDepth = phraseDepth} word@(LSymbol "define") = pure $ state - { lEvalMode = False, + { lPhraseDepth = phraseDepth + 1, lStack = word : stack } -interpretWord state@LState {lDefs = defs, lStack = stack} word@(LSymbol ";") = +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 - { lEvalMode = True, + { lPhraseDepth = phraseDepth - 1, lDefs = newDefs, lStack = newStack } -interpretWord state@LState {lStack = stack, lEvalMode = False} word = pure $ state {lStack = word : stack} -interpretWord state@LState {lStack = stack} word@(LInteger value) = pure $ state {lStack = word : stack} -interpretWord state@LState {lStack = stack} word@(LFloat value) = pure $ state {lStack = word : stack} -interpretWord state@LState {lStack = stack} word@(LVariable value) = pure $ state {lStack = word : stack} -interpretWord state@LState {lStack = stack} word@(LSymbol "dup") = - pure $ state {lStack = head stack : stack} -interpretWord state@LState {lStack = stack} word@(LSymbol "drop") = - pure $ state {lStack = tail stack} --- variables & printing -interpretWord state@LState {lStack = (LVariable a) : b : stack, lDict = dict} word@(LSymbol "!") = - let newDict = M.insert a b dict - in pure $ state {lDict = newDict, lStack = stack} -interpretWord state@LState {lStack = (LVariable a) : stack, lDict = dict} word@(LSymbol "@") = - let lookupWord = dict ! a - in pure $ state {lStack = lookupWord : stack} -interpretWord state@LState {lStack = a : stack} word@(LSymbol ".") = do - putStrLn $ reprWord a - pure $ state {lStack = stack} -interpretWord state@LState {lStack = ((LVariable a) : stack), lDict = dict} word@(LSymbol "?") = do - let lookupWord = dict ! a - putStrLn $ reprWord lookupWord - pure $ state {lStack = stack} --- math -interpretWord state@LState {lStack = (LInteger a) : stack} word@(LSymbol "float") = - pure $ state {lStack = LFloat (fromIntegral a) : stack} -interpretWord state@LState {lStack = (LFloat a) : stack} word@(LSymbol "round") = - pure $ state {lStack = LInteger (round a) : stack} -interpretWord state@LState {lStack = stack, lDict = dict} word@(LSymbol "+") = - let (a : b : stack') = stack - result = lAddNumbers a b - in pure $ state {lStack = result : stack'} -interpretWord state@LState {lStack = stack, lDict = dict} word@(LSymbol "*") = - let (a : b : stack') = stack - result = lMultiplyNumbers a b - in pure $ state {lStack = result : stack'} --- def lookup -interpretWord state@LState {lDefs = defs, lSource = source} word@(LSymbol other) = - let defM = M.lookup other defs - in case defM of - Just body -> pure $ state {lSource = body ++ source} - Nothing -> error $ "[error] not defined: " ++ other +-- 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@(LVariable _) = pure $ state {lStack = word : stack} +interpretWord state@LState {lStack = stack} word@(LPhrase _) = pure $ state {lStack = word : stack} +-- 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 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} + "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 (LVariable a : b : stack') = stack + newDict = M.insert a b dict + in pure $ state {lDict = newDict, lStack = stack'} + "@" -> + let (LVariable a : stack') = stack + lookupWord = dict ! a + in pure $ state {lStack = lookupWord : stack'} + "." -> do + let (a : stack') = stack + putStrLn $ reprWord a + pure $ state {lStack = stack'} + "?" -> do + let (LVariable a : stack') = stack + let lookupWord = dict ! a + putStrLn $ reprWord lookupWord + pure $ state {lStack = stack'} + "+" -> + let (a : b : stack') = stack + result = lAddNumbers a b + in pure $ state {lStack = result : stack'} + "*" -> + let (a : b : stack') = stack + result = lMultiplyNumbers a b + in pure $ state {lStack = result : stack'} + "eq?" -> + let (a : b : stack') = stack + in pure $ state {lStack = LBool (a == b) : stack'} + "cond" -> + let (fb : tb : (LBool cond) : stack') = stack + LPhrase branch = if cond then tb else fb + newSource = reverse branch ++ source + in pure $ state {lStack = stack', lSource = newSource} + _ -> 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 @@ -134,7 +177,7 @@ main = do LState { lDict = M.empty, lStack = [], - lEvalMode = True, + lPhraseDepth = 0, lDefs = M.empty, lSource = parsed } diff --git a/src/utils.hs b/src/utils.hs index 9ba2fa0..e3c0150 100644 --- a/src/utils.hs +++ b/src/utils.hs @@ -1,4 +1,5 @@ module Utils where +import qualified Data.Bifunctor as B (.>) = flip (.) @@ -28,3 +29,6 @@ isIntStr str = in case ir of Just _ -> True Nothing -> False + +breakOn :: (a -> Bool) -> [a] -> ([a], [a]) +breakOn cond xs = break cond xs $> B.second (drop 1) |