Speed up 'whereis' subcommand wrt #179

This commit is contained in:
Julian Ospald 2021-07-15 13:32:48 +02:00
parent 80e1924e5f
commit f04708e8ae
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
5 changed files with 118 additions and 41 deletions

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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 =

View File

@ -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