diff options
| -rw-r--r-- | samples/comparisons.sample | 2 | ||||
| -rw-r--r-- | samples/eval.sample | 14 | ||||
| -rw-r--r-- | samples/list.sample | 17 | ||||
| -rw-r--r-- | samples/modulo.sample | 5 | ||||
| -rw-r--r-- | samples/recursion.sample | 7 | ||||
| -rw-r--r-- | src/main.hs | 119 | ||||
| -rw-r--r-- | src/utils.hs | 1 |
7 files changed, 131 insertions, 34 deletions
diff --git a/samples/comparisons.sample b/samples/comparisons.sample new file mode 100644 index 0000000..aea6387 --- /dev/null +++ b/samples/comparisons.sample @@ -0,0 +1,2 @@ +define gte? lt? not ; +define lte? gt? not ; diff --git a/samples/eval.sample b/samples/eval.sample new file mode 100644 index 0000000..927621b --- /dev/null +++ b/samples/eval.sample @@ -0,0 +1,14 @@ +define update + $update_var ! + $update_phrase ! + $update_var @ @ $update_phrase @ unphrase + $update_var @ ! + $update_var forget $update_phrase forget + ; + +10 $num ! +[ 1 + ] $num update +$num ? + +[ 5 / ] $num update +$num ?
\ No newline at end of file diff --git a/samples/list.sample b/samples/list.sample new file mode 100644 index 0000000..914522f --- /dev/null +++ b/samples/list.sample @@ -0,0 +1,17 @@ +define prepend + $prepend_val ! + $prepend_phrase ! + '[ $prepend_val @ $prepend_phrase @ unphrase '] phrase + $prepend_val forget $prepend_phrase forget + ; + +define append + $append_val ! + $append_phrase ! + '[ $append_phrase @ unphrase $append_val @ '] phrase + $append_val forget $append_phrase forget + ; + +[ 2 3 ] 1 prepend . +[ 2 3 ] 4 append . +[ 1 2 3 ] pop . .
\ No newline at end of file diff --git a/samples/modulo.sample b/samples/modulo.sample new file mode 100644 index 0000000..235d135 --- /dev/null +++ b/samples/modulo.sample @@ -0,0 +1,5 @@ +10 $idx ! +[ $idx @ dup 0 gt? ] + [ 2 mod 0 eq? . + $idx @ 1 - $idx ! ] loop +drop
\ No newline at end of file diff --git a/samples/recursion.sample b/samples/recursion.sample new file mode 100644 index 0000000..7dc833b --- /dev/null +++ b/samples/recursion.sample @@ -0,0 +1,7 @@ +define factorial +-- Integer -> Integer + dup 0 eq? not + [ dup 1 - factorial * ] + [ drop 1 ] cond ; + +5 factorial . diff --git a/src/main.hs b/src/main.hs index 6cb8fc0..551714b 100644 --- a/src/main.hs +++ b/src/main.hs @@ -8,8 +8,23 @@ import Debug.Trace (trace, traceShow) import System.Environment (getArgs) import Utils -getFilename [] = error "empty argument list" -getFilename (f : fs) = f +data Config = Config + { configFileNameM :: Maybe String, + configDebugMode :: Bool + } + +getConfig config [] = config +getConfig config ("--debug" : rest) = + let newConfig = config {configDebugMode = True} + in getConfig newConfig rest +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 LWord = LSymbol String @@ -25,7 +40,7 @@ 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) ++ " ]" +reprWord (LPhrase a) = "P[ " ++ map reprWord a $> reverse .> unwords ++ " ]" data LState = LState { lDict :: Map String LWord, @@ -38,13 +53,16 @@ data LState = LState 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 "" +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 () parseWord rawStr | isIntStr rawStr = LInteger (read rawStr) @@ -54,13 +72,13 @@ parseWord rawStr parseSource source = source $> words .> map parseWord -interpretSource :: LState -> IO () -interpretSource LState {lSource = []} = pure () -interpretSource state@LState {lSource = (word : rest)} = do +interpretSource :: Config -> LState -> IO () +interpretSource config LState {lSource = []} = pure () +interpretSource config state@LState {lSource = (word : rest)} = do newState <- interpretWord state {lSource = rest} word - -- putStrLn $ "[debug] processed " ++ show word ++ ", newState =" - -- debugState newState - interpretSource newState + debugPrint config $ "processed " ++ show word ++ ", newState =" + debugState config newState + interpretSource config newState interpretWord :: LState -> LWord -> IO LState -- non-nestable structures @@ -103,6 +121,7 @@ interpretWord state@LState {lDefs = defs, lDict = dict, lSource = source, lPhras 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} @@ -123,6 +142,10 @@ interpretWord state@LState {lDefs = defs, lDict = dict, lSource = source, lPhras let (LVariable a : stack') = stack lookupWord = dict ! a in pure $ state {lStack = lookupWord : stack'} + "forget" -> + let (LVariable a : stack') = stack + newDict = M.delete a dict + in pure $ state {lStack = stack', lDict = newDict} "." -> do let (a : stack') = stack putStrLn $ reprWord a @@ -142,11 +165,15 @@ interpretWord state@LState {lDefs = defs, lDict = dict, lSource = source, lPhras in pure $ state {lStack = result : stack'} "*" -> let (a : b : stack') = stack - result = lMultiplyNumbers a b + result = lMultiplyNumbers b a in pure $ state {lStack = result : stack'} "/" -> let (a : b : stack') = stack - result = lDivideNumbers a b + 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 @@ -157,6 +184,21 @@ interpretWord state@LState {lDefs = defs, lDict = dict, lSource = source, lPhras "lt?" -> let (a : b : stack') = stack in pure $ state {lStack = lLesserThan b a : stack'} + "unphrase" -> + let (LPhrase phrase : stack') = stack + in pure $ state {lSource = reverse phrase ++ source, lStack = stack'} + "phrase" -> + let (LSymbol "]" : stack') = stack + (body, _ : newStack) = break (== LSymbol "[") stack' + in pure $ state {lStack = LPhrase body : newStack} + "pop" -> + let (LPhrase phrase : stack') = stack + (first : rest) = reverse phrase + in pure $ state {lStack = first : LPhrase (reverse rest) : 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 @@ -170,44 +212,53 @@ interpretWord state@LState {lDefs = defs, lDict = dict, lSource = source, lPhras _ -> 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 - lAddNumbers (LInteger a) (LInteger b) = LInteger (a + b) lAddNumbers (LFloat a) (LFloat b) = LFloat (a + b) -lAddNumbers a b = error $ "[error] sum it not defined for " ++ show a ++ ", " ++ show 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 it not defined for " ++ show a ++ ", " ++ show 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 it not defined for " ++ show a ++ ", " ++ show 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 it not defined for " ++ show a ++ ", " ++ show 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 it not defined for " ++ show a ++ ", " ++ show 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 it not defined for " ++ show a ++ ", " ++ show 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 - let filename = getFilename args - putStrLn $ "[info] executing file " ++ filename - source <- readFile filename - -- putStrLn source + let initialConfig = + Config + { configFileNameM = Nothing, + configDebugMode = False + } + let config = getConfig initialConfig args + let fileName = case configFileNameM config of + Just x -> x + Nothing -> error "[error] no file name specified" + + debugPrint config $ "executing file " ++ fileName + source <- readFile fileName + let sourceWoComments = source $> lines .> filter (\line -> not ("--" `isPrefixOf` line)) .> unlines let parsed = parseSource sourceWoComments - -- putStrLn $ "[info] parsed words:\n" ++ show parsed - putStrLn "[info] interpreter output:" + debugPrint config $ "parsed words:\n" ++ show parsed + debugPrint config "interpreter output:" let initialState = LState { lDict = M.empty, @@ -216,4 +267,4 @@ main = do lDefs = M.empty, lSource = parsed } - interpretSource initialState + interpretSource config initialState diff --git a/src/utils.hs b/src/utils.hs index e3c0150..7618f5b 100644 --- a/src/utils.hs +++ b/src/utils.hs @@ -1,4 +1,5 @@ module Utils where + import qualified Data.Bifunctor as B (.>) = flip (.) |