From d5fe35bb8a75a74c7b3616b864c4d35bafecaadd Mon Sep 17 00:00:00 2001 From: Jan Tuomi Date: Sun, 6 Feb 2022 19:05:46 +0200 Subject: Add proper cabal setup --- src/Interpreter.hs | 233 +++++++++++++++++++++++++++++++++++++++++++++++++++++ src/LTypes.hs | 93 +++++++++++++++++++++ src/Main.hs | 67 +++++++++++++++ src/Parser.hs | 76 +++++++++++++++++ src/Utils.hs | 66 +++++++++++++++ src/interpreter.hs | 233 ----------------------------------------------------- src/ltypes.hs | 93 --------------------- src/main.hs | 67 --------------- src/parser.hs | 76 ----------------- src/utils.hs | 66 --------------- 10 files changed, 535 insertions(+), 535 deletions(-) create mode 100644 src/Interpreter.hs create mode 100644 src/LTypes.hs create mode 100644 src/Main.hs create mode 100644 src/Parser.hs create mode 100644 src/Utils.hs delete mode 100644 src/interpreter.hs delete mode 100644 src/ltypes.hs delete mode 100644 src/main.hs delete mode 100644 src/parser.hs delete mode 100644 src/utils.hs (limited to 'src') diff --git a/src/Interpreter.hs b/src/Interpreter.hs new file mode 100644 index 0000000..cb71c62 --- /dev/null +++ b/src/Interpreter.hs @@ -0,0 +1,233 @@ +module Interpreter where + +import Control.Monad.Except +import Data.Char +import Data.Map (Map, (!)) +import qualified Data.Map as M +import LTypes +import Utils + +debugWaitForChar Config {configDebugMode = mode} = do + if mode + then do + c <- getChar + pure $ case c of + 'q' -> ExecExit + _ -> ExecContinue + else pure ExecContinue + +debugPrint Config {configDebugMode = mode} message = + if mode + then liftIO $ putStrLn $ fmt "[debug] %%" [message] + else pure () + +interpretSource :: Config -> LState -> ExceptT LException IO LState +interpretSource config state@LState {lSource = []} = pure state +interpretSource config state@LState {lSource = (word : rest)} = do + liftIO $ debugPrint config $ fmt "processing %%, current state =" [show word] + liftIO $ debugState config state + newState <- interpretWord state {lSource = rest} word + step <- liftIO $ debugWaitForChar config + case step of + ExecContinue -> interpretSource config newState + ExecExit -> pure newState + +interpretWord :: LState -> LWord -> ExceptT LException 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 ";") = do + let defineSpan = takeWhile (\word -> word /= LSymbol "define") stack + 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} +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 "]") = 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 = + 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" -> 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 + (a, stack') <- consume1 AnyT stack + liftIO . putStrLn $ reprWord a + pure $ state {lStack = stack'} + "s." -> do + (wordP, stack') <- consume1 LPhraseT stack + let LPhrase ws = wordP + let isLChar w = case w of LChar _ -> True; _ -> False + unless (all isLChar ws) $ throwError $ LException $ fmt "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 + (LLabel a, stack') <- consume1 LLabelT stack + let lookupWord = dict ! a + liftIO . putStrLn $ reprWord lookupWord + pure $ state {lStack = stack'} + "+" -> do + (a, b, stack') <- consume2 AnyT AnyT stack + result <- lAddNumbers b a + pure $ state {lStack = result : stack'} + "-" -> do + (a, b, stack') <- consume2 AnyT AnyT stack + result <- lSubNumbers b a + pure $ state {lStack = result : stack'} + "*" -> do + (a, b, stack') <- consume2 AnyT AnyT stack + result <- lMultiplyNumbers b a + pure $ state {lStack = result : stack'} + "/" -> do + (a, b, stack') <- consume2 AnyT AnyT stack + result <- lDivideNumbers b a + pure $ state {lStack = result : stack'} + "mod" -> do + (a, b, stack') <- consume2 AnyT AnyT stack + result <- lModNumbers b a + pure $ state {lStack = result : stack'} + "eq?" -> do + (a, b, stack') <- consume2 AnyT AnyT stack + pure $ state {lStack = LBool (a == b) : stack'} + "gt?" -> do + (a, b, stack') <- consume2 AnyT AnyT stack + result <- lGreaterThan b a + pure $ state {lStack = result : stack'} + "lt?" -> do + (a, b, stack') <- consume2 AnyT AnyT stack + result <- lLesserThan b a + pure $ state {lStack = result : 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} + "']" -> + pure $ state {lStack = LSymbol "]" : stack} + "'[" -> + pure $ state {lStack = LSymbol "[" : stack} + "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 = + concat + [ cond, + [LPhrase (body ++ [condP, bodyP, LSymbol "loop"])], + [LPhrase [], LSymbol "cond"] + ] + let newSource = ifWords ++ source + pure $ state {lStack = stack', lSource = newSource} + _ -> throwError $ LException $ fmt "not defined: %%" [symbol] + | otherwise = pure $ state {lStack = word : stack} + +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 $ fmt "sum 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 $ fmt "difference 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 $ fmt "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 $ fmt "division 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 $ fmt "greater-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 $ fmt "lesser-than 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 $ fmt "modulo is not defined for %%, %%" [show a, show b] diff --git a/src/LTypes.hs b/src/LTypes.hs new file mode 100644 index 0000000..e3f9b59 --- /dev/null +++ b/src/LTypes.hs @@ -0,0 +1,93 @@ +module LTypes where + +import Control.Monad.Except +import Data.Map (Map) +import qualified Data.Map as M +import Utils + +data LWord + = LSymbol String + | LInteger Integer + | LFloat Double + | LBool Bool + | LChar Char + | LLabel String + | LStringLitRef String + | 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 +reprWord (LFloat a) = show a +reprWord (LBool a) = show a +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 () + +newtype LException = LException String diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..b596a84 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,67 @@ +module Main where + +import Control.Monad.Except +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.Exit (exitFailure, exitSuccess) +import System.IO (BufferMode (NoBuffering), hSetBuffering, stdin) +import Utils + +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 + +getFileName :: Config -> ExceptT LException IO String +getFileName Config {configFileNameM = fileNameM} = do + case fileNameM of + Just str -> pure str + Nothing -> throwError $ LException "no filename specified" + +bootstrap :: [String] -> ExceptT LException IO () +bootstrap args = do + let initialConfig = + Config + { configFileNameM = Nothing, + configDebugMode = False + } + + let config = getConfig initialConfig args + fileName <- getFileName config + + debugPrint config $ fmt "executing file %%\n" [fileName] + source <- liftIO . readFile $ fileName + (parsedSource, strLitRefMap) <- parseSource source + debugPrint config $ fmt "parsed words:\n%%\n" [show parsedSource] + debugPrint config $ fmt "string literal refmap:\n%%\n" [show strLitRefMap] + debugPrint config "interpreter output:" + let initialState = + LState + { lDict = M.empty, + lStack = [], + lPhraseDepth = 0, + lDefs = M.empty, + lSource = parsedSource, + lStrLitRefMap = strLitRefMap + } + void $ interpretSource config initialState + +main :: IO () +main = do + hSetBuffering stdin NoBuffering + args <- getArgs + result <- runExceptT $ bootstrap args + case result of + Left (LException errStr) -> do + putStrLn $ "[error] " ++ errStr + exitFailure + _ -> exitSuccess diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 index 0000000..679f318 --- /dev/null +++ b/src/Parser.hs @@ -0,0 +1,76 @@ +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) +import Data.Map (Map, (!)) +import qualified Data.Map as M +import qualified Data.Text as T +import LTypes +import Utils + +parseWord rawStr + | isIntStr rawStr = LInteger (read rawStr) + | isFloatStr rawStr = LFloat $ read rawStr + | isCharStr rawStr = LChar $ rawStr !! 1 + | "##" `isPrefixOf` rawStr = LStringLitRef $ drop 2 rawStr + | "$" `isPrefixOf` rawStr = LLabel $ tail rawStr + | otherwise = LSymbol rawStr + +removeComments = + lines .> map (T.pack .> T.splitOn (T.pack "--") .> head .> T.unpack) .> unlines + +processStringLiterals :: Maybe String -> Map String [LWord] -> String -> ExceptT LException IO (String, Map String [LWord]) +processStringLiterals currentM refMap [] = case currentM of + Just _ -> throwError $ LException "nonterminated string literal" + Nothing -> pure ([], refMap) +processStringLiterals currentM refMap (c : source) = case c of + '"' -> case currentM of + Just str -> do + -- string literal ends + let hash = DH.hash str $> show + 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 -> + -- add char to current string literal + processStringLiterals (Just $ str ++ [c]) refMap source + Nothing -> + -- proceed normally + processStringLiterals Nothing refMap source $> fmap (B.first (c :)) + +internalNVar n = LLabel $ fmt "$__%%" [show n] + +processSLInterpolations :: LWord -> ExceptT LException IO [LWord] +processSLInterpolations strP@(LPhrase lChars) + | "%%" `isInfixOf` chars = pure [LPhrase interpolated, LSymbol "unphrase"] + | otherwise = pure [strP] + where + chars = lChars $> map (\(LChar c) -> c) + -- 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 -> [internalNVar n, LSymbol "!"]) .> reverse + part1 = concat varStores + -- interleave the n substrings and n - 1 variable reads + symbolLookups = labelIndices $> map (\n -> [internalNVar n, LSymbol "@", LSymbol "unphrase"]) + part2 = LSymbol "'[" : concat (mix separatedByMarker symbolLookups) ++ [LSymbol "']", LSymbol "phrase"] + -- forget the temp variables used + varForgets = labelIndices $> map (\n -> [internalNVar n, LSymbol "forget"]) + part3 = concat varForgets + -- combine everything into one phrase + interpolated = part1 ++ part2 ++ part3 +processSLInterpolations p = throwError $ LException $ fmt "non-phrase in processSLInterpolations: %%" [show p] + +parseSource source = do + let woComments = source $> removeComments + (woStringLiterals, stringLiteralRefMap) <- processStringLiterals Nothing M.empty woComments + pure (woStringLiterals $> words .> map parseWord, stringLiteralRefMap) \ No newline at end of file diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 index 0000000..96f5fcb --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,66 @@ +module Utils where + +import Control.Monad.Except +import qualified Data.Bifunctor as B +import Data.Text (Text) +import qualified Data.Text as T + +(.>) = flip (.) + +($>) = flip ($) + +infixr 6 $> + +countCond :: (a -> Bool) -> [a] -> Int +countCond cond list = filter cond list $> length + +occursTimes :: Eq a => a -> [a] -> Int +occursTimes needle = countCond (== needle) + +readMaybe :: (Read a) => String -> Maybe a +readMaybe s = case reads s of + [(x, "")] -> Just x + _ -> Nothing + +isFloatStr str = + let ir = readMaybe str :: Maybe Double + in case ir of + Just _ -> True + Nothing -> False + +isIntStr str = + let ir = readMaybe str :: Maybe Integer + in case ir of + Just _ -> True + Nothing -> False + +isCharStr str = + case str of + ['\'', c, '\''] -> True + _ -> False + +breakOn :: (a -> Bool) -> [a] -> ([a], [a]) +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 + +safeBreak cond ex = safeBreak' cond ex [] + +safeBreak' _ ex _ [] = throwError ex +safeBreak' cond ex acc lst@(x : xs) + | cond x = pure (reverse acc, lst) + | otherwise = safeBreak' cond ex (x : acc) xs + +fmt :: String -> [String] -> String +fmt str values = T.unpack $ fmt' (T.pack str) (map T.pack values) + +fmt' :: Text -> [Text] -> Text +fmt' text [] = text +fmt' text (v : rest) = + let pattern = T.pack "%%" + (front, back) = T.breakOn pattern text + res = T.concat [front, v, T.drop (T.length pattern) back] + in fmt' res rest diff --git a/src/interpreter.hs b/src/interpreter.hs deleted file mode 100644 index cb71c62..0000000 --- a/src/interpreter.hs +++ /dev/null @@ -1,233 +0,0 @@ -module Interpreter where - -import Control.Monad.Except -import Data.Char -import Data.Map (Map, (!)) -import qualified Data.Map as M -import LTypes -import Utils - -debugWaitForChar Config {configDebugMode = mode} = do - if mode - then do - c <- getChar - pure $ case c of - 'q' -> ExecExit - _ -> ExecContinue - else pure ExecContinue - -debugPrint Config {configDebugMode = mode} message = - if mode - then liftIO $ putStrLn $ fmt "[debug] %%" [message] - else pure () - -interpretSource :: Config -> LState -> ExceptT LException IO LState -interpretSource config state@LState {lSource = []} = pure state -interpretSource config state@LState {lSource = (word : rest)} = do - liftIO $ debugPrint config $ fmt "processing %%, current state =" [show word] - liftIO $ debugState config state - newState <- interpretWord state {lSource = rest} word - step <- liftIO $ debugWaitForChar config - case step of - ExecContinue -> interpretSource config newState - ExecExit -> pure newState - -interpretWord :: LState -> LWord -> ExceptT LException 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 ";") = do - let defineSpan = takeWhile (\word -> word /= LSymbol "define") stack - 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} -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 "]") = 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 = - 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" -> 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 - (a, stack') <- consume1 AnyT stack - liftIO . putStrLn $ reprWord a - pure $ state {lStack = stack'} - "s." -> do - (wordP, stack') <- consume1 LPhraseT stack - let LPhrase ws = wordP - let isLChar w = case w of LChar _ -> True; _ -> False - unless (all isLChar ws) $ throwError $ LException $ fmt "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 - (LLabel a, stack') <- consume1 LLabelT stack - let lookupWord = dict ! a - liftIO . putStrLn $ reprWord lookupWord - pure $ state {lStack = stack'} - "+" -> do - (a, b, stack') <- consume2 AnyT AnyT stack - result <- lAddNumbers b a - pure $ state {lStack = result : stack'} - "-" -> do - (a, b, stack') <- consume2 AnyT AnyT stack - result <- lSubNumbers b a - pure $ state {lStack = result : stack'} - "*" -> do - (a, b, stack') <- consume2 AnyT AnyT stack - result <- lMultiplyNumbers b a - pure $ state {lStack = result : stack'} - "/" -> do - (a, b, stack') <- consume2 AnyT AnyT stack - result <- lDivideNumbers b a - pure $ state {lStack = result : stack'} - "mod" -> do - (a, b, stack') <- consume2 AnyT AnyT stack - result <- lModNumbers b a - pure $ state {lStack = result : stack'} - "eq?" -> do - (a, b, stack') <- consume2 AnyT AnyT stack - pure $ state {lStack = LBool (a == b) : stack'} - "gt?" -> do - (a, b, stack') <- consume2 AnyT AnyT stack - result <- lGreaterThan b a - pure $ state {lStack = result : stack'} - "lt?" -> do - (a, b, stack') <- consume2 AnyT AnyT stack - result <- lLesserThan b a - pure $ state {lStack = result : 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} - "']" -> - pure $ state {lStack = LSymbol "]" : stack} - "'[" -> - pure $ state {lStack = LSymbol "[" : stack} - "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 = - concat - [ cond, - [LPhrase (body ++ [condP, bodyP, LSymbol "loop"])], - [LPhrase [], LSymbol "cond"] - ] - let newSource = ifWords ++ source - pure $ state {lStack = stack', lSource = newSource} - _ -> throwError $ LException $ fmt "not defined: %%" [symbol] - | otherwise = pure $ state {lStack = word : stack} - -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 $ fmt "sum 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 $ fmt "difference 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 $ fmt "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 $ fmt "division 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 $ fmt "greater-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 $ fmt "lesser-than 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 $ fmt "modulo is not defined for %%, %%" [show a, show b] diff --git a/src/ltypes.hs b/src/ltypes.hs deleted file mode 100644 index e3f9b59..0000000 --- a/src/ltypes.hs +++ /dev/null @@ -1,93 +0,0 @@ -module LTypes where - -import Control.Monad.Except -import Data.Map (Map) -import qualified Data.Map as M -import Utils - -data LWord - = LSymbol String - | LInteger Integer - | LFloat Double - | LBool Bool - | LChar Char - | LLabel String - | LStringLitRef String - | 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 -reprWord (LFloat a) = show a -reprWord (LBool a) = show a -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 () - -newtype LException = LException String diff --git a/src/main.hs b/src/main.hs deleted file mode 100644 index b596a84..0000000 --- a/src/main.hs +++ /dev/null @@ -1,67 +0,0 @@ -module Main where - -import Control.Monad.Except -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.Exit (exitFailure, exitSuccess) -import System.IO (BufferMode (NoBuffering), hSetBuffering, stdin) -import Utils - -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 - -getFileName :: Config -> ExceptT LException IO String -getFileName Config {configFileNameM = fileNameM} = do - case fileNameM of - Just str -> pure str - Nothing -> throwError $ LException "no filename specified" - -bootstrap :: [String] -> ExceptT LException IO () -bootstrap args = do - let initialConfig = - Config - { configFileNameM = Nothing, - configDebugMode = False - } - - let config = getConfig initialConfig args - fileName <- getFileName config - - debugPrint config $ fmt "executing file %%\n" [fileName] - source <- liftIO . readFile $ fileName - (parsedSource, strLitRefMap) <- parseSource source - debugPrint config $ fmt "parsed words:\n%%\n" [show parsedSource] - debugPrint config $ fmt "string literal refmap:\n%%\n" [show strLitRefMap] - debugPrint config "interpreter output:" - let initialState = - LState - { lDict = M.empty, - lStack = [], - lPhraseDepth = 0, - lDefs = M.empty, - lSource = parsedSource, - lStrLitRefMap = strLitRefMap - } - void $ interpretSource config initialState - -main :: IO () -main = do - hSetBuffering stdin NoBuffering - args <- getArgs - result <- runExceptT $ bootstrap args - case result of - Left (LException errStr) -> do - putStrLn $ "[error] " ++ errStr - exitFailure - _ -> exitSuccess diff --git a/src/parser.hs b/src/parser.hs deleted file mode 100644 index 679f318..0000000 --- a/src/parser.hs +++ /dev/null @@ -1,76 +0,0 @@ -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) -import Data.Map (Map, (!)) -import qualified Data.Map as M -import qualified Data.Text as T -import LTypes -import Utils - -parseWord rawStr - | isIntStr rawStr = LInteger (read rawStr) - | isFloatStr rawStr = LFloat $ read rawStr - | isCharStr rawStr = LChar $ rawStr !! 1 - | "##" `isPrefixOf` rawStr = LStringLitRef $ drop 2 rawStr - | "$" `isPrefixOf` rawStr = LLabel $ tail rawStr - | otherwise = LSymbol rawStr - -removeComments = - lines .> map (T.pack .> T.splitOn (T.pack "--") .> head .> T.unpack) .> unlines - -processStringLiterals :: Maybe String -> Map String [LWord] -> String -> ExceptT LException IO (String, Map String [LWord]) -processStringLiterals currentM refMap [] = case currentM of - Just _ -> throwError $ LException "nonterminated string literal" - Nothing -> pure ([], refMap) -processStringLiterals currentM refMap (c : source) = case c of - '"' -> case currentM of - Just str -> do - -- string literal ends - let hash = DH.hash str $> show - 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 -> - -- add char to current string literal - processStringLiterals (Just $ str ++ [c]) refMap source - Nothing -> - -- proceed normally - processStringLiterals Nothing refMap source $> fmap (B.first (c :)) - -internalNVar n = LLabel $ fmt "$__%%" [show n] - -processSLInterpolations :: LWord -> ExceptT LException IO [LWord] -processSLInterpolations strP@(LPhrase lChars) - | "%%" `isInfixOf` chars = pure [LPhrase interpolated, LSymbol "unphrase"] - | otherwise = pure [strP] - where - chars = lChars $> map (\(LChar c) -> c) - -- 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 -> [internalNVar n, LSymbol "!"]) .> reverse - part1 = concat varStores - -- interleave the n substrings and n - 1 variable reads - symbolLookups = labelIndices $> map (\n -> [internalNVar n, LSymbol "@", LSymbol "unphrase"]) - part2 = LSymbol "'[" : concat (mix separatedByMarker symbolLookups) ++ [LSymbol "']", LSymbol "phrase"] - -- forget the temp variables used - varForgets = labelIndices $> map (\n -> [internalNVar n, LSymbol "forget"]) - part3 = concat varForgets - -- combine everything into one phrase - interpolated = part1 ++ part2 ++ part3 -processSLInterpolations p = throwError $ LException $ fmt "non-phrase in processSLInterpolations: %%" [show p] - -parseSource source = do - let woComments = source $> removeComments - (woStringLiterals, stringLiteralRefMap) <- processStringLiterals Nothing M.empty woComments - pure (woStringLiterals $> words .> map parseWord, stringLiteralRefMap) \ No newline at end of file diff --git a/src/utils.hs b/src/utils.hs deleted file mode 100644 index 96f5fcb..0000000 --- a/src/utils.hs +++ /dev/null @@ -1,66 +0,0 @@ -module Utils where - -import Control.Monad.Except -import qualified Data.Bifunctor as B -import Data.Text (Text) -import qualified Data.Text as T - -(.>) = flip (.) - -($>) = flip ($) - -infixr 6 $> - -countCond :: (a -> Bool) -> [a] -> Int -countCond cond list = filter cond list $> length - -occursTimes :: Eq a => a -> [a] -> Int -occursTimes needle = countCond (== needle) - -readMaybe :: (Read a) => String -> Maybe a -readMaybe s = case reads s of - [(x, "")] -> Just x - _ -> Nothing - -isFloatStr str = - let ir = readMaybe str :: Maybe Double - in case ir of - Just _ -> True - Nothing -> False - -isIntStr str = - let ir = readMaybe str :: Maybe Integer - in case ir of - Just _ -> True - Nothing -> False - -isCharStr str = - case str of - ['\'', c, '\''] -> True - _ -> False - -breakOn :: (a -> Bool) -> [a] -> ([a], [a]) -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 - -safeBreak cond ex = safeBreak' cond ex [] - -safeBreak' _ ex _ [] = throwError ex -safeBreak' cond ex acc lst@(x : xs) - | cond x = pure (reverse acc, lst) - | otherwise = safeBreak' cond ex (x : acc) xs - -fmt :: String -> [String] -> String -fmt str values = T.unpack $ fmt' (T.pack str) (map T.pack values) - -fmt' :: Text -> [Text] -> Text -fmt' text [] = text -fmt' text (v : rest) = - let pattern = T.pack "%%" - (front, back) = T.breakOn pattern text - res = T.concat [front, v, T.drop (T.length pattern) back] - in fmt' res rest -- cgit v1.3