More stuff
This commit is contained in:
177
app/Main.hs
177
app/Main.hs
@@ -1,177 +0,0 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Bifunctor
|
||||
import Data.ByteString ( ByteString )
|
||||
import Data.Functor ( (<&>) )
|
||||
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.File
|
||||
import GHCup.Prelude
|
||||
import GHCup.Types
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import HPath
|
||||
import Options.Applicative
|
||||
import System.Console.Pretty
|
||||
import System.Exit
|
||||
|
||||
|
||||
|
||||
|
||||
data Options = Options
|
||||
{ optVerbose :: Bool
|
||||
, optCache :: Bool
|
||||
, optCommand :: Command
|
||||
}
|
||||
|
||||
data Command
|
||||
= InstallGHC InstallGHCOptions
|
||||
| InstallCabal InstallCabalOptions
|
||||
|
||||
data InstallGHCOptions = InstallGHCOptions
|
||||
{ ghcVer :: Maybe Version
|
||||
}
|
||||
|
||||
data InstallCabalOptions = InstallCabalOptions
|
||||
{ cabalVer :: Maybe Version
|
||||
}
|
||||
|
||||
|
||||
opts :: Parser Options
|
||||
opts =
|
||||
Options
|
||||
<$> switch
|
||||
(short 'v' <> long "verbose" <> help "Whether to enable verbosity")
|
||||
<*> switch (short 'c' <> long "cache" <> help "Whether to cache downloads")
|
||||
<*> com
|
||||
|
||||
|
||||
com :: Parser Command
|
||||
com = subparser
|
||||
( command
|
||||
"install-ghc"
|
||||
( InstallGHC
|
||||
<$> (info (installGHCOpts <**> helper)
|
||||
(progDesc "Install a GHC version")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"install-cabal"
|
||||
( InstallCabal
|
||||
<$> (info (installCabalOpts <**> helper)
|
||||
(progDesc "Install a cabal-install version")
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
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"
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
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"
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
toSettings :: Options -> Settings
|
||||
toSettings Options {..} = let cache = optCache in Settings { .. }
|
||||
|
||||
|
||||
-- TODO: something better than Show instance for errors
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
-- logger interpreter
|
||||
let runLogger = runStderrLoggingT
|
||||
|
||||
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
|
||||
>>= \opt@Options {..} -> do
|
||||
let settings = toSettings opt
|
||||
-- wrapper to run effects with settings
|
||||
let runInstTool =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE
|
||||
@'[ FileError
|
||||
, ArchiveError
|
||||
, ProcessError
|
||||
, URLException
|
||||
, PlatformResultError
|
||||
, NoDownload
|
||||
, NoCompatibleArch
|
||||
, DistroNotFound
|
||||
, TagNotFound
|
||||
, AlreadyInstalled
|
||||
, NotInstalled
|
||||
]
|
||||
|
||||
case optCommand of
|
||||
InstallGHC (InstallGHCOptions {..}) ->
|
||||
void
|
||||
$ (runInstTool $ do
|
||||
v <- maybe
|
||||
( getRecommended availableDownloads GHC
|
||||
?? TagNotFound Recommended GHC
|
||||
)
|
||||
pure
|
||||
ghcVer
|
||||
liftE $ installTool (ToolRequest GHC v)
|
||||
Nothing
|
||||
(OwnSpec availableDownloads)
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> runLogger $ $(logInfo) ([s|GHC installation successful|])
|
||||
VLeft (V (AlreadyInstalled treq)) ->
|
||||
runLogger $ $(logWarn)
|
||||
(T.pack (show treq) <> [s| already installed|])
|
||||
VLeft e -> die (color Red $ show e)
|
||||
InstallCabal (InstallCabalOptions {..}) ->
|
||||
void
|
||||
$ (runInstTool $ do
|
||||
v <- maybe
|
||||
( getRecommended availableDownloads Cabal
|
||||
?? TagNotFound Recommended Cabal
|
||||
)
|
||||
pure
|
||||
cabalVer
|
||||
liftE $ installTool (ToolRequest Cabal v)
|
||||
Nothing
|
||||
(OwnSpec availableDownloads)
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> runLogger $ $(logInfo) ([s|Cabal installation successful|])
|
||||
VLeft (V (AlreadyInstalled treq)) ->
|
||||
runLogger $ $(logWarn)
|
||||
(T.pack (show treq) <> [s| already installed|])
|
||||
VLeft e -> die (color Red $ show e)
|
||||
pure ()
|
||||
127
app/ghcup-gen/AvailableDownloads.hs
Normal file
127
app/ghcup-gen/AvailableDownloads.hs
Normal file
@@ -0,0 +1,127 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
||||
|
||||
module AvailableDownloads where
|
||||
|
||||
import qualified Data.Map as M
|
||||
import GHCup.Prelude
|
||||
import GHCup.Types
|
||||
import HPath
|
||||
import URI.ByteString.QQ
|
||||
|
||||
|
||||
|
||||
-- TODO: version quasiquoter
|
||||
availableDownloads :: AvailableDownloads
|
||||
availableDownloads = M.fromList
|
||||
[ ( GHC
|
||||
, M.fromList
|
||||
[ ( [ver|8.6.5|]
|
||||
, VersionInfo [Latest] $ M.fromList
|
||||
[ ( A_64
|
||||
, M.fromList
|
||||
[ ( Linux UnknownLinux
|
||||
, M.fromList
|
||||
[ ( Nothing
|
||||
, DownloadInfo
|
||||
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz|]
|
||||
(Just ([rel|ghc-8.6.5|] :: Path Rel))
|
||||
)
|
||||
]
|
||||
)
|
||||
, ( Linux Ubuntu
|
||||
, M.fromList
|
||||
[ ( Nothing
|
||||
, DownloadInfo
|
||||
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-deb9-linux.tar.xz|]
|
||||
(Just ([rel|ghc-8.6.5|] :: Path Rel))
|
||||
)
|
||||
]
|
||||
)
|
||||
, ( Linux Debian
|
||||
, M.fromList
|
||||
[ ( Nothing
|
||||
, DownloadInfo
|
||||
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|]
|
||||
(Just ([rel|ghc-8.6.5|] :: Path Rel))
|
||||
)
|
||||
, ( Just $ [vers|8|]
|
||||
, DownloadInfo
|
||||
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|]
|
||||
(Just ([rel|ghc-8.6.5|] :: Path Rel))
|
||||
)
|
||||
]
|
||||
)
|
||||
]
|
||||
)
|
||||
]
|
||||
),
|
||||
( [ver|8.4.4|]
|
||||
, VersionInfo [Latest] $ M.fromList
|
||||
[ ( A_64
|
||||
, M.fromList
|
||||
[ ( Linux UnknownLinux
|
||||
, M.fromList
|
||||
[ ( Nothing
|
||||
, DownloadInfo
|
||||
[uri|https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-fedora27-linux.tar.xz|]
|
||||
(Just ([rel|ghc-8.4.4|] :: Path Rel))
|
||||
)
|
||||
]
|
||||
)
|
||||
, ( Linux Ubuntu
|
||||
, M.fromList
|
||||
[ ( Nothing
|
||||
, DownloadInfo
|
||||
[uri|https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-deb9-linux.tar.xz|]
|
||||
(Just ([rel|ghc-8.4.4|] :: Path Rel))
|
||||
)
|
||||
]
|
||||
)
|
||||
, ( Linux Debian
|
||||
, M.fromList
|
||||
[ ( Nothing
|
||||
, DownloadInfo
|
||||
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|]
|
||||
(Just ([rel|ghc-8.6.5|] :: Path Rel))
|
||||
)
|
||||
, ( Just $ [vers|8|]
|
||||
, DownloadInfo
|
||||
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|]
|
||||
(Just ([rel|ghc-8.6.5|] :: Path Rel))
|
||||
)
|
||||
]
|
||||
)
|
||||
]
|
||||
)
|
||||
]
|
||||
)
|
||||
]
|
||||
)
|
||||
, ( Cabal
|
||||
, M.fromList
|
||||
[ ( [ver|3.0.0.0|]
|
||||
, VersionInfo [Recommended, Latest] $ M.fromList
|
||||
[ ( A_64
|
||||
, M.fromList
|
||||
[ ( Linux UnknownLinux
|
||||
, M.fromList
|
||||
[ ( Nothing
|
||||
, DownloadInfo
|
||||
[uri|https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-unknown-linux.tar.xz|]
|
||||
Nothing
|
||||
)
|
||||
]
|
||||
)
|
||||
]
|
||||
)
|
||||
]
|
||||
)
|
||||
]
|
||||
)
|
||||
]
|
||||
144
app/ghcup-gen/Main.hs
Normal file
144
app/ghcup-gen/Main.hs
Normal file
@@ -0,0 +1,144 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
||||
|
||||
module Main where
|
||||
|
||||
import AvailableDownloads
|
||||
import Data.Aeson ( eitherDecode )
|
||||
import Data.Aeson.Encode.Pretty
|
||||
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
|
||||
import System.IO ( stdout )
|
||||
import Validate
|
||||
|
||||
|
||||
|
||||
data Options = Options
|
||||
{ optCommand :: Command
|
||||
}
|
||||
|
||||
data Command = GenJSON GenJSONOpts
|
||||
| ValidateJSON ValidateJSONOpts
|
||||
|
||||
data Output
|
||||
= FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
|
||||
| StdOutput
|
||||
|
||||
fileOutput :: Parser Output
|
||||
fileOutput =
|
||||
FileOutput
|
||||
<$> (strOption
|
||||
(long "file" <> short 'f' <> metavar "FILENAME" <> help
|
||||
"Output to a file"
|
||||
)
|
||||
)
|
||||
|
||||
stdOutput :: Parser Output
|
||||
stdOutput = flag'
|
||||
StdOutput
|
||||
(short 'o' <> long "stdout" <> help "Print to stdout (default)")
|
||||
|
||||
outputP :: Parser Output
|
||||
outputP = fileOutput <|> stdOutput
|
||||
|
||||
|
||||
data GenJSONOpts = GenJSONOpts
|
||||
{ output :: Maybe Output
|
||||
}
|
||||
|
||||
genJSONOpts :: Parser GenJSONOpts
|
||||
genJSONOpts = GenJSONOpts <$> optional outputP
|
||||
|
||||
|
||||
data Input
|
||||
= FileInput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
|
||||
| StdInput
|
||||
|
||||
fileInput :: Parser Input
|
||||
fileInput =
|
||||
FileInput
|
||||
<$> (strOption
|
||||
(long "file" <> short 'f' <> metavar "FILENAME" <> help
|
||||
"Input file to validate"
|
||||
)
|
||||
)
|
||||
|
||||
stdInput :: Parser Input
|
||||
stdInput = flag'
|
||||
StdInput
|
||||
(short 'i' <> long "stdin" <> help "Validate from stdin (default)")
|
||||
|
||||
inputP :: Parser Input
|
||||
inputP = fileInput <|> stdInput
|
||||
|
||||
data ValidateJSONOpts = ValidateJSONOpts
|
||||
{ input :: Maybe Input
|
||||
}
|
||||
|
||||
validateJSONOpts :: Parser ValidateJSONOpts
|
||||
validateJSONOpts = ValidateJSONOpts <$> optional inputP
|
||||
|
||||
opts :: Parser Options
|
||||
opts = Options <$> com
|
||||
|
||||
com :: Parser Command
|
||||
com = subparser
|
||||
( (command
|
||||
"gen"
|
||||
( GenJSON
|
||||
<$> (info (genJSONOpts <**> helper)
|
||||
(progDesc "Generate the json downloads file")
|
||||
)
|
||||
)
|
||||
)
|
||||
<> (command
|
||||
"check"
|
||||
( ValidateJSON
|
||||
<$> (info (validateJSONOpts <**> helper)
|
||||
(progDesc "Generate the json downloads file")
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
|
||||
>>= \Options {..} -> case optCommand of
|
||||
GenJSON gopts -> do
|
||||
let
|
||||
bs = encodePretty' (defConfig { confIndent = Spaces 2 })
|
||||
availableDownloads
|
||||
case gopts of
|
||||
GenJSONOpts { output = Nothing } -> L.hPutStr stdout bs
|
||||
GenJSONOpts { output = Just StdOutput } -> L.hPutStr stdout bs
|
||||
GenJSONOpts { output = Just (FileOutput file) } ->
|
||||
L.writeFile file bs
|
||||
ValidateJSON vopts -> case vopts of
|
||||
ValidateJSONOpts { input = Nothing } ->
|
||||
L.getContents >>= valAndExit
|
||||
ValidateJSONOpts { input = Just StdInput } ->
|
||||
L.getContents >>= valAndExit
|
||||
ValidateJSONOpts { input = Just (FileInput file) } ->
|
||||
L.readFile file >>= valAndExit
|
||||
pure ()
|
||||
|
||||
where
|
||||
valAndExit contents = do
|
||||
av <- case eitherDecode contents of
|
||||
Right r -> pure r
|
||||
Left e -> die (color Red $ show e)
|
||||
myLoggerTStdout (validate av) >>= exitWith
|
||||
104
app/ghcup-gen/Validate.hs
Normal file
104
app/ghcup-gen/Validate.hs
Normal file
@@ -0,0 +1,104 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
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 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
|
||||
|
||||
|
||||
data ValidationError = InternalError String
|
||||
deriving Show
|
||||
|
||||
instance Exception ValidationError
|
||||
|
||||
|
||||
-- TODO: test that GHC is in semver
|
||||
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m)
|
||||
=> AvailableDownloads
|
||||
-> m ExitCode
|
||||
validate av = do
|
||||
ref <- liftIO $ newIORef 0
|
||||
flip runReaderT ref $ do
|
||||
-- unique tags
|
||||
forM_ (M.toList av) $ \(t, _) -> checkUniqueTags t
|
||||
|
||||
-- required platforms
|
||||
forM_ (M.toList av) $ \(t, versions) ->
|
||||
forM_ (M.toList versions) $ \(v, vi) ->
|
||||
forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do
|
||||
checkHasRequiredPlatforms t v arch (M.keys pspecs)
|
||||
|
||||
-- exit
|
||||
e <- liftIO $ readIORef ref
|
||||
if e > 0 then pure $ ExitFailure e else pure ExitSuccess
|
||||
where
|
||||
checkHasRequiredPlatforms t v arch pspecs = do
|
||||
let v' = prettyVer v
|
||||
when (not $ any (== Linux UnknownLinux) pspecs) $ do
|
||||
lift $ $(logError)
|
||||
[i|Linux UnknownLinux missing for for #{t} #{v'} #{arch}|]
|
||||
addError
|
||||
when (not $ any (== Darwin) pspecs) $ do
|
||||
lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch}|]
|
||||
addError
|
||||
when (not $ any (== FreeBSD) pspecs) $ lift $ $(logWarn)
|
||||
[i|FreeBSD missing for #{t} #{v'} #{arch}|]
|
||||
|
||||
checkUniqueTags tool = do
|
||||
let allTags = join $ fmap snd $ availableToolVersions av tool
|
||||
let nonUnique =
|
||||
fmap fst
|
||||
. filter (\(_, b) -> not b)
|
||||
<$> ( mapM
|
||||
(\case
|
||||
[] -> throwM $ InternalError "empty inner list"
|
||||
(t : ts) ->
|
||||
pure $ (t, ) $ if isUniqueTag t then ts == [] else True
|
||||
)
|
||||
. group
|
||||
. sort
|
||||
$ allTags
|
||||
)
|
||||
case join nonUnique of
|
||||
[] -> pure ()
|
||||
xs -> do
|
||||
lift $ $(logError) [i|Tags not unique: #{xs}|]
|
||||
addError
|
||||
where
|
||||
isUniqueTag Latest = True
|
||||
isUniqueTag Recommended = True
|
||||
|
||||
|
||||
addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()
|
||||
addError = do
|
||||
ref <- ask
|
||||
liftIO $ modifyIORef ref (+ 1)
|
||||
382
app/ghcup/Main.hs
Normal file
382
app/ghcup/Main.hs
Normal file
@@ -0,0 +1,382 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
||||
|
||||
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
|
||||
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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
data Options = Options
|
||||
{ optVerbose :: Bool
|
||||
, optCache :: Bool
|
||||
, optUrlSource :: Maybe URI
|
||||
, optCommand :: Command
|
||||
}
|
||||
|
||||
data Command
|
||||
= InstallGHC InstallGHCOptions
|
||||
| InstallCabal InstallCabalOptions
|
||||
| SetGHC SetGHCOptions
|
||||
| List ListOptions
|
||||
| Rm RmOptions
|
||||
|
||||
data InstallGHCOptions = InstallGHCOptions
|
||||
{ ghcVer :: Maybe Version
|
||||
}
|
||||
|
||||
data InstallCabalOptions = InstallCabalOptions
|
||||
{ cabalVer :: Maybe Version
|
||||
}
|
||||
|
||||
data SetGHCOptions = SetGHCOptions
|
||||
{ ghcVer :: Maybe Version
|
||||
}
|
||||
|
||||
data ListOptions = ListOptions
|
||||
{ lTool :: Maybe Tool
|
||||
, lCriteria :: Maybe ListCriteria
|
||||
}
|
||||
|
||||
data RmOptions = RmOptions
|
||||
{ ghcVer :: Version
|
||||
}
|
||||
|
||||
|
||||
opts :: Parser Options
|
||||
opts =
|
||||
Options
|
||||
<$> switch
|
||||
(short 'v' <> long "verbose" <> help
|
||||
"Whether to enable verbosity (default: False)"
|
||||
)
|
||||
<*> switch
|
||||
(short 'c' <> long "cache" <> help
|
||||
"Whether to cache downloads (default: False)"
|
||||
)
|
||||
<*> (optional
|
||||
(option
|
||||
(eitherReader parseUri)
|
||||
(short 's' <> long "url-source" <> metavar "URL" <> help
|
||||
"Alternative ghcup download info url (default: internal)"
|
||||
)
|
||||
)
|
||||
)
|
||||
<*> com
|
||||
where
|
||||
parseUri s =
|
||||
bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s)
|
||||
|
||||
com :: Parser Command
|
||||
com = subparser
|
||||
( command
|
||||
"install-ghc"
|
||||
( InstallGHC
|
||||
<$> (info (installGHCOpts <**> helper)
|
||||
(progDesc "Install a GHC version")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"install-cabal"
|
||||
( InstallCabal
|
||||
<$> (info (installCabalOpts <**> helper)
|
||||
(progDesc "Install a cabal-install version")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"set-ghc"
|
||||
( SetGHC
|
||||
<$> (info (setGHCOpts <**> helper)
|
||||
(progDesc "Set the currently active GHC version")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"list"
|
||||
( List
|
||||
<$> (info (listOpts <**> helper)
|
||||
(progDesc "Show available GHCs and other tools")
|
||||
)
|
||||
)
|
||||
<> command
|
||||
"rm"
|
||||
( Rm
|
||||
<$> (info (rmOpts <**> helper)
|
||||
(progDesc "Remove a GHC version installed by ghcup")
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
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"
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
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"
|
||||
)
|
||||
)
|
||||
|
||||
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)"
|
||||
)
|
||||
)
|
||||
|
||||
listOpts :: Parser ListOptions
|
||||
listOpts =
|
||||
ListOptions
|
||||
<$> optional
|
||||
(option
|
||||
(eitherReader toolParser)
|
||||
(short 't' <> long "tool" <> metavar "<ghc|cabal>" <> help
|
||||
"Tool to list versions for. Default is ghc only."
|
||||
)
|
||||
)
|
||||
<*> (optional
|
||||
(option
|
||||
(eitherReader criteriaParser)
|
||||
( short 'c'
|
||||
<> long "show-criteria"
|
||||
<> metavar "<installed|set>"
|
||||
<> help "Show only installed or set tool versions"
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
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"
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
||||
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)
|
||||
|
||||
|
||||
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)
|
||||
|
||||
|
||||
toSettings :: Options -> Settings
|
||||
toSettings Options {..} =
|
||||
let cache = optCache
|
||||
urlSource = maybe GHCupURL OwnSource optUrlSource
|
||||
in Settings { .. }
|
||||
|
||||
|
||||
-- TODO: something better than Show instance for errors
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
-- logger interpreter
|
||||
let runLogger = myLoggerTStderr
|
||||
|
||||
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
|
||||
>>= \opt@Options {..} -> do
|
||||
let settings = toSettings opt
|
||||
-- wrapper to run effects with settings
|
||||
let runInstTool =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE
|
||||
@'[ FileError
|
||||
, ArchiveError
|
||||
, ProcessError
|
||||
, URLException
|
||||
, PlatformResultError
|
||||
, NoDownload
|
||||
, NoCompatibleArch
|
||||
, DistroNotFound
|
||||
, TagNotFound
|
||||
, AlreadyInstalled
|
||||
, NotInstalled
|
||||
, JSONError
|
||||
]
|
||||
|
||||
let runSetGHC =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE @'[NotInstalled , TagNotFound, URLException , JSONError]
|
||||
|
||||
let runListGHC =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE @'[URLException , JSONError]
|
||||
|
||||
let runRmGHC =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE @'[NotInstalled]
|
||||
|
||||
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
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> runLogger
|
||||
$ $(logInfo) ([s|GHC installation successful|])
|
||||
VLeft (V (AlreadyInstalled treq)) ->
|
||||
runLogger $ $(logWarn)
|
||||
(T.pack (show treq) <> [s| already installed|])
|
||||
VLeft e -> die (color Red $ show e)
|
||||
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
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> runLogger
|
||||
$ $(logInfo) ([s|Cabal installation successful|])
|
||||
VLeft (V (AlreadyInstalled treq)) ->
|
||||
runLogger $ $(logWarn)
|
||||
(T.pack (show treq) <> [s| already installed|])
|
||||
VLeft e -> die (color Red $ show e)
|
||||
|
||||
SetGHC (SetGHCOptions {..}) ->
|
||||
void
|
||||
$ (runSetGHC $ do
|
||||
av <- liftE getDownloads
|
||||
v <- maybe
|
||||
( getRecommended av GHC
|
||||
?? TagNotFound Recommended GHC
|
||||
)
|
||||
pure
|
||||
ghcVer
|
||||
liftE $ setGHC v SetGHCOnly
|
||||
)
|
||||
>>= \case
|
||||
VRight _ ->
|
||||
runLogger $ $(logInfo) ([s|GHC successfully set|])
|
||||
VLeft e -> die (color Red $ show e)
|
||||
|
||||
List (ListOptions {..}) ->
|
||||
void
|
||||
$ (runListGHC $ do
|
||||
liftE $ listVersions lTool lCriteria
|
||||
)
|
||||
>>= \case
|
||||
VRight r -> liftIO $ printListResult r
|
||||
VLeft e -> die (color Red $ show e)
|
||||
|
||||
Rm (RmOptions {..}) ->
|
||||
void
|
||||
$ (runRmGHC $ do
|
||||
liftE $ rmGHCVer ghcVer
|
||||
)
|
||||
>>= \case
|
||||
VRight _ -> pure ()
|
||||
VLeft e -> die (color Red $ show e)
|
||||
|
||||
pure ()
|
||||
|
||||
|
||||
printListResult :: [ListResult] -> IO ()
|
||||
printListResult lr = do
|
||||
let
|
||||
formatted =
|
||||
gridString
|
||||
[ column expand left def def
|
||||
, column expand left def def
|
||||
, column expand left def def
|
||||
, column expand left def def
|
||||
]
|
||||
$ fmap
|
||||
(\ListResult {..} ->
|
||||
[ if
|
||||
| lSet -> (color Green "✔✔")
|
||||
| lInstalled -> (color Green "✓")
|
||||
| otherwise -> (color Red "✗")
|
||||
, fmap toLower . show $ lTool
|
||||
, T.unpack . prettyVer $ lVer
|
||||
, intercalate "," $ ((fmap . fmap) toLower . fmap show $ lTag)
|
||||
]
|
||||
)
|
||||
lr
|
||||
putStrLn $ formatted
|
||||
Reference in New Issue
Block a user