diff options
| -rwxr-xr-x | run.sh | 4 | ||||
| -rw-r--r-- | samples/divbyzero.sample | 1 | ||||
| -rw-r--r-- | src/interpreter.hs | 122 | ||||
| -rw-r--r-- | src/ltypes.hs | 3 | ||||
| -rw-r--r-- | src/main.hs | 33 | ||||
| -rw-r--r-- | src/parser.hs | 47 |
6 files changed, 127 insertions, 83 deletions
@@ -1,6 +1,8 @@ #!/bin/bash -set -uxo pipefail +set -uo pipefail ghc -o interpreter src/*.hs ./interpreter $@ +ret=$? rm src/*.{hi,o} +exit $ret diff --git a/samples/divbyzero.sample b/samples/divbyzero.sample new file mode 100644 index 0000000..77d211f --- /dev/null +++ b/samples/divbyzero.sample @@ -0,0 +1 @@ +10.0 0.0 / . diff --git a/src/interpreter.hs b/src/interpreter.hs index 6eb6697..01cc474 100644 --- a/src/interpreter.hs +++ b/src/interpreter.hs @@ -1,5 +1,6 @@ module Interpreter where +import Control.Monad.Except import Data.Char import Data.Map (Map, (!)) import qualified Data.Map as M @@ -19,21 +20,21 @@ debugWaitForChar Config {configDebugMode = mode} = debugPrint Config {configDebugMode = mode} message = if mode - then putStrLn $ "[debug] " ++ message + then liftIO $ putStrLn $ "[debug] " ++ message else pure () -interpretSource :: Config -> LState -> IO () +interpretSource :: Config -> LState -> ExceptT LException 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 + liftIO $ debugPrint config $ "processed " ++ show word ++ ", newState =" + liftIO $ debugState config newState + step <- liftIO $ debugWaitForChar config case step of ExecContinue -> interpretSource config newState ExecExit -> pure () -interpretWord :: LState -> LWord -> IO LState +interpretWord :: LState -> LWord -> ExceptT LException IO LState -- non-nestable structures interpretWord state@LState {lStack = stack, lPhraseDepth = phraseDepth} word@(LSymbol "define") = pure $ @@ -106,51 +107,51 @@ interpretWord state@LState {lDefs = defs, lDict = dict, lSource = source, lPhras in pure $ state {lStack = stack', lDict = newDict} "." -> do let (a : stack') = stack - putStrLn $ reprWord a + liftIO . 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 () + unless (all isLChar ws) $ throwError $ LException $ "cannot string-print heterogenous phrase: " ++ reprWord word let stringRepr = ws $> map (\(LChar c) -> c) - putStrLn stringRepr + liftIO . putStrLn $ stringRepr pure $ state {lStack = stack'} "?" -> do let (LLabel a : stack') = stack let lookupWord = dict ! a - putStrLn $ reprWord lookupWord + liftIO . putStrLn $ reprWord lookupWord pure $ state {lStack = stack'} - "+" -> + "+" -> do let (a : b : stack') = stack - result = lAddNumbers b a - in pure $ state {lStack = result : stack'} - "-" -> + result <- lAddNumbers b a + pure $ state {lStack = result : stack'} + "-" -> do let (a : b : stack') = stack - result = lSubNumbers b a - in pure $ state {lStack = result : stack'} - "*" -> + result <- lSubNumbers b a + pure $ state {lStack = result : stack'} + "*" -> do let (a : b : stack') = stack - result = lMultiplyNumbers b a - in pure $ state {lStack = result : stack'} - "/" -> + result <- lMultiplyNumbers b a + pure $ state {lStack = result : stack'} + "/" -> do let (a : b : stack') = stack - result = lDivideNumbers b a - in pure $ state {lStack = result : stack'} - "mod" -> + result <- lDivideNumbers b a + pure $ state {lStack = result : stack'} + "mod" -> do let (a : b : stack') = stack - result = lModNumbers b a - in pure $ state {lStack = result : stack'} - "eq?" -> + result <- lModNumbers b a + pure $ state {lStack = result : stack'} + "eq?" -> do let (a : b : stack') = stack - in pure $ state {lStack = LBool (a == b) : stack'} - "gt?" -> + pure $ state {lStack = LBool (a == b) : stack'} + "gt?" -> do let (a : b : stack') = stack - in pure $ state {lStack = lGreaterThan b a : stack'} - "lt?" -> + result <- lGreaterThan b a + pure $ state {lStack = result : stack'} + "lt?" -> do let (a : b : stack') = stack - in pure $ state {lStack = lLesserThan b a : stack'} + result <- lLesserThan b a + pure $ state {lStack = result : stack'} "unphrase" -> let (LPhrase phrase : stack') = stack in pure $ state {lSource = phrase ++ source, lStack = stack'} @@ -183,32 +184,45 @@ interpretWord state@LState {lDefs = defs, lDict = dict, lSource = source, lPhras 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 + _ -> throwError $ LException $ "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 +lAddNumbers :: LWord -> LWord -> ExceptT LException IO LWord +lAddNumbers (LInteger a) (LInteger b) = pure $ LInteger (a + b) +lAddNumbers (LFloat a) (LFloat b) = pure $ LFloat (a + b) +lAddNumbers a b = throwError $ LException $ "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 +lSubNumbers :: LWord -> LWord -> ExceptT LException IO LWord +lSubNumbers (LInteger a) (LInteger b) = pure $ LInteger (a - b) +lSubNumbers (LFloat a) (LFloat b) = pure $ LFloat (a - b) +lSubNumbers a b = throwError $ LException $ "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 +lMultiplyNumbers :: LWord -> LWord -> ExceptT LException IO LWord +lMultiplyNumbers (LInteger a) (LInteger b) = pure $ LInteger (a * b) +lMultiplyNumbers (LFloat a) (LFloat b) = pure $ LFloat (a * b) +lMultiplyNumbers a b = throwError $ LException $ "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 +lDivideNumbers :: LWord -> LWord -> ExceptT LException IO LWord +lDivideNumbers (LInteger a) (LInteger b) = + case b of + 0 -> throwError $ LException "division by zero" + _ -> pure $ LInteger (a `div` b) +lDivideNumbers (LFloat a) (LFloat b) = + case b of + 0 -> throwError $ LException "division by zero" + _ -> pure $ LFloat (a / b) +lDivideNumbers a b = throwError $ LException $ "division 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 +lGreaterThan :: LWord -> LWord -> ExceptT LException IO LWord +lGreaterThan (LInteger a) (LInteger b) = pure $ LBool (a > b) +lGreaterThan (LFloat a) (LFloat b) = pure $ LBool (a > b) +lGreaterThan a b = throwError $ LException $ "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 +lLesserThan :: LWord -> LWord -> ExceptT LException IO LWord +lLesserThan (LInteger a) (LInteger b) = pure $ LBool (a < b) +lLesserThan (LFloat a) (LFloat b) = pure $ LBool (a < b) +lLesserThan a b = throwError $ LException $ "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 +lModNumbers :: LWord -> LWord -> ExceptT LException IO LWord +lModNumbers (LInteger a) (LInteger b) = pure $ LInteger (a `mod` b) +lModNumbers a b = throwError $ LException $ "modulo is not defined for " ++ show a ++ ", " ++ show b diff --git a/src/ltypes.hs b/src/ltypes.hs index 27fdd35..ee4685e 100644 --- a/src/ltypes.hs +++ b/src/ltypes.hs @@ -1,5 +1,6 @@ module LTypes where +import Control.Monad.Except import Data.Map (Map) import qualified Data.Map as M import Utils @@ -52,3 +53,5 @@ debugState Config {configDebugMode = mode} state = putStrLn $ "lPhraseDepth: " ++ show (lPhraseDepth state) putStrLn "" else pure () + +newtype LException = LException String diff --git a/src/main.hs b/src/main.hs index 6582b38..39caad9 100644 --- a/src/main.hs +++ b/src/main.hs @@ -1,5 +1,6 @@ module Main where +import Control.Monad.Except import Data.Char import Data.Map (Map, (!)) import qualified Data.Map as M @@ -8,6 +9,7 @@ import Interpreter import LTypes import Parser import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) import Utils getConfig config [] = config @@ -18,23 +20,25 @@ getConfig config (fileName : rest) = let newConfig = config {configFileNameM = Just fileName} in getConfig newConfig rest -main :: IO () -main = do - args <- getArgs +getFileName :: Config -> ExceptT LException IO String +getFileName Config {configFileNameM = fileNameM} = do + case fileNameM of + Just str -> pure str + Nothing -> throwError $ LException "no file name specified" + +bootstrap :: [String] -> ExceptT LException IO () +bootstrap args = do 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" + fileName <- getFileName config debugPrint config $ "executing file " ++ fileName ++ "\n" - source <- readFile fileName - - let (parsedSource, strLitRefMap) = parseSource source + source <- liftIO . readFile $ fileName + (parsedSource, strLitRefMap) <- parseSource source debugPrint config $ "parsed words:\n" ++ show parsedSource ++ "\n" debugPrint config $ "string literal refmap:\n" ++ show strLitRefMap ++ "\n" debugPrint config "interpreter output:" @@ -48,3 +52,14 @@ main = do lStrLitRefMap = strLitRefMap } interpretSource config initialState + +main :: IO () +main = do + args <- getArgs + result <- runExceptT $ bootstrap args + case result of + Left ex -> case ex of + LException errStr -> do + putStrLn $ "[error] " ++ errStr + exitFailure + _ -> exitSuccess diff --git a/src/parser.hs b/src/parser.hs index f6883da..e1bea13 100644 --- a/src/parser.hs +++ b/src/parser.hs @@ -1,5 +1,6 @@ module Parser where +import Control.Monad.Except import qualified Data.Bifunctor as B import qualified Data.Hashable as DH import Data.List (intercalate, isInfixOf, isPrefixOf) @@ -23,46 +24,54 @@ removeComments source = processStringLiterals = processStringLiterals' Nothing M.empty -processStringLiterals' :: Maybe String -> Map String [LWord] -> String -> (String, Map String [LWord]) +processStringLiterals' :: Maybe String -> Map String [LWord] -> String -> ExceptT LException IO (String, Map String [LWord]) processStringLiterals' currentM refMap [] = case currentM of - Just _ -> error "[error] nonterminated string literal" - Nothing -> ([], refMap) + Just _ -> throwError $ LException "nonterminated string literal" + Nothing -> pure ([], refMap) processStringLiterals' currentM refMap (c : source) = case c of '"' -> case currentM of - Just str -> + Just str -> do -- string literal ends let hash = DH.hash str $> show - strP = str $> map LChar .> LPhrase - interpolated = processSLInterpolations strP - newRefMap = M.insert hash interpolated refMap - (resSource, resRefMap) = processStringLiterals' Nothing newRefMap source - in ("##" ++ hash ++ resSource, resRefMap) + let strP = str $> map LChar .> LPhrase + interpolated <- processSLInterpolations strP + let newRefMap = M.insert hash interpolated refMap + (resSource, resRefMap) <- processStringLiterals' Nothing newRefMap source + pure ("##" ++ hash ++ resSource, resRefMap) Nothing -> -- string literal starts processStringLiterals' (Just "") refMap source other -> case currentM of - Just str -> processStringLiterals' (Just $ str ++ [c]) refMap source -- add char to current string literal - Nothing -> processStringLiterals' Nothing refMap source $> B.first (c :) -- proceed normally + Just str -> + -- add char to current string literal + processStringLiterals' (Just $ str ++ [c]) refMap source + Nothing -> + -- proceed normally + processStringLiterals' Nothing refMap source $> fmap (B.first (c :)) -processSLInterpolations :: LWord -> [LWord] +processSLInterpolations :: LWord -> ExceptT LException IO [LWord] processSLInterpolations strP@(LPhrase lChars) - | "%%" `isInfixOf` chars = [LPhrase interpolated, LSymbol "unphrase"] - | otherwise = [strP] + | "%%" `isInfixOf` chars = pure [LPhrase interpolated, LSymbol "unphrase"] + | otherwise = pure [strP] where chars = lChars $> map (\(LChar c) -> c) - tChars = T.pack chars + -- split string on the %% marker into n substrings separatedByMarker = T.pack chars $> T.splitOn (T.pack "%%") .> map (T.unpack .> map LChar) labelIndices = [0 .. length separatedByMarker - 1 - 1] + -- store n - 1 variables from stack varStores = labelIndices $> map (\n -> [LLabel ("$__" ++ show n), LSymbol "!"]) .> reverse part1 = concat varStores + -- interleave the n substrings and n - 1 variable reads symbolLookups = labelIndices $> map (\n -> [LLabel ("$__" ++ show n), LSymbol "@", LSymbol "unphrase"]) part2 = LSymbol "'[" : concat (mix separatedByMarker symbolLookups) ++ [LSymbol "']", LSymbol "phrase"] + -- forget the temp variables used varForgets = labelIndices $> map (\n -> [LLabel ("$__" ++ show n), LSymbol "forget"]) part3 = concat varForgets + -- combine everything into one phrase interpolated = part1 ++ part2 ++ part3 -processSLInterpolations p = error $ "[error] non-phrase in processSLInterpolations: " ++ show p +processSLInterpolations p = throwError $ LException $ "non-phrase in processSLInterpolations: " ++ show p -parseSource source = +parseSource source = do let woComments = source $> removeComments - (woStringLiterals, stringLiteralRefMap) = processStringLiterals woComments - in (woStringLiterals $> words .> map parseWord, stringLiteralRefMap) + (woStringLiterals, stringLiteralRefMap) <- processStringLiterals woComments + pure (woStringLiterals $> words .> map parseWord, stringLiteralRefMap) |