Skip to content

Commit 7f9030c

Browse files
Avi-D-coderAvi-D-coder
committed
Reexpose splitCaseCmd under GhcMod plugin
1 parent 9f6fc95 commit 7f9030c

File tree

3 files changed

+123
-109
lines changed

3 files changed

+123
-109
lines changed

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

Lines changed: 3 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,6 @@ import Data.Monoid ((<>))
2020
import qualified Data.Set as Set
2121
import qualified Data.Text as T
2222
import ErrUtils
23-
import qualified Exception as G
2423
import Name
2524
import GHC.Generics
2625
import qualified GhcMod as GM
@@ -63,6 +62,7 @@ ghcmodDescriptor plId = PluginDescriptor
6362
, PluginCommand "lint" "Check files using `hlint'" lintCmd
6463
, PluginCommand "info" "Look up an identifier in the context of FILE (like ghci's `:info')" infoCmd
6564
, PluginCommand "type" "Get the type of the expression under (LINE,COL)" typeCmd
65+
, PluginCommand "casesplit" "Generate a pattern match for a binding under (LINE,COL)" Hie.splitCaseCmd
6666
]
6767
, pluginCodeActionProvider = Just codeActionProvider
6868
, pluginDiagnosticProvider = Nothing
@@ -225,7 +225,7 @@ lintCmd = CmdSync $ \_ uri ->
225225
lintCmd' :: Uri -> IdeGhcM (IdeResult T.Text)
226226
lintCmd' uri =
227227
pluginGetFile "lint: " uri $ \file ->
228-
fmap T.pack <$> runGhcModCommand (GM.lint GM.defaultLintOpts file)
228+
fmap T.pack <$> Hie.runGhcModCommand (GM.lint GM.defaultLintOpts file)
229229

230230
-- ---------------------------------------------------------------------
231231

@@ -249,7 +249,7 @@ infoCmd = CmdSync $ \_ (IP uri expr) ->
249249
infoCmd' :: Uri -> T.Text -> IdeGhcM (IdeResult T.Text)
250250
infoCmd' uri expr =
251251
pluginGetFile "info: " uri $ \file ->
252-
fmap T.pack <$> runGhcModCommand (GM.info file (GM.Expression (T.unpack expr)))
252+
fmap T.pack <$> Hie.runGhcModCommand (GM.info file (GM.Expression (T.unpack expr)))
253253

254254
-- ---------------------------------------------------------------------
255255
data TypeParams =
@@ -301,15 +301,6 @@ cmp a b
301301
isSubRangeOf :: Range -> Range -> Bool
302302
isSubRangeOf (Range sa ea) (Range sb eb) = sb <= sa && eb >= ea
303303

304-
runGhcModCommand :: IdeGhcM a
305-
-> IdeGhcM (IdeResult a)
306-
runGhcModCommand cmd =
307-
(IdeResultOk <$> cmd) `G.gcatch`
308-
\(e :: GM.GhcModError) ->
309-
return $
310-
IdeResultFail $
311-
IdeError PluginError (T.pack $ "hie-ghc-mod: " ++ show e) Null
312-
313304
-- ---------------------------------------------------------------------
314305

315306
newtype TypeDef = TypeDef T.Text deriving (Eq, Show)

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

Lines changed: 20 additions & 95 deletions
Original file line numberDiff line numberDiff line change
@@ -7,8 +7,6 @@
77
module Haskell.Ide.Engine.Plugin.HaRe where
88

