{-# LANGUAGE TypeFamilies #-}

{- |
Module                  : Toml.Type.Printer
Copyright               : (c) 2018-2022 Kowainik
SPDX-License-Identifier : MPL-2.0
Maintainer              : Kowainik <xrom.xkov@gmail.com>
Stability               : Stable
Portability             : Portable

Contains functions for pretty printing @toml@ types.

@since 0.0.0
-}

module Toml.Type.Printer
       ( PrintOptions(..)
       , Lines(..)
       , defaultOptions
       , pretty
       , prettyOptions
       , prettyKey
       ) where

import GHC.Exts (sortWith)
import Data.Bifunctor (first)
import Data.Char (isAscii, ord)
import Data.Coerce (coerce)
import Data.Function (on)
import Data.HashMap.Strict (HashMap)
import Data.List (sortBy, foldl')
import Data.List.NonEmpty (NonEmpty)
import Data.Semigroup (stimes)
import Data.Text (Text)
import Data.Time (ZonedTime, defaultTimeLocale, formatTime)

import Text.Printf (printf)

import Toml.Type.AnyValue (AnyValue (..))
import Toml.Type.Key (Key (..), Piece (..))
import Toml.Type.PrefixTree (PrefixMap, PrefixTree (..))
import Toml.Type.TOML (TOML (..))
import Toml.Type.Value (Value (..))

import qualified Data.HashMap.Strict as HashMap
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Text as Text



{- | Configures the pretty printer.

@since 0.5.0
-}
data PrintOptions = PrintOptions
    { {- | How table keys should be sorted, if at all.

      @since 1.1.0.0
      -}
      PrintOptions -> Maybe (Key -> Key -> Ordering)
printOptionsSorting :: !(Maybe (Key -> Key -> Ordering))

      {- | Number of spaces by which to indent.

      @since 1.1.0.0
      -}
    , PrintOptions -> Int
printOptionsIndent  :: !Int
    {- | How to print Array.
      OneLine:

      @
      foo = [a, b]
      @

      MultiLine:

      @
      foo =
          [ a
          , b
          ]
      @

      Default is 'OneLine'.
    -}
    , PrintOptions -> Lines
printOptionsLines :: !Lines
    }

{- | Default printing options.

1. Sorts all keys and tables by name.
2. Indents with 2 spaces.

@since 0.5.0
-}
defaultOptions :: PrintOptions
defaultOptions :: PrintOptions
defaultOptions = Maybe (Key -> Key -> Ordering) -> Int -> Lines -> PrintOptions
PrintOptions (forall a. a -> Maybe a
Just forall a. Ord a => a -> a -> Ordering
compare) Int
2 Lines
OneLine

data Lines = OneLine | MultiLine

{- | Converts 'TOML' type into 'Data.Text.Text' (using 'defaultOptions').

For example, this

@
TOML
    { tomlPairs  = HashMap.fromList
          [("title", AnyValue $ Text "TOML example")]
    , tomlTables = PrefixTree.fromList
          [( "example" <| "owner"
           , mempty
                 { tomlPairs  = HashMap.fromList
                       [("name", AnyValue $ Text "Kowainik")]
                 }
           )]
    , tomlTableArrays = mempty
    }
@

will be translated to this

@
title = "TOML Example"

[example.owner]
  name = \"Kowainik\"
@

@since 0.0.0
-}
pretty :: TOML -> Text
pretty :: TOML -> Text
pretty = PrintOptions -> TOML -> Text
prettyOptions PrintOptions
defaultOptions

{- | Converts 'TOML' type into 'Data.Text.Text' using provided 'PrintOptions'

@since 0.5.0
-}
prettyOptions :: PrintOptions -> TOML -> Text
prettyOptions :: PrintOptions -> TOML -> Text
prettyOptions PrintOptions
options = [Text] -> Text
Text.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrintOptions -> Int -> Text -> TOML -> [Text]
prettyTomlInd PrintOptions
options Int
0 Text
""

-- | Converts 'TOML' into a list of 'Data.Text.Text' elements with the given indent.
prettyTomlInd :: PrintOptions -- ^ Printing options
              -> Int          -- ^ Current indentation
              -> Text         -- ^ Accumulator for table names
              -> TOML         -- ^ Given 'TOML'
              -> [Text]       -- ^ Pretty result
prettyTomlInd :: PrintOptions -> Int -> Text -> TOML -> [Text]
prettyTomlInd PrintOptions
options Int
i Text
prefix TOML{HashMap Key (NonEmpty TOML)
HashMap Key AnyValue
PrefixMap TOML
tomlTableArrays :: TOML -> HashMap Key (NonEmpty TOML)
tomlTables :: TOML -> PrefixMap TOML
tomlPairs :: TOML -> HashMap Key AnyValue
tomlTableArrays :: HashMap Key (NonEmpty TOML)
tomlTables :: PrefixMap TOML
tomlPairs :: HashMap Key AnyValue
..} = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ PrintOptions -> Int -> HashMap Key AnyValue -> [Text]
prettyKeyValue    PrintOptions
options Int
i HashMap Key AnyValue
tomlPairs
    , PrintOptions -> Int -> Text -> PrefixMap TOML -> [Text]
prettyTables      PrintOptions
options Int
i Text
prefix PrefixMap TOML
tomlTables
    , PrintOptions
-> Int -> Text -> HashMap Key (NonEmpty TOML) -> [Text]
prettyTableArrays PrintOptions
options Int
i Text
prefix HashMap Key (NonEmpty TOML)
tomlTableArrays
    ]

{- | Converts a key to text

@since 0.0.0
-}
prettyKey :: Key -> Text
prettyKey :: Key -> Text
prettyKey = Text -> [Text] -> Text
Text.intercalate Text
"." forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NonEmpty.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce
{-# INLINE prettyKey #-}

-- | Returns pretty formatted  key-value pairs of the 'TOML'.
prettyKeyValue :: PrintOptions -> Int -> HashMap Key AnyValue -> [Text]
prettyKeyValue :: PrintOptions -> Int -> HashMap Key AnyValue -> [Text]
prettyKeyValue PrintOptions
options Int
i = forall v t. ((Key, v) -> [t]) -> PrintOptions -> [(Key, v)] -> [t]
mapOrdered (\(Key, AnyValue)
kv -> [(Key, AnyValue) -> Text
kvText (Key, AnyValue)
kv]) PrintOptions
options forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. HashMap k v -> [(k, v)]
HashMap.toList
  where
    kvText :: (Key, AnyValue) -> Text
    kvText :: (Key, AnyValue) -> Text
kvText (Key
k, AnyValue Value t
v) =
      PrintOptions -> Int -> Text
tabWith PrintOptions
options Int
i forall a. Semigroup a => a -> a -> a
<> Key -> Text
prettyKey Key
k forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> forall (t :: TValue). Value t -> Text
valText Value t
v

    valText :: Value t -> Text
    valText :: forall (t :: TValue). Value t -> Text
valText (Bool Bool
b)    = Text -> Text
Text.toLower forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Text
showText Bool
b
    valText (Integer Integer
n) = forall a. Show a => a -> Text
showText Integer
n
    valText (Double Double
d)  = Double -> Text
showDouble Double
d
    valText (Text Text
s)    = Text -> Text
showTextUnicode Text
s
    valText (Zoned ZonedTime
z)   = ZonedTime -> Text
showZonedTime ZonedTime
z
    valText (Local LocalTime
l)   = forall a. Show a => a -> Text
showText LocalTime
l
    valText (Day Day
d)     = forall a. Show a => a -> Text
showText Day
d
    valText (Hours TimeOfDay
h)   = forall a. Show a => a -> Text
showText TimeOfDay
h
    valText (Array [Value t]
a)   = forall (t :: TValue).
PrintOptions -> (Value t -> Text) -> [Value t] -> Text
withLines PrintOptions
options forall (t :: TValue). Value t -> Text
valText [Value t]
a

    showText :: Show a => a -> Text
    showText :: forall a. Show a => a -> Text
showText = String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show


    -- | Function encodes all non-ascii characters in TOML defined form using the isAscii function
    showTextUnicode :: Text -> Text
    showTextUnicode :: Text -> Text
showTextUnicode Text
text = String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show String
finalText
      where
        xss :: String
xss = Text -> String
Text.unpack Text
text
        finalText :: String
finalText = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\String
acc (Char
ch, Bool
asciiCh) -> String
acc forall a. [a] -> [a] -> [a]
++ Char -> Bool -> String
getCh Char
ch Bool
asciiCh) String
"" [(Char, Bool)]
asciiArr

        asciiArr :: [(Char, Bool)]
asciiArr = forall a b. [a] -> [b] -> [(a, b)]
zip String
xss forall a b. (a -> b) -> a -> b
$ String -> [Bool]
asciiStatus String
xss

        getCh :: Char -> Bool -> String
        getCh :: Char -> Bool -> String
getCh Char
ch Bool
True  = [Char
ch] -- it is true ascii character
        getCh Char
ch Bool
False = forall r. PrintfType r => String -> r
printf String
"\\U%08x" (Char -> Int
ord Char
ch) :: String -- it is not true ascii character, it must be encoded

        asciiStatus :: String -> [Bool]
        asciiStatus :: String -> [Bool]
asciiStatus = forall a b. (a -> b) -> [a] -> [b]
map Char -> Bool
isAscii

    showDouble :: Double -> Text
    showDouble :: Double -> Text
showDouble Double
d | forall a. RealFloat a => a -> Bool
isInfinite Double
d Bool -> Bool -> Bool
&& Double
d forall a. Ord a => a -> a -> Bool
< Double
0 = Text
"-inf"
                 | forall a. RealFloat a => a -> Bool
isInfinite Double
d = Text
"inf"
                 | forall a. RealFloat a => a -> Bool
isNaN Double
d = Text
"nan"
                 | Bool
otherwise = forall a. Show a => a -> Text
showText Double
d

    showZonedTime :: ZonedTime -> Text
    showZonedTime :: ZonedTime -> Text
showZonedTime ZonedTime
t = String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ ZonedTime -> String
showZonedDateTime ZonedTime
t forall a. Semigroup a => a -> a -> a
<> ZonedTime -> String
showZonedZone ZonedTime
t
      where
        showZonedDateTime :: ZonedTime -> String
showZonedDateTime = forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%FT%T%Q"
        showZonedZone :: ZonedTime -> String
showZonedZone
            = (\(String
x,String
y) -> String
x forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ String
y)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\String
z -> forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
z forall a. Num a => a -> a -> a
- Int
2) String
z)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%z"

