{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleContexts , UndecidableInstances, ScopedTypeVariables, Rank2Types #-} -- For ghc 6.6 compatibility -- {-# OPTIONS -fglasgow-exts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ---------------------------------------------------------------------- -- | -- Module : Graphics.UI.Phooey.Monad -- Copyright : (c) Conal Elliott 2006 -- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : provisional -- Portability : portable -- -- A functional UI monad. Uses explicit data-driven \"sources\" of -- values. Supports recursive GUIs. See -- . ---------------------------------------------------------------------- module Graphics.UI.Phooey.Monad ( -- * The UI monad CxLayout, UI, UI', biUI, inUI, toUI, fromUI , UIE, UIS , runUI, runNamedUI, act -- , accumE, accumS, monoidE, monoidS -- * Tools for high-level widgets , IWidget, OWidget, OWidget', IOWidget, MkWidget, widgetL , iwidget, iwidget', owidget, owidget', iowidget, testWidget -- * Some high-level widgets , stringEntry, stringDisplay, stringDisplay' , showDisplay, showDisplay' , islider, isliderDisplay, isliderDisplay' , fslider, fsliderDisplay, fsliderDisplay' , checkBoxEntry, checkBoxDisplay, checkBoxDisplay' , button, button', smallButton , choices , timedPoll -- * Explicit layout , fromTop, fromBottom, fromLeft, fromRight ) where import Control.Applicative import Control.Arrow ((>>>),first,second) import Data.Maybe (fromJust) import Data.List (elemIndex) -- mtl import Control.Monad.Reader import Control.Monad.Writer -- wxHaskell import Graphics.UI.WX hiding (Event,button,smallButton) import qualified Graphics.UI.WX as WX import qualified Graphics.UI.WXCore as WXC -- TypeCompose import Control.Compose (Unop,Binop) import Data.CxMonoid import Data.Bijection import Data.Title -- reactive import Data.Reactive -- Phooey import Graphics.UI.Phooey.Imperative (Win,empty',above,below,leftOf,rightOf) import Graphics.UI.Phooey.WinEvents (attrSource,getAttr,setAttr,wEvent_,WioS) {---------------------------------------------------------- The UI monad ----------------------------------------------------------} -- | Context-dependent layout type CxLayout = CxMonoid Layout instance Title Layout where title = boxed -- | The UI monad type UI = ReaderT Win (WriterT CxLayout (WriterT (Source Action) IO)) -- | Source-valued UI type UIS a = UI (Source a) -- | Event-valued UI type UIE a = UI (Event a) -- Standard monad-as-applicative instance instance Applicative UI where { pure = return ; (<*>) = ap } -- Standard AF-as-monoid instance instance Monoid o => Monoid (UI o) where mempty = pure mempty mappend = liftA2 mappend -- | Convenient variation of 'UI' type UI' a = Win -> IO ((a, CxLayout), Source Action) -- Convenient bijection biReaderT :: (r -> m a) :<->: ReaderT r m a biReaderT = Bi ReaderT runReaderT biWriterT :: m (a, w) :<->: WriterT w m a biWriterT = Bi WriterT runWriterT -- | Bijection for convenient manipulation. biUI :: UI' a :<->: UI a biUI = bimap (biWriterT >>> biWriterT) >>> biReaderT -- In biUI, the bimap is for the (->) Win, and each biWriterT un/wraps a WriterT. -- Separate biUI into separately typed pieces. -- TODO: look for alternatives. -- | Make from representation toUI :: UI' a -> UI a toUI = biTo biUI -- | Extract representation fromUI :: UI b -> UI' b fromUI = biFrom biUI -- | Apply a unary function inside the 'UI' representation. inUI :: (UI' a -> UI' b) -> (UI a -> UI b) inUI = (toUI .) . (. fromUI) -- | Run a 'UI' with window title \"Monadic Phooey GUI\". runUI :: UI () -> IO () runUI = runNamedUI "Monadic Phooey GUI" -- | Run a 'UI' with given window title. 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 -- | Move an action source into position to be executed act :: UI (Source Action) -> UI () act = inUI $ (fmap.fmap) doit where doit ((io, l), acts) = (((),l), acts `mappend` io) {---------------------------------------------------------- Tools for high-level widgets ----------------------------------------------------------} -- | Input widget type (with initial value) type IWidget a = a -> UI (Source a) -- | Output widget type type OWidget a = Source a -> UI () -- | Alternative output widget type type OWidget' a = UI (Sink a) -- | Combine input & output widget types type IOWidget a = (IWidget a, OWidget a, OWidget' a) -- | Utility type for making widgets 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))) -- | Make an input widget. See alos 'iwidget\''. iwidget :: (Commanding ctl, Widget ctl) => MkWidget ctl a (IWidget a) iwidget = iwidget' command -- | Make an input widget with a given update event. If the update is -- 'commanding' you can use 'iwidget'. 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 -- In the case of 'choices', the creation-time attribute set is not -- enough, so set it here again. set ctl [ attr := initial ] -- and invoke any event handlers join $ getAttr (on ev) ctl return ((src, widgetL filler ctl), mempty) -- TODO: look in WinEvents for helpers. -- | Tweaks output style outFun :: OWidget' a -> OWidget a outFun ui src = -- Apply sinks to values & move to actions act $ fmap (<$> src) ui -- | Make a high-level output widget owidget :: Widget widget => MkWidget widget a (OWidget a) owidget filler mkWid attr = outFun (owidget' filler mkWid attr) -- | Output widget, alternative style 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) -- | Convenience function combining 'iwidget', 'owidget', and 'owidget\'' 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) -- | For testing out WinEvents 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) {---------------------------------------------------------- Some high-level widgets ----------------------------------------------------------} -- | String input widget stringEntry :: IWidget String -- | String output widget stringDisplay :: OWidget String -- | Alternative string output widget stringDisplay' :: OWidget' String (stringEntry,stringDisplay,stringDisplay') = iowidget hfill textEntry text -- | Showable output widget showDisplay :: Show a => OWidget a showDisplay = stringDisplay . fmap show -- | Alternative showable output showDisplay' :: Show a => OWidget' a showDisplay' = fmap (. show) stringDisplay' -- | Slider input widget islider :: (Int,Int) -> IWidget Int -- | Slider output widget isliderDisplay :: (Int,Int) -> OWidget Int -- | Alternative slider output widget isliderDisplay' :: (Int,Int) -> OWidget' Int (islider,isliderDisplay,isliderDisplay') = unTriple1 $ \ (lo,hi) -> iowidget hfill (\ win -> hslider win True lo hi) selection -- Helpers -- unPair1 :: (a -> (b,c)) -> (a->b, a->c) -- unPair1 f = (fst . f, snd . f) 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 -- | Fractional slider, alternative interface 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 -- update the value display when it changes 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 -- Set the text attribute, and make sure the beginning is visible setText :: TextCtrl a -> String -> IO () setText ctl str = do setAttr text ctl str WXC.textCtrlSetInsertionPoint ctl 0 -- TODO: some factoring between fslider and fsliderDisplay'. -- | Fractional slider fsliderDisplay :: forall a. RealFrac a => (a,a) -> OWidget a fsliderDisplay = outFun . fsliderDisplay' -- | Fractional slider, alternative interface 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 -- ignore input ] 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 -- -- | Alternative output widget type -- type OWidget' a = UI (Sink a) -- | Boolean input widget checkBoxEntry :: IWidget Bool -- | Boolean output widget checkBoxDisplay :: OWidget Bool -- | Alternative Boolean output widget checkBoxDisplay' :: OWidget' Bool (checkBoxEntry,checkBoxDisplay,checkBoxDisplay') = iowidget hfill WX.checkBox checked -- | Input from a \"menu\" of string choices. 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 -- I don't know why the following line is required -- set ctl [ text' := dflt ] return ctl text' = newAttr "choiceSelection" (\ w -> fmap (strings !!) (getAttr selection w)) (\ w str -> setAttr selection w (fromJust (elemIndex str strings))) -- | Input from a timer and a means of polling. Interval is in seconds. -- If 'poll' is expensive, then apply 'cache' to the resulting UI. 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) -- type UI' a = Win -> IO ((a, CxLayout), Source Action) -- Wrap a title around a 'UI' instance Title_f UI where title_f str = onCxLayout' (boxed str .) -- | Simple button with value & label. Use 'button\'' for custom properties. button :: a -> String -> UI (Event a) button a txt = button' a [ text := txt ] -- | Button with value & properties. If you just want a label, use 'button'. 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) -- | Minimal size button with value & label 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) -- TODO: rewrite button', smallButton in >=> style. See how it looks. {---------------------------------------------------------- Layout ----------------------------------------------------------} 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)