load loads.

1 files changed, 25 insertions, 0 deletions

diff --git a/app/Builtins.hs b/app/Builtins.hs
index 9e72caa..7ef4c10 100644
--- a/app/Builtins.hs
+++ b/app/Builtins.hs
@@ -16,8 +16,10 @@ import Code
   , newHeapVars
   )
 import qualified Compiler as Co
+import Control.Exception (IOException, catch)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Except (runExceptT)
 import Control.Monad.Trans.State.Lazy (get, gets, modify)
 import Data.Functor.Identity (runIdentity)
 import Data.List (intercalate)
@@ -26,6 +28,7 @@ import Data.Maybe (fromJust)
 import Env (PrlgEnv(..), findAtom, findStruct, prlgError)
 import qualified IR
 import Interpreter (backtrack)
+import Load (processInput)
 import qualified Operators as O
 import System.Console.Haskeline (getInputChar, outputStr, outputStrLn)
 
@@ -299,6 +302,25 @@ addBi :: InterpFn -> String -> Int -> PrlgEnv ()
 addBi b n a =
   addProc [[U (LocalRef $ r - 1) | r <- [1 .. a]] ++ [Invoke $ bi b]] n a
 
+{- loading code -}
+load :: Bool -> InterpFn
+load queryMode =
+  withArgs [0] $ \[arg] -> do
+    heap <- gets (heap . cur)
+    IR.StrTable _ _ itos <- gets strtable --TODO the argument here should preferably be a string, right?
+    case derefHeap heap arg of
+      BoundRef _ (Atom a) -> do
+        let fn = itos M.! a
+        src' <- liftIO $ catch (Right <$> readFile fn) (pure . Left)
+        case src' of
+          Right src -> do
+            res <- runExceptT $ processInput fn queryMode src
+            case res of
+              Right _ -> continue
+              Left e -> prlgError $ "loading from '" ++ fn ++ "': " ++ e
+          Left e -> prlgError $ show (e :: IOException)
+      _ -> prlgError "load needs an atom"
+
 {- actual prlgude -}
 addPrelude :: PrlgEnv ()
 addPrelude = do
@@ -330,6 +352,9 @@ addPrelude = do
   addBi retractall "retractall" 1
   addBi call "call" 1
   addBi struct "struct" 3
+  {- code loading -}
+  addBi (load False) "load" 1
+  addBi (load True) "source" 1
   {- operators -}
   addBi op "op" 3
   addBi stashOps "stash_operators" 0