ghcup-hs/app/ghcup/GHCup/OptParse/Set.hs

{-# LANGUAGE CPP               #-}
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}

module GHCup.OptParse.Set where




import           GHCup.OptParse.Common

import           GHCup
import           GHCup.Errors
import           GHCup.Types
import           GHCup.Utils.Logger
import           GHCup.Utils.String.QQ

#if !MIN_VERSION_base(4,13,0)
import           Control.Monad.Fail             ( MonadFail )
#endif
import           Control.Monad.Reader
import           Control.Monad.Trans.Resource
import           Data.Either
import           Data.Functor
import           Data.Maybe
import           Data.Versions           hiding ( str )
import           GHC.Unicode
import           Haskus.Utils.Variant.Excepts
import           Options.Applicative     hiding ( style )
import           Options.Applicative.Help.Pretty ( text )
import           Prelude                 hiding ( appendFile )
import           System.Exit
import           Text.PrettyPrint.HughesPJClass ( prettyShow )

import qualified Data.Text                     as T
import Data.Bifunctor (second)
import Control.Exception.Safe (MonadMask)
import GHCup.Types.Optics




    ----------------
    --[ Commands ]--
    ----------------


data SetCommand = SetGHC SetOptions
                | SetCabal SetOptions
                | SetHLS SetOptions
                | SetStack SetOptions




    ---------------
    --[ Options ]--
    ---------------


data SetOptions = SetOptions
  { sToolVer :: SetToolVersion
  }




    ---------------
    --[ Parsers ]--
    ---------------

          
setParser :: Parser (Either SetCommand SetOptions)
setParser =
  (Left <$> subparser
      (  command
          "ghc"
          (   SetGHC
          <$> info
                (setOpts (Just GHC) <**> helper)
                (  progDesc "Set GHC version"
                <> footerDoc (Just $ text setGHCFooter)
                )
          )
      <> command
           "cabal"
           (   SetCabal
           <$> info
                 (setOpts (Just Cabal) <**> helper)
                 (  progDesc "Set Cabal version"
                 <> footerDoc (Just $ text setCabalFooter)
                 )
           )
      <> command
           "hls"
           (   SetHLS
           <$> info
                 (setOpts (Just HLS) <**> helper)
                 (  progDesc "Set haskell-language-server version"
                 <> footerDoc (Just $ text setHLSFooter)
                 )
           )
      <> command
           "stack"
           (   SetStack
           <$> info
                 (setOpts (Just Stack) <**> helper)
                 (  progDesc "Set stack version"
                 <> footerDoc (Just $ text setStackFooter)
                 )
           )
      )
    )
    <|> (Right <$> setOpts Nothing)
 where
  setGHCFooter :: String
  setGHCFooter = [s|Discussion:
    Sets the the current GHC version by creating non-versioned
    symlinks for all ghc binaries of the specified version in
    "~/.ghcup/bin/<binary>".|]

  setCabalFooter :: String
  setCabalFooter = [s|Discussion:
    Sets the the current Cabal version.|]

  setStackFooter :: String
  setStackFooter = [s|Discussion:
    Sets the the current Stack version.|]

  setHLSFooter :: String
  setHLSFooter = [s|Discussion:
    Sets the the current haskell-language-server version.|]


setOpts :: Maybe Tool -> Parser SetOptions
setOpts tool = SetOptions <$>
    (fromMaybe SetRecommended <$>
      optional (setVersionArgument (Just ListInstalled) tool))

setVersionArgument :: Maybe ListCriteria -> Maybe Tool -> Parser SetToolVersion
setVersionArgument criteria tool =
  argument (eitherReader setEither)
    (metavar "VERSION|TAG|next"
    <> completer (tagCompleter (fromMaybe GHC tool) ["next"])
    <> foldMap (completer . versionCompleter criteria) tool)
 where
  setEither s' =
        parseSet s'
    <|> second SetToolTag (tagEither s')
    <|> second SetToolVersion (tVersionEither s')
  parseSet s' = case fmap toLower s' of
                  "next" -> Right SetNext
                  other  -> Left $ "Unknown tag/version " <> other




    --------------
    --[ Footer ]--
    --------------


setFooter :: String
setFooter = [s|Discussion:
  Sets the currently active GHC or cabal version. When no command is given,
  defaults to setting GHC with the specified version/tag (if no tag
  is given, sets GHC to 'recommended' version).
  It is recommended to always specify a subcommand (ghc/cabal/hls/stack).|]



    ---------------------------
    --[ Effect interpreters ]--
    ---------------------------


type SetGHCEffects = '[ FileDoesNotExistError
                   , NotInstalled
                   , TagNotFound
                   , NextVerNotFound
                   , NoToolVersionSet]

runSetGHC :: (ReaderT env m (VEither SetGHCEffects a) -> m (VEither SetGHCEffects a))
          -> Excepts SetGHCEffects (ReaderT env m) a
          -> m (VEither SetGHCEffects a)
runSetGHC runAppState =
    runAppState
    . runE
      @SetGHCEffects


type SetCabalEffects = '[ NotInstalled
                        , TagNotFound
                        , NextVerNotFound
                        , NoToolVersionSet]

