{-# LANGUAGE TypeFamilies #-}

{- |
Copyright: (c) 2018-2020 Kowainik
SPDX-License-Identifier: MPL-2.0
Maintainer: Kowainik <xrom.xkov@gmail.com>

Contains functions for pretty printing @toml@ types.

@since 0.0.0
-}

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

import Data.Bifunctor (first)
import Data.Coerce (coerce)
import Data.Function (on)
import Data.HashMap.Strict (HashMap)
import Data.List (sortBy)
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import Data.Time (ZonedTime, defaultTimeLocale, formatTime)

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
    }

{- | 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 -> PrintOptions
PrintOptions ((Key -> Key -> Ordering) -> Maybe (Key -> Key -> Ordering)
forall a. a -> Maybe a
Just Key -> Key -> Ordering
forall a. Ord a => a -> a -> Ordering
compare) 2

{- | 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 options :: PrintOptions
options = [Text] -> Text
Text.unlines ([Text] -> Text) -> (TOML -> [Text]) -> TOML -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrintOptions -> Int -> Text -> TOML -> [Text]
prettyTomlInd PrintOptions
options 0 ""

-- | 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 options :: PrintOptions
options i :: Int
i prefix :: Text
prefix TOML{..} = [[Text]] -> [Text]
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] -> Text) -> (Key -> [Text]) -> Key -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty Text -> [Text])
-> (Key -> NonEmpty Text) -> Key -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> NonEmpty Text
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 options :: PrintOptions
options i :: Int
i = ((Key, AnyValue) -> [Text])
-> PrintOptions -> [(Key, AnyValue)] -> [Text]
forall v t. ((Key, v) -> [t]) -> PrintOptions -> [(Key, v)] -> [t]
mapOrdered (\kv :: (Key, AnyValue)
kv -> [(Key, AnyValue) -> Text
kvText (Key, AnyValue)
kv]) PrintOptions
options ([(Key, AnyValue)] -> [Text])
-> (HashMap Key AnyValue -> [(Key, AnyValue)])
-> HashMap Key AnyValue
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Key AnyValue -> [(Key, AnyValue)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList
  where
    kvText :: (Key, AnyValue) -> Text
    kvText :: (Key, AnyValue) -> Text
kvText (k :: Key
k, AnyValue v :: Value t
v) =
      PrintOptions -> Int -> Text
tabWith PrintOptions
options Int
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Key -> Text
prettyKey Key
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>  " = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value t -> Text
forall (t :: TValue). Value t -> Text
valText Value t
v

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

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

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

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

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

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

    prettyTable :: PrefixTree TOML -> [Text]
    prettyTable :: PrefixTree TOML -> [Text]
prettyTable (Leaf k :: Key
k toml :: 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 -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: PrintOptions -> Int -> Text
tabWith PrintOptions
options Int
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
prettyTableName Text
name Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
        -- We don't want empty lines between a table name and a subtable name
             (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "") (PrintOptions -> Int -> Text -> TOML -> [Text]
prettyTomlInd PrintOptions
options (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Text
name TOML
toml)

    prettyTable (Branch k :: Key
k mToml :: Maybe TOML
mToml prefMap :: PrefixMap TOML
prefMap) =
        let name :: Text
name  = Key -> Text -> Text
addPrefix Key
k Text
pref
            nextI :: Int
nextI = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
            toml :: [Text]
toml  = case Maybe TOML
mToml of
                        Nothing -> []
                        Just t :: 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 -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: PrintOptions -> Int -> Text
tabWith PrintOptions
options Int
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
prettyTableName Text
name Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
        -- We don't want empty lines between a table name and a subtable name
             (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "") ([Text]
toml [Text] -> [Text] -> [Text]
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 n :: Text
n = "[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "]"

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

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

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