{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Data.ListMap (
  ListMap (..),
  foldrWithKey,
  keys,
  keysSet,
  elems,
  lookup,
  filter,
  toMap,
  fromMap,
  mapKeys,
  map,
  empty,
  fromList,
  toList,
)
where

import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), decodeMapLen, encodeMapLen)
import Control.DeepSeq (NFData, NFData1)
import Control.Monad
import Data.Aeson (
  FromJSON (..),
  FromJSON1 (..),
  FromJSONKey (..),
  FromJSONKeyFunction (..),
  ToJSON (..),
  ToJSON1 (..),
  ToJSON2 (..),
  ToJSONKey (..),
  ToJSONKeyFunction (..),
  Value (..),
 )
import qualified Data.Aeson as J
import Data.Aeson.Encoding (dict)
import qualified Data.Aeson.Encoding as E
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KM
import Data.Aeson.Types (listValue)
import Data.Bifunctor (Bifunctor (..))
import Data.Coerce (coerce)
import qualified Data.List as L
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Vector as V
import GHC.Generics (Generic, Generic1)
import NoThunks.Class (NoThunks)
import Prelude hiding (filter, lookup, map)
import qualified Prelude as Pre

-- | ListMap is a wrapper around an associative list. It is encoded in CBOR
--   and JSON as an object/map.
newtype ListMap k v = ListMap
  { forall k v. ListMap k v -> [(k, v)]
unListMap :: [(k, v)]
  }
  deriving (Int -> ListMap k v -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k v. (Show k, Show v) => Int -> ListMap k v -> ShowS
forall k v. (Show k, Show v) => [ListMap k v] -> ShowS
forall k v. (Show k, Show v) => ListMap k v -> String
showList :: [ListMap k v] -> ShowS
$cshowList :: forall k v. (Show k, Show v) => [ListMap k v] -> ShowS
show :: ListMap k v -> String
$cshow :: forall k v. (Show k, Show v) => ListMap k v -> String
showsPrec :: Int -> ListMap k v -> ShowS
$cshowsPrec :: forall k v. (Show k, Show v) => Int -> ListMap k v -> ShowS
Show, forall a. ListMap k a -> Bool
forall k a. Eq a => a -> ListMap k a -> Bool
forall k a. Num a => ListMap k a -> a
forall k a. Ord a => ListMap k a -> a
forall m a. Monoid m => (a -> m) -> ListMap k a -> m
forall k m. Monoid m => ListMap k m -> m
forall k a. ListMap k a -> Bool
forall k a. ListMap k a -> Int
forall k a. ListMap k a -> [a]
forall a b. (a -> b -> b) -> b -> ListMap k a -> b
forall k a. (a -> a -> a) -> ListMap k a -> a
forall k m a. Monoid m => (a -> m) -> ListMap k a -> m
forall k b a. (b -> a -> b) -> b -> ListMap k a -> b
forall k a b. (a -> b -> b) -> b -> ListMap k a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => ListMap k a -> a
$cproduct :: forall k a. Num a => ListMap k a -> a
sum :: forall a. Num a => ListMap k a -> a
$csum :: forall k a. Num a => ListMap k a -> a
minimum :: forall a. Ord a => ListMap k a -> a
$cminimum :: forall k a. Ord a => ListMap k a -> a
maximum :: forall a. Ord a => ListMap k a -> a
$cmaximum :: forall k a. Ord a => ListMap k a -> a
elem :: forall a. Eq a => a -> ListMap k a -> Bool
$celem :: forall k a. Eq a => a -> ListMap k a -> Bool
length :: forall a. ListMap k a -> Int
$clength :: forall k a. ListMap k a -> Int
null :: forall a. ListMap k a -> Bool
$cnull :: forall k a. ListMap k a -> Bool
toList :: forall a. ListMap k a -> [a]
$ctoList :: forall k a. ListMap k a -> [a]
foldl1 :: forall a. (a -> a -> a) -> ListMap k a -> a
$cfoldl1 :: forall k a. (a -> a -> a) -> ListMap k a -> a
foldr1 :: forall a. (a -> a -> a) -> ListMap k a -> a
$cfoldr1 :: forall k a. (a -> a -> a) -> ListMap k a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> ListMap k a -> b
$cfoldl' :: forall k b a. (b -> a -> b) -> b -> ListMap k a -> b
foldl :: forall b a. (b -> a -> b) -> b -> ListMap k a -> b
$cfoldl :: forall k b a. (b -> a -> b) -> b -> ListMap k a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> ListMap k a -> b
$cfoldr' :: forall k a b. (a -> b -> b) -> b -> ListMap k a -> b
foldr :: forall a b. (a -> b -> b) -> b -> ListMap k a -> b
$cfoldr :: forall k a b. (a -> b -> b) -> b -> ListMap k a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> ListMap k a -> m
$cfoldMap' :: forall k m a. Monoid m => (a -> m) -> ListMap k a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> ListMap k a -> m
$cfoldMap :: forall k m a. Monoid m => (a -> m) -> ListMap k a -> m
fold :: forall m. Monoid m => ListMap k m -> m
$cfold :: forall k m. Monoid m => ListMap k m -> m
Foldable, forall a b. a -> ListMap k b -> ListMap k a
forall a b. (a -> b) -> ListMap k a -> ListMap k b
forall k a b. a -> ListMap k b -> ListMap k a
forall k a b. (a -> b) -> ListMap k a -> ListMap k b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ListMap k b -> ListMap k a
$c<$ :: forall k a b. a -> ListMap k b -> ListMap k a
fmap :: forall a b. (a -> b) -> ListMap k a -> ListMap k b
$cfmap :: forall k a b. (a -> b) -> ListMap k a -> ListMap k b
Functor, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k v x. Rep (ListMap k v) x -> ListMap k v
forall k v x. ListMap k v -> Rep (ListMap k v) x
$cto :: forall k v x. Rep (ListMap k v) x -> ListMap k v
$cfrom :: forall k v x. ListMap k v -> Rep (ListMap k v) x
Generic, forall k a. Rep1 (ListMap k) a -> ListMap k a
forall k a. ListMap k a -> Rep1 (ListMap k) a
forall k (f :: k -> *).
(forall (a :: k). f a -> Rep1 f a)
-> (forall (a :: k). Rep1 f a -> f a) -> Generic1 f
$cto1 :: forall k a. Rep1 (ListMap k) a -> ListMap k a
$cfrom1 :: forall k a. ListMap k a -> Rep1 (ListMap k) a
Generic1, ListMap k v -> ()
forall a. (a -> ()) -> NFData a
forall k v. (NFData k, NFData v) => ListMap k v -> ()
rnf :: ListMap k v -> ()
$crnf :: forall k v. (NFData k, NFData v) => ListMap k v -> ()
NFData)

