module Test.QuickCheck.StateModel.Lockstep.Op.SumProd (Op(..), intOpId) where

import Control.Monad ((<=<))
import Control.Monad.Reader (ReaderT)
import Control.Monad.State (StateT)
import GHC.Show (appPrec)

import Test.QuickCheck.StateModel.Lockstep.Op

{-------------------------------------------------------------------------------
  Example (but very useful) 'Operation' example

  Because this is designed for testing where we want everything to be 'Show'able
  and 'Typeable', matching on 'Op' might reveal some additonal constrants.
  This is useful in 'OpComp' where we have an existential variable (@b@), but
  it's also useful for example in 'OpRight': the caller might have a constraint
  @Show (Either a b)@, but that doesn't give them a way to obtain a constraint
  @Show a@; the implication only goes one way.

  (These are the same constraints that 'Any' imposes.)
-------------------------------------------------------------------------------}

-- | Operations with support for products (pairs) and sums ('Either')
data Op a b where
  OpId    :: Op a a
  OpFst   :: Op (a, b) a
  OpSnd   :: Op (b, a) a
  OpLeft  :: Op (Either a b) a
  OpRight :: Op (Either b a) a
  OpComp  :: Op b c -> Op a b -> Op a c

intOpId :: Op a b -> a -> Maybe b
intOpId :: forall a b. Op a b -> a -> Maybe b
intOpId Op a b
OpId         = a -> Maybe a
a -> Maybe b
forall a. a -> Maybe a
Just
intOpId Op a b
OpFst        = b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b) -> (a -> b) -> a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
(b, b) -> b
forall a b. (a, b) -> a
fst
intOpId Op a b
OpSnd        = b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b) -> (a -> b) -> a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
(b, b) -> b
forall a b. (a, b) -> b
snd
intOpId Op a b
OpLeft       = (b -> Maybe b) -> (b -> Maybe b) -> Either b b -> Maybe b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> Maybe b
forall a. a -> Maybe a
Just (Maybe b -> b -> Maybe b
forall a b. a -> b -> a
const Maybe b
forall a. Maybe a
Nothing)
intOpId Op a b
OpRight      = (b -> Maybe b) -> (b -> Maybe b) -> Either b b -> Maybe b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe b -> b -> Maybe b
forall a b. a -> b -> a
const Maybe b
forall a. Maybe a
Nothing) b -> Maybe b
forall a. a -> Maybe a
Just
intOpId (OpComp Op b b
g Op a b
f) = Op b b -> b -> Maybe b
forall a b. Op a b -> a -> Maybe b
intOpId Op b b
g (b -> Maybe b) -> (a -> Maybe b) -> a -> Maybe b
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Op a b -> a -> Maybe b
forall a b. Op a b -> a -> Maybe b
intOpId Op a b
f

{-------------------------------------------------------------------------------
  'InterpretOp' instances
-------------------------------------------------------------------------------}

instance Operation Op where
  opIdentity :: forall a. Op a a
opIdentity = Op a a
forall a. Op a a
OpId

instance InterpretOp Op (WrapRealized IO) where
  intOp :: forall a b.
Op a b -> WrapRealized IO a -> Maybe (WrapRealized IO b)
intOp = (Op a b -> a -> Maybe b)
-> Op a b -> WrapRealized IO a -> Maybe (WrapRealized IO b)
forall (m :: * -> *) a b (op :: * -> * -> *).
(Realized m a ~ a, Realized m b ~ b) =>
(op a b -> a -> Maybe b)
-> op a b -> WrapRealized m a -> Maybe (WrapRealized m b)
intOpRealizedId Op a b -> a -> Maybe b
forall a b. Op a b -> a -> Maybe b
intOpId

instance InterpretOp Op (WrapRealized m)
      => InterpretOp Op (WrapRealized (StateT s m)) where
  intOp :: forall a b.
Op a b
-> WrapRealized (StateT s m) a
-> Maybe (WrapRealized (StateT s m) b)
intOp = Op a b
-> WrapRealized (StateT s m) a
-> Maybe (WrapRealized (StateT s m) b)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b
       (op :: * -> * -> *).
