{-# OPTIONS -fplugin=WidgetRattus.Plugin #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE TypeOperators #-}
module WidgetRattus.Widgets
( Displayable (..)
, IsWidget (..)
, Widgets (..)
, Widget
, HStack
, VStack
, TextDropdown
, tddCurr
, tddEvent
, tddList
, Popup
, popCurr
, popEvent
, popChild
, Slider
, sldCurr
, sldEvent
, sldMin
, sldMax
, Button
, btnContent
, btnClick
, Label
, labText
, TextField
, tfContent
, tfInput
, mkButton
, mkTextField
, addInputSigTF
, mkLabel
, mkHStack
, mkConstHStack
, mkVStack
, mkConstVStack
, mkTextDropdown
, mkPopup
, mkSlider
, mkProgressBar
, btnOnClick
, btnOnClickSig
, setInputSigTF
, textFieldOnInput
, textFieldOnInputSig
, runApplication
) where
import WidgetRattus
import WidgetRattus.Widgets.InternalTypes
import WidgetRattus.Signal
import Data.Text
import WidgetRattus.InternalPrimitives
import System.IO.Unsafe
import Control.Concurrent hiding (Chan)
import Data.IntSet as IntSet
import Prelude hiding (const)
import qualified Monomer as M
instance Displayable Text where
display :: Text -> Text
display Text
x = Text
x
instance Displayable Int where
display :: Int -> Text
display Int
x = Int -> Text
forall a. Show a => a -> Text
toText Int
x
instance Displayable Time where
display :: Time -> Text
display = Time -> Text
forall a. Show a => a -> Text
toText
instance Displayable NominalDiffTime where
display :: NominalDiffTime -> Text
display = NominalDiffTime -> Text
forall a. Show a => a -> Text
toText
mkButton :: (Displayable a) => Sig a -> C Button
mkButton :: forall a. Displayable a => Sig a -> C Button
mkButton Sig a
t = do
Chan ()
c <- C (Chan ())
forall a. C (Chan a)
chan
Button -> C Button
forall a. a -> C a
forall (m :: * -> *) a. Monad m => a -> m a
return Button{btnContent :: Sig a
btnContent = Sig a
t, btnClick :: Chan ()
btnClick = Chan ()
c}
mkTextField :: Text -> C TextField
mkTextField :: Text -> C TextField
mkTextField Text
txt = do
Chan Text
c <- C (Chan Text)
forall a. C (Chan a)
chan
let sig :: Sig Text
sig = Text
txt Text -> O (Sig Text) -> Sig Text
forall a. a -> O (Sig a) -> Sig a
::: Box (O Text) -> O (Sig Text)
forall a. Box (O a) -> O (Sig a)
mkSig (O Text -> Box (O Text)
forall a. a -> Box a
box (Chan Text -> O Text
forall a. Chan a -> O a
wait Chan Text
c))
TextField -> C TextField
forall a. a -> C a
forall (m :: * -> *) a. Monad m => a -> m a
return TextField{tfContent :: Sig Text
tfContent = Sig Text
sig, tfInput :: Chan Text
tfInput = Chan Text
c}
mkLabel :: (Displayable a) => Sig a -> C Label
mkLabel :: forall a. Displayable a => Sig a -> C Label
mkLabel Sig a
t = do
Label -> C Label
forall a. a -> C a
forall (m :: * -> *) a. Monad m => a -> m a
return Label{labText :: Sig a
labText = Sig a
t}
class Widgets ws where
toWidgetList :: ws -> List Widget
instance {-# OVERLAPPABLE #-} IsWidget w => Widgets w where
toWidgetList :: w -> List Widget
toWidgetList w
w = [ w -> Widget
forall a. IsWidget a => a -> Widget
mkWidget w
w ]
instance {-# OVERLAPPING #-} (Widgets w, Widgets v) => Widgets (w :* v) where
toWidgetList :: (w :* v) -> List Widget
toWidgetList (w
w :* v
v) = w -> List Widget
forall ws. Widgets ws => ws -> List Widget
toWidgetList w
w List Widget -> List Widget -> List Widget
forall a. List a -> List a -> List a
+++ v -> List Widget
forall ws. Widgets ws => ws -> List Widget
toWidgetList v
v
instance {-# OVERLAPPING #-} (Widgets w) => Widgets (List w) where
toWidgetList :: List w -> List Widget
toWidgetList List w
w = (w -> List Widget) -> List w -> List Widget
forall a b. (a -> List b) -> List a -> List b
concatMap' w -> List Widget
forall ws. Widgets ws => ws -> List Widget
toWidgetList List w
w
mkHStack :: IsWidget a => Sig(List a) -> C HStack
mkHStack :: forall a. IsWidget a => Sig (List a) -> C HStack
mkHStack Sig (List a)
wl = do
HStack -> C HStack
forall a. a -> C a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sig (List a) -> HStack
forall a. IsWidget a => Sig (List a) -> HStack
HStack Sig (List a)
wl)
mkConstHStack :: Widgets ws => ws -> C HStack
mkConstHStack :: forall ws. Widgets ws => ws -> C HStack
mkConstHStack ws
w = Sig (List Widget) -> C HStack
forall a. IsWidget a => Sig (List a) -> C HStack
mkHStack (List Widget -> Sig (List Widget)
forall a. a -> Sig a
const (ws -> List Widget
forall ws. Widgets ws => ws -> List Widget
toWidgetList ws
w))
mkVStack :: IsWidget a => Sig(List a) -> C VStack
mkVStack :: forall a. IsWidget a => Sig (List a) -> C VStack
mkVStack Sig (List a)
wl = do
VStack -> C VStack
forall a. a -> C a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sig (List a) -> VStack
forall a. IsWidget a => Sig (List a) -> VStack
VStack Sig (List a)
wl)
mkConstVStack :: Widgets ws => ws -> C VStack
mkConstVStack :: forall ws. Widgets ws => ws -> C VStack
mkConstVStack ws
w = Sig (List Widget) -> C VStack
forall a. IsWidget a => Sig (List a) -> C VStack
mkVStack (List Widget -> Sig (List Widget)
forall a. a -> Sig a
const (ws -> List Widget
forall ws. Widgets ws => ws -> List Widget
toWidgetList ws
w))
mkTextDropdown :: Sig (List Text) -> Text -> C TextDropdown
mkTextDropdown :: Sig (List Text) -> Text -> C TextDropdown
mkTextDropdown Sig (List Text)
opts Text
init = do
Chan Text
c <- C (Chan Text)
forall a. C (Chan a)
chan
let curr :: Sig Text
curr = Text
init Text -> O (Sig Text) -> Sig Text
forall a. a -> O (Sig a) -> Sig a
::: Box (O Text) -> O (Sig Text)
forall a. Box (O a) -> O (Sig a)
mkSig (O Text -> Box (O Text)
forall a. a -> Box a
box (Chan Text -> O Text
forall a. Chan a -> O a
wait Chan Text
c))
TextDropdown -> C TextDropdown
forall a. a -> C a
forall (m :: * -> *) a. Monad m => a -> m a
return TextDropdown{tddCurr :: Sig Text
tddCurr = Sig Text
curr, tddEvent :: Chan Text
tddEvent = Chan Text
c, tddList :: Sig (List Text)
tddList = Sig (List Text)
opts}
mkPopup :: Sig Bool -> Sig Widget -> C Popup
Sig Bool
b Sig Widget
w = do
Chan Bool
c <- C (Chan Bool)
forall a. C (Chan a)
chan
let sig :: Sig Bool
sig = Sig Bool -> Bool
forall a. Sig a -> a
current Sig Bool
b Bool -> O (Sig Bool) -> Sig Bool
forall a. a -> O (Sig a) -> Sig a
::: Box (Bool -> Bool -> Bool)
-> O (Sig Bool) -> O (Sig Bool) -> O (Sig Bool)
forall a. Box (a -> a -> a) -> O (Sig a) -> O (Sig a) -> O (Sig a)
interleave ((Bool -> Bool -> Bool) -> Box (Bool -> Bool -> Bool)
forall a. a -> Box a
box (\Bool
x Bool
_ -> Bool
x)) (Sig Bool -> O (Sig Bool)
forall a. Sig a -> O (Sig a)
future Sig Bool
b) (Box (O Bool) -> O (Sig Bool)
forall a. Box (O a) -> O (Sig a)
mkSig (O Bool -> Box (O Bool)
forall a. a -> Box a
box (Chan Bool -> O Bool
forall a. Chan a -> O a
wait Chan Bool
c)))
Popup -> C Popup
forall a. a -> C a
forall (m :: * -> *) a. Monad m => a -> m a
return Popup{popCurr :: Sig Bool
popCurr = Sig Bool
sig, popEvent :: Chan Bool
popEvent = Chan Bool
c, popChild :: Sig Widget
popChild = Sig Widget
w}
mkSlider :: Int -> Sig Int -> Sig Int -> C Slider
mkSlider :: Int -> Sig Int -> Sig Int -> C Slider
mkSlider Int
start Sig Int
min Sig Int
max = do
Chan Int
c <- C (Chan Int)
forall a. C (Chan a)
chan
let curr :: Sig Int
curr = Int
start Int -> O (Sig Int) -> Sig Int
forall a. a -> O (Sig a) -> Sig a
::: Box (O Int) -> O (Sig Int)
forall a. Box (O a) -> O (Sig a)
mkSig (O Int -> Box (O Int)
forall a. a -> Box a
box (Chan Int -> O Int
forall a. Chan a -> O a
wait Chan Int
c))
Slider -> C Slider
forall a. a -> C a
forall (m :: * -> *) a. Monad m => a -> m a
return Slider{sldCurr :: Sig Int
sldCurr = Sig Int
curr, sldEvent :: Chan Int
sldEvent = Chan Int
c, sldMin :: Sig Int
sldMin = Sig Int
min, sldMax :: Sig Int
sldMax = Sig Int
max}
mkProgressBar :: Sig Int -> Sig Int -> Sig Int -> C Slider
mkProgressBar :: Sig Int -> Sig Int -> Sig Int -> C Slider
mkProgressBar Sig Int
min Sig Int
max Sig Int
curr = do
Chan Int
c <- C (Chan Int)
forall a. C (Chan a)
chan
let boundedCurrent :: Sig Int
boundedCurrent = Box (Int -> Int -> Int) -> Sig Int -> Sig Int -> Sig Int
forall a b c.
(Stable a, Stable b) =>
Box (a -> b -> c) -> Sig a -> Sig b -> Sig c
WidgetRattus.Signal.zipWith ((Int -> Int -> Int) -> Box (Int -> Int -> Int)
forall a. a -> Box a
box Int -> Int -> Int
forall a. Ord a => a -> a -> a
Prelude.min) Sig Int
curr Sig Int
max
Slider -> C Slider
forall a. a -> C a
forall (m :: * -> *) a. Monad m => a -> m a
return Slider{sldCurr :: Sig Int
sldCurr = Sig Int
boundedCurrent, sldEvent :: Chan Int
sldEvent = Chan Int
c, sldMin :: Sig Int
sldMin = Sig Int
min, sldMax :: Sig Int
sldMax = Sig Int
max}
btnOnClick :: Button -> Box(O())
btnOnClick :: Button -> Box (O ())
btnOnClick Button
btn =
let ch :: Chan ()
ch = Button -> Chan ()
btnClick Button
btn
in O () -> Box (O ())
forall a. a -> Box a
box (Chan () -> O ()
forall a. Chan a -> O a
wait Chan ()
ch)
btnOnClickSig :: Button -> O (Sig ())
btnOnClickSig :: Button -> O (Sig ())
btnOnClickSig Button
btn = Box (O ()) -> O (Sig ())
forall a. Box (O a) -> O (Sig a)
mkSig (Button -> Box (O ())
btnOnClick Button
btn)
setInputSigTF :: TextField -> Sig Text -> TextField
setInputSigTF :: TextField -> Sig Text -> TextField
setInputSigTF TextField
tf Sig Text
sig = TextField
tf{tfContent = sig}
addInputSigTF :: TextField -> O (Sig Text) -> TextField
addInputSigTF :: TextField -> O (Sig Text) -> TextField
addInputSigTF TextField
tf O (Sig Text)
sig =
let leaved :: Sig Text
leaved = Sig Text -> Text
forall a. Sig a -> a
current (TextField -> Sig Text
tfContent TextField
tf) Text -> O (Sig Text) -> Sig Text
forall a. a -> O (Sig a) -> Sig a
::: Box (Text -> Text -> Text)
-> O (Sig Text) -> O (Sig Text) -> O (Sig Text)
forall a. Box (a -> a -> a) -> O (Sig a) -> O (Sig a) -> O (Sig a)
interleave ((Text -> Text -> Text) -> Box (Text -> Text -> Text)
forall a. a -> Box a
box (\Text
x Text
_ -> Text
x)) (Sig Text -> O (Sig Text)
forall a. Sig a -> O (Sig a)
future (TextField -> Sig Text
tfContent TextField
tf)) O (Sig Text)
sig
in TextField
tf{tfContent = leaved, tfInput = tfInput tf}
textFieldOnInput :: TextField -> Box(O Text)
textFieldOnInput :: TextField -> Box (O Text)
textFieldOnInput TextField
tf =
let ch :: Chan Text
ch = TextField -> Chan Text
tfInput TextField
tf
in O Text -> Box (O Text)
forall a. a -> Box a
box (Chan Text -> O Text
forall a. Chan a -> O a
wait Chan Text
ch)
textFieldOnInputSig :: TextField -> O (Sig Text)
textFieldOnInputSig :: TextField -> O (Sig Text)
textFieldOnInputSig TextField
tf = Box (O Text) -> O (Sig Text)
forall a. Box (O a) -> O (Sig a)
mkSig (TextField -> Box (O Text)
textFieldOnInput TextField
tf)
mkTimerEvent :: Int -> (AppEvent -> IO ()) -> IO ()
mkTimerEvent :: Int -> (AppEvent -> IO ()) -> IO ()
mkTimerEvent Int
n AppEvent -> IO ()
cb = (Int -> IO ()
threadDelay Int
n IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AppEvent -> IO ()
cb (Chan () -> () -> AppEvent
forall a. Chan a -> a -> AppEvent
AppEvent (Int -> Chan ()
forall a. Int -> Chan a
Chan Int
n) ())) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# ANN runApplication AllowLazyData #-}
runApplication :: IsWidget a => C a -> IO ()
runApplication :: forall a. IsWidget a => C a -> IO ()
runApplication (C InputValue -> IO a
w) = do
a
w' <- InputValue -> IO a
w (Int -> () -> InputValue
forall a. Int -> a -> InputValue
OneInput Int
0 ())
AppModel
-> AppEventHandler AppModel AppEvent
-> AppUIBuilder AppModel AppEvent
-> [AppConfig AppModel AppEvent]
-> IO ()
forall s e.
(Eq s, WidgetModel s, WidgetEvent e) =>
s
-> AppEventHandler s e
-> AppUIBuilder s e
-> [AppConfig s e]
-> IO ()
M.startApp (a -> Clock -> AppModel
forall a. IsWidget a => a -> Clock -> AppModel
AppModel a
w' Clock
emptyClock) AppEventHandler AppModel AppEvent
forall {p} {p} {sp} {ep}.
p
-> p
-> AppModel
-> AppEvent
-> [EventResponse AppModel AppEvent sp ep]
handler AppUIBuilder AppModel AppEvent
forall {p}. p -> AppModel -> WidgetNode AppModel AppEvent
builder [AppConfig AppModel AppEvent]
config
where builder :: p -> AppModel -> WidgetNode AppModel AppEvent
builder p
_ (AppModel a
w Clock
_) = a -> WidgetNode AppModel AppEvent
forall a. IsWidget a => a -> WidgetNode AppModel AppEvent
mkWidgetNode a
w WidgetNode AppModel AppEvent
-> [StyleState] -> WidgetNode AppModel AppEvent
forall t. CmbStyleBasic t => t -> [StyleState] -> t
`M.styleBasic` [Double -> StyleState
forall t. CmbPadding t => Double -> t
M.padding Double
3]
handler :: p
-> p
-> AppModel
-> AppEvent
-> [EventResponse AppModel AppEvent sp ep]
handler p
_ p
_ (AppModel a
w Clock
cl) (AppEvent (Chan Int
ch) a
d) =
let inp :: InputValue
inp = Int -> a -> InputValue
forall a. Int -> a -> InputValue
OneInput Int
ch a
d in IO [EventResponse AppModel AppEvent sp ep]
-> [EventResponse AppModel AppEvent sp ep]
forall a. IO a -> a
unsafePerformIO (IO [EventResponse AppModel AppEvent sp ep]
-> [EventResponse AppModel AppEvent sp ep])
-> IO [EventResponse AppModel AppEvent sp ep]
-> [EventResponse AppModel AppEvent sp ep]
forall a b. (a -> b) -> a -> b
$ do
InputValue -> IO ()
progressPromoteStoreAtomic InputValue
inp
let (a
w' , Clock
cl') = InputValue -> a -> (a, Clock)
forall p. Continuous p => InputValue -> p -> (p, Clock)
progressAndNext InputValue
inp a
w
let activeTimers :: Clock
activeTimers = if Int
ch Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Int -> Clock -> Clock
IntSet.delete Int
ch Clock
cl else Clock
cl
let newTimers :: Clock
newTimers = (Int -> Bool) -> Clock -> Clock
IntSet.filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) Clock
cl' Clock -> Clock -> Clock
`IntSet.difference` Clock
activeTimers
let timers :: [EventResponse AppModel AppEvent sp ep]
timers = (Int -> EventResponse AppModel AppEvent sp ep)
-> [Int] -> [EventResponse AppModel AppEvent sp ep]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map (((AppEvent -> IO ()) -> IO ())
-> EventResponse AppModel AppEvent sp ep
forall s e sp ep. ProducerHandler e -> EventResponse s e sp ep
M.Producer (((AppEvent -> IO ()) -> IO ())
-> EventResponse AppModel AppEvent sp ep)
-> (Int -> (AppEvent -> IO ()) -> IO ())
-> Int
-> EventResponse AppModel AppEvent sp ep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (AppEvent -> IO ()) -> IO ()
mkTimerEvent) (Clock -> [Int]
IntSet.toList Clock
newTimers)
[EventResponse AppModel AppEvent sp ep]
-> IO [EventResponse AppModel AppEvent sp ep]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AppModel -> EventResponse AppModel AppEvent sp ep
forall s e sp ep. s -> EventResponse s e sp ep
M.Model (a -> Clock -> AppModel
forall a. IsWidget a => a -> Clock -> AppModel
AppModel a
w' (Clock
newTimers Clock -> Clock -> Clock
`IntSet.union` Clock
activeTimers)) EventResponse AppModel AppEvent sp ep
-> [EventResponse AppModel AppEvent sp ep]
-> [EventResponse AppModel AppEvent sp ep]
forall a. a -> [a] -> [a]
: WidgetRequest AppModel AppEvent
-> EventResponse AppModel AppEvent sp ep
forall s e sp ep. WidgetRequest s e -> EventResponse s e sp ep
M.Request WidgetRequest AppModel AppEvent
forall s e. WidgetRequest s e
M.RenderOnce EventResponse AppModel AppEvent sp ep
-> [EventResponse AppModel AppEvent sp ep]
-> [EventResponse AppModel AppEvent sp ep]
forall a. a -> [a] -> [a]
: [EventResponse AppModel AppEvent sp ep]
timers )
config :: [AppConfig AppModel AppEvent]
config = [
Text -> AppConfig AppModel AppEvent
forall s e. Text -> AppConfig s e
M.appWindowTitle Text
"GUI Application",
Theme -> AppConfig AppModel AppEvent
forall s e. Theme -> AppConfig s e
M.appTheme Theme
M.lightTheme,
Text -> Text -> AppConfig AppModel AppEvent
forall s e. Text -> Text -> AppConfig s e
M.appFontDef Text
"Regular" Text
"./assets/fonts/Roboto-Regular.ttf",
AppEvent -> AppConfig AppModel AppEvent
forall e s. e -> AppConfig s e
M.appInitEvent (Chan () -> () -> AppEvent
forall a. Chan a -> a -> AppEvent
AppEvent (Int -> Chan ()
forall a. Int -> Chan a
Chan Int
1) ())
]