{-# 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           Prelude hiding (filter, lookup, null)
import qualified Prelude
import           Test.StateMachine (Reference)
import qualified Test.StateMachine.Types.Rank2 as Rank2
import           Test.Util.ToExpr ()

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