Implemented `:load` directive

IHaskell/Eval/Evaluate.hs

@@ -8,7 +8,7 @@ module IHaskell.Eval.Evaluate (
   interpret, evaluate, Interpreter, liftIO, typeCleaner, globalImports
   ) where
 
-import ClassyPrelude hiding (liftIO, hGetContents)
+import ClassyPrelude hiding (liftIO, hGetContents, try)
 import Control.Concurrent (forkIO, threadDelay)
 import Prelude (putChar, head, tail, last, init, (!!))
 import Data.List.Utils
@@ -19,7 +19,7 @@ import Data.Char as Char
 import Data.Dynamic
 import Data.Typeable
 import qualified Data.Serialize as Serialize
-import System.Directory (removeFile, createDirectoryIfMissing, removeDirectoryRecursive)
+import System.Directory
 import System.Posix.IO
 import System.IO (hGetChar, hFlush)
 import System.Random (getStdGen, randomRs)
@@ -228,6 +228,7 @@ evalCommand _ (Import importStr) state = wrapExecution state $ do
 
 evalCommand _ (Module contents) state = wrapExecution state $ do
   write $ "Module:\n" ++ contents
+
   -- Write the module contents to a temporary file in our work directory
   namePieces <- getModuleName contents
   let directory = "./" ++ intercalate "/" (init namePieces) ++ "/"
@@ -241,16 +242,10 @@ evalCommand _ (Module contents) state = wrapExecution state $ do
   removeTarget $ TargetModule $ mkModuleName modName
   removeTarget $ TargetFile filename Nothing
 
-  -- Set to use object code for fast running times, as that is the only
-  -- reason you would want to use modules in IHaskell.
-  flags <- getSessionDynFlags
-  let objTarget = defaultObjectTarget
-  setSessionDynFlags flags{ hscTarget = objTarget }
-
   -- Remember which modules we've loaded before.
   importedModules <- getContext
 
-  let -- Get the dot-delimited pieces of hte module name.
+  let -- Get the dot-delimited pieces of the module name.
       moduleNameOf :: InteractiveImport -> [String]
       moduleNameOf (IIDecl decl) = split "." . moduleNameString . unLoc . ideclName $ decl
       moduleNameOf (IIModule imp) = split "." . moduleNameString $ imp
@@ -267,33 +262,13 @@ evalCommand _ (Module contents) state = wrapExecution state $ do
   -- Otherwise, GHC tries to load the original *.hs fails and then fails.
   case find preventsLoading importedModules of
     -- If something prevents loading this module, return an error.
-    Just previous -> 
-      let prevLoaded = intercalate "." (moduleNameOf previous) in
-        return $ displayError $
-          printf "Can't load module %s because already loaded %s" modName prevLoaded
+    Just previous -> do
+      let prevLoaded = intercalate "." (moduleNameOf previous)
+      return $ displayError $
+        printf "Can't load module %s because already loaded %s" modName prevLoaded
 
     -- Since nothing prevents loading the module, compile and load it.
-    Nothing -> do
-      -- Create a new target
-      target <- guessTarget modName Nothing
-      addTarget target
-      result <- load LoadAllTargets
-
-      -- Reset the context, since loading things screws it up.
-      initializeItVariable
-
-      -- Add imports
-      importDecl <- parseImportDecl $ "import " ++ modName
-      let implicitImport = importDecl { ideclImplicit = True }
-      setContext $ IIDecl implicitImport : importedModules
-
-      -- Switch back to interpreted mode.
-      flags <- getSessionDynFlags
-      setSessionDynFlags flags{ hscTarget = HscInterpreted }
-
-      case result of
-        Succeeded -> return []
-        Failed -> return $ displayError $ "Failed to load module " ++ modName
+    Nothing -> doLoadModule modName modName
 
 evalCommand _ (Directive SetExtension exts) state = wrapExecution state $ do
   write $ "Extension: " ++ exts
@@ -348,6 +323,21 @@ evalCommand _ (Directive GetType expr) state = wrapExecution state $ do
   let typeStr = showSDocUnqual flags $ ppr result
   return [plain typeStr, html $ formatGetType typeStr]
 
+evalCommand _ (Directive LoadFile name) state = wrapExecution state $ do
+  write $ "Load: " ++ name
+
+  let filename = if endswith ".hs" name
+                 then name
+                 else name ++ ".hs"
+  let modName =  replace "/" "."  $
+                   if endswith ".hs" name
+                   then replace ".hs" "" name
+                   else name
+
+  doLoadModule filename modName
+
+
+
 -- This is taken largely from GHCi's info section in InteractiveUI.
 evalCommand _ (Directive HelpForSet _) state = do
   write "Help for :set."
@@ -517,6 +507,46 @@ evalCommand _ (ParseError loc err) state = do
     evalState = state
   }
 
