{-|
Stability: experimental

This module is experimental, and its API might change between point releases. Use at your own risk.
-}

{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}

module Apecs.Experimental.Stores
  ( Pushdown(..), Stack(..)
  ) where

import Control.Monad.Reader
import Data.Proxy
import Data.Semigroup

import Apecs.Components (MaybeStore (..))
import Apecs.Core

-- | Overrides a store to have history/pushdown semantics.
--   Setting this store adds a new value on top of the stack.
--   Destroying pops the stack.
--   You can view the entire stack using the 'Stack' wrapper.
newtype Pushdown s c = Pushdown (s (Stack c))
newtype Stack c = Stack {forall c. Stack c -> [c]
getStack :: [c]} deriving (Stack c -> Stack c -> Bool
(Stack c -> Stack c -> Bool)
-> (Stack c -> Stack c -> Bool) -> Eq (Stack c)
forall c. Eq c => Stack c -> Stack c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall c. Eq c => Stack c -> Stack c -> Bool
== :: Stack c -> Stack c -> Bool
$c/= :: forall c. Eq c => Stack c -> Stack c -> Bool
/= :: Stack c -> Stack c -> Bool
Eq, Int -> Stack c -> ShowS
[Stack c] -> ShowS
Stack c -> String
(Int -> Stack c -> ShowS)
-> (Stack c -> String) -> ([Stack c] -> ShowS) -> Show (Stack c)
forall c. Show c => Int -> Stack c -> ShowS
forall c. Show c => [Stack c] -> ShowS
forall c. Show c => Stack c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall c. Show c => Int -> Stack c -> ShowS
showsPrec :: Int -> Stack c -> ShowS
$cshow :: forall c. Show c => Stack c -> String
show :: Stack c -> String
$cshowList :: forall c. Show c => [Stack c] -> ShowS
showList :: [Stack c] -> ShowS
Show, (forall a b. (a -> b) -> Stack a -> Stack b)
-> (forall a b. a -> Stack b -> Stack a) -> Functor Stack
forall a b. a -> Stack b -> Stack a
forall a b. (a -> b) -> Stack a -> Stack b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Stack a -> Stack b
fmap :: forall a b. (a -> b) -> Stack a -> Stack b
$c<$ :: forall a b. a -> Stack b -> Stack a
<$ :: forall a b. a -> Stack b -> Stack a
Functor, Functor Stack
Functor Stack =>
(forall a. a -> Stack a)
-> (forall a b. Stack (a -> b) -> Stack a -> Stack b)
-> (forall a b c. (a -> b -> c) -> Stack a -> Stack b -> Stack c)
-> (forall a b. Stack a -> Stack b -> Stack b)
-> (forall a b. Stack a -> Stack b -> Stack a)
-> Applicative Stack
forall a. a -> Stack a
forall a b. Stack a -> Stack b -> Stack a
forall a b. Stack a -> Stack b -> Stack b
forall a b. Stack (a -> b) -> Stack a -> Stack b
forall a b c. (a -> b -> c) -> Stack a -> Stack b -> Stack c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Stack a
pure :: forall a. a -> Stack a
$c<*> :: forall a b. Stack (a -> b) -> Stack a -> Stack b
<*> :: forall a b. Stack (a -> b) -> Stack a -> Stack b
$cliftA2 :: forall a b c. (a -> b -> c) -> Stack a -> Stack b -> Stack c
liftA2 :: forall a b c. (a -> b -> c) -> Stack a -> Stack b -> Stack c
$c*> :: forall a b. Stack a -> Stack b -> Stack b
*> :: forall a b. Stack a -> Stack b -> Stack b
$c<* :: forall a b. Stack a -> Stack b -> Stack a
<* :: forall a b. Stack a -> Stack b -> Stack a
Applicative, Applicative Stack
Applicative Stack =>
(forall a b. Stack a -> (a -> Stack b) -> Stack b)
-> (forall a b. Stack a -> Stack b -> Stack b)
-> (forall a. a -> Stack a)
-> Monad Stack
forall a. a -> Stack a
forall a b. Stack a -> Stack b -> Stack b
forall a b. Stack a -> (a -> Stack b) -> Stack b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Stack a -> (a -> Stack b) -> Stack b
>>= :: forall a b. Stack a -> (a -> Stack b) -> Stack b
$c>> :: forall a b. Stack a -> Stack b -> Stack b
>> :: forall a b. Stack a -> Stack b -> Stack b
$creturn :: forall a. a -> Stack a
return :: forall a. a -> Stack a
Monad, (forall m. Monoid m => Stack m -> m)
-> (forall m a. Monoid m => (a -> m) -> Stack a -> m)
-> (forall m a. Monoid m => (a -> m) -> Stack a -> m)
-> (forall a b. (a -> b -> b) -> b -> Stack a -> b)
-> (forall a b. (a -> b -> b) -> b -> Stack a -> b)
-> (forall b a. (b -> a -> b) -> b -> Stack a -> b)
-> (forall b a. (b -> a -> b) -> b -> Stack a -> b)
-> (forall a. (a -> a -> a) -> Stack a -> a)
-> (forall a. (a -> a -> a) -> Stack a -> a)
-> (forall c. Stack c -> [c])
-> (forall a. Stack a -> Bool)
-> (forall a. Stack a -> Int)
-> (forall a. Eq a => a -> Stack a -> Bool)
-> (forall a. Ord a => Stack a -> a)
-> (forall a. Ord a => Stack a -> a)
-> (forall a. Num a => Stack a -> a)
-> (forall a. Num a => Stack a -> a)
-> Foldable Stack
forall a. Eq a => a -> Stack a -> Bool
forall a. Num a => Stack a -> a
forall a. Ord a => Stack a -> a
forall m. Monoid m => Stack m -> m
forall a. Stack a -> Bool
forall a. Stack a -> Int
forall c. Stack c -> [c]
forall a. (a -> a -> a) -> Stack a -> a
forall m a. Monoid m => (a -> m) -> Stack a -> m
forall b a. (b -> a -> b) -> b -> Stack a -> b
forall a b. (a -> b -> b) -> b -> Stack a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Stack m -> m
fold :: forall m. Monoid m => Stack m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Stack a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Stack a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Stack a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Stack a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Stack a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Stack a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Stack a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Stack a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Stack a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Stack a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Stack a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Stack a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Stack a -> a
foldr1 :: forall a. (a -> a -> a) -> Stack a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Stack a -> a
foldl1 :: forall a. (a -> a -> a) -> Stack a -> a
$ctoList :: forall c. Stack c -> [c]
toList :: forall c. Stack c -> [c]
$cnull :: forall a. Stack a -> Bool
null :: forall a. Stack a -> Bool
$clength :: forall a. Stack a -> Int
length :: forall a. Stack a -> Int
$celem :: forall a. Eq a => a -> Stack a -> Bool
elem :: forall a. Eq a => a -> Stack a -> Bool
$cmaximum :: forall a. Ord a => Stack a -> a
maximum :: forall a. Ord a => Stack a -> a
$cminimum :: forall a. Ord a => Stack a -> a
minimum :: forall a. Ord a => Stack a -> a
$csum :: forall a. Num a => Stack a -> a
sum :: forall a. Num a => Stack a -> a
$cproduct :: forall a. Num a => Stack a -> a
product :: forall a. Num a => Stack a -> a
Foldable, Semigroup (Stack c)
Stack c
Semigroup (Stack c) =>
Stack c
-> (Stack c -> Stack c -> Stack c)
-> ([Stack c] -> Stack c)
-> Monoid (Stack c)
[Stack c] -> Stack c
Stack c -> Stack c -> Stack c
forall c. Semigroup (Stack c)
forall c. Stack c
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall c. [Stack c] -> Stack c
forall c. Stack c -> Stack c -> Stack c
$cmempty :: forall c. Stack c
mempty :: Stack c
$cmappend :: forall c. Stack c -> Stack c -> Stack c
mappend :: Stack c -> Stack c -> Stack c
$cmconcat :: forall c. [Stack c] -> Stack c
mconcat :: [Stack c] -> Stack c
Monoid, NonEmpty (Stack c) -> Stack c
Stack c -> Stack c -> Stack c
(Stack c -> Stack c -> Stack c)
-> (NonEmpty (Stack c) -> Stack c)
-> (forall b. Integral b => b -> Stack c -> Stack c)
-> Semigroup (Stack c)
forall b. Integral b => b -> Stack c -> Stack c
forall c. NonEmpty (Stack c) -> Stack c
forall c. Stack c -> Stack c -> Stack c
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall c b. Integral b => b -> Stack c -> Stack c
$c<> :: forall c. Stack c -> Stack c -> Stack c
<> :: Stack c -> Stack c -> Stack c
$csconcat :: forall c. NonEmpty (Stack c) -> Stack c
sconcat :: NonEmpty (Stack c) -> Stack c
$cstimes :: forall c b. Integral b => b -> Stack c -> Stack c
stimes :: forall b. Integral b => b -> Stack c -> Stack c
Semigroup)

