{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving         #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Test.StateMachine.Types.References
-- Copyright   :  (C) 2017, Jacob Stanley
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk>
-- Stability   :  provisional
-- Portability :  non-portable (GHC extensions)
--
-- This module contains reference related types. It's taken almost verbatim from
-- the Hedgehog <https://hackage.haskell.org/package/hedgehog library>.
--
-----------------------------------------------------------------------------

module Test.StateMachine.Types.References
  ( Var(Var)
  , Symbolic(Symbolic)
  , Concrete(Concrete)
  , Reference(Reference)
  , reference
  , concrete
  , opaque
  , Opaque(Opaque)
  , unOpaque
  )
  where

import           Data.Functor.Classes
                   (Eq1, Ord1, Show1, compare1, eq1, liftCompare,
                   liftEq, liftShowsPrec, showsPrec1)
import           Data.TreeDiff
                   (Expr(App), ToExpr, toExpr)
import           Data.Typeable
                   (Typeable)
import           GHC.Generics
                   (Generic)
import           Prelude

import qualified Test.StateMachine.Types.Rank2 as Rank2

------------------------------------------------------------------------

newtype Var = Var Int
  deriving stock   (Var -> Var -> Bool
(Var -> Var -> Bool) -> (Var -> Var -> Bool) -> Eq Var
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Var -> Var -> Bool
$c/= :: Var -> Var -> Bool
== :: Var -> Var -> Bool
$c== :: Var -> Var -> Bool
Eq, Eq Var
Eq Var
-> (Var -> Var -> Ordering)
-> (Var -> Var -> Bool)
-> (Var -> Var -> Bool)
-> (Var -> Var -> Bool)
-> (Var -> Var -> Bool)
-> (Var -> Var -> Var)
-> (Var -> Var -> Var)
-> Ord Var
Var -> Var -> Bool
Var -> Var -> Ordering
Var -> Var -> Var
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Var -> Var -> Var
$cmin :: Var -> Var -> Var
max :: Var -> Var -> Var
$cmax :: Var -> Var -> Var
>= :: Var -> Var -> Bool
$c>= :: Var -> Var -> Bool
> :: Var -> Var -> Bool
$c> :: Var -> Var -> Bool
<= :: Var -> Var -> Bool
$c<= :: Var -> Var -> Bool
< :: Var -> Var -> Bool
$c< :: Var -> Var -> Bool
compare :: Var -> Var -> Ordering
$ccompare :: Var -> Var -> Ordering
$cp1Ord :: Eq Var
Ord, Int -> Var -> ShowS
[Var] -> ShowS
Var -> String
(Int -> Var -> ShowS)
-> (Var -> String) -> ([Var] -> ShowS) -> Show Var
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Var] -> ShowS
$cshowList :: [Var] -> ShowS
show :: Var -> String
$cshow :: Var -> String
showsPrec :: Int -> Var -> ShowS
$cshowsPrec :: Int -> Var -> ShowS
Show, (forall x. Var -> Rep Var x)
-> (forall x. Rep Var x -> Var) -> Generic Var
forall x. Rep Var x -> Var
forall x. Var -> Rep Var x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Var x -> Var
$cfrom :: forall x. Var -> Rep Var x
Generic, ReadPrec [Var]
ReadPrec Var
Int -> ReadS Var
ReadS [Var]
(Int -> ReadS Var)
-> ReadS [Var] -> ReadPrec Var -> ReadPrec [Var] -> Read Var
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Var]
$creadListPrec :: ReadPrec [Var]
readPrec :: ReadPrec Var
$creadPrec :: ReadPrec Var
readList :: ReadS [Var]
$creadList :: ReadS [Var]
readsPrec :: Int -> ReadS Var
$creadsPrec :: Int -> ReadS Var
Read)
  deriving newtype ([Var] -> Expr
Var -> Expr
(Var -> Expr) -> ([Var] -> Expr) -> ToExpr Var
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
listToExpr :: [Var] -> Expr
$clistToExpr :: [Var] -> Expr
toExpr :: Var -> Expr
$ctoExpr :: Var -> Expr
ToExpr)

data Symbolic a where
  Symbolic :: Typeable a => Var -> Symbolic a