99
import Control.Lens.Operators
10-
import Control.Lens.Setter ((%~))
11-
import Control.Lens.Traversal (traverseOf)
1210
import Control.Monad.State
1311
import Control.Monad.Trans.Control
1412
import Data.Aeson
@@ -24,14 +22,12 @@ import qualified Data.Text.IO as T
2422
import Exception
2523
import GHC.Generics (Generic)
2624
import qualified GhcMod.Error as GM
27-
import qualified GhcMod.Exe.CaseSplit as GM
2825
import qualified GhcMod.Monad as GM
2926
import qualified GhcMod.Utils as GM
3027
import Haskell.Ide.Engine.ArtifactMap
3128
import Haskell.Ide.Engine.MonadFunctions
3229
import Haskell.Ide.Engine.MonadTypes
3330
import Haskell.Ide.Engine.PluginUtils
34-
import Haskell.Ide.Engine.Plugin.GhcMod (runGhcModCommand)
3531
import qualified Haskell.Ide.Engine.Plugin.HieExtras as Hie
3632
import Language.Haskell.GHC.ExactPrint.Print
3733
import qualified Language.Haskell.LSP.Core as Core
@@ -70,7 +66,7 @@ hareDescriptor plId = PluginDescriptor
7066
genApplicativeCommand
7167

7268
, PluginCommand "casesplit" "Generate a pattern match for a binding under (LINE,COL)"
73-
splitCaseCmd
69+
Hie.splitCaseCmd
7470
]
7571
, pluginCodeActionProvider = Just codeActionProvider
7672
, pluginDiagnosticProvider = Nothing
@@ -80,29 +76,16 @@ hareDescriptor plId = PluginDescriptor
8076

8177
-- ---------------------------------------------------------------------
8278

83-
customOptions :: Int -> J.Options
84-
customOptions n = J.defaultOptions { J.fieldLabelModifier = J.camelTo2 '_' . drop n}
85-
86-
data HarePoint =
87-
HP { hpFile :: Uri
88-
, hpPos :: Position
89-
} deriving (Eq,Generic,Show)
90-
91-
instance FromJSON HarePoint where
92-
parseJSON = genericParseJSON $ customOptions 2
93-
instance ToJSON HarePoint where
94-
toJSON = genericToJSON $ customOptions 2
95-
9679
data HarePointWithText =
9780
HPT { hptFile :: Uri
9881
, hptPos :: Position
9982
, hptText :: T.Text
10083
} deriving (Eq,Generic,Show)
10184

10285
instance FromJSON HarePointWithText where
103-
parseJSON = genericParseJSON $ customOptions 3
86+
parseJSON = genericParseJSON $ Hie.customOptions 3
10487
instance ToJSON HarePointWithText where
105-
toJSON = genericToJSON $ customOptions 3
88+
toJSON = genericToJSON $ Hie.customOptions 3
10689

10790
data HareRange =
10891
HR { hrFile :: Uri
@@ -111,14 +94,14 @@ data HareRange =
11194
} deriving (Eq,Generic,Show)
11295

11396
instance FromJSON HareRange where
114-
parseJSON = genericParseJSON $ customOptions 2
97+
parseJSON = genericParseJSON $ Hie.customOptions 2
11598
instance ToJSON HareRange where
116-
toJSON = genericToJSON $ customOptions 2
99+
toJSON = genericToJSON $ Hie.customOptions 2
117100

118101
-- ---------------------------------------------------------------------
119102

120-
demoteCmd :: CommandFunc HarePoint WorkspaceEdit
121-
demoteCmd = CmdSync $ \_ (HP uri pos) ->
103+
demoteCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
104+
demoteCmd = CmdSync $ \_ (Hie.HP uri pos) ->
122105
demoteCmd' uri pos
123106

124107
demoteCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
@@ -156,8 +139,8 @@ iftocaseCmd' uri (Range startPos endPos) =
156139

157140
-- ---------------------------------------------------------------------
158141

159-
liftonelevelCmd :: CommandFunc HarePoint WorkspaceEdit
160-
liftonelevelCmd = CmdSync $ \_ (HP uri pos) ->
142+
liftonelevelCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
143+
liftonelevelCmd = CmdSync $ \_ (Hie.HP uri pos) ->
161144
liftonelevelCmd' uri pos
162145

