{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

module Test.Util.RefEnv
  ( RefEnv
  -- opaque
  , elems
  , empty
  , filter
  , fromList
  , keys
  , lookup
  , null
  , reverseLookup
  , singleton
  , toList
  , union
  , (!)
  ) where

import Data.Bifunctor
import Data.Functor.Classes
import Data.List (intercalate)
import Data.TreeDiff (ToExpr)
import GHC.Generics (Generic)
import GHC.Stack
import Test.StateMachine (Reference)
import qualified Test.StateMachine.Types.Rank2 as Rank2
import Test.Util.ToExpr ()
import Prelude hiding (filter, lookup, null)
import qualified Prelude

data RefEnv k a r = RefEnv {forall k a (r :: * -> *). RefEnv k a r -> [(Reference k r, a)]
toList :: [(Reference k r, a)]}
  deriving ((forall x. RefEnv k a r -> Rep (RefEnv k a r) x)
-> (forall x. Rep (RefEnv k a r) x -> RefEnv k a r)
-> Generic (RefEnv k a r)
forall x. Rep (RefEnv k a r) x -> RefEnv k a r
forall x. RefEnv k a r -> Rep (RefEnv k a r) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k a (r :: * -> *) x. Rep (RefEnv k a r) x -> RefEnv k a r
forall k a (r :: * -> *) x. RefEnv k a r -> Rep (RefEnv k a r) x
$cfrom :: forall k a (r :: * -> *) x. RefEnv k a r -> Rep (RefEnv k a r) x
from :: forall x. RefEnv k a r -> Rep (RefEnv k a r) x
$cto :: forall k a (r :: * -> *) x. Rep (RefEnv k a r) x -> RefEnv k a r
to :: forall x. Rep (RefEnv k a r) x -> RefEnv k a r
Generic, [RefEnv k a r] -> Expr
RefEnv k a r -> Expr
(RefEnv k a r -> Expr)
-> ([RefEnv k a r] -> Expr) -> ToExpr (RefEnv k a r)
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
forall k a (r :: * -> *).
(ToExpr a, ToExpr (r k)) =>
[RefEnv k a r] -> Expr
forall k a (r :: * -> *).
(ToExpr a, ToExpr (r k)) =>
RefEnv k a r -> Expr
$ctoExpr :: forall k a (r :: * -> *).
(ToExpr a, ToExpr (r k)) =>
RefEnv k a r -> Expr
toExpr :: RefEnv k a r -> Expr
$clistToExpr :: forall k a (r :: * -> *).
(ToExpr a, ToExpr (r k)) =>
[RefEnv k a r] -> Expr
listToExpr :: [RefEnv k a r] -> Expr
ToExpr, Int -> RefEnv k a r -> ShowS
[RefEnv k a r] -> ShowS
RefEnv k a r -> String
(Int -> RefEnv k a r -> ShowS)
-> (RefEnv k a r -> String)
-> ([RefEnv k a r] -> ShowS)
-> Show (RefEnv k a r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k a (r :: * -> *).
(Show1 r, Show k, Show a) =>
Int -> RefEnv k a r -> ShowS
forall k a (r :: * -> *).
(Show1 r, Show k, Show a) =>
[RefEnv k a r] -> ShowS
forall k a (r :: * -> *).
(Show1 r, Show k, Show a) =>
RefEnv k a r -> String
$cshowsPrec :: forall k a (r :: * -> *).
(Show1 r, Show k, Show a) =>
Int -> RefEnv k a r -> ShowS
showsPrec :: Int -> RefEnv k a r -> ShowS
$cshow :: forall k a (r :: * -> *).
(Show1 r, Show k, Show a) =>
RefEnv k a r -> String
show :: RefEnv k a r -> String
$cshowList :: forall k a (r :: * -> *).
(Show1 r, Show k, Show a) =>
[RefEnv k a r] -> ShowS
showList :: [RefEnv k a r] -> ShowS
Show)

-- | Extend mapping
--
-- We don't insist that the keys are disjoint, but if the same key appears
-- twice, the value must agree.
extendMapping ::
  forall k v.
  (Eq k, Eq v, Show k, Show v, HasCallStack) =>
  [(k, v)] -> -- Mapping known to have duplicate keys
  [(k, v)] -> -- With potential duplicates
  [(k, v)]
extendMapping :: forall k v.
(Eq k, Eq v, Show k, Show v, HasCallStack) =>
[(k, v)] -> [(k, v)] -> [(k, v)]
extendMapping [(k, v)]
acc [] = [(k, v)]
acc
extendMapping [(k, v)]
acc ((k
k, v
v) : [(k, v)]
kvs) =
  case k -> [(k, v)] -> Maybe v
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup k
k [(k, v)]
acc of
    Just v
v' | v
v v -> v -> Bool
forall a. Eq a => a -> a -> Bool
/= v
v' -> String -> [(k, v)]
forall a. HasCallStack => String -> a
error (String -> [(k, v)]) -> String -> [(k, v)]
forall a b. (a -> b) -> a -> b
$ v -> String
renderError v
v'
    Maybe v
_otherwise -> [(k, v)] -> [(k, v)] -> [(k, v)]
forall k v.
(Eq k, Eq v, Show k, Show v, HasCallStack) =>
[(k, v)] -> [(k, v)] -> [(k, v)]
extendMapping ((k
k, v
v) (k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
: [(k, v)]
acc) [(k, v)]
kvs
 where
  renderError :: v -> String
  renderError :: v -> String
renderError v
v' =
    String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
      String
" "
      [ String
"Key"
      , k -> String
forall a. Show a => a -> String
show k
k
      , String
"with two different values"
      , v -> String
forall a. Show a => a -> String
show v
v
      , String
"and"
      , v -> String
forall a. Show a => a -> String
show v
v'
      ]

fromList ::
  (Eq k, Show k, Eq a, Show a, Eq1 r, Show1 r, HasCallStack) =>
  [(Reference k r, a)] -> RefEnv k a r
fromList :: forall k a (r :: * -> *).
(Eq k, Show k, Eq a, Show a, Eq1 r, Show1 r, HasCallStack) =>
[(Reference k r, a)] -> RefEnv k a r
fromList = [(Reference k r, a)] -> RefEnv k a r
forall k a (r :: * -> *). [(Reference k r, a)] -> RefEnv k a r
RefEnv ([(Reference k r, a)] -> RefEnv k a r)
-> ([(Reference k r, a)] -> [(Reference k r, a)])
-> [(Reference k r, a)]
-> RefEnv k a r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Reference k r, a)]
-> [(Reference k r, a)] -> [(Reference k r, a)]
forall k v.
(Eq k, Eq v, Show k, Show v, HasCallStack) =>
[(k, v)] -> [(k, v)] -> [(k, v)]
extendMapping []

instance Rank2.Functor (RefEnv k a) where
  fmap :: forall (p :: * -> *) (q :: * -> *).
(forall x. p x -> q x) -> RefEnv k a p -> RefEnv k a q
fmap forall x. p x -> q x
f (RefEnv [(Reference k p, a)]
ras) =
    [(Reference k q, a)] -> RefEnv k a q
forall k a (r :: * -> *). [(Reference k r, a)] -> RefEnv k a r
RefEnv ([(Reference k q, a)] -> RefEnv k a q)
-> [(Reference k q, a)] -> RefEnv k a q
forall a b. (a -> b) -> a -> b
$
      ((Reference k p, a) -> (Reference k q, a))
-> [(Reference k p, a)] -> [(Reference k q, a)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Reference k p -> Reference k q)
-> (Reference k p, a) -> (Reference k q, a)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((forall x. p x -> q x) -> Reference k p -> Reference k q
forall k (f :: (k -> *) -> *) (p :: k -> *) (q :: k -> *).
Functor f =>
(forall (x :: k). p x -> q x) -> f p -> f q
forall (p :: * -> *) (q :: * -> *).
(forall x. p x -> q x) -> Reference k p -> Reference k q
Rank2.fmap p x -> q x
forall x. p x -> q x
f)) [(Reference k p, a)]
ras

