Make casesplit a HaRe action

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

@@ -9,8 +9,6 @@ module Haskell.Ide.Engine.Plugin.GhcMod where
 import           Bag
 import           Control.Monad.IO.Class
 import           Control.Lens hiding (cons, children)
-import           Control.Lens.Setter ((%~))
-import           Control.Lens.Traversal (traverseOf)
 import           Data.Aeson
 import           Data.Function
 import qualified Data.HashMap.Strict               as HM
@@ -21,7 +19,6 @@ import           Data.Maybe
 import           Data.Monoid ((<>))
 import qualified Data.Set                          as Set
 import qualified Data.Text                         as T
-import qualified Data.Text.IO                      as T
 import           ErrUtils
 import qualified Exception                         as G
 import           Name
@@ -35,11 +32,9 @@ import qualified GhcMod.Monad                      as GM
 import qualified GhcMod.SrcUtils                   as GM
 import qualified GhcMod.Types                      as GM
 import qualified GhcMod.Utils                      as GM
-import qualified GhcMod.Exe.CaseSplit              as GM
 import           Haskell.Ide.Engine.MonadFunctions
 import           Haskell.Ide.Engine.MonadTypes
 import           Haskell.Ide.Engine.PluginUtils
-import           Haskell.Ide.Engine.Plugin.HaRe (HarePoint(..))
 import qualified Haskell.Ide.Engine.Plugin.HieExtras as Hie
 import           Haskell.Ide.Engine.ArtifactMap
 import qualified Language.Haskell.LSP.Types        as LSP
@@ -68,7 +63,6 @@ ghcmodDescriptor plId = PluginDescriptor
       , PluginCommand "lint" "Check files using `hlint'" lintCmd
       , PluginCommand "info" "Look up an identifier in the context of FILE (like ghci's `:info')" infoCmd
       , PluginCommand "type" "Get the type of the expression under (LINE,COL)" typeCmd
-      , PluginCommand "casesplit" "Generate a pattern match for a binding under (LINE,COL)" splitCaseCmd
       ]
   , pluginCodeActionProvider = Just codeActionProvider
   , pluginDiagnosticProvider = Nothing
@@ -307,65 +301,6 @@ cmp a b
 isSubRangeOf :: Range -> Range -> Bool
 isSubRangeOf (Range sa ea) (Range sb eb) = sb <= sa && eb >= ea
 
-
-splitCaseCmd :: CommandFunc HarePoint WorkspaceEdit
-splitCaseCmd = CmdSync $ \_ (HP uri pos) -> splitCaseCmd' uri pos
-
-splitCaseCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
-splitCaseCmd' uri newPos =
-  pluginGetFile "splitCaseCmd: " uri $ \path -> do
-    origText <- GM.withMappedFile path $ liftIO . T.readFile
-    ifCachedModule path (IdeResultOk mempty) $ \tm info -> runGhcModCommand $
-      case newPosToOld info newPos of
-        Just oldPos -> do
-          let (line, column) = unPos oldPos
-          splitResult' <- GM.splits' path tm line column
-          case splitResult' of
-            Just splitResult -> do
-              wEdit <- liftToGhc $ splitResultToWorkspaceEdit origText splitResult
-              return $ oldToNewPositions info wEdit
-            Nothing -> return mempty
-        Nothing -> return mempty
-  where
-
-    -- | Transform all ranges in a WorkspaceEdit from old to new positions.
-    oldToNewPositions :: CachedInfo -> WorkspaceEdit -> WorkspaceEdit
-    oldToNewPositions info wsEdit =
-      wsEdit
-        & LSP.documentChanges %~ (>>= traverseOf (traverse . LSP.edits . traverse . LSP.range) (oldRangeToNew info))
-        & LSP.changes %~ (>>= traverseOf (traverse . traverse . LSP.range) (oldRangeToNew info))
-
-    -- | Given the range and text to replace, construct a 'WorkspaceEdit'
-    -- by diffing the change against the current text.
-    splitResultToWorkspaceEdit :: T.Text -> GM.SplitResult -> IdeM WorkspaceEdit
-    splitResultToWorkspaceEdit originalText (GM.SplitResult replaceFromLine replaceFromCol replaceToLine replaceToCol replaceWith) =
-      diffText (uri, originalText) newText IncludeDeletions
-      where
-        before = takeUntil (toPos (replaceFromLine, replaceFromCol)) originalText
-        after = dropUntil (toPos (replaceToLine, replaceToCol)) originalText
-        newText = before <> replaceWith <> after
-
-    -- | Take the first part of text until the given position.
-    -- Returns all characters before the position.
-    takeUntil :: Position -> T.Text -> T.Text
-    takeUntil (Position l c) txt =
-      T.unlines takeLines <> takeCharacters
-      where
-        textLines = T.lines txt
-        takeLines = take l textLines
-        takeCharacters = T.take c (textLines !! c)
-
-    -- | Drop the first part of text until the given position.
-    -- Returns all characters after and including the position.
-    dropUntil :: Position -> T.Text -> T.Text
-    dropUntil (Position l c) txt = dropCharacters
-      where
-        textLines = T.lines txt
-        dropLines = drop l textLines
-        dropCharacters = T.drop c (T.unlines dropLines)
-
--- ---------------------------------------------------------------------
-
 runGhcModCommand :: IdeGhcM a
                  -> IdeGhcM (IdeResult a)
 runGhcModCommand cmd =

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

