{-|
Stability: experimtal

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 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
forall c. Eq c => Stack c -> Stack c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Stack c -> Stack c -> Bool
$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
Eq, Int -> Stack c -> ShowS
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
showList :: [Stack c] -> ShowS
$cshowList :: forall c. Show c => [Stack c] -> ShowS
show :: Stack c -> String
$cshow :: forall c. Show c => Stack c -> String
showsPrec :: Int -> Stack c -> ShowS
$cshowsPrec :: forall c. Show c => Int -> Stack c -> ShowS
Show, 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
<$ :: forall a b. a -> Stack b -> Stack a
$c<$ :: forall a b. a -> Stack b -> Stack a
fmap :: forall a b. (a -> b) -> Stack a -> Stack b
$cfmap :: forall a b. (a -> b) -> Stack a -> Stack b
Functor, Functor 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
<* :: forall a b. Stack a -> Stack b -> Stack a
$c<* :: forall a b. Stack a -> Stack b -> Stack a
*> :: forall a b. Stack a -> Stack b -> Stack b
$c*> :: forall a b. Stack a -> Stack b -> Stack b
liftA2 :: forall a b c. (a -> b -> c) -> Stack a -> Stack b -> Stack c
$cliftA2 :: forall a b c. (a -> b -> c) -> Stack a -> Stack b -> Stack c
<*> :: forall a b. Stack (a -> b) -> Stack a -> Stack b
$c<*> :: forall a b. Stack (a -> b) -> Stack a -> Stack b
pure :: forall a. a -> Stack a
$cpure :: forall a. a -> Stack a
Applicative, Applicative 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
return :: forall a. a -> Stack a
$creturn :: forall a. a -> Stack a
>> :: forall a b. Stack a -> Stack b -> Stack b
$c>> :: forall a b. Stack a -> Stack b -> Stack b
>>= :: forall a b. Stack a -> (a -> Stack b) -> Stack b
$c>>= :: forall a b. Stack a -> (a -> Stack b) -> Stack b
Monad, 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
product :: forall a. Num a => Stack a -> a
$cproduct :: forall a. Num a => Stack a -> a
sum :: forall a. Num a => Stack a -> a
$csum :: forall a. Num a => Stack a -> a
minimum :: forall a. Ord a => Stack a -> a
$cminimum :: forall a. Ord a => Stack a -> a
maximum :: forall a. Ord a => Stack a -> a
$cmaximum :: forall a. Ord a => Stack a -> a
elem :: forall a. Eq a => a -> Stack a -> Bool
$celem :: forall a. Eq a => a -> Stack a -> Bool
length :: forall a. Stack a -> Int
$clength :: forall a. Stack a -> Int
null :: forall a. Stack a -> Bool
$cnull :: forall a. Stack a -> Bool
toList :: forall c. Stack c -> [c]
$ctoList :: forall c. Stack c -> [c]
foldl1 :: forall a. (a -> a -> a) -> Stack a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Stack a -> a
foldr1 :: forall a. (a -> a -> a) -> Stack a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Stack a -> a
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
$cfoldl :: forall b a. (b -> a -> 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
$cfoldr :: forall a b. (a -> b -> b) -> b -> Stack a -> b
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
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Stack a -> m
fold :: forall m. Monoid m => Stack m -> m
$cfold :: forall m. Monoid m => Stack m -> m
Foldable, 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
mconcat :: [Stack c] -> Stack c
$cmconcat :: forall c. [Stack c] -> Stack c
mappend :: Stack c -> Stack c -> Stack c
$cmappend :: forall c. Stack c -> Stack c -> Stack c
mempty :: Stack c
$cmempty :: forall c. Stack c
Monoid, NonEmpty (Stack c) -> Stack c
Stack c -> Stack c -> 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
stimes :: forall b. Integral b => b -> Stack c -> Stack c
$cstimes :: forall c b. Integral b => b -> Stack c -> Stack c
sconcat :: NonEmpty (Stack c) -> Stack c
$csconcat :: forall c. NonEmpty (Stack c) -> Stack c
<> :: Stack c -> Stack c -> Stack c
$c<> :: forall c. Stack c -> 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 = forall (s :: * -> *) c. s (Stack c) -> Pushdown s c
Pushdown forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. ExplInit m s => m s
explInit

pattern StackList :: c -> [c] -> Maybe (Stack c)
pattern $bStackList :: forall c. c -> [c] -> Maybe (Stack c)
$mStackList :: forall {r} {c}.
Maybe (Stack c) -> (c -> [c] -> r) -> ((# #) -> r) -> r
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 = forall {c}. Maybe (Stack c) -> Bool
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet (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 = forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Stack c -> [c]
getStack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 <- forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet (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)
_                = []
      forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet s (Stack c)
s Int
ety (forall c. [c] -> Stack c
Stack (Elem (Pushdown s c)
cforall a. a -> [a] -> [a]
: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 <- forall (m :: * -> *) s. ExplGet m s => s -> Int -> m (Elem s)
explGet (forall s. s -> MaybeStore s
MaybeStore s (Stack c)
s) Int
ety
      case Maybe (Stack c)
mscs of
        StackList c
_ [c]
cs' -> forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet s (Stack c)
s Int
ety (forall c. [c] -> Stack c
Stack [c]
cs')
        Maybe (Stack c)
_               -> 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) = 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 = forall s. s -> StackStore s
StackStore forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) = 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)) = 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 []) = 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         = forall (m :: * -> *) s. ExplSet m s => s -> Int -> Elem s -> m ()
explSet s (Stack c)
s Int
ety 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)) = 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)) = forall (m :: * -> *) s. ExplMembers m s => s -> m (Vector Int)
explMembers s (Stack c)
s