From e0e1c1d7573fc5251fe537314b6a6cfefae09e39 Mon Sep 17 00:00:00 2001 From: Jan Tuomi Date: Sun, 11 Dec 2022 18:45:46 +0200 Subject: Ensure that imports do not overwrite symbols --- src/Builtins.hs | 5 ++++- src/Interpreter.hs | 46 ++++++++++++++++++++++++++++------------------ src/Utils.hs | 15 ++++++++++++--- 3 files changed, 44 insertions(+), 22 deletions(-) (limited to 'src') diff --git a/src/Builtins.hs b/src/Builtins.hs index 4ac6598..7cc6b5c 100644 --- a/src/Builtins.hs +++ b/src/Builtins.hs @@ -9,8 +9,11 @@ import qualified Data.Bifunctor as B import Control.Monad.State import Utils +builtinModule :: SourceModule +builtinModule = "" + builtinEnv :: Env -builtinEnv = M.fromList $ map (B.second Regular) [ +builtinEnv = M.fromList $ map (B.second (\v -> (builtinModule, Regular v))) [ -- number (integer, double) operations builtinNumAdd2, builtinNumSubtract2, diff --git a/src/Interpreter.hs b/src/Interpreter.hs index f8c45b0..dccba10 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -212,30 +212,40 @@ evaluateImport asts = do config <- getConfig atomMap <- getAtomMap + env <- getEnv + + path <- case args of + [AST { an = ASTString path }] -> return path + other -> throwL (astPos importAst, "invalid args passed to import: " ++ show other) + + let checkedPath = if (not $ ".milch" `L.isSuffixOf` path) + then (path ++ ".milch") + else path let initialState = LState { - stateConfig = config, + stateConfig = config { configScriptFileName = Just checkedPath }, stateDepth = 0, stateEnv = builtinEnv, 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, stateAtomMap = importedAtomMap } <- lift $ execStateT (runScriptFile checkedPath) initialState - env <- getEnv + LState { stateEnv = importedEnv, stateAtomMap = importedAtomMap } + <- lift $ execStateT (runScriptFile checkedPath) initialState + + let conflicting = M.intersection importedEnv env + $> M.assocs + .> map (\(k, (importedSm, _)) -> (k, importedSm, fst $ env M.! k)) + .> filter (\(_, sm1, sm2) -> sm1 /= sm2) - putEnv $ M.union importedEnv env - putAtomMap $ M.union importedAtomMap atomMap + when (length conflicting > 0) $ + throwL (astPos importAst, "import shadows symbols: " + ++ L.intercalate ", " (map (\(k, _, sm) -> k ++ " (defined in " ++ show sm ++ ")") conflicting)) - return $ importAst { an = ASTUnit } + putEnv $ M.union importedEnv env + putAtomMap $ M.union importedAtomMap atomMap - _ -> throwL (astPos importAst, "invalid arguments passed to import: " ++ show args) + return $ importAst { an = ASTUnit } evaluateRecord :: [AST] -> LContext AST evaluateRecord asts = do @@ -329,7 +339,7 @@ reifyFunctionReference ref = case ref of env <- getEnv let bindingM = resolveSymbol sym env case bindingM of - Just binding -> case binding of + Just (_, binding) -> case binding of Regular bound -> return $ ReifyRegularFunction $ bound Memoized _memoMap bound -> return $ ReifyMemoizedFunction sym $ bound Nothing -> throwL (astPos ref, "symbol " ++ sym ++ " not defined in environment") @@ -341,7 +351,7 @@ unsafeGetMemoMap :: String -> LContext (M.Map [AST] AST) unsafeGetMemoMap sym = do env <- getEnv case ((M.!) env sym) of - Memoized memoMap _ -> return memoMap + (_, Memoized memoMap _) -> return memoMap _ -> error $ "unreachable: unsafeGetMemoMap " ++ show env ++ ", " ++ sym callFunction :: AST -> AST -> LContext AST @@ -384,7 +394,7 @@ evaluateFunctionCall children = do insertEnv sym $ Memoized newMemoMap bound return $ fnAst { an = an result } -resolveSymbol :: String -> Env -> Maybe (Binding AST) +resolveSymbol :: String -> Env -> Maybe (SourceModule, Binding AST) resolveSymbol = M.lookup evaluateDo :: [AST] -> LContext AST @@ -439,7 +449,7 @@ evaluate ast@AST { an = fnc@(ASTFunctionCall args@(x:_)) } = evaluateMatch args ASTSymbol "let" -> evaluateLet args - ASTSymbol "Debug/env" -> + ASTSymbol "Debug/env!" -> evaluateDebugEnv args ASTSymbol "import" -> evaluateImport args @@ -463,7 +473,7 @@ evaluate ast@AST { an = ASTSymbol sym } = do env <- getEnv let bindingM = resolveSymbol sym env case bindingM of - Just binding -> return $ case binding of + Just (_, binding) -> return $ case binding of Regular v -> v Memoized _ v -> v Nothing -> throwL (astPos ast, "symbol " ++ sym ++ " not defined in environment") diff --git a/src/Utils.hs b/src/Utils.hs index 1eabd72..d1a1642 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -10,7 +10,8 @@ import qualified Data.Char as C import qualified Data.Text as T import qualified FarmHash as FH import qualified Data.ByteString.UTF8 as BSU -import Data.Word as W +import qualified Data.Maybe as MB +import qualified Data.Word as W -- TYPES @@ -39,7 +40,8 @@ data Binding a | Memoized (M.Map [a] a) a deriving Show -type Env = M.Map String (Binding AST) +type SourceModule = String +type Env = M.Map String (SourceModule, Binding AST) type Scope = [(String, AST)] type AtomMap = M.Map LAtomRef AST @@ -68,6 +70,12 @@ getConfig = do s <- get return $ stateConfig s +getCurrentModule :: LContext SourceModule +getCurrentModule = do + config <- getConfig + let curMod = configScriptFileName config $> MB.fromMaybe "" + return curMod + putEnv :: Env -> LContext () putEnv env = do modify (\s -> s { stateEnv = env }) @@ -75,7 +83,8 @@ putEnv env = do insertEnv :: String -> Binding AST -> LContext () insertEnv k v = do env <- getEnv - putEnv $ M.insert k v env + currentModule <- getCurrentModule + putEnv $ M.insert k (currentModule, v) env incrementDepth :: LContext () incrementDepth = -- cgit v1.3