reactive-0.0: src/Examples.hs

{-# LANGUAGE TypeOperators, FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-}

----------------------------------------------------------------------
-- |
-- Module      :  Examples
-- Copyright   :  (c) Conal Elliott 2007
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Simple test for Reactive
----------------------------------------------------------------------

-- module Main where

-- base
import Data.Monoid
import Control.Monad ((>=>),forM_)
import Control.Applicative
import Control.Arrow (first,second)
import Control.Concurrent (forkIO, killThread, threadDelay, ThreadId)

-- wxHaskell
import Graphics.UI.WX hiding (Event,Reactive)
import qualified Graphics.UI.WX as WX
-- TypeCompose
import Control.Compose ((:.)(..), inO,inO2)
import Data.Title

-- Reactive
import Data.Reactive


{--------------------------------------------------------------------
    Mini-Phooey
--------------------------------------------------------------------}

type Win = Panel ()

type Wio = ((->) Win) :. IO :. (,) Layout

type Wio' a = Win -> IO (Layout,a)


wio :: Wio' a -> Wio a
wio = O . O

unWio :: Wio a -> Wio' a
unWio = unO . unO

inWio :: (Wio' a -> Wio' b) -> (Wio a -> Wio b)
inWio f = wio . f . unWio

inWio2 :: (Wio' a -> Wio' b -> Wio' c) -> (Wio a -> Wio b -> Wio c)
inWio2 f = inWio . f . unWio

instance Title_f Wio where
  title_f str = inWio ((fmap.fmap.first) (boxed str))

-- Bake in vertical layout.  See phooey for flexible layout.
instance Monoid Layout where
  mempty  = WX.empty
  mappend = above

instance Monoid a => Monoid (Wio a) where
  mempty  = wio    mempty
  mappend = inWio2 mappend

type WioE a = Wio (Event    a)
type WioR a = Wio (Reactive a)

buttonE :: String -> WioE ()
buttonE str = wio $ \ win ->
  do (e, snk) <- mkEvent
     b <- button win [ text := str, on command := snk () ]
     return (hwidget b, e)

buttonE' :: String -> a -> WioE a
buttonE' str a = (a `replace`) <$> buttonE str

sliderE :: (Int,Int) -> Int -> WioE Int
sliderE (lo,hi) initial = wio $ \ win ->
  do (e, snk) <- mkEvent
     s <- hslider win True lo hi
            [ selection := initial ]
     set s [ on command := getAttr selection s >>= snk ]
     return (hwidget s, {-traceE shw-} e)

sliderR :: (Int,Int) -> Int -> WioR Int
sliderR lh initial = stepper initial <$> sliderE lh initial

stringO :: Wio (Sink String)
stringO = wio $ \ win ->
  do ctl <- textEntry win []
     return (hwidget ctl, setAttr text ctl)

showO :: Show a => Wio (Sink a)
showO = (. show) <$> stringO

showR :: Show a => WioR (Sink a)
showR = pure <$> showO


-- | Horizontally-filled widget layout
hwidget :: Widget w => w -> Layout
hwidget = hfill . widget

-- | Binary layout combinator
above, leftOf :: Layout -> Layout -> Layout
la `above`   lb = fill (column  0 [la,lb])
la `leftOf`  lb = fill (row     0 [la,lb])

-- |  Get attribute.  Just a flipped 'get'.  Handy for partial application.
getAttr :: Attr w a -> w -> IO a
getAttr = flip get

-- | Set a single attribute.  Handy for partial application.
setAttr :: Attr w a -> w -> Sink a
setAttr attr ctl x = set ctl [ attr := x ]


{--------------------------------------------------------------------
    Running
--------------------------------------------------------------------}

-- | Fork a 'Wio': handle frame & widget creation, and apply layout.
forkWio :: (o -> IO ThreadId) -> String -> Wio o -> IO ()
forkWio forker name w = start $
  do  f     <- frame [ visible := False, text := name ]
      pan   <- panel f []
      (l,o) <- unWio w pan
      set pan [ layout := l ]
      forker o
      set f   [ layout     := fill (widget pan)
              , visible    := True
              ]

-- | Fork a 'WioE'
forkWioE :: String -> WioE Action -> IO ()
forkWioE = forkWio forkE

-- | Fork a 'WioR'
forkWioR :: String -> WioR Action -> IO ()
forkWioR = forkWio forkR


{--------------------------------------------------------------------
    Examples
--------------------------------------------------------------------}

alarm :: Double -> Int -> IO (Event Int)
alarm secs reps =
  do (e,snk) <- mkEvent
     forkIO $ forM_ [1 .. reps] $ \ i ->
               do threadDelay micros
                  snk i
     return e
 where
   micros = round (1.0e6 * secs)
                          

t0 = alarm 0.5 10 >>= \ e -> runE $ print <$> {-traceE (const "boo!")-} e

mkAB :: WioE String
mkAB = buttonE' "a" "a" `mappend` buttonE' "b" "b"


t1 = forkWioE "t1" $ liftA2 (<$>) stringO mkAB

acc :: WioE String
acc = g <$> mkAB
 where
   g :: Event String -> Event String
   g e = "" `accumE` (flip (++) <$> e)

t2 = forkWioE "t2" $ liftA2 (<$>) stringO acc

total :: Show a => WioR (Sink a)
total = title "total" showR

apples, bananas, fruit :: WioR Int
apples  = title "apples"  $ sliderR (0,10) 3
bananas = title "bananas" $ sliderR (0,10) 7
fruit   = title "fruit"   $ (liftA2.liftA2) (+) apples bananas

t3 = forkWioR "t3" $ liftA2 (<**>) fruit total 

t4 = forkWioR "t4" $ liftA2 (<*>) showR (sliderR (0,10) 0)

t5 = forkWioR "t5" $ liftA2 (<$>) showO (sliderR (0,10) 0)

main = t3