{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}

module LiveCoding.HandlingState where

-- base
import Control.Arrow (arr, returnA, (>>>))
import Data.Data

-- transformers
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.State.Strict
import Data.Foldable (traverse_)

-- containers
import Data.IntMap
import qualified Data.IntMap as IntMap

-- essence-of-live-coding
import LiveCoding.Cell
import LiveCoding.Cell.Monad
import LiveCoding.Cell.Monad.Trans
import LiveCoding.LiveProgram
import LiveCoding.LiveProgram.Monad.Trans

data Handling h = Handling
  { forall h. Handling h -> Key
key :: Key
  , forall h. Handling h -> h
handle :: h
  }

type Destructors m = IntMap (Destructor m)

-- | Hold a map of registered handle keys and destructors
data HandlingState m = HandlingState
  { forall (m :: * -> *). HandlingState m -> Key
nHandles :: Key
  , forall (m :: * -> *). HandlingState m -> Destructors m
destructors :: Destructors m
  }
  deriving (HandlingState m -> DataType
HandlingState m -> Constr
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Key -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall {m :: * -> *}. Typeable m => Typeable (HandlingState m)
forall (m :: * -> *). Typeable m => HandlingState m -> DataType
forall (m :: * -> *). Typeable m => HandlingState m -> Constr
forall (m :: * -> *).
Typeable m =>
(forall b. Data b => b -> b) -> HandlingState m -> HandlingState m
forall (m :: * -> *) u.
Typeable m =>
Key -> (forall d. Data d => d -> u) -> HandlingState m -> u
forall (m :: * -> *) u.
Typeable m =>
(forall d. Data d => d -> u) -> HandlingState m -> [u]
forall (m :: * -> *) r r'.
Typeable m =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> HandlingState m -> r
forall (m :: * -> *) r r'.
Typeable m =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> HandlingState m -> r
forall (m :: * -> *) (m :: * -> *).
(Typeable m, Monad m) =>
(forall d. Data d => d -> m d)
-> HandlingState m -> m (HandlingState m)
forall (m :: * -> *) (m :: * -> *).
(Typeable m, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> HandlingState m -> m (HandlingState m)
forall (m :: * -> *) (c :: * -> *).
Typeable m =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (HandlingState m)
forall (m :: * -> *) (c :: * -> *).
Typeable m =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> HandlingState m -> c (HandlingState m)
forall (m :: * -> *) (t :: * -> *) (c :: * -> *).
(Typeable m, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (HandlingState m))
forall (m :: * -> *) (t :: * -> * -> *) (c :: * -> *).
(Typeable m, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (HandlingState m))
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (HandlingState m)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> HandlingState m -> c (HandlingState m)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> HandlingState m -> m (HandlingState m)
$cgmapMo :: forall (m :: * -> *) (m :: * -> *).
(Typeable m, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> HandlingState m -> m (HandlingState m)
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> HandlingState m -> m (HandlingState m)
$cgmapMp :: forall (m :: * -> *) (m :: * -> *).
(Typeable m, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> HandlingState m -> m (HandlingState m)
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> HandlingState m -> m (HandlingState m)
$cgmapM :: forall (m :: * -> *) (m :: * -> *).
(Typeable m, Monad m) =>
(forall d. Data d => d -> m d)
-> HandlingState m -> m (HandlingState m)
gmapQi :: forall u.
Key -> (forall d. Data d => d -> u) -> HandlingState m -> u
$cgmapQi :: forall (m :: * -> *) u.
Typeable m =>
Key -> (forall d. Data d => d -> u) -> HandlingState m -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> HandlingState m -> [u]
$cgmapQ :: forall (m :: * -> *) u.
Typeable m =>
(forall d. Data d => d -> u) -> HandlingState m -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> HandlingState m -> r
$cgmapQr :: forall (m :: * -> *) r r'.
Typeable m =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> HandlingState m -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> HandlingState m -> r
$cgmapQl :: forall (m :: * -> *) r r'.
Typeable m =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> HandlingState m -> r
gmapT :: (forall b. Data b => b -> b) -> HandlingState m -> HandlingState m
$cgmapT :: forall (m :: * -> *).
Typeable m =>
(forall b. Data b => b -> b) -> HandlingState m -> HandlingState m
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (HandlingState m))
$cdataCast2 :: forall (m :: * -> *) (t :: * -> * -> *) (c :: * -> *).
(Typeable m, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (HandlingState m))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (HandlingState m))
$cdataCast1 :: forall (m :: * -> *) (t :: * -> *) (c :: * -> *).
(Typeable m, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (HandlingState m))
dataTypeOf :: HandlingState m -> DataType
$cdataTypeOf :: forall (m :: * -> *). Typeable m => HandlingState m -> DataType
toConstr :: HandlingState m -> Constr
$ctoConstr :: forall (m :: * -> *). Typeable m => HandlingState m -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (HandlingState m)
$cgunfold :: forall (m :: * -> *) (c :: * -> *).
Typeable m =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (HandlingState m)
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> HandlingState m -> c (HandlingState m)
$cgfoldl :: forall (m :: * -> *) (c :: * -> *).
Typeable m =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> HandlingState m -> c (HandlingState m)
Data)

{- | In this monad, handles can be registered,
   and their destructors automatically executed.
   It is basically a monad in which handles are automatically garbage collected.
-}
type HandlingStateT m = StateT (HandlingState m) m

initHandlingState :: HandlingState m
initHandlingState :: forall (m :: * -> *). HandlingState m
initHandlingState =
  HandlingState
    { nHandles :: Key
nHandles = Key
0
    , destructors :: Destructors m
destructors = forall a. IntMap a
IntMap.empty
    }

{- | Handle the 'HandlingStateT' effect _without_ garbage collection.
   Apply this to your main loop after calling 'foreground'.
   Since there is no garbage collection, don't use this function for live coding.
-}
runHandlingStateT ::
  Monad m =>
  HandlingStateT m a ->
  m a
runHandlingStateT :: forall (m :: * -> *) a. Monad m => HandlingStateT m a -> m a
runHandlingStateT = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT forall (m :: * -> *). HandlingState m
initHandlingState

{- | Apply this to your main live cell before passing it to the runtime.

On the first tick, it initialises the 'HandlingState' at "no handles".

On every step, it does:

1. Unregister all handles
2. Register currently present handles
3. Destroy all still unregistered handles
   (i.e. those that were removed in the last tick)
-}
runHandlingStateC ::
  forall m a b.
  (Monad m, Typeable m) =>
  Cell (HandlingStateT m) a b ->
  Cell m a b
runHandlingStateC :: forall (m :: * -> *) a b.
(Monad m, Typeable m) =>
Cell (HandlingStateT m) a b -> Cell m a b
runHandlingStateC Cell (HandlingStateT m) a b
cell =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall stateT (m :: * -> *) a b.
(Data stateT, Monad m) =>
Cell (StateT stateT m) a b -> stateT -> Cell m a b
runStateC_ forall (m :: * -> *). HandlingState m
initHandlingState forall a b. (a -> b) -> a -> b
$
    forall (m1 :: * -> *) (m2 :: * -> *) b1 b2 a.
(Monad m1, Monad m2) =>
(forall s. m1 (b1, s) -> m2 (b2, s))
-> Cell m1 a b1 -> Cell m2 a b2
hoistCellOutput forall (m :: * -> *) a.
Monad m =>
HandlingStateT m a -> HandlingStateT m a
garbageCollected Cell (HandlingStateT m) a b
cell

-- | Like 'runHandlingStateC', but for whole live programs.
runHandlingState ::
  (Monad m, Typeable m) =>
  LiveProgram (HandlingStateT m) ->
  LiveProgram m
runHandlingState :: forall (m :: * -> *).
(Monad m, Typeable m) =>
LiveProgram (HandlingStateT m) -> LiveProgram m
runHandlingState LiveProgram {s
s -> HandlingStateT m s
liveStep :: ()
liveState :: ()
liveStep :: s -> HandlingStateT m s
liveState :: s
..} =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip
    forall stateT (m :: * -> *).
(Data stateT, Monad m) =>
LiveProgram (StateT stateT m) -> stateT -> LiveProgram m
runStateL
    forall (m :: * -> *). HandlingState m
initHandlingState
    LiveProgram
      { liveStep :: s -> HandlingStateT m s
liveStep = forall (m :: * -> *) a.
Monad m =>
HandlingStateT m a -> HandlingStateT m a
garbageCollected forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> HandlingStateT m s
liveStep
      , s
liveState :: s
liveState :: s
..
      }

garbageCollected ::
  Monad m =>
  HandlingStateT m a ->
  HandlingStateT m a
garbageCollected :: forall (m :: * -> *) a.
Monad m =>
HandlingStateT m a -> HandlingStateT m a
garbageCollected HandlingStateT m a
action = forall (m :: * -> *). Monad m => HandlingStateT m ()
unregisterAll forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HandlingStateT m a
action forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). Monad m => HandlingStateT m ()
destroyUnregistered

