Merge branch 'master' of https://github.com/haskell/haskell-ide-engine into import-code-actions

hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs

@@ -197,9 +197,9 @@ failModule fp err = do
       modifyCache (\gmc ->
           gmc {
             uriCaches = Map.insert fp' (UriCacheFailed err) (uriCaches gmc)
-          }  
+          }
         )
-      
+
       -- Fail the queued actions
       runDeferredActions fp' (Left err)
 

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

@@ -7,6 +7,9 @@ module Haskell.Ide.Engine.Plugin.GhcMod where
 
 import           Bag
 import           Control.Monad.IO.Class
+import           Control.Lens.Getter ((^.))
+import           Control.Lens.Setter ((%~))
+import           Control.Lens.Traversal (traverseOf)
 import           Data.Aeson
 #if __GLASGOW_HASKELL__ < 802
 import           Data.Aeson.Types
@@ -20,6 +23,7 @@ import           Data.Monoid
 #endif
 import qualified Data.Set                          as Set
 import qualified Data.Text                         as T
+import qualified Data.Text.IO                      as T
 import           DynFlags
 import           ErrUtils
 import qualified Exception                         as G
@@ -35,11 +39,13 @@ 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.ArtifactMap
 import           HscTypes
+import qualified Language.Haskell.LSP.Types        as LSP
 import           TcRnTypes
 import           Outputable                        (renderWithStyle, mkUserStyle, Depth(..))
 
@@ -57,6 +63,7 @@ ghcmodDescriptor = 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
       ]
   }
 
@@ -184,7 +191,7 @@ setTypecheckedModule uri =
     case mtm of
       Nothing -> do
         debugm $ "setTypecheckedModule: Didn't get typechecked module for: " ++ show fp
-        
+
         failModule fp (T.unlines errs)
 
         return $ IdeResultOk (diags,errs)
@@ -290,6 +297,69 @@ cmp a b
 isSubRangeOf :: Range -> Range -> Bool
 isSubRangeOf (Range sa ea) (Range sb eb) = sb <= sa && eb >= ea
 
+
+splitCaseCmd :: CommandFunc LSP.TextDocumentPositionParams WorkspaceEdit
+splitCaseCmd = CmdSync $ \posParams -> do
+    splitCaseCmd' (posParams ^. LSP.textDocument . LSP.uri) (posParams ^. LSP.position)
+
+splitCaseCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
+splitCaseCmd' uri newPos =
+  pluginGetFile "splitCaseCmd: " uri $ \path -> do
+    origText <- GM.withMappedFile path $ liftIO . T.readFile
+    cachedMod <- getCachedModule path
+    case cachedMod of
+      ModuleCached checkedModule _ ->
+        runGhcModCommand $
+        case newPosToOld checkedModule newPos of
+          Just oldPos -> do
+            let (line, column) = unPos oldPos
+            splitResult' <- GM.splits' path (tcMod checkedModule) line column
+            case splitResult' of
+              Just splitResult -> return
+                $ oldToNewPositions checkedModule
+                $ splitResultToWorkspaceEdit origText splitResult
+              Nothing -> return mempty
+          Nothing -> return mempty
+      ModuleFailed errText -> return $ IdeResultFail $ IdeError PluginError (T.append "hie-ghc-mod: " errText) Null
+      ModuleLoading -> return $ IdeResultOk mempty
+  where
+
+    -- | Transform all ranges in a WorkspaceEdit from old to new positions.
+    oldToNewPositions :: CachedModule -> WorkspaceEdit -> WorkspaceEdit
+    oldToNewPositions cMod wsEdit =
+      wsEdit
+        & LSP.documentChanges %~ (>>= traverseOf (traverse . LSP.edits . traverse . LSP.range) (oldRangeToNew cMod))
+        & LSP.changes %~ (>>= traverseOf (traverse . traverse . LSP.range) (oldRangeToNew cMod))
+
+    -- | Given the range and text to replace, construct a 'WorkspaceEdit'
+    -- by diffing the change against the current text.
+    splitResultToWorkspaceEdit :: T.Text -> GM.SplitResult -> WorkspaceEdit
+    splitResultToWorkspaceEdit originalText (GM.SplitResult replaceFromLine replaceFromCol replaceToLine replaceToCol replaceWith) =
+      diffText (uri, originalText) newText
+      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

test/GhcModPluginSpec.hs

@@ -3,6 +3,7 @@
 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
@@ -13,6 +14,7 @@ import           Haskell.Ide.Engine.MonadTypes
 import           Haskell.Ide.Engine.PluginDescriptor
 import           Haskell.Ide.Engine.PluginUtils
 import           Haskell.Ide.Engine.Plugin.GhcMod
+import           Language.Haskell.LSP.Types (TextEdit(..), TextDocumentPositionParams(..), TextDocumentIdentifier(..))
 import           System.Directory
 import           TestUtils
 
@@ -35,9 +37,8 @@ testPlugins = pluginDescToIdePlugins [("ghcmod",ghcmodDescriptor)]
 -- ---------------------------------------------------------------------
 
 ghcmodSpec :: Spec
-ghcmodSpec = do
-  describe "ghc-mod plugin commands" $ do
-
+ghcmodSpec =
+  describe "ghc-mod plugin commands(old plugin api)" $ do
     it "runs the check command" $ cdAndDo "./test/testdata" $ do
       fp <- makeAbsolute "./FileWithWarning.hs"
       let act = setTypecheckedModule arg
@@ -115,3 +116,36 @@ ghcmodSpec = do
         testCommand testPlugins act "ghcmod" "type" 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 = TextDocumentPositionParams (TextDocumentIdentifier 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" 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 = TextDocumentPositionParams (TextDocumentIdentifier 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" arg res

test/testdata/GhcModCaseSplit.hs

@@ -0,0 +1,5 @@
+
+main = putStrLn "hello"
+
+foo :: Maybe Int -> ()
+foo x = ()