Merge pull request #1170 from fendor/hsimport-importlist

HsImport importlist

Author: alanz

haskell-ide-engine.cabal

@@ -283,6 +283,7 @@ test-suite func-test
                      , lens
                      , text
                      , unordered-containers
+                     , containers
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall -Wredundant-constraints
   if flag(pedantic)
      ghc-options:      -Werror

hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs

@@ -207,15 +207,18 @@ type HoverProvider = Uri -> Position -> IdeM (IdeResult [Hover])
 
 type SymbolProvider = Uri -> IdeDeferM (IdeResult [DocumentSymbol])
 
--- | Format the document either as a whole or only a given Range of it.
-data FormattingType = FormatDocument
+-- | Format the given Text as a whole or only a @Range@ of it.
+-- Range must be relative to the text to format.
+-- To format the whole document, read the Text from the file and use 'FormatText'
+-- as the FormattingType.
+data FormattingType = FormatText
                     | FormatRange Range
 
 -- | Formats the given Text associated with the given Uri.
--- Should, but might not, honor the provided formatting options (e.g. Floskell does not).
--- A formatting type can be given to either format the whole document or only a Range.
--- 
--- Text to format, may or may not, originate from the associated Uri. 
+-- Should, but might not, honour the provided formatting options (e.g. Floskell does not).
+-- A formatting type can be given to either format the whole text or only a Range.
+--
+-- Text to format, may or may not, originate from the associated Uri.
 -- E.g. it is ok, to modify the text and then reformat it through this API.
 --
 -- The Uri is mainly used to discover formatting configurations in the file's path.
@@ -224,6 +227,11 @@ data FormattingType = FormatDocument
 -- Failing means here that a IdeResultFail is returned.
 -- This can be used to display errors to the user, unless the error is an Internal one.
 -- The record 'IdeError' and 'IdeErrorCode' can be used to determine the type of error.
+--
+--
+-- To format a whole document, the 'FormatText' @FormattingType@ can be used.
+-- It is required to pass in the whole Document Text for that to happen, an empty text
+-- and file uri, does not suffice.
 type FormattingProvider = T.Text -- ^ Text to format
         -> Uri -- ^ Uri of the file being formatted
         -> FormattingType  -- ^ How much to format

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

@@ -43,8 +43,8 @@ provider
 provider text uri formatType opts = pluginGetFile "brittanyCmd: " uri $ \fp -> do
   confFile <- liftIO $ getConfFile fp
   let (range, selectedContents) = case formatType of
-        FormatDocument -> (fullRange text, text)
-        FormatRange r  -> (normalize r, extractRange r text)
+        FormatText    -> (fullRange text, text)
+        FormatRange r -> (normalize r, extractRange r text)
 
   res <- formatText confFile opts selectedContents
   case res of
@@ -65,21 +65,28 @@ formatText
   => Maybe FilePath -- ^ Path to configs. If Nothing, default configs will be used.
   -> FormattingOptions -- ^ Options for the formatter such as indentation.
   -> Text -- ^ Text to format
-  -> m (Either [BrittanyError] Text) -- ^ Either formatted Text or a error from Brittany. 
-formatText confFile opts text = 
+  -> m (Either [BrittanyError] Text) -- ^ Either formatted Text or a error from Brittany.
+formatText confFile opts text =
   liftIO $ runBrittany tabSize confFile text
   where tabSize = opts ^. J.tabSize
 
--- | Extend to the line below to replace newline character, as above.
+-- | Extend to the line below and above to replace newline character.
 normalize :: Range -> Range
 normalize (Range (Position sl _) (Position el _)) =
   Range (Position sl 0) (Position (el + 1) 0)
 
--- | Recursively search in every directory of the given filepath for brittany.yaml
+-- | Recursively search in every directory of the given filepath for brittany.yaml.
 -- If no such file has been found, return Nothing.
 getConfFile :: FilePath -> IO (Maybe FilePath)
 getConfFile = findLocalConfigPath . takeDirectory
 