-- | Returns pretty formatted tables section of the 'TOML'.
prettyTables :: PrintOptions -> Int -> Text -> PrefixMap TOML -> [Text]
prettyTables :: PrintOptions -> Int -> Text -> PrefixMap TOML -> [Text]
prettyTables PrintOptions
options Int
i Text
pref PrefixMap TOML
asPieces = forall v t. ((Key, v) -> [t]) -> PrintOptions -> [(Key, v)] -> [t]
mapOrdered (PrefixTree TOML -> [Text]
prettyTable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) PrintOptions
options [(Key, PrefixTree TOML)]
asKeys
  where
    asKeys :: [(Key, PrefixTree TOML)]
    asKeys :: [(Key, PrefixTree TOML)]
asKeys = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Piece -> Key
pieceToKey) forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [(k, v)]
HashMap.toList PrefixMap TOML
asPieces

    pieceToKey :: Piece -> Key
    pieceToKey :: Piece -> Key
pieceToKey = NonEmpty Piece -> Key
Key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

    prettyTable :: PrefixTree TOML -> [Text]
    prettyTable :: PrefixTree TOML -> [Text]
prettyTable (Leaf Key
k TOML
toml) =
        let name :: Text
name = Key -> Text -> Text
addPrefix Key
k Text
pref
        -- Each "" results in an empty line, inserted above table names
        in Text
