Speed up 'whereis' subcommand wrt #179
This commit is contained in:
parent
80e1924e5f
commit
f04708e8ae
GPG Key ID:
3786C5262ECB4A3F
@ -142,6 +142,11 @@ else
|
||||
fi
|
||||
fi
|
||||
|
||||
# check that lazy loading works for 'whereis'
|
||||
cp "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml" "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml.bak"
|
||||
echo '**' > "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml"
|
||||
eghcup whereis ghc $(ghc --numeric-version)
|
||||
mv -f "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml.bak" "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml"
|
||||
|
||||
eghcup rm $(ghc --numeric-version)
|
||||
|
||||
@ -153,6 +158,7 @@ if [ "${OS}" = "LINUX" ] ; then
|
||||
fi
|
||||
fi
|
||||
|
||||
|
||||
eghcup upgrade
|
||||
eghcup upgrade -f
|
||||
|
||||
|
||||
@ -33,6 +33,8 @@ import GHCup.Version
|
||||
import Codec.Archive
|
||||
#endif
|
||||
import Control.Concurrent
|
||||
import Control.DeepSeq ( force )
|
||||
import Control.Exception ( evaluate )
|
||||
import Control.Exception.Safe
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
@ -64,6 +66,7 @@ import System.Environment
|
||||
import System.Exit
|
||||
import System.FilePath
|
||||
import System.IO hiding ( appendFile )
|
||||
import System.IO.Unsafe ( unsafeInterleaveIO )
|
||||
import Text.Read hiding ( lift )
|
||||
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||
import URI.ByteString
|
||||
@ -1237,7 +1240,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
let runLogger = myLoggerT loggerConfig
|
||||
let siletRunLogger = myLoggerT loggerConfig { colorOutter = \_ -> pure () }
|
||||
|
||||
pfreq <- (
|
||||
----------------------------------------
|
||||
-- Getting download and platform info --
|
||||
----------------------------------------
|
||||
|
||||
|
||||
pfreq <- unsafeInterleaveIO $ (
|
||||
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
|
||||
) >>= \case
|
||||
VRight r -> pure r
|
||||
@ -1246,13 +1254,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
($(logError) $ T.pack $ prettyShow e)
|
||||
exitWith (ExitFailure 2)
|
||||
|
||||
|
||||
|
||||
----------------------------------------
|
||||
-- Getting download and platform info --
|
||||
----------------------------------------
|
||||
|
||||
ghcupInfo <-
|
||||
ghcupInfo <- unsafeInterleaveIO $
|
||||
( runLogger
|
||||
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
|
||||
$ liftE
|
||||
@ -1265,12 +1267,25 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
($(logError) $ T.pack $ prettyShow e)
|
||||
exitWith (ExitFailure 2)
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
-- Setting up appstate --
|
||||
-------------------------
|
||||
|
||||
|
||||
let appstate@AppState{dirs = Dirs{..}
|
||||
, ghcupInfo = GHCupInfo { _ghcupDownloads = dls, .. }
|
||||
, ghcupInfo = ~GHCupInfo { _ghcupDownloads = dls, .. }
|
||||
} = AppState settings dirs keybindings ghcupInfo pfreq
|
||||
|
||||
|
||||
---------------------------
|
||||
-- Running startup tasks --
|
||||
---------------------------
|
||||
|
||||
case optCommand of
|
||||
Upgrade _ _ -> pure ()
|
||||
Whereis _ _ -> pure ()
|
||||
_ -> do
|
||||
lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
|
||||
Nothing -> runLogger $ flip runReaderT appstate $ checkForUpdates
|
||||
@ -1278,6 +1293,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
|
||||
|
||||
-- ensure global tools
|
||||
case optCommand of
|
||||
Whereis _ _ -> pure ()
|
||||
_ -> do
|
||||
(siletRunLogger $ flip runReaderT appstate $ runE ensureGlobalTools) >>= \case
|
||||
VRight _ -> pure ()
|
||||
VLeft e -> do
|
||||
@ -1771,13 +1789,13 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
runLogger $ $(logError) $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 30
|
||||
|
||||
Upgrade uOpts force -> do
|
||||
Upgrade uOpts force' -> do
|
||||
target <- case uOpts of
|
||||
UpgradeInplace -> Just <$> liftIO getExecutablePath
|
||||
(UpgradeAt p) -> pure $ Just p
|
||||
UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))
|
||||
|
||||
runUpgrade (liftE $ upgradeGHCup target force) >>= \case
|
||||
runUpgrade (liftE $ upgradeGHCup target force') >>= \case
|
||||
VRight v' -> do
|
||||
let pretty_v = prettyVer v'
|
||||
let vi = fromJust $ snd <$> getLatest dls GHCup
|
||||
@ -1849,6 +1867,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
|
||||
|
||||
Nuke ->
|
||||
runRm (do
|
||||
void $ liftIO $ evaluate $ force appstate
|
||||
lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system."
|
||||
lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
|
||||
liftIO $ threadDelay 10000000 -- wait 10s
|
||||
@ -1899,7 +1918,7 @@ fromVersion' SetRecommended tool = do
|
||||
(\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool
|
||||
?? TagNotFound Recommended tool
|
||||
fromVersion' (SetToolVersion v) tool = do
|
||||
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
|
||||
~AppState { ghcupInfo = ~GHCupInfo { _ghcupDownloads = dls }} <- lift ask
|
||||
let vi = getVersionInfo (_tvVersion v) tool dls
|
||||
case pvp $ prettyVer (_tvVersion v) of
|
||||
Left _ -> pure (v, vi)
|
||||
|
||||
@ -82,7 +82,6 @@ library
|
||||
QuasiQuotes
|
||||
RecordWildCards
|
||||
ScopedTypeVariables
|
||||
Strict
|
||||
StrictData
|
||||
TupleSections
|
||||
TypeApplications
|
||||
@ -195,7 +194,6 @@ executable ghcup
|
||||
PackageImports
|
||||
RecordWildCards
|
||||
ScopedTypeVariables
|
||||
Strict
|
||||
StrictData
|
||||
TupleSections
|
||||
|
||||
@ -207,6 +205,7 @@ executable ghcup
|
||||
, base >=4.13 && <5
|
||||
, bytestring ^>=0.10
|
||||
, containers ^>=0.6
|
||||
, deepseq ^>=1.4
|
||||
, filepath ^>=1.4.2.1
|
||||
, ghcup
|
||||
, haskus-utils-variant >=3.0 && <3.2
|
||||
@ -261,7 +260,6 @@ executable ghcup-gen
|
||||
QuasiQuotes
|
||||
RecordWildCards
|
||||
ScopedTypeVariables
|
||||
Strict
|
||||
StrictData
|
||||
TupleSections
|
||||
TypeApplications
|
||||
@ -305,6 +303,7 @@ executable ghcup-gen
|
||||
test-suite ghcup-test
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Main.hs
|
||||
build-tool-depends: hspec-discover:hspec-discover -any
|
||||
hs-source-dirs: test
|
||||
other-modules:
|
||||
GHCup.ArbitraryTypes
|
||||
@ -324,8 +323,6 @@ test-suite ghcup-test
|
||||
-Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
|
||||
-fwarn-incomplete-record-updates
|
||||
|
||||
build-tool-depends: hspec-discover:hspec-discover
|
||||
|
||||
build-depends:
|
||||
, base >=4.13 && <5
|
||||
, bytestring ^>=0.10
|
||||
|
||||
23
lib/GHCup.hs
23
lib/GHCup.hs
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
@ -42,6 +43,7 @@ import GHCup.Version
|
||||
import Codec.Archive ( ArchiveResult )
|
||||
#endif
|
||||
import Control.Applicative
|
||||
import Control.DeepSeq ( force )
|
||||
import Control.Exception ( evaluate )
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
@ -1393,19 +1395,21 @@ rmGhcupDirs = do
|
||||
rmEnvFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m ()
|
||||
rmEnvFile enFilePath = do
|
||||
$logInfo "Removing Ghcup Environment File"
|
||||
hideError doesNotExistErrorType $ liftIO $ deleteFile enFilePath
|
||||
liftIO $ deleteFile enFilePath
|
||||
|
||||
rmConfFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m ()
|
||||
rmConfFile confFilePath = do
|
||||
$logInfo "removing Ghcup Config File"
|
||||
hideError doesNotExistErrorType $ liftIO $ deleteFile confFilePath
|
||||
liftIO $ deleteFile confFilePath
|
||||
|
||||
rmDir :: (MonadLogger m, MonadIO m, MonadCatch m) => FilePath -> m ()
|
||||
rmDir dir = do
|
||||
rmDir dir =
|
||||
-- 'getDirectoryContentsRecursive' is lazy IO. In case
|
||||
-- an error leaks through, we catch it here as well,
|
||||
-- althought 'deleteFile' should already handle it.
|
||||
hideErrorDef [doesNotExistErrorType] () $ do
|
||||
$logInfo [i|removing #{dir}|]
|
||||
contents <- hideErrorDef [doesNotExistErrorType] []
|
||||
$ liftIO
|
||||
(getDirectoryContentsRecursive dir >>= evaluate)
|
||||
contents <- liftIO $ getDirectoryContentsRecursive dir
|
||||
forM_ contents (liftIO . deleteFile . (dir </>))
|
||||
|
||||
rmBinDir :: (MonadCatch m, MonadIO m) => FilePath -> m ()
|
||||
@ -1421,7 +1425,9 @@ rmGhcupDirs = do
|
||||
|
||||
reportRemainingFiles :: MonadIO m => FilePath -> m [FilePath]
|
||||
reportRemainingFiles dir = do
|
||||
remainingFiles <- liftIO $ getDirectoryContentsRecursive dir
|
||||
-- force the files so the errors don't leak
|
||||
(force -> !remainingFiles) <- liftIO
|
||||
(getDirectoryContentsRecursive dir >>= evaluate)
|
||||
let normalizedFilePaths = fmap normalise remainingFiles
|
||||
let sortedByDepthRemainingFiles = sortBy (flip compareFn) normalizedFilePaths
|
||||
let remainingFilesAbsolute = fmap (dir </>) sortedByDepthRemainingFiles
|
||||
@ -1448,7 +1454,8 @@ rmGhcupDirs = do
|
||||
|
||||
deleteFile :: FilePath -> IO ()
|
||||
deleteFile filepath = do
|
||||
hideError InappropriateType $ rmFile filepath
|
||||
hideError doesNotExistErrorType
|
||||
$ hideError InappropriateType $ rmFile filepath
|
||||
|
||||
removeDirIfEmptyOrIsSymlink :: (MonadCatch m, MonadIO m) => FilePath -> m ()
|
||||
removeDirIfEmptyOrIsSymlink filepath =
|
||||
|
||||
@ -1,7 +1,9 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
|
||||
{-|
|
||||
Module : GHCup.Types
|
||||
@ -21,6 +23,7 @@ module GHCup.Types
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.DeepSeq ( NFData, rnf )
|
||||
import Control.Monad.Logger
|
||||
import Data.Map.Strict ( Map )
|
||||
import Data.List.NonEmpty ( NonEmpty (..) )
|
||||
@ -60,6 +63,8 @@ data GHCupInfo = GHCupInfo
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
instance NFData GHCupInfo
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
@ -79,6 +84,8 @@ data Requirements = Requirements
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
instance NFData Requirements
|
||||
|
||||
|
||||
|
||||
|
||||
@ -105,9 +112,13 @@ data Tool = GHC
|
||||
| Stack
|
||||
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
|
||||
|
||||
instance NFData Tool
|
||||
|
||||
data GlobalTool = ShimGen
|
||||
deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
|
||||
|
||||
instance NFData GlobalTool
|
||||
|
||||
|
||||
-- | All necessary information of a tool version, including
|
||||
-- source download and per-architecture downloads.
|
||||
@ -123,6 +134,8 @@ data VersionInfo = VersionInfo
|
||||
}
|
||||
deriving (Eq, GHC.Generic, Show)
|
||||
|
||||
instance NFData VersionInfo
|
||||
|
||||
|
||||
-- | A tag. These are currently attached to a version of a tool.
|
||||
data Tag = Latest
|
||||
@ -133,6 +146,8 @@ data Tag = Latest
|
||||
| UnknownTag String -- ^ used for upwardscompat
|
||||
deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance
|
||||
|
||||
instance NFData Tag
|
||||
|
||||
tagToString :: Tag -> String
|
||||
tagToString Recommended = "recommended"
|
||||
tagToString Latest = "latest"
|
||||
@ -159,6 +174,8 @@ data Architecture = A_64
|
||||
| A_ARM64
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
instance NFData Architecture
|
||||
|
||||
archToString :: Architecture -> String
|
||||
archToString A_64 = "x86_64"
|
||||
archToString A_32 = "i386"
|
||||
@ -181,6 +198,8 @@ data Platform = Linux LinuxDistro
|
||||
-- ^ must exit
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
instance NFData Platform
|
||||
|
||||
platformToString :: Platform -> String
|
||||
platformToString (Linux distro) = "linux-" ++ distroToString distro
|
||||
platformToString Darwin = "darwin"
|
||||
@ -206,6 +225,8 @@ data LinuxDistro = Debian
|
||||
-- ^ must exit
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
instance NFData LinuxDistro
|
||||
|
||||
distroToString :: LinuxDistro -> String
|
||||
distroToString Debian = "debian"
|
||||
distroToString Ubuntu = "ubuntu"
|
||||
@ -232,6 +253,7 @@ data DownloadInfo = DownloadInfo
|
||||
}
|
||||
deriving (Eq, Ord, GHC.Generic, Show)
|
||||
|
||||
instance NFData DownloadInfo
|
||||
|
||||
|
||||
|
||||
@ -245,6 +267,8 @@ data TarDir = RealDir FilePath
|
||||
| RegexDir String -- ^ will be compiled to regex, the first match will "win"
|
||||
deriving (Eq, Ord, GHC.Generic, Show)
|
||||
|
||||
instance NFData TarDir
|
||||
|
||||
instance Pretty TarDir where
|
||||
pPrint (RealDir path) = text path
|
||||
pPrint (RegexDir regex) = text regex
|
||||
@ -257,6 +281,10 @@ data URLSource = GHCupURL
|
||||
| AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL
|
||||
deriving (GHC.Generic, Show)
|
||||
|
||||
instance NFData URLSource
|
||||
instance NFData (URIRef Absolute) where
|
||||
rnf (URI !_ !_ !_ !_ !_) = ()
|
||||
|
||||
|
||||
data UserSettings = UserSettings
|
||||
{ uCache :: Maybe Bool
|
||||
@ -298,6 +326,9 @@ data KeyBindings = KeyBindings
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
instance NFData KeyBindings
|
||||
instance NFData Key
|
||||
|
||||
defaultKeyBindings :: KeyBindings
|
||||
defaultKeyBindings = KeyBindings
|
||||
{ bUp = KUp
|
||||
@ -315,9 +346,11 @@ data AppState = AppState
|
||||
{ settings :: Settings
|
||||
, dirs :: Dirs
|
||||
, keyBindings :: KeyBindings
|
||||
, ghcupInfo :: GHCupInfo
|
||||
, pfreq :: PlatformRequest
|
||||
} deriving (Show)
|
||||
, ghcupInfo :: ~GHCupInfo
|
||||
, pfreq :: ~PlatformRequest
|
||||
} deriving (Show, GHC.Generic)
|
||||
|
||||
instance NFData AppState
|
||||
|
||||
data Settings = Settings
|
||||
{ cache :: Bool
|
||||
@ -329,6 +362,8 @@ data Settings = Settings
|
||||
}
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
instance NFData Settings
|
||||
|
||||
data Dirs = Dirs
|
||||
{ baseDir :: FilePath
|
||||
, binDir :: FilePath
|
||||
@ -336,19 +371,25 @@ data Dirs = Dirs
|
||||
, logsDir :: FilePath
|
||||
, confDir :: FilePath
|
||||
}
|
||||
deriving Show
|
||||
deriving (Show, GHC.Generic)
|
||||
|
||||
instance NFData Dirs
|
||||
|
||||
data KeepDirs = Always
|
||||
| Errors
|
||||
| Never
|
||||
deriving (Eq, Show, Ord)
|
||||
deriving (Eq, Show, Ord, GHC.Generic)
|
||||
|
||||
instance NFData KeepDirs
|
||||
|
||||
data Downloader = Curl
|
||||
| Wget
|
||||
#if defined(INTERNAL_DOWNLOADER)
|
||||
| Internal
|
||||
#endif
|
||||
deriving (Eq, Show, Ord)
|
||||
deriving (Eq, Show, Ord, GHC.Generic)
|
||||
|
||||
instance NFData Downloader
|
||||
|
||||
data DebugInfo = DebugInfo
|
||||
{ diBaseDir :: FilePath
|
||||
@ -371,7 +412,9 @@ data PlatformResult = PlatformResult
|
||||
{ _platform :: Platform
|
||||
, _distroVersion :: Maybe Versioning
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
deriving (Eq, Show, GHC.Generic)
|
||||
|
||||
instance NFData PlatformResult
|
||||
|
||||
platResToString :: PlatformResult -> String
|
||||
platResToString PlatformResult { _platform = plat, _distroVersion = Just v' }
|
||||
@ -387,7 +430,9 @@ data PlatformRequest = PlatformRequest
|
||||
, _rPlatform :: Platform
|
||||
, _rVersion :: Maybe Versioning
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
deriving (Eq, Show, GHC.Generic)
|
||||
|
||||
instance NFData PlatformRequest
|
||||
|
||||
pfReqToString :: PlatformRequest -> String
|
||||
pfReqToString (PlatformRequest arch plat ver) =
|
||||
@ -434,6 +479,8 @@ data VersionCmp = VR_gt Versioning
|
||||
| VR_eq Versioning
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
instance NFData VersionCmp
|
||||
|
||||
|
||||
-- | A version range. Supports && and ||, but not arbitrary
|
||||
-- combinations. This is a little simplified.
|
||||
@ -441,6 +488,7 @@ data VersionRange = SimpleRange (NonEmpty VersionCmp) -- And
|
||||
| OrRange (NonEmpty VersionCmp) VersionRange
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
instance NFData VersionRange
|
||||
|
||||
instance Pretty Versioning where
|
||||
pPrint = text . T.unpack . prettyV
|
||||
|
||||
Loading…
Reference in New Issue
Block a user