module Graphics.UI.Phooey.Monad
(
CxLayout, UI, UI', biUI, inUI, toUI, fromUI
, UIE, UIS
, runUI, runNamedUI, act
, IWidget, OWidget, OWidget', IOWidget, MkWidget, widgetL
, iwidget, iwidget', owidget, owidget', iowidget, testWidget
, stringEntry, stringDisplay, stringDisplay'
, showDisplay, showDisplay'
, islider, isliderDisplay, isliderDisplay'
, fslider, fsliderDisplay, fsliderDisplay'
, checkBoxEntry, checkBoxDisplay, checkBoxDisplay'
, button, button', smallButton
, choices
, timedPoll
, fromTop, fromBottom, fromLeft, fromRight
) where
import Control.Applicative
import Control.Arrow ((>>>),first,second)
import Data.Maybe (fromJust)
import Data.List (elemIndex)
import Control.Monad.Reader
import Control.Monad.Writer
import Graphics.UI.WX hiding (Event,button,smallButton)
import qualified Graphics.UI.WX as WX
import qualified Graphics.UI.WXCore as WXC
import Control.Compose (Unop,Binop)
import Data.CxMonoid
import Data.Bijection
import Data.Title
import Data.Reactive
import Graphics.UI.Phooey.Imperative
(Win,empty',above,below,leftOf,rightOf)
import Graphics.UI.Phooey.WinEvents (attrSource,getAttr,setAttr,wEvent_,WioS)
type CxLayout = CxMonoid Layout
instance Title Layout where title = boxed
type UI = ReaderT Win (WriterT CxLayout (WriterT (Source Action) IO))
type UIS a = UI (Source a)
type UIE a = UI (Event a)
instance Applicative UI where { pure = return ; (<*>) = ap }
instance Monoid o => Monoid (UI o) where
mempty = pure mempty
mappend = liftA2 mappend
type UI' a = Win -> IO ((a, CxLayout), Source Action)
biReaderT :: (r -> m a) :<->: ReaderT r m a
biReaderT = Bi ReaderT runReaderT
biWriterT :: m (a, w) :<->: WriterT w m a
biWriterT = Bi WriterT runWriterT
biUI :: UI' a :<->: UI a
biUI = bimap (biWriterT >>> biWriterT) >>> biReaderT
toUI :: UI' a -> UI a
toUI = biTo biUI
fromUI :: UI b -> UI' b
fromUI = biFrom biUI
inUI :: (UI' a -> UI' b) -> (UI a -> UI b)
inUI = (toUI .) . (. fromUI)
runUI :: UI () -> IO ()
runUI = runNamedUI "Monadic Phooey GUI"
runNamedUI :: String -> UI () -> IO ()
runNamedUI name ui = start $
do f <- frame [ visible := False, text := name ]
win <- panel f []
(((),cxl),acts) <- fromUI ui win
set win [ layout := unCxMonoid cxl (empty',above) ]
set f [ layout := fill (widget win), visible := True ]
forkR acts
act :: UI (Source Action) -> UI ()
act = inUI $ (fmap.fmap) doit
where
doit ((io, l), acts) = (((),l), acts `mappend` io)
type IWidget a = a -> UI (Source a)
type OWidget a = Source a -> UI ()
type OWidget' a = UI (Sink a)
type IOWidget a = (IWidget a, OWidget a, OWidget' a)
type MkWidget ctl a b =
Unop Layout -> (Win -> [Prop ctl] -> IO ctl) -> Attr ctl a -> b
widgetL :: Widget w => Unop Layout -> w -> CxLayout
widgetL filler ctl = CxMonoid (const (filler (widget ctl)))
iwidget :: (Commanding ctl, Widget ctl) => MkWidget ctl a (IWidget a)
iwidget = iwidget' command
iwidget' :: Widget ctl => WX.Event ctl (IO ()) -> MkWidget ctl a (IWidget a)
iwidget' ev filler mkWid attr initial = toUI $ \ win ->
do ctl <- mkWid win [ attr := initial ]
src <- attrSource ev attr ctl
set ctl [ attr := initial ]
join $ getAttr (on ev) ctl
return ((src, widgetL filler ctl), mempty)
outFun :: OWidget' a -> OWidget a
outFun ui src =
act $ fmap (<$> src) ui
owidget :: Widget widget => MkWidget widget a (OWidget a)
owidget filler mkWid attr = outFun (owidget' filler mkWid attr)
owidget' :: Widget ctl => MkWidget ctl a (OWidget' a)
owidget' filler mkWid attr = toUI $ \ win ->
do ctl <- mkWid win [ ]
return ((setAttr attr ctl, widgetL filler ctl), mempty)
iowidget :: (Commanding widget, Widget widget) => MkWidget widget a (IOWidget a)
iowidget filler mkWid attr =
(iwidget filler mkWid attr, owidget filler mkWid attr, owidget' filler mkWid attr)
testWidget :: WioS a -> UI (Source a)
testWidget wios = toUI $ \ win ->
do pan <- panel win [ size := Size 20 20 ]
s <- wios pan
return ((s, widgetL fill pan), mempty)
stringEntry :: IWidget String
stringDisplay :: OWidget String
stringDisplay' :: OWidget' String
(stringEntry,stringDisplay,stringDisplay') = iowidget hfill textEntry text
showDisplay :: Show a => OWidget a
showDisplay = stringDisplay . fmap show
showDisplay' :: Show a => OWidget' a
showDisplay' = fmap (. show) stringDisplay'
islider :: (Int,Int) -> IWidget Int
isliderDisplay :: (Int,Int) -> OWidget Int
isliderDisplay' :: (Int,Int) -> OWidget' Int
(islider,isliderDisplay,isliderDisplay') = unTriple1 $ \ (lo,hi) ->
iowidget hfill (\ win -> hslider win True lo hi) selection
unTriple1 :: (a -> (b,c,d)) -> (a->b, a->c, a->d)
unTriple1 f = (fst3 . f, snd3 . f, thd3 . f)
where
fst3 (a,_,_) = a
snd3 (_,b,_) = b
thd3 (_,_,c) = c
fslider :: forall a. RealFrac a => (a,a) -> IWidget a
fslider (lo,hi) initial = toUI $ \ win ->
do pan <- panel win [ ]
pbg <- get pan bgcolor
cval <- textEntry pan [ clientSize :~ \ (Size _ h) -> Size 50 h
, bgcolor := pbg
]
slid <- hslider pan False (toI lo) (toI hi)
[ selection := toI initial
, size :~ \ (Size _ h) -> (Size 80 h)]
set pan [ layout := row 5 [ widget cval, label (show lo)
, fill $ widget slid, label (show hi) ] ]
isrc <- attrSource command selection slid
let fsrc = fmap toF isrc
forkR $ (setText cval . show) <$> fsrc
return ((fsrc, widgetL hfill pan), mempty)
where
toI x = round ((x lo) * scale)
toF i = fromIntegral i / scale + lo
scale = steps / (hi lo)
steps = 3000 :: a
setText :: TextCtrl a -> String -> IO ()
setText ctl str =
do setAttr text ctl str
WXC.textCtrlSetInsertionPoint ctl 0
fsliderDisplay :: forall a. RealFrac a => (a,a) -> OWidget a
fsliderDisplay = outFun . fsliderDisplay'
fsliderDisplay' :: forall a. RealFrac a => (a,a) -> OWidget' a
fsliderDisplay' (lo,hi) = toUI $ \ win ->
do pan <- panel win [ ]
pbg <- get pan bgcolor
cval <- textEntry pan [ clientSize :~ \ (Size _ h) -> Size 50 h
, bgcolor := pbg
, on keyboard := mempty
]
slid <- hslider pan False (toI lo) (toI hi) [ enabled := False ]
set pan [ layout := row 5 [ widget cval, label (show lo)
, fill $ widget slid, label (show hi) ] ]
let update x = do set slid [ selection := toI x ]
setText cval (show x)
return ((update, widgetL hfill pan), mempty)
where
toI x = round ((x lo) * scale)
scale = steps / (hi lo)
steps = 3000 :: a
checkBoxEntry :: IWidget Bool
checkBoxDisplay :: OWidget Bool
checkBoxDisplay' :: OWidget' Bool
(checkBoxEntry,checkBoxDisplay,checkBoxDisplay') = iowidget hfill WX.checkBox checked
choices :: [String] -> IWidget String
choices strings dflt = iwidget' select hfill combo text' dflt
where
combo w props =
do ctl <- comboBox w props
mapM_ (appendText ctl) strings
return ctl
text' = newAttr "choiceSelection"
(\ w -> fmap (strings !!) (getAttr selection w))
(\ w str -> setAttr selection w (fromJust (elemIndex str strings)))
timedPoll :: Double -> IO a -> UI (Source a)
timedPoll secs poll = toUI $ \ w ->
do tim <- timer w [ interval := round (1000 * secs) ]
(ev,snk) <- mkEvent
set tim [ on command := poll >>= snk ]
a0 <- poll
return ((a0 `stepper` ev, mempty), mempty)
instance Title_f UI where title_f str = onCxLayout' (boxed str .)
button :: a -> String -> UI (Event a)
button a txt = button' a [ text := txt ]
button' :: a -> [Prop (Button ())] -> UI (Event a)
button' a props = toUI $ \ win ->
do ctl <- WX.button win props
press <- wEvent_ command ctl
return ( (replace a press, widgetL fill ctl)
, mempty)
smallButton :: a -> String -> UI (Event a)
smallButton a txt = toUI $ \ win ->
do ctl <- WX.smallButton win [ text := txt ]
press <- wEvent_ command ctl
return ( (replace a press, widgetL fill ctl)
, mempty)
fromTop, fromBottom, fromLeft, fromRight :: Unop (UI a)
fromTop = withDir above
fromBottom = withDir below
fromLeft = withDir leftOf
fromRight = withDir rightOf
withDir :: Binop Layout -> Unop (UI a)
withDir op = withCxMonoid (empty',op)
withCxMonoid :: MonoidDict Layout -> Unop (UI a)
withCxMonoid dict = compCxMonoid (const dict)
compCxMonoid :: Unop (MonoidDict Layout) -> Unop (UI a)
compCxMonoid f = onCxLayout' (. f)
onCxLayout :: Unop CxLayout -> Unop (UI a)
onCxLayout f = inUI $ (fmap.fmap.first.second) f
onCxLayout' :: Unop (MonoidDict Layout -> Layout) -> Unop (UI a)
onCxLayout' f' = onCxLayout (CxMonoid . f' . unCxMonoid)