From 03f2935eab0835fbc663c230196bc1c373cbe76d Mon Sep 17 00:00:00 2001 From: fendor Date: Thu, 2 Jan 2020 21:48:41 +0100 Subject: [PATCH] Query for data-files and download them on-the-fly --- haskell-ide-engine.cabal | 1 + src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs | 130 ++++++++++++++++++- src/Haskell/Ide/Engine/Server.hs | 22 ++++ 3 files changed, 146 insertions(+), 7 deletions(-) diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index 18ed3094f..98ea9ad4c 100644 --- a/haskell-ide-engine.cabal +++ b/haskell-ide-engine.cabal @@ -88,6 +88,7 @@ library , stm , syb , tagsoup + , temporary , text , transformers , unix-time >= 0.4.7 diff --git a/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs b/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs index 72ad9859c..ba8f6bdf5 100644 --- a/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs +++ b/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} -- | apply-refact applies refactorings specified by the refact package. It is -- currently integrated into hlint to enable the automatic application of @@ -17,6 +20,7 @@ import Control.Exception ( IOException import Control.Lens hiding ( List ) import Control.Monad.IO.Class import Control.Monad.Trans.Except +import Control.Monad ( filterM, forM_ ) import Data.Aeson hiding (Error) import Data.Maybe import Data.Monoid ((<>)) @@ -32,6 +36,18 @@ import Language.Haskell.HLint4 as Hlint import qualified Language.Haskell.LSP.Types as LSP import qualified Language.Haskell.LSP.Types.Lens as LSP import Refact.Apply +import System.Environment ( lookupEnv ) +import System.Directory ( doesFileExist + , getXdgDirectory + , XdgDirectory(..) + , findExecutable + , listDirectory + , copyFile + ) +import System.FilePath ( () ) +import System.Process +import System.IO.Temp ( withSystemTempDirectory ) +import System.Exit ( ExitCode(..) ) -- --------------------------------------------------------------------- {-# ANN module ("HLint: ignore Eta reduce" :: String) #-} @@ -106,6 +122,103 @@ applyAllCmd uri = pluginGetFile "applyAll: " uri $ \fp -> do -- --------------------------------------------------------------------- +newtype HlintDataDir = HlintDataDir + { getHlintDataDir :: Maybe FilePath + } + deriving (Show, Eq, Read, Ord) + + +instance ExtensionClass HlintDataDir where + initialValue = HlintDataDir Nothing + +data InitialisationError + = NoDataFiles FilePath + | InvalidDataDir FilePath + | Other + +ppInitialisationError :: InitialisationError -> String +ppInitialisationError (NoDataFiles fp) = + "We could not find the data-files at: \"" <> fp <> "\"" +ppInitialisationError (InvalidDataDir fp) = + "The location \"" + <> fp + <> "\" does not exist. We obtained that location from the environment variable: " + <> hlintDataDirEnvironmentVariable +ppInitialisationError Other = "We could not determine why it failed." + +data Tool = Stack | Cabal + +showTool :: Tool -> String +showTool Stack = "stack" +showTool Cabal = "cabal" + +hlintName :: String +hlintName = "hlint-" ++ VERSION_hlint + +hlintDataDirDefaultLocation :: MonadIO m => m FilePath +hlintDataDirDefaultLocation = liftIO $ getXdgDirectory XdgData ("hie" "hlint") + +hlintDataDirEnvironmentVariable :: String +hlintDataDirEnvironmentVariable = "HIE_HLINT_DATADIR" + +initializeHlint :: IdeGhcM (Either InitialisationError FilePath) +initializeHlint = do + explicitDataDirLocation <- liftIO $ lookupEnv hlintDataDirEnvironmentVariable + hieHlintDataDir <- hlintDataDirDefaultLocation + dataDirExists <- liftIO (doesFileExist hieHlintDataDir) + result <- case explicitDataDirLocation of + Just explicitDir -> do + liftIO (doesFileExist explicitDir) + >>= \case + True -> + return $ Right explicitDir + False -> + return $ Left $ InvalidDataDir explicitDir + Nothing -> + if dataDirExists + then return $ Right hieHlintDataDir + else return $ Left $ NoDataFiles hieHlintDataDir + + case result of + Right dataDir -> put $ HlintDataDir $ Just dataDir + _ -> return () + + return result + +downloadHlintDatafiles :: IO () +downloadHlintDatafiles = do + defaultLocation <- hlintDataDirDefaultLocation + availTools <- liftIO + $ filterM (fmap isJust . findExecutable . showTool) [Stack, Cabal] + case availTools of + [] -> return () + tool : _ -> withSystemTempDirectory "hie-hlint-datafiles" $ \tmpDir -> do + let toolArgs t = case t of + Cabal -> ["get", hlintName] + Stack -> ["unpack", hlintName] + + let process = + (proc (showTool tool) (toolArgs tool)) { cwd = Just tmpDir } + + (exitCode, _sout, _serr) <- liftIO + $ readCreateProcessWithExitCode process "" + + case exitCode of + ExitFailure _ -> + error + $ "Command `" + ++ unwords (showTool tool : toolArgs tool) + ++ "` failed." + ExitSuccess -> do + let dirPath = tmpDir hlintName "data" + dataFiles <- liftIO $ listDirectory dirPath + forM_ dataFiles + $ \dataFile -> do + let absoluteFile = dirPath dataFile + logm $ "Copy File \"" ++ absoluteFile ++ "\" to \"" ++ defaultLocation ++ "\"" + liftIO $ copyFile absoluteFile defaultLocation + + -- AZ:TODO: Why is this in IdeGhcM? lint :: Uri -> IdeGhcM (IdeResult PublishDiagnosticsParams) lint uri = pluginGetFile "lint: " uri $ \fp -> do @@ -238,8 +351,9 @@ ss2Range ss = Range ps pe applyHint :: FilePath -> Maybe OneHint -> (FilePath -> FilePath) -> IdeM (Either String WorkspaceEdit) applyHint fp mhint fileMap = do + dataDir :: HlintDataDir <- get runExceptT $ do - ideas <- getIdeas fp mhint + ideas <- getIdeas dataDir fp mhint let commands = map (show &&& ideaRefactoring) ideas liftIO $ logm $ "applyHint:apply=" ++ show commands -- set Nothing as "position" for "applyRefactorings" because @@ -270,9 +384,9 @@ applyHint fp mhint fileMap = do throwE (show err) -- | Gets HLint ideas for -getIdeas :: MonadIO m => FilePath -> Maybe OneHint -> ExceptT String m [Idea] -getIdeas lintFile mhint = do - let hOpts = hlintOpts lintFile (oneHintPos <$> mhint) +getIdeas :: MonadIO m => HlintDataDir -> FilePath -> Maybe OneHint -> ExceptT String m [Idea] +getIdeas dataDir lintFile mhint = do + let hOpts = hlintOpts dataDir lintFile (oneHintPos <$> mhint) ideas <- runHlint lintFile hOpts pure $ maybe ideas (`filterIdeas` ideas) mhint @@ -285,12 +399,14 @@ filterIdeas (OneHint (Position l c) title) ideas = ideaPos = (srcSpanStartLine &&& srcSpanStartColumn) . ideaSpan in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas -hlintOpts :: FilePath -> Maybe Position -> [String] -hlintOpts lintFile mpos = +hlintOpts :: HlintDataDir -> FilePath -> Maybe Position -> [String] +hlintOpts dataDir lintFile mpos = let posOpt (Position l c) = " --pos " ++ show (l+1) ++ "," ++ show (c+1) opts = maybe "" posOpt mpos - in [lintFile, "--quiet", "--refactor", "--refactor-options=" ++ opts ] + in [ lintFile, "--quiet", "--refactor", "--refactor-options=" ++ opts + ] + ++ [ "--datadir=" <> dir | HlintDataDir (Just dir) <- [dataDir] ] runHlint :: MonadIO m => FilePath -> [String] -> ExceptT String m [Idea] runHlint fp args = diff --git a/src/Haskell/Ide/Engine/Server.hs b/src/Haskell/Ide/Engine/Server.hs index b6407d5f1..e4f612886 100644 --- a/src/Haskell/Ide/Engine/Server.hs +++ b/src/Haskell/Ide/Engine/Server.hs @@ -457,7 +457,29 @@ reactor inp diagIn = do callback (Just db) = flip runReaderT renv $ do reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtLog $ "Using hoogle db at: " <> T.pack db + + let hlintReq = GReq tn "init-hlint" Nothing Nothing Nothing + hlintCallback (Left ApplyRefact.Other) $ do + logm "Initialise hlint" + res <- ApplyRefact.initializeHlint + logm $ "Finished hlint initialisation: " ++ either ApplyRefact.ppInitialisationError show res + return $ IdeResultOk res + + hlintCallback :: Either ApplyRefact.InitialisationError FilePath -> R () + hlintCallback (Left err) = flip runReaderT renv $ do + reactorSend + $ NotShowMessage + $ fmServerShowMessageNotification J.MtWarning + $ "Required HLint files are missing: " <> T.pack (ApplyRefact.ppInitialisationError err) + logm "Downloading hlint data-files now." + liftIO ApplyRefact.downloadHlintDatafiles + logm "Finished downloading." + hlintCallback (Right dataDir) = flip runReaderT renv $ + reactorSend $ NotShowMessage $ + fmServerShowMessageNotification J.MtLog $ "Using hlint data-files at: " <> T.pack dataDir + makeRequest hreq + makeRequest hlintReq -- -------------------------------