{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module LiveCoding.Handle where

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

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

-- mmorph
import Control.Monad.Morph

-- essence-of-live-coding
import LiveCoding.Cell
import LiveCoding.HandlingState

{- | 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 reloads occuring during 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 ()
  }

instance MFunctor Handle where
  hoist :: (forall a. m a -> n a) -> Handle m b -> Handle n b
hoist forall a. m a -> n a
morphism Handle { m b
b -> m ()
destroy :: b -> m ()
create :: m b
destroy :: forall (m :: * -> *) h. Handle m h -> h -> m ()
create :: forall (m :: * -> *) h. Handle m h -> m h
.. } = Handle :: forall (m :: * -> *) h. m h -> (h -> m ()) -> Handle m h
Handle
    { create :: n b
create = m b -> n b
forall a. m a -> n a
morphism m b
create
    , destroy :: b -> n ()
destroy = m () -> n ()
forall a. m a -> n a
morphism (m () -> n ()) -> (b -> m ()) -> b -> n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> m ()
destroy
    }

{- | 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
  }

{- | 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
     )
  => Handle m h
  -> Cell (HandlingStateT m) arbitrary h
handling :: Handle m h -> Cell (HandlingStateT m) arbitrary h
handling Handle m h
handle = (arbitrary -> ()) -> Cell (HandlingStateT m) arbitrary ()
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (() -> arbitrary -> ()
forall a b. a -> b -> a
const ()) Cell (HandlingStateT m) arbitrary ()
-> Cell (HandlingStateT m) () h
-> Cell (HandlingStateT m) arbitrary h
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ParametrisedHandle () m h -> Cell (HandlingStateT m) () h
forall h p (m :: * -> *).
(Typeable h, Typeable p, Monad m, Eq p) =>
ParametrisedHandle p m h -> Cell (HandlingStateT m) p h
handlingParametrised (Handle m h -> ParametrisedHandle () m h
forall (m :: * -> *) h.
Monad m =>
Handle m h -> ParametrisedHandle () m h
toParametrised Handle m h
handle)

{- | Generalisation of 'Handle' carrying an additional parameter which may change at runtime.

Like in a 'Handle', the @h@ value of a 'ParametrisedHandle' is preserved through live coding reloads.
Additionally, the parameter @p@ value can be adjusted,
and triggers a destruction and reinitialisation whenever it changes.
-}
data ParametrisedHandle p m h = ParametrisedHandle
  { ParametrisedHandle p m h -> p -> m h
createParametrised :: p -> m h
  , ParametrisedHandle p m h -> p -> p -> h -> m h
changeParametrised :: p -> p -> h -> m h
  , ParametrisedHandle p m h -> p -> h -> m ()
destroyParametrised :: p -> h -> m ()
  }

instance MFunctor (ParametrisedHandle p) where
  hoist :: (forall a. m a -> n a)
-> ParametrisedHandle p m b -> ParametrisedHandle p n b
hoist forall a. m a -> n a
morphism ParametrisedHandle { p -> m b
p -> p -> b -> m b
p -> b -> m ()
destroyParametrised :: p -> b -> m ()
changeParametrised :: p -> p -> b -> m b
createParametrised :: p -> m b
destroyParametrised :: forall p (m :: * -> *) h.
ParametrisedHandle p m h -> p -> h -> m ()
changeParametrised :: forall p (m :: * -> *) h.
ParametrisedHandle p m h -> p -> p -> h -> m h
createParametrised :: forall p (m :: * -> *) h. ParametrisedHandle p m h -> p -> m h
.. } = ParametrisedHandle :: forall p (m :: * -> *) h.
(p -> m h)
-> (p -> p -> h -> m h)
-> (p -> h -> m ())
-> ParametrisedHandle p m h
ParametrisedHandle
    { createParametrised :: p -> n b
createParametrised = m b -> n b
forall a. m a -> n a
morphism (m b -> n b) -> (p -> m b) -> p -> n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> m b
createParametrised
    , changeParametrised :: p -> p -> b -> n b
changeParametrised = ((m b -> n b
forall a. m a -> n a
morphism (m b -> n b) -> (b -> m b) -> b -> n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((b -> m b) -> b -> n b) -> (p -> b -> m b) -> p -> b -> n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((p -> b -> m b) -> p -> b -> n b)
-> (p -> p -> b -> m b) -> p -> p -> b -> n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> p -> b -> m b
changeParametrised
    , destroyParametrised :: p -> b -> n ()
destroyParametrised = (m () -> n ()
forall a. m a -> n a
morphism (m () -> n ()) -> (b -> m ()) -> b -> n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((b -> m ()) -> b -> n ()) -> (p -> b -> m ()) -> p -> b -> n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> b -> m ()
destroyParametrised
    }

-- | Given the methods 'createParametrised' and 'destroyParametrised',
--   build a fitting method for 'changeParametrised' which
defaultChange :: (Eq p, Monad m) => (p -> m h) -> (p -> h -> m ()) -> p -> p -> h -> m h
defaultChange :: (p -> m h) -> (p -> h -> m ()) -> p -> p -> h -> m h
defaultChange p -> m h
creator p -> h -> m ()
destructor p
pOld p
pNew h
h
  | p
pOld p -> p -> Bool
forall a. Eq a => a -> a -> Bool
== p
pNew = h -> m h
forall (m :: * -> *) a. Monad m => a -> m a
return h
h
  | Bool
otherwise    = do
      p -> h -> m ()
destructor p
pOld h
h
      p -> m h
creator p
pNew

-- | Like 'combineHandles', but for 'ParametrisedHandle's.
combineParametrisedHandles
  :: Applicative m
  => ParametrisedHandle  p1      m  h1
  -> ParametrisedHandle      p2  m      h2
  -> ParametrisedHandle (p1, p2) m (h1, h2)
combineParametrisedHandles :: ParametrisedHandle p1 m h1
-> ParametrisedHandle p2 m h2
-> ParametrisedHandle (p1, p2) m (h1, h2)
combineParametrisedHandles ParametrisedHandle p1 m h1
handle1 ParametrisedHandle p2 m h2
handle2 = ParametrisedHandle :: forall p (m :: * -> *) h.
(p -> m h)
-> (p -> p -> h -> m h)
-> (p -> h -> m ())
-> ParametrisedHandle p m h
ParametrisedHandle
  { createParametrised :: (p1, p2) -> m (h1, h2)
createParametrised = \(p1
p1, p2
p2) -> ( , ) (h1 -> h2 -> (h1, h2)) -> m h1 -> m (h2 -> (h1, h2))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParametrisedHandle p1 m h1 -> p1 -> m h1
forall p (m :: * -> *) h. ParametrisedHandle p m h -> p -> m h
createParametrised ParametrisedHandle p1 m h1
handle1 p1
p1 m (h2 -> (h1, h2)) -> m h2 -> m (h1, h2)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParametrisedHandle p2 m h2 -> p2 -> m h2
forall p (m :: * -> *) h. ParametrisedHandle p m h -> p -> m h
createParametrised ParametrisedHandle p2 m h2
handle2 p2
p2
  , changeParametrised :: (p1, p2) -> (p1, p2) -> (h1, h2) -> m (h1, h2)
changeParametrised = \(p1
pOld1, p2
pOld2) (p1
pNew1, p2
pNew2) (h1
h1, h2
h2) -> ( , ) (h1 -> h2 -> (h1, h2)) -> m h1 -> m (h2 -> (h1, h2))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParametrisedHandle p1 m h1 -> p1 -> p1 -> h1 -> m h1
forall p (m :: * -> *) h.
ParametrisedHandle p m h -> p -> p -> h -> m h
changeParametrised ParametrisedHandle p1 m h1
handle1 p1
pOld1 p1
pNew1 h1
h1 m (h2 -> (h1, h2)) -> m h2 -> m (h1, h2)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParametrisedHandle p2 m h2 -> p2 -> p2 -> h2 -> m h2
forall p (m :: * -> *) h.
ParametrisedHandle p m h -> p -> p -> h -> m h
changeParametrised ParametrisedHandle p2 m h2
handle2 p2
pOld2 p2
pNew2 h2
h2
  , destroyParametrised :: (p1, p2) -> (h1, h2) -> m ()
destroyParametrised = \(p1
p1, p2
p2) (h1
h1, h2
h2) -> ParametrisedHandle p1 m h1 -> p1 -> h1 -> m ()
forall p (m :: * -> *) h.
ParametrisedHandle p m h -> p -> h -> m ()
destroyParametrised ParametrisedHandle p1 m h1
handle1 p1
p1 h1
h1 m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParametrisedHandle p2 m h2 -> p2 -> h2 -> m ()
forall p (m :: * -> *) h.
ParametrisedHandle p m h -> p -> h -> m ()
destroyParametrised ParametrisedHandle p2 m h2
handle2 p2
p2 h2
h2
  }

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

Upon the first tick, directly after migration, and after each parameter change,
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, or the parameter changes.
A parameter change triggers the destructor immediately,
but if the cell 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 parametrised handles are only migrated if they have exactly the same type.
-}
handlingParametrised
  :: ( Typeable h, Typeable p
     , Monad m
     , Eq p
     )
  => ParametrisedHandle p m h
  -> Cell (HandlingStateT m) p h
handlingParametrised :: ParametrisedHandle p m h -> Cell (HandlingStateT m) p h
handlingParametrised handleImpl :: ParametrisedHandle p m h
handleImpl@ParametrisedHandle { p -> m h
p -> h -> m ()
p -> p -> h -> m h
destroyParametrised :: p -> h -> m ()
changeParametrised :: p -> p -> h -> m h
createParametrised :: p -> m h
destroyParametrised :: forall p (m :: * -> *) h.
ParametrisedHandle p m h -> p -> h -> m ()
changeParametrised :: forall p (m :: * -> *) h.
ParametrisedHandle p m h -> p -> p -> h -> m h
createParametrised :: forall p (m :: * -> *) h. ParametrisedHandle p m h -> p -> m h
.. } = Cell :: forall (m :: * -> *) a b s.
Data s =>
s -> (s -> a -> m (b, s)) -> Cell m a b
Cell { Handling (h, p)
Handling (h, p)
-> p -> StateT (HandlingState m) m (h, Handling (h, p))
forall h. Handling h
cellStep :: Handling (h, p)
-> p -> StateT (HandlingState m) m (h, Handling (h, p))
cellState :: Handling (h, p)
cellStep :: Handling (h, p)
-> p -> StateT (HandlingState m) m (h, Handling (h, p))
cellState :: forall h. Handling h
.. }
  where
    cellState :: Handling h
cellState = Handling h
forall h. Handling h
Uninitialized
    cellStep :: Handling (h, p)
-> p -> StateT (HandlingState m) m (h, Handling (h, p))
cellStep Handling (h, p)
Uninitialized p
parameter = do
      h
mereHandle <- m h -> StateT (HandlingState m) m h
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m h -> StateT (HandlingState m) m h)
-> m h -> StateT (HandlingState m) m h
forall a b. (a -> b) -> a -> b
$ p -> m h
createParametrised p
parameter
      let handle :: (h, p)
handle = (h
mereHandle, p
parameter)
      Key
key <- m () -> HandlingStateT m Key
forall (m :: * -> *). Monad m => m () -> HandlingStateT m Key
register (m () -> HandlingStateT m Key) -> m () -> HandlingStateT m Key
forall a b. (a -> b) -> a -> b
$ p -> h -> m ()
destroyParametrised p
parameter h
mereHandle
      (h, Handling (h, p))
-> StateT (HandlingState m) m (h, Handling (h, p))
forall (m :: * -> *) a. Monad m => a -> m a
return (h
mereHandle, Handling :: forall h. Key -> h -> Handling h
Handling { handle :: (h, p)
handle = (h, p)
handle, Key
key :: Key
key :: Key
.. })
    cellStep handling :: Handling (h, p)
handling@Handling { handle :: forall h. Handling h -> h
handle = (h
mereHandle, p
lastParameter), Key
key :: Key
key :: forall h. Handling h -> Key
.. } p
parameter
      | p
parameter p -> p -> Bool
forall a. Eq a => a -> a -> Bool
== p
lastParameter = do
          m () -> Key -> HandlingStateT m ()
forall (m :: * -> *). Monad m => m () -> Key -> HandlingStateT m ()
reregister (p -> h -> m ()
destroyParametrised p
parameter h
mereHandle) Key
key
          (h, Handling (h, p))
-> StateT (HandlingState m) m (h, Handling (h, p))
forall (m :: * -> *) a. Monad m => a -> m a
return (h
mereHandle, Handling (h, p)
handling)
      | Bool
otherwise = do
          h
mereHandle <- m h -> StateT (HandlingState m) m h
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m h -> StateT (HandlingState m) m h)
-> m h -> StateT (HandlingState m) m h
forall a b. (a -> b) -> a -> b
$ p -> p -> h -> m h
changeParametrised p
lastParameter p
parameter h
mereHandle
          m () -> Key -> HandlingStateT m ()
forall (m :: * -> *). Monad m => m () -> Key -> HandlingStateT m ()
reregister (p -> h -> m ()
destroyParametrised p
parameter h
mereHandle) Key
key
          (h, Handling (h, p))
-> StateT (HandlingState m) m (h, Handling (h, p))
forall (m :: * -> *) a. Monad m => a -> m a
return (h
mereHandle, Handling :: forall h. Key -> h -> Handling h
Handling { handle :: (h, p)
handle = (h
mereHandle, p
parameter), Key
key :: Key
key :: Key
.. })

-- | Every 'Handle' is trivially a 'ParametrisedHandle'
--   when the parameter is the trivial type.
toParametrised :: Monad m => Handle m h -> ParametrisedHandle () m h
toParametrised :: Handle m h -> ParametrisedHandle () m h
toParametrised 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
.. } = ParametrisedHandle :: forall p (m :: * -> *) h.
(p -> m h)
-> (p -> p -> h -> m h)
-> (p -> h -> m ())
-> ParametrisedHandle p m h
ParametrisedHandle
  { createParametrised :: () -> m h
createParametrised = m h -> () -> m h
forall a b. a -> b -> a
const m h
create
  , changeParametrised :: () -> () -> h -> m h
changeParametrised = (() -> h -> m h) -> () -> () -> h -> m h
forall a b. a -> b -> a
const ((() -> h -> m h) -> () -> () -> h -> m h)
-> (() -> h -> m h) -> () -> () -> h -> m h
forall a b. (a -> b) -> a -> b
$ (h -> m h) -> () -> h -> m h
forall a b. a -> b -> a
const h -> m h
forall (m :: * -> *) a. Monad m => a -> m a
return
  , destroyParametrised :: () -> h -> m ()
destroyParametrised = (h -> m ()) -> () -> h -> m ()
forall a b. a -> b -> a
const h -> m ()
destroy
  }