diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 9d0cbff..3628bd3 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -77,6 +77,9 @@ import System.Directory hiding ( findFiles ) import System.Environment import System.FilePath import System.IO.Error +#if defined(IS_WINDOWS) +import System.IO.Temp +#endif import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.Regex.Posix @@ -249,6 +252,22 @@ installPackedGHC :: ( MonadMask m #endif ] m () installPackedGHC dl msubdir inst ver = do +#if defined(IS_WINDOWS) + lift $ $(logInfo) "Installing GHC (this may take a while)" + + Dirs { tmpDir } <- lift getDirs + unpackDir <- liftIO $ emptyTempFile tmpDir "ghc" + liftIO $ rmFile unpackDir + + liftE $ unpackToDir unpackDir dl + + d <- case msubdir of + Just td -> liftE $ intoSubdir unpackDir td + Nothing -> pure unpackDir + + liftIO $ Win32.moveFileEx d (Just inst) 0 + liftIO $ rmPath unpackDir +#else PlatformRequest {..} <- lift getPlatformReq -- unpack @@ -264,6 +283,7 @@ installPackedGHC dl msubdir inst ver = do liftE $ runBuildAction tmpUnpack (Just inst) (installUnpackedGHC workdir inst ver) +#endif -- | Install an unpacked GHC distribution. This only deals with the GHC @@ -280,13 +300,6 @@ installUnpackedGHC :: ( MonadReader env m -> FilePath -- ^ Path to install to -> Version -- ^ The GHC version -> Excepts '[ProcessError] m () -#if defined(IS_WINDOWS) -installUnpackedGHC path inst _ = do - lift $ $(logInfo) "Installing GHC (this may take a while)" - -- windows bindists are relocatable and don't need - -- to run configure - liftIO $ copyDirectoryRecursive path inst -#else installUnpackedGHC path inst ver = do PlatformRequest {..} <- lift getPlatformReq @@ -309,7 +322,6 @@ installUnpackedGHC path inst ver = do Nothing lEM $ make ["install"] (Just path) pure () -#endif -- | Installs GHC into @~\/.ghcup\/ghc/\@ and places the @@ -1495,6 +1507,7 @@ rmGhcupDirs = do , binDir , logsDir , cacheDir + , tmpDir } <- getDirs let envFilePath = baseDir "env" @@ -1506,6 +1519,7 @@ rmGhcupDirs = do rmDir cacheDir rmDir logsDir rmBinDir binDir + rmDir tmpDir #if defined(IS_WINDOWS) rmDir (baseDir "msys64") #endif diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 79ea220..284b47d 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -384,6 +384,7 @@ data Dirs = Dirs , cacheDir :: FilePath , logsDir :: FilePath , confDir :: FilePath + , tmpDir :: FilePath } deriving (Show, GHC.Generic) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index fe2e4a0..b94b7e3 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -1086,19 +1086,14 @@ ensureGlobalTools = do -- | Ensure ghcup directory structure exists. ensureDirectories :: Dirs -> IO () -ensureDirectories dirs = do - let Dirs - { baseDir - , binDir - , cacheDir - , logsDir - , confDir - } = dirs +ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir tmpDir) = do createDirRecursive' baseDir + createDirRecursive' (baseDir "ghc") createDirRecursive' binDir createDirRecursive' cacheDir createDirRecursive' logsDir createDirRecursive' confDir + createDirRecursive' tmpDir pure () diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index 807bcc4..2bdb524 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -191,6 +191,15 @@ ghcupLogsDir = do #endif +-- | Defaults to '~/.ghcup/tmp. +-- +-- If 'GHCUP_USE_XDG_DIRS' is set (to anything), +-- then uses 'XDG_DATA_HOME/ghcup/tmp' as per xdg spec. +ghcupTmpDir :: IO FilePath +ghcupTmpDir = ghcupBaseDir <&> ( "tmp") + + + getAllDirs :: IO Dirs getAllDirs = do baseDir <- ghcupBaseDir @@ -198,6 +207,7 @@ getAllDirs = do cacheDir <- ghcupCacheDir logsDir <- ghcupLogsDir confDir <- ghcupConfigDir + tmpDir <- ghcupTmpDir pure Dirs { .. }