Ensure that imports do not overwrite symbols

6 files changed, 56 insertions, 24 deletions

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 = "<builtin>"
+
 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 "<repl>"
+    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 "<test>" 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 "<test>" 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")