Skip to content
This repository was archived by the owner on Oct 7, 2020. It is now read-only.

Commit ade8804

Browse files
alanzalanz
authored
Merge pull request #917 from Avi-D-coder/master
Make casesplit a HaRe action
2 parents adc9958 + d8dd18d commit ade8804

File tree

6 files changed

+155
-121
lines changed

6 files changed

+155
-121
lines changed

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

Lines changed: 3 additions & 77 deletions
Original file line numberDiff line numberDiff line change
@@ -9,8 +9,6 @@ module Haskell.Ide.Engine.Plugin.GhcMod where
99
import Bag
1010
import Control.Monad.IO.Class
1111
import Control.Lens hiding (cons, children)
12-
import Control.Lens.Setter ((%~))
13-
import Control.Lens.Traversal (traverseOf)
1412
import Data.Aeson
1513
import Data.Function
1614
import qualified Data.HashMap.Strict as HM
@@ -21,9 +19,7 @@ import Data.Maybe
2119
import Data.Monoid ((<>))
2220
import qualified Data.Set as Set
2321
import qualified Data.Text as T
24-
import qualified Data.Text.IO as T
2522
import ErrUtils
26-
import qualified Exception as G
2723
import Name
2824
import GHC.Generics
2925
import qualified GhcMod as GM
@@ -35,11 +31,9 @@ import qualified GhcMod.Monad as GM
3531
import qualified GhcMod.SrcUtils as GM
3632
import qualified GhcMod.Types as GM
3733
import qualified GhcMod.Utils as GM
38-
import qualified GhcMod.Exe.CaseSplit as GM
3934
import Haskell.Ide.Engine.MonadFunctions
4035
import Haskell.Ide.Engine.MonadTypes
4136
import Haskell.Ide.Engine.PluginUtils
42-
import Haskell.Ide.Engine.Plugin.HaRe (HarePoint(..))
4337
import qualified Haskell.Ide.Engine.Plugin.HieExtras as Hie
4438
import Haskell.Ide.Engine.ArtifactMap
4539
import qualified Language.Haskell.LSP.Types as LSP
@@ -68,7 +62,7 @@ ghcmodDescriptor plId = PluginDescriptor
6862
, PluginCommand "lint" "Check files using `hlint'" lintCmd
6963
, PluginCommand "info" "Look up an identifier in the context of FILE (like ghci's `:info')" infoCmd
7064
, PluginCommand "type" "Get the type of the expression under (LINE,COL)" typeCmd
71-
, PluginCommand "casesplit" "Generate a pattern match for a binding under (LINE,COL)" splitCaseCmd
65+
, PluginCommand "casesplit" "Generate a pattern match for a binding under (LINE,COL)" Hie.splitCaseCmd
7266
]
7367
, pluginCodeActionProvider = Just codeActionProvider
7468
, pluginDiagnosticProvider = Nothing
@@ -231,7 +225,7 @@ lintCmd = CmdSync $ \_ uri ->
231225
lintCmd' :: Uri -> IdeGhcM (IdeResult T.Text)
232226
lintCmd' uri =
233227
pluginGetFile "lint: " uri $ \file ->
234-
fmap T.pack <$> runGhcModCommand (GM.lint GM.defaultLintOpts file)
228+
fmap T.pack <$> Hie.runGhcModCommand (GM.lint GM.defaultLintOpts file)
235229

236230
-- ---------------------------------------------------------------------
237231

@@ -255,7 +249,7 @@ infoCmd = CmdSync $ \_ (IP uri expr) ->
255249
infoCmd' :: Uri -> T.Text -> IdeGhcM (IdeResult T.Text)
256250
infoCmd' uri expr =
257251
pluginGetFile "info: " uri $ \file ->
258-
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)))
259253

260254
-- ---------------------------------------------------------------------
261255
data TypeParams =
@@ -307,74 +301,6 @@ cmp a b
307301
isSubRangeOf :: Range -> Range -> Bool
308302
isSubRangeOf (Range sa ea) (Range sb eb) = sb <= sa && eb >= ea
309303