+doLoadModule :: String -> String -> Ghc [DisplayData]
+doLoadModule name modName = flip gcatch unload $ do
+  -- Compile loaded modules. 
+  flags <- getSessionDynFlags
+  let objTarget = defaultObjectTarget
+  setSessionDynFlags flags{ hscTarget = objTarget }
+
+  -- Remember which modules we've loaded before.
+  importedModules <- getContext
+
+  -- Create a new target
+  target <- guessTarget name Nothing
+  addTarget target
+  result <- load LoadAllTargets
+
+  -- Reset the context, since loading things screws it up.
+  initializeItVariable
+
+  -- Add imports
+  importDecl <- parseImportDecl $ "import " ++ modName
+  let implicitImport = importDecl { ideclImplicit = True }
+  setContext $ IIDecl implicitImport : importedModules
+
+  -- Switch back to interpreted mode.
+  flags <- getSessionDynFlags
+  setSessionDynFlags flags{ hscTarget = HscInterpreted }
+
+  case result of
+    Succeeded -> return []
+    Failed -> return $ displayError $ "Failed to load module " ++ modName
+  where
+    unload :: SomeException -> Ghc [DisplayData]
+    unload exception = do
+      -- Explicitly clear targets
+      setTargets []
+      load LoadAllTargets
+
+      initializeItVariable
+      return $ displayError $ "Failed to load module " ++ modName ++ ": " ++ show exception
+
 capturedStatement :: (String -> IO ())         -- ^ Function used to publish intermediate output.
                   -> String                            -- ^ Statement to evaluate.
                   -> Interpreter (String, RunResult)   -- ^ Return the output and result.

IHaskell/Eval/Parser.hs

@@ -58,6 +58,7 @@ data DirectiveType
   = GetType         -- ^ Get the type of an expression via ':type' (or unique prefixes)
   | GetInfo         -- ^ Get info about the identifier via ':info' (or unique prefixes)
   | SetExtension    -- ^ Enable or disable an extension via ':extension' (or prefixes)
+  | LoadFile        -- ^ Load a Haskell module.
   | SetLint         -- ^ Enable or disable a hlint via ':hlint on' or ':hlint off'
   | HelpForSet      -- ^ Provide useful info if people try ':set'.
   | GetHelp         -- ^ General help via ':?' or ':help'.
@@ -234,6 +235,7 @@ parseDirective (':':directive) line = case find rightDirective directives of
       [(GetType,      "type")
       ,(GetInfo,      "info")
       ,(SetExtension, "extension")
+      ,(LoadFile,     "load")
       ,(SetLint,      "hlint")
       ,(HelpForSet,   "set")
       ,(GetHelp,      "?")

IHaskell/IPython.hs

@@ -63,6 +63,7 @@ instance Read ViewFormat where
       "md" -> return Markdown
       _ -> pfail
 
+
 -- | Which commit of IPython we are on.
 ipythonCommit :: Text
 ipythonCommit = "9c922f54af799704f4000aeee94ec7c74cada194"

IHaskell/Types.hs

@@ -71,13 +71,15 @@ instance ToJSON Profile where
 -- | All state stored in the kernel between executions.
 data KernelState = KernelState
   { getExecutionCounter :: Int,
-    getLintStatus :: LintStatus  -- Whether to use hlint, and what arguments to pass it. 
+    getLintStatus :: LintStatus,  -- Whether to use hlint, and what arguments to pass it. 
+    getCwd :: String
   }
 
 -- | Initialization information for the kernel.
 data InitInfo = InitInfo {
   extensions :: [String],   -- ^ Extensions to enable at start.
-  initCells :: [String]     -- ^ Code blocks to run before start.
+  initCells :: [String],    -- ^ Code blocks to run before start.
+  initDir :: String         -- ^ Which directory this kernel should pretend to operate in.
   }
   deriving (Show, Read)
 

Main.hs

@@ -158,7 +158,11 @@ ihaskell (Args Notebook flags) = showingHelp Notebook flags $ do
                  xs -> Just $ last xs
 
   flags <- addDefaultConfFile flags
-  info <- initInfo flags
+
+  undirInfo <- initInfo flags
+  curdir <- getCurrentDirectory
+  let info = undirInfo { initDir = curdir }
+
   runNotebook info server
   where
     serveDir (ServeFrom dir) = Just dir
@@ -194,7 +198,7 @@ showingHelp mode flags act =
  
 -- | Parse initialization information from the flags.
 initInfo :: [Argument] -> IO InitInfo
-initInfo [] = return InitInfo { extensions = [], initCells = []}
+initInfo [] = return InitInfo { extensions = [], initCells = [], initDir = "."}
 initInfo (flag:flags) = do
   info <- initInfo flags
   case flag of
@@ -209,11 +213,7 @@ runKernel :: String    -- ^ Filename of profile JSON file.
           -> InitInfo  -- ^ Initialization information from the invocation.
           -> IO ()
 runKernel profileSrc initInfo = do
-  -- Switch to a temporary directory so that any files we create aren't
-  -- visible. On Unix, this is usually /tmp.  If there is no temporary
-  -- directory available, just stay in the current one and ignore the
-  -- raised exception.
-  try (getTemporaryDirectory >>= setCurrentDirectory) :: IO (Either SomeException ())
+  setCurrentDirectory $ initDir initInfo
 
   -- Parse the profile file.
   Just profile <- liftM decode . readFile . fpFromText $ pack profileSrc
@@ -221,7 +221,10 @@ runKernel profileSrc initInfo = do
   -- Serve on all sockets and ports defined in the profile.
   interface <- serveProfile profile
 
+  -- Create initial state in the directory the kernel *should* be in.
   state <- initialKernelState
+  modifyMVar_ state $ \initState ->
+    return initState { getCwd = initDir initInfo }
 
   -- Receive and reply to all messages on the shell socket.
   interpret $ do
@@ -259,7 +262,8 @@ initialKernelState :: IO (MVar KernelState)
 initialKernelState =
   newMVar KernelState {
     getExecutionCounter = 1,
-    getLintStatus = LintOn
+    getLintStatus = LintOn,
+    getCwd = "."
   }
 
 -- | Duplicate a message header, giving it a new UUID and message type.