{-|
Module      : Toml.Semantics.Ordered
Description : Tool for extracting an ordering from an existing TOML file
Copyright   : (c) Eric Mertens, 2023
License     : ISC
Maintainer  : emertens@gmail.com

This module can help build a key ordering projection given an existing
TOML file. This could be useful for applying a transformation to a TOML
file before pretty-printing it back in something very close to the
original order.

When using the computed order, table keys will be remembered in the order
they appeared in the source file. Any key additional keys added to the
tables will be ordered alphabetically after all the known keys.

@
demo =
 do txt <- 'readFile' \"demo.toml\"
    let Right exprs = 'Toml.Parser.parseRawToml' txt
        to          = 'extractTableOrder' exprs
        Right toml  = 'Toml.Semantics.semantics' exprs
        projection  = 'projectKey' to
    'print' ('Toml.Pretty.prettyTomlOrdered' projection toml)
@

-}
module Toml.Semantics.Ordered (
    TableOrder,
    extractTableOrder,
    projectKey,
    ProjectedKey,
    debugTableOrder,
    ) where

import Data.Foldable (foldl', toList)
import Data.List (sortOn)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Text (Text)
import Data.Text qualified as Text
import Toml.Syntax.Types (Expr(..), Key, Val(ValTable, ValArray))

-- | Summary of the order of the keys in a TOML document.
newtype TableOrder = TO (Map Text KeyOrder)

-- | Internal type used by 'TableOrder'
--
-- The 'Int' field determines the order of the current key and the
-- 'TableOrder' determines the order of the children of this key.
data KeyOrder = KeyOrder !Int TableOrder

-- | Opaque type used by 'projectKey'
newtype ProjectedKey = PK (Either Int Text)
    deriving (ProjectedKey -> ProjectedKey -> Bool
(ProjectedKey -> ProjectedKey -> Bool)
-> (ProjectedKey -> ProjectedKey -> Bool) -> Eq ProjectedKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProjectedKey -> ProjectedKey -> Bool
== :: ProjectedKey -> ProjectedKey -> Bool
$c/= :: ProjectedKey -> ProjectedKey -> Bool
/= :: ProjectedKey -> ProjectedKey -> Bool
Eq, Eq ProjectedKey
Eq ProjectedKey =>
(ProjectedKey -> ProjectedKey -> Ordering)
-> (ProjectedKey -> ProjectedKey -> Bool)
-> (ProjectedKey -> ProjectedKey -> Bool)
-> (ProjectedKey -> ProjectedKey -> Bool)
-> (ProjectedKey -> ProjectedKey -> Bool)
-> (ProjectedKey -> ProjectedKey -> ProjectedKey)
-> (ProjectedKey -> ProjectedKey -> ProjectedKey)
-> Ord ProjectedKey
ProjectedKey -> ProjectedKey -> Bool
ProjectedKey -> ProjectedKey -> Ordering
ProjectedKey -> ProjectedKey -> ProjectedKey
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ProjectedKey -> ProjectedKey -> Ordering
compare :: ProjectedKey -> ProjectedKey -> Ordering
$c< :: ProjectedKey -> ProjectedKey -> Bool
< :: ProjectedKey -> ProjectedKey -> Bool
$c<= :: ProjectedKey -> ProjectedKey -> Bool
<= :: ProjectedKey -> ProjectedKey -> Bool
$c> :: ProjectedKey -> ProjectedKey -> Bool
> :: ProjectedKey -> ProjectedKey -> Bool
$c>= :: ProjectedKey -> ProjectedKey -> Bool
>= :: ProjectedKey -> ProjectedKey -> Bool
$cmax :: ProjectedKey -> ProjectedKey -> ProjectedKey
max :: ProjectedKey -> ProjectedKey -> ProjectedKey
$cmin :: ProjectedKey -> ProjectedKey -> ProjectedKey
min :: ProjectedKey -> ProjectedKey -> ProjectedKey
Ord)

-- | Generate a projection function for use with 'Toml.Pretty.prettyTomlOrdered'
projectKey ::
    TableOrder   {- ^ table order                           -} ->
    [Text]       {- ^ table path                            -} ->
    Text         {- ^ key                                   -} ->
    ProjectedKey {- ^ type suitable for ordering table keys -}
projectKey :: TableOrder -> [Text] -> Text -> ProjectedKey
projectKey (TO Map Text KeyOrder
to) [] = \Text
k ->
    case Text -> Map Text KeyOrder -> Maybe KeyOrder
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
k Map Text KeyOrder
to of
        Just (KeyOrder Int
i TableOrder
_)     -> Either Int Text -> ProjectedKey
PK (Int -> Either Int Text
forall a b. a -> Either a b
Left Int
i)
        Maybe KeyOrder
Nothing                 -> Either Int Text -> ProjectedKey
PK (Text -> Either Int Text
forall a b. b -> Either a b
Right Text
k)
projectKey (TO Map Text KeyOrder
to) (Text
p:[Text]
ps) =
    case Text -> Map Text KeyOrder -> Maybe KeyOrder
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
p Map Text KeyOrder
to of
        Just (KeyOrder Int
_ TableOrder
to')   -> TableOrder -> [Text] -> Text -> ProjectedKey
projectKey TableOrder
to' [Text]
ps
        Maybe KeyOrder
Nothing                 -> Either Int Text -> ProjectedKey
PK (Either Int Text -> ProjectedKey)
-> (Text -> Either Int Text) -> Text -> ProjectedKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Int Text
forall a b. b -> Either a b
Right

emptyOrder :: TableOrder
emptyOrder :: TableOrder
emptyOrder = Map Text KeyOrder -> TableOrder
TO Map Text KeyOrder
forall k a. Map k a
Map.empty

-- | Extract a 'TableOrder' from the output of 'Toml.Parser.parseRawToml'
-- to be later used with 'projectKey'.
extractTableOrder :: [Expr a] -> TableOrder
extractTableOrder :: forall a. [Expr a] -> TableOrder
extractTableOrder = ([Text], TableOrder) -> TableOrder
forall a b. (a, b) -> b
snd (([Text], TableOrder) -> TableOrder)
-> ([Expr a] -> ([Text], TableOrder)) -> [Expr a] -> TableOrder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Text], TableOrder) -> Expr a -> ([Text], TableOrder))
-> ([Text], TableOrder) -> [Expr a] -> ([Text], TableOrder)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([Text], TableOrder) -> Expr a -> ([Text], TableOrder)
forall a. ([Text], TableOrder) -> Expr a -> ([Text], TableOrder)
addExpr ([], TableOrder
emptyOrder)

