diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/interpreter.hs | 146 | ||||
| -rw-r--r-- | src/ltypes.hs | 36 | ||||
| -rw-r--r-- | src/utils.hs | 10 |
3 files changed, 119 insertions, 73 deletions
diff --git a/src/interpreter.hs b/src/interpreter.hs index 01cc474..9ba4b3c 100644 --- a/src/interpreter.hs +++ b/src/interpreter.hs @@ -42,17 +42,17 @@ interpretWord state@LState {lStack = stack, lPhraseDepth = phraseDepth} word@(LS { lPhraseDepth = phraseDepth + 1, lStack = word : stack } -interpretWord state@LState {lDefs = defs, lStack = stack, lPhraseDepth = phraseDepth} word@(LSymbol ";") = +interpretWord state@LState {lDefs = defs, lStack = stack, lPhraseDepth = phraseDepth} word@(LSymbol ";") = do 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 - } + let newStack = dropWhile (\word -> word /= LSymbol "define") stack $> tail + (LSymbol identifier, body) <- consume1 LSymbolT (reverse defineSpan) + let newDefs = M.insert identifier body defs + 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} @@ -67,10 +67,10 @@ interpretWord state@LState {lSource = source, lStrLitRefMap = strLitRefMap} (LSt -- 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} +interpretWord state@LState {lStack = stack, lPhraseDepth = phraseDepth} word@(LSymbol "]") = do + (phrase, _ : stack') <- safeBreak (== LSymbol "[") (LException "phrase-start marker '[' missing in stack") stack + let newStack = LPhrase (reverse phrase) : stack' + 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 = @@ -84,89 +84,90 @@ interpretWord state@LState {lDefs = defs, lDict = dict, lSource = source, lPhras "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} + "not" -> do + (LBool a, stack') <- consume1 LBoolT stack + pure $ state {lStack = LBool (not a) : stack'} + "float" -> do + (LInteger a, stack') <- consume1 LIntegerT stack + pure $ state {lStack = LFloat (fromIntegral a) : stack'} + "round" -> do + (LFloat a, stack') <- consume1 LFloatT stack + pure $ state {lStack = LInteger (round a) : stack'} + "!" -> do + (LLabel a, b, stack') <- consume2 LLabelT AnyT stack + let newDict = M.insert a b dict + pure $ state {lDict = newDict, lStack = stack'} + "@" -> do + (LLabel a, stack') <- consume1 LLabelT stack + let lookupWord = dict ! a + pure $ state {lStack = lookupWord : stack'} + "forget" -> do + (LLabel a, stack') <- consume1 LLabelT stack + let newDict = M.delete a dict + pure $ state {lStack = stack', lDict = newDict} "." -> do - let (a : stack') = stack + (a, stack') <- consume1 AnyT stack liftIO . putStrLn $ reprWord a pure $ state {lStack = stack'} "s." -> do - let (word@(LPhrase ws) : stack') = stack + (wordP, stack') <- consume1 LPhraseT stack + let LPhrase ws = wordP let isLChar w = case w of LChar _ -> True; _ -> False - unless (all isLChar ws) $ throwError $ LException $ "cannot string-print heterogenous phrase: " ++ reprWord word + unless (all isLChar ws) $ throwError $ LException $ "cannot string-print heterogenous or non-string phrase: " ++ reprWord wordP let stringRepr = ws $> map (\(LChar c) -> c) liftIO . putStrLn $ stringRepr pure $ state {lStack = stack'} "?" -> do - let (LLabel a : stack') = stack + (LLabel a, stack') <- consume1 LLabelT stack let lookupWord = dict ! a liftIO . putStrLn $ reprWord lookupWord pure $ state {lStack = stack'} "+" -> do - let (a : b : stack') = stack + (a, b, stack') <- consume2 AnyT AnyT stack result <- lAddNumbers b a pure $ state {lStack = result : stack'} "-" -> do - let (a : b : stack') = stack + (a, b, stack') <- consume2 AnyT AnyT stack result <- lSubNumbers b a pure $ state {lStack = result : stack'} "*" -> do - let (a : b : stack') = stack + (a, b, stack') <- consume2 AnyT AnyT stack result <- lMultiplyNumbers b a pure $ state {lStack = result : stack'} "/" -> do - let (a : b : stack') = stack + (a, b, stack') <- consume2 AnyT AnyT stack result <- lDivideNumbers b a pure $ state {lStack = result : stack'} "mod" -> do - let (a : b : stack') = stack + (a, b, stack') <- consume2 AnyT AnyT stack result <- lModNumbers b a pure $ state {lStack = result : stack'} "eq?" -> do - let (a : b : stack') = stack + (a, b, stack') <- consume2 AnyT AnyT stack pure $ state {lStack = LBool (a == b) : stack'} "gt?" -> do - let (a : b : stack') = stack + (a, b, stack') <- consume2 AnyT AnyT stack result <- lGreaterThan b a pure $ state {lStack = result : stack'} "lt?" -> do - let (a : b : stack') = stack + (a, b, stack') <- consume2 AnyT AnyT stack result <- lLesserThan b a pure $ state {lStack = result : 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'} + "unphrase" -> do + (LPhrase phrase, stack') <- consume1 LPhraseT stack + pure $ state {lSource = phrase ++ source, lStack = stack'} + "phrase" -> do + (LSymbol "]", stack') <- consume1 LSymbolT stack + (body, _ : newStack) <- safeBreak (== LSymbol "[") (LException "phrase-start marker '[' missing in stack") stack' + pure $ state {lStack = LPhrase (reverse body) : newStack} + "repr" -> do + (word, stack') <- consume1 AnyT stack + let reprStr = reprWord word $> map LChar .> LPhrase + pure $ state {lStack = reprStr : stack'} + "pop" -> do + (LPhrase phrase, stack') <- consume1 LPhraseT stack + let (first : rest) = phrase + pure $ state {lStack = first : LPhrase rest : stack'} "stack-size" -> let size = LInteger $ fromIntegral (length stack) in pure $ state {lStack = size : stack} @@ -174,16 +175,17 @@ interpretWord state@LState {lDefs = defs, lDict = dict, lSource = source, lPhras 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} + "cond" -> do + (fb, tb, LBool cond, stack') <- consume3 LPhraseT LPhraseT LBoolT stack + let LPhrase branch = if cond then tb else fb + let newSource = branch ++ source + pure $ state {lStack = stack', lSource = newSource} + "loop" -> do + (bodyP, condP, stack') <- consume2 LPhraseT LPhraseT stack + let (LPhrase body, LPhrase cond) = (bodyP, condP) + let ifWords = cond ++ [LPhrase (body ++ [condP, bodyP, LSymbol "loop"])] ++ [LPhrase [], LSymbol "cond"] + let newSource = ifWords ++ source + pure $ state {lStack = stack', lSource = newSource} _ -> throwError $ LException $ "not defined: " ++ symbol | otherwise = pure $ state {lStack = word : stack} diff --git a/src/ltypes.hs b/src/ltypes.hs index ee4685e..e3f9b59 100644 --- a/src/ltypes.hs +++ b/src/ltypes.hs @@ -16,6 +16,42 @@ data LWord | LPhrase [LWord] deriving (Show, Eq) +data LWordT = LSymbolT | LIntegerT | LFloatT | LBoolT | LCharT | LLabelT | LPhraseT | AnyT deriving (Show) + +consumeErr wordT word = LException $ "expected " ++ show wordT ++ ", encountered " ++ show word + +consume1 :: LWordT -> [LWord] -> ExceptT LException IO (LWord, [LWord]) +consume1 wordT [] = + throwError $ LException $ "expected " ++ show wordT ++ ", encountered empty stack" +consume1 AnyT (word : stack') = pure (word, stack') +consume1 wordT@LSymbolT (word : stack') = + case word of LSymbol _ -> pure (word, stack'); _ -> throwError $ consumeErr wordT word +consume1 wordT@LIntegerT (word : stack') = + case word of LInteger _ -> pure (word, stack'); _ -> throwError $ consumeErr wordT word +consume1 wordT@LFloatT (word : stack') = + case word of LFloat _ -> pure (word, stack'); _ -> throwError $ consumeErr wordT word +consume1 wordT@LBoolT (word : stack') = + case word of LBool _ -> pure (word, stack'); _ -> throwError $ consumeErr wordT word +consume1 wordT@LCharT (word : stack') = + case word of LChar _ -> pure (word, stack'); _ -> throwError $ consumeErr wordT word +consume1 wordT@LLabelT (word : stack') = + case word of LLabel _ -> pure (word, stack'); _ -> throwError $ consumeErr wordT word +consume1 wordT@LPhraseT (word : stack') = + case word of LPhrase _ -> pure (word, stack'); _ -> throwError $ consumeErr wordT word + +consume2 :: LWordT -> LWordT -> [LWord] -> ExceptT LException IO (LWord, LWord, [LWord]) +consume2 wordT1 wordT2 stack = do + (ret1, stack1) <- consume1 wordT1 stack + (ret2, stack2) <- consume1 wordT2 stack1 + pure (ret1, ret2, stack2) + +consume3 :: LWordT -> LWordT -> LWordT -> [LWord] -> ExceptT LException IO (LWord, LWord, LWord, [LWord]) +consume3 wordT1 wordT2 wordT3 stack = do + (ret1, stack1) <- consume1 wordT1 stack + (ret2, stack2) <- consume1 wordT2 stack1 + (ret3, stack3) <- consume1 wordT3 stack2 + pure (ret1, ret2, ret3, stack3) + reprWord :: LWord -> String reprWord (LSymbol a) = a reprWord (LInteger a) = show a diff --git a/src/utils.hs b/src/utils.hs index 5b78682..4ffdf3b 100644 --- a/src/utils.hs +++ b/src/utils.hs @@ -1,5 +1,6 @@ module Utils where +import Control.Monad.Except import qualified Data.Bifunctor as B (.>) = flip (.) @@ -42,4 +43,11 @@ breakOn cond xs = break cond xs $> B.second (drop 1) mix :: [a] -> [a] -> [a] mix (x : xs) (y : ys) = x : y : mix xs ys mix x [] = x -mix [] y = y
\ No newline at end of file +mix [] y = y + +safeBreak cond ex = safeBreak' cond ex [] + +safeBreak' _ ex _ [] = throwError ex +safeBreak' cond ex acc lst@(x : xs) + | cond x = pure (acc, lst) + | otherwise = safeBreak' cond ex (x : acc) xs |