+-- | Run Brittany on the given text with the given tab size and
+-- a configuration path. If no configuration path is given, a
+-- default configuration is chosen. The configuration may overwrite
+-- tab size parameter.
+--
+-- Returns either a list of Brittany Errors or the reformatted text.
+-- May not throw an exception.
 runBrittany :: Int              -- ^ tab  size
             -> Maybe FilePath   -- ^ local config file
             -> Text             -- ^ text to format

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

@@ -35,9 +35,9 @@ provider contents uri typ _opts =
   pluginGetFile "Floskell: " uri $ \file -> do
     config <- liftIO $ findConfigOrDefault file
     let (range, selectedContents) = case typ of
-          FormatDocument -> (fullRange contents, contents)
-          FormatRange r  -> (r, extractRange r contents)
-        result = reformat config (uriToFilePath uri) (BS.fromStrict (T.encodeUtf8 selectedContents))
+          FormatText    -> (fullRange contents, contents)
+          FormatRange r -> (r, extractRange r contents)
+        result = reformat config (Just file) (BS.fromStrict (T.encodeUtf8 selectedContents))
     case result of
       Left  err -> return $ IdeResultFail (IdeError PluginError (T.pack $  "floskellCmd: " ++ err) Null)
       Right new -> return $ IdeResultOk [TextEdit range (T.decodeUtf8 (BS.toStrict new))]

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

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE LambdaCase #-}
 module Haskell.Ide.Engine.Plugin.HsImport where
 
 import           Control.Lens.Operators
@@ -42,60 +43,102 @@ hsimportDescriptor plId = PluginDescriptor
   , pluginFormattingProvider = Nothing
   }
 
+-- | Import Parameters for Modules.
+-- Can be used to import every symbol from a module,
+-- or to import only a specific function from a module.
 data ImportParams = ImportParams
-  { file           :: Uri
-  , moduleToImport :: T.Text
+  { file            :: Uri -- ^ Uri to the file to import the module to.
+  , addToImportList :: Maybe T.Text -- ^ If set, an import-list will be created.
+  , moduleToImport  :: T.Text -- ^ Name of the module to import.
   }
   deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON)
 
 importCmd :: CommandFunc ImportParams J.WorkspaceEdit
-importCmd = CmdSync $ \(ImportParams uri modName) -> importModule uri modName
+importCmd = CmdSync $ \(ImportParams uri importList modName) ->
+  importModule uri importList modName
 
-importModule :: Uri -> T.Text -> IdeGhcM (IdeResult J.WorkspaceEdit)
-importModule uri modName = pluginGetFile "hsimport cmd: " uri $ \origInput -> do
+-- | Import the given module for the given file.
+-- May take an explicit function name to perform an import-list import.
+-- Multiple import-list imports will result in merged imports,
+-- e.g. two consecutive imports for the same module will result in a single
+-- import line.
+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
                              }
+      -- execute hsimport on the given file and write into a temporary file.
       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
+          -- Since no error happened, calculate the differences of
+          -- the original file and after the import has been done.
           newText <- liftIO $ T.readFile output
           liftIO $ removeFile output
           J.WorkspaceEdit mChanges mDocChanges <- liftToGhc
             $ makeDiffResult input newText fileMap
 
+          -- If the client wants its import formatted,
+          -- it can be configured in the config.
           if shouldFormat
             then do
               config  <- getConfig
               plugins <- getPlugins
               let mprovider = Hie.getFormattingPlugin config plugins
               case mprovider of
+                -- Client may have no formatter selected
+                -- but still the option to format on import.
                 Nothing ->
                   return $ IdeResultOk (J.WorkspaceEdit mChanges mDocChanges)
 
                 Just (_, provider) -> do