deriving stock instance Show (Symbolic a)
deriving stock instance Typeable a => Read (Symbolic a)
deriving stock instance Eq   (Symbolic a)
deriving stock instance Ord  (Symbolic a)

instance Show1 Symbolic where
  liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Symbolic a -> ShowS
liftShowsPrec Int -> a -> ShowS
_ [a] -> ShowS
_ Int
p (Symbolic Var
x) =
    Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
appPrec) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"Symbolic " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Int -> Var -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
appPrec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Var
x
    where
      appPrec :: Int
appPrec = Int
10

instance ToExpr a => ToExpr (Symbolic a) where
  toExpr :: Symbolic a -> Expr
toExpr (Symbolic Var
x) = Var -> Expr
forall a. ToExpr a => a -> Expr
toExpr Var
x

instance Eq1 Symbolic where
  liftEq :: (a -> b -> Bool) -> Symbolic a -> Symbolic b -> Bool
liftEq a -> b -> Bool
_ (Symbolic Var
x) (Symbolic Var
y) = Var
x Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
y

instance Ord1 Symbolic where
  liftCompare :: (a -> b -> Ordering) -> Symbolic a -> Symbolic b -> Ordering
liftCompare a -> b -> Ordering
_ (Symbolic Var
x) (Symbolic Var
y) = Var -> Var -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Var
x Var
y

data Concrete a where
  Concrete :: Typeable a => a -> Concrete a

deriving stock instance Show a => Show (Concrete a)

instance Show1 Concrete where
  liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Concrete a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
_ Int
p (Concrete a
x) =
    Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
appPrec) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"Concrete " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Int -> a -> ShowS
sp (Int
appPrec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) a
x
    where
      appPrec :: Int
appPrec = Int
10

instance Eq1 Concrete where
  liftEq :: (a -> b -> Bool) -> Concrete a -> Concrete b -> Bool
liftEq a -> b -> Bool
eq (Concrete a
x) (Concrete b
y) = a -> b -> Bool
eq a
x b
y

instance Ord1 Concrete where
  liftCompare :: (a -> b -> Ordering) -> Concrete a -> Concrete b -> Ordering
liftCompare a -> b -> Ordering
comp (Concrete a
x) (Concrete b
y) = a -> b -> Ordering
comp a
x b
y

instance ToExpr a => ToExpr (Concrete a) where
  toExpr :: Concrete a -> Expr
toExpr (Concrete a
x) = a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
x

newtype Reference a r = Reference (r a)
  deriving stock (forall x. Reference a r -> Rep (Reference a r) x)
-> (forall x. Rep (Reference a r) x -> Reference a r)
-> Generic (Reference a r)
forall x. Rep (Reference a r) x -> Reference a r
forall x. Reference a r -> Rep (Reference a r) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a (r :: * -> *) x. Rep (Reference a r) x -> Reference a r
forall a (r :: * -> *) x. Reference a r -> Rep (Reference a r) x
$cto :: forall a (r :: * -> *) x. Rep (Reference a r) x -> Reference a r
$cfrom :: forall a (r :: * -> *) x. Reference a r -> Rep (Reference a r) x
Generic

deriving stock instance Typeable a => Read (Reference a Symbolic)

instance ToExpr (r a) => ToExpr (Reference a r)

instance Rank2.Functor (Reference a) where
  fmap :: (forall x. p x -> q x) -> Reference a p -> Reference a q
fmap forall x. p x -> q x
f (Reference p a
r) = q a -> Reference a q
forall a (r :: * -> *). r a -> Reference a r
Reference (p a -> q a
forall x. p x -> q x
f p a
r)

instance Rank2.Foldable (Reference a) where
  foldMap :: (forall x. p x -> m) -> Reference a p -> m
foldMap forall x. p x -> m
f (Reference p a
r) = p a -> m
forall x. p x -> m
f p a
r

instance Rank2.Traversable (Reference a) where
  traverse :: (forall a. p a -> f (q a)) -> Reference a p -> f (Reference a q)
