{-# LANGUAGE Arrows #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module LiveCoding.Handle
  ( Handle (..)
  , handling
  , HandlingState (..)
  , HandlingStateT
  , isRegistered
  , runHandlingState
  , runHandlingStateC
  , runHandlingStateT
  )
  where

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

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

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

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

{- | Container for unserialisable values,
such as 'IORef's, threads, 'MVar's, pointers, and device handles.

In a 'Handle', you can store a mechanism to create and destroy a value that survives live coding even if does not have a 'Data' instance.
Using the function 'handling', you can create a cell that will
automatically initialise your value,
and register it in the 'HandlingStateT' monad transformer,
which takes care of automatically destroying it (if necessary) when it does not occur anymore in a later revision of your live program.

Have a look at 'LiveCoding.Handle.Examples' for some ready-to-use implementations.

In short, 'Handle' is an opaque, automatically constructing and garbage collecting container for arbitrary values in the live coding environment.
-}
data Handle m h = Handle
  { Handle m h -> m h
create :: m h
  , Handle m h -> h -> m ()
destroy :: h -> m ()
  }

{- | Combine two handles to one.

'Handle's are not quite 'Monoid's because of the extra type parameter,
but it is possible to combine them.
In the combined handle, the first handle is created first and destroyed last.

Note: 'Handle' is not an 'Applicative' because it is not a 'Functor'
(because the destructor is contravariant in @h@).
-}
combineHandles :: Applicative m => Handle m h1 -> Handle m h2 -> Handle m (h1, h2)
combineHandles :: Handle m h1 -> Handle m h2 -> Handle m (h1, h2)
combineHandles Handle m h1
handle1 Handle m h2
handle2 = Handle :: forall (m :: * -> *) h. m h -> (h -> m ()) -> Handle m h
Handle
  { create :: m (h1, h2)
create = ( , ) (h1 -> h2 -> (h1, h2)) -> m h1 -> m (h2 -> (h1, h2))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle m h1 -> m h1
forall (m :: * -> *) h. Handle m h -> m h
create Handle m h1
handle1 m (h2 -> (h1, h2)) -> m h2 -> m (h1, h2)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Handle m h2 -> m h2
forall (m :: * -> *) h. Handle m h -> m h
create Handle m h2
handle2
  , destroy :: (h1, h2) -> m ()
destroy = \(h1
h1, h2
h2) -> Handle m h2 -> h2 -> m ()
forall (m :: * -> *) h. Handle m h -> h -> m ()
destroy Handle m h2
handle2 h2
h2 m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Handle m h1 -> h1 -> m ()
forall (m :: * -> *) h. Handle m h -> h -> m ()
destroy Handle m h1
handle1 h1
h1
  }

data Handling h where
  Handling
    :: { Handling h -> Key
id     :: Key
       , Handling h -> h
handle :: h
       }
    -> Handling h
  Uninitialized :: Handling h

type Destructors m = IntMap (Destructor m)

-- | Hold a map of registered handle keys and destructors
data HandlingState m = HandlingState
  { HandlingState m -> Key
nHandles    :: Key
  , HandlingState m -> Destructors m
destructors :: Destructors m
  }
  deriving Typeable (HandlingState m)
DataType
Constr
Typeable (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))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (HandlingState m))
-> (HandlingState m -> Constr)
-> (HandlingState m -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (HandlingState m)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c (HandlingState m)))
-> ((forall b. Data b => b -> b)
    -> HandlingState m -> HandlingState m)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> HandlingState m -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> HandlingState m -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> HandlingState m -> [u])
-> (forall u.
    Key -> (forall d. Data d => d -> u) -> HandlingState m -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> HandlingState m -> m (HandlingState m))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> HandlingState m -> m (HandlingState m))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> HandlingState m -> m (HandlingState m))
