From 8baa85fd4c3607a7b3cebf2518a930a3b8a924bf Mon Sep 17 00:00:00 2001 From: Jan Tuomi Date: Fri, 9 Dec 2022 23:52:58 +0200 Subject: Add atom data type --- TODO.txt | 1 - app/Main.hs | 4 +++- examples/atom-concept.milch | 11 ----------- examples/atom.milch | 14 +++++++++++++ src/Builtins.hs | 43 ++++++++++++++++++++++++++++++++++++++-- src/Interpreter.hs | 12 +++++++++--- src/Utils.hs | 48 +++++++++++++++++++++++++++++++++------------ test/Spec.hs | 11 +++++++++++ test/TestUtils.hs | 3 ++- test/scripts/atom1.milch | 14 +++++++++++++ 10 files changed, 129 insertions(+), 32 deletions(-) delete mode 100644 examples/atom-concept.milch create mode 100644 examples/atom.milch create mode 100644 test/scripts/atom1.milch diff --git a/TODO.txt b/TODO.txt index bbd55ae..59c655f 100644 --- a/TODO.txt +++ b/TODO.txt @@ -1,3 +1,2 @@ add a `Debug/break` builtin that allows simple interactive debugging -add an atom/cell/box data type for storing mutable state write tests diff --git a/app/Main.hs b/app/Main.hs index 37844c9..e5e7e90 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,6 +2,7 @@ module Main (main) where import System.Environment import Control.Monad.Except import System.Console.Haskeline +import qualified Data.Map as M import Utils import Builtins import Interpreter @@ -60,7 +61,8 @@ main = do ls = LState { stateConfig = config, stateEnv = builtinEnv, stateDepth = 0, - statePure = Impure } + statePure = Impure, + stateAtomMap = M.empty } if (configShowHelp config) then do putStrLn $ "Usage: " ++ progName ++ " # to open REPL" diff --git a/examples/atom-concept.milch b/examples/atom-concept.milch deleted file mode 100644 index 4158b45..0000000 --- a/examples/atom-concept.milch +++ /dev/null @@ -1,11 +0,0 @@ -(let state (atom! 10)) - -(let do-loop! (\![i n] - (match true - (lt? i n) (do (update! dec state) - (do-loop! (inc i) n)) - otherwise unit))) - -(do-loop! 0 5) -(get! state) -; => 5 diff --git a/examples/atom.milch b/examples/atom.milch new file mode 100644 index 0000000..0ee6f8f --- /dev/null +++ b/examples/atom.milch @@ -0,0 +1,14 @@ +(import "core/common") + +(let state (atom! 10)) + +(let do-loop! (\![i n] + (match true + (lt? i n) (do (atom-update! inc state) + (do-loop! (inc i) n)) + otherwise unit))) + +(do-loop! 0 5) + +(atom-get! state) +; => 15 diff --git a/src/Builtins.hs b/src/Builtins.hs index fb8ad7d..a83773b 100644 --- a/src/Builtins.hs +++ b/src/Builtins.hs @@ -47,12 +47,19 @@ builtinEnv = M.fromList $ map (B.second Regular) [ ("otherwise", makeNonsenseAST ASTHole), builtinFatal, builtinKind, + -- atom + builtinAtom, + builtinAtomUpdate, + builtinAtomGet, -- reserved keywords reservedKeyword "\\", + reservedKeyword "\\!", reservedKeyword "let", reservedKeyword "match", reservedKeyword "Debug/env", - reservedKeyword "record" + reservedKeyword "import", + reservedKeyword "record", + reservedKeyword "do" ] argError1 :: String -> AST -> String @@ -336,7 +343,6 @@ builtinSortByFirst = (name, makeNonsenseAST $ ASTFunction Pure fn1) where builtinTry :: (String, AST) builtinTry = (name, makeNonsenseAST $ ASTFunction Pure fn1) where name = "try!" - fn1 :: LFunction fn1 ast1@AST { an = ASTFunction Pure catchFn } = return $ makeNonsenseAST $ ASTFunction Pure $ fn2 where fn2 ast2@AST { an = ASTFunction _ tryFn } = @@ -354,3 +360,36 @@ builtinTry = (name, makeNonsenseAST $ ASTFunction Pure fn1) where catchFn $ ast2 { an = ASTString $ es } fn2 ast2 = throwL (astPos ast2, argError2 name ast1 ast2) fn1 ast1 = throwL (astPos ast1, argError1 name ast1) + +builtinAtom :: (String, AST) +builtinAtom = (name, makeNonsenseAST $ ASTFunction Impure fn1) where + name = "atom!" + fn1 ast1 = createAtom ast1 + +builtinAtomUpdate :: (String, AST) +builtinAtomUpdate = (name, makeNonsenseAST $ ASTFunction Pure fn1) where + name = "atom-update!" + fn1 ast1@AST { an = ASTFunction Pure updateFn } = + return $ makeNonsenseAST $ ASTFunction Impure $ fn2 where + fn2 ast2@AST { an = ASTAtom ref } = do + atomMap <- getAtomMap + case (M.lookup ref atomMap) of + Just hit -> do + mapped <- updateFn hit + insertAtomMap ref mapped + return ast2 + Nothing -> + throwL (astPos ast2, "invalid atom reference: " ++ show ref) + fn2 ast2 = throwL (astPos ast2, argError2 name ast1 ast2) + fn1 ast1 = throwL (astPos ast1, argError1 name ast1) + +builtinAtomGet :: (String, AST) +builtinAtomGet = (name, makeNonsenseAST $ ASTFunction Impure fn1) where + name = "atom-get!" + fn1 ast1@AST { an = ASTAtom ref } = do + atomMap <- getAtomMap + case (M.lookup ref atomMap) of + Just hit -> return hit + Nothing -> + throwL (astPos ast1, "invalid atom reference: " ++ show ref) + fn1 ast1 = throwL (astPos ast1, argError1 name ast1) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 6be5c71..41b2241 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -20,7 +20,7 @@ import Tokenizer ( tokenize' ) import Parser ( parse ) curryCall :: [AST] -> ASTNode -> LContext AST -curryCall [] astNode = return $ makeNonsenseAST astNode +curryCall [] fnAstNode = return $ makeNonsenseAST fnAstNode curryCall (arg:[]) (ASTFunction fPurity f) = do checkPurity fPurity f arg @@ -215,22 +215,28 @@ evaluateImport asts = do when (d > 1) $ throwL (astPos importAst, "import can only be called on the top level, current depth: " ++ show d) config <- getConfig + atomMap <- getAtomMap + let initialState = LState { stateConfig = config, stateDepth = 0, stateEnv = builtinEnv, - statePure = Impure + statePure = Impure, + stateAtomMap = atomMap } + case args of -- non-qualified import [AST { an = ASTString path }] -> do let checkedPath = if (not $ ".milch" `L.isSuffixOf` path) then (path ++ ".milch") else path - LState { stateEnv = importedEnv } <- lift $ execStateT (runScriptFile checkedPath) initialState + LState { stateEnv = importedEnv, stateAtomMap = importedAtomMap } <- lift $ execStateT (runScriptFile checkedPath) initialState env <- getEnv putEnv $ M.union importedEnv env + putAtomMap $ M.union importedAtomMap atomMap + return $ importAst { an = ASTUnit } _ -> throwL (astPos importAst, "invalid arguments passed to import: " ++ show args) diff --git a/src/Utils.hs b/src/Utils.hs index 76b3830..54f1267 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -41,12 +41,14 @@ data Binding a type Env = M.Map String (Binding AST) type Scope = [(String, AST)] +type AtomMap = M.Map LAtomRef AST data LState = LState { stateConfig :: Config, stateEnv :: Env, stateDepth :: Int, - statePure :: Purity + statePure :: Purity, + stateAtomMap :: AtomMap } type LineNo = Int @@ -93,6 +95,31 @@ getPurity = do s <- get return $ statePure s +getAtomMap :: LContext AtomMap +getAtomMap = do + s <- get + return $ stateAtomMap s + +putAtomMap :: AtomMap -> LContext () +putAtomMap atomMap = do + modify (\s -> s { stateAtomMap = atomMap }) + +insertAtomMap :: LAtomRef -> AST -> LContext () +insertAtomMap k v = do + atomMap <- getAtomMap + putAtomMap $ M.insert k v atomMap + +createAtom :: AST -> LContext AST +createAtom ast = do + atomMap <- getAtomMap + let (LAtomRef maxKey) = if (M.size atomMap > 0) + then fst $ M.findMax atomMap + else LAtomRef 0 + let nextKey = maxKey + 1 + let ref = LAtomRef nextKey + insertAtomMap ref ast + return $ ast { an = ASTAtom ref } + isAllowedPurity :: Purity -> LContext Bool isAllowedPurity purity = do s <- get @@ -129,6 +156,8 @@ type LFunction = AST -> LContext AST type LRecord = M.Map String AST type TagHash = Int +newtype LAtomRef = LAtomRef Int deriving (Eq, Ord, Show) + data ASTNode = ASTInteger Integer | ASTDouble Double @@ -141,6 +170,7 @@ data ASTNode | ASTHashMap (M.Map AST AST) | ASTFunction Purity LFunction | ASTRecord TagHash String LRecord + | ASTAtom LAtomRef | ASTUnit | ASTHole @@ -172,6 +202,7 @@ instance (Show ASTNode) where show (ASTRecord _ identifier record) = let assocsStrList = map (\(k, v) -> k ++ ":" ++ show v) (M.assocs record) in "(" ++ identifier ++ " " ++ L.intercalate " " assocsStrList ++ ")" + show (ASTAtom _) = "" show ASTUnit = "" show ASTHole = "" @@ -189,27 +220,18 @@ instance (Eq ASTNode) where ASTFunctionCall a == ASTFunctionCall b = a == b ASTHashMap a == ASTHashMap b = a == b ASTRecord ah _ hma == ASTRecord bh _ hmb = ah == bh && hma == hmb + ASTAtom a == ASTAtom b = a == b ASTUnit == ASTUnit = True ASTHole == _ = True _ == ASTHole = True _ == _ = False +-- Ord instance needed for M.Map instance (Ord AST) where AST { an = node1 } <= AST { an = node2 } = node1 <= node2 instance (Ord ASTNode) where - ASTInteger a <= ASTInteger b = a <= b - ASTDouble a <= ASTDouble b = a <= b - ASTSymbol a <= ASTSymbol b = a <= b - ASTBoolean a <= ASTBoolean b = a <= b - ASTString a <= ASTString b = a <= b - ASTVector a <= ASTVector b = a <= b - ASTFunctionCall a <= ASTFunctionCall b = a <= b - ASTHashMap a <= ASTHashMap b = a <= b - ASTUnit <= ASTUnit = True - ASTHole <= _ = True - _ <= ASTHole = True - _ <= _ = False + _ <= _ = True computeTagNSeed :: W.Word64 computeTagNSeed = 123 diff --git a/test/Spec.hs b/test/Spec.hs index 4839ace..68e575c 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -126,7 +126,18 @@ e2eTests = testGroup "e2e" [ let expectedLastAST = astRecord "Result/Ex" $ M.fromList [("value", astString "failed to read file: does-not-exist.txt")] + assertEqual "" expectedLastAST (last gotASTs), + + do let env = builtinEnv + script1 <- readFile "test/scripts/atom1.milch" + (gotASTs, gotState) <- expectSuccessL env $ runInlineScript "" script1 + + let expectedLastAST = astInteger 15 assertEqual "" expectedLastAST (last gotASTs) + + let expectedAtomMap = M.singleton (LAtomRef 1) (astInteger 15) + let gotAtomMap = stateAtomMap gotState + assertEqual "" expectedAtomMap gotAtomMap ] testGroup label xs = TestLabel label $ TestList $ map TestCase xs diff --git a/test/TestUtils.hs b/test/TestUtils.hs index ff53310..89bc6e6 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -20,7 +20,8 @@ testRunL env = runL LState { stateConfig = testConfig, stateEnv = env, stateDepth = 0, - statePure = Impure + statePure = Impure, + stateAtomMap = M.empty } expectSuccessL :: Env -> LContext a -> IO (a, LState) diff --git a/test/scripts/atom1.milch b/test/scripts/atom1.milch new file mode 100644 index 0000000..0ee6f8f --- /dev/null +++ b/test/scripts/atom1.milch @@ -0,0 +1,14 @@ +(import "core/common") + +(let state (atom! 10)) + +(let do-loop! (\![i n] + (match true + (lt? i n) (do (atom-update! inc state) + (do-loop! (inc i) n)) + otherwise unit))) + +(do-loop! 0 5) + +(atom-get! state) +; => 15 -- cgit v1.3