From f04708e8ae35bef995a8bb9b8c9cec0b76052c1a Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 15 Jul 2021 13:32:48 +0200 Subject: [PATCH] Speed up 'whereis' subcommand wrt #179 --- .gitlab/script/ghcup_version.sh | 6 ++++ app/ghcup/Main.hs | 55 ++++++++++++++++++---------- ghcup.cabal | 7 ++-- lib/GHCup.hs | 27 ++++++++------ lib/GHCup/Types.hs | 64 ++++++++++++++++++++++++++++----- 5 files changed, 118 insertions(+), 41 deletions(-) diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index f8bdff8..6959f60 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -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 diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index d985fb6..cfb4c15 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -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 |] 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 |] ($(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 |] ($(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,12 +1293,15 @@ Report bugs at |] -- ensure global tools - (siletRunLogger $ flip runReaderT appstate $ runE ensureGlobalTools) >>= \case - VRight _ -> pure () - VLeft e -> do - runLogger - ($(logError) $ T.pack $ prettyShow e) - exitWith (ExitFailure 30) + case optCommand of + Whereis _ _ -> pure () + _ -> do + (siletRunLogger $ flip runReaderT appstate $ runE ensureGlobalTools) >>= \case + VRight _ -> pure () + VLeft e -> do + runLogger + ($(logError) $ T.pack $ prettyShow e) + exitWith (ExitFailure 30) ------------------------- @@ -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) diff --git a/ghcup.cabal b/ghcup.cabal index 5c3cfa1..86b166a 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -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 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index a94876a..5fc8bdc 100644 --- a/lib/GHCup.hs +++ b/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,20 +1395,22 @@ 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 - $logInfo [i|removing #{dir}|] - contents <- hideErrorDef [doesNotExistErrorType] [] - $ liftIO - (getDirectoryContentsRecursive dir >>= evaluate) - forM_ contents (liftIO . deleteFile . (dir )) + 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 <- liftIO $ getDirectoryContentsRecursive dir + forM_ contents (liftIO . deleteFile . (dir )) rmBinDir :: (MonadCatch m, MonadIO m) => FilePath -> m () rmBinDir binDir = do @@ -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 = diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index dcb253f..65c7ed0 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -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