Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Clean up hie-bios wrapper scripts after they are used #179

Merged
merged 1 commit into from
May 7, 2020
Merged

Clean up hie-bios wrapper scripts after they are used #179

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
115 changes: 61 additions & 54 deletions src/HIE/Bios/Cradle.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -390,45 +390,53 @@ type GhcProc = (FilePath, [String])
-- generate a fake GHC that can be passed to cabal
-- when run with --interactive, it will print out its
-- command-line arguments and exit
getCabalWrapperTool :: GhcProc -> FilePath -> IO FilePath
getCabalWrapperTool (ghcPath, ghcArgs) wdir = do
wrapper_fp <-
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
createDirectoryIfMissing True cacheDir
let wrapper_hs = cacheDir </> wrapper_name <.> "hs"
writeFile wrapper_hs cabalWrapperHs
let ghc = (proc ghcPath $
ghcArgs ++ ["-rtsopts=ignore", "-outputdir", tmpDir, "-o", wrapper_fp, wrapper_hs])
{ cwd = Just wdir }
readCreateProcess ghc "" >>= putStr
return wrapper_fp
else writeSystemTempFile "bios-wrapper" cabalWrapper
withCabalWrapperTool :: GhcProc -> FilePath -> (FilePath -> IO a) -> IO a
withCabalWrapperTool (ghcPath, 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
createDirectoryIfMissing True cacheDir
let wrapper_hs = cacheDir </> wrapper_name <.> "hs"
writeFile wrapper_hs cabalWrapperHs
let ghc = (proc ghcPath $
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)

where
setMode wrapper_fp = do
setFileMode wrapper_fp accessModes
_check <- readFile wrapper_fp
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Should we just delete that?

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think we could, I had a look at where it was introduced and it used to print out the cradle to stderr after writing it to the file. That was modified when we started using a proper executable on windows to get the arguments.

return ()

setFileMode wrapper_fp accessModes
_check <- readFile wrapper_fp
return wrapper_fp

cabalAction :: FilePath -> Maybe String -> LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)
cabalAction work_dir mc l fp = do
wrapper_fp <- getCabalWrapperTool ("ghc", []) work_dir
let cab_args = ["v2-repl", "--with-compiler", wrapper_fp, fromMaybe (fixTargetPath fp) mc]
(ex, output, stde, args) <-
readProcessWithOutputFile l Nothing work_dir "cabal" cab_args
deps <- cabalCradleDependencies work_dir
case processCabalWrapperArgs args of
Nothing -> pure $ CradleFail (CradleError ex
["Failed to parse result of calling cabal"
, unlines output
, unlines stde
, unlines args])
Just (componentDir, final_args) -> pure $ makeCradleResult (ex, stde, componentDir, final_args) deps
withCabalWrapperTool ("ghc", []) work_dir $ \wrapper_fp -> do
let cab_args = ["v2-repl", "--with-compiler", wrapper_fp, fromMaybe (fixTargetPath fp) mc]
(ex, output, stde, args) <-
readProcessWithOutputFile l Nothing work_dir "cabal" cab_args
deps <- cabalCradleDependencies work_dir
case processCabalWrapperArgs args of
Nothing -> pure $ CradleFail (CradleError ex
["Failed to parse result of calling cabal"
, unlines output
, unlines stde
, unlines args])
Just (componentDir, final_args) -> pure $ makeCradleResult (ex, stde, componentDir, final_args) deps
where
-- Need to make relative on Windows, due to a Cabal bug with how it
-- parses file targets with a C: drive in it
Expand Down Expand Up @@ -480,25 +488,24 @@ stackAction :: FilePath -> Maybe String -> LoggingFunction -> FilePath -> IO (Cr
stackAction work_dir mc l _fp = do
let ghcProcArgs = ("stack", ["exec", "ghc", "--"])
-- Same wrapper works as with cabal
wrapper_fp <- getCabalWrapperTool ghcProcArgs work_dir

(ex1, _stdo, stde, args) <-
readProcessWithOutputFile l Nothing work_dir
"stack" $ ["repl", "--no-nix-pure", "--with-ghc", wrapper_fp]
++ [ comp | Just comp <- [mc] ]
(ex2, pkg_args, stdr, _) <-
readProcessWithOutputFile l Nothing work_dir "stack" ["path", "--ghc-package-path"]
let split_pkgs = concatMap splitSearchPath pkg_args
pkg_ghc_args = concatMap (\p -> ["-package-db", p] ) split_pkgs
deps <- stackCradleDependencies work_dir
return $ case processCabalWrapperArgs args of
Nothing -> CradleFail (CradleError ex1 $
("Failed to parse result of calling stack":
stde)
++ args)

Just (componentDir, ghc_args) ->
makeCradleResult (combineExitCodes [ex1, ex2], stde ++ stdr, componentDir, ghc_args ++ pkg_ghc_args) deps
withCabalWrapperTool ghcProcArgs work_dir $ \wrapper_fp -> do
(ex1, _stdo, stde, args) <-
readProcessWithOutputFile l Nothing work_dir
"stack" $ ["repl", "--no-nix-pure", "--with-ghc", wrapper_fp]
++ [ comp | Just comp <- [mc] ]
(ex2, pkg_args, stdr, _) <-
readProcessWithOutputFile l Nothing work_dir "stack" ["path", "--ghc-package-path"]
let split_pkgs = concatMap splitSearchPath pkg_args
pkg_ghc_args = concatMap (\p -> ["-package-db", p] ) split_pkgs
deps <- stackCradleDependencies work_dir
return $ case processCabalWrapperArgs args of
Nothing -> CradleFail (CradleError ex1 $
("Failed to parse result of calling stack":
stde)
++ args)

Just (componentDir, ghc_args) ->
makeCradleResult (combineExitCodes [ex1, ex2], stde ++ stdr, componentDir, ghc_args ++ pkg_ghc_args) deps

combineExitCodes :: [ExitCode] -> ExitCode
combineExitCodes = foldr go ExitSuccess
Expand Down