diff --git a/src/Haskell/Ide/Engine/Plugin/GhcMod.hs b/src/Haskell/Ide/Engine/Plugin/GhcMod.hs index f413150b7..8cda4c06d 100644 --- a/src/Haskell/Ide/Engine/Plugin/GhcMod.hs +++ b/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) diff --git a/src/Haskell/Ide/Engine/Plugin/HaRe.hs b/src/Haskell/Ide/Engine/Plugin/HaRe.hs index df4fa0408..595529ed0 100644 --- a/src/Haskell/Ide/Engine/Plugin/HaRe.hs +++ b/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,19 +76,6 @@ 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 @@ -93,9 +83,9 @@ data HarePointWithText = } 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) diff --git a/src/Haskell/Ide/Engine/Plugin/HieExtras.hs b/src/Haskell/Ide/Engine/Plugin/HieExtras.hs index 61cc386a1..2dc06f047 100644 --- a/src/Haskell/Ide/Engine/Plugin/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Plugin/HieExtras.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -17,13 +18,21 @@ module Haskell.Ide.Engine.Plugin.HieExtras , PosPrefixInfo(..) , getRangeFromVFS , rangeLinesFromVfs + , HarePoint(..) + , customOptions + , runGhcModCommand + , splitCaseCmd' + , splitCaseCmd ) where import ConLike -import Control.Lens.Operators ( (^?), (?~) ) +import Control.Lens.Operators ( (^?), (?~), (&) ) import Control.Lens.Prism ( _Just ) +import Control.Lens.Setter ((%~)) +import Control.Lens.Traversal (traverseOf) import Control.Monad.Reader import Data.Aeson +import qualified Data.Aeson.Types as J import Data.Char import Data.IORef import qualified Data.List as List @@ -31,14 +40,19 @@ import qualified Data.Map as Map import Data.Maybe import Data.Monoid ( (<>) ) import qualified Data.Text as T +import qualified Data.Text.IO as T import Data.Typeable import DataCon import Exception import FastString import Finder import GHC hiding (getContext) -import qualified GhcMod.LightGhc as GM +import GHC.Generics (Generic) +import qualified GhcMod.Error as GM +import qualified GhcMod.Exe.CaseSplit as GM import qualified GhcMod.Gap as GM +import qualified GhcMod.LightGhc as GM +import qualified GhcMod.Utils as GM import Haskell.Ide.Engine.ArtifactMap import Haskell.Ide.Engine.Context import Haskell.Ide.Engine.MonadFunctions @@ -596,3 +610,87 @@ rangeLinesFromVfs (VFS.VirtualFile _ yitext) (Range (Position lf _cf) (Position (_ ,s1) = Yi.splitAtLine lf yitext (s2, _) = Yi.splitAtLine (lt - lf) s1 r = Yi.toText s2 + +-- --------------------------------------------------------------------- + +data HarePoint = + HP { hpFile :: Uri + , hpPos :: Position + } deriving (Eq,Generic,Show) + +customOptions :: Int -> J.Options +customOptions n = J.defaultOptions { J.fieldLabelModifier = J.camelTo2 '_' . drop n} + +instance FromJSON HarePoint where + parseJSON = genericParseJSON $ customOptions 2 +instance ToJSON HarePoint where + toJSON = genericToJSON $ customOptions 2 + +-- --------------------------------------------------------------------- + +runGhcModCommand :: IdeGhcM a + -> IdeGhcM (IdeResult a) +runGhcModCommand cmd = + (IdeResultOk <$> cmd) `gcatch` + \(e :: GM.GhcModError) -> + return $ + IdeResultFail $ + IdeError PluginError (T.pack $ "hie-ghc-mod: " ++ show e) Null + +-- --------------------------------------------------------------------- + +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) diff --git a/test/functional/HaReSpec.hs b/test/functional/HaReSpec.hs index 4674958d3..35803e4ea 100644 --- a/test/functional/HaReSpec.hs +++ b/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 diff --git a/test/unit/GhcModPluginSpec.hs b/test/unit/GhcModPluginSpec.hs index 25c0dba95..2bc15d38d 100644 --- a/test/unit/GhcModPluginSpec.hs +++ b/test/unit/GhcModPluginSpec.hs @@ -11,11 +11,11 @@ import Data.Monoid import qualified Data.Set as S import qualified Data.Text as T import Haskell.Ide.Engine.MonadTypes +import Haskell.Ide.Engine.Plugin.GhcMod +import Haskell.Ide.Engine.Plugin.HieExtras 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 Language.Haskell.LSP.Types (TextEdit (..)) import System.Directory import TestUtils diff --git a/test/unit/JsonSpec.hs b/test/unit/JsonSpec.hs index b187f2eae..5b2bc3efc 100644 --- a/test/unit/JsonSpec.hs +++ b/test/unit/JsonSpec.hs @@ -10,6 +10,7 @@ import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.Plugin.ApplyRefact import Haskell.Ide.Engine.Plugin.GhcMod import Haskell.Ide.Engine.Plugin.HaRe +import Haskell.Ide.Engine.Plugin.HieExtras import Haskell.Ide.Engine.LSP.Config import Data.Aeson