References.hs

{-# 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   (Eq, Ord, Show, Generic, Read)
  deriving newtype (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 _ _ p (Symbolic x) =
    showParen (p > appPrec) $
      showString "Symbolic " .
      showsPrec (appPrec + 1) x
    where
      appPrec = 10

instance ToExpr a => ToExpr (Symbolic a) where
  toExpr (Symbolic x) = toExpr x

instance Eq1 Symbolic where
  liftEq _ (Symbolic x) (Symbolic y) = x == y

instance Ord1 Symbolic where
  liftCompare _ (Symbolic x) (Symbolic y) = compare x y

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

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

instance Show1 Concrete where
  liftShowsPrec sp _ p (Concrete x) =
    showParen (p > appPrec) $
      showString "Concrete " .
      sp (appPrec + 1) x
    where
      appPrec = 10

deriving instance Eq a => Eq (Concrete a)

instance Eq1 Concrete where
  liftEq eq (Concrete x) (Concrete y) = eq x y

deriving instance Ord a => Ord (Concrete a)

instance Ord1 Concrete where
  liftCompare comp (Concrete x) (Concrete y) = comp x y

instance ToExpr a => ToExpr (Concrete a) where
  toExpr (Concrete x) = toExpr x

newtype Reference a r = Reference (r a)
  deriving stock 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 f (Reference r) = Reference (f r)

instance Rank2.Foldable (Reference a) where
  foldMap f (Reference r) = f r

instance Rank2.Traversable (Reference a) where
  traverse f (Reference r) = Reference <$> f r

instance (Eq a, Eq1 r) => Eq (Reference a r) where
  Reference x == Reference y = eq1 x y

instance (Ord a, Ord1 r) => Ord (Reference a r) where
  compare (Reference x) (Reference y) = compare1 x y

instance (Show1 r, Show a) => Show (Reference a r) where
  showsPrec p (Reference v) = showParen (p > appPrec) $
      showString "Reference " .
      showsPrec1 p v
    where
      appPrec = 10

reference :: Typeable a => a -> Reference a Concrete
reference = Reference . Concrete

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

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

newtype Opaque a = Opaque
  { unOpaque :: a }
  deriving stock (Eq, Ord)

instance Show (Opaque a) where
  showsPrec _ (Opaque _) = showString "Opaque"

instance ToExpr (Opaque a) where
  toExpr _ = App "Opaque" []