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

Commit 51b912b

Browse files
fendorfendor
committed
Demote from top-level definition
1 parent 90268c5 commit 51b912b

File tree

1 file changed

+117
-67
lines changed

1 file changed

+117
-67
lines changed

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

Lines changed: 117 additions & 67 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE NoMonomorphismRestriction #-}
23
{-# LANGUAGE DeriveGeneric #-}
34
{-# LANGUAGE DeriveAnyClass #-}
45
{-# LANGUAGE TupleSections #-}
@@ -20,9 +21,11 @@ import qualified GhcMod.Utils as GM
2021
import HsImport
2122
import Haskell.Ide.Engine.Config
2223
import Haskell.Ide.Engine.MonadTypes
23-
import qualified Haskell.Ide.Engine.Support.HieExtras as Hie
24-
import qualified Language.Haskell.LSP.Types as J
25-
import qualified Language.Haskell.LSP.Types.Lens as J
24+
import qualified Haskell.Ide.Engine.Support.HieExtras
25+
as Hie
26+
import qualified Language.Haskell.LSP.Types as J
27+
import qualified Language.Haskell.LSP.Types.Lens
28+
as J
2629
import Haskell.Ide.Engine.PluginUtils
2730
import qualified Haskell.Ide.Engine.Plugin.Hoogle
2831
as Hoogle
@@ -31,28 +34,33 @@ import System.IO
3134

3235
hsimportDescriptor :: PluginId -> PluginDescriptor
3336
hsimportDescriptor plId = PluginDescriptor
34-
{ pluginId = plId
35-
, pluginName = "HsImport"
36-
, pluginDesc = "A tool for extending the import list of a Haskell source file."
37+
{ pluginId = plId
38+
, pluginName = "HsImport"
39+
, pluginDesc =
40+
"A tool for extending the import list of a Haskell source file."
3741
, pluginCommands = [PluginCommand "import" "Import a module" importCmd]
3842
, pluginCodeActionProvider = Just codeActionProvider
3943
, pluginDiagnosticProvider = Nothing
40-
, pluginHoverProvider = Nothing
41-
, pluginSymbolProvider = Nothing
44+
, pluginHoverProvider = Nothing
45+
, pluginSymbolProvider = Nothing
4246
, pluginFormattingProvider = Nothing
4347
}
4448

4549
data ImportParams = ImportParams
4650
{ file :: Uri
51+
, addToImportList :: Maybe T.Text
4752
, moduleToImport :: T.Text
4853
}
4954
deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON)
5055

5156
importCmd :: CommandFunc ImportParams J.WorkspaceEdit
52-
importCmd = CmdSync $ \(ImportParams uri modName) -> importModule uri modName
57+
importCmd = CmdSync $ \(ImportParams uri importList modName) ->
58+
importModule uri importList modName
5359

54-
importModule :: Uri -> T.Text -> IdeGhcM (IdeResult J.WorkspaceEdit)
55-
importModule uri modName = pluginGetFile "hsimport cmd: " uri $ \origInput -> do
60+
importModule
61+
:: Uri -> Maybe T.Text -> T.Text -> IdeGhcM (IdeResult J.WorkspaceEdit)
62+
importModule uri importList modName =
63+
pluginGetFile "hsimport cmd: " uri $ \origInput -> do
5664
shouldFormat <- formatOnImportOn <$> getConfig
5765

5866
fileMap <- GM.mkRevRedirMapFunc
@@ -64,8 +72,10 @@ importModule uri modName = pluginGetFile "hsimport cmd: " uri $ \origInput -> do
6472

6573
let args = defaultArgs { moduleName = T.unpack modName
6674
, inputSrcFile = input
75+
, symbolName = T.unpack $ fromMaybe "" importList
6776
, outputSrcFile = output
6877
}
78+
liftIO $ hPutStrLn stderr $ "hsimport args: " ++ show args
6979
maybeErr <- liftIO $ hsimportWithArgs defaultConfig args
7080
case maybeErr of
7181
Just err -> do
@@ -84,85 +94,125 @@ importModule uri modName = pluginGetFile "hsimport cmd: " uri $ \origInput -> do
8494
plugins <- getPlugins
8595
let mprovider = Hie.getFormattingPlugin config plugins
8696
case mprovider of
87-
Nothing ->
97+
Nothing ->
8898
return $ IdeResultOk (J.WorkspaceEdit mChanges mDocChanges)
8999

90100
Just (plugin, _) -> do
91101
newChanges <- forM mChanges $ \change -> do
92102
let func = mapM (formatTextEdit plugin)
93103
res <- mapM func change
94-
return $ fmap flatten res
104+
return $ fmap flatten res
95105

96106
newDocChanges <- forM mDocChanges $ \change -> do
97107
let cmd (J.TextDocumentEdit vids edits) = do
98108
newEdits <- mapM (formatTextEdit plugin) edits
99109
return $ J.TextDocumentEdit vids (flatten newEdits)
100110
mapM cmd change
101111

102-
return $ IdeResultOk
103-
(J.WorkspaceEdit newChanges
104-
newDocChanges
105-
)
106-
else
107-
return $ IdeResultOk (J.WorkspaceEdit mChanges mDocChanges)
112+
return
113+
$ IdeResultOk (J.WorkspaceEdit newChanges newDocChanges)
114+
else return $ IdeResultOk (J.WorkspaceEdit mChanges mDocChanges)
108115

109116
where
110-
flatten :: List [a] -> List a
111-
flatten (J.List list) = J.List (join list)
112-
113-
formatTextEdit :: PluginDescriptor -> J.TextEdit -> IdeGhcM [J.TextEdit]
114-
formatTextEdit plugin edit@(J.TextEdit r t) = do
115-
result <- runPluginCommand
116-
(pluginId plugin)
117-
"formatText"
118-
-- TODO: should this be in the configs?
119-
(dynToJSON $ toDynJSON $ FormatTextCmdParams t r (FormattingOptions 2 True))
120-
return $ case result of
121-
IdeResultOk e -> fromMaybe [edit] (fromDynJSON e)
122-
_ -> [edit]
117+
flatten :: List [a] -> List a
118+
flatten (J.List list) = J.List (join list)
119+
120+
formatTextEdit :: PluginDescriptor -> J.TextEdit -> IdeGhcM [J.TextEdit]
121+
formatTextEdit plugin edit@(J.TextEdit r t) = do
122+
result <- runPluginCommand
123+
(pluginId plugin)
124+
"formatText"
125+
-- TODO: should this be in the configs?
126+
(dynToJSON $ toDynJSON $ FormatTextCmdParams t
127+
r
128+
(FormattingOptions 2 True)
129+
)
130+
return $ case result of
131+
IdeResultOk e -> fromMaybe [edit] (fromDynJSON e)
132+
_ -> [edit]
123133

124134
codeActionProvider :: CodeActionProvider
125135
codeActionProvider plId docId _ context = do
126136
let J.List diags = context ^. J.diagnostics
127-
terms = mapMaybe getImportables diags
128-
129-
res <- mapM (bimapM return Hoogle.searchModules) terms
130-
actions <- catMaybes <$> mapM (uncurry mkImportAction) (concatTerms res)
137+
terms = mapMaybe getImportables diags
138+
strippedNames = map (head . T.words . snd) terms
139+
res <- zip strippedNames <$> mapM (bimapM return Hoogle.searchModules) terms
140+
actions <-
141+
catMaybes
142+
. concat
143+
<$> mapM
144+
(\(term, diags') -> do
145+
let
146+
actions = concatMap
147+
(\(d, t) ->
148+
[mkImportAction Nothing d t, mkImportAction (Just term) d t]
149+
)
150+
(concatTerms [diags'])
151+
sequenceA actions
152+
)
153+
res
131154

132155
if null actions
133-
then do
134-
let relaxedTerms = map (bimap id (head . T.words)) terms
135-
relaxedRes <- mapM (bimapM return Hoogle.searchModules) relaxedTerms
136-
relaxedActions <- catMaybes <$> mapM (uncurry mkImportAction) (concatTerms relaxedRes)
137-
return $ IdeResultOk relaxedActions
138-
else return $ IdeResultOk actions
139-
140-
where
141-
concatTerms = concatMap (\(d, ts) -> map (d,) ts)
142-
143-
--TODO: Check if package is already installed
144-
mkImportAction :: J.Diagnostic -> T.Text -> IdeM (Maybe J.CodeAction)
145-
mkImportAction diag modName = do
146-
cmd <- mkLspCommand plId "import" title (Just cmdParams)
147-
return (Just (codeAction cmd))
148-
where
149-
codeAction cmd = J.CodeAction title (Just J.CodeActionQuickFix) (Just (J.List [diag])) Nothing (Just cmd)
150-
title = "Import module " <> modName
151-
cmdParams = [toJSON (ImportParams (docId ^. J.uri) modName)]
152-
153-
getImportables :: J.Diagnostic -> Maybe (J.Diagnostic, T.Text)
154-
getImportables diag@(J.Diagnostic _ _ _ (Just "ghcmod") msg _) = (diag,) <$> extractImportableTerm msg
155-
getImportables _ = Nothing
156+
then do
157+
let relaxedTerms = map (bimap id (head . T.words)) terms
158+
strippedNames' = map snd relaxedTerms
159+
relaxedRes <- zip strippedNames' <$> mapM (bimapM return Hoogle.searchModules) relaxedTerms
160+
relaxedActions <-
161+
catMaybes
162+
. concat
163+
<$> mapM
164+
(\(term, diags') -> do
165+
let
166+
actions' = concatMap
167+
(\(d, t) ->
168+
[mkImportAction Nothing d t, mkImportAction (Just term) d t]
169+
)
170+
(concatTerms [diags'])
171+
sequenceA actions'
172+
)
173+
relaxedRes
174+
return $ IdeResultOk relaxedActions
175+
else return $ IdeResultOk actions
176+
177+
where
178+
concatTerms :: [(a, [b])] -> [(a, b)]
179+
concatTerms = concatMap (\(d, ts) -> map (d, ) ts)
180+
181+
--TODO: Check if package is already installed
182+
mkImportAction
183+
:: Maybe T.Text -> J.Diagnostic -> T.Text -> IdeM (Maybe J.CodeAction)
184+
mkImportAction importList diag modName = do
185+
cmd <- mkLspCommand plId "import" title (Just cmdParams)
186+
return (Just (codeAction cmd))
187+
where
188+
codeAction cmd = J.CodeAction title
189+
(Just J.CodeActionQuickFix)
190+
(Just (J.List [diag]))
191+
Nothing
192+
(Just cmd)
193+
title = "Import module " <> modName <> maybe "" (\name -> " (" <> name <> ")" ) importList
194+
cmdParams = [toJSON (ImportParams (docId ^. J.uri) importList modName)]
195+
196+
197+
getImportables :: J.Diagnostic -> Maybe (J.Diagnostic, T.Text)
198+
getImportables diag@(J.Diagnostic _ _ _ (Just "ghcmod") msg _) =
199+
(diag, ) <$> extractImportableTerm msg
200+
getImportables _ = Nothing
156201

157202
extractImportableTerm :: T.Text -> Maybe T.Text
158203
extractImportableTerm dirtyMsg = T.strip <$> asum
159204
[ T.stripPrefix "Variable not in scope: " msg
160205
, T.init <$> T.stripPrefix "Not in scope: type constructor or class ‘" msg
161-
, T.stripPrefix "Data constructor not in scope: " msg]
162-
where msg = head
163-
-- Get rid of the rename suggestion parts
164-
$ T.splitOn "Perhaps you meant "
165-
$ T.replace "\n" " "
166-
-- Get rid of trailing/leading whitespace on each individual line
167-
$ T.unlines $ map T.strip $ T.lines
168-
$ T.replace "• " "" dirtyMsg
206+
, T.stripPrefix "Data constructor not in scope: " msg
207+
]
208+
where
209+
msg =
210+
head
211+
-- Get rid of the rename suggestion parts
212+
$ T.splitOn "Perhaps you meant "
213+
$ T.replace "\n" " "
214+
-- Get rid of trailing/leading whitespace on each individual line
215+
$ T.unlines
216+
$ map T.strip
217+
$ T.lines
218+
$ T.replace "• " "" dirtyMsg

0 commit comments

Comments
 (0)