{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TupleSections #-}
module Toml.Codec.Combinator.Map
(
map
, tableMap
, hashMap
, tableHashMap
, intMap
, tableIntMap
) where
import Prelude hiding (map)
import Control.Applicative (empty)
import Control.Monad (forM_)
import Control.Monad.State (gets, modify)
import Data.HashMap.Strict (HashMap)
import Data.Hashable (Hashable)
import Data.IntMap.Strict (IntMap)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import Data.Traversable (for)
import Validation (Validation (..))
import Toml.Codec.BiMap (BiMap (..), TomlBiMap)
import Toml.Codec.Code (execTomlCodec)
import Toml.Codec.Combinator.Common (whenLeftBiMapError)
import Toml.Codec.Types (Codec (..), TomlCodec, TomlEnv, TomlState (..))
import Toml.Type.Key (Key, pattern (:||))
import Toml.Type.TOML (TOML (..), insertTable, insertTableArrays)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.IntMap.Strict as IntMap
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Toml.Type.PrefixTree as Prefix
map :: forall k v .
Ord k
=> TomlCodec k
-> TomlCodec v
-> Key
-> TomlCodec (Map k v)
map :: forall k v.
Ord k =>
TomlCodec k -> TomlCodec v -> Key -> TomlCodec (Map k v)
map = Map k v
-> (Map k v -> [(k, v)])
-> ([(k, v)] -> Map k v)
-> TomlCodec k
-> TomlCodec v
-> Key
-> TomlCodec (Map k v)
forall map k v.
map
-> (map -> [(k, v)])
-> ([(k, v)] -> map)
-> TomlCodec k
-> TomlCodec v
-> Key
-> TomlCodec map
internalMap Map k v
forall k a. Map k a
Map.empty Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
Map.toList [(k, v)] -> Map k v
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
tableMap
:: forall k v
. Ord k
=> TomlBiMap Key k
-> (Key -> TomlCodec v)
-> Key
-> TomlCodec (Map k v)
tableMap :: forall k v.
Ord k =>
TomlBiMap Key k
-> (Key -> TomlCodec v) -> Key -> TomlCodec (Map k v)
tableMap = Map k v
-> (Map k v -> [(k, v)])
-> ([(k, v)] -> Map k v)
-> TomlBiMap Key k
-> (Key -> TomlCodec v)
-> Key
-> TomlCodec (Map k v)
forall map k v.
map
-> (map -> [(k, v)])
-> ([(k, v)] -> map)
-> TomlBiMap Key k
-> (Key -> TomlCodec v)
-> Key
-> TomlCodec map
internalTableMap Map k v
forall k a. Map k a
Map.empty Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
Map.toList [(k, v)] -> Map k v
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
hashMap
:: forall k v
#if MIN_VERSION_hashable(1,4,0)
. (Hashable k)
#else
. (Eq k, Hashable k)
#endif
=> TomlCodec k
-> TomlCodec v
-> Key
-> TomlCodec (HashMap k v)
hashMap :: forall k v.
Hashable k =>
TomlCodec k -> TomlCodec v -> Key -> TomlCodec (HashMap k v)
hashMap = HashMap k v
-> (HashMap k v -> [(k, v)])
-> ([(k, v)] -> HashMap k v)
-> TomlCodec k
-> TomlCodec v
-> Key
-> TomlCodec (HashMap k v)
forall map k v.
map
-> (map -> [(k, v)])
-> ([(k, v)] -> map)
-> TomlCodec k
-> TomlCodec v
-> Key
-> TomlCodec map
internalMap HashMap k v
forall k v. HashMap k v
HashMap.empty HashMap k v -> [(k, v)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList [(k, v)] -> HashMap k v
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
tableHashMap
:: forall k v
#if MIN_VERSION_hashable(1,4,0)
. (Hashable k)
#else
. (Eq k, Hashable k)
#endif
=> TomlBiMap Key k
-> (Key -> TomlCodec v)
-> Key
-> TomlCodec (HashMap k v)
tableHashMap :: forall k v.
Hashable k =>
TomlBiMap Key k
-> (Key -> TomlCodec v) -> Key -> TomlCodec (HashMap k v)
tableHashMap = HashMap k v
-> (HashMap k v -> [(k, v)])
-> ([(k, v)] -> HashMap k v)
-> TomlBiMap Key k
-> (Key -> TomlCodec v)
-> Key
-> TomlCodec (HashMap k v)
forall map k v.
map
-> (map -> [(k, v)])
-> ([(k, v)] -> map)
-> TomlBiMap Key k
-> (Key -> TomlCodec v)
-> Key
-> TomlCodec map
internalTableMap HashMap k v
forall k v. HashMap k v
HashMap.empty HashMap k v -> [(k, v)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList [(k, v)] -> HashMap k v
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
intMap
:: forall v
. TomlCodec Int
-> TomlCodec v
-> Key
-> TomlCodec (IntMap v)
intMap :: forall v.
TomlCodec Int -> TomlCodec v -> Key -> TomlCodec (IntMap v)
intMap = IntMap v
-> (IntMap v -> [(Int, v)])
-> ([(Int, v)] -> IntMap v)
-> TomlCodec Int
-> TomlCodec v
-> Key
-> TomlCodec (IntMap v)
forall map k v.
map
-> (map -> [(k, v)])
-> ([(k, v)] -> map)
-> TomlCodec k
-> TomlCodec v
-> Key
-> TomlCodec map
internalMap IntMap v
forall a. IntMap a
IntMap.empty IntMap v -> [(Int, v)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList [(Int, v)] -> IntMap v
forall a. [(Int, a)] -> IntMap a
IntMap.fromList
tableIntMap
:: forall v
. TomlBiMap Key Int
-> (Key -> TomlCodec v)
-> Key
-> TomlCodec (IntMap v)
tableIntMap :: forall v.
TomlBiMap Key Int
-> (Key -> TomlCodec v) -> Key -> TomlCodec (IntMap v)
tableIntMap = IntMap v
-> (IntMap v -> [(Int, v)])
-> ([(Int, v)] -> IntMap v)
-> TomlBiMap Key Int
-> (Key -> TomlCodec v)
-> Key
-> TomlCodec (IntMap v)
forall map k v.
map
-> (map -> [(k, v)])
-> ([(k, v)] -> map)
-> TomlBiMap Key k
-> (Key -> TomlCodec v)
-> Key
-> TomlCodec map
internalTableMap IntMap v
forall a. IntMap a
IntMap.empty IntMap v -> [(Int, v)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList [(Int, v)] -> IntMap v
forall a. [(Int, a)] -> IntMap a
IntMap.fromList
internalMap :: forall map k v
. map
-> (map -> [(k, v)])
-> ([(k, v)] -> map)
-> TomlCodec k
-> TomlCodec v
-> Key
-> TomlCodec map
internalMap :: forall map k v.
map
-> (map -> [(k, v)])
-> ([(k, v)] -> map)
-> TomlCodec k
-> TomlCodec v
-> Key
-> TomlCodec map
internalMap map
emptyMap map -> [(k, v)]
toListMap [(k, v)] -> map
fromListMap TomlCodec k
keyCodec TomlCodec v
valCodec Key
key = TomlEnv map -> (map -> TomlState map) -> Codec map map
forall i o. TomlEnv o -> (i -> TomlState o) -> Codec i o
Codec TomlEnv map
input map -> TomlState map
output
where
input :: TomlEnv map
input :: TomlEnv map
input = \TOML
t -> case Key -> HashMap Key (NonEmpty TOML) -> Maybe (NonEmpty TOML)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Key
key (HashMap Key (NonEmpty TOML) -> Maybe (NonEmpty TOML))
-> HashMap Key (NonEmpty TOML) -> Maybe (NonEmpty TOML)
forall a b. (a -> b) -> a -> b
$ TOML -> HashMap Key (NonEmpty TOML)
tomlTableArrays TOML
t of
Maybe (NonEmpty TOML)
Nothing -> map -> Validation [TomlDecodeError] map
forall e a. a -> Validation e a
Success map
emptyMap
Just NonEmpty TOML
tomls -> ([(k, v)] -> map)
-> Validation [TomlDecodeError] [(k, v)]
-> Validation [TomlDecodeError] map
forall a b.
(a -> b)
-> Validation [TomlDecodeError] a -> Validation [TomlDecodeError] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(k, v)] -> map
fromListMap (Validation [TomlDecodeError] [(k, v)]
-> Validation [TomlDecodeError] map)
-> Validation [TomlDecodeError] [(k, v)]
-> Validation [TomlDecodeError] map
forall a b. (a -> b) -> a -> b
$ [TOML]
-> (TOML -> Validation [TomlDecodeError] (k, v))
-> Validation [TomlDecodeError] [(k, v)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (NonEmpty TOML -> [TOML]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty TOML
tomls) ((TOML -> Validation [TomlDecodeError] (k, v))
-> Validation [TomlDecodeError] [(k, v)])
-> (TOML -> Validation [TomlDecodeError] (k, v))
-> Validation [TomlDecodeError] [(k, v)]
forall a b. (a -> b) -> a -> b
$ \TOML
toml -> do
k
k <- TomlCodec k -> TomlEnv k
forall i o. Codec i o -> TomlEnv o
codecRead TomlCodec k
keyCodec TOML
toml
v
v <- TomlCodec v -> TomlEnv v
forall i o. Codec i o -> TomlEnv o
codecRead TomlCodec v
valCodec TOML
toml
pure (k
k, v
v)
output :: map -> TomlState map
output :: map -> TomlState map
output map
dict = do
let tomls :: [TOML]
tomls = ((k, v) -> TOML) -> [(k, v)] -> [TOML]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
(\(k
k, v
v) -> TomlCodec k -> k -> TOML
forall a. TomlCodec a -> a -> TOML
execTomlCodec TomlCodec k
keyCodec k
k TOML -> TOML -> TOML
forall a. Semigroup a => a -> a -> a
<> TomlCodec v -> v -> TOML
forall a. TomlCodec a -> a -> TOML
execTomlCodec TomlCodec v
valCodec v
v)
(map -> [(k, v)]
toListMap map
dict)
Maybe (NonEmpty TOML)
mTables <- (TOML -> Maybe (NonEmpty TOML))
-> TomlState (Maybe (NonEmpty TOML))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((TOML -> Maybe (NonEmpty TOML))
-> TomlState (Maybe (NonEmpty TOML)))
-> (TOML -> Maybe (NonEmpty TOML))
-> TomlState (Maybe (NonEmpty TOML))
forall a b. (a -> b) -> a -> b
$ Key -> HashMap Key (NonEmpty TOML) -> Maybe (NonEmpty TOML)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Key
key (HashMap Key (NonEmpty TOML) -> Maybe (NonEmpty TOML))
-> (TOML -> HashMap Key (NonEmpty TOML))
-> TOML
-> Maybe (NonEmpty TOML)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TOML -> HashMap Key (NonEmpty TOML)
tomlTableArrays
let updateAction :: TOML -> TOML
updateAction :: TOML -> TOML
updateAction = case Maybe (NonEmpty TOML)
mTables of
Maybe (NonEmpty TOML)
Nothing -> case [TOML]
tomls of
[] -> TOML -> TOML
forall a. a -> a
id
TOML
t:[TOML]
ts -> Key -> NonEmpty TOML -> TOML -> TOML
insertTableArrays Key
key (TOML
t TOML -> [TOML] -> NonEmpty TOML
forall a. a -> [a] -> NonEmpty a
:| [TOML]
ts)
Just (TOML
t :| [TOML]
ts) ->
Key -> NonEmpty TOML -> TOML -> TOML
insertTableArrays Key
key (NonEmpty TOML -> TOML -> TOML) -> NonEmpty TOML -> TOML -> TOML
forall a b. (a -> b) -> a -> b
$ TOML
t TOML -> [TOML] -> NonEmpty TOML
forall a. a -> [a] -> NonEmpty a
:| ([TOML]
ts [TOML] -> [TOML] -> [TOML]
forall a. [a] -> [a] -> [a]
++ [TOML]
tomls)
map
dict map -> TomlState () -> TomlState map
forall a b. a -> TomlState b -> TomlState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (TOML -> TOML) -> TomlState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify TOML -> TOML
updateAction
internalTableMap
:: forall map k v
. map
-> (map -> [(k, v)])
-> ([(k, v)] -> map)
-> TomlBiMap Key k
-> (Key -> TomlCodec v)
-> Key
-> TomlCodec map
internalTableMap :: forall map k v.
map
-> (map -> [(k, v)])
-> ([(k, v)] -> map)
-> TomlBiMap Key k
-> (Key -> TomlCodec v)
-> Key
-> TomlCodec map
internalTableMap map
emptyMap map -> [(k, v)]
toListMap [(k, v)] -> map
fromListMap TomlBiMap Key k
keyBiMap Key -> TomlCodec v
valCodec Key
tableName =
TomlEnv map -> (map -> TomlState map) -> Codec map map
forall i o. TomlEnv o -> (i -> TomlState o) -> Codec i o
Codec TomlEnv map
input map -> TomlState map
output
where
input :: TomlEnv map
input :: TomlEnv map
input = \TOML
t -> case Key -> PrefixMap TOML -> Maybe TOML
forall a. Key -> PrefixMap a -> Maybe a
Prefix.lookup Key
tableName (PrefixMap TOML -> Maybe TOML) -> PrefixMap TOML -> Maybe TOML
forall a b. (a -> b) -> a -> b
$ TOML -> PrefixMap TOML
tomlTables TOML
t of
Maybe TOML
Nothing -> map -> Validation [TomlDecodeError] map
forall e a. a -> Validation e a
Success map
emptyMap
Just TOML
toml ->
let valKeys :: [Key]
valKeys = HashMap Key AnyValue -> [Key]
forall k v. HashMap k v -> [k]
HashMap.keys (HashMap Key AnyValue -> [Key]) -> HashMap Key AnyValue -> [Key]
forall a b. (a -> b) -> a -> b
$ TOML -> HashMap Key AnyValue
tomlPairs TOML
toml
tableKeys :: [Key]
tableKeys = (Piece -> Key) -> [Piece] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Piece -> [Piece] -> Key
:|| []) ([Piece] -> [Key]) -> [Piece] -> [Key]
forall a b. (a -> b) -> a -> b
$ PrefixMap TOML -> [Piece]
forall k v. HashMap k v -> [k]
HashMap.keys (PrefixMap TOML -> [Piece]) -> PrefixMap TOML -> [Piece]
forall a b. (a -> b) -> a -> b
$ TOML -> PrefixMap TOML
tomlTables TOML
toml
tableArrayKey :: [Key]
tableArrayKey = HashMap Key (NonEmpty TOML) -> [Key]
forall k v. HashMap k v -> [k]
HashMap.keys (HashMap Key (NonEmpty TOML) -> [Key])
-> HashMap Key (NonEmpty TOML) -> [Key]
forall a b. (a -> b) -> a -> b
$ TOML -> HashMap Key (NonEmpty TOML)
tomlTableArrays TOML
toml
in ([(k, v)] -> map)
-> Validation [TomlDecodeError] [(k, v)]
-> Validation [TomlDecodeError] map
forall a b.
(a -> b)
-> Validation [TomlDecodeError] a -> Validation [TomlDecodeError] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(k, v)] -> map
fromListMap (Validation [TomlDecodeError] [(k, v)]
-> Validation [TomlDecodeError] map)
-> Validation [TomlDecodeError] [(k, v)]
-> Validation [TomlDecodeError] map
forall a b. (a -> b) -> a -> b
$ [Key]
-> (Key -> Validation [TomlDecodeError] (k, v))
-> Validation [TomlDecodeError] [(k, v)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([Key]
valKeys [Key] -> [Key] -> [Key]
forall a. Semigroup a => a -> a -> a
<> [Key]
tableKeys [Key] -> [Key] -> [Key]
forall a. Semigroup a => a -> a -> a
<> [Key]
tableArrayKey) ((Key -> Validation [TomlDecodeError] (k, v))
-> Validation [TomlDecodeError] [(k, v)])
-> (Key -> Validation [TomlDecodeError] (k, v))
-> Validation [TomlDecodeError] [(k, v)]
forall a b. (a -> b) -> a -> b
$ \Key
key ->
Key
-> Either TomlBiMapError k
-> (k -> Validation [TomlDecodeError] (k, v))
-> Validation [TomlDecodeError] (k, v)
forall a b.
Key
-> Either TomlBiMapError a
-> (a -> Validation [TomlDecodeError] b)
-> Validation [TomlDecodeError] b
whenLeftBiMapError Key
key (TomlBiMap Key k -> Key -> Either TomlBiMapError k
forall e a b. BiMap e a b -> a -> Either e b
forward TomlBiMap Key k
keyBiMap Key
key) ((k -> Validation [TomlDecodeError] (k, v))
-> Validation [TomlDecodeError] (k, v))
-> (k -> Validation [TomlDecodeError] (k, v))
-> Validation [TomlDecodeError] (k, v)
forall a b. (a -> b) -> a -> b
$ \k
k ->
(k
k,) (v -> (k, v))
-> Validation [TomlDecodeError] v
-> Validation [TomlDecodeError] (k, v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TomlCodec v -> TomlEnv v
forall i o. Codec i o -> TomlEnv o
codecRead (Key -> TomlCodec v
valCodec Key
key) TOML
toml
output :: map -> TomlState map
output :: map -> TomlState map
output map
m = do
Maybe TOML
mTable <- (TOML -> Maybe TOML) -> TomlState (Maybe TOML)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((TOML -> Maybe TOML) -> TomlState (Maybe TOML))
-> (TOML -> Maybe TOML) -> TomlState (Maybe TOML)
forall a b. (a -> b) -> a -> b
$ Key -> PrefixMap TOML -> Maybe TOML
forall a. Key -> PrefixMap a -> Maybe a
Prefix.lookup Key
tableName (PrefixMap TOML -> Maybe TOML)
-> (TOML -> PrefixMap TOML) -> TOML -> Maybe TOML
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TOML -> PrefixMap TOML
tomlTables
let toml :: TOML
toml = TOML -> Maybe TOML -> TOML
forall a. a -> Maybe a -> a
fromMaybe TOML
forall a. Monoid a => a
mempty Maybe TOML
mTable
let (Maybe ()
_, TOML
newToml) = TomlState () -> TOML -> (Maybe (), TOML)
forall a. TomlState a -> TOML -> (Maybe a, TOML)
unTomlState TomlState ()
updateMapTable TOML
toml
map
m map -> TomlState () -> TomlState map
forall a b. a -> TomlState b -> TomlState a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (TOML -> TOML) -> TomlState ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Key -> TOML -> TOML -> TOML
insertTable Key
tableName TOML
newToml)
where
updateMapTable :: TomlState ()
updateMapTable :: TomlState ()
updateMapTable = [(k, v)] -> ((k, v) -> TomlState v) -> TomlState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (map -> [(k, v)]
toListMap map
m) (((k, v) -> TomlState v) -> TomlState ())
-> ((k, v) -> TomlState v) -> TomlState ()
forall a b. (a -> b) -> a -> b
$ \(k
k, v
v) -> case TomlBiMap Key k -> k -> Either TomlBiMapError Key
forall e a b. BiMap e a b -> b -> Either e a
backward TomlBiMap Key k
keyBiMap k
k of
Left TomlBiMapError
_ -> TomlState v
forall a. TomlState a
forall (f :: * -> *) a. Alternative f => f a
empty
Right Key
key -> TomlCodec v -> v -> TomlState v
forall i o. Codec i o -> i -> TomlState o
codecWrite (Key -> TomlCodec v
valCodec Key
key) v
v