First draft for add to import list

Author: fendor

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

@@ -0,0 +1,218 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE TupleSections #-}
+module Haskell.Ide.Engine.Plugin.HsImport where
+
+import           Control.Lens.Operators
+import           Control.Monad.IO.Class
+import           Control.Monad
+import           Data.Aeson
+import           Data.Bitraversable
+import           Data.Bifunctor
+import           Data.Foldable
+import           Data.Maybe
+import           Data.Monoid                    ( (<>) )
+import qualified Data.Text                     as T
+import qualified Data.Text.IO                  as T
+import qualified GHC.Generics                  as Generics
+import qualified GhcMod.Utils                  as GM
+import           HsImport
+import           Haskell.Ide.Engine.Config
+import           Haskell.Ide.Engine.MonadTypes
+import qualified Haskell.Ide.Engine.Support.HieExtras
+                                               as Hie
+import qualified Language.Haskell.LSP.Types    as J
+import qualified Language.Haskell.LSP.Types.Lens
+                                               as J
+import           Haskell.Ide.Engine.PluginUtils
+import qualified Haskell.Ide.Engine.Plugin.Hoogle
+                                               as Hoogle
+import           System.Directory
+import           System.IO
+
+hsimportDescriptor :: PluginId -> PluginDescriptor
+hsimportDescriptor plId = PluginDescriptor
+  { pluginId                 = plId
+  , pluginName               = "HsImport"
+  , pluginDesc               =
+    "A tool for extending the import list of a Haskell source file."
+  , pluginCommands = [PluginCommand "import" "Import a module" importCmd]
+  , pluginCodeActionProvider = Just codeActionProvider
+  , pluginDiagnosticProvider = Nothing
+  , pluginHoverProvider      = Nothing
+  , pluginSymbolProvider     = Nothing
+  , pluginFormattingProvider = Nothing
+  }
+
+data ImportParams = ImportParams
+  { file           :: Uri
+  , addToImportList :: Maybe T.Text
+  , moduleToImport :: T.Text
+  }
+  deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON)
+
+importCmd :: CommandFunc ImportParams J.WorkspaceEdit
+importCmd = CmdSync $ \(ImportParams uri importList modName) ->
+  importModule uri importList modName
+
+importModule
+  :: Uri -> Maybe T.Text -> T.Text -> IdeGhcM (IdeResult J.WorkspaceEdit)
+importModule uri importList modName =
+  pluginGetFile "hsimport cmd: " uri $ \origInput -> do
+    shouldFormat <- formatOnImportOn <$> getConfig
+
+    fileMap      <- GM.mkRevRedirMapFunc
+    GM.withMappedFile origInput $ \input -> do
+
+      tmpDir            <- liftIO getTemporaryDirectory
+      (output, outputH) <- liftIO $ openTempFile tmpDir "hsimportOutput"
+      liftIO $ hClose outputH
+
+      let args = defaultArgs { moduleName    = T.unpack modName
+                             , inputSrcFile  = input
+                             , symbolName = T.unpack $ fromMaybe "" importList
+                             , outputSrcFile = output
+                             }
+      liftIO $ hPutStrLn stderr $ "hsimport args: " ++ show args 
+      maybeErr <- liftIO $ hsimportWithArgs defaultConfig args
+      case maybeErr of
+        Just err -> do
+          liftIO $ removeFile output
+          let msg = T.pack $ show err
+          return $ IdeResultFail (IdeError PluginError msg Null)
+        Nothing -> do
+          newText <- liftIO $ T.readFile output
+          liftIO $ removeFile output
+          J.WorkspaceEdit mChanges mDocChanges <- liftToGhc
+            $ makeDiffResult input newText fileMap
+
+          if shouldFormat
+            then do
+              config  <- getConfig
+              plugins <- getPlugins
+              let mprovider = Hie.getFormattingPlugin config plugins
+              case mprovider of
+                Nothing ->
+                  return $ IdeResultOk (J.WorkspaceEdit mChanges mDocChanges)
+
+                Just (plugin, _) -> do
+                  newChanges <- forM mChanges $ \change -> do
+                    let func = mapM (formatTextEdit plugin)
+                    res <- mapM func change
+                    return $ fmap flatten res
+
+                  newDocChanges <- forM mDocChanges $ \change -> do
+                    let cmd (J.TextDocumentEdit vids edits) = do
+                          newEdits <- mapM (formatTextEdit plugin) edits
+                          return $ J.TextDocumentEdit vids (flatten newEdits)
+                    mapM cmd change
+
+                  return
+                    $ IdeResultOk (J.WorkspaceEdit newChanges newDocChanges)
+            else return $ IdeResultOk (J.WorkspaceEdit mChanges mDocChanges)
+
+ where
+  flatten :: List [a] -> List a
+  flatten (J.List list) = J.List (join list)
+
+  formatTextEdit :: PluginDescriptor -> J.TextEdit -> IdeGhcM [J.TextEdit]
+  formatTextEdit plugin edit@(J.TextEdit r t) = do
+    result <- runPluginCommand
+      (pluginId plugin)
+      "formatText"
+      -- TODO: should this be in the configs?
+      (dynToJSON $ toDynJSON $ FormatTextCmdParams t
+                                                   r
+                                                   (FormattingOptions 2 True)
+      )
+    return $ case result of
+      IdeResultOk e -> fromMaybe [edit] (fromDynJSON e)
+      _             -> [edit]
+
+codeActionProvider :: CodeActionProvider
+codeActionProvider plId docId _ context = do
+  let J.List diags = context ^. J.diagnostics
+      terms        = mapMaybe getImportables diags
+      strippedNames = map (head . T.words . snd) terms
+  res     <- zip strippedNames <$> mapM (bimapM return Hoogle.searchModules) terms
+  actions <-
+    catMaybes
+    .   concat
+    <$> mapM
+          (\(term, diags') -> do
+            let
+              actions = concatMap
+                (\(d, t) ->
+                  [mkImportAction Nothing d t, mkImportAction (Just term) d t]
+                )
+                (concatTerms [diags'])
+            sequenceA actions
+          )
+          res
+
+  if null actions
+    then do
+      let relaxedTerms = map (bimap id (head . T.words)) terms
+          strippedNames' = map snd relaxedTerms
+      relaxedRes     <- zip strippedNames' <$> mapM (bimapM return Hoogle.searchModules) relaxedTerms
+      relaxedActions <-
+        catMaybes
+        .   concat
+        <$> mapM
+              (\(term, diags') -> do
+                let
+                  actions' = concatMap
+                    (\(d, t) ->
+                      [mkImportAction Nothing d t, mkImportAction (Just term) d t]
+                    )
+                    (concatTerms [diags'])
+                sequenceA actions'
+              )
+              relaxedRes
+      return $ IdeResultOk relaxedActions
+    else return $ IdeResultOk actions
+
+ where
+  concatTerms :: [(a, [b])] -> [(a, b)]
+  concatTerms = concatMap (\(d, ts) -> map (d, ) ts)
+
+  --TODO: Check if package is already installed
+  mkImportAction
+    :: Maybe T.Text -> J.Diagnostic -> T.Text -> IdeM (Maybe J.CodeAction)
+  mkImportAction importList diag modName = do
+    cmd <- mkLspCommand plId "import" title (Just cmdParams)
+    return (Just (codeAction cmd))
+   where
+    codeAction cmd = J.CodeAction title
+                                  (Just J.CodeActionQuickFix)
+                                  (Just (J.List [diag]))
+                                  Nothing
+                                  (Just cmd)
+    title     = "Import module " <> modName <> maybe ""  (\name -> " (" <> name <> ")" ) importList
+    cmdParams = [toJSON (ImportParams (docId ^. J.uri) importList modName)]
+
+
+  getImportables :: J.Diagnostic -> Maybe (J.Diagnostic, T.Text)
+  getImportables diag@(J.Diagnostic _ _ _ (Just "ghcmod") msg _) =
+    (diag, ) <$> extractImportableTerm msg
+  getImportables _ = Nothing
+
+extractImportableTerm :: T.Text -> Maybe T.Text
+extractImportableTerm dirtyMsg = T.strip <$> asum
+  [ T.stripPrefix "Variable not in scope: " msg
+  , T.init <$> T.stripPrefix "Not in scope: type constructor or class ‘" msg
+  , T.stripPrefix "Data constructor not in scope: " msg
+  ]
+ where
+  msg =
+    head
+        -- Get rid of the rename suggestion parts
+      $ T.splitOn "Perhaps you meant "
+      $ T.replace "\n" " "
+        -- Get rid of trailing/leading whitespace on each individual line
+      $ T.unlines
+      $ map T.strip
+      $ T.lines
+      $ T.replace "• " "" dirtyMsg