ghcup 0.1.17.4 → 0.1.17.5
raw patch · 30 files changed
+1017/−391 lines, 30 filesdep +terminal-sizePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: terminal-size
API changes (from Hackage documentation)
- GHCup.Utils: ghcLinkDestination :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) => FilePath -> GHCTargetVersion -> m FilePath
- GHCup.Utils: hlsSymlinks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [FilePath]
- GHCup.Utils: rmMajorSymlinks :: (MonadReader env m, HasDirs env, MonadIO m, HasLog env, MonadThrow m, MonadFail m, MonadMask m) => GHCTargetVersion -> Excepts '[NotInstalled] m ()
- GHCup.Utils: rmMinorSymlinks :: (MonadReader env m, HasDirs env, MonadIO m, HasLog env, MonadThrow m, MonadFail m, MonadMask m) => GHCTargetVersion -> Excepts '[NotInstalled] m ()
- GHCup.Utils: rmPlain :: (MonadReader env m, HasDirs env, HasLog env, MonadThrow m, MonadFail m, MonadIO m, MonadMask m) => Maybe Text -> Excepts '[NotInstalled] m ()
- GHCup.Utils.File.Common: [_exitCode] :: CapturedProcess -> ExitCode
- GHCup.Utils.File.Common: [_stdErr] :: CapturedProcess -> ByteString
- GHCup.Utils.File.Common: [_stdOut] :: CapturedProcess -> ByteString
- GHCup.Utils.File.Common: exitCode :: Lens' CapturedProcess ExitCode
- GHCup.Utils.File.Common: instance GHC.Classes.Eq GHCup.Utils.File.Common.CapturedProcess
- GHCup.Utils.File.Common: instance GHC.Show.Show GHCup.Utils.File.Common.CapturedProcess
- GHCup.Utils.File.Common: instance GHC.Show.Show GHCup.Utils.File.Common.ProcessError
- GHCup.Utils.File.Common: instance Text.PrettyPrint.HughesPJClass.Pretty GHCup.Utils.File.Common.ProcessError
- GHCup.Utils.File.Common: stdErr :: Lens' CapturedProcess ByteString
- GHCup.Utils.File.Common: stdOut :: Lens' CapturedProcess ByteString
- GHCup.Utils.Prelude: removeLensFieldLabel :: String -> String
+ GHCup: checkIfToolInstalled' :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Tool -> GHCTargetVersion -> m Bool
+ GHCup: installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Maybe Version -> Bool -> Excepts '[CopyError, FileAlreadyExistsError] m ()
+ GHCup: isLegacyHLSBindist :: FilePath -> IO Bool
+ GHCup.Types: CapturedProcess :: ExitCode -> ByteString -> ByteString -> CapturedProcess
+ GHCup.Types: NoSuchPid :: FilePath -> [String] -> ProcessError
+ GHCup.Types: NonZeroExit :: Int -> FilePath -> [String] -> ProcessError
+ GHCup.Types: PStopped :: FilePath -> [String] -> ProcessError
+ GHCup.Types: PTerminated :: FilePath -> [String] -> ProcessError
+ GHCup.Types: SetHLSOnly :: SetHLS
+ GHCup.Types: SetHLS_XYZ :: SetHLS
+ GHCup.Types: [$sel:_exitCode:CapturedProcess] :: CapturedProcess -> ExitCode
+ GHCup.Types: [$sel:_stdErr:CapturedProcess] :: CapturedProcess -> ByteString
+ GHCup.Types: [$sel:_stdOut:CapturedProcess] :: CapturedProcess -> ByteString
+ GHCup.Types: data CapturedProcess
+ GHCup.Types: data ProcessError
+ GHCup.Types: data SetHLS
+ GHCup.Types: exitCode :: Lens' CapturedProcess ExitCode
+ GHCup.Types: instance GHC.Classes.Eq GHCup.Types.CapturedProcess
+ GHCup.Types: instance GHC.Classes.Eq GHCup.Types.SetHLS
+ GHCup.Types: instance GHC.Show.Show GHCup.Types.CapturedProcess
+ GHCup.Types: instance GHC.Show.Show GHCup.Types.ProcessError
+ GHCup.Types: instance GHC.Show.Show GHCup.Types.SetHLS
+ GHCup.Types: instance Text.PrettyPrint.HughesPJClass.Pretty GHCup.Types.ProcessError
+ GHCup.Types: stdErr :: Lens' CapturedProcess ByteString
+ GHCup.Types: stdOut :: Lens' CapturedProcess ByteString
+ GHCup.Types.JSON.Utils: removeLensFieldLabel :: String -> String
+ GHCup.Utils: binarySymLinkDestination :: (MonadThrow m, MonadIO m) => FilePath -> FilePath -> m FilePath
+ GHCup.Utils: ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m) => GHCTargetVersion -> m FilePath
+ GHCup.Utils: hlsInternalServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadFail m) => Version -> Maybe Version -> m [FilePath]
+ GHCup.Utils: hlsInternalServerLibs :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadFail m) => Version -> Version -> m [FilePath]
+ GHCup.Utils: hlsInternalServerScripts :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> Maybe Version -> m [FilePath]
+ GHCup.Utils: installDestSanityCheck :: (MonadIO m, MonadCatch m) => FilePath -> Excepts '[DirNotEmpty] m ()
+ GHCup.Utils: isLegacyHLS :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
+ GHCup.Utils: rmMajorGHCSymlinks :: (MonadReader env m, HasDirs env, MonadIO m, HasLog env, MonadThrow m, MonadFail m, MonadMask m) => GHCTargetVersion -> Excepts '[NotInstalled] m ()
+ GHCup.Utils: rmMinorGHCSymlinks :: (MonadReader env m, HasDirs env, MonadIO m, HasLog env, MonadThrow m, MonadFail m, MonadMask m) => GHCTargetVersion -> Excepts '[NotInstalled] m ()
+ GHCup.Utils: rmMinorHLSSymlinks :: (MonadReader env m, HasDirs env, MonadIO m, HasLog env, MonadThrow m, MonadFail m, MonadMask m) => Version -> Excepts '[NotInstalled] m ()
+ GHCup.Utils: rmPlainGHC :: (MonadReader env m, HasDirs env, HasLog env, MonadThrow m, MonadFail m, MonadIO m, MonadMask m) => Maybe Text -> Excepts '[NotInstalled] m ()
+ GHCup.Utils: rmPlainHLS :: (MonadReader env m, HasDirs env, HasLog env, MonadThrow m, MonadFail m, MonadIO m, MonadMask m) => Excepts '[NotInstalled] m ()
+ GHCup.Utils.Dirs: ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
+ GHCup.Utils.Dirs: ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m) => Version -> m FilePath
+ GHCup.Utils.Dirs: parseGHCupHLSDir :: MonadThrow m => FilePath -> m Version
+ 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: expandFilePath :: [Either FilePath Regex] -> IO [FilePath]
- 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 -> Maybe FilePath -> Bool -> Excepts '[AlreadyInstalled, CopyError, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError] 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 -> Maybe FilePath -> 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 -> Maybe FilePath -> Bool -> Excepts '[AlreadyInstalled, CopyError, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError] 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 -> Maybe FilePath -> Bool -> Excepts '[AlreadyInstalled, CopyError, DigestError, GPGError, DownloadFailed, NoDownload, NotInstalled, UnknownArchive, TarDirDoesNotExist, ArchiveResult, FileAlreadyExistsError, ProcessError, DirNotEmpty] m ()
- GHCup: installHLSUnpacked :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Maybe Version -> Bool -> Excepts '[CopyError, FileAlreadyExistsError] m ()
+ GHCup: installHLSUnpacked :: (MonadMask m, MonadUnliftIO m, MonadReader env m, MonadFail m, HasLog env, HasDirs env, HasSettings env, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Version -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m ()
- GHCup: rmHLSNoGHC :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m, MonadMask m) => m ()
+ GHCup: rmHLSNoGHC :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m, MonadMask m, MonadFail m, MonadUnliftIO m) => Excepts '[NotInstalled] m ()
- GHCup: setGHC :: (MonadReader env m, HasDirs env, HasLog env, MonadThrow m, MonadFail m, MonadIO m, MonadCatch m, MonadMask m, MonadUnliftIO m) => GHCTargetVersion -> SetGHC -> Excepts '[NotInstalled] m GHCTargetVersion
+ GHCup: 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: setHLS :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m, MonadMask m, MonadFail m, MonadUnliftIO m) => Version -> Excepts '[NotInstalled] m ()
+ GHCup: setHLS :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m, MonadMask m, MonadFail m, MonadUnliftIO m) => Version -> SetHLS -> Maybe FilePath -> Excepts '[NotInstalled] m ()
Files
- CHANGELOG.md +14/−0
- app/ghcup/BrickMain.hs +2/−2
- app/ghcup/GHCup/OptParse.hs +21/−0
- app/ghcup/GHCup/OptParse/Common.hs +0/−12
- app/ghcup/GHCup/OptParse/Compile.hs +9/−4
- app/ghcup/GHCup/OptParse/GC.hs +1/−1
- app/ghcup/GHCup/OptParse/Install.hs +94/−15
- app/ghcup/GHCup/OptParse/Run.hs +348/−0
- app/ghcup/GHCup/OptParse/Set.hs +4/−4
- app/ghcup/GHCup/OptParse/Upgrade.hs +6/−6
- app/ghcup/Main.hs +17/−2
- ghcup.cabal +21/−4
- lib/GHCup.hs +160/−92
- lib/GHCup/Platform.hs +1/−1
- lib/GHCup/Types.hs +33/−1
- lib/GHCup/Types/JSON.hs +3/−4
- lib/GHCup/Types/JSON/Utils.hs +17/−0
- lib/GHCup/Utils.hs +205/−83
- lib/GHCup/Utils/Dirs.hs +23/−0
- lib/GHCup/Utils/File/Common.hs +22/−31
- lib/GHCup/Utils/File/Posix.hs +6/−6
- lib/GHCup/Utils/File/Windows.hs +2/−1
- lib/GHCup/Utils/Logger.hs +1/−2
- lib/GHCup/Utils/Logger.hs-boot +0/−2
- lib/GHCup/Utils/Prelude.hs +4/−7
- lib/GHCup/Utils/String/QQ.hs +1/−1
- lib/GHCup/Utils/Version/QQ.hs +1/−1
- lib/GHCup/Version.hs +1/−1
- lib/System/Console/Terminal/Common.hs +0/−43
- lib/System/Console/Terminal/Posix.hsc +0/−65
CHANGELOG.md view
@@ -1,5 +1,18 @@ # Revision history for ghcup +## 0.1.17.5 -- 2022-02-26++* Implement `ghcup run` subcommand wrt [#137](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/137)+* Support installation of dynamic HLS bindists wrt [HLS #2675](https://github.com/haskell/haskell-language-server/pull/2675) and [#237](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/237)+* Fix XDG support when `~/.local/bin` is a symlink wrt [#311](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/311)+* Add support for quilt-style patches wrt [#230](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/230), by James Hobson+* Fix redundant upgrade warnings in `ghcup upgrade`+* Fix `ghcup whereis ghc` for non-standard versions wrt [#289](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/289)+* Don't print logs to stdout, but stderr+* Allow unpacking legacy lzma archives wrt [#307](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/307)+* Allow to disable self-upgrade functionality wrt [#305](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/305)+* Fix `ghcup install ghc --set` when ghc is already installed wrt [#291](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/291)+ ## 0.1.17.4 -- 2021-11-13 * add `--metadata-caching` option, allowing to also disable yaml metadata caching wrt [#278](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/278)@@ -7,6 +20,7 @@ * fix parsing of atypical GHC versions (e.g. `8.10.5-patch1`) * fix compiling HLS dynamically linked, also see [#245](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/245) * redo (and break) some of the `ghcup compile <tool>` interface, improving patch options and setting custom cabal.project files+* avoid redundant update warnings wrt [#283](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/283) ## 0.1.17.3 -- 2021-10-27
app/ghcup/BrickMain.hs view
@@ -493,9 +493,9 @@ run (do case lTool of- GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()+ GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly Nothing $> () Cabal -> liftE $ setCabal lVer $> ()- HLS -> liftE $ setHLS lVer $> ()+ HLS -> liftE $ setHLS lVer SetHLSOnly Nothing $> () Stack -> liftE $ setStack lVer $> () GHCup -> pure () )
app/ghcup/GHCup/OptParse.hs view
@@ -15,13 +15,16 @@ , module GHCup.OptParse.Config , module GHCup.OptParse.Whereis , module GHCup.OptParse.List+#ifndef DISABLE_UPGRADE , module GHCup.OptParse.Upgrade+#endif , module GHCup.OptParse.ChangeLog , module GHCup.OptParse.Prefetch , module GHCup.OptParse.GC , module GHCup.OptParse.DInfo , module GHCup.OptParse.Nuke , module GHCup.OptParse.ToolRequirements+ , module GHCup.OptParse.Run , module GHCup.OptParse ) where @@ -31,11 +34,14 @@ import GHCup.OptParse.Set import GHCup.OptParse.UnSet import GHCup.OptParse.Rm+import GHCup.OptParse.Run import GHCup.OptParse.Compile import GHCup.OptParse.Config import GHCup.OptParse.Whereis import GHCup.OptParse.List+#ifndef DISABLE_UPGRADE import GHCup.OptParse.Upgrade+#endif import GHCup.OptParse.ChangeLog import GHCup.OptParse.Prefetch import GHCup.OptParse.GC@@ -89,7 +95,9 @@ | Compile CompileCommand | Config ConfigCommand | Whereis WhereisOptions WhereisCommand+#ifndef DISABLE_UPGRADE | Upgrade UpgradeOpts Bool+#endif | ToolRequirements | ChangeLog ChangeLogOptions | Nuke@@ -98,6 +106,7 @@ #endif | Prefetch PrefetchCommand | GC GCOptions+ | Run RunOptions @@ -208,6 +217,7 @@ (info (List <$> listOpts <**> helper) (progDesc "Show available GHCs and other tools") )+#ifndef DISABLE_UPGRADE <> command "upgrade" (info@@ -218,6 +228,7 @@ ) (progDesc "Upgrade ghcup") )+#endif <> command "compile" ( Compile@@ -255,6 +266,16 @@ (progDesc "Garbage collection" <> footerDoc ( Just $ text gcFooter )) )+ <> command+ "run"+ (Run+ <$>+ info+ (runOpts <**> helper)+ (progDesc "Run a command with the given tool in PATH"+ <> footerDoc ( Just $ text runFooter )+ )+ ) <> commandGroup "Main commands:" ) <|> subparser
app/ghcup/GHCup/OptParse/Common.hs view
@@ -89,18 +89,6 @@ mv _ = "VERSION|TAG" -toolVersionOption :: Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion-toolVersionOption criteria tool =- option (eitherReader toolVersionEither)- ( sh tool- <> completer (tagCompleter (fromMaybe GHC tool) [])- <> foldMap (completer . versionCompleter criteria) tool)- where- sh (Just GHC) = long "ghc" <> metavar "GHC_VERSION|TAG"- sh (Just HLS) = long "hls" <> metavar "HLS_VERSION|TAG"- sh _ = long "version" <> metavar "VERSION|TAG"-- versionParser :: Parser GHCTargetVersion versionParser = option (eitherReader tVersionEither)
app/ghcup/GHCup/OptParse/Compile.hs view
@@ -212,7 +212,7 @@ (fmap Left $ option str (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help- "Absolute path to patch directory (applies all .patch and .diff files in order using -p1)"+ "Absolute path to patch directory (applies all .patch and .diff files in order using -p1. This order is determined by a quilt series file if it exists, or the patches are lexicographically ordered)" ) ) )@@ -340,7 +340,12 @@ ) ) )- <*> some (toolVersionOption Nothing (Just GHC))+ <*> some (+ option (eitherReader toolVersionEither)+ ( 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))+ ) <*> many (argument str (metavar "CABAL_ARGS" <> help "Additional arguments to cabal install, prefix with '-- ' (longopts)")) @@ -461,7 +466,7 @@ GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo targetVer HLS dls when setCompile $ void $ liftE $- setHLS targetVer+ setHLS targetVer SetHLSOnly Nothing pure (vi, targetVer) ) >>= \case@@ -512,7 +517,7 @@ GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo let vi = getVersionInfo (_tvVersion targetVer) GHC dls when setCompile $ void $ liftE $- setGHC targetVer SetGHCOnly+ setGHC targetVer SetGHCOnly Nothing pure (vi, targetVer) ) >>= \case
app/ghcup/GHCup/OptParse/GC.hs view
@@ -132,7 +132,7 @@ when gcOldGHC rmOldGHC lift $ when gcProfilingLibs rmProfilingLibs lift $ when gcShareDir rmShareDir- lift $ when gcHLSNoGHC rmHLSNoGHC+ liftE $ when gcHLSNoGHC rmHLSNoGHC lift $ when gcCache rmCache lift $ when gcTmp rmTmp ) >>= \case
app/ghcup/GHCup/OptParse/Install.hs view
@@ -17,7 +17,6 @@ import GHCup import GHCup.Errors import GHCup.Types-import GHCup.Utils.File import GHCup.Utils.Logger import GHCup.Utils.String.QQ @@ -268,7 +267,65 @@ @InstallEffects +type InstallGHCEffects = '[ TagNotFound+ , NextVerNotFound+ , NoToolVersionSet+ , BuildFailed+ , 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)+ ]++runInstGHC :: AppState+ -> Maybe PlatformRequest+ -> Excepts InstallGHCEffects (ResourceT (ReaderT AppState IO)) a+ -> IO (VEither InstallGHCEffects a)+runInstGHC appstate' mInstPlatform =+ flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)+ . runResourceT+ . runE+ @InstallGHCEffects++ ------------------- --[ Entrypoints ]-- -------------------@@ -288,23 +345,25 @@ installGHC InstallOptions{..} = do s'@AppState{ dirs = Dirs{ .. } } <- liftIO getAppState' (case instBindist of- Nothing -> runInstTool s' instPlatform $ do+ Nothing -> runInstGHC s' instPlatform $ do (v, vi) <- liftE $ fromVersion instVer GHC- liftE $ installGHCBin- (_tvVersion v)- isolateDir- forceInstall- when instSet $ void $ liftE $ setGHC v SetGHCOnly- pure vi- Just uri -> do- runInstTool s'{ settings = settings {noVerify = True}} instPlatform $ do- (v, vi) <- liftE $ fromVersion instVer GHC- liftE $ installGHCBindist- (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")+ void $ liftE $ sequenceE (installGHCBin (_tvVersion v) isolateDir forceInstall- when instSet $ void $ liftE $ setGHC v SetGHCOnly+ )+ $ when instSet $ 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+ (DownloadInfo uri (Just $ RegexDir "ghc-.*") "")+ (_tvVersion v)+ isolateDir+ forceInstall+ )+ $ when instSet $ void $ setGHC v SetGHCOnly Nothing pure vi ) >>= \case@@ -313,14 +372,25 @@ forM_ (_viPostInstall =<< vi) $ \msg -> runLogger $ logInfo msg pure ExitSuccess++ VLeft (V (AlreadyInstalled _ v, ())) -> do+ runLogger $ logWarn $+ "GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'"+ pure ExitSuccess VLeft (V (AlreadyInstalled _ v)) -> do runLogger $ logWarn $ "GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup install ghc --force " <> prettyVer v <> "'" pure ExitSuccess+ VLeft (V (DirNotEmpty fp)) -> do runLogger $ logWarn $ "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless." pure $ ExitFailure 3+ VLeft (V (DirNotEmpty fp, ())) -> do+ runLogger $ logWarn $+ "Install directory " <> T.pack fp <> " is not empty. Use 'ghcup install ghc --isolate " <> T.pack fp <> " --force ..." <> "' to install regardless."+ pure $ ExitFailure 3+ VLeft err@(V (BuildFailed tmpdir _)) -> do case keepDirs settings of Never -> runLogger (logError $ T.pack $ prettyShow err)@@ -328,6 +398,14 @@ "Check the logs at " <> T.pack 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+ 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" <>+ "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")+ pure $ ExitFailure 3+ VLeft e -> do runLogger $ do logError $ T.pack $ prettyShow e@@ -390,8 +468,9 @@ Just uri -> do runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do (v, vi) <- liftE $ fromVersion instVer HLS+ -- TODO: support legacy liftE $ installHLSBindist- (DownloadInfo uri Nothing "")+ (DownloadInfo uri (Just $ RegexDir "haskell-language-server-*") "") (_tvVersion v) isolateDir forceInstall
+ app/ghcup/GHCup/OptParse/Run.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+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 ( getDirs )+import GHCup.Utils.Logger+import GHCup.Utils.String.QQ++import Control.Exception.Safe ( MonadMask, MonadCatch )+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail ( MonadFail )+#endif+import Codec.Archive+import Control.Monad.Reader+import Control.Monad.Trans.Resource+import Data.Functor+import Data.Maybe (isNothing)+import Data.List ( intercalate )+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.IO.Temp+import System.Exit+import Text.PrettyPrint.HughesPJClass ( prettyShow )++import qualified Data.Map.Strict as Map+import qualified Data.Text as T+#ifndef IS_WINDOWS+import qualified System.Posix.Process as SPP+#endif++++++ ---------------+ --[ Options ]--+ ---------------+++data RunOptions = RunOptions+ { runAppendPATH :: Bool+ , runInstTool' :: Bool+ , runGHCVer :: Maybe ToolVersion+ , runCabalVer :: Maybe ToolVersion+ , runHLSVer :: Maybe ToolVersion+ , runStackVer :: Maybe ToolVersion+ , runBinDir :: Maybe FilePath+ , runCOMMAND :: [String]+ }++++ ---------------+ --[ Parsers ]--+ ---------------++ +runOpts :: Parser RunOptions+runOpts =+ RunOptions+ <$> switch+ (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")+ <*> optional+ (option+ (eitherReader toolVersionEither)+ (metavar "GHC_VERSION" <> long "ghc" <> help "The ghc version")+ )+ <*> optional+ (option+ (eitherReader toolVersionEither)+ (metavar "CABAL_VERSION" <> long "cabal" <> help "The cabal version")+ )+ <*> optional+ (option+ (eitherReader toolVersionEither)+ (metavar "HLS_VERSION" <> long "hls" <> help "The HLS version")+ )+ <*> optional+ (option+ (eitherReader toolVersionEither)+ (metavar "STACK_VERSION" <> long "stack" <> help "The stack version")+ )+ <*> optional+ (option+ (eitherReader isolateParser)+ ( short 'b'+ <> long "bindir"+ <> metavar "DIR"+ <> help "directory where to create the tool symlinks (default: newly created system temp dir)"+ )+ )+ <*> many (argument str (metavar "COMMAND" <> help "The command to run, with arguments (use longopts --). If omitted, just prints the created bin/ dir to stdout and exits."))+ ++++ --------------+ --[ Footer ]--+ --------------+++runFooter :: String+runFooter = [s|Discussion:+ Adds the given tools to a dedicated bin/ directory and adds them to PATH, exposing+ the relevant binaries, then executes a command.++Examples:+ # run VSCode with all latest toolchain exposed, installing missing versions if necessary+ ghcup run --ghc latest --cabal latest --hls latest --stack latest --install -- code Setup.hs++ # create a custom toolchain bin/ dir with GHC and cabal that can be manually added to PATH+ ghcup run --ghc 8.10.7 --cabal 3.2.0.0 --bindir $HOME/toolchain/bin++ # run a specific ghc version+ ghcup run --ghc 8.10.7 -- ghc --version|]+++++ ---------------------------+ --[ Effect interpreters ]--+ ---------------------------+++type RunEffects = '[ AlreadyInstalled+ , UnknownArchive+ , ArchiveResult+ , FileDoesNotExistError+ , CopyError+ , NotInstalled+ , DirNotEmpty+ , NoDownload+ , NotInstalled+ , BuildFailed+ , TagNotFound+ , DigestError+ , GPGError+ , DownloadFailed+ , TarDirDoesNotExist+ , NextVerNotFound+ , NoToolVersionSet+ , FileAlreadyExistsError+ , ProcessError+ ]++runLeanRUN :: (MonadUnliftIO m, MonadIO m)+ => LeanAppState+ -> Excepts RunEffects (ReaderT LeanAppState m) a+ -> m (VEither RunEffects a)+runLeanRUN leanAppstate =+ -- Don't use runLeanAppState here, which is disabled on windows.+ -- This is the only command on all platforms that doesn't need full appstate.+ flip runReaderT leanAppstate+ . runE+ @RunEffects++runRUN :: MonadUnliftIO m+ => (ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a))+ -> Excepts RunEffects (ResourceT (ReaderT AppState m)) a+ -> m (VEither RunEffects a)+runRUN runAppState =+ runAppState+ . runResourceT+ . runE+ @RunEffects++++ ------------------+ --[ Entrypoint ]--+ ------------------++++run :: forall m. + ( MonadFail m+ , MonadMask m+ , MonadCatch m+ , MonadIO m+ , MonadUnliftIO m+ )+ => RunOptions+ -> (forall a. ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a))+ -> LeanAppState+ -> (ReaderT LeanAppState m () -> m ())+ -> m ExitCode+run RunOptions{..} runAppState leanAppstate runLogger = do+ tmp <- case runBinDir of+ Just bdir -> do+ liftIO $ createDirRecursive' bdir+ liftIO $ canonicalizePath bdir+ Nothing -> liftIO (getTemporaryDirectory >>= \tmp -> createTempDirectory tmp "ghcup")+ r <- do+ addToolsToDir tmp+ case r of+ VRight _ -> do+ case runCOMMAND of+ [] -> do+ liftIO $ putStr tmp+ pure ExitSuccess+ (cmd:args) -> do+ newEnv <- liftIO $ addToPath tmp+#ifndef IS_WINDOWS+ void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)+ pure ExitSuccess+#else+ r' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)+ case r' of+ VRight _ -> pure ExitSuccess+ VLeft e -> do+ runLogger $ logError $ T.pack $ prettyShow e+ pure $ ExitFailure 28+#endif+ VLeft e -> do+ runLogger $ logError $ T.pack $ prettyShow e+ pure $ ExitFailure 27+ where+ isToolTag :: ToolVersion -> Bool+ isToolTag (ToolTag _) = True+ isToolTag _ = False++ -- TODO: doesn't work for cross+ addToolsToDir tmp+ | or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool' = runRUN runAppState $ do+ forM_ runGHCVer $ \ver -> do+ (v, _) <- liftE $ fromVersion (Just ver) GHC+ installTool GHC v+ setTool GHC v tmp+ forM_ runCabalVer $ \ver -> do+ (v, _) <- liftE $ fromVersion (Just ver) Cabal+ installTool Cabal v+ setTool Cabal v tmp+ forM_ runHLSVer $ \ver -> do+ (v, _) <- liftE $ fromVersion (Just ver) HLS+ installTool HLS v+ setTool HLS v tmp+ forM_ runStackVer $ \ver -> do+ (v, _) <- liftE $ fromVersion (Just ver) Stack+ installTool Stack v+ setTool Stack v tmp+ | otherwise = runLeanRUN leanAppstate $ do+ case runGHCVer of+ Just (ToolVersion v) ->+ setTool GHC v tmp+ Nothing -> pure ()+ _ -> fail "Internal error"+ case runCabalVer of+ Just (ToolVersion v) ->+ setTool Cabal v tmp+ Nothing -> pure ()+ _ -> fail "Internal error"+ case runHLSVer of+ Just (ToolVersion v) ->+ setTool HLS v tmp+ Nothing -> pure ()+ _ -> fail "Internal error"+ case runStackVer of+ Just (ToolVersion v) ->+ setTool Stack v tmp+ Nothing -> pure ()+ _ -> fail "Internal error"++ installTool tool v = do+ isInstalled <- checkIfToolInstalled' tool v+ case tool of+ GHC -> do+ unless isInstalled $ when (runInstTool' && isNothing (_tvTarget v)) $ void $ liftE $ installGHCBin+ (_tvVersion v)+ Nothing+ False+ Cabal -> do+ unless isInstalled $ when runInstTool' $ void $ liftE $ installCabalBin+ (_tvVersion v)+ Nothing+ False+ Stack -> do+ unless isInstalled $ when runInstTool' $ void $ liftE $ installStackBin+ (_tvVersion v)+ Nothing+ False+ HLS -> do+ unless isInstalled $ when runInstTool' $ void $ liftE $ installHLSBin+ (_tvVersion v)+ Nothing+ False+ GHCup -> pure ()++ setTool tool v tmp =+ case tool of+ GHC -> do+ void $ liftE $ setGHC v SetGHC_XYZ (Just tmp)+ void $ liftE $ setGHC v SetGHCOnly (Just tmp)+ Cabal -> do+ bin <- liftE $ whereIsTool Cabal v+ cbin <- liftIO $ canonicalizePath bin+ lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("cabal" <.> exeExt))+ Stack -> do+ bin <- liftE $ whereIsTool Stack v+ cbin <- liftIO $ canonicalizePath bin+ lift $ createLink (relativeSymlink tmp cbin) (tmp </> ("stack" <.> exeExt))+ HLS -> do+ Dirs {..} <- getDirs+ let v' = _tvVersion v+ legacy <- isLegacyHLS v'+ if legacy+ then do+ -- TODO: factor this out+ (Just hlsWrapper) <- hlsWrapperBinary v'+ cw <- liftIO $ canonicalizePath (binDir </> hlsWrapper)+ lift $ createLink (relativeSymlink tmp cw) (tmp </> takeFileName cw)+ 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)+ else do+ liftE $ setHLS (_tvVersion v) SetHLS_XYZ (Just tmp)+ liftE $ setHLS (_tvVersion v) SetHLSOnly (Just tmp)+ GHCup -> pure ()+ + addToPath path = do+ cEnv <- Map.fromList <$> getEnvironment+ let paths = ["PATH", "Path"]+ curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths+ newPath = intercalate [searchPathSeparator] (if runAppendPATH then (curPaths ++ [path]) else (path : curPaths))+ envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths+ pathVar = if isWindows then "Path" else "PATH"+ envWithNewPath = Map.toList $ Map.insert pathVar newPath envWithoutPath+ liftIO $ setEnv pathVar newPath+ return envWithNewPath
app/ghcup/GHCup/OptParse/Set.hs view
@@ -271,10 +271,10 @@ -> m ExitCode setGHC' SetOptions{ sToolVer } = case sToolVer of- (SetToolVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly >> pure v)+ (SetToolVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly Nothing >> pure v) _ -> runSetGHC runAppState (do v <- liftE $ fst <$> fromVersion' sToolVer GHC- liftE $ setGHC v SetGHCOnly+ liftE $ setGHC v SetGHCOnly Nothing ) >>= \case VRight GHCTargetVersion{..} -> do@@ -311,10 +311,10 @@ -> m ExitCode setHLS' SetOptions{ sToolVer } = case sToolVer of- (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) >> pure v)+ (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing >> pure v) _ -> runSetHLS runAppState (do v <- liftE $ fst <$> fromVersion' sToolVer HLS- liftE $ setHLS (_tvVersion v)+ liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing pure v ) >>= \case
app/ghcup/GHCup/OptParse/Upgrade.hs view
@@ -113,17 +113,17 @@ upgrade :: ( Monad m- , MonadMask m- , MonadUnliftIO m- , MonadFail m- )+ , MonadMask m+ , MonadUnliftIO m+ , MonadFail m+ ) => UpgradeOpts -> Bool+ -> Dirs -> (forall a. ReaderT AppState m (VEither UpgradeEffects a) -> m (VEither UpgradeEffects a)) -> (ReaderT LeanAppState m () -> m ()) -> m ExitCode-upgrade uOpts force' runAppState runLogger = do- VRight Dirs{ .. } <- runAppState (VRight <$> getDirs)+upgrade uOpts force' Dirs{..} runAppState runLogger = do target <- case uOpts of UpgradeInplace -> Just <$> liftIO getExecutablePath (UpgradeAt p) -> pure $ Just p
app/ghcup/Main.hs view
@@ -140,7 +140,12 @@ <> hidden ) let listCommands = infoOption- "install set rm install-cabal list upgrade compile debug-info tool-requirements changelog"+ ("install set rm install-cabal list"+#ifndef DISABLE_UPGRADE+ <> " upgrade"+#endif+ <> " compile debug-info tool-requirements changelog"+ ) ( long "list-commands" <> help "List available commands for shell completion" <> internal@@ -238,10 +243,14 @@ alreadyInstalling' <- alreadyInstalling optCommand newTool when (not alreadyInstalling') $ case t of+#ifdef DISABLE_UPGRADE+ GHCup -> pure ()+#else GHCup -> runLogger $ logWarn ("New GHCup version available: " <> prettyVer l <> ". To upgrade, run 'ghcup upgrade'")+#endif _ -> runLogger $ logWarn ("New " <> T.pack (prettyShow t)@@ -296,12 +305,15 @@ Config configCommand -> config configCommand settings keybindings runLogger Whereis whereisOptions whereisCommand -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger- Upgrade uOpts force' -> upgrade uOpts force' runAppState runLogger+#ifndef DISABLE_UPGRADE+ Upgrade uOpts force' -> upgrade uOpts force' dirs runAppState runLogger+#endif ToolRequirements -> toolRequirements runAppState runLogger ChangeLog changelogOpts -> changelog changelogOpts runAppState runLogger Nuke -> nuke appState runLogger Prefetch pfCom -> prefetch pfCom runAppState runLogger GC gcOpts -> gc gcOpts runAppState runLogger+ Run runCommand -> run runCommand runAppState leanAppstate runLogger case res of ExitSuccess -> pure ()@@ -339,6 +351,9 @@ (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+#ifndef DISABLE_UPGRADE+ alreadyInstalling (Upgrade _ _) (GHCup, _) = pure True+#endif alreadyInstalling _ _ = pure False cmp' :: ( HasLog env
ghcup.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghcup-version: 0.1.17.4+version: 0.1.17.5 license: LGPL-3.0-only license-file: LICENSE copyright: Julian Ospald 2020@@ -48,6 +48,13 @@ default: False manual: True +flag disable-upgrade+ description:+ Build the brick powered tui (ghcup tui). This is disabled on windows.++ default: False+ manual: True+ library exposed-modules: GHCup@@ -58,6 +65,7 @@ GHCup.Requirements GHCup.Types GHCup.Types.JSON+ GHCup.Types.JSON.Utils GHCup.Types.Optics GHCup.Utils GHCup.Utils.Dirs@@ -166,11 +174,10 @@ GHCup.Utils.File.Posix GHCup.Utils.Posix GHCup.Utils.Prelude.Posix- System.Console.Terminal.Common- System.Console.Terminal.Posix build-depends: , bz2 >=0.5.0.5 && <1.1+ , terminal-size ^>=0.3.2.1 , unix ^>=2.7 , unix-bytestring ^>=0.3.7.3 @@ -193,10 +200,10 @@ GHCup.OptParse.Nuke GHCup.OptParse.Prefetch GHCup.OptParse.Rm+ GHCup.OptParse.Run GHCup.OptParse.Set GHCup.OptParse.ToolRequirements GHCup.OptParse.UnSet- GHCup.OptParse.Upgrade GHCup.OptParse.Whereis hs-source-dirs: app/ghcup@@ -237,6 +244,7 @@ , resourcet ^>=1.2.2 , safe ^>=0.3.18 , safe-exceptions ^>=0.1+ , temporary ^>=1.3 , template-haskell >=2.7 && <2.18 , text ^>=1.2.4.0 , uri-bytestring ^>=0.3.2.2@@ -259,9 +267,18 @@ if os(windows) cpp-options: -DIS_WINDOWS+ else+ build-depends:+ , unix ^>=2.7 if flag(no-exe) buildable: False++ if (flag(disable-upgrade))+ cpp-options: -DDISABLE_UPGRADE+ else+ other-modules:+ GHCup.OptParse.Upgrade test-suite ghcup-test type: exitcode-stdio-1.0
lib/GHCup.hs view
@@ -5,8 +5,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-} {-| Module : GHCup@@ -301,24 +301,8 @@ liftE $ runBuildAction tmpUnpack (Just inst) (installUnpackedGHC workdir inst ver)- where- -- | Does basic checks for isolated installs- -- Isolated Directory:- -- 1. if it doesn't exist -> proceed- -- 2. if it exists and is empty -> proceed- -- 3. if it exists and is non-empty -> panic and leave the house- installDestSanityCheck :: ( MonadIO m- , MonadCatch m- ) =>- FilePath ->- Excepts '[DirNotEmpty] m ()- installDestSanityCheck isoDir = do- hideErrorDef [doesNotExistErrorType] () $ do- contents <- liftIO $ getDirectoryContentsRecursive isoDir- unless (null contents) (throwE $ DirNotEmpty isoDir) - -- | Install an unpacked GHC distribution. This only deals with the GHC -- build system and nothing else. installUnpackedGHC :: ( MonadReader env m@@ -582,6 +566,8 @@ , TarDirDoesNotExist , ArchiveResult , FileAlreadyExistsError+ , ProcessError+ , DirNotEmpty ] m ()@@ -617,29 +603,58 @@ -- 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+ , (Just fp) <- isoFilepath -> liftE $ installDestSanityCheck fp+ | otherwise -> pure ()+ case isoFilepath of Just isoDir -> do lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir- liftE $ installHLSUnpacked workdir isoDir Nothing forceInstall+ if legacy+ then liftE $ installHLSUnpackedLegacy workdir isoDir Nothing forceInstall+ else liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir isoDir ver Nothing -> do- liftE $ installHLSUnpacked workdir binDir (Just ver) forceInstall+ if legacy+ then liftE $ installHLSUnpackedLegacy workdir binDir (Just ver) forceInstall+ else do+ inst <- ghcupHLSDir ver+ liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir inst ver+ liftE $ setHLS ver SetHLS_XYZ Nothing liftE $ installHLSPostInst isoFilepath ver +isLegacyHLSBindist :: FilePath -- ^ Path to the unpacked hls bindist+ -> IO Bool+isLegacyHLSBindist path = do+ not <$> doesFileExist (path </> "GNUmakefile") -- | Install an unpacked hls distribution.-installHLSUnpacked :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)- => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)- -> FilePath -- ^ Path to install to- -> Maybe Version -- ^ Nothing for isolated install- -> Bool -- ^ is it a force install- -> Excepts '[CopyError, FileAlreadyExistsError] m ()-installHLSUnpacked path inst mver' forceInstall = do+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)+ -> FilePath -- ^ Path to install to+ -> Version+ -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled] m ()+installHLSUnpacked path 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)+ -> FilePath -- ^ Path to install to+ -> Maybe Version -- ^ Nothing for isolated install+ -> Bool -- ^ is it a force install+ -> Excepts '[CopyError, FileAlreadyExistsError] m ()+installHLSUnpackedLegacy path inst mver' forceInstall = do+ lift $ logInfo "Installing HLS"+ liftIO $ createDirRecursive' inst+ -- install haskell-language-server-<ghcver> bins@(_:_) <- liftIO $ findFiles path@@ -692,7 +707,7 @@ -- create symlink if this is the latest version in a regular install hlsVers <- lift $ fmap rights getInstalledHLSs let lInstHLS = headMay . reverse . sort $ hlsVers- when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver+ when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver SetHLSOnly Nothing -- | Installs hls binaries @haskell-language-server-\<ghcver\>@@@ -725,6 +740,8 @@ , TarDirDoesNotExist , ArchiveResult , FileAlreadyExistsError+ , ProcessError+ , DirNotEmpty ] m ()@@ -894,9 +911,9 @@ case isolateDir of Just isoDir -> do lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir- liftE $ installHLSUnpacked installDir isoDir Nothing True+ liftE $ installHLSUnpackedLegacy installDir isoDir Nothing True Nothing -> do- liftE $ installHLSUnpacked installDir binDir (Just installVer) True+ liftE $ installHLSUnpackedLegacy installDir binDir (Just installVer) True ) liftE $ installHLSPostInst isolateDir installVer@@ -1075,22 +1092,29 @@ ) => 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 = do+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- Dirs {..} <- lift getDirs+ 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)- case sghc of- SetGHCOnly -> liftE $ rmPlain (_tvTarget ver)- SetGHC_XY -> liftE $ rmMajorSymlinks ver- SetGHC_XYZ -> liftE $ rmMinorSymlinks ver+ 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@@ -1109,15 +1133,17 @@ -- create symlink forM_ mTargetFile $ \targetFile -> do+ bindir <- ghcInternalBinDir ver let fullF = binDir </> targetFile <> exeExt- fileWithExt = file <> exeExt- destL <- lift $ ghcLinkDestination fileWithExt ver+ fileWithExt = bindir </> file <> exeExt+ destL <- binarySymLinkDestination binDir fileWithExt lift $ createLink destL fullF - -- create symlink for share dir- when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS+ when (isNothing mBinDir) $ do+ -- create symlink for share dir+ when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS - when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility+ when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility pure ver @@ -1170,7 +1196,7 @@ ) => Maybe Text -> Excepts '[NotInstalled] m ()-unsetGHC = rmPlain+unsetGHC = rmPlainGHC -- | Set the @~\/.ghcup\/bin\/cabal@ symlink.@@ -1222,37 +1248,62 @@ , MonadUnliftIO m ) => Version+ -> SetHLS -- Nothing for legacy+ -> 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 = do- Dirs {..} <- lift getDirs+setHLS ver shls mBinDir = do+ whenM (lift $ not <$> hlsInstalled ver) (throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))) - -- Delete old symlinks, since these might have different ghc versions than the- -- selected version, so we could end up with stray or incorrect symlinks.- oldSyms <- lift hlsSymlinks- forM_ oldSyms $ \f -> do- lift $ logDebug $ "rm " <> T.pack (binDir </> f)- lift $ rmLink (binDir </> f)+ -- symlink destination+ binDir <- case mBinDir of+ Just x -> pure x+ Nothing -> do+ Dirs {binDir = f} <- lift getDirs+ pure f - -- set haskell-language-server-<ghcver> symlinks- bins <- lift $ hlsServerBinaries ver Nothing- when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)+ -- 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 - forM_ bins $ \f -> do- let destL = f- let target = (<> exeExt) . head . splitOn "~" $ f- lift $ createLink destL (binDir </> target)+ case shls of+ -- not for legacy+ SetHLS_XYZ -> do+ bins <- lift $ hlsInternalServerScripts ver Nothing - -- 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+ 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) - lift $ createLink destL wrapper+ -- 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) - lift warnAboutHlsCompatibility+ forM_ bins $ \f -> do+ let destL = f+ let target = (<> exeExt) . head . splitOn "~" $ f+ lift $ createLink destL (binDir </> target) - pure ()+ -- 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@@ -1720,14 +1771,14 @@ -- this isn't atomic, order matters when isSetGHC $ do lift $ logInfo "Removing ghc symlinks"- liftE $ rmPlain (_tvTarget ver)+ liftE $ rmPlainGHC (_tvTarget ver) lift $ logInfo "Removing ghc-x.y.z symlinks"- liftE $ rmMinorSymlinks ver+ liftE $ rmMinorGHCSymlinks ver lift $ logInfo "Removing/rewiring ghc-x.y symlinks" -- first remove- handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorSymlinks ver+ handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver -- then fix them (e.g. with an earlier version) lift $ logInfo $ "Removing directory recursively: " <> T.pack dir@@ -1739,7 +1790,7 @@ $ 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)+ >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing) Dirs {..} <- lift getDirs @@ -1794,24 +1845,19 @@ rmHLSVer ver = do whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)) - isHlsSet <- lift hlsSet-- Dirs {..} <- lift getDirs+ isHlsSet <- lift hlsSet - bins <- lift $ hlsAllBinaries ver- forM_ bins $ \f -> lift $ recycleFile (binDir </> f)+ liftE $ rmMinorHLSSymlinks ver+ hlsDir <- ghcupHLSDir ver+ recyclePathForcibly hlsDir when (Just ver == isHlsSet) $ do -- delete all set symlinks- oldSyms <- lift hlsSymlinks- forM_ oldSyms $ \f -> do- let fullF = binDir </> f- lift $ logDebug $ "rm " <> T.pack fullF- lift $ rmLink fullF+ rmPlainHLS -- set latest hls hlsVers <- lift $ fmap rights getInstalledHLSs case headMay . reverse . sort $ hlsVers of- Just latestver -> setHLS latestver+ Just latestver -> setHLS latestver SetHLSOnly Nothing Nothing -> pure () @@ -2245,7 +2291,7 @@ Nothing -> do reThrowAll GHCupSetError $ postGHCInstall installVer -- restore- when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly+ when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly Nothing _ -> pure () @@ -2639,7 +2685,7 @@ => GHCTargetVersion -> Excepts '[NotInstalled] m () postGHCInstall ver@GHCTargetVersion {..} = do- void $ liftE $ setGHC ver SetGHC_XYZ+ void $ liftE $ setGHC ver SetGHC_XYZ Nothing -- Create ghc-x.y symlinks. This may not be the current -- version, create it regardless.@@ -2648,7 +2694,7 @@ $ fmap Just $ getMajorMinorV _tvVersion forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) _tvTarget)- >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)+ >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing) -- | Reports the binary location of a given tool:@@ -2687,7 +2733,11 @@ HLS -> do whenM (lift $ fmap not $ hlsInstalled _tvVersion) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing _tvVersion))- pure (binDir dirs </> "haskell-language-server-wrapper-" <> T.unpack (prettyVer _tvVersion) <> exeExt)+ 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)@@ -2705,13 +2755,21 @@ Tool -> Version -> m Bool+checkIfToolInstalled tool ver = checkIfToolInstalled' tool (mkTVer ver) -checkIfToolInstalled tool ver =+checkIfToolInstalled' :: ( MonadIO m+ , MonadReader env m+ , HasDirs env+ , MonadCatch m) =>+ Tool ->+ GHCTargetVersion ->+ m Bool+checkIfToolInstalled' tool ver = case tool of- Cabal -> cabalInstalled ver- HLS -> hlsInstalled ver- Stack -> stackInstalled ver- GHC -> ghcInstalled $ mkTVer ver+ Cabal -> cabalInstalled (_tvVersion ver)+ HLS -> hlsInstalled (_tvVersion ver)+ Stack -> stackInstalled (_tvVersion ver)+ GHC -> ghcInstalled ver _ -> pure False throwIfFileAlreadyExists :: ( MonadIO m ) =>@@ -2800,21 +2858,31 @@ , HasLog env , MonadIO m , MonadMask m+ , MonadFail m+ , MonadUnliftIO m )- => 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- forM_ hlsGHCs $ \ghc -> do - when (ghc `notElem` ghcs) $ do- bins <- hlsServerBinaries hls (Just $ _tvVersion ghc)- forM_ bins $ \bin -> do- let f = binDir </> bin+ 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
lib/GHCup/Platform.hs view
@@ -4,7 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-} {-|
lib/GHCup/Types.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DuplicateRecordFields #-} {-|@@ -30,12 +31,15 @@ import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Text ( Text ) import Data.Versions-import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)+import GHC.IO.Exception ( ExitCode )+import Optics ( makeLenses )+import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text, (<+>)) import URI.ByteString #if defined(BRICK) import Graphics.Vty ( Key(..) ) #endif +import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified GHC.Generics as GHC @@ -484,7 +488,11 @@ | SetGHC_XYZ -- ^ ghc-x.y.z deriving (Eq, Show) +data SetHLS = SetHLSOnly -- ^ unversioned 'hls'+ | SetHLS_XYZ -- ^ haskell-language-server-a.b.c~x.y.z, where a.b.c is GHC version and x.y.z is HLS version+ deriving (Eq, Show) + data PlatformResult = PlatformResult { _platform :: Platform , _distroVersion :: Maybe Versioning@@ -596,3 +604,27 @@ instance NFData LoggerConfig where rnf (LoggerConfig !lcPrintDebug !_ !_ !fancyColors) = rnf (lcPrintDebug, fancyColors)++data ProcessError = NonZeroExit Int FilePath [String]+ | PTerminated FilePath [String]+ | PStopped FilePath [String]+ | NoSuchPid FilePath [String]+ deriving Show++instance Pretty ProcessError where+ pPrint (NonZeroExit e exe args) =+ text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".")+ pPrint (PTerminated exe args) =+ text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated."+ pPrint (PStopped exe args) =+ text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped."+ pPrint (NoSuchPid exe args) =+ text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."+data CapturedProcess = CapturedProcess+ { _exitCode :: ExitCode+ , _stdOut :: BL.ByteString+ , _stdErr :: BL.ByteString+ }+ deriving (Eq, Show)++makeLenses ''CapturedProcess
lib/GHCup/Types/JSON.hs view
@@ -22,10 +22,8 @@ module GHCup.Types.JSON where import GHCup.Types+import GHCup.Types.JSON.Utils import GHCup.Utils.MegaParsec-import GHCup.Utils.Prelude-import GHCup.Utils.Logger () -- TH is broken shite and needs GHCup.Utils.Logger for linking, although we don't depend on the file.- -- This is due to the boot file. import Control.Applicative ( (<|>) ) import Data.Aeson hiding (Key)@@ -40,6 +38,7 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Text as T+import qualified Data.Text.Encoding.Error as E import qualified Text.Megaparsec as MP import qualified Text.Megaparsec.Char as MPC @@ -78,7 +77,7 @@ x -> pure (UnknownTag x) instance ToJSON URI where- toJSON = toJSON . decUTF8Safe . serializeURIRef'+ toJSON = toJSON . E.decodeUtf8With E.lenientDecode . serializeURIRef' instance FromJSON URI where parseJSON = withText "URL" $ \t ->
+ lib/GHCup/Types/JSON/Utils.hs view
@@ -0,0 +1,17 @@+{-|+Module : GHCup.Types.JSON.Utils+Description : Utils for TH splices+Copyright : (c) Julian Ospald, 2020+License : LGPL-3.0+Maintainer : hasufell@hasufell.de+Stability : experimental+Portability : portable+-}++module GHCup.Types.JSON.Utils where++import qualified Data.Text as T++removeLensFieldLabel :: String -> String+removeLensFieldLabel str' =+ maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
lib/GHCup/Utils.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} @@ -125,31 +124,32 @@ ------------------------ --- | The symlink destination of a ghc tool.-ghcLinkDestination :: ( MonadReader env m- , HasDirs env- , MonadThrow m, MonadIO m)- => FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.- -> GHCTargetVersion- -> m FilePath-ghcLinkDestination tool ver = do- Dirs {..} <- getDirs- ghcd <- ghcupGHCDir ver- pure (relativeSymlink binDir (ghcd </> "bin" </> tool))+-- | Create a relative symlink destination for the binary directory,+-- given a target toolpath.+binarySymLinkDestination :: ( MonadThrow m+ , MonadIO m+ )+ => FilePath -- ^ binary dir+ -> FilePath -- ^ the full toolpath+ -> m FilePath+binarySymLinkDestination binDir toolPath = do+ toolPath' <- liftIO $ canonicalizePath toolPath+ binDir' <- liftIO $ canonicalizePath binDir+ pure (relativeSymlink binDir' toolPath') -- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.-rmMinorSymlinks :: ( MonadReader env m- , HasDirs env- , MonadIO m- , HasLog env- , MonadThrow m- , MonadFail m- , MonadMask m- )- => GHCTargetVersion- -> Excepts '[NotInstalled] m ()-rmMinorSymlinks tv@GHCTargetVersion{..} = do+rmMinorGHCSymlinks :: ( MonadReader env m+ , HasDirs env+ , MonadIO m+ , HasLog env+ , MonadThrow m+ , MonadFail m+ , MonadMask m+ )+ => GHCTargetVersion+ -> Excepts '[NotInstalled] m ()+rmMinorGHCSymlinks tv@GHCTargetVersion{..} = do Dirs {..} <- lift getDirs files <- liftE $ ghcToolFiles tv@@ -161,17 +161,17 @@ -- | Removes the set ghc version for the given target, if any.-rmPlain :: ( MonadReader env m- , HasDirs env- , HasLog env- , MonadThrow m- , MonadFail m- , MonadIO m- , MonadMask m- )- => Maybe Text -- ^ target- -> Excepts '[NotInstalled] m ()-rmPlain target = do+rmPlainGHC :: ( MonadReader env m+ , HasDirs env+ , HasLog env+ , MonadThrow m+ , MonadFail m+ , MonadIO m+ , MonadMask m+ )+ => Maybe Text -- ^ target+ -> Excepts '[NotInstalled] m ()+rmPlainGHC target = do Dirs {..} <- lift getDirs mtv <- lift $ ghcSet target forM_ mtv $ \tv -> do@@ -187,17 +187,17 @@ -- | Remove the major GHC symlink, e.g. ghc-8.6.-rmMajorSymlinks :: ( MonadReader env m- , HasDirs env- , MonadIO m- , HasLog env- , MonadThrow m- , MonadFail m- , MonadMask m- )- => GHCTargetVersion- -> Excepts '[NotInstalled] m ()-rmMajorSymlinks tv@GHCTargetVersion{..} = do+rmMajorGHCSymlinks :: ( MonadReader env m+ , HasDirs env+ , MonadIO m+ , HasLog env+ , MonadThrow m+ , MonadFail m+ , MonadMask m+ )+ => GHCTargetVersion+ -> Excepts '[NotInstalled] m ()+rmMajorGHCSymlinks tv@GHCTargetVersion{..} = do Dirs {..} <- lift getDirs (mj, mi) <- getMajorMinorV _tvVersion let v' = intToText mj <> "." <> intToText mi@@ -210,8 +210,64 @@ lift $ hideError doesNotExistErrorType $ rmLink fullF +-- | Removes the minor HLS files, e.g. 'haskell-language-server-8.10.7~1.6.1.0'+-- and 'haskell-language-server-wrapper-1.6.1.0'.+rmMinorHLSSymlinks :: ( MonadReader env m+ , HasDirs env+ , MonadIO m+ , HasLog env+ , MonadThrow m+ , MonadFail m+ , MonadMask m+ )+ => Version+ -> Excepts '[NotInstalled] m ()+rmMinorHLSSymlinks ver = do+ Dirs {..} <- lift getDirs + hlsBins <- hlsAllBinaries ver+ forM_ hlsBins $ \f -> do+ let fullF = binDir </> f+ lift $ logDebug ("rm -f " <> T.pack fullF)+ -- on unix, this may be either a file (legacy) or a symlink+ -- on windows, this is always a file... hence 'rmFile'+ -- works consistently across platforms+ lift $ rmFile fullF +-- | Removes the set HLS version, if any.+rmPlainHLS :: ( MonadReader env m+ , HasDirs env+ , HasLog env+ , MonadThrow m+ , MonadFail m+ , MonadIO m+ , MonadMask m+ )+ => Excepts '[NotInstalled] m ()+rmPlainHLS = do+ Dirs {..} <- lift getDirs++ -- delete 'haskell-language-server-8.10.7'+ hlsBins <- fmap (filter (\f -> not ("haskell-language-server-wrapper" `isPrefixOf` f) && ('~' `notElem` f)))+ $ liftIO $ handleIO (\_ -> pure []) $ findFiles+ binDir+ (makeRegexOpts compExtended execBlank ([s|^haskell-language-server-.*$|] :: ByteString))+ forM_ hlsBins $ \f -> do+ let fullF = binDir </> f+ lift $ logDebug ("rm -f " <> T.pack fullF)+ if isWindows+ then lift $ rmLink fullF+ else lift $ rmFile fullF++ -- 'haskell-language-server-wrapper'+ let hlswrapper = binDir </> "haskell-language-server-wrapper" <> exeExt+ lift $ logDebug ("rm -f " <> T.pack hlswrapper)+ if isWindows+ then lift $ hideError doesNotExistErrorType $ rmLink hlswrapper+ else lift $ hideError doesNotExistErrorType $ rmFile hlswrapper+++ ----------------------------------- --[ Set/Installed introspection ]-- -----------------------------------@@ -353,7 +409,8 @@ -- | Get all installed hls, by matching on--- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.+-- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@,+-- as well as @~\/.ghcup\/hls\/<\hlsver\>@ getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [Either FilePath Version] getInstalledHLSs = do@@ -364,7 +421,7 @@ execBlank ([s|^haskell-language-server-wrapper-.*$|] :: ByteString) )- forM bins $ \f ->+ legacy <- forM bins $ \f -> case version . T.pack <$> (stripSuffix exeExt =<< stripPrefix "haskell-language-server-wrapper-" f) of@@ -372,6 +429,14 @@ Just (Left _) -> pure $ Left f Nothing -> pure $ Left f + hlsdir <- ghcupHLSBaseDir+ fs <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory hlsdir+ new <- forM fs $ \f -> case parseGHCupHLSDir f of+ Right r -> pure $ Right r+ Left _ -> pure $ Left f+ pure (nub (new <> legacy))++ -- | Get all installed stacks, by matching on -- @~\/.ghcup\/bin/stack-<\stackver\>@. getInstalledStacks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)@@ -447,6 +512,10 @@ vers <- fmap rights getInstalledHLSs pure $ elem ver vers +isLegacyHLS :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool+isLegacyHLS ver = do+ bdir <- ghcupHLSDir ver+ not <$> liftIO (doesDirectoryExist bdir) -- Return the currently set hls version, if any.@@ -518,7 +587,7 @@ pure . sortBy (flip compare) . rights $ vers --- | Get all server binaries for an hls version, if any.+-- | Get all server binaries for an hls version from the ~/.ghcup/bin directory, if any. hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m) => Version -> Maybe Version -- ^ optional GHC version@@ -539,7 +608,45 @@ ) ) +-- | Get all scripts for a hls version from the ~/.ghcup/hls/<ver>/bin directory, if any.+-- Returns the full path.+hlsInternalServerScripts :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)+ => Version+ -> Maybe Version -- ^ optional GHC version+ -> m [FilePath]+hlsInternalServerScripts ver mghcVer = do+ dir <- ghcupHLSDir ver+ let bdir = dir </> "bin"+ fmap (bdir </>) . filter (\f -> maybe True (\gv -> ("-" <> T.unpack (prettyVer gv)) `isSuffixOf` f) mghcVer)+ <$> liftIO (listDirectory bdir) +-- | Get all binaries for a hls version from the ~/.ghcup/hls/<ver>/lib/haskell-language-server-<ver>/bin directory, if any.+-- Returns the full path.+hlsInternalServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadFail m)+ => Version+ -> Maybe Version -- ^ optional GHC version+ -> m [FilePath]+hlsInternalServerBinaries ver mghcVer = do+ dir <- 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)+ <$> liftIO (listDirectory bdir)++-- | Get all libraries for a hls version from the ~/.ghcup/hls/<ver>/lib/haskell-language-server-<ver>/lib/<ghc-ver>/+-- directory, if any.+-- Returns the full path.+hlsInternalServerLibs :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadFail m)+ => Version+ -> Version -- ^ GHC version+ -> m [FilePath]+hlsInternalServerLibs ver ghcVer = do+ dir <- 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)++ -- | Get the wrapper binary for an hls version, if any. hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m) => Version@@ -569,22 +676,6 @@ pure (maybeToList wrapper ++ hls) --- | Get the active symlinks for hls.-hlsSymlinks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [FilePath]-hlsSymlinks = do- Dirs {..} <- getDirs- oldSyms <- liftIO $ handleIO (\_ -> pure []) $ findFiles- binDir- (makeRegexOpts compExtended- execBlank- ([s|^haskell-language-server-.*$|] :: ByteString)- )- filterM- ( liftIO- . pathIsLink- . (binDir </>)- )- oldSyms @@ -715,7 +806,7 @@ (untar . GZip.decompress =<< rf av) | ".tar.xz" `isSuffixOf` fn -> do filecontents <- liftE $ rf av- let decompressed = Lzma.decompress filecontents+ let decompressed = Lzma.decompressWith (Lzma.defaultDecompressParams { Lzma.decompressAutoDecoder= True }) filecontents liftE $ untar decompressed | ".tar.bz2" `isSuffixOf` fn -> liftE (untar . BZip.decompress =<< rf av)@@ -744,7 +835,7 @@ (entries . GZip.decompress =<< rf av) | ".tar.xz" `isSuffixOf` fn -> do filecontents <- liftE $ rf av- let decompressed = Lzma.decompress filecontents+ let decompressed = Lzma.decompressWith (Lzma.defaultDecompressParams { Lzma.decompressAutoDecoder= True }) filecontents liftE $ entries decompressed | ".tar.bz2" `isSuffixOf` fn -> liftE (entries . BZip.decompress =<< rf av)@@ -809,8 +900,16 @@ --[ Other ]-- ------------- +-- | Usually @~\/.ghcup\/ghc\/\<ver\>\/bin\/@+ghcInternalBinDir :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)+ => GHCTargetVersion+ -> m FilePath+ghcInternalBinDir ver = do+ ghcdir <- ghcupGHCDir ver+ pure (ghcdir </> "bin") --- | Get tool files from @~\/.ghcup\/bin\/ghc\/\<ver\>\/bin\/\*@++-- | Get tool files from @~\/.ghcup\/ghc\/\<ver\>\/bin\/\*@ -- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix. -- -- Returns unversioned relative files without extension, e.g.:@@ -820,11 +919,10 @@ => GHCTargetVersion -> Excepts '[NotInstalled] m [FilePath] ghcToolFiles ver = do- ghcdir <- lift $ ghcupGHCDir ver- let bindir = ghcdir </> "bin"+ bindir <- ghcInternalBinDir ver -- fail if ghc is not installed- whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)+ whenM (fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver)) files <- liftIO (listDirectory bindir >>= filterM (doesFileExist . (bindir </>)))@@ -879,22 +977,30 @@ executeOut mymake args workdir --- | Try to apply patches in order. Fails with 'PatchFailed'--- on first failure.+-- | Try to apply patches in order. The order is determined by+-- a quilt series file (in the patch directory) if one exists,+-- else the patches are applied in lexicographical order.+-- Fails with 'PatchFailed' on first failure. applyPatches :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m) => FilePath -- ^ dir containing patches -> FilePath -- ^ dir to apply patches in -> Excepts '[PatchFailed] m () applyPatches pdir ddir = do- patches <- (fmap . fmap) (pdir </>) $ liftIO $ findFiles- pdir- (makeRegexOpts compExtended- execBlank- ([s|.+\.(patch|diff)$|] :: ByteString)- )- forM_ (sort patches) $ \patch' -> applyPatch patch' ddir+ let lexicographical = (fmap . fmap) (pdir </>) $ sort <$> findFiles+ pdir+ (makeRegexOpts compExtended+ execBlank+ ([s|.+\.(patch|diff)$|] :: ByteString)+ )+ let quilt = map (pdir </>) . lines <$> readFile (pdir </> "series") + patches <- liftIO $ quilt `catchIO` (\e ->+ if isDoesNotExistError e || isPermissionError e then+ lexicographical + else throwIO e)+ forM_ patches $ \patch' -> applyPatch patch' ddir + applyPatch :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m) => FilePath -- ^ Patch -> FilePath -- ^ dir to apply patches in@@ -1141,11 +1247,27 @@ -- | For ghc without arch triple, this is: ----- - ghc-<ver> (e.g. ghc-8.10.4)+-- - ghc -- -- For ghc with arch triple: ----- - <triple>-ghc-<ver> (e.g. arm-linux-gnueabihf-ghc-8.10.4)+-- - <triple>-ghc (e.g. arm-linux-gnueabihf-ghc) ghcBinaryName :: GHCTargetVersion -> String-ghcBinaryName (GHCTargetVersion (Just t) v') = T.unpack (t <> "-ghc-" <> prettyVer v' <> T.pack exeExt)-ghcBinaryName (GHCTargetVersion Nothing v') = T.unpack ("ghc-" <> prettyVer v' <> T.pack exeExt)+ghcBinaryName (GHCTargetVersion (Just t) _) = T.unpack (t <> "-ghc" <> T.pack exeExt)+ghcBinaryName (GHCTargetVersion Nothing _) = T.unpack ("ghc" <> T.pack exeExt)+++-- | Does basic checks for isolated installs+-- Isolated Directory:+-- 1. if it doesn't exist -> proceed+-- 2. if it exists and is empty -> proceed+-- 3. if it exists and is non-empty -> panic and leave the house+installDestSanityCheck :: ( MonadIO m+ , MonadCatch m+ ) =>+ FilePath ->+ Excepts '[DirNotEmpty] m ()+installDestSanityCheck isoDir = do+ hideErrorDef [doesNotExistErrorType] () $ do+ contents <- liftIO $ getDirectoryContentsRecursive isoDir+ unless (null contents) (throwE $ DirNotEmpty isoDir)
lib/GHCup/Utils/Dirs.hs view
@@ -20,8 +20,11 @@ , ghcupCacheDir , ghcupGHCBaseDir , ghcupGHCDir+ , ghcupHLSBaseDir+ , ghcupHLSDir , mkGhcupTmpDir , parseGHCupGHCDir+ , parseGHCupHLSDir , relativeSymlink , withGHCupTmpDir , getConfigFilePath@@ -46,6 +49,7 @@ import Control.Monad.Trans.Resource hiding (throwM) import Data.Bifunctor import Data.Maybe+import Data.Versions import GHC.IO.Exception ( IOErrorType(NoSuchThing) ) import Haskus.Utils.Variant.Excepts import Optics@@ -244,7 +248,25 @@ parseGHCupGHCDir (T.pack -> fp) = throwEither $ MP.parse ghcTargetVerP "" fp +parseGHCupHLSDir :: MonadThrow m => FilePath -> m Version+parseGHCupHLSDir (T.pack -> fp) =+ throwEither $ MP.parse version' "" fp +-- | ~/.ghcup/hls by default, for new-style installs.+ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m FilePath+ghcupHLSBaseDir = do+ Dirs {..} <- getDirs+ pure (baseDir </> "hls")++-- | Gets '~/.ghcup/hls/<hls-ver>' for new-style installs.+ghcupHLSDir :: (MonadReader env m, HasDirs env, MonadThrow m)+ => Version+ -> m FilePath+ghcupHLSDir ver = do+ basedir <- ghcupHLSBaseDir+ let verdir = T.unpack $ prettyVer ver+ pure (basedir </> verdir)+ mkGhcupTmpDir :: ( MonadReader env m , HasDirs env , MonadUnliftIO m@@ -313,6 +335,7 @@ useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS" +-- | Like 'relpath'. Assumes the inputs are resolved in case of symlinks. relativeSymlink :: FilePath -- ^ the path in which to create the symlink -> FilePath -- ^ the symlink destination -> FilePath
lib/GHCup/Utils/File/Common.hs view
@@ -1,11 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ViewPatterns #-} -module GHCup.Utils.File.Common where+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@@ -13,7 +16,7 @@ import Data.Void import GHC.IO.Exception import Optics hiding ((<|), (|>))-import System.Directory+import System.Directory hiding (findFiles) import System.FilePath import Text.PrettyPrint.HughesPJClass hiding ( (<>) ) import Text.Regex.Posix@@ -24,33 +27,6 @@ -data ProcessError = NonZeroExit Int FilePath [String]- | PTerminated FilePath [String]- | PStopped FilePath [String]- | NoSuchPid FilePath [String]- deriving Show--instance Pretty ProcessError where- pPrint (NonZeroExit e exe args) =- text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".")- pPrint (PTerminated exe args) =- text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated."- pPrint (PStopped exe args) =- text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped."- pPrint (NoSuchPid exe args) =- text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."--data CapturedProcess = CapturedProcess- { _exitCode :: ExitCode- , _stdOut :: BL.ByteString- , _stdErr :: BL.ByteString- }- deriving (Eq, Show)--makeLenses ''CapturedProcess--- -- | Search for a file in the search paths. -- -- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.@@ -98,6 +74,21 @@ 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]
lib/GHCup/Utils/File/Posix.hs view
@@ -35,7 +35,7 @@ import Data.List import Data.Word8 import GHC.IO.Exception-import System.Console.Terminal.Common+import System.IO ( stderr ) import System.IO.Error import System.FilePath import System.Directory@@ -51,7 +51,7 @@ 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.Posix as TP+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@@ -143,14 +143,14 @@ printToRegion :: Fd -> Fd -> Int -> MVar Bool -> Bool -> IO () printToRegion fileFd fdIn size pState no_color = do -- init region- forM_ [1..size] $ \_ -> BS.putStr "\n"+ forM_ [1..size] $ \_ -> BS.hPut stderr "\n" void $ flip runStateT mempty $ do handle (\(ex :: SomeException) -> do ps <- liftIO $ takeMVar pState- when ps (liftIO $ BS.putStr (pos1 <> moveLineUp size <> clearScreen))+ when ps (liftIO $ BS.hPut stderr (pos1 <> moveLineUp size <> clearScreen)) throw ex ) $ readTilEOF lineAction fdIn @@ -182,10 +182,10 @@ modify (swapRegs bs') liftIO TP.size >>= \case Nothing -> pure ()- Just (Window _ w) -> do+ Just (TP.Window _ w) -> do regs <- get liftIO $ forM_ (Sq.zip regs (Sq.fromList [0..(Sq.length regs - 1)])) $ \(bs, i) -> do- BS.putStr+ BS.hPut stderr . overwriteNthLine (size - i) . trim w . blue
lib/GHCup/Utils/File/Windows.hs view
@@ -196,7 +196,8 @@ then pure () else do void $ BS.appendFile logFile some- void $ BS.hPut stdout some+ -- subprocess stdout also goes to stderr for logging+ void $ BS.hPut stderr some go
lib/GHCup/Utils/Logger.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} @@ -18,7 +17,7 @@ import GHCup.Types import GHCup.Types.Optics-import {-# SOURCE #-} GHCup.Utils.File.Common+import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles) import GHCup.Utils.String.QQ import Control.Exception.Safe
lib/GHCup/Utils/Logger.hs-boot view
@@ -1,7 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-} module GHCup.Utils.Logger where
lib/GHCup/Utils/Prelude.hs view
@@ -30,7 +30,7 @@ import GHCup.Types import GHCup.Errors import GHCup.Types.Optics-import {-# SOURCE #-} GHCup.Utils.Logger+import {-# SOURCE #-} GHCup.Utils.Logger (logWarn) #if defined(IS_WINDOWS) import GHCup.Utils.Prelude.Windows #else@@ -308,11 +308,6 @@ intToText = TL.toStrict . B.toLazyText . B.decimal -removeLensFieldLabel :: String -> String-removeLensFieldLabel str' =- maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'-- pvpToVersion :: MonadThrow m => PVP -> Text -> m Version pvpToVersion pvp_ rest = either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . (<> rest) . prettyPVP $ pvp_@@ -477,7 +472,9 @@ let dest = tmp </> takeFileName fp liftIO (moveFile fp dest) `catch`- (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)+ (\e -> if | isDoesNotExistError e -> pure ()+ | isPermissionError e {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)+ | otherwise -> throwIO e) `finally` liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp) | otherwise = liftIO $ removePathForcibly fp
lib/GHCup/Utils/String/QQ.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-} {-| Module : GHCup.Utils.String.QQ
lib/GHCup/Utils/Version/QQ.hs view
@@ -4,7 +4,7 @@ {-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-} {-|
lib/GHCup/Version.hs view
@@ -28,7 +28,7 @@ -- Note that when updating this, CI requires that the file exsists AND the same file exists at -- 'https://www.haskell.org/ghcup/exp/ghcup-<ver>.yaml' with some newlines added. ghcupURL :: URI-ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.6.yaml|]+ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.7.yaml|] -- | The current ghcup version. ghcUpVer :: PVP
− lib/System/Console/Terminal/Common.hs
@@ -1,43 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveTraversable #-}--#if __GLASGOW_HASKELL__ >= 702-#define LANGUAGE_DeriveGeneric-{-# LANGUAGE DeriveGeneric #-}-#endif--module System.Console.Terminal.Common- ( Window(..)- ) where--import Data.Data (Typeable, Data)--#if __GLASGOW_HASKELL__ < 710-import Data.Foldable (Foldable)-import Data.Traversable (Traversable)-#endif--#ifdef LANGUAGE_DeriveGeneric-import GHC.Generics- ( Generic-#if __GLASGOW_HASKELL__ >= 706- , Generic1-#endif- )-#endif---- | Terminal window width and height-data Window a = Window- { height :: !a- , width :: !a- } deriving- ( Show, Eq, Read, Data, Typeable- , Foldable, Functor, Traversable-#ifdef LANGUAGE_DeriveGeneric- , Generic-#if __GLASGOW_HASKELL__ >= 706- , Generic1-#endif-#endif- )
− lib/System/Console/Terminal/Posix.hsc
@@ -1,65 +0,0 @@-{-# LANGUAGE CApiFFI #-}--module System.Console.Terminal.Posix- ( size, fdSize, hSize- ) where--import System.Console.Terminal.Common-import Control.Exception (catch)-import Data.Typeable (cast)-import Foreign-import Foreign.C.Error-import Foreign.C.Types-import GHC.IO.FD (FD(FD, fdFD))-import GHC.IO.Handle.Internals (withHandle_)-import GHC.IO.Handle.Types (Handle, Handle__(Handle__, haDevice))-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 706)-import Prelude hiding (catch)-#endif-import System.Posix.Types (Fd(Fd))--#include <sys/ioctl.h>-#include <unistd.h>---#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)----- Interesting part of @struct winsize@-data CWin = CWin CUShort CUShort--instance Storable CWin where- sizeOf _ = (#size struct winsize)- alignment _ = (#alignment struct winsize)- peek ptr = do- row <- (#peek struct winsize, ws_row) ptr- col <- (#peek struct winsize, ws_col) ptr- return $ CWin row col- poke ptr (CWin row col) = do- (#poke struct winsize, ws_row) ptr row- (#poke struct winsize, ws_col) ptr col---fdSize :: Integral n => Fd -> IO (Maybe (Window n))-fdSize (Fd fd) = with (CWin 0 0) $ \ws -> do- _ <- throwErrnoIfMinus1 "ioctl" $- ioctl fd (#const TIOCGWINSZ) ws- CWin row col <- peek ws- return . Just $ Window (fromIntegral row) (fromIntegral col)- `catch`- handler- where- handler :: IOError -> IO (Maybe (Window h))- handler _ = return Nothing--foreign import capi "sys/ioctl.h ioctl"- ioctl :: CInt -> CULong -> Ptr CWin -> IO CInt--size :: Integral n => IO (Maybe (Window n))-size = fdSize (Fd (#const STDOUT_FILENO))--hSize :: Integral n => Handle -> IO (Maybe (Window n))-hSize h = withHandle_ "hSize" h $ \Handle__ { haDevice = dev } ->- case cast dev of- Nothing -> return Nothing- Just FD { fdFD = fd } -> fdSize (Fd fd)