ghcup-hs/app/ghcup/Main.hs

{-# 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.File
import           GHCup.Utils.Logger
import           GHCup.Utils.Prelude

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.String.QQ
import           Data.Versions
import           Haskus.Utils.Variant.Excepts
import           HPath
import           Options.Applicative     hiding ( style )
import           System.Console.Pretty
import           System.Exit
import           System.IO
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.Encoding            as E





data Options = Options
  {
  -- global options
    optVerbose   :: Bool
  , optCache     :: Bool
  , optUrlSource :: Maybe URI
  -- commands
  , optCommand   :: Command
  }

data Command
  = Install InstallCommand
  | SetGHC SetGHCOptions
  | List ListOptions
  | Rm RmOptions
  | DInfo
  | Compile CompileOptions

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 CompileOptions = CompileOptions
  { ghcVer       :: Version
  , bootstrapVer :: Version
  , jobs         :: Maybe Int
  , buildConfig  :: Maybe (Path Abs)
  }


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"
          (   Install
          <$> (info (installP <**> helper) (progDesc "Install GHC or cabal"))
          )
      <> command
           "list"
           (   List
           <$> (info (listOpts <**> helper)
                     (progDesc "Show available GHCs and other tools")
               )
           )
      <> 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")
                   )
               )
          <> command
               "compile"
               (   Compile
               <$> (info (compileOpts <**> helper)
                         (progDesc "Compile GHC from source")
                   )
               )
          <> commandGroup "GHC commands:"
          <> hidden
          )
    <|> subparser
          (  command
              "debug-info"
              ((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info")))
          <> 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


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 GHC 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
  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
                  . runResourceT
                  . runE
                    @'[ AlreadyInstalled
                      , ArchiveError
                      , DistroNotFound
                      , FileDoesNotExistError
                      , FileError
                      , JSONError
                      , NoCompatibleArch
                      , NoDownload
                      , NotInstalled
                      , PlatformResultError
                      , ProcessError
                      , TagNotFound
                      , URLException
                      , DigestError
                      ]

          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]

          let runCompileGHC =
                runLogger
                  . flip runReaderT settings
                  . runResourceT
                  . runE
                    @'[ AlreadyInstalled
                      , NotInstalled
                      , GHCNotFound
                      , ArchiveError
                      , ProcessError
                      , URLException
                      , DigestError
                      , BuildConfigNotFound
                      , FileDoesNotExistError
                      , URLException
                      , JSONError
                      ]

          case optCommand of
            Install (InstallGHC InstallOptions {..}) ->
              void
                $   (runInstTool $ do
                      dls <- _binaryDownloads <$> liftE getDownloads
                      v  <- liftE $ fromVersion dls instVer GHC
                      liftE $ installTool dls (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
            Install (InstallCabal InstallOptions {..}) ->
              void
                $   (runInstTool $ do
                      dls <- _binaryDownloads <$> liftE getDownloads
                      v  <- liftE $ fromVersion dls instVer Cabal
                      liftE $ installTool dls (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
                      dls <- _binaryDownloads <$> 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 <- _binaryDownloads <$> 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 (CompileOptions {..}) ->
              void
                $   (runCompileGHC $ do
                      dls <- _sourceDownloads <$> liftE getDownloads
                      liftE $ compileGHC dls ghcVer bootstrapVer jobs buildConfig
                    )
                >>= \case
                      VRight _ ->
                        runLogger $ $(logInfo)
                          ([s|GHC successfully compiled and installed|])
                      VLeft (V (AlreadyInstalled treq)) ->
                        runLogger $ $(logWarn)
                          (T.pack (show treq) <> [s| already installed|])
                      VLeft e ->
                        runLogger ($(logError) [i|#{e}|]) >> exitFailure

  pure ()


fromVersion :: Monad m
            => BinaryDownloads
            -> 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