Merge pull request #449 from gibiansky/show-module-compilation-errors

Improving module loading; fixes #312

src/IHaskell/Eval/Evaluate.hs

@@ -18,7 +18,7 @@ import           ClassyPrelude hiding (init, last, liftIO, head, hGetContents, t
 import           Control.Concurrent (forkIO, threadDelay)
 import           Prelude (putChar, head, tail, last, init, (!!))
 import           Data.List.Utils
-import           Data.List (findIndex, and, foldl1)
+import           Data.List (findIndex, and, foldl1, nubBy)
 import           Data.String.Utils
 import           Text.Printf
 import           Data.Char as Char
@@ -397,7 +397,6 @@ evalCommand _ (Module contents) state = wrapExecution state $ do
 
   -- Write the module contents to a temporary file in our work directory
   namePieces <- getModuleName contents
-  liftIO (print namePieces)
   let directory = "./" ++ intercalate "/" (init namePieces) ++ "/"
       filename = last namePieces ++ ".hs"
   liftIO $ do
@@ -557,15 +556,17 @@ evalCommand _ (Directive GetKind expr) state = wrapExecution state $ do
   let typeStr = showSDocUnqual flags $ ppr kind
   return $ formatType $ expr ++ " :: " ++ typeStr
 
-evalCommand _ (Directive LoadFile name) state = wrapExecution state $ do
-  write state $ "Load: " ++ name
+evalCommand _ (Directive LoadFile names) state = wrapExecution state $ do
+  write state $ "Load: " ++ names
 
-  let filename = if endswith ".hs" name
-                   then name
-                   else name ++ ".hs"
-  contents <- readFile $ fpFromString filename
-  modName <- intercalate "." <$> getModuleName contents
-  doLoadModule filename modName
+  displays <- forM (words names) $ \name -> do
+                let filename = if endswith ".hs" name
+                                 then name
+                                 else name ++ ".hs"
+                contents <- readFile $ fpFromString filename
+                modName <- intercalate "." <$> getModuleName contents
+                doLoadModule filename modName
+  return (ManyDisplay displays)
 
 evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
   case words cmd of
@@ -1001,26 +1002,6 @@ hoogleResults state results =
     fmt = Hoogle.HTML
     output = unlines $ map (Hoogle.render fmt) results
 
--- Read from a file handle until we hit a delimiter or until we've read as many characters as
--- requested
-readChars :: Handle -> String -> Int -> IO String
--- If we're done reading, return nothing.
-readChars handle delims 0 = return []
-
-readChars handle delims nchars = do
-  -- Try reading a single character. It will throw an exception if the handle is already closed.
-  tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char)
-  case tryRead of
-    Right char ->
-      -- If this is a delimiter, stop reading.
-      if char `elem` delims
-        then return [char]
-        else do
-          next <- readChars handle delims (nchars - 1)
-          return $ char : next
-    -- An error occurs at the end of the stream, so just stop reading.
-    Left _ -> return []
-
 doLoadModule :: String -> String -> Ghc Display
 doLoadModule name modName = do
   -- Remember which modules we've loaded before.
@@ -1029,32 +1010,43 @@ doLoadModule name modName = do
   flip gcatch (unload importedModules) $ do
     -- Compile loaded modules.
     flags <- getSessionDynFlags
-    setSessionDynFlags flags { hscTarget = objTarget flags }
-
-    -- Clear old targets to be sure.
-    setTargets []
-    load LoadAllTargets
+    errRef <- liftIO $ newIORef []
+    setSessionDynFlags
+      flags
+        { hscTarget = objTarget flags
+        , log_action = \dflags sev srcspan ppr msg -> modifyIORef errRef (showSDoc flags msg :)
+        }
 
     -- Load the new target.
     target <- guessTarget name Nothing
+    oldTargets <- getTargets
+    -- Add a target, but make sure targets are unique!
     addTarget target
+    getTargets >>= return . (nubBy ((==) `on` targetId)) >>= setTargets
     result <- load LoadAllTargets
 
     -- Reset the context, since loading things screws it up.
     initializeItVariable
 
+    -- Reset targets if we failed.
+    case result of
+      Failed      -> setTargets oldTargets
+      Succeeded{} -> return ()
+
     -- Add imports
-    importDecl <- parseImportDecl $ "import " ++ modName
-    let implicitImport = importDecl { ideclImplicit = True }
-    setContext $ IIDecl implicitImport : importedModules
+    setContext $
+      case result of
+        Failed    -> importedModules
+        Succeeded -> IIDecl (simpleImportDecl $ mkModuleName modName) : importedModules
 
     -- Switch back to interpreted mode.
-    flags <- getSessionDynFlags
-    setSessionDynFlags flags { hscTarget = HscInterpreted }
+    setSessionDynFlags flags
 
     case result of
       Succeeded -> return mempty
-      Failed    -> return $ displayError $ "Failed to load module " ++ modName
+      Failed -> do
+        errorStrs <- unlines <$> reverse <$> liftIO (readIORef errRef)
+        return $ displayError $ "Failed to load module " ++ modName ++ "\n" ++ errorStrs
 
   where
     unload :: [InteractiveImport] -> SomeException -> Ghc Display
@@ -1154,27 +1146,6 @@ capturedStatement output stmt = do
             fd <- head <$> unsafeCoerce hValues
             fdToHandle fd
 
-  -- Read from a file handle until we hit a delimiter or until we've read as many characters as
-  -- requested
-  let readChars :: Handle -> String -> Int -> IO String
-
-      -- If we're done reading, return nothing.
-      readChars handle delims 0 = return []
-
-      readChars handle delims nchars = do
-        -- Try reading a single character. It will throw an exception if the handle is already closed.
-        tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char)
-        case tryRead of
-          Right char ->
-            -- If this is a delimiter, stop reading.
-            if char `elem` delims
-              then return [char]
-              else do
-                next <- readChars handle delims (nchars - 1)
-                return $ char : next
-          -- An error occurs at the end of the stream, so just stop reading.
-          Left _ -> return []
-
 
   -- Keep track of whether execution has completed.
   completed <- liftIO $ newMVar False
@@ -1232,6 +1203,26 @@ capturedStatement output stmt = do
   printedOutput <- liftIO $ readMVar outputAccum
   return (printedOutput, result)
 
+-- Read from a file handle until we hit a delimiter or until we've read as many characters as
+-- requested
+readChars :: Handle -> String -> Int -> IO String
+readChars handle delims 0 =
+  -- If we're done reading, return nothing.
+  return []
+readChars handle delims nchars = do
+  -- Try reading a single character. It will throw an exception if the handle is already closed.
+  tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char)
+  case tryRead of
+    Right char ->
+      -- If this is a delimiter, stop reading.
+      if char `elem` delims
+        then return [char]
+        else do
+          next <- readChars handle delims (nchars - 1)
+          return $ char : next
+    -- An error occurs at the end of the stream, so just stop reading.
+    Left _ -> return []
+
 formatError :: ErrMsg -> String
 formatError = formatErrorWithClass "err-msg"