{-# LANGUAGE OverloadedStrings #-}

-- | This module contains convenience functions to print the values returned by
-- 'Conftrack.runFetchConfig'.
--
-- These functions can be used as-is in programs using this library, or serve as
-- examples for people who wish to display the results some another way.
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)


-- | A convenience function, to be @>>=@'d with 'Conftrack.runFetchConfig'.
--
-- It prints any errors in case of failure and then aborts the program, and prints
-- any warnings (and, if the first argument is @True@, also each value's origin) and
-- returns the config in case of success.
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

-- TODO: perhaps sort it by source, not by key?
-- also, shadowed values are currently never read
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" -- Note: this branch never occurs (for now)