310-
311-
splitCaseCmd :: CommandFunc HarePoint WorkspaceEdit
312-
splitCaseCmd = CmdSync $ \_ (HP uri pos) -> splitCaseCmd' uri pos
313-
314-
splitCaseCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
315-
splitCaseCmd' uri newPos =
316-
pluginGetFile "splitCaseCmd: " uri $ \path -> do
317-
origText <- GM.withMappedFile path $ liftIO . T.readFile
318-
ifCachedModule path (IdeResultOk mempty) $ \tm info -> runGhcModCommand $
319-
case newPosToOld info newPos of
320-
Just oldPos -> do
321-
let (line, column) = unPos oldPos
322-
splitResult' <- GM.splits' path tm line column
323-
case splitResult' of
324-
Just splitResult -> do
325-
wEdit <- liftToGhc $ splitResultToWorkspaceEdit origText splitResult
326-
return $ oldToNewPositions info wEdit
327-
Nothing -> return mempty
328-
Nothing -> return mempty
329-
where
330-
331-
-- | Transform all ranges in a WorkspaceEdit from old to new positions.
332-
oldToNewPositions :: CachedInfo -> WorkspaceEdit -> WorkspaceEdit
333-
oldToNewPositions info wsEdit =
334-
wsEdit
335-
& LSP.documentChanges %~ (>>= traverseOf (traverse . LSP.edits . traverse . LSP.range) (oldRangeToNew info))
336-
& LSP.changes %~ (>>= traverseOf (traverse . traverse . LSP.range) (oldRangeToNew info))
337-
338-
-- | Given the range and text to replace, construct a 'WorkspaceEdit'
339-
-- by diffing the change against the current text.
340-
splitResultToWorkspaceEdit :: T.Text -> GM.SplitResult -> IdeM WorkspaceEdit
341-
splitResultToWorkspaceEdit originalText (GM.SplitResult replaceFromLine replaceFromCol replaceToLine replaceToCol replaceWith) =
342-
diffText (uri, originalText) newText IncludeDeletions
343-
where
344-
before = takeUntil (toPos (replaceFromLine, replaceFromCol)) originalText
345-
after = dropUntil (toPos (replaceToLine, replaceToCol)) originalText
346-
newText = before <> replaceWith <> after
347-
348-
-- | Take the first part of text until the given position.
349-
-- Returns all characters before the position.
350-
takeUntil :: Position -> T.Text -> T.Text
351-
takeUntil (Position l c) txt =
352-
T.unlines takeLines <> takeCharacters
353-
where
354-
textLines = T.lines txt
355-
takeLines = take l textLines
356-
takeCharacters = T.take c (textLines !! c)
357-
358-
-- | Drop the first part of text until the given position.
359-
-- Returns all characters after and including the position.
360-
dropUntil :: Position -> T.Text -> T.Text
361-
dropUntil (Position l c) txt = dropCharacters
362-
where
363-
textLines = T.lines txt
364-
dropLines = drop l textLines
365-
dropCharacters = T.drop c (T.unlines dropLines)
366-
367-
-- ---------------------------------------------------------------------
368-
369-
runGhcModCommand :: IdeGhcM a
370-
-> IdeGhcM (IdeResult a)
371-
runGhcModCommand cmd =
372-
(IdeResultOk <$> cmd) `G.gcatch`
373-
\(e :: GM.GhcModError) ->
374-
return $
375-
IdeResultFail $
376-
IdeError PluginError (T.pack $ "hie-ghc-mod: " ++ show e) Null
377-
378304
-- ---------------------------------------------------------------------
379305

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

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

Lines changed: 41 additions & 39 deletions
Original file line numberDiff line numberDiff line change
@@ -64,6 +64,9 @@ hareDescriptor plId = PluginDescriptor
6464
deleteDefCmd
6565
, PluginCommand "genapplicative" "Generalise a monadic function to use applicative"
6666
genApplicativeCommand
67+
68+
, PluginCommand "casesplit" "Generate a pattern match for a binding under (LINE,COL)"
69+
Hie.splitCaseCmd
6770
]
6871
, pluginCodeActionProvider = Just codeActionProvider
6972
, pluginDiagnosticProvider = Nothing
@@ -73,29 +76,16 @@ hareDescriptor plId = PluginDescriptor
7376

7477
-- ---------------------------------------------------------------------
7578

