{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Safe #-}
module Cryptol.Utils.RecordMap
( RecordMap
, displayOrder
, canonicalFields
, displayFields
, recordElements
, displayElements
, fieldSet
, recordFromFields
, recordFromFieldsErr
, recordFromFieldsWithDisplay
, lookupField
, adjustField
, traverseRecordMap
, mapWithFieldName
, zipRecordsM
, zipRecords
, recordMapAccum
) where
import Control.DeepSeq
import Control.Monad.Except (ExceptT, MonadError(..), runExceptT)
import Control.Monad.Trans (MonadTrans(..))
import Data.Functor.Identity
import Data.Set (Set)
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Map.Merge.Strict as Map
import Cryptol.Utils.Panic
data RecordMap a b =
RecordMap
{ forall a b. RecordMap a b -> Map a b
recordMap :: !(Map a b)
, forall a b. RecordMap a b -> [a]
_displayOrder :: [a]
}
instance (Ord a, Eq b) => Eq (RecordMap a b) where
RecordMap a b
a == :: RecordMap a b -> RecordMap a b -> Bool
== RecordMap a b
b = RecordMap a b -> Map a b
forall a b. RecordMap a b -> Map a b
recordMap RecordMap a b
a Map a b -> Map a b -> Bool
forall a. Eq a => a -> a -> Bool
== RecordMap a b -> Map a b
forall a b. RecordMap a b -> Map a b
recordMap RecordMap a b
b
instance (Ord a, Ord b) => Ord (RecordMap a b) where
compare :: RecordMap a b -> RecordMap a b -> Ordering
compare RecordMap a b
a RecordMap a b
b = Map a b -> Map a b -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RecordMap a b -> Map a b
forall a b. RecordMap a b -> Map a b
recordMap RecordMap a b
a) (RecordMap a b -> Map a b
forall a b. RecordMap a b -> Map a b
recordMap RecordMap a b
b)
instance (Show a, Ord a, Show b) => Show (RecordMap a b) where
show :: RecordMap a b -> String
show = [(a, b)] -> String
forall a. Show a => a -> String
show ([(a, b)] -> String)
-> (RecordMap a b -> [(a, b)]) -> RecordMap a b -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordMap a b -> [(a, b)]
forall a b. (Show a, Ord a) => RecordMap a b -> [(a, b)]
displayFields
instance (NFData a, NFData b) => NFData (RecordMap a b) where
rnf :: RecordMap a b -> ()
rnf = [(a, b)] -> ()
forall a. NFData a => a -> ()
rnf ([(a, b)] -> ())
-> (RecordMap a b -> [(a, b)]) -> RecordMap a b -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordMap a b -> [(a, b)]
forall a b. RecordMap a b -> [(a, b)]
canonicalFields
fieldSet :: Ord a => RecordMap a b -> Set a
fieldSet :: forall a b. Ord a => RecordMap a b -> Set a
fieldSet RecordMap a b
r = Map a b -> Set a
forall k a. Map k a -> Set k
Map.keysSet (RecordMap a b -> Map a b
forall a b. RecordMap a b -> Map a b
recordMap RecordMap a b
r)
displayOrder :: RecordMap a b -> [a]
displayOrder :: forall a b. RecordMap a b -> [a]
displayOrder RecordMap a b
r = RecordMap a b -> [a]
forall a b. RecordMap a b -> [a]
_displayOrder RecordMap a b
r
recordElements :: RecordMap a b -> [b]
recordElements :: forall a b. RecordMap a b -> [b]
recordElements = ((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd ([(a, b)] -> [b])
-> (RecordMap a b -> [(a, b)]) -> RecordMap a b -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordMap a b -> [(a, b)]
forall a b. RecordMap a b -> [(a, b)]
canonicalFields
canonicalFields :: RecordMap a b -> [(a,b)]
canonicalFields :: forall a b. RecordMap a b -> [(a, b)]
canonicalFields = Map a b -> [(a, b)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map a b -> [(a, b)])
-> (RecordMap a b -> Map a b) -> RecordMap a b -> [(a, b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordMap a b -> Map a b
forall a b. RecordMap a b -> Map a b
recordMap
displayElements :: (Show a, Ord a) => RecordMap a b -> [b]
displayElements :: forall a b. (Show a, Ord a) => RecordMap a b -> [b]
displayElements = ((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd ([(a, b)] -> [b])
-> (RecordMap a b -> [(a, b)]) -> RecordMap a b -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordMap a b -> [(a, b)]
forall a b. (Show a, Ord a) => RecordMap a b -> [(a, b)]
displayFields
displayFields :: (Show a, Ord a) => RecordMap a b -> [(a,b)]
displayFields :: forall a b. (Show a, Ord a) => RecordMap a b -> [(a, b)]
displayFields RecordMap a b
r = (a -> (a, b)) -> [a] -> [(a, b)]
forall a b. (a -> b) -> [a] -> [b]
map a -> (a, b)
find (RecordMap a b -> [a]
forall a b. RecordMap a b -> [a]
displayOrder RecordMap a b
r)
where
find :: a -> (a, b)
find a
x =
case a -> Map a b -> Maybe b
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
x (RecordMap a b -> Map a b
forall a b. RecordMap a b -> Map a b
recordMap RecordMap a b
r) of
Just b
v -> (a
x, b
v)
Maybe b
Nothing ->
String -> [String] -> (a, b)
forall a. HasCallStack => String -> [String] -> a
panic String
"displayFields"
[String
"Could not find field in recordMap " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
, String
"Display order: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => a -> String
show (RecordMap a b -> [a]
forall a b. RecordMap a b -> [a]
displayOrder RecordMap a b
r)
, String
"Canonical order:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => a -> String
show (((a, b) -> a) -> [(a, b)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> a
forall a b. (a, b) -> a
fst (RecordMap a b -> [(a, b)]
forall a b. RecordMap a b -> [(a, b)]
canonicalFields RecordMap a b
r))
]
recordFromFields :: (Show a, Ord a) => [(a,b)] -> RecordMap a b
recordFromFields :: forall a b. (Show a, Ord a) => [(a, b)] -> RecordMap a b
recordFromFields [(a, b)]
xs =
case [(a, b)] -> Either (a, b) (RecordMap a b)
forall a b.
(Show a, Ord a) =>
[(a, b)] -> Either (a, b) (RecordMap a b)
recordFromFieldsErr [(a, b)]
xs of
Left (a
x,b
_) ->
String -> [String] -> RecordMap a b
forall a. HasCallStack => String -> [String] -> a
panic String
"recordFromFields"
[String
"Repeated field value: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x]
Right RecordMap a b
r -> RecordMap a b
r
recordFromFieldsErr :: (Show a, Ord a) => [(a,b)] -> Either (a,b) (RecordMap a b)
recordFromFieldsErr :: forall a b.
(Show a, Ord a) =>
[(a, b)] -> Either (a, b) (RecordMap a b)
recordFromFieldsErr [(a, b)]
xs0 = Map a b -> [(a, b)] -> Either (a, b) (RecordMap a b)
forall {a}. Map a a -> [(a, a)] -> Either (a, a) (RecordMap a a)
loop Map a b
forall a. Monoid a => a
mempty [(a, b)]
xs0
where
loop :: Map a a -> [(a, a)] -> Either (a, a) (RecordMap a a)
loop Map a a
m [] = RecordMap a a -> Either (a, a) (RecordMap a a)
forall a b. b -> Either a b
Right (Map a a -> [a] -> RecordMap a a
forall a b. Map a b -> [a] -> RecordMap a b
RecordMap Map a a
m (((a, b) -> a) -> [(a, b)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> a
forall a b. (a, b) -> a
fst [(a, b)]
xs0))
loop Map a a
m ((a
x,a
v):[(a, a)]
xs)
| Just a
_ <- a -> Map a a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
x Map a a
m = (a, a) -> Either (a, a) (RecordMap a a)
forall a b. a -> Either a b
Left (a
x,a
v)
| Bool
otherwise = Map a a -> [(a, a)] -> Either (a, a) (RecordMap a a)
loop (a -> a -> Map a a -> Map a a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
x a
v Map a a
m) [(a, a)]
xs
recordFromFieldsWithDisplay :: (Show a, Ord a) => [a] -> [(a,b)] -> RecordMap a b
recordFromFieldsWithDisplay :: forall a b. (Show a, Ord a) => [a] -> [(a, b)] -> RecordMap a b
recordFromFieldsWithDisplay [a]
dOrd [(a, b)]
fs = RecordMap a b
r { _displayOrder = dOrd }
where
r :: RecordMap a b
r = [(a, b)] -> RecordMap a b
forall a b. (Show a, Ord a) => [(a, b)] -> RecordMap a b
recordFromFields [(a, b)]
fs
lookupField :: Ord a => a -> RecordMap a b -> Maybe b
lookupField :: forall a b. Ord a => a -> RecordMap a b -> Maybe b
lookupField a
x RecordMap a b
m = a -> Map a b -> Maybe b
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
x (RecordMap a b -> Map a b
forall a b. RecordMap a b -> Map a b
recordMap RecordMap a b
m)
adjustField :: forall a b. Ord a => a -> (b -> b) -> RecordMap a b -> Maybe (RecordMap a b)
adjustField :: forall a b.
Ord a =>
a -> (b -> b) -> RecordMap a b -> Maybe (RecordMap a b)
adjustField a
x b -> b
f RecordMap a b
r = Map a b -> RecordMap a b
forall {b}. Map a b -> RecordMap a b
mkRec (Map a b -> RecordMap a b)
-> Maybe (Map a b) -> Maybe (RecordMap a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe b -> Maybe (Maybe b)) -> a -> Map a b -> Maybe (Map a b)
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF Maybe b -> Maybe (Maybe b)
f' a
x (RecordMap a b -> Map a b
forall a b. RecordMap a b -> Map a b
recordMap RecordMap a b
r)
where
mkRec :: Map a b -> RecordMap a b
mkRec Map a b
m = RecordMap a b
r{ recordMap = m }
f' :: Maybe b -> Maybe (Maybe b)
f' :: Maybe b -> Maybe (Maybe b)
f' Maybe b
Nothing = Maybe (Maybe b)
forall a. Maybe a
Nothing
f' (Just b
v) = Maybe b -> Maybe (Maybe b)
forall a. a -> Maybe a
Just (b -> Maybe b
forall a. a -> Maybe a
Just (b -> b
f b
v))
traverseRecordMap :: Applicative t =>
(a -> b -> t c) -> RecordMap a b -> t (RecordMap a c)
traverseRecordMap :: forall (t :: * -> *) a b c.
Applicative t =>
(a -> b -> t c) -> RecordMap a b -> t (RecordMap a c)
traverseRecordMap a -> b -> t c
f RecordMap a b
r =
(\Map a c
m -> Map a c -> [a] -> RecordMap a c
forall a b. Map a b -> [a] -> RecordMap a b
RecordMap Map a c
m (RecordMap a b -> [a]
forall a b. RecordMap a b -> [a]
displayOrder RecordMap a b
r)) (Map a c -> RecordMap a c) -> t (Map a c) -> t (RecordMap a c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> b -> t c) -> Map a b -> t (Map a c)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey a -> b -> t c
f (RecordMap a b -> Map a b
forall a b. RecordMap a b -> Map a b
recordMap RecordMap a b
r)
mapWithFieldName :: (a -> b -> c) -> RecordMap a b -> RecordMap a c
mapWithFieldName :: forall a b c. (a -> b -> c) -> RecordMap a b -> RecordMap a c
mapWithFieldName a -> b -> c
f = Identity (RecordMap a c) -> RecordMap a c
forall a. Identity a -> a
runIdentity (Identity (RecordMap a c) -> RecordMap a c)
-> (RecordMap a b -> Identity (RecordMap a c))
-> RecordMap a b
-> RecordMap a c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b -> Identity c) -> RecordMap a b -> Identity (RecordMap a c)
forall (t :: * -> *) a b c.
Applicative t =>
(a -> b -> t c) -> RecordMap a b -> t (RecordMap a c)
traverseRecordMap (\a
a b
b -> c -> Identity c
forall a. a -> Identity a
Identity (a -> b -> c
f a
a b
b))
instance Functor (RecordMap a) where
fmap :: forall a b. (a -> b) -> RecordMap a a -> RecordMap a b
fmap a -> b
f = (a -> a -> b) -> RecordMap a a -> RecordMap a b
forall a b c. (a -> b -> c) -> RecordMap a b -> RecordMap a c
mapWithFieldName (\a
_ -> a -> b
f)
instance Foldable (RecordMap a) where
foldMap :: forall m a. Monoid m => (a -> m) -> RecordMap a a -> m
foldMap a -> m
f = ((a, a) -> m) -> [(a, a)] -> m
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (a -> m
f (a -> m) -> ((a, a) -> a) -> (a, a) -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, a) -> a
forall a b. (a, b) -> b
snd) ([(a, a)] -> m)
-> (RecordMap a a -> [(a, a)]) -> RecordMap a a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordMap a a -> [(a, a)]
forall a b. RecordMap a b -> [(a, b)]
canonicalFields
instance Traversable (RecordMap a) where
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> RecordMap a a -> f (RecordMap a b)
traverse a -> f b
f = (a -> a -> f b) -> RecordMap a a -> f (RecordMap a b)
forall (t :: * -> *) a b c.
Applicative t =>
(a -> b -> t c) -> RecordMap a b -> t (RecordMap a c)
traverseRecordMap (\a
_ -> a -> f b
f)
recordMapAccum :: (a -> b -> (a,c)) -> a -> RecordMap k b -> (a, RecordMap k c)
recordMapAccum :: forall a b c k.
(a -> b -> (a, c)) -> a -> RecordMap k b -> (a, RecordMap k c)
recordMapAccum a -> b -> (a, c)
f a
z RecordMap k b
r = (a
a, RecordMap k b
r{ recordMap = m' })
where
(a
a, Map k c
m') = (a -> b -> (a, c)) -> a -> Map k b -> (a, Map k c)
forall a b c k. (a -> b -> (a, c)) -> a -> Map k b -> (a, Map k c)
Map.mapAccum a -> b -> (a, c)
f a
z (RecordMap k b -> Map k b
forall a b. RecordMap a b -> Map a b
recordMap RecordMap k b
r)
zipRecordsM :: forall t a b c d. (Ord a, Monad t) =>
(a -> b -> c -> t d) -> RecordMap a b -> RecordMap a c -> t (Either (Either a a) (RecordMap a d))
zipRecordsM :: forall (t :: * -> *) a b c d.
(Ord a, Monad t) =>
(a -> b -> c -> t d)
-> RecordMap a b
-> RecordMap a c
-> t (Either (Either a a) (RecordMap a d))
zipRecordsM a -> b -> c -> t d
f RecordMap a b
r1 RecordMap a c
r2 = ExceptT (Either a a) t (RecordMap a d)
-> t (Either (Either a a) (RecordMap a d))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Map a d -> RecordMap a d
forall {b}. Map a b -> RecordMap a b
mkRec (Map a d -> RecordMap a d)
-> ExceptT (Either a a) t (Map a d)
-> ExceptT (Either a a) t (RecordMap a d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map a b -> Map a c -> ExceptT (Either a a) t (Map a d)
zipMap (RecordMap a b -> Map a b
forall a b. RecordMap a b -> Map a b
recordMap RecordMap a b
r1) (RecordMap a c -> Map a c
forall a b. RecordMap a b -> Map a b
recordMap RecordMap a c
r2))
where
mkRec :: Map a b -> RecordMap a b
mkRec Map a b
m = Map a b -> [a] -> RecordMap a b
forall a b. Map a b -> [a] -> RecordMap a b
RecordMap Map a b
m (RecordMap a b -> [a]
forall a b. RecordMap a b -> [a]
displayOrder RecordMap a b
r1)
zipMap :: Map a b -> Map a c -> ExceptT (Either a a) t (Map a d)
zipMap :: Map a b -> Map a c -> ExceptT (Either a a) t (Map a d)
zipMap = WhenMissing (ExceptT (Either a a) t) a b d
-> WhenMissing (ExceptT (Either a a) t) a c d
-> WhenMatched (ExceptT (Either a a) t) a b c d
-> Map a b
-> Map a c
-> ExceptT (Either a a) t (Map a d)
forall (f :: * -> *) k a c b.
(Applicative f, Ord k) =>
WhenMissing f k a c
-> WhenMissing f k b c
-> WhenMatched f k a b c
-> Map k a
-> Map k b
-> f (Map k c)
Map.mergeA WhenMissing (ExceptT (Either a a) t) a b d
forall {x} {y}. WhenMissing (ExceptT (Either a a) t) a x y
missingLeft WhenMissing (ExceptT (Either a a) t) a c d
forall {x} {y}. WhenMissing (ExceptT (Either a a) t) a x y
missingRight WhenMatched (ExceptT (Either a a) t) a b c d
matched
missingLeft :: WhenMissing (ExceptT (Either a a) t) a x y
missingLeft = (a -> x -> ExceptT (Either a a) t y)
-> WhenMissing (ExceptT (Either a a) t) a x y
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> f y) -> WhenMissing f k x y
Map.traverseMissing (\a
a x
_b -> Either a a -> ExceptT (Either a a) t y
forall a. Either a a -> ExceptT (Either a a) t a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (a -> Either a a
forall a b. a -> Either a b
Left a
a))
missingRight :: WhenMissing (ExceptT (Either a a) t) a x y
missingRight = (a -> x -> ExceptT (Either a a) t y)
-> WhenMissing (ExceptT (Either a a) t) a x y
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> f y) -> WhenMissing f k x y
Map.traverseMissing (\a
a x
_c -> Either a a -> ExceptT (Either a a) t y
forall a. Either a a -> ExceptT (Either a a) t a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (a -> Either a a
forall a b. b -> Either a b
Right a
a))
matched :: WhenMatched (ExceptT (Either a a) t) a b c d
matched = (a -> b -> c -> ExceptT (Either a a) t d)
-> WhenMatched (ExceptT (Either a a) t) a b c d
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> f z) -> WhenMatched f k x y z
Map.zipWithAMatched (\a
a b
b c
c -> t d -> ExceptT (Either a a) t d
forall (m :: * -> *) a. Monad m => m a -> ExceptT (Either a a) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (a -> b -> c -> t d
f a
a b
b c
c))
zipRecords :: forall a b c d. Ord a =>
(a -> b -> c -> d) -> RecordMap a b -> RecordMap a c -> Either (Either a a) (RecordMap a d)
zipRecords :: forall a b c d.
Ord a =>
(a -> b -> c -> d)
-> RecordMap a b
-> RecordMap a c
-> Either (Either a a) (RecordMap a d)
zipRecords a -> b -> c -> d
f RecordMap a b
r1 RecordMap a c
r2 = Identity (Either (Either a a) (RecordMap a d))
-> Either (Either a a) (RecordMap a d)
forall a. Identity a -> a
runIdentity ((a -> b -> c -> Identity d)
-> RecordMap a b
-> RecordMap a c
-> Identity (Either (Either a a) (RecordMap a d))
forall (t :: * -> *) a b c d.
(Ord a, Monad t) =>
(a -> b -> c -> t d)
-> RecordMap a b
-> RecordMap a c
-> t (Either (Either a a) (RecordMap a d))
zipRecordsM (\a
a b
b c
c -> d -> Identity d
forall a. a -> Identity a
Identity (a -> b -> c -> d
f a
a b
b c
c)) RecordMap a b
r1 RecordMap a c
r2)