@@ -7,6 +7,8 @@
 module Haskell.Ide.Engine.Plugin.HaRe where
 
 import           Control.Lens.Operators
+import           Control.Lens.Setter ((%~))
+import           Control.Lens.Traversal (traverseOf)
 import           Control.Monad.State
 import           Control.Monad.Trans.Control
 import           Data.Aeson
@@ -22,12 +24,14 @@ import qualified Data.Text.IO                                 as T
 import           Exception
 import           GHC.Generics                                 (Generic)
 import qualified GhcMod.Error                                 as GM
+import qualified GhcMod.Exe.CaseSplit                         as GM
 import qualified GhcMod.Monad                                 as GM
 import qualified GhcMod.Utils                                 as GM
 import           Haskell.Ide.Engine.ArtifactMap
 import           Haskell.Ide.Engine.MonadFunctions
 import           Haskell.Ide.Engine.MonadTypes
 import           Haskell.Ide.Engine.PluginUtils
+import           Haskell.Ide.Engine.Plugin.GhcMod             (runGhcModCommand)
 import qualified Haskell.Ide.Engine.Plugin.HieExtras          as Hie
 import           Language.Haskell.GHC.ExactPrint.Print
 import qualified Language.Haskell.LSP.Core                    as Core
@@ -64,6 +68,9 @@ hareDescriptor plId = PluginDescriptor
           deleteDefCmd
       , PluginCommand "genapplicative" "Generalise a monadic function to use applicative"
           genApplicativeCommand
+
+      , PluginCommand "casesplit" "Generate a pattern match for a binding under (LINE,COL)"
+          splitCaseCmd
       ]
   , pluginCodeActionProvider = Just codeActionProvider
   , pluginDiagnosticProvider = Nothing
@@ -213,6 +220,64 @@ genApplicativeCommand' uri pos =
 
 -- ---------------------------------------------------------------------
 
+splitCaseCmd :: CommandFunc HarePoint WorkspaceEdit
+splitCaseCmd = CmdSync $ \_ (HP uri pos) -> splitCaseCmd' uri pos
+
+splitCaseCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
+splitCaseCmd' uri newPos =
+  pluginGetFile "splitCaseCmd: " uri $ \path -> do
+    origText <- GM.withMappedFile path $ liftIO . T.readFile
+    ifCachedModule path (IdeResultOk mempty) $ \tm info -> runGhcModCommand $
+      case newPosToOld info newPos of
+        Just oldPos -> do
+          let (line, column) = unPos oldPos
+          splitResult' <- GM.splits' path tm line column
+          case splitResult' of
+            Just splitResult -> do
+              wEdit <- liftToGhc $ splitResultToWorkspaceEdit origText splitResult
+              return $ oldToNewPositions info wEdit
+            Nothing -> return mempty
+        Nothing -> return mempty
+  where
+
+    -- | Transform all ranges in a WorkspaceEdit from old to new positions.
+    oldToNewPositions :: CachedInfo -> WorkspaceEdit -> WorkspaceEdit
+    oldToNewPositions info wsEdit =
+      wsEdit
+        & J.documentChanges %~ (>>= traverseOf (traverse . J.edits . traverse . J.range) (oldRangeToNew info))
+        & J.changes %~ (>>= traverseOf (traverse . traverse . J.range) (oldRangeToNew info))
+
+    -- | Given the range and text to replace, construct a 'WorkspaceEdit'
+    -- by diffing the change against the current text.
+    splitResultToWorkspaceEdit :: T.Text -> GM.SplitResult -> IdeM WorkspaceEdit
+    splitResultToWorkspaceEdit originalText (GM.SplitResult replaceFromLine replaceFromCol replaceToLine replaceToCol replaceWith) =
+      diffText (uri, originalText) newText IncludeDeletions
+      where
+        before = takeUntil (toPos (replaceFromLine, replaceFromCol)) originalText
+        after = dropUntil (toPos (replaceToLine, replaceToCol)) originalText
+        newText = before <> replaceWith <> after
+
+    -- | Take the first part of text until the given position.
+    -- Returns all characters before the position.
+    takeUntil :: Position -> T.Text -> T.Text
+    takeUntil (Position l c) txt =
+      T.unlines takeLines <> takeCharacters
+      where
+        textLines = T.lines txt
+        takeLines = take l textLines
+        takeCharacters = T.take c (textLines !! c)
+
+    -- | Drop the first part of text until the given position.
+    -- Returns all characters after and including the position.
+    dropUntil :: Position -> T.Text -> T.Text
+    dropUntil (Position l c) txt = dropCharacters
+      where
+        textLines = T.lines txt
+        dropLines = drop l textLines
+        dropCharacters = T.drop c (T.unlines dropLines)
+
+-- ---------------------------------------------------------------------
+
 getRefactorResult :: [ApplyRefacResult] -> [(FilePath,T.Text)]
 getRefactorResult = map getNewFile . filter fileModified
   where fileModified ((_,m),_) = m == RefacModified
