{-# LANGUAGE CPP #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
module Control.Monad.Trans.MultiGST.Common
( HListM(..)
, CanReadWrite(..)
, CanReadWriteFlag(..)
, HListMContainsImplication
, HListMContains(..)
, ContainsReader
, ContainsState
, ContainsWriter
, CanWriteConstraint
, AppendM
, HListMReaders
, AppendMReaders
, HListMGettableClass(..)
)
where
import Data.Kind (Type)
import Data.Semigroup
import qualified Data.HList.HList as HList
import Control.Monad.Trans.MultiReader.Class
import Control.Monad.Trans.MultiWriter.Class
import Control.Monad.Trans.MultiState.Class
import GHC.Exts (Constraint)
data CanReadWrite a
= Gettable a
| Settable a
| Tellable a
data CanReadWriteFlag
= GettableFlag
| SettableFlag
| TellableFlag
type family HListMContainsImplication (can :: CanReadWriteFlag) t cts :: Constraint where
HListMContainsImplication 'GettableFlag t cts = ()
HListMContainsImplication 'TellableFlag t cts = ()
HListMContainsImplication 'SettableFlag t cts = HListMContains 'GettableFlag t cts
class HListMContainsImplication can t cts => HListMContains (can :: CanReadWriteFlag) t cts where
readHListMElem :: HListM cts -> t
writeHListMElem :: CanWriteConstraint can => t -> HListM cts -> HListM cts
type ContainsReader = HListMContains 'GettableFlag
type ContainsState = HListMContains 'SettableFlag
type ContainsWriter = HListMContains 'TellableFlag
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HListMContains 'GettableFlag x ('Gettable x ': tr) where
readHListMElem :: HListM ('Gettable x : tr) -> x
readHListMElem (x
x :+-: HListM xr
_) = x
x
x
writeHListMElem :: x -> HListM ('Gettable x : tr) -> HListM ('Gettable x : tr)
writeHListMElem = [Char]
-> x -> HListM ('Gettable x : tr) -> HListM ('Gettable x : tr)
forall a. HasCallStack => [Char] -> a
error [Char]
"writeHListMElem CanRead"
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HListMContains 'GettableFlag x ('Settable x ': tr) where
readHListMElem :: HListM ('Settable x : tr) -> x
readHListMElem (x
x :++: HListM xr
_) = x
x
x
writeHListMElem :: x -> HListM ('Settable x : tr) -> HListM ('Settable x : tr)
writeHListMElem = [Char]
-> x -> HListM ('Settable x : tr) -> HListM ('Settable x : tr)
forall a. HasCallStack => [Char] -> a
error [Char]
"writeHListMElem CanRead"
instance HListMContains 'GettableFlag x ts => HListMContains 'GettableFlag x (t ': ts) where
readHListMElem :: HListM (t : ts) -> x
readHListMElem (x
_ :+-: HListM xr
xr) = HListM xr -> x
forall (can :: CanReadWriteFlag) t (cts :: [CanReadWrite *]).
HListMContains can t cts =>
HListM cts -> t
readHListMElem @'GettableFlag HListM xr
xr
readHListMElem (x
_ :-+: HListM xr
xr) = HListM xr -> x
forall (can :: CanReadWriteFlag) t (cts :: [CanReadWrite *]).
HListMContains can t cts =>
HListM cts -> t
readHListMElem @'GettableFlag HListM xr
xr
readHListMElem (x
_ :++: HListM xr
xr) = HListM xr -> x
forall (can :: CanReadWriteFlag) t (cts :: [CanReadWrite *]).
HListMContains can t cts =>
HListM cts -> t
readHListMElem @'GettableFlag HListM xr
xr
writeHListMElem :: x -> HListM (t : ts) -> HListM (t : ts)
writeHListMElem = [Char] -> x -> HListM (t : ts) -> HListM (t : ts)
forall a. HasCallStack => [Char] -> a
error [Char]
"writeHListMElem CanRead"
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HListMContains 'TellableFlag x ('Tellable x ': tr) where
readHListMElem :: HListM ('Tellable x : tr) -> x
readHListMElem (x
x :-+: HListM xr
_) = x
x
x
writeHListMElem :: x -> HListM ('Tellable x : tr) -> HListM ('Tellable x : tr)
writeHListMElem x
x HListM ('Tellable x : tr)
ts = case HListM ('Tellable x : tr)
ts of (x
_ :-+: HListM xr
tr) -> x
x x -> HListM xr -> HListM ('Tellable x : xr)
forall xr (xr :: [CanReadWrite *]).
xr -> HListM xr -> HListM ('Tellable xr : xr)
:-+: HListM xr
tr
instance HListMContains 'TellableFlag x ts => HListMContains 'TellableFlag x (t ': ts) where
readHListMElem :: HListM (t : ts) -> x
readHListMElem (x
_ :+-: HListM xr
xr) = HListM xr -> x
forall (can :: CanReadWriteFlag) t (cts :: [CanReadWrite *]).
HListMContains can t cts =>
HListM cts -> t
readHListMElem @'TellableFlag HListM xr
xr
readHListMElem (x
_ :-+: HListM xr
xr) = HListM xr -> x
forall (can :: CanReadWriteFlag) t (cts :: [CanReadWrite *]).
HListMContains can t cts =>
HListM cts -> t
readHListMElem @'TellableFlag HListM xr
xr
readHListMElem (x
_ :++: HListM xr
xr) = HListM xr -> x
forall (can :: CanReadWriteFlag) t (cts :: [CanReadWrite *]).
HListMContains can t cts =>
HListM cts -> t
readHListMElem @'TellableFlag HListM xr
xr
writeHListMElem :: x -> HListM (t : ts) -> HListM (t : ts)
writeHListMElem x
x (x
t :+-: HListM xr
tr) = x
t x -> HListM xr -> HListM ('Gettable x : xr)
forall x (x :: [CanReadWrite *]).
x -> HListM x -> HListM ('Gettable x : x)
:+-: x -> HListM xr -> HListM xr
forall (can :: CanReadWriteFlag) t (cts :: [CanReadWrite *]).
(HListMContains can t cts, CanWriteConstraint can) =>
t -> HListM cts -> HListM cts
writeHListMElem @'TellableFlag x
x HListM xr
tr
writeHListMElem x
x (x
t :-+: HListM xr
tr) = x
t x -> HListM xr -> HListM ('Tellable x : xr)
forall xr (xr :: [CanReadWrite *]).
xr -> HListM xr -> HListM ('Tellable xr : xr)
:-+: x -> HListM xr -> HListM xr
forall (can :: CanReadWriteFlag) t (cts :: [CanReadWrite *]).
(HListMContains can t cts, CanWriteConstraint can) =>
t -> HListM cts -> HListM cts
writeHListMElem @'TellableFlag x
x HListM xr
tr
writeHListMElem x
x (x
t :++: HListM xr
tr) = x
t x -> HListM xr -> HListM ('Settable x : xr)
forall x (xr :: [CanReadWrite *]).
x -> HListM xr -> HListM ('Settable x : xr)
:++: x -> HListM xr -> HListM xr
forall (can :: CanReadWriteFlag) t (cts :: [CanReadWrite *]).
(HListMContains can t cts, CanWriteConstraint can) =>
t -> HListM cts -> HListM cts
writeHListMElem @'TellableFlag x
x HListM xr
tr
instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#endif
HListMContains 'GettableFlag x ('Settable x ': tr)
=> HListMContains 'SettableFlag x ('Settable x ': tr) where
readHListMElem :: HListM ('Settable x : tr) -> x
readHListMElem (x
x :++: HListM xr
_) = x
x
x
writeHListMElem :: x -> HListM ('Settable x : tr) -> HListM ('Settable x : tr)
writeHListMElem x
x HListM ('Settable x : tr)
ts = case HListM ('Settable x : tr)
ts of (x
_ :++: HListM xr
tr) -> x
x x -> HListM xr -> HListM ('Settable x : xr)
forall x (xr :: [CanReadWrite *]).
x -> HListM xr -> HListM ('Settable x : xr)
:++: HListM xr
tr
instance HListMContains 'SettableFlag x ts => HListMContains 'SettableFlag x (t ': ts) where
readHListMElem :: HListM (t : ts) -> x
readHListMElem (x
_ :+-: HListM xr
xr) = HListM xr -> x
forall (can :: CanReadWriteFlag) t (cts :: [CanReadWrite *]).
HListMContains can t cts =>
HListM cts -> t
readHListMElem @'SettableFlag HListM xr
xr
readHListMElem (x
_ :-+: HListM xr
xr) = HListM xr -> x
forall (can :: CanReadWriteFlag) t (cts :: [CanReadWrite *]).
HListMContains can t cts =>
HListM cts -> t
readHListMElem @'SettableFlag HListM xr
xr
readHListMElem (x
_ :++: HListM xr
xr) = HListM xr -> x
forall (can :: CanReadWriteFlag) t (cts :: [CanReadWrite *]).
HListMContains can t cts =>
HListM cts -> t
readHListMElem @'SettableFlag HListM xr
xr
writeHListMElem :: x -> HListM (t : ts) -> HListM (t : ts)
writeHListMElem x
x (x
t :+-: HListM xr
tr) = x
t x -> HListM xr -> HListM ('Gettable x : xr)
forall x (x :: [CanReadWrite *]).
x -> HListM x -> HListM ('Gettable x : x)
:+-: x -> HListM xr -> HListM xr
forall (can :: CanReadWriteFlag) t (cts :: [CanReadWrite *]).
(HListMContains can t cts, CanWriteConstraint can) =>
t -> HListM cts -> HListM cts
writeHListMElem @'SettableFlag x
x HListM xr
tr
writeHListMElem x
x (x
t :-+: HListM xr
tr) = x
t x -> HListM xr -> HListM ('Tellable x : xr)
forall xr (xr :: [CanReadWrite *]).
xr -> HListM xr -> HListM ('Tellable xr : xr)
:-+: x -> HListM xr -> HListM xr
forall (can :: CanReadWriteFlag) t (cts :: [CanReadWrite *]).
(HListMContains can t cts, CanWriteConstraint can) =>
t -> HListM cts -> HListM cts
writeHListMElem @'SettableFlag x
x HListM xr
tr
writeHListMElem x
x (x
t :++: HListM xr
tr) = x
t x -> HListM xr -> HListM ('Settable x : xr)
forall x (xr :: [CanReadWrite *]).
x -> HListM xr -> HListM ('Settable x : xr)
:++: x -> HListM xr -> HListM xr
forall (can :: CanReadWriteFlag) t (cts :: [CanReadWrite *]).
(HListMContains can t cts, CanWriteConstraint can) =>
t -> HListM cts -> HListM cts
writeHListMElem @'SettableFlag x
x HListM xr
tr
type family CanWriteConstraint (f :: CanReadWriteFlag) :: Constraint where
CanWriteConstraint 'TellableFlag = ()
CanWriteConstraint 'SettableFlag = ()
data HListM :: [CanReadWrite Type] -> Type where
HNilM :: HListM '[]
(:+-:) :: x -> HListM xr -> HListM ('Gettable x ': xr)
(:++:) :: x -> HListM xr -> HListM ('Settable x ': xr)
(:-+:) :: x -> HListM xr -> HListM ('Tellable x ': xr)
instance Semigroup (HListM '[]) where
HListM '[]
_ <> :: HListM '[] -> HListM '[] -> HListM '[]
<> HListM '[]
_ = HListM '[]
HNilM
instance Monoid (HListM '[]) where
mempty :: HListM '[]
mempty = HListM '[]
HNilM
mappend :: HListM '[] -> HListM '[] -> HListM '[]
mappend = HListM '[] -> HListM '[] -> HListM '[]
forall a. Semigroup a => a -> a -> a
(<>)
instance Eq (HListM '[]) where
HListM '[]
HNilM == :: HListM '[] -> HListM '[] -> Bool
== HListM '[]
HNilM = Bool
True
HListM '[]
HNilM /= :: HListM '[] -> HListM '[] -> Bool
/= HListM '[]
HNilM = Bool
False
instance (Eq x, Eq (HListM xs))
=> Eq (HListM ('Gettable x ': xs))
where
x
x1 :+-: HListM xr
xr1 == :: HListM ('Gettable x : xs) -> HListM ('Gettable x : xs) -> Bool
== x
x2 :+-: HListM xr
xr2 = x
x1x -> x -> Bool
forall a. Eq a => a -> a -> Bool
==x
x
x2 Bool -> Bool -> Bool
&& HListM xr
xr1HListM xr -> HListM xr -> Bool
forall a. Eq a => a -> a -> Bool
==HListM xr
HListM xr
xr2
x
x1 :+-: HListM xr
xr1 /= :: HListM ('Gettable x : xs) -> HListM ('Gettable x : xs) -> Bool
/= x
x2 :+-: HListM xr
xr2 = x
x1x -> x -> Bool
forall a. Eq a => a -> a -> Bool
/=x
x
x2 Bool -> Bool -> Bool
|| HListM xr
xr1HListM xr -> HListM xr -> Bool
forall a. Eq a => a -> a -> Bool
/=HListM xr
HListM xr
xr2
instance (Eq x, Eq (HListM xs))
=> Eq (HListM ('Tellable x ': xs))
where
x
x1 :-+: HListM xr
xr1 == :: HListM ('Tellable x : xs) -> HListM ('Tellable x : xs) -> Bool
== x
x2 :-+: HListM xr
xr2 = x
x1x -> x -> Bool
forall a. Eq a => a -> a -> Bool
==x
x
x2 Bool -> Bool -> Bool
&& HListM xr
xr1HListM xr -> HListM xr -> Bool
forall a. Eq a => a -> a -> Bool
==HListM xr
HListM xr
xr2
x
x1 :-+: HListM xr
xr1 /= :: HListM ('Tellable x : xs) -> HListM ('Tellable x : xs) -> Bool
/= x
x2 :-+: HListM xr
xr2 = x
x1x -> x -> Bool
forall a. Eq a => a -> a -> Bool
/=x
x
x2 Bool -> Bool -> Bool
|| HListM xr
xr1HListM xr -> HListM xr -> Bool
forall a. Eq a => a -> a -> Bool
/=HListM xr
HListM xr
xr2
instance (Eq x, Eq (HListM xs))
=> Eq (HListM ('Settable x ': xs))
where
x
x1 :++: HListM xr
xr1 == :: HListM ('Settable x : xs) -> HListM ('Settable x : xs) -> Bool
== x
x2 :++: HListM xr
xr2 = x
x1x -> x -> Bool
forall a. Eq a => a -> a -> Bool
==x
x
x2 Bool -> Bool -> Bool
&& HListM xr
xr1HListM xr -> HListM xr -> Bool
forall a. Eq a => a -> a -> Bool
==HListM xr
HListM xr
xr2
x
x1 :++: HListM xr
xr1 /= :: HListM ('Settable x : xs) -> HListM ('Settable x : xs) -> Bool
/= x
x2 :++: HListM xr
xr2 = x
x1x -> x -> Bool
forall a. Eq a => a -> a -> Bool
/=x
x
x2 Bool -> Bool -> Bool
|| HListM xr
xr1HListM xr -> HListM xr -> Bool
forall a. Eq a => a -> a -> Bool
/=HListM xr
HListM xr
xr2
type family AppendM (l1 :: [CanReadWrite Type]) (l2 :: [CanReadWrite Type]) :: [CanReadWrite Type] where
AppendM '[] l2 = l2
AppendM (car1 ': cdr2) l2 = car1 ': AppendM cdr2 l2
type family HListMReaders (l :: [Type]) :: [CanReadWrite Type] where
HListMReaders '[] = '[]
HListMReaders (t ': tr) = 'Gettable t ': HListMReaders tr
type family AppendMReaders (l1 :: [Type]) (l2 :: [CanReadWrite Type]) :: [CanReadWrite Type] where
AppendMReaders '[] l2 = l2
AppendMReaders (t ': tr) l2 = 'Gettable t ': AppendMReaders tr l2
class HListMGettableClass ts where
type HListMGettableOnly ts :: [Type]
hListMGettableOnly :: HListM ts -> HList.HList (HListMGettableOnly ts)
instance HListMGettableClass '[] where
type HListMGettableOnly '[] = '[]
hListMGettableOnly :: HListM '[] -> HList (HListMGettableOnly '[])
hListMGettableOnly HListM '[]
HNilM = HList '[]
HList (HListMGettableOnly '[])
HList.HNil
instance HListMGettableClass tr => HListMGettableClass ('Gettable t ': tr) where
type HListMGettableOnly ('Gettable t ': tr) = (t ': HListMGettableOnly tr)
hListMGettableOnly :: HListM ('Gettable t : tr)
-> HList (HListMGettableOnly ('Gettable t : tr))
hListMGettableOnly (x
t :+-: HListM xr
tr) = x
t x
-> HList (HListMGettableOnly tr)
-> HList (x : HListMGettableOnly tr)
forall x (xs :: [*]). x -> HList xs -> HList (x : xs)
HList.:+: HListM xr -> HList (HListMGettableOnly xr)
forall (ts :: [CanReadWrite *]).
HListMGettableClass ts =>
HListM ts -> HList (HListMGettableOnly ts)
hListMGettableOnly HListM xr
tr
instance HListMGettableClass tr => HListMGettableClass ('Settable t ': tr) where
type HListMGettableOnly ('Settable t ': tr) = HListMGettableOnly tr
hListMGettableOnly :: HListM ('Settable t : tr)
-> HList (HListMGettableOnly ('Settable t : tr))
hListMGettableOnly (x
_ :++: HListM xr
tr) = HListM xr -> HList (HListMGettableOnly xr)
forall (ts :: [CanReadWrite *]).
HListMGettableClass ts =>
HListM ts -> HList (HListMGettableOnly ts)
hListMGettableOnly HListM xr
tr
instance HListMGettableClass tr => HListMGettableClass ('Tellable t ': tr) where
type HListMGettableOnly ('Tellable t ': tr) = HListMGettableOnly tr
hListMGettableOnly :: HListM ('Tellable t : tr)
-> HList (HListMGettableOnly ('Tellable t : tr))
hListMGettableOnly (x
_ :-+: HListM xr
tr) = HListM xr -> HList (HListMGettableOnly xr)
forall (ts :: [CanReadWrite *]).
HListMGettableClass ts =>
HListM ts -> HList (HListMGettableOnly ts)
hListMGettableOnly HListM xr
tr