instance Rank2.Foldable (RefEnv k a) where
  foldMap :: forall m (p :: * -> *).
Monoid m =>
(forall x. p x -> m) -> RefEnv k a p -> m
foldMap forall x. p x -> m
f (RefEnv [(Reference k p, a)]
ras) =
    ((Reference k p, a) -> m) -> [(Reference k p, 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 ((forall x. p x -> m) -> Reference k p -> m
forall m (p :: * -> *).
Monoid m =>
(forall x. p x -> m) -> Reference k p -> m
forall k (f :: (k -> *) -> *) m (p :: k -> *).
(Foldable f, Monoid m) =>
(forall (x :: k). p x -> m) -> f p -> m
Rank2.foldMap p x -> m
forall x. p x -> m
f (Reference k p -> m)
-> ((Reference k p, a) -> Reference k p) -> (Reference k p, a) -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reference k p, a) -> Reference k p
forall a b. (a, b) -> a
fst) [(Reference k p, a)]
ras

instance Rank2.Traversable (RefEnv k a) where
  traverse :: forall (f :: * -> *) (p :: * -> *) (q :: * -> *).
Applicative f =>
(forall a. p a -> f (q a)) -> RefEnv k a p -> f (RefEnv k a q)
traverse forall a. p a -> f (q a)
f (RefEnv [(Reference k p, a)]
ras) =
    [(Reference k q, a)] -> RefEnv k a q
forall k a (r :: * -> *). [(Reference k r, a)] -> RefEnv k a r
RefEnv
      ([(Reference k q, a)] -> RefEnv k a q)
-> f [(Reference k q, a)] -> f (RefEnv k a q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Reference k p, a) -> f (Reference k q, a))
-> [(Reference k p, a)] -> f [(Reference k q, a)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\(Reference k p
r, a
a) -> (,a
a) (Reference k q -> (Reference k q, a))
-> f (Reference k q) -> f (Reference k q, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. p a -> f (q a)) -> Reference k p -> f (Reference k q)
forall k (t :: (k -> *) -> *) (f :: * -> *) (p :: k -> *)
       (q :: k -> *).
(Traversable t, Applicative f) =>
(forall (a :: k). p a -> f (q a)) -> t p -> f (t q)
forall (f :: * -> *) (p :: * -> *) (q :: * -> *).
Applicative f =>
(forall a. p a -> f (q a)) -> Reference k p -> f (Reference k q)
Rank2.traverse p a -> f (q a)
forall a. p a -> f (q a)
f Reference k p
r) [(Reference k p, a)]
ras

