Clone HsImport API for more fine grained control

Enables to use imports of constructors

Author: fendor

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

@@ -44,10 +44,10 @@ hoogleDescriptor plId = PluginDescriptor
 
 -- ---------------------------------------------------------------------
 
-data HoogleError 
+data HoogleError
   = NoDb
   | DbFail T.Text
-  | NoResults 
+  | NoResults
   deriving (Eq,Ord,Show)
 
 newtype HoogleDb = HoogleDb (Maybe FilePath)

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

@@ -1,24 +1,21 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE LambdaCase #-}
 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 GhcModCore                    as GM ( mkRevRedirMapFunc, withMappedFile )
-import           HsImport
+import qualified HsImport
 import           Haskell.Ide.Engine.Config
 import           Haskell.Ide.Engine.MonadTypes
 import qualified Haskell.Ide.Engine.Support.HieExtras as Hie
@@ -29,6 +26,7 @@ import qualified Haskell.Ide.Engine.Plugin.Hoogle
                                                as Hoogle
 import           System.Directory
 import           System.IO
+import qualified Safe as S
 
 hsimportDescriptor :: PluginId -> PluginDescriptor
 hsimportDescriptor plId = PluginDescriptor
@@ -43,28 +41,70 @@ hsimportDescriptor plId = PluginDescriptor
   , pluginFormattingProvider = Nothing
   }
 
+data SymbolType
+  = Symbol
+  | Constructor
+  | Type
+  deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON)
+
+
+-- | What of the symbol should be taken.
+data SymbolKind
+  = Only  SymbolName -- ^ only the symbol should be taken
+  | AllOf DatatypeName -- ^ all constructors or methods of the symbol should be taken: Symbol(..)
+  | OneOf DatatypeName SymbolName -- ^ some constructors or methods of the symbol should be taken: Symbol(X, Y)
+  deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON)
+
+-- | The imported or from the import hidden symbol.
+data SymbolImport a
+  = Import a -- ^ the symbol to import
+  | Hiding a -- ^ the symbol to hide from the import
+  deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON)
+
+
+extractSymbolImport :: SymbolImport a -> a
+extractSymbolImport (Hiding s) = s
+extractSymbolImport (Import s) = s
+
+type ModuleName = T.Text
+type SymbolName = T.Text
+type DatatypeName = T.Text
+
+data ImportStyle
+    = Simple -- ^ Import the whole module
+    | Complex (SymbolImport SymbolKind) -- ^ Complex operation, import module hiding symbols or import only selected symbols.
+    deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON)
+
+data ImportDiagnostic = ImportDiagnostic
+  { diagnostic :: J.Diagnostic
+  , term :: SymbolName
+  , termType :: SymbolImport SymbolType
+  }
+  deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON)
+
+
 -- | 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 -- ^ 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.
+  { file           :: Uri -- ^ Uri to the file to import the module to.
+  , importStyle    :: ImportStyle -- ^ How to import the module
+  , moduleToImport :: ModuleName -- ^ Name of the module to import.
   }
   deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON)
 
 importCmd :: CommandFunc ImportParams J.WorkspaceEdit
-importCmd = CmdSync $ \(ImportParams uri importList modName) ->
-  importModule uri importList modName
+importCmd = CmdSync $ \(ImportParams uri style modName) ->
+  importModule uri style modName
 
 -- | 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 =
+  :: Uri -> ImportStyle -> ModuleName -> IdeGhcM (IdeResult J.WorkspaceEdit)
+importModule uri impStyle modName =
   pluginGetFile "hsimport cmd: " uri $ \origInput -> do
     shouldFormat <- formatOnImportOn <$> getConfig
     fileMap      <- GM.mkRevRedirMapFunc
@@ -73,13 +113,9 @@ importModule uri importList modName =
       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
-                             }
+      let args = importStyleToHsImportArgs input output modName impStyle
       -- execute hsimport on the given file and write into a temporary file.
-      maybeErr <- liftIO $ hsimportWithArgs defaultConfig args
+      maybeErr <- liftIO $ HsImport.hsimportWithArgs HsImport.defaultConfig args
       case maybeErr of
         Just err -> do
           liftIO $ removeFile output
@@ -153,6 +189,29 @@ importModule uri importList modName =
                     $ IdeResultOk (J.WorkspaceEdit newChanges newDocChanges)
             else return $ IdeResultOk (J.WorkspaceEdit mChanges mDocChanges)
 
+importStyleToHsImportArgs
+  :: FilePath -> FilePath -> ModuleName -> ImportStyle -> HsImport.HsImportArgs
+importStyleToHsImportArgs input output modName style =
+  let defaultArgs =
+        HsImport.defaultArgs { HsImport.moduleName = T.unpack modName
+                             , HsImport.inputSrcFile = input
+                             , HsImport.outputSrcFile = output
+                             }
+      kindToArgs kind = case kind of
+        Only sym     -> defaultArgs { HsImport.symbolName = T.unpack sym }
+        OneOf dt sym -> defaultArgs { HsImport.symbolName = T.unpack dt
+                                    , HsImport.with = [T.unpack sym]
+                                    }
+        AllOf dt     -> defaultArgs { HsImport.symbolName = T.unpack dt
+                                    , HsImport.all = True
+                                    }
+  in case style of
+       Simple    -> defaultArgs
+       Complex s -> case s of
+         Hiding kind -> kindToArgs kind {- TODO: wait for hsimport version bump -}
+         Import kind -> kindToArgs kind
+
+
 -- | 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.
@@ -188,28 +247,23 @@ codeActionProvider plId docId _ context = do
   --
   -- 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
