module Internal.UICircuit (
UICircuit (UICircuit),
fromCircuit,
run
) where
import Prelude hiding ((.))
import Control.Category as Category hiding (id)
import qualified Control.Category as Category
import Control.Arrow as Arrow
import Control.Arrow.Transformer.Reader as ReaderArrow
import Control.Concurrent.MVar as MVar
import FRP.Grapefruit.Circuit as Circuit
import FRP.Grapefruit.Signal as Signal
import FRP.Grapefruit.Signal.Discrete as DSignal
import Internal.UIItem as UIItem
import Graphics.UI.Grapefruit.Backend as UIBackend
import Graphics.UI.Grapefruit.Comp as UIComp
newtype UICircuit item uiBackend era i o = UICircuit (ReaderArrow (Placement item uiBackend)
(Circuit era)
i
o)
instance Category (UICircuit item uiBackend era) where
id = UICircuit Category.id
UICircuit arrow1 . UICircuit arrow2 = UICircuit (arrow1 . arrow2)
instance Arrow (UICircuit item uiBackend era) where
arr fun = UICircuit (arr fun)
first (UICircuit arrow) = UICircuit (first arrow)
second (UICircuit arrow) = UICircuit (second arrow)
UICircuit arrow1 *** UICircuit arrow2 = UICircuit (arrow1 *** arrow2)
UICircuit arrow1 &&& UICircuit arrow2 = UICircuit (arrow1 &&& arrow2)
instance ArrowLoop (UICircuit item uiBackend era) where
loop (UICircuit arrow) = UICircuit (Arrow.loop arrow)
instance UIComp UICircuit where
circuit |>> uiCircuit = fromCircuit circuit >>> uiCircuit
uiCircuit >>| circuit = uiCircuit >>> fromCircuit circuit
loop = Arrow.loop
toUICircuit = id
fromUIItem (UIItem uiCircuit) = uiCircuit
fromCircuit :: Circuit era i o -> UICircuit item uiBackend era i o
fromCircuit = liftReader >>> UICircuit
run :: (UIBackend uiBackend)
=> uiBackend
-> (forall era. UICircuit Window uiBackend era i (DSignal era o))
-> i
-> IO o
run uiBackend uiCircuit i = run where
run = do
oMVar <- newEmptyMVar
UIBackend.initialize uiBackend
let
circuitCreation = Circuit.create
(proc _ -> do
quittingReq <- runReader $
case uiCircuit of
UICircuit arrow -> arrow
-< (i,topLevel uiBackend)
consume $ DSignal.consumer qReqHdlr -< quittingReq)
()
qReqHdlr o = do
requestQuitting uiBackend
putMVar oMVar o
(_,finalizeCircuit) <- circuitCreation
UIBackend.handleEvents uiBackend
finalizeCircuit
UIBackend.finalize uiBackend
takeMVar oMVar