411 lines
12 KiB
Haskell
411 lines
12 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
|
|
|
|
module Main where
|
|
|
|
import GHCup
|
|
import GHCup.File
|
|
import GHCup.Logger
|
|
import GHCup.Prelude
|
|
import GHCup.Types
|
|
|
|
import Control.Monad.Logger
|
|
import Control.Monad.Reader
|
|
import Data.Bifunctor
|
|
import Data.Char
|
|
import Data.List ( intercalate )
|
|
import Data.Semigroup ( (<>) )
|
|
import Data.String.Interpolate
|
|
import Data.String.QQ
|
|
import Data.Versions
|
|
import Haskus.Utils.Variant.Excepts
|
|
import Options.Applicative hiding ( style )
|
|
import System.Console.Pretty
|
|
import System.Exit
|
|
import System.IO
|
|
import Text.Layout.Table
|
|
import URI.ByteString
|
|
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.ByteString.UTF8 as UTF8
|
|
import qualified Data.Text as T
|
|
|
|
|
|
|
|
|
|
|
|
data Options = Options
|
|
{ optVerbose :: Bool
|
|
, optCache :: Bool
|
|
, optUrlSource :: Maybe URI
|
|
, optCommand :: Command
|
|
}
|
|
|
|
data Command
|
|
= InstallGHC InstallGHCOptions
|
|
| InstallCabal InstallCabalOptions
|
|
| SetGHC SetGHCOptions
|
|
| List ListOptions
|
|
| Rm RmOptions
|
|
| DInfo
|
|
|
|
data ToolVersion = ToolVersion Version
|
|
| ToolTag Tag
|
|
|
|
|
|
data InstallGHCOptions = InstallGHCOptions
|
|
{ ghcVer :: Maybe ToolVersion
|
|
}
|
|
|
|
data InstallCabalOptions = InstallCabalOptions
|
|
{ cabalVer :: Maybe ToolVersion
|
|
}
|
|
|
|
data SetGHCOptions = SetGHCOptions
|
|
{ ghcVer :: Maybe ToolVersion
|
|
}
|
|
|
|
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")
|
|
)
|
|
)
|
|
<> command
|
|
"debug-info"
|
|
((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info")))
|
|
)
|
|
|
|
installGHCOpts :: Parser InstallGHCOptions
|
|
installGHCOpts = InstallGHCOptions <$> optional toolVersionParser
|
|
|
|
|
|
installCabalOpts :: Parser InstallCabalOptions
|
|
installCabalOpts = InstallCabalOptions <$> optional toolVersionParser
|
|
|
|
setGHCOpts :: Parser SetGHCOptions
|
|
setGHCOpts = SetGHCOptions <$> optional toolVersionParser
|
|
|
|
listOpts :: Parser ListOptions
|
|
listOpts =
|
|
ListOptions
|
|
<$> optional
|
|
(option
|
|
(eitherReader toolParser)
|
|
(short 't' <> long "tool" <> metavar "<ghc|cabal>" <> help
|
|
"Tool to list versions for. Default is all"
|
|
)
|
|
)
|
|
<*> (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
|
|
(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')
|
|
|
|
|
|
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
|
|
|
|
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
|
|
>>= \opt@Options {..} -> do
|
|
let settings = toSettings opt
|
|
|
|
-- logger interpreter
|
|
let runLogger = myLoggerT (LoggerConfig optVerbose $ B.hPut stderr)
|
|
|
|
-- wrapper to run effects with settings
|
|
let runInstTool =
|
|
runLogger
|
|
. flip runReaderT settings
|
|
. runE
|
|
@'[ AlreadyInstalled
|
|
, ArchiveError
|
|
, DistroNotFound
|
|
, FileDoesNotExistError
|
|
, FileError
|
|
, JSONError
|
|
, NoCompatibleArch
|
|
, NoDownload
|
|
, NotInstalled
|
|
, PlatformResultError
|
|
, ProcessError
|
|
, TagNotFound
|
|
, URLException
|
|
]
|
|
|
|
let runSetGHC =
|
|
runLogger
|
|
. flip runReaderT settings
|
|
. runE
|
|
@'[ FileDoesNotExistError
|
|
, NotInstalled
|
|
, TagNotFound
|
|
, URLException
|
|
, JSONError
|
|
, TagNotFound
|
|
]
|
|
|
|
let runListGHC =
|
|
runLogger
|
|
. flip runReaderT settings
|
|
. runE @'[FileDoesNotExistError , URLException , JSONError]
|
|
|
|
let runRmGHC =
|
|
runLogger . flip runReaderT settings . runE @'[NotInstalled]
|
|
|
|
let runDebugInfo =
|
|
runLogger
|
|
. flip runReaderT settings
|
|
. runE
|
|
@'[PlatformResultError , NoCompatibleArch , DistroNotFound]
|
|
|
|
case optCommand of
|
|
InstallGHC (InstallGHCOptions {..}) ->
|
|
void
|
|
$ (runInstTool $ do
|
|
av <- liftE getDownloads
|
|
v <- liftE $ fromVersion av ghcVer GHC
|
|
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 ->
|
|
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
|
InstallCabal (InstallCabalOptions {..}) ->
|
|
void
|
|
$ (runInstTool $ do
|
|
av <- liftE getDownloads
|
|
v <- liftE $ fromVersion av cabalVer Cabal
|
|
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 ->
|
|
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
|
|
|
SetGHC (SetGHCOptions {..}) ->
|
|
void
|
|
$ (runSetGHC $ do
|
|
av <- liftE getDownloads
|
|
v <- liftE $ fromVersion av ghcVer GHC
|
|
liftE $ setGHC v SetGHCOnly
|
|
)
|
|
>>= \case
|
|
VRight _ ->
|
|
runLogger $ $(logInfo) ([s|GHC successfully set|])
|
|
VLeft e ->
|
|
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
|
|
|
List (ListOptions {..}) ->
|
|
void
|
|
$ (runListGHC $ do
|
|
liftE $ listVersions lTool lCriteria
|
|
)
|
|
>>= \case
|
|
VRight r -> liftIO $ printListResult r
|
|
VLeft e ->
|
|
runLogger ($(logError) [i|#{e}|]) >> exitFailure
|
|
|
|
Rm (RmOptions {..}) ->
|
|
void
|
|
$ (runRmGHC $ do
|
|
liftE $ rmGHCVer ghcVer
|
|
)
|
|
>>= \case
|
|
VRight _ -> pure ()
|
|
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
|
|
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
|