163146
liftonelevelCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
@@ -169,8 +152,8 @@ liftonelevelCmd' uri pos =
169152

170153
-- ---------------------------------------------------------------------
171154

172-
lifttotoplevelCmd :: CommandFunc HarePoint WorkspaceEdit
173-
lifttotoplevelCmd = CmdSync $ \_ (HP uri pos) ->
155+
lifttotoplevelCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
156+
lifttotoplevelCmd = CmdSync $ \_ (Hie.HP uri pos) ->
174157
lifttotoplevelCmd' uri pos
175158

176159
lifttotoplevelCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
@@ -195,8 +178,8 @@ renameCmd' uri pos name =
195178

196179
-- ---------------------------------------------------------------------
197180

198-
deleteDefCmd :: CommandFunc HarePoint WorkspaceEdit
199-
deleteDefCmd = CmdSync $ \_ (HP uri pos) ->
181+
deleteDefCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
182+
deleteDefCmd = CmdSync $ \_ (Hie.HP uri pos) ->
200183
deleteDefCmd' uri pos
201184

202185
deleteDefCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
@@ -208,8 +191,8 @@ deleteDefCmd' uri pos =
208191

209192
-- ---------------------------------------------------------------------
210193

211-
genApplicativeCommand :: CommandFunc HarePoint WorkspaceEdit
212-
genApplicativeCommand = CmdSync $ \_ (HP uri pos) ->
194+
genApplicativeCommand :: CommandFunc Hie.HarePoint WorkspaceEdit
195+
genApplicativeCommand = CmdSync $ \_ (Hie.HP uri pos) ->
213196
genApplicativeCommand' uri pos
214197

215198
genApplicativeCommand' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
@@ -220,64 +203,6 @@ genApplicativeCommand' uri pos =
220203

221204
-- ---------------------------------------------------------------------
222205

223-
splitCaseCmd :: CommandFunc HarePoint WorkspaceEdit
224-
splitCaseCmd = CmdSync $ \_ (HP uri pos) -> splitCaseCmd' uri pos
225-
226-
splitCaseCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
227-
splitCaseCmd' uri newPos =
228-
pluginGetFile "splitCaseCmd: " uri $ \path -> do
229-
origText <- GM.withMappedFile path $ liftIO . T.readFile
230-
ifCachedModule path (IdeResultOk mempty) $ \tm info -> runGhcModCommand $
231-
case newPosToOld info newPos of
232-
Just oldPos -> do
233-
let (line, column) = unPos oldPos
234-
splitResult' <- GM.splits' path tm line column
235-
case splitResult' of
236-
Just splitResult -> do
237-
wEdit <- liftToGhc $ splitResultToWorkspaceEdit origText splitResult
238-
return $ oldToNewPositions info wEdit
239-
Nothing -> return mempty
240-
Nothing -> return mempty
241-
where
242-
243-
-- | Transform all ranges in a WorkspaceEdit from old to new positions.
244-
oldToNewPositions :: CachedInfo -> WorkspaceEdit -> WorkspaceEdit
245-
oldToNewPositions info wsEdit =
246-
wsEdit
247-
& J.documentChanges %~ (>>= traverseOf (traverse . J.edits . traverse . J.range) (oldRangeToNew info))
248-
& J.changes %~ (>>= traverseOf (traverse . traverse . J.range) (oldRangeToNew info))
249-
250-
-- | Given the range and text to replace, construct a 'WorkspaceEdit'
251-
-- by diffing the change against the current text.
252-
splitResultToWorkspaceEdit :: T.Text -> GM.SplitResult -> IdeM WorkspaceEdit
253-
splitResultToWorkspaceEdit originalText (GM.SplitResult replaceFromLine replaceFromCol replaceToLine replaceToCol replaceWith) =
254-
diffText (uri, originalText) newText IncludeDeletions
255-
where
256-
before = takeUntil (toPos (replaceFromLine, replaceFromCol)) originalText
257-
after = dropUntil (toPos (replaceToLine, replaceToCol)) originalText
258-
newText = before <> replaceWith <> after
259-
260-
-- | Take the first part of text until the given position.
261-
-- Returns all characters before the position.
262-
takeUntil :: Position -> T.Text -> T.Text
263-
takeUntil (Position l c) txt =
264-
T.unlines takeLines <> takeCharacters
265-
where
266-
textLines = T.lines txt
267-
takeLines = take l textLines
268-
takeCharacters = T.take c (textLines !! c)
269-
270-
-- | Drop the first part of text until the given position.
271-
-- Returns all characters after and including the position.
272-
dropUntil :: Position -> T.Text -> T.Text
273-
dropUntil (Position l c) txt = dropCharacters
274-
where
275-
textLines = T.lines txt
276-
dropLines = drop l textLines
277-
dropCharacters = T.drop c (T.unlines dropLines)
278-
279-
-- ---------------------------------------------------------------------
280-
281206
getRefactorResult :: [ApplyRefacResult] -> [(FilePath,T.Text)]
282207
getRefactorResult = map getNewFile . filter fileModified
283208
where fileModified ((_,m),_) = m == RefacModified
@@ -382,25 +307,25 @@ codeActionProvider pId docId _ _ (J.Range pos _) _ =
382307

