{-|
Module      : Graphics.QML.Transient.Property
License     : BSD3
Maintainer  : marcin.jan.mrotek@email.com
Stability   : experimental

Bindings to the property mechanism of QML, and functions to manipulate them.
'Prop's can be mapped and applied (think 'Functor' and 'Applicative') using 'Lens'es.
If you only need to read the value, you can use 'readonly' to obtain a 'PropRO', which is a regular 'Functor' and 'Applicative'.
-}

{-# LANGUAGE 
    DeriveFunctor
  , RankNTypes
  , TypeFamilies 
  #-}

module Graphics.QML.Transient.Property where

import Graphics.QML.Transient.Internal.Types 
import Graphics.QML.Transient.Internal

import Control.Concurrent.STM
import Control.Concurrent.MVar
import Control.Lens
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Transient hiding (spawn)
import Data.Foldable
import qualified Data.IntMap.Strict as Map
import Data.IORef
import Data.Typeable
import Graphics.QML

{-| A property is a mutable cell of memory, usually accessible to the QML side.
Getting and setting actions are kept separate - when a value is set, only action using the 'get' are ran.
-}
data Prop a = Prop 
  { get  :: React a     -- ^A callback that is ran whenever its value changes.
  , put  :: a -> Qml () -- ^An action that changes the value.
  , peek :: IO a        -- ^Look at the value of the property without triggering the computation whenever it's changed.
  }

modifyProp :: Prop a -> (a -> a) -> Qml ()
-- ^Apply a function to the contents of a 'Prop', triggering any computations that depend on it.
modifyProp (Prop _ s p) f = s =<< f <$> liftIO p

mapProp :: Lens' a b -> Prop a -> Prop b
{-^ A 'Functor' 'fmap' analog for properties - a mapping from 'Lens'es into functions of properties.
As the 'Prop' type is both covariant and contravariant in its argument, 
it cannot be mapped with a single function, only with a lens; 
'peek' is used internally to retrieve the value of the property at the moment of setting.
The 'get' callback and the 'set' action are left uncoupled.
-}
mapProp l (Prop g s p) = Prop 
  { get = view l <$> g
  , put = \b -> s =<< (liftIO p <&> l .~ b)
  , peek = view l <$> p
  }

applyProp :: Prop (ALens' a b) -> Prop a -> Prop b
-- ^An 'Applicative' '<*>' analog.
applyProp (Prop gl _ pl) (Prop g s p) = Prop
  { get = (^#) <$> g <*> gl
  , put = \b -> do
    l <- liftIO pl
    a <- liftIO p
    s $ a & l #~ b
  , peek = (^#) <$> p <*> pl
  }

pairProp :: Prop a -> Prop b -> Prop (a,b)
{-^ A pairing combinator, provided as an alternative to 'applyProp'.
As curried 'Iso's are uncommon, using 'applyProp' with multiple 'Prop's can be cumbersome.
-}
pairProp (Prop g1 s1 p1) (Prop g2 s2 p2) = Prop { get = (,) <$> g1 <*> g2 , put = \(a,b) -> s1 a >> s2 b , peek = (,) <$> p1 <*> p2 }

tupleProp2 :: Prop a -> Prop b -> Prop (a,b)
-- ^Synonym to 'pairProp'.
tupleProp2 = pairProp

tupleProp3 :: Prop a -> Prop b -> Prop c -> Prop (a, b, c)
tupleProp3 (Prop g1 s1 p1) (Prop g2 s2 p2) (Prop g3 s3 p3) = Prop
  { get = (,,) <$> g1 <*> g2 <*> g3
  , put = \(a,b,c) -> s1 a >> s2 b >> s3 c
  , peek = (,,) <$> p1 <*> p2 <*> p3
  }

tupleProp4 :: Prop a -> Prop b -> Prop c -> Prop d -> Prop (a, b, c, d)
tupleProp4 (Prop g1 s1 p1) (Prop g2 s2 p2) (Prop g3 s3 p3) (Prop g4 s4 p4) = Prop
  { get = (,,,) <$> g1 <*> g2 <*> g3 <*> g4
  , put = \(a,b,c,d) -> s1 a >> s2 b >> s3 c >> s4 d
  , peek = (,,,) <$> p1 <*> p2 <*> p3 <*> p4
  }

tupleProp5 :: Prop a -> Prop b -> Prop c -> Prop d -> Prop e -> Prop (a, b, c, d, e)
tupleProp5 (Prop g1 s1 p1) (Prop g2 s2 p2) (Prop g3 s3 p3) (Prop g4 s4 p4) (Prop g5 s5 p5) = Prop
  { get = (,,,,) <$> g1 <*> g2 <*> g3 <*> g4 <*> g5
  , put = \(a,b,c,d,e) -> s1 a >> s2 b >> s3 c >> s4 d >> s5 e
  , peek = (,,,,) <$> p1 <*> p2 <*> p3 <*> p4 <*> p5
  }

tupleProp6 :: Prop a -> Prop b -> Prop c -> Prop d -> Prop e -> Prop f -> Prop (a, b, c, d, e, f)
tupleProp6 (Prop g1 s1 p1) (Prop g2 s2 p2) (Prop g3 s3 p3) (Prop g4 s4 p4) (Prop g5 s5 p5) (Prop g6 s6 p6) = Prop
  { get = (,,,,,) <$> g1 <*> g2 <*> g3 <*> g4 <*> g5 <*> g6
  , put = \(a,b,c,d,e,f) -> s1 a >> s2 b >> s3 c >> s4 d >> s5 e >> s6 f
  , peek = (,,,,,) <$> p1 <*> p2 <*> p3 <*> p4 <*> p5 <*> p6
  }

data PropRO a = PropRO { getRO :: React a , peekRO :: IO a }
  deriving Functor

instance Applicative PropRO where
  pure = PropRO <$> pure <*> pure
  PropRO fg fp <*> PropRO xg xp = PropRO (fg <*> xg) (fp <*> xp)

readonly :: Prop a -> PropRO a
-- ^Any property can be referenced as if it was read-only.
readonly (Prop g _ p) = PropRO g p

pureProp :: a -> Build (Prop a)
{-^ Analogous to 'pure'.
-}
pureProp a = do
  store'ir <- liftIO $ newIORef a
  handlers'tv <- liftIO $ newTVarIO Map.empty
  let addHandler = do
         mv <- liftIO $ do
          mv <- newMVar ()
          atomically $ do
            handlers <- readTVar handlers'tv
            let handlerN = length handlers
            modifyTVar handlers'tv 
              $ Map.insert handlerN mv
            pure ()
          pure mv
         waitEvents $ takeMVar mv
         liftIO $ readIORef store'ir
      write val = do 
        atomicWriteIORef store'ir val
        handlers <- readTVarIO handlers'tv 
        for_ handlers $ \mv -> putMVar mv ()
  pure $ Prop (React addHandler) (liftIO.write) (readIORef store'ir)

propertyConst
  :: ( Typeable a
     , Marshal a
     , CanReturnTo a ~ Yes
     )
  => String -> a -> Build ()
-- ^A constant field of a Qml object.
propertyConst name = 
    addMember 
  . defPropertyConst' name 
  . const . return

propertySelf 
  :: String -> Build ()
-- ^A self referencing field, useful for connecting signals in QML.
propertySelf name = addMember $ defPropertyConst' name return

propertyRO
  :: ( Typeable a
     , Marshal a
     , CanReturnTo a ~ Yes
     ) 
  => String -> a -> Build (Prop a)
-- ^A field that is read-only from the QML side.
propertyRO name initial = do
  handlers'tv <- liftIO $ newTVarIO Map.empty
  skey <- liftIO newSignalKey
  store'ir <- liftIO $ newIORef initial
  let write val = do
        atomicWriteIORef store'ir val
        handlers <- readTVarIO handlers'tv
        traverse_ ($ val) handlers
      callback i action =
          atomically 
        . modifyTVar' handlers'tv
        $ Map.insert i action
      putQml t a = liftIO $ do
        write a
        fireSignal skey t
      addHandler = do
        handlerN <- liftIO . atomically $ do
          handlers <- readTVar handlers'tv
          let handlerN = length handlers
          modifyTVar handlers'tv 
            $ Map.insert handlerN (const $ pure ())
          pure handlerN
        liftTrans
          . react (callback handlerN)
          $ return ()
  addMember $ defPropertySigRO' name skey (const $ readIORef store'ir)
  return 
    $ Prop (React addHandler)
    ( \a -> Qml . ReaderT $ \t -> putQml t a )
    ( readIORef store'ir )

propertyRW 
  :: ( Typeable a
     , Marshal a
     , CanReturnTo a ~ Yes
     , CanGetFrom a ~ Yes
     ) 
  => String -> a -> Build (Prop a)
-- ^A field that is readable and writable from both sides.
propertyRW name initial = do
  handlers'tv <- liftIO $ newTVarIO Map.empty
  skey <- liftIO newSignalKey
  store'ir <- liftIO $ newIORef initial
  let write val = do
        atomicWriteIORef store'ir val
        handlers <- readTVarIO handlers'tv
        traverse_ ($ val) handlers
      callback i action =
          atomically 
        . modifyTVar' handlers'tv
        $ Map.insert i action
      putQml t a = liftIO $ do
        write a
        fireSignal skey t 
      addHandler = do
        handlerN <- liftIO . atomically $ do
          handlers <- readTVar handlers'tv
          let handlerN = length handlers
          modifyTVar handlers'tv 
            $ Map.insert handlerN (const $ pure ())
          pure handlerN
        liftTrans
          . react (callback handlerN)
          $ return ()
  addMember $ defPropertySigRW' name skey (const $ readIORef store'ir) (const write)
  return 
    $ Prop (React addHandler)
    ( \a -> Qml . ReaderT $ \t -> putQml t a )
    ( readIORef store'ir )