@@ -294,20 +359,26 @@ hoist f a =
 codeActionProvider :: CodeActionProvider
 codeActionProvider pId docId _ _ (J.Range pos _) _ =
   pluginGetFile "HaRe codeActionProvider: " (docId ^. J.uri) $ \file ->
-    ifCachedInfo file (IdeResultOk mempty) $ \info -> do
-      let symbols = getArtifactsAtPos pos (defMap info)
-      debugm $ show $ map (Hie.showName . snd) symbols
-      if not (null symbols)
-        then
-          let name = Hie.showName $ snd $ head symbols
-            in IdeResultOk <$> sequence [
+    ifCachedInfo file (IdeResultOk mempty) $ \info ->
+      case getArtifactsAtPos pos (defMap info) of
+        [h] -> do
+          let name = Hie.showName $ snd h
+          debugm $ show name
+          IdeResultOk <$> sequence [
               mkLiftOneAction name
             , mkLiftTopAction name
             , mkDemoteAction name
             , mkDeleteAction name
             , mkDuplicateAction name
             ]
-        else return (IdeResultOk [])
+        _   -> case getArtifactsAtPos pos (locMap info) of
+               [h] -> do
+                let name = Hie.showName $ snd h
+                debugm $ show name
+                IdeResultOk <$> sequence [
+                  mkCaseSplitAction name
+                  ]
+               _   -> return $ IdeResultOk []
 
   where
     mkLiftOneAction name = do
@@ -339,3 +410,9 @@ codeActionProvider pId docId _ _ (J.Range pos _) _ =
           title = "Duplicate definition of " <> name
       dupCmd <- mkLspCommand pId "dupdef" title (Just args)
       return $ J.CodeAction title (Just J.CodeActionRefactor) mempty Nothing (Just dupCmd)
+
+    mkCaseSplitAction name = do
+      let args = [J.toJSON $ HP (docId ^. J.uri) pos]
+          title = "Case split on " <> name
+      splCmd <- mkLspCommand pId "casesplit" title (Just args)
+      return $ J.CodeAction title (Just J.CodeActionRefactorRewrite) mempty Nothing (Just splCmd)

test/functional/HaReSpec.hs

@@ -49,6 +49,13 @@ spec = describe "HaRe" $
           expected = "\nmain = putStrLn \"hello\"\n\n\
                      \foo x = y + 3\n  where\n    y = 7\n"
         in execCodeAction "HaReDemote.hs" r "Demote y one level" expected
+    context "casesplit argument" $ it "works" $
+      let r = Range (Position 4 5) (Position 4 6)
+          expected = "\nmain = putStrLn \"hello\"\n\n\
+                     \foo :: Maybe Int -> ()\n\
+                     \foo Nothing = ()\n\
+                     \foo (Just x) = ()\n"
+        in execCodeAction "GhcModCaseSplit.hs" r "Case split on x" expected
 
 
 getCANamed :: T.Text -> [CAResult] -> CodeAction

test/unit/GhcModPluginSpec.hs

@@ -3,7 +3,6 @@
 module GhcModPluginSpec where
 
 import           Control.Exception
-import qualified Data.HashMap.Strict                 as H
 import qualified Data.Map                            as Map
 #if __GLASGOW_HASKELL__ < 804
 import           Data.Monoid
@@ -14,8 +13,6 @@ import           Haskell.Ide.Engine.MonadTypes
 import           Haskell.Ide.Engine.PluginDescriptor
 import           Haskell.Ide.Engine.PluginUtils
 import           Haskell.Ide.Engine.Plugin.GhcMod
-import           Haskell.Ide.Engine.Plugin.HaRe ( HarePoint(..) )
-import           Language.Haskell.LSP.Types     ( TextEdit(..) )
 import           System.Directory
 import           TestUtils
 
@@ -115,38 +112,3 @@ ghcmodSpec =
               ,(Range (toPos (5,1)) (toPos (5,14)), "Int -> Int")
               ]
         testCommand testPlugins act "ghcmod" "type"dummyVfs arg res