-- | Eq works similarly to Map
instance (Ord k, Ord v) => Eq (ListMap k v) where
  (ListMap [(k, v)]
xs) == :: ListMap k v -> ListMap k v -> Bool
== (ListMap [(k, v)]
ys) = forall a. Ord a => [a] -> [a]
L.sort [(k, v)]
xs forall a. Eq a => a -> a -> Bool
== forall a. Ord a => [a] -> [a]
L.sort [(k, v)]
ys

instance Semigroup (ListMap k v) where
  ListMap [(k, v)]
xs <> :: ListMap k v -> ListMap k v -> ListMap k v
<> ListMap [(k, v)]
ys = forall k v. [(k, v)] -> ListMap k v
ListMap forall a b. (a -> b) -> a -> b
$ [(k, v)]
xs forall a. Semigroup a => a -> a -> a
<> [(k, v)]
ys

instance Monoid (ListMap k v) where
  mempty :: ListMap k v
mempty = forall k v. [(k, v)] -> ListMap k v
ListMap forall a. Monoid a => a
mempty

instance (NoThunks k, NoThunks v) => NoThunks (ListMap k v)

instance (DecCBOR k, DecCBOR v) => DecCBOR (ListMap k v) where
  decCBOR :: forall s. Decoder s (ListMap k v)
decCBOR =
    forall k v. [(k, v)] -> ListMap k v
ListMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      Int
len <- forall s. Decoder s Int
decodeMapLen
      forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
len forall a b. (a -> b) -> a -> b
$ do
        k
k <- forall a s. DecCBOR a => Decoder s a
decCBOR
        v
v <- forall a s. DecCBOR a => Decoder s a
decCBOR
        forall (m :: * -> *) a. Monad m => a -> m a
return (k
k, v
v)

instance (EncCBOR k, EncCBOR v) => EncCBOR (ListMap k v) where
  encCBOR :: ListMap k v -> Encoding
encCBOR (ListMap [(k, v)]
xs) = Word -> Encoding
encodeMapLen (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [(k, v)]
xs) forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a} {a}.
(EncCBOR a, EncCBOR a) =>
(a, a) -> Encoding -> Encoding
f forall a. Monoid a => a
mempty [(k, v)]
xs
    where
      f :: (a, a) -> Encoding -> Encoding