383308
where
384309
mkLiftOneAction name = do
385-
let args = [J.toJSON $ HP (docId ^. J.uri) pos]
310+
let args = [J.toJSON $ Hie.HP (docId ^. J.uri) pos]
386311
title = "Lift " <> name <> " one level"
387312
liftCmd <- mkLspCommand pId "liftonelevel" title (Just args)
388313
return $ J.CodeAction title (Just J.CodeActionRefactorExtract) mempty Nothing (Just liftCmd)
389314

390315
mkLiftTopAction name = do
391-
let args = [J.toJSON $ HP (docId ^. J.uri) pos]
316+
let args = [J.toJSON $ Hie.HP (docId ^. J.uri) pos]
392317
title = "Lift " <> name <> " to top level"
393318
liftCmd <- mkLspCommand pId "lifttotoplevel" title (Just args)
394319
return $ J.CodeAction title (Just J.CodeActionRefactorExtract) mempty Nothing (Just liftCmd)
395320

396321
mkDemoteAction name = do
397-
let args = [J.toJSON $ HP (docId ^. J.uri) pos]
322+
let args = [J.toJSON $ Hie.HP (docId ^. J.uri) pos]
398323
title = "Demote " <> name <> " one level"
399324
demCmd <- mkLspCommand pId "demote" title (Just args)
400325
return $ J.CodeAction title (Just J.CodeActionRefactorInline) mempty Nothing (Just demCmd)
401326

402327
mkDeleteAction name = do
403-
let args = [J.toJSON $ HP (docId ^. J.uri) pos]
328+
let args = [J.toJSON $ Hie.HP (docId ^. J.uri) pos]
404329
title = "Delete definition of " <> name
405330
delCmd <- mkLspCommand pId "deletedef" title (Just args)
406331
return $ J.CodeAction title (Just J.CodeActionRefactor) mempty Nothing (Just delCmd)
@@ -412,7 +337,7 @@ codeActionProvider pId docId _ _ (J.Range pos _) _ =
412337
return $ J.CodeAction title (Just J.CodeActionRefactor) mempty Nothing (Just dupCmd)
413338

414339
mkCaseSplitAction name = do
415-
let args = [J.toJSON $ HP (docId ^. J.uri) pos]
340+
let args = [J.toJSON $ Hie.HP (docId ^. J.uri) pos]
416341
title = "Case split on " <> name
417342
splCmd <- mkLspCommand pId "casesplit" title (Just args)
418343
return $ J.CodeAction title (Just J.CodeActionRefactorRewrite) mempty Nothing (Just splCmd)

0 commit comments

Comments
 (0)