union ::
  (Eq k, Show k, Eq a, Show a, Eq1 r, Show1 r, HasCallStack) =>
  RefEnv k a r -> RefEnv k a r -> RefEnv k a r
union :: forall k a (r :: * -> *).
(Eq k, Show k, Eq a, Show a, Eq1 r, Show1 r, HasCallStack) =>
RefEnv k a r -> RefEnv k a r -> RefEnv k a r
union (RefEnv [(Reference k r, a)]
ras1) (RefEnv [(Reference k r, a)]
ras2) = [(Reference k r, a)] -> RefEnv k a r
forall k a (r :: * -> *). [(Reference k r, a)] -> RefEnv k a r
RefEnv ([(Reference k r, a)]
-> [(Reference k r, a)] -> [(Reference k r, a)]
forall k v.
(Eq k, Eq v, Show k, Show v, HasCallStack) =>
[(k, v)] -> [(k, v)] -> [(k, v)]
extendMapping [(Reference k r, a)]
ras1 [(Reference k r, a)]
ras2)

-- | Empty environment
--
-- In most context 'mempty' can be used, but the 'Monoid' instance requires
-- equality, which 'empty' does not.
empty :: RefEnv k a r
empty :: forall k a (r :: * -> *). RefEnv k a r
empty = [(Reference k r, a)] -> RefEnv k a r
forall k a (r :: * -> *). [(Reference k r, a)] -> RefEnv k a r
RefEnv []

