{-# LANGUAGE OverloadedStrings #-}
module Conftrack.Pretty (unwrapConfigResult, printConfigOrigins, printConfigWarnings, printConfigErrors, displayError) where
import Conftrack.Value (Origin(..), ConfigError (..), ConfigValue(..), Key)
import Conftrack (Warning (..), Config)
import Data.Map (Map)
import qualified Data.Map.Strict as M
import qualified Data.Text.IO as T
import qualified Data.Text as T
import GHC.Exts (groupWith)
import System.Exit (exitFailure)
import Control.Monad (when)
unwrapConfigResult
:: forall a. Config a
=> Bool
-> Either [ConfigError] (a, Map Key [Origin], [Warning])
-> IO a
unwrapConfigResult :: forall a.
Config a =>
Bool
-> Either [ConfigError] (a, Map Key [Origin], [Warning]) -> IO a
unwrapConfigResult Bool
_ (Left [ConfigError]
errors) = do
[ConfigError] -> IO ()
printConfigErrors [ConfigError]
errors
IO a
forall a. IO a
exitFailure
unwrapConfigResult Bool
verbose (Right (a
config, Map Key [Origin]
origins, [Warning]
warnings)) = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Map Key [Origin] -> IO ()
printConfigOrigins Map Key [Origin]
origins
[Warning] -> IO ()
printConfigWarnings [Warning]
warnings
a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
config
printConfigOrigins :: Map Key [Origin] -> IO ()
printConfigOrigins :: Map Key [Origin] -> IO ()
printConfigOrigins =
([(Key, [Origin])] -> IO ()) -> [[(Key, [Origin])]] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> IO ()
T.putStrLn (Text -> IO ())
-> ([(Key, [Origin])] -> Text) -> [(Key, [Origin])] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, [Origin])] -> Text
forall {a}. Show a => [(a, [Origin])] -> Text
prettyOrigin)
([[(Key, [Origin])]] -> IO ())
-> (Map Key [Origin] -> [[(Key, [Origin])]])
-> Map Key [Origin]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, [Origin]) -> Text)
-> [(Key, [Origin])] -> [[(Key, [Origin])]]
forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupWith ((\(Origin a
_ Text
s) -> Text
s) (Origin -> Text)
-> ((Key, [Origin]) -> Origin) -> (Key, [Origin]) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Origin] -> Origin
forall a. HasCallStack => [a] -> a
head ([Origin] -> Origin)
-> ((Key, [Origin]) -> [Origin]) -> (Key, [Origin]) -> Origin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, [Origin]) -> [Origin]
forall a b. (a, b) -> b
snd)
([(Key, [Origin])] -> [[(Key, [Origin])]])
-> (Map Key [Origin] -> [(Key, [Origin])])
-> Map Key [Origin]
-> [[(Key, [Origin])]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, [Origin]) -> Bool) -> [(Key, [Origin])] -> [(Key, [Origin])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Key, [Origin]) -> Bool) -> (Key, [Origin]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Origin] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Origin] -> Bool)
-> ((Key, [Origin]) -> [Origin]) -> (Key, [Origin]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, [Origin]) -> [Origin]
forall a b. (a, b) -> b
snd)
([(Key, [Origin])] -> [(Key, [Origin])])
-> (Map Key [Origin] -> [(Key, [Origin])])
-> Map Key [Origin]
-> [(Key, [Origin])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Key [Origin] -> [(Key, [Origin])]
forall k a. Map k a -> [(k, a)]
M.toList
where prettyOrigin :: [(a, [Origin])] -> Text
prettyOrigin [(a, [Origin])]
origins =
[Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Origin] -> Text
originSource ((a, [Origin]) -> [Origin]
forall a b. (a, b) -> b
snd ([(a, [Origin])] -> (a, [Origin])
forall a. HasCallStack => [a] -> a
head [(a, [Origin])]
origins)) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ((a, [Origin]) -> Text) -> [(a, [Origin])] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, [Origin]) -> Text
forall {a}. Show a => (a, [Origin]) -> Text
prettyKey [(a, [Origin])]
origins
prettyKey :: (a, [Origin]) -> Text
prettyKey (a
key, []) = Text
"\n " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (a -> String
forall a. Show a => a -> String
show a
key)
prettyKey (a
key, (Origin a
val Text
_):[Origin]
shadowed) = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
[Text
"\n ", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
key, Text
" = ", a -> Text
forall a. ConfigValue a => a -> Text
prettyValue a
val]
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Origin -> Text) -> [Origin] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Origin a
_ Text
text) -> Text
"\n (occurrance in "Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
textText -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
" shadowed)") [Origin]
shadowed
originSource :: [Origin] -> Text
originSource [] = Text
"default value"
originSource (Origin a
_ Text
text:[Origin]
_) = Text
text
printConfigWarnings :: [Warning] -> IO ()
printConfigWarnings :: [Warning] -> IO ()
printConfigWarnings [Warning]
warnings =
Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Warnings:\n " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"\n " ((Warning -> Text) -> [Warning] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Warning Text
text) -> Text
text) [Warning]
warnings)
printConfigErrors :: [ConfigError] -> IO ()
printConfigErrors :: [ConfigError] -> IO ()
printConfigErrors [ConfigError]
errors =
Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Errors while reading configuration:\n " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"\n " ((ConfigError -> Text) -> [ConfigError] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConfigError -> Text
displayError [ConfigError]
errors)
displayError :: ConfigError -> T.Text
displayError :: ConfigError -> Text
displayError (ParseError Text
text) = Text
"Parse Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text
displayError (TypeMismatch Text
text Value
val) = Text
"Type Error: got" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Value -> String
forall a. Show a => a -> String
show Value
val) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but expected " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
displayError (NotPresent Key
key) = Text
"Required key " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Key -> String
forall a. Show a => a -> String
show Key
key) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is missing."
displayError ConfigError
Shadowed = Text
"Shadowed"