{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
module LiveCoding.HandlingState where
import Control.Arrow (arr, returnA, (>>>))
import Data.Data
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.State.Strict
import Data.Foldable (traverse_)
import Data.IntMap
import qualified Data.IntMap as IntMap
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)
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)
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
}
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
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
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 =>
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
..}
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"