+    :: SearchStyle -> [ImportDiagnostic] -> IdeM [J.CodeAction]
+  importActionsForTerms style importDiagnostics = do
+    let searchTerms   = map (applySearchStyle style . term) importDiagnostics
+    searchResults <- mapM Hoogle.searchModules searchTerms
+    let importTerms = zip searchResults importDiagnostics
+    concat <$> mapM (uncurry (termToActions style)) importTerms
 
   -- | 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
+  applySearchStyle Exact termName = "is:exact " <> termName
+  applySearchStyle ExactName termName = case T.words termName of
+    [] -> termName
     (x : _) -> "is:exact " <> x
-  applySearchStyle (Relax relax) term = relax term
+  applySearchStyle (Relax relax) termName = relax termName
 
   -- | Turn a search term with function name into Import Actions.
   -- Function name may be of only the exact phrase to import.
@@ -224,55 +278,121 @@ codeActionProvider plId docId _ context = do
   -- 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)
+    :: SearchStyle -> [ModuleName] -> ImportDiagnostic -> IdeM [J.CodeAction]
+  termToActions style modules impDiagnostic =
+    concat <$> mapM (importModuleAction style impDiagnostic) modules
+
+  importModuleAction
+    :: SearchStyle -> ImportDiagnostic -> ModuleName -> IdeM [J.CodeAction]
+  importModuleAction searchStyle impDiagnostic moduleName =
+    catMaybes <$> sequenceA codeActions
+    where
+      importListActions :: [IdeM (Maybe J.CodeAction)]
+      importListActions = case searchStyle of
+        Relax _ -> []
+        _       -> catMaybes
+          $ case extractSymbolImport $ termType impDiagnostic of
+            Symbol
+              -> [ mkImportAction moduleName impDiagnostic . Just . Only
+                     <$> symName (term impDiagnostic)
+                ]
+            Constructor
+              -> [ mkImportAction moduleName impDiagnostic . Just . AllOf
+                     <$> datatypeName (term impDiagnostic)
+                 , (\dt sym -> mkImportAction moduleName impDiagnostic . Just
+                    $ OneOf dt sym)
+                     <$> datatypeName (term impDiagnostic)
+                     <*> symName (term impDiagnostic)
+                 ]
+            Type
+              -> [ mkImportAction moduleName impDiagnostic . Just . Only
+                     <$> symName (term impDiagnostic)]
+
+      codeActions :: [IdeM (Maybe J.CodeAction)]
+      codeActions = case termType impDiagnostic of
+        Hiding _ -> []
+        Import _ -> [mkImportAction moduleName impDiagnostic Nothing]
+        ++ importListActions
+
+      signatureOf :: T.Text -> Maybe T.Text
+      signatureOf sig = do
+        let parts =  T.splitOn "::" sig
+        typeSig <- S.tailMay parts
+        S.headMay typeSig
+
+      datatypeName :: T.Text -> Maybe T.Text
+      datatypeName sig = do
+        sig_ <- signatureOf sig
+        let sigParts = T.splitOn "->" sig_
+        lastPart <- S.lastMay sigParts
+        let dtNameSig = T.words lastPart
+        qualifiedDtName <- S.headMay dtNameSig
+        let qualifiedDtNameParts = T.splitOn "." qualifiedDtName
+        S.lastMay qualifiedDtNameParts
+
+      symName :: T.Text -> Maybe SymbolName
+      symName = S.headMay . T.words
 
-  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
+    :: ModuleName -> ImportDiagnostic -> Maybe SymbolKind -> IdeM (Maybe J.CodeAction)
+  mkImportAction modName importDiagnostic symbolType = 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]))
+                                  (Just (J.List [diagnostic importDiagnostic]))
                                   Nothing
                                   (Just cmd)
-    title =
-      "Import module "
-        <> modName
-        <> maybe "" (\name -> " (" <> name <> ")") importList
-    cmdParams = [toJSON (ImportParams (docId ^. J.uri) importList modName)]
+    title = "Import module "
+      <> modName
+      <> case termType importDiagnostic of
+        Hiding _ -> "hiding "
+        Import _ -> ""
+      <> case symbolType of
+        Just s  -> case s of
+          Only sym  -> "(" <> sym <> ")"
+          AllOf dt -> "(" <> dt <> " (..))"
+          OneOf dt sym -> "(" <> dt <> " (" <> sym <> "))"
+        Nothing -> ""
+
+    importStyleParam :: ImportStyle
+    importStyleParam = case symbolType of
+        Nothing -> Simple
+        Just k -> case termType importDiagnostic of
+          Hiding _ -> Complex (Hiding k)
+          Import _ -> Complex (Import k)
+
+    cmdParams = [toJSON (ImportParams (docId ^. J.uri) importStyleParam 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 :: J.Diagnostic -> Maybe ImportDiagnostic
   getImportables diag@(J.Diagnostic _ _ _ (Just "ghcmod") msg _) =
-    (diag, ) <$> extractImportableTerm msg
+    uncurry (ImportDiagnostic 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
-  ]
+extractImportableTerm :: T.Text -> Maybe (T.Text, (SymbolImport SymbolType) )
+extractImportableTerm dirtyMsg =
+  let extractedTerm  =
+        asum
+          [ (\name -> (name, Import Symbol)) <$> T.stripPrefix "Variable not in scope: " importMsg
+          , (\name -> (T.init name, Import Type)) <$> T.stripPrefix "Not in scope: type constructor or class ‘" importMsg
+          , (\name -> (name, Import Constructor)) <$> T.stripPrefix "Data constructor not in scope: " importMsg
+          ]
+  in do
+    (n, s) <- extractedTerm
+    let n' = T.strip n
+    return (n', s)
  where
-  msg =
+  importMsg =
     head
         -- Get rid of the rename suggestion parts
       $ T.splitOn "Perhaps you meant "