Stores.hs

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

{-|
Stability: experimental

This module is experimental, and its API might change between point releases. Use at your own risk.
-}
module Apecs.Experimental.Stores
  ( Pushdown (..)
  , Stack (..)
  ) where

import Control.Monad.Trans.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 {getStack :: [c]} deriving (Eq, Show, Functor, Applicative, Monad, Foldable, Monoid, Semigroup)

type instance Elem (Pushdown s c) = c

instance (Functor m, ExplInit m (s (Stack c))) => ExplInit m (Pushdown s c) where
  explInit = Pushdown <$> explInit

pattern StackList :: c -> [c] -> Maybe (Stack c)
pattern 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) ety = f <$> explGet (MaybeStore s) ety
    where
      f (StackList _ _) = True
      f _ = False
  explGet (Pushdown s) ety = head . getStack <$> explGet s 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) ety c = do
    ms <- explGet (MaybeStore s) ety
    let tail (StackList _ cs) = cs
        tail _ = []
    explSet s ety (Stack (c : tail 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) ety = do
    mscs <- explGet (MaybeStore s) ety
    case mscs of
      StackList _ cs' -> explSet s ety (Stack cs')
      _ -> explDestroy s ety

instance
  ( Monad m
  , ExplMembers m (s (Stack c))
  , Elem (s (Stack c)) ~ Stack c
  )
  => ExplMembers m (Pushdown s c)
  where
  explMembers (Pushdown s) = explMembers s
  explMemberSet (Pushdown s) = explMemberSet 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 = StackStore <$> getStore

instance
  ( Elem (s (Stack c)) ~ Stack c
  , ExplGet m (s (Stack c))
  )
  => ExplGet m (StackStore (Pushdown s c))
  where
  explExists (StackStore s) = explExists s
  explGet (StackStore (Pushdown s)) = explGet 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)) ety (Stack []) = explDestroy s ety
  explSet (StackStore (Pushdown s)) ety st = explSet s ety st

instance
  ( Elem (s (Stack c)) ~ Stack c
  , ExplDestroy m (s (Stack c))
  )
  => ExplDestroy m (StackStore (Pushdown s c))
  where
  explDestroy (StackStore (Pushdown s)) = explDestroy s

instance
  ( Elem (s (Stack c)) ~ Stack c
  , ExplMembers m (s (Stack c))
  )
  => ExplMembers m (StackStore (Pushdown s c))
  where
  explMembers (StackStore (Pushdown s)) = explMembers s
  explMemberSet (StackStore (Pushdown s)) = explMemberSet s