f (a
k, a
v) Encoding
e = forall a. EncCBOR a => a -> Encoding
encCBOR a
k forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR a
v forall a. Semigroup a => a -> a -> a
<> Encoding
e

instance ToJSONKey k => ToJSON1 (ListMap k) where
  liftToJSON :: forall a.
(a -> Bool)
-> (a -> Value) -> ([a] -> Value) -> ListMap k a -> Value
liftToJSON a -> Bool
_ a -> Value
g [a] -> Value
_ = case forall a. ToJSONKey a => ToJSONKeyFunction a
toJSONKey of
    ToJSONKeyText k -> Key
f k -> Encoding' Key
_ -> Object -> Value
Object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. [(Key, v)] -> KeyMap v
KM.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. ListMap k v -> [(k, v)]
unListMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap k -> Key
f a -> Value
g
    ToJSONKeyValue k -> Value
f k -> Encoding
_ -> Array -> Value
Array forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Vector a
V.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
L.map (forall a b. (a -> Value) -> (b -> Value) -> (a, b) -> Value
toJSONPair k -> Value
f a -> Value
g) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. ListMap k v -> [(k, v)]
unListMap
    where
      toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value
      toJSONPair :: forall a b. (a -> Value) -> (b -> Value) -> (a, b) -> Value
toJSONPair a -> Value
a b -> Value
b = forall (f :: * -> * -> *) a b.
ToJSON2 f =>
(a -> Bool)
-> (a -> Value)
-> ([a] -> Value)
-> (b -> Bool)
-> (b -> Value)
-> ([b] -> Value)
-> f a b
-> Value
liftToJSON2 (forall a b. a -> b -> a
const Bool
False) a -> Value
a (forall a. (a -> Value) -> [a] -> Value
listValue a -> Value
a) (forall a b. a -> b -> a
const Bool
False) b -> Value
b (forall a. (a -> Value) -> [a] -> Value
listValue b -> Value
b)

  liftToEncoding :: forall a.
(a -> Bool)
-> (a -> Encoding) -> ([a] -> Encoding) -> ListMap k a -> Encoding
liftToEncoding a -> Bool
_ a -> Encoding
g [a] -> Encoding
_ = case forall a. ToJSONKey a => ToJSONKeyFunction a
toJSONKey of
    ToJSONKeyText k -> Key
_ k -> Encoding' Key
f -> forall k v m.
(k -> Encoding' Key)
-> (v -> Encoding)
-> (forall a. (k -> v -> a -> a) -> a -> m -> a)
-> m
-> Encoding
dict k -> Encoding' Key
f a -> Encoding
g (forall k a b. ((k, a) -> b -> b) -> b -> ListMap k a -> b
foldrWithKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry)
    ToJSONKeyValue k -> Value
_ k -> Encoding
f -> forall a. (a -> Encoding) -> [a] -> Encoding
E.list ((k -> Encoding) -> (k, a) -> Encoding
pairEncoding k -> Encoding
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. ListMap k v -> [(k, v)]
unListMap
    where
      pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding
pairEncoding k -> Encoding
f (k
a, a
b) = forall a. (a -> Encoding) -> [a] -> Encoding
E.list forall a. a -> a
id [k -> Encoding
f k
a, a -> Encoding
g a
b]

instance (ToJSON v, ToJSONKey k) => ToJSON (ListMap k v) where
  toJSON :: ListMap k v -> Value
toJSON = forall (f :: * -> *) a. (ToJSON1 f, ToJSON a) => f a -> Value
J.toJSON1
  toEncoding :: ListMap k v -> Encoding
toEncoding = forall (f :: * -> *) a. (ToJSON1 f, ToJSON a) => f a -> Encoding
J.toEncoding1

instance (FromJSON k, FromJSONKey k) => FromJSON1 (ListMap k) where
  liftParseJSON :: forall a.
Maybe a
-> (Value -> Parser a)
-> (Value -> Parser [a])
-> Value
-> Parser (ListMap k a)
liftParseJSON Maybe a
_ Value -> Parser a
parser Value -> Parser [a]
_ = forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"ListMap" forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    let kv :: [(Key, Value)]
kv = forall v. KeyMap v -> [(Key, v)]
KM.toList Object
obj
    [(k, a)]
res <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Key, Value)]
kv forall a b. (a -> b) -> a -> b
$ \(Key
k, Value
v) -> do
      let t :: Text
t = Key -> Text
Key.toText Key
k
      k