data Destructor m = Destructor
  { forall (m :: * -> *). Destructor m -> Bool
isRegistered :: Bool
  , forall (m :: * -> *). Destructor m -> m ()
action :: m ()
  }

register ::
  Monad m =>
  -- | Destructor
  m () ->
  HandlingStateT m Key
register :: forall (m :: * -> *). Monad m => m () -> HandlingStateT m Key
register m ()
destructor = do
  HandlingState {Key
Destructors m
destructors :: Destructors m
nHandles :: Key
destructors :: forall (m :: * -> *). HandlingState m -> Destructors m
nHandles :: forall (m :: * -> *). HandlingState m -> Key
..} <- forall (m :: * -> *) s. Monad m => StateT s m s
get
  let key :: Key
key = Key
nHandles forall a. Num a => a -> a -> a
+ Key
1
  forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put
    HandlingState
      { nHandles :: Key
nHandles = Key
key
      , destructors :: Destructors m
destructors = forall (m :: * -> *). m () -> Key -> Destructors m -> Destructors m
insertDestructor m ()
destructor Key
key Destructors m
destructors
      }
  forall (m :: * -> *) a. Monad m => a -> m a
return Key
key

reregister ::
  Monad m =>
  m () ->
  Key ->
  HandlingStateT m ()
reregister :: forall (m :: * -> *). Monad m => m () -> Key -> HandlingStateT m ()
reregister m ()
action Key
key = do
  HandlingState {Key
Destructors m
destructors :: Destructors m
nHandles :: Key
destructors :: forall (m :: * -> *). HandlingState m -> Destructors m
nHandles :: forall (m :: * -> *). HandlingState m -> Key
..} <- forall (m :: * -> *) s. Monad m => StateT s m s
get
  forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put HandlingState {destructors :: Destructors m
destructors = forall (m :: * -> *). m () -> Key -> Destructors m -> Destructors m
insertDestructor m ()
action Key
key Destructors m
destructors, Key
nHandles :: Key
nHandles :: Key
..}

