Printer.hs

{-# OPTIONS_GHC -fno-warn-deprecations #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module System.Etc.Internal.Extra.Printer (
    renderConfig
  , renderConfigColor
  , printPrettyConfig
  , hPrintPrettyConfig
  ) where

import           RIO         hiding ((<>))
import qualified RIO.HashMap as HashMap
import           RIO.List    (intersperse, maximum)
import qualified RIO.Set     as Set
import qualified RIO.Text    as Text

import qualified Data.Aeson as JSON

import Text.PrettyPrint.ANSI.Leijen

import System.Etc.Internal.Types

renderJsonValue :: Text -> Value JSON.Value -> (Doc, Int)
renderJsonValue key value' = case value' of
  Plain JSON.Null         -> (text "null", 4)

  Plain (JSON.String str) -> (text $ Text.unpack str, Text.length str)

  Plain (JSON.Number scientific) ->
    let number = show scientific in (text number, length number)
  Plain     (JSON.Bool bool') -> if bool' then (text "true", 5) else (text "false", 5)
  Sensitive _                 -> (text "<<sensitive>>", 13)
  _ ->
    value'
      & tshow
      & ("Invalid configuration value creation " `mappend`)
      & InvalidConfiguration (Just key)
      & show
      & error

data ColorFn
  = ColorFn {
    greenColor :: !(Doc -> Doc)
  , blueColor  :: !(Doc -> Doc)
  }

renderConfig' :: ColorFn -> Config -> Doc
renderConfig' ColorFn { greenColor, blueColor } (Config configValue0) =
  let
    brackets' = enclose (lbracket <> space) (space <> rbracket)

    renderSource :: Text -> ConfigSource -> ((Doc, Int), Doc)
    renderSource key source' = case source' of
      Default value' -> (renderJsonValue key value', brackets' (fill 10 (text "Default")))

      File _index filepath' value' ->
        ( renderJsonValue key value'
        , brackets' (fill 10 (text "File:" <+> text (Text.unpack filepath')))
        )

      Env varname value' ->
        ( renderJsonValue key value'
        , brackets' (fill 10 (text "Env:" <+> text (Text.unpack varname)))
        )

      Cli value' -> (renderJsonValue key value', brackets' (fill 10 (text "Cli")))

      None       -> ((mempty, 0), mempty)

    renderSources :: Text -> [ConfigSource] -> Doc
    renderSources keys sources0 =
      let
        sources@(((selValueDoc, _), selSourceDoc) : others) =
          map (renderSource keys) sources0

        fillingWidth  = sources & map (snd . fst) & maximum & max 10

        selectedValue = [greenColor $ fill fillingWidth selValueDoc <+> selSourceDoc]

        otherValues   = map
          (\((valueDoc, _), sourceDoc) -> fill fillingWidth valueDoc <+> sourceDoc)
          others
      in
        selectedValue & flip mappend otherValues & vcat & indent 2

    configEntryRenderer :: [Text] -> [Doc] -> Text -> ConfigValue -> [Doc]
    configEntryRenderer keys resultDoc configKey configValue =
      resultDoc `mappend` loop (configKey : keys) configValue

    loop keys configValue = case configValue of
      SubConfig subConfigm ->
        HashMap.foldlWithKey' (configEntryRenderer keys) mempty subConfigm

      ConfigValue sources0 ->
        let
          configKey = keys & reverse & Text.intercalate "."

          sources   = Set.toDescList sources0
        in
          if null sources
          then
            []
          else
            [blueColor (text (Text.unpack configKey)) <$$> renderSources configKey sources]
  in
    loop [] configValue0 & intersperse (linebreak <> linebreak) & hcat & (<> linebreak)


renderConfigColor :: Config -> Doc
renderConfigColor = renderConfig' ColorFn {greenColor = green, blueColor = blue}

renderConfig :: Config -> Doc
renderConfig = renderConfig' ColorFn {greenColor = id, blueColor = id}

printPrettyConfig :: Config -> IO ()
printPrettyConfig = putDoc . renderConfig

hPrintPrettyConfig :: Handle -> Config -> IO ()
hPrintPrettyConfig handle' = hPutDoc handle' . renderConfig