traverse forall a. p a -> f (q a)
f (Reference p a
r) = q a -> Reference a q
forall a (r :: * -> *). r a -> Reference a r
Reference (q a -> Reference a q) -> f (q a) -> f (Reference a q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p a -> f (q a)
forall a. p a -> f (q a)
f p a
r

instance (Eq a, Eq1 r) => Eq (Reference a r) where
  Reference r a
x == :: Reference a r -> Reference a r -> Bool
== Reference r a
y = r a -> r a -> Bool
forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1 r a
x r a
y

instance (Ord a, Ord1 r) => Ord (Reference a r) where
  compare :: Reference a r -> Reference a r -> Ordering
compare (Reference r a
x) (Reference r a
y) = r a -> r a -> Ordering
forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1 r a
x r a
y

instance (Show1 r, Show a) => Show (Reference a r) where
  showsPrec :: Int -> Reference a r -> ShowS
showsPrec Int
p (Reference r a
v) = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
appPrec) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"Reference " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Int -> r a -> ShowS
forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1 Int
p r a
v
    where
      appPrec :: Int
appPrec = Int
10

reference :: Typeable a => a -> Reference a Concrete
reference :: a -> Reference a Concrete
reference = Concrete a -> Reference a Concrete
forall a (r :: * -> *). r a -> Reference a r
Reference (Concrete a -> Reference a Concrete)
-> (a -> Concrete a) -> a -> Reference a Concrete
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Concrete a
forall a. Typeable a => a -> Concrete a
Concrete

concrete :: Reference a Concrete -> a
concrete :: Reference a Concrete -> a
concrete (Reference (Concrete a
x)) = a
x

opaque :: Reference (Opaque a) Concrete -> a
opaque :: Reference (Opaque a) Concrete -> a
opaque (Reference (Concrete (Opaque a
x))) = a
x

newtype Opaque a = Opaque
  { Opaque a -> a
unOpaque :: a }
  deriving stock (Opaque a -> Opaque a -> Bool
(Opaque a -> Opaque a -> Bool)
-> (Opaque a -> Opaque a -> Bool) -> Eq (Opaque a)
forall a. Eq a => Opaque a -> Opaque a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Opaque a -> Opaque a -> Bool
$c/= :: forall a. Eq a => Opaque a -> Opaque a -> Bool
== :: Opaque a -> Opaque a -> Bool
$c== :: forall a. Eq a => Opaque a -> Opaque a -> Bool
Eq, Eq (Opaque a)
Eq (Opaque a)
-> (Opaque a -> Opaque a -> Ordering)
-> (Opaque a -> Opaque a -> Bool)
-> (Opaque a -> Opaque a -> Bool)
-> (Opaque a -> Opaque a -> Bool)
-> (Opaque a -> Opaque a -> Bool)
-> (Opaque a -> Opaque a -> Opaque a)
-> (Opaque a -> Opaque a -> Opaque a)
-> Ord (Opaque a)
Opaque a -> Opaque a -> Bool
Opaque a -> Opaque a -> Ordering
Opaque a -> Opaque a -> Opaque a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Opaque a)
forall a. Ord a => Opaque a -> Opaque a -> Bool
forall a. Ord a => Opaque a -> Opaque a -> Ordering
forall a. Ord a => Opaque a -> Opaque a -> Opaque a
min :: Opaque a -> Opaque a -> Opaque a
$cmin :: forall a. Ord a => Opaque a -> Opaque a -> Opaque a
max :: Opaque a -> Opaque a -> Opaque a
$cmax :: forall a. Ord a => Opaque a -> Opaque a -> Opaque a
>= :: Opaque a -> Opaque a -> Bool
$c>= :: forall a. Ord a => Opaque a -> Opaque a -> Bool
> :: Opaque a -> Opaque a -> Bool
$c> :: forall a. Ord a => Opaque a -> Opaque a -> Bool
<= :: Opaque a -> Opaque a -> Bool
$c<= :: forall a. Ord a => Opaque a -> Opaque a -> Bool
< :: Opaque a -> Opaque a -> Bool
$c< :: forall a. Ord a => Opaque a -> Opaque a -> Bool
compare :: Opaque a -> Opaque a -> Ordering
$ccompare :: forall a. Ord a => Opaque a -> Opaque a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Opaque a)
Ord)

instance Show (Opaque a) where
  showsPrec :: Int -> Opaque a -> ShowS
showsPrec Int
_ (Opaque a
_) = String -> ShowS
showString String
"Opaque"

instance ToExpr (Opaque a) where
  toExpr :: Opaque a -> Expr
toExpr Opaque a
_ = String -> [Expr] -> Expr
App String
"Opaque" []