Julian Ospald
7a2a5074fa
This is a major refactor of some CLI code. We try to distinguish GHC versions from other versions, so that we can use distinct parsers. Hopefully this doesn't introduce new bugs. This also forces ghcup run to use the new internal ~/.ghcup/tmp dir.
335 lines
9.0 KiB
Haskell
335 lines
9.0 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
|
|
module GHCup.OptParse.Whereis where
|
|
|
|
|
|
|
|
|
|
import GHCup
|
|
import GHCup.Errors
|
|
import GHCup.OptParse.Common
|
|
import GHCup.Types
|
|
import GHCup.Utils
|
|
import GHCup.Prelude.Logger
|
|
import GHCup.Prelude.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.Functor
|
|
import Data.Maybe
|
|
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 Control.Exception.Safe (MonadMask)
|
|
import System.FilePath (takeDirectory)
|
|
import GHCup.Types.Optics
|
|
|
|
|
|
|
|
|
|
----------------
|
|
--[ Commands ]--
|
|
----------------
|
|
|
|
|
|
data WhereisCommand = WhereisTool Tool (Maybe ToolVersion)
|
|
| WhereisBaseDir
|
|
| WhereisBinDir
|
|
| WhereisCacheDir
|
|
| WhereisLogsDir
|
|
| WhereisConfDir
|
|
|
|
|
|
|
|
|
|
|
|
---------------
|
|
--[ Options ]--
|
|
---------------
|
|
|
|
|
|
data WhereisOptions = WhereisOptions {
|
|
directory :: Bool
|
|
}
|
|
|
|
|
|
|
|
|
|
---------------
|
|
--[ Parsers ]--
|
|
---------------
|
|
|
|
|
|
whereisP :: Parser WhereisCommand
|
|
whereisP = subparser
|
|
(commandGroup "Tools locations:" <>
|
|
command
|
|
"ghc"
|
|
(WhereisTool GHC <$> info
|
|
( optional (toolVersionTagArgument Nothing (Just GHC)) <**> helper )
|
|
( progDesc "Get GHC location"
|
|
<> footerDoc (Just $ text whereisGHCFooter ))
|
|
)
|
|
<>
|
|
command
|
|
"cabal"
|
|
(WhereisTool Cabal <$> info
|
|
( optional (toolVersionTagArgument Nothing (Just Cabal)) <**> helper )
|
|
( progDesc "Get cabal location"
|
|
<> footerDoc (Just $ text whereisCabalFooter ))
|
|
)
|
|
<>
|
|
command
|
|
"hls"
|
|
(WhereisTool HLS <$> info
|
|
( optional (toolVersionTagArgument Nothing (Just HLS)) <**> helper )
|
|
( progDesc "Get HLS location"
|
|
<> footerDoc (Just $ text whereisHLSFooter ))
|
|
)
|
|
<>
|
|
command
|
|
"stack"
|
|
(WhereisTool Stack <$> info
|
|
( optional (toolVersionTagArgument Nothing (Just Stack)) <**> helper )
|
|
( progDesc "Get stack location"
|
|
<> footerDoc (Just $ text whereisStackFooter ))
|
|
)
|
|
<>
|
|
command
|
|
"ghcup"
|
|
(WhereisTool GHCup <$> info ( pure Nothing <**> helper ) ( progDesc "Get ghcup location" ))
|
|
) <|> subparser ( commandGroup "Directory locations:"
|
|
<>
|
|
command
|
|
"basedir"
|
|
(info (pure WhereisBaseDir <**> helper)
|
|
( progDesc "Get ghcup base directory location" )
|
|
)
|
|
<>
|
|
command
|
|
"bindir"
|
|
(info (pure WhereisBinDir <**> helper)
|
|
( progDesc "Get ghcup binary directory location" )
|
|
)
|
|
<>
|
|
command
|
|
"cachedir"
|
|
(info (pure WhereisCacheDir <**> helper)
|
|
( progDesc "Get ghcup cache directory location" )
|
|
)
|
|
<>
|
|
command
|
|
"logsdir"
|
|
(info (pure WhereisLogsDir <**> helper)
|
|
( progDesc "Get ghcup logs directory location" )
|
|
)
|
|
<>
|
|
command
|
|
"confdir"
|
|
(info (pure WhereisConfDir <**> helper)
|
|
( progDesc "Get ghcup config directory location" )
|
|
)
|
|
)
|
|
where
|
|
whereisGHCFooter = [s|Discussion:
|
|
Finds the location of a GHC executable, which usually resides in
|
|
a self-contained "~/.ghcup/ghc/<ghcver>" directory.
|
|
|
|
Examples:
|
|
# outputs ~/.ghcup/ghc/8.10.5/bin/ghc.exe
|
|
ghcup whereis ghc 8.10.5
|
|
# outputs ~/.ghcup/ghc/8.10.5/bin/
|
|
ghcup whereis --directory ghc 8.10.5 |]
|
|
|
|
whereisCabalFooter = [s|Discussion:
|
|
Finds the location of a Cabal executable, which usually resides in
|
|
"~/.ghcup/bin/".
|
|
|
|
Examples:
|
|
# outputs ~/.ghcup/bin/cabal-3.4.0.0
|
|
ghcup whereis cabal 3.4.0.0
|
|
# outputs ~/.ghcup/bin
|
|
ghcup whereis --directory cabal 3.4.0.0|]
|
|
|
|
whereisHLSFooter = [s|Discussion:
|
|
Finds the location of a HLS executable, which usually resides in
|
|
"~/.ghcup/bin/".
|
|
|
|
Examples:
|
|
# outputs ~/.ghcup/bin/haskell-language-server-wrapper-1.2.0
|
|
ghcup whereis hls 1.2.0
|
|
# outputs ~/.ghcup/bin/
|
|
ghcup whereis --directory hls 1.2.0|]
|
|
|
|
whereisStackFooter = [s|Discussion:
|
|
Finds the location of a stack executable, which usually resides in
|
|
"~/.ghcup/bin/".
|
|
|
|
Examples:
|
|
# outputs ~/.ghcup/bin/stack-2.7.1
|
|
ghcup whereis stack 2.7.1
|
|
# outputs ~/.ghcup/bin/
|
|
ghcup whereis --directory stack 2.7.1|]
|
|
|
|
|
|
|
|
--------------
|
|
--[ Footer ]--
|
|
--------------
|
|
|
|
|
|
whereisFooter :: String
|
|
whereisFooter = [s|Discussion:
|
|
Finds the location of a tool. For GHC, this is the ghc binary, that
|
|
usually resides in a self-contained "~/.ghcup/ghc/<ghcver>" directory.
|
|
For cabal/stack/hls this the binary usually at "~/.ghcup/bin/<tool>-<ver>".
|
|
|
|
Examples:
|
|
# outputs ~/.ghcup/ghc/8.10.5/bin/ghc.exe
|
|
ghcup whereis ghc 8.10.5
|
|
# outputs ~/.ghcup/ghc/8.10.5/bin/
|
|
ghcup whereis --directory ghc 8.10.5
|
|
# outputs ~/.ghcup/bin/cabal-3.4.0.0
|
|
ghcup whereis cabal 3.4.0.0
|
|
# outputs ~/.ghcup/bin/
|
|
ghcup whereis --directory cabal 3.4.0.0|]
|
|
|
|
|
|
|
|
|
|
---------------------------
|
|
--[ Effect interpreters ]--
|
|
---------------------------
|
|
|
|
|
|
type WhereisEffects = '[ NotInstalled
|
|
, NoToolVersionSet
|
|
, NextVerNotFound
|
|
, TagNotFound
|
|
]
|
|
|
|
|
|
runLeanWhereIs :: (MonadUnliftIO m, MonadIO m)
|
|
=> LeanAppState
|
|
-> Excepts WhereisEffects (ReaderT LeanAppState m) a
|
|
-> m (VEither WhereisEffects a)
|
|
runLeanWhereIs leanAppstate =
|
|
-- Don't use runLeanAppState here, which is disabled on windows.
|
|
-- This is the only command on all platforms that doesn't need full appstate.
|
|
flip runReaderT leanAppstate
|
|
. runE
|
|
@WhereisEffects
|
|
|
|
|
|
runWhereIs :: (MonadUnliftIO m, MonadIO m)
|
|
=> (ReaderT AppState m (VEither WhereisEffects a) -> m (VEither WhereisEffects a))
|
|
-> Excepts WhereisEffects (ReaderT AppState m) a
|
|
-> m (VEither WhereisEffects a)
|
|
runWhereIs runAppState =
|
|
runAppState
|
|
. runE
|
|
@WhereisEffects
|
|
|
|
|
|
|
|
------------------
|
|
--[ Entrypoint ]--
|
|
------------------
|
|
|
|
|
|
|
|
whereis :: ( Monad m
|
|
, MonadMask m
|
|
, MonadUnliftIO m
|
|
, MonadFail m
|
|
)
|
|
=> WhereisCommand
|
|
-> WhereisOptions
|
|
-> (forall a. ReaderT AppState m (VEither WhereisEffects a) -> m (VEither WhereisEffects a))
|
|
-> LeanAppState
|
|
-> (ReaderT LeanAppState m () -> m ())
|
|
-> m ExitCode
|
|
whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
|
|
Dirs{ .. } <- runReaderT getDirs leanAppstate
|
|
case (whereisCommand, whereisOptions) of
|
|
(WhereisTool tool (Just (GHCVersion v)), WhereisOptions{..}) ->
|
|
runLeanWhereIs leanAppstate (do
|
|
loc <- liftE $ whereIsTool tool v
|
|
if directory
|
|
then pure $ takeDirectory loc
|
|
else pure loc
|
|
)
|
|
>>= \case
|
|
VRight r -> do
|
|
liftIO $ putStr r
|
|
pure ExitSuccess
|
|
VLeft e -> do
|
|
runLogger $ logError $ T.pack $ prettyShow e
|
|
pure $ ExitFailure 30
|
|
(WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->
|
|
runLeanWhereIs leanAppstate (do
|
|
loc <- liftE $ whereIsTool tool (mkTVer v)
|
|
if directory
|
|
then pure $ takeDirectory loc
|
|
else pure loc
|
|
)
|
|
>>= \case
|
|
VRight r -> do
|
|
liftIO $ putStr r
|
|
pure ExitSuccess
|
|
VLeft e -> do
|
|
runLogger $ logError $ T.pack $ prettyShow e
|
|
pure $ ExitFailure 30
|
|
|
|
(WhereisTool tool whereVer, WhereisOptions{..}) -> do
|
|
runWhereIs runAppState (do
|
|
(v, _) <- liftE $ fromVersion whereVer tool
|
|
loc <- liftE $ whereIsTool tool v
|
|
if directory
|
|
then pure $ takeDirectory loc
|
|
else pure loc
|
|
)
|
|
>>= \case
|
|
VRight r -> do
|
|
liftIO $ putStr r
|
|
pure ExitSuccess
|
|
VLeft e -> do
|
|
runLogger $ logError $ T.pack $ prettyShow e
|
|
pure $ ExitFailure 30
|
|
|
|
(WhereisBaseDir, _) -> do
|
|
liftIO $ putStr $ fromGHCupPath baseDir
|
|
pure ExitSuccess
|
|
|
|
(WhereisBinDir, _) -> do
|
|
liftIO $ putStr binDir
|
|
pure ExitSuccess
|
|
|
|
(WhereisCacheDir, _) -> do
|
|
liftIO $ putStr $ fromGHCupPath cacheDir
|
|
pure ExitSuccess
|
|
|
|
(WhereisLogsDir, _) -> do
|
|
liftIO $ putStr $ fromGHCupPath logsDir
|
|
pure ExitSuccess
|
|
|
|
(WhereisConfDir, _) -> do
|
|
liftIO $ putStr $ fromGHCupPath confDir
|
|
pure ExitSuccess
|