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

Yo

Browse Source
This commit is contained in:
Julian Ospald 2020-03-01 00:07:39 +01:00
parent 6489e8430b
commit e1fb60d3b1
11 changed files with 298 additions and 253 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
TODO.md
View File

@ -5,11 +5,8 @@
* download progress * download progress
* upgrade Upgrade this script in-place * upgrade Upgrade this script in-place
* rm Remove an already installed GHC * maybe: changelog Show the changelog of a GHC release (online)
* debug-info Print debug info (e.g. detected system/distro) * maybe: print-system-reqs Print an approximation of system requirements
* changelog Show the changelog of a GHC release (online)
* print-system-reqs Print an approximation of system requirements
* install major ver
* testing (especially distro detection -> unit tests) * testing (especially distro detection -> unit tests)
@ -25,7 +22,6 @@
* check for new version on start * check for new version on start
* tarball tags as well as version tags? * tarball tags as well as version tags?
* --copy-compiler-tools
* installing multiple versions in parallel? * installing multiple versions in parallel?
* how to version and extend the format of the downloads file? Compatibility? * how to version and extend the format of the downloads file? Compatibility?
* how to propagate updates? Automatically? Might solve the versioning problem * how to propagate updates? Automatically? Might solve the versioning problem

6
app/ghcup-gen/AvailableDownloads.hs
View File

