ghcup-hs/app/ghcup/Main.hs

703 lines
22 KiB
Haskell
Raw Normal View History

2020-01-11 20:15:05 +00:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Main where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import GHCup.Version
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Bifunctor
import Data.Char
import Data.List ( intercalate )
import Data.Semigroup ( (<>) )
import Data.String.Interpolate
import Data.Versions
import Haskus.Utils.Variant.Excepts
import HPath
import HPath.IO
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Console.Pretty
import System.Environment
import System.Exit
import System.IO hiding ( appendFile )
import Text.Read
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
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E
data Options = Options
{
-- global options
optVerbose :: Bool
, optCache :: Bool
, optUrlSource :: Maybe URI
, optNoVerify :: Bool
-- commands
, optCommand :: Command
}
data Command
= Install InstallCommand
| SetGHC SetGHCOptions
| List ListOptions
| Rm RmOptions
| DInfo
| Compile CompileCommand
| Upgrade UpgradeOpts
| NumericVersion
data ToolVersion = ToolVersion Version
| ToolTag Tag
data InstallCommand = InstallGHC InstallOptions
| InstallCabal InstallOptions
data InstallOptions = InstallOptions
{ instVer :: Maybe ToolVersion
}
data SetGHCOptions = SetGHCOptions
{ ghcVer :: Maybe ToolVersion
}
data ListOptions = ListOptions
{ lTool :: Maybe Tool
, lCriteria :: Maybe ListCriteria
}
data RmOptions = RmOptions
{ ghcVer :: Version
}
data CompileCommand = CompileGHC CompileOptions
| CompileCabal CompileOptions
data CompileOptions = CompileOptions
{ targetVer :: Version
, bootstrapVer :: Version
, jobs :: Maybe Int
, buildConfig :: Maybe (Path Abs)
}
data UpgradeOpts = UpgradeInplace
| UpgradeAt (Path Abs)
| UpgradeGHCupDir
deriving Show
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" <> internal
)
)
)
<*> switch
(short 'n' <> long "no-verify" <> help
"Skip tarball checksum verification (default: False)"
)
<*> com
where
parseUri s' =
bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s')
com :: Parser Command
com =
subparser
( command
"install"
( Install
<$> (info (installP <**> helper)
(progDesc "Install or update GHC/cabal")
)
)
<> command
"list"
( List
<$> (info (listOpts <**> helper)
(progDesc "Show available GHCs and other tools")
)
)
<> command
"upgrade"
( Upgrade
<$> (info
(upgradeOptsP <**> helper)
(progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)")
)
)
<> command
"compile"
( Compile
<$> (info (compileP <**> helper)
(progDesc "Compile a tool from source")
)
)
<> commandGroup "Main commands:"
)
<|> subparser
( command
"set"
( SetGHC
<$> (info (setGHCOpts <**> helper)
(progDesc "Set the currently active GHC version")
)
)
<> command
"rm"
( Rm
<$> (info
(rmOpts <**> helper)
(progDesc "Remove a GHC version installed by ghcup")
)
)
<> commandGroup "GHC commands:"
<> hidden
)
<|> subparser
( command
"debug-info"
((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info")))
<> command
"numeric-version"
( (\_ -> NumericVersion)
<$> (info (helper) (progDesc "Show the numeric version"))
)
<> commandGroup "Other commands:"
<> hidden
)
installP :: Parser InstallCommand
installP = subparser
( command
"ghc"
( InstallGHC
<$> (info (installOpts <**> helper) (progDesc "Install a GHC version"))
)
<> command
"cabal"
( InstallCabal
<$> (info (installOpts <**> helper)
(progDesc "Install or update a Cabal version")
)
)
)
installOpts :: Parser InstallOptions
installOpts = InstallOptions <$> 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 <$> versionParser
compileP :: Parser CompileCommand
compileP = subparser
( command
"ghc"
( CompileGHC
<$> (info (compileOpts <**> helper) (progDesc "Compile GHC from source")
)
)
<> command
"cabal"
( CompileCabal
<$> (info (compileOpts <**> helper)
(progDesc "Compile Cabal from source")
)
)
)
compileOpts :: Parser CompileOptions
compileOpts =
CompileOptions
<$> (option
(eitherReader
(bimap (const "Not a valid version") id . version . T.pack)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The tool version to compile"
)
)
<*> (option
(eitherReader
(bimap (const "Not a valid version") id . version . T.pack)
)
( short 'b'
<> long "bootstrap-version"
<> metavar "BOOTSTRAP_VERSION"
<> help "The GHC version to bootstrap with (must be installed)"
)
)
<*> optional
(option
(eitherReader (readEither @Int))
(short 'j' <> long "jobs" <> metavar "JOBS" <> help
"How many jobs to use for make"
)
)
<*> optional
(option
(eitherReader
(\x ->
bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
String
(Path Abs)
)
)
(short 'c' <> long "config" <> metavar "CONFIG" <> help
"Absolute path to build config file"
)
)
versionParser :: Parser Version
versionParser = option
(eitherReader (bimap (const "Not a valid version") id . version . T.pack))
(short 'v' <> long "version" <> metavar "VERSION" <> help "The target 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" <> help "The target 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
noVerify = optNoVerify
in Settings { .. }
upgradeOptsP :: Parser UpgradeOpts
upgradeOptsP =
flag'
UpgradeInplace
(short 'i' <> long "inplace" <> help
"Upgrade ghcup in-place (wherever it's at)"
)
<|> ( UpgradeAt
<$> (option
(eitherReader
(\x ->
bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
String
(Path Abs)
)
)
(short 't' <> long "target" <> metavar "TARGET_DIR" <> help
"Absolute filepath to write ghcup into"
)
)
)
<|> (pure UpgradeGHCupDir)
main :: IO ()
main = do
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \opt@Options {..} -> do
let settings = toSettings opt
-- logger interpreter
logfile <- initGHCupFileLogging ([rel|ghcup.log|] :: Path Rel)
let runLogger = myLoggerT LoggerConfig
{ lcPrintDebug = optVerbose
, colorOutter = B.hPut stderr
, rawOutter = appendFile logfile
}
-- wrapper to run effects with settings
let runInstTool =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[ AlreadyInstalled
, UnknownArchive
, DistroNotFound
, FileDoesNotExistError
, CopyError
, JSONError
, NoCompatibleArch
, NoDownload
, NotInstalled
, NoCompatiblePlatform
, BuildFailed
, TagNotFound
, DigestError
, DownloadFailed
]
let runSetGHC =
runLogger
. flip runReaderT settings
. runE
@'[ FileDoesNotExistError
, NotInstalled
, TagNotFound
, JSONError
, TagNotFound
, DownloadFailed
]
let runListGHC =
runLogger
. flip runReaderT settings
. runE @'[FileDoesNotExistError , JSONError , DownloadFailed]
let runRmGHC =
runLogger . flip runReaderT settings . runE @'[NotInstalled]
let runDebugInfo =
runLogger
. flip runReaderT settings
. runE
@'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
let runCompileGHC =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[ AlreadyInstalled
, BuildFailed
, DigestError
, DownloadFailed
, GHCupSetError
, NoDownload
, UnknownArchive
--
, JSONError
]
let runCompileCabal =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[ JSONError
, UnknownArchive
, NoDownload
, DigestError
, DownloadFailed
, BuildFailed
]
let runUpgrade =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[ DigestError
, DistroNotFound
, NoCompatiblePlatform
, NoCompatibleArch
, NoDownload
, FileDoesNotExistError
, JSONError
, DownloadFailed
, CopyError
]
case optCommand of
Install (InstallGHC InstallOptions {..}) ->
void
$ (runInstTool $ do
dls <- liftE getDownloads
v <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBin dls v Nothing
)
>>= \case
VRight _ -> runLogger
$ $(logInfo) ([s|GHC installation successful|])
VLeft (V (AlreadyInstalled _ v)) ->
runLogger $ $(logWarn)
[i|GHC ver #{prettyVer v} already installed|]
VLeft (V (BuildFailed tmpdir e)) ->
runLogger
($(logError) [i|Build failed with #{e}
Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
)
>> exitFailure
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
exitFailure
Install (InstallCabal InstallOptions {..}) ->
void
$ (runInstTool $ do
dls <- liftE getDownloads
v <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBin dls v Nothing
)
>>= \case
VRight _ -> runLogger
$ $(logInfo) ([s|Cabal installation successful|])
VLeft (V (AlreadyInstalled _ v)) ->
runLogger $ $(logWarn)
[i|Cabal ver #{prettyVer v} already installed|]
VLeft e -> do
runLogger $ do
$(logError) [i|#{e}|]
$(logError) [i|Also check the logs in ~/.ghcup/logs|]
exitFailure
SetGHC (SetGHCOptions {..}) ->
void
$ (runSetGHC $ do
dls <- liftE getDownloads
v <- liftE $ fromVersion dls 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
dls <- liftE getDownloads
liftIO $ listVersions dls 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
Compile (CompileGHC CompileOptions {..}) ->
void
$ (runCompileGHC $ do
dls <- liftE getDownloads
liftE
$ compileGHC dls targetVer bootstrapVer jobs buildConfig
)
>>= \case
VRight _ ->
runLogger $ $(logInfo)
([s|GHC successfully compiled and installed|])
VLeft (V (AlreadyInstalled _ v)) ->
runLogger $ $(logWarn)
[i|GHC ver #{prettyVer v} already installed|]
VLeft (V (BuildFailed tmpdir e)) ->
runLogger
($(logError) [i|Build failed with #{e}
Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
)
>> exitFailure
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
Compile (CompileCabal CompileOptions {..}) ->
void
$ (runCompileCabal $ do
dls <- liftE getDownloads
liftE $ compileCabal dls
targetVer
bootstrapVer
jobs
)
>>= \case
VRight _ ->
runLogger $ $(logInfo)
([s|Cabal successfully compiled and installed|])
VLeft (V (BuildFailed tmpdir e)) ->
runLogger
($(logError) [i|Build failed with #{e}
Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
)
>> exitFailure
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
Upgrade (uOpts) -> do
target <- case uOpts of
UpgradeInplace -> do
efp <- liftIO $ getExecutablePath
p <- parseAbs . E.encodeUtf8 . T.pack $ efp
pure $ Just p
(UpgradeAt p) -> pure $ Just p
UpgradeGHCupDir -> do
bdir <- liftIO $ ghcupBinDir
pure (Just (bdir </> ([rel|ghcup|] :: Path Rel)))
void
$ (runUpgrade $ do
dls <- liftE getDownloads
liftE $ upgradeGHCup dls target
)
>>= \case
VRight v' -> do
let pretty_v = prettyVer v'
runLogger
$ $(logInfo)
[i|Successfully upgraded GHCup to version #{pretty_v}|]
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
NumericVersion -> T.hPutStr stdout (prettyPVP ghcUpVer)
pure ()
fromVersion :: Monad m
=> GHCupDownloads
-> 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
, 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)
, if fromSrc then (color Blue "compiled") else mempty
]
)
lr
putStrLn $ formatted