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 ++++++++++++--- test/Spec.hs | 9 ++++++++- test/TestUtils.hs | 3 ++- test/scripts/import1.milch | 2 ++ 6 files changed, 56 insertions(+), 24 deletions(-) create mode 100644 test/scripts/import1.milch 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 = diff --git a/test/Spec.hs b/test/Spec.hs index e522c9c..0059ea7 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -144,7 +144,14 @@ e2eTests = testGroup "e2e" [ (gotASTs, _) <- expectSuccessL env $ runInlineScript "" script1 let expectedLastAST = astBoolean True - assertEqual "" expectedLastAST (last gotASTs) + assertEqual "" expectedLastAST (last gotASTs), + + do let env = M.empty + script1 <- readFile "test/scripts/import1.milch" + got <- expectErrorL env $ runInlineScript "" script1 + + let expected = "error: import shadows symbols: id" + assertBool "" (expected `L.isInfixOf` got) ] testGroup label xs = TestLabel label $ TestList $ map TestCase xs diff --git a/test/TestUtils.hs b/test/TestUtils.hs index 89bc6e6..42352e5 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -4,6 +4,7 @@ module TestUtils where import qualified Data.Map as M import qualified Data.Bifunctor as B import Utils +import Builtins ( builtinModule ) testConfig :: Config testConfig = Config { @@ -39,7 +40,7 @@ expectErrorL env lc = Right (val, _) -> error $ "unexpected success: " ++ show val makeEnv :: [(String, AST)] -> Env -makeEnv = M.fromList . map (B.second Regular) +makeEnv = M.fromList . map (B.second (\v -> (builtinModule, Regular v))) ast :: ASTNode -> AST ast node = makeNonsenseAST node diff --git a/test/scripts/import1.milch b/test/scripts/import1.milch new file mode 100644 index 0000000..bd3d111 --- /dev/null +++ b/test/scripts/import1.milch @@ -0,0 +1,2 @@ +(let id 123) +(import "core/common") -- cgit v1.3