insertDestructor ::
  m () ->
  Key ->
  Destructors m ->
  Destructors m
insertDestructor :: forall (m :: * -> *). m () -> Key -> Destructors m -> Destructors m
insertDestructor m ()
action Key
key Destructors m
destructors =
  let destructor :: Destructor m
destructor = Destructor {isRegistered :: Bool
isRegistered = Bool
True, m ()
action :: m ()
action :: m ()
..}
   in forall a. Key -> a -> IntMap a -> IntMap a
insert Key
key Destructor m
destructor Destructors m
destructors

unregisterAll ::
  Monad m =>
  HandlingStateT m ()
unregisterAll :: forall (m :: * -> *). Monad m => HandlingStateT m ()
unregisterAll = do
  HandlingState {Key
Destructors m
destructors :: Destructors m
nHandles :: Key
destructors :: forall (m :: * -> *). HandlingState m -> Destructors m
nHandles :: forall (m :: * -> *). HandlingState m -> Key
..} <- forall (m :: * -> *) s. Monad m => StateT s m s
get
  let newDestructors :: Destructors m
newDestructors = forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (\Destructor m
destructor -> Destructor m
destructor {isRegistered :: Bool
isRegistered = Bool
False}) Destructors m
destructors
  forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put HandlingState {destructors :: Destructors m
destructors = Destructors m
newDestructors, Key
nHandles :: Key
nHandles :: Key
..}

destroyUnregistered ::
  Monad m =>
  HandlingStateT m ()
destroyUnregistered :: forall (m :: * -> *). Monad m => HandlingStateT m ()
destroyUnregistered = do
  HandlingState {Key
Destructors m
destructors :: Destructors m
nHandles :: Key
destructors :: forall (m :: * -> *). HandlingState m -> Destructors m
nHandles :: forall (m :: * -> *). HandlingState m -> Key
..} <- forall (m :: * -> *) s. Monad m => StateT s m s
get
  let
    (Destructors m
registered, Destructors m
unregistered) = forall a. (a -> Bool) -> IntMap a -> (IntMap a, IntMap a)
partition forall (m :: * -> *). Destructor m -> Bool
isRegistered Destructors m
destructors
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Destructor m -> m ()
action) Destructors m
unregistered
  forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put HandlingState {destructors :: Destructors m
destructors = Destructors m
registered, Key
nHandles :: Key
nHandles :: Key
..}

-- * 'Data' instances
dataTypeDestructor :: DataType
dataTypeDestructor :: DataType
dataTypeDestructor = String -> [Constr] -> DataType
mkDataType String
"Destructor" [Constr
destructorConstr]

destructorConstr :: Constr
destructorConstr :: Constr
destructorConstr = DataType -> String -> [String] -> Fixity -> Constr
mkConstr DataType
dataTypeDestructor String
"Destructor" [] Fixity
Prefix

instance Typeable m => Data (Destructor m) where
  dataTypeOf :: Destructor m -> DataType
dataTypeOf Destructor m
_ = DataType
dataTypeDestructor
  toConstr :: Destructor m -> Constr
toConstr Destructor {m ()
Bool
action :: m ()
isRegistered :: Bool
action :: forall (m :: * -> *). Destructor m -> m ()
isRegistered :: forall (m :: * -> *). Destructor m -> Bool
..} = Constr
destructorConstr
  gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Destructor m)
gunfold forall b r. Data b => c (b -> r) -> c r
_ forall r. r -> c r
_ = forall a. HasCallStack => String -> a
error String
"Destructor.gunfold"