type instance Elem (Pushdown s c) = c

instance (Functor m, ExplInit m (s (Stack c))) => ExplInit m (Pushdown s c) where
  explInit :: m (Pushdown s c)
explInit = s (Stack c) -> Pushdown s c
forall (s :: * -> *) c. s (Stack c) -> Pushdown s c
Pushdown (s (Stack c) -> Pushdown s c)
-> m (s (Stack c)) -> m (Pushdown s c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (s (Stack c))
forall (m :: * -> *) s. ExplInit m s => m s
explInit

pattern StackList :: c -> [c] -> Maybe (Stack c)
pattern $mStackList :: forall {r} {c}.
Maybe (Stack c) -> (c -> [c] -> r) -> ((# #) -> r) -> r
$bStackList :: forall c. c -> [c] -> Maybe (Stack c)
StackList x xs = Just (Stack (x:xs))

instance
  ( Monad m
  , ExplGet m (s (Stack c))
  , Elem (s (Stack c)) ~ Stack c
  ) => ExplGet m (Pushdown s c) where
    explExists :: Pushdown s c -> Int -> m Bool
explExists (Pushdown s (Stack c)
s) Int
ety = Maybe (Stack c) -> Bool
forall {c}. Maybe (Stack c) -> Bool
f (Maybe (Stack c) -> Bool) -> m (Maybe (Stack c)) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeStore (s (Stack c))
-> Int -> m (Elem (MaybeStore (s (Stack c))))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet (s (Stack c) -> MaybeStore (s (Stack c))
forall s. s -> MaybeStore s
MaybeStore s (Stack c)
s) Int
ety
      where
        f :: Maybe (Stack c) -> Bool
f (StackList c
_ [c]
_) = Bool
True
        f Maybe (Stack c)
_               = Bool
False
    explGet :: Pushdown s c -> Int -> m (Elem (Pushdown s c))
explGet (Pushdown s (Stack c)
s) Int
ety = [c] -> c
forall a. HasCallStack => [a] -> a
head ([c] -> c) -> (Stack c -> [c]) -> Stack c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack c -> [c]
forall c. Stack c -> [c]
getStack (Stack c -> c) -> m (Stack c) -> m c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s (Stack c) -> Int -> m (Elem (s (Stack c)))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet s (Stack c)
s Int
ety

instance
  ( Monad m
  , ExplGet m (s (Stack c))
  , ExplSet m (s (Stack c))
  , Elem (s (Stack c)) ~ Stack c
  ) => ExplSet m (Pushdown s c) where
    explSet :: Pushdown s c -> Int -> Elem (Pushdown s c) -> m ()
explSet (Pushdown s (Stack c)
s) Int
ety Elem (Pushdown s c)
c = do
      Maybe (Stack c)
ms <- MaybeStore (s (Stack c))
-> Int -> m (Elem (MaybeStore (s (Stack c))))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet (s (Stack c) -> MaybeStore (s (Stack c))
forall s. s -> MaybeStore s
MaybeStore s (Stack c)
s) Int
ety
      let tail :: Maybe (Stack c) -> [c]
tail (StackList c
_ [c]
cs) = [c]
cs
          tail Maybe (Stack c)
_                = []
      s (Stack c) -> Int -> Elem (s (Stack c)) -> m ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet s (Stack c)
s Int
ety ([c] -> Stack c
forall c. [c] -> Stack c
Stack (c
Elem (Pushdown s c)
cc -> [c] -> [c]
forall a. a -> [a] -> [a]
:Maybe (Stack c) -> [c]
forall {c}. Maybe (Stack c) -> [c]
tail Maybe (Stack c)
ms))

instance
  ( Monad m
  , ExplGet m (s (Stack c))
  , ExplSet m (s (Stack c))
  , ExplDestroy m (s (Stack c))
  , Elem (s (Stack c)) ~ Stack c
  ) => ExplDestroy m (Pushdown s c) where
    explDestroy :: Pushdown s c -> Int -> m ()
explDestroy (Pushdown s (Stack c)
s) Int
ety = do
      Maybe (Stack c)
mscs <- MaybeStore (s (Stack c))
-> Int -> m (Elem (MaybeStore (s (Stack c))))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet (s (Stack c) -> MaybeStore (s (Stack c))
forall s. s -> MaybeStore s
MaybeStore s (Stack c)
s) Int
ety
      case Maybe (Stack c)
mscs of
        StackList c
_ [c]
cs' -> s (Stack c) -> Int -> Elem (s (Stack c)) -> m ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet s (Stack c)
s Int
ety ([c] -> Stack c
forall c. [c] -> Stack c
Stack [c]
cs')
        Maybe (Stack c)
_               -> s (Stack c) -> Int -> m ()
forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy s (Stack c)
s Int
ety

instance
  ( Monad m
  , ExplMembers m (s (Stack c))
  , Elem (s (Stack c)) ~ Stack c
  ) => ExplMembers m (Pushdown s c) where
    explMembers :: Pushdown s c -> m (Vector Int)
explMembers (Pushdown s (Stack c)
s) = s (Stack c) -> m (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers s (Stack c)
s

instance (Storage c ~ Pushdown s c, Component c) => Component (Stack c) where
  type Storage (Stack c) = StackStore (Storage c)

newtype StackStore s = StackStore s
type instance Elem (StackStore s) = Stack (Elem s)

instance (Storage c ~ Pushdown s c, Has w m c) => Has w m (Stack c) where
  getStore :: SystemT w m (Storage (Stack c))
getStore = Pushdown s c -> StackStore (Pushdown s c)
forall s. s -> StackStore s
StackStore (Pushdown s c -> StackStore (Pushdown s c))
-> SystemT w m (Pushdown s c)
-> SystemT w m (StackStore (Pushdown s c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SystemT w m (Storage c)
SystemT w m (Pushdown s c)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore

instance
  ( Elem (s (Stack c)) ~ Stack c
  , ExplGet m (s (Stack c))
  ) => ExplGet m (StackStore (Pushdown s c)) where
  explExists :: StackStore (Pushdown s c) -> Int -> m Bool
explExists (StackStore Pushdown s c
s) = Pushdown s c -> Int -> m Bool
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m Bool
explExists Pushdown s c
s
  explGet :: StackStore (Pushdown s c)
-> Int -> m (Elem (StackStore (Pushdown s c)))
explGet (StackStore (Pushdown s (Stack c)
s)) = s (Stack c) -> Int -> m (Elem (s (Stack c)))
forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet s (Stack c)
s

instance
  ( Elem (s (Stack c)) ~ Stack c
  , ExplSet     m (s (Stack c))
  , ExplDestroy m (s (Stack c))
  ) => ExplSet m (StackStore (Pushdown s c)) where
  explSet :: StackStore (Pushdown s c)
-> Int -> Elem (StackStore (Pushdown s c)) -> m ()
explSet (StackStore (Pushdown s (Stack c)
s)) Int
ety (Stack []) = s (Stack c) -> Int -> m ()
forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy s (Stack c)
s Int
ety
  explSet (StackStore (Pushdown s (Stack c)
s)) Int
ety Elem (StackStore (Pushdown s c))
st         = s (Stack c) -> Int -> Elem (s (Stack c)) -> m ()
forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet s (Stack c)
s Int
ety Elem (s (Stack c))
Elem (StackStore (Pushdown s c))
st

instance
  ( Elem (s (Stack c)) ~ Stack c
  , ExplDestroy m (s (Stack c))
  ) => ExplDestroy m (StackStore (Pushdown s c)) where
  explDestroy :: StackStore (Pushdown s c) -> Int -> m ()
explDestroy (StackStore (Pushdown s (Stack c)
s)) = s (Stack c) -> Int -> m ()
forall (m :: * -> *) s. ExplDestroy m s => s -> Int -> m ()
explDestroy s (Stack c)
s

instance
  ( Elem (s (Stack c)) ~ Stack c
  , ExplMembers m (s (Stack c))
  ) => ExplMembers m (StackStore (Pushdown s c)) where
  explMembers :: StackStore (Pushdown s c) -> m (Vector Int)
explMembers (StackStore (Pushdown s (Stack c)
s)) = s (Stack c) -> m (Vector Int)
forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers s (Stack c)
s