383 lines
11 KiB
Haskell
383 lines
11 KiB
Haskell
{-# 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
|