-                  let formatEdit :: J.TextEdit -> IdeGhcM J.TextEdit
-                      formatEdit origEdit@(J.TextEdit _ t) = do
+                  let
+                      -- | Dirty little hack.
+                      -- Necessary in the following case:
+                      -- We want to add an item to an existing import-list.
+                      -- The diff algorithm does not count the newline character
+                      -- as part of the diff between new and old text.
+                      -- However, some formatters (Brittany), add a trailing
+                      -- newline nevertheless.
+                      -- This leads to the problem that an additional
+                      -- newline is inserted into the source.
+                      -- This function makes sure, that if the original text
+                      -- did not have a newline, none will be added, assuming
+                      -- that the diff algorithm continues to not count newlines
+                      -- as part of the diff.
+                      -- This is only save to do in this very specific environment.
+                      -- In any other case, this function may not be copy-pasted
+                      -- to solve a similar problem.
+                      renormalise :: T.Text -> T.Text -> T.Text
+                      renormalise orig formatted
+                        | T.null orig || T.null formatted = orig <> formatted
+                        | T.last orig /= '\n' && T.last formatted == '\n' = T.init formatted
+                        | otherwise = formatted
+
+                      formatEdit :: J.TextEdit -> IdeGhcM J.TextEdit
+                      formatEdit origEdit@(J.TextEdit r t) = do
                         -- TODO: are these default FormattingOptions ok?
-                        res <- liftToGhc $ provider t uri FormatDocument (FormattingOptions 2 True)
-                        let formatEdits = case res of
-                                            IdeResultOk xs -> xs
-                                            _ -> []
-                        return $ foldl' J.editTextEdit origEdit formatEdits
+                        formatEdits <-
+                          liftToGhc $ provider t uri FormatText (FormattingOptions 2 True) >>= \case
+                            IdeResultOk xs -> return xs
+                            _              -> return [origEdit]
+                        -- let edits = foldl' J.editTextEdit origEdit formatEdits -- TODO: this seems broken.
+                        return (J.TextEdit r (renormalise t . J._newText $ head formatEdits))
 
                   -- behold: the legendary triple mapM
                   newChanges <- (mapM . mapM . mapM) formatEdit mChanges
@@ -110,48 +153,132 @@ importModule uri modName = pluginGetFile "hsimport cmd: " uri $ \origInput -> do
                     $ IdeResultOk (J.WorkspaceEdit newChanges newDocChanges)
             else return $ IdeResultOk (J.WorkspaceEdit mChanges mDocChanges)
 
+-- | Search style for Hoogle.
+-- Can be used to look either for the exact term,
+-- only the exact name or a relaxed form of the term.
+data SearchStyle
+  = Exact -- ^ If you want to match exactly the search string.
+  | ExactName -- ^ If you want to match exactly a function name.
+              -- Same as @Exact@ if the term is just a function name.
+  | Relax (T.Text -> T.Text) -- ^ Relax the search term to match even more.
+
+-- | Produces code actions.
 codeActionProvider :: CodeActionProvider
 codeActionProvider plId docId _ context = do
   let J.List diags = context ^. J.diagnostics
-      terms = mapMaybe getImportables diags
-
-  res <- mapM (bimapM return Hoogle.searchModules) terms
-  actions <- catMaybes <$> mapM (uncurry mkImportAction) (concatTerms res)
+      terms        = mapMaybe getImportables diags
+  -- Search for the given diagnostics and produce appropiate import actions.
+  actions <- importActionsForTerms Exact terms
 
   if null actions
