Only query directories once

lib/GHCup/Types.hs

@@ -158,14 +158,25 @@ data URLSource = GHCupURL
 
 
 data Settings = Settings
-  { cache      :: Bool
+  { -- * set by user
+    cache      :: Bool
   , noVerify   :: Bool
   , keepDirs   :: KeepDirs
   , downloader :: Downloader
   , verbose    :: Bool
+
+    -- * set on app start
+  , dirs       :: Dirs
   }
   deriving Show
 
+data Dirs = Dirs
+  { baseDir  :: Path Abs
+  , binDir   :: Path Abs
+  , cacheDir :: Path Abs
+  , logsDir  :: Path Abs
+  }
+  deriving Show
 
 data KeepDirs = Always
               | Errors

lib/GHCup/Utils.hs

@@ -576,24 +576,18 @@ runBuildAction :: (Show (V e), MonadReader Settings m, MonadIO m, MonadMask m)
                -> Excepts '[BuildFailed] m a
 runBuildAction bdir instdir action = do
   Settings {..} <- lift ask
-  v <- flip
+  let exAction = do
-      onException
-      (do
         forM_ instdir $ \dir ->
           liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
         when (keepDirs == Never)
           $ liftIO
           $ hideError doesNotExistErrorType
           $ deleteDirRecursive bdir
-      )
+  v <-
+    flip onException exAction
     $ catchAllE
         (\es -> do
-          forM_ instdir $ \dir ->
+          exAction
-            liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
-          when (keepDirs == Never)
-            $ liftIO
-            $ hideError doesNotExistErrorType
-            $ deleteDirRecursive bdir
           throwE (BuildFailed bdir es)
         )
     $ action

lib/GHCup/Utils/Dirs.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE QuasiQuotes           #-}
 {-# LANGUAGE ViewPatterns          #-}
 
@@ -11,7 +12,16 @@ Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : POSIX
 -}
-module GHCup.Utils.Dirs where
+module GHCup.Utils.Dirs
+  ( getDirs
+  , ghcupGHCBaseDir
+  , ghcupGHCDir
+  , parseGHCupGHCDir
+  , mkGhcupTmpDir
+  , withGHCupTmpDir
+  , relativeSymlink
+  )
+where
 
 
 import           GHCup.Types
@@ -36,7 +46,7 @@ import           Prelude                 hiding ( abs
 import           System.Posix.Env.ByteString    ( getEnv
                                                 , getEnvDefault
                                                 )
-import           System.Posix.FilePath  hiding  ( (</>) )
+import           System.Posix.FilePath   hiding ( (</>) )
 import           System.Posix.Temp.ByteString   ( mkdtemp )
 
 import qualified Data.ByteString.UTF8          as UTF8
@@ -47,9 +57,9 @@ import qualified Text.Megaparsec               as MP
 
 
 
-    -------------------------
+    ------------------------------
-    --[ GHCup directories ]--
+    --[ GHCup base directories ]--
-    -------------------------
+    ------------------------------
 
 
 -- | ~/.ghcup by default
@@ -74,29 +84,6 @@ ghcupBaseDir = do
       pure (bdir </> [rel|.ghcup|])
 
 
--- | ~/.ghcup/ghc by default.
-ghcupGHCBaseDir :: IO (Path Abs)
-ghcupGHCBaseDir = ghcupBaseDir <&> (</> [rel|ghc|])
-
-
--- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
--- The dir may be of the form
---   * armv7-unknown-linux-gnueabihf-8.8.3
---   * 8.8.4
-ghcupGHCDir :: GHCTargetVersion -> IO (Path Abs)
-ghcupGHCDir ver = do
-  ghcbasedir <- ghcupGHCBaseDir
-  verdir     <- parseRel $ E.encodeUtf8 (prettyTVer ver)
-  pure (ghcbasedir </> verdir)
-
-
--- | See 'ghcupToolParser'.
-parseGHCupGHCDir :: MonadThrow m => Path Rel -> m GHCTargetVersion
-parseGHCupGHCDir (toFilePath -> f) = do
-  fp <- throwEither $ E.decodeUtf8' f
-  throwEither $ MP.parse ghcTargetVerP "" fp
-
-
 -- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
 -- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin'
 -- (which, sadly is not strictly xdg spec).
@@ -112,6 +99,7 @@ ghcupBinDir = do
           pure (home </> [rel|.local/bin|])
     else ghcupBaseDir <&> (</> [rel|bin|])
 
+
 -- | Defaults to '~/.ghcup/cache'.
 --
 -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
@@ -129,6 +117,7 @@ ghcupCacheDir = do
       pure (bdir </> [rel|ghcup|])
     else ghcupBaseDir <&> (</> [rel|cache|])
 
+
 -- | Defaults to '~/.ghcup/logs'.
 --
 -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
@@ -147,6 +136,49 @@ ghcupLogsDir = do
     else ghcupBaseDir <&> (</> [rel|logs|])
 
 
+getDirs :: IO Dirs
+getDirs = do
+  baseDir  <- ghcupBaseDir
+  binDir   <- ghcupBinDir
+  cacheDir <- ghcupCacheDir
+  logsDir  <- ghcupLogsDir
+  pure Dirs { .. }
+
+
+
+    -------------------------
+    --[ GHCup directories ]--
+    -------------------------
+
+
+-- | ~/.ghcup/ghc by default.
+ghcupGHCBaseDir :: (MonadReader Settings m) => m (Path Abs)
+ghcupGHCBaseDir = do
+  Settings {..} <- ask
+  pure (baseDir dirs </> [rel|ghc|])
+
+
+-- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
+-- The dir may be of the form
+--   * armv7-unknown-linux-gnueabihf-8.8.3
+--   * 8.8.4
+ghcupGHCDir :: (MonadReader Settings m, MonadThrow m)
+            => GHCTargetVersion
+            -> m (Path Abs)
+ghcupGHCDir ver = do
+  Settings {..} <- ask
+  ghcbasedir    <- ghcupGHCBaseDir
+  verdir        <- parseRel $ E.encodeUtf8 (prettyTVer ver)
+  pure (ghcbasedir </> verdir)
+
+
+-- | See 'ghcupToolParser'.
+parseGHCupGHCDir :: MonadThrow m => Path Rel -> m GHCTargetVersion
+parseGHCupGHCDir (toFilePath -> f) = do
+  fp <- throwEither $ E.decodeUtf8' f
+  throwEither $ MP.parse ghcTargetVerP "" fp
+
+
 mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
 mkGhcupTmpDir = do
   tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
@@ -158,6 +190,8 @@ withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
 withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
 
 
+
+
     --------------
     --[ Others ]--
     --------------
@@ -181,14 +215,13 @@ relativeSymlink :: Path Abs  -- ^ the path in which to create the symlink
                 -> Path Abs  -- ^ the symlink destination
                 -> ByteString
 relativeSymlink (toFilePath -> p1) (toFilePath -> p2) =
-  let d1            = splitDirectories p1
+  let d1      = splitDirectories p1
-      d2            = splitDirectories p2
+      d2      = splitDirectories p2
-      common        = takeWhile (\(x, y) -> x == y) $ zip d1 d2
+      common  = takeWhile (\(x, y) -> x == y) $ zip d1 d2
-      cPrefix       = drop (length common) d1
+      cPrefix = drop (length common) d1
   in  joinPath (replicate (length cPrefix) "..")
         <> joinPath ("/" : (drop (length common) d2))
 
 
 
 
-