phooey 1.0 → 1.2
raw patch · 7 files changed
+280/−39 lines, 7 filesdep ~TypeCompose
Dependency ranges changed: TypeCompose
Files
- CHANGES +10/−0
- Makefile +1/−1
- phooey.cabal +2/−2
- src/Examples/Applicative.hs +172/−0
- src/Graphics/UI/Phooey/Applicative.hs +11/−11
- src/Graphics/UI/Phooey/Imperative.hs +20/−9
- src/Graphics/UI/Phooey/Monad.hs +64/−16
CHANGES view
@@ -1,3 +1,13 @@+Version 1.2:+* Renamed "Upd" to "Act" in Monad.hs+* Added "commandNews" in Imperative.hs+* Tweaked for compatibility with TypeCompose-0.1++Version 1.1:+* Added src/Examples/Applicative.hs. I'd accidentally omitted it.+* Imperative.hs: renamed "mkNews" to "commandNews" and added a more+ general function called "mkNews".+ Version 1.0: * Uses new TypeCompose package, which includes a simple implementation of data-driven computation.
Makefile view
@@ -3,7 +3,7 @@ haddock-interfaces=\ http://haskell.org/ghc/docs/latest/html/libraries/base,c:/ghc/ghc-6.6/doc/html/libraries/base/base.haddock \ http://haskell.org/ghc/docs/latest/html/libraries/mtl,c:/ghc/ghc-6.6/doc/html/libraries/mtl/mtl.haddock \- http://darcs.haskell.org/packages/TypeCompose/doc/html,c:/Haskell/packages/TypeCompose-0.0/doc/html/TypeCompose.haddock \+ http://darcs.haskell.org/packages/TypeCompose/doc/html,c:/Haskell/packages/TypeCompose-0.1/doc/html/TypeCompose.haddock \ http://wxhaskell.sourceforge.net/doc,c:/Haskell/wxhaskell/out/doc/wxhaskell.haddock include ../my-cabal-make.inc
phooey.cabal view
@@ -1,5 +1,5 @@ Name: phooey-Version: 1.0+Version: 1.2 Synopsis: Functional user interfaces Category: User Interfaces Description:@@ -33,7 +33,7 @@ Stability: provisional Hs-Source-Dirs: src Extensions: CPP, Arrows-Build-Depends: base, mtl, arrows, TypeCompose, wx, wxcore+Build-Depends: base, mtl, arrows, TypeCompose>=0.1, wx, wxcore Exposed-Modules: Graphics.UI.Phooey.Imperative Graphics.UI.Phooey.TagT
+ src/Examples/Applicative.hs view
@@ -0,0 +1,172 @@+{-# OPTIONS #-} + +---------------------------------------------------------------------- +-- | +-- Module : Examples.Applicative +-- Copyright : (c) Conal Elliott 2007 +-- License : LGPL +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- Portability : portable +-- +-- Applicative-style Phooey examples. Use 'runUI' +---------------------------------------------------------------------- + +module Examples.Applicative where + +import Control.Applicative +import Control.Monad.Fix (fix) + +import Graphics.UI.Phooey.Applicative + +-- For oPair etc +import Control.DataDriven (Sink,Updater) +import Data.Monoid + +h :: UI String +h = pure "Hello World!" + +sl0 :: IWidget Int +sl0 = islider (0,10) + +uia,uib :: UI Upd +uia = stringDisplay <*> h +uib = showDisplay <*> sl0 3 + + +ui1 :: UI Upd +ui1 = title "Shopping List" $ fruit <**> total + +apples, bananas, fruit :: UI Int +apples = title "apples" (sl0 3) +bananas = title "bananas" (sl0 7) + +fruit = liftA2 (+) apples bananas + +-- With overloading, we could say +-- fruit = apples + bananas + +total :: Num a => OWidget a +total = title "total" showDisplay + + +pair :: Applicative f => f a -> f b -> f (a,b) +pair = liftA2 (,) + +lo,hi :: UI Int +lo = title "lo" $ sl0 2 +hi = title "hi" $ sl0 8 + +val :: UI Int +val = title "val" $ isliderDyn (pair lo hi) 5 + +-- Note that the "val" title is around the lo & hi sliders as well. I +-- guess that layout reflects the purpose of the lo & hi sliders. I don't +-- know how to get a "val" title on just the dynamically-bounded slider. +ui2 :: UI Upd +ui2 = (fact <$> val) <**> title "factorial" showDisplay + +-- minor variation +ui2' = val <**> + pure fact <**> + title "factorial" showDisplay + +-- Variation + +fact :: Int -> Int +fact n = product [1 .. n] + + +o1 :: UI (Snk (Int -> Int -> Int)) +o1 = oLambda apples (oLambda bananas total) + +ui4 :: UI Upd +ui4 = o1 <*> pure (+) + +-- Experiments. None of these functions is specific to UI + +-- iPair :: Applicative ui => ui a -> ui b -> ui (a,b) +-- iPair = liftA2 (,) -- fromLeft + +-- oPair :: (Applicative ui, Applicative src, Monoid (Updater src)) +-- => ui (Sink src a) -> ui (Sink src b) -> ui (Sink src (a,b)) +-- oPair = liftA2 oPair' -- fromLeft + +-- -- Suggested use: m = src () +-- oLambda :: Applicative ui +-- => ui a -> ui (b -> m) -> ui ((a->b) -> m) +-- oLambda = liftA2 oLambda' -- fromTop + +-- -- Monoid variant for oPair + +-- oPairM :: (Applicative ui, Monoid m) +-- => ui (a -> m) -> ui (b -> m) -> ui ((a,b) -> m) +-- oPairM = liftA2 oPairM' + +-- oPairM' :: Monoid m => (a -> m) -> (b -> m) -> ((a,b) -> m) +-- oPairM' oa ob (a,b) = oa a `mappend` ob b -- fromLeft + +iPair :: UI a -> UI b -> UI (a,b) +iPair a b = fromLeft (liftA2 (,) a b) + +oPair :: (Monoid (Updater src), Applicative src) -- e.g., src == IO + => UI (Sink src a) -> UI (Sink src b) -> UI (Sink src (a,b)) +oPair a b = fromLeft (liftA2 oPair' a b) + +oPair' :: (Monoid (Updater src), Applicative src) + => Sink src a -> Sink src b -> Sink src (a,b) +oPair' oa ob (a,b) = oa a `mappend` ob b + +-- Suggested use: m = src () +oLambda :: UI a -> UI (b -> m) -> UI ((a->b) -> m) +oLambda a b = fromTop (liftA2 oLambda' a b) + +oLambda' :: a -> (b -> m) -> ((a->b) -> m) +oLambda' ia ob f = ob (f ia) + + +o2 :: UI (Snk ((Int,Int) -> Int)) +o2 = oLambda (iPair apples bananas) total + +ui5 :: UI Upd +ui5 = o2 <*> pure (uncurry (+)) + +o3 :: UI (Snk ((Int,Int) -> (Int,Int))) +o3 = oLambda (iPair sli sli) (oPair slo slo) + where + sli = sl0 5 + slo = isliderDisplay (0,10) + +ui6 :: UI Upd +ui6 = o3 <*> pure (\ (a,b) -> (b,a)) + + +---- Recursive: + +-- ffix :: Functor f => f (a->a) -> f a +-- ffix = fmap fix + +-- or +-- ffix :: (m a -> m a) -> m a +-- ffix = fix + +unPair :: Functor f => f (a, b) -> (f a, f b) +unPair p = (fmap fst p, fmap snd p) + +ui7 :: UI (Int,Int) +ui7 = fix f + where f :: UI (Int,Int) -> UI (Int,Int) + f bounds = liftA2 (,) + (isliderDyn (pair (pure 0) hi) 3) + (isliderDyn (pair lo (pure 10)) 8) + where + ~(lo,hi) = unPair bounds + +ui8 :: UI Upd +ui8 = total <*> fmap (uncurry (+)) ui7 + +ui9 :: UI Upd +ui9 = fix f *> pure mempty + where f :: UI Int -> UI Int + f val = isliderDyn (pair ((subtract 5) <$> val) ((+ 5) <$> val)) 10
src/Graphics/UI/Phooey/Applicative.hs view
@@ -18,7 +18,7 @@ module Graphics.UI.Phooey.Applicative ( -- * The UI applicative functor- UI, runUI, runNamedUI, Upd, Snk+ UI, runUI, runNamedUI, Act, Snk -- * Tools for high-level widgets , IWidget, OWidget -- * Some high-level widgets@@ -38,7 +38,7 @@ import Graphics.UI.Phooey.TagT import qualified Graphics.UI.Phooey.Monad as M-import Graphics.UI.Phooey.Monad (Source,Upd,Snk)+import Graphics.UI.Phooey.Monad (Source,Act,Snk) {----------------------------------------------------------@@ -46,15 +46,15 @@ ----------------------------------------------------------} -- | The UI applicative functor.-type UI = Compose M.UI Source+type UI = O M.UI Source -- | Run a 'UI' with window title \"Monadic Phooey GUI\".-runUI :: UI Upd -> IO ()+runUI :: UI Act -> IO () runUI = runNamedUI "Applicative Phooey GUI" -- | Run a 'UI' with given window title.-runNamedUI :: String -> UI Upd -> IO ()-runNamedUI name = M.runNamedUI' name . unComp+runNamedUI :: String -> UI Act -> IO ()+runNamedUI name = M.runNamedUI' name . unO {----------------------------------------------------------@@ -69,11 +69,11 @@ -- | Make an input widget iwidget :: M.IWidget a -> IWidget a-iwidget mwid a = Comp (mwid a)+iwidget mwid a = O (mwid a) -- | Make an output widget owidget :: M.OWidget' a -> OWidget a-owidget mwid = Comp (fmap pure mwid)+owidget mwid = O (fmap pure mwid) {----------------------------------------------------------@@ -103,7 +103,7 @@ -- | Slider widget with dynamic bounds. isliderDyn :: UI (Int,Int) -> IWidget Int-isliderDyn (Comp bounds) initial = Comp $+isliderDyn (O bounds) initial = O $ bounds >>= flip M.isliderDyn initial -- | Boolean input widget@@ -116,7 +116,7 @@ -- | Wrap a title around a 'UI' title :: String -> Unop (UI a)-title str = onComp (M.title str)+title str = inO (M.title str) -- mapLayout (boxed str) {----------------------------------------------------------@@ -125,7 +125,7 @@ -- | Tweak the 'LayoutT' onLayoutT :: LayoutTOp IO -> Unop (UI a)-onLayoutT f = onComp (M.onLayoutT f)+onLayoutT f = inO (M.onLayoutT f) -- | Lay out from top to bottom fromTop :: Unop (UI a)
src/Graphics/UI/Phooey/Imperative.hs view
@@ -16,7 +16,7 @@ module Graphics.UI.Phooey.Imperative ( -- * Widget & layout tools- hwidget,lhwidget ,hsliderDyn, mkNews+ hwidget,lhwidget ,hsliderDyn, mkNews, commandNews -- * Simple abstraction around widget containers and frames , Win, Wio, runWio )@@ -27,7 +27,7 @@ import Data.IORef import Control.Monad (join)-import Data.Monoid (mempty,mappend)+import Data.Monoid (mappend) import Control.Instances () -- For Monoid (IO a) instance {-----------------------------------------------------------------------@@ -77,13 +77,24 @@ when (lo <= x && x <= hi) (set ctl [ selection := x ]) --- | Make a "news" publisher and an action that executes all subscribed actions-mkNews :: Commanding wid => wid -> IO (IO () -> IO ())-mkNews wid = - do -- putStrLn "mkNews"- ref <- newIORef (mempty :: IO ()) -- contains subscribed actions- set wid [ on command := join (readIORef ref) ]- return $ modifyIORef ref . mappend+-- | Make a \"news\" publisher given a function that (destructively) assigns+-- a single action to be executed upon some event. The publisher can+-- remember any number of actions (the "subscribers").+mkNews :: (IO () -> IO ()) -> IO (IO () -> IO ())+mkNews setNotify = + do ref <- newIORef (return ()) -- contains subscribed actions+ setNotify (join (readIORef ref))+ return $ modifyIORef ref . mappend++-- | Make a \"news\" publisher for a widget's command.+commandNews :: Commanding wid => wid -> IO (IO () -> IO ())+commandNews wid = mkNews (\ act -> set wid [ on command := act ])++-- cmdNews wid = +-- do -- putStrLn "mkNews"+-- ref <- newIORef (return ()) -- contains subscribed actions+-- set wid [ on command := join (readIORef ref) ]+-- return $ modifyIORef ref . mappend -- TODO: perform action only when the value actually changes. I get an -- extra kick on grabbing a slider and two extra on releasing. Is there a
src/Graphics/UI/Phooey/Monad.hs view
@@ -18,7 +18,7 @@ module Graphics.UI.Phooey.Monad ( -- * The UI monad- UI, Source, Upd, Snk, runUI, runNamedUI, runUI', runNamedUI'+ UI, Source, Act, Snk, runUI, runNamedUI, runUI', runNamedUI' -- * Tools for high-level widgets , IWidget, OWidget, OWidget', IOWidget, MkWidget , iwidget, owidget, owidget', iowidget@@ -56,13 +56,13 @@ ----------------------------------------------------------} -- | The UI monad-type UI = ReaderT Win (WriterT Upd (LayoutT IO))+type UI = ReaderT Win (WriterT Act (LayoutT IO)) -- | Sources of values (data-driven) type Source = DataDriven IO --- | IO-based updater-type Upd = Updater IO -- == IO ()+-- | IO-based action+type Act = Action IO -- == IO () -- | IO-based sink type Snk a = Sink IO a@@ -75,16 +75,16 @@ runNamedUI :: String -> UI (Source ()) -> IO () runNamedUI name = runL name . ((liftM runDD' . runWriterT) .) . runReaderT where- runDD' :: (Source (), Upd) -> Upd+ runDD' :: (Source (), Act) -> Act runDD' (src, delayed) = runDD src >> delayed -- or delayed first? -- | Run a 'UI' with window title \"Monadic Phooey GUI\" -- alternative version-runUI' :: UI (Source Upd) -> Upd+runUI' :: UI (Source Act) -> Act runUI' = runNamedUI' "Monadic Phooey GUI" -- | Run a 'UI' with given window title -- alternative version. Works -- with \"alternative\"-style outputs.-runNamedUI' :: String -> UI (Source Upd) -> Upd+runNamedUI' :: String -> UI (Source Act) -> Act runNamedUI' name = runNamedUI name . liftM joinDD @@ -106,13 +106,53 @@ type MkWidget widget a b = Unop Layout -> (Win -> [Prop widget] -> IO widget) -> Attr widget a -> b +-- iwidgetSource :: Commanding widget =>+-- (Win -> [Prop widget] -> IO widget) -- ^ widget maker+-- -> Attr widget a -- ^ widget attribute+-- -> a -- ^ initial value+-- -> Win -- ^ parent+-- -> IO (widget, Source a)+-- iwidgetSource mkWid attr initial win =+-- do wid <- mkWid win [ attr := initial ]+-- news <- commandNews wid+-- return (wid, dd news (get wid attr))++-- | Make a (data-driven) value source for a given widget and attribute.+commandSource :: Commanding widget =>+ widget -- ^ widget+ -> Attr widget a -- ^ attribute+ -> IO (Source a)+commandSource wid attr = fmap (dd (get wid attr)) (commandNews wid)++-- commandSource wid attr =+-- do news <- commandNews wid+-- return (dd news (get wid attr))++ -- | Make a high-level input widget iwidget :: (Commanding widget, Widget widget) => MkWidget widget a (IWidget a)++-- iwidget layf mkWid attr initial = mkWidget layf $ \ win ->+-- do (wid, src) <- iwidgetSource mkWid attr initial win+-- return (wid, (src,mempty))++-- iwidget layf mkWid attr initial =+-- mkWidget layf (fmap tag . iwidgetSource mkWid attr initial)+-- where+-- tag (wid, src) = (wid, (src,mempty))++-- mkWidget layf (second (flip (,) mempty) (iwidgetSource mkWid attr initial))+ iwidget layf mkWid attr initial = mkWidget layf $ \ win ->- do wid <- mkWid win [ attr := initial ]- onCmd <- mkNews wid- return (wid, (dd onCmd (get wid attr), mempty))+ do wid <- mkWid win [ attr := initial ]+ src <- commandSource wid attr+ return (wid, (src,mempty)) +-- iwidget layf mkWid attr initial = mkWidget layf $ \ win ->+-- do wid <- mkWid win [ attr := initial ]+-- news <- commandNews wid+-- return (wid, (dd news (get wid attr), mempty))+ type IWidgetDyn a b = Source a -> IWidget b type MkIWidgetDyn widget a b =@@ -123,13 +163,21 @@ -- | Slider widget with static initial value and dynamic bounds (min,max) iwidgetDyn :: (Commanding widget, Widget widget) => MkIWidgetDyn widget a b-iwidgetDyn layf mkWid attr src initial = mkWidget layf $ \ win ->++iwidgetDyn layf mkWid attr srcA initial = mkWidget layf $ \ win -> do (wid,snkA) <- mkWid win [ attr := initial ]- onCmd <- mkNews wid+ src <- commandSource wid attr return ( wid- , ( dd onCmd (get wid attr)- , runDD (mapSrc (>>= snkA) src) ) )+ , ( src+ , runDD (mapCur (>>= snkA) srcA) ) ) +-- iwidgetDyn layf mkWid attr src initial = mkWidget layf $ \ win ->+-- do (wid,snkA) <- mkWid win [ attr := initial ]+-- news <- commandNews wid+-- return ( wid+-- , ( dd news (get wid attr)+-- , runDD (mapGet (>>= snkA) src) ) )+ -- OWidget is convenient for a monad interface. For building an -- applicative functor, we'll want the the alternative OWidget' style. @@ -249,11 +297,11 @@ -- | Make a widget mkWidget :: forall a widget. Widget widget => Unop Layout -- ^ filler: id, hfill, vfill, or fill- -> (Win -> IO (widget, (a, Upd)))+ -> (Win -> IO (widget, (a, Act))) -> UI a mkWidget layf f = ReaderT (WriterT . mkTag . panelWrap layf f') where- f' :: Win -> IO (Maybe Layout, (a, Upd))+ f' :: Win -> IO (Maybe Layout, (a, Act)) f' w = liftM (first (Just . layf . widget)) (f w)