-> Data (HandlingState m)
HandlingState m -> DataType
HandlingState m -> Constr
(forall b. Data b => b -> b) -> HandlingState m -> HandlingState m
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> HandlingState m -> c (HandlingState m)
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (HandlingState m)
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 u.
Key -> (forall d. Data d => d -> u) -> HandlingState m -> u
forall u. (forall d. Data d => d -> u) -> HandlingState m -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> HandlingState m -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> HandlingState m -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> HandlingState m -> m (HandlingState m)
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 (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> HandlingState m -> m (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)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (HandlingState m))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (HandlingState m))
$cHandlingState :: Constr
$tHandlingState :: DataType
gmapMo :: (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 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 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 :: 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 d. Data d => d -> u) -> HandlingState m -> [u]
$cgmapQ :: forall (m :: * -> *) u.
Typeable m =>
(forall d. Data d => d -> u) -> HandlingState m -> [u]
gmapQr :: (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 :: (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 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 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 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 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)
$cp1Data :: forall (m :: * -> *). Typeable m => Typeable (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 :: HandlingState m
initHandlingState = HandlingState :: forall (m :: * -> *). Key -> Destructors m -> HandlingState m
HandlingState
  { nHandles :: Key
nHandles = Key
0
  , destructors :: Destructors m
destructors = Destructors m
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 :: HandlingStateT m a -> m a
runHandlingStateT = (HandlingStateT m a -> HandlingState m -> m a)
-> HandlingState m -> HandlingStateT m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip HandlingStateT m a -> HandlingState m -> m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT HandlingState m
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 :: Cell (HandlingStateT m) a b -> Cell m a b
runHandlingStateC Cell (HandlingStateT m) a b
cell = (Cell (HandlingStateT m) a b -> HandlingState m -> Cell m a b)
-> HandlingState m -> Cell (HandlingStateT m) a b -> Cell m a b
forall a b c. (a -> b -> c) -> b -> a -> c
flip Cell (HandlingStateT m) a b -> HandlingState m -> Cell m a b
forall stateT (m :: * -> *) a b.
(Data stateT, Monad m) =>
Cell (StateT stateT m) a b -> stateT -> Cell m a b
runStateC_ HandlingState m
forall (m :: * -> *). HandlingState m
initHandlingState
  (Cell (HandlingStateT m) a b -> Cell m a b)
-> Cell (HandlingStateT m) a b -> Cell m a b
forall a b. (a -> b) -> a -> b
$ (forall s. HandlingStateT m (b, s) -> HandlingStateT m (b, s))
-> Cell (HandlingStateT m) a b -> Cell (HandlingStateT m) 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 s. HandlingStateT m (b, s) -> HandlingStateT m (b, s)
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 :: LiveProgram (HandlingStateT m) -> LiveProgram m
runHandlingState LiveProgram { s
s -> HandlingStateT m s
liveStep :: ()
liveState :: ()
liveStep :: s -> HandlingStateT m s
liveState :: s
.. } = (LiveProgram (HandlingStateT m)
 -> HandlingState m -> LiveProgram m)
-> HandlingState m
-> LiveProgram (HandlingStateT m)
-> LiveProgram m
forall a b c. (a -> b -> c) -> b -> a -> c
flip LiveProgram (HandlingStateT m) -> HandlingState m -> LiveProgram m
forall stateT (m :: * -> *).
(Data stateT, Monad m) =>
LiveProgram (StateT stateT m) -> stateT -> LiveProgram m
runStateL HandlingState m
forall (m :: * -> *). HandlingState m
initHandlingState LiveProgram :: forall (m :: * -> *) s. Data s => s -> (s -> m s) -> LiveProgram m
LiveProgram
  { liveStep :: s -> HandlingStateT m s
liveStep = HandlingStateT m s -> HandlingStateT m s
forall (m :: * -> *) a.
Monad m =>
HandlingStateT m a -> HandlingStateT m a
garbageCollected (HandlingStateT m s -> HandlingStateT m s)
-> (s -> HandlingStateT m s) -> s -> HandlingStateT m s
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 :: HandlingStateT m a -> HandlingStateT m a
garbageCollected HandlingStateT m a
action = HandlingStateT m ()
forall (m :: * -> *). Monad m => HandlingStateT m ()
unregisterAll HandlingStateT m () -> HandlingStateT m a -> HandlingStateT m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HandlingStateT m a
action HandlingStateT m a -> HandlingStateT m () -> HandlingStateT m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* HandlingStateT m ()
forall (m :: * -> *). Monad m => HandlingStateT m ()
destroyUnregistered

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

{- | Hide a handle in a cell,
taking care of initialisation and destruction.

Upon the first tick (or directly after migration),
the 'create' method of the 'Handle' is called,
and the result stored.
This result is then not changed anymore until the cell is removed again.
Once it is removed, the destructor will be called on the next tick.

Migrations will by default not inspect the interior of a 'handling' cell.
This means that handles are only migrated if they have exactly the same type.
-}
handling
  :: ( Typeable h
     , Monad m
    --  , MonadBase m m
    --  , MonadState (HandlingState m) n
    --  , MonadBase m n
     )
  => Handle m h
  -> Cell (HandlingStateT m) arbitrary h
handling :: Handle m h -> Cell (HandlingStateT m) arbitrary h
handling handleImpl :: Handle m h
handleImpl@Handle { m h
h -> m ()
destroy :: h -> m ()
create :: m h
destroy :: forall (m :: * -> *) h. Handle m h -> h -> m ()
create :: forall (m :: * -> *) h. Handle m h -> m h
.. } = Cell :: forall (m :: * -> *) a b s.
Data s =>
s -> (s -> a -> m (b, s)) -> Cell m a b
Cell
  { cellState :: Handling h
cellState = Handling h
forall h. Handling h
Uninitialized
  , cellStep :: Handling h -> arbitrary -> HandlingStateT m (h, Handling h)
cellStep = \Handling h
state arbitrary
input -> case Handling h
state of
      handling :: Handling h
handling@Handling { h
Key
handle :: h
id :: Key
handle :: forall h. Handling h -> h
id :: forall h. Handling h -> Key
.. } -> do
        Handle m h -> Handling h -> HandlingStateT m ()
forall (m :: * -> *) h.
Monad m =>
Handle m h -> Handling h -> HandlingStateT m ()
reregister Handle m h
handleImpl Handling h
handling
        (h, Handling h) -> HandlingStateT m (h, Handling h)
forall (m :: * -> *) a. Monad m => a -> m a
return (h
handle, Handling h
state)
      Handling h
Uninitialized -> do
        h
handle <- m h -> StateT (HandlingState m) m h
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m h
create
        Key
id <- Handle m h -> h -> HandlingStateT m Key
forall (m :: * -> *) h.
Monad m =>
Handle m h -> h -> HandlingStateT m Key
register Handle m h
handleImpl h
handle
        (h, Handling h) -> HandlingStateT m (h, Handling h)
forall (m :: * -> *) a. Monad m => a -> m a
return (h
handle, Handling :: forall h. Key -> h -> Handling h
Handling { h
Key
id :: Key
handle :: h
handle :: h
id :: Key
.. })
  }

register
  :: Monad m
  => Handle m h
  -> h
  -> HandlingStateT m Key
register :: Handle m h -> h -> HandlingStateT m Key
register Handle m h
handleImpl h
handle = do
  HandlingState { Key
Destructors m
destructors :: Destructors m
nHandles :: Key
destructors :: forall (m :: * -> *). HandlingState m -> Destructors m
nHandles :: forall (m :: * -> *). HandlingState m -> Key
.. } <- StateT (HandlingState m) m (HandlingState m)
forall (m :: * -> *) s. Monad m => StateT s m s
get
  let id :: Key
id = Key
nHandles Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1
  HandlingState m -> StateT (HandlingState m) m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put HandlingState :: forall (m :: * -> *). Key -> Destructors m -> HandlingState m
HandlingState
    { nHandles :: Key
nHandles = Key
id
    , destructors :: Destructors m
destructors = Handle m h -> Key -> h -> Destructors m -> Destructors m
forall (m :: * -> *) h.
Handle m h -> Key -> h -> Destructors m -> Destructors m
insertDestructor Handle m h
handleImpl Key
id h
handle Destructors m
destructors
    }
  Key -> HandlingStateT m Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
id

reregister
  :: Monad m
  => Handle m h
  -> Handling h
  -> HandlingStateT m ()
reregister :: Handle m h -> Handling h -> HandlingStateT m ()
reregister Handle m h
handleImpl Handling { h
Key
handle :: h
id :: Key
handle :: forall h. Handling h -> h
id :: forall h. Handling h -> Key
.. } = do
  HandlingState { Key
Destructors m
destructors :: Destructors m
nHandles :: Key
destructors :: forall (m :: * -> *). HandlingState m -> Destructors m
nHandles :: forall (m :: * -> *). HandlingState m -> Key
.. } <- StateT (HandlingState m) m (HandlingState m)
forall (m :: * -> *) s. Monad m => StateT s m s
get
  HandlingState m -> HandlingStateT m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put HandlingState :: forall (m :: * -> *). Key -> Destructors m -> HandlingState m
HandlingState { destructors :: Destructors m
destructors = Handle m h -> Key -> h -> Destructors m -> Destructors m
forall (m :: * -> *) h.
Handle m h -> Key -> h -> Destructors m -> Destructors m
insertDestructor Handle m h
handleImpl Key
id h
handle Destructors m
destructors, Key
nHandles :: Key
nHandles :: Key
.. }

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

unregisterAll
  :: Monad m
  => HandlingStateT m ()
unregisterAll :: 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
.. } <- StateT (HandlingState m) m (HandlingState m)
forall (m :: * -> *) s. Monad m => StateT s m s
get
  let newDestructors :: Destructors m
newDestructors = (Destructor m -> Destructor m) -> Destructors m -> Destructors m
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
  HandlingState m -> HandlingStateT m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put HandlingState :: forall (m :: * -> *). Key -> Destructors m -> HandlingState m
HandlingState { destructors :: Destructors m
destructors = Destructors m
newDestructors, Key
nHandles :: Key
nHandles :: Key
.. }

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

-- * 'Data' instances

dataTypeHandling :: DataType
dataTypeHandling :: DataType
dataTypeHandling = String -> [Constr] -> DataType
mkDataType String
"Handling" [Constr
handlingConstr, Constr
uninitializedConstr]

handlingConstr :: Constr
handlingConstr :: Constr
handlingConstr = DataType -> String -> [String] -> Fixity -> Constr
mkConstr DataType
dataTypeHandling String
"Handling" [] Fixity
Prefix

uninitializedConstr :: Constr
uninitializedConstr :: Constr
uninitializedConstr = DataType -> String -> [String] -> Fixity -> Constr
mkConstr DataType
dataTypeHandling String
"Uninitialized" [] Fixity
Prefix

instance (Typeable h) => Data (Handling h) where
  dataTypeOf :: Handling h -> DataType
dataTypeOf Handling h
_ = DataType
dataTypeHandling
  toConstr :: Handling h -> Constr
toConstr Handling { h
Key
handle :: h
id :: Key
handle :: forall h. Handling h -> h
id :: forall h. Handling h -> Key
.. } = Constr
handlingConstr
  toConstr Handling h
Uninitialized = Constr
uninitializedConstr
  gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Handling h)
gunfold forall b r. Data b => c (b -> r) -> c r
_cons forall r. r -> c r
nil Constr
constructor = Handling h -> c (Handling h)
forall r. r -> c r
nil Handling h
forall h. Handling h
Uninitialized

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 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
_ = String -> Constr -> c (Destructor m)
forall a. HasCallStack => String -> a
error String
"Destructor.gunfold"