lookup :: (Eq k, Eq1 r) => Reference k r -> RefEnv k a r -> Maybe a
lookup :: forall k (r :: * -> *) a.
(Eq k, Eq1 r) =>
Reference k r -> RefEnv k a r -> Maybe a
lookup Reference k r
r (RefEnv [(Reference k r, a)]
ras) = Reference k r -> [(Reference k r, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup Reference k r
r [(Reference k r, a)]
ras

(!) :: (Eq k, Eq1 r) => RefEnv k a r -> Reference k r -> a
RefEnv k a r
env ! :: forall k (r :: * -> *) a.
(Eq k, Eq1 r) =>
RefEnv k a r -> Reference k r -> a
! Reference k r
r = case Reference k r -> RefEnv k a r -> Maybe a
forall k (r :: * -> *) a.
(Eq k, Eq1 r) =>
Reference k r -> RefEnv k a r -> Maybe a
lookup Reference k r
r RefEnv k a r
env of
  Just a
a -> a
a
  Maybe a
Nothing -> String -> a
forall a. HasCallStack => String -> a
error String
"(RefEnv.!): key not found"

keys :: RefEnv k a r -> [Reference k r]
keys :: forall k a (r :: * -> *). RefEnv k a r -> [Reference k r]
keys (RefEnv [(Reference k r, a)]
ras) = ((Reference k r, a) -> Reference k r)
-> [(Reference k r, a)] -> [Reference k r]
forall a b. (a -> b) -> [a] -> [b]
map (Reference k r, a) -> Reference k r
forall a b. (a, b) -> a
fst [(Reference k r, a)]
ras

elems :: RefEnv k a r -> [a]
elems :: forall k a (r :: * -> *). RefEnv k a r -> [a]
elems (RefEnv [(Reference k r, a)]
ras) = ((Reference k r, a) -> a) -> [(Reference k r, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Reference k r, a) -> a
forall a b. (a, b) -> b
snd [(Reference k r, a)]
ras

null :: RefEnv k a r -> Bool
null :: forall k a (r :: * -> *). RefEnv k a r -> Bool
null (RefEnv [(Reference k r, a)]
ras) = [(Reference k r, a)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
Prelude.null [(Reference k r, a)]
ras

singleton :: Reference k r -> a -> RefEnv k a r
singleton :: forall k (r :: * -> *) a. Reference k r -> a -> RefEnv k a r
singleton Reference k r
r a
a = [(Reference k r, a)] -> RefEnv k a r
forall k a (r :: * -> *). [(Reference k r, a)] -> RefEnv k a r
RefEnv [(Reference k r
r, a
a)]

filter :: (a -> Bool) -> RefEnv k a r -> RefEnv k a r
filter :: forall a k (r :: * -> *).
(a -> Bool) -> RefEnv k a r -> RefEnv k a r
filter a -> Bool
p (RefEnv [(Reference k r, a)]
ras) = [(Reference k r, a)] -> RefEnv k a r
forall k a (r :: * -> *). [(Reference k r, a)] -> RefEnv k a r
RefEnv (((Reference k r, a) -> Bool)
-> [(Reference k r, a)] -> [(Reference k r, a)]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (a -> Bool
p (a -> Bool)
-> ((Reference k r, a) -> a) -> (Reference k r, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reference k r, a) -> a
forall a b. (a, b) -> b
snd) [(Reference k r, a)]
ras)

reverseLookup :: (a -> Bool) -> RefEnv k a r -> [Reference k r]
reverseLookup :: forall a k (r :: * -> *).
(a -> Bool) -> RefEnv k a r -> [Reference k r]
reverseLookup a -> Bool
p = RefEnv k a r -> [Reference k r]
forall k a (r :: * -> *). RefEnv k a r -> [Reference k r]
keys (RefEnv k a r -> [Reference k r])
-> (RefEnv k a r -> RefEnv k a r)
-> RefEnv k a r
-> [Reference k r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> RefEnv k a r -> RefEnv k a r
forall a k (r :: * -> *).
(a -> Bool) -> RefEnv k a r -> RefEnv k a r
filter a -> Bool
p