runSetCabal :: (ReaderT env m (VEither SetCabalEffects a) -> m (VEither SetCabalEffects a))
            -> Excepts SetCabalEffects (ReaderT env m) a
            -> m (VEither SetCabalEffects a)
runSetCabal runAppState =
    runAppState
    . runE
      @SetCabalEffects


type SetHLSEffects = '[ NotInstalled
                      , TagNotFound
                      , NextVerNotFound
                      , NoToolVersionSet]

runSetHLS :: (ReaderT env m (VEither SetHLSEffects a) -> m (VEither SetHLSEffects a))
          -> Excepts SetHLSEffects (ReaderT env m) a
          -> m (VEither SetHLSEffects a)
runSetHLS runAppState =
    runAppState
    . runE
      @SetHLSEffects


type SetStackEffects = '[ NotInstalled
                        , TagNotFound
                        , NextVerNotFound
                        , NoToolVersionSet]

runSetStack :: (ReaderT env m (VEither SetStackEffects a) -> m (VEither SetStackEffects a))
            -> Excepts SetStackEffects (ReaderT env m) a
            -> m (VEither SetStackEffects a)
runSetStack runAppState =
    runAppState
    . runE
      @SetStackEffects



    -------------------
    --[ Entrypoints ]--
    -------------------


set :: forall m env.
       ( Monad m
       , MonadMask m
       , MonadUnliftIO m
       , MonadFail m
       , HasDirs env
       , HasLog env
       )
    => Either SetCommand SetOptions
    -> (forall eff . ReaderT AppState m (VEither eff GHCTargetVersion)
        -> m (VEither eff GHCTargetVersion))
    -> (forall eff. ReaderT env m (VEither eff GHCTargetVersion)
        -> m (VEither eff GHCTargetVersion))
    -> (ReaderT LeanAppState m () -> m ())
    -> m ExitCode
set setCommand runAppState runLeanAppState runLogger = case setCommand of
  (Right sopts) -> do
    runLogger (logWarn "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.")
    setGHC' sopts
  (Left (SetGHC sopts)) -> setGHC' sopts
  (Left (SetCabal sopts)) -> setCabal' sopts
  (Left (SetHLS sopts)) -> setHLS' sopts
  (Left (SetStack sopts)) -> setStack' sopts

 where
  setGHC' :: SetOptions
          -> m ExitCode
  setGHC' SetOptions{ sToolVer } =
    case sToolVer of
      (SetToolVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly >> pure v)
      _ -> runSetGHC runAppState (do
          v <- liftE $ fst <$> fromVersion' sToolVer GHC
          liftE $ setGHC v SetGHCOnly
        )
      >>= \case
            VRight GHCTargetVersion{..} -> do
              runLogger
                $ logInfo $
                    "GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget
              pure ExitSuccess
            VLeft e -> do
              runLogger $ logError $ T.pack $ prettyShow e
              pure $ ExitFailure 5


  setCabal' :: SetOptions
            -> m ExitCode
  setCabal' SetOptions{ sToolVer } =
    case sToolVer of
      (SetToolVersion v) -> runSetCabal runLeanAppState (liftE $ setCabal (_tvVersion v) >> pure v)
      _ -> runSetCabal runAppState (do
          v <- liftE $ fst <$> fromVersion' sToolVer Cabal
          liftE $ setCabal (_tvVersion v)
          pure v
        )
      >>= \case
            VRight GHCTargetVersion{..} -> do
              runLogger
                $ logInfo $
                    "Cabal " <> prettyVer _tvVersion <> " successfully set as default version"
              pure ExitSuccess
            VLeft  e -> do
              runLogger $ logError $ T.pack $ prettyShow e
              pure $ ExitFailure 14

  setHLS' :: SetOptions
          -> m ExitCode
  setHLS' SetOptions{ sToolVer } =
    case sToolVer of
      (SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS (_tvVersion v) SetHLSOnly >> pure v)
      _ -> runSetHLS runAppState (do
          v <- liftE $ fst <$> fromVersion' sToolVer HLS
          liftE $ setHLS (_tvVersion v) SetHLSOnly
          pure v
        )
      >>= \case
            VRight GHCTargetVersion{..} -> do
              runLogger
                $ logInfo $
                    "HLS " <> prettyVer _tvVersion <> " successfully set as default version"
              pure ExitSuccess
            VLeft  e -> do
              runLogger $ logError $ T.pack $ prettyShow e
              pure $ ExitFailure 14


  setStack' :: SetOptions
            -> m ExitCode
  setStack' SetOptions{ sToolVer } =
    case sToolVer of
      (SetToolVersion v) -> runSetStack runLeanAppState (liftE $ setStack (_tvVersion v) >> pure v)
      _ -> runSetStack runAppState (do
            v <- liftE $ fst <$> fromVersion' sToolVer Stack
            liftE $ setStack (_tvVersion v)
            pure v
          )
      >>= \case
            VRight GHCTargetVersion{..} -> do
              runLogger
                $ logInfo $
                    "Stack " <> prettyVer _tvVersion <> " successfully set as default version"
              pure ExitSuccess
            VLeft  e -> do
              runLogger $ logError $ T.pack $ prettyShow e
              pure $ ExitFailure 14