-     then do
-       let relaxedTerms = map (bimap id (head . T.words)) terms
-       relaxedRes <- mapM (bimapM return Hoogle.searchModules) relaxedTerms
-       relaxedActions <- catMaybes <$> mapM (uncurry mkImportAction) (concatTerms relaxedRes)
-       return $ IdeResultOk relaxedActions
-     else return $ IdeResultOk actions
-
-  where
-    concatTerms = concatMap (\(d, ts) -> map (d,) ts)
-
-    --TODO: Check if package is already installed
-    mkImportAction :: J.Diagnostic -> T.Text -> IdeM (Maybe J.CodeAction)
-    mkImportAction 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
-       cmdParams = [toJSON (ImportParams (docId ^. J.uri) modName)]
-
-    getImportables :: J.Diagnostic -> Maybe (J.Diagnostic, T.Text)
-    getImportables diag@(J.Diagnostic _ _ _ (Just "ghcmod") msg _) = (diag,) <$> extractImportableTerm msg
-    getImportables _ = Nothing
+    then do
+      -- If we didn't find any exact matches, relax the search terms.
+      -- Only looks for the function names, not the exact siganture.
+      relaxedActions <- importActionsForTerms ExactName terms
+      return $ IdeResultOk relaxedActions
+    else return $ IdeResultOk actions
+
+ where
+  -- | Creates CodeActions from the diagnostics to add imports.
+  -- Takes a relaxation Function. Used to relax the search term,
+  -- e.g. instead of `take :: Int -> [a] -> [a]` use `take` as the search term.
+  --
+  -- List of Diagnostics with the associated term to look for.
+  -- Diagnostic that is supposed to import the appropiate term.
+  --
+  -- Result may produce several import actions, or none.
+  importActionsForTerms
+    :: SearchStyle -> [(J.Diagnostic, T.Text)] -> IdeM [J.CodeAction]
+  importActionsForTerms style terms = do
+    let searchTerms   = map (bimap id (applySearchStyle style)) terms
+    -- Get the function names for a nice import-list title.
+    let functionNames = map (head . T.words . snd) terms
+    searchResults' <- mapM (bimapM return Hoogle.searchModules) searchTerms
+    let searchResults = zip functionNames searchResults'
+    let normalise =
+          concatMap (\(a, b) -> zip (repeat a) (concatTerms b)) searchResults
+
+    concat <$> mapM (uncurry (termToActions style)) normalise
+
+  -- | Apply the search style to given term.
+  -- Can be used to look for a term that matches exactly the search term,
+  -- or one that matches only the exact name.
+  -- At last, a custom relaxation function can be passed for more control.
+  applySearchStyle :: SearchStyle -> T.Text -> T.Text
+  applySearchStyle Exact term = "is:exact " <> term
+  applySearchStyle ExactName term = case T.words term of
+    [] -> term
+    (x : _) -> "is:exact " <> x
+  applySearchStyle (Relax relax) term = relax term
+
+  -- | Turn a search term with function name into Import Actions.
+  -- Function name may be of only the exact phrase to import.
+  -- The resulting CodeAction's contain a general import of a module or
+  -- uses an Import-List.
+  --
+  -- Note, that repeated use of the Import-List will add imports to
+  -- the appropriate import line, e.g. no module import is duplicated, except
+  -- for qualified imports.
+  --
+  -- If the search term is relaxed in a custom way,
+  -- no import list can be offered, since the function name
+  -- may be not the one we expect.
+  termToActions
+    :: SearchStyle -> T.Text -> (J.Diagnostic, T.Text) -> IdeM [J.CodeAction]
+  termToActions style functionName (diagnostic, termName) = do
+    let useImportList = case style of
+          Relax _ -> Nothing
+          _ -> Just (mkImportAction (Just functionName) diagnostic termName)
+    catMaybes <$> sequenceA
+      (mkImportAction Nothing diagnostic termName : maybeToList useImportList)
+
+  concatTerms :: (a, [b]) -> [(a, b)]
+  concatTerms (a, b) = zip (repeat a) b
+
+  --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)]
+
+
+  -- | For a Diagnostic, get an associated function name.
+  -- If Ghc-Mod can not find any candidates, Nothing is returned.
+  getImportables :: J.Diagnostic -> Maybe (J.Diagnostic, T.Text)
+  getImportables diag@(J.Diagnostic _ _ _ (Just "ghcmod") msg _) =
+    (diag, ) <$> extractImportableTerm msg
+  getImportables _ = Nothing
 
+-- | Extract from an error message an appropriate term to search for.
+-- This looks at the error message and tries to extract the expected
+-- signature of an unknown function.
+-- If this is not possible, Nothing is returned.
 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
+  , 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