ghcup 0.1.19.0 → 0.1.19.1
raw patch · 12 files changed
+277/−163 lines, 12 files
Files
- CHANGELOG.md +10/−0
- app/ghcup/GHCup/OptParse/Config.hs +83/−34
- app/ghcup/GHCup/OptParse/Set.hs +5/−17
- app/ghcup/Main.hs +4/−4
- ghcup.cabal +1/−1
- lib/GHCup/Download.hs +6/−2
- lib/GHCup/Errors.hs +16/−0
- lib/GHCup/Prelude/File/Posix.hs +6/−6
- lib/GHCup/Prelude/File/Posix/Traversals.hs +0/−92
- lib/GHCup/Prelude/File/Posix/Traversals.hsc +139/−0
- lib/GHCup/Types.hs +2/−2
- test/GHCup/Prelude/File/Posix/TraversalsSpec.hs +5/−5
CHANGELOG.md view
@@ -1,5 +1,15 @@ # Revision history for ghcup +## 0.1.19.1 -- 2023-2-19++* Fix GHCup on JFS/ReiserFS and other filesystem that don't support `d_type`, fixes [#766](https://github.com/haskell/ghcup-hs/issues/766)+* Don't fail on setModificationTime, fixes [#784](https://github.com/haskell/ghcup-hs/issues/784) and many GitHub actions issues+* Make armv7/aarch64 linux binaries more portable (built on Debian buster)+* Improve usability on 'ghcup config add-release-channel', fixes [#751](https://github.com/haskell/ghcup-hs/issues/751)+* Make version shortcuts work with 'ghcup set', fixes [#757](https://github.com/haskell/ghcup-hs/issues/757)+* Don't implicitly smuggle in config options in `ghcup config set` wrt [#775](https://github.com/haskell/ghcup-hs/issues/775)+* Fix build on unix with -ftui+ ## 0.1.19.0 -- 2023-1-13 * restore proper support for FreeBSD and Linux armv7
app/ghcup/GHCup/OptParse/Config.hs view
@@ -51,7 +51,7 @@ = ShowConfig | SetConfig String (Maybe String) | InitConfig- | AddReleaseChannel URI+ | AddReleaseChannel Bool URI @@ -59,7 +59,7 @@ --[ Parsers ]-- --------------- - + configP :: Parser ConfigCommand configP = subparser ( command "init" initP@@ -74,7 +74,7 @@ showP = info (pure ShowConfig) (progDesc "Show current config (default)") setP = info argsP (progDesc "Set config KEY to VALUE (or specify as single json value)" <> footerDoc (Just $ text configSetFooter)) argsP = SetConfig <$> argument str (metavar "<JSON_VALUE | YAML_KEY>") <*> optional (argument str (metavar "YAML_VALUE"))- addP = info (AddReleaseChannel <$> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri))+ addP = info (AddReleaseChannel <$> switch (long "force" <> help "Delete existing entry (if any) and append instead of failing") <*> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri)) (progDesc "Add a release channel from a URI") @@ -120,21 +120,38 @@ formatConfig = UTF8.toString . Y.encode -updateSettings :: UserSettings -> Settings -> Settings-updateSettings UserSettings{..} Settings{..} =- let cache' = fromMaybe cache uCache- metaCache' = fromMaybe metaCache uMetaCache- metaMode' = fromMaybe metaMode uMetaMode- noVerify' = fromMaybe noVerify uNoVerify- keepDirs' = fromMaybe keepDirs uKeepDirs- downloader' = fromMaybe downloader uDownloader- verbose' = fromMaybe verbose uVerbose- urlSource' = fromMaybe urlSource uUrlSource- noNetwork' = fromMaybe noNetwork uNoNetwork- gpgSetting' = fromMaybe gpgSetting uGPGSetting- platformOverride' = uPlatformOverride <|> platformOverride- mirrors' = fromMaybe mirrors uMirrors- in Settings cache' metaCache' metaMode' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride' mirrors'+updateSettings :: UserSettings -> UserSettings -> UserSettings+updateSettings usl usr =+ let cache' = uCache usl <|> uCache usr+ metaCache' = uMetaCache usl <|> uMetaCache usr+ metaMode' = uMetaMode usl <|> uMetaMode usr+ noVerify' = uNoVerify usl <|> uNoVerify usr+ verbose' = uVerbose usl <|> uVerbose usr+ keepDirs' = uKeepDirs usl <|> uKeepDirs usr+ downloader' = uDownloader usl <|> uDownloader usr+ urlSource' = uUrlSource usl <|> uUrlSource usr+ noNetwork' = uNoNetwork usl <|> uNoNetwork usr+ gpgSetting' = uGPGSetting usl <|> uGPGSetting usr+ platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr+ mirrors' = uMirrors usl <|> uMirrors usr+ in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors'+ where+ updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings+ updateKeyBindings Nothing Nothing = Nothing+ updateKeyBindings (Just kbl) Nothing = Just kbl+ updateKeyBindings Nothing (Just kbr) = Just kbr+ updateKeyBindings (Just kbl) (Just kbr) =+ Just $ UserKeyBindings {+ kUp = kUp kbl <|> kUp kbr+ , kDown = kDown kbl <|> kDown kbr+ , kQuit = kQuit kbl <|> kQuit kbr+ , kInstall = kInstall kbl <|> kInstall kbr+ , kUninstall = kUninstall kbl <|> kUninstall kbr+ , kSet = kSet kbl <|> kSet kbr+ , kChangelog = kChangelog kbl <|> kChangelog kbr+ , kShowAll = kShowAll kbl <|> kShowAll kbr+ , kShowAllTools = kShowAllTools kbl <|> kShowAllTools kbr+ } @@ -142,6 +159,9 @@ --[ Entrypoint ]-- ------------------ +data Duplicate = Duplicate -- ^ there is a duplicate somewhere in the middle+ | NoDuplicate -- ^ there is no duplicate+ | DuplicateLast -- ^ there's a duplicate, but it's the last element config :: forall m. ( Monad m@@ -151,10 +171,11 @@ ) => ConfigCommand -> Settings+ -> UserSettings -> KeyBindings -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode-config configCommand settings keybindings runLogger = case configCommand of+config configCommand settings userConf keybindings runLogger = case configCommand of InitConfig -> do path <- getConfigFilePath liftIO $ writeFile path $ formatConfig $ fromSettings settings (Just keybindings)@@ -185,27 +206,55 @@ pure $ ExitFailure 65 VLeft _ -> pure $ ExitFailure 65 - AddReleaseChannel uri -> do- case urlSource settings of- AddSource xs -> do- doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (xs <> [Right uri]) })- pure ExitSuccess- GHCupURL -> do- doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })- pure ExitSuccess- OwnSource xs -> do- doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource (xs <> [Right uri]) })- pure ExitSuccess- OwnSpec spec -> do- doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource ([Left spec, Right uri]) })+ AddReleaseChannel force uri -> do+ r <- runE @'[DuplicateReleaseChannel] $ do+ case urlSource settings of+ AddSource xs -> do+ case checkDuplicate xs (Right uri) of+ Duplicate+ | not force -> throwE (DuplicateReleaseChannel uri)+ DuplicateLast -> pure ()+ _ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (appendUnique xs (Right uri)) })+ GHCupURL -> do+ lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })+ pure ()+ OwnSource xs -> do+ case checkDuplicate xs (Right uri) of+ Duplicate+ | not force -> throwE (DuplicateReleaseChannel uri)+ DuplicateLast -> pure ()+ _ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource (appendUnique xs (Right uri)) })+ OwnSpec spec -> do+ lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource [Left spec, Right uri] })+ pure ()+ case r of+ VRight _ -> do pure ExitSuccess+ VLeft e -> do+ runLogger $ logError $ T.pack $ prettyHFError e+ pure $ ExitFailure 15 where+ checkDuplicate :: Eq a => [a] -> a -> Duplicate+ checkDuplicate xs a+ | last xs == a = DuplicateLast+ | a `elem` xs = Duplicate+ | otherwise = NoDuplicate++ -- appends the element to the end of the list, but also removes it from the existing list+ appendUnique :: Eq a => [a] -> a -> [a]+ appendUnique xs' e = go xs'+ where+ go [] = [e]+ go (x:xs)+ | x == e = go xs -- skip+ | otherwise = x : go xs+ doConfig :: MonadIO m => UserSettings -> m () doConfig usersettings = do- let settings' = updateSettings usersettings settings+ let settings' = updateSettings usersettings userConf path <- liftIO getConfigFilePath- liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)+ liftIO $ writeFile path $ formatConfig $ settings' runLogger $ logDebug $ T.pack $ show settings' pure ()
app/ghcup/GHCup/OptParse/Set.hs view
@@ -259,7 +259,7 @@ -> m (VEither eff GHCTargetVersion)) -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode-set setCommand runAppState runLeanAppState runLogger = case setCommand of+set setCommand runAppState _ runLogger = case setCommand of (Right sopts) -> do runLogger (logWarn "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.") setGHC' sopts@@ -271,10 +271,7 @@ where setGHC' :: SetOptions -> m ExitCode- setGHC' SetOptions{ sToolVer } =- case sToolVer of- (SetGHCVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly Nothing >> pure v)- _ -> runSetGHC runAppState (do+ setGHC' SetOptions{ sToolVer } = runSetGHC runAppState (do v <- liftE $ fst <$> fromVersion' sToolVer GHC liftE $ setGHC v SetGHCOnly Nothing )@@ -291,10 +288,7 @@ setCabal' :: SetOptions -> m ExitCode- setCabal' SetOptions{ sToolVer } =- case sToolVer of- (SetToolVersion v) -> runSetCabal runLeanAppState (liftE $ setCabal v >> pure (mkTVer v))- _ -> runSetCabal runAppState (do+ setCabal' SetOptions{ sToolVer } = runSetCabal runAppState (do v <- liftE $ fst <$> fromVersion' sToolVer Cabal liftE $ setCabal (_tvVersion v) pure v@@ -311,10 +305,7 @@ setHLS' :: SetOptions -> m ExitCode- setHLS' SetOptions{ sToolVer } =- case sToolVer of- (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS v SetHLSOnly Nothing >> pure (mkTVer v))- _ -> runSetHLS runAppState (do+ setHLS' SetOptions{ sToolVer } = runSetHLS runAppState (do v <- liftE $ fst <$> fromVersion' sToolVer HLS liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing pure v@@ -332,10 +323,7 @@ setStack' :: SetOptions -> m ExitCode- setStack' SetOptions{ sToolVer } =- case sToolVer of- (SetToolVersion v) -> runSetStack runLeanAppState (liftE $ setStack v >> pure (mkTVer v))- _ -> runSetStack runAppState (do+ setStack' SetOptions{ sToolVer } = runSetStack runAppState (do v <- liftE $ fst <$> fromVersion' sToolVer Stack liftE $ setStack (_tvVersion v) pure v
app/ghcup/Main.hs view
@@ -63,7 +63,7 @@ -toSettings :: Options -> IO (Settings, KeyBindings)+toSettings :: Options -> IO (Settings, KeyBindings, UserSettings) toSettings options = do noColor <- isJust <$> lookupEnv "NO_COLOR" userConf <- runE @'[ JSONError ] ghcupConfigFile >>= \case@@ -73,7 +73,7 @@ pure defaultUserSettings _ -> do die "Unexpected error!"- pure $ mergeConf options userConf noColor+ pure $ (\(s', k) -> (s', k, userConf)) $ mergeConf options userConf noColor where mergeConf :: Options -> UserSettings -> Bool -> (Settings, KeyBindings) mergeConf Options{..} UserSettings{..} noColor =@@ -176,7 +176,7 @@ -- create ~/.ghcup dir ensureDirectories dirs - (settings, keybindings) <- toSettings opt+ (settings, keybindings, userConf) <- toSettings opt -- logger interpreter logfile <- runReaderT initGHCupFileLogging dirs@@ -303,7 +303,7 @@ Rm rmCommand -> rm rmCommand runAppState runLogger DInfo -> dinfo runAppState runLogger Compile compileCommand -> compile compileCommand settings dirs runAppState runLogger- Config configCommand -> config configCommand settings keybindings runLogger+ Config configCommand -> config configCommand settings userConf keybindings runLogger Whereis whereisOptions whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger Upgrade uOpts force' fatal -> upgrade uOpts force' fatal dirs runAppState runLogger
ghcup.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghcup-version: 0.1.19.0+version: 0.1.19.1 license: LGPL-3.0-only license-file: LICENSE copyright: Julian Ospald 2020
lib/GHCup/Download.hs view
@@ -263,8 +263,12 @@ dlWithMod modTime json_file = do let (dir, fn) = splitFileName json_file f <- liftE $ download uri' (Just $ over pathL' (<> ".sig") uri') Nothing Nothing dir (Just fn) True- liftIO $ setModificationTime f modTime- liftIO $ setAccessTime f modTime++ -- make these failures non-fatal, also see:+ -- https://github.com/actions/runner-images/issues/7061+ handleIO (\e -> logWarn $ "setModificationTime failed with: " <> T.pack (displayException e)) $ liftIO $ setModificationTime f modTime+ handleIO (\e -> logWarn $ "setAccessTime failed with: " <> T.pack (displayException e)) $ liftIO $ setAccessTime f modTime+ pure f
lib/GHCup/Errors.hs view
@@ -35,6 +35,8 @@ import qualified Data.Map.Strict as M import qualified Data.Text as T+import qualified Data.Text.Encoding as E+import qualified Data.Text.Encoding.Error as E import Data.Data (Proxy(..)) @@ -82,6 +84,7 @@ , let proxy = Proxy :: Proxy HadrianNotFound in format proxy , let proxy = Proxy :: Proxy ToolShadowed in format proxy , let proxy = Proxy :: Proxy ContentLengthError in format proxy+ , let proxy = Proxy :: Proxy DuplicateReleaseChannel in format proxy , "" , "# high level errors (4000+)" , let proxy = Proxy :: Proxy DownloadFailed in format proxy@@ -639,6 +642,19 @@ instance HFErrorProject ContentLengthError where eBase _ = 340 eDesc _ = "File content length verification failed"++data DuplicateReleaseChannel = DuplicateReleaseChannel URI+ deriving Show++instance HFErrorProject DuplicateReleaseChannel where+ eBase _ = 350+ eDesc _ = "Duplicate release channel detected when adding URI.\nGiving up. You can use '--force' to remove and append the duplicate URI (this may change order/semantics)."++instance Pretty DuplicateReleaseChannel where+ pPrint (DuplicateReleaseChannel uri) =+ text $ "Duplicate release channel detected when adding: \n "+ <> (T.unpack . E.decodeUtf8With E.lenientDecode . serializeURIRef') uri+ <> "\nGiving up. You can use '--force' to remove and append the duplicate URI (this may change order/semantics)." ------------------------- --[ High-level errors ]--
lib/GHCup/Prelude/File/Posix.hs view
@@ -279,11 +279,11 @@ -- | Create an 'Unfold' of directory contents. unfoldDirContents :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath (FD.DirType, FilePath)-unfoldDirContents = U.bracket (liftIO . openDirStream) (liftIO . closeDirStream) (Unfold step return)+unfoldDirContents = U.bracket (liftIO . openDirStreamPortable) (liftIO . closeDirStreamPortable) (Unfold step return) where {-# INLINE [0] step #-} step dirstream = do- (typ, e) <- liftIO $ readDirEnt dirstream+ (typ, e) <- liftIO $ readDirEntPortable dirstream return $ if | null e -> D.Stop | "." == e -> D.Skip dirstream@@ -308,8 +308,8 @@ step (_, Nothing, []) = return D.Stop step (topdir, Just (cdir, dirstream, finalizer), dirs) = flip onException (runIOFinalizer finalizer) $ do- (dt, f) <- liftIO $ readDirEnt dirstream- if | FD.dtUnknown == dt -> do+ (dt, f) <- liftIO $ readDirEntPortable dirstream+ if | f == "" -> do runIOFinalizer finalizer return $ D.Skip (topdir, Nothing, dirs) | f == "." || f == ".."@@ -323,8 +323,8 @@ acquire dir = withRunInIO $ \run -> mask_ $ run $ do- dirstream <- liftIO $ openDirStream dir- ref <- newIOFinalizer (liftIO $ closeDirStream dirstream)+ dirstream <- liftIO $ openDirStreamPortable dir+ ref <- newIOFinalizer (liftIO $ closeDirStreamPortable dirstream) return (dirstream, ref) getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m)
− lib/GHCup/Prelude/File/Posix/Traversals.hs
@@ -1,92 +0,0 @@-{-# LANGUAGE CApiFFI #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wall #-}---module GHCup.Prelude.File.Posix.Traversals (--- lower-level stuff- readDirEnt-, unpackDirStream-) where---#if __GLASGOW_HASKELL__ < 710-import Control.Applicative ((<$>))-#endif-import GHCup.Prelude.File.Posix.Foreign--import Unsafe.Coerce (unsafeCoerce)-import Foreign.C.Error-import Foreign.C.String-import Foreign.C.Types-import Foreign.Ptr-import Foreign.Storable-import System.Posix-import Foreign (alloca)-import System.Posix.Internals (peekFilePath)------------------------------------------------------------------- dodgy stuff--data {-# CTYPE "DIR" #-} CDir-data {-# CTYPE "struct dirent" #-} CDirent---- Posix doesn't export DirStream, so to re-use that type we need to use--- unsafeCoerce. It's just a newtype, so this is a legitimate usage.--- ugly trick.-unpackDirStream :: DirStream -> Ptr CDir-unpackDirStream = unsafeCoerce---- the __hscore_* functions are defined in the unix package. We can import them and let--- the linker figure it out.-foreign import ccall unsafe "__hscore_readdir"- c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt--foreign import ccall unsafe "__hscore_free_dirent"- c_freeDirEnt :: Ptr CDirent -> IO ()--foreign import ccall unsafe "__hscore_d_name"- c_name :: Ptr CDirent -> IO CString--foreign import capi unsafe "dirutils.h __posixdir_d_type"- c_type :: Ptr CDirent -> IO DirType--------------------------------------------------------------- less dodgy but still lower-level---readDirEnt :: DirStream -> IO (DirType, FilePath)-readDirEnt (unpackDirStream -> dirp) =- alloca $ \ptr_dEnt -> loop ptr_dEnt- where- loop ptr_dEnt = do- resetErrno- r <- c_readdir dirp ptr_dEnt- if r == 0- then do- dEnt <- peek ptr_dEnt- if dEnt == nullPtr- then return (dtUnknown, mempty)- else do- dName <- c_name dEnt >>= peekFilePath- dType <- c_type dEnt- c_freeDirEnt dEnt- return (dType, dName)- else do- errno <- getErrno- if errno == eINTR- then loop ptr_dEnt- else do- let (Errno eo) = errno- if eo == 0- then return (dtUnknown, mempty)- else throwErrno "readDirEnt"-
+ lib/GHCup/Prelude/File/Posix/Traversals.hsc view
@@ -0,0 +1,139 @@+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wall #-}+++module GHCup.Prelude.File.Posix.Traversals (+-- lower-level stuff+ readDirEnt+, readDirEntPortable+, openDirStreamPortable+, closeDirStreamPortable+, unpackDirStream+, DirStreamPortable+) where++#include <limits.h>+#include <stdlib.h>+#include <dirent.h>+#include <sys/types.h>+#include <sys/stat.h>+#include <fcntl.h>+++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+#endif+import GHCup.Prelude.File.Posix.Foreign++import Unsafe.Coerce (unsafeCoerce)+import Foreign.C.Error+import Foreign.C.String+import Foreign.C.Types+import Foreign.Ptr+import Foreign.Storable+import System.Posix+import Foreign (alloca)+import System.Posix.Internals (peekFilePath)+import System.FilePath++++++----------------------------------------------------------+-- dodgy stuff++data {-# CTYPE "DIR" #-} CDir+data {-# CTYPE "struct dirent" #-} CDirent++-- Posix doesn't export DirStream, so to re-use that type we need to use+-- unsafeCoerce. It's just a newtype, so this is a legitimate usage.+-- ugly trick.+unpackDirStream :: DirStream -> Ptr CDir+unpackDirStream = unsafeCoerce++-- the __hscore_* functions are defined in the unix package. We can import them and let+-- the linker figure it out.+foreign import ccall unsafe "__hscore_readdir"+ c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt++foreign import ccall unsafe "__hscore_free_dirent"+ c_freeDirEnt :: Ptr CDirent -> IO ()++foreign import ccall unsafe "__hscore_d_name"+ c_name :: Ptr CDirent -> IO CString++foreign import capi unsafe "dirutils.h __posixdir_d_type"+ c_type :: Ptr CDirent -> IO DirType++----------------------------------------------------------+-- less dodgy but still lower-level+++readDirEnt :: DirStream -> IO (DirType, FilePath)+readDirEnt (unpackDirStream -> dirp) =+ alloca $ \ptr_dEnt -> loop ptr_dEnt+ where+ loop ptr_dEnt = do+ resetErrno+ r <- c_readdir dirp ptr_dEnt+ if r == 0+ then do+ dEnt <- peek ptr_dEnt+ if dEnt == nullPtr+ then return (dtUnknown, mempty)+ else do+ dName <- c_name dEnt >>= peekFilePath+ dType <- c_type dEnt+ c_freeDirEnt dEnt+ return (dType, dName)+ else do+ errno <- getErrno+ if errno == eINTR+ then loop ptr_dEnt+ else do+ let (Errno eo) = errno+ if eo == 0+ then return (dtUnknown, mempty)+ else throwErrno "readDirEnt"+++newtype DirStreamPortable = DirStreamPortable (FilePath, DirStream)++openDirStreamPortable :: FilePath -> IO DirStreamPortable+openDirStreamPortable fp = do+ dirs <- openDirStream fp+ pure $ DirStreamPortable (fp, dirs)++closeDirStreamPortable :: DirStreamPortable -> IO ()+closeDirStreamPortable (DirStreamPortable (_, dirs)) = closeDirStream dirs++readDirEntPortable :: DirStreamPortable -> IO (DirType, FilePath)+readDirEntPortable (DirStreamPortable (basedir, dirs)) = do+ (dt, fp) <- readDirEnt dirs+ case (dt, fp) of+ (DirType #{const DT_BLK}, _) -> pure (dt, fp)+ (DirType #{const DT_CHR}, _) -> pure (dt, fp)+ (DirType #{const DT_DIR}, _) -> pure (dt, fp)+ (DirType #{const DT_FIFO}, _) -> pure (dt, fp)+ (DirType #{const DT_LNK}, _) -> pure (dt, fp)+ (DirType #{const DT_REG}, _) -> pure (dt, fp)+ (DirType #{const DT_SOCK}, _) -> pure (dt, fp)+ (DirType #{const DT_UNKNOWN}, _) -> pure (dt, fp)+ (_, _)+ | fp /= "" -> do+ stat <- getSymbolicLinkStatus (basedir </> fp)+ pure $ (, fp) $ if | isBlockDevice stat -> DirType #{const DT_BLK}+ | isCharacterDevice stat -> DirType #{const DT_CHR}+ | isDirectory stat -> DirType #{const DT_DIR}+ | isNamedPipe stat -> DirType #{const DT_FIFO}+ | isSymbolicLink stat -> DirType #{const DT_LNK}+ | isRegularFile stat -> DirType #{const DT_REG}+ | isSocket stat -> DirType #{const DT_SOCK}+ | otherwise -> DirType #{const DT_UNKNOWN}+
lib/GHCup/Types.hs view
@@ -66,7 +66,7 @@ , _ghcupDownloads :: GHCupDownloads , _globalTools :: Map GlobalTool DownloadInfo }- deriving (Show, GHC.Generic)+ deriving (Show, GHC.Generic, Eq) instance NFData GHCupInfo @@ -87,7 +87,7 @@ { _distroPKGs :: [Text] , _notes :: Text }- deriving (Show, GHC.Generic)+ deriving (Show, GHC.Generic, Eq) instance NFData Requirements
test/GHCup/Prelude/File/Posix/TraversalsSpec.hs view
@@ -24,11 +24,11 @@ -- https://github.com/haskell/ghcup-hs/issues/415 describe "GHCup.Prelude.File.Posix.Traversals" $ do it "readDirEnt" $ do- dirstream <- liftIO $ openDirStream "test/data"- (dt1, fp1) <- readDirEnt dirstream- (dt2, fp2) <- readDirEnt dirstream- (dt3, fp3) <- readDirEnt dirstream- (dt4, fp4) <- readDirEnt dirstream+ dirstream <- liftIO $ openDirStreamPortable "test/data"+ (dt1, fp1) <- readDirEntPortable dirstream+ (dt2, fp2) <- readDirEntPortable dirstream+ (dt3, fp3) <- readDirEntPortable dirstream+ (dt4, fp4) <- readDirEntPortable dirstream let xs = sortOn snd [ (dt1, fp1), (dt2, fp2) , (dt3, fp3), (dt4, fp4) ]