76-
customOptions :: Int -> J.Options
77-
customOptions n = J.defaultOptions { J.fieldLabelModifier = J.camelTo2 '_' . drop n}
78-
79-
data HarePoint =
80-
HP { hpFile :: Uri
81-
, hpPos :: Position
82-
} deriving (Eq,Generic,Show)
83-
84-
instance FromJSON HarePoint where
85-
parseJSON = genericParseJSON $ customOptions 2
86-
instance ToJSON HarePoint where
87-
toJSON = genericToJSON $ customOptions 2
88-
8979
data HarePointWithText =
9080
HPT { hptFile :: Uri
9181
, hptPos :: Position
9282
, hptText :: T.Text
9383
} deriving (Eq,Generic,Show)
9484

9585
instance FromJSON HarePointWithText where
96-
parseJSON = genericParseJSON $ customOptions 3
86+
parseJSON = genericParseJSON $ Hie.customOptions 3
9787
instance ToJSON HarePointWithText where
98-
toJSON = genericToJSON $ customOptions 3
88+
toJSON = genericToJSON $ Hie.customOptions 3
9989

10090
data HareRange =
10191
HR { hrFile :: Uri
@@ -104,14 +94,14 @@ data HareRange =
10494
} deriving (Eq,Generic,Show)
10595

10696
instance FromJSON HareRange where
107-
parseJSON = genericParseJSON $ customOptions 2
97+
parseJSON = genericParseJSON $ Hie.customOptions 2
10898
instance ToJSON HareRange where
109-
toJSON = genericToJSON $ customOptions 2
99+
toJSON = genericToJSON $ Hie.customOptions 2
110100

111101
-- ---------------------------------------------------------------------
112102

113-
demoteCmd :: CommandFunc HarePoint WorkspaceEdit
114-
demoteCmd = CmdSync $ \_ (HP uri pos) ->
103+
demoteCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
104+
demoteCmd = CmdSync $ \_ (Hie.HP uri pos) ->
115105
demoteCmd' uri pos
116106

117107
demoteCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
@@ -149,8 +139,8 @@ iftocaseCmd' uri (Range startPos endPos) =
149139

150140
-- ---------------------------------------------------------------------
151141

152-
liftonelevelCmd :: CommandFunc HarePoint WorkspaceEdit
153-
liftonelevelCmd = CmdSync $ \_ (HP uri pos) ->
142+
liftonelevelCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
143+
liftonelevelCmd = CmdSync $ \_ (Hie.HP uri pos) ->
154144
liftonelevelCmd' uri pos
155145

156146
liftonelevelCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
@@ -162,8 +152,8 @@ liftonelevelCmd' uri pos =
162152

163153
-- ---------------------------------------------------------------------
164154

165-
lifttotoplevelCmd :: CommandFunc HarePoint WorkspaceEdit
166-
lifttotoplevelCmd = CmdSync $ \_ (HP uri pos) ->
155+
lifttotoplevelCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
156+
lifttotoplevelCmd = CmdSync $ \_ (Hie.HP uri pos) ->
167157
lifttotoplevelCmd' uri pos
168158

169159
lifttotoplevelCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
@@ -188,8 +178,8 @@ renameCmd' uri pos name =
188178

189179
-- ---------------------------------------------------------------------
190180

191-
deleteDefCmd :: CommandFunc HarePoint WorkspaceEdit
192-
deleteDefCmd = CmdSync $ \_ (HP uri pos) ->
181+
deleteDefCmd :: CommandFunc Hie.HarePoint WorkspaceEdit
182+
deleteDefCmd = CmdSync $ \_ (Hie.HP uri pos) ->
193183
deleteDefCmd' uri pos
194184

195185
deleteDefCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
@@ -201,8 +191,8 @@ deleteDefCmd' uri pos =
201191

202192
-- ---------------------------------------------------------------------
203193

204-
genApplicativeCommand :: CommandFunc HarePoint WorkspaceEdit
205-
genApplicativeCommand = CmdSync $ \_ (HP uri pos) ->
194+
genApplicativeCommand :: CommandFunc Hie.HarePoint WorkspaceEdit
195+
genApplicativeCommand = CmdSync $ \_ (Hie.HP uri pos) ->
206196
genApplicativeCommand' uri pos
207197