addExpr :: ([Text], TableOrder) -> Expr a -> ([Text], TableOrder)
addExpr :: forall a. ([Text], TableOrder) -> Expr a -> ([Text], TableOrder)
addExpr ([Text]
prefix, TableOrder
to) = \case
    TableExpr Key a
k      -> let k' :: [Text]
k' = Key a -> [Text]
forall a. Key a -> [Text]
keyPath Key a
k in ([Text]
k', TableOrder -> [Text] -> TableOrder
addKey TableOrder
to [Text]
k')
    ArrayTableExpr Key a
k -> let k' :: [Text]
k' = Key a -> [Text]
forall a. Key a -> [Text]
keyPath Key a
k in ([Text]
k', TableOrder -> [Text] -> TableOrder
addKey TableOrder
to [Text]
k')
    KeyValExpr Key a
k Val a
v   -> ([Text]
prefix, [Text] -> TableOrder -> Val a -> TableOrder
forall a. [Text] -> TableOrder -> Val a -> TableOrder
addVal [Text]
prefix (TableOrder -> [Text] -> TableOrder
addKey TableOrder
to ([Text]
prefix [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Key a -> [Text]
forall a. Key a -> [Text]
keyPath Key a
k)) Val a
v)

addVal :: [Text] -> TableOrder -> Val a -> TableOrder
addVal :: forall a. [Text] -> TableOrder -> Val a -> TableOrder
addVal [Text]
prefix TableOrder
to Val a
lval =
    case Val a
lval of
        ValArray a
_ [Val a]
xs -> (TableOrder -> Val a -> TableOrder)
-> TableOrder -> [Val a] -> TableOrder
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([Text] -> TableOrder -> Val a -> TableOrder
forall a. [Text] -> TableOrder -> Val a -> TableOrder
addVal [Text]
prefix) TableOrder
to [Val a]
xs
        ValTable a
_ [(Key a, Val a)]
kvs ->
            (TableOrder -> (Key a, Val a) -> TableOrder)
-> TableOrder -> [(Key a, Val a)] -> TableOrder
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\TableOrder
acc (Key a
k,Val a
v) ->
                let k' :: [Text]
k' = [Text]
prefix [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Key a -> [Text]
forall a. Key a -> [Text]
keyPath Key a
k in
                [Text] -> TableOrder -> Val a -> TableOrder
forall a. [Text] -> TableOrder -> Val a -> TableOrder
addVal [Text]
k' (TableOrder -> [Text] -> TableOrder
addKey TableOrder
acc [Text]
k') Val a
v) TableOrder
to [(Key a, Val a)]
kvs
        Val a
_ -> TableOrder
to

addKey :: TableOrder -> [Text] -> TableOrder
addKey :: TableOrder -> [Text] -> TableOrder
addKey TableOrder
to [] = TableOrder
to
addKey (TO Map Text KeyOrder
to) (Text
x:[Text]
xs) = Map Text KeyOrder -> TableOrder
TO ((Maybe KeyOrder -> Maybe KeyOrder)
-> Text -> Map Text KeyOrder -> Map Text KeyOrder
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe KeyOrder -> Maybe KeyOrder
f Text
x Map Text KeyOrder
to)
    where
        f :: Maybe KeyOrder -> Maybe KeyOrder
f Maybe KeyOrder
Nothing = KeyOrder -> Maybe KeyOrder
forall a. a -> Maybe a
Just (Int -> TableOrder -> KeyOrder
KeyOrder (Map Text KeyOrder -> Int
forall k a. Map k a -> Int
Map.size Map Text KeyOrder
to) (TableOrder -> [Text] -> TableOrder
addKey TableOrder
emptyOrder [Text]
xs))
        f (Just (KeyOrder Int
i TableOrder
m)) = KeyOrder -> Maybe KeyOrder
forall a. a -> Maybe a
Just (Int -> TableOrder -> KeyOrder
KeyOrder Int
i (TableOrder -> [Text] -> TableOrder
addKey TableOrder
m [Text]
xs))

keyPath :: Key a -> [Text]
keyPath :: forall a. Key a -> [Text]
keyPath = ((a, Text) -> Text) -> [(a, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (a, Text) -> Text
forall a b. (a, b) -> b
snd ([(a, Text)] -> [Text])
-> (Key a -> [(a, Text)]) -> Key a -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key a -> [(a, Text)]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

-- | Render a white-space nested representation of the key ordering extracted
-- by 'extractTableOrder'. This is provided for debugging and understandability.
debugTableOrder :: TableOrder -> String
debugTableOrder :: TableOrder -> String
debugTableOrder TableOrder
to = [String] -> String
unlines (Int -> TableOrder -> [String] -> [String]
go Int
0 TableOrder
to [])
    where
        go :: Int -> TableOrder -> [String] -> [String]
go Int
i (TO Map Text KeyOrder
m) [String]
z =
            ((Text, KeyOrder) -> [String] -> [String])
-> [String] -> [(Text, KeyOrder)] -> [String]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int -> (Text, KeyOrder) -> [String] -> [String]
go1 Int
i) [String]
z
                (((Text, KeyOrder) -> Int)
-> [(Text, KeyOrder)] -> [(Text, KeyOrder)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Text, KeyOrder) -> Int
forall {a}. (a, KeyOrder) -> Int
p (Map Text KeyOrder -> [(Text, KeyOrder)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map Text KeyOrder
m))

        go1 :: Int -> (Text, KeyOrder) -> [String] -> [String]
go1 Int
i (Text
k, KeyOrder Int
_ TableOrder
v) [String]
z =
            (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
4Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
i) Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
k) String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
            Int -> TableOrder -> [String] -> [String]
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) TableOrder
v [String]
z

        p :: (a, KeyOrder) -> Int
p (a
_, KeyOrder Int
i TableOrder
_) = Int
i