""forall a. a -> [a] -> [a]
: PrintOptions -> Int -> Text
tabWith PrintOptions
options Int
i forall a. Semigroup a => a -> a -> a
<> Text -> Text
prettyTableName Text
name forall a. a -> [a] -> [a]
:
        -- We don't want empty lines between a table name and a subtable name
             forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Text
"") (PrintOptions -> Int -> Text -> TOML -> [Text]
prettyTomlInd PrintOptions
options (Int
i forall a. Num a => a -> a -> a
+ Int
1) Text
name TOML
toml)

    prettyTable (Branch Key
k Maybe TOML
mToml PrefixMap TOML
prefMap) =
        let name :: Text
name  = Key -> Text -> Text
addPrefix Key
k Text
pref
            nextI :: Int
nextI = Int
i forall a. Num a => a -> a -> a
+ Int
1
            toml :: [Text]
toml  = case Maybe TOML
mToml of
                        Maybe TOML
Nothing -> []
                        Just TOML
t  -> PrintOptions -> Int -> Text -> TOML -> [Text]
prettyTomlInd PrintOptions
options Int
nextI Text
name TOML
t
        -- Each "" results in an empty line, inserted above table names
        in Text
""forall a. a -> [a] -> [a]
: PrintOptions -> Int -> Text
tabWith PrintOptions
options Int
i forall a. Semigroup a => a -> a -> a
<> Text -> Text
prettyTableName Text
name forall a. a -> [a] -> [a]
:
        -- We don't want empty lines between a table name and a subtable name
             forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Text
"") ([Text]
toml forall a. [a] -> [a] -> [a]
++ PrintOptions -> Int -> Text -> PrefixMap TOML -> [Text]
prettyTables PrintOptions
options Int
nextI Text
name PrefixMap TOML
prefMap)

    prettyTableName :: Text -> Text
    prettyTableName :: Text -> Text
prettyTableName Text
n = Text
"[" forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
"]"

