{-# LANGUAGE CPP #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}

-- | Common definitions for MultiGST.Strict and MultiGST.Lazy
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"
  -- ghc is too stupid to acknowledge that the constraint cannot be fulfilled..

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"
  -- ghc is too stupid to acknowledge that the constraint cannot be fulfilled..

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