@ -21,7 +21,7 @@ availableDownloads :: AvailableDownloads
availableDownloads = M.fromList availableDownloads = M.fromList
[ ( GHC [ ( GHC
, M.fromList , M.fromList
[ ( [ver|8.6.5|] [ ( [vver|8.6.5|]
, VersionInfo [Latest] $ M.fromList , VersionInfo [Latest] $ M.fromList
[ ( A_64 [ ( A_64
, M.fromList , M.fromList
@ -61,7 +61,7 @@ availableDownloads = M.fromList
) )
] ]
), ),
( [ver|8.4.4|] ( [vver|8.4.4|]
, VersionInfo [Latest] $ M.fromList , VersionInfo [Latest] $ M.fromList
[ ( A_64 [ ( A_64
, M.fromList , M.fromList
@ -105,7 +105,7 @@ availableDownloads = M.fromList
) )
, ( Cabal , ( Cabal
, M.fromList , M.fromList
[ ( [ver|3.0.0.0|] [ ( [vver|3.0.0.0|]
, VersionInfo [Recommended, Latest] $ M.fromList , VersionInfo [Recommended, Latest] $ M.fromList
[ ( A_64 [ ( A_64
, M.fromList , M.fromList

1
app/ghcup-gen/Main.hs
View File

@ -15,7 +15,6 @@ import qualified Data.ByteString.Lazy as L
import Data.Semigroup ( (<>) ) import Data.Semigroup ( (<>) )
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
import Control.Monad.Logger
import GHCup.Logger import GHCup.Logger
import System.Console.Pretty import System.Console.Pretty
import System.Exit import System.Exit

11
app/ghcup-gen/Validate.hs
View File

@ -4,32 +4,23 @@
module Validate where module Validate where
import AvailableDownloads
import GHCup import GHCup
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics
import Control.Monad import Control.Monad
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad.Reader.Class import Control.Monad.Reader.Class
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Reader ( ReaderT import Control.Monad.Trans.Reader ( runReaderT )
, runReaderT
)
import Data.List import Data.List
import Data.String.QQ
import Data.String.Interpolate import Data.String.Interpolate
import Data.Versions import Data.Versions
import Data.IORef import Data.IORef
import Optics
import System.Exit import System.Exit
import System.Console.Pretty
import System.IO
import Control.Monad.Logger import Control.Monad.Logger
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified Data.ByteString as B
-- TODO: improve logging -- TODO: improve logging

222
app/ghcup/Main.hs
View File

@ -10,21 +10,13 @@ module Main where
import Control.Monad.Logger import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.IO.Class
import Data.Bifunctor import Data.Bifunctor
import Data.ByteString ( ByteString )
import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.UTF8 as UTF8
import Data.Char import Data.Char
import Data.Functor ( (<&>) )
import Data.List ( intercalate ) import Data.List ( intercalate )
import qualified Data.Map as M
import Data.Maybe
import Data.Semigroup ( (<>) ) import Data.Semigroup ( (<>) )
import Data.String.QQ import Data.String.QQ
import Data.Text ( Text )
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Traversable
import Data.Versions import Data.Versions
import GHCup import GHCup
import GHCup.Logger import GHCup.Logger
@ -32,12 +24,12 @@ import GHCup.File
import GHCup.Prelude import GHCup.Prelude
import GHCup.Types import GHCup.Types
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import HPath
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
import System.Console.Pretty import System.Console.Pretty
import System.Exit import System.Exit
import URI.ByteString import URI.ByteString
import Text.Layout.Table import Text.Layout.Table
import Data.String.Interpolate
@ -56,17 +48,22 @@ data Command
| SetGHC SetGHCOptions | SetGHC SetGHCOptions
| List ListOptions | List ListOptions
| Rm RmOptions | Rm RmOptions
| DInfo
data ToolVersion = ToolVersion Version
| ToolTag Tag
data InstallGHCOptions = InstallGHCOptions data InstallGHCOptions = InstallGHCOptions
{ ghcVer :: Maybe Version { ghcVer :: Maybe ToolVersion
} }
data InstallCabalOptions = InstallCabalOptions data InstallCabalOptions = InstallCabalOptions
{ cabalVer :: Maybe Version { cabalVer :: Maybe ToolVersion
} }
data SetGHCOptions = SetGHCOptions data SetGHCOptions = SetGHCOptions
{ ghcVer :: Maybe Version { ghcVer :: Maybe ToolVersion
} }
data ListOptions = ListOptions data ListOptions = ListOptions
@ -100,8 +97,8 @@ opts =
) )
<*> com <*> com
where where
parseUri s = parseUri s' =
bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s) bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s')
com :: Parser Command com :: Parser Command
com = subparser com = subparser
@ -140,41 +137,20 @@ com = subparser
(progDesc "Remove a GHC version installed by ghcup") (progDesc "Remove a GHC version installed by ghcup")
) )
) )
<> command
"debug-info"
((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info")))
) )
installGHCOpts :: Parser InstallGHCOptions installGHCOpts :: Parser InstallGHCOptions
installGHCOpts = InstallGHCOptions <$> optional installGHCOpts = InstallGHCOptions <$> optional toolVersionParser
(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"
)
)
installCabalOpts :: Parser InstallCabalOptions installCabalOpts :: Parser InstallCabalOptions
installCabalOpts = InstallCabalOptions <$> optional installCabalOpts = InstallCabalOptions <$> optional toolVersionParser
(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"
)
)
setGHCOpts :: Parser SetGHCOptions setGHCOpts :: Parser SetGHCOptions
setGHCOpts = SetGHCOptions <$> optional setGHCOpts = SetGHCOptions <$> optional toolVersionParser
(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)"
)
)
listOpts :: Parser ListOptions listOpts :: Parser ListOptions
listOpts = listOpts =
@ -183,7 +159,7 @@ listOpts =
(option (option
(eitherReader toolParser) (eitherReader toolParser)
(short 't' <> long "tool" <> metavar "<ghc|cabal>" <> help (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 <*> (optional
@ -198,30 +174,55 @@ listOpts =
) )
rmOpts :: Parser RmOptions rmOpts :: Parser RmOptions
rmOpts = RmOptions <$> rmOpts =
(option RmOptions
(eitherReader <$> (option
(\s -> bimap (const "Not a valid version") id . version . T.pack $ s) (eitherReader
) (bimap (const "Not a valid version") id . version . T.pack)
(short 'v' <> long "version" <> metavar "VERSION" <> help )
"The GHC version to remove" (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 :: String -> Either String Tool
toolParser s | t == T.pack "ghc" = Right GHC toolParser s' | t == T.pack "ghc" = Right GHC
| t == T.pack "cabal" = Right Cabal | t == T.pack "cabal" = Right Cabal
| otherwise = Left ("Unknown tool: " <> s) | otherwise = Left ("Unknown tool: " <> s')
where t = T.toLower (T.pack s) where t = T.toLower (T.pack s')
criteriaParser :: String -> Either String ListCriteria criteriaParser :: String -> Either String ListCriteria
criteriaParser s | t == T.pack "installed" = Right ListInstalled criteriaParser s' | t == T.pack "installed" = Right ListInstalled
| t == T.pack "set" = Right ListSet | t == T.pack "set" = Right ListSet
| otherwise = Left ("Unknown criteria: " <> s) | otherwise = Left ("Unknown criteria: " <> s')
where t = T.toLower (T.pack s) where t = T.toLower (T.pack s')
toSettings :: Options -> Settings toSettings :: Options -> Settings
@ -246,49 +247,54 @@ main = do
runLogger runLogger
. flip runReaderT settings . flip runReaderT settings
. runE . runE
@'[ FileError @'[ AlreadyInstalled
, ArchiveError , ArchiveError
, ProcessError
, URLException
, PlatformResultError
, NoDownload
, NoCompatibleArch
, DistroNotFound , DistroNotFound
, TagNotFound , FileDoesNotExistError
, AlreadyInstalled , FileError
, NotInstalled
, JSONError , JSONError
, NoCompatibleArch
, NoDownload
, NotInstalled
, PlatformResultError
, ProcessError
, TagNotFound
, URLException
] ]
let runSetGHC = let runSetGHC =
runLogger runLogger
. flip runReaderT settings . flip runReaderT settings
. runE @'[NotInstalled , TagNotFound, URLException , JSONError] . runE
@'[ FileDoesNotExistError
, NotInstalled
, TagNotFound
, URLException
, JSONError
, TagNotFound
]
let runListGHC = let runListGHC =
runLogger runLogger
. flip runReaderT settings . flip runReaderT settings
. runE @'[URLException , JSONError] . runE @'[FileDoesNotExistError , URLException , JSONError]
let runRmGHC = let runRmGHC =
runLogger . flip runReaderT settings . runE @'[NotInstalled]
let runDebugInfo =
runLogger runLogger
. flip runReaderT settings . flip runReaderT settings
. runE @'[NotInstalled] . runE
@'[PlatformResultError , NoCompatibleArch , DistroNotFound]
case optCommand of case optCommand of
InstallGHC (InstallGHCOptions {..}) -> InstallGHC (InstallGHCOptions {..}) ->
void void
$ (runInstTool $ do $ (runInstTool $ do
av <- liftE getDownloads av <- liftE getDownloads
v <- maybe v <- liftE $ fromVersion av ghcVer GHC
( getRecommended av GHC liftE $ installTool (ToolRequest GHC v) Nothing
?? TagNotFound Recommended GHC
)
pure
ghcVer
av <- liftE getDownloads
liftE $ installTool (ToolRequest GHC v)
Nothing
) )
>>= \case >>= \case
VRight _ -> runLogger VRight _ -> runLogger
@ -296,20 +302,14 @@ main = do
VLeft (V (AlreadyInstalled treq)) -> VLeft (V (AlreadyInstalled treq)) ->
runLogger $ $(logWarn) runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|]) (T.pack (show treq) <> [s| already installed|])
VLeft e -> die (color Red $ show e) VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
InstallCabal (InstallCabalOptions {..}) -> InstallCabal (InstallCabalOptions {..}) ->
void void
$ (runInstTool $ do $ (runInstTool $ do
av <- liftE getDownloads av <- liftE getDownloads
v <- maybe v <- liftE $ fromVersion av cabalVer Cabal
( getRecommended av Cabal liftE $ installTool (ToolRequest Cabal v) Nothing
?? TagNotFound Recommended Cabal
)
pure
cabalVer
av <- liftE getDownloads
liftE $ installTool (ToolRequest Cabal v)
Nothing
) )
>>= \case >>= \case
VRight _ -> runLogger VRight _ -> runLogger
@ -317,24 +317,21 @@ main = do
VLeft (V (AlreadyInstalled treq)) -> VLeft (V (AlreadyInstalled treq)) ->
runLogger $ $(logWarn) runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|]) (T.pack (show treq) <> [s| already installed|])
VLeft e -> die (color Red $ show e) VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
SetGHC (SetGHCOptions {..}) -> SetGHC (SetGHCOptions {..}) ->
void void
$ (runSetGHC $ do $ (runSetGHC $ do
av <- liftE getDownloads av <- liftE getDownloads
v <- maybe v <- liftE $ fromVersion av ghcVer GHC
( getRecommended av GHC
?? TagNotFound Recommended GHC
)
pure
ghcVer
liftE $ setGHC v SetGHCOnly liftE $ setGHC v SetGHCOnly
) )
>>= \case >>= \case
VRight _ -> VRight _ ->
runLogger $ $(logInfo) ([s|GHC successfully set|]) runLogger $ $(logInfo) ([s|GHC successfully set|])
VLeft e -> die (color Red $ show e) VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
List (ListOptions {..}) -> List (ListOptions {..}) ->
void void
@ -343,7 +340,8 @@ main = do
) )
>>= \case >>= \case
VRight r -> liftIO $ printListResult r VRight r -> liftIO $ printListResult r
VLeft e -> die (color Red $ show e) VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
Rm (RmOptions {..}) -> Rm (RmOptions {..}) ->
void void
@ -352,11 +350,35 @@ main = do
) )
>>= \case >>= \case
VRight _ -> pure () 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 () 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 :: [ListResult] -> IO ()
printListResult lr = do printListResult lr = do
let let

3
ghcup.cabal
View File

@ -32,6 +32,7 @@ common bzlib { build-depends: bzlib >= 0.5.0.5 }
common containers { build-depends: containers >= 0.6 } common containers { build-depends: containers >= 0.6 }
common generics-sop { build-depends: generics-sop >= 0.5 } common generics-sop { build-depends: generics-sop >= 0.5 }
common haskus-utils-variant { build-depends: haskus-utils-variant >= 3.0 } 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 { build-depends: hpath >= 0.11 }
common hpath-directory { build-depends: hpath-directory >= 0.13.2 } common hpath-directory { build-depends: hpath-directory >= 0.13.2 }
common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 } common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 }
@ -98,6 +99,7 @@ library
, containers , containers
, generics-sop , generics-sop
, haskus-utils-variant , haskus-utils-variant
, haskus-utils-types
, hpath , hpath
, hpath-directory , hpath-directory
, hpath-filepath , hpath-filepath
@ -160,6 +162,7 @@ executable ghcup
, hpath , hpath
, pretty-terminal , pretty-terminal
, string-qq , string-qq
, string-interpolate
, table-layout , table-layout
, uri-bytestring , uri-bytestring
, utf8-string , utf8-string

183
lib/GHCup.hs
View File

@ -18,17 +18,14 @@ import Control.Monad
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Logger import Control.Monad.Logger
import Control.Monad.Cont
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Class ( lift )
import Control.Monad.IO.Class
import Control.Exception.Safe import Control.Exception.Safe
import Data.Aeson import Data.Aeson
import Data.Attoparsec.ByteString import Data.Attoparsec.ByteString
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Data.ByteString.Builder import Data.ByteString.Builder
import Data.Foldable ( asum ) import Data.Foldable
import Data.String.QQ import Data.String.QQ
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Versions import Data.Versions
@ -37,8 +34,8 @@ import GHCup.Bash
import GHCup.File import GHCup.File
import GHCup.Prelude import GHCup.Prelude
import GHCup.Types import GHCup.Types
import GHCup.Types.JSON
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import HPath import HPath
import HPath.IO import HPath.IO
import Optics import Optics
@ -48,7 +45,6 @@ import Prelude hiding ( abs
import Data.List import Data.List
import System.Info import System.Info
import System.IO.Error import System.IO.Error
import Data.Foldable ( foldrM )
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
import qualified Data.Text.ICU as ICU import qualified Data.Text.ICU as ICU
@ -56,33 +52,21 @@ import Data.Maybe
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.Word8 import Data.Word8
import GHC.IO.Exception import GHC.IO.Exception
import GHC.IO.Handle
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import Haskus.Utils.Variant.VEither
import Network.Http.Client hiding ( URL ) import Network.Http.Client hiding ( URL )
import System.IO.Streams ( InputStream
, OutputStream
, stdout
)
import qualified System.IO.Streams as Streams import qualified System.IO.Streams as Streams
import System.Posix.FilePath ( takeExtension import System.Posix.FilePath ( takeFileName )
, takeFileName
, splitExtension
)
import qualified System.Posix.FilePath as FP import qualified System.Posix.FilePath as FP
import System.Posix.Files.ByteString ( readSymbolicLink ) import System.Posix.Files.ByteString ( readSymbolicLink )
import System.Posix.Env.ByteString ( getEnvDefault ) import System.Posix.Env.ByteString ( getEnvDefault )
import System.Posix.Temp.ByteString import System.Posix.Temp.ByteString
import qualified System.Posix.RawFilePath.Directory
as RD
import System.Posix.RawFilePath.Directory.Errors import System.Posix.RawFilePath.Directory.Errors
( hideError ) ( hideError )
import "unix" System.Posix.IO.ByteString import "unix" System.Posix.IO.ByteString
hiding ( fdWrite ) hiding ( fdWrite )
import System.Posix.FD as FD
import System.Posix.Foreign ( oTrunc )
import qualified Data.ByteString as B import qualified Data.ByteString as B
import OpenSSL ( withOpenSSL )
import qualified Data.ByteString.Char8 as C
import Data.Functor ( ($>) )
import System.Posix.Types import System.Posix.Types
import "unix-bytestring" System.Posix.IO.ByteString import "unix-bytestring" System.Posix.IO.ByteString
( fdWrite ) ( fdWrite )
@ -90,12 +74,6 @@ import "unix-bytestring" System.Posix.IO.ByteString
import qualified Codec.Compression.GZip as GZip import qualified Codec.Compression.GZip as GZip
import qualified Codec.Compression.Lzma as Lzma import qualified Codec.Compression.Lzma as Lzma
import qualified Codec.Compression.BZip as BZip 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
import URI.ByteString.QQ import URI.ByteString.QQ
import Data.String.Interpolate import Data.String.Interpolate
@ -121,7 +99,7 @@ getCache = ask <&> cache
--------------------------- ---------------------------
data PlatformResultError = NoCompatiblePlatform data PlatformResultError = NoCompatiblePlatform String
deriving Show deriving Show
data NoDownload = NoDownload data NoDownload = NoDownload
@ -160,6 +138,9 @@ data JSONError = JSONDecodeError String
data ParseError = ParseError String data ParseError = ParseError String
deriving Show deriving Show
data FileDoesNotExistError = FileDoesNotExistError ByteString
deriving Show
instance Exception ParseError instance Exception ParseError
@ -195,15 +176,19 @@ getDownloads :: ( FromJSONKey Tool
, FromJSONKey Version , FromJSONKey Version
, FromJSON VersionInfo , FromJSON VersionInfo
, MonadIO m , MonadIO m
, MonadCatch m
, MonadReader Settings m , MonadReader Settings m
) )
=> Excepts '[URLException , JSONError] m AvailableDownloads => Excepts
'[FileDoesNotExistError , URLException , JSONError]
m
AvailableDownloads
getDownloads = lift getUrlSource >>= \case getDownloads = lift getUrlSource >>= \case
GHCupURL -> do GHCupURL -> do
bs <- liftE $ downloadBS ghcupURL bs <- liftE $ downloadBS ghcupURL
lE' JSONDecodeError $ eitherDecode' bs lE' JSONDecodeError $ eitherDecode' bs
(OwnSource uri) -> do (OwnSource url) -> do
bs <- liftE $ downloadBS uri bs <- liftE $ downloadBS url
lE' JSONDecodeError $ eitherDecode' bs lE' JSONDecodeError $ eitherDecode' bs
(OwnSpec av) -> pure $ av (OwnSpec av) -> pure $ av
@ -222,12 +207,13 @@ getDownloadInfo :: ( MonadLogger m
=> ToolRequest => ToolRequest
-> Maybe PlatformRequest -> Maybe PlatformRequest
-> Excepts -> Excepts
'[ PlatformResultError '[ DistroNotFound
, NoDownload , FileDoesNotExistError
, NoCompatibleArch
, DistroNotFound
, URLException
, JSONError , JSONError
, NoCompatibleArch
, NoDownload
, PlatformResultError
, URLException
] ]
m m
DownloadInfo DownloadInfo
@ -235,7 +221,7 @@ getDownloadInfo (ToolRequest t v) mpfReq = do
urlSource <- lift getUrlSource urlSource <- lift getUrlSource
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|] lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
-- lift $ monadLoggerLog undefined undefined undefined "" -- lift $ monadLoggerLog undefined undefined undefined ""
(PlatformRequest arch plat ver) <- case mpfReq of (PlatformRequest arch' plat ver) <- case mpfReq of
Just x -> pure x Just x -> pure x
Nothing -> do Nothing -> do
(PlatformResult rp rv) <- liftE getPlatform (PlatformResult rp rv) <- liftE getPlatform
@ -244,7 +230,7 @@ getDownloadInfo (ToolRequest t v) mpfReq = do
dls <- liftE $ getDownloads dls <- liftE $ getDownloads
lE $ getDownloadInfo' t v arch plat ver dls lE $ getDownloadInfo' t v arch' plat ver dls
getDownloadInfo' :: Tool getDownloadInfo' :: Tool
@ -288,8 +274,8 @@ download dli dest mfn
where where
dl https = do dl https = do
let uri = E.decodeUtf8 (serializeURIRef' (view dlUri dli)) let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
lift $ $(logInfo) [i|downloading: #{uri}|] lift $ $(logInfo) [i|downloading: #{uri'}|]
host <- host <-
preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
?? UnsupportedURL ?? UnsupportedURL
@ -300,20 +286,34 @@ download dli dest mfn
liftIO $ download' https host path port dest mfn liftIO $ download' https host path port dest mfn
downloadBS :: MonadIO m => URI -> Excepts '[URLException] m L.ByteString -- | This is used for downloading the JSON.
downloadBS uri | view (uriSchemeL' % schemeBSL') uri == [s|https|] = dl True downloadBS :: (MonadCatch m, MonadIO m)
| view (uriSchemeL' % schemeBSL') uri == [s|http|] = dl False => URI
| otherwise = throwE UnsupportedURL -> 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 where
scheme = view (uriSchemeL' % schemeBSL') uri'
path = view pathL' uri'
dl https = do dl https = do
host <- host <-
preview (authorityL' % _Just % authorityHostL' % hostBSL') uri preview (authorityL' % _Just % authorityHostL' % hostBSL') uri'
?? UnsupportedURL ?? UnsupportedURL
let path = view pathL' uri
let port = preview let port = preview
(authorityL' % _Just % authorityPortL' % _Just % portNumberL') (authorityL' % _Just % authorityPortL' % _Just % portNumberL')
uri uri'
liftIO $ downloadBS' https host path port liftIO $ downloadBS' https host path port
@ -386,13 +386,13 @@ downloadInternal https host path port consumer = do
receiveResponse receiveResponse
c c
(\p i -> do (\_ i' -> do
outStream <- Streams.makeOutputStream outStream <- Streams.makeOutputStream
(\case (\case
Just bs -> void $ consumer bs Just bs -> void $ consumer bs
Nothing -> pure () Nothing -> pure ()
) )
Streams.connect i outStream Streams.connect i' outStream
) )
closeConnection c closeConnection c
@ -428,7 +428,7 @@ getPlatform = do
"freebsd" -> do "freebsd" -> do
ver <- getFreeBSDVersion ver <- getFreeBSDVersion
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver } pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
what -> throwE NoCompatiblePlatform what -> throwE $ NoCompatiblePlatform what
lift $ $(logDebug) [i|Identified Platform as: #{pfr}|] lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
pure pfr pure pfr
where getFreeBSDVersion = pure Nothing where getFreeBSDVersion = pure Nothing
@ -552,17 +552,17 @@ installTool :: ( MonadThrow m
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, FileError
, ArchiveError , ArchiveError
, DistroNotFound
, FileDoesNotExistError
, FileError
, JSONError
, NoCompatibleArch
, NoDownload
, NotInstalled
, PlatformResultError
, ProcessError , ProcessError
, URLException , URLException
, PlatformResultError
, NoDownload
, NoCompatibleArch
, DistroNotFound
, NotInstalled
, URLException
, JSONError
] ]
m m
() ()
@ -592,7 +592,7 @@ installTool treq mpfReq = do
unpacked <- liftE $ unpackToTmpDir dl unpacked <- liftE $ unpackToTmpDir dl
-- prepare paths -- prepare paths
ghcdir <- liftIO $ ghcupGHCDir (view toolVersion $ treq) ghcdir <- liftIO $ ghcupGHCDir (view trVersion $ treq)
bindir <- liftIO ghcupBinDir bindir <- liftIO ghcupBinDir
-- the subdir of the archive where we do the work -- the subdir of the archive where we do the work
@ -607,14 +607,14 @@ installTool treq mpfReq = do
-- version, create it regardless. -- version, create it regardless.
(mj, mi) <- liftIO $ getGHCMajor ver (mj, mi) <- liftIO $ getGHCMajor ver
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor) getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor)
(ToolRequest Cabal ver) -> liftE $ installCabal archiveSubdir bindir (ToolRequest Cabal _) -> liftE $ installCabal archiveSubdir bindir
pure () pure ()
toolAlreadyInstalled :: ToolRequest -> IO Bool toolAlreadyInstalled :: ToolRequest -> IO Bool
toolAlreadyInstalled ToolRequest {..} = case _tool of toolAlreadyInstalled ToolRequest {..} = case _trTool of
GHC -> ghcInstalled _toolVersion GHC -> ghcInstalled _trVersion
Cabal -> cabalInstalled _toolVersion Cabal -> cabalInstalled _trVersion
@ -678,15 +678,15 @@ setGHC ver sghc = do
-- for ghc tools (ghc, ghci, haddock, ...) -- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ver verfiles <- ghcToolFiles ver
forM verfiles $ \file -> do forM_ verfiles $ \file -> do
liftIO $ hideError doesNotExistErrorType $ deleteFile (destdir </> file) liftIO $ hideError doesNotExistErrorType $ deleteFile (destdir </> file)
targetFile <- case sghc of targetFile <- case sghc of
SetGHCOnly -> pure file SetGHCOnly -> pure file
SetGHCMajor -> do SetGHCMajor -> do
major <- major' <-
(\(mj, mi) -> E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi) (\(mj, mi) -> E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi)
<$> getGHCMajor ver <$> getGHCMajor ver
parseRel (toFilePath file <> B.singleton _hyphen <> major) parseRel (toFilePath file <> B.singleton _hyphen <> major')
SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS) SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
liftIO $ hideError doesNotExistErrorType $ deleteFile liftIO $ hideError doesNotExistErrorType $ deleteFile
(destdir </> targetFile) (destdir </> targetFile)
@ -743,10 +743,13 @@ availableToolVersions av tool = toListOf
av av
listVersions :: (MonadReader Settings m, MonadIO m) listVersions :: (MonadReader Settings m, MonadIO m, MonadCatch m)
=> Maybe Tool => Maybe Tool
-> Maybe ListCriteria -> Maybe ListCriteria
-> Excepts '[URLException , JSONError] m [ListResult] -> Excepts
'[FileDoesNotExistError , URLException , JSONError]
m
[ListResult]
listVersions lt criteria = do listVersions lt criteria = do
dls <- liftE $ getDownloads dls <- liftE $ getDownloads
liftIO $ listVersions' dls lt criteria 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. -- | This function may throw and crash in various ways.
@ -799,14 +802,13 @@ rmGHCVer ver = do
isSetGHC <- fmap (maybe False (== ver)) $ ghcSet isSetGHC <- fmap (maybe False (== ver)) $ ghcSet
dir <- liftIO $ ghcupGHCDir ver dir <- liftIO $ ghcupGHCDir ver
let d' = toFilePath dir let d' = toFilePath dir
let v' = prettyVer ver exists <- liftIO $ doesDirectoryExist dir
exists <- liftIO $ doesDirectoryExist dir
toolsFiles <- liftE $ ghcToolFiles ver toolsFiles <- liftE $ ghcToolFiles ver
if exists if exists
then do then do
-- this isn't atomic -- this isn't atomic, order matters
lift $ $(logInfo) [i|Removing directory recursively: #{d'}|] lift $ $(logInfo) [i|Removing directory recursively: #{d'}|]
liftIO $ deleteDirRecursive dir liftIO $ deleteDirRecursive dir
@ -818,7 +820,7 @@ rmGHCVer ver = do
when isSetGHC $ liftE $ do when isSetGHC $ liftE $ do
lift $ $(logInfo) [i|Removing ghc symlinks|] lift $ $(logInfo) [i|Removing ghc symlinks|]
rmPlain dir toolsFiles rmPlain toolsFiles
liftIO liftIO
$ ghcupBaseDir $ ghcupBaseDir
@ -841,10 +843,9 @@ rmGHCVer ver = do
-- E.g. ghc, if this version is the set one. -- E.g. ghc, if this version is the set one.
-- This reads `ghcupGHCDir`. -- This reads `ghcupGHCDir`.
rmPlain :: (MonadThrow m, MonadFail m, MonadIO m) rmPlain :: (MonadThrow m, MonadFail m, MonadIO m)
=> Path Abs => [Path Rel] -- ^ tools files
-> [Path Rel] -- ^ tools files
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
rmPlain ghcDir files = do rmPlain files = do
bindir <- liftIO $ ghcupBinDir bindir <- liftIO $ ghcupBinDir
forM_ files $ \f -> liftIO $ deleteFile (bindir </> f) 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 ]-- --[ Utilities ]--
@ -957,7 +979,7 @@ getGHCForMajor :: (MonadIO m, MonadThrow m)
=> Int -- ^ major version component => Int -- ^ major version component
-> Int -- ^ minor version component -> Int -- ^ minor version component
-> m (Maybe Version) -> m (Maybe Version)
getGHCForMajor major minor = do getGHCForMajor major' minor' = do
p <- liftIO $ ghcupGHCBaseDir p <- liftIO $ ghcupGHCBaseDir
ghcs <- liftIO $ getDirsFiles' p ghcs <- liftIO $ getDirsFiles' p
semvers <- forM ghcs $ throwEither . semver . E.decodeUtf8 . toFilePath semvers <- forM ghcs $ throwEither . semver . E.decodeUtf8 . toFilePath
@ -967,7 +989,7 @@ getGHCForMajor major minor = do
. sort . sort
. filter . filter
(\SemVer {..} -> (\SemVer {..} ->
fromIntegral _svMajor == major && fromIntegral _svMinor == minor fromIntegral _svMajor == major' && fromIntegral _svMinor == minor'
) )
$ semvers $ semvers
@ -1016,7 +1038,6 @@ ghcToolFiles ver = do
ghcdir <- liftIO $ ghcupGHCDir ver ghcdir <- liftIO $ ghcupGHCDir ver
-- fail if ghc is not installed -- fail if ghc is not installed
exists <- liftIO $ doesDirectoryExist ghcdir
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir) whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
(throwE (NotInstalled $ ToolRequest GHC ver)) (throwE (NotInstalled $ ToolRequest GHC ver))

29
lib/GHCup/File.hs
View File

@ -19,7 +19,6 @@ import Data.Foldable
import Control.Monad import Control.Monad
import Control.Exception.Safe import Control.Exception.Safe
import Data.Functor import Data.Functor
import System.Posix.Files.ByteString
import System.Posix.Foreign ( oExcl ) import System.Posix.Foreign ( oExcl )
import System.Posix.Env.ByteString import System.Posix.Env.ByteString
import System.IO 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.Internal.Data.Unfold as SU
import qualified Streamly.Prelude as S import qualified Streamly.Prelude as S
import System.Exit 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 System.Posix.FD as FD
import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.UTF8 as UTF8
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen ) import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
@ -61,11 +54,12 @@ data ProcessError = NonZeroExit Int ByteString [ByteString]
deriving Show deriving Show
data CapturedProcess = CapturedProcess { data CapturedProcess = CapturedProcess
_exitCode :: ExitCode { _exitCode :: ExitCode
, _stdOut :: ByteString , _stdOut :: ByteString
, _stdErr :: ByteString , _stdErr :: ByteString
} deriving (Eq, Show) }
deriving (Eq, Show)
makeLenses ''CapturedProcess makeLenses ''CapturedProcess
@ -101,7 +95,7 @@ findExecutable ex = do
-- figure out if a file exists, then treat it as a negative result. -- figure out if a file exists, then treat it as a negative result.
asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap
-- asum for short-circuiting behavior -- asum for short-circuiting behavior
(\s -> (isExecutable (s </> ex) >>= guard) $> (Just (s </> ex))) (\s' -> (isExecutable (s' </> ex) >>= guard) $> (Just (s' </> ex)))
sPaths sPaths
@ -111,10 +105,9 @@ executeOut :: Path b -- ^ command as filename, e.g. 'ls'
-> [ByteString] -- ^ arguments to the command -> [ByteString] -- ^ arguments to the command
-> Maybe (Path Abs) -- ^ chdir to this path -> Maybe (Path Abs) -- ^ chdir to this path
-> IO CapturedProcess -> IO CapturedProcess
executeOut path args chdir = executeOut path args chdir = captureOutStreams $ do
captureOutStreams $ do maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir SPPB.executeFile (toFilePath path) True args Nothing
SPPB.executeFile (toFilePath path) True args Nothing
-- | Capture the stdout and stderr of the given action, which -- | Capture the stdout and stderr of the given action, which
@ -150,9 +143,9 @@ captureOutStreams action =
stdout' <- L.toStrict <$> readFd parentStdoutRead stdout' <- L.toStrict <$> readFd parentStdoutRead
stderr' <- L.toStrict <$> readFd parentStderrRead stderr' <- L.toStrict <$> readFd parentStderrRead
pure $ CapturedProcess { _exitCode = es pure $ CapturedProcess { _exitCode = es
, _stdOut = stdout' , _stdOut = stdout'
, _stdErr = stderr' , _stdErr = stderr'
} }
_ -> throwIO $ userError $ ("No such PID " ++ show pid) _ -> throwIO $ userError $ ("No such PID " ++ show pid)
where where

24
lib/GHCup/Logger.hs
View File

@ -1,30 +1,10 @@
module GHCup.Logger where 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.Console.Pretty
import System.IO import System.IO
import Control.Monad.Logger import Control.Monad.Logger
import qualified Data.Map.Strict as M
import qualified Data.ByteString as B 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 myLoggerT outter loggingt = runLoggingT loggingt mylogger
where where
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO () mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
mylogger loc source level str = do mylogger _ _ level str' = do
let l = case level of let l = case level of
LevelDebug -> toLogStr (style Bold $ color Blue "[ Debug ]") LevelDebug -> toLogStr (style Bold $ color Blue "[ Debug ]")
LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]") LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]")
LevelWarn -> toLogStr (style Bold $ color Yellow "[ Warn ]") LevelWarn -> toLogStr (style Bold $ color Yellow "[ Warn ]")
LevelError -> toLogStr (style Bold $ color Red "[ Error ]") LevelError -> toLogStr (style Bold $ color Red "[ Error ]")
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]" LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
let out = fromLogStr (l <> toLogStr " " <> str <> toLogStr "\n") let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
outter out outter out
myLoggerTStdout :: LoggingT m a -> m a myLoggerTStdout :: LoggingT m a -> m a

45
lib/GHCup/Prelude.hs
View File

@ -15,6 +15,7 @@ module GHCup.Prelude where
import Control.Applicative import Control.Applicative
import Control.Monad import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Class ( lift )
import Control.Exception.Safe import Control.Exception.Safe
import Data.Bifunctor import Data.Bifunctor
@ -23,8 +24,8 @@ import qualified Data.Strict.Maybe as S
import Data.Monoid ( (<>) ) import Data.Monoid ( (<>) )
import Data.String import Data.String
import qualified Data.Text.Lazy.Builder as B import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Builder.Int as B import qualified Data.Text.Lazy.Builder.Int as B
import qualified Data.Text.Lazy.Encoding as TLE import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Data.Text ( Text ) import Data.Text ( Text )
@ -32,6 +33,7 @@ import qualified Data.Text.Encoding as E
import qualified Data.Text as T import qualified Data.Text as T
import Data.Versions import Data.Versions
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import System.IO.Error import System.IO.Error
import Language.Haskell.TH import Language.Haskell.TH
@ -99,9 +101,14 @@ lBS2sT :: L.ByteString -> Text
lBS2sT = TL.toStrict . TLE.decodeUtf8 lBS2sT = TL.toStrict . TLE.decodeUtf8
handleIO' :: IOErrorType -> (IOException -> IO a) -> IO a -> IO a
handleIO' err handler = handleIO' :: (MonadIO m, MonadCatch m)
handleIO (\e -> if err == ioeGetErrorType e then handler e else ioError e) => 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 (??) :: 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 a b -> VEither '[a] b
fromEither = either (VLeft . V) VRight 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 hideExcept :: forall e es es' a m
. (Monad m, e :< es, LiftVariant (Remove e es) es') . (Monad m, e :< es, LiftVariant (Remove e es) es')
=> e => e
-> a -> a
-> Excepts es m a -> Excepts es m a
-> Excepts es' m a -> Excepts es' m a
hideExcept h a action = hideExcept _ a action =
catchLiftLeft ((\(x@e) -> pure a) :: (e -> Excepts es' m a)) action catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b 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)" "illegal QuasiQuote (allowed as expression only, used as a declaration)"
} }
ver :: QuasiQuoter vver :: QuasiQuoter
ver = qq mkV vver = qq mkV
where where
mkV :: Text -> Q Exp mkV :: Text -> Q Exp
mkV = either (fail . show) TH.lift . version mkV = either (fail . show) TH.lift . version

19
lib/GHCup/Types.hs
View File

@ -9,9 +9,21 @@ import Data.Versions
import URI.ByteString 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' data SetGHC = SetGHCOnly -- ^ unversioned 'ghc'
| SetGHCMajor -- ^ ghc-x.y | SetGHCMajor -- ^ ghc-x.y
| SetGHCMinor -- ^ ghc-x.y.z | SetGHCMinor -- ^ ghc-x.y.z -- TODO: rename
deriving Show deriving Show
@ -33,11 +45,12 @@ data DownloadInfo = DownloadInfo
data Tool = GHC data Tool = GHC
| Cabal | Cabal
| GHCUp
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
data ToolRequest = ToolRequest data ToolRequest = ToolRequest
{ _tool :: Tool { _trTool :: Tool
, _toolVersion :: Version , _trVersion :: Version
} }
deriving (Eq, Show) deriving (Eq, Show)