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,9 +19,7 @@ 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
 import           GHC.Generics
 import qualified GhcMod                            as GM
@@ -35,11 +31,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 +62,7 @@ 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
+      , PluginCommand "casesplit" "Generate a pattern match for a binding under (LINE,COL)" Hie.splitCaseCmd
       ]
   , pluginCodeActionProvider = Just codeActionProvider
   , pluginDiagnosticProvider = Nothing
@@ -231,7 +225,7 @@ lintCmd = CmdSync $ \_ uri ->
 lintCmd' :: Uri -> IdeGhcM (IdeResult T.Text)
 lintCmd' uri =
   pluginGetFile "lint: " uri $ \file ->
-    fmap T.pack <$> runGhcModCommand (GM.lint GM.defaultLintOpts file)
+    fmap T.pack <$> Hie.runGhcModCommand (GM.lint GM.defaultLintOpts file)
 
 -- ---------------------------------------------------------------------
 
@@ -255,7 +249,7 @@ infoCmd = CmdSync $ \_ (IP uri expr) ->
 infoCmd' :: Uri -> T.Text -> IdeGhcM (IdeResult T.Text)
 infoCmd' uri expr =
   pluginGetFile "info: " uri $ \file ->
-    fmap T.pack <$> runGhcModCommand (GM.info file (GM.Expression (T.unpack expr)))
+    fmap T.pack <$> Hie.runGhcModCommand (GM.info file (GM.Expression (T.unpack expr)))
 
 -- ---------------------------------------------------------------------
 data TypeParams =
@@ -307,74 +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 =
-  (IdeResultOk <$> cmd) `G.gcatch`
-    \(e :: GM.GhcModError) ->
-      return $
-      IdeResultFail $
-      IdeError PluginError (T.pack $ "hie-ghc-mod: " ++ show e) Null
-
 -- ---------------------------------------------------------------------
 
 newtype TypeDef = TypeDef T.Text deriving (Eq, Show)

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

@@ -64,6 +64,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)"
+          Hie.splitCaseCmd
       ]
   , pluginCodeActionProvider = Just codeActionProvider
   , pluginDiagnosticProvider = Nothing
@@ -73,29 +76,16 @@ hareDescriptor plId = PluginDescriptor
 
 -- ---------------------------------------------------------------------
 
-customOptions :: Int -> J.Options
-customOptions n = J.defaultOptions { J.fieldLabelModifier = J.camelTo2 '_' . drop n}
-
-data HarePoint =
-  HP { hpFile :: Uri
-     , hpPos  :: Position
-     } deriving (Eq,Generic,Show)
-
-instance FromJSON HarePoint where
-  parseJSON = genericParseJSON $ customOptions 2
-instance ToJSON HarePoint where
-  toJSON = genericToJSON $ customOptions 2
-
 data HarePointWithText =
   HPT { hptFile :: Uri
       , hptPos  :: Position
       , hptText :: T.Text
       } deriving (Eq,Generic,Show)
 
 instance FromJSON HarePointWithText where
-  parseJSON = genericParseJSON $ customOptions 3
+  parseJSON = genericParseJSON $ Hie.customOptions 3
 instance ToJSON HarePointWithText where
-  toJSON = genericToJSON $ customOptions 3
+  toJSON = genericToJSON $ Hie.customOptions 3
 
 data HareRange =
   HR { hrFile     :: Uri
@@ -104,14 +94,14 @@ data HareRange =
      } deriving (Eq,Generic,Show)
 
 instance FromJSON HareRange where
-  parseJSON = genericParseJSON $ customOptions 2
+  parseJSON = genericParseJSON $ Hie.customOptions 2
 instance ToJSON HareRange where
-  toJSON = genericToJSON $ customOptions 2
+  toJSON = genericToJSON $ Hie.customOptions 2
 
 -- ---------------------------------------------------------------------
 
-demoteCmd :: CommandFunc HarePoint WorkspaceEdit
-demoteCmd  = CmdSync $ \_ (HP uri pos) ->
+demoteCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
+demoteCmd  = CmdSync $ \_ (Hie.HP uri pos) ->
   demoteCmd' uri pos
 
 demoteCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
