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

-- The identity function.
instance Displayable Text where
      display :: Text -> Text
display Text
x = Text
x

-- Convert Int to Text via String.
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 


-- Functions for constructing Async Rattus widgets. 
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 
mkPopup :: Sig Bool -> Sig Widget -> C Popup
mkPopup 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}


-- Helper function that takes a Button and returns a boxed delayed computation.
-- The delayed computation is defined from the buttons input channel.
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)

-- Function that constructs a delayed signal from a Button.
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)

-- Creates a new textfield whose contents are determined by
-- the input signal.
-- Therefore user input will only be shown if the input signal
-- ticks in response to user input on the textfield.
-- Note: the input TF and output TF share an input channel
-- Hence if both are part of a GUI they will be written to simultaneously
setInputSigTF :: TextField -> Sig Text -> TextField
setInputSigTF :: TextField -> Sig Text -> TextField
setInputSigTF TextField
tf Sig Text
sig = TextField
tf{tfContent = sig} 

-- Uses the input signal to create a new textfield
-- The returned textfield updates in response to the input signal
-- as well as the content signal of the original textfield.
-- Note: the input TF and output TF share an input channel
-- Hence if both are part of a GUI they will be written to simultaneously
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}

-- Helper function that takes a TextField and returns a boxed delayed computation.
-- The delayed computation is defined from the Textfields input channel.
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)

-- Function that constructs a delayed signal from a Textfield.
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)


-- Function which creates a timed event. Associated clock will be part of the AppModel.
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 ()


-- runApplication takes as input a widget and starts the GUI applicaiton
-- by calling Monomer's startApp function.
{-# 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) ())
                ]