-
-    -- ---------------------------------
-
-    it "runs the casesplit command" $ cdAndDo "./test/testdata" $ do
-      fp <- makeAbsolute "GhcModCaseSplit.hs"
-      let uri = filePathToUri fp
-          act = do
-            _ <- setTypecheckedModule uri
-            splitCaseCmd' uri (toPos (5,5))
-          arg = HP uri (toPos (5,5))
-          res = IdeResultOk $ WorkspaceEdit
-            (Just $ H.singleton uri
-                                $ List [TextEdit (Range (Position 4 0) (Position 4 10))
-                                          "foo Nothing = ()\nfoo (Just x) = ()"])
-            Nothing
-      testCommand testPlugins act "ghcmod" "casesplit" dummyVfs arg res
-
-    it "runs the casesplit command with an absolute path from another folder, correct params" $ do
-      fp <- makeAbsolute "./test/testdata/GhcModCaseSplit.hs"
-      cd <- getCurrentDirectory
-      cd2 <- getHomeDirectory
-      bracket (setCurrentDirectory cd2)
-              (\_-> setCurrentDirectory cd)
-              $ \_-> do
-        let uri = filePathToUri fp
-            act = do
-              _ <- setTypecheckedModule uri
-              splitCaseCmd' uri (toPos (5,5))
-            arg = HP uri (toPos (5,5))
-            res = IdeResultOk $ WorkspaceEdit
-              (Just $ H.singleton uri
-                                  $ List [TextEdit (Range (Position 4 0) (Position 4 10))
-                                            "foo Nothing = ()\nfoo (Just x) = ()"])
-              Nothing
-        testCommand testPlugins act "ghcmod" "casesplit" dummyVfs arg res

test/unit/HaRePluginSpec.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module HaRePluginSpec where
 
+import           Control.Exception
 import           Control.Monad.Trans.Free
 import           Control.Monad.IO.Class
 import           Data.Aeson
@@ -173,6 +174,41 @@ hareSpec = do
 
     -- ---------------------------------
 
+    it "runs the casesplit command" $ cdAndDo "./test/testdata" $ do
+      fp <- makeAbsolute "GhcModCaseSplit.hs"
+      let uri = filePathToUri fp
+          act = do
+            _ <- setTypecheckedModule uri
+            splitCaseCmd' uri (toPos (5,5))
+          arg = HP uri (toPos (5,5))
+          res = IdeResultOk $ WorkspaceEdit
+            (Just $ H.singleton uri
+                                $ List [TextEdit (Range (Position 4 0) (Position 4 10))
+                                          "foo Nothing = ()\nfoo (Just x) = ()"])
+            Nothing
+      testCommand testPlugins act "hare" "casesplit" dummyVfs arg res
+
+    it "runs the casesplit command with an absolute path from another folder, correct params" $ do
+      fp <- makeAbsolute "./test/testdata/GhcModCaseSplit.hs"
+      cd <- getCurrentDirectory
+      cd2 <- getHomeDirectory
+      bracket (setCurrentDirectory cd2)
+              (\_-> setCurrentDirectory cd)
+              $ \_-> do
+        let uri = filePathToUri fp
+            act = do
+              _ <- setTypecheckedModule uri
+              splitCaseCmd' uri (toPos (5,5))
+            arg = HP uri (toPos (5,5))
+            res = IdeResultOk $ WorkspaceEdit
+              (Just $ H.singleton uri
+                                  $ List [TextEdit (Range (Position 4 0) (Position 4 10))
+                                            "foo Nothing = ()\nfoo (Just x) = ()"])
+              Nothing
+        testCommand testPlugins act "hare" "casesplit" dummyVfs arg res
+
+    -- ---------------------------------
+
   describe "Additional GHC API commands" $ do
     cwd <- runIO getCurrentDirectory