Merge pull request #1220 from Hogeyama/catch-applyrefact-error

Prevent hie crash if apply-refact crashes

Author: alanz

src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs

@@ -6,6 +6,9 @@ module Haskell.Ide.Engine.Plugin.ApplyRefact where
 
 import           Control.Arrow
 import           Control.Exception              ( IOException
+                                                , ErrorCall
+                                                , Handler(..)
+                                                , catches
                                                 , try
                                                 )
 import           Control.Lens            hiding ( List )
@@ -251,10 +254,17 @@ applyHint fp mhint fileMap = do
     -- If we provide "applyRefactorings" with "Just (1,13)" then
     -- the "Redundant bracket" hint will never be executed
     -- because SrcSpan (1,20,??,??) doesn't contain position (1,13).
-    appliedFile <- liftIO $ applyRefactorings Nothing commands fp
-    diff <- ExceptT $ Right <$> makeDiffResult fp (T.pack appliedFile) fileMap
-    liftIO $ logm $ "applyHint:diff=" ++ show diff
-    return diff
+    res <- liftIO $ (Right <$> applyRefactorings Nothing commands fp) `catches`
+              [ Handler $ \e -> return (Left (show (e :: IOException)))
+              , Handler $ \e -> return (Left (show (e :: ErrorCall)))
+              ]
+    case res of
+      Right appliedFile -> do
+        diff <- ExceptT $ Right <$> makeDiffResult fp (T.pack appliedFile) fileMap
+        liftIO $ logm $ "applyHint:diff=" ++ show diff
+        return diff
+      Left err ->
+        throwE (show err)
 
 -- | Gets HLint ideas for
 getIdeas :: MonadIO m => FilePath -> Maybe OneHint -> ExceptT String m [Idea]

test/testdata/ApplyRefactError.hs

@@ -0,0 +1,2 @@
+foo :: forall a. (a -> a) -> a -> a
+foo f x = f $ x

test/unit/ApplyRefactPluginSpec.hs

@@ -4,6 +4,7 @@
 module ApplyRefactPluginSpec where
 
 import qualified Data.HashMap.Strict                   as H
+import qualified Data.Text                             as T
 import           Haskell.Ide.Engine.Plugin.ApplyRefact
 import           Haskell.Ide.Engine.MonadTypes
 import           Haskell.Ide.Engine.PluginUtils
@@ -153,3 +154,15 @@ applyRefactSpec = do
             , _diagnostics = List []
             }
            ))
+
+    -- ---------------------------------
+
+    it "reports error without crash" $ do
+      filePath  <- filePathToUri <$> makeAbsolute "./test/testdata/ApplyRefactError.hs"
+
+      let req = applyAllCmd' filePath
+          isExpectedError (IdeResultFail (IdeError PluginError err _)) =
+              "Illegal symbol '.' in type" `T.isInfixOf` err
+          isExpectedError _ = False
+      r <- withCurrentDirectory "./test/testdata" $ runIGM testPlugins req
+      r `shouldSatisfy` isExpectedError