Yo
This commit is contained in:
parent
6489e8430b
commit
e1fb60d3b1
8
TODO.md
8
TODO.md
@ -5,11 +5,8 @@
|
||||
* download progress
|
||||
|
||||
* upgrade Upgrade this script in-place
|
||||
* rm Remove an already installed GHC
|
||||
* debug-info Print debug info (e.g. detected system/distro)
|
||||
* changelog Show the changelog of a GHC release (online)
|
||||
* print-system-reqs Print an approximation of system requirements
|
||||
* install major ver
|
||||
* maybe: changelog Show the changelog of a GHC release (online)
|
||||
* maybe: print-system-reqs Print an approximation of system requirements
|
||||
|
||||
* testing (especially distro detection -> unit tests)
|
||||
|
||||
@ -25,7 +22,6 @@
|
||||
* check for new version on start
|
||||
* tarball tags as well as version tags?
|
||||
|
||||
* --copy-compiler-tools
|
||||
* installing multiple versions in parallel?
|
||||
* how to version and extend the format of the downloads file? Compatibility?
|
||||
* how to propagate updates? Automatically? Might solve the versioning problem
|
||||
|
||||
@ -21,7 +21,7 @@ availableDownloads :: AvailableDownloads
|
||||
availableDownloads = M.fromList
|
||||
[ ( GHC
|
||||
, M.fromList
|
||||
[ ( [ver|8.6.5|]
|
||||
[ ( [vver|8.6.5|]
|
||||
, VersionInfo [Latest] $ M.fromList
|
||||
[ ( A_64
|
||||
, M.fromList
|
||||
@ -61,7 +61,7 @@ availableDownloads = M.fromList
|
||||
)
|
||||
]
|
||||
),
|
||||
( [ver|8.4.4|]
|
||||
( [vver|8.4.4|]
|
||||
, VersionInfo [Latest] $ M.fromList
|
||||
[ ( A_64
|
||||
, M.fromList
|
||||
@ -105,7 +105,7 @@ availableDownloads = M.fromList
|
||||
)
|
||||
, ( Cabal
|
||||
, M.fromList
|
||||
[ ( [ver|3.0.0.0|]
|
||||
[ ( [vver|3.0.0.0|]
|
||||
, VersionInfo [Recommended, Latest] $ M.fromList
|
||||
[ ( A_64
|
||||
, M.fromList
|
||||
|
||||
@ -15,7 +15,6 @@ import qualified Data.ByteString.Lazy as L
|
||||
import Data.Semigroup ( (<>) )
|
||||
import GHCup.Types.JSON ( )
|
||||
import Options.Applicative hiding ( style )
|
||||
import Control.Monad.Logger
|
||||
import GHCup.Logger
|
||||
import System.Console.Pretty
|
||||
import System.Exit
|
||||
|
||||
@ -4,32 +4,23 @@
|
||||
|
||||
module Validate where
|
||||
|
||||
import AvailableDownloads
|
||||
import GHCup
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
|
||||
import Control.Monad
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad.Reader.Class
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Control.Monad.Trans.Reader ( ReaderT
|
||||
, runReaderT
|
||||
)
|
||||
import Control.Monad.Trans.Reader ( runReaderT )
|
||||
import Data.List
|
||||
import Data.String.QQ
|
||||
import Data.String.Interpolate
|
||||
import Data.Versions
|
||||
import Data.IORef
|
||||
import Optics
|
||||
import System.Exit
|
||||
import System.Console.Pretty
|
||||
import System.IO
|
||||
import Control.Monad.Logger
|
||||
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.ByteString as B
|
||||
|
||||
|
||||
-- TODO: improve logging
|
||||
|
||||
@ -10,21 +10,13 @@ module Main where
|
||||
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Bifunctor
|
||||
import Data.ByteString ( ByteString )
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
import Data.Char
|
||||
import Data.Functor ( (<&>) )
|
||||
import Data.List ( intercalate )
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import Data.Semigroup ( (<>) )
|
||||
import Data.String.QQ
|
||||
import Data.Text ( Text )
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import Data.Traversable
|
||||
import Data.Versions
|
||||
import GHCup
|
||||
import GHCup.Logger
|
||||
@ -32,12 +24,12 @@ import GHCup.File
|
||||
import GHCup.Prelude
|
||||
import GHCup.Types
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import HPath
|
||||
import Options.Applicative hiding ( style )
|
||||
import System.Console.Pretty
|
||||
import System.Exit
|
||||
import URI.ByteString
|
||||
import Text.Layout.Table
|
||||
import Data.String.Interpolate
|
||||
|
||||
|
||||
|
||||
@ -56,17 +48,22 @@ data Command
|
||||
| SetGHC SetGHCOptions
|
||||
| List ListOptions
|
||||
| Rm RmOptions
|
||||
| DInfo
|
||||
|
||||
data ToolVersion = ToolVersion Version
|
||||
| ToolTag Tag
|
||||
|
||||
|
||||
data InstallGHCOptions = InstallGHCOptions
|
||||
{ ghcVer :: Maybe Version
|
||||
{ ghcVer :: Maybe ToolVersion
|
||||
}
|
||||
|
||||
data InstallCabalOptions = InstallCabalOptions
|
||||
{ cabalVer :: Maybe Version
|
||||
{ cabalVer :: Maybe ToolVersion
|
||||
}
|
||||
|
||||
data SetGHCOptions = SetGHCOptions
|
||||
{ ghcVer :: Maybe Version
|
||||
{ ghcVer :: Maybe ToolVersion
|
||||
}
|
||||
|
||||
data ListOptions = ListOptions
|
||||
@ -100,8 +97,8 @@ opts =
|
||||
)
|
||||
<*> com
|
||||
where
|
||||
parseUri s =
|
||||
bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s)
|
||||
parseUri s' =
|
||||
bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s')
|
||||
|
||||
com :: Parser Command
|
||||
com = subparser
|
||||
@ -140,41 +137,20 @@ com = subparser
|
||||
(progDesc "Remove a GHC version installed by ghcup")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"debug-info"
|
||||
((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info")))
|
||||
)
|
||||
|
||||
installGHCOpts :: Parser InstallGHCOptions
|
||||
installGHCOpts = InstallGHCOptions <$> optional
|
||||
(option
|
||||
(eitherReader
|
||||
(\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
|
||||
)
|
||||
(short 'v' <> long "version" <> metavar "VERSION" <> help
|
||||
"The GHC version to install"
|
||||
)
|
||||
)
|
||||
installGHCOpts = InstallGHCOptions <$> optional toolVersionParser
|
||||
|
||||
|
||||
installCabalOpts :: Parser InstallCabalOptions
|
||||
installCabalOpts = InstallCabalOptions <$> optional
|
||||
(option
|
||||
(eitherReader
|
||||
(\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
|
||||
)
|
||||
(short 'v' <> long "version" <> metavar "VERSION" <> help
|
||||
"The Cabal version to install"
|
||||
)
|
||||
)
|
||||
installCabalOpts = InstallCabalOptions <$> optional toolVersionParser
|
||||
|
||||
setGHCOpts :: Parser SetGHCOptions
|
||||
setGHCOpts = SetGHCOptions <$> optional
|
||||
(option
|
||||
(eitherReader
|
||||
(\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
|
||||
)
|
||||
(short 'v' <> long "version" <> metavar "VERSION" <> help
|
||||
"The GHC version to set (default: recommended)"
|
||||
)
|
||||
)
|
||||
setGHCOpts = SetGHCOptions <$> optional toolVersionParser
|
||||
|
||||
listOpts :: Parser ListOptions
|
||||
listOpts =
|
||||
@ -183,7 +159,7 @@ listOpts =
|
||||
(option
|
||||
(eitherReader toolParser)
|
||||
(short 't' <> long "tool" <> metavar "<ghc|cabal>" <> help
|
||||
"Tool to list versions for. Default is ghc only."
|
||||
"Tool to list versions for. Default is all"
|
||||
)
|
||||
)
|
||||
<*> (optional
|
||||
@ -198,30 +174,55 @@ listOpts =
|
||||
)
|
||||
|
||||
rmOpts :: Parser RmOptions
|
||||
rmOpts = RmOptions <$>
|
||||
(option
|
||||
(eitherReader
|
||||
(\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
|
||||
)
|
||||
(short 'v' <> long "version" <> metavar "VERSION" <> help
|
||||
"The GHC version to remove"
|
||||
)
|
||||
)
|
||||
rmOpts =
|
||||
RmOptions
|
||||
<$> (option
|
||||
(eitherReader
|
||||
(bimap (const "Not a valid version") id . version . T.pack)
|
||||
)
|
||||
(short 'v' <> long "version" <> metavar "VERSION" <> help
|
||||
"The GHC version to remove"
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
||||
versionParser :: Parser Version
|
||||
versionParser = option
|
||||
(eitherReader (bimap (const "Not a valid version") id . version . T.pack))
|
||||
(short 'v' <> long "version" <> metavar "VERSION")
|
||||
|
||||
|
||||
toolVersionParser :: Parser ToolVersion
|
||||
toolVersionParser = verP <|> toolP
|
||||
where
|
||||
verP = ToolVersion <$> versionParser
|
||||
toolP =
|
||||
ToolTag
|
||||
<$> (option
|
||||
(eitherReader
|
||||
(\s' -> case fmap toLower s' of
|
||||
"recommended" -> Right Recommended
|
||||
"latest" -> Right Latest
|
||||
other -> Left ([i|Unknown tag #{other}|])
|
||||
)
|
||||
)
|
||||
(short 't' <> long "tag" <> metavar "TAG")
|
||||
)
|
||||
|
||||
|
||||
toolParser :: String -> Either String Tool
|
||||
toolParser s | t == T.pack "ghc" = Right GHC
|
||||
| t == T.pack "cabal" = Right Cabal
|
||||
| otherwise = Left ("Unknown tool: " <> s)
|
||||
where t = T.toLower (T.pack s)
|
||||
toolParser s' | t == T.pack "ghc" = Right GHC
|
||||
| t == T.pack "cabal" = Right Cabal
|
||||
| otherwise = Left ("Unknown tool: " <> s')
|
||||
where t = T.toLower (T.pack s')
|
||||
|
||||
|
||||
criteriaParser :: String -> Either String ListCriteria
|
||||
criteriaParser s | t == T.pack "installed" = Right ListInstalled
|
||||
| t == T.pack "set" = Right ListSet
|
||||
| otherwise = Left ("Unknown criteria: " <> s)
|
||||
where t = T.toLower (T.pack s)
|
||||
criteriaParser s' | t == T.pack "installed" = Right ListInstalled
|
||||
| t == T.pack "set" = Right ListSet
|
||||
| otherwise = Left ("Unknown criteria: " <> s')
|
||||
where t = T.toLower (T.pack s')
|
||||
|
||||
|
||||
toSettings :: Options -> Settings
|
||||
@ -246,49 +247,54 @@ main = do
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE
|
||||
@'[ FileError
|
||||
@'[ AlreadyInstalled
|
||||
, ArchiveError
|
||||
, ProcessError
|
||||
, URLException
|
||||
, PlatformResultError
|
||||
, NoDownload
|
||||
, NoCompatibleArch
|
||||
, DistroNotFound
|
||||
, TagNotFound
|
||||
, AlreadyInstalled
|
||||
, NotInstalled
|
||||
, FileDoesNotExistError
|
||||
, FileError
|
||||
, JSONError
|
||||
, NoCompatibleArch
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, PlatformResultError
|
||||
, ProcessError
|
||||
, TagNotFound
|
||||
, URLException
|
||||
]
|
||||
|
||||
let runSetGHC =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE @'[NotInstalled , TagNotFound, URLException , JSONError]
|
||||
. runE
|
||||
@'[ FileDoesNotExistError
|
||||
, NotInstalled
|
||||
, TagNotFound
|
||||
, URLException
|
||||
, JSONError
|
||||
, TagNotFound
|
||||
]
|
||||
|
||||
let runListGHC =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE @'[URLException , JSONError]
|
||||
. runE @'[FileDoesNotExistError , URLException , JSONError]
|
||||
|
||||
let runRmGHC =
|
||||
runLogger . flip runReaderT settings . runE @'[NotInstalled]
|
||||
|
||||
let runDebugInfo =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE @'[NotInstalled]
|
||||
. runE
|
||||
@'[PlatformResultError , NoCompatibleArch , DistroNotFound]
|
||||
|
||||
case optCommand of
|
||||
InstallGHC (InstallGHCOptions {..}) ->
|
||||
void
|
||||
$ (runInstTool $ do
|
||||
av <- liftE getDownloads
|
||||
v <- maybe
|
||||
( getRecommended av GHC
|
||||
?? TagNotFound Recommended GHC
|
||||
)
|
||||
pure
|
||||
ghcVer
|
||||
av <- liftE getDownloads
|
||||
liftE $ installTool (ToolRequest GHC v)
|
||||
Nothing
|
||||
v <- liftE $ fromVersion av ghcVer GHC
|
||||
liftE $ installTool (ToolRequest GHC v) Nothing
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> runLogger
|
||||
@ -296,20 +302,14 @@ main = do
|
||||
VLeft (V (AlreadyInstalled treq)) ->
|
||||
runLogger $ $(logWarn)
|
||||
(T.pack (show treq) <> [s| already installed|])
|
||||
VLeft e -> die (color Red $ show e)
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
InstallCabal (InstallCabalOptions {..}) ->
|
||||
void
|
||||
$ (runInstTool $ do
|
||||
av <- liftE getDownloads
|
||||
v <- maybe
|
||||
( getRecommended av Cabal
|
||||
?? TagNotFound Recommended Cabal
|
||||
)
|
||||
pure
|
||||
cabalVer
|
||||
av <- liftE getDownloads
|
||||
liftE $ installTool (ToolRequest Cabal v)
|
||||
Nothing
|
||||
v <- liftE $ fromVersion av cabalVer Cabal
|
||||
liftE $ installTool (ToolRequest Cabal v) Nothing
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> runLogger
|
||||
@ -317,24 +317,21 @@ main = do
|
||||
VLeft (V (AlreadyInstalled treq)) ->
|
||||
runLogger $ $(logWarn)
|
||||
(T.pack (show treq) <> [s| already installed|])
|
||||
VLeft e -> die (color Red $ show e)
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
|
||||
SetGHC (SetGHCOptions {..}) ->
|
||||
void
|
||||
$ (runSetGHC $ do
|
||||
av <- liftE getDownloads
|
||||
v <- maybe
|
||||
( getRecommended av GHC
|
||||
?? TagNotFound Recommended GHC
|
||||
)
|
||||
pure
|
||||
ghcVer
|
||||
v <- liftE $ fromVersion av ghcVer GHC
|
||||
liftE $ setGHC v SetGHCOnly
|
||||
)
|
||||
>>= \case
|
||||
VRight _ ->
|
||||
runLogger $ $(logInfo) ([s|GHC successfully set|])
|
||||
VLeft e -> die (color Red $ show e)
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
|
||||
List (ListOptions {..}) ->
|
||||
void
|
||||
@ -343,7 +340,8 @@ main = do
|
||||
)
|
||||
>>= \case
|
||||
VRight r -> liftIO $ printListResult r
|
||||
VLeft e -> die (color Red $ show e)
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
|
||||
Rm (RmOptions {..}) ->
|
||||
void
|
||||
@ -352,11 +350,35 @@ main = do
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> pure ()
|
||||
VLeft e -> die (color Red $ show e)
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
|
||||
DInfo -> do
|
||||
void
|
||||
$ (runDebugInfo $ do
|
||||
liftE $ getDebugInfo
|
||||
)
|
||||
>>= \case
|
||||
VRight dinfo -> putStrLn $ show dinfo
|
||||
VLeft e ->
|
||||
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
||||
pure ()
|
||||
|
||||
|
||||
fromVersion :: Monad m
|
||||
=> AvailableDownloads
|
||||
-> Maybe ToolVersion
|
||||
-> Tool
|
||||
-> Excepts '[TagNotFound] m Version
|
||||
fromVersion av Nothing tool =
|
||||
getRecommended av tool ?? TagNotFound Recommended tool
|
||||
fromVersion _ (Just (ToolVersion v)) _ = pure v
|
||||
fromVersion av (Just (ToolTag Latest)) tool =
|
||||
getLatest av tool ?? TagNotFound Latest tool
|
||||
fromVersion av (Just (ToolTag Recommended)) tool =
|
||||
getRecommended av tool ?? TagNotFound Recommended tool
|
||||
|
||||
|
||||
printListResult :: [ListResult] -> IO ()
|
||||
printListResult lr = do
|
||||
let
|
||||
|
||||
@ -32,6 +32,7 @@ common bzlib { build-depends: bzlib >= 0.5.0.5 }
|
||||
common containers { build-depends: containers >= 0.6 }
|
||||
common generics-sop { build-depends: generics-sop >= 0.5 }
|
||||
common haskus-utils-variant { build-depends: haskus-utils-variant >= 3.0 }
|
||||
common haskus-utils-types { build-depends: haskus-utils-types >= 1.5 }
|
||||
common hpath { build-depends: hpath >= 0.11 }
|
||||
common hpath-directory { build-depends: hpath-directory >= 0.13.2 }
|
||||
common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 }
|
||||
@ -98,6 +99,7 @@ library
|
||||
, containers
|
||||
, generics-sop
|
||||
, haskus-utils-variant
|
||||
, haskus-utils-types
|
||||
, hpath
|
||||
, hpath-directory
|
||||
, hpath-filepath
|
||||
@ -160,6 +162,7 @@ executable ghcup
|
||||
, hpath
|
||||
, pretty-terminal
|
||||
, string-qq
|
||||
, string-interpolate
|
||||
, table-layout
|
||||
, uri-bytestring
|
||||
, utf8-string
|
||||
|
||||
183
lib/GHCup.hs
183
lib/GHCup.hs
@ -18,17 +18,14 @@ import Control.Monad
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Cont
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Exception.Safe
|
||||
import Data.Aeson
|
||||
import Data.Attoparsec.ByteString
|
||||
import Data.ByteString ( ByteString )
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.ByteString.Builder
|
||||
import Data.Foldable ( asum )
|
||||
import Data.Foldable
|
||||
import Data.String.QQ
|
||||
import Data.Text ( Text )
|
||||
import Data.Versions
|
||||
@ -37,8 +34,8 @@ import GHCup.Bash
|
||||
import GHCup.File
|
||||
import GHCup.Prelude
|
||||
import GHCup.Types
|
||||
import GHCup.Types.JSON
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Types.JSON ( )
|
||||
import HPath
|
||||
import HPath.IO
|
||||
import Optics
|
||||
@ -48,7 +45,6 @@ import Prelude hiding ( abs
|
||||
import Data.List
|
||||
import System.Info
|
||||
import System.IO.Error
|
||||
import Data.Foldable ( foldrM )
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Text.ICU as ICU
|
||||
@ -56,33 +52,21 @@ import Data.Maybe
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Word8
|
||||
import GHC.IO.Exception
|
||||
import GHC.IO.Handle
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Haskus.Utils.Variant.VEither
|
||||
import Network.Http.Client hiding ( URL )
|
||||
import System.IO.Streams ( InputStream
|
||||
, OutputStream
|
||||
, stdout
|
||||
)
|
||||
import qualified System.IO.Streams as Streams
|
||||
import System.Posix.FilePath ( takeExtension
|
||||
, takeFileName
|
||||
, splitExtension
|
||||
)
|
||||
import System.Posix.FilePath ( takeFileName )
|
||||
import qualified System.Posix.FilePath as FP
|
||||
import System.Posix.Files.ByteString ( readSymbolicLink )
|
||||
import System.Posix.Env.ByteString ( getEnvDefault )
|
||||
import System.Posix.Temp.ByteString
|
||||
import qualified System.Posix.RawFilePath.Directory
|
||||
as RD
|
||||
import System.Posix.RawFilePath.Directory.Errors
|
||||
( hideError )
|
||||
import "unix" System.Posix.IO.ByteString
|
||||
hiding ( fdWrite )
|
||||
import System.Posix.FD as FD
|
||||
import System.Posix.Foreign ( oTrunc )
|
||||
import qualified Data.ByteString as B
|
||||
import OpenSSL ( withOpenSSL )
|
||||
import qualified Data.ByteString.Char8 as C
|
||||
import Data.Functor ( ($>) )
|
||||
import System.Posix.Types
|
||||
import "unix-bytestring" System.Posix.IO.ByteString
|
||||
( fdWrite )
|
||||
@ -90,12 +74,6 @@ import "unix-bytestring" System.Posix.IO.ByteString
|
||||
import qualified Codec.Compression.GZip as GZip
|
||||
import qualified Codec.Compression.Lzma as Lzma
|
||||
import qualified Codec.Compression.BZip as BZip
|
||||
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
import qualified System.Posix.Process.ByteString
|
||||
as SPPB
|
||||
import System.Posix.Directory.ByteString
|
||||
( changeWorkingDirectory )
|
||||
import URI.ByteString
|
||||
import URI.ByteString.QQ
|
||||
import Data.String.Interpolate
|
||||
@ -121,7 +99,7 @@ getCache = ask <&> cache
|
||||
---------------------------
|
||||
|
||||
|
||||
data PlatformResultError = NoCompatiblePlatform
|
||||
data PlatformResultError = NoCompatiblePlatform String
|
||||
deriving Show
|
||||
|
||||
data NoDownload = NoDownload
|
||||
@ -160,6 +138,9 @@ data JSONError = JSONDecodeError String
|
||||
data ParseError = ParseError String
|
||||
deriving Show
|
||||
|
||||
data FileDoesNotExistError = FileDoesNotExistError ByteString
|
||||
deriving Show
|
||||
|
||||
instance Exception ParseError
|
||||
|
||||
|
||||
@ -195,15 +176,19 @@ getDownloads :: ( FromJSONKey Tool
|
||||
, FromJSONKey Version
|
||||
, FromJSON VersionInfo
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
, MonadReader Settings m
|
||||
)
|
||||
=> Excepts '[URLException , JSONError] m AvailableDownloads
|
||||
=> Excepts
|
||||
'[FileDoesNotExistError , URLException , JSONError]
|
||||
m
|
||||
AvailableDownloads
|
||||
getDownloads = lift getUrlSource >>= \case
|
||||
GHCupURL -> do
|
||||
bs <- liftE $ downloadBS ghcupURL
|
||||
lE' JSONDecodeError $ eitherDecode' bs
|
||||
(OwnSource uri) -> do
|
||||
bs <- liftE $ downloadBS uri
|
||||
(OwnSource url) -> do
|
||||
bs <- liftE $ downloadBS url
|
||||
lE' JSONDecodeError $ eitherDecode' bs
|
||||
(OwnSpec av) -> pure $ av
|
||||
|
||||
@ -222,12 +207,13 @@ getDownloadInfo :: ( MonadLogger m
|
||||
=> ToolRequest
|
||||
-> Maybe PlatformRequest
|
||||
-> Excepts
|
||||
'[ PlatformResultError
|
||||
, NoDownload
|
||||
, NoCompatibleArch
|
||||
, DistroNotFound
|
||||
, URLException
|
||||
'[ DistroNotFound
|
||||
, FileDoesNotExistError
|
||||
, JSONError
|
||||
, NoCompatibleArch
|
||||
, NoDownload
|
||||
, PlatformResultError
|
||||
, URLException
|
||||
]
|
||||
m
|
||||
DownloadInfo
|
||||
@ -235,7 +221,7 @@ getDownloadInfo (ToolRequest t v) mpfReq = do
|
||||
urlSource <- lift getUrlSource
|
||||
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
|
||||
-- lift $ monadLoggerLog undefined undefined undefined ""
|
||||
(PlatformRequest arch plat ver) <- case mpfReq of
|
||||
(PlatformRequest arch' plat ver) <- case mpfReq of
|
||||
Just x -> pure x
|
||||
Nothing -> do
|
||||
(PlatformResult rp rv) <- liftE getPlatform
|
||||
@ -244,7 +230,7 @@ getDownloadInfo (ToolRequest t v) mpfReq = do
|
||||
|
||||
dls <- liftE $ getDownloads
|
||||
|
||||
lE $ getDownloadInfo' t v arch plat ver dls
|
||||
lE $ getDownloadInfo' t v arch' plat ver dls
|
||||
|
||||
|
||||
getDownloadInfo' :: Tool
|
||||
@ -288,8 +274,8 @@ download dli dest mfn
|
||||
|
||||
where
|
||||
dl https = do
|
||||
let uri = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
|
||||
lift $ $(logInfo) [i|downloading: #{uri}|]
|
||||
let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
|
||||
lift $ $(logInfo) [i|downloading: #{uri'}|]
|
||||
host <-
|
||||
preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
|
||||
?? UnsupportedURL
|
||||
@ -300,20 +286,34 @@ download dli dest mfn
|
||||
liftIO $ download' https host path port dest mfn
|
||||
|
||||
|
||||
downloadBS :: MonadIO m => URI -> Excepts '[URLException] m L.ByteString
|
||||
downloadBS uri | view (uriSchemeL' % schemeBSL') uri == [s|https|] = dl True
|
||||
| view (uriSchemeL' % schemeBSL') uri == [s|http|] = dl False
|
||||
| otherwise = throwE UnsupportedURL
|
||||
-- | This is used for downloading the JSON.
|
||||
downloadBS :: (MonadCatch m, MonadIO m)
|
||||
=> URI
|
||||
-> Excepts
|
||||
'[FileDoesNotExistError , URLException]
|
||||
m
|
||||
L.ByteString
|
||||
downloadBS uri'
|
||||
| scheme == [s|https|]
|
||||
= dl True
|
||||
| scheme == [s|http|]
|
||||
= dl False
|
||||
| scheme == [s|file|]
|
||||
= liftException doesNotExistErrorType (FileDoesNotExistError path)
|
||||
$ (liftIO $ RD.readFile path :: MonadIO m => Excepts '[] m L.ByteString)
|
||||
| otherwise
|
||||
= throwE UnsupportedURL
|
||||
|
||||
where
|
||||
scheme = view (uriSchemeL' % schemeBSL') uri'
|
||||
path = view pathL' uri'
|
||||
dl https = do
|
||||
host <-
|
||||
preview (authorityL' % _Just % authorityHostL' % hostBSL') uri
|
||||
preview (authorityL' % _Just % authorityHostL' % hostBSL') uri'
|
||||
?? UnsupportedURL
|
||||
let path = view pathL' uri
|
||||
let port = preview
|
||||
(authorityL' % _Just % authorityPortL' % _Just % portNumberL')
|
||||
uri
|
||||
uri'
|
||||
liftIO $ downloadBS' https host path port
|
||||
|
||||
|
||||
@ -386,13 +386,13 @@ downloadInternal https host path port consumer = do
|
||||
|
||||
receiveResponse
|
||||
c
|
||||
(\p i -> do
|
||||
(\_ i' -> do
|
||||
outStream <- Streams.makeOutputStream
|
||||
(\case
|
||||
Just bs -> void $ consumer bs
|
||||
Nothing -> pure ()
|
||||
)
|
||||
Streams.connect i outStream
|
||||
Streams.connect i' outStream
|
||||
)
|
||||
|
||||
closeConnection c
|
||||
@ -428,7 +428,7 @@ getPlatform = do
|
||||
"freebsd" -> do
|
||||
ver <- getFreeBSDVersion
|
||||
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
|
||||
what -> throwE NoCompatiblePlatform
|
||||
what -> throwE $ NoCompatiblePlatform what
|
||||
lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
|
||||
pure pfr
|
||||
where getFreeBSDVersion = pure Nothing
|
||||
@ -552,17 +552,17 @@ installTool :: ( MonadThrow m
|
||||
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
|
||||
-> Excepts
|
||||
'[ AlreadyInstalled
|
||||
, FileError
|
||||
, ArchiveError
|
||||
, DistroNotFound
|
||||
, FileDoesNotExistError
|
||||
, FileError
|
||||
, JSONError
|
||||
, NoCompatibleArch
|
||||
, NoDownload
|
||||
, NotInstalled
|
||||
, PlatformResultError
|
||||
, ProcessError
|
||||
, URLException
|
||||
, PlatformResultError
|
||||
, NoDownload
|
||||
, NoCompatibleArch
|
||||
, DistroNotFound
|
||||
, NotInstalled
|
||||
, URLException
|
||||
, JSONError
|
||||
]
|
||||
m
|
||||
()
|
||||
@ -592,7 +592,7 @@ installTool treq mpfReq = do
|
||||
unpacked <- liftE $ unpackToTmpDir dl
|
||||
|
||||
-- prepare paths
|
||||
ghcdir <- liftIO $ ghcupGHCDir (view toolVersion $ treq)
|
||||
ghcdir <- liftIO $ ghcupGHCDir (view trVersion $ treq)
|
||||
bindir <- liftIO ghcupBinDir
|
||||
|
||||
-- the subdir of the archive where we do the work
|
||||
@ -607,14 +607,14 @@ installTool treq mpfReq = do
|
||||
-- version, create it regardless.
|
||||
(mj, mi) <- liftIO $ getGHCMajor ver
|
||||
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor)
|
||||
(ToolRequest Cabal ver) -> liftE $ installCabal archiveSubdir bindir
|
||||
(ToolRequest Cabal _) -> liftE $ installCabal archiveSubdir bindir
|
||||
pure ()
|
||||
|
||||
|
||||
toolAlreadyInstalled :: ToolRequest -> IO Bool
|
||||
toolAlreadyInstalled ToolRequest {..} = case _tool of
|
||||
GHC -> ghcInstalled _toolVersion
|
||||
Cabal -> cabalInstalled _toolVersion
|
||||
toolAlreadyInstalled ToolRequest {..} = case _trTool of
|
||||
GHC -> ghcInstalled _trVersion
|
||||
Cabal -> cabalInstalled _trVersion
|
||||
|
||||
|
||||
|
||||
@ -678,15 +678,15 @@ setGHC ver sghc = do
|
||||
|
||||
-- for ghc tools (ghc, ghci, haddock, ...)
|
||||
verfiles <- ghcToolFiles ver
|
||||
forM verfiles $ \file -> do
|
||||
forM_ verfiles $ \file -> do
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile (destdir </> file)
|
||||
targetFile <- case sghc of
|
||||
SetGHCOnly -> pure file
|
||||
SetGHCMajor -> do
|
||||
major <-
|
||||
major' <-
|
||||
(\(mj, mi) -> E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi)
|
||||
<$> getGHCMajor ver
|
||||
parseRel (toFilePath file <> B.singleton _hyphen <> major)
|
||||
parseRel (toFilePath file <> B.singleton _hyphen <> major')
|
||||
SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
|
||||
liftIO $ hideError doesNotExistErrorType $ deleteFile
|
||||
(destdir </> targetFile)
|
||||
@ -743,10 +743,13 @@ availableToolVersions av tool = toListOf
|
||||
av
|
||||
|
||||
|
||||
listVersions :: (MonadReader Settings m, MonadIO m)
|
||||
listVersions :: (MonadReader Settings m, MonadIO m, MonadCatch m)
|
||||
=> Maybe Tool
|
||||
-> Maybe ListCriteria
|
||||
-> Excepts '[URLException , JSONError] m [ListResult]
|
||||
-> Excepts
|
||||
'[FileDoesNotExistError , URLException , JSONError]
|
||||
m
|
||||
[ListResult]
|
||||
listVersions lt criteria = do
|
||||
dls <- liftE $ getDownloads
|
||||
liftIO $ listVersions' dls lt criteria
|
||||
@ -786,9 +789,9 @@ listVersions' av lt criteria = case lt of
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ List tools ]--
|
||||
------------------
|
||||
--------------
|
||||
--[ GHC rm ]--
|
||||
--------------
|
||||
|
||||
|
||||
-- | This function may throw and crash in various ways.
|
||||
@ -799,14 +802,13 @@ rmGHCVer ver = do
|
||||
isSetGHC <- fmap (maybe False (== ver)) $ ghcSet
|
||||
dir <- liftIO $ ghcupGHCDir ver
|
||||
let d' = toFilePath dir
|
||||
let v' = prettyVer ver
|
||||
exists <- liftIO $ doesDirectoryExist dir
|
||||
exists <- liftIO $ doesDirectoryExist dir
|
||||
|
||||
toolsFiles <- liftE $ ghcToolFiles ver
|
||||
|
||||
if exists
|
||||
then do
|
||||
-- this isn't atomic
|
||||
-- this isn't atomic, order matters
|
||||
lift $ $(logInfo) [i|Removing directory recursively: #{d'}|]
|
||||
liftIO $ deleteDirRecursive dir
|
||||
|
||||
@ -818,7 +820,7 @@ rmGHCVer ver = do
|
||||
|
||||
when isSetGHC $ liftE $ do
|
||||
lift $ $(logInfo) [i|Removing ghc symlinks|]
|
||||
rmPlain dir toolsFiles
|
||||
rmPlain toolsFiles
|
||||
|
||||
liftIO
|
||||
$ ghcupBaseDir
|
||||
@ -841,10 +843,9 @@ rmGHCVer ver = do
|
||||
-- E.g. ghc, if this version is the set one.
|
||||
-- This reads `ghcupGHCDir`.
|
||||
rmPlain :: (MonadThrow m, MonadFail m, MonadIO m)
|
||||
=> Path Abs
|
||||
-> [Path Rel] -- ^ tools files
|
||||
=> [Path Rel] -- ^ tools files
|
||||
-> Excepts '[NotInstalled] m ()
|
||||
rmPlain ghcDir files = do
|
||||
rmPlain files = do
|
||||
bindir <- liftIO $ ghcupBinDir
|
||||
forM_ files $ \f -> liftIO $ deleteFile (bindir </> f)
|
||||
|
||||
@ -868,6 +869,27 @@ rmGHCVer ver = do
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--[ Debug info ]--
|
||||
------------------
|
||||
|
||||
|
||||
getDebugInfo :: (MonadLogger m, MonadCatch m, MonadReader Settings m, MonadIO m)
|
||||
=> Excepts
|
||||
'[PlatformResultError , NoCompatibleArch , DistroNotFound]
|
||||
m
|
||||
DebugInfo
|
||||
getDebugInfo = do
|
||||
diBaseDir <- liftIO $ ghcupBaseDir
|
||||
diBinDir <- liftIO $ ghcupBinDir
|
||||
diGHCDir <- liftIO $ ghcupGHCBaseDir
|
||||
diCacheDir <- liftIO $ ghcupCacheDir
|
||||
diURLSource <- lift $ getUrlSource
|
||||
diArch <- lE getArchitecture
|
||||
diPlatform <- liftE $ getPlatform
|
||||
pure $ DebugInfo { .. }
|
||||
|
||||
|
||||
|
||||
-----------------
|
||||
--[ Utilities ]--
|
||||
@ -957,7 +979,7 @@ getGHCForMajor :: (MonadIO m, MonadThrow m)
|
||||
=> Int -- ^ major version component
|
||||
-> Int -- ^ minor version component
|
||||
-> m (Maybe Version)
|
||||
getGHCForMajor major minor = do
|
||||
getGHCForMajor major' minor' = do
|
||||
p <- liftIO $ ghcupGHCBaseDir
|
||||
ghcs <- liftIO $ getDirsFiles' p
|
||||
semvers <- forM ghcs $ throwEither . semver . E.decodeUtf8 . toFilePath
|
||||
@ -967,7 +989,7 @@ getGHCForMajor major minor = do
|
||||
. sort
|
||||
. filter
|
||||
(\SemVer {..} ->
|
||||
fromIntegral _svMajor == major && fromIntegral _svMinor == minor
|
||||
fromIntegral _svMajor == major' && fromIntegral _svMinor == minor'
|
||||
)
|
||||
$ semvers
|
||||
|
||||
@ -1016,7 +1038,6 @@ ghcToolFiles ver = do
|
||||
ghcdir <- liftIO $ ghcupGHCDir ver
|
||||
|
||||
-- fail if ghc is not installed
|
||||
exists <- liftIO $ doesDirectoryExist ghcdir
|
||||
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
|
||||
(throwE (NotInstalled $ ToolRequest GHC ver))
|
||||
|
||||
|
||||
@ -19,7 +19,6 @@ import Data.Foldable
|
||||
import Control.Monad
|
||||
import Control.Exception.Safe
|
||||
import Data.Functor
|
||||
import System.Posix.Files.ByteString
|
||||
import System.Posix.Foreign ( oExcl )
|
||||
import System.Posix.Env.ByteString
|
||||
import System.IO
|
||||
@ -40,12 +39,6 @@ import qualified Streamly.FileSystem.Handle as FH
|
||||
import qualified Streamly.Internal.Data.Unfold as SU
|
||||
import qualified Streamly.Prelude as S
|
||||
import System.Exit
|
||||
import qualified Streamly.Data.Fold as FL
|
||||
import Data.ByteString.Builder
|
||||
import Foreign.C.Error
|
||||
import GHCup.Prelude
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent
|
||||
import System.Posix.FD as FD
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
|
||||
@ -61,11 +54,12 @@ data ProcessError = NonZeroExit Int ByteString [ByteString]
|
||||
deriving Show
|
||||
|
||||
|
||||
data CapturedProcess = CapturedProcess {
|
||||
_exitCode :: ExitCode
|
||||
data CapturedProcess = CapturedProcess
|
||||
{ _exitCode :: ExitCode
|
||||
, _stdOut :: ByteString
|
||||
, _stdErr :: ByteString
|
||||
} deriving (Eq, Show)
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
makeLenses ''CapturedProcess
|
||||
|
||||
@ -101,7 +95,7 @@ findExecutable ex = do
|
||||
-- figure out if a file exists, then treat it as a negative result.
|
||||
asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap
|
||||
-- asum for short-circuiting behavior
|
||||
(\s -> (isExecutable (s </> ex) >>= guard) $> (Just (s </> ex)))
|
||||
(\s' -> (isExecutable (s' </> ex) >>= guard) $> (Just (s' </> ex)))
|
||||
sPaths
|
||||
|
||||
|
||||
@ -111,10 +105,9 @@ executeOut :: Path b -- ^ command as filename, e.g. 'ls'
|
||||
-> [ByteString] -- ^ arguments to the command
|
||||
-> Maybe (Path Abs) -- ^ chdir to this path
|
||||
-> IO CapturedProcess
|
||||
executeOut path args chdir =
|
||||
captureOutStreams $ do
|
||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||
SPPB.executeFile (toFilePath path) True args Nothing
|
||||
executeOut path args chdir = captureOutStreams $ do
|
||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||
SPPB.executeFile (toFilePath path) True args Nothing
|
||||
|
||||
|
||||
-- | Capture the stdout and stderr of the given action, which
|
||||
@ -150,9 +143,9 @@ captureOutStreams action =
|
||||
stdout' <- L.toStrict <$> readFd parentStdoutRead
|
||||
stderr' <- L.toStrict <$> readFd parentStderrRead
|
||||
pure $ CapturedProcess { _exitCode = es
|
||||
, _stdOut = stdout'
|
||||
, _stdErr = stderr'
|
||||
}
|
||||
, _stdOut = stdout'
|
||||
, _stdErr = stderr'
|
||||
}
|
||||
_ -> throwIO $ userError $ ("No such PID " ++ show pid)
|
||||
|
||||
where
|
||||
|
||||
@ -1,30 +1,10 @@
|
||||
module GHCup.Logger where
|
||||
|
||||
|
||||
import GHCup
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics
|
||||
|
||||
import Control.Monad
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad.Reader.Class
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Control.Monad.Trans.Reader ( ReaderT
|
||||
, runReaderT
|
||||
)
|
||||
import Data.List
|
||||
import Data.String.QQ
|
||||
import Data.String.Interpolate
|
||||
import Data.Versions
|
||||
import Data.IORef
|
||||
import Optics
|
||||
import System.Exit
|
||||
import System.Console.Pretty
|
||||
import System.IO
|
||||
import Control.Monad.Logger
|
||||
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.ByteString as B
|
||||
|
||||
|
||||
@ -32,14 +12,14 @@ myLoggerT :: (B.ByteString -> IO ()) -> LoggingT m a -> m a
|
||||
myLoggerT outter loggingt = runLoggingT loggingt mylogger
|
||||
where
|
||||
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
|
||||
mylogger loc source level str = do
|
||||
mylogger _ _ level str' = do
|
||||
let l = case level of
|
||||
LevelDebug -> toLogStr (style Bold $ color Blue "[ Debug ]")
|
||||
LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]")
|
||||
LevelWarn -> toLogStr (style Bold $ color Yellow "[ Warn ]")
|
||||
LevelError -> toLogStr (style Bold $ color Red "[ Error ]")
|
||||
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
|
||||
let out = fromLogStr (l <> toLogStr " " <> str <> toLogStr "\n")
|
||||
let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
|
||||
outter out
|
||||
|
||||
myLoggerTStdout :: LoggingT m a -> m a
|
||||
|
||||
@ -15,6 +15,7 @@ module GHCup.Prelude where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Control.Exception.Safe
|
||||
import Data.Bifunctor
|
||||
@ -23,8 +24,8 @@ import qualified Data.Strict.Maybe as S
|
||||
import Data.Monoid ( (<>) )
|
||||
import Data.String
|
||||
|
||||
import qualified Data.Text.Lazy.Builder as B
|
||||
import qualified Data.Text.Lazy.Builder.Int as B
|
||||
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
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import Data.Text ( Text )
|
||||
@ -32,6 +33,7 @@ import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Text as T
|
||||
import Data.Versions
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Haskus.Utils.Types.List
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import System.IO.Error
|
||||
import Language.Haskell.TH
|
||||
@ -99,9 +101,14 @@ lBS2sT :: L.ByteString -> Text
|
||||
lBS2sT = TL.toStrict . TLE.decodeUtf8
|
||||
|
||||
|
||||
handleIO' :: IOErrorType -> (IOException -> IO a) -> IO a -> IO a
|
||||
handleIO' err handler =
|
||||
handleIO (\e -> if err == ioeGetErrorType e then handler e else ioError e)
|
||||
|
||||
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
|
||||
@ -139,14 +146,34 @@ lEM' f em = lift em >>= lE . bimap f id
|
||||
fromEither :: Either a b -> VEither '[a] b
|
||||
fromEither = either (VLeft . V) VRight
|
||||
|
||||
|
||||
liftException :: ( MonadCatch m
|
||||
, MonadIO m
|
||||
, Monad m
|
||||
, e :< es'
|
||||
, LiftVariant es es'
|
||||
)
|
||||
=> IOErrorType
|
||||
-> e
|
||||
-> Excepts es m a
|
||||
-> Excepts es' m a
|
||||
liftException errType ex =
|
||||
handleIO
|
||||
(\e ->
|
||||
if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
|
||||
)
|
||||
. liftE
|
||||
|
||||
|
||||
-- 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 h a action =
|
||||
catchLiftLeft ((\(x@e) -> pure a) :: (e -> Excepts es' m a)) action
|
||||
hideExcept _ a action =
|
||||
catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action
|
||||
|
||||
|
||||
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
|
||||
@ -177,8 +204,8 @@ qq quoteExp' = QuasiQuoter
|
||||
"illegal QuasiQuote (allowed as expression only, used as a declaration)"
|
||||
}
|
||||
|
||||
ver :: QuasiQuoter
|
||||
ver = qq mkV
|
||||
vver :: QuasiQuoter
|
||||
vver = qq mkV
|
||||
where
|
||||
mkV :: Text -> Q Exp
|
||||
mkV = either (fail . show) TH.lift . version
|
||||
|
||||
@ -9,9 +9,21 @@ import Data.Versions
|
||||
import URI.ByteString
|
||||
|
||||
|
||||
data DebugInfo = DebugInfo
|
||||
{ diBaseDir :: Path Abs
|
||||
, diBinDir :: Path Abs
|
||||
, diGHCDir :: Path Abs
|
||||
, diCacheDir :: Path Abs
|
||||
, diURLSource :: URLSource
|
||||
, diArch :: Architecture
|
||||
, diPlatform :: PlatformResult
|
||||
}
|
||||
deriving Show
|
||||
|
||||
|
||||
data SetGHC = SetGHCOnly -- ^ unversioned 'ghc'
|
||||
| SetGHCMajor -- ^ ghc-x.y
|
||||
| SetGHCMinor -- ^ ghc-x.y.z
|
||||
| SetGHCMinor -- ^ ghc-x.y.z -- TODO: rename
|
||||
deriving Show
|
||||
|
||||
|
||||
@ -33,11 +45,12 @@ data DownloadInfo = DownloadInfo
|
||||
|
||||
data Tool = GHC
|
||||
| Cabal
|
||||
| GHCUp
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
data ToolRequest = ToolRequest
|
||||
{ _tool :: Tool
|
||||
, _toolVersion :: Version
|
||||
{ _trTool :: Tool
|
||||
, _trVersion :: Version
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user