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.File
import           GHCup.Logger
import           GHCup.Prelude
import           GHCup.Types

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           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
  {
  -- global options
    optVerbose   :: Bool
  , optCache     :: Bool
  , optUrlSource :: Maybe URI
  -- commands
  , optCommand   :: Command
  }

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

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
  }


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")
                   )
               )
          <> 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
    <$> (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" <> 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
                      ]

          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
            Install (InstallGHC InstallOptions {..}) ->
              void
                $   (runInstTool $ do
                      av <- liftE getDownloads
                      v  <- liftE $ fromVersion av instVer 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
            Install (InstallGHC InstallOptions {..}) ->
              void
                $   (runInstTool $ do
                      av <- liftE getDownloads
                      v  <- liftE $ fromVersion av instVer 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