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

120 lines
3.6 KiB
Haskell
Raw Permalink Normal View History

2021-10-15 20:24:23 +00:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.DInfo where
import GHCup
import GHCup.Errors
import GHCup.Version
import GHCup.Types
import GHCup.Utils.Dirs
2022-05-21 20:54:18 +00:00
import GHCup.Prelude
import GHCup.Prelude.Logger
import GHCup.Prelude.Process
2021-10-15 20:24:23 +00:00
#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 Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
import Language.Haskell.TH
-----------------
--[ Utilities ]--
-----------------
describe_result :: String
describe_result = $( LitE . StringL <$>
runIO (do
CapturedProcess{..} <- do
dirs <- liftIO getAllDirs
let settings = AppState (defaultSettings { noNetwork = True })
2021-10-15 20:24:23 +00:00
dirs
defaultKeyBindings
flip runReaderT settings $ executeOut "git" ["describe"] Nothing
case _exitCode of
ExitSuccess -> pure . T.unpack . decUTF8Safe' $ _stdOut
ExitFailure _ -> pure numericVer
)
)
prettyDebugInfo :: DebugInfo -> String
prettyDebugInfo DebugInfo {..} = "Debug Info" <> "\n" <>
"==========" <> "\n" <>
"GHCup base dir: " <> diBaseDir <> "\n" <>
"GHCup bin dir: " <> diBinDir <> "\n" <>
"GHCup GHC directory: " <> diGHCDir <> "\n" <>
"GHCup cache directory: " <> diCacheDir <> "\n" <>
"Architecture: " <> prettyShow diArch <> "\n" <>
"Platform: " <> prettyShow diPlatform <> "\n" <>
"Version: " <> describe_result
---------------------------
--[ Effect interpreters ]--
---------------------------
type DInfoEffects = '[ NoCompatiblePlatform , NoCompatibleArch , DistroNotFound ]
runDebugInfo :: (ReaderT env m (VEither DInfoEffects a) -> m (VEither DInfoEffects a))
-> Excepts DInfoEffects (ReaderT env m) a
-> m (VEither DInfoEffects a)
runDebugInfo runAppState =
runAppState
. runE
@DInfoEffects
------------------
--[ Entrypoint ]--
------------------
dinfo :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
, Alternative m
)
=> (ReaderT AppState m (VEither DInfoEffects DebugInfo)
-> m (VEither DInfoEffects DebugInfo))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
dinfo runAppState runLogger = do
runDebugInfo runAppState (liftE getDebugInfo)
>>= \case
VRight di -> do
liftIO $ putStrLn $ prettyDebugInfo di
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 8