From 0fb47284d996a640a924def696a7aad4037e55cd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Avi=20=D7=93?= Date: Tue, 30 Oct 2018 01:01:50 -0400 Subject: [PATCH 1/4] Make casesplit a HaRe action --- src/Haskell/Ide/Engine/Plugin/GhcMod.hs | 65 ----------------- src/Haskell/Ide/Engine/Plugin/HaRe.hs | 93 ++++++++++++++++++++++--- test/unit/GhcModPluginSpec.hs | 38 ---------- test/unit/HaRePluginSpec.hs | 36 ++++++++++ 4 files changed, 121 insertions(+), 111 deletions(-) diff --git a/src/Haskell/Ide/Engine/Plugin/GhcMod.hs b/src/Haskell/Ide/Engine/Plugin/GhcMod.hs index f413150b7..717460c73 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,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 = diff --git a/src/Haskell/Ide/Engine/Plugin/HaRe.hs b/src/Haskell/Ide/Engine/Plugin/HaRe.hs index df4fa0408..8932341f2 100644 --- a/src/Haskell/Ide/Engine/Plugin/HaRe.hs +++ b/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) diff --git a/test/unit/GhcModPluginSpec.hs b/test/unit/GhcModPluginSpec.hs index 25c0dba95..3468af672 100644 --- a/test/unit/GhcModPluginSpec.hs +++ b/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 diff --git a/test/unit/HaRePluginSpec.hs b/test/unit/HaRePluginSpec.hs index 8b6322f73..f46c6ce06 100644 --- a/test/unit/HaRePluginSpec.hs +++ b/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 From 9f6fc95dabd210a60d04c31ba5d1e4b54c7d81d1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Avi=20=D7=93?= Date: Tue, 30 Oct 2018 14:13:45 -0400 Subject: [PATCH 2/4] Add casesplit CodeAction test --- test/functional/HaReSpec.hs | 7 +++++++ 1 file changed, 7 insertions(+) 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 From 7f9030ce32ef0c4516de4ebfc6bbddfcca26ab09 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Avi=20=D7=93?= Date: Wed, 31 Oct 2018 11:59:42 -0400 Subject: [PATCH 3/4] Reexpose splitCaseCmd under GhcMod plugin --- src/Haskell/Ide/Engine/Plugin/GhcMod.hs | 15 +-- src/Haskell/Ide/Engine/Plugin/HaRe.hs | 115 ++++----------------- src/Haskell/Ide/Engine/Plugin/HieExtras.hs | 102 +++++++++++++++++- 3 files changed, 123 insertions(+), 109 deletions(-) diff --git a/src/Haskell/Ide/Engine/Plugin/GhcMod.hs b/src/Haskell/Ide/Engine/Plugin/GhcMod.hs index 717460c73..8cda4c06d 100644 --- a/src/Haskell/Ide/Engine/Plugin/GhcMod.hs +++ b/src/Haskell/Ide/Engine/Plugin/GhcMod.hs @@ -20,7 +20,6 @@ import Data.Monoid ((<>)) import qualified Data.Set as Set import qualified Data.Text as T import ErrUtils -import qualified Exception as G import Name import GHC.Generics import qualified GhcMod as GM @@ -63,6 +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)" Hie.splitCaseCmd ] , pluginCodeActionProvider = Just codeActionProvider , pluginDiagnosticProvider = Nothing @@ -225,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) -- --------------------------------------------------------------------- @@ -249,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 = @@ -301,15 +301,6 @@ cmp a b isSubRangeOf :: Range -> Range -> Bool isSubRangeOf (Range sa ea) (Range sb eb) = sb <= sa && eb >= ea -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 8932341f2..595529ed0 100644 --- a/src/Haskell/Ide/Engine/Plugin/HaRe.hs +++ b/src/Haskell/Ide/Engine/Plugin/HaRe.hs @@ -7,8 +7,6 @@ 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 @@ -24,14 +22,12 @@ 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 @@ -70,7 +66,7 @@ hareDescriptor plId = PluginDescriptor genApplicativeCommand , PluginCommand "casesplit" "Generate a pattern match for a binding under (LINE,COL)" - splitCaseCmd + Hie.splitCaseCmd ] , pluginCodeActionProvider = Just codeActionProvider , pluginDiagnosticProvider = Nothing @@ -80,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 @@ -100,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 @@ -111,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) @@ -156,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) @@ -169,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) @@ -195,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) @@ -208,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) @@ -220,64 +203,6 @@ 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 @@ -382,25 +307,25 @@ codeActionProvider pId docId _ _ (J.Range pos _) _ = 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) @@ -412,7 +337,7 @@ codeActionProvider pId docId _ _ (J.Range pos _) _ = return $ J.CodeAction title (Just J.CodeActionRefactor) mempty Nothing (Just dupCmd) mkCaseSplitAction name = do - let args = [J.toJSON $ HP (docId ^. J.uri) pos] + 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) From d8dd18d16056941b2daa67fb4ba1af934da6cfea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Avi=20=D7=93?= Date: Wed, 31 Oct 2018 13:17:33 -0400 Subject: [PATCH 4/4] Move splitCaseCmd tests back to GhcMod --- test/unit/GhcModPluginSpec.hs | 40 ++++++++++++++++++++++++++++++++++- test/unit/HaRePluginSpec.hs | 36 ------------------------------- test/unit/JsonSpec.hs | 1 + 3 files changed, 40 insertions(+), 37 deletions(-) diff --git a/test/unit/GhcModPluginSpec.hs b/test/unit/GhcModPluginSpec.hs index 3468af672..2bc15d38d 100644 --- a/test/unit/GhcModPluginSpec.hs +++ b/test/unit/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 @@ -10,9 +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 Language.Haskell.LSP.Types (TextEdit (..)) import System.Directory import TestUtils @@ -112,3 +115,38 @@ 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 diff --git a/test/unit/HaRePluginSpec.hs b/test/unit/HaRePluginSpec.hs index f46c6ce06..8b6322f73 100644 --- a/test/unit/HaRePluginSpec.hs +++ b/test/unit/HaRePluginSpec.hs @@ -5,7 +5,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module HaRePluginSpec where -import Control.Exception import Control.Monad.Trans.Free import Control.Monad.IO.Class import Data.Aeson @@ -174,41 +173,6 @@ 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 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