@@ -149,8 +139,8 @@ iftocaseCmd' uri (Range startPos endPos) =
 
 -- ---------------------------------------------------------------------
 
-liftonelevelCmd :: CommandFunc HarePoint WorkspaceEdit
-liftonelevelCmd = CmdSync $ \_ (HP uri pos) ->
+liftonelevelCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
+liftonelevelCmd = CmdSync $ \_ (Hie.HP uri pos) ->
   liftonelevelCmd' uri pos
 
 liftonelevelCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
@@ -162,8 +152,8 @@ liftonelevelCmd' uri pos =
 
 -- ---------------------------------------------------------------------
 
-lifttotoplevelCmd :: CommandFunc HarePoint WorkspaceEdit
-lifttotoplevelCmd = CmdSync $ \_ (HP uri pos) ->
+lifttotoplevelCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
+lifttotoplevelCmd = CmdSync $ \_ (Hie.HP uri pos) ->
   lifttotoplevelCmd' uri pos
 
 lifttotoplevelCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
@@ -188,8 +178,8 @@ renameCmd' uri pos name =
 
 -- ---------------------------------------------------------------------
 
-deleteDefCmd :: CommandFunc HarePoint WorkspaceEdit
-deleteDefCmd  = CmdSync $ \_ (HP uri pos) ->
+deleteDefCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
+deleteDefCmd  = CmdSync $ \_ (Hie.HP uri pos) ->
   deleteDefCmd' uri pos
 
 deleteDefCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
@@ -201,8 +191,8 @@ deleteDefCmd' uri pos =
 
 -- ---------------------------------------------------------------------
 
-genApplicativeCommand :: CommandFunc HarePoint WorkspaceEdit
-genApplicativeCommand  = CmdSync $ \_ (HP uri pos) ->
+genApplicativeCommand :: CommandFunc Hie.HarePoint WorkspaceEdit
+genApplicativeCommand  = CmdSync $ \_ (Hie.HP uri pos) ->
   genApplicativeCommand' uri pos
 
 genApplicativeCommand' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
@@ -294,42 +284,48 @@ 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
-      let args = [J.toJSON $ HP (docId ^. J.uri) pos]
+      let args = [J.toJSON $ Hie.HP (docId ^. J.uri) pos]
           title = "Lift " <> name <> " one level"
       liftCmd <- mkLspCommand pId "liftonelevel" title (Just args)
       return $ J.CodeAction title (Just J.CodeActionRefactorExtract) mempty Nothing (Just liftCmd)
 
     mkLiftTopAction name = do
-      let args = [J.toJSON $ HP (docId ^. J.uri) pos]
+      let args = [J.toJSON $ Hie.HP (docId ^. J.uri) pos]
           title = "Lift " <> name <> " to top level"
       liftCmd <- mkLspCommand pId "lifttotoplevel" title (Just args)
       return $ J.CodeAction title (Just J.CodeActionRefactorExtract) mempty Nothing (Just liftCmd)
 
     mkDemoteAction name = do
-      let args = [J.toJSON $ HP (docId ^. J.uri) pos]
+      let args = [J.toJSON $ Hie.HP (docId ^. J.uri) pos]
           title = "Demote " <> name <> " one level"
       demCmd <- mkLspCommand pId "demote" title (Just args)
       return $ J.CodeAction title (Just J.CodeActionRefactorInline) mempty Nothing (Just demCmd)
 
     mkDeleteAction name = do
-      let args = [J.toJSON $ HP (docId ^. J.uri) pos]
+      let args = [J.toJSON $ Hie.HP (docId ^. J.uri) pos]
           title = "Delete definition of " <> name
       delCmd <- mkLspCommand pId "deletedef" title (Just args)
       return $ J.CodeAction title (Just J.CodeActionRefactor) mempty Nothing (Just delCmd)
@@ -339,3 +335,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 $ Hie.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)