mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-09-20 16:27:49 +03:00
82 lines
2.0 KiB
Haskell
82 lines
2.0 KiB
Haskell
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
module TestComposite (testComposite) where
|
|
|
|
import Debug.Trace
|
|
|
|
import Codec.Serialise
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Lens
|
|
import Control.Monad (forM_)
|
|
|
|
import Data.Default
|
|
import GHC.Generics
|
|
import TextShow
|
|
|
|
import Monomer.Core.Combinators
|
|
import Monomer.Core.Style
|
|
import Monomer.Graphics.Color
|
|
import Monomer.Core.WidgetTypes
|
|
import Monomer.Core.Util
|
|
import Monomer.Widgets
|
|
|
|
import Types
|
|
|
|
data CompState = CompState {
|
|
_csCounter :: Int,
|
|
_csProduced :: Int
|
|
} deriving (Show, Eq, Generic, Serialise)
|
|
|
|
instance Default CompState where
|
|
def = CompState 0 0
|
|
|
|
makeLenses ''CompState
|
|
|
|
data CompEvent
|
|
= InitComposite
|
|
| MessageParent
|
|
| CallSandbox
|
|
| StartTask
|
|
| StartProducer
|
|
| HandleProducer Int
|
|
deriving (Eq, Show)
|
|
|
|
testComposite :: WidgetNode CompState AppEvent
|
|
testComposite = composite "testComposite" id (Just InitComposite) buildComposite handleCompositeEvent
|
|
|
|
handleCompositeEvent wenv model evt = case evt of
|
|
InitComposite -> [Task $ do
|
|
threadDelay 1000
|
|
putStrLn "Initialized composite"
|
|
return Nothing]
|
|
MessageParent -> [Report IncreaseMessage]
|
|
CallSandbox -> [Event (HandleProducer 20), Task $ return Nothing]
|
|
StartTask -> [Task $ do
|
|
putStrLn "Composite event handler called"
|
|
return Nothing]
|
|
StartProducer -> [Producer $ \sendMessage ->
|
|
forM_ [1..10] $ \_ -> do
|
|
sendMessage (HandleProducer 1)
|
|
threadDelay $ 1000 * 1000]
|
|
HandleProducer val -> [Model $ model & csProduced %~ (+val)]
|
|
|
|
buildComposite wenv model = trace "Created composite UI" $
|
|
vgrid [
|
|
scroll $ label "This is a composite label!",
|
|
scroll $ label "This is a composite label again!",
|
|
vgrid [
|
|
hgrid [
|
|
button "Message parent" MessageParent
|
|
],
|
|
hgrid [
|
|
button "Run task" StartTask
|
|
],
|
|
hgrid [
|
|
button "Run Producer" StartProducer,
|
|
label ("Produced: " <> showt (_csProduced model))
|
|
]
|
|
] `style` [bgColor gray]
|
|
]
|