ghcup 0.1.17.10 → 0.1.18.0
raw patch · 76 files changed
+7888/−5768 lines, 76 filesdep +exceptionsdep +streamlydep ~bytestringdep ~generic-arbitraryPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: exceptions, streamly
Dependency ranges changed: bytestring, generic-arbitrary
API changes (from Hackage documentation)
- GHCup: ListAvailable :: ListCriteria
- GHCup: ListInstalled :: ListCriteria
- GHCup: ListResult :: Tool -> Version -> Maybe Text -> [Tag] -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> ListResult
- GHCup: ListSet :: ListCriteria
- GHCup: [fromSrc] :: ListResult -> Bool
- GHCup: [hlsPowered] :: ListResult -> Bool
- GHCup: [lCross] :: ListResult -> Maybe Text
- GHCup: [lInstalled] :: ListResult -> Bool
- GHCup: [lNoBindist] :: ListResult -> Bool
- GHCup: [lSet] :: ListResult -> Bool
- GHCup: [lStray] :: ListResult -> Bool
- GHCup: [lTag] :: ListResult -> [Tag]
- GHCup: [lTool] :: ListResult -> Tool
- GHCup: [lVer] :: ListResult -> Version
- GHCup: applyAnyPatch :: (MonadReader env m, HasDirs env, HasLog env, HasSettings env, MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m, MonadMask m, MonadIO m) => Maybe (Either FilePath [URI]) -> FilePath -> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
- GHCup: availableToolVersions :: GHCupDownloads -> Tool -> Map Version VersionInfo
- GHCup: data ListCriteria
- GHCup: data ListResult
- GHCup: installCabalBin :: (MonadMask m, MonadCatch m, MonadReader env m, HasPlatformReq env, HasGHCupInfo env, HasDirs env, HasSettings env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => Version -> InstallDir -> Bool -> Excepts '[AlreadyInstalled, CopyError, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError] m ()
- GHCup: installCabalBindist :: (MonadMask m, MonadCatch m, MonadReader env m, HasPlatformReq env, HasDirs env, HasSettings env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => DownloadInfo -> Version -> InstallDir -> Bool -> Excepts '[AlreadyInstalled, CopyError, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError] m ()
- GHCup: installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m) => FilePath -> InstallDirResolved -> Version -> Bool -> Excepts '[CopyError, FileAlreadyExistsError] m ()
- GHCup: installStackBin :: (MonadMask m, MonadCatch m, MonadReader env m, HasDirs env, HasSettings env, HasPlatformReq env, HasGHCupInfo env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => Version -> InstallDir -> Bool -> Excepts '[AlreadyInstalled, CopyError, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError] m ()
- GHCup: installStackBindist :: (MonadMask m, MonadCatch m, MonadReader env m, HasPlatformReq env, HasDirs env, HasSettings env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => DownloadInfo -> Version -> InstallDir -> Bool -> Excepts '[AlreadyInstalled, CopyError, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError] m ()
- GHCup: installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) => FilePath -> InstallDirResolved -> Version -> Bool -> Excepts '[CopyError, FileAlreadyExistsError] m ()
- GHCup: instance GHC.Classes.Eq GHCup.ListResult
- GHCup: instance GHC.Classes.Ord GHCup.ListResult
- GHCup: instance GHC.Show.Show GHCup.ListCriteria
- GHCup: instance GHC.Show.Show GHCup.ListResult
- GHCup: listVersions :: (MonadCatch m, HasLog env, MonadThrow m, HasLog env, MonadIO m, MonadReader env m, HasDirs env, HasPlatformReq env, HasGHCupInfo env) => Maybe Tool -> Maybe ListCriteria -> m [ListResult]
- GHCup: rmCabalVer :: (MonadMask m, MonadReader env m, HasDirs env, MonadThrow m, HasLog env, MonadIO m, MonadFail m, MonadCatch m, MonadUnliftIO m) => Version -> Excepts '[NotInstalled] m ()
- GHCup: rmStackVer :: (MonadMask m, MonadReader env m, HasDirs env, MonadThrow m, HasLog env, MonadIO m, MonadFail m, MonadCatch m, MonadUnliftIO m) => Version -> Excepts '[NotInstalled] m ()
- GHCup: setCabal :: (MonadMask m, MonadReader env m, HasDirs env, HasLog env, MonadFail m, MonadIO m, MonadUnliftIO m) => Version -> Excepts '[NotInstalled] m ()
- GHCup: setStack :: (MonadMask m, MonadReader env m, HasDirs env, HasLog env, MonadThrow m, MonadFail m, MonadIO m, MonadUnliftIO m) => Version -> Excepts '[NotInstalled] m ()
- GHCup: throwIfFileAlreadyExists :: MonadIO m => FilePath -> Excepts '[FileAlreadyExistsError] m ()
- GHCup: unsetCabal :: (MonadMask m, MonadReader env m, HasDirs env, MonadIO m) => m ()
- GHCup: unsetStack :: (MonadMask m, MonadReader env m, HasDirs env, MonadIO m) => m ()
- GHCup: warnAboutHlsCompatibility :: (MonadReader env m, HasDirs env, HasLog env, MonadThrow m, MonadCatch m, MonadIO m) => m ()
- GHCup.Errors: GHCupShadowed :: FilePath -> FilePath -> Version -> GHCupShadowed
- GHCup.Errors: data GHCupShadowed
- GHCup.Errors: instance GHC.Show.Show GHCup.Errors.GHCupShadowed
- GHCup.Errors: instance Text.PrettyPrint.HughesPJClass.Pretty GHCup.Errors.GHCupShadowed
- GHCup.Types: instance Control.DeepSeq.NFData GHCup.Types.Key
- GHCup.Types: instance GHC.Classes.Eq GHCup.Types.Key
- GHCup.Types: instance GHC.Classes.Ord GHCup.Types.Key
- GHCup.Types: instance GHC.Generics.Generic GHCup.Types.Key
- GHCup.Types: instance GHC.Read.Read GHCup.Types.Key
- GHCup.Types: instance GHC.Show.Show GHCup.Types.Key
- GHCup.Types.JSON: instance Data.Aeson.Types.FromJSON.FromJSON GHCup.Types.Key
- GHCup.Types.JSON: instance Data.Aeson.Types.ToJSON.ToJSON GHCup.Types.Key
- GHCup.Utils: createLink :: (MonadMask m, MonadThrow m, HasLog env, MonadIO m, MonadReader env m, HasDirs env, MonadUnliftIO m, MonadFail m) => FilePath -> FilePath -> m ()
- GHCup.Utils: exeExt :: String
- GHCup.Utils: exeExt' :: ByteString
- GHCup.Utils: getLinkTarget :: FilePath -> IO FilePath
- GHCup.Utils: pathIsLink :: FilePath -> IO Bool
- GHCup.Utils: rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
- GHCup.Utils.File: actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
- GHCup.Utils.File: captureOutStreams :: IO a -> IO CapturedProcess
- GHCup.Utils.File: chmod_755 :: (MonadReader env m, HasLog env, MonadIO m) => FilePath -> m ()
- GHCup.Utils.File: cleanup :: [Fd] -> IO ()
- GHCup.Utils.File: createRegularFileFd :: FileMode -> FilePath -> IO Fd
- GHCup.Utils.File: exec :: MonadIO m => String -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> m (Either ProcessError ())
- GHCup.Utils.File: execLogged :: (MonadReader env m, HasSettings env, HasLog env, HasDirs env, MonadIO m, MonadThrow m) => FilePath -> [String] -> Maybe FilePath -> FilePath -> Maybe [(String, String)] -> m (Either ProcessError ())
- GHCup.Utils.File: executeOut :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> m CapturedProcess
- GHCup.Utils.File: isBrokenSymlink :: FilePath -> IO Bool
- GHCup.Utils.File: newFilePerms :: FileMode
- GHCup.Utils.File: toProcessError :: FilePath -> [String] -> Maybe ProcessStatus -> Either ProcessError ()
- GHCup.Utils.File.Common: CapturedProcess :: ExitCode -> ByteString -> ByteString -> CapturedProcess
- GHCup.Utils.File.Common: NoSuchPid :: FilePath -> [String] -> ProcessError
- GHCup.Utils.File.Common: NonZeroExit :: Int -> FilePath -> [String] -> ProcessError
- GHCup.Utils.File.Common: PStopped :: FilePath -> [String] -> ProcessError
- GHCup.Utils.File.Common: PTerminated :: FilePath -> [String] -> ProcessError
- GHCup.Utils.File.Common: [$sel:_exitCode:CapturedProcess] :: CapturedProcess -> ExitCode
- GHCup.Utils.File.Common: [$sel:_stdErr:CapturedProcess] :: CapturedProcess -> ByteString
- GHCup.Utils.File.Common: [$sel:_stdOut:CapturedProcess] :: CapturedProcess -> ByteString
- GHCup.Utils.File.Common: checkFileAlreadyExists :: MonadIO m => FilePath -> m Bool
- GHCup.Utils.File.Common: data CapturedProcess
- GHCup.Utils.File.Common: data ProcessError
- GHCup.Utils.File.Common: expandFilePath :: [Either FilePath Regex] -> IO [FilePath]
- GHCup.Utils.File.Common: findFiles :: FilePath -> Regex -> IO [FilePath]
- GHCup.Utils.File.Common: findFiles' :: FilePath -> Parsec Void Text a -> IO [FilePath]
- GHCup.Utils.File.Common: findFilesDeep :: FilePath -> Regex -> IO [FilePath]
- GHCup.Utils.File.Common: isInPath :: FilePath -> IO Bool
- GHCup.Utils.File.Common: isShadowed :: FilePath -> IO (Maybe FilePath)
- GHCup.Utils.File.Common: searchPath :: [FilePath] -> FilePath -> IO (Maybe FilePath)
- GHCup.Utils.Logger: initGHCupFileLogging :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => m FilePath
- GHCup.Utils.Logger: logDebug :: (MonadReader env m, LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) => Text -> m ()
- GHCup.Utils.Logger: logError :: (MonadReader env m, LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) => Text -> m ()
- GHCup.Utils.Logger: logInfo :: (MonadReader env m, LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) => Text -> m ()
- GHCup.Utils.Logger: logInternal :: (MonadReader env m, LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) => LogLevel -> Text -> m ()
- GHCup.Utils.Logger: logWarn :: (MonadReader env m, LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) => Text -> m ()
- GHCup.Utils.MegaParsec: choice' :: (MonadFail f, MonadParsec e s f) => [f a] -> f a
- GHCup.Utils.MegaParsec: ghcProjectVersion :: Parsec Void Text Version
- GHCup.Utils.MegaParsec: ghcTargetBinP :: Text -> Parsec Void Text (Maybe Text, Text)
- GHCup.Utils.MegaParsec: ghcTargetVerP :: Parsec Void Text GHCTargetVersion
- GHCup.Utils.MegaParsec: parseUntil :: Parsec Void Text a -> Parsec Void Text Text
- GHCup.Utils.MegaParsec: parseUntil1 :: Parsec Void Text a -> Parsec Void Text Text
- GHCup.Utils.MegaParsec: pathSep :: Parsec Void Text Char
- GHCup.Utils.MegaParsec: verP :: Parsec Void Text Text -> Parsec Void Text Versioning
- GHCup.Utils.Prelude: (!?) :: forall e es a m. (Monad m, e :< es) => m (Maybe a) -> e -> Excepts es m a
- GHCup.Utils.Prelude: (??) :: forall e es a m. (Monad m, e :< es) => Maybe a -> e -> Excepts es m a
- GHCup.Utils.Prelude: breakOn :: Eq a => [a] -> [a] -> ([a], [a])
- GHCup.Utils.Prelude: catchWarn :: forall es m env. (Pretty (V es), MonadReader env m, HasLog env, MonadIO m, Monad m) => Excepts es m () -> Excepts '[] m ()
- GHCup.Utils.Prelude: copyDirectoryRecursive :: FilePath -> FilePath -> (FilePath -> FilePath -> IO ()) -> IO ()
- GHCup.Utils.Prelude: copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Excepts xs m ()
- GHCup.Utils.Prelude: createDirRecursive' :: FilePath -> IO ()
- GHCup.Utils.Prelude: decUTF8Safe :: ByteString -> Text
- GHCup.Utils.Prelude: decUTF8Safe' :: ByteString -> Text
- GHCup.Utils.Prelude: dropPrefix :: Eq a => [a] -> [a] -> [a]
- GHCup.Utils.Prelude: dropSuffix :: Eq a => [a] -> [a] -> [a]
- GHCup.Utils.Prelude: escapeVerRex :: Version -> ByteString
- GHCup.Utils.Prelude: fS :: IsString a => String -> a
- GHCup.Utils.Prelude: fSM :: Maybe a -> Maybe a
- GHCup.Utils.Prelude: findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
- GHCup.Utils.Prelude: forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
- GHCup.Utils.Prelude: fromEither :: Either a b -> VEither '[a] b
- GHCup.Utils.Prelude: fromStrictMaybe :: Maybe a -> Maybe a
- GHCup.Utils.Prelude: getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
- GHCup.Utils.Prelude: guardM :: (Monad m, Alternative m) => m Bool -> m ()
- GHCup.Utils.Prelude: handleIO' :: (MonadIO m, MonadCatch m) => IOErrorType -> (IOException -> m a) -> m a -> m a
- GHCup.Utils.Prelude: hideError :: (MonadIO m, MonadCatch m) => IOErrorType -> m () -> m ()
- GHCup.Utils.Prelude: hideErrorDef :: (MonadIO m, MonadCatch m) => [IOErrorType] -> a -> m a -> m a
- GHCup.Utils.Prelude: hideErrorDefM :: (MonadIO m, MonadCatch m) => [IOErrorType] -> m a -> m a -> m a
- GHCup.Utils.Prelude: hideExcept :: forall e es es' a m. (Monad m, e :< es, LiftVariant (Remove e es) es') => e -> a -> Excepts es m a -> Excepts es' m a
- GHCup.Utils.Prelude: hideExcept' :: forall e es es' m. (Monad m, e :< es, LiftVariant (Remove e es) es') => e -> Excepts es m () -> Excepts es' m ()
- GHCup.Utils.Prelude: iE :: String -> IO a
- GHCup.Utils.Prelude: ifM :: Monad m => m Bool -> m a -> m a -> m a
- GHCup.Utils.Prelude: intToText :: Integral a => a -> Text
- GHCup.Utils.Prelude: internalError :: String -> IO a
- GHCup.Utils.Prelude: isNewLine :: Word8 -> Bool
- GHCup.Utils.Prelude: isNotWindows :: Bool
- GHCup.Utils.Prelude: isWindows :: Bool
- GHCup.Utils.Prelude: lE :: forall e es a m. (Monad m, e :< es) => Either e a -> Excepts es m a
- GHCup.Utils.Prelude: lE' :: forall e' e es a m. (Monad m, e :< es) => (e' -> e) -> Either e' a -> Excepts es m a
- GHCup.Utils.Prelude: lEM :: forall e es a m. (Monad m, e :< es) => m (Either e a) -> Excepts es m a
- GHCup.Utils.Prelude: lEM' :: forall e' e es a m. (Monad m, e :< es) => (e' -> e) -> m (Either e' a) -> Excepts es m a
- GHCup.Utils.Prelude: liftIOException :: (MonadCatch m, MonadIO m, Monad m, e :< es') => IOErrorType -> e -> m a -> Excepts es' m a
- GHCup.Utils.Prelude: liftIOException' :: (MonadCatch m, MonadIO m, Monad m, e :< es', LiftVariant es es') => IOErrorType -> e -> Excepts es m a -> Excepts es' m a
- GHCup.Utils.Prelude: moveFile :: FilePath -> FilePath -> IO ()
- GHCup.Utils.Prelude: moveFilePortable :: FilePath -> FilePath -> IO ()
- GHCup.Utils.Prelude: pvpFromList :: [Int] -> PVP
- GHCup.Utils.Prelude: pvpToVersion :: MonadThrow m => PVP -> Text -> m Version
- GHCup.Utils.Prelude: reThrowAll :: forall e es es' a m. (Monad m, e :< es') => (V es -> e) -> Excepts es m a -> Excepts es' m a
- GHCup.Utils.Prelude: reThrowAllIO :: forall e es es' a m. (MonadCatch m, Monad m, MonadIO m, e :< es') => (V es -> e) -> (IOException -> e) -> Excepts es m a -> Excepts es' m a
- GHCup.Utils.Prelude: recover :: (MonadIO m, MonadMask m) => m a -> m a
- GHCup.Utils.Prelude: recycleFile :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env) => FilePath -> m ()
- GHCup.Utils.Prelude: recyclePathForcibly :: (MonadIO m, MonadReader env m, HasDirs env, MonadMask m) => FilePath -> m ()
- GHCup.Utils.Prelude: rmDirectory :: (MonadIO m, MonadMask m) => FilePath -> m ()
- GHCup.Utils.Prelude: rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env) => FilePath -> m ()
- GHCup.Utils.Prelude: rmFile :: (MonadIO m, MonadMask m) => FilePath -> m ()
- GHCup.Utils.Prelude: rmPathForcibly :: (MonadIO m, MonadMask m) => FilePath -> m ()
- GHCup.Utils.Prelude: showT :: Show a => a -> Text
- GHCup.Utils.Prelude: split :: (a -> Bool) -> [a] -> [[a]]
- GHCup.Utils.Prelude: splitOn :: Eq a => [a] -> [a] -> [[a]]
- GHCup.Utils.Prelude: splitOnPVP :: String -> String -> (String, String)
- GHCup.Utils.Prelude: stripNewline :: String -> String
- GHCup.Utils.Prelude: stripNewline' :: Text -> Text
- GHCup.Utils.Prelude: stripNewlineEnd :: String -> String
- GHCup.Utils.Prelude: stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
- GHCup.Utils.Prelude: tSM :: Maybe a -> Maybe a
- GHCup.Utils.Prelude: throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
- GHCup.Utils.Prelude: throwEither' :: (Exception a, MonadThrow m) => a -> Either x b -> m b
- GHCup.Utils.Prelude: throwMaybe :: (Exception a, MonadThrow m) => a -> Maybe b -> m b
- GHCup.Utils.Prelude: throwMaybeM :: (Exception a, MonadThrow m) => a -> m (Maybe b) -> m b
- GHCup.Utils.Prelude: toStrictMaybe :: Maybe a -> Maybe a
- GHCup.Utils.Prelude: traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
- GHCup.Utils.Prelude: unlessM :: Monad m => m Bool -> m () -> m ()
- GHCup.Utils.Prelude: verToBS :: Version -> ByteString
- GHCup.Utils.Prelude: verToS :: Version -> String
- GHCup.Utils.Prelude: versionToPVP :: MonadThrow m => Version -> m (PVP, Text)
- GHCup.Utils.Prelude: whenM :: Monad m => m Bool -> m () -> m ()
- GHCup.Utils.Prelude: whileM :: Monad m => m a -> (a -> m Bool) -> m a
- GHCup.Utils.Prelude: whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
- GHCup.Utils.String.QQ: s :: QuasiQuoter
- GHCup.Utils.Version.QQ: instance Data.Data.Data Data.Versions.MChunk
- GHCup.Utils.Version.QQ: instance Data.Data.Data Data.Versions.Mess
- GHCup.Utils.Version.QQ: instance Data.Data.Data Data.Versions.PVP
- GHCup.Utils.Version.QQ: instance Data.Data.Data Data.Versions.SemVer
- GHCup.Utils.Version.QQ: instance Data.Data.Data Data.Versions.VSep
- GHCup.Utils.Version.QQ: instance Data.Data.Data Data.Versions.VUnit
- GHCup.Utils.Version.QQ: instance Data.Data.Data Data.Versions.Version
- GHCup.Utils.Version.QQ: instance Data.Data.Data Data.Versions.Versioning
- GHCup.Utils.Version.QQ: instance Language.Haskell.TH.Syntax.Lift Data.Versions.MChunk
- GHCup.Utils.Version.QQ: instance Language.Haskell.TH.Syntax.Lift Data.Versions.Mess
- GHCup.Utils.Version.QQ: instance Language.Haskell.TH.Syntax.Lift Data.Versions.PVP
- GHCup.Utils.Version.QQ: instance Language.Haskell.TH.Syntax.Lift Data.Versions.SemVer
- GHCup.Utils.Version.QQ: instance Language.Haskell.TH.Syntax.Lift Data.Versions.VSep
- GHCup.Utils.Version.QQ: instance Language.Haskell.TH.Syntax.Lift Data.Versions.VUnit
- GHCup.Utils.Version.QQ: instance Language.Haskell.TH.Syntax.Lift Data.Versions.Version
- GHCup.Utils.Version.QQ: instance Language.Haskell.TH.Syntax.Lift Data.Versions.Versioning
- GHCup.Utils.Version.QQ: liftDataWithText :: Data a => a -> Q Exp
- GHCup.Utils.Version.QQ: liftText :: Text -> Q Exp
- GHCup.Utils.Version.QQ: mver :: QuasiQuoter
- GHCup.Utils.Version.QQ: pver :: QuasiQuoter
- GHCup.Utils.Version.QQ: qq :: (Text -> Q Exp) -> QuasiQuoter
- GHCup.Utils.Version.QQ: sver :: QuasiQuoter
- GHCup.Utils.Version.QQ: vers :: QuasiQuoter
- GHCup.Utils.Version.QQ: vver :: QuasiQuoter
+ GHCup: getCabalVersion :: (MonadIO m, MonadFail m) => FilePath -> m Version
+ GHCup.Cabal: installCabalBin :: (MonadMask m, MonadCatch m, MonadReader env m, HasPlatformReq env, HasGHCupInfo env, HasDirs env, HasSettings env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => Version -> InstallDir -> Bool -> Excepts '[AlreadyInstalled, CopyError, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError] m ()
+ GHCup.Cabal: installCabalBindist :: (MonadMask m, MonadCatch m, MonadReader env m, HasPlatformReq env, HasDirs env, HasSettings env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => DownloadInfo -> Version -> InstallDir -> Bool -> Excepts '[AlreadyInstalled, CopyError, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError] m ()
+ GHCup.Cabal: installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m) => FilePath -> InstallDirResolved -> Version -> Bool -> Excepts '[CopyError, FileAlreadyExistsError] m ()
+ GHCup.Cabal: rmCabalVer :: (MonadMask m, MonadReader env m, HasDirs env, MonadThrow m, HasLog env, MonadIO m, MonadFail m, MonadCatch m, MonadUnliftIO m) => Version -> Excepts '[NotInstalled] m ()
+ GHCup.Cabal: setCabal :: (MonadMask m, MonadReader env m, HasDirs env, HasLog env, MonadFail m, MonadIO m, MonadUnliftIO m) => Version -> Excepts '[NotInstalled] m ()
+ GHCup.Cabal: unsetCabal :: (MonadMask m, MonadReader env m, HasDirs env, MonadIO m) => m ()
+ GHCup.Errors: InstallSetError :: V xs1 -> V xs2 -> InstallSetError
+ GHCup.Errors: MergeFileTreeError :: IOException -> FilePath -> FilePath -> MergeFileTreeError
+ GHCup.Errors: ToolShadowed :: Tool -> FilePath -> FilePath -> Version -> ToolShadowed
+ GHCup.Errors: UninstallFailed :: FilePath -> [FilePath] -> UninstallFailed
+ GHCup.Errors: data InstallSetError
+ GHCup.Errors: data MergeFileTreeError
+ GHCup.Errors: data ToolShadowed
+ GHCup.Errors: data UninstallFailed
+ GHCup.Errors: instance GHC.Show.Show GHCup.Errors.DirNotEmpty
+ GHCup.Errors: instance GHC.Show.Show GHCup.Errors.InstallSetError
+ GHCup.Errors: instance GHC.Show.Show GHCup.Errors.MergeFileTreeError
+ GHCup.Errors: instance GHC.Show.Show GHCup.Errors.ToolShadowed
+ GHCup.Errors: instance GHC.Show.Show GHCup.Errors.UninstallFailed
+ GHCup.Errors: instance Text.PrettyPrint.HughesPJClass.Pretty GHCup.Errors.InstallSetError
+ GHCup.Errors: instance Text.PrettyPrint.HughesPJClass.Pretty GHCup.Errors.MergeFileTreeError
+ GHCup.Errors: instance Text.PrettyPrint.HughesPJClass.Pretty GHCup.Errors.ToolShadowed
+ GHCup.Errors: instance Text.PrettyPrint.HughesPJClass.Pretty GHCup.Errors.UninstallFailed
+ GHCup.GHC: GitDist :: GitBranch -> GHCVer v
+ GHCup.GHC: RemoteDist :: URI -> GHCVer v
+ GHCup.GHC: SourceDist :: v -> GHCVer v
+ GHCup.GHC: compileGHC :: (MonadMask m, MonadReader env m, HasDirs env, HasPlatformReq env, HasGHCupInfo env, HasSettings env, MonadThrow m, MonadResource m, HasLog env, MonadIO m, MonadUnliftIO m, MonadFail m) => GHCVer GHCTargetVersion -> Maybe Version -> Either Version FilePath -> Maybe Int -> Maybe FilePath -> Maybe (Either FilePath [URI]) -> [Text] -> Maybe String -> Bool -> InstallDir -> Excepts '[AlreadyInstalled, BuildFailed, DigestError, GPGError, DownloadFailed, GHCupSetError, NoDownload, NotFoundInPATH, PatchFailed, UnknownArchive, TarDirDoesNotExist, NotInstalled, DirNotEmpty, ArchiveResult, FileDoesNotExistError, HadrianNotFound, InvalidBuildConfig, ProcessError, CopyError, BuildFailed, UninstallFailed, MergeFileTreeError] m GHCTargetVersion
+ GHCup.GHC: data GHCVer v
+ GHCup.GHC: fetchGHCSrc :: (MonadFail m, MonadMask m, MonadCatch m, MonadReader env m, HasDirs env, HasSettings env, HasPlatformReq env, HasGHCupInfo env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m) => Version -> Maybe FilePath -> Excepts '[DigestError, GPGError, DownloadFailed, NoDownload] m FilePath
+ GHCup.GHC: installGHCBin :: (MonadFail m, MonadMask m, MonadCatch m, MonadReader env m, HasPlatformReq env, HasGHCupInfo env, HasDirs env, HasSettings env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m) => Version -> InstallDir -> Bool -> [Text] -> Excepts '[AlreadyInstalled, BuildFailed, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, DirNotEmpty, ArchiveResult, ProcessError, UninstallFailed, MergeFileTreeError] m ()
+ GHCup.GHC: installGHCBindist :: (MonadFail m, MonadMask m, MonadCatch m, MonadReader env m, HasDirs env, HasSettings env, HasPlatformReq env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m) => DownloadInfo -> Version -> InstallDir -> Bool -> [Text] -> Excepts '[AlreadyInstalled, BuildFailed, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, DirNotEmpty, ArchiveResult, ProcessError, UninstallFailed, MergeFileTreeError] m ()
+ GHCup.GHC: installPackedGHC :: (MonadMask m, MonadCatch m, MonadReader env m, HasDirs env, HasPlatformReq env, HasSettings env, MonadThrow m, HasLog env, MonadIO m, MonadUnliftIO m, MonadFail m, MonadResource m) => FilePath -> Maybe TarDir -> InstallDirResolved -> Version -> Bool -> [Text] -> Excepts '[BuildFailed, UnknownArchive, TarDirDoesNotExist, DirNotEmpty, ArchiveResult, ProcessError, MergeFileTreeError] m ()
+ GHCup.GHC: installUnpackedGHC :: (MonadReader env m, HasPlatformReq env, HasDirs env, HasSettings env, MonadThrow m, HasLog env, MonadIO m, MonadUnliftIO m, MonadMask m, MonadResource m, MonadFail m) => GHCupPath -> InstallDirResolved -> Version -> Bool -> [Text] -> Excepts '[ProcessError, MergeFileTreeError] m ()
+ GHCup.GHC: postGHCInstall :: (MonadReader env m, HasDirs env, HasLog env, MonadThrow m, MonadFail m, MonadIO m, MonadCatch m, MonadMask m, MonadUnliftIO m) => GHCTargetVersion -> Excepts '[NotInstalled] m ()
+ GHCup.GHC: rmGHCVer :: (MonadReader env m, HasDirs env, MonadThrow m, HasLog env, MonadIO m, MonadFail m, MonadCatch m, MonadMask m, MonadUnliftIO m) => GHCTargetVersion -> Excepts '[NotInstalled, UninstallFailed] m ()
+ GHCup.GHC: setGHC :: (MonadReader env m, HasDirs env, HasLog env, MonadThrow m, MonadFail m, MonadIO m, MonadCatch m, MonadMask m, MonadUnliftIO m) => GHCTargetVersion -> SetGHC -> Maybe FilePath -> Excepts '[NotInstalled] m GHCTargetVersion
+ GHCup.GHC: unsetGHC :: (MonadReader env m, HasDirs env, HasLog env, MonadThrow m, MonadFail m, MonadIO m, MonadMask m) => Maybe Text -> Excepts '[NotInstalled] m ()
+ GHCup.HLS: GitDist :: GitBranch -> HLSVer
+ GHCup.HLS: HackageDist :: Version -> HLSVer
+ GHCup.HLS: RemoteDist :: URI -> HLSVer
+ GHCup.HLS: SourceDist :: Version -> HLSVer
+ GHCup.HLS: compileHLS :: (MonadMask m, MonadCatch m, MonadReader env m, HasDirs env, HasSettings env, HasPlatformReq env, HasGHCupInfo env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => HLSVer -> [Version] -> Maybe Int -> Either Bool Version -> InstallDir -> Maybe (Either FilePath URI) -> Maybe URI -> Bool -> Maybe (Either FilePath [URI]) -> [Text] -> Excepts '[NoDownload, GPGError, DownloadFailed, DigestError, UnknownArchive, TarDirDoesNotExist, ArchiveResult, BuildFailed, NotInstalled] m Version
+ GHCup.HLS: data HLSVer
+ GHCup.HLS: getCabalVersion :: (MonadIO m, MonadFail m) => FilePath -> m Version
+ GHCup.HLS: installHLSBin :: (MonadMask m, MonadCatch m, MonadReader env m, HasPlatformReq env, HasGHCupInfo env, HasDirs env, HasSettings env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => Version -> InstallDir -> Bool -> Excepts '[AlreadyInstalled, CopyError, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError, ProcessError, DirNotEmpty, UninstallFailed, MergeFileTreeError] m ()
+ GHCup.HLS: installHLSBindist :: (MonadMask m, MonadCatch m, MonadReader env m, HasPlatformReq env, HasDirs env, HasSettings env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => DownloadInfo -> Version -> InstallDir -> Bool -> Excepts '[AlreadyInstalled, CopyError, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError, ProcessError, DirNotEmpty, UninstallFailed, MergeFileTreeError] m ()
+ GHCup.HLS: installHLSUnpacked :: (MonadMask m, MonadUnliftIO m, MonadReader env m, MonadFail m, HasLog env, HasDirs env, HasSettings env, MonadCatch m, MonadIO m, MonadResource m, HasPlatformReq env) => FilePath -> InstallDirResolved -> Version -> Bool -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled, MergeFileTreeError] m ()
+ GHCup.HLS: installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m) => FilePath -> InstallDirResolved -> Version -> Bool -> Excepts '[CopyError, FileAlreadyExistsError] m ()
+ GHCup.HLS: isLegacyHLSBindist :: FilePath -> IO Bool
+ GHCup.HLS: rmHLSVer :: (MonadMask m, MonadReader env m, HasDirs env, MonadThrow m, HasLog env, MonadIO m, MonadFail m, MonadCatch m, MonadUnliftIO m) => Version -> Excepts '[NotInstalled, UninstallFailed] m ()
+ GHCup.HLS: setHLS :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m, MonadMask m, MonadFail m, MonadUnliftIO m) => Version -> SetHLS -> Maybe FilePath -> Excepts '[NotInstalled] m ()
+ GHCup.HLS: unsetHLS :: (MonadMask m, MonadReader env m, HasDirs env, MonadIO m) => m ()
+ GHCup.List: ListAvailable :: ListCriteria
+ GHCup.List: ListInstalled :: ListCriteria
+ GHCup.List: ListResult :: Tool -> Version -> Maybe Text -> [Tag] -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> ListResult
+ GHCup.List: ListSet :: ListCriteria
+ GHCup.List: [fromSrc] :: ListResult -> Bool
+ GHCup.List: [hlsPowered] :: ListResult -> Bool
+ GHCup.List: [lCross] :: ListResult -> Maybe Text
+ GHCup.List: [lInstalled] :: ListResult -> Bool
+ GHCup.List: [lNoBindist] :: ListResult -> Bool
+ GHCup.List: [lSet] :: ListResult -> Bool
+ GHCup.List: [lStray] :: ListResult -> Bool
+ GHCup.List: [lTag] :: ListResult -> [Tag]
+ GHCup.List: [lTool] :: ListResult -> Tool
+ GHCup.List: [lVer] :: ListResult -> Version
+ GHCup.List: availableToolVersions :: GHCupDownloads -> Tool -> Map Version VersionInfo
+ GHCup.List: data ListCriteria
+ GHCup.List: data ListResult
+ GHCup.List: instance GHC.Classes.Eq GHCup.List.ListResult
+ GHCup.List: instance GHC.Classes.Ord GHCup.List.ListResult
+ GHCup.List: instance GHC.Show.Show GHCup.List.ListCriteria
+ GHCup.List: instance GHC.Show.Show GHCup.List.ListResult
+ GHCup.List: listVersions :: (MonadCatch m, HasLog env, MonadThrow m, HasLog env, MonadIO m, MonadReader env m, HasDirs env, HasPlatformReq env, HasGHCupInfo env) => Maybe Tool -> Maybe ListCriteria -> m [ListResult]
+ GHCup.Prelude: catchWarn :: forall es m env. (Pretty (V es), MonadReader env m, HasLog env, MonadIO m, Monad m) => Excepts es m () -> Excepts '[] m ()
+ GHCup.Prelude: enableAnsiSupport :: IO (Either String Bool)
+ GHCup.Prelude: isNotWindows :: Bool
+ GHCup.Prelude: isWindows :: Bool
+ GHCup.Prelude: runBothE' :: forall e m a b. (Monad m, Show (V e), Pretty (V e), PopVariant InstallSetError e, LiftVariant' e (InstallSetError : e), e :<< (InstallSetError : e)) => Excepts e m a -> Excepts e m b -> Excepts (InstallSetError : e) m ()
+ GHCup.Prelude: throwSomeE :: forall es' es a m. (Monad m, LiftVariant es' es) => V es' -> Excepts es m a
+ GHCup.Prelude.File: chmod_755 :: MonadIO m => FilePath -> m ()
+ GHCup.Prelude.File: copyFile :: FilePath -> FilePath -> Bool -> IO ()
+ GHCup.Prelude.File: copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Bool -> Excepts xs m ()
+ GHCup.Prelude.File: createDirRecursive' :: FilePath -> IO ()
+ GHCup.Prelude.File: createLink :: (MonadMask m, MonadThrow m, HasLog env, MonadIO m, MonadReader env m, HasDirs env, MonadUnliftIO m, MonadFail m) => FilePath -> FilePath -> m ()
+ GHCup.Prelude.File: deleteFile :: FilePath -> IO ()
+ GHCup.Prelude.File: exeExt :: String
+ GHCup.Prelude.File: exeExt' :: ByteString
+ GHCup.Prelude.File: findFilesDeep :: GHCupPath -> Regex -> IO [FilePath]
+ GHCup.Prelude.File: getDirectoryContentsRecursive :: (MonadCatch m, MonadAsync m, MonadMask m) => GHCupPath -> SerialT m FilePath
+ GHCup.Prelude.File: getDirectoryContentsRecursiveBFS :: (MonadCatch m, MonadAsync m, MonadMask m) => GHCupPath -> SerialT m FilePath
+ GHCup.Prelude.File: getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, MonadAsync m) => FilePath -> SerialT m FilePath
+ GHCup.Prelude.File: getDirectoryContentsRecursiveDFS :: (MonadCatch m, MonadAsync m, MonadMask m) => GHCupPath -> SerialT m FilePath
+ GHCup.Prelude.File: getDirectoryContentsRecursiveDFSUnsafe :: (MonadMask m, MonadIO m, MonadAsync m) => FilePath -> SerialT m FilePath
+ GHCup.Prelude.File: getDirectoryContentsRecursiveUnsafe :: (MonadCatch m, MonadAsync m, MonadMask m) => FilePath -> SerialT m FilePath
+ GHCup.Prelude.File: getLinkTarget :: FilePath -> IO FilePath
+ GHCup.Prelude.File: install :: FilePath -> FilePath -> Bool -> IO ()
+ GHCup.Prelude.File: isBrokenSymlink :: FilePath -> IO Bool
+ GHCup.Prelude.File: mergeFileTree :: (MonadMask m, MonadAsync m, MonadReader env m, HasDirs env, HasLog env, MonadCatch m) => GHCupPath -> InstallDirResolved -> Tool -> GHCTargetVersion -> (FilePath -> FilePath -> m ()) -> Excepts '[MergeFileTreeError] m ()
+ GHCup.Prelude.File: moveFile :: FilePath -> FilePath -> IO ()
+ GHCup.Prelude.File: moveFilePortable :: FilePath -> FilePath -> IO ()
+ GHCup.Prelude.File: pathIsLink :: FilePath -> IO Bool
+ GHCup.Prelude.File: recordedInstallationFile :: (MonadReader env m, HasDirs env) => Tool -> GHCTargetVersion -> m FilePath
+ GHCup.Prelude.File: recycleFile :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env) => FilePath -> m ()
+ GHCup.Prelude.File: recyclePathForcibly :: (MonadIO m, MonadReader env m, HasDirs env, MonadMask m) => GHCupPath -> m ()
+ GHCup.Prelude.File: removeDirIfEmptyOrIsSymlink :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
+ GHCup.Prelude.File: removeEmptyDirectory :: FilePath -> IO ()
+ GHCup.Prelude.File: removeEmptyDirsRecursive :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
+ GHCup.Prelude.File: rmDirectory :: (MonadIO m, MonadMask m) => GHCupPath -> m ()
+ GHCup.Prelude.File: rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env) => FilePath -> m ()
+ GHCup.Prelude.File: rmFile :: (MonadIO m, MonadMask m) => FilePath -> m ()
+ GHCup.Prelude.File: rmFileForce :: (MonadMask m, MonadIO m) => FilePath -> m ()
+ GHCup.Prelude.File: rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
+ GHCup.Prelude.File: rmPathForcibly :: (MonadIO m, MonadMask m) => GHCupPath -> m ()
+ GHCup.Prelude.File.Search: CapturedProcess :: ExitCode -> ByteString -> ByteString -> CapturedProcess
+ GHCup.Prelude.File.Search: NoSuchPid :: FilePath -> [String] -> ProcessError
+ GHCup.Prelude.File.Search: NonZeroExit :: Int -> FilePath -> [String] -> ProcessError
+ GHCup.Prelude.File.Search: PStopped :: FilePath -> [String] -> ProcessError
+ GHCup.Prelude.File.Search: PTerminated :: FilePath -> [String] -> ProcessError
+ GHCup.Prelude.File.Search: [$sel:_exitCode:CapturedProcess] :: CapturedProcess -> ExitCode
+ GHCup.Prelude.File.Search: [$sel:_stdErr:CapturedProcess] :: CapturedProcess -> ByteString
+ GHCup.Prelude.File.Search: [$sel:_stdOut:CapturedProcess] :: CapturedProcess -> ByteString
+ GHCup.Prelude.File.Search: data CapturedProcess
+ GHCup.Prelude.File.Search: data ProcessError
+ GHCup.Prelude.File.Search: expandFilePath :: [Either FilePath Regex] -> IO [FilePath]
+ GHCup.Prelude.File.Search: findFiles :: FilePath -> Regex -> IO [FilePath]
+ GHCup.Prelude.File.Search: findFiles' :: FilePath -> Parsec Void Text a -> IO [FilePath]
+ GHCup.Prelude.File.Search: isInPath :: FilePath -> IO Bool
+ GHCup.Prelude.File.Search: isShadowed :: FilePath -> IO (Maybe FilePath)
+ GHCup.Prelude.File.Search: searchPath :: [FilePath] -> FilePath -> IO (Maybe FilePath)
+ GHCup.Prelude.Internal: (!?) :: forall e es a m. (Monad m, e :< es) => m (Maybe a) -> e -> Excepts es m a
+ GHCup.Prelude.Internal: (??) :: forall e es a m. (Monad m, e :< es) => Maybe a -> e -> Excepts es m a
+ GHCup.Prelude.Internal: breakOn :: Eq a => [a] -> [a] -> ([a], [a])
+ GHCup.Prelude.Internal: decUTF8Safe :: ByteString -> Text
+ GHCup.Prelude.Internal: decUTF8Safe' :: ByteString -> Text
+ GHCup.Prelude.Internal: dropPrefix :: Eq a => [a] -> [a] -> [a]
+ GHCup.Prelude.Internal: dropSuffix :: Eq a => [a] -> [a] -> [a]
+ GHCup.Prelude.Internal: escapeVerRex :: Version -> ByteString
+ GHCup.Prelude.Internal: fS :: IsString a => String -> a
+ GHCup.Prelude.Internal: fSM :: Maybe a -> Maybe a
+ GHCup.Prelude.Internal: findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
+ GHCup.Prelude.Internal: forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
+ GHCup.Prelude.Internal: fromEither :: Either a b -> VEither '[a] b
+ GHCup.Prelude.Internal: fromStrictMaybe :: Maybe a -> Maybe a
+ GHCup.Prelude.Internal: guardM :: (Monad m, Alternative m) => m Bool -> m ()
+ GHCup.Prelude.Internal: handleIO' :: (MonadIO m, MonadCatch m) => IOErrorType -> (IOException -> m a) -> m a -> m a
+ GHCup.Prelude.Internal: hideError :: (MonadIO m, MonadCatch m) => IOErrorType -> m () -> m ()
+ GHCup.Prelude.Internal: hideErrorDef :: (MonadIO m, MonadCatch m) => [IOErrorType] -> a -> m a -> m a
+ GHCup.Prelude.Internal: hideErrorDefM :: (MonadIO m, MonadCatch m) => [IOErrorType] -> m a -> m a -> m a
+ GHCup.Prelude.Internal: hideExcept :: forall e es es' a m. (Monad m, e :< es, LiftVariant (Remove e es) es') => e -> a -> Excepts es m a -> Excepts es' m a
+ GHCup.Prelude.Internal: hideExcept' :: forall e es es' m. (Monad m, e :< es, LiftVariant (Remove e es) es') => e -> Excepts es m () -> Excepts es' m ()
+ GHCup.Prelude.Internal: iE :: String -> IO a
+ GHCup.Prelude.Internal: ifM :: Monad m => m Bool -> m a -> m a -> m a
+ GHCup.Prelude.Internal: intToText :: Integral a => a -> Text
+ GHCup.Prelude.Internal: internalError :: String -> IO a
+ GHCup.Prelude.Internal: isNewLine :: Word8 -> Bool
+ GHCup.Prelude.Internal: lE :: forall e es a m. (Monad m, e :< es) => Either e a -> Excepts es m a
+ GHCup.Prelude.Internal: lE' :: forall e' e es a m. (Monad m, e :< es) => (e' -> e) -> Either e' a -> Excepts es m a
+ GHCup.Prelude.Internal: lEM :: forall e es a m. (Monad m, e :< es) => m (Either e a) -> Excepts es m a
+ GHCup.Prelude.Internal: lEM' :: forall e' e es a m. (Monad m, e :< es) => (e' -> e) -> m (Either e' a) -> Excepts es m a
+ GHCup.Prelude.Internal: liftIOException :: (MonadCatch m, MonadIO m, Monad m, e :< es') => IOErrorType -> e -> m a -> Excepts es' m a
+ GHCup.Prelude.Internal: liftIOException' :: (MonadCatch m, MonadIO m, Monad m, e :< es', LiftVariant es es') => IOErrorType -> e -> Excepts es m a -> Excepts es' m a
+ GHCup.Prelude.Internal: reThrowAll :: forall e es es' a m. (Monad m, e :< es') => (V es -> e) -> Excepts es m a -> Excepts es' m a
+ GHCup.Prelude.Internal: reThrowAllIO :: forall e es es' a m. (MonadCatch m, Monad m, MonadIO m, e :< es') => (V es -> e) -> (IOException -> e) -> Excepts es m a -> Excepts es' m a
+ GHCup.Prelude.Internal: recover :: (MonadIO m, MonadMask m) => m a -> m a
+ GHCup.Prelude.Internal: showT :: Show a => a -> Text
+ GHCup.Prelude.Internal: split :: (a -> Bool) -> [a] -> [[a]]
+ GHCup.Prelude.Internal: splitOn :: Eq a => [a] -> [a] -> [[a]]
+ GHCup.Prelude.Internal: splitOnPVP :: String -> String -> (String, String)
+ GHCup.Prelude.Internal: stripNewline :: String -> String
+ GHCup.Prelude.Internal: stripNewline' :: Text -> Text
+ GHCup.Prelude.Internal: stripNewlineEnd :: String -> String
+ GHCup.Prelude.Internal: stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
+ GHCup.Prelude.Internal: tSM :: Maybe a -> Maybe a
+ GHCup.Prelude.Internal: throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
+ GHCup.Prelude.Internal: throwEither' :: (Exception a, MonadThrow m) => a -> Either x b -> m b
+ GHCup.Prelude.Internal: throwMaybe :: (Exception a, MonadThrow m) => a -> Maybe b -> m b
+ GHCup.Prelude.Internal: throwMaybeM :: (Exception a, MonadThrow m) => a -> m (Maybe b) -> m b
+ GHCup.Prelude.Internal: toStrictMaybe :: Maybe a -> Maybe a
+ GHCup.Prelude.Internal: traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
+ GHCup.Prelude.Internal: unlessM :: Monad m => m Bool -> m () -> m ()
+ GHCup.Prelude.Internal: verToBS :: Version -> ByteString
+ GHCup.Prelude.Internal: verToS :: Version -> String
+ GHCup.Prelude.Internal: whenM :: Monad m => m Bool -> m () -> m ()
+ GHCup.Prelude.Internal: whileM :: Monad m => m a -> (a -> m Bool) -> m a
+ GHCup.Prelude.Internal: whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
+ GHCup.Prelude.Logger: initGHCupFileLogging :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => m FilePath
+ GHCup.Prelude.Logger.Internal: logDebug :: (MonadReader env m, LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) => Text -> m ()
+ GHCup.Prelude.Logger.Internal: logError :: (MonadReader env m, LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) => Text -> m ()
+ GHCup.Prelude.Logger.Internal: logInfo :: (MonadReader env m, LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) => Text -> m ()
+ GHCup.Prelude.Logger.Internal: logInternal :: (MonadReader env m, LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) => LogLevel -> Text -> m ()
+ GHCup.Prelude.Logger.Internal: logWarn :: (MonadReader env m, LabelOptic' "loggerConfig" A_Lens env LoggerConfig, MonadIO m) => Text -> m ()
+ GHCup.Prelude.MegaParsec: choice' :: (MonadFail f, MonadParsec e s f) => [f a] -> f a
+ GHCup.Prelude.MegaParsec: ghcProjectVersion :: Parsec Void Text Version
+ GHCup.Prelude.MegaParsec: ghcTargetBinP :: Text -> Parsec Void Text (Maybe Text, Text)
+ GHCup.Prelude.MegaParsec: ghcTargetVerP :: Parsec Void Text GHCTargetVersion
+ GHCup.Prelude.MegaParsec: parseUntil :: Parsec Void Text a -> Parsec Void Text Text
+ GHCup.Prelude.MegaParsec: parseUntil1 :: Parsec Void Text a -> Parsec Void Text Text
+ GHCup.Prelude.MegaParsec: pathSep :: Parsec Void Text Char
+ GHCup.Prelude.MegaParsec: verP :: Parsec Void Text Text -> Parsec Void Text Versioning
+ GHCup.Prelude.Process: exec :: MonadIO m => String -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> m (Either ProcessError ())
+ GHCup.Prelude.Process: execLogged :: (MonadReader env m, HasSettings env, HasLog env, HasDirs env, MonadIO m, MonadThrow m) => FilePath -> [String] -> Maybe FilePath -> FilePath -> Maybe [(String, String)] -> m (Either ProcessError ())
+ GHCup.Prelude.Process: executeOut :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> m CapturedProcess
+ GHCup.Prelude.Process: toProcessError :: FilePath -> [String] -> Maybe ProcessStatus -> Either ProcessError ()
+ GHCup.Prelude.String.QQ: s :: QuasiQuoter
+ GHCup.Prelude.Version.QQ: instance Data.Data.Data Data.Versions.MChunk
+ GHCup.Prelude.Version.QQ: instance Data.Data.Data Data.Versions.Mess
+ GHCup.Prelude.Version.QQ: instance Data.Data.Data Data.Versions.PVP
+ GHCup.Prelude.Version.QQ: instance Data.Data.Data Data.Versions.SemVer
+ GHCup.Prelude.Version.QQ: instance Data.Data.Data Data.Versions.VSep
+ GHCup.Prelude.Version.QQ: instance Data.Data.Data Data.Versions.VUnit
+ GHCup.Prelude.Version.QQ: instance Data.Data.Data Data.Versions.Version
+ GHCup.Prelude.Version.QQ: instance Data.Data.Data Data.Versions.Versioning
+ GHCup.Prelude.Version.QQ: instance Language.Haskell.TH.Syntax.Lift Data.Versions.MChunk
+ GHCup.Prelude.Version.QQ: instance Language.Haskell.TH.Syntax.Lift Data.Versions.Mess
+ GHCup.Prelude.Version.QQ: instance Language.Haskell.TH.Syntax.Lift Data.Versions.PVP
+ GHCup.Prelude.Version.QQ: instance Language.Haskell.TH.Syntax.Lift Data.Versions.SemVer
+ GHCup.Prelude.Version.QQ: instance Language.Haskell.TH.Syntax.Lift Data.Versions.VSep
+ GHCup.Prelude.Version.QQ: instance Language.Haskell.TH.Syntax.Lift Data.Versions.VUnit
+ GHCup.Prelude.Version.QQ: instance Language.Haskell.TH.Syntax.Lift Data.Versions.Version
+ GHCup.Prelude.Version.QQ: instance Language.Haskell.TH.Syntax.Lift Data.Versions.Versioning
+ GHCup.Prelude.Version.QQ: liftDataWithText :: Data a => a -> Q Exp
+ GHCup.Prelude.Version.QQ: liftText :: Text -> Q Exp
+ GHCup.Prelude.Version.QQ: mver :: QuasiQuoter
+ GHCup.Prelude.Version.QQ: pver :: QuasiQuoter
+ GHCup.Prelude.Version.QQ: qq :: (Text -> Q Exp) -> QuasiQuoter
+ GHCup.Prelude.Version.QQ: sver :: QuasiQuoter
+ GHCup.Prelude.Version.QQ: vers :: QuasiQuoter
+ GHCup.Prelude.Version.QQ: vver :: QuasiQuoter
+ GHCup.Prompts: PromptNo :: PromptResponse
+ GHCup.Prompts: PromptYes :: PromptResponse
+ GHCup.Prompts: data PromptResponse
+ GHCup.Prompts: getUserPromptResponse :: (HasLog env, MonadReader env m, MonadIO m) => PromptQuestion -> m PromptResponse
+ GHCup.Prompts: type PromptQuestion = Text
+ GHCup.Stack: installStackBin :: (MonadMask m, MonadCatch m, MonadReader env m, HasDirs env, HasSettings env, HasPlatformReq env, HasGHCupInfo env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => Version -> InstallDir -> Bool -> Excepts '[AlreadyInstalled, CopyError, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError] m ()
+ GHCup.Stack: installStackBindist :: (MonadMask m, MonadCatch m, MonadReader env m, HasPlatformReq env, HasDirs env, HasSettings env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => DownloadInfo -> Version -> InstallDir -> Bool -> Excepts '[AlreadyInstalled, CopyError, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError] m ()
+ GHCup.Stack: installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) => GHCupPath -> InstallDirResolved -> Version -> Bool -> Excepts '[CopyError, FileAlreadyExistsError] m ()
+ GHCup.Stack: rmStackVer :: (MonadMask m, MonadReader env m, HasDirs env, MonadThrow m, HasLog env, MonadIO m, MonadFail m, MonadCatch m, MonadUnliftIO m) => Version -> Excepts '[NotInstalled] m ()
+ GHCup.Stack: setStack :: (MonadMask m, MonadReader env m, HasDirs env, HasLog env, MonadThrow m, MonadFail m, MonadIO m, MonadUnliftIO m) => Version -> Excepts '[NotInstalled] m ()
+ GHCup.Stack: unsetStack :: (MonadMask m, MonadReader env m, HasDirs env, MonadIO m) => m ()
+ GHCup.Types: GHCupBinDir :: FilePath -> InstallDirResolved
+ GHCup.Types: PromptNo :: PromptResponse
+ GHCup.Types: PromptYes :: PromptResponse
+ GHCup.Types: [$sel:dbDir:Dirs] :: Dirs -> GHCupPath
+ GHCup.Types: [$sel:tmpDir:Dirs] :: Dirs -> GHCupPath
+ GHCup.Types: data PromptResponse
+ GHCup.Types: fromAppState :: AppState -> LeanAppState
+ GHCup.Types: instance Control.DeepSeq.NFData Graphics.Vty.Input.Events.Key
+ GHCup.Types: instance GHC.Classes.Eq GHCup.Types.PromptResponse
+ GHCup.Types: instance GHC.Show.Show GHCup.Types.PromptResponse
+ GHCup.Types: isSafeDir :: InstallDirResolved -> Bool
+ GHCup.Types: type PromptQuestion = Text
+ GHCup.Types.JSON: instance Data.Aeson.Types.FromJSON.FromJSON Graphics.Vty.Input.Events.Key
+ GHCup.Types.JSON: instance Data.Aeson.Types.ToJSON.ToJSON Graphics.Vty.Input.Events.Key
+ GHCup.Utils: applyAnyPatch :: (MonadReader env m, HasDirs env, HasLog env, HasSettings env, MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m, MonadMask m, MonadIO m) => Maybe (Either FilePath [URI]) -> FilePath -> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()
+ GHCup.Utils: cleanFinally :: (MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m, MonadCatch m) => GHCupPath -> Excepts e m a -> Excepts e m a
+ GHCup.Utils: getInstalledFiles :: (MonadIO m, MonadCatch m, MonadReader env m, HasDirs env, MonadFail m) => Tool -> GHCTargetVersion -> m (Maybe [FilePath])
+ GHCup.Utils: gitOut :: (MonadReader env m, HasLog env, MonadIO m) => [String] -> FilePath -> Excepts '[ProcessError] m Text
+ GHCup.Utils: isCommitHash :: String -> Bool
+ GHCup.Utils: isNotWindows :: Bool
+ GHCup.Utils: isWindows :: Bool
+ GHCup.Utils: processBranches :: Text -> [String]
+ GHCup.Utils: warnAboutHlsCompatibility :: (MonadReader env m, HasDirs env, HasLog env, MonadThrow m, MonadCatch m, MonadIO m) => m ()
+ GHCup.Utils.Dirs: XdgCache :: XdgDirectory
+ GHCup.Utils.Dirs: XdgConfig :: XdgDirectory
+ GHCup.Utils.Dirs: XdgConfigDirs :: XdgDirectoryList
+ GHCup.Utils.Dirs: XdgData :: XdgDirectory
+ GHCup.Utils.Dirs: XdgDataDirs :: XdgDirectoryList
+ GHCup.Utils.Dirs: appendGHCupPath :: GHCupPath -> FilePath -> GHCupPath
+ GHCup.Utils.Dirs: canonicalizePath :: FilePath -> IO FilePath
+ GHCup.Utils.Dirs: copyPermissions :: FilePath -> FilePath -> IO ()
+ GHCup.Utils.Dirs: createDirectory :: FilePath -> IO ()
+ GHCup.Utils.Dirs: createDirectoryIfMissing :: Bool -> FilePath -> IO ()
+ GHCup.Utils.Dirs: createDirectoryLink :: FilePath -> FilePath -> IO ()
+ GHCup.Utils.Dirs: createFileLink :: FilePath -> FilePath -> IO ()
+ GHCup.Utils.Dirs: createTempGHCupDirectory :: GHCupPath -> FilePath -> IO GHCupPath
+ GHCup.Utils.Dirs: data GHCupPath
+ GHCup.Utils.Dirs: data Permissions
+ GHCup.Utils.Dirs: data XdgDirectory
+ GHCup.Utils.Dirs: data XdgDirectoryList
+ GHCup.Utils.Dirs: doesDirectoryExist :: FilePath -> IO Bool
+ GHCup.Utils.Dirs: doesFileExist :: FilePath -> IO Bool
+ GHCup.Utils.Dirs: doesPathExist :: FilePath -> IO Bool
+ GHCup.Utils.Dirs: emptyPermissions :: Permissions
+ GHCup.Utils.Dirs: exeExtension :: String
+ GHCup.Utils.Dirs: executable :: Permissions -> Bool
+ GHCup.Utils.Dirs: findExecutable :: String -> IO (Maybe FilePath)
+ GHCup.Utils.Dirs: findExecutables :: String -> IO [FilePath]
+ GHCup.Utils.Dirs: findExecutablesInDirectories :: [FilePath] -> String -> IO [FilePath]
+ GHCup.Utils.Dirs: findFile :: [FilePath] -> String -> IO (Maybe FilePath)
+ GHCup.Utils.Dirs: findFileWith :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO (Maybe FilePath)
+ GHCup.Utils.Dirs: findFilesWith :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO [FilePath]
+ GHCup.Utils.Dirs: fromGHCupPath :: GHCupPath -> FilePath
+ GHCup.Utils.Dirs: getAccessTime :: FilePath -> IO UTCTime
+ GHCup.Utils.Dirs: getAppUserDataDirectory :: FilePath -> IO FilePath
+ GHCup.Utils.Dirs: getCurrentDirectory :: IO FilePath
+ GHCup.Utils.Dirs: getDirectoryContents :: FilePath -> IO [FilePath]
+ GHCup.Utils.Dirs: getFileSize :: FilePath -> IO Integer
+ GHCup.Utils.Dirs: getGHCupTmpDirs :: IO [GHCupPath]
+ GHCup.Utils.Dirs: getHomeDirectory :: IO FilePath
+ GHCup.Utils.Dirs: getModificationTime :: FilePath -> IO UTCTime
+ GHCup.Utils.Dirs: getPermissions :: FilePath -> IO Permissions
+ GHCup.Utils.Dirs: getSymbolicLinkTarget :: FilePath -> IO FilePath
+ GHCup.Utils.Dirs: getTemporaryDirectory :: IO FilePath
+ GHCup.Utils.Dirs: getUserDocumentsDirectory :: IO FilePath
+ GHCup.Utils.Dirs: getXdgDirectory :: XdgDirectory -> FilePath -> IO FilePath
+ GHCup.Utils.Dirs: getXdgDirectoryList :: XdgDirectoryList -> IO [FilePath]
+ GHCup.Utils.Dirs: instance Control.DeepSeq.NFData GHCup.Utils.Dirs.GHCupPath
+ GHCup.Utils.Dirs: instance GHC.Classes.Eq GHCup.Utils.Dirs.GHCupPath
+ GHCup.Utils.Dirs: instance GHC.Classes.Ord GHCup.Utils.Dirs.GHCupPath
+ GHCup.Utils.Dirs: instance GHC.Show.Show GHCup.Utils.Dirs.GHCupPath
+ GHCup.Utils.Dirs: isSymbolicLink :: FilePath -> IO Bool
+ GHCup.Utils.Dirs: listDirectory :: FilePath -> IO [FilePath]
+ GHCup.Utils.Dirs: makeAbsolute :: FilePath -> IO FilePath
+ GHCup.Utils.Dirs: makeRelativeToCurrentDirectory :: FilePath -> IO FilePath
+ GHCup.Utils.Dirs: pathIsSymbolicLink :: FilePath -> IO Bool
+ GHCup.Utils.Dirs: readable :: Permissions -> Bool
+ GHCup.Utils.Dirs: removeDirectory :: GHCupPath -> IO ()
+ GHCup.Utils.Dirs: removeDirectoryLink :: FilePath -> IO ()
+ GHCup.Utils.Dirs: removeDirectoryRecursive :: GHCupPath -> IO ()
+ GHCup.Utils.Dirs: removeFile :: FilePath -> IO ()
+ GHCup.Utils.Dirs: removePathForcibly :: GHCupPath -> IO ()
+ GHCup.Utils.Dirs: renameDirectory :: FilePath -> FilePath -> IO ()
+ GHCup.Utils.Dirs: renameFile :: FilePath -> FilePath -> IO ()
+ GHCup.Utils.Dirs: renamePath :: FilePath -> FilePath -> IO ()
+ GHCup.Utils.Dirs: searchable :: Permissions -> Bool
+ GHCup.Utils.Dirs: setAccessTime :: FilePath -> UTCTime -> IO ()
+ GHCup.Utils.Dirs: setCurrentDirectory :: FilePath -> IO ()
+ GHCup.Utils.Dirs: setModificationTime :: FilePath -> UTCTime -> IO ()
+ GHCup.Utils.Dirs: setOwnerExecutable :: Bool -> Permissions -> Permissions
+ GHCup.Utils.Dirs: setOwnerReadable :: Bool -> Permissions -> Permissions
+ GHCup.Utils.Dirs: setOwnerSearchable :: Bool -> Permissions -> Permissions
+ GHCup.Utils.Dirs: setOwnerWritable :: Bool -> Permissions -> Permissions
+ GHCup.Utils.Dirs: setPermissions :: FilePath -> Permissions -> IO ()
+ GHCup.Utils.Dirs: withCurrentDirectory :: FilePath -> IO a -> IO a
+ GHCup.Utils.Dirs: writable :: Permissions -> Bool
+ GHCup.Version: pvpFromList :: [Int] -> PVP
+ GHCup.Version: pvpToVersion :: MonadThrow m => PVP -> Text -> m Version
+ GHCup.Version: versionToPVP :: MonadThrow m => Version -> m (PVP, Text)
- GHCup: compileGHC :: (MonadMask m, MonadReader env m, HasDirs env, HasPlatformReq env, HasGHCupInfo env, HasSettings env, MonadThrow m, MonadResource m, HasLog env, MonadIO m, MonadUnliftIO m, MonadFail m) => Either GHCTargetVersion GitBranch -> Maybe Version -> Either Version FilePath -> Maybe Int -> Maybe FilePath -> Maybe (Either FilePath [URI]) -> [Text] -> Maybe String -> Bool -> InstallDir -> Excepts '[AlreadyInstalled, BuildFailed, DigestError, GPGError, DownloadFailed, GHCupSetError, NoDownload, NotFoundInPATH, PatchFailed, UnknownArchive, TarDirDoesNotExist, NotInstalled, DirNotEmpty, ArchiveResult, FileDoesNotExistError, HadrianNotFound, InvalidBuildConfig, ProcessError, CopyError, BuildFailed] m GHCTargetVersion
+ GHCup: compileGHC :: (MonadMask m, MonadReader env m, HasDirs env, HasPlatformReq env, HasGHCupInfo env, HasSettings env, MonadThrow m, MonadResource m, HasLog env, MonadIO m, MonadUnliftIO m, MonadFail m) => GHCVer GHCTargetVersion -> Maybe Version -> Either Version FilePath -> Maybe Int -> Maybe FilePath -> Maybe (Either FilePath [URI]) -> [Text] -> Maybe String -> Bool -> InstallDir -> Excepts '[AlreadyInstalled, BuildFailed, DigestError, GPGError, DownloadFailed, GHCupSetError, NoDownload, NotFoundInPATH, PatchFailed, UnknownArchive, TarDirDoesNotExist, NotInstalled, DirNotEmpty, ArchiveResult, FileDoesNotExistError, HadrianNotFound, InvalidBuildConfig, ProcessError, CopyError, BuildFailed, UninstallFailed, MergeFileTreeError] m GHCTargetVersion
- GHCup: compileHLS :: (MonadMask m, MonadCatch m, MonadReader env m, HasDirs env, HasSettings env, HasPlatformReq env, HasGHCupInfo env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => Either Version GitBranch -> [Version] -> Maybe Int -> Maybe Version -> InstallDir -> Maybe (Either FilePath URI) -> Maybe URI -> Maybe (Either FilePath [URI]) -> [Text] -> Excepts '[NoDownload, GPGError, DownloadFailed, DigestError, UnknownArchive, TarDirDoesNotExist, ArchiveResult, BuildFailed, NotInstalled] m Version
+ GHCup: compileHLS :: (MonadMask m, MonadCatch m, MonadReader env m, HasDirs env, HasSettings env, HasPlatformReq env, HasGHCupInfo env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => HLSVer -> [Version] -> Maybe Int -> Either Bool Version -> InstallDir -> Maybe (Either FilePath URI) -> Maybe URI -> Bool -> Maybe (Either FilePath [URI]) -> [Text] -> Excepts '[NoDownload, GPGError, DownloadFailed, DigestError, UnknownArchive, TarDirDoesNotExist, ArchiveResult, BuildFailed, NotInstalled] m Version
- GHCup: installGHCBin :: (MonadFail m, MonadMask m, MonadCatch m, MonadReader env m, HasPlatformReq env, HasGHCupInfo env, HasDirs env, HasSettings env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m) => Version -> InstallDir -> Bool -> Excepts '[AlreadyInstalled, BuildFailed, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, DirNotEmpty, ArchiveResult, ProcessError] m ()
+ GHCup: installGHCBin :: (MonadFail m, MonadMask m, MonadCatch m, MonadReader env m, HasPlatformReq env, HasGHCupInfo env, HasDirs env, HasSettings env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m) => Version -> InstallDir -> Bool -> [Text] -> Excepts '[AlreadyInstalled, BuildFailed, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, DirNotEmpty, ArchiveResult, ProcessError, UninstallFailed, MergeFileTreeError] m ()
- GHCup: installGHCBindist :: (MonadFail m, MonadMask m, MonadCatch m, MonadReader env m, HasDirs env, HasSettings env, HasPlatformReq env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m) => DownloadInfo -> Version -> InstallDir -> Bool -> Excepts '[AlreadyInstalled, BuildFailed, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, DirNotEmpty, ArchiveResult, ProcessError] m ()
+ GHCup: installGHCBindist :: (MonadFail m, MonadMask m, MonadCatch m, MonadReader env m, HasDirs env, HasSettings env, HasPlatformReq env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m) => DownloadInfo -> Version -> InstallDir -> Bool -> [Text] -> Excepts '[AlreadyInstalled, BuildFailed, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, DirNotEmpty, ArchiveResult, ProcessError, UninstallFailed, MergeFileTreeError] m ()
- GHCup: installHLSBin :: (MonadMask m, MonadCatch m, MonadReader env m, HasPlatformReq env, HasGHCupInfo env, HasDirs env, HasSettings env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => Version -> InstallDir -> Bool -> Excepts '[AlreadyInstalled, CopyError, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError, ProcessError, DirNotEmpty] m ()
+ GHCup: installHLSBin :: (MonadMask m, MonadCatch m, MonadReader env m, HasPlatformReq env, HasGHCupInfo env, HasDirs env, HasSettings env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => Version -> InstallDir -> Bool -> Excepts '[AlreadyInstalled, CopyError, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError, ProcessError, DirNotEmpty, UninstallFailed, MergeFileTreeError] m ()
- GHCup: installHLSBindist :: (MonadMask m, MonadCatch m, MonadReader env m, HasPlatformReq env, HasDirs env, HasSettings env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => DownloadInfo -> Version -> InstallDir -> Bool -> Excepts '[AlreadyInstalled, CopyError, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError, ProcessError, DirNotEmpty] m ()
+ GHCup: installHLSBindist :: (MonadMask m, MonadCatch m, MonadReader env m, HasPlatformReq env, HasDirs env, HasSettings env, HasLog env, MonadResource m, MonadIO m, MonadUnliftIO m, MonadFail m) => DownloadInfo -> Version -> InstallDir -> Bool -> Excepts '[AlreadyInstalled, CopyError, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError, ProcessError, DirNotEmpty, UninstallFailed, MergeFileTreeError] m ()
- GHCup: installHLSUnpacked :: (MonadMask m, MonadUnliftIO m, MonadReader env m, MonadFail m, HasLog env, HasDirs env, HasSettings env, MonadCatch m, MonadIO m) => FilePath -> InstallDirResolved -> Version -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m ()
+ GHCup: installHLSUnpacked :: (MonadMask m, MonadUnliftIO m, MonadReader env m, MonadFail m, HasLog env, HasDirs env, HasSettings env, MonadCatch m, MonadIO m, MonadResource m, HasPlatformReq env) => FilePath -> InstallDirResolved -> Version -> Bool -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled, MergeFileTreeError] m ()
- GHCup: installPackedGHC :: (MonadMask m, MonadCatch m, MonadReader env m, HasDirs env, HasPlatformReq env, HasSettings env, MonadThrow m, HasLog env, MonadIO m, MonadUnliftIO m, MonadFail m) => FilePath -> Maybe TarDir -> InstallDirResolved -> Version -> Bool -> Excepts '[BuildFailed, UnknownArchive, TarDirDoesNotExist, DirNotEmpty, ArchiveResult, ProcessError] m ()
+ GHCup: installPackedGHC :: (MonadMask m, MonadCatch m, MonadReader env m, HasDirs env, HasPlatformReq env, HasSettings env, MonadThrow m, HasLog env, MonadIO m, MonadUnliftIO m, MonadFail m, MonadResource m) => FilePath -> Maybe TarDir -> InstallDirResolved -> Version -> Bool -> [Text] -> Excepts '[BuildFailed, UnknownArchive, TarDirDoesNotExist, DirNotEmpty, ArchiveResult, ProcessError, MergeFileTreeError] m ()
- GHCup: installUnpackedGHC :: (MonadReader env m, HasPlatformReq env, HasDirs env, HasSettings env, MonadThrow m, HasLog env, MonadIO m, MonadUnliftIO m, MonadMask m) => FilePath -> InstallDirResolved -> Version -> Excepts '[ProcessError] m ()
+ GHCup: installUnpackedGHC :: (MonadReader env m, HasPlatformReq env, HasDirs env, HasSettings env, MonadThrow m, HasLog env, MonadIO m, MonadUnliftIO m, MonadMask m, MonadResource m, MonadFail m) => GHCupPath -> InstallDirResolved -> Version -> Bool -> [Text] -> Excepts '[ProcessError, MergeFileTreeError] m ()
- GHCup: rmGHCVer :: (MonadReader env m, HasDirs env, MonadThrow m, HasLog env, MonadIO m, MonadFail m, MonadCatch m, MonadMask m, MonadUnliftIO m) => GHCTargetVersion -> Excepts '[NotInstalled] m ()
+ GHCup: rmGHCVer :: (MonadReader env m, HasDirs env, MonadThrow m, HasLog env, MonadIO m, MonadFail m, MonadCatch m, MonadMask m, MonadUnliftIO m) => GHCTargetVersion -> Excepts '[NotInstalled, UninstallFailed] m ()
- GHCup: rmHLSNoGHC :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m, MonadMask m, MonadFail m, MonadUnliftIO m) => Excepts '[NotInstalled] m ()
+ GHCup: rmHLSNoGHC :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m, MonadMask m, MonadFail m, MonadUnliftIO m) => Excepts '[NotInstalled, UninstallFailed] m ()
- GHCup: rmHLSVer :: (MonadMask m, MonadReader env m, HasDirs env, MonadThrow m, HasLog env, MonadIO m, MonadFail m, MonadCatch m, MonadUnliftIO m) => Version -> Excepts '[NotInstalled] m ()
+ GHCup: rmHLSVer :: (MonadMask m, MonadReader env m, HasDirs env, MonadThrow m, HasLog env, MonadIO m, MonadFail m, MonadCatch m, MonadUnliftIO m) => Version -> Excepts '[NotInstalled, UninstallFailed] m ()
- GHCup: rmOldGHC :: (MonadReader env m, HasGHCupInfo env, HasDirs env, HasLog env, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m) => Excepts '[NotInstalled] m ()
+ GHCup: rmOldGHC :: (MonadReader env m, HasGHCupInfo env, HasDirs env, HasLog env, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m) => Excepts '[NotInstalled, UninstallFailed] m ()
- GHCup: rmTool :: (MonadReader env m, HasDirs env, HasLog env, MonadFail m, MonadMask m, MonadUnliftIO m) => ListResult -> Excepts '[NotInstalled] m ()
+ GHCup: rmTool :: (MonadReader env m, HasDirs env, HasLog env, MonadFail m, MonadMask m, MonadUnliftIO m) => ListResult -> Excepts '[NotInstalled, UninstallFailed] m ()
- GHCup: upgradeGHCup :: (MonadMask m, MonadReader env m, HasDirs env, HasPlatformReq env, HasGHCupInfo env, HasSettings env, MonadCatch m, HasLog env, MonadThrow m, MonadFail m, MonadResource m, MonadIO m, MonadUnliftIO m) => Maybe FilePath -> Bool -> Bool -> Excepts '[CopyError, DigestError, GPGError, GPGError, DownloadFailed, NoDownload, NoUpdate, GHCupShadowed] m Version
+ GHCup: upgradeGHCup :: (MonadMask m, MonadReader env m, HasDirs env, HasPlatformReq env, HasGHCupInfo env, HasSettings env, MonadCatch m, HasLog env, MonadThrow m, MonadFail m, MonadResource m, MonadIO m, MonadUnliftIO m) => Maybe FilePath -> Bool -> Bool -> Excepts '[CopyError, DigestError, GPGError, GPGError, DownloadFailed, NoDownload, NoUpdate, ToolShadowed] m Version
- GHCup.Types: Dirs :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> Dirs
+ GHCup.Types: Dirs :: GHCupPath -> FilePath -> GHCupPath -> GHCupPath -> GHCupPath -> GHCupPath -> GHCupPath -> GHCupPath -> Dirs
- GHCup.Types: GHCupDir :: FilePath -> InstallDirResolved
+ GHCup.Types: GHCupDir :: GHCupPath -> InstallDirResolved
- GHCup.Types: [$sel:baseDir:Dirs] :: Dirs -> FilePath
+ GHCup.Types: [$sel:baseDir:Dirs] :: Dirs -> GHCupPath
- GHCup.Types: [$sel:cacheDir:Dirs] :: Dirs -> FilePath
+ GHCup.Types: [$sel:cacheDir:Dirs] :: Dirs -> GHCupPath
- GHCup.Types: [$sel:confDir:Dirs] :: Dirs -> FilePath
+ GHCup.Types: [$sel:confDir:Dirs] :: Dirs -> GHCupPath
- GHCup.Types: [$sel:logsDir:Dirs] :: Dirs -> FilePath
+ GHCup.Types: [$sel:logsDir:Dirs] :: Dirs -> GHCupPath
- GHCup.Types: [$sel:recycleDir:Dirs] :: Dirs -> FilePath
+ GHCup.Types: [$sel:recycleDir:Dirs] :: Dirs -> GHCupPath
- GHCup.Utils: cleanUpOnError :: (MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m, MonadCatch m) => FilePath -> Excepts e m a -> Excepts e m a
+ GHCup.Utils: cleanUpOnError :: forall e m a env. (MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m, MonadCatch m) => GHCupPath -> Excepts e m a -> Excepts e m a
- GHCup.Utils: installDestSanityCheck :: (MonadIO m, MonadCatch m) => InstallDirResolved -> Excepts '[DirNotEmpty] m ()
+ GHCup.Utils: installDestSanityCheck :: (MonadIO m, MonadCatch m, MonadMask m) => InstallDirResolved -> Excepts '[DirNotEmpty] m ()
- GHCup.Utils: intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m) => FilePath -> TarDir -> Excepts '[TarDirDoesNotExist] m FilePath
+ GHCup.Utils: intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m) => GHCupPath -> TarDir -> Excepts '[TarDirDoesNotExist] m GHCupPath
- GHCup.Utils: rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
+ GHCup.Utils: rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => GHCupPath -> m ()
- GHCup.Utils: runBuildAction :: (MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m, MonadCatch m) => FilePath -> Maybe FilePath -> Excepts e m a -> Excepts e m a
+ GHCup.Utils: runBuildAction :: (MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m, HasLog env, MonadUnliftIO m, MonadFail m, MonadCatch m) => GHCupPath -> Excepts e m a -> Excepts e m a
- GHCup.Utils.Dirs: ghcupBaseDir :: IO FilePath
+ GHCup.Utils.Dirs: ghcupBaseDir :: IO GHCupPath
- GHCup.Utils.Dirs: ghcupCacheDir :: IO FilePath
+ GHCup.Utils.Dirs: ghcupCacheDir :: IO GHCupPath
- GHCup.Utils.Dirs: ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
+ GHCup.Utils.Dirs: ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath
- GHCup.Utils.Dirs: ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m FilePath
+ GHCup.Utils.Dirs: ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m GHCupPath
- GHCup.Utils.Dirs: ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
+ GHCup.Utils.Dirs: ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath
- GHCup.Utils.Dirs: ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m) => Version -> m FilePath
+ GHCup.Utils.Dirs: ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m) => Version -> m GHCupPath
- GHCup.Utils.Dirs: mkGhcupTmpDir :: (MonadReader env m, HasDirs env, MonadUnliftIO m, HasLog env, MonadCatch m, MonadThrow m, MonadMask m, MonadIO m) => m FilePath
+ GHCup.Utils.Dirs: mkGhcupTmpDir :: (MonadReader env m, HasDirs env, MonadUnliftIO m, HasLog env, MonadCatch m, MonadThrow m, MonadMask m, MonadIO m) => m GHCupPath
- GHCup.Utils.Dirs: withGHCupTmpDir :: (MonadReader env m, HasDirs env, HasLog env, HasSettings env, MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m, MonadMask m, MonadIO m) => m FilePath
+ GHCup.Utils.Dirs: withGHCupTmpDir :: (MonadReader env m, HasDirs env, HasLog env, HasSettings env, MonadUnliftIO m, MonadCatch m, MonadResource m, MonadThrow m, MonadMask m, MonadIO m) => m GHCupPath
Files
- CHANGELOG.md +27/−0
- app/ghcup/BrickMain.hs +41/−12
- app/ghcup/GHCup/OptParse/ChangeLog.hs +10/−8
- app/ghcup/GHCup/OptParse/Common.hs +54/−29
- app/ghcup/GHCup/OptParse/Compile.hs +92/−35
- app/ghcup/GHCup/OptParse/Config.hs +3/−4
- app/ghcup/GHCup/OptParse/DInfo.hs +3/−3
- app/ghcup/GHCup/OptParse/GC.hs +11/−11
- app/ghcup/GHCup/OptParse/Install.hs +75/−149
- app/ghcup/GHCup/OptParse/List.hs +1/−1
- app/ghcup/GHCup/OptParse/Nuke.hs +2/−2
- app/ghcup/GHCup/OptParse/Prefetch.hs +12/−12
- app/ghcup/GHCup/OptParse/Rm.hs +5/−5
- app/ghcup/GHCup/OptParse/Run.hs +134/−91
- app/ghcup/GHCup/OptParse/Set.hs +28/−25
- app/ghcup/GHCup/OptParse/ToolRequirements.hs +3/−3
- app/ghcup/GHCup/OptParse/UnSet.hs +2/−2
- app/ghcup/GHCup/OptParse/Upgrade.hs +3/−2
- app/ghcup/GHCup/OptParse/Whereis.hs +28/−13
- app/ghcup/Main.hs +18/−15
- cbits/dirutils.c +7/−0
- ghcup.cabal +41/−21
- lib/GHCup.hs +600/−2937
- lib/GHCup/Cabal.hs +284/−0
- lib/GHCup/Download.hs +8/−8
- lib/GHCup/Download/IOStreams.hs +1/−1
- lib/GHCup/Download/Utils.hs +1/−1
- lib/GHCup/Errors.hs +39/−7
- lib/GHCup/GHC.hs +1157/−0
- lib/GHCup/HLS.hs +723/−0
- lib/GHCup/List.hs +410/−0
- lib/GHCup/Platform.hs +5/−5
- lib/GHCup/Prelude.hs +82/−0
- lib/GHCup/Prelude/File.hs +426/−0
- lib/GHCup/Prelude/File/Posix.hs +324/−0
- lib/GHCup/Prelude/File/Posix/Foreign.hsc +58/−0
- lib/GHCup/Prelude/File/Posix/Traversals.hs +92/−0
- lib/GHCup/Prelude/File/Search.hs +115/−0
- lib/GHCup/Prelude/File/Windows.hs +311/−0
- lib/GHCup/Prelude/Internal.hs +519/−0
- lib/GHCup/Prelude/Logger.hs +61/−0
- lib/GHCup/Prelude/Logger/Internal.hs +103/−0
- lib/GHCup/Prelude/MegaParsec.hs +124/−0
- lib/GHCup/Prelude/Posix.hs +19/−0
- lib/GHCup/Prelude/Process.hs +25/−0
- lib/GHCup/Prelude/Process/Posix.hs +362/−0
- lib/GHCup/Prelude/Process/Windows.hs +278/−0
- lib/GHCup/Prelude/String/QQ.hs +57/−0
- lib/GHCup/Prelude/Version/QQ.hs +107/−0
- lib/GHCup/Prelude/Windows.hs +53/−0
- lib/GHCup/Prompts.hs +28/−0
- lib/GHCup/Stack.hs +283/−0
- lib/GHCup/Types.hs +28/−8
- lib/GHCup/Types/JSON.hs +36/−34
- lib/GHCup/Utils.hs +176/−139
- lib/GHCup/Utils.hs-boot +0/−4
- lib/GHCup/Utils/Dirs.hs +235/−67
- lib/GHCup/Utils/Dirs.hs-boot +37/−0
- lib/GHCup/Utils/File.hs +0/−17
- lib/GHCup/Utils/File/Common.hs +0/−111
- lib/GHCup/Utils/File/Common.hs-boot +0/−5
- lib/GHCup/Utils/File/Posix.hs +0/−401
- lib/GHCup/Utils/File/Windows.hs +0/−271
- lib/GHCup/Utils/Logger.hs +0/−130
- lib/GHCup/Utils/Logger.hs-boot +0/−19
- lib/GHCup/Utils/MegaParsec.hs +0/−124
- lib/GHCup/Utils/Posix.hs +0/−14
- lib/GHCup/Utils/Prelude.hs +0/−765
- lib/GHCup/Utils/Prelude/Posix.hs +0/−20
- lib/GHCup/Utils/Prelude/Windows.hs +0/−17
- lib/GHCup/Utils/String/QQ.hs +0/−57
- lib/GHCup/Utils/Version/QQ.hs +0/−107
- lib/GHCup/Utils/Windows.hs +0/−48
- lib/GHCup/Version.hs +62/−6
- test/GHCup/Utils/FileSpec.hs +58/−0
- test/Main.hs +1/−2
CHANGELOG.md view
@@ -1,5 +1,32 @@ # Revision history for ghcup +## 0.1.18.0 -- 2022-07-30++* Fix tui set wrt [#266](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/266) by Arjun Kathuria+ - Ask the user to install the tool via prompt when setting an non-installed version+* improvements to safe (un-)installations+ - bindists that don't support `make DESTDIR=/some/tmp/dir install` are now unsupported+ - installed GHC files are now recorded to avoid use of `removePathForcibly`+ - internally uses a newtype wrapper for user-input paths and restrict destructive operations to validated paths+* Add `--disable-ld-override` for darwin bindists wrt #391+* Allow passing bindist configure args wrt #377+* use of `TMPDIR` is dropped... now uses an internal tmp dir `~/.ghcup/tmp`+* improvements to error handling and warnings+* Require --isolate to have an absolute directory, fixes #367+* Fix mingw PATH handling wrt #371+* Add --mingw-path switch to `ghcup run`+* Fix `ghcup run` on windows, fixes #375+* Improve `ghcup compile <hls|ghc>`+ - short hashes now work+ - print the long hash in addition to the detected version+* Improve `ghcup compile hls`+ - add `--git-describe-version` switch as an alternative to `--overwrite-version`+ - Allow to build HLS from hackage (now is the default)+ - Allow to run 'cabal update' automatically before the HLS build+ - Fix parser and completer for 'ghcup compile hls --version'+* Improve `ghcup compile ghc`+ - Allow to build from arbitrary GHC source dists+ ## 0.1.17.10 -- 2022-05-12 * windows hotfix (hackage-only release)
app/ghcup/BrickMain.hs view
@@ -13,9 +13,11 @@ import GHCup.Types.Optics ( getDirs ) import GHCup.Types hiding ( LeanAppState(..) ) import GHCup.Utils-import GHCup.Utils.Logger-import GHCup.Utils.Prelude ( decUTF8Safe )-import GHCup.Utils.File+import GHCup.Prelude ( decUTF8Safe )+import GHCup.Prelude.File+import GHCup.Prelude.Logger+import GHCup.Prelude.Process+import GHCup.Prompts import Brick import Brick.Widgets.Border@@ -44,7 +46,6 @@ import Data.Versions hiding ( str ) import Haskus.Utils.Variant.Excepts import Prelude hiding ( appendFile )-import System.Directory ( canonicalizePath ) import System.FilePath import System.Exit import System.IO.Unsafe@@ -52,6 +53,8 @@ import URI.ByteString import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as B+import qualified Data.Text.Lazy as L import qualified Graphics.Vty as Vty import qualified Data.Vector as V import System.Environment (getExecutablePath)@@ -98,7 +101,7 @@ [ (bQuit, const "Quit" , halt) , (bInstall, const "Install" , withIOAction install') , (bUninstall, const "Uninstall", withIOAction del')- , (bSet, const "Set" , withIOAction ((liftIO .) . set'))+ , (bSet, const "Set" , withIOAction set') , (bChangelog, const "ChangeLog", withIOAction changelog') , ( bShowAllVersions , \BrickSettings {..} ->@@ -437,7 +440,9 @@ , TarDirDoesNotExist , FileAlreadyExistsError , ProcessError- , GHCupShadowed+ , ToolShadowed+ , UninstallFailed+ , MergeFileTreeError ] run (do@@ -447,7 +452,7 @@ case lTool of GHC -> do let vi = getVersionInfo lVer GHC dls- liftE $ installGHCBin lVer GHCupInternal False $> (vi, dirs, ce)+ liftE $ installGHCBin lVer GHCupInternal False [] $> (vi, dirs, ce) Cabal -> do let vi = getVersionInfo lVer Cabal dls liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce)@@ -484,9 +489,12 @@ <> "Also check the logs in ~/.ghcup/logs" -set' :: BrickState -> (Int, ListResult) -> IO (Either String ())-set' _ (_, ListResult {..}) = do- settings <- readIORef settings'+set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)+ => BrickState+ -> (Int, ListResult)+ -> m (Either String ())+set' bs input@(_, ListResult {..}) = do+ settings <- liftIO $ readIORef settings' let run = flip runReaderT settings@@ -502,9 +510,30 @@ ) >>= \case VRight _ -> pure $ Right ()- VLeft e -> pure $ Left (prettyShow e)+ VLeft e -> case e of+ (V (NotInstalled tool _)) -> do+ promptAnswer <- getUserPromptResponse userPrompt+ case promptAnswer of+ PromptYes -> do+ res <- install' bs input+ case res of+ (Left err) -> pure $ Left err+ (Right _) -> do+ logInfo "Setting now..."+ set' bs input + PromptNo -> pure $ Left (prettyShow e)+ where+ userPrompt = L.toStrict . B.toLazyText . B.fromString $+ "This Version of "+ <> show tool+ <> " you are trying to set is not installed.\n"+ <> "Would you like to install it first? [Y/N]: " + _ -> pure $ Left (prettyShow e)+++ del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m) => BrickState -> (Int, ListResult)@@ -512,7 +541,7 @@ del' _ (_, ListResult {..}) = do AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask - let run = runE @'[NotInstalled]+ let run = runE @'[NotInstalled, UninstallFailed] run (do let vi = getVersionInfo lVer lTool dls
app/ghcup/GHCup/OptParse/ChangeLog.hs view
@@ -12,9 +12,11 @@ import GHCup.Types-import GHCup.Utils.Logger import GHCup.OptParse.Common-import GHCup.Utils.String.QQ+import GHCup.Prelude+import GHCup.Prelude.Logger+import GHCup.Prelude.String.QQ+import GHCup.Prelude.Process (exec) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail )@@ -34,8 +36,6 @@ import GHCup.Utils import Data.Versions import URI.ByteString (serializeURIRef')-import GHCup.Utils.Prelude-import GHCup.Utils.File (exec) import Data.Char (toLower) @@ -58,7 +58,7 @@ --[ Parsers ]-- --------------- - + changelogP :: Parser ChangeLogOptions changelogP = (\x y -> ChangeLogOptions x y)@@ -71,15 +71,16 @@ "cabal" -> Right Cabal "ghcup" -> Right GHCup "stack" -> Right Stack+ "hls" -> Right HLS e -> Left e ) )- (short 't' <> long "tool" <> metavar "<ghc|cabal|ghcup>" <> help+ (short 't' <> long "tool" <> metavar "<ghc|cabal|hls|ghcup>" <> help "Open changelog for given tool (default: ghc)" <> completer toolCompleter ) )- <*> optional (toolVersionArgument Nothing Nothing)+ <*> optional (toolVersionTagArgument Nothing Nothing) @@ -116,7 +117,8 @@ ver' = maybe (Right Latest) (\case- ToolVersion tv -> Left (_tvVersion tv) -- FIXME: ugly sharing of ToolVersion+ GHCVersion tv -> Left (_tvVersion tv)+ ToolVersion tv -> Left tv ToolTag t -> Right t ) clToolVer
app/ghcup/GHCup/OptParse/Common.hs view
@@ -16,10 +16,10 @@ import GHCup.Types import GHCup.Types.Optics import GHCup.Utils-import GHCup.Utils.File-import GHCup.Utils.Logger-import GHCup.Utils.MegaParsec-import GHCup.Utils.Prelude+import GHCup.Prelude+import GHCup.Prelude.Process+import GHCup.Prelude.Logger+import GHCup.Prelude.MegaParsec import Control.DeepSeq import Control.Concurrent@@ -52,7 +52,6 @@ import Options.Applicative hiding ( style ) import Prelude hiding ( appendFile ) import Safe-import System.Directory import System.Process ( readProcess ) import System.FilePath import Text.HTML.TagSoup hiding ( Tag )@@ -71,20 +70,24 @@ --[ Types ]-- ------------- -data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal+data ToolVersion = GHCVersion GHCTargetVersion+ | ToolVersion Version | ToolTag Tag -- a superset of ToolVersion-data SetToolVersion = SetToolVersion GHCTargetVersion+data SetToolVersion = SetGHCVersion GHCTargetVersion+ | SetToolVersion Version | SetToolTag Tag | SetRecommended | SetNext prettyToolVer :: ToolVersion -> String-prettyToolVer (ToolVersion v') = T.unpack $ tVerToText v'+prettyToolVer (GHCVersion v') = T.unpack $ tVerToText v'+prettyToolVer (ToolVersion v') = T.unpack $ prettyVer v' prettyToolVer (ToolTag t) = show t toSetToolVer :: Maybe ToolVersion -> SetToolVersion+toSetToolVer (Just (GHCVersion v')) = SetGHCVersion v' toSetToolVer (Just (ToolVersion v')) = SetToolVersion v' toSetToolVer (Just (ToolTag t')) = SetToolTag t' toSetToolVer Nothing = SetRecommended@@ -97,10 +100,9 @@ -------------- --- | same as toolVersionParser, except as an argument.-toolVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion-toolVersionArgument criteria tool =- argument (eitherReader toolVersionEither)+toolVersionTagArgument :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion+toolVersionTagArgument criteria tool =+ argument (eitherReader (parser tool)) (metavar (mv tool) <> completer (tagCompleter (fromMaybe GHC tool) []) <> foldMap (completer . versionCompleter criteria) tool)@@ -109,20 +111,19 @@ mv (Just HLS) = "HLS_VERSION|TAG" mv _ = "VERSION|TAG" + parser (Just GHC) = ghcVersionTagEither+ parser Nothing = ghcVersionTagEither+ parser _ = toolVersionTagEither -versionParser :: Parser GHCTargetVersion-versionParser = option- (eitherReader tVersionEither)- (short 'v' <> long "version" <> metavar "VERSION" <> help "The target version"- ) versionParser' :: Maybe ListCriteria -> Maybe Tool -> Parser Version versionParser' criteria tool = argument (eitherReader (first show . version . T.pack)) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool) -versionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion-versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool)+ghcVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion+ghcVersionArgument criteria tool = argument (eitherReader ghcVersionEither)+ (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool) -- https://github.com/pcapriotti/optparse-applicative/issues/148@@ -227,14 +228,20 @@ False -> Left "Please enter a valid absolute filepath." isolateParser :: FilePath -> Either String FilePath-isolateParser f = case isValid f of+isolateParser f = case isValid f && isAbsolute f of True -> Right $ normalise f False -> Left "Please enter a valid filepath for isolate dir." -toolVersionEither :: String -> Either String ToolVersion-toolVersionEither s' =- second ToolTag (tagEither s') <|> second ToolVersion (tVersionEither s')+-- this accepts cross prefix+ghcVersionTagEither :: String -> Either String ToolVersion+ghcVersionTagEither s' =+ second ToolTag (tagEither s') <|> second GHCVersion (ghcVersionEither s') +-- this ignores cross prefix+toolVersionTagEither :: String -> Either String ToolVersion+toolVersionTagEither s' =+ second ToolTag (tagEither s') <|> second ToolVersion (toolVersionEither s')+ tagEither :: String -> Either String Tag tagEither s' = case fmap toLower s' of "recommended" -> Right Recommended@@ -245,11 +252,15 @@ other -> Left $ "Unknown tag " <> other -tVersionEither :: String -> Either String GHCTargetVersion-tVersionEither =+ghcVersionEither :: String -> Either String GHCTargetVersion+ghcVersionEither = first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack +toolVersionEither :: String -> Either String Version+toolVersionEither =+ first (const "Not a valid version") . MP.parse version' "" . T.pack + toolParser :: String -> Either String Tool toolParser s' | t == T.pack "ghc" = Right GHC | t == T.pack "cabal" = Right Cabal@@ -441,9 +452,11 @@ pure $ nub $ (add ++) $ fmap tagToString allTags VLeft _ -> pure (nub $ ["recommended", "latest"] ++ add) - versionCompleter :: Maybe ListCriteria -> Tool -> Completer-versionCompleter criteria tool = listIOCompleter $ do+versionCompleter criteria tool = versionCompleter' criteria tool (const True)++versionCompleter' :: Maybe ListCriteria -> Tool -> (Version -> Bool) -> Completer+versionCompleter' criteria tool filter' = listIOCompleter $ do dirs' <- liftIO getAllDirs let loggerConfig = LoggerConfig { lcPrintDebug = False@@ -472,7 +485,7 @@ runEnv = flip runReaderT appState installedVersions <- runEnv $ listVersions (Just tool) criteria- return $ T.unpack . prettyVer . lVer <$> installedVersions+ return $ fmap (T.unpack . prettyVer) . filter filter' . fmap lVer $ installedVersions toolDlCompleter :: Tool -> Completer@@ -664,7 +677,7 @@ GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo bimap mkTVer Just <$> getRecommended dls tool ?? TagNotFound Recommended tool-fromVersion' (SetToolVersion v) tool = do+fromVersion' (SetGHCVersion v) tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo (_tvVersion v) tool dls case pvp $ prettyVer (_tvVersion v) of -- need to be strict here@@ -676,6 +689,18 @@ when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') pure (GHCTargetVersion (_tvTarget v) v', Just vi') Nothing -> pure (v, vi)+fromVersion' (SetToolVersion v) tool = do+ GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo+ let vi = getVersionInfo v tool dls+ case pvp $ prettyVer v of -- need to be strict here+ Left _ -> pure (mkTVer v, vi)+ Right pvpIn ->+ lift (getLatestToolFor tool pvpIn dls) >>= \case+ Just (pvp_, vi') -> do+ v' <- lift $ pvpToVersion pvp_ ""+ when (v' /= v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')+ pure (GHCTargetVersion mempty v', Just vi')+ Nothing -> pure (mkTVer v, vi) fromVersion' (SetToolTag Latest) tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo bimap mkTVer Just <$> getLatest dls tool ?? TagNotFound Latest tool
app/ghcup/GHCup/OptParse/Compile.hs view
@@ -12,14 +12,15 @@ import GHCup+import qualified GHCup.GHC as GHC+import qualified GHCup.HLS as HLS import GHCup.Errors-import GHCup.Utils.File import GHCup.Types import GHCup.Types.Optics import GHCup.Utils-import GHCup.Utils.Logger+import GHCup.Prelude.Logger+import GHCup.Prelude.String.QQ import GHCup.OptParse.Common-import GHCup.Utils.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail )@@ -31,7 +32,8 @@ import Data.Bifunctor import Data.Functor import Data.Maybe-import Data.Versions ( Version, prettyVer, version )+import Data.Versions ( Version, prettyVer, version, pvp )+import qualified Data.Versions as V import Data.Text ( Text ) import Haskus.Utils.Variant.Excepts import Options.Applicative hiding ( style )@@ -42,7 +44,7 @@ import URI.ByteString hiding ( uriParser ) import qualified Data.Text as T-import Control.Exception.Safe (MonadMask)+import Control.Exception.Safe (MonadMask, displayException) import System.FilePath (isPathSeparator) import Text.Read (readEither) @@ -65,7 +67,7 @@ data GHCCompileOptions = GHCCompileOptions- { targetGhc :: Either Version GitBranch+ { targetGhc :: GHC.GHCVer Version , bootstrapGhc :: Either Version FilePath , jobs :: Maybe Int , buildConfig :: Maybe FilePath@@ -79,11 +81,13 @@ , isolateDir :: Maybe FilePath } + data HLSCompileOptions = HLSCompileOptions- { targetHLS :: Either Version GitBranch+ { targetHLS :: HLS.HLSVer , jobs :: Maybe Int , setCompile :: Bool- , ovewrwiteVer :: Maybe Version+ , updateCabal :: Bool+ , ovewrwiteVer :: Either Bool Version , isolateDir :: Maybe FilePath , cabalProject :: Maybe (Either FilePath URI) , cabalProjectLocal :: Maybe URI@@ -146,20 +150,22 @@ compileHLSFooter = [s|Discussion: Compiles and installs the specified HLS version.- The last argument is a list of GHC versions to compile for.+ The --ghc arguments are necessary to specify which GHC version to build for/against. These need to be available in PATH prior to compilation. Examples:- # compile 1.4.0 for ghc 8.10.5 and 8.10.7- ghcup compile hls -v 1.4.0 -j 12 --ghc 8.10.5 --ghc 8.10.7- # compile from master for ghc 8.10.7, linking everything dynamically- ghcup compile hls -g master -j 12 --ghc 8.10.7 -- --ghc-options='-dynamic'|]+ # compile 1.7.0.0 from hackage for 8.10.7, running 'cabal update' before the build+ ghcup compile hls --version 1.7.0.0 --ghc 8.10.7 --cabal-update+ # compile from master for ghc 9.2.3 using 'git describe' to name the binary and ignore the pinned index state+ ghcup compile hls -g master --git-describe-version --ghc 9.2.3 -- --index-state=@(date '+%s')+ # compile a specific commit for ghc 9.2.3 and set a specifc version for the binary name+ ghcup compile hls -g a32db0b -o 1.7.0.0-p1 --ghc 9.2.3|] ghcCompileOpts :: Parser GHCCompileOptions ghcCompileOpts = GHCCompileOptions- <$> ((Left <$> option+ <$> ((GHC.SourceDist <$> option (eitherReader (first (const "Not a valid version") . version . T.pack) )@@ -168,7 +174,7 @@ <> (completer $ versionCompleter Nothing GHC) ) ) <|>- (Right <$> (GitBranch <$> option+ (GHC.GitDist <$> (GitBranch <$> option str (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help "The git commit/branch/ref to build from"@@ -177,7 +183,18 @@ short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to GHC upstream)" <> completer (gitFileUri ["https://gitlab.haskell.org/ghc/ghc.git"]) ))- )))+ ))+ <|>+ (+ GHC.RemoteDist <$> (option+ (eitherReader uriParser)+ (long "remote-source-dist" <> metavar "URI" <> help+ "URI (https/http/file) to a GHC source distribution"+ <> completer fileUri+ )+ )+ )+ ) <*> option (eitherReader (\x ->@@ -233,7 +250,7 @@ "Build cross-compiler for this platform" ) )- <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)"))+ <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to compile configure, prefix with '-- ' (longopts)")) <*> fmap (fromMaybe False) (invertableSwitch "set" Nothing False (help "Set as active version after install")) <*> optional (option@@ -269,24 +286,46 @@ hlsCompileOpts :: Parser HLSCompileOptions hlsCompileOpts = HLSCompileOptions- <$> ((Left <$> option+ <$> ((HLS.HackageDist <$> option (eitherReader- (first (const "Not a valid version") . version . T.pack)+ ((>>= first displayException . V.version . V.prettyPVP) . first (const "Not a valid PVP version") . pvp . T.pack) ) (short 'v' <> long "version" <> metavar "VERSION" <> help- "The tool version to compile"- <> (completer $ versionCompleter Nothing HLS)+ "The version to compile (pulled from hackage)"+ <> (completer $ versionCompleter' Nothing HLS (either (const False) (const True) . V.pvp . V.prettyVer)) )- ) <|>- (Right <$> (GitBranch <$> option+ )+ <|>+ (HLS.GitDist <$> (GitBranch <$> option str (short 'g' <> long "git-ref" <> metavar "GIT_REFERENCE" <> help- "The git commit/branch/ref to build from"+ "The git commit/branch/ref to build from (accepts anything 'git checkout' accepts)" ) <*> optional (option str (short 'r' <> long "repository" <> metavar "GIT_REPOSITORY" <> help "The git repository to build from (defaults to HLS upstream)" <> completer (gitFileUri ["https://github.com/haskell/haskell-language-server.git"]) ))- )))+ ))+ <|>+ (HLS.SourceDist <$> (option+ (eitherReader+ (first (const "Not a valid version") . version . T.pack)+ )+ (long "source-dist" <> metavar "VERSION" <> help+ "The version to compile (pulled from packaged git sources)"+ <> (completer $ versionCompleter Nothing HLS)+ )+ ))+ <|>+ (+ HLS.RemoteDist <$> (option+ (eitherReader uriParser)+ (long "remote-source-dist" <> metavar "URI" <> help+ "URI (https/http/file) to a HLS source distribution"+ <> completer fileUri+ )+ )+ )+ ) <*> optional (option (eitherReader (readEither @Int))@@ -296,8 +335,10 @@ ) ) <*> fmap (fromMaybe True) (invertableSwitch "set" Nothing True (help "Don't set as active version after install"))- <*> optional- (option+ <*> switch (long "cabal-update" <> help "Run 'cabal update' before the build")+ <*>+ (+ (Right <$> option (eitherReader (first (const "Not a valid version") . version . T.pack) )@@ -306,6 +347,14 @@ <> (completer $ versionCompleter Nothing HLS) ) )+ <|>+ (Left <$> (switch+ (long "git-describe-version"+ <> help "Use the output of 'git describe' (if building from git) as the VERSION component of the installed binary."+ )+ )+ )+ ) <*> optional (option (eitherReader isolateParser)@@ -352,7 +401,7 @@ ) ) <*> some (- option (eitherReader toolVersionEither)+ option (eitherReader ghcVersionTagEither) ( long "ghc" <> metavar "GHC_VERSION|TAG" <> help "For which GHC version to compile for (can be specified multiple times)" <> completer (tagCompleter GHC []) <> completer (versionCompleter Nothing GHC))@@ -388,6 +437,8 @@ , ProcessError , CopyError , BuildFailed+ , UninstallFailed+ , MergeFileTreeError ] type HLSEffects = '[ AlreadyInstalled , BuildFailed@@ -406,6 +457,8 @@ , NotInstalled , DirNotEmpty , ArchiveResult+ , UninstallFailed+ , MergeFileTreeError ] @@ -454,7 +507,7 @@ (CompileHLS HLSCompileOptions { .. }) -> do runCompileHLS runAppState (do case targetHLS of- Left targetVer -> do+ HLS.SourceDist targetVer -> do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo targetVer HLS dls forM_ (_viPreCompile =<< vi) $ \msg -> do@@ -462,7 +515,7 @@ lift $ logInfo "...waiting for 5 seconds, you can still abort..." liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene- Right _ -> pure ()+ _ -> pure () ghcs <- liftE $ forM targetGHCs (\ghc -> fmap (_tvVersion . fst) . fromVersion (Just ghc) $ GHC) targetVer <- liftE $ compileHLS targetHLS@@ -472,6 +525,7 @@ (maybe GHCupInternal IsolateDir isolateDir) cabalProject cabalProjectLocal+ updateCabal patches cabalArgs GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo@@ -492,7 +546,7 @@ case keepDirs settings of Never -> runLogger $ logError $ T.pack $ prettyShow err _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>- "Check the logs at " <> T.pack logsDir <> " and the build directory "+ "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards.") pure $ ExitFailure 9@@ -505,7 +559,7 @@ (CompileGHC GHCCompileOptions {..}) -> runCompileGHC runAppState (do case targetGhc of- Left targetVer -> do+ GHC.SourceDist targetVer -> do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo targetVer GHC dls forM_ (_viPreCompile =<< vi) $ \msg -> do@@ -513,9 +567,12 @@ lift $ logInfo "...waiting for 5 seconds, you can still abort..." liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene- Right _ -> pure ()+ _ -> pure () targetVer <- liftE $ compileGHC- (first (GHCTargetVersion crossTarget) targetGhc)+ ((\case+ GHC.SourceDist v -> GHC.SourceDist $ GHCTargetVersion crossTarget v+ GHC.GitDist g -> GHC.GitDist g+ GHC.RemoteDist r -> GHC.RemoteDist r) targetGhc) ovewrwiteVer bootstrapGhc jobs@@ -551,7 +608,7 @@ case keepDirs settings of Never -> runLogger $ logError $ T.pack $ prettyShow err _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>- "Check the logs at " <> T.pack logsDir <> " and the build directory "+ "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards.") pure $ ExitFailure 9
app/ghcup/GHCup/OptParse/Config.hs view
@@ -7,7 +7,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ExplicitForAll #-} module GHCup.OptParse.Config where @@ -15,9 +14,9 @@ import GHCup.Errors import GHCup.Types import GHCup.Utils-import GHCup.Utils.Prelude-import GHCup.Utils.Logger-import GHCup.Utils.String.QQ+import GHCup.Prelude+import GHCup.Prelude.Logger+import GHCup.Prelude.String.QQ import GHCup.OptParse.Common #if !MIN_VERSION_base(4,13,0)
app/ghcup/GHCup/OptParse/DInfo.hs view
@@ -17,9 +17,10 @@ import GHCup.Errors import GHCup.Version import GHCup.Types-import GHCup.Utils.Prelude import GHCup.Utils.Dirs-import GHCup.Utils.Logger+import GHCup.Prelude+import GHCup.Prelude.Logger+import GHCup.Prelude.Process #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail )@@ -36,7 +37,6 @@ import qualified Data.Text as T import Control.Exception.Safe (MonadMask)-import GHCup.Utils.File import Language.Haskell.TH
app/ghcup/GHCup/OptParse/GC.hs view
@@ -14,8 +14,8 @@ import GHCup import GHCup.Errors import GHCup.Types-import GHCup.Utils.Logger-import GHCup.Utils.String.QQ+import GHCup.Prelude.Logger+import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail )@@ -56,26 +56,26 @@ --[ Parsers ]-- --------------- - + gcP :: Parser GCOptions gcP = GCOptions- <$> + <$> switch (short 'o' <> long "ghc-old" <> help "Remove GHC versions marked as 'old'")- <*> + <*> switch (short 'p' <> long "profiling-libs" <> help "Remove profiling libs of GHC versions")- <*> + <*> switch (short 's' <> long "share-dir" <> help "Remove GHC share directories (documentation)")- <*> + <*> switch (short 'h' <> long "hls-no-ghc" <> help "Remove HLS versions that don't have a corresponding installed GHC version")- <*> + <*> switch (short 'c' <> long "cache" <> help "GC the GHCup cache")- <*> + <*> switch (short 't' <> long "tmpdirs" <> help "Remove tmpdir leftovers") @@ -98,7 +98,7 @@ --------------------------- -type GCEffects = '[ NotInstalled ]+type GCEffects = '[ NotInstalled, UninstallFailed ] runGC :: MonadUnliftIO m@@ -129,7 +129,7 @@ -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode gc GCOptions{..} runAppState runLogger = runGC runAppState (do- when gcOldGHC rmOldGHC+ when gcOldGHC (liftE rmOldGHC) lift $ when gcProfilingLibs rmProfilingLibs lift $ when gcShareDir rmShareDir liftE $ when gcHLSNoGHC rmHLSNoGHC
app/ghcup/GHCup/OptParse/Install.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeOperators #-} module GHCup.OptParse.Install where @@ -18,8 +19,10 @@ import GHCup import GHCup.Errors import GHCup.Types-import GHCup.Utils.Logger-import GHCup.Utils.String.QQ+import GHCup.Utils.Dirs+import GHCup.Prelude+import GHCup.Prelude.Logger+import GHCup.Prelude.String.QQ import Codec.Archive #if !MIN_VERSION_base(4,13,0)@@ -30,7 +33,6 @@ import Data.Either import Data.Functor import Data.Maybe-import Data.Versions hiding ( str ) import Haskus.Utils.Variant.Excepts import Options.Applicative hiding ( style ) import Options.Applicative.Help.Pretty ( text )@@ -69,6 +71,7 @@ , instSet :: Bool , isolateDir :: Maybe FilePath , forceInstall :: Bool+ , addConfArgs :: [T.Text] } @@ -193,7 +196,7 @@ <> completer (toolDlCompleter (fromMaybe GHC tool)) ) )- <*> (Just <$> toolVersionArgument Nothing tool)+ <*> (Just <$> toolVersionTagArgument Nothing tool) ) <|> pure (Nothing, Nothing) )@@ -211,6 +214,7 @@ ) <*> switch (short 'f' <> long "force" <> help "Force install (THIS IS UNSAFE, only use it in Dockerfiles or CI)")+ <*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to bindist configure, prefix with '-- ' (longopts)")) where setDefault = case tool of Nothing -> False@@ -257,48 +261,9 @@ , NoToolVersionSet , FileAlreadyExistsError , ProcessError-- , (AlreadyInstalled, ())- , (UnknownArchive, ())- , (ArchiveResult, ())- , (FileDoesNotExistError, ())- , (CopyError, ())- , (NotInstalled, ())- , (DirNotEmpty, ())- , (NoDownload, ())- , (NotInstalled, ())- , (BuildFailed, ())- , (TagNotFound, ())- , (DigestError, ())- , (GPGError, ())- , (DownloadFailed, ())- , (TarDirDoesNotExist, ())- , (NextVerNotFound, ())- , (NoToolVersionSet, ())- , (FileAlreadyExistsError, ())- , (ProcessError, ())-- , (AlreadyInstalled, NotInstalled)- , (UnknownArchive, NotInstalled)- , (ArchiveResult, NotInstalled)- , (FileDoesNotExistError, NotInstalled)- , (CopyError, NotInstalled)- , (NotInstalled, NotInstalled)- , (DirNotEmpty, NotInstalled)- , (NoDownload, NotInstalled)- , (NotInstalled, NotInstalled)- , (BuildFailed, NotInstalled)- , (TagNotFound, NotInstalled)- , (DigestError, NotInstalled)- , (GPGError, NotInstalled)- , (DownloadFailed, NotInstalled)- , (TarDirDoesNotExist, NotInstalled)- , (NextVerNotFound, NotInstalled)- , (NoToolVersionSet, NotInstalled)- , (FileAlreadyExistsError, NotInstalled)- , (ProcessError, NotInstalled)-- , ((), NotInstalled)+ , UninstallFailed+ , MergeFileTreeError+ , InstallSetError ] @@ -313,52 +278,27 @@ @InstallEffects -type InstallGHCEffects = '[ TagNotFound- , NextVerNotFound- , NoToolVersionSet+type InstallGHCEffects = '[ AlreadyInstalled+ , ArchiveResult , BuildFailed+ , CopyError+ , DigestError , DirNotEmpty- , AlreadyInstalled-- , (AlreadyInstalled, NotInstalled)- , (UnknownArchive, NotInstalled)- , (ArchiveResult, NotInstalled)- , (FileDoesNotExistError, NotInstalled)- , (CopyError, NotInstalled)- , (NotInstalled, NotInstalled)- , (DirNotEmpty, NotInstalled)- , (NoDownload, NotInstalled)- , (BuildFailed, NotInstalled)- , (TagNotFound, NotInstalled)- , (DigestError, NotInstalled)- , (GPGError, NotInstalled)- , (DownloadFailed, NotInstalled)- , (TarDirDoesNotExist, NotInstalled)- , (NextVerNotFound, NotInstalled)- , (NoToolVersionSet, NotInstalled)- , (FileAlreadyExistsError, NotInstalled)- , (ProcessError, NotInstalled)-- , (AlreadyInstalled, ())- , (UnknownArchive, ())- , (ArchiveResult, ())- , (FileDoesNotExistError, ())- , (CopyError, ())- , (NotInstalled, ())- , (DirNotEmpty, ())- , (NoDownload, ())- , (BuildFailed, ())- , (TagNotFound, ())- , (DigestError, ())- , (GPGError, ())- , (DownloadFailed, ())- , (TarDirDoesNotExist, ())- , (NextVerNotFound, ())- , (NoToolVersionSet, ())- , (FileAlreadyExistsError, ())- , (ProcessError, ())-- , ((), NotInstalled)+ , DownloadFailed+ , FileAlreadyExistsError+ , FileDoesNotExistError+ , GPGError+ , MergeFileTreeError+ , NextVerNotFound+ , NoDownload+ , NoToolVersionSet+ , NotInstalled+ , ProcessError+ , TagNotFound+ , TarDirDoesNotExist+ , UninstallFailed+ , UnknownArchive+ , InstallSetError ] runInstGHC :: AppState@@ -393,23 +333,25 @@ (case instBindist of Nothing -> runInstGHC s' instPlatform $ do (v, vi) <- liftE $ fromVersion instVer GHC- void $ liftE $ sequenceE (installGHCBin+ liftE $ runBothE' (installGHCBin (_tvVersion v) (maybe GHCupInternal IsolateDir isolateDir) forceInstall+ addConfArgs )- $ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing+ $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing pure vi Just uri -> do runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do (v, vi) <- liftE $ fromVersion instVer GHC- void $ liftE $ sequenceE (installGHCBindist+ liftE $ runBothE' (installGHCBindist (DownloadInfo uri (Just $ RegexDir "ghc-.*") "") (_tvVersion v) (maybe GHCupInternal IsolateDir isolateDir) forceInstall+ addConfArgs )- $ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing+ $ when instSet $ when (isNothing isolateDir) $ liftE $ void $ setGHC v SetGHCOnly Nothing pure vi ) >>= \case@@ -419,20 +361,18 @@ runLogger $ logInfo msg pure ExitSuccess - VLeft (V (AlreadyInstalled _ v, ())) -> do- runLogger $ logWarn $- "GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"+ VLeft e@(V (AlreadyInstalled _ _)) -> do+ runLogger $ logWarn $ T.pack $ prettyShow e pure ExitSuccess- VLeft (V (AlreadyInstalled _ v)) -> do- runLogger $ logWarn $- "GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"+ VLeft e@(V (AlreadyInstalled _ _)) -> do+ runLogger $ logWarn $ T.pack $ prettyShow e pure ExitSuccess VLeft (V (DirNotEmpty fp)) -> do runLogger $ logError $ "Install directory " <> T.pack fp <> " is not empty." pure $ ExitFailure 3- VLeft (V (DirNotEmpty fp, ())) -> do+ VLeft (V (DirNotEmpty fp)) -> do runLogger $ logError $ "Install directory " <> T.pack fp <> " is not empty." pure $ ExitFailure 3@@ -441,21 +381,21 @@ case keepDirs settings of Never -> runLogger (logError $ T.pack $ prettyShow err) _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>- "Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>+ "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards.") pure $ ExitFailure 3- VLeft err@(V (BuildFailed tmpdir _, ())) -> do+ VLeft err@(V (BuildFailed tmpdir _)) -> do case keepDirs settings of Never -> runLogger (logError $ T.pack $ prettyShow err) _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>- "Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>+ "Check the logs at " <> T.pack (fromGHCupPath logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards.") pure $ ExitFailure 3 VLeft e -> do runLogger $ do logError $ T.pack $ prettyShow e- logError $ "Also check the logs in " <> T.pack logsDir+ logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir) pure $ ExitFailure 3 @@ -465,21 +405,21 @@ (case instBindist of Nothing -> runInstTool s' instPlatform $ do (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal- void $ liftE $ sequenceE (installCabalBin+ liftE $ runBothE' (installCabalBin v (maybe GHCupInternal IsolateDir isolateDir) forceInstall- ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v+ ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v pure vi Just uri -> do runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Cabal- void $ liftE $ sequenceE (installCabalBindist+ liftE $ runBothE' (installCabalBindist (DownloadInfo uri Nothing "") v (maybe GHCupInternal IsolateDir isolateDir) forceInstall- ) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v+ ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setCabal v pure vi ) >>= \case@@ -488,26 +428,24 @@ forM_ (_viPostInstall =<< vi) $ \msg -> runLogger $ logInfo msg pure ExitSuccess- VLeft (V (AlreadyInstalled _ v)) -> do- runLogger $ logWarn $- "Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"+ VLeft e@(V (AlreadyInstalled _ _)) -> do+ runLogger $ logWarn $ T.pack $ prettyShow e pure ExitSuccess VLeft (V (FileAlreadyExistsError fp)) -> do runLogger $ logWarn $ "File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." pure $ ExitFailure 3- VLeft (V (AlreadyInstalled _ v, ())) -> do- runLogger $ logWarn $- "Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install cabal --force " <> prettyVer v <> "'"+ VLeft e@(V (AlreadyInstalled _ _)) -> do+ runLogger $ logWarn $ T.pack $ prettyShow e pure ExitSuccess- VLeft (V (FileAlreadyExistsError fp, ())) -> do+ VLeft (V (FileAlreadyExistsError fp)) -> do runLogger $ logWarn $ "File " <> T.pack fp <> " already exists. Use 'ghcup install cabal --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." pure $ ExitFailure 3 VLeft e -> do runLogger $ do logError $ T.pack $ prettyShow e- logError $ "Also check the logs in " <> T.pack logsDir+ logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir) pure $ ExitFailure 4 installHLS :: InstallOptions -> IO ExitCode@@ -516,22 +454,22 @@ (case instBindist of Nothing -> runInstTool s' instPlatform $ do (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS- void $ liftE $ sequenceE (installHLSBin+ liftE $ runBothE' (installHLSBin v (maybe GHCupInternal IsolateDir isolateDir) forceInstall- ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing+ ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing pure vi Just uri -> do runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do (_tvVersion -> v, vi) <- liftE $ fromVersion instVer HLS -- TODO: support legacy- void $ liftE $ sequenceE (installHLSBindist+ liftE $ runBothE' (installHLSBindist (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "") v (maybe GHCupInternal IsolateDir isolateDir) forceInstall- ) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing+ ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setHLS v SetHLSOnly Nothing pure vi ) >>= \case@@ -540,34 +478,24 @@ forM_ (_viPostInstall =<< vi) $ \msg -> runLogger $ logInfo msg pure ExitSuccess- VLeft (V (AlreadyInstalled _ v)) -> do- runLogger $ logWarn $- "HLS ver "- <> prettyVer v- <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "- <> prettyVer v- <> "'"+ VLeft e@(V (AlreadyInstalled _ _)) -> do+ runLogger $ logWarn $ T.pack $ prettyShow e pure ExitSuccess VLeft (V (FileAlreadyExistsError fp)) -> do runLogger $ logWarn $ "File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." pure $ ExitFailure 3- VLeft (V (AlreadyInstalled _ v, ())) -> do- runLogger $ logWarn $- "HLS ver "- <> prettyVer v- <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install hls --force "- <> prettyVer v- <> "'"+ VLeft e@(V (AlreadyInstalled _ _)) -> do+ runLogger $ logWarn $ T.pack $ prettyShow e pure ExitSuccess- VLeft (V (FileAlreadyExistsError fp, ())) -> do+ VLeft (V (FileAlreadyExistsError fp)) -> do runLogger $ logWarn $ "File " <> T.pack fp <> " already exists. Use 'ghcup install hls --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." pure $ ExitFailure 3 VLeft e -> do runLogger $ do logError $ T.pack $ prettyShow e- logError $ "Also check the logs in " <> T.pack logsDir+ logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir) pure $ ExitFailure 4 installStack :: InstallOptions -> IO ExitCode@@ -576,21 +504,21 @@ (case instBindist of Nothing -> runInstTool s' instPlatform $ do (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack- void $ liftE $ sequenceE (installStackBin+ liftE $ runBothE' (installStackBin v (maybe GHCupInternal IsolateDir isolateDir) forceInstall- ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v+ ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v pure vi Just uri -> do runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do (_tvVersion -> v, vi) <- liftE $ fromVersion instVer Stack- void $ liftE $ sequenceE (installStackBindist+ liftE $ runBothE' (installStackBindist (DownloadInfo uri Nothing "") v (maybe GHCupInternal IsolateDir isolateDir) forceInstall- ) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v+ ) $ when instSet $ when (isNothing isolateDir) $ liftE $ setStack v pure vi ) >>= \case@@ -599,25 +527,23 @@ forM_ (_viPostInstall =<< vi) $ \msg -> runLogger $ logInfo msg pure ExitSuccess- VLeft (V (AlreadyInstalled _ v)) -> do- runLogger $ logWarn $- "Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"+ VLeft e@(V (AlreadyInstalled _ _)) -> do+ runLogger $ logWarn $ T.pack $ prettyShow e pure ExitSuccess VLeft (V (FileAlreadyExistsError fp)) -> do runLogger $ logWarn $ "File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." pure $ ExitFailure 3- VLeft (V (AlreadyInstalled _ v, ())) -> do- runLogger $ logWarn $- "Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install stack --force " <> prettyVer v <> "'"+ VLeft e@(V (AlreadyInstalled _ _)) -> do+ runLogger $ logWarn $ T.pack $ prettyShow e pure ExitSuccess- VLeft (V (FileAlreadyExistsError fp, ())) -> do+ VLeft (V (FileAlreadyExistsError fp)) -> do runLogger $ logWarn $ "File " <> T.pack fp <> " already exists. Use 'ghcup install stack --isolate " <> T.pack fp <> " --force ..." <> "' if you want to overwrite." pure $ ExitFailure 3 VLeft e -> do runLogger $ do logError $ T.pack $ prettyShow e- logError $ "Also check the logs in " <> T.pack logsDir+ logError $ "Also check the logs in " <> T.pack (fromGHCupPath logsDir) pure $ ExitFailure 4
app/ghcup/GHCup/OptParse/List.hs view
@@ -11,7 +11,7 @@ import GHCup-import GHCup.Utils.Prelude+import GHCup.Prelude import GHCup.Types import GHCup.OptParse.Common
app/ghcup/GHCup/OptParse/Nuke.hs view
@@ -14,7 +14,7 @@ import GHCup import GHCup.Errors import GHCup.Types-import GHCup.Utils.Logger+import GHCup.Prelude.Logger #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail )@@ -42,7 +42,7 @@ --------------------------- -type NukeEffects = '[ NotInstalled ]+type NukeEffects = '[ NotInstalled, UninstallFailed ] runNuke :: AppState
app/ghcup/GHCup/OptParse/Prefetch.hs view
@@ -14,9 +14,10 @@ import GHCup import GHCup.Errors import GHCup.Types-import GHCup.Utils.Logger+import GHCup.Prelude.File+import GHCup.Prelude.Logger+import GHCup.Prelude.String.QQ import GHCup.OptParse.Common-import GHCup.Utils.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail )@@ -33,7 +34,6 @@ import qualified Data.Text as T import Control.Exception.Safe (MonadMask)-import GHCup.Utils.Prelude import GHCup.Download (getDownloadsF) @@ -74,44 +74,44 @@ --[ Parsers ]-- --------------- - + prefetchP :: Parser PrefetchCommand prefetchP = subparser ( command "ghc"- (info + (info (PrefetchGHC <$> (PrefetchGHCOptions <$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper ) <*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))- <*> optional (toolVersionArgument Nothing (Just GHC)) )+ <*> optional (toolVersionTagArgument Nothing (Just GHC)) ) ( progDesc "Download GHC assets for installation") ) <> command "cabal"- (info + (info (PrefetchCabal <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))- <*> ( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper ))+ <*> ( optional (toolVersionTagArgument Nothing (Just Cabal)) <**> helper )) ( progDesc "Download cabal assets for installation") ) <> command "hls"- (info + (info (PrefetchHLS <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))- <*> ( optional (toolVersionArgument Nothing (Just HLS)) <**> helper ))+ <*> ( optional (toolVersionTagArgument Nothing (Just HLS)) <**> helper )) ( progDesc "Download HLS assets for installation") ) <> command "stack"- (info + (info (PrefetchStack <$> fmap PrefetchOptions (optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)" <> completer (bashCompleter "directory"))))- <*> ( optional (toolVersionArgument Nothing (Just Stack)) <**> helper ))+ <*> ( optional (toolVersionTagArgument Nothing (Just Stack)) <**> helper )) ( progDesc "Download stack assets for installation") ) <>
app/ghcup/GHCup/OptParse/Rm.hs view
@@ -18,9 +18,9 @@ import GHCup.Types import GHCup.Types.Optics import GHCup.Utils-import GHCup.Utils.Logger+import GHCup.Prelude.Logger+import GHCup.Prelude.String.QQ import GHCup.OptParse.Common-import GHCup.Utils.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail )@@ -71,7 +71,7 @@ --[ Parsers ]-- --------------- - + rmParser :: Parser (Either RmCommand RmOptions) rmParser = (Left <$> subparser@@ -103,7 +103,7 @@ rmOpts :: Maybe Tool -> Parser RmOptions-rmOpts tool = RmOptions <$> versionArgument (Just ListInstalled) tool+rmOpts tool = RmOptions <$> ghcVersionArgument (Just ListInstalled) tool @@ -127,7 +127,7 @@ --------------------------- -type RmEffects = '[ NotInstalled ]+type RmEffects = '[ NotInstalled, UninstallFailed ] runRm :: (ReaderT env m (VEither RmEffects a) -> m (VEither RmEffects a))
app/ghcup/GHCup/OptParse/Run.hs view
@@ -5,19 +5,24 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-} module GHCup.OptParse.Run where import GHCup import GHCup.Utils-import GHCup.Utils.Prelude-import GHCup.Utils.File import GHCup.OptParse.Common import GHCup.Errors import GHCup.Types import GHCup.Types.Optics-import GHCup.Utils.Logger-import GHCup.Utils.String.QQ+import GHCup.Prelude+import GHCup.Prelude.File+#ifdef IS_WINDOWS+import GHCup.Prelude.Process+import GHCup.Prelude.Process.Windows ( execNoMinGW )+#endif+import GHCup.Prelude.Logger+import GHCup.Prelude.String.QQ import Control.Exception.Safe ( MonadMask, MonadCatch ) #if !MIN_VERSION_base(4,13,0)@@ -32,7 +37,6 @@ import Haskus.Utils.Variant.Excepts import Options.Applicative hiding ( style ) import Prelude hiding ( appendFile )-import System.Directory import System.FilePath import System.Environment import System.Exit@@ -43,6 +47,7 @@ #ifndef IS_WINDOWS import qualified System.Posix.Process as SPP #endif+import Data.Versions ( prettyVer, Version ) @@ -56,6 +61,7 @@ data RunOptions = RunOptions { runAppendPATH :: Bool , runInstTool' :: Bool+ , runMinGWPath :: Bool , runGHCVer :: Maybe ToolVersion , runCabalVer :: Maybe ToolVersion , runHLSVer :: Maybe ToolVersion@@ -80,9 +86,11 @@ (short 'a' <> long "append" <> help "Append bin/ dir to PATH instead of prepending (this means that e.g. a system installation may take precedence)") <*> switch (short 'i' <> long "install" <> help "Install the tool, if missing")+ <*> switch+ (short 'm' <> long "mingw-path" <> help "On windows, add mingw64 PATHs to environment (does nothing on unix)") <*> optional (option- (eitherReader toolVersionEither)+ (eitherReader ghcVersionTagEither) (metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version" <> completer (tagCompleter GHC []) <> (completer $ versionCompleter Nothing GHC)@@ -90,7 +98,7 @@ ) <*> optional (option- (eitherReader toolVersionEither)+ (eitherReader toolVersionTagEither) (metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version" <> completer (tagCompleter Cabal []) <> (completer $ versionCompleter Nothing Cabal)@@ -98,7 +106,7 @@ ) <*> optional (option- (eitherReader toolVersionEither)+ (eitherReader toolVersionTagEither) (metavar "HLS_VERSION" <> long "hls" <> help "The HLS version" <> completer (tagCompleter HLS []) <> (completer $ versionCompleter Nothing HLS)@@ -106,7 +114,7 @@ ) <*> optional (option- (eitherReader toolVersionEither)+ (eitherReader toolVersionTagEither) (metavar "STACK_VERSION" <> long "stack" <> help "The stack version" <> completer (tagCompleter Stack []) <> (completer $ versionCompleter Nothing Stack)@@ -176,6 +184,8 @@ , NoToolVersionSet , FileAlreadyExistsError , ProcessError+ , UninstallFailed+ , MergeFileTreeError ] runLeanRUN :: (MonadUnliftIO m, MonadIO m)@@ -209,7 +219,7 @@ -run :: forall m. +run :: forall m . ( MonadFail m , MonadMask m , MonadCatch m@@ -225,12 +235,16 @@ r <- if not runQuick then runRUN runAppState $ do toolchain <- liftE resolveToolchainFull- tmp <- liftIO $ createTmpDir toolchain++ -- oh dear+ r <- lift ask+ tmp <- lift . lift . lift . flip runReaderT (fromAppState r) $ createTmpDir toolchain+ liftE $ installToolChainFull toolchain tmp pure tmp else runLeanRUN leanAppstate $ do toolchain <- resolveToolchain- tmp <- liftIO $ createTmpDir toolchain+ tmp <- lift $ createTmpDir toolchain liftE $ installToolChain toolchain tmp pure tmp case r of@@ -245,7 +259,9 @@ void $ liftIO $ SPP.executeFile cmd True args (Just newEnv) pure ExitSuccess #else- r' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)+ r' <- if runMinGWPath+ then runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)+ else runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ execNoMinGW cmd args Nothing (Just newEnv) case r' of VRight _ -> pure ExitSuccess VLeft e -> do@@ -258,17 +274,6 @@ where - createTmpDir :: Toolchain -> IO FilePath- createTmpDir toolchain =- case runBinDir of- Just bindir -> do- createDirRecursive' bindir- canonicalizePath bindir- Nothing -> do- d <- predictableTmpDir toolchain- createDirRecursive' d- canonicalizePath d- -- TODO: doesn't work for cross resolveToolchainFull :: ( MonadFail m , MonadThrow m@@ -286,29 +291,33 @@ pure v cabalVer <- forM runCabalVer $ \ver -> do (v, _) <- liftE $ fromVersion (Just ver) Cabal- pure v+ pure (_tvVersion v) hlsVer <- forM runHLSVer $ \ver -> do (v, _) <- liftE $ fromVersion (Just ver) HLS- pure v+ pure (_tvVersion v) stackVer <- forM runStackVer $ \ver -> do (v, _) <- liftE $ fromVersion (Just ver) Stack- pure v+ pure (_tvVersion v) pure Toolchain{..} resolveToolchain = do ghcVer <- case runGHCVer of- Just (ToolVersion v) -> pure $ Just v+ Just (GHCVersion v) -> pure $ Just v+ Just (ToolVersion v) -> pure $ Just (mkTVer v) Nothing -> pure Nothing _ -> fail "Internal error" cabalVer <- case runCabalVer of+ Just (GHCVersion v) -> pure $ Just (_tvVersion v) Just (ToolVersion v) -> pure $ Just v Nothing -> pure Nothing _ -> fail "Internal error" hlsVer <- case runHLSVer of+ Just (GHCVersion v) -> pure $ Just (_tvVersion v) Just (ToolVersion v) -> pure $ Just v Nothing -> pure Nothing _ -> fail "Internal error" stackVer <- case runStackVer of+ Just (GHCVersion v) -> pure $ Just (_tvVersion v) Just (ToolVersion v) -> pure $ Just v Nothing -> pure Nothing _ -> fail "Internal error"@@ -339,36 +348,47 @@ , AlreadyInstalled , FileAlreadyExistsError , CopyError+ , UninstallFailed+ , MergeFileTreeError ] (ResourceT (ReaderT AppState m)) () installToolChainFull Toolchain{..} tmp = do- forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do- isInstalled <- maybe (pure False) (\(tool, v) -> lift $ checkIfToolInstalled' tool v) mt- case mt of- Just (GHC, v) -> do- unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin- (_tvVersion v)- GHCupInternal- False- setTool GHC v tmp- Just (Cabal, v) -> do- unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin- (_tvVersion v)- GHCupInternal- False- setTool Cabal v tmp- Just (Stack, v) -> do- unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin- (_tvVersion v)- GHCupInternal- False- setTool Stack v tmp- Just (HLS, v) -> do- unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin- (_tvVersion v)- GHCupInternal- False- setTool HLS v tmp- _ -> pure ()+ case ghcVer of+ Just v -> do+ isInstalled <- lift $ checkIfToolInstalled' GHC v+ unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin+ (_tvVersion v)+ GHCupInternal+ False+ []+ setGHC' v tmp+ _ -> pure ()+ case cabalVer of+ Just v -> do+ isInstalled <- lift $ checkIfToolInstalled' Cabal (mkTVer v)+ unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin+ v+ GHCupInternal+ False+ setCabal' v tmp+ _ -> pure ()+ case stackVer of+ Just v -> do+ isInstalled <- lift $ checkIfToolInstalled' Stack (mkTVer v)+ unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin+ v+ GHCupInternal+ False+ setStack' v tmp+ _ -> pure ()+ case hlsVer of+ Just v -> do+ isInstalled <- lift $ checkIfToolInstalled' HLS (mkTVer v)+ unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin+ v+ GHCupInternal+ False+ setHLS' v tmp+ _ -> pure () installToolChain :: ( MonadFail m , MonadThrow m@@ -379,46 +399,47 @@ -> FilePath -> Excepts '[NotInstalled] (ReaderT LeanAppState m) () installToolChain Toolchain{..} tmp = do- forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do- case mt of- Just (GHC, v) -> setTool GHC v tmp- Just (Cabal, v) -> setTool Cabal v tmp- Just (Stack, v) -> setTool Stack v tmp- Just (HLS, v) -> setTool HLS v tmp- _ -> pure ()+ case ghcVer of+ Just v -> setGHC' v tmp+ _ -> pure ()+ case cabalVer of+ Just v -> setCabal' v tmp+ _ -> pure ()+ case stackVer of+ Just v -> setStack' v tmp+ _ -> pure ()+ case hlsVer of+ Just v -> setHLS' v tmp+ _ -> pure () - setTool tool v tmp =- case tool of- GHC -> do+ setGHC' v tmp = do void $ liftE $ setGHC v SetGHC_XYZ (Just tmp) void $ liftE $ setGHC v SetGHCOnly (Just tmp)- Cabal -> do- bin <- liftE $ whereIsTool Cabal v+ setCabal' v tmp = do+ bin <- liftE $ whereIsTool Cabal (mkTVer v) cbin <- liftIO $ canonicalizePath bin lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("cabal" <.> exeExt))- Stack -> do- bin <- liftE $ whereIsTool Stack v+ setStack' v tmp = do+ bin <- liftE $ whereIsTool Stack (mkTVer v) cbin <- liftIO $ canonicalizePath bin lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("stack" <.> exeExt))- HLS -> do+ setHLS' v tmp = do Dirs {..} <- getDirs- let v' = _tvVersion v- legacy <- isLegacyHLS v'+ legacy <- isLegacyHLS v if legacy then do -- TODO: factor this out- hlsWrapper <- liftE @_ @'[NotInstalled] $ hlsWrapperBinary v' !? (NotInstalled HLS (mkTVer v'))+ hlsWrapper <- liftE @_ @'[NotInstalled] $ hlsWrapperBinary v !? (NotInstalled HLS (mkTVer v)) cw <- liftIO $ canonicalizePath (binDir </> hlsWrapper) lift $ createLink (relativeSymlink tmp cw) (tmp </> takeFileName cw)- hlsBins <- hlsServerBinaries v' Nothing >>= liftIO . traverse (canonicalizePath . (binDir </>))+ hlsBins <- hlsServerBinaries v Nothing >>= liftIO . traverse (canonicalizePath . (binDir </>)) forM_ hlsBins $ \bin -> lift $ createLink (relativeSymlink tmp bin) (tmp </> takeFileName bin)- liftE $ setHLS (_tvVersion v) SetHLSOnly (Just tmp)+ liftE $ setHLS v SetHLSOnly (Just tmp) else do- liftE $ setHLS (_tvVersion v) SetHLS_XYZ (Just tmp)- liftE $ setHLS (_tvVersion v) SetHLSOnly (Just tmp)- GHCup -> pure ()- + liftE $ setHLS v SetHLS_XYZ (Just tmp)+ liftE $ setHLS v SetHLSOnly (Just tmp)+ addToPath path = do cEnv <- Map.fromList <$> getEnvironment let paths = ["PATH", "Path"]@@ -430,16 +451,38 @@ liftIO $ setEnv pathVar newPath return envWithNewPath - predictableTmpDir (Toolchain Nothing Nothing Nothing Nothing) =- liftIO (getTemporaryDirectory >>= \tmp -> pure (tmp </> "ghcup-none"))+ createTmpDir :: ( MonadUnliftIO m+ , MonadCatch m+ , MonadThrow m+ , MonadMask m+ , MonadIO m+ )+ => Toolchain+ -> ReaderT LeanAppState m FilePath+ createTmpDir toolchain =+ case runBinDir of+ Just bindir -> do+ liftIO $ createDirRecursive' bindir+ liftIO $ canonicalizePath bindir+ Nothing -> do+ d <- predictableTmpDir toolchain+ liftIO $ createDirRecursive' d+ liftIO $ canonicalizePath d++ predictableTmpDir :: Monad m+ => Toolchain+ -> ReaderT LeanAppState m FilePath+ predictableTmpDir (Toolchain Nothing Nothing Nothing Nothing) = do+ Dirs { tmpDir } <- getDirs+ pure (fromGHCupPath tmpDir </> "ghcup-none") predictableTmpDir Toolchain{..} = do- tmp <- getTemporaryDirectory- pure $ tmp+ Dirs { tmpDir } <- getDirs+ pure $ fromGHCupPath tmpDir </> ("ghcup-" <> intercalate "_" ( maybe [] ( (:[]) . ("ghc-" <>) . T.unpack . tVerToText) ghcVer- <> maybe [] ( (:[]) . ("cabal-" <>) . T.unpack . tVerToText) cabalVer- <> maybe [] ( (:[]) . ("hls-" <>) . T.unpack . tVerToText) hlsVer- <> maybe [] ( (:[]) . ("stack-" <>) . T.unpack . tVerToText) stackVer+ <> maybe [] ( (:[]) . ("cabal-" <>) . T.unpack . prettyVer) cabalVer+ <> maybe [] ( (:[]) . ("hls-" <>) . T.unpack . prettyVer) hlsVer+ <> maybe [] ( (:[]) . ("stack-" <>) . T.unpack . prettyVer) stackVer ) ) @@ -453,7 +496,7 @@ data Toolchain = Toolchain { ghcVer :: Maybe GHCTargetVersion- , cabalVer :: Maybe GHCTargetVersion- , hlsVer :: Maybe GHCTargetVersion- , stackVer :: Maybe GHCTargetVersion- }+ , cabalVer :: Maybe Version+ , hlsVer :: Maybe Version+ , stackVer :: Maybe Version+ } deriving Show
app/ghcup/GHCup/OptParse/Set.hs view
@@ -17,8 +17,8 @@ import GHCup import GHCup.Errors import GHCup.Types-import GHCup.Utils.Logger-import GHCup.Utils.String.QQ+import GHCup.Prelude.Logger+import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail )@@ -74,7 +74,7 @@ --[ Parsers ]-- --------------- - + setParser :: Parser (Either SetCommand SetOptions) setParser = (Left <$> subparser@@ -82,7 +82,7 @@ "ghc" ( SetGHC <$> info- (setOpts (Just GHC) <**> helper)+ (setOpts GHC <**> helper) ( progDesc "Set GHC version" <> footerDoc (Just $ text setGHCFooter) )@@ -91,7 +91,7 @@ "cabal" ( SetCabal <$> info- (setOpts (Just Cabal) <**> helper)+ (setOpts Cabal <**> helper) ( progDesc "Set Cabal version" <> footerDoc (Just $ text setCabalFooter) )@@ -100,7 +100,7 @@ "hls" ( SetHLS <$> info- (setOpts (Just HLS) <**> helper)+ (setOpts HLS <**> helper) ( progDesc "Set haskell-language-server version" <> footerDoc (Just $ text setHLSFooter) )@@ -109,14 +109,14 @@ "stack" ( SetStack <$> info- (setOpts (Just Stack) <**> helper)+ (setOpts Stack <**> helper) ( progDesc "Set stack version" <> footerDoc (Just $ text setStackFooter) ) ) ) )- <|> (Right <$> setOpts Nothing)+ <|> (Right <$> setOpts GHC) where setGHCFooter :: String setGHCFooter = [s|Discussion:@@ -137,22 +137,25 @@ Sets the the current haskell-language-server version.|] -setOpts :: Maybe Tool -> Parser SetOptions+setOpts :: Tool -> Parser SetOptions setOpts tool = SetOptions <$> (fromMaybe SetRecommended <$> optional (setVersionArgument (Just ListInstalled) tool)) -setVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser SetToolVersion+setVersionArgument :: Maybe ListCriteria -> Tool -> Parser SetToolVersion setVersionArgument criteria tool = argument (eitherReader setEither) (metavar "VERSION|TAG|next"- <> completer (tagCompleter (fromMaybe GHC tool) ["next"])- <> foldMap (completer . versionCompleter criteria) tool)+ <> completer (tagCompleter tool ["next"])+ <> (completer . versionCompleter criteria) tool) where setEither s' = parseSet s' <|> second SetToolTag (tagEither s')- <|> second SetToolVersion (tVersionEither s')+ <|> se s'+ se s' = case tool of+ GHC -> second SetGHCVersion (ghcVersionEither s')+ _ -> second SetToolVersion (toolVersionEither s') parseSet s' = case fmap toLower s' of "next" -> Right SetNext other -> Left $ "Unknown tag/version " <> other@@ -261,9 +264,9 @@ (Right sopts) -> do runLogger (logWarn "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.") setGHC' sopts- (Left (SetGHC sopts)) -> setGHC' sopts+ (Left (SetGHC sopts)) -> setGHC' sopts (Left (SetCabal sopts)) -> setCabal' sopts- (Left (SetHLS sopts)) -> setHLS' sopts+ (Left (SetHLS sopts)) -> setHLS' sopts (Left (SetStack sopts)) -> setStack' sopts where@@ -271,7 +274,7 @@ -> m ExitCode setGHC' SetOptions{ sToolVer } = case sToolVer of- (SetToolVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly Nothing >> pure v)+ (SetGHCVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly Nothing >> pure v) _ -> runSetGHC runAppState (do v <- liftE $ fst <$> fromVersion' sToolVer GHC liftE $ setGHC v SetGHCOnly Nothing@@ -291,17 +294,17 @@ -> m ExitCode setCabal' SetOptions{ sToolVer } = case sToolVer of- (SetToolVersion v) -> runSetCabal runLeanAppState (liftE $ setCabal (_tvVersion v) >> pure v)+ (SetToolVersion v) -> runSetCabal runLeanAppState (liftE $ setCabal v >> pure (mkTVer v)) _ -> runSetCabal runAppState (do v <- liftE $ fst <$> fromVersion' sToolVer Cabal liftE $ setCabal (_tvVersion v) pure v ) >>= \case- VRight GHCTargetVersion{..} -> do+ VRight v -> do runLogger $ logInfo $- "Cabal " <> prettyVer _tvVersion <> " successfully set as default version"+ "Cabal " <> prettyVer (_tvVersion v) <> " successfully set as default version" pure ExitSuccess VLeft e -> do runLogger $ logError $ T.pack $ prettyShow e@@ -311,17 +314,17 @@ -> m ExitCode setHLS' SetOptions{ sToolVer } = case sToolVer of- (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing >> pure v)+ (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS v SetHLSOnly Nothing >> pure (mkTVer v)) _ -> runSetHLS runAppState (do v <- liftE $ fst <$> fromVersion' sToolVer HLS liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing pure v ) >>= \case- VRight GHCTargetVersion{..} -> do+ VRight v -> do runLogger $ logInfo $- "HLS " <> prettyVer _tvVersion <> " successfully set as default version"+ "HLS " <> prettyVer (_tvVersion v) <> " successfully set as default version" pure ExitSuccess VLeft e -> do runLogger $ logError $ T.pack $ prettyShow e@@ -332,17 +335,17 @@ -> m ExitCode setStack' SetOptions{ sToolVer } = case sToolVer of- (SetToolVersion v) -> runSetStack runLeanAppState (liftE $ setStack (_tvVersion v) >> pure v)+ (SetToolVersion v) -> runSetStack runLeanAppState (liftE $ setStack v >> pure (mkTVer v)) _ -> runSetStack runAppState (do v <- liftE $ fst <$> fromVersion' sToolVer Stack liftE $ setStack (_tvVersion v) pure v ) >>= \case- VRight GHCTargetVersion{..} -> do+ VRight v -> do runLogger $ logInfo $- "Stack " <> prettyVer _tvVersion <> " successfully set as default version"+ "Stack " <> prettyVer (_tvVersion v) <> " successfully set as default version" pure ExitSuccess VLeft e -> do runLogger $ logError $ T.pack $ prettyShow e
app/ghcup/GHCup/OptParse/ToolRequirements.hs view
@@ -11,8 +11,8 @@ import GHCup.Errors import GHCup.Types-import GHCup.Utils.Logger-import GHCup.Utils.String.QQ+import GHCup.Prelude.Logger+import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail )@@ -30,7 +30,7 @@ import Control.Exception.Safe (MonadMask) import GHCup.Types.Optics import GHCup.Platform-import GHCup.Utils.Prelude+import GHCup.Prelude import GHCup.Requirements import System.IO
app/ghcup/GHCup/OptParse/UnSet.hs view
@@ -16,8 +16,8 @@ import GHCup import GHCup.Errors import GHCup.Types-import GHCup.Utils.Logger-import GHCup.Utils.String.QQ+import GHCup.Prelude.Logger+import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail )
app/ghcup/GHCup/OptParse/Upgrade.hs view
@@ -14,7 +14,8 @@ import GHCup import GHCup.Errors import GHCup.Types-import GHCup.Utils.Logger+import GHCup.Prelude.File+import GHCup.Prelude.Logger #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail )@@ -93,7 +94,7 @@ , FileDoesNotExistError , CopyError , DownloadFailed- , GHCupShadowed+ , ToolShadowed ]
app/ghcup/GHCup/OptParse/Whereis.hs view
@@ -17,8 +17,9 @@ import GHCup.Errors import GHCup.OptParse.Common import GHCup.Types-import GHCup.Utils.Logger-import GHCup.Utils.String.QQ+import GHCup.Utils+import GHCup.Prelude.Logger+import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail )@@ -74,14 +75,14 @@ --[ Parsers ]-- --------------- - + whereisP :: Parser WhereisCommand whereisP = subparser- (commandGroup "Tools locations:" <> + (commandGroup "Tools locations:" <> command "ghc" (WhereisTool GHC <$> info- ( optional (toolVersionArgument Nothing (Just GHC)) <**> helper )+ ( optional (toolVersionTagArgument Nothing (Just GHC)) <**> helper ) ( progDesc "Get GHC location" <> footerDoc (Just $ text whereisGHCFooter )) )@@ -89,7 +90,7 @@ command "cabal" (WhereisTool Cabal <$> info- ( optional (toolVersionArgument Nothing (Just Cabal)) <**> helper )+ ( optional (toolVersionTagArgument Nothing (Just Cabal)) <**> helper ) ( progDesc "Get cabal location" <> footerDoc (Just $ text whereisCabalFooter )) )@@ -97,7 +98,7 @@ command "hls" (WhereisTool HLS <$> info- ( optional (toolVersionArgument Nothing (Just HLS)) <**> helper )+ ( optional (toolVersionTagArgument Nothing (Just HLS)) <**> helper ) ( progDesc "Get HLS location" <> footerDoc (Just $ text whereisHLSFooter )) )@@ -105,7 +106,7 @@ command "stack" (WhereisTool Stack <$> info- ( optional (toolVersionArgument Nothing (Just Stack)) <**> helper )+ ( optional (toolVersionTagArgument Nothing (Just Stack)) <**> helper ) ( progDesc "Get stack location" <> footerDoc (Just $ text whereisStackFooter )) )@@ -267,7 +268,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do Dirs{ .. } <- runReaderT getDirs leanAppstate case (whereisCommand, whereisOptions) of- (WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->+ (WhereisTool tool (Just (GHCVersion v)), WhereisOptions{..}) -> runLeanWhereIs leanAppstate (do loc <- liftE $ whereIsTool tool v if directory@@ -281,6 +282,20 @@ VLeft e -> do runLogger $ logError $ T.pack $ prettyShow e pure $ ExitFailure 30+ (WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->+ runLeanWhereIs leanAppstate (do+ loc <- liftE $ whereIsTool tool (mkTVer v)+ if directory+ then pure $ takeDirectory loc+ else pure loc+ )+ >>= \case+ VRight r -> do+ liftIO $ putStr r+ pure ExitSuccess+ VLeft e -> do+ runLogger $ logError $ T.pack $ prettyShow e+ pure $ ExitFailure 30 (WhereisTool tool whereVer, WhereisOptions{..}) -> do runWhereIs runAppState (do@@ -299,7 +314,7 @@ pure $ ExitFailure 30 (WhereisBaseDir, _) -> do- liftIO $ putStr baseDir+ liftIO $ putStr $ fromGHCupPath baseDir pure ExitSuccess (WhereisBinDir, _) -> do@@ -307,13 +322,13 @@ pure ExitSuccess (WhereisCacheDir, _) -> do- liftIO $ putStr cacheDir+ liftIO $ putStr $ fromGHCupPath cacheDir pure ExitSuccess (WhereisLogsDir, _) -> do- liftIO $ putStr logsDir+ liftIO $ putStr $ fromGHCupPath logsDir pure ExitSuccess (WhereisConfDir, _) -> do- liftIO $ putStr confDir+ liftIO $ putStr $ fromGHCupPath confDir pure ExitSuccess
app/ghcup/Main.hs view
@@ -14,6 +14,8 @@ import BrickMain ( brickMain ) #endif +import qualified GHCup.GHC as GHC+import qualified GHCup.HLS as HLS import GHCup.OptParse import GHCup.Download@@ -22,9 +24,9 @@ import GHCup.Types import GHCup.Types.Optics hiding ( toolRequirements ) import GHCup.Utils-import GHCup.Utils.Logger-import GHCup.Utils.Prelude-import GHCup.Utils.String.QQ+import GHCup.Prelude+import GHCup.Prelude.Logger+import GHCup.Prelude.String.QQ import GHCup.Version import Cabal.Plan ( findPlanJson, SearchPlanJson(..) )@@ -155,7 +157,6 @@ versions. It maintains a self-contained ~/.ghcup directory. ENV variables:- * TMPDIR: where ghcup does the work (unpacking, building, ...) * GHCUP_INSTALL_BASE_PREFIX: the base of ghcup (default: $HOME) * GHCUP_USE_XDG_DIRS: set to anything to use XDG style directories @@ -220,7 +221,7 @@ let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig race_ (liftIO $ runReaderT cleanupTrash s')- (threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually"))+ (threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack (fromGHCupPath recycleDir) <> " manually")) case optCommand of Nuke -> pure ()@@ -237,7 +238,7 @@ | Just False <- optVerbose -> pure () | otherwise -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, NextVerNotFound, NoToolVersionSet] $ do- newTools <- lift checkForUpdates + newTools <- lift checkForUpdates forM_ newTools $ \newTool@(t, l) -> do -- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/283 alreadyInstalling' <- alreadyInstalling optCommand newTool@@ -278,8 +279,8 @@ runAppState action' = do s' <- liftIO appState runReaderT action' s'- + ----------------- -- Run command -- -----------------@@ -338,14 +339,16 @@ alreadyInstalling (Install (Left (InstallHLS InstallOptions{..}))) (HLS, ver) = cmp' HLS instVer ver alreadyInstalling (Install (Left (InstallStack InstallOptions{..}))) (Stack, ver) = cmp' Stack instVer ver alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ ovewrwiteVer = Just over }))- (GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer over)) ver- alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = Left tver }))- (GHC, ver) = cmp' GHC (Just $ ToolVersion (mkTVer tver)) ver- alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Just over }))- (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer over)) ver- alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = Left tver }))- (HLS, ver) = cmp' HLS (Just $ ToolVersion (mkTVer tver)) ver- alreadyInstalling (Upgrade _ _ _) (GHCup, _) = pure True+ (GHC, ver) = cmp' GHC (Just $ GHCVersion (mkTVer over)) ver+ alreadyInstalling (Compile (CompileGHC GHCCompileOptions{ targetGhc = GHC.SourceDist tver }))+ (GHC, ver) = cmp' GHC (Just $ ToolVersion tver) ver+ alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ ovewrwiteVer = Right over }))+ (HLS, ver) = cmp' HLS (Just $ ToolVersion over) ver+ alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HLS.SourceDist tver }))+ (HLS, ver) = cmp' HLS (Just $ ToolVersion tver) ver+ alreadyInstalling (Compile (CompileHLS HLSCompileOptions{ targetHLS = HLS.HackageDist tver }))+ (HLS, ver) = cmp' HLS (Just $ ToolVersion tver) ver+ alreadyInstalling (Upgrade {}) (GHCup, _) = pure True alreadyInstalling _ _ = pure False cmp' :: ( HasLog env
+ cbits/dirutils.c view
@@ -0,0 +1,7 @@+#include "dirutils.h"++unsigned int+ __posixdir_d_type(struct dirent* d)+ {+ return(d -> d_type);+ }
ghcup.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghcup-version: 0.1.17.10+version: 0.1.18.0 license: LGPL-3.0-only license-file: LICENSE copyright: Julian Ospald 2020@@ -44,31 +44,40 @@ manual: True flag no-exe- description: Don't build any executables + description: Don't build any executables default: False manual: True library exposed-modules: GHCup+ GHCup.Cabal GHCup.Download GHCup.Download.Utils GHCup.Errors+ GHCup.GHC+ GHCup.HLS+ GHCup.List GHCup.Platform+ GHCup.Prelude+ GHCup.Prelude.File+ GHCup.Prelude.File.Search+ GHCup.Prelude.Internal+ GHCup.Prelude.Logger+ GHCup.Prelude.Logger.Internal+ GHCup.Prelude.MegaParsec+ GHCup.Prelude.Process+ GHCup.Prelude.String.QQ+ GHCup.Prelude.Version.QQ+ GHCup.Prompts GHCup.Requirements+ GHCup.Stack GHCup.Types GHCup.Types.JSON GHCup.Types.JSON.Utils GHCup.Types.Optics GHCup.Utils GHCup.Utils.Dirs- GHCup.Utils.File- GHCup.Utils.File.Common- GHCup.Utils.Logger- GHCup.Utils.MegaParsec- GHCup.Utils.Prelude- GHCup.Utils.String.QQ- GHCup.Utils.Version.QQ GHCup.Version hs-source-dirs: lib@@ -100,8 +109,8 @@ , base >=4.12 && <5 , base16-bytestring >=0.1.1.6 && <1.1 , binary ^>=0.8.6.0- , bytestring ^>=0.10- , Cabal ^>=3.6.2.0+ , bytestring >=0.10 && <0.12+ , Cabal ^>=3.0.0.0 || ^>=3.2.0.0 || ^>=3.4.0.0 || ^>=3.6.0.0 , case-insensitive ^>=1.2.1.0 , casing ^>=0.1.4.1 , containers ^>=0.6@@ -109,6 +118,7 @@ , deepseq ^>=1.4.4.0 , directory ^>=1.3.6.0 , disk-free-space ^>=0.1.0.1+ , exceptions ^>=0.10 , filepath ^>=1.4.2.1 , haskus-utils-types ^>=1.5 , haskus-utils-variant ^>=3.2.1@@ -126,6 +136,7 @@ , safe ^>=0.3.18 , safe-exceptions ^>=0.1 , split ^>=0.2.3.4+ , streamly ^>=0.8.2 , strict-base ^>=0.4 , template-haskell >=2.7 && <2.18 , temporary ^>=1.3@@ -153,9 +164,11 @@ if os(windows) cpp-options: -DIS_WINDOWS other-modules:- GHCup.Utils.File.Windows- GHCup.Utils.Prelude.Windows- GHCup.Utils.Windows+ GHCup.Prelude.File.Windows+ GHCup.Prelude.Windows+ -- GHCup.OptParse.Run uses this+ exposed-modules:+ GHCup.Prelude.Process.Windows build-depends: , bzlib@@ -164,10 +177,13 @@ else other-modules:- GHCup.Utils.File.Posix- GHCup.Utils.Posix- GHCup.Utils.Prelude.Posix+ GHCup.Prelude.File.Posix+ GHCup.Prelude.File.Posix.Foreign+ GHCup.Prelude.File.Posix.Traversals+ GHCup.Prelude.Posix+ GHCup.Prelude.Process.Posix + c-sources: cbits/dirutils.c build-depends: , bz2 >=0.5.0.5 && <1.1 , terminal-size ^>=0.3.2.1@@ -221,13 +237,14 @@ , aeson-pretty ^>=0.8.8 , async ^>=2.2.3 , base >=4.12 && <5- , bytestring ^>=0.10+ , bytestring >=0.10 && <0.12 , cabal-plan ^>=0.7.2 , containers ^>=0.6 , deepseq ^>=1.4 , directory ^>=1.3.6.0 , filepath ^>=1.4.2.1 , ghcup+ , haskus-utils-types ^>=1.5 , haskus-utils-variant ^>=3.2.1 , libarchive ^>=3.0.3.0 , megaparsec >=8.0.0 && <9.3@@ -271,7 +288,6 @@ if flag(no-exe) buildable: False - test-suite ghcup-test type: exitcode-stdio-1.0 main-is: Main.hs@@ -280,6 +296,7 @@ other-modules: GHCup.ArbitraryTypes GHCup.Types.JSONSpec+ GHCup.Utils.FileSpec Spec default-language: Haskell2010@@ -297,14 +314,17 @@ build-depends: , base >=4.12 && <5- , bytestring ^>=0.10+ , bytestring >=0.10 && <0.12 , containers ^>=0.6- , generic-arbitrary >=0.1.0 && <0.3+ , directory ^>=1.3.6.0+ , filepath ^>=1.4.2.1+ , generic-arbitrary >=0.1.0 && < 0.2.1 || >=0.2.2 && <0.3 , ghcup , hspec >=2.7.10 && <2.10 , hspec-golden-aeson ^>=0.9 , QuickCheck ^>=2.14.1 , quickcheck-arbitrary-adt ^>=0.3.1.0+ , streamly ^>=0.8.2 , text ^>=1.2.4.0 , uri-bytestring ^>=0.3.2.2 , versions >=4.0.1 && <5.1
lib/GHCup.hs view
@@ -6,2940 +6,603 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}--{-|-Module : GHCup-Description : GHCup installation functions-Copyright : (c) Julian Ospald, 2020-License : LGPL-3.0-Maintainer : hasufell@hasufell.de-Stability : experimental-Portability : portable--This module contains the main functions that correspond-to the command line interface, like installation, listing versions-and so on.--These are the entry points.--}-module GHCup where---import GHCup.Download-import GHCup.Errors-import GHCup.Platform-import GHCup.Types-import GHCup.Types.JSON ( )-import GHCup.Types.Optics-import GHCup.Utils-import GHCup.Utils.File-import GHCup.Utils.Logger-import GHCup.Utils.Prelude-import GHCup.Utils.String.QQ-import GHCup.Utils.Version.QQ-import GHCup.Version--import Codec.Archive ( ArchiveResult )-import Control.Applicative-import Control.DeepSeq ( force )-import Control.Exception ( evaluate )-import Control.Exception.Safe-import Control.Monad-#if !MIN_VERSION_base(4,13,0)-import Control.Monad.Fail ( MonadFail )-#endif-import Control.Monad.Reader-import Control.Monad.Trans.Resource- hiding ( throwM )-import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )-import Data.ByteString ( ByteString )-import Data.Either-import Data.List-import Data.Maybe-import Data.List.NonEmpty ( NonEmpty((:|)) )-import Data.String ( fromString )-import Data.Text ( Text )-import Data.Time.Clock-import Data.Time.Format.ISO8601-import Data.Versions hiding ( patch )-import Distribution.Types.Version hiding ( Version )-import Distribution.Types.PackageId-import Distribution.Types.PackageDescription-import Distribution.Types.GenericPackageDescription-import Distribution.PackageDescription.Parsec-import GHC.IO.Exception-import Haskus.Utils.Variant.Excepts-import Language.Haskell.TH-import Language.Haskell.TH.Syntax ( Quasi(qAddDependentFile) )-import Optics-import Prelude hiding ( abs- , writeFile- )-import Safe hiding ( at )-import System.Directory hiding ( findFiles )-import System.Environment-import System.FilePath-import System.IO.Error-import System.IO.Temp-import Text.PrettyPrint.HughesPJClass ( prettyShow )-import Text.Regex.Posix-import URI.ByteString--import qualified Crypto.Hash.SHA256 as SHA256-import qualified Data.List.NonEmpty as NE-import qualified Data.ByteString.Base16 as B16-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.Map.Strict as Map-import qualified Data.Text as T-import qualified Data.Text.IO as T-import qualified Data.Text.Encoding as E-import qualified Text.Megaparsec as MP-import GHCup.Utils.MegaParsec-import Control.Concurrent (threadDelay)--- ---------------------- --[ Tool fetching ]--- ------------------------fetchToolBindist :: ( MonadFail m- , MonadMask m- , MonadCatch m- , MonadReader env m- , HasDirs env- , HasSettings env- , HasPlatformReq env- , HasGHCupInfo env- , HasLog env- , MonadResource m- , MonadIO m- , MonadUnliftIO m- )- => Version- -> Tool- -> Maybe FilePath- -> Excepts- '[ DigestError- , GPGError- , DownloadFailed- , NoDownload- ]- m- FilePath-fetchToolBindist v t mfp = do- dlinfo <- liftE $ getDownloadInfo t v- liftE $ downloadCached' dlinfo Nothing mfp---fetchGHCSrc :: ( MonadFail m- , MonadMask m- , MonadCatch m- , MonadReader env m- , HasDirs env- , HasSettings env- , HasPlatformReq env- , HasGHCupInfo env- , HasLog env- , MonadResource m- , MonadIO m- , MonadUnliftIO m- )- => Version- -> Maybe FilePath- -> Excepts- '[ DigestError- , GPGError- , DownloadFailed- , NoDownload- ]- m- FilePath-fetchGHCSrc v mfp = do- GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo- dlInfo <-- preview (ix GHC % ix v % viSourceDL % _Just) dls- ?? NoDownload- liftE $ downloadCached' dlInfo Nothing mfp---- -------------------------- --[ Tool installation ]--- ------------------------------ | Like 'installGHCBin', except takes the 'DownloadInfo' as--- argument instead of looking it up from 'GHCupDownloads'.-installGHCBindist :: ( MonadFail m- , MonadMask m- , MonadCatch m- , MonadReader env m- , HasDirs env- , HasSettings env- , HasPlatformReq env- , HasLog env- , MonadResource m- , MonadIO m- , MonadUnliftIO m- )- => DownloadInfo -- ^ where/how to download- -> Version -- ^ the version to install- -> InstallDir- -> Bool -- ^ Force install- -> Excepts- '[ AlreadyInstalled- , BuildFailed- , DigestError- , GPGError- , DownloadFailed- , NoDownload- , NotInstalled- , UnknownArchive- , TarDirDoesNotExist- , DirNotEmpty- , ArchiveResult- , ProcessError- ]- m- ()-installGHCBindist dlinfo ver installDir forceInstall = do- let tver = mkTVer ver-- lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver-- regularGHCInstalled <- lift $ checkIfToolInstalled GHC ver-- if- | not forceInstall- , regularGHCInstalled- , GHCupInternal <- installDir -> do- throwE $ AlreadyInstalled GHC ver-- | forceInstall- , regularGHCInstalled- , GHCupInternal <- installDir -> do- lift $ logInfo "Removing the currently installed GHC version first!"- liftE $ rmGHCVer tver-- | otherwise -> pure ()-- -- download (or use cached version)- dl <- liftE $ downloadCached dlinfo Nothing--- toolchainSanityChecks-- case installDir of- IsolateDir isoDir -> do -- isolated install- lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir- liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) ver forceInstall- GHCupInternal -> do -- regular install- -- prepare paths- ghcdir <- lift $ ghcupGHCDir tver-- liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) ver forceInstall-- -- make symlinks & stuff when regular install,- liftE $ postGHCInstall tver-- where- toolchainSanityChecks = do- r <- forM ["CC", "LD"] (liftIO . lookupEnv)- case catMaybes r of- [] -> pure ()- _ -> do- lift $ logWarn $ "CC/LD environment variable is set. This will change the compiler/linker"- <> "\n" <> "GHC uses internally and can cause defunct GHC in some cases (e.g. in Anaconda"- <> "\n" <> "environments). If you encounter problems, unset CC and LD and reinstall."----- | Install a packed GHC distribution. This only deals with unpacking and the GHC--- build system and nothing else.-installPackedGHC :: ( MonadMask m- , MonadCatch m- , MonadReader env m- , HasDirs env- , HasPlatformReq env- , HasSettings env- , MonadThrow m- , HasLog env- , MonadIO m- , MonadUnliftIO m- , MonadFail m- )- => FilePath -- ^ Path to the packed GHC bindist- -> Maybe TarDir -- ^ Subdir of the archive- -> InstallDirResolved- -> Version -- ^ The GHC version- -> Bool -- ^ Force install- -> Excepts- '[ BuildFailed- , UnknownArchive- , TarDirDoesNotExist- , DirNotEmpty- , ArchiveResult- , ProcessError- ] m ()-installPackedGHC dl msubdir inst ver forceInstall = do- PlatformRequest {..} <- lift getPlatformReq-- unless forceInstall- (liftE $ installDestSanityCheck inst)-- -- unpack- tmpUnpack <- lift mkGhcupTmpDir- liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)- liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack-- -- the subdir of the archive where we do the work- workdir <- maybe (pure tmpUnpack)- (liftE . intoSubdir tmpUnpack)- msubdir-- liftE $ runBuildAction tmpUnpack- (case inst of- IsolateDirResolved _ -> Nothing -- don't clean up for isolated installs, since that'd potentially delete other- -- user files if '--force' is supplied- GHCupDir d -> Just d- )- (installUnpackedGHC workdir inst ver)----- | Install an unpacked GHC distribution. This only deals with the GHC--- build system and nothing else.-installUnpackedGHC :: ( MonadReader env m- , HasPlatformReq env- , HasDirs env- , HasSettings env- , MonadThrow m- , HasLog env- , MonadIO m- , MonadUnliftIO m- , MonadMask m- )- => FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides)- -> InstallDirResolved -- ^ Path to install to- -> Version -- ^ The GHC version- -> Excepts '[ProcessError] m ()-installUnpackedGHC path inst ver- | isWindows = do- lift $ logInfo "Installing GHC (this may take a while)"- -- Windows bindists are relocatable and don't need- -- to run configure.- -- We also must make sure to preserve mtime to not confuse ghc-pkg.- lift $ withRunInIO $ \run -> flip onException (case inst of- IsolateDirResolved _ -> pure ()- GHCupDir d -> run $ recyclePathForcibly d- ) $ copyDirectoryRecursive path (fromInstallDir inst) $ \source dest -> do- mtime <- getModificationTime source- moveFilePortable source dest- setModificationTime dest mtime- | otherwise = do- PlatformRequest {..} <- lift getPlatformReq-- let alpineArgs- | ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform- = ["--disable-ld-override"]- | otherwise- = []-- lift $ logInfo "Installing GHC (this may take a while)"- lEM $ execLogged "sh"- ("./configure" : ("--prefix=" <> fromInstallDir inst)- : alpineArgs- )- (Just path)- "ghc-configure"- Nothing- lEM $ make ["install"] (Just path)- pure ()----- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the--- following symlinks in @~\/.ghcup\/bin@:------ * @ghc-x.y.z -> ..\/ghc\/x.y.z\/bin/ghc@--- * @ghc-x.y -> ..\/ghc\/x.y.z\/bin/ghc@ (if x.y.z is the latest x.y version)-installGHCBin :: ( MonadFail m- , MonadMask m- , MonadCatch m- , MonadReader env m- , HasPlatformReq env- , HasGHCupInfo env- , HasDirs env- , HasSettings env- , HasLog env- , MonadResource m- , MonadIO m- , MonadUnliftIO m- )- => Version -- ^ the version to install- -> InstallDir- -> Bool -- ^ force install- -> Excepts- '[ AlreadyInstalled- , BuildFailed- , DigestError- , GPGError- , DownloadFailed- , NoDownload- , NotInstalled- , UnknownArchive- , TarDirDoesNotExist- , DirNotEmpty- , ArchiveResult- , ProcessError- ]- m- ()-installGHCBin ver installDir forceInstall = do- dlinfo <- liftE $ getDownloadInfo GHC ver- liftE $ installGHCBindist dlinfo ver installDir forceInstall----- | Like 'installCabalBin', except takes the 'DownloadInfo' as--- argument instead of looking it up from 'GHCupDownloads'.-installCabalBindist :: ( MonadMask m- , MonadCatch m- , MonadReader env m- , HasPlatformReq env- , HasDirs env- , HasSettings env- , HasLog env- , MonadResource m- , MonadIO m- , MonadUnliftIO m- , MonadFail m- )- => DownloadInfo- -> Version- -> InstallDir- -> Bool -- ^ Force install- -> Excepts- '[ AlreadyInstalled- , CopyError- , DigestError- , GPGError- , DownloadFailed- , NoDownload- , NotInstalled- , UnknownArchive- , TarDirDoesNotExist- , ArchiveResult- , FileAlreadyExistsError- ]- m- ()-installCabalBindist dlinfo ver installDir forceInstall = do- lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver-- PlatformRequest {..} <- lift getPlatformReq- Dirs {..} <- lift getDirs-- -- check if we already have a regular cabal already installed- regularCabalInstalled <- lift $ checkIfToolInstalled Cabal ver-- if- | not forceInstall- , regularCabalInstalled- , GHCupInternal <- installDir -> do- throwE $ AlreadyInstalled Cabal ver-- | forceInstall- , regularCabalInstalled- , GHCupInternal <- installDir -> do- lift $ logInfo "Removing the currently installed version first!"- liftE $ rmCabalVer ver-- | otherwise -> pure ()--- -- download (or use cached version)- dl <- liftE $ downloadCached dlinfo Nothing-- -- unpack- tmpUnpack <- lift withGHCupTmpDir- liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)- liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack-- -- the subdir of the archive where we do the work- workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)-- case installDir of- IsolateDir isoDir -> do -- isolated install- lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir- liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall-- GHCupInternal -> do -- regular install- liftE $ installCabalUnpacked workdir (GHCupDir binDir) ver forceInstall----- | Install an unpacked cabal distribution.Symbol-installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m)- => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)- -> InstallDirResolved -- ^ Path to install to- -> Version- -> Bool -- ^ Force Install- -> Excepts '[CopyError, FileAlreadyExistsError] m ()-installCabalUnpacked path inst ver forceInstall = do- lift $ logInfo "Installing cabal"- let cabalFile = "cabal"- liftIO $ createDirRecursive' (fromInstallDir inst)- let destFileName = cabalFile- <> (case inst of- IsolateDirResolved _ -> ""- GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver- )- <> exeExt- let destPath = fromInstallDir inst </> destFileName-- unless forceInstall -- Overwrite it when it IS a force install- (liftE $ throwIfFileAlreadyExists destPath)-- copyFileE- (path </> cabalFile <> exeExt)- destPath- lift $ chmod_755 destPath---- | Installs cabal into @~\/.ghcup\/bin/cabal-\<ver\>@ and--- creates a default @cabal -> cabal-x.y.z.q@ symlink for--- the latest installed version.-installCabalBin :: ( MonadMask m- , MonadCatch m- , MonadReader env m- , HasPlatformReq env- , HasGHCupInfo env- , HasDirs env- , HasSettings env- , HasLog env- , MonadResource m- , MonadIO m- , MonadUnliftIO m- , MonadFail m- )- => Version- -> InstallDir- -> Bool -- force install- -> Excepts- '[ AlreadyInstalled- , CopyError- , DigestError- , GPGError- , DownloadFailed- , NoDownload- , NotInstalled- , UnknownArchive- , TarDirDoesNotExist- , ArchiveResult- , FileAlreadyExistsError- ]- m- ()-installCabalBin ver installDir forceInstall = do- dlinfo <- liftE $ getDownloadInfo Cabal ver- installCabalBindist dlinfo ver installDir forceInstall----- | Like 'installHLSBin, except takes the 'DownloadInfo' as--- argument instead of looking it up from 'GHCupDownloads'.-installHLSBindist :: ( MonadMask m- , MonadCatch m- , MonadReader env m- , HasPlatformReq env- , HasDirs env- , HasSettings env- , HasLog env- , MonadResource m- , MonadIO m- , MonadUnliftIO m- , MonadFail m- )- => DownloadInfo- -> Version- -> InstallDir -- ^ isolated install path, if user passed any- -> Bool -- ^ Force install- -> Excepts- '[ AlreadyInstalled- , CopyError- , DigestError- , GPGError- , DownloadFailed- , NoDownload- , NotInstalled- , UnknownArchive- , TarDirDoesNotExist- , ArchiveResult- , FileAlreadyExistsError- , ProcessError- , DirNotEmpty- ]- m- ()-installHLSBindist dlinfo ver installDir forceInstall = do- lift $ logDebug $ "Requested to install hls version " <> prettyVer ver-- PlatformRequest {..} <- lift getPlatformReq- Dirs {..} <- lift getDirs-- regularHLSInstalled <- lift $ checkIfToolInstalled HLS ver-- if- | not forceInstall- , regularHLSInstalled- , GHCupInternal <- installDir -> do -- regular install- throwE $ AlreadyInstalled HLS ver-- | forceInstall- , regularHLSInstalled- , GHCupInternal <- installDir -> do -- regular forced install- lift $ logInfo "Removing the currently installed version of HLS before force installing!"- liftE $ rmHLSVer ver-- | otherwise -> pure ()-- -- download (or use cached version)- dl <- liftE $ downloadCached dlinfo Nothing-- -- unpack- tmpUnpack <- lift withGHCupTmpDir- liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)- liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack-- -- the subdir of the archive where we do the work- workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)- legacy <- liftIO $ isLegacyHLSBindist workdir-- if- | not forceInstall- , not legacy- , (IsolateDir fp) <- installDir -> liftE $ installDestSanityCheck (IsolateDirResolved fp)- | otherwise -> pure ()-- case installDir of- IsolateDir isoDir -> do- lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir- if legacy- then liftE $ installHLSUnpackedLegacy workdir (IsolateDirResolved isoDir) ver forceInstall- else liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver-- GHCupInternal -> do- if legacy- then liftE $ installHLSUnpackedLegacy workdir (GHCupDir binDir) ver forceInstall- else do- inst <- ghcupHLSDir ver- liftE $ runBuildAction tmpUnpack (Just inst)- $ installHLSUnpacked workdir (GHCupDir inst) ver- liftE $ setHLS ver SetHLS_XYZ Nothing---isLegacyHLSBindist :: FilePath -- ^ Path to the unpacked hls bindist- -> IO Bool-isLegacyHLSBindist path = do- not <$> doesFileExist (path </> "GNUmakefile")---- | Install an unpacked hls distribution.-installHLSUnpacked :: (MonadMask m, MonadUnliftIO m, MonadReader env m, MonadFail m, HasLog env, HasDirs env, HasSettings env, MonadCatch m, MonadIO m)- => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)- -> InstallDirResolved -- ^ Path to install to- -> Version- -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m ()-installHLSUnpacked path (fromInstallDir -> inst) _ = do- lift $ logInfo "Installing HLS"- liftIO $ createDirRecursive' inst- lEM $ make ["PREFIX=" <> inst, "install"] (Just path)---- | Install an unpacked hls distribution (legacy).-installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)- => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)- -> InstallDirResolved -- ^ Path to install to- -> Version- -> Bool -- ^ is it a force install- -> Excepts '[CopyError, FileAlreadyExistsError] m ()-installHLSUnpackedLegacy path installDir ver forceInstall = do- lift $ logInfo "Installing HLS"- liftIO $ createDirRecursive' (fromInstallDir installDir)-- -- install haskell-language-server-<ghcver>- bins@(_:_) <- liftIO $ findFiles- path- (makeRegexOpts compExtended- execBlank- ([s|^haskell-language-server-[0-9].*$|] :: ByteString)- )- forM_ bins $ \f -> do- let toF = dropSuffix exeExt f- <> (case installDir of- IsolateDirResolved _ -> ""- GHCupDir _ -> ("~" <>) . T.unpack . prettyVer $ ver- )- <> exeExt-- let srcPath = path </> f- let destPath = fromInstallDir installDir </> toF-- unless forceInstall -- if it is a force install, overwrite it.- (liftE $ throwIfFileAlreadyExists destPath)-- copyFileE- srcPath- destPath- lift $ chmod_755 destPath-- -- install haskell-language-server-wrapper- let wrapper = "haskell-language-server-wrapper"- toF = wrapper- <> (case installDir of- IsolateDirResolved _ -> ""- GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver- )- <> exeExt- srcWrapperPath = path </> wrapper <> exeExt- destWrapperPath = fromInstallDir installDir </> toF-- unless forceInstall- (liftE $ throwIfFileAlreadyExists destWrapperPath)-- copyFileE- srcWrapperPath- destWrapperPath-- lift $ chmod_755 destWrapperPath------ | Installs hls binaries @haskell-language-server-\<ghcver\>@--- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.-installHLSBin :: ( MonadMask m- , MonadCatch m- , MonadReader env m- , HasPlatformReq env- , HasGHCupInfo env- , HasDirs env- , HasSettings env- , HasLog env- , MonadResource m- , MonadIO m- , MonadUnliftIO m- , MonadFail m- )- => Version- -> InstallDir- -> Bool -- force install- -> Excepts- '[ AlreadyInstalled- , CopyError- , DigestError- , GPGError- , DownloadFailed- , NoDownload- , NotInstalled- , UnknownArchive- , TarDirDoesNotExist- , ArchiveResult- , FileAlreadyExistsError- , ProcessError- , DirNotEmpty- ]- m- ()-installHLSBin ver installDir forceInstall = do- dlinfo <- liftE $ getDownloadInfo HLS ver- installHLSBindist dlinfo ver installDir forceInstall---compileHLS :: ( MonadMask m- , MonadCatch m- , MonadReader env m- , HasDirs env- , HasSettings env- , HasPlatformReq env- , HasGHCupInfo env- , HasLog env- , MonadResource m- , MonadIO m- , MonadUnliftIO m- , MonadFail m- )- => Either Version GitBranch- -> [Version]- -> Maybe Int- -> Maybe Version- -> InstallDir- -> Maybe (Either FilePath URI)- -> Maybe URI- -> Maybe (Either FilePath [URI]) -- ^ patches- -> [Text] -- ^ additional args to cabal install- -> Excepts '[ NoDownload- , GPGError- , DownloadFailed- , DigestError- , UnknownArchive- , TarDirDoesNotExist- , ArchiveResult- , BuildFailed- , NotInstalled- ] m Version-compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patches cabalArgs = do- PlatformRequest { .. } <- lift getPlatformReq- GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo- Dirs { .. } <- lift getDirs--- (workdir, tver) <- case targetHLS of- -- unpack from version tarball- Left tver -> do- lift $ logDebug $ "Requested to compile: " <> prettyVer tver-- -- download source tarball- dlInfo <-- preview (ix HLS % ix tver % viSourceDL % _Just) dls- ?? NoDownload- dl <- liftE $ downloadCached dlInfo Nothing-- -- unpack- tmpUnpack <- lift mkGhcupTmpDir- liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)- liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack-- workdir <- maybe (pure tmpUnpack)- (liftE . intoSubdir tmpUnpack)- (view dlSubdir dlInfo)-- pure (workdir, tver)-- -- clone from git- Right GitBranch{..} -> do- tmpUnpack <- lift mkGhcupTmpDir- let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing- tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do- let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo- lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"- lEM $ git [ "init" ]- lEM $ git [ "remote"- , "add"- , "origin"- , fromString rep ]-- let fetch_args =- [ "fetch"- , "--depth"- , "1"- , "--quiet"- , "origin"- , fromString ref ]- lEM $ git fetch_args-- lEM $ git [ "checkout", "FETCH_HEAD" ]- (Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (tmpUnpack </> "haskell-language-server.cabal"))- pure . (\c -> Version Nothing c [] Nothing)- . NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral)- . versionNumbers- . pkgVersion- . package- . packageDescription- $ gpd-- liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack- lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver-- pure (tmpUnpack, tver)-- -- the version that's installed may differ from the- -- compiled version, so the user can overwrite it- let installVer = fromMaybe tver ov-- liftE $ runBuildAction- workdir- Nothing- (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed workdir) $ do- let tmpInstallDir = workdir </> "out"- liftIO $ createDirRecursive' tmpInstallDir-- -- apply patches- liftE $ applyAnyPatch patches workdir-- -- set up project files- cp <- case cabalProject of- Just (Left cp)- | isAbsolute cp -> do- copyFileE cp (workdir </> "cabal.project")- pure "cabal.project"- | otherwise -> pure (takeFileName cp)- Just (Right uri) -> do- tmpUnpack <- lift withGHCupTmpDir- cp <- liftE $ download uri Nothing Nothing tmpUnpack (Just "cabal.project") False- copyFileE cp (workdir </> "cabal.project")- pure "cabal.project"- Nothing -> pure "cabal.project"- forM_ cabalProjectLocal $ \uri -> do- tmpUnpack <- lift withGHCupTmpDir- cpl <- liftE $ download uri Nothing Nothing tmpUnpack (Just (cp <.> "local")) False- copyFileE cpl (workdir </> cp <.> "local")- artifacts <- forM (sort ghcs) $ \ghc -> do- let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)- liftIO $ createDirRecursive' tmpInstallDir- lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc- liftE $ lEM @_ @'[ProcessError] $- execLogged "cabal" ( [ "v2-install"- , "-w"- , "ghc-" <> T.unpack (prettyVer ghc)- , "--install-method=copy"- ] ++- maybe [] (\j -> ["--jobs=" <> show j]) jobs ++- [ "--overwrite-policy=always"- , "--disable-profiling"- , "--disable-tests"- , "--installdir=" <> ghcInstallDir- , "--project-file=" <> cp- ] ++ fmap T.unpack cabalArgs ++ [- "exe:haskell-language-server"- , "exe:haskell-language-server-wrapper"]- )- (Just workdir) "cabal" Nothing- pure ghcInstallDir-- forM_ artifacts $ \artifact -> do- liftIO $ renameFile (artifact </> "haskell-language-server" <.> exeExt)- (tmpInstallDir </> "haskell-language-server-" <> takeFileName artifact <.> exeExt)- liftIO $ renameFile (artifact </> "haskell-language-server-wrapper" <.> exeExt)- (tmpInstallDir </> "haskell-language-server-wrapper" <.> exeExt)- liftIO $ rmPathForcibly artifact-- case installDir of- IsolateDir isoDir -> do- lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir- liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True- GHCupInternal -> do- liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupDir binDir) installVer True- )-- pure installVer------ | Installs stack into @~\/.ghcup\/bin/stack-\<ver\>@ and--- creates a default @stack -> stack-x.y.z.q@ symlink for--- the latest installed version.-installStackBin :: ( MonadMask m- , MonadCatch m- , MonadReader env m- , HasDirs env- , HasSettings env- , HasPlatformReq env- , HasGHCupInfo env- , HasLog env- , MonadResource m- , MonadIO m- , MonadUnliftIO m- , MonadFail m- )- => Version- -> InstallDir- -> Bool -- ^ Force install- -> Excepts- '[ AlreadyInstalled- , CopyError- , DigestError- , GPGError- , DownloadFailed- , NoDownload- , NotInstalled- , UnknownArchive- , TarDirDoesNotExist- , ArchiveResult- , FileAlreadyExistsError- ]- m- ()-installStackBin ver installDir forceInstall = do- dlinfo <- liftE $ getDownloadInfo Stack ver- installStackBindist dlinfo ver installDir forceInstall----- | Like 'installStackBin', except takes the 'DownloadInfo' as--- argument instead of looking it up from 'GHCupDownloads'.-installStackBindist :: ( MonadMask m- , MonadCatch m- , MonadReader env m- , HasPlatformReq env- , HasDirs env- , HasSettings env- , HasLog env- , MonadResource m- , MonadIO m- , MonadUnliftIO m- , MonadFail m- )- => DownloadInfo- -> Version- -> InstallDir- -> Bool -- ^ Force install- -> Excepts- '[ AlreadyInstalled- , CopyError- , DigestError- , GPGError- , DownloadFailed- , NoDownload- , NotInstalled- , UnknownArchive- , TarDirDoesNotExist- , ArchiveResult- , FileAlreadyExistsError- ]- m- ()-installStackBindist dlinfo ver installDir forceInstall = do- lift $ logDebug $ "Requested to install stack version " <> prettyVer ver-- PlatformRequest {..} <- lift getPlatformReq- Dirs {..} <- lift getDirs-- regularStackInstalled <- lift $ checkIfToolInstalled Stack ver-- if- | not forceInstall- , regularStackInstalled- , GHCupInternal <- installDir -> do- throwE $ AlreadyInstalled Stack ver-- | forceInstall- , regularStackInstalled- , GHCupInternal <- installDir -> do- lift $ logInfo "Removing the currently installed version of Stack first!"- liftE $ rmStackVer ver-- | otherwise -> pure ()-- -- download (or use cached version)- dl <- liftE $ downloadCached dlinfo Nothing-- -- unpack- tmpUnpack <- lift withGHCupTmpDir- liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)- liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack-- -- the subdir of the archive where we do the work- workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)-- case installDir of- IsolateDir isoDir -> do -- isolated install- lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir- liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall- GHCupInternal -> do -- regular install- liftE $ installStackUnpacked workdir (GHCupDir binDir) ver forceInstall----- | Install an unpacked stack distribution.-installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)- => FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)- -> InstallDirResolved- -> Version- -> Bool -- ^ Force install- -> Excepts '[CopyError, FileAlreadyExistsError] m ()-installStackUnpacked path installDir ver forceInstall = do- lift $ logInfo "Installing stack"- let stackFile = "stack"- liftIO $ createDirRecursive' (fromInstallDir installDir)- let destFileName = stackFile- <> (case installDir of- IsolateDirResolved _ -> ""- GHCupDir _ -> ("-" <>) . T.unpack . prettyVer $ ver- )- <> exeExt- destPath = fromInstallDir installDir </> destFileName-- unless forceInstall- (liftE $ throwIfFileAlreadyExists destPath)-- copyFileE- (path </> stackFile <> exeExt)- destPath- lift $ chmod_755 destPath--- ---------------------- --[ Set GHC/cabal ]--- --------------------------- | Set GHC symlinks in @~\/.ghcup\/bin@ for the requested GHC version. The behavior depends--- on `SetGHC`:------ * SetGHCOnly: @~\/.ghcup\/bin\/ghc -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@--- * SetGHC_XY: @~\/.ghcup\/bin\/ghc-X.Y -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@--- * SetGHC_XYZ: @~\/.ghcup\/bin\/ghc-\<ver\> -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@------ Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@--- for 'SetGHCOnly' constructor.-setGHC :: ( MonadReader env m- , HasDirs env- , HasLog env- , MonadThrow m- , MonadFail m- , MonadIO m- , MonadCatch m- , MonadMask m- , MonadUnliftIO m- )- => GHCTargetVersion- -> SetGHC- -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin- -- and don't want mess with other versions- -> Excepts '[NotInstalled] m GHCTargetVersion-setGHC ver sghc mBinDir = do- let verS = T.unpack $ prettyVer (_tvVersion ver)- ghcdir <- lift $ ghcupGHCDir ver-- whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver))-- -- symlink destination- binDir <- case mBinDir of- Just x -> pure x- Nothing -> do- Dirs {binDir = f} <- lift getDirs- pure f-- -- first delete the old symlinks (this fixes compatibility issues- -- with old ghcup)- when (isNothing mBinDir) $- case sghc of- SetGHCOnly -> liftE $ rmPlainGHC (_tvTarget ver)- SetGHC_XY -> liftE $ rmMajorGHCSymlinks ver- SetGHC_XYZ -> liftE $ rmMinorGHCSymlinks ver-- -- for ghc tools (ghc, ghci, haddock, ...)- verfiles <- ghcToolFiles ver- forM_ verfiles $ \file -> do- mTargetFile <- case sghc of- SetGHCOnly -> pure $ Just file- SetGHC_XY -> do- handle- (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)- $ do- (mj, mi) <- getMajorMinorV (_tvVersion ver)- let major' = intToText mj <> "." <> intToText mi- pure $ Just (file <> "-" <> T.unpack major')- SetGHC_XYZ ->- pure $ Just (file <> "-" <> verS)-- -- create symlink- forM_ mTargetFile $ \targetFile -> do- bindir <- ghcInternalBinDir ver- let fullF = binDir </> targetFile <> exeExt- fileWithExt = bindir </> file <> exeExt- destL <- binarySymLinkDestination binDir fileWithExt- lift $ createLink destL fullF-- when (isNothing mBinDir) $ do- -- create symlink for share dir- when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS-- when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility-- pure ver-- where-- symlinkShareDir :: ( MonadReader env m- , HasDirs env- , MonadIO m- , HasLog env- , MonadCatch m- , MonadMask m- )- => FilePath- -> String- -> m ()- symlinkShareDir ghcdir ver' = do- Dirs {..} <- getDirs- let destdir = baseDir- case sghc of- SetGHCOnly -> do- let sharedir = "share"- let fullsharedir = ghcdir </> sharedir- logDebug $ "Checking for sharedir existence: " <> T.pack fullsharedir- whenM (liftIO $ doesDirectoryExist fullsharedir) $ do- let fullF = destdir </> sharedir- let targetF = "." </> "ghc" </> ver' </> sharedir- logDebug $ "rm -f " <> T.pack fullF- hideError doesNotExistErrorType $ rmDirectoryLink fullF- logDebug $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF-- if isWindows- then liftIO- -- On windows we need to be more permissive- -- in case symlinks can't be created, be just- -- give up here. This symlink isn't strictly necessary.- $ hideError permissionErrorType- $ hideError illegalOperationErrorType- $ createDirectoryLink targetF fullF- else liftIO- $ createDirectoryLink targetF fullF- _ -> pure ()--unsetGHC :: ( MonadReader env m- , HasDirs env- , HasLog env- , MonadThrow m- , MonadFail m- , MonadIO m- , MonadMask m- )- => Maybe Text- -> Excepts '[NotInstalled] m ()-unsetGHC = rmPlainGHC----- | Set the @~\/.ghcup\/bin\/cabal@ symlink.-setCabal :: ( MonadMask m- , MonadReader env m- , HasDirs env- , HasLog env- , MonadFail m- , MonadIO m- , MonadUnliftIO m)- => Version- -> Excepts '[NotInstalled] m ()-setCabal ver = do- let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt-- -- symlink destination- Dirs {..} <- lift getDirs-- whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))- $ throwE- $ NotInstalled Cabal (GHCTargetVersion Nothing ver)-- let cabalbin = binDir </> "cabal" <> exeExt-- -- create link- let destL = targetFile- lift $ createLink destL cabalbin-- pure ()--unsetCabal :: ( MonadMask m- , MonadReader env m- , HasDirs env- , MonadIO m)- => m ()-unsetCabal = do- Dirs {..} <- getDirs- let cabalbin = binDir </> "cabal" <> exeExt- hideError doesNotExistErrorType $ rmLink cabalbin----- | Set the haskell-language-server symlinks.-setHLS :: ( MonadReader env m- , HasDirs env- , HasLog env- , MonadIO m- , MonadMask m- , MonadFail m- , MonadUnliftIO m- )- => Version- -> SetHLS- -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin- -- and don't want mess with other versions- -> Excepts '[NotInstalled] m ()-setHLS ver shls mBinDir = do- whenM (lift $ not <$> hlsInstalled ver) (throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)))-- -- symlink destination- binDir <- case mBinDir of- Just x -> pure x- Nothing -> do- Dirs {binDir = f} <- lift getDirs- pure f-- -- first delete the old symlinks- when (isNothing mBinDir) $- case shls of- -- not for legacy- SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver- -- legacy and new- SetHLSOnly -> liftE rmPlainHLS-- case shls of- -- not for legacy- SetHLS_XYZ -> do- bins <- lift $ hlsInternalServerScripts ver Nothing-- forM_ bins $ \f -> do- let fname = takeFileName f- destL <- binarySymLinkDestination binDir f- let target = if "haskell-language-server-wrapper" `isPrefixOf` fname- then fname <> "-" <> T.unpack (prettyVer ver) <> exeExt- else fname <> "~" <> T.unpack (prettyVer ver) <> exeExt- lift $ createLink destL (binDir </> target)-- -- legacy and new- SetHLSOnly -> do- -- set haskell-language-server-<ghcver> symlinks- bins <- lift $ hlsServerBinaries ver Nothing- when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)-- forM_ bins $ \f -> do- let destL = f- let target = (<> exeExt) . head . splitOn "~" $ f- lift $ createLink destL (binDir </> target)-- -- set haskell-language-server-wrapper symlink- let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt- let wrapper = binDir </> "haskell-language-server-wrapper" <> exeExt-- lift $ createLink destL wrapper-- when (isNothing mBinDir) $- lift warnAboutHlsCompatibility---unsetHLS :: ( MonadMask m- , MonadReader env m- , HasDirs env- , MonadIO m)- => m ()-unsetHLS = do- Dirs {..} <- getDirs- let wrapper = binDir </> "haskell-language-server-wrapper" <> exeExt- bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles'- binDir- (MP.chunk "haskell-language-server-" <* pvp' <* MP.chunk (T.pack exeExt) <* MP.eof)- forM_ bins (hideError doesNotExistErrorType . rmLink . (binDir </>))- hideError doesNotExistErrorType $ rmLink wrapper----- | Set the @~\/.ghcup\/bin\/stack@ symlink.-setStack :: ( MonadMask m- , MonadReader env m- , HasDirs env- , HasLog env- , MonadThrow m- , MonadFail m- , MonadIO m- , MonadUnliftIO m- )- => Version- -> Excepts '[NotInstalled] m ()-setStack ver = do- let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt-- -- symlink destination- Dirs {..} <- lift getDirs-- whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))- $ throwE- $ NotInstalled Stack (GHCTargetVersion Nothing ver)-- let stackbin = binDir </> "stack" <> exeExt-- lift $ createLink targetFile stackbin-- pure ()---unsetStack :: ( MonadMask m- , MonadReader env m- , HasDirs env- , MonadIO m)- => m ()-unsetStack = do- Dirs {..} <- getDirs- let stackbin = binDir </> "stack" <> exeExt- hideError doesNotExistErrorType $ rmLink stackbin----- | Warn if the installed and set HLS is not compatible with the installed and--- set GHC version.-warnAboutHlsCompatibility :: ( MonadReader env m- , HasDirs env- , HasLog env- , MonadThrow m- , MonadCatch m- , MonadIO m- )- => m ()-warnAboutHlsCompatibility = do- supportedGHC <- hlsGHCVersions- currentGHC <- fmap _tvVersion <$> ghcSet Nothing- currentHLS <- hlsSet-- case (currentGHC, currentHLS) of- (Just gv, Just hv) | gv `notElem` supportedGHC -> do- logWarn $- "GHC " <> T.pack (prettyShow gv) <> " is not compatible with " <>- "Haskell Language Server " <> T.pack (prettyShow hv) <> "." <> "\n" <>- "Haskell IDE support may not work until this is fixed." <> "\n" <>- "Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <>- T.pack (prettyShow supportedGHC)-- _ -> return ()-- ------------------- --[ List tools ]--- ----------------------- | Filter data type for 'listVersions'.-data ListCriteria = ListInstalled- | ListSet- | ListAvailable- deriving Show---- | A list result describes a single tool version--- and various of its properties.-data ListResult = ListResult- { lTool :: Tool- , lVer :: Version- , lCross :: Maybe Text -- ^ currently only for GHC- , lTag :: [Tag]- , lInstalled :: Bool- , lSet :: Bool -- ^ currently active version- , fromSrc :: Bool -- ^ compiled from source- , lStray :: Bool -- ^ not in download info- , lNoBindist :: Bool -- ^ whether the version is available for this platform/arch- , hlsPowered :: Bool- }- deriving (Eq, Ord, Show)----- | Extract all available tool versions and their tags.-availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version VersionInfo-availableToolVersions av tool = view- (at tool % non Map.empty)- av----- | List all versions from the download info, as well as stray--- versions.-listVersions :: ( MonadCatch m- , HasLog env- , MonadThrow m- , HasLog env- , MonadIO m- , MonadReader env m- , HasDirs env- , HasPlatformReq env- , HasGHCupInfo env- )- => Maybe Tool- -> Maybe ListCriteria- -> m [ListResult]-listVersions lt' criteria = do- -- some annoying work to avoid too much repeated IO- cSet <- cabalSet- cabals <- getInstalledCabals- hlsSet' <- hlsSet- hlses <- getInstalledHLSs- sSet <- stackSet- stacks <- getInstalledStacks-- go lt' cSet cabals hlsSet' hlses sSet stacks- where- go lt cSet cabals hlsSet' hlses sSet stacks = do- case lt of- Just t -> do- GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo- -- get versions from GHCupDownloads- let avTools = availableToolVersions dls t- lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks)-- case t of- GHC -> do- slr <- strayGHCs avTools- pure (sort (slr ++ lr))- Cabal -> do- slr <- strayCabals avTools cSet cabals- pure (sort (slr ++ lr))- HLS -> do- slr <- strayHLS avTools hlsSet' hlses- pure (sort (slr ++ lr))- Stack -> do- slr <- strayStacks avTools sSet stacks- pure (sort (slr ++ lr))- GHCup -> do- let cg = maybeToList $ currentGHCup avTools- pure (sort (cg ++ lr))- Nothing -> do- ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks- cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks- hlsvers <- go (Just HLS) cSet cabals hlsSet' hlses sSet stacks- ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks- stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks- pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers)- strayGHCs :: ( MonadCatch m- , MonadReader env m- , HasDirs env- , MonadThrow m- , HasLog env- , MonadIO m- )- => Map.Map Version VersionInfo- -> m [ListResult]- strayGHCs avTools = do- ghcs <- getInstalledGHCs- fmap catMaybes $ forM ghcs $ \case- Right tver@GHCTargetVersion{ _tvTarget = Nothing, .. } -> do- case Map.lookup _tvVersion avTools of- Just _ -> pure Nothing- Nothing -> do- lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing- fromSrc <- ghcSrcInstalled tver- hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions- pure $ Just $ ListResult- { lTool = GHC- , lVer = _tvVersion- , lCross = Nothing- , lTag = []- , lInstalled = True- , lStray = isNothing (Map.lookup _tvVersion avTools)- , lNoBindist = False- , ..- }- Right tver@GHCTargetVersion{ .. } -> do- lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget- fromSrc <- ghcSrcInstalled tver- hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions- pure $ Just $ ListResult- { lTool = GHC- , lVer = _tvVersion- , lCross = _tvTarget- , lTag = []- , lInstalled = True- , lStray = True -- NOTE: cross currently cannot be installed via bindist- , lNoBindist = False- , ..- }- Left e -> do- logWarn- $ "Could not parse version of stray directory" <> T.pack e- pure Nothing-- strayCabals :: ( MonadReader env m- , HasDirs env- , MonadCatch m- , MonadThrow m- , HasLog env- , MonadIO m- )- => Map.Map Version VersionInfo- -> Maybe Version- -> [Either FilePath Version]- -> m [ListResult]- strayCabals avTools cSet cabals = do- fmap catMaybes $ forM cabals $ \case- Right ver ->- case Map.lookup ver avTools of- Just _ -> pure Nothing- Nothing -> do- let lSet = cSet == Just ver- pure $ Just $ ListResult- { lTool = Cabal- , lVer = ver- , lCross = Nothing- , lTag = []- , lInstalled = True- , lStray = isNothing (Map.lookup ver avTools)- , lNoBindist = False- , fromSrc = False -- actually, we don't know :>- , hlsPowered = False- , ..- }- Left e -> do- logWarn- $ "Could not parse version of stray directory" <> T.pack e- pure Nothing-- strayHLS :: ( MonadReader env m- , HasDirs env- , MonadCatch m- , MonadThrow m- , HasLog env- , MonadIO m)- => Map.Map Version VersionInfo- -> Maybe Version- -> [Either FilePath Version]- -> m [ListResult]- strayHLS avTools hlsSet' hlss = do- fmap catMaybes $ forM hlss $ \case- Right ver ->- case Map.lookup ver avTools of- Just _ -> pure Nothing- Nothing -> do- let lSet = hlsSet' == Just ver- pure $ Just $ ListResult- { lTool = HLS- , lVer = ver- , lCross = Nothing- , lTag = []- , lInstalled = True- , lStray = isNothing (Map.lookup ver avTools)- , lNoBindist = False- , fromSrc = False -- actually, we don't know :>- , hlsPowered = False- , ..- }- Left e -> do- logWarn- $ "Could not parse version of stray directory" <> T.pack e- pure Nothing-- strayStacks :: ( MonadReader env m- , HasDirs env- , MonadCatch m- , MonadThrow m- , HasLog env- , MonadIO m- )- => Map.Map Version VersionInfo- -> Maybe Version- -> [Either FilePath Version]- -> m [ListResult]- strayStacks avTools stackSet' stacks = do- fmap catMaybes $ forM stacks $ \case- Right ver ->- case Map.lookup ver avTools of- Just _ -> pure Nothing- Nothing -> do- let lSet = stackSet' == Just ver- pure $ Just $ ListResult- { lTool = Stack- , lVer = ver- , lCross = Nothing- , lTag = []- , lInstalled = True- , lStray = isNothing (Map.lookup ver avTools)- , lNoBindist = False- , fromSrc = False -- actually, we don't know :>- , hlsPowered = False- , ..- }- Left e -> do- logWarn- $ "Could not parse version of stray directory" <> T.pack e- pure Nothing-- currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult- currentGHCup av =- let currentVer = fromJust $ pvpToVersion ghcUpVer ""- listVer = Map.lookup currentVer av- latestVer = fst <$> headOf (getTagged Latest) av- recommendedVer = fst <$> headOf (getTagged Latest) av- isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer- in if | Map.member currentVer av -> Nothing- | otherwise -> Just $ ListResult { lVer = currentVer- , lTag = maybe (if isOld then [Old] else []) _viTags listVer- , lCross = Nothing- , lTool = GHCup- , fromSrc = False- , lStray = isNothing listVer- , lSet = True- , lInstalled = True- , lNoBindist = False- , hlsPowered = False- }-- -- NOTE: this are not cross ones, because no bindists- toListResult :: ( HasLog env- , MonadReader env m- , HasDirs env- , HasGHCupInfo env- , HasPlatformReq env- , MonadIO m- , MonadCatch m- )- => Tool- -> Maybe Version- -> [Either FilePath Version]- -> Maybe Version- -> [Either FilePath Version]- -> Maybe Version- -> [Either FilePath Version]- -> (Version, VersionInfo)- -> m ListResult- toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, _viTags -> tags) = do- case t of- GHC -> do- lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v- let tver = mkTVer v- lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing- lInstalled <- ghcInstalled tver- fromSrc <- ghcSrcInstalled tver- hlsPowered <- fmap (elem v) hlsGHCVersions- pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }- Cabal -> do- lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v- let lSet = cSet == Just v- let lInstalled = elem v $ rights cabals- pure ListResult { lVer = v- , lCross = Nothing- , lTag = tags- , lTool = t- , fromSrc = False- , lStray = False- , hlsPowered = False- , ..- }- GHCup -> do- let lSet = prettyPVP ghcUpVer == prettyVer v- let lInstalled = lSet- pure ListResult { lVer = v- , lTag = tags- , lCross = Nothing- , lTool = t- , fromSrc = False- , lStray = False- , lNoBindist = False- , hlsPowered = False- , ..- }- HLS -> do- lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo HLS v- let lSet = hlsSet' == Just v- let lInstalled = elem v $ rights hlses- pure ListResult { lVer = v- , lCross = Nothing- , lTag = tags- , lTool = t- , fromSrc = False- , lStray = False- , hlsPowered = False- , ..- }- Stack -> do- lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Stack v- let lSet = stackSet' == Just v- let lInstalled = elem v $ rights stacks- pure ListResult { lVer = v- , lCross = Nothing- , lTag = tags- , lTool = t- , fromSrc = False- , lStray = False- , hlsPowered = False- , ..- }--- filter' :: [ListResult] -> [ListResult]- filter' lr = case criteria of- Nothing -> lr- Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr- Just ListSet -> filter (\ListResult {..} -> lSet) lr- Just ListAvailable -> filter (\ListResult {..} -> not lNoBindist) lr---- --------------------- --[ GHC/cabal rm ]--- ------------------------- | Delete a ghc version and all its symlinks.------ This may leave GHCup without a "set" version.--- Will try to fix the ghc-x.y symlink after removal (e.g. to an--- older version).-rmGHCVer :: ( MonadReader env m- , HasDirs env- , MonadThrow m- , HasLog env- , MonadIO m- , MonadFail m- , MonadCatch m- , MonadMask m- , MonadUnliftIO m- )- => GHCTargetVersion- -> Excepts '[NotInstalled] m ()-rmGHCVer ver = do- isSetGHC <- lift $ fmap (== Just ver) $ ghcSet (_tvTarget ver)-- whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver))- dir <- lift $ ghcupGHCDir ver-- -- this isn't atomic, order matters- when isSetGHC $ do- lift $ logInfo "Removing ghc symlinks"- liftE $ rmPlainGHC (_tvTarget ver)-- lift $ logInfo "Removing ghc-x.y.z symlinks"- liftE $ rmMinorGHCSymlinks ver-- lift $ logInfo "Removing/rewiring ghc-x.y symlinks"- -- first remove- handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver- -- then fix them (e.g. with an earlier version)-- lift $ logInfo $ "Removing directory recursively: " <> T.pack dir- lift $ recyclePathForcibly dir-- v' <-- handle- (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)- $ fmap Just- $ getMajorMinorV (_tvVersion ver)- forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) (_tvTarget ver))- >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing)-- Dirs {..} <- lift getDirs-- lift $ hideError doesNotExistErrorType $ rmDirectoryLink (baseDir </> "share")----- | Delete a cabal version. Will try to fix the @cabal@ symlink--- after removal (e.g. setting it to an older version).-rmCabalVer :: ( MonadMask m- , MonadReader env m- , HasDirs env- , MonadThrow m- , HasLog env- , MonadIO m- , MonadFail m- , MonadCatch m- , MonadUnliftIO m- )- => Version- -> Excepts '[NotInstalled] m ()-rmCabalVer ver = do- whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing ver))-- cSet <- lift cabalSet-- Dirs {..} <- lift getDirs-- let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt- lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> cabalFile)-- when (Just ver == cSet) $ do- cVers <- lift $ fmap rights getInstalledCabals- case headMay . reverse . sort $ cVers of- Just latestver -> setCabal latestver- Nothing -> lift $ rmLink (binDir </> "cabal" <> exeExt)----- | Delete a hls version. Will try to fix the hls symlinks--- after removal (e.g. setting it to an older version).-rmHLSVer :: ( MonadMask m- , MonadReader env m- , HasDirs env- , MonadThrow m- , HasLog env- , MonadIO m- , MonadFail m- , MonadCatch m- , MonadUnliftIO m- )- => Version- -> Excepts '[NotInstalled] m ()-rmHLSVer ver = do- whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))-- isHlsSet <- lift hlsSet-- liftE $ rmMinorHLSSymlinks ver- hlsDir <- ghcupHLSDir ver- recyclePathForcibly hlsDir-- when (Just ver == isHlsSet) $ do- -- delete all set symlinks- rmPlainHLS- -- set latest hls- hlsVers <- lift $ fmap rights getInstalledHLSs- case headMay . reverse . sort $ hlsVers of- Just latestver -> setHLS latestver SetHLSOnly Nothing- Nothing -> pure ()----- | Delete a stack version. Will try to fix the @stack@ symlink--- after removal (e.g. setting it to an older version).-rmStackVer :: ( MonadMask m- , MonadReader env m- , HasDirs env- , MonadThrow m- , HasLog env- , MonadIO m- , MonadFail m- , MonadCatch m- , MonadUnliftIO m- )- => Version- -> Excepts '[NotInstalled] m ()-rmStackVer ver = do- whenM (lift $ fmap not $ stackInstalled ver) $ throwE (NotInstalled Stack (GHCTargetVersion Nothing ver))-- sSet <- lift stackSet-- Dirs {..} <- lift getDirs-- let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt- lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> stackFile)-- when (Just ver == sSet) $ do- sVers <- lift $ fmap rights getInstalledStacks- case headMay . reverse . sort $ sVers of- Just latestver -> setStack latestver- Nothing -> lift $ rmLink (binDir </> "stack" <> exeExt)----- assuming the current scheme of having just 1 ghcup bin, no version info is required.-rmGhcup :: ( MonadReader env m- , HasDirs env- , MonadIO m- , MonadCatch m- , HasLog env- , MonadMask m- , MonadUnliftIO m- )- => m ()-rmGhcup = do- Dirs { .. } <- getDirs- let ghcupFilename = "ghcup" <> exeExt- let ghcupFilepath = binDir </> ghcupFilename-- currentRunningExecPath <- liftIO getExecutablePath-- -- if paths do no exist, warn user, and continue to compare them, as is,- -- which should eventually fail and result in a non-standard install warning-- p1 <- handleIO' doesNotExistErrorType- (handlePathNotPresent currentRunningExecPath)- (liftIO $ canonicalizePath currentRunningExecPath)-- p2 <- handleIO' doesNotExistErrorType- (handlePathNotPresent ghcupFilepath)- (liftIO $ canonicalizePath ghcupFilepath)-- let areEqualPaths = equalFilePath p1 p2-- unless areEqualPaths $ logWarn $ nonStandardInstallLocationMsg currentRunningExecPath-- if isWindows- then do- -- since it doesn't seem possible to delete a running exe on windows- -- we move it to temp dir, to be deleted at next reboot- tempFilepath <- mkGhcupTmpDir- hideError UnsupportedOperation $- liftIO $ hideError NoSuchThing $- moveFile ghcupFilepath (tempFilepath </> "ghcup")- else- -- delete it.- hideError doesNotExistErrorType $ rmFile ghcupFilepath-- where- handlePathNotPresent fp _err = do- logDebug $ "Error: The path does not exist, " <> T.pack fp- pure fp-- nonStandardInstallLocationMsg path = T.pack $- "current ghcup is invoked from a non-standard location: \n"- <> path <>- "\n you may have to uninstall it manually."--rmTool :: ( MonadReader env m- , HasDirs env- , HasLog env- , MonadFail m- , MonadMask m- , MonadUnliftIO m)- => ListResult- -> Excepts '[NotInstalled ] m ()-rmTool ListResult {lVer, lTool, lCross} = do- case lTool of- GHC ->- let ghcTargetVersion = GHCTargetVersion lCross lVer- in rmGHCVer ghcTargetVersion- HLS -> rmHLSVer lVer- Cabal -> rmCabalVer lVer- Stack -> rmStackVer lVer- GHCup -> lift rmGhcup---rmGhcupDirs :: ( MonadReader env m- , HasDirs env- , MonadIO m- , HasLog env- , MonadCatch m- , MonadMask m )- => m [FilePath]-rmGhcupDirs = do- Dirs- { baseDir- , binDir- , logsDir- , cacheDir- , recycleDir- } <- getDirs-- let envFilePath = baseDir </> "env"-- confFilePath <- getConfigFilePath-- handleRm $ rmEnvFile envFilePath- handleRm $ rmConfFile confFilePath-- -- for xdg dirs, the order matters here- handleRm $ rmDir logsDir- handleRm $ rmDir cacheDir-- handleRm $ rmBinDir binDir- handleRm $ rmDir recycleDir- when isWindows $ do- logInfo $ "removing " <> T.pack (baseDir </> "msys64")- handleRm $ rmPathForcibly (baseDir </> "msys64")-- handleRm $ removeEmptyDirsRecursive baseDir-- -- report files in baseDir that are left-over after- -- the standard location deletions above- hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir-- where- handleRm :: (MonadReader env m, MonadCatch m, HasLog env, MonadIO m) => m () -> m ()- handleRm = handleIO (\e -> logDebug $ "Part of the cleanup action failed with error: " <> T.pack (displayException e) <> "\n"- <> "continuing regardless...")-- rmEnvFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()- rmEnvFile enFilePath = do- logInfo "Removing Ghcup Environment File"- hideErrorDef [permissionErrorType] () $ deleteFile enFilePath-- rmConfFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()- rmConfFile confFilePath = do- logInfo "removing Ghcup Config File"- hideErrorDef [permissionErrorType] () $ deleteFile confFilePath-- rmDir :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()- 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 $ "removing " <> T.pack dir- contents <- liftIO $ getDirectoryContentsRecursive dir- forM_ contents (deleteFile . (dir </>))-- rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()- rmBinDir binDir- | isWindows = removeDirIfEmptyOrIsSymlink binDir- | otherwise = do- isXDGStyle <- liftIO useXDG- if not isXDGStyle- then removeDirIfEmptyOrIsSymlink binDir- else pure ()-- reportRemainingFiles :: MonadIO m => FilePath -> m [FilePath]- reportRemainingFiles dir = do- -- 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-- pure remainingFilesAbsolute-- where- calcDepth :: FilePath -> Int- calcDepth = length . filter isPathSeparator-- compareFn :: FilePath -> FilePath -> Ordering- compareFn fp1 fp2 = compare (calcDepth fp1) (calcDepth fp2)-- removeEmptyDirsRecursive :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()- removeEmptyDirsRecursive fp = do- cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)- forM_ cs removeEmptyDirsRecursive- hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp--- -- we expect only files inside cache/log dir- -- we report remaining files/dirs later,- -- hence the force/quiet mode in these delete functions below.-- deleteFile :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m) => FilePath -> m ()- deleteFile filepath = do- hideError doesNotExistErrorType- $ hideError InappropriateType $ rmFile filepath-- removeDirIfEmptyOrIsSymlink :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()- removeDirIfEmptyOrIsSymlink filepath =- hideError UnsatisfiedConstraints $- handleIO' InappropriateType- (handleIfSym filepath)- (liftIO $ rmDirectory filepath)- where- handleIfSym fp e = do- isSym <- liftIO $ pathIsSymbolicLink fp- if isSym- then deleteFile fp- else liftIO $ ioError e---- ------------------- --[ Debug info ]--- ---------------------getDebugInfo :: ( Alternative m- , MonadFail m- , MonadReader env m- , HasDirs env- , HasLog env- , MonadCatch m- , MonadIO m- )- => Excepts- '[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]- m- DebugInfo-getDebugInfo = do- Dirs {..} <- lift getDirs- let diBaseDir = baseDir- let diBinDir = binDir- diGHCDir <- lift ghcupGHCBaseDir- let diCacheDir = cacheDir- diArch <- lE getArchitecture- diPlatform <- liftE getPlatform- pure $ DebugInfo { .. }----- ---------------- --[ Compile ]--- -------------------- | Compile a GHC from source. This behaves wrt symlinks and installation--- the same as 'installGHCBin'.-compileGHC :: ( MonadMask m- , MonadReader env m- , HasDirs env- , HasPlatformReq env- , HasGHCupInfo env- , HasSettings env- , MonadThrow m- , MonadResource m- , HasLog env- , MonadIO m- , MonadUnliftIO m- , MonadFail m- )- => Either GHCTargetVersion GitBranch -- ^ version to install- -> Maybe Version -- ^ overwrite version- -> Either Version FilePath -- ^ version to bootstrap with- -> Maybe Int -- ^ jobs- -> Maybe FilePath -- ^ build config- -> Maybe (Either FilePath [URI]) -- ^ patches- -> [Text] -- ^ additional args to ./configure- -> Maybe String -- ^ build flavour- -> Bool- -> InstallDir- -> Excepts- '[ AlreadyInstalled- , BuildFailed- , DigestError- , GPGError- , DownloadFailed- , GHCupSetError- , NoDownload- , NotFoundInPATH- , PatchFailed- , UnknownArchive- , TarDirDoesNotExist- , NotInstalled- , DirNotEmpty- , ArchiveResult- , FileDoesNotExistError- , HadrianNotFound- , InvalidBuildConfig- , ProcessError- , CopyError- , BuildFailed- ]- m- GHCTargetVersion-compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir- = do- PlatformRequest { .. } <- lift getPlatformReq- GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo-- (workdir, tmpUnpack, tver) <- case targetGhc of- -- unpack from version tarball- Left tver -> do- lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap-- -- download source tarball- dlInfo <-- preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls- ?? NoDownload- dl <- liftE $ downloadCached dlInfo Nothing-- -- unpack- tmpUnpack <- lift mkGhcupTmpDir- liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)- liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack-- workdir <- maybe (pure tmpUnpack)- (liftE . intoSubdir tmpUnpack)- (view dlSubdir dlInfo)- liftE $ applyAnyPatch patches workdir-- pure (workdir, tmpUnpack, tver)-- -- clone from git- Right GitBranch{..} -> do- tmpUnpack <- lift mkGhcupTmpDir- let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing- tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do- let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo- lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"- lEM $ git [ "init" ]- lEM $ git [ "remote"- , "add"- , "origin"- , fromString rep ]-- let fetch_args =- [ "fetch"- , "--depth"- , "1"- , "--quiet"- , "origin"- , fromString ref ]- lEM $ git fetch_args-- lEM $ git [ "checkout", "FETCH_HEAD" ]- lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]- liftE $ applyAnyPatch patches tmpUnpack- lEM $ execWithGhcEnv "python3" ["./boot"] (Just tmpUnpack) "ghc-bootstrap"- lEM $ execWithGhcEnv "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap"- CapturedProcess {..} <- lift $ makeOut- ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack)- case _exitCode of- ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut- ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr))-- liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack- lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver-- pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)- -- the version that's installed may differ from the- -- compiled version, so the user can overwrite it- let installVer = maybe tver (\ov' -> tver { _tvVersion = ov' }) ov-- alreadyInstalled <- lift $ ghcInstalled installVer- alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer)-- when alreadyInstalled $ do- case installDir of- IsolateDir isoDir ->- lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Isolate installing to " <> T.pack isoDir- GHCupInternal ->- lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Will overwrite existing version."- lift $ logWarn- "...waiting for 10 seconds before continuing, you can still abort..."- liftIO $ threadDelay 10000000 -- give the user a sec to intervene-- ghcdir <- case installDir of- IsolateDir isoDir -> pure $ IsolateDirResolved isoDir- GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer)-- (mBindist, bmk) <- liftE $ runBuildAction- tmpUnpack- Nothing- (do- b <- if hadrian- then compileHadrianBindist tver workdir ghcdir- else compileMakeBindist tver workdir ghcdir- bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk workdir)- pure (b, bmk)- )-- case installDir of- GHCupInternal ->- -- only remove old ghc in regular installs- when alreadyInstalled $ do- lift $ logInfo "Deleting existing installation"- liftE $ rmGHCVer installVer-- _ -> pure ()-- forM_ mBindist $ \bindist -> do- liftE $ installPackedGHC bindist- (Just $ RegexDir "ghc-.*")- ghcdir- (installVer ^. tvVersion)- False -- not a force install, since we already overwrite when compiling.-- liftIO $ B.writeFile (fromInstallDir ghcdir </> ghcUpSrcBuiltFile) bmk-- case installDir of- -- set and make symlinks for regular (non-isolated) installs- GHCupInternal -> do- reThrowAll GHCupSetError $ postGHCInstall installVer- -- restore- when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly Nothing-- _ -> pure ()-- pure installVer-- where- defaultConf =- let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross")))- default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default")))- in case targetGhc of- Left (GHCTargetVersion (Just _) _) -> cross_mk- _ -> default_mk-- compileHadrianBindist :: ( MonadReader env m- , HasDirs env- , HasSettings env- , HasPlatformReq env- , MonadThrow m- , MonadCatch m- , HasLog env- , MonadIO m- , MonadFail m- )- => GHCTargetVersion- -> FilePath- -> InstallDirResolved- -> Excepts- '[ FileDoesNotExistError- , HadrianNotFound- , InvalidBuildConfig- , PatchFailed- , ProcessError- , NotFoundInPATH- , CopyError]- m- (Maybe FilePath) -- ^ output path of bindist, None for cross- compileHadrianBindist tver workdir ghcdir = do- lEM $ execWithGhcEnv "python3" ["./boot"] (Just workdir) "ghc-bootstrap"-- liftE $ configureBindist tver workdir ghcdir-- lift $ logInfo "Building (this may take a while)..."- hadrian_build <- liftE $ findHadrianFile workdir- lEM $ execWithGhcEnv hadrian_build- ( maybe [] (\j -> ["-j" <> show j] ) jobs- ++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour- ++ ["binary-dist"]- )- (Just workdir) "ghc-make"- [tar] <- liftIO $ findFiles- (workdir </> "_build" </> "bindist")- (makeRegexOpts compExtended- execBlank- ([s|^ghc-.*\.tar\..*$|] :: ByteString)- )- liftE $ fmap Just $ copyBindist tver tar (workdir </> "_build" </> "bindist")-- findHadrianFile :: (MonadIO m)- => FilePath- -> Excepts- '[HadrianNotFound]- m- FilePath- findHadrianFile workdir = do- let possible_files = if isWindows- then ((workdir </> "hadrian") </>) <$> ["build.bat"]- else ((workdir </> "hadrian") </>) <$> ["build", "build.sh"]- exsists <- forM possible_files (\f -> liftIO (doesFileExist f) <&> (,f))- case filter fst exsists of- [] -> throwE HadrianNotFound- ((_, x):_) -> pure x-- compileMakeBindist :: ( MonadReader env m- , HasDirs env- , HasSettings env- , HasPlatformReq env- , MonadThrow m- , MonadCatch m- , HasLog env- , MonadIO m- , MonadFail m- )- => GHCTargetVersion- -> FilePath- -> InstallDirResolved- -> Excepts- '[ FileDoesNotExistError- , HadrianNotFound- , InvalidBuildConfig- , PatchFailed- , ProcessError- , NotFoundInPATH- , CopyError]- m- (Maybe FilePath) -- ^ output path of bindist, None for cross- compileMakeBindist tver workdir ghcdir = do- liftE $ configureBindist tver workdir ghcdir-- case mbuildConfig of- Just bc -> liftIOException- doesNotExistErrorType- (FileDoesNotExistError bc)- (liftIO $ copyFile bc (build_mk workdir))- Nothing ->- liftIO $ T.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf)-- liftE $ checkBuildConfig (build_mk workdir)-- lift $ logInfo "Building (this may take a while)..."- lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)-- if | isCross tver -> do- lift $ logInfo "Installing cross toolchain..."- lEM $ make ["install"] (Just workdir)- pure Nothing- | otherwise -> do- lift $ logInfo "Creating bindist..."- lEM $ make ["binary-dist"] (Just workdir)- [tar] <- liftIO $ findFiles- workdir- (makeRegexOpts compExtended- execBlank- ([s|^ghc-.*\.tar\..*$|] :: ByteString)- )- liftE $ fmap Just $ copyBindist tver tar workdir-- build_mk workdir = workdir </> "mk" </> "build.mk"-- copyBindist :: ( MonadReader env m- , HasDirs env- , HasSettings env- , HasPlatformReq env- , MonadIO m- , MonadThrow m- , MonadCatch m- , HasLog env- )- => GHCTargetVersion- -> FilePath -- ^ tar file- -> FilePath -- ^ workdir- -> Excepts- '[CopyError]- m- FilePath- copyBindist tver tar workdir = do- Dirs {..} <- lift getDirs- pfreq <- lift getPlatformReq- c <- liftIO $ BL.readFile (workdir </> tar)- cDigest <-- fmap (T.take 8)- . lift- . throwEither- . E.decodeUtf8'- . B16.encode- . SHA256.hashlazy- $ c- cTime <- liftIO getCurrentTime- let tarName = makeValid ("ghc-"- <> T.unpack (tVerToText tver)- <> "-"- <> pfReqToString pfreq- <> "-"- <> iso8601Show cTime- <> "-"- <> T.unpack cDigest- <> ".tar"- <> takeExtension tar)- let tarPath = cacheDir </> tarName- copyFileE (workdir </> tar)- tarPath- lift $ logInfo $ "Copied bindist to " <> T.pack tarPath- pure tarPath-- checkBuildConfig :: (MonadReader env m, MonadCatch m, MonadIO m, HasLog env)- => FilePath- -> Excepts- '[FileDoesNotExistError, InvalidBuildConfig]- m- ()- checkBuildConfig bc = do- c <- liftIOException- doesNotExistErrorType- (FileDoesNotExistError bc)- (liftIO $ B.readFile bc)- let lines' = fmap T.strip . T.lines $ decUTF8Safe c-- -- for cross, we need Stage1Only- case targetGhc of- Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE- (InvalidBuildConfig- [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|]- )- _ -> pure ()-- forM_ buildFlavour $ \bf ->- when (T.pack ("BuildFlavour = " <> bf) `notElem` lines') $ do- lift $ logWarn $ "Customly specified build config overwrites --flavour=" <> T.pack bf <> " switch! Waiting 5 seconds..."- liftIO $ threadDelay 5000000-- addBuildFlavourToConf bc = case buildFlavour of- Just bf -> "BuildFlavour = " <> T.pack bf <> "\n" <> bc- Nothing -> bc-- isCross :: GHCTargetVersion -> Bool- isCross = isJust . _tvTarget--- configureBindist :: ( MonadReader env m- , HasDirs env- , HasSettings env- , HasPlatformReq env- , MonadThrow m- , MonadCatch m- , HasLog env- , MonadIO m- , MonadFail m- )- => GHCTargetVersion- -> FilePath- -> InstallDirResolved- -> Excepts- '[ FileDoesNotExistError- , InvalidBuildConfig- , PatchFailed- , ProcessError- , NotFoundInPATH- , CopyError- ]- m- ()- configureBindist tver workdir (fromInstallDir -> ghcdir) = do- lift $ logInfo [s|configuring build|]-- if | _tvVersion tver >= [vver|8.8.0|] -> do- lEM $ execWithGhcEnv- "sh"- ("./configure" : maybe mempty- (\x -> ["--target=" <> T.unpack x])- (_tvTarget tver)- ++ ["--prefix=" <> ghcdir]- ++ (if isWindows then ["--enable-tarballs-autodownload"] else [])- ++ fmap T.unpack aargs- )- (Just workdir)- "ghc-conf"- | otherwise -> do- lEM $ execLogged- "sh"- ( [ "./configure", "--with-ghc=" <> either id id bghc- ]- ++ maybe mempty- (\x -> ["--target=" <> T.unpack x])- (_tvTarget tver)- ++ ["--prefix=" <> ghcdir]- ++ (if isWindows then ["--enable-tarballs-autodownload"] else [])- ++ fmap T.unpack aargs- )- (Just workdir)- "ghc-conf"- Nothing- pure ()-- execWithGhcEnv :: ( MonadReader env m- , HasSettings env- , HasDirs env- , HasLog env- , MonadIO m- , MonadThrow m)- => FilePath -- ^ thing to execute- -> [String] -- ^ args for the thing- -> Maybe FilePath -- ^ optionally chdir into this- -> FilePath -- ^ log filename (opened in append mode)- -> m (Either ProcessError ())- execWithGhcEnv fp args dir logf = do- env <- ghcEnv- execLogged fp args dir logf (Just env)-- bghc = case bstrap of- Right g -> Right g- Left bver -> Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt)-- ghcEnv :: (MonadThrow m, MonadIO m) => m [(String, String)]- ghcEnv = do- cEnv <- liftIO getEnvironment- bghcPath <- case bghc of- Right ghc' -> pure ghc'- Left bver -> do- spaths <- liftIO getSearchPath- throwMaybeM (NotFoundInPATH bver) $ liftIO (searchPath spaths bver)- pure (("GHC", bghcPath) : cEnv)------- ---------------------- --[ Upgrade GHCup ]--- -------------------------- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,--- if no path is provided.-upgradeGHCup :: ( MonadMask m- , MonadReader env m- , HasDirs env- , HasPlatformReq env- , HasGHCupInfo env- , HasSettings env- , MonadCatch m- , HasLog env- , MonadThrow m- , MonadFail m- , MonadResource m- , MonadIO m- , MonadUnliftIO m- )- => Maybe FilePath -- ^ full file destination to write ghcup into- -> Bool -- ^ whether to force update regardless- -- of currently installed version- -> Bool -- ^ whether to throw an error if ghcup is shadowed- -> Excepts- '[ CopyError- , DigestError- , GPGError- , GPGError- , DownloadFailed- , NoDownload- , NoUpdate- , GHCupShadowed- ]- m- Version-upgradeGHCup mtarget force' fatal = do- Dirs {..} <- lift getDirs- GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo-- lift $ logInfo "Upgrading GHCup..."- let latestVer = fst (fromJust (getLatest dls GHCup))- (Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer ""- when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate- dli <- liftE $ getDownloadInfo GHCup latestVer- tmp <- lift withGHCupTmpDir- let fn = "ghcup" <> exeExt- p <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp (Just fn) False- let destDir = takeDirectory destFile- destFile = fromMaybe (binDir </> fn) mtarget- lift $ logDebug $ "mkdir -p " <> T.pack destDir- liftIO $ createDirRecursive' destDir- lift $ logDebug $ "rm -f " <> T.pack destFile- lift $ hideError NoSuchThing $ recycleFile destFile- lift $ logDebug $ "cp " <> T.pack p <> " " <> T.pack destFile- copyFileE p- destFile- lift $ chmod_755 destFile-- liftIO (isInPath destFile) >>= \b -> unless b $- lift $ logWarn $ T.pack (takeFileName destFile) <> " is not in PATH! You have to add it in order to use ghcup."- liftIO (isShadowed destFile) >>= \case- Nothing -> pure ()- Just pa- | fatal -> throwE (GHCupShadowed pa destFile latestVer)- | otherwise ->- lift $ logWarn $ "ghcup is shadowed by "- <> T.pack pa- <> ". The upgrade will not be in effect, unless you remove "- <> T.pack pa- <> " or make sure "- <> T.pack destDir- <> " comes before "- <> T.pack (takeDirectory pa)- <> " in PATH."-- pure latestVer---- -------------- --[ Other ]--- ------------------- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for--- both installing from source and bindist.-postGHCInstall :: ( MonadReader env m- , HasDirs env- , HasLog env- , MonadThrow m- , MonadFail m- , MonadIO m- , MonadCatch m- , MonadMask m- , MonadUnliftIO m- )- => GHCTargetVersion- -> Excepts '[NotInstalled] m ()-postGHCInstall ver@GHCTargetVersion {..} = do- void $ liftE $ setGHC ver SetGHC_XYZ Nothing-- -- Create ghc-x.y symlinks. This may not be the current- -- version, create it regardless.- v' <-- handle (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)- $ fmap Just- $ getMajorMinorV _tvVersion- forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) _tvTarget)- >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing)----- | Reports the binary location of a given tool:------ * for GHC, this reports: @~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@--- * for cabal, this reports @~\/.ghcup\/bin\/cabal-\<ver\>@--- * for hls, this reports @~\/.ghcup\/bin\/haskell-language-server-wrapper-\<ver\>@--- * for stack, this reports @~\/.ghcup\/bin\/stack-\<ver\>@--- * for ghcup, this reports the location of the currently running executable-whereIsTool :: ( MonadReader env m- , HasDirs env- , HasLog env- , MonadThrow m- , MonadFail m- , MonadIO m- , MonadCatch m- , MonadMask m- , MonadUnliftIO m- )- => Tool- -> GHCTargetVersion- -> Excepts '[NotInstalled] m FilePath-whereIsTool tool ver@GHCTargetVersion {..} = do- dirs <- lift getDirs-- case tool of- GHC -> do- whenM (lift $ fmap not $ ghcInstalled ver)- $ throwE (NotInstalled GHC ver)- bdir <- lift $ ghcupGHCDir ver- pure (bdir </> "bin" </> ghcBinaryName ver)- Cabal -> do- whenM (lift $ fmap not $ cabalInstalled _tvVersion)- $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing _tvVersion))- pure (binDir dirs </> "cabal-" <> T.unpack (prettyVer _tvVersion) <> exeExt)- HLS -> do- whenM (lift $ fmap not $ hlsInstalled _tvVersion)- $ throwE (NotInstalled HLS (GHCTargetVersion Nothing _tvVersion))- ifM (lift $ isLegacyHLS _tvVersion)- (pure (binDir dirs </> "haskell-language-server-wrapper-" <> T.unpack (prettyVer _tvVersion) <> exeExt))- $ do- bdir <- lift $ ghcupHLSDir _tvVersion- pure (bdir </> "bin" </> "haskell-language-server-wrapper" <> exeExt)-- Stack -> do- whenM (lift $ fmap not $ stackInstalled _tvVersion)- $ throwE (NotInstalled Stack (GHCTargetVersion Nothing _tvVersion))- pure (binDir dirs </> "stack-" <> T.unpack (prettyVer _tvVersion) <> exeExt)- GHCup -> do- currentRunningExecPath <- liftIO getExecutablePath- liftIO $ canonicalizePath currentRunningExecPath---- | Doesn't work for cross GHC.-checkIfToolInstalled :: ( MonadIO m- , MonadReader env m- , HasDirs env- , MonadCatch m) =>- Tool ->- Version ->- m Bool-checkIfToolInstalled tool ver = checkIfToolInstalled' tool (mkTVer ver)--checkIfToolInstalled' :: ( MonadIO m- , MonadReader env m- , HasDirs env- , MonadCatch m) =>- Tool ->- GHCTargetVersion ->- m Bool-checkIfToolInstalled' tool ver =- case tool of- Cabal -> cabalInstalled (_tvVersion ver)- HLS -> hlsInstalled (_tvVersion ver)- Stack -> stackInstalled (_tvVersion ver)- GHC -> ghcInstalled ver- _ -> pure False--throwIfFileAlreadyExists :: ( MonadIO m ) =>- FilePath ->- Excepts '[FileAlreadyExistsError] m ()--throwIfFileAlreadyExists fp = whenM (checkFileAlreadyExists fp)- (throwE $ FileAlreadyExistsError fp)---- --------------------------- --[ Garbage collection ]--- -----------------------------rmOldGHC :: ( MonadReader env m- , HasGHCupInfo env- , HasDirs env- , HasLog env- , MonadIO m- , MonadFail m- , MonadMask m- , MonadUnliftIO m- )- => Excepts '[NotInstalled] m ()-rmOldGHC = do- GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo- let oldGHCs = mkTVer <$> toListOf (ix GHC % getTagged Old % to fst) dls- ghcs <- lift $ fmap rights getInstalledGHCs- forM_ ghcs $ \ghc -> when (ghc `elem` oldGHCs) $ rmGHCVer ghc----rmProfilingLibs :: ( MonadReader env m- , HasDirs env- , HasLog env- , MonadIO m- , MonadFail m- , MonadMask m- , MonadUnliftIO m- )- => m ()-rmProfilingLibs = do- ghcs <- fmap rights getInstalledGHCs-- let regexes :: [ByteString]- regexes = [[s|.*_p\.a$|], [s|.*\.p_hi$|]]-- forM_ regexes $ \regex ->- forM_ ghcs $ \ghc -> do- d <- ghcupGHCDir ghc- matches <- liftIO $ handleIO (\_ -> pure []) $ findFilesDeep- d- (makeRegexOpts compExtended- execBlank- regex- )- forM_ matches $ \m -> do- let p = d </> m- logDebug $ "rm " <> T.pack p- rmFile p----rmShareDir :: ( MonadReader env m- , HasDirs env- , HasLog env- , MonadIO m- , MonadFail m- , MonadMask m- , MonadUnliftIO m- )- => m ()-rmShareDir = do- ghcs <- fmap rights getInstalledGHCs- forM_ ghcs $ \ghc -> do- d <- ghcupGHCDir ghc- let p = d </> "share"- logDebug $ "rm -rf " <> T.pack p- rmPathForcibly p---rmHLSNoGHC :: ( MonadReader env m- , HasDirs env- , HasLog env- , MonadIO m- , MonadMask m- , MonadFail m- , MonadUnliftIO m- )- => Excepts '[NotInstalled] m ()-rmHLSNoGHC = do- Dirs {..} <- getDirs- ghcs <- fmap rights getInstalledGHCs- hlses <- fmap rights getInstalledHLSs- forM_ hlses $ \hls -> do- hlsGHCs <- fmap mkTVer <$> hlsGHCVersions' hls- let candidates = filter (`notElem` ghcs) hlsGHCs- if (length hlsGHCs - length candidates) <= 0- then rmHLSVer hls- else- forM_ candidates $ \ghc -> do- bins1 <- fmap (binDir </>) <$> hlsServerBinaries hls (Just $ _tvVersion ghc)- bins2 <- ifM (isLegacyHLS hls) (pure []) $ do- shs <- hlsInternalServerScripts hls (Just $ _tvVersion ghc)- bins <- hlsInternalServerBinaries hls (Just $ _tvVersion ghc)- libs <- hlsInternalServerLibs hls (_tvVersion ghc)- pure (shs ++ bins ++ libs)- forM_ (bins1 ++ bins2) $ \f -> do- logDebug $ "rm " <> T.pack f- rmFile f- pure ()---rmCache :: ( MonadReader env m- , HasDirs env- , HasLog env- , MonadIO m- , MonadMask m- )- => m ()-rmCache = do- Dirs {..} <- getDirs- contents <- liftIO $ listDirectory cacheDir- forM_ contents $ \f -> do- let p = cacheDir </> f- logDebug $ "rm " <> T.pack p- rmFile p---rmTmp :: ( MonadReader env m- , HasDirs env- , HasLog env- , MonadIO m- , MonadMask m- )- => m ()-rmTmp = do- tmpdir <- liftIO getCanonicalTemporaryDirectory- ghcup_dirs <- liftIO $ handleIO (\_ -> pure []) $ findFiles- tmpdir- (makeRegexOpts compExtended- execBlank- ([s|^ghcup-.*$|] :: ByteString)- )- forM_ ghcup_dirs $ \f -> do- let p = tmpdir </> f- logDebug $ "rm -rf " <> T.pack p- rmPathForcibly p---applyAnyPatch :: ( MonadReader env m- , HasDirs env- , HasLog env- , HasSettings env- , MonadUnliftIO m- , MonadCatch m- , MonadResource m- , MonadThrow m- , MonadMask m- , MonadIO m)- => Maybe (Either FilePath [URI])- -> FilePath- -> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()-applyAnyPatch Nothing _ = pure ()-applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir-applyAnyPatch (Just (Right uris)) workdir = do- tmpUnpack <- lift withGHCupTmpDir- forM_ uris $ \uri -> do- patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False- liftE $ applyPatch patch workdir++{-|+Module : GHCup+Description : GHCup installation functions+Copyright : (c) Julian Ospald, 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : portable++This module contains the main functions that correspond+to the command line interface, like installation, listing versions+and so on.++These are the entry points.+-}+module GHCup (+ module GHCup,+ module GHCup.Cabal,+ module GHCup.GHC,+ module GHCup.HLS,+ module GHCup.Stack,+ module GHCup.List+) where+++import GHCup.Cabal+import GHCup.GHC hiding ( GHCVer(..) )+import GHCup.HLS hiding ( HLSVer(..) )+import GHCup.Stack+import GHCup.List+import GHCup.Download+import GHCup.Errors+import GHCup.Platform+import GHCup.Types+import GHCup.Types.JSON ( )+import GHCup.Types.Optics+import GHCup.Utils+import GHCup.Prelude+import GHCup.Prelude.File+import GHCup.Prelude.Logger+import GHCup.Prelude.String.QQ+import GHCup.Version++import Control.Applicative+import Control.Exception.Safe+import Control.Monad+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail ( MonadFail )+#endif+import Control.Monad.Reader+import Control.Monad.Trans.Resource+ hiding ( throwM )+import Data.ByteString ( ByteString )+import Data.Either+import Data.List+import Data.Maybe+import Data.Versions hiding ( patch )+import GHC.IO.Exception+import Haskus.Utils.Variant.Excepts+import Optics+import Prelude hiding ( abs+ , writeFile+ )+import System.Environment+import System.FilePath+import System.IO.Error+import Text.Regex.Posix++import qualified Data.Text as T+import qualified Streamly.Prelude as S+import Text.PrettyPrint.HughesPJClass (prettyShow)+++++ ---------------------+ --[ Tool fetching ]--+ ---------------------+++fetchToolBindist :: ( MonadFail m+ , MonadMask m+ , MonadCatch m+ , MonadReader env m+ , HasDirs env+ , HasSettings env+ , HasPlatformReq env+ , HasGHCupInfo env+ , HasLog env+ , MonadResource m+ , MonadIO m+ , MonadUnliftIO m+ )+ => Version+ -> Tool+ -> Maybe FilePath+ -> Excepts+ '[ DigestError+ , GPGError+ , DownloadFailed+ , NoDownload+ ]+ m+ FilePath+fetchToolBindist v t mfp = do+ dlinfo <- liftE $ getDownloadInfo t v+ liftE $ downloadCached' dlinfo Nothing mfp++++ ------------+ --[ Nuke ]--+ ------------+++++rmTool :: ( MonadReader env m+ , HasDirs env+ , HasLog env+ , MonadFail m+ , MonadMask m+ , MonadUnliftIO m)+ => ListResult+ -> Excepts '[NotInstalled, UninstallFailed] m ()+rmTool ListResult {lVer, lTool, lCross} = do+ case lTool of+ GHC ->+ let ghcTargetVersion = GHCTargetVersion lCross lVer+ in rmGHCVer ghcTargetVersion+ HLS -> rmHLSVer lVer+ Cabal -> liftE $ rmCabalVer lVer+ Stack -> liftE $ rmStackVer lVer+ GHCup -> lift rmGhcup+++rmGhcupDirs :: ( MonadReader env m+ , HasDirs env+ , MonadIO m+ , HasLog env+ , MonadCatch m+ , MonadMask m )+ => m [FilePath]+rmGhcupDirs = do+ Dirs+ { baseDir+ , binDir+ , logsDir+ , cacheDir+ , recycleDir+ , dbDir+ , tmpDir+ } <- getDirs++ let envFilePath = fromGHCupPath baseDir </> "env"++ confFilePath <- getConfigFilePath++ handleRm $ rmEnvFile envFilePath+ handleRm $ rmConfFile confFilePath++ -- for xdg dirs, the order matters here+ handleRm $ rmPathForcibly logsDir+ handleRm $ rmPathForcibly tmpDir+ handleRm $ rmPathForcibly cacheDir++ handleRm $ rmBinDir binDir+ handleRm $ rmPathForcibly recycleDir+ handleRm $ rmPathForcibly dbDir+ when isWindows $ do+ logInfo $ "removing " <> T.pack (fromGHCupPath baseDir </> "msys64")+ handleRm $ rmPathForcibly (baseDir `appendGHCupPath` "msys64")++ handleRm $ removeEmptyDirsRecursive (fromGHCupPath baseDir)++ -- report files in baseDir that are left-over after+ -- the standard location deletions above+ hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles (fromGHCupPath baseDir)++ where+ handleRm :: (MonadReader env m, MonadCatch m, HasLog env, MonadIO m) => m () -> m ()+ handleRm = handleIO (\e -> logDebug $ "Part of the cleanup action failed with error: " <> T.pack (displayException e) <> "\n"+ <> "continuing regardless...")++ rmEnvFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()+ rmEnvFile enFilePath = do+ logInfo "Removing Ghcup Environment File"+ hideErrorDef [permissionErrorType] () $ rmFileForce enFilePath++ rmConfFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()+ rmConfFile confFilePath = do+ logInfo "removing Ghcup Config File"+ hideErrorDef [permissionErrorType] () $ rmFileForce confFilePath++ rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()+ rmBinDir binDir+ | isWindows = removeDirIfEmptyOrIsSymlink binDir+ | otherwise = do+ isXDGStyle <- liftIO useXDG+ when (not isXDGStyle) $+ removeDirIfEmptyOrIsSymlink binDir++ reportRemainingFiles :: (MonadMask m, MonadIO m) => FilePath -> m [FilePath]+ reportRemainingFiles dir = do+ remainingFiles <- liftIO $ S.toList (getDirectoryContentsRecursiveUnsafe dir)+ let normalizedFilePaths = fmap normalise remainingFiles+ let sortedByDepthRemainingFiles = sortBy (flip compareFn) normalizedFilePaths+ let remainingFilesAbsolute = fmap (dir </>) sortedByDepthRemainingFiles++ pure remainingFilesAbsolute++ where+ calcDepth :: FilePath -> Int+ calcDepth = length . filter isPathSeparator++ compareFn :: FilePath -> FilePath -> Ordering+ compareFn fp1 fp2 = compare (calcDepth fp1) (calcDepth fp2)+++++ ------------------+ --[ Debug info ]--+ ------------------+++getDebugInfo :: ( Alternative m+ , MonadFail m+ , MonadReader env m+ , HasDirs env+ , HasLog env+ , MonadCatch m+ , MonadIO m+ )+ => Excepts+ '[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]+ m+ DebugInfo+getDebugInfo = do+ Dirs {..} <- lift getDirs+ let diBaseDir = fromGHCupPath baseDir+ let diBinDir = binDir+ diGHCDir <- fromGHCupPath <$> lift ghcupGHCBaseDir+ let diCacheDir = fromGHCupPath cacheDir+ diArch <- lE getArchitecture+ diPlatform <- liftE getPlatform+ pure $ DebugInfo { .. }+++++ -------------------------+ --[ GHCup upgrade etc ]--+ -------------------------+++-- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@,+-- if no path is provided.+upgradeGHCup :: ( MonadMask m+ , MonadReader env m+ , HasDirs env+ , HasPlatformReq env+ , HasGHCupInfo env+ , HasSettings env+ , MonadCatch m+ , HasLog env+ , MonadThrow m+ , MonadFail m+ , MonadResource m+ , MonadIO m+ , MonadUnliftIO m+ )+ => Maybe FilePath -- ^ full file destination to write ghcup into+ -> Bool -- ^ whether to force update regardless+ -- of currently installed version+ -> Bool -- ^ whether to throw an error if ghcup is shadowed+ -> Excepts+ '[ CopyError+ , DigestError+ , GPGError+ , GPGError+ , DownloadFailed+ , NoDownload+ , NoUpdate+ , ToolShadowed+ ]+ m+ Version+upgradeGHCup mtarget force' fatal = do+ Dirs {..} <- lift getDirs+ GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo++ lift $ logInfo "Upgrading GHCup..."+ let latestVer = fst (fromJust (getLatest dls GHCup))+ (Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer ""+ when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate+ dli <- liftE $ getDownloadInfo GHCup latestVer+ tmp <- fromGHCupPath <$> lift withGHCupTmpDir+ let fn = "ghcup" <> exeExt+ p <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp (Just fn) False+ let destDir = takeDirectory destFile+ destFile = fromMaybe (binDir </> fn) mtarget+ lift $ logDebug $ "mkdir -p " <> T.pack destDir+ liftIO $ createDirRecursive' destDir+ lift $ logDebug $ "rm -f " <> T.pack destFile+ lift $ hideError NoSuchThing $ recycleFile destFile+ lift $ logDebug $ "cp " <> T.pack p <> " " <> T.pack destFile+ copyFileE p destFile False+ lift $ chmod_755 destFile++ liftIO (isInPath destFile) >>= \b -> unless b $+ lift $ logWarn $ T.pack (takeFileName destFile) <> " is not in PATH! You have to add it in order to use ghcup."+ liftIO (isShadowed destFile) >>= \case+ Nothing -> pure ()+ Just pa+ | fatal -> throwE (ToolShadowed GHCup pa destFile latestVer)+ | otherwise ->+ lift $ logWarn $ T.pack $ prettyShow (ToolShadowed GHCup pa destFile latestVer)++ pure latestVer+++-- assuming the current scheme of having just 1 ghcup bin, no version info is required.+rmGhcup :: ( MonadReader env m+ , HasDirs env+ , MonadIO m+ , MonadCatch m+ , HasLog env+ , MonadMask m+ , MonadUnliftIO m+ )+ => m ()+rmGhcup = do+ Dirs { .. } <- getDirs+ let ghcupFilename = "ghcup" <> exeExt+ let ghcupFilepath = binDir </> ghcupFilename++ currentRunningExecPath <- liftIO getExecutablePath++ -- if paths do no exist, warn user, and continue to compare them, as is,+ -- which should eventually fail and result in a non-standard install warning++ p1 <- handleIO' doesNotExistErrorType+ (handlePathNotPresent currentRunningExecPath)+ (liftIO $ canonicalizePath currentRunningExecPath)++ p2 <- handleIO' doesNotExistErrorType+ (handlePathNotPresent ghcupFilepath)+ (liftIO $ canonicalizePath ghcupFilepath)++ let areEqualPaths = equalFilePath p1 p2++ unless areEqualPaths $ logWarn $ nonStandardInstallLocationMsg currentRunningExecPath++ if isWindows+ then do+ -- since it doesn't seem possible to delete a running exe on windows+ -- we move it to temp dir, to be deleted at next reboot+ tempFilepath <- mkGhcupTmpDir+ hideError UnsupportedOperation $+ liftIO $ hideError NoSuchThing $+ moveFile ghcupFilepath (fromGHCupPath tempFilepath </> "ghcup")+ else+ -- delete it.+ hideError doesNotExistErrorType $ rmFile ghcupFilepath++ where+ handlePathNotPresent fp _err = do+ logDebug $ "Error: The path does not exist, " <> T.pack fp+ pure fp++ nonStandardInstallLocationMsg path = T.pack $+ "current ghcup is invoked from a non-standard location: \n"+ <> path <>+ "\n you may have to uninstall it manually."++++ ---------------+ --[ Whereis ]--+ ---------------++++-- | Reports the binary location of a given tool:+--+-- * for GHC, this reports: @~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@+-- * for cabal, this reports @~\/.ghcup\/bin\/cabal-\<ver\>@+-- * for hls, this reports @~\/.ghcup\/bin\/haskell-language-server-wrapper-\<ver\>@+-- * for stack, this reports @~\/.ghcup\/bin\/stack-\<ver\>@+-- * for ghcup, this reports the location of the currently running executable+whereIsTool :: ( MonadReader env m+ , HasDirs env+ , HasLog env+ , MonadThrow m+ , MonadFail m+ , MonadIO m+ , MonadCatch m+ , MonadMask m+ , MonadUnliftIO m+ )+ => Tool+ -> GHCTargetVersion+ -> Excepts '[NotInstalled] m FilePath+whereIsTool tool ver@GHCTargetVersion {..} = do+ dirs <- lift getDirs++ case tool of+ GHC -> do+ whenM (lift $ fmap not $ ghcInstalled ver)+ $ throwE (NotInstalled GHC ver)+ bdir <- fromGHCupPath <$> lift (ghcupGHCDir ver)+ pure (bdir </> "bin" </> ghcBinaryName ver)+ Cabal -> do+ whenM (lift $ fmap not $ cabalInstalled _tvVersion)+ $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing _tvVersion))+ pure (binDir dirs </> "cabal-" <> T.unpack (prettyVer _tvVersion) <> exeExt)+ HLS -> do+ whenM (lift $ fmap not $ hlsInstalled _tvVersion)+ $ throwE (NotInstalled HLS (GHCTargetVersion Nothing _tvVersion))+ ifM (lift $ isLegacyHLS _tvVersion)+ (pure (binDir dirs </> "haskell-language-server-wrapper-" <> T.unpack (prettyVer _tvVersion) <> exeExt))+ $ do+ bdir <- fromGHCupPath <$> lift (ghcupHLSDir _tvVersion)+ pure (bdir </> "bin" </> "haskell-language-server-wrapper" <> exeExt)++ Stack -> do+ whenM (lift $ fmap not $ stackInstalled _tvVersion)+ $ throwE (NotInstalled Stack (GHCTargetVersion Nothing _tvVersion))+ pure (binDir dirs </> "stack-" <> T.unpack (prettyVer _tvVersion) <> exeExt)+ GHCup -> do+ currentRunningExecPath <- liftIO getExecutablePath+ liftIO $ canonicalizePath currentRunningExecPath+++-- | Doesn't work for cross GHC.+checkIfToolInstalled :: ( MonadIO m+ , MonadReader env m+ , HasDirs env+ , MonadCatch m) =>+ Tool ->+ Version ->+ m Bool+checkIfToolInstalled tool ver = checkIfToolInstalled' tool (mkTVer ver)+++checkIfToolInstalled' :: ( MonadIO m+ , MonadReader env m+ , HasDirs env+ , MonadCatch m) =>+ Tool ->+ GHCTargetVersion ->+ m Bool+checkIfToolInstalled' tool ver =+ case tool of+ Cabal -> cabalInstalled (_tvVersion ver)+ HLS -> hlsInstalled (_tvVersion ver)+ Stack -> stackInstalled (_tvVersion ver)+ GHC -> ghcInstalled ver+ _ -> pure False+++++ --------------------------+ --[ Garbage collection ]--+ --------------------------+++rmOldGHC :: ( MonadReader env m+ , HasGHCupInfo env+ , HasDirs env+ , HasLog env+ , MonadIO m+ , MonadFail m+ , MonadMask m+ , MonadUnliftIO m+ )+ => Excepts '[NotInstalled, UninstallFailed] m ()+rmOldGHC = do+ GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo+ let oldGHCs = mkTVer <$> toListOf (ix GHC % getTagged Old % to fst) dls+ ghcs <- lift $ fmap rights getInstalledGHCs+ forM_ ghcs $ \ghc -> when (ghc `elem` oldGHCs) $ rmGHCVer ghc++++rmProfilingLibs :: ( MonadReader env m+ , HasDirs env+ , HasLog env+ , MonadIO m+ , MonadFail m+ , MonadMask m+ , MonadUnliftIO m+ )+ => m ()+rmProfilingLibs = do+ ghcs <- fmap rights getInstalledGHCs++ let regexes :: [ByteString]+ regexes = [[s|.*_p\.a$|], [s|.*\.p_hi$|]]++ forM_ regexes $ \regex ->+ forM_ ghcs $ \ghc -> do+ d <- ghcupGHCDir ghc+ -- TODO: audit findFilesDeep+ matches <- liftIO $ handleIO (\_ -> pure []) $ findFilesDeep+ d+ (makeRegexOpts compExtended+ execBlank+ regex+ )+ forM_ matches $ \m -> do+ let p = fromGHCupPath d </> m+ logDebug $ "rm " <> T.pack p+ rmFile p++++rmShareDir :: ( MonadReader env m+ , HasDirs env+ , HasLog env+ , MonadIO m+ , MonadFail m+ , MonadMask m+ , MonadUnliftIO m+ )+ => m ()+rmShareDir = do+ ghcs <- fmap rights getInstalledGHCs+ forM_ ghcs $ \ghc -> do+ d <- ghcupGHCDir ghc+ let p = d `appendGHCupPath` "share"+ logDebug $ "rm -rf " <> T.pack (fromGHCupPath p)+ rmPathForcibly p+++rmHLSNoGHC :: ( MonadReader env m+ , HasDirs env+ , HasLog env+ , MonadIO m+ , MonadMask m+ , MonadFail m+ , MonadUnliftIO m+ )+ => Excepts '[NotInstalled, UninstallFailed] m ()+rmHLSNoGHC = do+ Dirs {..} <- getDirs+ ghcs <- fmap rights getInstalledGHCs+ hlses <- fmap rights getInstalledHLSs+ forM_ hlses $ \hls -> do+ hlsGHCs <- fmap mkTVer <$> hlsGHCVersions' hls+ let candidates = filter (`notElem` ghcs) hlsGHCs+ if (length hlsGHCs - length candidates) <= 0+ then rmHLSVer hls+ else+ forM_ candidates $ \ghc -> do+ bins1 <- fmap (binDir </>) <$> hlsServerBinaries hls (Just $ _tvVersion ghc)+ bins2 <- ifM (isLegacyHLS hls) (pure []) $ do+ shs <- hlsInternalServerScripts hls (Just $ _tvVersion ghc)+ bins <- hlsInternalServerBinaries hls (Just $ _tvVersion ghc)+ libs <- hlsInternalServerLibs hls (_tvVersion ghc)+ pure (shs ++ bins ++ libs)+ forM_ (bins1 ++ bins2) $ \f -> do+ logDebug $ "rm " <> T.pack f+ rmFile f+ pure ()+++rmCache :: ( MonadReader env m+ , HasDirs env+ , HasLog env+ , MonadIO m+ , MonadMask m+ )+ => m ()+rmCache = do+ Dirs {..} <- getDirs+ contents <- liftIO $ listDirectory (fromGHCupPath cacheDir)+ forM_ contents $ \f -> do+ let p = fromGHCupPath cacheDir </> f+ logDebug $ "rm " <> T.pack p+ rmFile p+++rmTmp :: ( MonadReader env m+ , HasDirs env+ , HasLog env+ , MonadIO m+ , MonadMask m+ )+ => m ()+rmTmp = do+ ghcup_dirs <- liftIO getGHCupTmpDirs+ forM_ ghcup_dirs $ \f -> do+ logDebug $ "rm -rf " <> T.pack (fromGHCupPath f)+ rmPathForcibly f++
+ lib/GHCup/Cabal.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+Module : GHCup.Cabal+Description : GHCup installation functions for Cabal+Copyright : (c) Julian Ospald, 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : portable+-}+module GHCup.Cabal where++import GHCup.Download+import GHCup.Errors+import GHCup.Types+import GHCup.Types.JSON ( )+import GHCup.Types.Optics+import GHCup.Utils+import GHCup.Prelude+import GHCup.Prelude.File+import GHCup.Prelude.Logger++import Codec.Archive ( ArchiveResult )+import Control.Applicative+import Control.Exception.Safe+import Control.Monad+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail ( MonadFail )+#endif+import Control.Monad.Reader+import Control.Monad.Trans.Resource+ hiding ( throwM )+import Data.Either+import Data.List+import Data.Maybe+import Data.Versions hiding ( patch )+import Haskus.Utils.Variant.Excepts+import Optics+import Prelude hiding ( abs+ , writeFile+ )+import Safe hiding ( at )+import System.FilePath+import System.IO.Error++import qualified Data.Text as T+import Text.PrettyPrint.HughesPJClass (prettyShow)++++ -------------------------+ --[ Tool installation ]--+ -------------------------+++-- | Like 'installCabalBin', except takes the 'DownloadInfo' as+-- argument instead of looking it up from 'GHCupDownloads'.+installCabalBindist :: ( MonadMask m+ , MonadCatch m+ , MonadReader env m+ , HasPlatformReq env+ , HasDirs env+ , HasSettings env+ , HasLog env+ , MonadResource m+ , MonadIO m+ , MonadUnliftIO m+ , MonadFail m+ )+ => DownloadInfo+ -> Version+ -> InstallDir+ -> Bool -- ^ Force install+ -> Excepts+ '[ AlreadyInstalled+ , CopyError+ , DigestError+ , GPGError+ , DownloadFailed+ , NoDownload+ , NotInstalled+ , UnknownArchive+ , TarDirDoesNotExist+ , ArchiveResult+ , FileAlreadyExistsError+ ]+ m+ ()+installCabalBindist dlinfo ver installDir forceInstall = do+ lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver++ PlatformRequest {..} <- lift getPlatformReq+ Dirs {..} <- lift getDirs++ -- check if we already have a regular cabal already installed+ regularCabalInstalled <- lift $ cabalInstalled ver++ if+ | not forceInstall+ , regularCabalInstalled+ , GHCupInternal <- installDir -> do+ throwE $ AlreadyInstalled Cabal ver++ | forceInstall+ , regularCabalInstalled+ , GHCupInternal <- installDir -> do+ lift $ logInfo "Removing the currently installed version first!"+ liftE $ rmCabalVer ver++ | otherwise -> pure ()+++ -- download (or use cached version)+ dl <- liftE $ downloadCached dlinfo Nothing++ -- unpack+ tmpUnpack <- lift withGHCupTmpDir+ liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)+ liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)++ -- the subdir of the archive where we do the work+ workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)++ case installDir of+ IsolateDir isoDir -> do -- isolated install+ lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir+ liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall++ GHCupInternal -> do -- regular install+ liftE $ installCabalUnpacked workdir (GHCupBinDir binDir) ver forceInstall+++-- | Install an unpacked cabal distribution.Symbol+installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m)+ => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)+ -> InstallDirResolved -- ^ Path to install to+ -> Version+ -> Bool -- ^ Force Install+ -> Excepts '[CopyError, FileAlreadyExistsError] m ()+installCabalUnpacked path inst ver forceInstall = do+ lift $ logInfo "Installing cabal"+ let cabalFile = "cabal"+ liftIO $ createDirRecursive' (fromInstallDir inst)+ let destFileName = cabalFile+ <> (case inst of+ IsolateDirResolved _ -> ""+ _ -> ("-" <>) . T.unpack . prettyVer $ ver+ )+ <> exeExt+ let destPath = fromInstallDir inst </> destFileName++ copyFileE+ (path </> cabalFile <> exeExt)+ destPath+ (not forceInstall)+ lift $ chmod_755 destPath++-- | Installs cabal into @~\/.ghcup\/bin/cabal-\<ver\>@ and+-- creates a default @cabal -> cabal-x.y.z.q@ symlink for+-- the latest installed version.+installCabalBin :: ( MonadMask m+ , MonadCatch m+ , MonadReader env m+ , HasPlatformReq env+ , HasGHCupInfo env+ , HasDirs env+ , HasSettings env+ , HasLog env+ , MonadResource m+ , MonadIO m+ , MonadUnliftIO m+ , MonadFail m+ )+ => Version+ -> InstallDir+ -> Bool -- force install+ -> Excepts+ '[ AlreadyInstalled+ , CopyError+ , DigestError+ , GPGError+ , DownloadFailed+ , NoDownload+ , NotInstalled+ , UnknownArchive+ , TarDirDoesNotExist+ , ArchiveResult+ , FileAlreadyExistsError+ ]+ m+ ()+installCabalBin ver installDir forceInstall = do+ dlinfo <- liftE $ getDownloadInfo Cabal ver+ installCabalBindist dlinfo ver installDir forceInstall+++ -----------------+ --[ Set cabal ]--+ -----------------+++-- | Set the @~\/.ghcup\/bin\/cabal@ symlink.+setCabal :: ( MonadMask m+ , MonadReader env m+ , HasDirs env+ , HasLog env+ , MonadFail m+ , MonadIO m+ , MonadUnliftIO m)+ => Version+ -> Excepts '[NotInstalled] m ()+setCabal ver = do+ let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt++ -- symlink destination+ Dirs {..} <- lift getDirs++ whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))+ $ throwE+ $ NotInstalled Cabal (GHCTargetVersion Nothing ver)++ let cabalbin = binDir </> "cabal" <> exeExt++ -- create link+ let destL = targetFile+ lift $ createLink destL cabalbin++ liftIO (isShadowed cabalbin) >>= \case+ Nothing -> pure ()+ Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed Cabal pa cabalbin ver)++ pure ()++unsetCabal :: ( MonadMask m+ , MonadReader env m+ , HasDirs env+ , MonadIO m)+ => m ()+unsetCabal = do+ Dirs {..} <- getDirs+ let cabalbin = binDir </> "cabal" <> exeExt+ hideError doesNotExistErrorType $ rmLink cabalbin+++ ----------------+ --[ Rm cabal ]--+ ----------------+++-- | Delete a cabal version. Will try to fix the @cabal@ symlink+-- after removal (e.g. setting it to an older version).+rmCabalVer :: ( MonadMask m+ , MonadReader env m+ , HasDirs env+ , MonadThrow m+ , HasLog env+ , MonadIO m+ , MonadFail m+ , MonadCatch m+ , MonadUnliftIO m+ )+ => Version+ -> Excepts '[NotInstalled] m ()+rmCabalVer ver = do+ whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing ver))++ cSet <- lift cabalSet++ Dirs {..} <- lift getDirs++ let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt+ lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> cabalFile)++ when (Just ver == cSet) $ do+ cVers <- lift $ fmap rights getInstalledCabals+ case headMay . reverse . sort $ cVers of+ Just latestver -> setCabal latestver+ Nothing -> lift $ rmLink (binDir </> "cabal" <> exeExt)
lib/GHCup/Download.hs view
@@ -34,9 +34,10 @@ import GHCup.Types.Optics import GHCup.Types.JSON ( ) import GHCup.Utils.Dirs-import GHCup.Utils.File-import GHCup.Utils.Logger-import GHCup.Utils.Prelude+import GHCup.Prelude+import GHCup.Prelude.File+import GHCup.Prelude.Logger.Internal+import GHCup.Prelude.Process import GHCup.Version import Control.Applicative@@ -69,7 +70,6 @@ , writeFile ) import Safe-import System.Directory import System.Environment import System.Exit import System.FilePath@@ -145,7 +145,7 @@ yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath yamlFromCache uri = do Dirs{..} <- getDirs- pure (cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri))+ pure (fromGHCupPath cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri)) etagsFile :: FilePath -> FilePath@@ -242,7 +242,7 @@ Settings { metaCache } <- lift getSettings -- for local files, let's short-circuit and ignore access time- if | scheme == "file" -> liftE $ download uri' Nothing Nothing cacheDir Nothing True+ if | scheme == "file" -> liftE $ download uri' Nothing Nothing (fromGHCupPath cacheDir) Nothing True | e -> do accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime@@ -581,7 +581,7 @@ True -> downloadCached' dli mfn Nothing False -> do tmp <- lift withGHCupTmpDir- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp mfn False+ liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) (fromGHCupPath tmp) mfn False downloadCached' :: ( MonadReader env m@@ -599,7 +599,7 @@ -> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath downloadCached' dli mfn mDestDir = do Dirs { cacheDir } <- lift getDirs- let destDir = fromMaybe cacheDir mDestDir+ let destDir = fromMaybe (fromGHCupPath cacheDir) mDestDir let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn let cachfile = destDir </> fn fileExists <- liftIO $ doesFileExist cachfile
lib/GHCup/Download/IOStreams.hs view
@@ -10,7 +10,7 @@ import GHCup.Download.Utils import GHCup.Errors import GHCup.Types.JSON ( )-import GHCup.Utils.Prelude+import GHCup.Prelude import Control.Applicative import Control.Exception.Safe
lib/GHCup/Download/Utils.hs view
@@ -10,7 +10,7 @@ import GHCup.Errors import GHCup.Types.Optics import GHCup.Types.JSON ( )-import GHCup.Utils.Prelude+import GHCup.Prelude import Control.Applicative import Control.Monad
lib/GHCup/Errors.hs view
@@ -105,6 +105,15 @@ pPrint (CopyError reason) = text ("Unable to copy a file. Reason was: " ++ reason) +-- | Unable to merge file trees.+data MergeFileTreeError = MergeFileTreeError IOException FilePath FilePath+ deriving Show++instance Pretty MergeFileTreeError where+ pPrint (MergeFileTreeError e from to) =+ text "Failed to merge file tree from" <+> text from <+> text "to" <+> text to <+> text "\nexception was:" <+> text (displayException e)+ <+> text "\n...you may need to delete" <+> text to <+> text "manually. Make sure it's gone."+ -- | Unable to find a tag of a tool. data TagNotFound = TagNotFound Tag Tool deriving Show@@ -128,10 +137,13 @@ instance Pretty AlreadyInstalled where pPrint (AlreadyInstalled tool ver') =- pPrint tool <+> text "-" <+> pPrint ver' <+> text "is already installed"+ (pPrint tool <> text "-" <> pPrint ver') <+> text "is already installed;"+ <+> text "if you really want to reinstall it, you may want to run 'ghcup install cabal --force" <+> (pPrint ver' <> text "'") + -- | The Directory is supposed to be empty, but wasn't. data DirNotEmpty = DirNotEmpty {path :: FilePath}+ deriving Show instance Pretty DirNotEmpty where pPrint (DirNotEmpty path) = do@@ -146,6 +158,13 @@ pPrint (NotInstalled tool ver) = text "The version" <+> pPrint ver <+> text "of the tool" <+> pPrint tool <+> text "is not installed." +data UninstallFailed = UninstallFailed FilePath [FilePath]+ deriving Show++instance Pretty UninstallFailed where+ pPrint (UninstallFailed dir files) =+ text "The following files survived uninstallation: " <+> pPrint files <+> text "...consider removing" <+> pPrint dir <+> text "manually."+ -- | An executable was expected to be in PATH, but was not found. data NotFoundInPATH = NotFoundInPATH FilePath deriving Show@@ -292,19 +311,21 @@ pPrint HadrianNotFound = text "Could not find Hadrian build files. Does this GHC version support Hadrian builds?" -data GHCupShadowed = GHCupShadowed+data ToolShadowed = ToolShadowed+ Tool FilePath -- shadow binary FilePath -- upgraded binary Version -- upgraded version deriving Show -instance Pretty GHCupShadowed where- pPrint (GHCupShadowed sh up _) =- text ("ghcup is shadowed by "+instance Pretty ToolShadowed where+ pPrint (ToolShadowed tool sh up _) =+ text (prettyShow tool+ <> " is shadowed by " <> sh- <> ". The upgrade will not be in effect, unless you remove "+ <> ".\nThe upgrade will not be in effect, unless you remove " <> sh- <> " or make sure "+ <> "\nor make sure " <> takeDirectory up <> " comes before " <> takeDirectory sh@@ -325,6 +346,17 @@ _ -> text "Download failed:" <+> pPrint reason deriving instance Show DownloadFailed++data InstallSetError = forall xs1 xs2 . (Show (V xs1), Pretty (V xs1), Show (V xs2), Pretty (V xs2)) => InstallSetError (V xs1) (V xs2)++instance Pretty InstallSetError where+ pPrint (InstallSetError reason1 reason2) =+ text "Both installation and setting the tool failed. Install error was:"+ <+> pPrint reason1+ <+> text "\nSet error was:"+ <+> pPrint reason2++deriving instance Show InstallSetError -- | A build failed.
+ lib/GHCup/GHC.hs view
@@ -0,0 +1,1157 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++{-|+Module : GHCup.GHC+Description : GHCup installation functions for GHC+Copyright : (c) Julian Ospald, 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : portable+-}+module GHCup.GHC where+++import GHCup.Download+import GHCup.Errors+import GHCup.Types+import GHCup.Types.JSON ( )+import GHCup.Types.Optics+import GHCup.Utils+import GHCup.Prelude+import GHCup.Prelude.File+import GHCup.Prelude.Logger+import GHCup.Prelude.Process+import GHCup.Prelude.String.QQ+import GHCup.Prelude.Version.QQ+import GHCup.Prelude.MegaParsec++import Codec.Archive ( ArchiveResult )+import Control.Applicative+import Control.Concurrent ( threadDelay )+import Control.Exception.Safe+import Control.Monad+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail ( MonadFail )+#endif+import Control.Monad.Reader+import Control.Monad.Trans.Resource+ hiding ( throwM )+import Data.ByteString ( ByteString )+import Data.Either+import Data.List+import Data.Maybe+import Data.List.NonEmpty ( NonEmpty((:|)) )+import Data.String ( fromString )+import Data.Text ( Text )+import Data.Time.Clock+import Data.Time.Format.ISO8601+import Data.Versions hiding ( patch )+import GHC.IO.Exception+import Haskus.Utils.Variant.Excepts+import Language.Haskell.TH+import Language.Haskell.TH.Syntax ( Quasi(qAddDependentFile) )+import Optics+import Prelude hiding ( abs+ , writeFile+ )+import System.Environment+import System.FilePath+import System.IO.Error+import Text.PrettyPrint.HughesPJClass ( prettyShow )+import Text.Regex.Posix+import URI.ByteString++import qualified Crypto.Hash.SHA256 as SHA256+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Text.Encoding as E+import qualified Text.Megaparsec as MP+++data GHCVer v = SourceDist v+ | GitDist GitBranch+ | RemoteDist URI++++ ---------------------+ --[ Tool fetching ]--+ ---------------------++++fetchGHCSrc :: ( MonadFail m+ , MonadMask m+ , MonadCatch m+ , MonadReader env m+ , HasDirs env+ , HasSettings env+ , HasPlatformReq env+ , HasGHCupInfo env+ , HasLog env+ , MonadResource m+ , MonadIO m+ , MonadUnliftIO m+ )+ => Version+ -> Maybe FilePath+ -> Excepts+ '[ DigestError+ , GPGError+ , DownloadFailed+ , NoDownload+ ]+ m+ FilePath+fetchGHCSrc v mfp = do+ GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo+ dlInfo <-+ preview (ix GHC % ix v % viSourceDL % _Just) dls+ ?? NoDownload+ liftE $ downloadCached' dlInfo Nothing mfp++++ -------------------------+ --[ Tool installation ]--+ -------------------------+++-- | Like 'installGHCBin', except takes the 'DownloadInfo' as+-- argument instead of looking it up from 'GHCupDownloads'.+installGHCBindist :: ( MonadFail m+ , MonadMask m+ , MonadCatch m+ , MonadReader env m+ , HasDirs env+ , HasSettings env+ , HasPlatformReq env+ , HasLog env+ , MonadResource m+ , MonadIO m+ , MonadUnliftIO m+ )+ => DownloadInfo -- ^ where/how to download+ -> Version -- ^ the version to install+ -> InstallDir+ -> Bool -- ^ Force install+ -> [T.Text] -- ^ additional configure args for bindist+ -> Excepts+ '[ AlreadyInstalled+ , BuildFailed+ , DigestError+ , GPGError+ , DownloadFailed+ , NoDownload+ , NotInstalled+ , UnknownArchive+ , TarDirDoesNotExist+ , DirNotEmpty+ , ArchiveResult+ , ProcessError+ , UninstallFailed+ , MergeFileTreeError+ ]+ m+ ()+installGHCBindist dlinfo ver installDir forceInstall addConfArgs = do+ let tver = mkTVer ver++ lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver++ regularGHCInstalled <- lift $ ghcInstalled tver++ if+ | not forceInstall+ , regularGHCInstalled+ , GHCupInternal <- installDir -> do+ throwE $ AlreadyInstalled GHC ver++ | forceInstall+ , regularGHCInstalled+ , GHCupInternal <- installDir -> do+ lift $ logInfo "Removing the currently installed GHC version first!"+ liftE $ rmGHCVer tver++ | otherwise -> pure ()++ -- download (or use cached version)+ dl <- liftE $ downloadCached dlinfo Nothing+++ toolchainSanityChecks++ case installDir of+ IsolateDir isoDir -> do -- isolated install+ lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir+ liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) ver forceInstall addConfArgs+ GHCupInternal -> do -- regular install+ -- prepare paths+ ghcdir <- lift $ ghcupGHCDir tver++ liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) ver forceInstall addConfArgs++ -- make symlinks & stuff when regular install,+ liftE $ postGHCInstall tver++ where+ toolchainSanityChecks = do+ r <- forM ["CC", "LD"] (liftIO . lookupEnv)+ case catMaybes r of+ [] -> pure ()+ _ -> do+ lift $ logWarn $ "CC/LD environment variable is set. This will change the compiler/linker"+ <> "\n" <> "GHC uses internally and can cause defunct GHC in some cases (e.g. in Anaconda"+ <> "\n" <> "environments). If you encounter problems, unset CC and LD and reinstall."+++-- | Install a packed GHC distribution. This only deals with unpacking and the GHC+-- build system and nothing else.+installPackedGHC :: ( MonadMask m+ , MonadCatch m+ , MonadReader env m+ , HasDirs env+ , HasPlatformReq env+ , HasSettings env+ , MonadThrow m+ , HasLog env+ , MonadIO m+ , MonadUnliftIO m+ , MonadFail m+ , MonadResource m+ )+ => FilePath -- ^ Path to the packed GHC bindist+ -> Maybe TarDir -- ^ Subdir of the archive+ -> InstallDirResolved+ -> Version -- ^ The GHC version+ -> Bool -- ^ Force install+ -> [T.Text] -- ^ additional configure args for bindist+ -> Excepts+ '[ BuildFailed+ , UnknownArchive+ , TarDirDoesNotExist+ , DirNotEmpty+ , ArchiveResult+ , ProcessError+ , MergeFileTreeError+ ] m ()+installPackedGHC dl msubdir inst ver forceInstall addConfArgs = do+ PlatformRequest {..} <- lift getPlatformReq++ unless forceInstall+ (liftE $ installDestSanityCheck inst)++ -- unpack+ tmpUnpack <- lift mkGhcupTmpDir+ liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)+ liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)++ -- the subdir of the archive where we do the work+ workdir <- maybe (pure tmpUnpack)+ (liftE . intoSubdir tmpUnpack)+ msubdir++ liftE $ runBuildAction tmpUnpack+ (installUnpackedGHC workdir inst ver forceInstall addConfArgs)+++-- | Install an unpacked GHC distribution. This only deals with the GHC+-- build system and nothing else.+installUnpackedGHC :: ( MonadReader env m+ , HasPlatformReq env+ , HasDirs env+ , HasSettings env+ , MonadThrow m+ , HasLog env+ , MonadIO m+ , MonadUnliftIO m+ , MonadMask m+ , MonadResource m+ , MonadFail m+ )+ => GHCupPath -- ^ Path to the unpacked GHC bindist (where the configure script resides)+ -> InstallDirResolved -- ^ Path to install to+ -> Version -- ^ The GHC version+ -> Bool -- ^ Force install+ -> [T.Text] -- ^ additional configure args for bindist+ -> Excepts '[ProcessError, MergeFileTreeError] m ()+installUnpackedGHC path inst ver forceInstall addConfArgs+ | isWindows = do+ lift $ logInfo "Installing GHC (this may take a while)"+ -- Windows bindists are relocatable and don't need+ -- to run configure.+ -- We also must make sure to preserve mtime to not confuse ghc-pkg.+ liftE $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> do+ mtime <- liftIO $ ifM (pathIsSymbolicLink source) (pure Nothing) (Just <$> getModificationTime source)+ when forceInstall $ hideError doesNotExistErrorType $ hideError InappropriateType $ recycleFile dest+ liftIO $ moveFilePortable source dest+ forM_ mtime $ liftIO . setModificationTime dest+ | otherwise = do+ PlatformRequest {..} <- lift getPlatformReq++ let ldOverride+ | ver >= [vver|8.2.2|]+ , _rPlatform `elem` [Linux Alpine, Darwin]+ = ["--disable-ld-override"]+ | otherwise+ = []++ lift $ logInfo "Installing GHC (this may take a while)"+ lEM $ execLogged "sh"+ ("./configure" : ("--prefix=" <> fromInstallDir inst)+ : (ldOverride <> (T.unpack <$> addConfArgs))+ )+ (Just $ fromGHCupPath path)+ "ghc-configure"+ Nothing+ tmpInstallDest <- lift withGHCupTmpDir+ lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just $ fromGHCupPath path)+ liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest)+ liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst))+ inst+ GHC+ (mkTVer ver)+ (\f t -> liftIO $ do+ mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f)+ install f t (not forceInstall)+ forM_ mtime $ setModificationTime t)++ pure ()+++-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the+-- following symlinks in @~\/.ghcup\/bin@:+--+-- * @ghc-x.y.z -> ..\/ghc\/x.y.z\/bin/ghc@+-- * @ghc-x.y -> ..\/ghc\/x.y.z\/bin/ghc@ (if x.y.z is the latest x.y version)+installGHCBin :: ( MonadFail m+ , MonadMask m+ , MonadCatch m+ , MonadReader env m+ , HasPlatformReq env+ , HasGHCupInfo env+ , HasDirs env+ , HasSettings env+ , HasLog env+ , MonadResource m+ , MonadIO m+ , MonadUnliftIO m+ )+ => Version -- ^ the version to install+ -> InstallDir+ -> Bool -- ^ force install+ -> [T.Text] -- ^ additional configure args for bindist+ -> Excepts+ '[ AlreadyInstalled+ , BuildFailed+ , DigestError+ , GPGError+ , DownloadFailed+ , NoDownload+ , NotInstalled+ , UnknownArchive+ , TarDirDoesNotExist+ , DirNotEmpty+ , ArchiveResult+ , ProcessError+ , UninstallFailed+ , MergeFileTreeError+ ]+ m+ ()+installGHCBin ver installDir forceInstall addConfArgs = do+ dlinfo <- liftE $ getDownloadInfo GHC ver+ liftE $ installGHCBindist dlinfo ver installDir forceInstall addConfArgs++++++ ---------------+ --[ Set GHC ]--+ ---------------++++-- | Set GHC symlinks in @~\/.ghcup\/bin@ for the requested GHC version. The behavior depends+-- on `SetGHC`:+--+-- * SetGHCOnly: @~\/.ghcup\/bin\/ghc -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@+-- * SetGHC_XY: @~\/.ghcup\/bin\/ghc-X.Y -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@+-- * SetGHC_XYZ: @~\/.ghcup\/bin\/ghc-\<ver\> -> ~\/.ghcup\/ghc\/\<ver\>\/bin\/ghc@+--+-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\<ver\>\/share symlink@+-- for 'SetGHCOnly' constructor.+setGHC :: ( MonadReader env m+ , HasDirs env+ , HasLog env+ , MonadThrow m+ , MonadFail m+ , MonadIO m+ , MonadCatch m+ , MonadMask m+ , MonadUnliftIO m+ )+ => GHCTargetVersion+ -> SetGHC+ -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin+ -- and don't want mess with other versions+ -> Excepts '[NotInstalled] m GHCTargetVersion+setGHC ver sghc mBinDir = do+ let verS = T.unpack $ prettyVer (_tvVersion ver)+ ghcdir <- lift $ ghcupGHCDir ver++ whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver))++ -- symlink destination+ binDir <- case mBinDir of+ Just x -> pure x+ Nothing -> do+ Dirs {binDir = f} <- lift getDirs+ pure f++ -- first delete the old symlinks (this fixes compatibility issues+ -- with old ghcup)+ when (isNothing mBinDir) $+ case sghc of+ SetGHCOnly -> liftE $ rmPlainGHC (_tvTarget ver)+ SetGHC_XY -> liftE $ rmMajorGHCSymlinks ver+ SetGHC_XYZ -> liftE $ rmMinorGHCSymlinks ver++ -- for ghc tools (ghc, ghci, haddock, ...)+ verfiles <- ghcToolFiles ver+ forM_ verfiles $ \file -> do+ mTargetFile <- case sghc of+ SetGHCOnly -> pure $ Just file+ SetGHC_XY -> do+ handle+ (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)+ $ do+ (mj, mi) <- getMajorMinorV (_tvVersion ver)+ let major' = intToText mj <> "." <> intToText mi+ pure $ Just (file <> "-" <> T.unpack major')+ SetGHC_XYZ ->+ pure $ Just (file <> "-" <> verS)++ -- create symlink+ forM_ mTargetFile $ \targetFile -> do+ bindir <- ghcInternalBinDir ver+ let fullF = binDir </> targetFile <> exeExt+ fileWithExt = bindir </> file <> exeExt+ destL <- binarySymLinkDestination binDir fileWithExt+ lift $ createLink destL fullF++ when (targetFile == "ghc") $+ liftIO (isShadowed fullF) >>= \case+ Nothing -> pure ()+ Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed GHC pa fullF (_tvVersion ver))++ when (isNothing mBinDir) $ do+ -- create symlink for share dir+ when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir (fromGHCupPath ghcdir) verS++ when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility++ pure ver++ where++ symlinkShareDir :: ( MonadReader env m+ , HasDirs env+ , MonadIO m+ , HasLog env+ , MonadCatch m+ , MonadMask m+ )+ => FilePath+ -> String+ -> m ()+ symlinkShareDir ghcdir ver' = do+ Dirs {..} <- getDirs+ let destdir = fromGHCupPath baseDir+ case sghc of+ SetGHCOnly -> do+ let sharedir = "share"+ let fullsharedir = ghcdir </> sharedir+ logDebug $ "Checking for sharedir existence: " <> T.pack fullsharedir+ whenM (liftIO $ doesDirectoryExist fullsharedir) $ do+ let fullF = destdir </> sharedir+ let targetF = "." </> "ghc" </> ver' </> sharedir+ logDebug $ "rm -f " <> T.pack fullF+ hideError doesNotExistErrorType $ rmDirectoryLink fullF+ logDebug $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF++ if isWindows+ then liftIO+ -- On windows we need to be more permissive+ -- in case symlinks can't be created, be just+ -- give up here. This symlink isn't strictly necessary.+ $ hideError permissionErrorType+ $ hideError illegalOperationErrorType+ $ createDirectoryLink targetF fullF+ else liftIO+ $ createDirectoryLink targetF fullF+ _ -> pure ()++unsetGHC :: ( MonadReader env m+ , HasDirs env+ , HasLog env+ , MonadThrow m+ , MonadFail m+ , MonadIO m+ , MonadMask m+ )+ => Maybe Text+ -> Excepts '[NotInstalled] m ()+unsetGHC = rmPlainGHC++++++ --------------+ --[ GHC rm ]--+ --------------+++-- | Delete a ghc version and all its symlinks.+--+-- This may leave GHCup without a "set" version.+-- Will try to fix the ghc-x.y symlink after removal (e.g. to an+-- older version).+rmGHCVer :: ( MonadReader env m+ , HasDirs env+ , MonadThrow m+ , HasLog env+ , MonadIO m+ , MonadFail m+ , MonadCatch m+ , MonadMask m+ , MonadUnliftIO m+ )+ => GHCTargetVersion+ -> Excepts '[NotInstalled, UninstallFailed] m ()+rmGHCVer ver = do+ isSetGHC <- lift $ fmap (== Just ver) $ ghcSet (_tvTarget ver)++ whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver))++ -- this isn't atomic, order matters+ when isSetGHC $ do+ lift $ logInfo "Removing ghc symlinks"+ liftE $ rmPlainGHC (_tvTarget ver)++ lift $ logInfo "Removing ghc-x.y.z symlinks"+ liftE $ rmMinorGHCSymlinks ver++ lift $ logInfo "Removing/rewiring ghc-x.y symlinks"+ -- first remove+ handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver+ -- then fix them (e.g. with an earlier version)++ dir' <- lift $ ghcupGHCDir ver+ let dir = fromGHCupPath dir'+ lift (getInstalledFiles GHC ver) >>= \case+ Just files -> do+ lift $ logInfo $ "Removing files safely from: " <> T.pack dir+ forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> dir </> dropDrive f))+ removeEmptyDirsRecursive dir+ survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir+ f <- recordedInstallationFile GHC ver+ lift $ recycleFile f+ when (not (null survivors)) $ throwE $ UninstallFailed dir survivors+ Nothing -> do+ isDir <- liftIO $ doesDirectoryExist dir+ isSyml <- liftIO $ handleIO (\_ -> pure False) $ pathIsSymbolicLink dir+ when (isDir && not isSyml) $ do+ lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack dir+ recyclePathForcibly dir'++ v' <-+ handle+ (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)+ $ fmap Just+ $ getMajorMinorV (_tvVersion ver)+ forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) (_tvTarget ver))+ >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing)++ Dirs {..} <- lift getDirs++ lift $ hideError doesNotExistErrorType $ rmDirectoryLink (fromGHCupPath baseDir </> "share")+++++ ---------------+ --[ Compile ]--+ ---------------+++-- | Compile a GHC from source. This behaves wrt symlinks and installation+-- the same as 'installGHCBin'.+compileGHC :: ( MonadMask m+ , MonadReader env m+ , HasDirs env+ , HasPlatformReq env+ , HasGHCupInfo env+ , HasSettings env+ , MonadThrow m+ , MonadResource m+ , HasLog env+ , MonadIO m+ , MonadUnliftIO m+ , MonadFail m+ )+ => GHCVer GHCTargetVersion+ -> Maybe Version -- ^ overwrite version+ -> Either Version FilePath -- ^ version to bootstrap with+ -> Maybe Int -- ^ jobs+ -> Maybe FilePath -- ^ build config+ -> Maybe (Either FilePath [URI]) -- ^ patches+ -> [Text] -- ^ additional args to ./configure+ -> Maybe String -- ^ build flavour+ -> Bool+ -> InstallDir+ -> Excepts+ '[ AlreadyInstalled+ , BuildFailed+ , DigestError+ , GPGError+ , DownloadFailed+ , GHCupSetError+ , NoDownload+ , NotFoundInPATH+ , PatchFailed+ , UnknownArchive+ , TarDirDoesNotExist+ , NotInstalled+ , DirNotEmpty+ , ArchiveResult+ , FileDoesNotExistError+ , HadrianNotFound+ , InvalidBuildConfig+ , ProcessError+ , CopyError+ , BuildFailed+ , UninstallFailed+ , MergeFileTreeError+ ]+ m+ GHCTargetVersion+compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir+ = do+ PlatformRequest { .. } <- lift getPlatformReq+ GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo++ (workdir, tmpUnpack, tver) <- case targetGhc of+ -- unpack from version tarball+ SourceDist tver -> do+ lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap++ -- download source tarball+ dlInfo <-+ preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls+ ?? NoDownload+ dl <- liftE $ downloadCached dlInfo Nothing++ -- unpack+ tmpUnpack <- lift mkGhcupTmpDir+ liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)+ liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform $ fromGHCupPath tmpUnpack++ workdir <- maybe (pure tmpUnpack)+ (liftE . intoSubdir tmpUnpack)+ (view dlSubdir dlInfo)+ liftE $ applyAnyPatch patches (fromGHCupPath workdir)++ pure (workdir, tmpUnpack, tver)++ RemoteDist uri -> do+ lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri)++ -- download source tarball+ tmpDownload <- lift withGHCupTmpDir+ tmpUnpack <- lift mkGhcupTmpDir+ tar <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpDownload) Nothing False+ (bf, tver) <- liftE $ cleanUpOnError @'[UnknownArchive, ArchiveResult, ProcessError] tmpUnpack $ do+ liftE $ unpackToDir (fromGHCupPath tmpUnpack) tar+ let regex = [s|^(.*/)*boot$|] :: B.ByteString+ [bootFile] <- liftIO $ findFilesDeep+ tmpUnpack+ (makeRegexOpts compExtended+ execBlank+ regex+ )+ tver <- liftE $ getGHCVer (appendGHCupPath tmpUnpack (takeDirectory bootFile))+ pure (bootFile, tver)++ let workdir = appendGHCupPath tmpUnpack (takeDirectory bf)++ pure (workdir, tmpUnpack, mkTVer tver)++ -- clone from git+ GitDist GitBranch{..} -> do+ tmpUnpack <- lift mkGhcupTmpDir+ let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing+ tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do+ let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo+ lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"+ lEM $ git [ "init" ]+ lEM $ git [ "remote"+ , "add"+ , "origin"+ , fromString rep ]++ -- figure out if we can do a shallow clone+ remoteBranches <- catchE @ProcessError @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] @'[PatchFailed, NotFoundInPATH, DigestError, DownloadFailed, GPGError] (\(_ :: ProcessError) -> pure [])+ $ fmap processBranches $ gitOut ["ls-remote", "--heads", "origin"] (fromGHCupPath tmpUnpack)+ let shallow_clone+ | isCommitHash ref = True+ | fromString ref `elem` remoteBranches = True+ | otherwise = False+ lift $ logDebug $ "Shallow clone: " <> T.pack (show shallow_clone)++ -- fetch+ let fetch_args+ | shallow_clone = ["fetch", "--depth", "1", "--quiet", "origin", fromString ref]+ | otherwise = ["fetch", "--tags", "--quiet", "origin" ]+ lEM $ git fetch_args++ -- initial checkout+ lEM $ git [ "checkout", fromString ref ]++ -- gather some info+ git_describe <- if shallow_clone+ then pure Nothing+ else fmap Just $ liftE $ gitOut ["describe", "--tags"] (fromGHCupPath tmpUnpack)+ chash <- liftE $ gitOut ["rev-parse", "HEAD" ] (fromGHCupPath tmpUnpack)++ -- clone submodules+ lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]++ -- apply patches+ liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack)++ -- bootstrap+ tver <- liftE $ getGHCVer tmpUnpack+ liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)+ lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n " <>+ "GHC version (from Makefile): " <> prettyVer tver <>+ (if not shallow_clone then "\n " <> "'git describe' output: " <> fromJust git_describe else mempty) <>+ (if isCommitHash ref then mempty else "\n " <> "commit hash: " <> chash)+ liftIO $ threadDelay 5000000 -- give the user a sec to intervene++ pure tver++ pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)+ -- the version that's installed may differ from the+ -- compiled version, so the user can overwrite it+ let installVer = maybe tver (\ov' -> tver { _tvVersion = ov' }) ov++ alreadyInstalled <- lift $ ghcInstalled installVer+ alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer)++ when alreadyInstalled $ do+ case installDir of+ IsolateDir isoDir ->+ lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Isolate installing to " <> T.pack isoDir+ GHCupInternal ->+ lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Will overwrite existing version."+ lift $ logWarn+ "...waiting for 10 seconds before continuing, you can still abort..."+ liftIO $ threadDelay 10000000 -- give the user a sec to intervene++ ghcdir <- case installDir of+ IsolateDir isoDir -> pure $ IsolateDirResolved isoDir+ GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer)++ (mBindist, bmk) <- liftE $ runBuildAction+ tmpUnpack+ (do+ b <- if hadrian+ then compileHadrianBindist tver (fromGHCupPath workdir) ghcdir+ else compileMakeBindist tver (fromGHCupPath workdir) ghcdir+ bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk $ fromGHCupPath workdir)+ pure (b, bmk)+ )++ case installDir of+ GHCupInternal ->+ -- only remove old ghc in regular installs+ when alreadyInstalled $ do+ lift $ logInfo "Deleting existing installation"+ liftE $ rmGHCVer installVer++ _ -> pure ()++ forM_ mBindist $ \bindist -> do+ liftE $ installPackedGHC bindist+ (Just $ RegexDir "ghc-.*")+ ghcdir+ (installVer ^. tvVersion)+ False -- not a force install, since we already overwrite when compiling.+ []++ liftIO $ B.writeFile (fromInstallDir ghcdir </> ghcUpSrcBuiltFile) bmk++ case installDir of+ -- set and make symlinks for regular (non-isolated) installs+ GHCupInternal -> do+ reThrowAll GHCupSetError $ postGHCInstall installVer+ -- restore+ when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly Nothing++ _ -> pure ()++ pure installVer++ where+ getGHCVer :: ( MonadReader env m+ , HasSettings env+ , HasDirs env+ , HasLog env+ , MonadIO m+ , MonadThrow m+ )+ => GHCupPath+ -> Excepts '[ProcessError] m Version+ getGHCVer tmpUnpack = do+ lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"+ lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap"+ CapturedProcess {..} <- lift $ makeOut+ ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack)+ case _exitCode of+ ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . T.pack . stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut+ ExitFailure c -> throwE $ NonZeroExit c "make" ["show!", "--quiet", "VALUE=ProjectVersion" ]++ defaultConf =+ let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross")))+ default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default")))+ in case targetGhc of+ SourceDist (GHCTargetVersion (Just _) _) -> cross_mk+ _ -> default_mk++ compileHadrianBindist :: ( MonadReader env m+ , HasDirs env+ , HasSettings env+ , HasPlatformReq env+ , MonadThrow m+ , MonadCatch m+ , HasLog env+ , MonadIO m+ , MonadFail m+ )+ => GHCTargetVersion+ -> FilePath+ -> InstallDirResolved+ -> Excepts+ '[ FileDoesNotExistError+ , HadrianNotFound+ , InvalidBuildConfig+ , PatchFailed+ , ProcessError+ , NotFoundInPATH+ , CopyError]+ m+ (Maybe FilePath) -- ^ output path of bindist, None for cross+ compileHadrianBindist tver workdir ghcdir = do+ lEM $ execWithGhcEnv "python3" ["./boot"] (Just workdir) "ghc-bootstrap"++ liftE $ configureBindist tver workdir ghcdir++ lift $ logInfo "Building (this may take a while)..."+ hadrian_build <- liftE $ findHadrianFile workdir+ lEM $ execWithGhcEnv hadrian_build+ ( maybe [] (\j -> ["-j" <> show j] ) jobs+ ++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour+ ++ ["binary-dist"]+ )+ (Just workdir) "ghc-make"+ [tar] <- liftIO $ findFiles+ (workdir </> "_build" </> "bindist")+ (makeRegexOpts compExtended+ execBlank+ ([s|^ghc-.*\.tar\..*$|] :: ByteString)+ )+ liftE $ fmap Just $ copyBindist tver tar (workdir </> "_build" </> "bindist")++ findHadrianFile :: (MonadIO m)+ => FilePath+ -> Excepts+ '[HadrianNotFound]+ m+ FilePath+ findHadrianFile workdir = do+ let possible_files = if isWindows+ then ((workdir </> "hadrian") </>) <$> ["build.bat"]+ else ((workdir </> "hadrian") </>) <$> ["build", "build.sh"]+ exsists <- forM possible_files (\f -> liftIO (doesFileExist f) <&> (,f))+ case filter fst exsists of+ [] -> throwE HadrianNotFound+ ((_, x):_) -> pure x++ compileMakeBindist :: ( MonadReader env m+ , HasDirs env+ , HasSettings env+ , HasPlatformReq env+ , MonadThrow m+ , MonadCatch m+ , HasLog env+ , MonadIO m+ , MonadFail m+ )+ => GHCTargetVersion+ -> FilePath+ -> InstallDirResolved+ -> Excepts+ '[ FileDoesNotExistError+ , HadrianNotFound+ , InvalidBuildConfig+ , PatchFailed+ , ProcessError+ , NotFoundInPATH+ , CopyError]+ m+ (Maybe FilePath) -- ^ output path of bindist, None for cross+ compileMakeBindist tver workdir ghcdir = do+ liftE $ configureBindist tver workdir ghcdir++ case mbuildConfig of+ Just bc -> liftIOException+ doesNotExistErrorType+ (FileDoesNotExistError bc)+ (liftIO $ copyFile bc (build_mk workdir) False)+ Nothing ->+ liftIO $ T.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf)++ liftE $ checkBuildConfig (build_mk workdir)++ lift $ logInfo "Building (this may take a while)..."+ lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)++ if | isCross tver -> do+ lift $ logInfo "Installing cross toolchain..."+ lEM $ make ["install"] (Just workdir)+ pure Nothing+ | otherwise -> do+ lift $ logInfo "Creating bindist..."+ lEM $ make ["binary-dist"] (Just workdir)+ [tar] <- liftIO $ findFiles+ workdir+ (makeRegexOpts compExtended+ execBlank+ ([s|^ghc-.*\.tar\..*$|] :: ByteString)+ )+ liftE $ fmap Just $ copyBindist tver tar workdir++ build_mk workdir = workdir </> "mk" </> "build.mk"++ copyBindist :: ( MonadReader env m+ , HasDirs env+ , HasSettings env+ , HasPlatformReq env+ , MonadIO m+ , MonadThrow m+ , MonadCatch m+ , HasLog env+ )+ => GHCTargetVersion+ -> FilePath -- ^ tar file+ -> FilePath -- ^ workdir+ -> Excepts+ '[CopyError]+ m+ FilePath+ copyBindist tver tar workdir = do+ Dirs {..} <- lift getDirs+ pfreq <- lift getPlatformReq+ c <- liftIO $ BL.readFile (workdir </> tar)+ cDigest <-+ fmap (T.take 8)+ . lift+ . throwEither+ . E.decodeUtf8'+ . B16.encode+ . SHA256.hashlazy+ $ c+ cTime <- liftIO getCurrentTime+ let tarName = makeValid ("ghc-"+ <> T.unpack (tVerToText tver)+ <> "-"+ <> pfReqToString pfreq+ <> "-"+ <> iso8601Show cTime+ <> "-"+ <> T.unpack cDigest+ <> ".tar"+ <> takeExtension tar)+ let tarPath = fromGHCupPath cacheDir </> tarName+ copyFileE (workdir </> tar) tarPath False+ lift $ logInfo $ "Copied bindist to " <> T.pack tarPath+ pure tarPath++ checkBuildConfig :: (MonadReader env m, MonadCatch m, MonadIO m, HasLog env)+ => FilePath+ -> Excepts+ '[FileDoesNotExistError, InvalidBuildConfig]+ m+ ()+ checkBuildConfig bc = do+ c <- liftIOException+ doesNotExistErrorType+ (FileDoesNotExistError bc)+ (liftIO $ B.readFile bc)+ let lines' = fmap T.strip . T.lines $ decUTF8Safe c++ -- for cross, we need Stage1Only+ case targetGhc of+ SourceDist (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE+ (InvalidBuildConfig+ [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|]+ )+ _ -> pure ()++ forM_ buildFlavour $ \bf ->+ when (T.pack ("BuildFlavour = " <> bf) `notElem` lines') $ do+ lift $ logWarn $ "Customly specified build config overwrites --flavour=" <> T.pack bf <> " switch! Waiting 5 seconds..."+ liftIO $ threadDelay 5000000++ addBuildFlavourToConf bc = case buildFlavour of+ Just bf -> "BuildFlavour = " <> T.pack bf <> "\n" <> bc+ Nothing -> bc++ isCross :: GHCTargetVersion -> Bool+ isCross = isJust . _tvTarget+++ configureBindist :: ( MonadReader env m+ , HasDirs env+ , HasSettings env+ , HasPlatformReq env+ , MonadThrow m+ , MonadCatch m+ , HasLog env+ , MonadIO m+ , MonadFail m+ )+ => GHCTargetVersion+ -> FilePath+ -> InstallDirResolved+ -> Excepts+ '[ FileDoesNotExistError+ , InvalidBuildConfig+ , PatchFailed+ , ProcessError+ , NotFoundInPATH+ , CopyError+ ]+ m+ ()+ configureBindist tver workdir (fromInstallDir -> ghcdir) = do+ lift $ logInfo [s|configuring build|]++ if | _tvVersion tver >= [vver|8.8.0|] -> do+ lEM $ execWithGhcEnv+ "sh"+ ("./configure" : maybe mempty+ (\x -> ["--target=" <> T.unpack x])+ (_tvTarget tver)+ ++ ["--prefix=" <> ghcdir]+ ++ (if isWindows then ["--enable-tarballs-autodownload"] else [])+ ++ fmap T.unpack aargs+ )+ (Just workdir)+ "ghc-conf"+ | otherwise -> do+ lEM $ execLogged+ "sh"+ ( [ "./configure", "--with-ghc=" <> either id id bghc+ ]+ ++ maybe mempty+ (\x -> ["--target=" <> T.unpack x])+ (_tvTarget tver)+ ++ ["--prefix=" <> ghcdir]+ ++ (if isWindows then ["--enable-tarballs-autodownload"] else [])+ ++ fmap T.unpack aargs+ )+ (Just workdir)+ "ghc-conf"+ Nothing+ pure ()++ execWithGhcEnv :: ( MonadReader env m+ , HasSettings env+ , HasDirs env+ , HasLog env+ , MonadIO m+ , MonadThrow m)+ => FilePath -- ^ thing to execute+ -> [String] -- ^ args for the thing+ -> Maybe FilePath -- ^ optionally chdir into this+ -> FilePath -- ^ log filename (opened in append mode)+ -> m (Either ProcessError ())+ execWithGhcEnv fp args dir logf = do+ env <- ghcEnv+ execLogged fp args dir logf (Just env)++ bghc = case bstrap of+ Right g -> Right g+ Left bver -> Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt)++ ghcEnv :: (MonadThrow m, MonadIO m) => m [(String, String)]+ ghcEnv = do+ cEnv <- liftIO getEnvironment+ bghcPath <- case bghc of+ Right ghc' -> pure ghc'+ Left bver -> do+ spaths <- liftIO getSearchPath+ throwMaybeM (NotFoundInPATH bver) $ liftIO (searchPath spaths bver)+ pure (("GHC", bghcPath) : cEnv)+++++ -------------+ --[ Other ]--+ -------------++++-- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for+-- both installing from source and bindist.+postGHCInstall :: ( MonadReader env m+ , HasDirs env+ , HasLog env+ , MonadThrow m+ , MonadFail m+ , MonadIO m+ , MonadCatch m+ , MonadMask m+ , MonadUnliftIO m+ )+ => GHCTargetVersion+ -> Excepts '[NotInstalled] m ()+postGHCInstall ver@GHCTargetVersion {..} = do+ void $ liftE $ setGHC ver SetGHC_XYZ Nothing++ -- Create ghc-x.y symlinks. This may not be the current+ -- version, create it regardless.+ v' <-+ handle (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)+ $ fmap Just+ $ getMajorMinorV _tvVersion+ forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) _tvTarget)+ >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing)+
+ lib/GHCup/HLS.hs view
@@ -0,0 +1,723 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++{-|+Module : GHCup.HLS+Description : GHCup installation functions for HLS+Copyright : (c) Julian Ospald, 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : portable+-}+module GHCup.HLS where++import GHCup.Download+import GHCup.Errors+import GHCup.Types+import GHCup.Types.JSON ( )+import GHCup.Types.Optics+import GHCup.Utils+import GHCup.Prelude+import GHCup.Prelude.File+import GHCup.Prelude.Logger+import GHCup.Prelude.Process+import GHCup.Prelude.String.QQ++import Codec.Archive ( ArchiveResult )+import Control.Applicative+import Control.Exception.Safe+import Control.Monad+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail ( MonadFail )+#endif+import Control.Monad.Reader+import Control.Monad.Trans.Resource+ hiding ( throwM )+import Data.ByteString ( ByteString )+import Data.Either+import Data.List+import Data.Maybe+import Data.String ( fromString )+import Data.Text ( Text )+import Data.Versions hiding ( patch )+import Distribution.Types.Version hiding ( Version )+import Distribution.Types.PackageId+import Distribution.Types.PackageDescription+import Distribution.Types.GenericPackageDescription+import Distribution.PackageDescription.Parsec+import GHC.IO.Exception+import Haskus.Utils.Variant.Excepts+import Optics+import Prelude hiding ( abs+ , writeFile+ )+import Safe hiding ( at )+import System.FilePath+import System.IO.Error+import Text.Regex.Posix+import URI.ByteString++import qualified Data.List.NonEmpty as NE+import qualified Data.ByteString as B+import qualified Data.Text as T+import qualified Text.Megaparsec as MP+import Text.PrettyPrint.HughesPJClass (prettyShow)+++data HLSVer = SourceDist Version+ | GitDist GitBranch+ | HackageDist Version+ | RemoteDist URI++++ --------------------+ --[ Installation ]--+ --------------------+++-- | Like 'installHLSBin, except takes the 'DownloadInfo' as+-- argument instead of looking it up from 'GHCupDownloads'.+installHLSBindist :: ( MonadMask m+ , MonadCatch m+ , MonadReader env m+ , HasPlatformReq env+ , HasDirs env+ , HasSettings env+ , HasLog env+ , MonadResource m+ , MonadIO m+ , MonadUnliftIO m+ , MonadFail m+ )+ => DownloadInfo+ -> Version+ -> InstallDir -- ^ isolated install path, if user passed any+ -> Bool -- ^ Force install+ -> Excepts+ '[ AlreadyInstalled+ , CopyError+ , DigestError+ , GPGError+ , DownloadFailed+ , NoDownload+ , NotInstalled+ , UnknownArchive+ , TarDirDoesNotExist+ , ArchiveResult+ , FileAlreadyExistsError+ , ProcessError+ , DirNotEmpty+ , UninstallFailed+ , MergeFileTreeError+ ]+ m+ ()+installHLSBindist dlinfo ver installDir forceInstall = do+ lift $ logDebug $ "Requested to install hls version " <> prettyVer ver++ PlatformRequest {..} <- lift getPlatformReq+ Dirs {..} <- lift getDirs++ regularHLSInstalled <- lift $ hlsInstalled ver++ if+ | not forceInstall+ , regularHLSInstalled+ , GHCupInternal <- installDir -> do -- regular install+ throwE $ AlreadyInstalled HLS ver++ | forceInstall+ , regularHLSInstalled+ , GHCupInternal <- installDir -> do -- regular forced install+ lift $ logInfo "Removing the currently installed version of HLS before force installing!"+ liftE $ rmHLSVer ver++ | otherwise -> pure ()++ -- download (or use cached version)+ dl <- liftE $ downloadCached dlinfo Nothing++ -- unpack+ tmpUnpack <- lift withGHCupTmpDir+ liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)+ liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)++ -- the subdir of the archive where we do the work+ workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)+ legacy <- liftIO $ isLegacyHLSBindist workdir++ if+ | not forceInstall+ , not legacy+ , (IsolateDir fp) <- installDir -> liftE $ installDestSanityCheck (IsolateDirResolved fp)+ | otherwise -> pure ()++ case installDir of+ IsolateDir isoDir -> do+ lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir+ if legacy+ then liftE $ installHLSUnpackedLegacy workdir (IsolateDirResolved isoDir) ver forceInstall+ else liftE $ runBuildAction tmpUnpack $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall++ GHCupInternal -> do+ if legacy+ then liftE $ installHLSUnpackedLegacy workdir (GHCupBinDir binDir) ver forceInstall+ else do+ inst <- ghcupHLSDir ver+ liftE $ runBuildAction tmpUnpack+ $ installHLSUnpacked workdir (GHCupDir inst) ver forceInstall+ liftE $ setHLS ver SetHLS_XYZ Nothing+++isLegacyHLSBindist :: FilePath -- ^ Path to the unpacked hls bindist+ -> IO Bool+isLegacyHLSBindist path = do+ not <$> doesFileExist (path </> "GNUmakefile")++-- | Install an unpacked hls distribution.+installHLSUnpacked :: ( MonadMask m+ , MonadUnliftIO m+ , MonadReader env m+ , MonadFail m+ , HasLog env+ , HasDirs env+ , HasSettings env+ , MonadCatch m+ , MonadIO m+ , MonadResource m+ , HasPlatformReq env+ )+ => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)+ -> InstallDirResolved -- ^ Path to install to+ -> Version+ -> Bool+ -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled, MergeFileTreeError] m ()+installHLSUnpacked path inst ver forceInstall = do+ PlatformRequest { .. } <- lift getPlatformReq+ lift $ logInfo "Installing HLS"+ tmpInstallDest <- lift withGHCupTmpDir+ lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path)+ liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest)+ liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst))+ inst+ HLS+ (mkTVer ver)+ (\f t -> liftIO $ do+ mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f)+ install f t (not forceInstall)+ forM_ mtime $ setModificationTime t)++-- | Install an unpacked hls distribution (legacy).+installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)+ => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)+ -> InstallDirResolved -- ^ Path to install to+ -> Version+ -> Bool -- ^ is it a force install+ -> Excepts '[CopyError, FileAlreadyExistsError] m ()+installHLSUnpackedLegacy path installDir ver forceInstall = do+ lift $ logInfo "Installing HLS"+ liftIO $ createDirRecursive' (fromInstallDir installDir)++ -- install haskell-language-server-<ghcver>+ bins@(_:_) <- liftIO $ findFiles+ path+ (makeRegexOpts compExtended+ execBlank+ ([s|^haskell-language-server-[0-9].*$|] :: ByteString)+ )+ forM_ bins $ \f -> do+ let toF = dropSuffix exeExt f+ <> (case installDir of+ IsolateDirResolved _ -> ""+ _ -> ("~" <>) . T.unpack . prettyVer $ ver+ )+ <> exeExt++ let srcPath = path </> f+ let destPath = fromInstallDir installDir </> toF++ -- destination could be an existing symlink+ -- for new make-based HLSes+ liftIO $ rmFileForce destPath++ copyFileE+ srcPath+ destPath+ (not forceInstall)+ lift $ chmod_755 destPath++ -- install haskell-language-server-wrapper+ let wrapper = "haskell-language-server-wrapper"+ toF = wrapper+ <> (case installDir of+ IsolateDirResolved _ -> ""+ _ -> ("-" <>) . T.unpack . prettyVer $ ver+ )+ <> exeExt+ srcWrapperPath = path </> wrapper <> exeExt+ destWrapperPath = fromInstallDir installDir </> toF++ liftIO $ rmFileForce destWrapperPath+ copyFileE+ srcWrapperPath+ destWrapperPath+ (not forceInstall)++ lift $ chmod_755 destWrapperPath++++-- | Installs hls binaries @haskell-language-server-\<ghcver\>@+-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.+installHLSBin :: ( MonadMask m+ , MonadCatch m+ , MonadReader env m+ , HasPlatformReq env+ , HasGHCupInfo env+ , HasDirs env+ , HasSettings env+ , HasLog env+ , MonadResource m+ , MonadIO m+ , MonadUnliftIO m+ , MonadFail m+ )+ => Version+ -> InstallDir+ -> Bool -- force install+ -> Excepts+ '[ AlreadyInstalled+ , CopyError+ , DigestError+ , GPGError+ , DownloadFailed+ , NoDownload+ , NotInstalled+ , UnknownArchive+ , TarDirDoesNotExist+ , ArchiveResult+ , FileAlreadyExistsError+ , ProcessError+ , DirNotEmpty+ , UninstallFailed+ , MergeFileTreeError+ ]+ m+ ()+installHLSBin ver installDir forceInstall = do+ dlinfo <- liftE $ getDownloadInfo HLS ver+ installHLSBindist dlinfo ver installDir forceInstall+++compileHLS :: ( MonadMask m+ , MonadCatch m+ , MonadReader env m+ , HasDirs env+ , HasSettings env+ , HasPlatformReq env+ , HasGHCupInfo env+ , HasLog env+ , MonadResource m+ , MonadIO m+ , MonadUnliftIO m+ , MonadFail m+ )+ => HLSVer+ -> [Version]+ -> Maybe Int+ -> Either Bool Version+ -> InstallDir+ -> Maybe (Either FilePath URI)+ -> Maybe URI+ -> Bool+ -> Maybe (Either FilePath [URI]) -- ^ patches+ -> [Text] -- ^ additional args to cabal install+ -> Excepts '[ NoDownload+ , GPGError+ , DownloadFailed+ , DigestError+ , UnknownArchive+ , TarDirDoesNotExist+ , ArchiveResult+ , BuildFailed+ , NotInstalled+ ] m Version+compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal updateCabal patches cabalArgs = do+ PlatformRequest { .. } <- lift getPlatformReq+ GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo+ Dirs { .. } <- lift getDirs++ when updateCabal $ reThrowAll @_ @'[ProcessError] DownloadFailed $ do+ lift $ logInfo "Updating cabal DB"+ lEM $ exec "cabal" ["update"] (Just $ fromGHCupPath tmpDir) Nothing++ (workdir, tmpUnpack, tver, git_describe) <- case targetHLS of+ -- unpack from version tarball+ SourceDist tver -> do+ lift $ logDebug $ "Requested to compile: " <> prettyVer tver++ -- download source tarball+ dlInfo <-+ preview (ix HLS % ix tver % viSourceDL % _Just) dls+ ?? NoDownload+ dl <- liftE $ downloadCached dlInfo Nothing++ -- unpack+ tmpUnpack <- lift mkGhcupTmpDir+ liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)+ liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)++ workdir <- maybe (pure tmpUnpack)+ (liftE . intoSubdir tmpUnpack)+ (view dlSubdir dlInfo)++ pure (workdir, tmpUnpack, tver, Nothing)++ HackageDist tver -> do+ lift $ logDebug $ "Requested to compile (from hackage): " <> prettyVer tver++ -- download source tarball+ tmpUnpack <- lift mkGhcupTmpDir+ let hls = "haskell-language-server-" <> T.unpack (prettyVer tver)+ reThrowAll @_ @'[ProcessError] DownloadFailed $ do+ -- unpack+ lEM $ exec "cabal" ["unpack", hls] (Just $ fromGHCupPath tmpUnpack) Nothing++ let workdir = appendGHCupPath tmpUnpack hls++ pure (workdir, tmpUnpack, tver, Nothing)++ RemoteDist uri -> do+ lift $ logDebug $ "Requested to compile (from uri): " <> T.pack (show uri)++ -- download source tarball+ tmpDownload <- lift withGHCupTmpDir+ tmpUnpack <- lift mkGhcupTmpDir+ tar <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpDownload) Nothing False+ (cf, tver) <- liftE $ cleanUpOnError tmpUnpack $ do+ unpackToDir (fromGHCupPath tmpUnpack) tar+ let regex = [s|^(.*/)*haskell-language-server\.cabal$|] :: B.ByteString+ [cabalFile] <- liftIO $ findFilesDeep+ tmpUnpack+ (makeRegexOpts compExtended+ execBlank+ regex+ )+ tver <- getCabalVersion (fromGHCupPath tmpUnpack </> cabalFile)+ pure (cabalFile, tver)++ let workdir = appendGHCupPath tmpUnpack (takeDirectory cf)++ pure (workdir, tmpUnpack, tver, Nothing)++ -- clone from git+ GitDist GitBranch{..} -> do+ tmpUnpack <- lift mkGhcupTmpDir+ let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing+ reThrowAll @_ @'[ProcessError] DownloadFailed $ do+ let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo+ lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"+ lEM $ git [ "init" ]+ lEM $ git [ "remote"+ , "add"+ , "origin"+ , fromString rep ]++ -- figure out if we can do a shallow clone+ remoteBranches <- catchE @ProcessError @'[ProcessError] @'[] (\_ -> pure [])+ $ fmap processBranches $ gitOut ["ls-remote", "--heads", "origin"] (fromGHCupPath tmpUnpack)+ let shallow_clone+ | gitDescribeRequested = False+ | isCommitHash ref = True+ | fromString ref `elem` remoteBranches = True+ | otherwise = False++ lift $ logDebug $ "Shallow clone: " <> T.pack (show shallow_clone)++ -- fetch+ let fetch_args+ | shallow_clone = ["fetch", "--depth", "1", "--quiet", "origin", fromString ref]+ | otherwise = ["fetch", "--tags", "--quiet", "origin" ]+ lEM $ git fetch_args++ -- checkout+ lEM $ git [ "checkout", fromString ref ]++ -- gather some info+ git_describe <- if shallow_clone+ then pure Nothing+ else fmap Just $ gitOut ["describe", "--tags"] (fromGHCupPath tmpUnpack)+ chash <- gitOut ["rev-parse", "HEAD" ] (fromGHCupPath tmpUnpack)+ tver <- getCabalVersion (fromGHCupPath tmpUnpack </> "haskell-language-server.cabal")++ liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)+ lift $ logInfo $ "Examining git ref " <> T.pack ref <> "\n " <>+ "HLS version (from cabal file): " <> prettyVer tver <>+ (if not shallow_clone then "\n " <> "'git describe' output: " <> fromJust git_describe else mempty) <>+ (if isCommitHash ref then mempty else "\n " <> "commit hash: " <> chash)++ pure (tmpUnpack, tmpUnpack, tver, git_describe)++ -- the version that's installed may differ from the+ -- compiled version, so the user can overwrite it+ installVer <- case ov of+ Left True -> case git_describe of+ -- git describe+ Just h -> either (fail . displayException) pure . version $ h+ -- git describe, but not building from git, lol+ Nothing -> pure tver+ -- default: use detected version+ Left False -> pure tver+ -- overwrite version with users value+ Right v -> pure v++ liftE $ runBuildAction+ tmpUnpack+ (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do+ let tmpInstallDir = fromGHCupPath workdir </> "out"+ liftIO $ createDirRecursive' tmpInstallDir++ -- apply patches+ liftE $ applyAnyPatch patches (fromGHCupPath workdir)++ -- set up project files+ cp <- case cabalProject of+ Just (Left cp)+ | isAbsolute cp -> do+ copyFileE cp (fromGHCupPath workdir </> "cabal.project") False+ pure "cabal.project"+ | otherwise -> pure (takeFileName cp)+ Just (Right uri) -> do+ tmpUnpack' <- lift withGHCupTmpDir+ cp <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack') (Just "cabal.project") False+ copyFileE cp (fromGHCupPath workdir </> "cabal.project") False+ pure "cabal.project"+ Nothing+ | HackageDist _ <- targetHLS -> do+ liftIO $ B.writeFile (fromGHCupPath workdir </> "cabal.project") "packages: ./"+ pure "cabal.project"+ | RemoteDist _ <- targetHLS -> do+ let cabalFile = fromGHCupPath workdir </> "cabal.project"+ liftIO $ whenM (not <$> doesFileExist cabalFile) $ B.writeFile cabalFile "packages: ./"+ pure "cabal.project"+ | otherwise -> pure "cabal.project"+ forM_ cabalProjectLocal $ \uri -> do+ tmpUnpack' <- lift withGHCupTmpDir+ cpl <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack') (Just (cp <.> "local")) False+ copyFileE cpl (fromGHCupPath workdir </> cp <.> "local") False+ artifacts <- forM (sort ghcs) $ \ghc -> do+ let ghcInstallDir = tmpInstallDir </> T.unpack (prettyVer ghc)+ liftIO $ createDirRecursive' tmpInstallDir+ lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc+ liftE $ lEM @_ @'[ProcessError] $+ execLogged "cabal" ( [ "v2-install"+ , "-w"+ , "ghc-" <> T.unpack (prettyVer ghc)+ , "--install-method=copy"+ ] +++ maybe [] (\j -> ["--jobs=" <> show j]) jobs +++ [ "--overwrite-policy=always"+ , "--disable-profiling"+ , "--disable-tests"+ , "--installdir=" <> ghcInstallDir+ , "--project-file=" <> cp+ ] ++ fmap T.unpack cabalArgs ++ [+ "exe:haskell-language-server"+ , "exe:haskell-language-server-wrapper"]+ )+ (Just $ fromGHCupPath workdir)+ "cabal"+ Nothing+ pure ghcInstallDir++ forM_ artifacts $ \artifact -> do+ logDebug $ T.pack (show artifact)+ liftIO $ renameFile (artifact </> "haskell-language-server" <.> exeExt)+ (tmpInstallDir </> "haskell-language-server-" <> takeFileName artifact <.> exeExt)+ liftIO $ renameFile (artifact </> "haskell-language-server-wrapper" <.> exeExt)+ (tmpInstallDir </> "haskell-language-server-wrapper" <.> exeExt)++ case installDir of+ IsolateDir isoDir -> do+ lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir+ liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True+ GHCupInternal -> do+ liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupBinDir binDir) installVer True+ )++ pure installVer+ where+ gitDescribeRequested = case ov of+ Left b -> b+ _ -> False+++ -----------------+ --[ Set/Unset ]--+ -----------------++-- | Set the haskell-language-server symlinks.+setHLS :: ( MonadReader env m+ , HasDirs env+ , HasLog env+ , MonadIO m+ , MonadMask m+ , MonadFail m+ , MonadUnliftIO m+ )+ => Version+ -> SetHLS+ -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin+ -- and don't want mess with other versions+ -> Excepts '[NotInstalled] m ()+setHLS ver shls mBinDir = do+ whenM (lift $ not <$> hlsInstalled ver) (throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)))++ -- symlink destination+ binDir <- case mBinDir of+ Just x -> pure x+ Nothing -> do+ Dirs {binDir = f} <- lift getDirs+ pure f++ -- first delete the old symlinks+ when (isNothing mBinDir) $+ case shls of+ -- not for legacy+ SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver+ -- legacy and new+ SetHLSOnly -> liftE rmPlainHLS++ case shls of+ -- not for legacy+ SetHLS_XYZ -> do+ bins <- lift $ hlsInternalServerScripts ver Nothing++ forM_ bins $ \f -> do+ let fname = takeFileName f+ destL <- binarySymLinkDestination binDir f+ let target = if "haskell-language-server-wrapper" `isPrefixOf` fname+ then fname <> "-" <> T.unpack (prettyVer ver) <> exeExt+ else fname <> "~" <> T.unpack (prettyVer ver) <> exeExt+ lift $ createLink destL (binDir </> target)++ -- legacy and new+ SetHLSOnly -> do+ -- set haskell-language-server-<ghcver> symlinks+ bins <- lift $ hlsServerBinaries ver Nothing+ when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)++ forM_ bins $ \f -> do+ let destL = f+ let target = (<> exeExt) . head . splitOn "~" $ f+ lift $ createLink destL (binDir </> target)++ -- set haskell-language-server-wrapper symlink+ let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt+ let wrapper = binDir </> "haskell-language-server-wrapper" <> exeExt++ lift $ createLink destL wrapper++ when (isNothing mBinDir) $+ lift warnAboutHlsCompatibility++ liftIO (isShadowed wrapper) >>= \case+ Nothing -> pure ()+ Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed HLS pa wrapper ver)+++unsetHLS :: ( MonadMask m+ , MonadReader env m+ , HasDirs env+ , MonadIO m)+ => m ()+unsetHLS = do+ Dirs {..} <- getDirs+ let wrapper = binDir </> "haskell-language-server-wrapper" <> exeExt+ bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles'+ binDir+ (MP.chunk "haskell-language-server-" <* pvp' <* MP.chunk (T.pack exeExt) <* MP.eof)+ forM_ bins (hideError doesNotExistErrorType . rmLink . (binDir </>))+ hideError doesNotExistErrorType $ rmLink wrapper+++++ ---------------+ --[ Removal ]--+ ---------------+++-- | Delete a hls version. Will try to fix the hls symlinks+-- after removal (e.g. setting it to an older version).+rmHLSVer :: ( MonadMask m+ , MonadReader env m+ , HasDirs env+ , MonadThrow m+ , HasLog env+ , MonadIO m+ , MonadFail m+ , MonadCatch m+ , MonadUnliftIO m+ )+ => Version+ -> Excepts '[NotInstalled, UninstallFailed] m ()+rmHLSVer ver = do+ whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))++ isHlsSet <- lift hlsSet++ liftE $ rmMinorHLSSymlinks ver++ when (Just ver == isHlsSet) $ do+ -- delete all set symlinks+ liftE rmPlainHLS++ hlsDir' <- ghcupHLSDir ver+ let hlsDir = fromGHCupPath hlsDir'+ lift (getInstalledFiles HLS (mkTVer ver)) >>= \case+ Just files -> do+ lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir+ forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> hlsDir </> dropDrive f))+ removeEmptyDirsRecursive hlsDir+ survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory hlsDir+ f <- recordedInstallationFile HLS (mkTVer ver)+ lift $ recycleFile f+ when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors+ Nothing -> do+ isDir <- liftIO $ doesDirectoryExist hlsDir+ isSyml <- liftIO $ handleIO (\_ -> pure False) $ pathIsSymbolicLink hlsDir+ when (isDir && not isSyml) $ do+ lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack hlsDir+ recyclePathForcibly hlsDir'++ when (Just ver == isHlsSet) $ do+ -- set latest hls+ hlsVers <- lift $ fmap rights getInstalledHLSs+ case headMay . reverse . sort $ hlsVers of+ Just latestver -> liftE $ setHLS latestver SetHLSOnly Nothing+ Nothing -> pure ()+++getCabalVersion :: (MonadIO m, MonadFail m) => FilePath -> m Version+getCabalVersion fp = do+ contents <- liftIO $ B.readFile fp+ gpd <- case parseGenericPackageDescriptionMaybe contents of+ Nothing -> fail $ "could not parse cabal file: " <> fp+ Just r -> pure r+ let tver = (\c -> Version Nothing c [] Nothing)+ . NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral)+ . versionNumbers+ . pkgVersion+ . package+ . packageDescription+ $ gpd+ pure tver
+ lib/GHCup/List.hs view
@@ -0,0 +1,410 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+Module : GHCup.List+Description : Listing versions and tools+Copyright : (c) Julian Ospald, 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : portable+-}+module GHCup.List where++import GHCup.Download+import GHCup.Errors+import GHCup.Types+import GHCup.Types.JSON ( )+import GHCup.Types.Optics+import GHCup.Utils+import GHCup.Prelude.Logger+import GHCup.Version++import Control.Applicative+import Control.Exception.Safe+import Control.Monad+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail ( MonadFail )+#endif+import Control.Monad.Reader+import Data.Either+import Data.List+import Data.Maybe+import Data.Text ( Text )+import Data.Versions hiding ( patch )+import Haskus.Utils.Variant.Excepts+import Optics+import Prelude hiding ( abs+ , writeFile+ )++import qualified Data.Map.Strict as Map+import qualified Data.Text as T+++++++++++ ------------------+ --[ List tools ]--+ ------------------+++-- | Filter data type for 'listVersions'.+data ListCriteria = ListInstalled+ | ListSet+ | ListAvailable+ deriving Show++-- | A list result describes a single tool version+-- and various of its properties.+data ListResult = ListResult+ { lTool :: Tool+ , lVer :: Version+ , lCross :: Maybe Text -- ^ currently only for GHC+ , lTag :: [Tag]+ , lInstalled :: Bool+ , lSet :: Bool -- ^ currently active version+ , fromSrc :: Bool -- ^ compiled from source+ , lStray :: Bool -- ^ not in download info+ , lNoBindist :: Bool -- ^ whether the version is available for this platform/arch+ , hlsPowered :: Bool+ }+ deriving (Eq, Ord, Show)+++-- | Extract all available tool versions and their tags.+availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version VersionInfo+availableToolVersions av tool = view+ (at tool % non Map.empty)+ av+++-- | List all versions from the download info, as well as stray+-- versions.+listVersions :: ( MonadCatch m+ , HasLog env+ , MonadThrow m+ , HasLog env+ , MonadIO m+ , MonadReader env m+ , HasDirs env+ , HasPlatformReq env+ , HasGHCupInfo env+ )+ => Maybe Tool+ -> Maybe ListCriteria+ -> m [ListResult]+listVersions lt' criteria = do+ -- some annoying work to avoid too much repeated IO+ cSet <- cabalSet+ cabals <- getInstalledCabals+ hlsSet' <- hlsSet+ hlses <- getInstalledHLSs+ sSet <- stackSet+ stacks <- getInstalledStacks++ go lt' cSet cabals hlsSet' hlses sSet stacks+ where+ go lt cSet cabals hlsSet' hlses sSet stacks = do+ case lt of+ Just t -> do+ GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo+ -- get versions from GHCupDownloads+ let avTools = availableToolVersions dls t+ lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks)++ case t of+ GHC -> do+ slr <- strayGHCs avTools+ pure (sort (slr ++ lr))+ Cabal -> do+ slr <- strayCabals avTools cSet cabals+ pure (sort (slr ++ lr))+ HLS -> do+ slr <- strayHLS avTools hlsSet' hlses+ pure (sort (slr ++ lr))+ Stack -> do+ slr <- strayStacks avTools sSet stacks+ pure (sort (slr ++ lr))+ GHCup -> do+ let cg = maybeToList $ currentGHCup avTools+ pure (sort (cg ++ lr))+ Nothing -> do+ ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks+ cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks+ hlsvers <- go (Just HLS) cSet cabals hlsSet' hlses sSet stacks+ ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks+ stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks+ pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers)+ strayGHCs :: ( MonadCatch m+ , MonadReader env m+ , HasDirs env+ , MonadThrow m+ , HasLog env+ , MonadIO m+ )+ => Map.Map Version VersionInfo+ -> m [ListResult]+ strayGHCs avTools = do+ ghcs <- getInstalledGHCs+ fmap catMaybes $ forM ghcs $ \case+ Right tver@GHCTargetVersion{ _tvTarget = Nothing, .. } -> do+ case Map.lookup _tvVersion avTools of+ Just _ -> pure Nothing+ Nothing -> do+ lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing+ fromSrc <- ghcSrcInstalled tver+ hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions+ pure $ Just $ ListResult+ { lTool = GHC+ , lVer = _tvVersion+ , lCross = Nothing+ , lTag = []+ , lInstalled = True+ , lStray = isNothing (Map.lookup _tvVersion avTools)+ , lNoBindist = False+ , ..+ }+ Right tver@GHCTargetVersion{ .. } -> do+ lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget+ fromSrc <- ghcSrcInstalled tver+ hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions+ pure $ Just $ ListResult+ { lTool = GHC+ , lVer = _tvVersion+ , lCross = _tvTarget+ , lTag = []+ , lInstalled = True+ , lStray = True -- NOTE: cross currently cannot be installed via bindist+ , lNoBindist = False+ , ..+ }+ Left e -> do+ logWarn+ $ "Could not parse version of stray directory" <> T.pack e+ pure Nothing++ strayCabals :: ( MonadReader env m+ , HasDirs env+ , MonadCatch m+ , MonadThrow m+ , HasLog env+ , MonadIO m+ )+ => Map.Map Version VersionInfo+ -> Maybe Version+ -> [Either FilePath Version]+ -> m [ListResult]+ strayCabals avTools cSet cabals = do+ fmap catMaybes $ forM cabals $ \case+ Right ver ->+ case Map.lookup ver avTools of+ Just _ -> pure Nothing+ Nothing -> do+ let lSet = cSet == Just ver+ pure $ Just $ ListResult+ { lTool = Cabal+ , lVer = ver+ , lCross = Nothing+ , lTag = []+ , lInstalled = True+ , lStray = isNothing (Map.lookup ver avTools)+ , lNoBindist = False+ , fromSrc = False -- actually, we don't know :>+ , hlsPowered = False+ , ..+ }+ Left e -> do+ logWarn+ $ "Could not parse version of stray directory" <> T.pack e+ pure Nothing++ strayHLS :: ( MonadReader env m+ , HasDirs env+ , MonadCatch m+ , MonadThrow m+ , HasLog env+ , MonadIO m)+ => Map.Map Version VersionInfo+ -> Maybe Version+ -> [Either FilePath Version]+ -> m [ListResult]+ strayHLS avTools hlsSet' hlss = do+ fmap catMaybes $ forM hlss $ \case+ Right ver ->+ case Map.lookup ver avTools of+ Just _ -> pure Nothing+ Nothing -> do+ let lSet = hlsSet' == Just ver+ pure $ Just $ ListResult+ { lTool = HLS+ , lVer = ver+ , lCross = Nothing+ , lTag = []+ , lInstalled = True+ , lStray = isNothing (Map.lookup ver avTools)+ , lNoBindist = False+ , fromSrc = False -- actually, we don't know :>+ , hlsPowered = False+ , ..+ }+ Left e -> do+ logWarn+ $ "Could not parse version of stray directory" <> T.pack e+ pure Nothing++ strayStacks :: ( MonadReader env m+ , HasDirs env+ , MonadCatch m+ , MonadThrow m+ , HasLog env+ , MonadIO m+ )+ => Map.Map Version VersionInfo+ -> Maybe Version+ -> [Either FilePath Version]+ -> m [ListResult]+ strayStacks avTools stackSet' stacks = do+ fmap catMaybes $ forM stacks $ \case+ Right ver ->+ case Map.lookup ver avTools of+ Just _ -> pure Nothing+ Nothing -> do+ let lSet = stackSet' == Just ver+ pure $ Just $ ListResult+ { lTool = Stack+ , lVer = ver+ , lCross = Nothing+ , lTag = []+ , lInstalled = True+ , lStray = isNothing (Map.lookup ver avTools)+ , lNoBindist = False+ , fromSrc = False -- actually, we don't know :>+ , hlsPowered = False+ , ..+ }+ Left e -> do+ logWarn+ $ "Could not parse version of stray directory" <> T.pack e+ pure Nothing++ currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult+ currentGHCup av =+ let currentVer = fromJust $ pvpToVersion ghcUpVer ""+ listVer = Map.lookup currentVer av+ latestVer = fst <$> headOf (getTagged Latest) av+ recommendedVer = fst <$> headOf (getTagged Latest) av+ isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer+ in if | Map.member currentVer av -> Nothing+ | otherwise -> Just $ ListResult { lVer = currentVer+ , lTag = maybe (if isOld then [Old] else []) _viTags listVer+ , lCross = Nothing+ , lTool = GHCup+ , fromSrc = False+ , lStray = isNothing listVer+ , lSet = True+ , lInstalled = True+ , lNoBindist = False+ , hlsPowered = False+ }++ -- NOTE: this are not cross ones, because no bindists+ toListResult :: ( HasLog env+ , MonadReader env m+ , HasDirs env+ , HasGHCupInfo env+ , HasPlatformReq env+ , MonadIO m+ , MonadCatch m+ )+ => Tool+ -> Maybe Version+ -> [Either FilePath Version]+ -> Maybe Version+ -> [Either FilePath Version]+ -> Maybe Version+ -> [Either FilePath Version]+ -> (Version, VersionInfo)+ -> m ListResult+ toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, _viTags -> tags) = do+ case t of+ GHC -> do+ lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v+ let tver = mkTVer v+ lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing+ lInstalled <- ghcInstalled tver+ fromSrc <- ghcSrcInstalled tver+ hlsPowered <- fmap (elem v) hlsGHCVersions+ pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. }+ Cabal -> do+ lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v+ let lSet = cSet == Just v+ let lInstalled = elem v $ rights cabals+ pure ListResult { lVer = v+ , lCross = Nothing+ , lTag = tags+ , lTool = t+ , fromSrc = False+ , lStray = False+ , hlsPowered = False+ , ..+ }+ GHCup -> do+ let lSet = prettyPVP ghcUpVer == prettyVer v+ let lInstalled = lSet+ pure ListResult { lVer = v+ , lTag = tags+ , lCross = Nothing+ , lTool = t+ , fromSrc = False+ , lStray = False+ , lNoBindist = False+ , hlsPowered = False+ , ..+ }+ HLS -> do+ lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo HLS v+ let lSet = hlsSet' == Just v+ let lInstalled = elem v $ rights hlses+ pure ListResult { lVer = v+ , lCross = Nothing+ , lTag = tags+ , lTool = t+ , fromSrc = False+ , lStray = False+ , hlsPowered = False+ , ..+ }+ Stack -> do+ lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Stack v+ let lSet = stackSet' == Just v+ let lInstalled = elem v $ rights stacks+ pure ListResult { lVer = v+ , lCross = Nothing+ , lTag = tags+ , lTool = t+ , fromSrc = False+ , lStray = False+ , hlsPowered = False+ , ..+ }+++ filter' :: [ListResult] -> [ListResult]+ filter' lr = case criteria of+ Nothing -> lr+ Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr+ Just ListSet -> filter (\ListResult {..} -> lSet) lr+ Just ListAvailable -> filter (\ListResult {..} -> not lNoBindist) lr+
lib/GHCup/Platform.hs view
@@ -23,10 +23,11 @@ import GHCup.Types import GHCup.Types.Optics import GHCup.Types.JSON ( )-import GHCup.Utils.File-import GHCup.Utils.Logger-import GHCup.Utils.Prelude-import GHCup.Utils.String.QQ+import GHCup.Utils.Dirs+import GHCup.Prelude+import GHCup.Prelude.Logger+import GHCup.Prelude.Process+import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail )@@ -46,7 +47,6 @@ , writeFile ) import System.Info-import System.Directory import System.OsRelease import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.Regex.Posix
+ lib/GHCup/Prelude.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{-|+Module : GHCup.Prelude+Description : MegaParsec utilities+Copyright : (c) Julian Ospald, 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : portable++GHCup specific prelude. Lots of Excepts functionality.+-}+module GHCup.Prelude+ (module GHCup.Prelude,+ module GHCup.Prelude.Internal,+#if defined(IS_WINDOWS)+ module GHCup.Prelude.Windows+#else+ module GHCup.Prelude.Posix+#endif+ )+where++import GHCup.Errors+import GHCup.Prelude.Internal+import GHCup.Types.Optics (HasLog)+import GHCup.Prelude.Logger (logWarn)+#if defined(IS_WINDOWS)+import GHCup.Prelude.Windows+#else+import GHCup.Prelude.Posix+#endif++import Control.Monad.IO.Class+import Control.Monad.Reader+import Haskus.Utils.Variant.Excepts+import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )+import qualified Data.Text as T++++-- for some obscure reason... this won't type-check if we move it to a different module+catchWarn :: forall es m env . ( Pretty (V es)+ , MonadReader env m+ , HasLog env+ , MonadIO m+ , Monad m) => Excepts es m () -> Excepts '[] m ()+catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))+++runBothE' :: forall e m a b .+ ( Monad m+ , Show (V e)+ , Pretty (V e)+ , PopVariant InstallSetError e+ , LiftVariant' e (InstallSetError ': e)+ , e :<< (InstallSetError ': e)+ )+ => Excepts e m a+ -> Excepts e m b+ -> Excepts (InstallSetError ': e) m ()+runBothE' a1 a2 = do+ r1 <- lift $ runE @e a1+ r2 <- lift $ runE @e a2+ case (r1, r2) of+ (VLeft e1, VLeft e2) -> throwE (InstallSetError e1 e2)+ (VLeft e , _ ) -> throwSomeE e+ (_ , VLeft e ) -> throwSomeE e+ (VRight _, VRight _) -> pure ()+++-- | Throw some exception+throwSomeE :: forall es' es a m. (Monad m, LiftVariant es' es) => V es' -> Excepts es m a+{-# INLINABLE throwSomeE #-}+throwSomeE = Excepts . pure . VLeft . liftVariant
+ lib/GHCup/Prelude/File.hs view
@@ -0,0 +1,426 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module GHCup.Prelude.File (+ mergeFileTree,+ copyFileE,+ findFilesDeep,+ getDirectoryContentsRecursive,+ getDirectoryContentsRecursiveBFS,+ getDirectoryContentsRecursiveDFS,+ getDirectoryContentsRecursiveUnsafe,+ getDirectoryContentsRecursiveBFSUnsafe,+ getDirectoryContentsRecursiveDFSUnsafe,+ recordedInstallationFile,+ module GHCup.Prelude.File.Search,++ chmod_755,+ isBrokenSymlink,+ copyFile,+ deleteFile,+ install,+ removeEmptyDirectory,+ removeDirIfEmptyOrIsSymlink,+ removeEmptyDirsRecursive,+ rmFileForce,+ createDirRecursive',+ recyclePathForcibly,+ rmDirectory,+ recycleFile,+ rmFile,+ rmDirectoryLink,+ moveFilePortable,+ moveFile,+ rmPathForcibly,++ exeExt,+ exeExt',+ getLinkTarget,+ pathIsLink,+ rmLink,+ createLink+) where++import GHCup.Utils.Dirs+import GHCup.Prelude.Logger.Internal (logInfo, logDebug)+import GHCup.Prelude.Internal+import GHCup.Prelude.File.Search+#if IS_WINDOWS+import GHCup.Prelude.File.Windows+import GHCup.Prelude.Windows+#else+import GHCup.Prelude.File.Posix+import GHCup.Prelude.Posix+#endif+import GHCup.Errors+import GHCup.Types+import GHCup.Types.Optics++import Text.Regex.Posix+import Control.Monad.IO.Unlift ( MonadUnliftIO )+import Control.Exception.Safe+import Control.Monad.Reader+import Data.ByteString ( ByteString )+import Haskus.Utils.Variant.Excepts+import System.FilePath+import Text.PrettyPrint.HughesPJClass (prettyShow)++import qualified Data.Text as T+import qualified Streamly.Prelude as S+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import GHC.IO.Exception+import System.IO.Error+++-- | Merge one file tree to another given a copy operation.+--+-- Records every successfully installed file into the destination+-- returned by 'recordedInstallationFile'.+--+-- If any copy operation fails, the record file is deleted, as well+-- as the partially installed files.+mergeFileTree :: ( MonadMask m+ , S.MonadAsync m+ , MonadReader env m+ , HasDirs env+ , HasLog env+ , MonadCatch m+ )+ => GHCupPath -- ^ source base directory from which to install findFiles+ -> InstallDirResolved -- ^ destination base dir+ -> Tool+ -> GHCTargetVersion+ -> (FilePath -> FilePath -> m ()) -- ^ file copy operation+ -> Excepts '[MergeFileTreeError] m ()+mergeFileTree _ (GHCupBinDir fp) _ _ _ =+ throwIO $ userError ("mergeFileTree: internal error, called on " <> fp)+mergeFileTree sourceBase destBase tool v' copyOp = do+ lift $ logInfo $ "Merging file tree from \""+ <> T.pack (fromGHCupPath sourceBase)+ <> "\" to \""+ <> T.pack (fromInstallDir destBase)+ <> "\""+ recFile <- recordedInstallationFile tool v'++ wrapInExcepts $ do+ -- These checks are not atomic, but we perform them to have+ -- the opportunity to abort before copying has started.+ --+ -- The actual copying might still fail.+ liftIO $ baseCheck (fromGHCupPath sourceBase)+ liftIO $ destCheck (fromInstallDir destBase)++ -- we only record for non-isolated installs+ when (isSafeDir destBase) $ do+ whenM (liftIO $ doesFileExist recFile)+ $ throwIO $ userError ("mergeFileTree: DB file " <> recFile <> " already exists!")+ liftIO $ createDirectoryIfMissing True (takeDirectory recFile)++ -- we want the cleanup action to leak through in case of exception+ onE_ (cleanupOnPartialInstall recFile) $ wrapInExcepts $ do+ logDebug "Starting merge"+ lift $ flip S.mapM_ (getDirectoryContentsRecursive sourceBase) $ \f -> do+ copy f+ logDebug $ T.pack "Recording installed file: " <> T.pack f+ recordInstalledFile f recFile+ pure f++ where+ wrapInExcepts = handleIO (\e -> throwE $ MergeFileTreeError e (fromGHCupPath sourceBase) (fromInstallDir destBase))++ cleanupOnPartialInstall recFile = when (isSafeDir destBase) $ do+ (force -> !l) <- hideErrorDef [NoSuchThing] [] $ lines <$> liftIO+ (readFile recFile >>= evaluate)+ logDebug "Deleting recorded files due to partial install"+ forM_ l $ \f -> do+ let dest = fromInstallDir destBase </> dropDrive f+ logDebug $ "rm -f " <> T.pack f+ hideError NoSuchThing $ rmFile dest+ pure ()+ logDebug $ "rm -f " <> T.pack recFile+ hideError NoSuchThing $ rmFile recFile+ logDebug $ "rm -f " <> T.pack (fromInstallDir destBase)+ hideError UnsatisfiedConstraints $ hideError NoSuchThing $+ removeEmptyDirsRecursive (fromInstallDir destBase)+++ recordInstalledFile f recFile = when (isSafeDir destBase) $+ liftIO $ appendFile recFile (f <> "\n")++ copy source = do+ let dest = fromInstallDir destBase </> source+ src = fromGHCupPath sourceBase </> source++ when (isAbsolute source)+ $ throwIO $ userError ("mergeFileTree: source file " <> source <> " is not relative!")++ liftIO . createDirectoryIfMissing True . takeDirectory $ dest++ copyOp src dest+++ baseCheck src = do+ when (isRelative src)+ $ throwIO $ userError ("mergeFileTree: source base directory " <> src <> " is not absolute!")+ whenM (not <$> doesDirectoryExist src)+ $ throwIO $ userError ("mergeFileTree: source base directory " <> src <> " does not exist!")+ destCheck dest = do+ when (isRelative dest)+ $ throwIO $ userError ("mergeFileTree: destination base directory " <> dest <> " is not absolute!")++++copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Bool -> Excepts xs m ()+copyFileE from to = handleIO (throwE . CopyError . show) . liftIO . copyFile from to+++-- | List all the files in a directory and all subdirectories.+--+-- The order places files in sub-directories after all the files in their+-- parent directories. The list is generated lazily so is not well defined if+-- the source directory structure changes before the list is used.+--+-- depth first+getDirectoryContentsRecursiveDFS :: (MonadCatch m, S.MonadAsync m, MonadMask m)+ => GHCupPath+ -> S.SerialT m FilePath+getDirectoryContentsRecursiveDFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveDFSUnsafe fp++-- breadth first+getDirectoryContentsRecursiveBFS :: (MonadCatch m, S.MonadAsync m, MonadMask m)+ => GHCupPath+ -> S.SerialT m FilePath+getDirectoryContentsRecursiveBFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveBFSUnsafe fp+++getDirectoryContentsRecursive :: (MonadCatch m, S.MonadAsync m, MonadMask m)+ => GHCupPath+ -> S.SerialT m FilePath+getDirectoryContentsRecursive = getDirectoryContentsRecursiveBFS++getDirectoryContentsRecursiveUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m)+ => FilePath+ -> S.SerialT m FilePath+getDirectoryContentsRecursiveUnsafe = getDirectoryContentsRecursiveBFSUnsafe++findFilesDeep :: GHCupPath -> Regex -> IO [FilePath]+findFilesDeep path regex =+ S.toList $ S.filter (match regex) $ getDirectoryContentsRecursive path+++recordedInstallationFile :: ( MonadReader env m+ , HasDirs env+ )+ => Tool+ -> GHCTargetVersion+ -> m FilePath+recordedInstallationFile t v' = do+ Dirs {..} <- getDirs+ pure (fromGHCupPath dbDir </> prettyShow t </> T.unpack (tVerToText v'))++removeDirIfEmptyOrIsSymlink :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()+removeDirIfEmptyOrIsSymlink filepath =+ hideError UnsatisfiedConstraints $+ handleIO' InappropriateType+ (handleIfSym filepath)+ (liftIO $ removeEmptyDirectory filepath)+ where+ handleIfSym fp e = do+ isSym <- liftIO $ pathIsSymbolicLink fp+ if isSym+ then rmFileForce fp+ else liftIO $ ioError e++removeEmptyDirsRecursive :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()+removeEmptyDirsRecursive = go+ where+ go fp = do+ cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)+ forM_ cs go+ liftIO $ removeEmptyDirectory fp++rmFileForce :: (MonadMask m, MonadIO m) => FilePath -> m ()+rmFileForce filepath = do+ hideError doesNotExistErrorType+ $ hideError InappropriateType $ rmFile filepath++-- | More permissive version of 'createDirRecursive'. This doesn't+-- error when the destination is a symlink to a directory.+createDirRecursive' :: FilePath -> IO ()+createDirRecursive' p =+ handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)+ . createDirectoryIfMissing True+ $ p++ where+ isSymlinkDir e = do+ ft <- pathIsSymbolicLink p+ case ft of+ True -> do+ rp <- canonicalizePath p+ rft <- doesDirectoryExist rp+ case rft of+ True -> pure ()+ _ -> throwIO e+ _ -> throwIO e+++-- https://github.com/haskell/directory/issues/110+-- https://github.com/haskell/directory/issues/96+-- https://www.sqlite.org/src/info/89f1848d7f+recyclePathForcibly :: ( MonadIO m+ , MonadReader env m+ , HasDirs env+ , MonadMask m+ )+ => GHCupPath+ -> m ()+recyclePathForcibly fp+ | isWindows = do+ Dirs { recycleDir } <- getDirs+ tmp <- liftIO $ createTempGHCupDirectory recycleDir "recyclePathForcibly"+ let dest = tmp `appendGHCupPath` takeFileName (fromGHCupPath fp)+ liftIO (moveFile (fromGHCupPath fp) (fromGHCupPath dest))+ `catch`+ (\e -> if | isDoesNotExistError e -> pure ()+ | isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)+ | otherwise -> throwIO e)+ `finally`+ liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)+ | otherwise = liftIO $ removePathForcibly fp++++rmDirectory :: (MonadIO m, MonadMask m)+ => GHCupPath+ -> m ()+rmDirectory fp+ | isWindows = recover (liftIO $ removeDirectory fp)+ | otherwise = liftIO $ removeDirectory fp+++-- https://www.sqlite.org/src/info/89f1848d7f+-- https://github.com/haskell/directory/issues/96+recycleFile :: ( MonadIO m+ , MonadMask m+ , MonadReader env m+ , HasDirs env+ )+ => FilePath+ -> m ()+recycleFile fp+ | isWindows = do+ Dirs { recycleDir } <- getDirs+ liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))+ tmp <- liftIO $ createTempGHCupDirectory recycleDir "recycleFile"+ let dest = fromGHCupPath tmp </> takeFileName fp+ liftIO (moveFile fp dest)+ `catch`+ (\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ rmFile fp) else throwIO e)+ `finally`+ liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)+ | otherwise = liftIO $ removeFile fp+++rmFile :: ( MonadIO m+ , MonadMask m+ )+ => FilePath+ -> m ()+rmFile fp+ | isWindows = recover (liftIO $ removeFile fp)+ | otherwise = liftIO $ removeFile fp+++rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)+ => FilePath+ -> m ()+rmDirectoryLink fp+ | isWindows = recover (liftIO $ removeDirectoryLink fp)+ | otherwise = liftIO $ removeDirectoryLink fp+++rmPathForcibly :: ( MonadIO m+ , MonadMask m+ )+ => GHCupPath+ -> m ()+rmPathForcibly fp+ | isWindows = recover (liftIO $ removePathForcibly fp)+ | otherwise = liftIO $ removePathForcibly fp+++-- | The file extension for executables.+exeExt :: String+exeExt+ | isWindows = ".exe"+ | otherwise = ""++-- | The file extension for executables.+exeExt' :: ByteString+exeExt'+ | isWindows = ".exe"+ | otherwise = ""+++rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()+rmLink fp+ | isWindows = do+ hideError doesNotExistErrorType . recycleFile $ fp+ hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")+ | otherwise = hideError doesNotExistErrorType . recycleFile $ fp+++-- | Creates a symbolic link on unix and a fake symlink on windows for+-- executables, which:+-- 1. is a shim exe+-- 2. has a corresponding .shim file in the same directory that+-- contains the target+--+-- This overwrites previously existing files.+--+-- On windows, this requires that 'ensureGlobalTools' was run beforehand.+createLink :: ( MonadMask m+ , MonadThrow m+ , HasLog env+ , MonadIO m+ , MonadReader env m+ , HasDirs env+ , MonadUnliftIO m+ , MonadFail m+ )+ => FilePath -- ^ path to the target executable+ -> FilePath -- ^ path to be created+ -> m ()+createLink link exe+ | isWindows = do+ dirs <- getDirs+ let shimGen = fromGHCupPath (cacheDir dirs) </> "gs.exe"++ let shim = dropExtension exe <.> "shim"+ -- For hardlinks, link needs to be absolute.+ -- If link is relative, it's relative to the target exe.+ -- Note that (</>) drops lhs when rhs is absolute.+ fullLink = takeDirectory exe </> link+ shimContents = "path = " <> fullLink++ logDebug $ "rm -f " <> T.pack exe+ rmLink exe++ logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe+ liftIO $ copyFile shimGen exe False+ liftIO $ writeFile shim shimContents+ | otherwise = do+ logDebug $ "rm -f " <> T.pack exe+ hideError doesNotExistErrorType $ recycleFile exe++ logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe+ liftIO $ createFileLink link exe
+ lib/GHCup/Prelude/File/Posix.hs view
@@ -0,0 +1,324 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE CApiFFI #-}++{-|+Module : GHCup.Utils.File.Posix+Description : File and directory handling for unix+Copyright : (c) Julian Ospald, 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : POSIX+-}+module GHCup.Prelude.File.Posix where++import GHCup.Prelude.File.Posix.Traversals++import Control.Exception.Safe+import Control.Monad.Reader+import Foreign.C.String+import Foreign.C.Error+import Foreign.C.Types+import System.IO ( hClose, hSetBinaryMode )+import System.IO.Error hiding ( catchIOError )+import System.FilePath+import System.Directory ( removeFile, pathIsSymbolicLink, getSymbolicLinkTarget, doesPathExist )+import System.Posix.Directory+import System.Posix.Error ( throwErrnoPathIfMinus1Retry )+import System.Posix.Internals ( withFilePath )+import System.Posix.Files+import System.Posix.Types+++import qualified System.Posix.Directory as PD+import qualified System.Posix.Files as PF+import qualified System.Posix.IO as SPI+import qualified System.Posix as Posix+import qualified Streamly.FileSystem.Handle as FH+import qualified Streamly.Internal.FileSystem.Handle+ as IFH+import qualified Streamly.Prelude as S+import qualified GHCup.Prelude.File.Posix.Foreign as FD+import qualified Streamly.Internal.Data.Stream.StreamD.Type+ as D+import Streamly.Internal.Data.Unfold.Type+import qualified Streamly.Internal.Data.Unfold as U+import Streamly.Internal.Control.Concurrent ( withRunInIO )+import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer )+++-- | On unix, we can use symlinks, so we just get the+-- symbolic link target.+--+-- On windows, we have to emulate symlinks via shims,+-- see 'createLink'.+getLinkTarget :: FilePath -> IO FilePath+getLinkTarget = getSymbolicLinkTarget+++-- | Checks whether the path is a link.+pathIsLink :: FilePath -> IO Bool+pathIsLink = pathIsSymbolicLink+++chmod_755 :: MonadIO m => FilePath -> m ()+chmod_755 fp = do+ let exe_mode =+ nullFileMode+ `unionFileModes` ownerExecuteMode+ `unionFileModes` ownerReadMode+ `unionFileModes` ownerWriteMode+ `unionFileModes` groupExecuteMode+ `unionFileModes` groupReadMode+ `unionFileModes` otherExecuteMode+ `unionFileModes` otherReadMode+ liftIO $ setFileMode fp exe_mode+++-- |Default permissions for a new file.+newFilePerms :: FileMode+newFilePerms =+ ownerWriteMode+ `unionFileModes` ownerReadMode+ `unionFileModes` groupWriteMode+ `unionFileModes` groupReadMode+ `unionFileModes` otherWriteMode+ `unionFileModes` otherReadMode+++-- | Checks whether the binary is a broken link.+isBrokenSymlink :: FilePath -> IO Bool+isBrokenSymlink fp = do+ try (pathIsSymbolicLink fp) >>= \case+ Right True -> do+ let symDir = takeDirectory fp+ tfp <- getSymbolicLinkTarget fp+ not <$> doesPathExist+ -- this drops 'symDir' if 'tfp' is absolute+ (symDir </> tfp)+ Right b -> pure b+ Left e | isDoesNotExistError e -> pure False+ | otherwise -> throwIO e++copyFile :: FilePath -- ^ source file+ -> FilePath -- ^ destination file+ -> Bool -- ^ fail if file exists+ -> IO ()+copyFile from to fail' = do+ bracket+ (openFdHandle from SPI.ReadOnly [FD.oNofollow] Nothing)+ (hClose . snd)+ $ \(fromFd, fH) -> do+ sourceFileMode <- fileMode <$> getFdStatus fromFd+ let dflags = [ FD.oNofollow+ , if fail' then FD.oExcl else FD.oTrunc+ ]+ bracket+ (openFdHandle to SPI.WriteOnly dflags $ Just sourceFileMode)+ (hClose . snd)+ $ \(_, tH) -> do+ hSetBinaryMode fH True+ hSetBinaryMode tH True+ streamlyCopy (fH, tH)+ where+ openFdHandle fp omode flags fM = do+ fd <- openFd' fp omode flags fM+ handle' <- SPI.fdToHandle fd+ pure (fd, handle')+ streamlyCopy (fH, tH) =+ S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH++foreign import capi unsafe "fcntl.h open"+ c_open :: CString -> CInt -> Posix.CMode -> IO CInt+++open_ :: CString+ -> Posix.OpenMode+ -> [FD.Flags]+ -> Maybe Posix.FileMode+ -> IO Posix.Fd+open_ str how optional_flags maybe_mode = do+ fd <- c_open str all_flags mode_w+ return (Posix.Fd fd)+ where+ all_flags = FD.unionFlags $ optional_flags ++ [open_mode] ++ creat+++ (creat, mode_w) = case maybe_mode of+ Nothing -> ([],0)+ Just x -> ([FD.oCreat], x)++ open_mode = case how of+ Posix.ReadOnly -> FD.oRdonly+ Posix.WriteOnly -> FD.oWronly+ Posix.ReadWrite -> FD.oRdwr+++-- |Open and optionally create this file. See 'System.Posix.Files'+-- for information on how to use the 'FileMode' type.+--+-- Note that passing @Just x@ as the 4th argument triggers the+-- `oCreat` status flag, which must be set when you pass in `oExcl`+-- to the status flags. Also see the manpage for @open(2)@.+openFd' :: FilePath+ -> Posix.OpenMode+ -> [FD.Flags] -- ^ status flags of @open(2)@+ -> Maybe Posix.FileMode -- ^ @Just x@ => creates the file with the given modes, Nothing => the file must exist.+ -> IO Posix.Fd+openFd' name how optional_flags maybe_mode =+ withFilePath name $ \str ->+ throwErrnoPathIfMinus1Retry "openFd" name $+ open_ str how optional_flags maybe_mode+++-- |Deletes the given file. Raises `eISDIR`+-- if run on a directory. Does not follow symbolic links.+--+-- Throws:+--+-- - `InappropriateType` for wrong file type (directory)+-- - `NoSuchThing` if the file does not exist+-- - `PermissionDenied` if the directory cannot be read+--+-- Notes: calls `unlink`+deleteFile :: FilePath -> IO ()+deleteFile = removeLink+++-- |Recreate a symlink.+--+-- In `Overwrite` copy mode only files and empty directories are deleted.+--+-- Safety/reliability concerns:+--+-- * `Overwrite` mode is inherently non-atomic+--+-- Throws:+--+-- - `InvalidArgument` if source file is wrong type (not a symlink)+-- - `PermissionDenied` if output directory cannot be written to+-- - `PermissionDenied` if source directory cannot be opened+-- - `SameFile` if source and destination are the same file+-- (`HPathIOException`)+--+--+-- Throws in `Strict` mode only:+--+-- - `AlreadyExists` if destination already exists+--+-- Throws in `Overwrite` mode only:+--+-- - `UnsatisfiedConstraints` if destination file is non-empty directory+--+-- Notes:+--+-- - calls `symlink`+recreateSymlink :: FilePath -- ^ the old symlink file+ -> FilePath -- ^ destination file+ -> Bool -- ^ fail if destination file exists+ -> IO ()+recreateSymlink symsource newsym fail' = do+ sympoint <- readSymbolicLink symsource+ case fail' of+ True -> pure ()+ False ->+ handleIO (\e -> if doesNotExistErrorType == ioeGetErrorType e then pure () else liftIO . ioError $ e) $ deleteFile newsym+ createSymbolicLink sympoint newsym+++-- copys files, recreates symlinks, fails on all other types+install :: FilePath -> FilePath -> Bool -> IO ()+install from to fail' = do+ fs <- PF.getSymbolicLinkStatus from+ decide fs+ where+ decide fs | PF.isRegularFile fs = copyFile from to fail'+ | PF.isSymbolicLink fs = recreateSymlink from to fail'+ | otherwise = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from)++moveFile :: FilePath -> FilePath -> IO ()+moveFile = rename+++moveFilePortable :: FilePath -> FilePath -> IO ()+moveFilePortable from to = do+ catchErrno [eXDEV] (moveFile from to) $ do+ copyFile from to True+ removeFile from+++catchErrno :: [Errno] -- ^ errno to catch+ -> IO a -- ^ action to try, which can raise an IOException+ -> IO a -- ^ action to carry out in case of an IOException and+ -- if errno matches+ -> IO a+catchErrno en a1 a2 =+ catchIOError a1 $ \e -> do+ errno <- getErrno+ if errno `elem` en+ then a2+ else ioError e++removeEmptyDirectory :: FilePath -> IO ()+removeEmptyDirectory = PD.removeDirectory+++-- | 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)+ where+ {-# INLINE [0] step #-}+ step dirstream = do+ (typ, e) <- liftIO $ readDirEnt dirstream+ return $ if+ | null e -> D.Stop+ | "." == e -> D.Skip dirstream+ | ".." == e -> D.Skip dirstream+ | otherwise -> D.Yield (typ, e) dirstream+++getDirectoryContentsRecursiveDFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m)+ => FilePath+ -> S.SerialT m FilePath+getDirectoryContentsRecursiveDFSUnsafe fp = go ""+ where+ go cd = flip S.concatMap (S.unfold unfoldDirContents (fp </> cd)) $ \(t, f) ->+ if | t == FD.dtDir -> go (cd </> f)+ | otherwise -> pure (cd </> f)+++getDirectoryContentsRecursiveUnfold :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath FilePath+getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, [""]))+ where+ {-# INLINE [0] step #-}+ 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+ runIOFinalizer finalizer+ return $ D.Skip (topdir, Nothing, dirs)+ | f == "." || f == ".."+ -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), dirs)+ | FD.dtDir == dt -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), (cdir </> f):dirs)+ | otherwise -> return $ D.Yield (cdir </> f) (topdir, Just (cdir, dirstream, finalizer), dirs)++ step (topdir, Nothing, dir:dirs) = do+ (s, f) <- acquire (topdir </> dir)+ return $ D.Skip (topdir, Just (dir, s, f), dirs)++ acquire dir =+ withRunInIO $ \run -> mask_ $ run $ do+ dirstream <- liftIO $ openDirStream dir+ ref <- newIOFinalizer (liftIO $ closeDirStream dirstream)+ return (dirstream, ref)++getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m)+ => FilePath+ -> S.SerialT m FilePath+getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold++
+ lib/GHCup/Prelude/File/Posix/Foreign.hsc view
@@ -0,0 +1,58 @@+{-# LANGUAGE PatternSynonyms #-}++module GHCup.Prelude.File.Posix.Foreign where++import Data.Bits+import Data.List (foldl')+import Foreign.C.Types++#include <limits.h>+#include <stdlib.h>+#include <dirent.h>+#include <sys/types.h>+#include <sys/stat.h>+#include <fcntl.h>++newtype DirType = DirType Int deriving (Eq, Show)+data Flags = Flags Int | UnsupportedFlag String deriving (Eq, Show)++unFlags :: Flags -> Int+unFlags (Flags i) = i+unFlags (UnsupportedFlag name) = error (name ++ " is not supported on this platform")++-- |Returns @True@ if posix-paths was compiled with support for the provided+-- flag. (As of this writing, the only flag for which this check may be+-- necessary is 'oCloexec'; all other flags will always yield @True@.)+isSupported :: Flags -> Bool+isSupported (Flags _) = True+isSupported _ = False++-- |@O_CLOEXEC@ is not supported on every POSIX platform. Use+-- @'isSupported' oCloexec@ to determine if support for @O_CLOEXEC@ was+-- compiled into your version of posix-paths. (If not, using @oCloexec@ will+-- throw an exception.)+oCloexec :: Flags+#ifdef O_CLOEXEC+oCloexec = Flags #{const O_CLOEXEC}+#else+{-# WARNING oCloexec+ "This version of posix-paths was compiled without @O_CLOEXEC@ support." #-}+oCloexec = UnsupportedFlag "O_CLOEXEC"+#endif++++-- If these enum declarations occur earlier in the file, haddock+-- gets royally confused about the above doc comments.+-- Probably http://trac.haskell.org/haddock/ticket/138++#{enum DirType, DirType, DT_BLK, DT_CHR, DT_DIR, DT_FIFO, DT_LNK, DT_REG, DT_SOCK, DT_UNKNOWN}++#{enum Flags, Flags, O_APPEND, O_ASYNC, O_CREAT, O_DIRECTORY, O_EXCL, O_NOCTTY, O_NOFOLLOW, O_NONBLOCK, O_RDONLY, O_WRONLY, O_RDWR, O_SYNC, O_TRUNC}++pathMax :: Int+pathMax = #{const PATH_MAX}++unionFlags :: [Flags] -> CInt+unionFlags = fromIntegral . foldl' ((. unFlags) . (.|.)) 0+
+ lib/GHCup/Prelude/File/Posix/Traversals.hs view
@@ -0,0 +1,92 @@+{-# 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++type CDir = ()+type 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 ccall unsafe "__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/Search.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++module GHCup.Prelude.File.Search (+ module GHCup.Prelude.File.Search+ , ProcessError(..)+ , CapturedProcess(..)+ ) where++import GHCup.Types(ProcessError(..), CapturedProcess(..))++import Control.Monad.Reader+import Data.Maybe+import Data.Text ( Text )+import Data.Void+import GHC.IO.Exception+import System.Directory hiding ( removeDirectory+ , removeDirectoryRecursive+ , removePathForcibly+ , findFiles+ )+import System.FilePath+import Text.Regex.Posix+++import qualified Data.Text as T+import qualified Text.Megaparsec as MP+import Control.Exception.Safe (handleIO)+import System.Directory.Internal.Prelude (ioeGetErrorType)++++-- | Search for a file in the search paths.+--+-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.+searchPath :: [FilePath] -> FilePath -> IO (Maybe FilePath)+searchPath paths needle = go paths+ where+ go [] = pure Nothing+ go (x : xs) =+ handleIO (\e -> if ioeGetErrorType e `elem` [InappropriateType, PermissionDenied, NoSuchThing] then go xs else ioError e)+ $ do+ contents <- listDirectory x+ findM (isMatch x) contents >>= \case+ Just _ -> pure $ Just (x </> needle)+ Nothing -> go xs+ isMatch basedir p = do+ if p == needle+ then isExecutable (basedir </> needle)+ else pure False++ isExecutable :: FilePath -> IO Bool+ isExecutable file = executable <$> getPermissions file++ -- TODO: inlined from GHCup.Prelude+ findM ~p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing)+ ifM ~b ~t ~f = do+ b' <- b+ if b' then t else f+++-- | Check wether a binary is shadowed by another one that comes before+-- it in PATH. Returns the path to said binary, if any.+isShadowed :: FilePath -> IO (Maybe FilePath)+isShadowed p = do+ let dir = takeDirectory p+ let fn = takeFileName p+ spaths <- liftIO getSearchPath+ if dir `elem` spaths+ then do+ let shadowPaths = takeWhile (/= dir) spaths+ searchPath shadowPaths fn+ else pure Nothing+++-- | Check whether the binary is in PATH. This returns only `True`+-- if the directory containing the binary is part of PATH.+isInPath :: FilePath -> IO Bool+isInPath p = do+ let dir = takeDirectory p+ let fn = takeFileName p+ spaths <- liftIO getSearchPath+ if dir `elem` spaths+ then isJust <$> searchPath [dir] fn+ else pure False+++-- | Follows the first match in case of Regex.+expandFilePath :: [Either FilePath Regex] -> IO [FilePath]+expandFilePath = go ""+ where+ go :: FilePath -> [Either FilePath Regex] -> IO [FilePath]+ go p [] = pure [p]+ go p (x:xs) = do+ case x of+ Left s -> go (p </> s) xs+ Right regex -> do+ fps <- findFiles p regex+ res <- forM fps $ \fp -> go (p </> fp) xs+ pure $ mconcat res+++findFiles :: FilePath -> Regex -> IO [FilePath]+findFiles path regex = do+ contents <- listDirectory path+ pure $ filter (match regex) contents+++findFiles' :: FilePath -> MP.Parsec Void Text a -> IO [FilePath]+findFiles' path parser = do+ contents <- listDirectory path+ pure $ filter (\fp -> either (const False) (const True) $ MP.parse parser "" (T.pack fp)) contents++
+ lib/GHCup/Prelude/File/Windows.hs view
@@ -0,0 +1,311 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}++{-|+Module : GHCup.Utils.File.Windows+Description : File and directory handling for windows+Copyright : (c) Julian Ospald, 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : Windows+-}+module GHCup.Prelude.File.Windows where++import GHCup.Utils.Dirs+import GHCup.Prelude.Internal++import Control.Exception.Safe+import Control.Monad+import Control.Monad.Reader+import Data.List+import qualified GHC.Unicode as U+import System.FilePath+import qualified System.IO.Error as IOE++import qualified System.Win32.Info as WS+import qualified System.Win32.File as WS++import qualified Streamly.Internal.Data.Stream.StreamD.Type+ as D+import Streamly.Internal.Data.Unfold.Type hiding ( concatMap )+import Data.Bits ((.&.))+import qualified Streamly.Prelude as S+import qualified Streamly.Internal.Data.Unfold as U+import Streamly.Internal.Control.Concurrent ( withRunInIO )+import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer )++++-- | On unix, we can use symlinks, so we just get the+-- symbolic link target.+--+-- On windows, we have to emulate symlinks via shims,+-- see 'createLink'.+getLinkTarget :: FilePath -> IO FilePath+getLinkTarget fp = do+ content <- readFile (dropExtension fp <.> "shim")+ [p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content+ pure $ stripNewline $ dropPrefix "path = " p+++-- | Checks whether the path is a link.+pathIsLink :: FilePath -> IO Bool+pathIsLink fp = doesPathExist (dropExtension fp <.> "shim")++++chmod_755 :: MonadIO m => FilePath -> m ()+chmod_755 fp =+ let perm = setOwnerWritable True emptyPermissions+ in liftIO $ setPermissions fp perm+++-- | Checks whether the binary is a broken link.+isBrokenSymlink :: FilePath -> IO Bool+isBrokenSymlink fp = do+ b <- pathIsLink fp+ if b+ then do+ tfp <- getLinkTarget fp+ not <$> doesPathExist+ -- this drops 'symDir' if 'tfp' is absolute+ (takeDirectory fp </> tfp)+ else pure False+++copyFile :: FilePath -- ^ source file+ -> FilePath -- ^ destination file+ -> Bool -- ^ fail if file exists+ -> IO ()+copyFile = WS.copyFile++deleteFile :: FilePath -> IO ()+deleteFile = WS.deleteFile+++install :: FilePath -> FilePath -> Bool -> IO ()+install = copyFile+++moveFile :: FilePath -> FilePath -> IO ()+moveFile from to = WS.moveFileEx from (Just to) 0+++moveFilePortable :: FilePath -> FilePath -> IO ()+moveFilePortable = WS.moveFile+++removeEmptyDirectory :: FilePath -> IO ()+removeEmptyDirectory = WS.removeDirectory+++unfoldDirContents :: (S.MonadAsync m, MonadIO m, MonadCatch m, MonadMask m) => Unfold m FilePath (WS.FileAttributeOrFlag, FilePath)+unfoldDirContents = U.bracket alloc dealloc (Unfold step return)+ where+ {-# INLINE [0] step #-}+ step (_, False, _, _) = return D.Stop+ step (topdir, True, h, fd) = flip onException (liftIO $ WS.findClose h) $ do+ f <- liftIO $ WS.getFindDataFileName fd+ more <- liftIO $ WS.findNextFile h fd++ -- can't get file attribute from FindData yet (needs Win32 PR)+ fattr <- liftIO $ WS.getFileAttributes (topdir </> f)++ if | f == "." || f == ".." -> return $ D.Skip (topdir, more, h, fd)+ | otherwise -> return $ D.Yield (fattr, f) (topdir, more, h, fd)++ alloc topdir = do+ query <- liftIO $ furnishPath (topdir </> "*")+ (h, fd) <- liftIO $ WS.findFirstFile query+ pure (topdir, True, h, fd)++ dealloc (_, _, fd, _) = liftIO $ WS.findClose fd+++getDirectoryContentsRecursiveDFSUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m, S.IsStream t)+ => FilePath+ -> t m FilePath+getDirectoryContentsRecursiveDFSUnsafe fp = go ""+ where+ isDir attrs = attrs .&. WS.fILE_ATTRIBUTE_DIRECTORY /= 0++ go cd = flip S.concatMap (S.unfold unfoldDirContents (fp </> cd)) $ \(t, f) ->+ if | isDir t -> go (cd </> f)+ | otherwise -> pure (cd </> f)+++getDirectoryContentsRecursiveUnfold :: (MonadCatch m, S.MonadAsync m, MonadMask m) => Unfold m FilePath FilePath+getDirectoryContentsRecursiveUnfold = Unfold step init'+ where+ {-# INLINE [0] step #-}+ step (_, Nothing, []) = return D.Stop++ step (topdir, state@(Just (cdir, (h, findData, ref))), dirs) = flip onException (runIOFinalizer ref) $ do+ f <- liftIO $ WS.getFindDataFileName findData++ more <- liftIO $ WS.findNextFile h findData+ when (not more) $ runIOFinalizer ref+ let nextState = if more then state else Nothing++ -- can't get file attribute from FindData yet (needs Win32 PR)+ fattr <- liftIO $ WS.getFileAttributes (topdir </> cdir </> f)++ if | f == "." || f == ".." -> return $ D.Skip (topdir, nextState, dirs)+ | isDir fattr -> return $ D.Skip (topdir, nextState, (cdir </> f):dirs)+ | otherwise -> return $ D.Yield (cdir </> f) (topdir, nextState, dirs)++ step (topdir, Nothing, dir:dirs) = do+ (h, findData, ref) <- acquire (topdir </> dir)+ return $ D.Skip (topdir, Just (dir, (h, findData, ref)), dirs)++ init' topdir = do+ (h, findData, ref) <- acquire topdir+ return (topdir, Just ("", (h, findData, ref)), [])++ isDir attrs = attrs .&. WS.fILE_ATTRIBUTE_DIRECTORY /= 0++ acquire dir = do+ query <- liftIO $ furnishPath (dir </> "*")+ withRunInIO $ \run -> mask_ $ run $ do+ (h, findData) <- liftIO $ WS.findFirstFile query+ ref <- newIOFinalizer (liftIO $ WS.findClose h)+ return (h, findData, ref)+++getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m)+ => FilePath+ -> S.SerialT m FilePath+getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold++++ --------------------------------------+ --[ Inlined from directory package ]--+ --------------------------------------+++furnishPath :: FilePath -> IO FilePath+furnishPath path =+ (toExtendedLengthPath <$> rawPrependCurrentDirectory path)+ `IOE.catchIOError` \ _ ->+ pure path+++toExtendedLengthPath :: FilePath -> FilePath+toExtendedLengthPath path+ | isRelative path = simplifiedPath+ | otherwise =+ case simplifiedPath of+ '\\' : '?' : '?' : '\\' : _ -> simplifiedPath+ '\\' : '\\' : '?' : '\\' : _ -> simplifiedPath+ '\\' : '\\' : '.' : '\\' : _ -> simplifiedPath+ '\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath+ _ -> "\\\\?\\" <> simplifiedPath+ where simplifiedPath = simplify path+++simplify :: FilePath -> FilePath+simplify = simplifyWindows++simplifyWindows :: FilePath -> FilePath+simplifyWindows "" = ""+simplifyWindows path =+ case drive' of+ "\\\\?\\" -> drive' <> subpath+ _ -> simplifiedPath+ where+ simplifiedPath = joinDrive drive' subpath'+ (drive, subpath) = splitDrive path+ drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive))+ subpath' = appendSep . avoidEmpty . prependSep . joinPath .+ stripPardirs . expandDots . skipSeps .+ splitDirectories $ subpath++ upperDrive d = case d of+ c : ':' : s | U.isAlpha c && all isPathSeparator s -> U.toUpper c : ':' : s+ _ -> d+ skipSeps = filter (not . (`elem` (pure <$> pathSeparators)))+ stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== "..")+ | otherwise = id+ prependSep | subpathIsAbsolute = (pathSeparator :)+ | otherwise = id+ avoidEmpty | not pathIsAbsolute+ && (null drive || hasTrailingPathSep) -- prefer "C:" over "C:."+ = emptyToCurDir+ | otherwise = id+ appendSep p | hasTrailingPathSep+ && not (pathIsAbsolute && null p)+ = addTrailingPathSeparator p+ | otherwise = p+ pathIsAbsolute = not (isRelative path)+ subpathIsAbsolute = any isPathSeparator (take 1 subpath)+ hasTrailingPathSep = hasTrailingPathSeparator subpath++emptyToCurDir :: FilePath -> FilePath+emptyToCurDir "" = "."+emptyToCurDir path = path++normaliseTrailingSep :: FilePath -> FilePath+normaliseTrailingSep path = do+ let path' = reverse path+ let (sep, path'') = span isPathSeparator path'+ let addSep = if null sep then id else (pathSeparator :)+ reverse (addSep path'')++normalisePathSeps :: FilePath -> FilePath+normalisePathSeps p = (\ c -> if isPathSeparator c then pathSeparator else c) <$> p++expandDots :: [FilePath] -> [FilePath]+expandDots = reverse . go []+ where+ go ys' xs' =+ case xs' of+ [] -> ys'+ x : xs ->+ case x of+ "." -> go ys' xs+ ".." ->+ case ys' of+ [] -> go (x : ys') xs+ ".." : _ -> go (x : ys') xs+ _ : ys -> go ys xs+ _ -> go (x : ys') xs++rawPrependCurrentDirectory :: FilePath -> IO FilePath+rawPrependCurrentDirectory path+ | isRelative path =+ ((`ioeAddLocation` "prependCurrentDirectory") .+ (`IOE.ioeSetFileName` path)) `IOE.modifyIOError` do+ getFullPathName path+ | otherwise = pure path++ioeAddLocation :: IOError -> String -> IOError+ioeAddLocation e loc = do+ IOE.ioeSetLocation e newLoc+ where+ newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc+ oldLoc = IOE.ioeGetLocation e++getFullPathName :: FilePath -> IO FilePath+getFullPathName path =+ fromExtendedLengthPath <$> WS.getFullPathName (toExtendedLengthPath path)++fromExtendedLengthPath :: FilePath -> FilePath+fromExtendedLengthPath ePath =+ case ePath of+ '\\' : '\\' : '?' : '\\' : path ->+ case path of+ 'U' : 'N' : 'C' : subpath@('\\' : _) -> "\\" <> subpath+ drive : ':' : subpath+ -- if the path is not "regular", then the prefix is necessary+ -- to ensure the path is interpreted literally+ | U.isAlpha drive && U.isAscii drive && isPathRegular subpath -> path+ _ -> ePath+ _ -> ePath+ where+ isPathRegular path =+ not ('/' `elem` path ||+ "." `elem` splitDirectories path ||+ ".." `elem` splitDirectories path)
+ lib/GHCup/Prelude/Internal.hs view
@@ -0,0 +1,519 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{-|+Module : GHCup.Prelude.Internal+Description : MegaParsec utilities+Copyright : (c) Julian Ospald, 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : portable++Stuff that doesn't need GHCup modules, so we can avoid+recursive imports.+-}+module GHCup.Prelude.Internal where+++import Control.Applicative+import Control.Exception.Safe+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader+import Data.Bifunctor+import Data.ByteString ( ByteString )+import Data.List ( intercalate, stripPrefix, isPrefixOf, dropWhileEnd )+import Data.Maybe+import Data.String+import Data.Text ( Text )+import Data.Versions+import Data.Word8 hiding ( isDigit )+import Haskus.Utils.Types.List+import Haskus.Utils.Variant.Excepts+import System.IO.Error++import Control.Retry+import GHC.IO.Exception++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.Strict.Maybe as S+import qualified Data.List.Split as Split+import qualified Data.Text as T+import qualified Data.Text.Encoding as E+import qualified Data.Text.Encoding.Error as E+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as B+import qualified Data.Text.Lazy.Builder.Int as B+import qualified Data.Text.Lazy.Encoding as TLE++++-- $setup+-- >>> import Data.ByteString.Internal (c2w, w2c)+-- >>> import Test.QuickCheck+-- >>> import Data.Word8+-- >>> import qualified Data.Text as T+-- >>> import qualified Data.Char as C+-- >>> import Data.List+-- >>> instance Arbitrary T.Text where arbitrary = T.pack <$> arbitrary+++fS :: IsString a => String -> a+fS = fromString++fromStrictMaybe :: S.Maybe a -> Maybe a+fromStrictMaybe = S.maybe Nothing Just++fSM :: S.Maybe a -> Maybe a+fSM = fromStrictMaybe++toStrictMaybe :: Maybe a -> S.Maybe a+toStrictMaybe = maybe S.Nothing S.Just++tSM :: Maybe a -> S.Maybe a+tSM = toStrictMaybe++internalError :: String -> IO a+internalError = fail . ("Internal error: " <>)++iE :: String -> IO a+iE = internalError+++showT :: Show a => a -> Text+showT = fS . show++-- | Like 'when', but where the test can be monadic.+whenM :: Monad m => m Bool -> m () -> m ()+whenM ~b ~t = ifM b t (return ())++-- | Like 'unless', but where the test can be monadic.+unlessM :: Monad m => m Bool -> m () -> m ()+unlessM ~b ~f = ifM b (return ()) f++-- | Like @if@, but where the test can be monadic.+ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM ~b ~t ~f = do+ b' <- b+ if b' then t else f++whileM :: Monad m => m a -> (a -> m Bool) -> m a+whileM ~action ~f = do+ a <- action+ b' <- f a+ if b' then whileM action f else pure a++whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()+whileM_ ~action = void . whileM action++guardM :: (Monad m, Alternative m) => m Bool -> m ()+guardM ~f = guard =<< f+++handleIO' :: (MonadIO m, MonadCatch m)+ => IOErrorType+ -> (IOException -> m a)+ -> m a+ -> m a+handleIO' err handler = handleIO+ (\e -> if err == ioeGetErrorType e then handler e else liftIO $ ioError e)+++(??) :: forall e es a m . (Monad m, e :< es) => Maybe a -> e -> Excepts es m a+(??) m e = maybe (throwE e) pure m+++(!?) :: forall e es a m+ . (Monad m, e :< es)+ => m (Maybe a)+ -> e+ -> Excepts es m a+(!?) em e = lift em >>= (?? e)+++lE :: forall e es a m . (Monad m, e :< es) => Either e a -> Excepts es m a+lE = liftE . veitherToExcepts . fromEither++lE' :: forall e' e es a m+ . (Monad m, e :< es)+ => (e' -> e)+ -> Either e' a+ -> Excepts es m a+lE' f = liftE . veitherToExcepts . fromEither . first f++lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a+lEM em = lift em >>= lE++lEM' :: forall e' e es a m+ . (Monad m, e :< es)+ => (e' -> e)+ -> m (Either e' a)+ -> Excepts es m a+lEM' f em = lift em >>= lE . first f+++fromEither :: Either a b -> VEither '[a] b+fromEither = either (VLeft . V) VRight+++liftIOException' :: ( MonadCatch m+ , MonadIO m+ , Monad m+ , e :< es'+ , LiftVariant es es'+ )+ => IOErrorType+ -> e+ -> Excepts es m a+ -> Excepts es' m a+liftIOException' errType ex =+ handleIO+ (\e ->+ if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e+ )+ . liftE+++liftIOException :: (MonadCatch m, MonadIO m, Monad m, e :< es')+ => IOErrorType+ -> e+ -> m a+ -> Excepts es' m a+liftIOException errType ex =+ handleIO+ (\e ->+ if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e+ )+ . lift+++-- | Uses safe-exceptions.+hideError :: (MonadIO m, MonadCatch m) => IOErrorType -> m () -> m ()+hideError err = handleIO (\e -> if err == ioeGetErrorType e then pure () else liftIO . ioError $ e)+++hideErrorDef :: (MonadIO m, MonadCatch m) => [IOErrorType] -> a -> m a -> m a+hideErrorDef errs def =+ handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else liftIO $ ioError e)+++hideErrorDefM :: (MonadIO m, MonadCatch m) => [IOErrorType] -> m a -> m a -> m a+hideErrorDefM errs def =+ handleIO (\e -> if ioeGetErrorType e `elem` errs then def else liftIO $ ioError e)+++-- TODO: does this work?+hideExcept :: forall e es es' a m+ . (Monad m, e :< es, LiftVariant (Remove e es) es')+ => e+ -> a+ -> Excepts es m a+ -> Excepts es' m a+hideExcept _ a =+ catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a))+++hideExcept' :: forall e es es' m+ . (Monad m, e :< es, LiftVariant (Remove e es) es')+ => e+ -> Excepts es m ()+ -> Excepts es' m ()+hideExcept' _ =+ catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ()))+++reThrowAll :: forall e es es' a m+ . (Monad m, e :< es')+ => (V es -> e)+ -> Excepts es m a+ -> Excepts es' m a+reThrowAll f = catchAllE (throwE . f)+++reThrowAllIO :: forall e es es' a m+ . (MonadCatch m, Monad m, MonadIO m, e :< es')+ => (V es -> e)+ -> (IOException -> e)+ -> Excepts es m a+ -> Excepts es' m a+reThrowAllIO f g = handleIO (throwE . g) . catchAllE (throwE . f)+++throwEither :: (Exception a, MonadThrow m) => Either a b -> m b+throwEither a = case a of+ Left e -> throwM e+ Right r -> pure r+++throwEither' :: (Exception a, MonadThrow m) => a -> Either x b -> m b+throwEither' e eth = case eth of+ Left _ -> throwM e+ Right r -> pure r++throwMaybe :: (Exception a, MonadThrow m) => a -> Maybe b -> m b+throwMaybe a m = case m of+ Nothing -> throwM a+ Just r -> pure r++throwMaybeM :: (Exception a, MonadThrow m) => a -> m (Maybe b) -> m b+throwMaybeM a am = do+ m <- am+ throwMaybe a m+++verToBS :: Version -> ByteString+verToBS = E.encodeUtf8 . prettyVer++verToS :: Version -> String+verToS = T.unpack . prettyVer++intToText :: Integral a => a -> T.Text+intToText = TL.toStrict . B.toLazyText . B.decimal++++-- | Safe 'decodeUtf8With'. Replaces an invalid input byte with+-- the Unicode replacement character U+FFFD.+decUTF8Safe :: ByteString -> Text+decUTF8Safe = E.decodeUtf8With E.lenientDecode++decUTF8Safe' :: L.ByteString -> Text+decUTF8Safe' = TL.toStrict . TLE.decodeUtf8With E.lenientDecode+++-- | Escape a version for use in regex+escapeVerRex :: Version -> ByteString+escapeVerRex = B.pack . go . B.unpack . verToBS+ where+ go [] = []+ go (x : xs) | x == _period = [_backslash, _period] ++ go xs+ | otherwise = x : go xs++++recover :: (MonadIO m, MonadMask m) => m a -> m a+recover action = + recovering (fullJitterBackoff 25000 <> limitRetries 10)+ [\_ -> Handler (\e -> pure $ isPermissionError e)+ ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))+ ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))+ ]+ (\_ -> action)+++-- | Gathering monoidal values+--+-- >>> traverseFold (pure . (:["0"])) ["1","2"]+-- ["1","0","2","0"]+-- >>> traverseFold Just ["1","2","3","4","5"]+-- Just "12345"+--+-- prop> \t -> traverseFold Just t === Just (mconcat t)+traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b+traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)++-- | Gathering monoidal values+forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b+forFold = \t -> (`traverseFold` t)+++-- | Strip @\\r@ and @\\n@ from 'String's+--+-- >>> stripNewline "foo\n\n\n"+-- "foo"+-- >>> stripNewline "foo\n\n\nfoo"+-- "foofoo"+-- >>> stripNewline "foo\r"+-- "foo"+-- >>> stripNewline "foo"+-- "foo"+--+-- prop> \t -> stripNewline (t <> "\n") === stripNewline t+-- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewline t == t+stripNewline :: String -> String+stripNewline = filter (`notElem` "\n\r")+++-- | Strip @\\r@ and @\\n@ from end of 'String'.+--+-- >>> stripNewlineEnd "foo\n\n\n"+-- "foo"+-- >>> stripNewlineEnd "foo\n\n\nfoo"+-- "foo\n\n\nfoo"+-- >>> stripNewlineEnd "foo\r"+-- "foo"+-- >>> stripNewlineEnd "foo"+-- "foo"+--+-- prop> \t -> stripNewlineEnd (t <> "\n") === stripNewlineEnd t+-- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewlineEnd t == t+stripNewlineEnd :: String -> String+stripNewlineEnd = dropWhileEnd (`elem` "\n\r")+++-- | Strip @\\r@ and @\\n@ from 'Text's+--+-- >>> stripNewline' "foo\n\n\n"+-- "foo"+-- >>> stripNewline' "foo\n\n\nfoo"+-- "foofoo"+-- >>> stripNewline' "foo\r"+-- "foo"+-- >>> stripNewline' "foo"+-- "foo"+--+-- prop> \t -> stripNewline' (t <> "\n") === stripNewline' t+-- prop> \t -> not (T.any (isNewLine . c2w) t) ==> stripNewline' t == t+stripNewline' :: T.Text -> T.Text+stripNewline' = T.filter (`notElem` "\n\r")+++-- | Is the word8 a newline?+--+-- >>> isNewLine (c2w '\n')+-- True+-- >>> isNewLine (c2w '\r')+-- True+--+-- prop> \w -> w /= _lf && w /= _cr ==> not (isNewLine w)+isNewLine :: Word8 -> Bool+isNewLine w+ | w == _lf = True+ | w == _cr = True+ | otherwise = False+++-- | Split on a PVP suffix.+--+-- >>> splitOnPVP "-" "ghc-iserv-dyn-9.3.20210706"+-- ("ghc-iserv-dyn","9.3.20210706")+-- >>> splitOnPVP "-" "ghc-iserv-dyn"+-- ("ghc-iserv-dyn","")+splitOnPVP :: String -> String -> (String, String)+splitOnPVP c s = case Split.splitOn c s of+ [] -> def+ [_] -> def+ xs+ | let l = last xs+ , (Right _) <- pvp (T.pack l) -> (intercalate c (init xs), l)+ | otherwise -> def+ where+ def = (s, "")++++-- | Like 'find', but where the test can be monadic.+--+-- >>> findM (Just . C.isUpper) "teST"+-- Just (Just 'S')+-- >>> findM (Just . C.isUpper) "test"+-- Just Nothing+-- >>> findM (Just . const True) ["x",undefined]+-- Just (Just "x")+findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)+findM ~p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing)+++-- | Drops the given suffix from a list.+-- It returns the original sequence if the sequence doesn't end with the given suffix.+--+-- >>> dropSuffix "!" "Hello World!"+-- "Hello World"+-- >>> dropSuffix "!" "Hello World!!"+-- "Hello World!"+-- >>> dropSuffix "!" "Hello World."+-- "Hello World."+dropSuffix :: Eq a => [a] -> [a] -> [a]+dropSuffix a b = fromMaybe b $ stripSuffix a b++-- | Return the prefix of the second list if its suffix+-- matches the entire first list.+--+-- >>> stripSuffix "bar" "foobar"+-- Just "foo"+-- >>> stripSuffix "" "baz"+-- Just "baz"+-- >>> stripSuffix "foo" "quux"+-- Nothing+stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]+stripSuffix a b = reverse <$> stripPrefix (reverse a) (reverse b)+++-- | Drops the given prefix from a list.+-- It returns the original sequence if the sequence doesn't start with the given prefix.+--+-- >>> dropPrefix "Mr. " "Mr. Men"+-- "Men"+-- >>> dropPrefix "Mr. " "Dr. Men"+-- "Dr. Men"+dropPrefix :: Eq a => [a] -> [a] -> [a]+dropPrefix a b = fromMaybe b $ stripPrefix a b++++-- | Break a list into pieces separated by the first+-- list argument, consuming the delimiter. An empty delimiter is+-- invalid, and will cause an error to be raised.+--+-- >>> splitOn "\r\n" "a\r\nb\r\nd\r\ne"+-- ["a","b","d","e"]+-- >>> splitOn "aaa" "aaaXaaaXaaaXaaa"+-- ["","X","X","X",""]+-- >>> splitOn "x" "x"+-- ["",""]+-- >>> splitOn "x" ""+-- [""]+--+-- prop> \s x -> s /= "" ==> intercalate s (splitOn s x) == x+-- prop> \c x -> splitOn [c] x == split (==c) x+splitOn :: Eq a => [a] -> [a] -> [[a]]+splitOn [] _ = error "splitOn, needle may not be empty"+splitOn _ [] = [[]]+splitOn needle haystack = a : if null b then [] else splitOn needle $ drop (length needle) b+ where (a,b) = breakOn needle haystack+++-- | Splits a list into components delimited by separators,+-- where the predicate returns True for a separator element. The+-- resulting components do not contain the separators. Two adjacent+-- separators result in an empty component in the output.+--+-- >>> split (== 'a') "aabbaca"+-- ["","","bb","c",""]+-- >>> split (== 'a') ""+-- [""]+-- >>> split (== ':') "::xyz:abc::123::"+-- ["","","xyz","abc","","123","",""]+-- >>> split (== ',') "my,list,here"+-- ["my","list","here"]+split :: (a -> Bool) -> [a] -> [[a]]+split _ [] = [[]]+split f (x:xs)+ | f x = [] : split f xs+ | y:ys <- split f xs = (x:y) : ys+ | otherwise = [[]]+++-- | Find the first instance of @needle@ in @haystack@.+-- The first element of the returned tuple+-- is the prefix of @haystack@ before @needle@ is matched. The second+-- is the remainder of @haystack@, starting with the match.+-- If you want the remainder /without/ the match, use 'stripInfix'.+--+-- >>> breakOn "::" "a::b::c"+-- ("a","::b::c")+-- >>> breakOn "/" "foobar"+-- ("foobar","")+--+-- prop> \needle haystack -> let (prefix,match) = breakOn needle haystack in prefix ++ match == haystack+breakOn :: Eq a => [a] -> [a] -> ([a], [a])+breakOn needle haystack | needle `isPrefixOf` haystack = ([], haystack)+breakOn _ [] = ([], [])+breakOn needle (x:xs) = first (x:) $ breakOn needle xs
+ lib/GHCup/Prelude/Logger.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+Module : GHCup.Utils.Logger+Description : logger definition+Copyright : (c) Julian Ospald, 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : portable++Here we define our main logger.+-}+module GHCup.Prelude.Logger+ ( module GHCup.Prelude.Logger+ , module GHCup.Prelude.Logger.Internal+ )+where++import GHCup.Prelude.Logger.Internal+import GHCup.Types+import GHCup.Types.Optics+import GHCup.Utils.Dirs (fromGHCupPath)+import GHCup.Prelude.Internal+import GHCup.Prelude.File.Search (findFiles)+import GHCup.Prelude.File (recycleFile)+import GHCup.Prelude.String.QQ++import Control.Exception.Safe+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader+import Prelude hiding ( appendFile )+import System.FilePath+import System.IO.Error+import Text.Regex.Posix++import qualified Data.ByteString as B++++initGHCupFileLogging :: ( MonadReader env m+ , HasDirs env+ , MonadIO m+ , MonadMask m+ ) => m FilePath+initGHCupFileLogging = do+ Dirs { logsDir } <- getDirs+ let logfile = fromGHCupPath logsDir </> "ghcup.log"+ logFiles <- liftIO $ findFiles+ (fromGHCupPath logsDir)+ (makeRegexOpts compExtended+ execBlank+ ([s|^.*\.log$|] :: B.ByteString)+ )+ forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (fromGHCupPath logsDir </>)++ liftIO $ writeFile logfile ""+ pure logfile
+ lib/GHCup/Prelude/Logger/Internal.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+Module : GHCup.Utils.Logger.Internal+Description : logger definition+Copyright : (c) Julian Ospald, 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : portable++Breaking import cycles.+-}+module GHCup.Prelude.Logger.Internal where++import GHCup.Types+import GHCup.Types.Optics++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader+import Data.Text ( Text )+import Optics+import Prelude hiding ( appendFile )+import System.Console.Pretty++import qualified Data.Text as T++logInfo :: ( MonadReader env m+ , LabelOptic' "loggerConfig" A_Lens env LoggerConfig+ , MonadIO m+ )+ => Text+ -> m ()+logInfo = logInternal Info++logWarn :: ( MonadReader env m+ , LabelOptic' "loggerConfig" A_Lens env LoggerConfig+ , MonadIO m+ )+ => Text+ -> m ()+logWarn = logInternal Warn++logDebug :: ( MonadReader env m+ , LabelOptic' "loggerConfig" A_Lens env LoggerConfig+ , MonadIO m+ )+ => Text+ -> m ()+logDebug = logInternal Debug++logError :: ( MonadReader env m+ , LabelOptic' "loggerConfig" A_Lens env LoggerConfig+ , MonadIO m+ )+ => Text+ -> m ()+logError = logInternal Error+++logInternal :: ( MonadReader env m+ , LabelOptic' "loggerConfig" A_Lens env LoggerConfig+ , MonadIO m+ ) => LogLevel+ -> Text+ -> m ()+logInternal logLevel msg = do+ LoggerConfig {..} <- gets @"loggerConfig"+ let color' c = if fancyColors then color c else id+ let style' = case logLevel of+ Debug -> style Bold . color' Blue+ Info -> style Bold . color' Green+ Warn -> style Bold . color' Yellow+ Error -> style Bold . color' Red+ let l = case logLevel of+ Debug -> style' "[ Debug ]"+ Info -> style' "[ Info ]"+ Warn -> style' "[ Warn ]"+ Error -> style' "[ Error ]"+ let strs = T.split (== '\n') msg+ let out = case strs of+ [] -> T.empty+ (x:xs) ->+ foldr (\a b -> a <> "\n" <> b) mempty+ . ((l <> " " <> x) :)+ . fmap (\line' -> style' "[ ... ] " <> line' )+ $ xs++ when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug)))+ $ liftIO $ consoleOutter out++ -- raw output+ let lr = case logLevel of+ Debug -> "Debug:"+ Info -> "Info:"+ Warn -> "Warn:"+ Error -> "Error:"+ let outr = lr <> " " <> msg <> "\n"+ liftIO $ fileOutter outr+
+ lib/GHCup/Prelude/MegaParsec.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+Module : GHCup.Utils.MegaParsec+Description : MegaParsec utilities+Copyright : (c) Julian Ospald, 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : portable+-}+module GHCup.Prelude.MegaParsec where++import GHCup.Types++import Control.Applicative+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail ( MonadFail )+#endif+import Data.Functor+import Data.Maybe+import Data.Text ( Text )+import Data.Versions+import Data.Void+import System.FilePath++import qualified Data.List.NonEmpty as NE+import qualified Data.Text as T+import qualified Text.Megaparsec as MP+++choice' :: (MonadFail f, MP.MonadParsec e s f) => [f a] -> f a+choice' [] = fail "Empty list"+choice' [x ] = x+choice' (x : xs) = MP.try x <|> choice' xs+++parseUntil :: MP.Parsec Void Text a -> MP.Parsec Void Text Text+parseUntil p = do+ (MP.try (MP.lookAhead p) $> mempty)+ <|> (do+ c <- T.singleton <$> MP.anySingle+ c2 <- parseUntil p+ pure (c `mappend` c2)+ )++parseUntil1 :: MP.Parsec Void Text a -> MP.Parsec Void Text Text+parseUntil1 p = do+ i1 <- MP.getOffset+ t <- parseUntil p+ i2 <- MP.getOffset+ if i1 == i2 then fail "empty parse" else pure t++++-- | Parses e.g.+-- * armv7-unknown-linux-gnueabihf-ghc+-- * armv7-unknown-linux-gnueabihf-ghci+ghcTargetBinP :: Text -> MP.Parsec Void Text (Maybe Text, Text)+ghcTargetBinP t =+ (,)+ <$> ( MP.try+ (Just <$> parseUntil1 (MP.chunk "-" *> MP.chunk t) <* MP.chunk "-"+ )+ <|> ((\ _ x -> x) Nothing <$> mempty)+ )+ <*> (MP.chunk t <* MP.eof)+++-- | Extracts the version from @ProjectVersion="8.10.5"@.+ghcProjectVersion :: MP.Parsec Void Text Version+ghcProjectVersion = do+ _ <- MP.chunk "ProjectVersion=\""+ ver <- parseUntil1 $ MP.chunk "\""+ MP.setInput ver+ version'+++-- | Extracts target triple and version from e.g.+-- * armv7-unknown-linux-gnueabihf-8.8.3+-- * armv7-unknown-linux-gnueabihf-8.8.3+ghcTargetVerP :: MP.Parsec Void Text GHCTargetVersion+ghcTargetVerP =+ (\x y -> GHCTargetVersion x y)+ <$> (MP.try (Just <$> parseUntil1 (MP.chunk "-" *> verP') <* MP.chunk "-")+ <|> ((\ _ x -> x) Nothing <$> mempty)+ )+ <*> (version' <* MP.eof)+ where+ verP' :: MP.Parsec Void Text Text+ verP' = do+ v <- version'+ let startsWithDigists =+ and+ . take 3+ . concatMap+ (map+ (\case+ (Digits _) -> True+ (Str _) -> False+ ) . NE.toList)+ . NE.toList+ $ _vChunks v+ if startsWithDigists && isNothing (_vEpoch v)+ then pure $ prettyVer v+ else fail "Oh"+++verP :: MP.Parsec Void Text Text -> MP.Parsec Void Text Versioning+verP suffix = do+ ver <- parseUntil suffix+ if T.null ver+ then fail "empty version"+ else do+ rest <- MP.getInput+ MP.setInput ver+ v <- versioning'+ MP.setInput rest+ pure v+++pathSep :: MP.Parsec Void Text Char+pathSep = MP.oneOf pathSeparators
+ lib/GHCup/Prelude/Posix.hs view
@@ -0,0 +1,19 @@+module GHCup.Prelude.Posix where+++-- | Enables ANSI support on windows, does nothing on unix.+--+-- Returns 'Left str' on errors and 'Right bool' on success, where+-- 'bool' markes whether ansi support was already enabled.+--+-- This function never crashes.+--+-- Rip-off of https://docs.rs/ansi_term/0.12.1/x86_64-pc-windows-msvc/src/ansi_term/windows.rs.html#10-61+enableAnsiSupport :: IO (Either String Bool)+enableAnsiSupport = pure (Right True)++isWindows, isNotWindows :: Bool+isWindows = False+isNotWindows = not isWindows++
+ lib/GHCup/Prelude/Process.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE CPP #-}++{-|+Module : GHCup.Utils.Process+Description : Process handling+Copyright : (c) Julian Ospald, 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : portable+-}+module GHCup.Prelude.Process (+ executeOut,+ execLogged,+ exec,+ toProcessError,+) where+++#if IS_WINDOWS+import GHCup.Prelude.Process.Windows+#else+import GHCup.Prelude.Process.Posix+#endif+
+ lib/GHCup/Prelude/Process/Posix.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE CApiFFI #-}++{-|+Module : GHCup.Utils.File.Posix+Description : Process handling for unix+Copyright : (c) Julian Ospald, 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : POSIX+-}+module GHCup.Prelude.Process.Posix where++import GHCup.Utils.Dirs+import GHCup.Prelude.File+import GHCup.Prelude.File.Posix+import GHCup.Prelude+import GHCup.Prelude.Logger+import GHCup.Types+import GHCup.Types.Optics++import Control.Concurrent+import Control.Concurrent.Async+import qualified Control.Exception as E+import Control.Exception.Safe+import Control.Monad+import Control.Monad.Reader+import Control.Monad.Trans.State.Strict+import Data.ByteString ( ByteString )+import Data.Foldable+import Data.IORef+import Data.Sequence ( Seq, (|>) )+import Data.List+import Data.Word8+import GHC.IO.Exception+import System.IO ( stderr )+import System.IO.Error hiding ( catchIOError )+import System.FilePath+import System.Posix.Directory+import System.Posix.IO+import System.Posix.Process ( ProcessStatus(..) )+import System.Posix.Types+++import qualified Control.Exception as EX+import qualified Data.Sequence as Sq+import qualified Data.Text as T+import qualified Data.Text.Encoding as E+import qualified System.Posix.Process as SPP+import qualified System.Console.Terminal.Size as TP+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified "unix-bytestring" System.Posix.IO.ByteString+ as SPIB++++-- | Execute the given command and collect the stdout, stderr and the exit code.+-- The command is run in a subprocess.+executeOut :: MonadIO m+ => FilePath -- ^ command as filename, e.g. 'ls'+ -> [String] -- ^ arguments to the command+ -> Maybe FilePath -- ^ chdir to this path+ -> m CapturedProcess+executeOut path args chdir = liftIO $ captureOutStreams $ do+ maybe (pure ()) changeWorkingDirectory chdir+ SPP.executeFile path True args Nothing+++execLogged :: ( MonadReader env m+ , HasSettings env+ , HasLog env+ , HasDirs env+ , MonadIO m+ , MonadThrow m)+ => FilePath -- ^ thing to execute+ -> [String] -- ^ args for the thing+ -> Maybe FilePath -- ^ optionally chdir into this+ -> FilePath -- ^ log filename (opened in append mode)+ -> Maybe [(String, String)] -- ^ optional environment+ -> m (Either ProcessError ())+execLogged exe args chdir lfile env = do+ Settings {..} <- getSettings+ Dirs {..} <- getDirs+ logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args+ let logfile = fromGHCupPath logsDir </> lfile <> ".log"+ liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })+ closeFd+ (action verbose noColor)+ where+ action verbose no_color fd = do+ actionWithPipes $ \(stdoutRead, stdoutWrite) -> do+ -- start the thread that logs to stdout+ pState <- newEmptyMVar+ done <- newEmptyMVar+ void+ $ forkIO+ $ EX.handle (\(_ :: IOException) -> pure ())+ $ EX.finally+ (if verbose+ then tee fd stdoutRead+ else printToRegion fd stdoutRead 6 pState no_color+ )+ (putMVar done ())++ -- fork the subprocess+ pid <- SPP.forkProcess $ do+ void $ dupTo stdoutWrite stdOutput+ void $ dupTo stdoutWrite stdError+ closeFd stdoutRead+ closeFd stdoutWrite++ -- execute the action+ maybe (pure ()) changeWorkingDirectory chdir+ void $ SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env++ closeFd stdoutWrite++ -- wait for the subprocess to finish+ e <- toProcessError exe args <$!> SPP.getProcessStatus True True pid+ putMVar pState (either (const False) (const True) e)++ void $ race (takeMVar done) (threadDelay (1000000 * 3))+ closeFd stdoutRead++ pure e++ tee :: Fd -> Fd -> IO ()+ tee fileFd = readTilEOF lineAction++ where+ lineAction :: ByteString -> IO ()+ lineAction bs' = do+ void $ SPIB.fdWrite fileFd (bs' <> "\n")+ void $ SPIB.fdWrite stdOutput (bs' <> "\n")++ -- Reads fdIn and logs the output in a continous scrolling area+ -- of 'size' terminal lines. Also writes to a log file.+ printToRegion :: Fd -> Fd -> Int -> MVar Bool -> Bool -> IO ()+ printToRegion fileFd fdIn size pState no_color = do+ -- init region+ forM_ [1..size] $ \_ -> BS.hPut stderr "\n"++ void $ flip runStateT mempty+ $ do+ handle+ (\(ex :: SomeException) -> do+ ps <- liftIO $ takeMVar pState+ when ps (liftIO $ BS.hPut stderr (pos1 <> moveLineUp size <> clearScreen))+ throw ex+ ) $ readTilEOF lineAction fdIn++ where+ clearScreen :: ByteString+ clearScreen = "\x1b[0J"+ clearLine :: ByteString+ clearLine = "\x1b[2K"+ moveLineUp :: Int -> ByteString+ moveLineUp n = "\x1b[" <> E.encodeUtf8 (T.pack (show n)) <> "A"+ moveLineDown :: Int -> ByteString+ moveLineDown n = "\x1b[" <> E.encodeUtf8 (T.pack (show n)) <> "B"+ pos1 :: ByteString+ pos1 = "\r"+ overwriteNthLine :: Int -> ByteString -> ByteString+ overwriteNthLine n str = pos1 <> moveLineUp n <> clearLine <> str <> moveLineDown n <> pos1++ blue :: ByteString -> ByteString+ blue bs + | no_color = bs+ | otherwise = "\x1b[0;34m" <> bs <> "\x1b[0m"++ -- action to perform line by line+ lineAction :: (MonadMask m, MonadIO m)+ => ByteString+ -> StateT (Seq ByteString) m ()+ lineAction = \bs' -> do+ void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")+ modify (swapRegs bs')+ liftIO TP.size >>= \case+ Nothing -> pure ()+ Just (TP.Window _ w) -> do+ regs <- get+ liftIO $ forM_ (Sq.zip regs (Sq.fromList [0..(Sq.length regs - 1)])) $ \(bs, i) -> do+ BS.hPut stderr+ . overwriteNthLine (size - i)+ . trim w+ . blue+ . (\b -> "[ " <> E.encodeUtf8 (T.pack lfile) <> " ] " <> b)+ $ bs++ swapRegs :: a -> Seq a -> Seq a+ swapRegs bs = \regs -> if+ | Sq.length regs < size -> regs |> bs+ | otherwise -> Sq.drop 1 regs |> bs++ -- trim output line to terminal width+ trim :: Int -> ByteString -> ByteString+ trim w = \bs -> if+ | BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."+ | otherwise -> bs++ -- Consecutively read from Fd in 512 chunks until we hit+ -- newline or EOF.+ readLine :: MonadIO m+ => Fd -- ^ input file descriptor+ -> ByteString -- ^ rest buffer (read across newline)+ -> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)+ readLine fd = go+ where+ go inBs = do+ -- if buffer is not empty, process it first+ mbs <- if BS.length inBs == 0+ -- otherwise attempt read+ then liftIO+ $ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)+ $ fmap Just+ $ SPIB.fdRead fd 512+ else pure $ Just inBs+ case mbs of+ Nothing -> pure ("", "", True)+ Just bs -> do+ -- split on newline+ let (line, rest) = BS.span (/= _lf) bs+ if+ | BS.length rest /= 0 -> pure (line, BS.tail rest, False)+ -- if rest is empty, then there was no newline, process further+ | otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty++ readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()+ readTilEOF ~action' fd' = go mempty+ where+ go bs' = do+ (bs, rest, eof) <- readLine fd' bs'+ if eof+ then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)+ else void (action' bs) >> go rest+++-- | Capture the stdout and stderr of the given action, which+-- is run in a subprocess. Stdin is closed. You might want to+-- 'race' this to make sure it terminates.+captureOutStreams :: IO a+ -- ^ the action to execute in a subprocess+ -> IO CapturedProcess+captureOutStreams action = do+ actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->+ actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do+ pid <- SPP.forkProcess $ do+ -- dup stdout+ void $ dupTo childStdoutWrite stdOutput+ closeFd childStdoutWrite+ closeFd parentStdoutRead++ -- dup stderr+ void $ dupTo childStderrWrite stdError+ closeFd childStderrWrite+ closeFd parentStderrRead++ -- execute the action+ a <- action+ void $ E.evaluate a++ -- close everything we don't need+ closeFd childStdoutWrite+ closeFd childStderrWrite++ -- start thread that writes the output+ refOut <- newIORef BL.empty+ refErr <- newIORef BL.empty+ done <- newEmptyMVar+ _ <-+ forkIO+ $ EX.handle (\(_ :: IOException) -> pure ())+ $ flip EX.finally (putMVar done ())+ $ writeStds parentStdoutRead parentStderrRead refOut refErr++ status <- SPP.getProcessStatus True True pid+ void $ race (takeMVar done) (threadDelay (1000000 * 3))++ case status of+ -- readFd will take care of closing the fd+ Just (SPP.Exited es) -> do+ stdout' <- readIORef refOut+ stderr' <- readIORef refErr+ pure $ CapturedProcess { _exitCode = es+ , _stdOut = stdout'+ , _stdErr = stderr'+ }++ _ -> throwIO $ userError ("No such PID " ++ show pid)++ where+ writeStds :: Fd -> Fd -> IORef BL.ByteString -> IORef BL.ByteString -> IO ()+ writeStds pout perr rout rerr = do+ doneOut <- newEmptyMVar+ void+ $ forkIO+ $ hideError eofErrorType+ $ flip EX.finally (putMVar doneOut ())+ $ readTilEOF (\x -> modifyIORef' rout (<> BL.fromStrict x)) pout+ doneErr <- newEmptyMVar+ void+ $ forkIO+ $ hideError eofErrorType+ $ flip EX.finally (putMVar doneErr ())+ $ readTilEOF (\x -> modifyIORef' rerr (<> BL.fromStrict x)) perr+ takeMVar doneOut+ takeMVar doneErr++ readTilEOF ~action' fd' = do+ bs <- SPIB.fdRead fd' 512+ void $ action' bs+ readTilEOF action' fd'+++actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b+actionWithPipes a =+ createPipe >>= \(p1, p2) -> flip finally (cleanup [p1, p2]) $ a (p1, p2)++cleanup :: [Fd] -> IO ()+cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd++++-- | Create a new regular file in write-only mode. The file must not exist.+createRegularFileFd :: FileMode -> FilePath -> IO Fd+createRegularFileFd fm dest =+ openFd dest WriteOnly (Just fm) defaultFileFlags{ exclusive = True }+++-- | Thin wrapper around `executeFile`.+exec :: MonadIO m+ => String -- ^ thing to execute+ -> [String] -- ^ args for the thing+ -> Maybe FilePath -- ^ optionally chdir into this+ -> Maybe [(String, String)] -- ^ optional environment+ -> m (Either ProcessError ())+exec exe args chdir env = liftIO $ do+ pid <- SPP.forkProcess $ do+ maybe (pure ()) changeWorkingDirectory chdir+ SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env++ fmap (toProcessError exe args) $ SPP.getProcessStatus True True pid+++toProcessError :: FilePath+ -> [String]+ -> Maybe ProcessStatus+ -> Either ProcessError ()+toProcessError exe args mps = case mps of+ Just (SPP.Exited (ExitFailure xi)) -> Left $ NonZeroExit xi exe args+ Just (SPP.Exited ExitSuccess ) -> Right ()+ Just (Terminated _ _ ) -> Left $ PTerminated exe args+ Just (Stopped _ ) -> Left $ PStopped exe args+ Nothing -> Left $ NoSuchPid exe args+++
+ lib/GHCup/Prelude/Process/Windows.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}++{-|+Module : GHCup.Utils.Process.Windows+Description : Process handling for windows+Copyright : (c) Julian Ospald, 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : Windows+-}+module GHCup.Prelude.Process.Windows where++import GHCup.Utils.Dirs+import GHCup.Prelude.File.Search+import GHCup.Prelude.Logger.Internal+import GHCup.Types+import GHCup.Types.Optics++import Control.Concurrent+import Control.DeepSeq+import Control.Exception.Safe+import Control.Monad+import Control.Monad.Reader+import Data.List+import Foreign.C.Error+import GHC.IO.Exception+import GHC.IO.Handle+import System.Environment+import System.FilePath+import System.IO+import System.Process++import qualified Control.Exception as EX+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+++++toProcessError :: FilePath+ -> [FilePath]+ -> ExitCode+ -> Either ProcessError ()+toProcessError exe args exitcode = case exitcode of+ (ExitFailure xi) -> Left $ NonZeroExit xi exe args+ ExitSuccess -> Right ()+++-- | @readCreateProcessWithExitCode@ works exactly like 'readProcessWithExitCode' except that it+-- lets you pass 'CreateProcess' giving better flexibility.+--+-- Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the CreateProcess+-- record will be ignored.+--+-- @since 1.2.3.0+readCreateProcessWithExitCodeBS+ :: CreateProcess+ -> BL.ByteString+ -> IO (ExitCode, BL.ByteString, BL.ByteString) -- ^ exitcode, stdout, stderr+readCreateProcessWithExitCodeBS cp input = do+ let cp_opts = cp {+ std_in = CreatePipe,+ std_out = CreatePipe,+ std_err = CreatePipe+ }+ withCreateProcess_ "readCreateProcessWithExitCodeBS" cp_opts $+ \mb_inh mb_outh mb_errh ph ->+ case (mb_inh, mb_outh, mb_errh) of+ (Just inh, Just outh, Just errh) -> do++ out <- BS.hGetContents outh+ err <- BS.hGetContents errh++ -- fork off threads to start consuming stdout & stderr+ withForkWait (EX.evaluate $ rnf out) $ \waitOut ->+ withForkWait (EX.evaluate $ rnf err) $ \waitErr -> do++ -- now write any input+ unless (BL.null input) $+ ignoreSigPipe $ BL.hPut inh input+ -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE+ ignoreSigPipe $ hClose inh++ -- wait on the output+ waitOut+ waitErr++ hClose outh+ hClose errh++ -- wait on the process+ ex <- waitForProcess ph+ return (ex, BL.fromStrict out, BL.fromStrict err)++ (Nothing,_,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdin handle."+ (_,Nothing,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdout handle."+ (_,_,Nothing) -> error "readCreateProcessWithExitCodeBS: Failed to get a stderr handle."+ where+ ignoreSigPipe :: IO () -> IO ()+ ignoreSigPipe = EX.handle $ \e -> case e of+ IOError { ioe_type = ResourceVanished+ , ioe_errno = Just ioe }+ | Errno ioe == ePIPE -> return ()+ _ -> throwIO e+ -- wrapper so we can get exceptions with the appropriate function name.+ withCreateProcess_+ :: String+ -> CreateProcess+ -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)+ -> IO a+ withCreateProcess_ fun c action =+ EX.bracketOnError (createProcess_ fun c) cleanupProcess+ (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)++-- | Fork a thread while doing something else, but kill it if there's an+-- exception.+--+-- This is important in the cases above because we want to kill the thread+-- that is holding the Handle lock, because when we clean up the process we+-- try to close that handle, which could otherwise deadlock.+--+withForkWait :: IO () -> (IO () -> IO a) -> IO a+withForkWait async' body = do+ waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))+ mask $ \restore -> do+ tid <- forkIO $ try (restore async') >>= putMVar waitVar+ let wait' = takeMVar waitVar >>= either throwIO return+ restore (body wait') `EX.onException` killThread tid+++-- | Execute the given command and collect the stdout, stderr and the exit code.+-- The command is run in a subprocess.+executeOut :: MonadIO m+ => FilePath -- ^ command as filename, e.g. 'ls'+ -> [String] -- ^ arguments to the command+ -> Maybe FilePath -- ^ chdir to this path+ -> m CapturedProcess+executeOut path args chdir = do+ cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir })+ (exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp ""+ pure $ CapturedProcess exit out err+++execLogged :: ( MonadReader env m+ , HasDirs env+ , HasLog env+ , HasSettings env+ , MonadIO m+ , MonadThrow m)+ => FilePath -- ^ thing to execute+ -> [String] -- ^ args for the thing+ -> Maybe FilePath -- ^ optionally chdir into this+ -> FilePath -- ^ log filename (opened in append mode)+ -> Maybe [(String, String)] -- ^ optional environment+ -> m (Either ProcessError ())+execLogged exe args chdir lfile env = do+ Dirs {..} <- getDirs+ logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args+ let stdoutLogfile = fromGHCupPath logsDir </> lfile <> ".stdout.log"+ stderrLogfile = fromGHCupPath logsDir </> lfile <> ".stderr.log"+ cp <- createProcessWithMingwPath ((proc exe args)+ { cwd = chdir+ , env = env+ , std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ })+ fmap (toProcessError exe args)+ $ liftIO+ $ withCreateProcess cp+ $ \_ mout merr ph ->+ case (mout, merr) of+ (Just cStdout, Just cStderr) -> do+ withForkWait (tee stdoutLogfile cStdout) $ \waitOut ->+ withForkWait (tee stderrLogfile cStderr) $ \waitErr -> do+ waitOut+ waitErr+ waitForProcess ph+ _ -> fail "Could not acquire out/err handle"++ where+ tee :: FilePath -> Handle -> IO ()+ tee logFile handle' = go+ where+ go = do+ some <- BS.hGetSome handle' 512+ if BS.null some+ then pure ()+ else do+ void $ BS.appendFile logFile some+ -- subprocess stdout also goes to stderr for logging+ void $ BS.hPut stderr some+ go+++-- | Thin wrapper around `executeFile`.+exec :: MonadIO m+ => FilePath -- ^ thing to execute+ -> [FilePath] -- ^ args for the thing+ -> Maybe FilePath -- ^ optionally chdir into this+ -> Maybe [(String, String)] -- ^ optional environment+ -> m (Either ProcessError ())+exec exe args chdir env = do+ -- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375+ forM_ (Map.fromList <$> env) $ \cEnv -> do+ let paths = ["PATH", "Path"]+ curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths+ newPath = intercalate [searchPathSeparator] curPaths+ liftIO $ setEnv "PATH" ""+ liftIO $ setEnv "Path" newPath+ cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env })+ exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p+ pure $ toProcessError exe args exit_code++-- | Like 'exec', except doesn't add msys2 stuff to PATH.+execNoMinGW :: MonadIO m+ => FilePath -- ^ thing to execute+ -> [FilePath] -- ^ args for the thing+ -> Maybe FilePath -- ^ optionally chdir into this+ -> Maybe [(String, String)] -- ^ optional environment+ -> m (Either ProcessError ())+execNoMinGW exe args chdir env = do+ -- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/375+ forM_ (Map.fromList <$> env) $ \cEnv -> do+ let paths = ["PATH", "Path"]+ curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths+ newPath = intercalate [searchPathSeparator] curPaths+ liftIO $ setEnv "PATH" ""+ liftIO $ setEnv "Path" newPath+ let cp = (proc exe args) { cwd = chdir, env = env }+ exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p+ pure $ toProcessError exe args exit_code+++-- | Thin wrapper around `executeFile`.+execShell :: MonadIO m+ => FilePath -- ^ thing to execute+ -> [FilePath] -- ^ args for the thing+ -> Maybe FilePath -- ^ optionally chdir into this+ -> Maybe [(String, String)] -- ^ optional environment+ -> m (Either ProcessError ())+execShell exe args chdir env = do+ let cmd = exe <> " " <> concatMap (' ':) args+ cp <- createProcessWithMingwPath ((shell cmd) { cwd = chdir, env = env })+ exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p+ pure $ toProcessError cmd [] exit_code+++createProcessWithMingwPath :: MonadIO m+ => CreateProcess+ -> m CreateProcess+createProcessWithMingwPath cp = do+ msys2Dir <- liftIO ghcupMsys2Dir+ cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp)+ let mingWPaths = [msys2Dir </> "mingw64" </> "bin"+ ,msys2Dir </> "usr" </> "bin"+ ]+ paths = ["PATH", "Path"]+ curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths+ newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths)+ envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths+ envWithNewPath = Map.insert "Path" newPath envWithoutPath+ liftIO $ setEnv "Path" newPath+ pure $ cp { env = Just $ Map.toList envWithNewPath }++ghcupMsys2Dir :: IO FilePath+ghcupMsys2Dir =+ lookupEnv "GHCUP_MSYS2" >>= \case+ Just fp -> pure fp+ Nothing -> do+ baseDir <- liftIO ghcupBaseDir+ pure (fromGHCupPath baseDir </> "msys64")+
+ lib/GHCup/Prelude/String/QQ.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE TemplateHaskellQuotes #-}++{-|+Module : GHCup.Utils.String.QQ+Description : String quasi quoters+Copyright : (c) Audrey Tang <audreyt@audreyt.org> 2019, Julian Ospald <hasufell@posteo.de> 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : portable++QuasiQuoter for non-interpolated strings, texts and bytestrings.++The "s" quoter contains a multi-line string with no interpolation at all,+except that the leading newline is trimmed and carriage returns stripped.++@+{-\# LANGUAGE QuasiQuotes #-}+import Data.Text (Text)+import Data.String.QQ+foo :: Text -- "String", "ByteString" etc also works+foo = [s|+Well here is a+ multi-line string!+|]+@++Any instance of the IsString type is permitted.++(For GHC versions 6, write "[$s||]" instead of "[s||]".)++-}+module GHCup.Prelude.String.QQ+ ( s+ )+where+++import Data.Char+import GHC.Exts ( IsString(..) )+import Language.Haskell.TH.Quote++-- | QuasiQuoter for a non-interpolating ASCII IsString literal.+-- The pattern portion is undefined.+s :: QuasiQuoter+s = QuasiQuoter+ (\s' -> case all isAscii s' of+ True -> (\a -> [|fromString a|]) . trimLeadingNewline . removeCRs $ s'+ False -> fail "Not ascii"+ )+ (error "Cannot use s as a pattern")+ (error "Cannot use s as a type")+ (error "Cannot use s as a dec")+ where+ removeCRs = filter (/= '\r')+ trimLeadingNewline ('\n' : xs) = xs+ trimLeadingNewline xs = xs
+ lib/GHCup/Prelude/Version/QQ.hs view
@@ -0,0 +1,107 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+++{-|+Module : GHCup.Utils.Version.QQ+Description : Version quasi-quoters+Copyright : (c) Julian Ospald, 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : portable+-}+module GHCup.Prelude.Version.QQ where++import Data.Data+import Data.Text ( Text )+import Data.Versions+#if !MIN_VERSION_base(4,13,0)+import GHC.Base+#endif+import Language.Haskell.TH+import Language.Haskell.TH.Quote ( QuasiQuoter(..) )+import Language.Haskell.TH.Syntax ( Lift+ , dataToExpQ+ )+import qualified Data.Text as T+import qualified Language.Haskell.TH.Syntax as TH++++deriving instance Data Versioning+deriving instance Lift Versioning+deriving instance Data Version+deriving instance Lift Version+deriving instance Data SemVer+deriving instance Lift SemVer+deriving instance Data Mess+deriving instance Lift Mess+deriving instance Data MChunk+deriving instance Lift MChunk+deriving instance Data PVP+deriving instance Lift PVP+deriving instance Lift VSep+deriving instance Data VSep+deriving instance Lift VUnit+deriving instance Data VUnit++#if !MIN_VERSION_base(4,13,0)+deriving instance Lift (NonEmpty Word)+deriving instance Lift (NonEmpty VChunk)+deriving instance Lift (NonEmpty MChunk)+deriving instance Lift (NonEmpty VUnit)+#endif++qq :: (Text -> Q Exp) -> QuasiQuoter+qq quoteExp' = QuasiQuoter+ { quoteExp = \s -> quoteExp' . T.pack $ s+ , quotePat = \_ ->+ fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"+ , quoteType = \_ ->+ fail "illegal QuasiQuote (allowed as expression only, used as a type)"+ , quoteDec = \_ -> fail+ "illegal QuasiQuote (allowed as expression only, used as a declaration)"+ }++vver :: QuasiQuoter+vver = qq mkV+ where+ mkV :: Text -> Q Exp+ mkV = either (fail . show) liftDataWithText . version++mver :: QuasiQuoter+mver = qq mkV+ where+ mkV :: Text -> Q Exp+ mkV = either (fail . show) liftDataWithText . mess++sver :: QuasiQuoter+sver = qq mkV+ where+ mkV :: Text -> Q Exp+ mkV = either (fail . show) liftDataWithText . semver++vers :: QuasiQuoter+vers = qq mkV+ where+ mkV :: Text -> Q Exp+ mkV = either (fail . show) liftDataWithText . versioning++pver :: QuasiQuoter+pver = qq mkV+ where+ mkV :: Text -> Q Exp+ mkV = either (fail . show) liftDataWithText . pvp++-- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable+liftText :: T.Text -> Q Exp+liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)++liftDataWithText :: Data a => a -> Q Exp+liftDataWithText = dataToExpQ (fmap liftText . cast)
+ lib/GHCup/Prelude/Windows.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module GHCup.Prelude.Windows where+++import Control.Exception.Safe+import Control.Monad+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail ( MonadFail )+#endif+import Data.Bits++import System.Win32.Console+import System.Win32.File hiding ( copyFile )+import System.Win32.Types+++++-- | Enables ANSI support on windows, does nothing on unix.+--+-- Returns 'Left str' on errors and 'Right bool' on success, where+-- 'bool' markes whether ansi support was already enabled.+--+-- This function never crashes.+--+-- Rip-off of https://docs.rs/ansi_term/0.12.1/x86_64-pc-windows-msvc/src/ansi_term/windows.rs.html#10-61+enableAnsiSupport :: IO (Either String Bool)+enableAnsiSupport = handleIO (pure . Left . displayException) $ do+ -- ref: https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilew+ -- Using `CreateFileW("CONOUT$", ...)` to retrieve the console handle works correctly even if STDOUT and/or STDERR are redirected+ h <- createFile "CONOUT$" (gENERIC_WRITE .|. gENERIC_READ)+ fILE_SHARE_WRITE Nothing oPEN_EXISTING 0 Nothing+ when (h == iNVALID_HANDLE_VALUE ) $ fail "invalid handle value"++ -- ref: https://docs.microsoft.com/en-us/windows/console/getconsolemode+ m <- getConsoleMode h++ -- VT processing not already enabled?+ if m .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING == 0+ -- https://docs.microsoft.com/en-us/windows/console/setconsolemode+ then setConsoleMode h (m .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING)+ >> pure (Right False)+ else pure (Right True)+++isWindows, isNotWindows :: Bool+isWindows = True+isNotWindows = not isWindows+
+ lib/GHCup/Prompts.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++module GHCup.Prompts+ ( PromptQuestion,+ PromptResponse (..),+ getUserPromptResponse,+ )+where++import Control.Monad.Reader+import qualified Data.Text.IO as TIO+import GHCup.Prelude.Logger+import GHCup.Types.Optics+import GHCup.Types (PromptQuestion, PromptResponse(..))++getUserPromptResponse :: ( HasLog env+ , MonadReader env m+ , MonadIO m)+ => PromptQuestion+ -> m PromptResponse++getUserPromptResponse prompt = do+ logInfo prompt+ resp <- liftIO TIO.getLine+ if resp `elem` ["YES", "yes", "y", "Y"]+ then pure PromptYes+ else pure PromptNo
+ lib/GHCup/Stack.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+Module : GHCup.Stack+Description : GHCup installation functions for Stack+Copyright : (c) Julian Ospald, 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : portable+-}+module GHCup.Stack where++import GHCup.Download+import GHCup.Errors+import GHCup.Types+import GHCup.Types.JSON ( )+import GHCup.Types.Optics+import GHCup.Utils+import GHCup.Prelude+import GHCup.Prelude.File+import GHCup.Prelude.Logger++import Codec.Archive ( ArchiveResult )+import Control.Applicative+import Control.Exception.Safe+import Control.Monad+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail ( MonadFail )+#endif+import Control.Monad.Reader+import Control.Monad.Trans.Resource+ hiding ( throwM )+import Data.Either+import Data.List+import Data.Maybe+import Data.Versions hiding ( patch )+import Haskus.Utils.Variant.Excepts+import Optics+import Prelude hiding ( abs+ , writeFile+ )+import Safe hiding ( at )+import System.FilePath+import System.IO.Error++import qualified Data.Text as T+import Text.PrettyPrint.HughesPJClass (prettyShow)++++ --------------------+ --[ Installation ]--+ --------------------+++-- | Installs stack into @~\/.ghcup\/bin/stack-\<ver\>@ and+-- creates a default @stack -> stack-x.y.z.q@ symlink for+-- the latest installed version.+installStackBin :: ( MonadMask m+ , MonadCatch m+ , MonadReader env m+ , HasDirs env+ , HasSettings env+ , HasPlatformReq env+ , HasGHCupInfo env+ , HasLog env+ , MonadResource m+ , MonadIO m+ , MonadUnliftIO m+ , MonadFail m+ )+ => Version+ -> InstallDir+ -> Bool -- ^ Force install+ -> Excepts+ '[ AlreadyInstalled+ , CopyError+ , DigestError+ , GPGError+ , DownloadFailed+ , NoDownload+ , NotInstalled+ , UnknownArchive+ , TarDirDoesNotExist+ , ArchiveResult+ , FileAlreadyExistsError+ ]+ m+ ()+installStackBin ver installDir forceInstall = do+ dlinfo <- liftE $ getDownloadInfo Stack ver+ installStackBindist dlinfo ver installDir forceInstall+++-- | Like 'installStackBin', except takes the 'DownloadInfo' as+-- argument instead of looking it up from 'GHCupDownloads'.+installStackBindist :: ( MonadMask m+ , MonadCatch m+ , MonadReader env m+ , HasPlatformReq env+ , HasDirs env+ , HasSettings env+ , HasLog env+ , MonadResource m+ , MonadIO m+ , MonadUnliftIO m+ , MonadFail m+ )+ => DownloadInfo+ -> Version+ -> InstallDir+ -> Bool -- ^ Force install+ -> Excepts+ '[ AlreadyInstalled+ , CopyError+ , DigestError+ , GPGError+ , DownloadFailed+ , NoDownload+ , NotInstalled+ , UnknownArchive+ , TarDirDoesNotExist+ , ArchiveResult+ , FileAlreadyExistsError+ ]+ m+ ()+installStackBindist dlinfo ver installDir forceInstall = do+ lift $ logDebug $ "Requested to install stack version " <> prettyVer ver++ PlatformRequest {..} <- lift getPlatformReq+ Dirs {..} <- lift getDirs++ regularStackInstalled <- lift $ stackInstalled ver++ if+ | not forceInstall+ , regularStackInstalled+ , GHCupInternal <- installDir -> do+ throwE $ AlreadyInstalled Stack ver++ | forceInstall+ , regularStackInstalled+ , GHCupInternal <- installDir -> do+ lift $ logInfo "Removing the currently installed version of Stack first!"+ liftE $ rmStackVer ver++ | otherwise -> pure ()++ -- download (or use cached version)+ dl <- liftE $ downloadCached dlinfo Nothing++ -- unpack+ tmpUnpack <- lift withGHCupTmpDir+ liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl)+ liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack)++ -- the subdir of the archive where we do the work+ workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)++ case installDir of+ IsolateDir isoDir -> do -- isolated install+ lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir+ liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall+ GHCupInternal -> do -- regular install+ liftE $ installStackUnpacked workdir (GHCupBinDir binDir) ver forceInstall+++-- | Install an unpacked stack distribution.+installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)+ => GHCupPath -- ^ Path to the unpacked stack bindist (where the executable resides)+ -> InstallDirResolved+ -> Version+ -> Bool -- ^ Force install+ -> Excepts '[CopyError, FileAlreadyExistsError] m ()+installStackUnpacked path installDir ver forceInstall = do+ lift $ logInfo "Installing stack"+ let stackFile = "stack"+ liftIO $ createDirRecursive' (fromInstallDir installDir)+ let destFileName = stackFile+ <> (case installDir of+ IsolateDirResolved _ -> ""+ _ -> ("-" <>) . T.unpack . prettyVer $ ver+ )+ <> exeExt+ destPath = fromInstallDir installDir </> destFileName++ copyFileE+ (fromGHCupPath path </> stackFile <> exeExt)+ destPath+ (not forceInstall)+ lift $ chmod_755 destPath++++ -----------------+ --[ Set stack ]--+ -----------------+++-- | Set the @~\/.ghcup\/bin\/stack@ symlink.+setStack :: ( MonadMask m+ , MonadReader env m+ , HasDirs env+ , HasLog env+ , MonadThrow m+ , MonadFail m+ , MonadIO m+ , MonadUnliftIO m+ )+ => Version+ -> Excepts '[NotInstalled] m ()+setStack ver = do+ let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt++ -- symlink destination+ Dirs {..} <- lift getDirs++ whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))+ $ throwE+ $ NotInstalled Stack (GHCTargetVersion Nothing ver)++ let stackbin = binDir </> "stack" <> exeExt++ lift $ createLink targetFile stackbin++ liftIO (isShadowed stackbin) >>= \case+ Nothing -> pure ()+ Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed Cabal pa stackbin ver)++ pure ()+++unsetStack :: ( MonadMask m+ , MonadReader env m+ , HasDirs env+ , MonadIO m)+ => m ()+unsetStack = do+ Dirs {..} <- getDirs+ let stackbin = binDir </> "stack" <> exeExt+ hideError doesNotExistErrorType $ rmLink stackbin+++ ----------------+ --[ Rm stack ]--+ ----------------++-- | Delete a stack version. Will try to fix the @stack@ symlink+-- after removal (e.g. setting it to an older version).+rmStackVer :: ( MonadMask m+ , MonadReader env m+ , HasDirs env+ , MonadThrow m+ , HasLog env+ , MonadIO m+ , MonadFail m+ , MonadCatch m+ , MonadUnliftIO m+ )+ => Version+ -> Excepts '[NotInstalled] m ()+rmStackVer ver = do+ whenM (lift $ fmap not $ stackInstalled ver) $ throwE (NotInstalled Stack (GHCTargetVersion Nothing ver))++ sSet <- lift stackSet++ Dirs {..} <- lift getDirs++ let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt+ lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> stackFile)++ when (Just ver == sSet) $ do+ sVers <- lift $ fmap rights getInstalledStacks+ case headMay . reverse . sort $ sVers of+ Just latestver -> setStack latestver+ Nothing -> lift $ rmLink (binDir </> "stack" <> exeExt)
lib/GHCup/Types.hs view
@@ -26,6 +26,8 @@ ) where +import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath, GHCupPath )+ import Control.DeepSeq ( NFData, rnf ) import Data.Map.Strict ( Map ) import Data.List.NonEmpty ( NonEmpty (..) )@@ -405,6 +407,9 @@ instance NFData AppState +fromAppState :: AppState -> LeanAppState+fromAppState AppState {..} = LeanAppState {..}+ data LeanAppState = LeanAppState { settings :: Settings , dirs :: Dirs@@ -438,12 +443,14 @@ instance NFData Settings data Dirs = Dirs- { baseDir :: FilePath- , binDir :: FilePath- , cacheDir :: FilePath- , logsDir :: FilePath- , confDir :: FilePath- , recycleDir :: FilePath -- mainly used on windows+ { baseDir :: GHCupPath+ , binDir :: FilePath+ , cacheDir :: GHCupPath+ , logsDir :: GHCupPath+ , confDir :: GHCupPath+ , dbDir :: GHCupPath+ , recycleDir :: GHCupPath -- mainly used on windows+ , tmpDir :: GHCupPath } deriving (Show, GHC.Generic) @@ -635,9 +642,22 @@ deriving (Eq, Show) data InstallDirResolved = IsolateDirResolved FilePath- | GHCupDir FilePath+ | GHCupDir GHCupPath+ | GHCupBinDir FilePath deriving (Eq, Show) fromInstallDir :: InstallDirResolved -> FilePath fromInstallDir (IsolateDirResolved fp) = fp-fromInstallDir (GHCupDir fp) = fp+fromInstallDir (GHCupDir fp) = fromGHCupPath fp+fromInstallDir (GHCupBinDir fp) = fp+++isSafeDir :: InstallDirResolved -> Bool+isSafeDir (IsolateDirResolved _) = False+isSafeDir (GHCupDir _) = True+isSafeDir (GHCupBinDir _) = False++type PromptQuestion = Text++data PromptResponse = PromptYes | PromptNo+ deriving (Show, Eq)
lib/GHCup/Types/JSON.hs view
@@ -23,7 +23,7 @@ import GHCup.Types import GHCup.Types.JSON.Utils-import GHCup.Utils.MegaParsec+import GHCup.Prelude.MegaParsec import Control.Applicative ( (<|>) ) import Data.Aeson hiding (Key)@@ -79,37 +79,6 @@ instance ToJSON URI where toJSON = toJSON . E.decodeUtf8With E.lenientDecode . serializeURIRef' -instance FromJSON URLSource where- parseJSON v =- parseGHCupURL v- <|> parseOwnSourceLegacy v- <|> parseOwnSourceNew1 v- <|> parseOwnSourceNew2 v- <|> parseOwnSpec v- <|> legacyParseAddSource v- <|> newParseAddSource v- where- parseOwnSourceLegacy = withObject "URLSource" $ \o -> do- r :: URI <- o .: "OwnSource"- pure (OwnSource [Right r])- parseOwnSourceNew1 = withObject "URLSource" $ \o -> do- r :: [URI] <- o .: "OwnSource"- pure (OwnSource (fmap Right r))- parseOwnSourceNew2 = withObject "URLSource" $ \o -> do- r :: [Either GHCupInfo URI] <- o .: "OwnSource"- pure (OwnSource r)- parseOwnSpec = withObject "URLSource" $ \o -> do- r :: GHCupInfo <- o .: "OwnSpec"- pure (OwnSpec r)- parseGHCupURL = withObject "URLSource" $ \o -> do- _ :: [Value] <- o .: "GHCupURL"- pure GHCupURL- legacyParseAddSource = withObject "URLSource" $ \o -> do- r :: Either GHCupInfo URI <- o .: "AddSource"- pure (AddSource [r])- newParseAddSource = withObject "URLSource" $ \o -> do- r :: [Either GHCupInfo URI] <- o .: "AddSource"- pure (AddSource r) instance FromJSON URI where parseJSON = withText "URL" $ \t ->@@ -349,7 +318,40 @@ deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings-deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings- deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key++instance FromJSON URLSource where+ parseJSON v =+ parseGHCupURL v+ <|> parseOwnSourceLegacy v+ <|> parseOwnSourceNew1 v+ <|> parseOwnSourceNew2 v+ <|> parseOwnSpec v+ <|> legacyParseAddSource v+ <|> newParseAddSource v+ where+ parseOwnSourceLegacy = withObject "URLSource" $ \o -> do+ r :: URI <- o .: "OwnSource"+ pure (OwnSource [Right r])+ parseOwnSourceNew1 = withObject "URLSource" $ \o -> do+ r :: [URI] <- o .: "OwnSource"+ pure (OwnSource (fmap Right r))+ parseOwnSourceNew2 = withObject "URLSource" $ \o -> do+ r :: [Either GHCupInfo URI] <- o .: "OwnSource"+ pure (OwnSource r)+ parseOwnSpec = withObject "URLSource" $ \o -> do+ r :: GHCupInfo <- o .: "OwnSpec"+ pure (OwnSpec r)+ parseGHCupURL = withObject "URLSource" $ \o -> do+ _ :: [Value] <- o .: "GHCupURL"+ pure GHCupURL+ legacyParseAddSource = withObject "URLSource" $ \o -> do+ r :: Either GHCupInfo URI <- o .: "AddSource"+ pure (AddSource [r])+ newParseAddSource = withObject "URLSource" $ \o -> do+ r :: [Either GHCupInfo URI] <- o .: "AddSource"+ pure (AddSource r)++deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings+
lib/GHCup/Utils.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}@@ -22,18 +23,18 @@ ( module GHCup.Utils.Dirs , module GHCup.Utils #if defined(IS_WINDOWS)- , module GHCup.Utils.Windows+ , module GHCup.Prelude.Windows #else- , module GHCup.Utils.Posix+ , module GHCup.Prelude.Posix #endif ) where #if defined(IS_WINDOWS)-import GHCup.Utils.Windows+import GHCup.Prelude.Windows #else-import GHCup.Utils.Posix+import GHCup.Prelude.Posix #endif import GHCup.Download import GHCup.Errors@@ -41,11 +42,13 @@ import GHCup.Types.Optics import GHCup.Types.JSON ( ) import GHCup.Utils.Dirs-import GHCup.Utils.File-import GHCup.Utils.Logger-import GHCup.Utils.MegaParsec-import GHCup.Utils.Prelude-import GHCup.Utils.String.QQ+import GHCup.Version+import GHCup.Prelude+import GHCup.Prelude.File+import GHCup.Prelude.Logger.Internal+import GHCup.Prelude.MegaParsec+import GHCup.Prelude.Process+import GHCup.Prelude.String.QQ import Codec.Archive hiding ( Directory ) import Control.Applicative@@ -58,6 +61,7 @@ import Control.Monad.Trans.Resource hiding ( throwM ) import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )+import Data.Char ( isHexDigit ) import Data.Bifunctor ( first ) import Data.ByteString ( ByteString ) import Data.Either@@ -71,10 +75,10 @@ import Haskus.Utils.Variant.Excepts import Optics import Safe-import System.Directory hiding ( findFiles ) import System.FilePath import System.IO.Error import Text.Regex.Posix+import Text.PrettyPrint.HughesPJClass (prettyShow) import URI.ByteString import qualified Codec.Compression.BZip as BZip@@ -86,6 +90,9 @@ import qualified Data.Text.Encoding as E import qualified Text.Megaparsec as MP import qualified Data.List.NonEmpty as NE+import qualified Streamly.Prelude as S+import Control.DeepSeq (force)+import GHC.IO (evaluate) -- $setup@@ -96,14 +103,14 @@ -- >>> import System.Directory -- >>> import URI.ByteString -- >>> import qualified Data.Text as T--- >>> import GHCup.Utils.Prelude+-- >>> import GHCup.Prelude -- >>> import GHCup.Download -- >>> import GHCup.Version -- >>> import GHCup.Errors -- >>> import GHCup.Types -- >>> import GHCup.Types.Optics -- >>> import Optics--- >>> import GHCup.Utils.Version.QQ+-- >>> import GHCup.Prelude.Version.QQ -- >>> import qualified Data.Text.Encoding as E -- >>> import Control.Monad.Reader -- >>> import Haskus.Utils.Variant.Excepts@@ -277,14 +284,14 @@ ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool ghcInstalled ver = do ghcdir <- ghcupGHCDir ver- liftIO $ doesDirectoryExist ghcdir+ liftIO $ doesDirectoryExist (fromGHCupPath ghcdir) -- | Whether the given GHC version is installed from source. ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool ghcSrcInstalled ver = do ghcdir <- ghcupGHCDir ver- liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)+ liftIO $ doesFileExist (fromGHCupPath ghcdir </> ghcUpSrcBuiltFile) -- | Whether the given GHC version is set as the current.@@ -327,7 +334,7 @@ getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion] getInstalledGHCs = do ghcdir <- ghcupGHCBaseDir- fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir+ fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory (fromGHCupPath ghcdir) forM fs $ \f -> case parseGHCupGHCDir f of Right r -> pure $ Right r Left _ -> pure $ Left f@@ -430,7 +437,7 @@ Nothing -> pure $ Left f hlsdir <- ghcupHLSBaseDir- fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory hlsdir+ fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory (fromGHCupPath hlsdir) new <- forM fs $ \f -> case parseGHCupHLSDir f of Right r -> pure $ Right r Left _ -> pure $ Left f@@ -515,7 +522,7 @@ isLegacyHLS :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool isLegacyHLS ver = do bdir <- ghcupHLSDir ver- not <$> liftIO (doesDirectoryExist bdir)+ not <$> liftIO (doesDirectoryExist $ fromGHCupPath bdir) -- Return the currently set hls version, if any.@@ -616,7 +623,7 @@ -> m [FilePath] hlsInternalServerScripts ver mghcVer = do dir <- ghcupHLSDir ver- let bdir = dir </> "bin"+ let bdir = fromGHCupPath dir </> "bin" fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer) <$> liftIO (listDirectory bdir) @@ -627,7 +634,7 @@ -> Maybe Version -- ^ optional GHC version -> m [FilePath] hlsInternalServerBinaries ver mghcVer = do- dir <- ghcupHLSDir ver+ dir <- fromGHCupPath <$> ghcupHLSDir ver let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString) (Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir </> "lib"), Right regex, Left "bin"] fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer)@@ -641,7 +648,7 @@ -> Version -- ^ GHC version -> m [FilePath] hlsInternalServerLibs ver ghcVer = do- dir <- ghcupHLSDir ver+ dir <- fromGHCupPath <$> ghcupHLSDir ver let regex = makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString) (Just bdir) <- fmap headMay $ liftIO $ expandFilePath [Left (dir </> "lib"), Right regex, Left ("lib" </> T.unpack (prettyVer ghcVer))] fmap (bdir </>) <$> liftIO (listDirectory bdir)@@ -845,21 +852,21 @@ intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m)- => FilePath -- ^ unpacked tar dir+ => GHCupPath -- ^ unpacked tar dir -> TarDir -- ^ how to descend- -> Excepts '[TarDirDoesNotExist] m FilePath+ -> Excepts '[TarDirDoesNotExist] m GHCupPath intoSubdir bdir tardir = case tardir of RealDir pr -> do- whenM (fmap not . liftIO . doesDirectoryExist $ (bdir </> pr))+ whenM (fmap not . liftIO . doesDirectoryExist $ fromGHCupPath (bdir `appendGHCupPath` pr)) (throwE $ TarDirDoesNotExist tardir)- pure (bdir </> pr)+ pure (bdir `appendGHCupPath` pr) RegexDir r -> do let rs = split (`elem` pathSeparators) r foldlM (\y x ->- (handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= (\case+ (handleIO (\_ -> pure []) . liftIO . findFiles (fromGHCupPath y) . regex $ x) >>= (\case [] -> throwE $ TarDirDoesNotExist tardir- (p : _) -> pure (y </> p)) . sort+ (p : _) -> pure (y `appendGHCupPath` p)) . sort ) bdir rs@@ -905,7 +912,7 @@ => GHCTargetVersion -> m FilePath ghcInternalBinDir ver = do- ghcdir <- ghcupGHCDir ver+ ghcdir <- fromGHCupPath <$> ghcupGHCDir ver pure (ghcdir </> "bin") @@ -1016,6 +1023,28 @@ !? PatchFailed +applyAnyPatch :: ( MonadReader env m+ , HasDirs env+ , HasLog env+ , HasSettings env+ , MonadUnliftIO m+ , MonadCatch m+ , MonadResource m+ , MonadThrow m+ , MonadMask m+ , MonadIO m)+ => Maybe (Either FilePath [URI])+ -> FilePath+ -> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m ()+applyAnyPatch Nothing _ = pure ()+applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir+applyAnyPatch (Just (Right uris)) workdir = do+ tmpUnpack <- fromGHCupPath <$> lift withGHCupTmpDir+ forM_ uris $ \uri -> do+ patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False+ liftE $ applyPatch patch workdir++ -- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353 darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m) => Platform@@ -1029,6 +1058,8 @@ darwinNotarization _ _ = pure $ Right () ++ getChangeLog :: GHCupDownloads -> Tool -> Either Version Tag -> Maybe URI getChangeLog dls tool (Left v') = preview (ix tool % ix v' % viChangeLog % _Just) dls@@ -1039,7 +1070,6 @@ -- | Execute a build action while potentially cleaning up: -- -- 1. the build directory, depending on the KeepDirs setting--- 2. the install destination, depending on whether the build failed runBuildAction :: ( MonadReader env m , HasDirs env , HasSettings env@@ -1050,15 +1080,12 @@ , MonadFail m , MonadCatch m )- => FilePath -- ^ build directory (cleaned up depending on Settings)- -> Maybe FilePath -- ^ dir to *always* clean up on exception+ => GHCupPath -- ^ build directory (cleaned up depending on Settings) -> Excepts e m a -> Excepts e m a-runBuildAction bdir instdir action = do+runBuildAction bdir action = do Settings {..} <- lift getSettings let exAction = do- forM_ instdir $ \dir ->- hideError doesNotExistErrorType $ recyclePathForcibly dir when (keepDirs == Never) $ rmBDir bdir v <-@@ -1070,7 +1097,8 @@ -- | Clean up the given directory if the action fails, -- depending on the Settings.-cleanUpOnError :: ( MonadReader env m+cleanUpOnError :: forall e m a env .+ ( MonadReader env m , HasDirs env , HasSettings env , MonadIO m@@ -1080,7 +1108,7 @@ , MonadFail m , MonadCatch m )- => FilePath -- ^ build directory (cleaned up depending on Settings)+ => GHCupPath -- ^ build directory (cleaned up depending on Settings) -> Excepts e m a -> Excepts e m a cleanUpOnError bdir action = do@@ -1089,13 +1117,33 @@ flip onException (lift exAction) $ onE_ exAction action +-- | Clean up the given directory if the action fails,+-- depending on the Settings.+cleanFinally :: ( MonadReader env m+ , HasDirs env+ , HasSettings env+ , MonadIO m+ , MonadMask m+ , HasLog env+ , MonadUnliftIO m+ , MonadFail m+ , MonadCatch m+ )+ => GHCupPath -- ^ build directory (cleaned up depending on Settings)+ -> Excepts e m a+ -> Excepts e m a+cleanFinally bdir action = do+ Settings {..} <- lift getSettings+ let exAction = when (keepDirs == Never) $ rmBDir bdir+ flip finally (lift exAction) $ onE_ exAction action + -- | Remove a build directory, ignoring if it doesn't exist and gracefully -- printing other errors without crashing.-rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => FilePath -> m ()+rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => GHCupPath -> m () rmBDir dir = withRunInIO (\run -> run $ liftIO $ handleIO (\e -> run $ logWarn $- "Couldn't remove build dir " <> T.pack dir <> ", error was: " <> T.pack (displayException e))+ "Couldn't remove build dir " <> T.pack (fromGHCupPath dir) <> ", error was: " <> T.pack (displayException e)) $ hideError doesNotExistErrorType $ rmPathForcibly dir) @@ -1113,97 +1161,6 @@ ) --- | The file extension for executables.-exeExt :: String-exeExt- | isWindows = ".exe"- | otherwise = ""---- | The file extension for executables.-exeExt' :: ByteString-exeExt'- | isWindows = ".exe"- | otherwise = ""------- | On unix, we can use symlinks, so we just get the--- symbolic link target.------ On windows, we have to emulate symlinks via shims,--- see 'createLink'.-getLinkTarget :: FilePath -> IO FilePath-getLinkTarget fp- | isWindows = do- content <- readFile (dropExtension fp <.> "shim")- [p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content- pure $ stripNewline $ dropPrefix "path = " p- | otherwise = getSymbolicLinkTarget fp----- | Checks whether the path is a link.-pathIsLink :: FilePath -> IO Bool-pathIsLink fp- | isWindows = doesPathExist (dropExtension fp <.> "shim")- | otherwise = pathIsSymbolicLink fp---rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()-rmLink fp- | isWindows = do- hideError doesNotExistErrorType . recycleFile $ fp- hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")- | otherwise = hideError doesNotExistErrorType . recycleFile $ fp----- | Creates a symbolic link on unix and a fake symlink on windows for--- executables, which:--- 1. is a shim exe--- 2. has a corresponding .shim file in the same directory that--- contains the target------ This overwrites previously existing files.------ On windows, this requires that 'ensureGlobalTools' was run beforehand.-createLink :: ( MonadMask m- , MonadThrow m- , HasLog env- , MonadIO m- , MonadReader env m- , HasDirs env- , MonadUnliftIO m- , MonadFail m- )- => FilePath -- ^ path to the target executable- -> FilePath -- ^ path to be created- -> m ()-createLink link exe- | isWindows = do- dirs <- getDirs- let shimGen = cacheDir dirs </> "gs.exe"-- let shim = dropExtension exe <.> "shim"- -- For hardlinks, link needs to be absolute.- -- If link is relative, it's relative to the target exe.- -- Note that (</>) drops lhs when rhs is absolute.- fullLink = takeDirectory exe </> link- shimContents = "path = " <> fullLink-- logDebug $ "rm -f " <> T.pack exe- rmLink exe-- logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe- liftIO $ copyFile shimGen exe- liftIO $ writeFile shim shimContents- | otherwise = do- logDebug $ "rm -f " <> T.pack exe- hideError doesNotExistErrorType $ recycleFile exe-- logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe- liftIO $ createFileLink link exe-- ensureGlobalTools :: ( MonadMask m , MonadThrow m , HasLog env@@ -1225,8 +1182,8 @@ let dl = downloadCached' shimDownload (Just "gs.exe") Nothing void $ (\DigestError{} -> do lift $ logWarn "Digest doesn't match, redownloading gs.exe..."- lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs </> "gs.exe"))- lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")+ lift $ logDebug ("rm -f " <> T.pack (fromGHCupPath (cacheDir dirs) </> "gs.exe"))+ lift $ hideError doesNotExistErrorType $ recycleFile (fromGHCupPath (cacheDir dirs) </> "gs.exe") liftE @'[GPGError, DigestError , DownloadFailed] $ dl ) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl | otherwise = pure ()@@ -1234,14 +1191,17 @@ -- | Ensure ghcup directory structure exists. ensureDirectories :: Dirs -> IO ()-ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do- createDirRecursive' baseDir- createDirRecursive' (baseDir </> "ghc")+ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir tmpDir) = do+ createDirRecursive' (fromGHCupPath baseDir)+ createDirRecursive' (fromGHCupPath baseDir </> "ghc")+ createDirRecursive' (fromGHCupPath baseDir </> "hls") createDirRecursive' binDir- createDirRecursive' cacheDir- createDirRecursive' logsDir- createDirRecursive' confDir- createDirRecursive' trashDir+ createDirRecursive' (fromGHCupPath cacheDir)+ createDirRecursive' (fromGHCupPath logsDir)+ createDirRecursive' (fromGHCupPath confDir)+ createDirRecursive' (fromGHCupPath trashDir)+ createDirRecursive' (fromGHCupPath dbDir)+ createDirRecursive' (fromGHCupPath tmpDir) pure () @@ -1264,11 +1224,88 @@ -- 3. if it exists and is non-empty -> panic and leave the house installDestSanityCheck :: ( MonadIO m , MonadCatch m+ , MonadMask m ) => InstallDirResolved -> Excepts '[DirNotEmpty] m () installDestSanityCheck (IsolateDirResolved isoDir) = do hideErrorDef [doesNotExistErrorType] () $ do- contents <- liftIO $ getDirectoryContentsRecursive isoDir- unless (null contents) (throwE $ DirNotEmpty isoDir)+ empty' <- liftIO $ S.null $ getDirectoryContentsRecursiveUnsafe isoDir+ when (not empty') (throwE $ DirNotEmpty isoDir) installDestSanityCheck _ = pure ()+++-- | Returns 'Nothing' for legacy installs.+getInstalledFiles :: ( MonadIO m+ , MonadCatch m+ , MonadReader env m+ , HasDirs env+ , MonadFail m+ )+ => Tool+ -> GHCTargetVersion+ -> m (Maybe [FilePath])+getInstalledFiles t v' = hideErrorDef [doesNotExistErrorType] Nothing $ do+ f <- recordedInstallationFile t v'+ (force -> !c) <- liftIO+ (readFile f >>= evaluate)+ pure (Just $ lines c)+++-- | Warn if the installed and set HLS is not compatible with the installed and+-- set GHC version.+warnAboutHlsCompatibility :: ( MonadReader env m+ , HasDirs env+ , HasLog env+ , MonadThrow m+ , MonadCatch m+ , MonadIO m+ )+ => m ()+warnAboutHlsCompatibility = do+ supportedGHC <- hlsGHCVersions+ currentGHC <- fmap _tvVersion <$> ghcSet Nothing+ currentHLS <- hlsSet++ case (currentGHC, currentHLS) of+ (Just gv, Just hv) | gv `notElem` supportedGHC -> do+ logWarn $+ "GHC " <> T.pack (prettyShow gv) <> " is not compatible with " <>+ "Haskell Language Server " <> T.pack (prettyShow hv) <> "." <> "\n" <>+ "Haskell IDE support may not work until this is fixed." <> "\n" <>+ "Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <>+ T.pack (prettyShow supportedGHC)++ _ -> return ()++++ -----------+ --[ Git ]--+ -----------++++isCommitHash :: String -> Bool+isCommitHash str' = let hex = all isHexDigit str'+ len = length str'+ in hex && len == 40+++gitOut :: (MonadReader env m, HasLog env, MonadIO m) => [String] -> FilePath -> Excepts '[ProcessError] m T.Text+gitOut args dir = do+ CapturedProcess {..} <- lift $ executeOut "git" args (Just dir)+ case _exitCode of+ ExitSuccess -> pure $ T.pack $ stripNewlineEnd $ T.unpack $ decUTF8Safe' _stdOut+ ExitFailure c -> do+ let pe = NonZeroExit c "git" args+ lift $ logDebug $ T.pack (prettyShow pe)+ throwE pe++processBranches :: T.Text -> [String]+processBranches str' = let lines' = lines (T.unpack str')+ words' = fmap words lines'+ refs = catMaybes $ fmap (`atMay` 1) words'+ branches = catMaybes $ fmap (stripPrefix "refs/heads/") $ filter (isPrefixOf "refs/heads/") refs+ in branches+
− lib/GHCup/Utils.hs-boot
@@ -1,4 +0,0 @@-module GHCup.Utils where--getLinkTarget :: FilePath -> IO FilePath-pathIsLink :: FilePath -> IO Bool
lib/GHCup/Utils/Dirs.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE QuasiQuotes #-} {-| Module : GHCup.Utils.Dirs@@ -30,6 +31,74 @@ , getConfigFilePath , useXDG , cleanupTrash++ , GHCupPath+ , appendGHCupPath+ , fromGHCupPath+ , createTempGHCupDirectory+ , getGHCupTmpDirs++ , removeDirectory+ , removeDirectoryRecursive+ , removePathForcibly++ -- System.Directory re-exports+ , createDirectory+ , createDirectoryIfMissing+ , renameDirectory+ , listDirectory+ , getDirectoryContents+ , getCurrentDirectory+ , setCurrentDirectory+ , withCurrentDirectory+ , getHomeDirectory+ , XdgDirectory(..)+ , getXdgDirectory+ , XdgDirectoryList(..)+ , getXdgDirectoryList+ , getAppUserDataDirectory+ , getUserDocumentsDirectory+ , getTemporaryDirectory+ , removeFile+ , renameFile+ , renamePath+ , getFileSize+ , canonicalizePath+ , makeAbsolute+ , makeRelativeToCurrentDirectory+ , doesPathExist+ , doesFileExist+ , doesDirectoryExist+ , findExecutable+ , findExecutables+ , findExecutablesInDirectories+ , findFile+ , findFileWith+ , findFilesWith+ , exeExtension+ , createFileLink+ , createDirectoryLink+ , removeDirectoryLink+ , pathIsSymbolicLink+ , getSymbolicLinkTarget+ , Permissions+ , emptyPermissions+ , readable+ , writable+ , executable+ , searchable+ , setOwnerReadable+ , setOwnerWritable+ , setOwnerExecutable+ , setOwnerSearchable+ , getPermissions+ , setPermissions+ , copyPermissions+ , getAccessTime+ , getModificationTime+ , setAccessTime+ , setModificationTime+ , isSymbolicLink ) where @@ -38,35 +107,86 @@ import GHCup.Types import GHCup.Types.JSON ( ) import GHCup.Types.Optics-import GHCup.Utils.MegaParsec-import GHCup.Utils.Logger-import GHCup.Utils.Prelude+import GHCup.Prelude.MegaParsec+import GHCup.Prelude.File.Search+import GHCup.Prelude.String.QQ+import GHCup.Prelude.Logger.Internal (logWarn, logDebug)+#if defined(IS_WINDOWS)+import GHCup.Prelude.Windows ( isWindows )+#else+import GHCup.Prelude.Posix ( isWindows )+#endif +import Control.DeepSeq (NFData, rnf) import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Unlift import Control.Monad.Reader import Control.Monad.Trans.Resource hiding (throwM)+import Data.List+import Data.ByteString ( ByteString ) import Data.Bifunctor import Data.Maybe import Data.Versions import GHC.IO.Exception ( IOErrorType(NoSuchThing) ) import Haskus.Utils.Variant.Excepts import Optics-import System.Directory -import System.DiskSpace +import Safe+import System.Directory hiding ( removeDirectory+ , removeDirectoryRecursive+ , removePathForcibly+ , findFiles+ )+import qualified System.Directory as SD+ import System.Environment import System.FilePath import System.IO.Temp+import Text.Regex.Posix import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Data.Yaml.Aeson as Y import qualified Text.Megaparsec as MP-import Control.Concurrent (threadDelay)+import System.IO.Error (ioeGetErrorType) + ---------------------------+ --[ GHCupPath utilities ]--+ ---------------------------++-- | A 'GHCupPath' is a safe sub-path that can be recursively deleted.+--+-- The constructor is not exported.+newtype GHCupPath = GHCupPath FilePath+ deriving (Show, Eq, Ord)++instance NFData GHCupPath where+ rnf (GHCupPath fp) = rnf fp++appendGHCupPath :: GHCupPath -> FilePath -> GHCupPath+appendGHCupPath (GHCupPath gp) fp = GHCupPath (gp </> fp)++fromGHCupPath :: GHCupPath -> FilePath+fromGHCupPath (GHCupPath gp) = gp++createTempGHCupDirectory :: GHCupPath -> FilePath -> IO GHCupPath+createTempGHCupDirectory (GHCupPath gp) d = GHCupPath <$> createTempDirectory gp d+++getGHCupTmpDirs :: IO [GHCupPath]+getGHCupTmpDirs = do+ tmpdir <- fromGHCupPath <$> ghcupTMPDir+ ghcup_dirs <- handleIO (\_ -> pure []) $ findFiles+ tmpdir+ (makeRegexOpts compExtended+ execBlank+ ([s|^ghcup-.*$|] :: ByteString)+ )+ pure (fmap (\p -> GHCupPath (tmpdir </> p)) $ filter (maybe False ("ghcup-" `isPrefixOf`) . lastMay . splitPath) ghcup_dirs)++ ------------------------------ --[ GHCup base directories ]-- ------------------------------@@ -76,11 +196,11 @@ -- -- If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.-ghcupBaseDir :: IO FilePath+ghcupBaseDir :: IO GHCupPath ghcupBaseDir | isWindows = do bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"- pure (bdir </> "ghcup")+ pure (GHCupPath (bdir </> "ghcup")) | otherwise = do xdg <- useXDG if xdg@@ -90,19 +210,19 @@ Nothing -> do home <- liftIO getHomeDirectory pure (home </> ".local" </> "share")- pure (bdir </> "ghcup")+ pure (GHCupPath (bdir </> "ghcup")) else do bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case Just r -> pure r Nothing -> liftIO getHomeDirectory- pure (bdir </> ".ghcup")+ pure (GHCupPath (bdir </> ".ghcup")) -- | ~/.ghcup by default -- -- If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec.-ghcupConfigDir :: IO FilePath+ghcupConfigDir :: IO GHCupPath ghcupConfigDir | isWindows = ghcupBaseDir | otherwise = do@@ -114,12 +234,12 @@ Nothing -> do home <- liftIO getHomeDirectory pure (home </> ".config")- pure (bdir </> "ghcup")+ pure (GHCupPath (bdir </> "ghcup")) else do bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case Just r -> pure r Nothing -> liftIO getHomeDirectory- pure (bdir </> ".ghcup")+ pure (GHCupPath (bdir </> ".ghcup")) -- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),@@ -127,7 +247,7 @@ -- (which, sadly is not strictly xdg spec). ghcupBinDir :: IO FilePath ghcupBinDir- | isWindows = ghcupBaseDir <&> (</> "bin")+ | isWindows = (fromGHCupPath <$> ghcupBaseDir) <&> (</> "bin") | otherwise = do xdg <- useXDG if xdg@@ -137,16 +257,16 @@ Nothing -> do home <- liftIO getHomeDirectory pure (home </> ".local" </> "bin")- else ghcupBaseDir <&> (</> "bin")+ else (fromGHCupPath <$> ghcupBaseDir) <&> (</> "bin") -- | Defaults to '~/.ghcup/cache'. -- -- If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.-ghcupCacheDir :: IO FilePath+ghcupCacheDir :: IO GHCupPath ghcupCacheDir- | isWindows = ghcupBaseDir <&> (</> "cache")+ | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache")) | otherwise = do xdg <- useXDG if xdg@@ -156,17 +276,17 @@ Nothing -> do home <- liftIO getHomeDirectory pure (home </> ".cache")- pure (bdir </> "ghcup")- else ghcupBaseDir <&> (</> "cache")+ pure (GHCupPath (bdir </> "ghcup"))+ else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "cache")) -- | Defaults to '~/.ghcup/logs'. -- -- If 'GHCUP_USE_XDG_DIRS' is set (to anything), -- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec.-ghcupLogsDir :: IO FilePath+ghcupLogsDir :: IO GHCupPath ghcupLogsDir- | isWindows = ghcupBaseDir <&> (</> "logs")+ | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "logs")) | otherwise = do xdg <- useXDG if xdg@@ -176,17 +296,56 @@ Nothing -> do home <- liftIO getHomeDirectory pure (home </> ".cache")- pure (bdir </> "ghcup" </> "logs")- else ghcupBaseDir <&> (</> "logs")+ pure (GHCupPath (bdir </> "ghcup" </> "logs"))+ else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "logs")) +-- | Defaults to '~/.ghcup/db.+--+-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),+-- then uses 'XDG_CACHE_HOME/ghcup/db as per xdg spec.+ghcupDbDir :: IO GHCupPath+ghcupDbDir+ | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))+ | otherwise = do+ xdg <- useXDG+ if xdg+ then do+ bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case+ Just r -> pure r+ Nothing -> do+ home <- liftIO getHomeDirectory+ pure (home </> ".cache")+ pure (GHCupPath (bdir </> "ghcup" </> "db"))+ else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "db"))++ -- | '~/.ghcup/trash'. -- Mainly used on windows to improve file removal operations-ghcupRecycleDir :: IO FilePath-ghcupRecycleDir = ghcupBaseDir <&> (</> "trash")+ghcupRecycleDir :: IO GHCupPath+ghcupRecycleDir = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "trash")) +-- | Defaults to '~/.ghcup/tmp.+--+-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),+-- then uses 'XDG_CACHE_HOME/ghcup/tmp as per xdg spec.+ghcupTMPDir :: IO GHCupPath+ghcupTMPDir+ | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "tmp"))+ | otherwise = do+ xdg <- useXDG+ if xdg+ then do+ bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case+ Just r -> pure r+ Nothing -> do+ home <- liftIO getHomeDirectory+ pure (home </> ".cache")+ pure (GHCupPath (bdir </> "ghcup" </> "tmp"))+ else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "tmp")) + getAllDirs :: IO Dirs getAllDirs = do baseDir <- ghcupBaseDir@@ -195,6 +354,8 @@ logsDir <- ghcupLogsDir confDir <- ghcupConfigDir recycleDir <- ghcupRecycleDir+ tmpDir <- ghcupTMPDir+ dbDir <- ghcupDbDir pure Dirs { .. } @@ -206,16 +367,21 @@ getConfigFilePath :: (MonadIO m) => m FilePath getConfigFilePath = do confDir <- liftIO ghcupConfigDir- pure $ confDir </> "config.yaml"+ pure $ fromGHCupPath confDir </> "config.yaml" ghcupConfigFile :: (MonadIO m) => Excepts '[JSONError] m UserSettings ghcupConfigFile = do filepath <- getConfigFilePath- contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile filepath+ contents <- liftIO $ handleIO (\e -> if NoSuchThing == ioeGetErrorType e then pure Nothing else liftIO $ ioError e) $ Just <$> BS.readFile filepath case contents of Nothing -> pure defaultUserSettings- Just contents' -> lE' JSONDecodeError . first displayException . Y.decodeEither' $ contents'+ Just contents' -> liftE+ . veitherToExcepts @_ @'[JSONError]+ . either (VLeft . V) VRight+ . first (JSONDecodeError . displayException)+ . Y.decodeEither'+ $ contents' -------------------------@@ -224,10 +390,10 @@ -- | ~/.ghcup/ghc by default.-ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath+ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath ghcupGHCBaseDir = do Dirs {..} <- getDirs- pure (baseDir </> "ghc")+ pure (baseDir `appendGHCupPath` "ghc") -- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.@@ -236,11 +402,11 @@ -- * 8.8.4 ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion- -> m FilePath+ -> m GHCupPath ghcupGHCDir ver = do ghcbasedir <- ghcupGHCBaseDir let verdir = T.unpack $ tVerToText ver- pure (ghcbasedir </> verdir)+ pure (ghcbasedir `appendGHCupPath` verdir) -- | See 'ghcupToolParser'.@@ -252,21 +418,28 @@ parseGHCupHLSDir (T.pack -> fp) = throwEither $ MP.parse version' "" fp +-- TODO: inlined from GHCup.Prelude+throwEither :: (Exception a, MonadThrow m) => Either a b -> m b+throwEither a = case a of+ Left e -> throwM e+ Right r -> pure r+ -- | ~/.ghcup/hls by default, for new-style installs.-ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m FilePath+ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath ghcupHLSBaseDir = do Dirs {..} <- getDirs- pure (baseDir </> "hls")+ pure (baseDir `appendGHCupPath` "hls") -- | Gets '~/.ghcup/hls/<hls-ver>' for new-style installs. ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m) => Version- -> m FilePath+ -> m GHCupPath ghcupHLSDir ver = do basedir <- ghcupHLSBaseDir let verdir = T.unpack $ prettyVer ver- pure (basedir </> verdir)+ pure (basedir `appendGHCupPath` verdir) + mkGhcupTmpDir :: ( MonadReader env m , HasDirs env , MonadUnliftIO m@@ -275,31 +448,10 @@ , MonadThrow m , MonadMask m , MonadIO m)- => m FilePath-mkGhcupTmpDir = do- tmpdir <- liftIO getCanonicalTemporaryDirectory-- let minSpace = 5000 -- a rough guess, aight?- space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir- when (maybe False (toBytes minSpace >) space) $ do- logWarn ("Possibly insufficient disk space on "- <> T.pack tmpdir- <> ". At least "- <> T.pack (show minSpace)- <> " MB are recommended, but only "- <> toMB (fromJust space)- <> " are free. Consider freeing up disk space or setting TMPDIR env variable.")- logWarn- "...waiting for 10 seconds before continuing anyway, you can still abort..."- liftIO $ threadDelay 10000000 -- give the user a sec to intervene-- liftIO $ createTempDirectory tmpdir "ghcup"- where- toBytes mb = mb * 1024 * 1024- toMB b = T.pack $ show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2)- truncate' :: Double -> Int -> Double- truncate' x n = fromIntegral (floor (x * t) :: Integer) / t- where t = 10^n+ => m GHCupPath+mkGhcupTmpDir = GHCupPath <$> do+ Dirs { tmpDir } <- getDirs+ liftIO $ createTempDirectory (fromGHCupPath tmpDir) "ghcup" withGHCupTmpDir :: ( MonadReader env m@@ -312,15 +464,15 @@ , MonadThrow m , MonadMask m , MonadIO m)- => m FilePath+ => m GHCupPath withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) (\fp -> handleIO (\e -> run- $ logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e)))- . rmPathForcibly+ $ logDebug ("Resource cleanup failed for " <> T.pack (fromGHCupPath fp) <> ", error was: " <> T.pack (displayException e)))+ . removePathForcibly $ fp)) @@ -360,12 +512,28 @@ => m () cleanupTrash = do Dirs { recycleDir } <- getDirs- contents <- liftIO $ listDirectory recycleDir+ contents <- liftIO $ listDirectory (fromGHCupPath recycleDir) if null contents then pure () else do- logWarn ("Removing leftover files in " <> T.pack recycleDir)+ logWarn ("Removing leftover files in " <> T.pack (fromGHCupPath recycleDir)) forM_ contents (\fp -> handleIO (\e -> logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))- ) $ liftIO $ removePathForcibly (recycleDir </> fp))+ ) $ liftIO $ removePathForcibly (recycleDir `appendGHCupPath` fp))++++-- System.Directory re-exports with GHCupPath++removeDirectory :: GHCupPath -> IO ()+removeDirectory (GHCupPath fp) = SD.removeDirectory fp++removeDirectoryRecursive :: GHCupPath -> IO ()+removeDirectoryRecursive (GHCupPath fp) = SD.removeDirectoryRecursive fp++removePathForcibly :: GHCupPath -> IO ()+removePathForcibly (GHCupPath fp) = SD.removePathForcibly fp+++
+ lib/GHCup/Utils/Dirs.hs-boot view
@@ -0,0 +1,37 @@+module GHCup.Utils.Dirs+ ( GHCupPath+ , appendGHCupPath+ , fromGHCupPath+ , createTempGHCupDirectory+ , removeDirectory+ , removeDirectoryRecursive+ , removePathForcibly+ )+ where++import Control.DeepSeq (NFData)+++-- | A 'GHCupPath' is a safe sub-path that can be recursively deleted.+newtype GHCupPath = GHCupPath FilePath++instance Show GHCupPath where++instance Eq GHCupPath where++instance Ord GHCupPath where++instance NFData GHCupPath where++appendGHCupPath :: GHCupPath -> FilePath -> GHCupPath++fromGHCupPath :: GHCupPath -> FilePath++createTempGHCupDirectory :: GHCupPath -> FilePath -> IO GHCupPath++removeDirectory :: GHCupPath -> IO ()++removeDirectoryRecursive :: GHCupPath -> IO ()++removePathForcibly :: GHCupPath -> IO ()+
− lib/GHCup/Utils/File.hs
@@ -1,17 +0,0 @@-{-# LANGUAGE CPP #-}--module GHCup.Utils.File (- module GHCup.Utils.File.Common,-#if IS_WINDOWS- module GHCup.Utils.File.Windows-#else- module GHCup.Utils.File.Posix-#endif-) where--import GHCup.Utils.File.Common-#if IS_WINDOWS-import GHCup.Utils.File.Windows-#else-import GHCup.Utils.File.Posix-#endif
− lib/GHCup/Utils/File/Common.hs
@@ -1,111 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}--module GHCup.Utils.File.Common (- module GHCup.Utils.File.Common- , ProcessError(..)- , CapturedProcess(..)- ) where--import GHCup.Utils.Prelude-import GHCup.Types(ProcessError(..), CapturedProcess(..))--import Control.Monad.Reader-import Data.Maybe-import Data.Text ( Text )-import Data.Void-import GHC.IO.Exception-import Optics hiding ((<|), (|>))-import System.Directory hiding (findFiles)-import System.FilePath-import Text.PrettyPrint.HughesPJClass hiding ( (<>) )-import Text.Regex.Posix--import qualified Data.Text as T-import qualified Data.ByteString.Lazy as BL-import qualified Text.Megaparsec as MP------ | Search for a file in the search paths.------ Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.-searchPath :: [FilePath] -> FilePath -> IO (Maybe FilePath)-searchPath paths needle = go paths- where- go [] = pure Nothing- go (x : xs) =- hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs)- $ do- contents <- listDirectory x- findM (isMatch x) contents >>= \case- Just _ -> pure $ Just (x </> needle)- Nothing -> go xs- isMatch basedir p = do- if p == needle- then isExecutable (basedir </> needle)- else pure False-- isExecutable :: FilePath -> IO Bool- isExecutable file = executable <$> getPermissions file----- | Check wether a binary is shadowed by another one that comes before--- it in PATH. Returns the path to said binary, if any.-isShadowed :: FilePath -> IO (Maybe FilePath)-isShadowed p = do- let dir = takeDirectory p- let fn = takeFileName p- spaths <- liftIO getSearchPath- if dir `elem` spaths- then do- let shadowPaths = takeWhile (/= dir) spaths- searchPath shadowPaths fn- else pure Nothing----- | Check whether the binary is in PATH. This returns only `True`--- if the directory containing the binary is part of PATH.-isInPath :: FilePath -> IO Bool-isInPath p = do- let dir = takeDirectory p- let fn = takeFileName p- spaths <- liftIO getSearchPath- if dir `elem` spaths- then isJust <$> searchPath [dir] fn- else pure False----- | Follows the first match in case of Regex.-expandFilePath :: [Either FilePath Regex] -> IO [FilePath]-expandFilePath = go ""- where- go :: FilePath -> [Either FilePath Regex] -> IO [FilePath]- go p [] = pure [p]- go p (x:xs) = do- case x of- Left s -> go (p </> s) xs- Right regex -> do- fps <- findFiles p regex- res <- forM fps $ \fp -> go (p </> fp) xs- pure $ mconcat res---findFiles :: FilePath -> Regex -> IO [FilePath]-findFiles path regex = do- contents <- listDirectory path- pure $ filter (match regex) contents--findFilesDeep :: FilePath -> Regex -> IO [FilePath]-findFilesDeep path regex = do- contents <- getDirectoryContentsRecursive path- pure $ filter (match regex) contents--findFiles' :: FilePath -> MP.Parsec Void Text a -> IO [FilePath]-findFiles' path parser = do- contents <- listDirectory path- pure $ filter (\fp -> either (const False) (const True) $ MP.parse parser "" (T.pack fp)) contents---checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool-checkFileAlreadyExists fp = liftIO $ doesFileExist fp
− lib/GHCup/Utils/File/Common.hs-boot
@@ -1,5 +0,0 @@-module GHCup.Utils.File.Common where--import Text.Regex.Posix--findFiles :: FilePath -> Regex -> IO [FilePath]
− lib/GHCup/Utils/File/Posix.hs
@@ -1,401 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}--{-|-Module : GHCup.Utils.File.Posix-Description : File and unix APIs-Copyright : (c) Julian Ospald, 2020-License : LGPL-3.0-Maintainer : hasufell@hasufell.de-Stability : experimental-Portability : POSIX--This module handles file and executable handling.-Some of these functions use sophisticated logging.--}-module GHCup.Utils.File.Posix where--import GHCup.Utils.File.Common-import GHCup.Utils.Prelude-import GHCup.Utils.Logger-import GHCup.Types-import GHCup.Types.Optics--import Control.Concurrent-import Control.Concurrent.Async-import Control.Exception ( evaluate )-import Control.Exception.Safe-import Control.Monad-import Control.Monad.Reader-import Control.Monad.Trans.State.Strict-import Data.ByteString ( ByteString )-import Data.Foldable-import Data.IORef-import Data.Sequence ( Seq, (|>) )-import Data.List-import Data.Word8-import GHC.IO.Exception-import System.IO ( stderr )-import System.IO.Error-import System.FilePath-import System.Directory-import System.Posix.Directory-import System.Posix.Files-import System.Posix.IO-import System.Posix.Process ( ProcessStatus(..) )-import System.Posix.Types---import qualified Control.Exception as EX-import qualified Data.Sequence as Sq-import qualified Data.Text as T-import qualified Data.Text.Encoding as E-import qualified System.Posix.Process as SPP-import qualified System.Console.Terminal.Size as TP-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BL-import qualified "unix-bytestring" System.Posix.IO.ByteString- as SPIB------ | Execute the given command and collect the stdout, stderr and the exit code.--- The command is run in a subprocess.-executeOut :: MonadIO m- => FilePath -- ^ command as filename, e.g. 'ls'- -> [String] -- ^ arguments to the command- -> Maybe FilePath -- ^ chdir to this path- -> m CapturedProcess-executeOut path args chdir = liftIO $ captureOutStreams $ do- maybe (pure ()) changeWorkingDirectory chdir- SPP.executeFile path True args Nothing---execLogged :: ( MonadReader env m- , HasSettings env- , HasLog env- , HasDirs env- , MonadIO m- , MonadThrow m)- => FilePath -- ^ thing to execute- -> [String] -- ^ args for the thing- -> Maybe FilePath -- ^ optionally chdir into this- -> FilePath -- ^ log filename (opened in append mode)- -> Maybe [(String, String)] -- ^ optional environment- -> m (Either ProcessError ())-execLogged exe args chdir lfile env = do- Settings {..} <- getSettings- Dirs {..} <- getDirs- logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args- let logfile = logsDir </> lfile <> ".log"- liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })- closeFd- (action verbose noColor)- where- action verbose no_color fd = do- actionWithPipes $ \(stdoutRead, stdoutWrite) -> do- -- start the thread that logs to stdout- pState <- newEmptyMVar- done <- newEmptyMVar- void- $ forkIO- $ EX.handle (\(_ :: IOException) -> pure ())- $ EX.finally- (if verbose- then tee fd stdoutRead- else printToRegion fd stdoutRead 6 pState no_color- )- (putMVar done ())-- -- fork the subprocess- pid <- SPP.forkProcess $ do- void $ dupTo stdoutWrite stdOutput- void $ dupTo stdoutWrite stdError- closeFd stdoutRead- closeFd stdoutWrite-- -- execute the action- maybe (pure ()) changeWorkingDirectory chdir- void $ SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env-- closeFd stdoutWrite-- -- wait for the subprocess to finish- e <- toProcessError exe args <$!> SPP.getProcessStatus True True pid- putMVar pState (either (const False) (const True) e)-- void $ race (takeMVar done) (threadDelay (1000000 * 3))- closeFd stdoutRead-- pure e-- tee :: Fd -> Fd -> IO ()- tee fileFd = readTilEOF lineAction-- where- lineAction :: ByteString -> IO ()- lineAction bs' = do- void $ SPIB.fdWrite fileFd (bs' <> "\n")- void $ SPIB.fdWrite stdOutput (bs' <> "\n")-- -- Reads fdIn and logs the output in a continous scrolling area- -- of 'size' terminal lines. Also writes to a log file.- printToRegion :: Fd -> Fd -> Int -> MVar Bool -> Bool -> IO ()- printToRegion fileFd fdIn size pState no_color = do- -- init region- forM_ [1..size] $ \_ -> BS.hPut stderr "\n"-- void $ flip runStateT mempty- $ do- handle- (\(ex :: SomeException) -> do- ps <- liftIO $ takeMVar pState- when ps (liftIO $ BS.hPut stderr (pos1 <> moveLineUp size <> clearScreen))- throw ex- ) $ readTilEOF lineAction fdIn-- where- clearScreen :: ByteString- clearScreen = "\x1b[0J"- clearLine :: ByteString- clearLine = "\x1b[2K"- moveLineUp :: Int -> ByteString- moveLineUp n = "\x1b[" <> E.encodeUtf8 (T.pack (show n)) <> "A"- moveLineDown :: Int -> ByteString- moveLineDown n = "\x1b[" <> E.encodeUtf8 (T.pack (show n)) <> "B"- pos1 :: ByteString- pos1 = "\r"- overwriteNthLine :: Int -> ByteString -> ByteString- overwriteNthLine n str = pos1 <> moveLineUp n <> clearLine <> str <> moveLineDown n <> pos1-- blue :: ByteString -> ByteString- blue bs - | no_color = bs- | otherwise = "\x1b[0;34m" <> bs <> "\x1b[0m"-- -- action to perform line by line- lineAction :: (MonadMask m, MonadIO m)- => ByteString- -> StateT (Seq ByteString) m ()- lineAction = \bs' -> do- void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")- modify (swapRegs bs')- liftIO TP.size >>= \case- Nothing -> pure ()- Just (TP.Window _ w) -> do- regs <- get- liftIO $ forM_ (Sq.zip regs (Sq.fromList [0..(Sq.length regs - 1)])) $ \(bs, i) -> do- BS.hPut stderr- . overwriteNthLine (size - i)- . trim w- . blue- . (\b -> "[ " <> E.encodeUtf8 (T.pack lfile) <> " ] " <> b)- $ bs-- swapRegs :: a -> Seq a -> Seq a- swapRegs bs = \regs -> if- | Sq.length regs < size -> regs |> bs- | otherwise -> Sq.drop 1 regs |> bs-- -- trim output line to terminal width- trim :: Int -> ByteString -> ByteString- trim w = \bs -> if- | BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."- | otherwise -> bs-- -- Consecutively read from Fd in 512 chunks until we hit- -- newline or EOF.- readLine :: MonadIO m- => Fd -- ^ input file descriptor- -> ByteString -- ^ rest buffer (read across newline)- -> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)- readLine fd = go- where- go inBs = do- -- if buffer is not empty, process it first- mbs <- if BS.length inBs == 0- -- otherwise attempt read- then liftIO- $ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)- $ fmap Just- $ SPIB.fdRead fd 512- else pure $ Just inBs- case mbs of- Nothing -> pure ("", "", True)- Just bs -> do- -- split on newline- let (line, rest) = BS.span (/= _lf) bs- if- | BS.length rest /= 0 -> pure (line, BS.tail rest, False)- -- if rest is empty, then there was no newline, process further- | otherwise -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty-- readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()- readTilEOF ~action' fd' = go mempty- where- go bs' = do- (bs, rest, eof) <- readLine fd' bs'- if eof- then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)- else void (action' bs) >> go rest----- | Capture the stdout and stderr of the given action, which--- is run in a subprocess. Stdin is closed. You might want to--- 'race' this to make sure it terminates.-captureOutStreams :: IO a- -- ^ the action to execute in a subprocess- -> IO CapturedProcess-captureOutStreams action = do- actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->- actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do- pid <- SPP.forkProcess $ do- -- dup stdout- void $ dupTo childStdoutWrite stdOutput- closeFd childStdoutWrite- closeFd parentStdoutRead-- -- dup stderr- void $ dupTo childStderrWrite stdError- closeFd childStderrWrite- closeFd parentStderrRead-- -- execute the action- a <- action- void $ evaluate a-- -- close everything we don't need- closeFd childStdoutWrite- closeFd childStderrWrite-- -- start thread that writes the output- refOut <- newIORef BL.empty- refErr <- newIORef BL.empty- done <- newEmptyMVar- _ <-- forkIO- $ EX.handle (\(_ :: IOException) -> pure ())- $ flip EX.finally (putMVar done ())- $ writeStds parentStdoutRead parentStderrRead refOut refErr-- status <- SPP.getProcessStatus True True pid- void $ race (takeMVar done) (threadDelay (1000000 * 3))-- case status of- -- readFd will take care of closing the fd- Just (SPP.Exited es) -> do- stdout' <- readIORef refOut- stderr' <- readIORef refErr- pure $ CapturedProcess { _exitCode = es- , _stdOut = stdout'- , _stdErr = stderr'- }-- _ -> throwIO $ userError ("No such PID " ++ show pid)-- where- writeStds :: Fd -> Fd -> IORef BL.ByteString -> IORef BL.ByteString -> IO ()- writeStds pout perr rout rerr = do- doneOut <- newEmptyMVar- void- $ forkIO- $ hideError eofErrorType- $ flip EX.finally (putMVar doneOut ())- $ readTilEOF (\x -> modifyIORef' rout (<> BL.fromStrict x)) pout- doneErr <- newEmptyMVar- void- $ forkIO- $ hideError eofErrorType- $ flip EX.finally (putMVar doneErr ())- $ readTilEOF (\x -> modifyIORef' rerr (<> BL.fromStrict x)) perr- takeMVar doneOut- takeMVar doneErr-- readTilEOF ~action' fd' = do- bs <- SPIB.fdRead fd' 512- void $ action' bs- readTilEOF action' fd'---actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b-actionWithPipes a =- createPipe >>= \(p1, p2) -> flip finally (cleanup [p1, p2]) $ a (p1, p2)--cleanup :: [Fd] -> IO ()-cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd------ | Create a new regular file in write-only mode. The file must not exist.-createRegularFileFd :: FileMode -> FilePath -> IO Fd-createRegularFileFd fm dest =- openFd dest WriteOnly (Just fm) defaultFileFlags{ exclusive = True }----- | Thin wrapper around `executeFile`.-exec :: MonadIO m- => String -- ^ thing to execute- -> [String] -- ^ args for the thing- -> Maybe FilePath -- ^ optionally chdir into this- -> Maybe [(String, String)] -- ^ optional environment- -> m (Either ProcessError ())-exec exe args chdir env = liftIO $ do- pid <- SPP.forkProcess $ do- maybe (pure ()) changeWorkingDirectory chdir- SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env-- fmap (toProcessError exe args) $ SPP.getProcessStatus True True pid---toProcessError :: FilePath- -> [String]- -> Maybe ProcessStatus- -> Either ProcessError ()-toProcessError exe args mps = case mps of- Just (SPP.Exited (ExitFailure xi)) -> Left $ NonZeroExit xi exe args- Just (SPP.Exited ExitSuccess ) -> Right ()- Just (Terminated _ _ ) -> Left $ PTerminated exe args- Just (Stopped _ ) -> Left $ PStopped exe args- Nothing -> Left $ NoSuchPid exe args----chmod_755 :: (MonadReader env m, HasLog env, MonadIO m) => FilePath -> m ()-chmod_755 fp = do- let exe_mode =- nullFileMode- `unionFileModes` ownerExecuteMode- `unionFileModes` ownerReadMode- `unionFileModes` ownerWriteMode- `unionFileModes` groupExecuteMode- `unionFileModes` groupReadMode- `unionFileModes` otherExecuteMode- `unionFileModes` otherReadMode- logDebug ("chmod 755 " <> T.pack fp)- liftIO $ setFileMode fp exe_mode----- |Default permissions for a new file.-newFilePerms :: FileMode-newFilePerms =- ownerWriteMode- `unionFileModes` ownerReadMode- `unionFileModes` groupWriteMode- `unionFileModes` groupReadMode- `unionFileModes` otherWriteMode- `unionFileModes` otherReadMode----- | Checks whether the binary is a broken link.-isBrokenSymlink :: FilePath -> IO Bool-isBrokenSymlink fp = do- try (pathIsSymbolicLink fp) >>= \case- Right True -> do- let symDir = takeDirectory fp- tfp <- getSymbolicLinkTarget fp- not <$> doesPathExist- -- this drops 'symDir' if 'tfp' is absolute- (symDir </> tfp)- Right b -> pure b- Left e | isDoesNotExistError e -> pure False- | otherwise -> throwIO e
− lib/GHCup/Utils/File/Windows.hs
@@ -1,271 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}--{-|-Module : GHCup.Utils.File.Windows-Description : File and windows APIs-Copyright : (c) Julian Ospald, 2020-License : LGPL-3.0-Maintainer : hasufell@hasufell.de-Stability : experimental-Portability : Windows--This module handles file and executable handling.-Some of these functions use sophisticated logging.--}-module GHCup.Utils.File.Windows where--import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )-import GHCup.Utils.Dirs-import GHCup.Utils.File.Common-import GHCup.Utils.Logger-import GHCup.Types-import GHCup.Types.Optics--import Control.Concurrent-import Control.DeepSeq-import Control.Exception.Safe-import Control.Monad-import Control.Monad.Reader-import Data.List-import Foreign.C.Error-import GHC.IO.Exception-import GHC.IO.Handle-import System.Directory-import System.Environment-import System.FilePath-import System.IO-import System.Process- -import qualified Control.Exception as EX-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BL-import qualified Data.Map.Strict as Map-import qualified Data.Text as T----toProcessError :: FilePath- -> [FilePath]- -> ExitCode- -> Either ProcessError ()-toProcessError exe args exitcode = case exitcode of- (ExitFailure xi) -> Left $ NonZeroExit xi exe args- ExitSuccess -> Right ()----- | @readCreateProcessWithExitCode@ works exactly like 'readProcessWithExitCode' except that it--- lets you pass 'CreateProcess' giving better flexibility.------ Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the CreateProcess--- record will be ignored.------ @since 1.2.3.0-readCreateProcessWithExitCodeBS- :: CreateProcess- -> BL.ByteString- -> IO (ExitCode, BL.ByteString, BL.ByteString) -- ^ exitcode, stdout, stderr-readCreateProcessWithExitCodeBS cp input = do- let cp_opts = cp {- std_in = CreatePipe,- std_out = CreatePipe,- std_err = CreatePipe- }- withCreateProcess_ "readCreateProcessWithExitCodeBS" cp_opts $- \mb_inh mb_outh mb_errh ph ->- case (mb_inh, mb_outh, mb_errh) of- (Just inh, Just outh, Just errh) -> do-- out <- BS.hGetContents outh- err <- BS.hGetContents errh-- -- fork off threads to start consuming stdout & stderr- withForkWait (EX.evaluate $ rnf out) $ \waitOut ->- withForkWait (EX.evaluate $ rnf err) $ \waitErr -> do-- -- now write any input- unless (BL.null input) $- ignoreSigPipe $ BL.hPut inh input- -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE- ignoreSigPipe $ hClose inh-- -- wait on the output- waitOut- waitErr-- hClose outh- hClose errh-- -- wait on the process- ex <- waitForProcess ph- return (ex, BL.fromStrict out, BL.fromStrict err)-- (Nothing,_,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdin handle."- (_,Nothing,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdout handle."- (_,_,Nothing) -> error "readCreateProcessWithExitCodeBS: Failed to get a stderr handle."- where- ignoreSigPipe :: IO () -> IO ()- ignoreSigPipe = EX.handle $ \e -> case e of- IOError { ioe_type = ResourceVanished- , ioe_errno = Just ioe }- | Errno ioe == ePIPE -> return ()- _ -> throwIO e- -- wrapper so we can get exceptions with the appropriate function name.- withCreateProcess_- :: String- -> CreateProcess- -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)- -> IO a- withCreateProcess_ fun c action =- EX.bracketOnError (createProcess_ fun c) cleanupProcess- (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)---- | Fork a thread while doing something else, but kill it if there's an--- exception.------ This is important in the cases above because we want to kill the thread--- that is holding the Handle lock, because when we clean up the process we--- try to close that handle, which could otherwise deadlock.----withForkWait :: IO () -> (IO () -> IO a) -> IO a-withForkWait async' body = do- waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))- mask $ \restore -> do- tid <- forkIO $ try (restore async') >>= putMVar waitVar- let wait' = takeMVar waitVar >>= either throwIO return- restore (body wait') `EX.onException` killThread tid----- | Execute the given command and collect the stdout, stderr and the exit code.--- The command is run in a subprocess.-executeOut :: MonadIO m- => FilePath -- ^ command as filename, e.g. 'ls'- -> [String] -- ^ arguments to the command- -> Maybe FilePath -- ^ chdir to this path- -> m CapturedProcess-executeOut path args chdir = do- cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir })- (exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp ""- pure $ CapturedProcess exit out err---execLogged :: ( MonadReader env m- , HasDirs env- , HasLog env- , HasSettings env- , MonadIO m- , MonadThrow m)- => FilePath -- ^ thing to execute- -> [String] -- ^ args for the thing- -> Maybe FilePath -- ^ optionally chdir into this- -> FilePath -- ^ log filename (opened in append mode)- -> Maybe [(String, String)] -- ^ optional environment- -> m (Either ProcessError ())-execLogged exe args chdir lfile env = do- Dirs {..} <- getDirs- logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args- let stdoutLogfile = logsDir </> lfile <> ".stdout.log"- stderrLogfile = logsDir </> lfile <> ".stderr.log"- cp <- createProcessWithMingwPath ((proc exe args)- { cwd = chdir- , env = env- , std_in = CreatePipe- , std_out = CreatePipe- , std_err = CreatePipe- })- fmap (toProcessError exe args)- $ liftIO- $ withCreateProcess cp- $ \_ mout merr ph ->- case (mout, merr) of- (Just cStdout, Just cStderr) -> do- withForkWait (tee stdoutLogfile cStdout) $ \waitOut ->- withForkWait (tee stderrLogfile cStderr) $ \waitErr -> do- waitOut- waitErr- waitForProcess ph- _ -> fail "Could not acquire out/err handle"-- where- tee :: FilePath -> Handle -> IO ()- tee logFile handle' = go- where- go = do- some <- BS.hGetSome handle' 512- if BS.null some- then pure ()- else do- void $ BS.appendFile logFile some- -- subprocess stdout also goes to stderr for logging- void $ BS.hPut stderr some- go- ---- | Thin wrapper around `executeFile`.-exec :: MonadIO m- => FilePath -- ^ thing to execute- -> [FilePath] -- ^ args for the thing- -> Maybe FilePath -- ^ optionally chdir into this- -> Maybe [(String, String)] -- ^ optional environment- -> m (Either ProcessError ())-exec exe args chdir env = do- cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env })- exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p- pure $ toProcessError exe args exit_code----- | Thin wrapper around `executeFile`.-execShell :: MonadIO m- => FilePath -- ^ thing to execute- -> [FilePath] -- ^ args for the thing- -> Maybe FilePath -- ^ optionally chdir into this- -> Maybe [(String, String)] -- ^ optional environment- -> m (Either ProcessError ())-execShell exe args chdir env = do- let cmd = exe <> " " <> concatMap (' ':) args- cp <- createProcessWithMingwPath ((shell cmd) { cwd = chdir, env = env })- exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p- pure $ toProcessError cmd [] exit_code---chmod_755 :: MonadIO m => FilePath -> m ()-chmod_755 fp =- let perm = setOwnerWritable True emptyPermissions- in liftIO $ setPermissions fp perm---createProcessWithMingwPath :: MonadIO m- => CreateProcess- -> m CreateProcess-createProcessWithMingwPath cp = do- msys2Dir <- liftIO ghcupMsys2Dir- cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp)- let mingWPaths = [msys2Dir </> "usr" </> "bin"- ,msys2Dir </> "mingw64" </> "bin"]- paths = ["PATH", "Path"]- curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths- newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths)- envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths- envWithNewPath = Map.insert "Path" newPath envWithoutPath- liftIO $ setEnv "Path" newPath- pure $ cp { env = Just $ Map.toList envWithNewPath }--ghcupMsys2Dir :: IO FilePath-ghcupMsys2Dir =- lookupEnv "GHCUP_MSYS2" >>= \case- Just fp -> pure fp- Nothing -> do- baseDir <- liftIO ghcupBaseDir- pure (baseDir </> "msys64")---- | Checks whether the binary is a broken link.-isBrokenSymlink :: FilePath -> IO Bool-isBrokenSymlink fp = do- b <- pathIsLink fp- if b- then do- tfp <- getLinkTarget fp- not <$> doesPathExist- -- this drops 'symDir' if 'tfp' is absolute- (takeDirectory fp </> tfp)- else pure False
− lib/GHCup/Utils/Logger.hs
@@ -1,130 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}--{-|-Module : GHCup.Utils.Logger-Description : logger definition-Copyright : (c) Julian Ospald, 2020-License : LGPL-3.0-Maintainer : hasufell@hasufell.de-Stability : experimental-Portability : portable--Here we define our main logger.--}-module GHCup.Utils.Logger where--import GHCup.Types-import GHCup.Types.Optics-import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles)-import GHCup.Utils.String.QQ--import Control.Exception.Safe-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Reader-import Data.Text ( Text )-import Optics-import Prelude hiding ( appendFile )-import System.Console.Pretty-import System.FilePath-import System.IO.Error-import Text.Regex.Posix--import qualified Data.ByteString as B-import GHCup.Utils.Prelude-import qualified Data.Text as T--logInfo :: ( MonadReader env m- , LabelOptic' "loggerConfig" A_Lens env LoggerConfig- , MonadIO m- )- => Text- -> m ()-logInfo = logInternal Info--logWarn :: ( MonadReader env m- , LabelOptic' "loggerConfig" A_Lens env LoggerConfig- , MonadIO m- )- => Text- -> m ()-logWarn = logInternal Warn--logDebug :: ( MonadReader env m- , LabelOptic' "loggerConfig" A_Lens env LoggerConfig- , MonadIO m- )- => Text- -> m ()-logDebug = logInternal Debug--logError :: ( MonadReader env m- , LabelOptic' "loggerConfig" A_Lens env LoggerConfig- , MonadIO m- )- => Text- -> m ()-logError = logInternal Error---logInternal :: ( MonadReader env m- , LabelOptic' "loggerConfig" A_Lens env LoggerConfig- , MonadIO m- ) => LogLevel- -> Text- -> m ()-logInternal logLevel msg = do- LoggerConfig {..} <- gets @"loggerConfig"- let color' c = if fancyColors then color c else id- let style' = case logLevel of- Debug -> style Bold . color' Blue- Info -> style Bold . color' Green- Warn -> style Bold . color' Yellow- Error -> style Bold . color' Red- let l = case logLevel of- Debug -> style' "[ Debug ]"- Info -> style' "[ Info ]"- Warn -> style' "[ Warn ]"- Error -> style' "[ Error ]"- let strs = T.split (== '\n') msg- let out = case strs of- [] -> T.empty- (x:xs) -> - foldr (\a b -> a <> "\n" <> b) mempty- . ((l <> " " <> x) :)- . fmap (\line' -> style' "[ ... ] " <> line' )- $ xs-- when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug)))- $ liftIO $ consoleOutter out-- -- raw output- let lr = case logLevel of- Debug -> "Debug:"- Info -> "Info:"- Warn -> "Warn:"- Error -> "Error:"- let outr = lr <> " " <> msg <> "\n"- liftIO $ fileOutter outr---initGHCupFileLogging :: ( MonadReader env m- , HasDirs env- , MonadIO m- , MonadMask m- ) => m FilePath-initGHCupFileLogging = do- Dirs { logsDir } <- getDirs- let logfile = logsDir </> "ghcup.log"- logFiles <- liftIO $ findFiles- logsDir- (makeRegexOpts compExtended- execBlank- ([s|^.*\.log$|] :: B.ByteString)- )- forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (logsDir </>)-- liftIO $ writeFile logfile ""- pure logfile
− lib/GHCup/Utils/Logger.hs-boot
@@ -1,19 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DataKinds #-}--module GHCup.Utils.Logger where--import GHCup.Types--import Control.Monad.IO.Class-import Control.Monad.Reader-import Data.Text ( Text )-import Optics--logWarn :: ( MonadReader env m- , LabelOptic' "loggerConfig" A_Lens env LoggerConfig- , MonadIO m- )- => Text- -> m ()-
− lib/GHCup/Utils/MegaParsec.hs
@@ -1,124 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}--{-|-Module : GHCup.Utils.MegaParsec-Description : MegaParsec utilities-Copyright : (c) Julian Ospald, 2020-License : LGPL-3.0-Maintainer : hasufell@hasufell.de-Stability : experimental-Portability : portable--}-module GHCup.Utils.MegaParsec where--import GHCup.Types--import Control.Applicative-#if !MIN_VERSION_base(4,13,0)-import Control.Monad.Fail ( MonadFail )-#endif-import Data.Functor-import Data.Maybe-import Data.Text ( Text )-import Data.Versions-import Data.Void-import System.FilePath--import qualified Data.List.NonEmpty as NE-import qualified Data.Text as T-import qualified Text.Megaparsec as MP---choice' :: (MonadFail f, MP.MonadParsec e s f) => [f a] -> f a-choice' [] = fail "Empty list"-choice' [x ] = x-choice' (x : xs) = MP.try x <|> choice' xs---parseUntil :: MP.Parsec Void Text a -> MP.Parsec Void Text Text-parseUntil p = do- (MP.try (MP.lookAhead p) $> mempty)- <|> (do- c <- T.singleton <$> MP.anySingle- c2 <- parseUntil p- pure (c `mappend` c2)- )--parseUntil1 :: MP.Parsec Void Text a -> MP.Parsec Void Text Text-parseUntil1 p = do- i1 <- MP.getOffset- t <- parseUntil p- i2 <- MP.getOffset- if i1 == i2 then fail "empty parse" else pure t------ | Parses e.g.--- * armv7-unknown-linux-gnueabihf-ghc--- * armv7-unknown-linux-gnueabihf-ghci-ghcTargetBinP :: Text -> MP.Parsec Void Text (Maybe Text, Text)-ghcTargetBinP t =- (,)- <$> ( MP.try- (Just <$> parseUntil1 (MP.chunk "-" *> MP.chunk t) <* MP.chunk "-"- )- <|> ((\ _ x -> x) Nothing <$> mempty)- )- <*> (MP.chunk t <* MP.eof)----- | Extracts the version from @ProjectVersion="8.10.5"@.-ghcProjectVersion :: MP.Parsec Void Text Version-ghcProjectVersion = do- _ <- MP.chunk "ProjectVersion=\""- ver <- parseUntil1 $ MP.chunk "\""- MP.setInput ver- version'----- | Extracts target triple and version from e.g.--- * armv7-unknown-linux-gnueabihf-8.8.3--- * armv7-unknown-linux-gnueabihf-8.8.3-ghcTargetVerP :: MP.Parsec Void Text GHCTargetVersion-ghcTargetVerP =- (\x y -> GHCTargetVersion x y)- <$> (MP.try (Just <$> parseUntil1 (MP.chunk "-" *> verP') <* MP.chunk "-")- <|> ((\ _ x -> x) Nothing <$> mempty)- )- <*> (version' <* MP.eof)- where- verP' :: MP.Parsec Void Text Text- verP' = do- v <- version'- let startsWithDigists =- and- . take 3- . concatMap- (map- (\case- (Digits _) -> True- (Str _) -> False- ) . NE.toList)- . NE.toList- $ _vChunks v- if startsWithDigists && isNothing (_vEpoch v)- then pure $ prettyVer v- else fail "Oh"---verP :: MP.Parsec Void Text Text -> MP.Parsec Void Text Versioning-verP suffix = do- ver <- parseUntil suffix- if T.null ver- then fail "empty version"- else do- rest <- MP.getInput- MP.setInput ver- v <- versioning'- MP.setInput rest- pure v---pathSep :: MP.Parsec Void Text Char-pathSep = MP.oneOf pathSeparators
− lib/GHCup/Utils/Posix.hs
@@ -1,14 +0,0 @@-module GHCup.Utils.Posix where----- | Enables ANSI support on windows, does nothing on unix.------ Returns 'Left str' on errors and 'Right bool' on success, where--- 'bool' markes whether ansi support was already enabled.------ This function never crashes.------ Rip-off of https://docs.rs/ansi_term/0.12.1/x86_64-pc-windows-msvc/src/ansi_term/windows.rs.html#10-61-enableAnsiSupport :: IO (Either String Bool)-enableAnsiSupport = pure (Right True)-
− lib/GHCup/Utils/Prelude.hs
@@ -1,765 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}--{-|-Module : GHCup.Utils.Prelude-Description : MegaParsec utilities-Copyright : (c) Julian Ospald, 2020-License : LGPL-3.0-Maintainer : hasufell@hasufell.de-Stability : experimental-Portability : portable--GHCup specific prelude. Lots of Excepts functionality.--}-module GHCup.Utils.Prelude- (module GHCup.Utils.Prelude,-#if defined(IS_WINDOWS)- module GHCup.Utils.Prelude.Windows-#else- module GHCup.Utils.Prelude.Posix-#endif- )-where--import GHCup.Types-import GHCup.Errors-import GHCup.Types.Optics-import {-# SOURCE #-} GHCup.Utils.Logger (logWarn)-#if defined(IS_WINDOWS)-import GHCup.Utils.Prelude.Windows-#else-import GHCup.Utils.Prelude.Posix-#endif--import Control.Applicative-import Control.Exception.Safe-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Reader-import Data.Bifunctor-import Data.ByteString ( ByteString )-import Data.List ( nub, intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse )-import Data.Maybe-import Data.Foldable-import Data.List.NonEmpty ( NonEmpty( (:|) ))-import Data.String-import Data.Text ( Text )-import Data.Versions-import Data.Word8 hiding ( isDigit )-import Haskus.Utils.Types.List-import Haskus.Utils.Variant.Excepts-import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )-import System.IO.Error-import System.IO.Temp-import System.IO.Unsafe-import System.Directory-import System.FilePath--import Control.Retry-import GHC.IO.Exception--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import qualified Data.Strict.Maybe as S-import qualified Data.List.Split as Split-import qualified Data.List.NonEmpty as NE-import qualified Data.Text as T-import qualified Data.Text.Encoding as E-import qualified Data.Text.Encoding.Error as E-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as B-import qualified Data.Text.Lazy.Builder.Int as B-import qualified Data.Text.Lazy.Encoding as TLE----- $setup--- >>> import Data.ByteString.Internal (c2w, w2c)--- >>> import Test.QuickCheck--- >>> import Data.Word8--- >>> import qualified Data.Text as T--- >>> import qualified Data.Char as C--- >>> import Data.List--- >>> instance Arbitrary T.Text where arbitrary = T.pack <$> arbitrary---fS :: IsString a => String -> a-fS = fromString--fromStrictMaybe :: S.Maybe a -> Maybe a-fromStrictMaybe = S.maybe Nothing Just--fSM :: S.Maybe a -> Maybe a-fSM = fromStrictMaybe--toStrictMaybe :: Maybe a -> S.Maybe a-toStrictMaybe = maybe S.Nothing S.Just--tSM :: Maybe a -> S.Maybe a-tSM = toStrictMaybe--internalError :: String -> IO a-internalError = fail . ("Internal error: " <>)--iE :: String -> IO a-iE = internalError---showT :: Show a => a -> Text-showT = fS . show---- | Like 'when', but where the test can be monadic.-whenM :: Monad m => m Bool -> m () -> m ()-whenM ~b ~t = ifM b t (return ())---- | Like 'unless', but where the test can be monadic.-unlessM :: Monad m => m Bool -> m () -> m ()-unlessM ~b ~f = ifM b (return ()) f---- | Like @if@, but where the test can be monadic.-ifM :: Monad m => m Bool -> m a -> m a -> m a-ifM ~b ~t ~f = do- b' <- b- if b' then t else f--whileM :: Monad m => m a -> (a -> m Bool) -> m a-whileM ~action ~f = do- a <- action- b' <- f a- if b' then whileM action f else pure a--whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()-whileM_ ~action = void . whileM action--guardM :: (Monad m, Alternative m) => m Bool -> m ()-guardM ~f = guard =<< f---handleIO' :: (MonadIO m, MonadCatch m)- => IOErrorType- -> (IOException -> m a)- -> m a- -> m a-handleIO' err handler = handleIO- (\e -> if err == ioeGetErrorType e then handler e else liftIO $ ioError e)---(??) :: forall e es a m . (Monad m, e :< es) => Maybe a -> e -> Excepts es m a-(??) m e = maybe (throwE e) pure m---(!?) :: forall e es a m- . (Monad m, e :< es)- => m (Maybe a)- -> e- -> Excepts es m a-(!?) em e = lift em >>= (?? e)---lE :: forall e es a m . (Monad m, e :< es) => Either e a -> Excepts es m a-lE = liftE . veitherToExcepts . fromEither--lE' :: forall e' e es a m- . (Monad m, e :< es)- => (e' -> e)- -> Either e' a- -> Excepts es m a-lE' f = liftE . veitherToExcepts . fromEither . first f--lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a-lEM em = lift em >>= lE--lEM' :: forall e' e es a m- . (Monad m, e :< es)- => (e' -> e)- -> m (Either e' a)- -> Excepts es m a-lEM' f em = lift em >>= lE . first f---- for some obscure reason... this won't type-check if we move it to a different module-catchWarn :: forall es m env . ( Pretty (V es)- , MonadReader env m- , HasLog env- , MonadIO m- , Monad m) => Excepts es m () -> Excepts '[] m ()-catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))--fromEither :: Either a b -> VEither '[a] b-fromEither = either (VLeft . V) VRight---liftIOException' :: ( MonadCatch m- , MonadIO m- , Monad m- , e :< es'- , LiftVariant es es'- )- => IOErrorType- -> e- -> Excepts es m a- -> Excepts es' m a-liftIOException' errType ex =- handleIO- (\e ->- if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e- )- . liftE---liftIOException :: (MonadCatch m, MonadIO m, Monad m, e :< es')- => IOErrorType- -> e- -> m a- -> Excepts es' m a-liftIOException errType ex =- handleIO- (\e ->- if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e- )- . lift----- | Uses safe-exceptions.-hideError :: (MonadIO m, MonadCatch m) => IOErrorType -> m () -> m ()-hideError err = handleIO (\e -> if err == ioeGetErrorType e then pure () else liftIO . ioError $ e)---hideErrorDef :: (MonadIO m, MonadCatch m) => [IOErrorType] -> a -> m a -> m a-hideErrorDef errs def =- handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else liftIO $ ioError e)---hideErrorDefM :: (MonadIO m, MonadCatch m) => [IOErrorType] -> m a -> m a -> m a-hideErrorDefM errs def =- handleIO (\e -> if ioeGetErrorType e `elem` errs then def else liftIO $ ioError e)----- TODO: does this work?-hideExcept :: forall e es es' a m- . (Monad m, e :< es, LiftVariant (Remove e es) es')- => e- -> a- -> Excepts es m a- -> Excepts es' m a-hideExcept _ a =- catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a))---hideExcept' :: forall e es es' m- . (Monad m, e :< es, LiftVariant (Remove e es) es')- => e- -> Excepts es m ()- -> Excepts es' m ()-hideExcept' _ =- catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ()))---reThrowAll :: forall e es es' a m- . (Monad m, e :< es')- => (V es -> e)- -> Excepts es m a- -> Excepts es' m a-reThrowAll f = catchAllE (throwE . f)---reThrowAllIO :: forall e es es' a m- . (MonadCatch m, Monad m, MonadIO m, e :< es')- => (V es -> e)- -> (IOException -> e)- -> Excepts es m a- -> Excepts es' m a-reThrowAllIO f g = handleIO (throwE . g) . catchAllE (throwE . f)---throwEither :: (Exception a, MonadThrow m) => Either a b -> m b-throwEither a = case a of- Left e -> throwM e- Right r -> pure r---throwEither' :: (Exception a, MonadThrow m) => a -> Either x b -> m b-throwEither' e eth = case eth of- Left _ -> throwM e- Right r -> pure r--throwMaybe :: (Exception a, MonadThrow m) => a -> Maybe b -> m b-throwMaybe a m = case m of- Nothing -> throwM a- Just r -> pure r--throwMaybeM :: (Exception a, MonadThrow m) => a -> m (Maybe b) -> m b-throwMaybeM a am = do- m <- am- throwMaybe a m---verToBS :: Version -> ByteString-verToBS = E.encodeUtf8 . prettyVer--verToS :: Version -> String-verToS = T.unpack . prettyVer--intToText :: Integral a => a -> T.Text-intToText = TL.toStrict . B.toLazyText . B.decimal---pvpToVersion :: MonadThrow m => PVP -> Text -> m Version-pvpToVersion pvp_ rest =- either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . (<> rest) . prettyPVP $ pvp_---- | Convert a version to a PVP and unparsable rest.------ -- prop> \v -> let (Just (pvp', r)) = versionToPVP v in pvpToVersion pvp' r === Just v-versionToPVP :: MonadThrow m => Version -> m (PVP, Text)-versionToPVP (Version (Just _) _ _ _) = throwM $ ParseError "Unexpected epoch"-versionToPVP v = either (\_ -> (, rest v) <$> alternative v) (pure . (, mempty)) . pvp . prettyVer $ v- where- alternative :: MonadThrow m => Version -> m PVP- alternative v' = case NE.takeWhile isDigit (_vChunks v') of- [] -> throwM $ ParseError "Couldn't convert Version to PVP"- xs -> pure $ pvpFromList (unsafeDigit <$> xs)-- rest :: Version -> Text- rest (Version _ cs pr me) =- let chunks = NE.dropWhile isDigit cs- ver = intersperse (T.pack ".") . chunksAsT $ chunks- me' = maybe [] (\m -> [T.pack "+",m]) me- pr' = foldable [] (T.pack "-" :) $ intersperse (T.pack ".") (chunksAsT pr)- prefix = case (ver, pr', me') of- (_:_, _, _) -> T.pack "."- _ -> T.pack ""- in prefix <> mconcat (ver <> pr' <> me')- where- chunksAsT :: Functor t => t VChunk -> t Text- chunksAsT = fmap (foldMap f)- where- f :: VUnit -> Text- f (Digits i) = T.pack $ show i- f (Str s) = s-- foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b- foldable d g f | null f = d- | otherwise = g f---- isDigit :: VChunk -> Bool- isDigit (Digits _ :| []) = True- isDigit _ = False-- unsafeDigit :: VChunk -> Int- unsafeDigit (Digits x :| []) = fromIntegral x- unsafeDigit _ = error "unsafeDigit: wrong input"--pvpFromList :: [Int] -> PVP-pvpFromList = PVP . NE.fromList . fmap fromIntegral---- | Safe 'decodeUtf8With'. Replaces an invalid input byte with--- the Unicode replacement character U+FFFD.-decUTF8Safe :: ByteString -> Text-decUTF8Safe = E.decodeUtf8With E.lenientDecode--decUTF8Safe' :: L.ByteString -> Text-decUTF8Safe' = TL.toStrict . TLE.decodeUtf8With E.lenientDecode----- | Escape a version for use in regex-escapeVerRex :: Version -> ByteString-escapeVerRex = B.pack . go . B.unpack . verToBS- where- go [] = []- go (x : xs) | x == _period = [_backslash, _period] ++ go xs- | otherwise = x : go xs---- | More permissive version of 'createDirRecursive'. This doesn't--- error when the destination is a symlink to a directory.-createDirRecursive' :: FilePath -> IO ()-createDirRecursive' p =- handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)- . createDirectoryIfMissing True- $ p-- where- isSymlinkDir e = do- ft <- pathIsSymbolicLink p- case ft of- True -> do- rp <- canonicalizePath p- rft <- doesDirectoryExist rp- case rft of- True -> pure ()- _ -> throwIO e- _ -> throwIO e----- | Recursively copy the contents of one directory to another path.------ This is a rip-off of Cabal library.-copyDirectoryRecursive :: FilePath -> FilePath -> (FilePath -> FilePath -> IO ()) -> IO ()-copyDirectoryRecursive srcDir destDir doCopy = do- srcFiles <- getDirectoryContentsRecursive srcDir- copyFilesWith destDir [ (srcDir, f)- | f <- srcFiles ]- where- -- | Common implementation of 'copyFiles', 'installOrdinaryFiles',- -- 'installExecutableFiles' and 'installMaybeExecutableFiles'.- copyFilesWith :: FilePath -> [(FilePath, FilePath)] -> IO ()- copyFilesWith targetDir srcFiles = do-- -- Create parent directories for everything- let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles- traverse_ (createDirectoryIfMissing True) dirs-- -- Copy all the files- sequence_ [ let src = srcBase </> srcFile- dest = targetDir </> srcFile- in doCopy src dest- | (srcBase, srcFile) <- srcFiles ]----- | List all the files in a directory and all subdirectories.------ The order places files in sub-directories after all the files in their--- parent directories. The list is generated lazily so is not well defined if--- the source directory structure changes before the list is used.----getDirectoryContentsRecursive :: FilePath -> IO [FilePath]-getDirectoryContentsRecursive topdir = recurseDirectories [""]- where- recurseDirectories :: [FilePath] -> IO [FilePath]- recurseDirectories [] = return []- recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do- (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)- files' <- recurseDirectories (dirs' ++ dirs)- return (files ++ files')-- where- collect files dirs' [] = return (reverse files- ,reverse dirs')- collect files dirs' (entry:entries) | ignore entry- = collect files dirs' entries- collect files dirs' (entry:entries) = do- let dirEntry = dir </> entry- isDirectory <- doesDirectoryExist (topdir </> dirEntry)- if isDirectory- then collect files (dirEntry:dirs') entries- else collect (dirEntry:files) dirs' entries-- ignore ['.'] = True- ignore ['.', '.'] = True- ignore _ = False----- https://github.com/haskell/directory/issues/110--- https://github.com/haskell/directory/issues/96--- https://www.sqlite.org/src/info/89f1848d7f-recyclePathForcibly :: ( MonadIO m- , MonadReader env m- , HasDirs env- , MonadMask m- )- => FilePath- -> m ()-recyclePathForcibly fp- | isWindows = do- Dirs { recycleDir } <- getDirs- tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"- let dest = tmp </> takeFileName fp- liftIO (moveFile fp dest)- `catch`- (\e -> if | isDoesNotExistError e -> pure ()- | isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)- | otherwise -> throwIO e)- `finally`- liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)- | otherwise = liftIO $ removePathForcibly fp---rmPathForcibly :: ( MonadIO m- , MonadMask m- )- => FilePath- -> m ()-rmPathForcibly fp- | isWindows = recover (liftIO $ removePathForcibly fp)- | otherwise = liftIO $ removePathForcibly fp---rmDirectory :: (MonadIO m, MonadMask m)- => FilePath- -> m ()-rmDirectory fp- | isWindows = recover (liftIO $ removeDirectory fp)- | otherwise = liftIO $ removeDirectory fp----- https://www.sqlite.org/src/info/89f1848d7f--- https://github.com/haskell/directory/issues/96-recycleFile :: ( MonadIO m- , MonadMask m- , MonadReader env m- , HasDirs env- )- => FilePath- -> m ()-recycleFile fp- | isWindows = do- Dirs { recycleDir } <- getDirs- liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))- tmp <- liftIO $ createTempDirectory recycleDir "recycleFile"- let dest = tmp </> takeFileName fp- liftIO (moveFile fp dest)- `catch`- (\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)- `finally`- liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)- | otherwise = liftIO $ removeFile fp---rmFile :: ( MonadIO m- , MonadMask m- )- => FilePath- -> m ()-rmFile fp- | isWindows = recover (liftIO $ removeFile fp)- | otherwise = liftIO $ removeFile fp---rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)- => FilePath- -> m ()-rmDirectoryLink fp- | isWindows = recover (liftIO $ removeDirectoryLink fp)- | otherwise = liftIO $ removeDirectoryLink fp---recover :: (MonadIO m, MonadMask m) => m a -> m a-recover action = - recovering (fullJitterBackoff 25000 <> limitRetries 10)- [\_ -> Handler (\e -> pure $ isPermissionError e)- ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))- ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))- ]- (\_ -> action)---copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Excepts xs m ()-copyFileE from = handleIO (throwE . CopyError . show) . liftIO . copyFile from----- | Gathering monoidal values------ >>> traverseFold (pure . (:["0"])) ["1","2"]--- ["1","0","2","0"]--- >>> traverseFold Just ["1","2","3","4","5"]--- Just "12345"------ prop> \t -> traverseFold Just t === Just (mconcat t)-traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b-traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)---- | Gathering monoidal values-forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b-forFold = \t -> (`traverseFold` t)----- | Strip @\\r@ and @\\n@ from 'String's------ >>> stripNewline "foo\n\n\n"--- "foo"--- >>> stripNewline "foo\n\n\nfoo"--- "foofoo"--- >>> stripNewline "foo\r"--- "foo"--- >>> stripNewline "foo"--- "foo"------ prop> \t -> stripNewline (t <> "\n") === stripNewline t--- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewline t == t-stripNewline :: String -> String-stripNewline = filter (`notElem` "\n\r")----- | Strip @\\r@ and @\\n@ from end of 'String'.------ >>> stripNewlineEnd "foo\n\n\n"--- "foo"--- >>> stripNewlineEnd "foo\n\n\nfoo"--- "foo\n\n\nfoo"--- >>> stripNewlineEnd "foo\r"--- "foo"--- >>> stripNewlineEnd "foo"--- "foo"------ prop> \t -> stripNewlineEnd (t <> "\n") === stripNewlineEnd t--- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewlineEnd t == t-stripNewlineEnd :: String -> String-stripNewlineEnd = dropWhileEnd (`elem` "\n\r")----- | Strip @\\r@ and @\\n@ from 'Text's------ >>> stripNewline' "foo\n\n\n"--- "foo"--- >>> stripNewline' "foo\n\n\nfoo"--- "foofoo"--- >>> stripNewline' "foo\r"--- "foo"--- >>> stripNewline' "foo"--- "foo"------ prop> \t -> stripNewline' (t <> "\n") === stripNewline' t--- prop> \t -> not (T.any (isNewLine . c2w) t) ==> stripNewline' t == t-stripNewline' :: T.Text -> T.Text-stripNewline' = T.filter (`notElem` "\n\r")----- | Is the word8 a newline?------ >>> isNewLine (c2w '\n')--- True--- >>> isNewLine (c2w '\r')--- True------ prop> \w -> w /= _lf && w /= _cr ==> not (isNewLine w)-isNewLine :: Word8 -> Bool-isNewLine w- | w == _lf = True- | w == _cr = True- | otherwise = False----- | Split on a PVP suffix.------ >>> splitOnPVP "-" "ghc-iserv-dyn-9.3.20210706"--- ("ghc-iserv-dyn","9.3.20210706")--- >>> splitOnPVP "-" "ghc-iserv-dyn"--- ("ghc-iserv-dyn","")-splitOnPVP :: String -> String -> (String, String)-splitOnPVP c s = case Split.splitOn c s of- [] -> def- [_] -> def- xs- | let l = last xs- , (Right _) <- pvp (T.pack l) -> (intercalate c (init xs), l)- | otherwise -> def- where- def = (s, "")------ | Like 'find', but where the test can be monadic.------ >>> findM (Just . C.isUpper) "teST"--- Just (Just 'S')--- >>> findM (Just . C.isUpper) "test"--- Just Nothing--- >>> findM (Just . const True) ["x",undefined]--- Just (Just "x")-findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)-findM ~p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing)----- | Drops the given suffix from a list.--- It returns the original sequence if the sequence doesn't end with the given suffix.------ >>> dropSuffix "!" "Hello World!"--- "Hello World"--- >>> dropSuffix "!" "Hello World!!"--- "Hello World!"--- >>> dropSuffix "!" "Hello World."--- "Hello World."-dropSuffix :: Eq a => [a] -> [a] -> [a]-dropSuffix a b = fromMaybe b $ stripSuffix a b---- | Return the prefix of the second list if its suffix--- matches the entire first list.------ >>> stripSuffix "bar" "foobar"--- Just "foo"--- >>> stripSuffix "" "baz"--- Just "baz"--- >>> stripSuffix "foo" "quux"--- Nothing-stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]-stripSuffix a b = reverse <$> stripPrefix (reverse a) (reverse b)----- | Drops the given prefix from a list.--- It returns the original sequence if the sequence doesn't start with the given prefix.------ >>> dropPrefix "Mr. " "Mr. Men"--- "Men"--- >>> dropPrefix "Mr. " "Dr. Men"--- "Dr. Men"-dropPrefix :: Eq a => [a] -> [a] -> [a]-dropPrefix a b = fromMaybe b $ stripPrefix a b------ | Break a list into pieces separated by the first--- list argument, consuming the delimiter. An empty delimiter is--- invalid, and will cause an error to be raised.------ >>> splitOn "\r\n" "a\r\nb\r\nd\r\ne"--- ["a","b","d","e"]--- >>> splitOn "aaa" "aaaXaaaXaaaXaaa"--- ["","X","X","X",""]--- >>> splitOn "x" "x"--- ["",""]--- >>> splitOn "x" ""--- [""]------ prop> \s x -> s /= "" ==> intercalate s (splitOn s x) == x--- prop> \c x -> splitOn [c] x == split (==c) x-splitOn :: Eq a => [a] -> [a] -> [[a]]-splitOn [] _ = error "splitOn, needle may not be empty"-splitOn _ [] = [[]]-splitOn needle haystack = a : if null b then [] else splitOn needle $ drop (length needle) b- where (a,b) = breakOn needle haystack----- | Splits a list into components delimited by separators,--- where the predicate returns True for a separator element. The--- resulting components do not contain the separators. Two adjacent--- separators result in an empty component in the output.------ >>> split (== 'a') "aabbaca"--- ["","","bb","c",""]--- >>> split (== 'a') ""--- [""]--- >>> split (== ':') "::xyz:abc::123::"--- ["","","xyz","abc","","123","",""]--- >>> split (== ',') "my,list,here"--- ["my","list","here"]-split :: (a -> Bool) -> [a] -> [[a]]-split _ [] = [[]]-split f (x:xs)- | f x = [] : split f xs- | y:ys <- split f xs = (x:y) : ys- | otherwise = [[]]----- | Find the first instance of @needle@ in @haystack@.--- The first element of the returned tuple--- is the prefix of @haystack@ before @needle@ is matched. The second--- is the remainder of @haystack@, starting with the match.--- If you want the remainder /without/ the match, use 'stripInfix'.------ >>> breakOn "::" "a::b::c"--- ("a","::b::c")--- >>> breakOn "/" "foobar"--- ("foobar","")------ prop> \needle haystack -> let (prefix,match) = breakOn needle haystack in prefix ++ match == haystack-breakOn :: Eq a => [a] -> [a] -> ([a], [a])-breakOn needle haystack | needle `isPrefixOf` haystack = ([], haystack)-breakOn _ [] = ([], [])-breakOn needle (x:xs) = first (x:) $ breakOn needle xs-
− lib/GHCup/Utils/Prelude/Posix.hs
@@ -1,20 +0,0 @@-module GHCup.Utils.Prelude.Posix where--import System.Directory-import System.Posix.Files---isWindows, isNotWindows :: Bool-isWindows = False-isNotWindows = not isWindows---moveFile :: FilePath -> FilePath -> IO ()-moveFile = rename---moveFilePortable :: FilePath -> FilePath -> IO ()-moveFilePortable from to = do- copyFile from to- removeFile from-
− lib/GHCup/Utils/Prelude/Windows.hs
@@ -1,17 +0,0 @@-module GHCup.Utils.Prelude.Windows where--import qualified System.Win32.File as Win32---isWindows, isNotWindows :: Bool-isWindows = True-isNotWindows = not isWindows---moveFile :: FilePath -> FilePath -> IO ()-moveFile from to = Win32.moveFileEx from (Just to) 0---moveFilePortable :: FilePath -> FilePath -> IO ()-moveFilePortable = Win32.moveFile-
− lib/GHCup/Utils/String/QQ.hs
@@ -1,57 +0,0 @@-{-# LANGUAGE TemplateHaskellQuotes #-}--{-|-Module : GHCup.Utils.String.QQ-Description : String quasi quoters-Copyright : (c) Audrey Tang <audreyt@audreyt.org> 2019, Julian Ospald <hasufell@posteo.de> 2020-License : LGPL-3.0-Maintainer : hasufell@hasufell.de-Stability : experimental-Portability : portable--QuasiQuoter for non-interpolated strings, texts and bytestrings.--The "s" quoter contains a multi-line string with no interpolation at all,-except that the leading newline is trimmed and carriage returns stripped.--@-{-\# LANGUAGE QuasiQuotes #-}-import Data.Text (Text)-import Data.String.QQ-foo :: Text -- "String", "ByteString" etc also works-foo = [s|-Well here is a- multi-line string!-|]-@--Any instance of the IsString type is permitted.--(For GHC versions 6, write "[$s||]" instead of "[s||]".)---}-module GHCup.Utils.String.QQ- ( s- )-where---import Data.Char-import GHC.Exts ( IsString(..) )-import Language.Haskell.TH.Quote---- | QuasiQuoter for a non-interpolating ASCII IsString literal.--- The pattern portion is undefined.-s :: QuasiQuoter-s = QuasiQuoter- (\s' -> case all isAscii s' of- True -> (\a -> [|fromString a|]) . trimLeadingNewline . removeCRs $ s'- False -> fail "Not ascii"- )- (error "Cannot use s as a pattern")- (error "Cannot use s as a type")- (error "Cannot use s as a dec")- where- removeCRs = filter (/= '\r')- trimLeadingNewline ('\n' : xs) = xs- trimLeadingNewline xs = xs
− lib/GHCup/Utils/Version/QQ.hs
@@ -1,107 +0,0 @@-{-# OPTIONS_GHC -Wno-orphans #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskellQuotes #-}---{-|-Module : GHCup.Utils.Version.QQ-Description : Version quasi-quoters-Copyright : (c) Julian Ospald, 2020-License : LGPL-3.0-Maintainer : hasufell@hasufell.de-Stability : experimental-Portability : portable--}-module GHCup.Utils.Version.QQ where--import Data.Data-import Data.Text ( Text )-import Data.Versions-#if !MIN_VERSION_base(4,13,0)-import GHC.Base-#endif-import Language.Haskell.TH-import Language.Haskell.TH.Quote ( QuasiQuoter(..) )-import Language.Haskell.TH.Syntax ( Lift- , dataToExpQ- )-import qualified Data.Text as T-import qualified Language.Haskell.TH.Syntax as TH----deriving instance Data Versioning-deriving instance Lift Versioning-deriving instance Data Version-deriving instance Lift Version-deriving instance Data SemVer-deriving instance Lift SemVer-deriving instance Data Mess-deriving instance Lift Mess-deriving instance Data MChunk-deriving instance Lift MChunk-deriving instance Data PVP-deriving instance Lift PVP-deriving instance Lift VSep-deriving instance Data VSep-deriving instance Lift VUnit-deriving instance Data VUnit--#if !MIN_VERSION_base(4,13,0)-deriving instance Lift (NonEmpty Word)-deriving instance Lift (NonEmpty VChunk)-deriving instance Lift (NonEmpty MChunk)-deriving instance Lift (NonEmpty VUnit)-#endif--qq :: (Text -> Q Exp) -> QuasiQuoter-qq quoteExp' = QuasiQuoter- { quoteExp = \s -> quoteExp' . T.pack $ s- , quotePat = \_ ->- fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"- , quoteType = \_ ->- fail "illegal QuasiQuote (allowed as expression only, used as a type)"- , quoteDec = \_ -> fail- "illegal QuasiQuote (allowed as expression only, used as a declaration)"- }--vver :: QuasiQuoter-vver = qq mkV- where- mkV :: Text -> Q Exp- mkV = either (fail . show) liftDataWithText . version--mver :: QuasiQuoter-mver = qq mkV- where- mkV :: Text -> Q Exp- mkV = either (fail . show) liftDataWithText . mess--sver :: QuasiQuoter-sver = qq mkV- where- mkV :: Text -> Q Exp- mkV = either (fail . show) liftDataWithText . semver--vers :: QuasiQuoter-vers = qq mkV- where- mkV :: Text -> Q Exp- mkV = either (fail . show) liftDataWithText . versioning--pver :: QuasiQuoter-pver = qq mkV- where- mkV :: Text -> Q Exp- mkV = either (fail . show) liftDataWithText . pvp---- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable-liftText :: T.Text -> Q Exp-liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)--liftDataWithText :: Data a => a -> Q Exp-liftDataWithText = dataToExpQ (fmap liftText . cast)
− lib/GHCup/Utils/Windows.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}--module GHCup.Utils.Windows where---import Control.Exception.Safe-import Control.Monad-#if !MIN_VERSION_base(4,13,0)-import Control.Monad.Fail ( MonadFail )-#endif-import Data.Bits--import System.Win32.Console-import System.Win32.File hiding ( copyFile )-import System.Win32.Types------- | Enables ANSI support on windows, does nothing on unix.------ Returns 'Left str' on errors and 'Right bool' on success, where--- 'bool' markes whether ansi support was already enabled.------ This function never crashes.------ Rip-off of https://docs.rs/ansi_term/0.12.1/x86_64-pc-windows-msvc/src/ansi_term/windows.rs.html#10-61-enableAnsiSupport :: IO (Either String Bool)-enableAnsiSupport = handleIO (pure . Left . displayException) $ do- -- ref: https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilew- -- Using `CreateFileW("CONOUT$", ...)` to retrieve the console handle works correctly even if STDOUT and/or STDERR are redirected- h <- createFile "CONOUT$" (gENERIC_WRITE .|. gENERIC_READ)- fILE_SHARE_WRITE Nothing oPEN_EXISTING 0 Nothing- when (h == iNVALID_HANDLE_VALUE ) $ fail "invalid handle value"-- -- ref: https://docs.microsoft.com/en-us/windows/console/getconsolemode- m <- getConsoleMode h-- -- VT processing not already enabled?- if m .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING == 0- -- https://docs.microsoft.com/en-us/windows/console/setconsolemode- then setConsoleMode h (m .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING)- >> pure (Right False)- else pure (Right True)-
lib/GHCup/Version.hs view
@@ -16,12 +16,18 @@ import Paths_ghcup (version) import Data.Version (Version(versionBranch))-import Data.Versions hiding (version) import URI.ByteString import URI.ByteString.QQ import qualified Data.List.NonEmpty as NE import qualified Data.Text as T+import qualified Data.Versions as V+import Control.Exception.Safe (MonadThrow)+import Data.Text (Text)+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.List (intersperse)+import Control.Monad.Catch (throwM)+import GHCup.Errors (ParseError(..)) -- | This reflects the API version of the YAML. --@@ -31,22 +37,72 @@ ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.7.yaml|] -- | The current ghcup version.-ghcUpVer :: PVP-ghcUpVer = PVP . NE.fromList . fmap fromIntegral $ versionBranch version+ghcUpVer :: V.PVP+ghcUpVer = V.PVP . NE.fromList . fmap fromIntegral $ versionBranch version -- | ghcup version as numeric string. numericVer :: String-numericVer = T.unpack . prettyPVP $ ghcUpVer+numericVer = T.unpack . V.prettyPVP $ ghcUpVer -versionCmp :: Versioning -> VersionCmp -> Bool+versionCmp :: V.Versioning -> VersionCmp -> Bool versionCmp ver1 (VR_gt ver2) = ver1 > ver2 versionCmp ver1 (VR_gteq ver2) = ver1 >= ver2 versionCmp ver1 (VR_lt ver2) = ver1 < ver2 versionCmp ver1 (VR_lteq ver2) = ver1 <= ver2 versionCmp ver1 (VR_eq ver2) = ver1 == ver2 -versionRange :: Versioning -> VersionRange -> Bool+versionRange :: V.Versioning -> VersionRange -> Bool versionRange ver' (SimpleRange cmps) = and $ fmap (versionCmp ver') cmps versionRange ver' (OrRange cmps range) = versionRange ver' (SimpleRange cmps) || versionRange ver' range +pvpToVersion :: MonadThrow m => V.PVP -> Text -> m V.Version+pvpToVersion pvp_ rest =+ either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . V.version . (<> rest) . V.prettyPVP $ pvp_++-- | Convert a version to a PVP and unparsable rest.+--+-- -- prop> \v -> let (Just (pvp', r)) = versionToPVP v in pvpToVersion pvp' r === Just v+versionToPVP :: MonadThrow m => V.Version -> m (V.PVP, Text)+versionToPVP (V.Version (Just _) _ _ _) = throwM $ ParseError "Unexpected epoch"+versionToPVP v = either (\_ -> (, rest v) <$> alternative v) (pure . (, mempty)) . V.pvp . V.prettyVer $ v+ where+ alternative :: MonadThrow m => V.Version -> m V.PVP+ alternative v' = case NE.takeWhile isDigit (V._vChunks v') of+ [] -> throwM $ ParseError "Couldn't convert Version to PVP"+ xs -> pure $ pvpFromList (unsafeDigit <$> xs)++ rest :: V.Version -> Text+ rest (V.Version _ cs pr me) =+ let chunks = NE.dropWhile isDigit cs+ ver = intersperse (T.pack ".") . chunksAsT $ chunks+ me' = maybe [] (\m -> [T.pack "+",m]) me+ pr' = foldable [] (T.pack "-" :) $ intersperse (T.pack ".") (chunksAsT pr)+ prefix = case (ver, pr', me') of+ (_:_, _, _) -> T.pack "."+ _ -> T.pack ""+ in prefix <> mconcat (ver <> pr' <> me')+ where+ chunksAsT :: Functor t => t V.VChunk -> t Text+ chunksAsT = fmap (foldMap f)+ where+ f :: V.VUnit -> Text+ f (V.Digits i) = T.pack $ show i+ f (V.Str s) = s++ foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b+ foldable d g f | null f = d+ | otherwise = g f++++ isDigit :: V.VChunk -> Bool+ isDigit (V.Digits _ :| []) = True+ isDigit _ = False++ unsafeDigit :: V.VChunk -> Int+ unsafeDigit (V.Digits x :| []) = fromIntegral x+ unsafeDigit _ = error "unsafeDigit: wrong input"++pvpFromList :: [Int] -> V.PVP+pvpFromList = V.PVP . NE.fromList . fmap fromIntegral
+ test/GHCup/Utils/FileSpec.hs view
@@ -0,0 +1,58 @@+module GHCup.Utils.FileSpec where++import GHCup.Prelude.File++import Data.List+import System.Directory+import System.FilePath+import System.IO.Unsafe+import qualified Streamly.Prelude as S++import Test.Hspec++++spec :: Spec+spec = do+ describe "GHCup.Utils.File" $ do+ it "getDirectoryContentsRecursiveBFS" $ do+ l1 <- sort <$> S.toList (getDirectoryContentsRecursiveBFSUnsafe "lib")+ l2 <- sort <$> getDirectoryContentsRecursiveLazy "lib"+ not (null l1) `shouldBe` True+ not (null l2) `shouldBe` True+ l1 `shouldBe` l2+ it "getDirectoryContentsRecursiveDFS" $ do+ l1 <- sort <$> S.toList (getDirectoryContentsRecursiveDFSUnsafe "lib")+ l2 <- sort <$> getDirectoryContentsRecursiveLazy "lib"+ not (null l1) `shouldBe` True+ not (null l2) `shouldBe` True+ l1 `shouldBe` l2+++getDirectoryContentsRecursiveLazy :: FilePath -> IO [FilePath]+getDirectoryContentsRecursiveLazy topdir = recurseDirectories [""]+ where+ recurseDirectories :: [FilePath] -> IO [FilePath]+ recurseDirectories [] = return []+ recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do+ (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)+ files' <- recurseDirectories (dirs' ++ dirs)+ return (files ++ files')++ where+ collect files dirs' [] = return (reverse files+ ,reverse dirs')+ collect files dirs' (entry:entries) | ignore entry+ = collect files dirs' entries+ collect files dirs' (entry:entries) = do+ let dirEntry = dir </> entry+ isDirectory <- doesDirectoryExist (topdir </> dirEntry)+ if isDirectory+ then collect files (dirEntry:dirs') entries+ else collect (dirEntry:files) dirs' entries++ ignore ['.'] = True+ ignore ['.', '.'] = True+ ignore _ = False++
test/Main.hs view
@@ -1,10 +1,9 @@ import Test.Hspec.Runner-import Test.Hspec.Formatters import qualified Spec main :: IO () main = hspecWith- defaultConfig { configFormatter = Just progress }+ defaultConfig Spec.spec