hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Speed up 'whereis' subcommand wrt #179

Browse Source
This commit is contained in:
Julian Ospald
2021-07-15 13:32:48 +02:00
parent 80e1924e5f
commit f04708e8ae
5 changed files with 118 additions and 41 deletions
Download Patch File Download Diff File Expand all files Collapse all files

27
lib/GHCup.hs
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,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 =

64
lib/GHCup/Types.hs
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