diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,14 @@ # ChangeLog hie-bios +## 2021-01-29 - 0.7.3 + +* Set builddir for cabal [#264](https://github.com/mpickering/hie-bios/pull/264) + * Essentially, change the build directory for cabal to the [`XDG_CACHE_HOME`](https://specifications.freedesktop.org/basedir-spec/basedir-spec-latest.html) + directory (e.g. `~/.cache/hie-bios/...`). This way, user + invocations of cabal will no longer trigger a `configure` step, improving + the overall developer experience. +* Optparse-applicative CLI [#276](https://github.com/mpickering/hie-bios/pull/276) + ## 2020-12-16 - 0.7.2 * Faster Bios protocol [#271](https://github.com/mpickering/hie-bios/pull/271) diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,18 +1,14 @@ -{-# LANGUAGE DeriveDataTypeable, LambdaCase #-} +{-# LANGUAGE LambdaCase #-} module Main where import Config (cProjectVersion) -import Control.Exception (Exception, Handler(..), ErrorCall(..)) -import qualified Control.Exception as E import Control.Monad ( forM ) -import Data.Typeable (Typeable) import Data.Version (showVersion) +import Options.Applicative import System.Directory (getCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (exitFailure) -import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8) +import System.IO (stdout, hSetEncoding, utf8) import System.FilePath( () ) import HIE.Bios @@ -25,99 +21,77 @@ progVersion :: String progVersion = "hie-bios version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n" -ghcOptHelp :: String -ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] " +data Command + = Check { checkTargetFiles :: [FilePath] } + | Flags { flagTargetFiles :: [FilePath] } + | Debug { debugComponents :: FilePath } + | ConfigInfo { configFiles :: [FilePath] } + | CradleInfo { cradleFiles :: [FilePath] } + | Root + | Version -usage :: String -usage = progVersion - ++ "Usage:\n" - ++ "\t hie-bios check" ++ ghcOptHelp ++ "\n" - ++ "\t hie-bios expand \n" - ++ "\t hie-bios flags \n" - ++ "\t hie-bios debug []\n" - ++ "\t hie-bios config \n" - ++ "\t hie-bios cradle \n" - ++ "\t hie-bios root\n" - ++ "\t hie-bios version\n" ----------------------------------------------------------------- +filepathParser :: Parser [FilePath] +filepathParser = some (argument str ( metavar "TARGET_FILES...")) -data HhpcError = SafeList - | TooManyArguments String - | NotEnoughArguments String - | NoSuchCommand String - | CmdArg [String] - | FileNotExist String deriving (Show, Typeable) +progInfo :: ParserInfo Command +progInfo = info (progParser <**> helper) + ( fullDesc + <> progDesc "hie-bios is the way to specify how haskell-language-server and ghcide set up a GHC API session.\ + \Delivers the full set of flags to pass to GHC in order to build the project." + <> header progVersion + <> footer "You can report issues/contribute at https://github.com/mpickering/hie-bios") -instance Exception HhpcError +progParser :: Parser Command +progParser = subparser + (command "check" (info (Check <$> filepathParser) (progDesc "Try to load modules into the GHC API.")) + <> command "flags" (info (Flags <$> filepathParser) (progDesc "Print out the options that hie-bios thinks you will need to load a file.")) + <> command "debug" (info (Debug <$> argument str ( metavar "TARGET_FILES...")) (progDesc "Print out the options that hie-bios thinks you will need to load a file.")) + <> command "config" (info (ConfigInfo <$> filepathParser) (progDesc "Print out the cradle config.")) + <> command "cradle" (info (CradleInfo <$> filepathParser) (progDesc ".")) + <> command "root" (info (pure Root) (progDesc "Display the path towards the selected hie.yaml.")) + <> command "version" (info (pure Version) (progDesc "Print version and exit.")) + ) + ---------------------------------------------------------------- main :: IO () -main = flip E.catches handlers $ do +main = do hSetEncoding stdout utf8 - args <- getArgs cwd <- getCurrentDirectory cradle <- -- find cradle does a takeDirectory on the argument, so make it into a file findCradle (cwd "File.hs") >>= \case Just yaml -> loadCradle yaml Nothing -> loadImplicitCradle (cwd "File.hs") - let cmdArg0 = args !. 0 - remainingArgs = tail args - res <- case cmdArg0 of - "check" -> checkSyntax cradle remainingArgs - "debug" - | null remainingArgs -> debugInfo (cradleRootDir cradle) cradle - | (fp:_) <- remainingArgs -> debugInfo fp cradle - "root" -> rootInfo cradle - "version" -> return progVersion - "config" -> configInfo remainingArgs - "cradle" -> cradleInfo remainingArgs - "flags" - | null remainingArgs -> E.throw $ NotEnoughArguments cmdArg0 - | otherwise -> do - res <- forM remainingArgs $ \fp -> do - res <- getCompilerOptions fp cradle - case res of - CradleFail (CradleError _deps _ex err) -> - return $ "Failed to show flags for \"" - ++ fp - ++ "\": " ++ show err - CradleSuccess opts -> - return $ unlines ["Options: " ++ show (componentOptions opts) - ,"ComponentDir: " ++ (componentRoot opts) - ,"Dependencies: " ++ show (componentDependencies opts) ] - CradleNone -> return "No flags: this component should not be loaded" - return (unlines res) - "help" -> return usage - "--help" -> return usage - "-h" -> return usage + cmd <- execParser progInfo - cmd -> E.throw (NoSuchCommand cmd) + res <- case cmd of + Check targetFiles -> checkSyntax cradle targetFiles + Debug files -> case files of + [] -> debugInfo (cradleRootDir cradle) cradle + fp -> debugInfo fp cradle + Flags files -> case files of + -- TODO force optparse to acquire one + [] -> error "too few arguments" + _ -> do + res <- forM files $ \fp -> do + res <- getCompilerOptions fp cradle + case res of + CradleFail (CradleError _deps _ex err) -> + return $ "Failed to show flags for \"" + ++ fp + ++ "\": " ++ show err + CradleSuccess opts -> + return $ unlines ["Options: " ++ show (componentOptions opts) + ,"ComponentDir: " ++ componentRoot opts + ,"Dependencies: " ++ show (componentDependencies opts) ] + CradleNone -> return $ "No flags/None Cradle: component " ++ fp ++ " should not be loaded" + return (unlines res) + ConfigInfo files -> configInfo files + CradleInfo files -> cradleInfo files + Root -> rootInfo cradle + Version -> return progVersion putStr res - where - handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)] - handleThenExit handler e = handler e >> exitFailure - handler1 :: ErrorCall -> IO () - handler1 = print -- for debug - handler2 :: HhpcError -> IO () - handler2 SafeList = hPutStr stderr usage - handler2 (TooManyArguments cmd) = - hPutStrLn stderr $ "\"" ++ cmd ++ "\": Too many arguments" - handler2 (NotEnoughArguments cmd) = do - hPutStrLn stderr $ "\"" ++ cmd ++ "\": Not enough arguments" - hPutStrLn stderr "" - hPutStr stderr usage - handler2 (NoSuchCommand cmd) = do - hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported" - hPutStrLn stderr "" - hPutStr stderr usage - handler2 (CmdArg errs) = - mapM_ (hPutStr stderr) errs - handler2 (FileNotExist file) = - hPutStrLn stderr $ "\"" ++ file ++ "\" not found" - xs !. idx - | length xs <= idx = E.throw SafeList - | otherwise = xs !! idx diff --git a/hie-bios.cabal b/hie-bios.cabal --- a/hie-bios.cabal +++ b/hie-bios.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: hie-bios -Version: 0.7.2 +Version: 0.7.3 Author: Matthew Pickering Maintainer: Matthew Pickering License: BSD-3-Clause @@ -148,13 +148,13 @@ base >= 4.8 && < 5, aeson >= 1.4.5 && < 2, base16-bytestring >= 0.1.1 && < 1.1, - bytestring >= 0.10.8 && < 0.11, + bytestring >= 0.10.8 && < 0.12, deepseq >= 1.4.3 && < 1.5, containers >= 0.5.10 && < 0.7, cryptohash-sha1 >= 0.11.100 && < 0.12, directory >= 1.3.0 && < 1.4, filepath >= 1.4.1 && < 1.5, - time >= 1.8.0 && < 1.10, + time >= 1.8.0 && < 1.12, extra >= 1.6.14 && < 1.8, process >= 1.6.1 && < 1.7, ghc >= 8.4.1 && < 8.11, @@ -182,6 +182,7 @@ , filepath , ghc , hie-bios + , optparse-applicative test-suite parser-tests type: exitcode-stdio-1.0 diff --git a/src/HIE/Bios/Cradle.hs b/src/HIE/Bios/Cradle.hs --- a/src/HIE/Bios/Cradle.hs +++ b/src/HIE/Bios/Cradle.hs @@ -26,6 +26,7 @@ import Control.Exception (handleJust) import qualified Data.Yaml as Yaml import Data.Void +import Data.Char (isSpace) import System.Process import System.Exit import HIE.Bios.Types hiding (ActionName(..)) @@ -407,15 +408,14 @@ { actionName = Types.Cabal , runCradle = cabalAction wdir mc , runGhcCmd = \args -> do + buildDir <- cabalBuildDir wdir -- Workaround for a cabal-install bug on 3.0.0.0: -- ./dist-newstyle/tmp/environment.-24811: createDirectory: does not exist (No such file or directory) - -- (It's ok to pass 'dist-newstyle' here, as it can only be changed - -- with the --builddir flag and not cabal.project, which we aren't - -- using in our call to v2-exec) - createDirectoryIfMissing True (wdir "dist-newstyle" "tmp") + createDirectoryIfMissing True (buildDir "tmp") -- Need to pass -v0 otherwise we get "resolving dependencies..." + wrapper_fp <- withCabalWrapperTool ("ghc", []) wdir readProcessWithCwd - wdir "cabal" (["v2-exec", "ghc", "-v0", "--"] ++ args) "" + wdir "cabal" (["--builddir="<>buildDir,"v2-exec","--with-compiler", wrapper_fp, "ghc", "-v0", "--"] ++ args) "" } } @@ -464,40 +464,45 @@ -- | Generate a fake GHC that can be passed to cabal -- when run with --interactive, it will print out its -- command-line arguments and exit -withCabalWrapperTool :: GhcProc -> FilePath -> (FilePath -> IO a) -> IO a -withCabalWrapperTool (mbGhc, ghcArgs) wdir k = do - if isWindows - then do - cacheDir <- getCacheDir "" - let srcHash = show (fingerprintString cabalWrapperHs) - let wrapper_name = "wrapper-" ++ srcHash - let wrapper_fp = cacheDir wrapper_name <.> "exe" - exists <- doesFileExist wrapper_fp - unless exists $ withSystemTempDirectory "hie-bios" $ \ tmpDir -> do +withCabalWrapperTool :: GhcProc -> FilePath -> IO FilePath +withCabalWrapperTool (mbGhc, ghcArgs) wdir = do + cacheDir <- getCacheDir "" + let wrapperContents = if isWindows then cabalWrapperHs else cabalWrapper + suffix fp = if isWindows then fp <.> "exe" else fp + let srcHash = show (fingerprintString wrapperContents) + let wrapper_name = "wrapper-" ++ srcHash + let wrapper_fp = suffix $ cacheDir wrapper_name + exists <- doesFileExist wrapper_fp + unless exists $ + if isWindows + then do + withSystemTempDirectory "hie-bios" $ \ tmpDir -> do createDirectoryIfMissing True cacheDir let wrapper_hs = cacheDir wrapper_name <.> "hs" - writeFile wrapper_hs cabalWrapperHs + writeFile wrapper_hs wrapperContents let ghc = (proc mbGhc $ ghcArgs ++ ["-rtsopts=ignore", "-outputdir", tmpDir, "-o", wrapper_fp, wrapper_hs]) { cwd = Just wdir } readCreateProcess ghc "" >>= putStr - setMode wrapper_fp - k wrapper_fp - else withSystemTempFile "bios-wrapper" - (\loc h -> do - hPutStr h cabalWrapper - hClose h - setMode loc - k loc) - + else withFile wrapper_fp WriteMode $ \h -> hPutStr h wrapperContents + setMode wrapper_fp + pure wrapper_fp where setMode wrapper_fp = setFileMode wrapper_fp accessModes +-- | Given the root directory, get the build dir we are using for cabal +-- In the `hie-bios` cache directory +cabalBuildDir :: FilePath -> IO FilePath +cabalBuildDir work_dir = do + abs_work_dir <- makeAbsolute work_dir + let dirHash = show (fingerprintString abs_work_dir) + getCacheDir ("dist-"<>filter (not . isSpace) (takeBaseName abs_work_dir)<>"-"<>dirHash) cabalAction :: FilePath -> Maybe String -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions) cabalAction work_dir mc l fp = do - withCabalWrapperTool ("ghc", []) work_dir $ \wrapper_fp -> do - let cab_args = ["v2-repl", "--with-compiler", wrapper_fp, fromMaybe (fixTargetPath fp) mc] + wrapper_fp <- withCabalWrapperTool ("ghc", []) work_dir + buildDir <- cabalBuildDir work_dir + let cab_args = ["--builddir="<>buildDir,"v2-repl", "--with-compiler", wrapper_fp, fromMaybe (fixTargetPath fp) mc] (ex, output, stde, [(_,mb_args)]) <- readProcessWithOutputs [hie_bios_output] l work_dir (proc "cabal" cab_args) let args = fromMaybe [] mb_args @@ -622,38 +627,38 @@ stackAction work_dir mc syaml l _fp = do let ghcProcArgs = ("stack", stackYamlProcessArgs syaml <> ["exec", "ghc", "--"]) -- Same wrapper works as with cabal - withCabalWrapperTool ghcProcArgs work_dir $ \wrapper_fp -> do - (ex1, _stdo, stde, [(_, mb_args)]) <- - readProcessWithOutputs [hie_bios_output] l work_dir $ - stackProcess syaml - $ ["repl", "--no-nix-pure", "--with-ghc", wrapper_fp] - <> [ comp | Just comp <- [mc] ] - (ex2, pkg_args, stdr, _) <- - readProcessWithOutputs [hie_bios_output] l work_dir $ - stackProcess syaml ["path", "--ghc-package-path"] - let split_pkgs = concatMap splitSearchPath pkg_args - pkg_ghc_args = concatMap (\p -> ["-package-db", p] ) split_pkgs - args = fromMaybe [] mb_args - case processCabalWrapperArgs args of - Nothing -> do - -- Best effort. Assume the working directory is the - -- the root of the component, so we are right in trivial cases at least. - deps <- stackCradleDependencies work_dir work_dir syaml - pure $ CradleFail - (CradleError deps ex1 $ - [ "Failed to parse result of calling stack" ] - ++ stde - ++ args - ) + wrapper_fp <- withCabalWrapperTool ghcProcArgs work_dir + (ex1, _stdo, stde, [(_, mb_args)]) <- + readProcessWithOutputs [hie_bios_output] l work_dir $ + stackProcess syaml + $ ["repl", "--no-nix-pure", "--with-ghc", wrapper_fp] + <> [ comp | Just comp <- [mc] ] + (ex2, pkg_args, stdr, _) <- + readProcessWithOutputs [hie_bios_output] l work_dir $ + stackProcess syaml ["path", "--ghc-package-path"] + let split_pkgs = concatMap splitSearchPath pkg_args + pkg_ghc_args = concatMap (\p -> ["-package-db", p] ) split_pkgs + args = fromMaybe [] mb_args + case processCabalWrapperArgs args of + Nothing -> do + -- Best effort. Assume the working directory is the + -- the root of the component, so we are right in trivial cases at least. + deps <- stackCradleDependencies work_dir work_dir syaml + pure $ CradleFail + (CradleError deps ex1 $ + [ "Failed to parse result of calling stack" ] + ++ stde + ++ args + ) - Just (componentDir, ghc_args) -> do - deps <- stackCradleDependencies work_dir componentDir syaml - pure $ makeCradleResult - ( combineExitCodes [ex1, ex2] - , stde ++ stdr, componentDir - , ghc_args ++ pkg_ghc_args - ) - deps + Just (componentDir, ghc_args) -> do + deps <- stackCradleDependencies work_dir componentDir syaml + pure $ makeCradleResult + ( combineExitCodes [ex1, ex2] + , stde ++ stdr, componentDir + , ghc_args ++ pkg_ghc_args + ) + deps stackProcess :: StackYaml -> [String] -> CreateProcess stackProcess syaml args = proc "stack" $ stackYamlProcessArgs syaml <> args diff --git a/src/HIE/Bios/Ghc/Check.hs b/src/HIE/Bios/Ghc/Check.hs --- a/src/HIE/Bios/Ghc/Check.hs +++ b/src/HIE/Bios/Ghc/Check.hs @@ -41,7 +41,7 @@ where handleRes (CradleSuccess x) f = f x handleRes (CradleFail ce) _f = liftIO $ throwIO ce - handleRes CradleNone _f = return "No cradle" + handleRes CradleNone _f = return "None cradle" ---------------------------------------------------------------- diff --git a/wrappers/cabal.hs b/wrappers/cabal.hs --- a/wrappers/cabal.hs +++ b/wrappers/cabal.hs @@ -9,9 +9,9 @@ main :: IO () main = do args <- getArgs - output_file <- getEnv "HIE_BIOS_OUTPUT" case args of "--interactive":_ -> do + output_file <- getEnv "HIE_BIOS_OUTPUT" h <- openFile output_file AppendMode getCurrentDirectory >>= hPutStrLn h mapM_ (hPutStrLn h) args