prettyTableArrays :: PrintOptions -> Int -> Text -> HashMap Key (NonEmpty TOML) -> [Text]
prettyTableArrays :: PrintOptions
-> Int -> Text -> HashMap Key (NonEmpty TOML) -> [Text]
prettyTableArrays PrintOptions
options Int
i Text
pref = forall v t. ((Key, v) -> [t]) -> PrintOptions -> [(Key, v)] -> [t]
mapOrdered (Key, NonEmpty TOML) -> [Text]
arrText PrintOptions
options forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. HashMap k v -> [(k, v)]
HashMap.toList
  where
    arrText :: (Key, NonEmpty TOML) -> [Text]
    arrText :: (Key, NonEmpty TOML) -> [Text]
arrText (Key
k, NonEmpty TOML
ne) =
      let name :: Text
name = Key -> Text -> Text
addPrefix Key
k Text
pref
          render :: TOML -> [Text]
render TOML
toml =
            -- Each "" results in an empty line, inserted above array names
            Text
""forall a. a -> [a] -> [a]
: PrintOptions -> Int -> Text
tabWith PrintOptions
options Int
i forall a. Semigroup a => a -> a -> a
<> Text
"[[" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"]]" forall a. a -> [a] -> [a]
:
            -- We don't want empty lines between an array name and a subtable name
              forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Text
"") (PrintOptions -> Int -> Text -> TOML -> [Text]
prettyTomlInd PrintOptions
options (Int
i forall a. Num a => a -> a -> a
+ Int
1) Text
name TOML
toml)
      in forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TOML -> [Text]
render forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty TOML
ne

-----------------------------------------------------
-- Helper functions
-----------------------------------------------------

-- Returns an indentation prefix
tabWith :: PrintOptions -> Int -> Text
tabWith :: PrintOptions -> Int -> Text
tabWith PrintOptions{Int
Maybe (Key -> Key -> Ordering)
Lines
printOptionsLines :: Lines
printOptionsIndent :: Int
printOptionsSorting :: Maybe (Key -> Key -> Ordering)
printOptionsLines :: PrintOptions -> Lines
printOptionsIndent :: PrintOptions -> Int
printOptionsSorting :: PrintOptions -> Maybe (Key -> Key -> Ordering)
..} Int
n = Int -> Text -> Text
Text.replicate (Int
n forall a. Num a => a -> a -> a
* Int
printOptionsIndent) Text
" "

-- Returns a proper sorting function
mapOrdered :: ((Key, v) -> [t]) -> PrintOptions -> [(Key, v)] -> [t]
mapOrdered :: forall v t. ((Key, v) -> [t]) -> PrintOptions -> [(Key, v)] -> [t]
mapOrdered (Key, v) -> [t]
f PrintOptions
options = case PrintOptions -> Maybe (Key -> Key -> Ordering)
printOptionsSorting PrintOptions
options of
    Just Key -> Key -> Ordering
sorter -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Key, v) -> [t]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Key -> Key -> Ordering
sorter forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst)
    Maybe (Key -> Key -> Ordering)
Nothing     -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Key, v) -> [t]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith forall a b. (a, b) -> a
fst

-- Adds next part of the table name to the accumulator.
addPrefix :: Key -> Text -> Text
addPrefix :: Key -> Text -> Text
addPrefix Key
key = \case
    Text
"" -> Key -> Text
prettyKey Key
key
    Text
prefix -> Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> Key -> Text
prettyKey Key
key

withLines :: PrintOptions -> (Value t -> Text) -> [Value t] -> Text
withLines :: forall (t :: TValue).
PrintOptions -> (Value t -> Text) -> [Value t] -> Text
withLines PrintOptions{Int
Maybe (Key -> Key -> Ordering)
Lines
printOptionsLines :: Lines
printOptionsIndent :: Int
printOptionsSorting :: Maybe (Key -> Key -> Ordering)
printOptionsLines :: PrintOptions -> Lines
printOptionsIndent :: PrintOptions -> Int
printOptionsSorting :: PrintOptions -> Maybe (Key -> Key -> Ordering)
..} Value t -> Text
valTxt [Value t]
a = case Lines
printOptionsLines of
    Lines
OneLine -> Text
"[" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map Value t -> Text
valTxt [Value t]
a) forall a. Semigroup a => a -> a -> a
<> Text
"]"
    Lines
MultiLine -> Text
off forall a. Semigroup a => a -> a -> a
<> Text
"[ " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate (Text
off forall a. Semigroup a => a -> a -> a
<> Text
", ") (forall a b. (a -> b) -> [a] -> [b]
map Value t -> Text
valTxt [Value t]
a) forall a. Semigroup a => a -> a -> a
<> Text
off forall a. Semigroup a => a -> a -> a
<> Text
"]"
  where
    off :: Text
    off :: Text
off = Text
"\n" forall a. Semigroup a => a -> a -> a
<> forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes Int
printOptionsIndent Text
" "