(Realized (t m) a ~ Realized m a, Realized (t m) b ~ Realized m b,
 InterpretOp op (WrapRealized m)) =>
op a b -> WrapRealized (t m) a -> Maybe (WrapRealized (t m) b)
intOpTransformer

instance InterpretOp Op (WrapRealized m)
      => InterpretOp Op (WrapRealized (ReaderT r m)) where
  intOp :: forall a b.
Op a b
-> WrapRealized (ReaderT r m) a
-> Maybe (WrapRealized (ReaderT r m) b)
intOp = Op a b
-> WrapRealized (ReaderT r m) a
-> Maybe (WrapRealized (ReaderT r m) b)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b
       (op :: * -> * -> *).
(Realized (t m) a ~ Realized m a, Realized (t m) b ~ Realized m b,
 InterpretOp op (WrapRealized m)) =>
op a b -> WrapRealized (t m) a -> Maybe (WrapRealized (t m) b)
intOpTransformer

{-------------------------------------------------------------------------------
  'Show' and 'Eq' instances
-------------------------------------------------------------------------------}

sameOp :: Op a b -> Op c d -> Bool
sameOp :: forall a b c d. Op a b -> Op c d -> Bool
sameOp = Op a b -> Op c d -> Bool
forall a b c d. Op a b -> Op c d -> Bool
go
  where
    go :: Op a b -> Op c d -> Bool
    go :: forall a b c d. Op a b -> Op c d -> Bool
go Op a b
OpId         Op c d
OpId           = Bool
True
    go Op a b
OpFst        Op c d
OpFst          = Bool
True
    go Op a b
OpSnd        Op c d
OpSnd          = Bool
True
    go Op a b
OpLeft       Op c d
OpLeft         = Bool
True
    go Op a b
OpRight      Op c d
OpRight        = Bool
True
    go (OpComp Op b b
g Op a b
f) (OpComp Op b d
g' Op c b
f') = Op b b -> Op b d -> Bool
forall a b c d. Op a b -> Op c d -> Bool
go Op b b
g Op b d
g' Bool -> Bool -> Bool
&& Op a b -> Op c b -> Bool
forall a b c d. Op a b -> Op c d -> Bool
go Op a b
f Op c b
f'
    go Op a b
_            Op c d
_              = Bool
False

    _coveredAllCases :: Op a b -> ()
    _coveredAllCases :: forall a b. Op a b -> ()
_coveredAllCases = \case
        Op a b
OpId    -> ()
        Op a b
OpFst   -> ()
        Op a b
OpSnd   -> ()
        Op a b
OpLeft  -> ()
        Op a b
OpRight -> ()
        OpComp{} -> ()

instance Eq (Op a b)  where
  == :: Op a b -> Op a b -> Bool
(==) = Op a b -> Op a b -> Bool
forall a b c d. Op a b -> Op c d -> Bool
sameOp

instance Show (Op a b) where
  showsPrec :: Int -> Op a b -> ShowS
showsPrec Int
p = \Op a b
op -> case Op a b
op of
      OpComp{} -> Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
appPrec) (Op a b -> ShowS
forall x y. Op x y -> ShowS
go Op a b
op)
      Op a b
_        -> Op a b -> ShowS
forall x y. Op x y -> ShowS
go Op a b
op
    where
      go :: Op x y -> String -> String
      go :: forall x y. Op x y -> ShowS
go Op x y
OpId         = String -> ShowS
showString String
"OpId"
      go Op x y
OpFst        = String -> ShowS
showString String
"OpFst"
      go Op x y
OpSnd        = String -> ShowS
showString String
"OpSnd"
      go Op x y
OpLeft       = String -> ShowS
showString String
"OpLeft"
      go Op x y
OpRight      = String -> ShowS
showString String
"OpRight"
      go (OpComp Op b y
g Op x b
f) = Op b y -> ShowS
forall x y. Op x y -> ShowS
go Op b y
g ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" `OpComp` " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Op x b -> ShowS
forall x y. Op x y -> ShowS
go Op x b
f