{-|
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)
@

@since 1.3.1.0

-}
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 Toml.Located (Located(locThing))
import Toml.Parser.Types (Expr(..), Key, Val(ValTable, ValArray))

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

data KeyOrder = KeyOrder !Int TableOrder

newtype ProjectedKey = PK (Either Int String)
    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 -} ->
    [String] {- ^ table path -} ->
    String {- ^ key -} ->
    ProjectedKey {- ^ type suitable for ordering table keys -}
projectKey :: TableOrder -> [String] -> String -> ProjectedKey
projectKey (TO Map String KeyOrder
to) [] = \String
k ->
    case String -> Map String KeyOrder -> Maybe KeyOrder
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
k Map String KeyOrder
to of
        Just (KeyOrder Int
i TableOrder
_)     -> Either Int String -> ProjectedKey
PK (Int -> Either Int String
forall a b. a -> Either a b
Left Int
i)
        Maybe KeyOrder
Nothing                 -> Either Int String -> ProjectedKey
PK (String -> Either Int String
forall a b. b -> Either a b
Right String
k)
projectKey (TO Map String KeyOrder
to) (String
p:[String]
ps) =
    case String -> Map String KeyOrder -> Maybe KeyOrder
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
p Map String KeyOrder
to of
        Just (KeyOrder Int
_ TableOrder
to')   -> TableOrder -> [String] -> String -> ProjectedKey
projectKey TableOrder
to' [String]
ps
        Maybe KeyOrder
Nothing                 -> Either Int String -> ProjectedKey
PK (Either Int String -> ProjectedKey)
-> (String -> Either Int String) -> String -> ProjectedKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either Int String
forall a b. b -> Either a b
Right

emptyOrder :: TableOrder
emptyOrder :: TableOrder
emptyOrder = Map String KeyOrder -> TableOrder
TO Map String 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] -> TableOrder
extractTableOrder :: [Expr] -> TableOrder
extractTableOrder = ([String], TableOrder) -> TableOrder
forall a b. (a, b) -> b
snd (([String], TableOrder) -> TableOrder)
-> ([Expr] -> ([String], TableOrder)) -> [Expr] -> TableOrder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([String], TableOrder) -> Expr -> ([String], TableOrder))
-> ([String], TableOrder) -> [Expr] -> ([String], TableOrder)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([String], TableOrder) -> Expr -> ([String], TableOrder)
addExpr ([], TableOrder
emptyOrder)

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

addVal :: [String] -> TableOrder -> Val -> TableOrder
addVal :: [String] -> TableOrder -> Val -> TableOrder
addVal [String]
prefix TableOrder
to = \case
    ValArray [Val]
xs -> (TableOrder -> Val -> TableOrder)
-> TableOrder -> [Val] -> TableOrder
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([String] -> TableOrder -> Val -> TableOrder
addVal [String]
prefix) TableOrder
to [Val]
xs
    ValTable [(Key, Val)]
kvs -> (TableOrder -> (Key, Val) -> TableOrder)
-> TableOrder -> [(Key, Val)] -> 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
k,Val
v) ->
                              let k' :: [String]
k' = [String]
prefix [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Key -> [String]
keyPath Key
k in
                                 [String] -> TableOrder -> Val -> TableOrder
addVal [String]
k' (TableOrder -> [String] -> TableOrder
addKey TableOrder
acc [String]
k') Val
v) TableOrder
to [(Key, Val)]
kvs
    Val
_ -> TableOrder
to

addKey :: TableOrder -> [String] -> TableOrder
addKey :: TableOrder -> [String] -> TableOrder
addKey TableOrder
to [] = TableOrder
to
addKey (TO Map String KeyOrder
to) (String
x:[String]
xs) = Map String KeyOrder -> TableOrder
TO ((Maybe KeyOrder -> Maybe KeyOrder)
-> String -> Map String KeyOrder -> Map String KeyOrder
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe KeyOrder -> Maybe KeyOrder
f String
x Map String 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 String KeyOrder -> Int
forall k a. Map k a -> Int
Map.size Map String KeyOrder
to) (TableOrder -> [String] -> TableOrder
addKey TableOrder
emptyOrder [String]
xs))
        f (Just (KeyOrder Int
i TableOrder
m)) = KeyOrder -> Maybe KeyOrder
forall a. a -> Maybe a
Just (Int -> TableOrder -> KeyOrder
KeyOrder Int
i (TableOrder -> [String] -> TableOrder
addKey TableOrder
m [String]
xs))

keyPath :: Key -> [String]
keyPath :: Key -> [String]
keyPath = (Located String -> String) -> [Located String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Located String -> String
forall a. Located a -> a
locThing ([Located String] -> [String])
-> (Key -> [Located String]) -> Key -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> [Located String]
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 String KeyOrder
m) [String]
z =
            ((String, KeyOrder) -> [String] -> [String])
-> [String] -> [(String, 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 -> (String, KeyOrder) -> [String] -> [String]
go1 Int
i) [String]
z
                (((String, KeyOrder) -> Int)
-> [(String, KeyOrder)] -> [(String, KeyOrder)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (String, KeyOrder) -> Int
forall {a}. (a, KeyOrder) -> Int
p (Map String KeyOrder -> [(String, KeyOrder)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map String KeyOrder
m))

        go1 :: Int -> (String, KeyOrder) -> [String] -> [String]
go1 Int
i (String
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]
++ String
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