DebugInfo.hs

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

module GHCup.OptParse.DebugInfo where




import           GHCup.Command.DebugInfo
import           GHCup.Errors
import           GHCup.Hardcoded.Version
import           GHCup.Types
import           GHCup.Query.GHCupDirs
import           GHCup.Prelude
import           GHCup.Prelude.Process

#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           Data.List                      ( intercalate )
import           Data.Variant.Excepts
import           Options.Applicative     hiding ( style )
import           Prelude                 hiding ( appendFile )
import           System.Exit
import           System.FilePath
import           Text.PrettyPrint.HughesPJClass ( prettyShow )
import           URI.ByteString (serializeURIRef')

import qualified Data.Text                     as T
import Control.Exception.Safe (MonadMask)
import Language.Haskell.TH
import Data.Bifunctor (bimap)



    -----------------
    --[ Utilities ]--
    -----------------


describe_result :: String
describe_result = $( LitE . StringL <$>
                     runIO (do
                             CapturedProcess{..} <-  do
                              dirs <- liftIO getAllDirs
                              let settings = AppState (defaultSettings { noNetwork = True })
                                               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 { diDirs = Dirs { .. }, ..} =
  "===== Main ======"                              <> "\n"  <>
  "Architecture:  "   <> prettyShow diArch         <> "\n"  <>
  "Platform:      "   <> prettyShow diPlatform     <> "\n"  <>
  "GHCup Version: "   <> describe_result           <> "\n"  <>
  "===== Directories ======"                       <> "\n"  <>
  "base:    " <> fromGHCupPath baseDir             <> "\n"  <>
  "bin:     " <> binDir                            <> "\n"  <>
  "GHCs:    " <> (fromGHCupPath baseDir </> "ghc") <> "\n"  <>
  "cache:   " <> fromGHCupPath cacheDir            <> "\n"  <>
  "logs:    " <> fromGHCupPath logsDir             <> "\n"  <>
  "config:  " <> fromGHCupPath confDir             <> "\n"  <>
  "db:      " <> fromGHCupPath dbDir               <> "\n"  <>
  whenWin ("recycle: " <> fromGHCupPath recycleDir <> "\n") <>
  "temp:    " <> fromGHCupPath tmpDir              <> "\n"  <>
  whenWin ("msys2:   " <> msys2Dir                 <> "\n") <>
  "\n===== Metadata ======\n" <>
  intercalate "\n" ((\(c, u) -> pad (c <> ":") <> " " <> u) <$> channels)
 where
  pad xs
    | xl < maxLength = xs <> replicate (maxLength - xl) ' '
    | otherwise = xs
   where
    xl = length xs
  channels = bimap (T.unpack . channelAliasText) (T.unpack . decUTF8Safe . serializeURIRef') <$> diChannels
  maxLength = (+1) . maximum . fmap (length . fst) $ channels
  whenWin x = if isWindows then x else mempty




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


type DInfoEffects = '[ NoCompatiblePlatform , NoCompatibleArch , DistroNotFound ]



    ------------------
    --[ Entrypoint ]--
    ------------------



dinfo :: ( Monad m
         , MonadMask m
         , MonadUnliftIO m
         , MonadFail m
         , Alternative m
         )
      => (IO (AppState, IO ()), LeanAppState)
      -> m ExitCode
dinfo (getAppState', leanAppstate) = do
  run (liftE getDebugInfo)
    >>= \case
          (VRight di, up) -> do
            liftIO $ putStrLn $ prettyDebugInfo di
            liftIO up
            pure ExitSuccess
          (VLeft e, _) -> do
            runLogger $ logError $ T.pack $ prettyHFError e
            pure $ ExitFailure 8
 where
  runLogger = flip runReaderT leanAppstate
  run action' = do
    (appstate', up) <- liftIO getAppState'
    r <- flip runReaderT appstate'
                  . runResourceT
                  . runE
                    @DInfoEffects
                  $ action'
    pure (r, up)