ghcup-hs/app/Main.hs

{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE QuasiQuotes       #-}

module Main where

import           Control.Monad.Logger
import           Control.Monad.Reader
import           Control.Monad.IO.Class
import           Data.Bifunctor
import           Data.ByteString                ( ByteString )
import           Data.Functor                   ( (<&>) )
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.File
import           GHCup.Prelude
import           GHCup.Types
import           Haskus.Utils.Variant.Excepts
import           HPath
import           Options.Applicative
import           System.Console.Pretty
import           System.Exit




data Options = Options
  { optVerbose :: Bool
  , optCache :: Bool
  , optCommand :: Command
  }

data Command
  = InstallGHC InstallGHCOptions
  | InstallCabal InstallCabalOptions

data InstallGHCOptions = InstallGHCOptions
  {
    ghcVer          :: Maybe Version
  }

data InstallCabalOptions = InstallCabalOptions
  {
    cabalVer        :: Maybe Version
  }


opts :: Parser Options
opts =
  Options
    <$> switch
          (short 'v' <> long "verbose" <> help "Whether to enable verbosity")
    <*> switch (short 'c' <> long "cache" <> help "Whether to cache downloads")
    <*> com


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")
           )
       )
  )

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"
    )
  )


toSettings :: Options -> Settings
toSettings Options {..} = let cache = optCache in Settings { .. }


-- TODO: something better than Show instance for errors

main :: IO ()
main = do
  -- logger interpreter
  let runLogger = runStderrLoggingT

  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]

          case optCommand of
            InstallGHC (InstallGHCOptions {..}) ->
              void
                $ (runInstTool $ do
                      v <- maybe
                        (  getRecommended availableDownloads GHC
                        ?? TagNotFound Recommended GHC
                        )
                        pure
                        ghcVer
                      liftE $ installTool (ToolRequest GHC v)
                                          Nothing
                                          (OwnSpec availableDownloads)
                    )
                >>= \case
                      VRight _ -> pure ()
                      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
                      v <- maybe
                        (  getRecommended availableDownloads Cabal
                        ?? TagNotFound Recommended Cabal
                        )
                        pure
                        cabalVer
                      liftE $ installTool (ToolRequest Cabal v)
                                          Nothing
                                          (OwnSpec availableDownloads)
                    )
                >>= \case
                      VRight _ -> pure ()
                      VLeft (V (AlreadyInstalled treq)) ->
                        runLogger $ $(logWarn)
                          (T.pack (show treq) <> [s| already installed|])
                      VLeft e -> die (color Red $ show e)
  pure ()