k' <- case forall a. FromJSONKey a => FromJSONKeyFunction a
fromJSONKey of
        FromJSONKeyFunction k
FromJSONKeyCoerce -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce Text
t
        FromJSONKeyText Text -> k
f -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> k
f Text
t
        FromJSONKeyTextParser Text -> Parser k
f -> Text -> Parser k
f Text
t
        -- TODO figure out what to do here
        FromJSONKeyValue Value -> Parser k
_ -> forall a. HasCallStack => String -> a
error String
"key conversion not implemented"
      a
v' <- Value -> Parser a
parser Value
v
      forall (m :: * -> *) a. Monad m => a -> m a
return (k
k', a
v')
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k v. [(k, v)] -> ListMap k v
ListMap [(k, a)]
res

instance (FromJSON v, FromJSON k, FromJSONKey k) => FromJSON (ListMap k v) where
  parseJSON :: Value -> Parser (ListMap k v)
parseJSON = forall (f :: * -> *) a.
(FromJSON1 f, FromJSON a) =>
Value -> Parser (f a)
J.parseJSON1

instance NFData k => NFData1 (ListMap k)

instance Bifunctor ListMap where
  bimap :: forall a b c d. (a -> b) -> (c -> d) -> ListMap a c -> ListMap b d
bimap a -> b
f c -> d
g (ListMap [(a, c)]
xs) = forall k v. [(k, v)] -> ListMap k v
ListMap forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f c -> d
g) [(a, c)]
xs

foldrWithKey :: ((k, a) -> b -> b) -> b -> ListMap k a -> b
foldrWithKey :: forall k a b. ((k, a) -> b -> b) -> b -> ListMap k a -> b
foldrWithKey (k, a) -> b -> b
f b
z = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr (k, a) -> b -> b
f b
z forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. ListMap k v -> [(k, v)]
unListMap

keys :: ListMap k a -> [k]
keys :: forall k a. ListMap k a -> [k]
keys (ListMap [(k, a)]
xs) = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(k, a)]
xs

keysSet :: Ord k => ListMap k a -> Set.Set k
keysSet :: forall k a. Ord k => ListMap k a -> Set k
keysSet ListMap k a
lm = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall k a. ListMap k a -> [k]
keys ListMap k a
lm

elems :: ListMap k a -> [a]
elems :: forall k a. ListMap k a -> [a]
elems (ListMap [(k, a)]
xs) = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(k, a)]
xs

lookup :: Eq k => k -> ListMap k v -> Maybe v
lookup :: forall k v. Eq k => k -> ListMap k v -> Maybe v
lookup k
k (ListMap [(k, v)]
xs) = forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup k
k [(k, v)]
xs

filter :: (k -> v -> Bool) -> ListMap k v -> ListMap k v
filter :: forall k v. (k -> v -> Bool) -> ListMap k v -> ListMap k v
filter k -> v -> Bool
f (ListMap [(k, v)]
xs) = forall k v. [(k, v)] -> ListMap k v
ListMap forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
Pre.filter (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry k -> v -> Bool
f) [(k, v)]
xs

toMap :: Ord k => ListMap k v -> Map.Map k v
toMap :: forall k v. Ord k => ListMap k v -> Map k v
toMap (ListMap [(k, v)]
xs) = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(k, v)]
xs

fromMap :: Map.Map k v -> ListMap k v
fromMap :: forall k v. Map k v -> ListMap k v
fromMap = forall k v. [(k, v)] -> ListMap k v
ListMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList

mapKeys :: (k1 -> k2) -> ListMap k1 a -> ListMap k2 a
mapKeys :: forall a b c. (a -> b) -> ListMap a c -> ListMap b c
mapKeys k1 -> k2
f = forall k v. [(k, v)] -> ListMap k v
ListMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first k1 -> k2
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. ListMap k v -> [(k, v)]
unListMap

map :: (a -> v) -> ListMap k a -> ListMap k v
map :: forall b c a. (b -> c) -> ListMap a b -> ListMap a c
map = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

empty :: ListMap k a
empty :: forall k v. ListMap k v
empty = forall k v. [(k, v)] -> ListMap k v
ListMap []

fromList :: [(k, v)] -> ListMap k v
fromList :: forall k v. [(k, v)] -> ListMap k v
fromList = forall k v. [(k, v)] -> ListMap k v
ListMap

toList :: ListMap k v -> [(k, v)]
toList :: forall k v. ListMap k v -> [(k, v)]
toList = forall k v. ListMap k v -> [(k, v)]
unListMap