From aece30500314a0b7c980807ec1fcacc2ee33a351 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 23 Sep 2021 12:53:01 +0200 Subject: [PATCH] Move logger stuff to logger module --- app/ghcup-gen/Main.hs | 2 +- app/ghcup-gen/Validate.hs | 1 + app/ghcup/BrickMain.hs | 2 +- lib/GHCup.hs | 1 + lib/GHCup/Download.hs | 1 + lib/GHCup/Platform.hs | 1 + lib/GHCup/Types/JSON.hs | 2 + lib/GHCup/Types/Optics.hs | 78 ---------------------------- lib/GHCup/Utils.hs | 1 + lib/GHCup/Utils/Dirs.hs | 1 + lib/GHCup/Utils/File/Common.hs-boot | 5 ++ lib/GHCup/Utils/File/Posix.hs | 1 + lib/GHCup/Utils/Logger.hs | 80 ++++++++++++++++++++++++++++- lib/GHCup/Utils/Logger.hs-boot | 21 ++++++++ lib/GHCup/Utils/Prelude.hs | 1 + 15 files changed, 117 insertions(+), 81 deletions(-) create mode 100644 lib/GHCup/Utils/File/Common.hs-boot create mode 100644 lib/GHCup/Utils/Logger.hs-boot diff --git a/app/ghcup-gen/Main.hs b/app/ghcup-gen/Main.hs index a177c7a..f5bae3f 100644 --- a/app/ghcup-gen/Main.hs +++ b/app/ghcup-gen/Main.hs @@ -11,10 +11,10 @@ module Main where import GHCup.Types -import GHCup.Types.Optics import GHCup.Errors import GHCup.Platform import GHCup.Utils.Dirs +import GHCup.Utils.Logger import GHCup.Types.JSON ( ) import Control.Monad.Trans.Reader ( runReaderT ) diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index 3aaeeb6..3e949e9 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -15,6 +15,7 @@ import GHCup.Errors import GHCup.Types import GHCup.Types.Optics import GHCup.Utils +import GHCup.Utils.Logger import GHCup.Utils.Version.QQ import Codec.Archive diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index e9148e1..0981a10 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -13,9 +13,9 @@ module BrickMain where import GHCup import GHCup.Download import GHCup.Errors -import GHCup.Types.Optics hiding ( getGHCupInfo ) import GHCup.Types hiding ( LeanAppState(..) ) import GHCup.Utils +import GHCup.Utils.Logger import GHCup.Utils.Prelude ( decUTF8Safe ) import GHCup.Utils.File diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 502d86e..e3c6543 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -34,6 +34,7 @@ import GHCup.Types.JSON ( ) import GHCup.Types.Optics import GHCup.Utils import GHCup.Utils.File +import GHCup.Utils.Logger import GHCup.Utils.Prelude import GHCup.Utils.String.QQ import GHCup.Utils.Version.QQ diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 3cc22cd..505ab89 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -35,6 +35,7 @@ import GHCup.Types.Optics import GHCup.Types.JSON ( ) import GHCup.Utils.Dirs import GHCup.Utils.File +import GHCup.Utils.Logger import GHCup.Utils.Prelude import GHCup.Version diff --git a/lib/GHCup/Platform.hs b/lib/GHCup/Platform.hs index 4876498..99092bd 100644 --- a/lib/GHCup/Platform.hs +++ b/lib/GHCup/Platform.hs @@ -23,6 +23,7 @@ import GHCup.Types import GHCup.Types.Optics import GHCup.Types.JSON ( ) import GHCup.Utils.File +import GHCup.Utils.Logger import GHCup.Utils.Prelude import GHCup.Utils.String.QQ diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 0dabf99..ab265ae 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -24,6 +24,8 @@ module GHCup.Types.JSON where import GHCup.Types import GHCup.Utils.MegaParsec import GHCup.Utils.Prelude +import GHCup.Utils.Logger () -- TH is broken shite and needs GHCup.Utils.Logger for linking, although we don't depend on the file. + -- This is due to the boot file. import Control.Applicative ( (<|>) ) import Data.Aeson diff --git a/lib/GHCup/Types/Optics.hs b/lib/GHCup/Types/Optics.hs index 3d6f3c2..f6887b2 100644 --- a/lib/GHCup/Types/Optics.hs +++ b/lib/GHCup/Types/Optics.hs @@ -23,12 +23,9 @@ import GHCup.Types import Control.Monad.Reader import Data.ByteString ( ByteString ) -import Data.Text ( Text ) import Optics import URI.ByteString -import System.Console.Pretty -import qualified Data.Text as T makePrisms ''Tool makePrisms ''Architecture @@ -117,81 +114,6 @@ getDirs :: ( MonadReader env m getDirs = gets @"dirs" -logInfo :: ( MonadReader env m - , LabelOptic' "loggerConfig" A_Lens env LoggerConfig - , MonadIO m - ) - => Text - -> m () -logInfo = logInternal Info - -logWarn :: ( MonadReader env m - , LabelOptic' "loggerConfig" A_Lens env LoggerConfig - , MonadIO m - ) - => Text - -> m () -logWarn = logInternal Warn - -logDebug :: ( MonadReader env m - , LabelOptic' "loggerConfig" A_Lens env LoggerConfig - , MonadIO m - ) - => Text - -> m () -logDebug = logInternal Debug - -logError :: ( MonadReader env m - , LabelOptic' "loggerConfig" A_Lens env LoggerConfig - , MonadIO m - ) - => Text - -> m () -logError = logInternal Error - - -logInternal :: ( MonadReader env m - , LabelOptic' "loggerConfig" A_Lens env LoggerConfig - , MonadIO m - ) => LogLevel - -> Text - -> m () -logInternal logLevel msg = do - LoggerConfig {..} <- gets @"loggerConfig" - let color' c = if fancyColors then color c else id - let style' = case logLevel of - Debug -> style Bold . color' Blue - Info -> style Bold . color' Green - Warn -> style Bold . color' Yellow - Error -> style Bold . color' Red - let l = case logLevel of - Debug -> style' "[ Debug ]" - Info -> style' "[ Info ]" - Warn -> style' "[ Warn ]" - Error -> style' "[ Error ]" - let strs = T.split (== '\n') msg - let out = case strs of - [] -> T.empty - (x:xs) -> - foldr (\a b -> a <> "\n" <> b) mempty - . ((l <> " " <> x) :) - . fmap (\line' -> style' "[ ... ] " <> line' ) - $ xs - - when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug))) - $ liftIO $ consoleOutter out - - -- raw output - let lr = case logLevel of - Debug -> "Debug:" - Info -> "Info:" - Warn -> "Warn:" - Error -> "Error:" - let outr = lr <> " " <> msg <> "\n" - liftIO $ fileOutter outr - - - getLogCleanup :: ( MonadReader env m , LabelOptic' "logCleanup" A_Lens env (IO ()) ) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 6546e5d..4b11bab 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -35,6 +35,7 @@ import GHCup.Types.Optics import GHCup.Types.JSON ( ) import GHCup.Utils.Dirs import GHCup.Utils.File +import GHCup.Utils.Logger import GHCup.Utils.MegaParsec import GHCup.Utils.Prelude import GHCup.Utils.String.QQ diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index d5f04f1..a22bd73 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -38,6 +38,7 @@ import GHCup.Types import GHCup.Types.JSON ( ) import GHCup.Types.Optics import GHCup.Utils.MegaParsec +import GHCup.Utils.Logger import GHCup.Utils.Prelude import Control.Exception.Safe diff --git a/lib/GHCup/Utils/File/Common.hs-boot b/lib/GHCup/Utils/File/Common.hs-boot new file mode 100644 index 0000000..5933883 --- /dev/null +++ b/lib/GHCup/Utils/File/Common.hs-boot @@ -0,0 +1,5 @@ +module GHCup.Utils.File.Common where + +import Text.Regex.Posix + +findFiles :: FilePath -> Regex -> IO [FilePath] diff --git a/lib/GHCup/Utils/File/Posix.hs b/lib/GHCup/Utils/File/Posix.hs index 441b442..a30397e 100644 --- a/lib/GHCup/Utils/File/Posix.hs +++ b/lib/GHCup/Utils/File/Posix.hs @@ -17,6 +17,7 @@ module GHCup.Utils.File.Posix where import GHCup.Utils.File.Common import GHCup.Utils.Prelude +import GHCup.Utils.Logger import GHCup.Types import GHCup.Types.Optics diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Utils/Logger.hs index 3d56c22..980485a 100644 --- a/lib/GHCup/Utils/Logger.hs +++ b/lib/GHCup/Utils/Logger.hs @@ -1,5 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} {-| Module : GHCup.Utils.Logger @@ -16,21 +18,97 @@ module GHCup.Utils.Logger where import GHCup.Types import GHCup.Types.Optics -import GHCup.Utils.File +import {-# SOURCE #-} GHCup.Utils.File.Common import GHCup.Utils.String.QQ import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader +import Data.Text ( Text ) +import Optics import Prelude hiding ( appendFile ) +import System.Console.Pretty import System.FilePath import System.IO.Error import Text.Regex.Posix import qualified Data.ByteString as B import GHCup.Utils.Prelude +import qualified Data.Text as T +logInfo :: ( MonadReader env m + , LabelOptic' "loggerConfig" A_Lens env LoggerConfig + , MonadIO m + ) + => Text + -> m () +logInfo = logInternal Info + +logWarn :: ( MonadReader env m + , LabelOptic' "loggerConfig" A_Lens env LoggerConfig + , MonadIO m + ) + => Text + -> m () +logWarn = logInternal Warn + +logDebug :: ( MonadReader env m + , LabelOptic' "loggerConfig" A_Lens env LoggerConfig + , MonadIO m + ) + => Text + -> m () +logDebug = logInternal Debug + +logError :: ( MonadReader env m + , LabelOptic' "loggerConfig" A_Lens env LoggerConfig + , MonadIO m + ) + => Text + -> m () +logError = logInternal Error + + +logInternal :: ( MonadReader env m + , LabelOptic' "loggerConfig" A_Lens env LoggerConfig + , MonadIO m + ) => LogLevel + -> Text + -> m () +logInternal logLevel msg = do + LoggerConfig {..} <- gets @"loggerConfig" + let color' c = if fancyColors then color c else id + let style' = case logLevel of + Debug -> style Bold . color' Blue + Info -> style Bold . color' Green + Warn -> style Bold . color' Yellow + Error -> style Bold . color' Red + let l = case logLevel of + Debug -> style' "[ Debug ]" + Info -> style' "[ Info ]" + Warn -> style' "[ Warn ]" + Error -> style' "[ Error ]" + let strs = T.split (== '\n') msg + let out = case strs of + [] -> T.empty + (x:xs) -> + foldr (\a b -> a <> "\n" <> b) mempty + . ((l <> " " <> x) :) + . fmap (\line' -> style' "[ ... ] " <> line' ) + $ xs + + when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug))) + $ liftIO $ consoleOutter out + + -- raw output + let lr = case logLevel of + Debug -> "Debug:" + Info -> "Info:" + Warn -> "Warn:" + Error -> "Error:" + let outr = lr <> " " <> msg <> "\n" + liftIO $ fileOutter outr initGHCupFileLogging :: ( MonadReader env m diff --git a/lib/GHCup/Utils/Logger.hs-boot b/lib/GHCup/Utils/Logger.hs-boot new file mode 100644 index 0000000..0995e40 --- /dev/null +++ b/lib/GHCup/Utils/Logger.hs-boot @@ -0,0 +1,21 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +module GHCup.Utils.Logger where + +import GHCup.Types + +import Control.Monad.IO.Class +import Control.Monad.Reader +import Data.Text ( Text ) +import Optics + +logWarn :: ( MonadReader env m + , LabelOptic' "loggerConfig" A_Lens env LoggerConfig + , MonadIO m + ) + => Text + -> m () + diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index be5e51f..ee06c0d 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -23,6 +23,7 @@ module GHCup.Utils.Prelude where import GHCup.Types #endif import GHCup.Types.Optics +import {-# SOURCE #-} GHCup.Utils.Logger import Control.Applicative import Control.Exception.Safe