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))
newtype TableOrder = TO (Map String KeyOrder)
data KeyOrder = KeyOrder !Int TableOrder
newtype ProjectedKey = PK (Either Int String)
deriving (ProjectedKey -> ProjectedKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProjectedKey -> ProjectedKey -> Bool
$c/= :: ProjectedKey -> ProjectedKey -> Bool
== :: ProjectedKey -> ProjectedKey -> Bool
$c== :: ProjectedKey -> ProjectedKey -> Bool
Eq, Eq 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
min :: ProjectedKey -> ProjectedKey -> ProjectedKey
$cmin :: ProjectedKey -> ProjectedKey -> ProjectedKey
max :: ProjectedKey -> ProjectedKey -> ProjectedKey
$cmax :: ProjectedKey -> ProjectedKey -> ProjectedKey
>= :: ProjectedKey -> ProjectedKey -> Bool
$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
compare :: ProjectedKey -> ProjectedKey -> Ordering
$ccompare :: ProjectedKey -> ProjectedKey -> Ordering
Ord)
projectKey ::
TableOrder ->
[String] ->
String ->
ProjectedKey
projectKey :: TableOrder -> [String] -> String -> ProjectedKey
projectKey (TO Map String KeyOrder
to) [] = \String
k ->
case 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 (forall a b. a -> Either a b
Left Int
i)
Maybe KeyOrder
Nothing -> Either Int String -> ProjectedKey
PK (forall a b. b -> Either a b
Right String
k)
projectKey (TO Map String KeyOrder
to) (String
p:[String]
ps) =
case 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right
emptyOrder :: TableOrder
emptyOrder :: TableOrder
emptyOrder = Map String KeyOrder -> TableOrder
TO forall k a. Map k a
Map.empty
extractTableOrder :: [Expr] -> TableOrder
= forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 -> 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 -> 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 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 (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 = forall a. a -> Maybe a
Just (Int -> TableOrder -> KeyOrder
KeyOrder (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)) = 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 = forall a b. (a -> b) -> [a] -> [b]
map forall a. Located a -> a
locThing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
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 =
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int -> (String, KeyOrder) -> [String] -> [String]
go1 Int
i) [String]
z
(forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall {a}. (a, KeyOrder) -> Int
p (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 =
(forall a. Int -> a -> [a]
replicate (Int
4forall a. Num a => a -> a -> a
*Int
i) Char
' ' forall a. [a] -> [a] -> [a]
++ String
k) forall a. a -> [a] -> [a]
:
Int -> TableOrder -> [String] -> [String]
go (Int
iforall a. Num a => a -> a -> a
+Int
1) TableOrder
v [String]
z
p :: (a, KeyOrder) -> Int
p (a
_, KeyOrder Int
i TableOrder
_) = Int
i