208198
genApplicativeCommand' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit)
@@ -294,42 +284,48 @@ hoist f a =
294284
codeActionProvider :: CodeActionProvider
295285
codeActionProvider pId docId _ _ (J.Range pos _) _ =
296286
pluginGetFile "HaRe codeActionProvider: " (docId ^. J.uri) $ \file ->
297-
ifCachedInfo file (IdeResultOk mempty) $ \info -> do
298-
let symbols = getArtifactsAtPos pos (defMap info)
299-
debugm $ show $ map (Hie.showName . snd) symbols
300-
if not (null symbols)
301-
then
302-
let name = Hie.showName $ snd $ head symbols
303-
in IdeResultOk <$> sequence [
287+
ifCachedInfo file (IdeResultOk mempty) $ \info ->
288+
case getArtifactsAtPos pos (defMap info) of
289+
[h] -> do
290+
let name = Hie.showName $ snd h
291+
debugm $ show name
292+
IdeResultOk <$> sequence [
304293
mkLiftOneAction name
305294
, mkLiftTopAction name
306295
, mkDemoteAction name
307296
, mkDeleteAction name
308297
, mkDuplicateAction name
309298
]
310-
else return (IdeResultOk [])
299+
_ -> case getArtifactsAtPos pos (locMap info) of
300+
[h] -> do
301+
let name = Hie.showName $ snd h
302+
debugm $ show name
303+
IdeResultOk <$> sequence [
304+
mkCaseSplitAction name
305+
]
306+
_ -> return $ IdeResultOk []
311307

312308
where
313309
mkLiftOneAction name = do
314-
let args = [J.toJSON $ HP (docId ^. J.uri) pos]
310+
let args = [J.toJSON $ Hie.HP (docId ^. J.uri) pos]
315311
title = "Lift " <> name <> " one level"
316312
liftCmd <- mkLspCommand pId "liftonelevel" title (Just args)
317313
return $ J.CodeAction title (Just J.CodeActionRefactorExtract) mempty Nothing (Just liftCmd)
318314

319315
mkLiftTopAction name = do
320-
let args = [J.toJSON $ HP (docId ^. J.uri) pos]
316+
let args = [J.toJSON $ Hie.HP (docId ^. J.uri) pos]
321317
title = "Lift " <> name <> " to top level"
322318
liftCmd <- mkLspCommand pId "lifttotoplevel" title (Just args)
323319
return $ J.CodeAction title (Just J.CodeActionRefactorExtract) mempty Nothing (Just liftCmd)
324320

325321
mkDemoteAction name = do
326-
let args = [J.toJSON $ HP (docId ^. J.uri) pos]
322+
let args = [J.toJSON $ Hie.HP (docId ^. J.uri) pos]
327323
title = "Demote " <> name <> " one level"
328324
demCmd <- mkLspCommand pId "demote" title (Just args)
329325
return $ J.CodeAction title (Just J.CodeActionRefactorInline) mempty Nothing (Just demCmd)
330326

331327
mkDeleteAction name = do
332-
let args = [J.toJSON $ HP (docId ^. J.uri) pos]
328+
let args = [J.toJSON $ Hie.HP (docId ^. J.uri) pos]
333329
title = "Delete definition of " <> name
334330
delCmd <- mkLspCommand pId "deletedef" title (Just args)
335331
return $ J.CodeAction title (Just J.CodeActionRefactor) mempty Nothing (Just delCmd)
@@ -339,3 +335,9 @@ codeActionProvider pId docId _ _ (J.Range pos _) _ =
339335
title = "Duplicate definition of " <> name
340336
dupCmd <- mkLspCommand pId "dupdef" title (Just args)
341337
return $ J.CodeAction title (Just J.CodeActionRefactor) mempty Nothing (Just dupCmd)
338+
339+
mkCaseSplitAction name = do
340+
let args = [J.toJSON $ Hie.HP (docId ^. J.uri) pos]
341+
title = "Case split on " <> name
342+
splCmd <- mkLspCommand pId "casesplit" title (Just args)
343+
return $ J.CodeAction title (Just J.CodeActionRefactorRewrite) mempty Nothing (Just splCmd)

0 commit comments

Comments
 (0)