diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Builtins.hs | 43 | ||||
| -rw-r--r-- | src/Interpreter.hs | 12 | ||||
| -rw-r--r-- | src/Utils.hs | 48 |
3 files changed, 85 insertions, 18 deletions
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 _) = "<atom>" show ASTUnit = "<unit>" show ASTHole = "<hole>" @@ -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 |