phooey 0.3 → 1.0
raw patch · 21 files changed
+1058/−759 lines, 21 filesdep +TypeCompose
Dependencies added: TypeCompose
Files
- CHANGES +17/−0
- Makefile +1/−0
- phooey.cabal +18/−15
- src/Examples.hs +0/−86
- src/Examples/Arrow.hs +116/−0
- src/Examples/Examples.hs +21/−0
- src/Examples/Imperative.hs +70/−0
- src/Examples/Monad.hs +159/−0
- src/Graphics/UI/Phooey.hs +0/−152
- src/Graphics/UI/Phooey/AFA.hs +0/−51
- src/Graphics/UI/Phooey/Applicative.hs +172/−0
- src/Graphics/UI/Phooey/Arrow.hs +138/−0
- src/Graphics/UI/Phooey/ArrowUI.hs +0/−126
- src/Graphics/UI/Phooey/CallBackT.hs +0/−57
- src/Graphics/UI/Phooey/Imperative.hs +36/−77
- src/Graphics/UI/Phooey/LayoutT.hs +23/−6
- src/Graphics/UI/Phooey/Monad.hs +275/−0
- src/Graphics/UI/Phooey/MonadUI.hs +0/−156
- src/Graphics/UI/Phooey/TagT.hs +9/−4
- src/Graphics/UI/Phooey/tst.hs +3/−2
- src/MonadExamples.hs +0/−27
CHANGES view
@@ -1,3 +1,20 @@+Version 1.0:+* Uses new TypeCompose package, which includes a simple implementation of+ data-driven computation.+* New Applicative functor interface.+* Eliminated the catch-all Phooey.hs module. Now import any one of+ Graphics.UI.Phooey.{Monad,Applicative,Arrow}. +* renamed "textEntry" to "stringEntry"+* added "isliderDisplay"+* Phooey.Monad has two different styles of output widgets, made by owidget+ and owidget'. The latter is used to implement Phooey.Applicative.+* Self- and mutually-recursive widgets now work again in Phooey.Monad.+ They still hang in Phooey.Arrow.++Version 0.3.1:+* Fixed dos-style line breaks in src/MonadExamples.hs+* Fixed Functor UI def (broke the circularity)+ Version 0.3: * Finished renaming "CallbackT" to "CallBackT" (thanks to Michal Palka for catching the inconsistency).
Makefile view
@@ -3,6 +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://wxhaskell.sourceforge.net/doc,c:/Haskell/wxhaskell/out/doc/wxhaskell.haddock include ../my-cabal-make.inc
phooey.cabal view
@@ -1,15 +1,14 @@ Name: phooey-Version: 0.3+Version: 1.0 Synopsis: Functional user interfaces Category: User Interfaces Description:- Phooey is a library for functional UIs.- .- If you just want to /use/ Phooey, see the main module below- ("Graphics.UI.Phooey"). The other modules (@UI.Graphics.Phooey.*@) are- useful for understanding the implementation and adding new features.+ Phooey is a library for functional UIs, providing three different+ functional interfaces: Monad, Applicative, and Arrow. See the+ correspondingly named modules in the list below. The other modules are+ exposed for extensibility. .- Try out the examples in @src\/Examples.hs@.+ Try out the examples in @src\/Examples\/@. . See also .@@ -18,6 +17,9 @@ * Use of Phooey for composable interfaces in the TV library: <http://haskell.org/haskellwiki/GuiTV> .+ * The implementation of data-driven computation (used in Phooey) from+ the TypeCompose library: <http://haskell.org/haskellwiki/TypeCompose>+ . This page and the module documentation pages have links to colorized source code and to wiki pages where you can read and contribute /user comments/. Enjoy!@@ -30,17 +32,18 @@ License: BSD3 Stability: provisional Hs-Source-Dirs: src-Extensions: CPP Arrows, UndecidableInstances-Build-Depends: base, mtl, arrows, wx, wxcore+Extensions: CPP, Arrows+Build-Depends: base, mtl, arrows, TypeCompose, wx, wxcore Exposed-Modules: - Graphics.UI.Phooey Graphics.UI.Phooey.Imperative- Graphics.UI.Phooey.CallBackT Graphics.UI.Phooey.TagT Graphics.UI.Phooey.LayoutT- Graphics.UI.Phooey.MonadUI- Graphics.UI.Phooey.AFA- Graphics.UI.Phooey.ArrowUI+ Graphics.UI.Phooey.Monad+ Graphics.UI.Phooey.Applicative+ Graphics.UI.Phooey.Arrow Extra-Source-Files:- Examples+ Examples.Imperative+ Examples.Monad+ Examples.Applicative+ Examples.Arrow ghc-options: -O -Wall
− src/Examples.hs
@@ -1,86 +0,0 @@-{-# OPTIONS -fglasgow-exts -farrows #-}-------------------------------------------------------------------------- |--- Module : Examples--- Copyright : (c) Conal Elliott 2006--- License : LGPL--- --- Maintainer : conal@conal.net--- Stability : experimental--- Portability : portable--- --- Phooey examples. Run them with 'runUI'-------------------------------------------------------------------------module Examples where--import Control.Arrow-import Graphics.UI.Phooey-import Graphics.UI.Phooey.Imperative---- Simple shopping list--ui1 :: UI () ()-ui1 = title "Shopping List" $- proc () -> do- a <- title "apples" (islider 3) -< (0,10)- b <- title "bananas" (islider 7) -< (0,10)- title "total" showDisplay -< a+b----- Dynamic bounds--ui2 = proc () -> do- lo <- title "lo" (islider 3) -< (0,10)- hi <- title "hi" (islider 8) -< (0,10)- val <- title "val" (islider 5) -< (lo,hi)- title "factorial" showDisplay -< fact val--fact n = product [1 .. n]----- In the two examples above, visual layout is implicitly chosen to be--- top-down, following the order in which the components are declared in--- the arrow expressions. This choice may be overridden, as in the--- following examples.--uiB1 = fromBottom ui1-uiL1 = fromLeft ui1-uiR1 = fromRight ui1--ui3 = fromBottom $- proc () -> do- (a,b) <- fromRight fruit -< (0,10)- title "total" showDisplay -< a+b- where - fruit = title "apples" (islider 3) &&&- title "bananas" (islider 7)----- Recursive examples. These ones just hang. Investigate.--ui4 = proc () -> do- rec lo <- title "lo" (islider 3) -< (0,hi)- hi <- title "hi" (islider 8) -< (lo,10)- val <- title "val" (islider 5) -< (lo,hi)- title "factorial" showDisplay -< fact val- returnA -< ()---ui5 = proc () -> do- rec val <- title "val" (islider 6) -< (val-5,val+5)- title "squared" showDisplay -< val*val----ui6 = proc () -> do- s <- title "message" textEntry -< ()- title "reversed" stringDisplay -< reverse s----- Simpler example for testing-uia = proc () -> do- n <- islider 5 -< (0,10)- showDisplay -< fact n--uia' = fromLeft uia
+ src/Examples/Arrow.hs view
@@ -0,0 +1,116 @@+{-# OPTIONS -fglasgow-exts -farrows #-}+----------------------------------------------------------------------+-- |+-- Module : Examples.Arrow+-- Copyright : (c) Conal Elliott 2006+-- License : LGPL+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- Portability : portable+-- +-- Phooey examples. Run them with 'runUI'+----------------------------------------------------------------------++module Examples.Arrow where++import Control.Arrow+import Graphics.UI.Phooey.Arrow++-- Simple shopping list++sl0 :: IWidget Int+sl0 = islider (0,10)++ui1 :: UI () ()+ui1 = title "Shopping List" $+ proc () -> do+ a <- title "apples" $ sl0 3 -< ()+ b <- title "bananas" $ sl0 7 -< ()+ title "total" showDisplay -< a+b+++lo,hi :: UI () Int+lo = title "lo" (sl0 3)+hi = title "hi" (sl0 8)++-- Dynamic bounds+ui2 = proc () -> do+ l <- lo -< ()+ h <- hi -< ()+ v <- title "val" $ isliderDyn 5 -< (l,h)+ title "factorial" showDisplay -< fact v++bounds :: UI () (Int,Int)+bounds = lo &&& hi++bounds' = proc () -> do + l <- lo -< ()+ h <- hi -< ()+ returnA -< (l,h)+ ++val :: UI () Int+val = title "val" $ (lo &&& hi) >>> isliderDyn 5++val' = bounds >>> title "val" (isliderDyn 5)++ui2' = val' >>> pure fact >>> title "factorial" showDisplay++ui2'' = (fact ^<< val') >>> title "factorial" showDisplay+++fact n = product [1 .. n]+++-- In the two examples above, visual layout is implicitly chosen to be+-- top-down, following the order in which the components are declared in+-- the arrow expressions. This choice may be overridden, as in the+-- following examples.++uiB1 = fromBottom ui1+uiL1 = fromLeft ui1+uiR1 = fromRight ui1++ui3 = fromBottom $+ proc () -> do+ (a,b) <- fromRight fruit -< (0,10)+ title "total" showDisplay -< a+b+ where + fruit = title "apples" (isliderDyn 3) &&&+ title "bananas" (isliderDyn 7)+++-- Recursive examples. These ones just hang. Investigate.+++uir1 = proc () -> do+ rec lo <- title "lo" (isliderDyn 3) -< (0,hi)+ hi <- title "hi" (isliderDyn 8) -< (lo,10)+ val <- title "val" (isliderDyn 5) -< (lo,hi)+ title "factorial" showDisplay -< fact val+ returnA -< ()++uir2 = proc () -> do+ rec val <- title "val" (isliderDyn 6) -< (val-5,val+5)+ title "squared" showDisplay -< val*val++uir3 = proc () -> do+ s <- title "message" (stringEntry "") -< ()+ title "reversed" stringDisplay -< reverse s+++-- -- Simpler example for testing+-- uia = proc () -> do+-- n <- sl0 5 -< ()+-- showDisplay -< fact n++-- uia' = fromLeft uia++-- uib :: UI () ()+-- uib = title "Shopping List" $+-- proc () -> do+-- a <- title "apples" (sl0 3) -< ()+-- b <- title "bananas" (sl0 7) -< ()+-- title "sum" showDisplay -< a+b+-- title "product" showDisplay -< a*b
+ src/Examples/Examples.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS #-} + +---------------------------------------------------------------------- +-- | +-- Module : Examples.Examples +-- Copyright : (c) Conal Elliott 2007 +-- License : LGPL +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- Portability : portable +-- +-- Imports example modules for easy error-checking +---------------------------------------------------------------------- + +module Examples.Examples where + +import qualified Examples.Imperative as Imp +import qualified Examples.Monad as Mon +import qualified Examples.Applicative as App +import qualified Examples.Arrow as Arr
+ src/Examples/Imperative.hs view
@@ -0,0 +1,70 @@+{-# OPTIONS #-} + +---------------------------------------------------------------------- +-- | +-- Module : Examples.Imperative +-- Copyright : (c) Conal Elliott 2007 +-- License : LGPL +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- Portability : portable +-- +-- Imperative Phooey examples +---------------------------------------------------------------------- + +module Examples.Imperative where + +import Graphics.UI.Phooey.Imperative + +import Graphics.UI.WX + + +runUI0 :: IO () +runUI0 = start $ + do f <- frame [ visible := False, text := "ui0" ] + pan <- panel f [] + count <- hslider pan True 0 10 [ selection := 3 ] + countSub <- mkNews count + double <- textEntry pan [ ] + triple <- textEntry pan [ ] + + let updDouble = do n <- get count selection + set double [ text := show (2*n) ] + let updTriple = do n <- get count selection + set triple [ text := show (3*n) ] + countSub updDouble + countSub updTriple + updDouble + updTriple + set pan [ layout := + boxed "Shopping List" $ + fill $ column 0 + [ lhwidget "count" count + , lhwidget "double" double {-""-} + , lhwidget "triple" triple ] ] + set f [ layout := hwidget pan, visible := True ] + +runUI1 :: IO () +runUI1 = start $ + do f <- frame [ visible := False, text := "ui1" ] + pan <- panel f [] + apples <- hslider pan True 0 10 [ selection := 3 ] + newsA <- mkNews apples + bananas <- hslider pan True 0 10 [ selection := 7 ] + newsB <- mkNews bananas + total <- textEntry pan [ ] + let updTot = do a <- get apples selection + b <- get bananas selection + set total [ text := show (a+b) ] + newsA updTot + newsB updTot + updTot + set pan [ layout := + boxed "Shopping List" $ + fill $ column 0 + [ lhwidget "apples" apples + , lhwidget "bananas" bananas {-""-} + , lhwidget "total" total ] ] + set f [ layout := hwidget pan, visible := True ] +
+ src/Examples/Monad.hs view
@@ -0,0 +1,159 @@+{-# OPTIONS -fglasgow-exts #-}++----------------------------------------------------------------------+-- |+-- Module : Examples.Monad+-- Copyright : (c) Conal Elliott 2007+-- License : LGPL+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- Portability : portable+-- +-- Monadic-style Phooey examples. Use 'runUI'+----------------------------------------------------------------------++module Examples.Monad where++import Control.Applicative+import Control.Monad (liftM2)+import Control.Monad.Fix+import Data.Monoid (mappend,mempty)++import Graphics.UI.Phooey.Monad+++-- h :: UI (Source String)+-- h = return (pure "Hello World!")++-- uia,uib :: UI (Source ())+-- uia = stringDisplay =<< h+-- uib = showDisplay =<< sl0 3+++ui1 :: UI (Source ())+ui1 = title "Shopping List" $+ do a <- title "apples" $ islider (0,10) 3+ b <- title "bananas" $ islider (0,10) 7+ title "total" $ showDisplay (liftA2 (+) a b)++-- Refactoring++sl0 :: IWidget Int+sl0 = islider (0,10)++apples, bananas :: UI (Source Int)+apples = title "apples" $ sl0 3+bananas = title "bananas" $ sl0 7++total :: Num a => OWidget a+total = title "total" . showDisplay++ui1x :: UI (Source ())+ui1x = title "Shopping List" $+ do a <- apples+ b <- bananas+ total (liftA2 (+) a b)++fruit :: UI (Source Int)+fruit = liftM2 (liftA2 (+)) apples bananas++ui1y :: UI (Source ())+ui1y = title "Shopping List" $ fruit >>= total+++-- In the two examples above, visual layout is implicitly chosen to be+-- top-down, following the order in which the components are declared in+-- the arrow expressions. This choice may be overridden, as in the+-- following examples.++uiB1 = fromBottom ui1+uiL1 = fromLeft ui1+uiR1 = fromRight ui1+++ui3 = fromBottom $+ title "Shopping List" $+ fromRight fruit >>= total+++-- Experiments with multiple displays+uix = do n <- sl0 3+ liftM2 mappend+ (showDisplay (liftA (*2) n))+ (showDisplay (liftA (*3) n))++-- Dynamic++ui2 :: UI (Source ())+ui2 = do l <- title "lo" $ sl0 3+ h <- title "hi" $ sl0 8+ v <- title "val" $ isliderDyn (pair l h) 5+ title "factorial" $ showDisplay (liftA fact v)++fact :: Int -> Int+fact n = product [1 .. n]++-- Refactor++lo,hi :: UI (Source Int)+lo = title "lo" $ sl0 3+hi = title "hi" $ sl0 8++bounds :: UI (Source (Int,Int))+bounds = liftM2 pair lo hi++val :: UI (Source Int)+val = do b <- bounds+ title "val" $ isliderDyn b 5++-- Alternative style, in which the "val" title is around the lo & hi+-- sliders as well. This layout reflects the purpose of the lo & hi+-- sliders.++val' = title "val" $+ do b <- bounds+ isliderDyn b 5++ui2' = do v <- val'+ title "factorial" $ showDisplay (liftA fact v)+++-- Recursive++uir1 :: UI (Source ())+uir1 = mdo l <- title "lo" $ isliderDyn (pair (pure 0) h) 3+ h <- title "hi" $ isliderDyn (pair l (pure 10)) 8+ v <- title "val" $ isliderDyn (pair l h) 5+ title "factorial" $ showDisplay (liftA fact v)++-- Refactor++boundsR :: UI (Source (Int,Int))+boundsR = mfix boundsF+ where+ boundsF lh = liftM2 pair+ (title "lo" $ isliderDyn (pair (pure 0) h) 3)+ (title "hi" $ isliderDyn (pair l (pure 10)) 8)+ where+ (l,h) = unPair lh++unPair :: Functor f => f (a, b) -> (f a, f b)+unPair p = (fmap fst p, fmap snd p)++valR :: UI (Source Int)+valR = do b <- boundsR+ title "val" $ isliderDyn b 5++uir1' = do v <- valR+ title "factorial" $ showDisplay (liftA fact v)+++uir2 = mdo v <- title "val" (isliderDyn (liftA (plusMinus 5) v) 6)+ title "squared" (showDisplay (liftA square v))+ where+ plusMinus n x = (x-n,x+n)+ square y = y*y++pair :: Applicative f => f a -> f b -> f (a,b)+pair = liftA2 (,)
− src/Graphics/UI/Phooey.hs
@@ -1,152 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--{- |-- Module : Graphics.UI.Phooey- Copyright : (c) Conal Elliott 2006- License : LGPL-- Maintainer : conal@conal.net- Stability : provisional- Portability : portable--Phooey presents a simple, functional, and arrow-based interface to UI-construction.--This module simply re-exports most of "Graphics.UI.Phooey.ArrowUI" (hiding-the implementation and extensibility).--GUIs are usually programmed in an \"unnatural\" style, in that-implementation dependencies are inverted, relative to logical-dependencies. This reversal results directly from the imperative-orientation of most GUI libraries. While outputs depend on inputs from a-user and semantic point of view, the imperative approach imposes an-implementation dependence of inputs on outputs.--Phooey (\"/ph/unctional /oo/s/e/r /y/nterfaces\") retains the functional-style, in which outputs are expressed in terms of inputs. In addition,-Phooey supports dynamic input bounds, flexible layout, and-mutually-referential widgets.--As a first example, here is a simple shopping list GUI. The /total/-displayed at the bottom of the window always shows the sum of the values-of the /apples/ and /bananas/ input sliders. When a user changes the-inputs, the output updates accordingly.--@ <<http://haskell.org/sitewiki/images/2/2f/Ui1.png>>@--@- ui1 :: 'UI' () ()- ui1 = 'title' \"Shopping List\" $- proc () -> do- a <- 'title' \"apples\" ('islider' 3) -< (0,10)- b <- 'title' \"bananas\" ('islider' 7) -< (0,10)- 'title' \"total\" 'showDisplay' -< a+b-@--To run this example (found in @src\/Examples.hs@ in the source release),-do @'runUI' ui1@.--A @UI@ value (widget, complete interactive application, or anything in-between) represents both functionality /and/ user interface. Each UI has-information flowing in and information flowing out. For this reason, @UI@-has two type parameters, the input and output types. For instance, a-slider has its (potentially varying) bounds as input and its (varying)-value as output, while a display has the value to be displayed as input-and a @()@ output. Any UI may be wrapped with a title and automatically-routes input and output to and from the wrapped UI. (See below for the-types of 'islider', 'showDisplay', and 'title', as used in defining @u1@-above.)--The slider bounds in @ui1@ are all static. In the following example, the-first two sliders determine the bounds of the third slider.--@ <<http://haskell.org/sitewiki/images/1/1b/Ui2.png>>@--@- ui2 = proc () -> do- lo <- 'title' \"lo\" ('islider' 3) -< (0,10)- hi <- 'title' \"hi\" ('islider' 8) -< (0,10)- val <- 'title' \"val\" ('islider' 5) -< (lo,hi)- 'title' \"factorial\" 'showDisplay' -< fact val- where- fact n = 'product' [1 .. n]-@--By default, UI layout follows the order of the specification, with-earlier-specified components above later-specified ones. This layout may-be overridden by explicit layout functions. For instance, the following-definitions form variations of @u1@ laid out from bottom to top and from-left to right.--GUIs & code:--@ <<http://haskell.org/sitewiki/images/1/1b/UiB1.png>>@--@ <<http://haskell.org/sitewiki/images/f/f1/UiL1.png>>@--@- uiB1 = 'fromBottom' ui1- uiL1 = 'fromLeft' ui1-@---We can also lay out a sub-assembly, as in @ui3@ below, which uses the-arrow @&&&@ operator to feed a single input flow into two UIs and pair up-the outputs.--@ <<http://haskell.org/sitewiki/images/7/70/Ui3.png>>@--@- ui3 = 'fromBottom' $- proc () -> do- (a,b) <- 'fromRight' fruit -< (0,10)- 'title' \"total\" 'showDisplay' -< a+b- where - fruit = 'title' \"apples\" ('islider' 3) &&&- 'title' \"bananas\" ('islider' 7)-@--Next is a recursive example. It is like @ui2@, but the @lo@ and @hi@-sliders are used to bound each other. The specification enforces the-constraint that @lo <= hi@.--@ <<http://haskell.org/sitewiki/images/4/46/Ui4.png>>@--@- ui4 = proc () -> do- rec lo <- 'title' \"lo\" ('islider' 3) -< (0,hi)- hi <- 'title' \"hi\" ('islider' 8) -< (lo,10)- val <- 'title' \"val\" ('islider' 5) -< (lo,hi)- 'title' \"factorial\" 'showDisplay' -< fact val- returnA -< ()-@--The final example is tightly recursive. A slider is used to bound-/itself/, so that the range is always the current value ±5.--@ <<http://haskell.org/sitewiki/images/7/71/Ui5.png>>@--@- ui5 = proc () -> do- rec val <- 'title' \"val\" ('islider' 6) -< (val-5,val+5)- 'title' \"squared\" 'showDisplay' -< val*val-@--These last two examples just hang when run. The pictures are from a-previous implementation. Hmm.---}--module Graphics.UI.Phooey- (- -- * The UI arrow- UI, runUI, runNamedUI- -- * High-level widgets- , stringDisplay, showDisplay, textEntry, islider- , checkBoxDisplay, checkBoxEntry, title- -- * Explicit layout- , fromTop, fromBottom, fromLeft, fromRight, flipLayout- ) where--import Graphics.UI.Phooey.ArrowUI
− src/Graphics/UI/Phooey/AFA.hs
@@ -1,51 +0,0 @@-{-# OPTIONS -fglasgow-exts -farrows #-}--------------------------------------------------------------------------- |--- Module : Graphics.UI.Phooey.AFA--- Copyright : (c) Conal Elliott 2006--- License : LGPL--- --- Maintainer : conal@conal.net--- Stability : provisional--- Portability : portable--- --- This module captures a pattern that for building an arrow from an arrow--- and an applicative functor. (Hence the name \"AFA\".) Motivation--- follows.--- --- The UI monad makes for simple examples, but an awkwardness remains,--- namely explicit Source types. The reason for Source types is that in a--- monadic bind, @m >>= f@ (as hidden in @do@ notation), nothing can be--- known about the function @f@ until it is applied to a value generated--- by @m@. In other words, the monadic interface prevents us from--- accessing the static aspects of @f@ and separating them from the--- dynamic aspects. This difficulty is the main motivation for--- generalizing monads to arrows.-------------------------------------------------------------------------module Graphics.UI.Phooey.AFA where--import Control.Arrow hiding (pure)-import Control.Applicative (Applicative, liftA,liftA2)--newtype AFA (~>) src i o = AFA (src i ~> src o)--instance {-""-} (Arrow (~>), Applicative src)- => Arrow (AFA (~>) src) where- arr f = AFA (arr (liftA f))- AFA ab >>> AFA bc = AFA (ab >>> bc)- first (AFA a) =- AFA (arr splitA >>> first a >>> arr mergeA)--instance {-""-} (ArrowLoop (~>), Applicative src)- => ArrowLoop (AFA (~>) src) where- -- loop :: UI (b,d) (c,d) -> UI b c- loop (AFA k) =- AFA (loop (arr mergeA >>> k >>> arr splitA))--mergeA :: Applicative m => (m a, m c) -> m (a,c)-mergeA ~(ma,mc) = liftA2 (,) ma mc--splitA :: Applicative m => m (a,b) -> (m a, m b)-splitA m = (liftA fst m, liftA snd m)
+ src/Graphics/UI/Phooey/Applicative.hs view
@@ -0,0 +1,172 @@+{-# OPTIONS -fglasgow-exts #-}++----------------------------------------------------------------------+-- |+-- Module : Graphics.UI.Phooey.Applicative+-- Copyright : (c) Conal Elliott 2007+-- License : LGPL+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- Portability : portable+-- +-- UIs as applicative functors. This module is a very simple layering+-- over "Graphics.UI.Phooey.Monad". It serves to hide the 'Source' types+-- and give an applicative feel to UI construction.+----------------------------------------------------------------------++module Graphics.UI.Phooey.Applicative+ (+ -- * The UI applicative functor+ UI, runUI, runNamedUI, Upd, Snk+ -- * Tools for high-level widgets+ , IWidget, OWidget+ -- * Some high-level widgets+ , stringEntry, stringDisplay, showDisplay+ , islider, isliderDyn, isliderDisplay+ , checkBoxEntry, checkBoxDisplay+ , title+ -- * Explicit layout+ , fromTop, fromBottom, fromLeft, fromRight, flipLayout+ ) where++import Control.Monad.Reader+import Control.Applicative+import Control.Compose++import Graphics.UI.Phooey.LayoutT+import Graphics.UI.Phooey.TagT++import qualified Graphics.UI.Phooey.Monad as M+import Graphics.UI.Phooey.Monad (Source,Upd,Snk)+++{----------------------------------------------------------+ The UI applicative functor+----------------------------------------------------------}++-- | The UI applicative functor.+type UI = Compose M.UI Source++-- | Run a 'UI' with window title \"Monadic Phooey GUI\".+runUI :: UI Upd -> IO ()+runUI = runNamedUI "Applicative Phooey GUI"++-- | Run a 'UI' with given window title.+runNamedUI :: String -> UI Upd -> IO ()+runNamedUI name = M.runNamedUI' name . unComp+++{----------------------------------------------------------+ Tools for high-level widgets+----------------------------------------------------------}++-- | Input widget, with initial value.+type IWidget a = a -> UI a++-- | Output widget. Yields a sink of values+type OWidget a = UI (Snk a)++-- | Make an input widget+iwidget :: M.IWidget a -> IWidget a+iwidget mwid a = Comp (mwid a)++-- | Make an output widget+owidget :: M.OWidget' a -> OWidget a+owidget mwid = Comp (fmap pure mwid)+++{----------------------------------------------------------+ Some high-level widgets+----------------------------------------------------------}++-- | String input widget+stringEntry :: IWidget String+stringEntry = iwidget M.stringEntry++-- | String display widget+stringDisplay :: OWidget String+stringDisplay = owidget M.stringDisplay'++-- | Showable output widget+showDisplay :: Show a => OWidget a+showDisplay = owidget M.showDisplay'+++-- | Slider input widget with static bounds+islider :: (Int,Int) -> IWidget Int+islider bounds = iwidget (M.islider bounds)++-- | Slider output widget with static bounds+isliderDisplay :: (Int,Int) -> OWidget Int+isliderDisplay bounds = owidget (M.isliderDisplay' bounds)++-- | Slider widget with dynamic bounds.+isliderDyn :: UI (Int,Int) -> IWidget Int+isliderDyn (Comp bounds) initial = Comp $+ bounds >>= flip M.isliderDyn initial++-- | Boolean input widget+checkBoxEntry :: IWidget Bool+checkBoxEntry = iwidget M.checkBoxEntry++-- | Boolean display widget+checkBoxDisplay :: OWidget Bool+checkBoxDisplay = owidget M.checkBoxDisplay'++-- | Wrap a title around a 'UI'+title :: String -> Unop (UI a)+title str = onComp (M.title str)+ -- mapLayout (boxed str)++{----------------------------------------------------------+ Layout+----------------------------------------------------------}++-- | Tweak the 'LayoutT'+onLayoutT :: LayoutTOp IO -> Unop (UI a)+onLayoutT f = onComp (M.onLayoutT f)++-- | Lay out from top to bottom+fromTop :: Unop (UI a)++-- | Lay out from bottom to top+fromBottom :: Unop (UI a)++-- | Lay out from left to right+fromLeft :: Unop (UI a)++-- | Lay out from right to left+fromRight :: Unop (UI a)++-- | Reverse layout+flipLayout :: Unop (UI a)++fromTop = onLayoutT fromTopL+fromBottom = onLayoutT fromBottomL+fromLeft = onLayoutT fromLeftL+fromRight = onLayoutT fromRightL+flipLayout = onLayoutT flipL+++-----++{-++-- Overloading mischief. Standard incantation for applicative functors.++instance Show (UI a) where+ show _ = "<UI>"++instance Eq (UI a) where+ (==) = error "no Eq for UI"++instance Ord (UI a) where+ (<) = error "no Ord for UI"++instance Num a => Num (UI a) where+ (+) = liftA2 (+)+ fromInteger = pure . fromInteger+ -- etc++-}
+ src/Graphics/UI/Phooey/Arrow.hs view
@@ -0,0 +1,138 @@+{-# OPTIONS -fglasgow-exts #-}++----------------------------------------------------------------------+-- |+-- Module : Graphics.UI.Phooey.Arrow+-- Copyright : (c) Conal Elliott 2006+-- License : LGPL+-- +-- Maintainer : conal@conal.net+-- Stability : provisional+-- Portability : portable+-- +-- A functional UI arrow. See explanation and examples in+-- "Graphics.UI.Phooey".+----------------------------------------------------------------------++module Graphics.UI.Phooey.Arrow+ ( + -- * The UI arrow+ UI(..), runUI, runNamedUI+ -- * High-level widgets+ , IWidget, OWidget+ , stringDisplay, showDisplay, stringEntry, islider, isliderDyn+ , checkBoxDisplay, checkBoxEntry, title+ -- * Explicit layout+ , fromTop, fromBottom, fromLeft, fromRight, flipLayout+ -- * Internal (extensibility)+ , ui, sourceOp, onLayoutT+ ) where+++import Control.Arrow+import Data.Monoid++import Graphics.UI.Phooey.TagT (Unop)+import Graphics.UI.Phooey.LayoutT+import qualified Graphics.UI.Phooey.Monad as M++import Control.Compose++{----------------------------------------------------------+ The UI arrow+----------------------------------------------------------}++-- | The UI arrow+newtype UI i o = UI ((ArrowAp (Kleisli M.UI) M.Source) i o)+ deriving (Arrow,ArrowLoop)++-- | Run a 'UI' with window title \"Phooey Arrow GUI\".+runUI :: UI () () -> IO ()+runUI = runNamedUI "Phooey Arrow GUI"++-- | Run a 'UI' with given window title.+runNamedUI :: String -> UI () () -> IO ()+runNamedUI str (UI (ArrowAp (Kleisli f))) = M.runNamedUI str (f mempty)++-- runNamedUI str (UI (ArrowAp (Kleisli f))) = M.runNamedUI str (f mempty)++-- | Wrap up monadic UI function as a 'UI'+ui :: (M.Source i -> M.UI (M.Source o)) -> UI i o+ui = UI . ArrowAp . Kleisli+++{----------------------------------------------------------+ High-level widgets+----------------------------------------------------------}++-- | Input widget type (with initial value)+type IWidget a = a -> UI () a+-- | Output widget type+type OWidget a = UI a ()++-- | String display widget+stringDisplay :: OWidget String+stringDisplay = ui M.stringDisplay++-- | Showable display widget+showDisplay :: Show a => OWidget a+showDisplay = pure show >>> stringDisplay+ -- or: ui M.showDisplay++-- | Simple text input widget+stringEntry :: IWidget String+stringEntry initial = ui (const (M.stringEntry initial))++-- | Slider widget with initial value and /static/ bounds (min,max)+islider :: (Int,Int) -> IWidget Int+islider bounds initial = ui (const (M.islider bounds initial))++-- | Slider widget with static initial value and /dynamic/ bounds (min,max)+isliderDyn :: Int -> UI (Int,Int) Int+isliderDyn initial = ui (flip M.isliderDyn initial)++-- | String display widget+checkBoxDisplay :: UI Bool ()+checkBoxDisplay = ui M.checkBoxDisplay++-- | Simple checkbox input widget+checkBoxEntry :: Bool -> UI () Bool+checkBoxEntry initial = ui (const (M.checkBoxEntry initial))++-- | Wrap a title around a 'UI'+title :: String -> Unop (UI a b)+title str = sourceOp (M.title str)+++{----------------------------------------------------------+ Layout+----------------------------------------------------------}++-- | Lay out from top to bottom+fromTop :: Unop (UI a b)+fromTop = onLayoutT fromTopL++-- | Lay out from bottom to top+fromBottom :: Unop (UI a b)+fromBottom = onLayoutT fromBottomL++-- | Lay out from left to right+fromLeft :: Unop (UI a b)+fromLeft = onLayoutT fromLeftL++-- | Lay out from right to left+fromRight :: Unop (UI a b)+fromRight = onLayoutT fromRightL++-- | Reverse layout+flipLayout :: Unop (UI a b)+flipLayout = onLayoutT flipL+++---- Misc unexported++sourceOp :: Unop (M.UI (M.Source b)) -> Unop (UI a b)+sourceOp f (UI (ArrowAp (Kleisli g))) = ui (f . g)++onLayoutT :: LayoutTOp IO -> Unop (UI a b)+onLayoutT f = sourceOp (M.onLayoutT f)
− src/Graphics/UI/Phooey/ArrowUI.hs
@@ -1,126 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--------------------------------------------------------------------------- |--- Module : Graphics.UI.Phooey.ArrowUI--- Copyright : (c) Conal Elliott 2006--- License : LGPL--- --- Maintainer : conal@conal.net--- Stability : provisional--- Portability : portable--- --- A functional UI arrow. See explanation and examples in--- "Graphics.UI.Phooey".-------------------------------------------------------------------------module Graphics.UI.Phooey.ArrowUI- ( - -- * The UI arrow- UI(..), runUI, runNamedUI- -- * High-level widgets- , stringDisplay, showDisplay, textEntry, islider- , checkBoxDisplay, checkBoxEntry, title- -- * Explicit layout- , fromTop, fromBottom, fromLeft, fromRight, flipLayout- -- * Internal (extensibility)- , ui, sourceOp, onLayoutT- ) where---import Control.Arrow--import Graphics.UI.Phooey.Imperative (Source,skip)-import Graphics.UI.Phooey.TagT (Unop)-import Graphics.UI.Phooey.LayoutT-import qualified Graphics.UI.Phooey.MonadUI as M-import Graphics.UI.Phooey.AFA---{----------------------------------------------------------- The UI arrow-----------------------------------------------------------}---- | The UI arrow-newtype UI i o = UI (AFA (Kleisli M.UI) IO i o)- deriving (Arrow,ArrowLoop)---- | Run a 'UI' with window title \"Phooey GUI\".-runUI :: UI () () -> IO ()-runUI = runNamedUI "Phooey GUI"---- | Run a 'UI' with given window title.-runNamedUI :: String -> UI () () -> IO ()-runNamedUI str (UI (AFA (Kleisli f))) = M.runNamedUI str (f skip)---- | Wrap up monadic UI function as a 'UI'-ui :: (Source i -> M.UI (Source o)) -> UI i o-ui = UI . AFA . Kleisli---{----------------------------------------------------------- High-level widgets-----------------------------------------------------------}---- | String display widget-stringDisplay :: UI String ()-stringDisplay = ui M.stringDisplay---- | Showable display widget-showDisplay :: Show a => UI a ()-showDisplay = pure show >>> stringDisplay- -- or: ui M.showDisplay---- | Simple text input widget-textEntry :: UI () String-textEntry = ui (const M.textEntry)---- | Slider widget with static initial value and dynamic bounds (min,max)-islider :: Int -> UI (Int,Int) Int-islider initial = ui (M.islider initial)---- | String display widget-checkBoxDisplay :: UI Bool ()-checkBoxDisplay = ui M.checkBoxDisplay---- | Simple checkbox input widget-checkBoxEntry :: Bool -> UI () Bool-checkBoxEntry initial = ui (const (M.checkBoxEntry initial))---- | Wrap a title around a 'UI'-title :: String -> Unop (UI a b)-title str = sourceOp (M.title str)---{----------------------------------------------------------- Layout-----------------------------------------------------------}---- | Lay out from top to bottom-fromTop :: Unop (UI a b)-fromTop = onLayoutT fromTopL---- | Lay out from bottom to top-fromBottom :: Unop (UI a b)-fromBottom = onLayoutT fromBottomL---- | Lay out from left to right-fromLeft :: Unop (UI a b)-fromLeft = onLayoutT fromLeftL---- | Lay out from right to left-fromRight :: Unop (UI a b)-fromRight = onLayoutT fromRightL---- | Reverse layout-flipLayout :: Unop (UI a b)-flipLayout = onLayoutT flipL------- Misc unexported--sourceOp :: Unop (M.UI (Source b)) -> Unop (UI a b)-sourceOp f (UI (AFA (Kleisli g))) = ui (f . g)--onLayoutT :: LayoutTOp IO -> Unop (UI a b)-onLayoutT f = sourceOp (M.onLayoutT f)
− src/Graphics/UI/Phooey/CallBackT.hs
@@ -1,57 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--------------------------------------------------------------------------- |--- Module : Graphics.UI.Phooey.CallBackT--- Copyright : (c) Conal Elliott 2006--- License : LGPL--- --- Maintainer : conal@conal.net--- Stability : provisional--- Portability : portable--- --- A monad transformer for managing callbacks.--- --- In imperative GUI programs (wxHaskell. at least), the constructed--- widgets are used in four ways: extracting the current value, setting--- the callback invoked on user input, updating, and constructing a--- layout. 'CallBackT' manages callbacks and updates. /(Work on this--- description.)/-------------------------------------------------------------------------module Graphics.UI.Phooey.CallBackT (CallBackT(..), runCB) where--import Control.Monad.Reader-import Control.Monad.Trans--import Graphics.UI.Phooey.Imperative---- | The callback monad transformer.-newtype CallBackT m a =- CB {unCB :: m (a, Sink Updater, Updater)}--instance Monad m => Monad (CallBackT m) where- return a = lift (return a)- p >>= f = CB (do (a,ona,upda) <- unCB p- (b,onb,updb) <- unCB (f a)- return ( b- , \ u -> ona (updb>>u) >> onb u- , upda>>updb))--instance MonadTrans CallBackT where- lift m = CB (do a <- m- return (a, munch, skip))--instance {-""-} MonadFix m- => MonadFix (CallBackT m) where- mfix f = CB (mdo ~(a,snk,upd) <- unCB (f a)- return (a, snk.(>>upd), upd))---- | /Run/ a callback-transformed-monad value-runCB :: Monad m =>- (Updater -> m ()) -- ^ lifter- -> CallBackT m a- -> m a-runCB liftUpd (CB m) = do (a,on,upd) <- m- liftUpd (on upd >> upd)- return a
src/Graphics/UI/Phooey/Imperative.hs view
@@ -15,53 +15,37 @@ module Graphics.UI.Phooey.Imperative (- -- * Producers & consumers of values- Source,Sink,Updater, skip, munch, set1 -- * Widget & layout tools- , getSel, onCommand, hwidget,lhwidget ,hsliderDyn- -- * Wio+ hwidget,lhwidget ,hsliderDyn, mkNews+ -- * Simple abstraction around widget containers and frames , Win, Wio, runWio- -- * Testing- , runUI1 ) where import Graphics.UI.WX import Graphics.UI.WXCore (sliderGetMin,sliderGetMax,sliderSetRange) --{------------------------------------------------------------------------ Producers & consumers of values-------------------------------------------------------------------------}--type Source a = IO a -- ^ A producer (/source/) of values-type Sink a = a -> Updater -- ^ A consumer (/sink/) of values-type Updater = IO () -- ^ Something that /updates/ state---- | The do-nothing 'Updater'-skip :: Updater-skip = return ()---- | The do-nothing 'Sink'-munch :: Sink a-munch = const skip--set1 :: w -> Attr w a -> Sink a-set1 w attr val = set w [ attr := val ]-+import Data.IORef+import Control.Monad (join)+import Data.Monoid (mempty,mappend)+import Control.Instances () -- For Monoid (IO a) instance {----------------------------------------------------------------------- Widget & layout tools -----------------------------------------------------------------------} --- | Get the current 'selection' value of a widget-getSel :: Selection ctl => ctl -> IO Int-getSel ctl = get ctl selection+-- -- | Get the current 'selection' value of a widget+-- getSel :: Selection ctl => ctl -> IO Int+-- getSel ctl = get ctl selection --- | Set the 'command' callback-onCommand :: Commanding ctl => ctl -> Updater -> IO ()-onCommand ctl upd = set ctl [ on command := upd ]+-- -- | Set a single attribute+-- set1 :: w -> Attr w a -> a -> IO ()+-- set1 w attr val = set w [ attr := val ] +-- -- | Set the 'command' callback+-- onCommand :: Commanding ctl => ctl -> IO () -> IO ()+-- onCommand ctl io = set ctl [ on command := io ]+ -- | Horizontally-filled widget layout hwidget :: Widget w => w -> Layout hwidget = hfill . widget@@ -71,32 +55,20 @@ lhwidget str = boxed str . hwidget -{- -- Unused---- | Vertical layout-vertical :: [Layout] -> Layout-vertical layouts = fill (column 0 layouts)---- | Horizontal layout-horizontal :: [Layout] -> Layout-horizontal layouts = fill (row 0 layouts)---}- -- | Dynamically bounded slider. The main complication is keeping the -- slider value within the dynamic bounds. hsliderDyn :: Window a -> Bool -> [Prop (Slider ())]- -> IO (Slider (), Sink (Int,Int))+ -> IO (Slider (), (Int,Int) -> IO ()) hsliderDyn win showBounds props =- do -- The reason for +- 1000 in |makeISlider| is simply to reserve+ do -- The reason for +- 100 in |makeISlider| is simply to reserve -- space. There's a wxWidgets (I think) oddity that requires manual -- resizing otherwise.- ctl <- hslider win showBounds (-1000) (1000) props+ ctl <- hslider win showBounds (-100) (100) props return (ctl, setBounds ctl) where- setBounds ctl (lo',hi') =+ setBounds ctl (lo',hi') = do sliderSetRange ctl lo' hi'- val <- getSel ctl+ val <- get ctl selection when (val < lo') (setVal ctl lo') when (val > hi') (setVal ctl hi') setVal ctl x =@@ -105,6 +77,19 @@ 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++-- 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+-- way to eliminate them?++ {----------------------------------------------------------------------- Wio -- simple abstraction around widget containers and frames -----------------------------------------------------------------------}@@ -112,37 +97,11 @@ type Win = Panel () -- ^ Container of widgets type Wio = Win -> IO Layout -- ^ Consumes container and yield layout --- | "Run" a 'Wio': handle frame & widget creation, and apply layout.+-- | Run a 'Wio': handle frame & widget creation, and apply layout. runWio :: String -> Wio -> IO () runWio name wio = start $- do f <- frame [visible := False, text := name]+ do f <- frame [ visible := False, text := name ] win <- panel f [] l <- wio win set win [ layout := l ] set f [ layout := hwidget win, visible := True ]-------- Examples--runUI1 :: IO ()-runUI1 = start $- do f <- frame [ visible := False, text := "ui1" ]- pan <- panel f []- apples <- hslider pan True 0 10 [ selection := 3 ]- bananas <- hslider pan True 0 10 [ selection := 7 ]- total <- textEntry pan [ ]- let updTot = do a <- getSel apples- b <- getSel bananas- set total [ text := show (a+b) ]- onCommand apples updTot- onCommand bananas updTot- updTot- set pan [ layout :=- boxed "Shopping List" $- fill $ column 0- [ lhwidget "apples" apples- , lhwidget "bananas" bananas {-""-}- , lhwidget "total" total ] ]- set f [ layout := hwidget pan, visible := True ]-
src/Graphics/UI/Phooey/LayoutT.hs view
@@ -21,10 +21,11 @@ -- * 'LayoutT' combinators , flipL , fromTopL, fromBottomL, fromLeftL, fromRightL -- , above, beside, fempty , setLayoutL+ -- * Miscellany+ , panelWrap ) where import Data.Maybe (fromMaybe)-import Control.Monad (liftM) import Graphics.UI.WX import Graphics.UI.Phooey.Imperative (Win, runWio)@@ -40,13 +41,15 @@ -- | /Run/ a 'LayoutT'. runLayout :: Monad m => LayoutT m a -> m (Layout,a) runLayout lt =- do (mbl,a) <- runTag above lt+ do ~(mbl,a) <- runTag above lt return (fromMaybe fempty mbl, a) --- | Create a window and run a 'LayoutT' in it.-runL :: String -> (Win -> LayoutT IO a) -> IO ()-runL name f = runWio name $ \ win ->- liftM fst (runLayout (f win))+-- | Create a window, and run a 'LayoutT' in it.+runL :: String -> (Win -> LayoutT IO (IO ())) -> IO ()+runL name f = runWio name $ \ win -> + do ~(l,upd) <- runLayout (f win)+ upd+ return l {----------------------------------------------------------@@ -97,3 +100,17 @@ -- fromBottomL = flipL . fromTopL -- fromRightL = flipL . fromLeftL+++{----------------------------------------------------------+ Miscellany+----------------------------------------------------------}++-- | Wrap another panel and layout unop (probably id, hfill, vfill, or fill)+-- to get desired stretchiness.+panelWrap :: Unop Layout -> Unop (Win -> IO (Maybe Layout, b))+panelWrap layf f w = do pan <- panel w []+ ~(mbl,b) <- f pan+ -- if we get a layout, use it for the panel.+ maybe (return ()) (\ l -> set pan [ layout := l ]) mbl+ return (Just (layf (widget pan)), b)
+ src/Graphics/UI/Phooey/Monad.hs view
@@ -0,0 +1,275 @@+{-# OPTIONS -fglasgow-exts #-}++----------------------------------------------------------------------+-- |+-- Module : Graphics.UI.Phooey.Monad+-- Copyright : (c) Conal Elliott 2006+-- License : LGPL+-- +-- Maintainer : conal@conal.net+-- Stability : provisional+-- Portability : portable+-- +-- A functional UI monad. Uses explicit data-driven \"sources\" of+-- values. Supports recursive GUIs. See+-- <http://haskell.org/haskellwiki/Phooey#Monadic_Interface>.+----------------------------------------------------------------------++module Graphics.UI.Phooey.Monad+ (+ -- * The UI monad+ UI, Source, Upd, Snk, runUI, runNamedUI, runUI', runNamedUI'+ -- * Tools for high-level widgets+ , IWidget, OWidget, OWidget', IOWidget, MkWidget+ , iwidget, owidget, owidget', iowidget+ -- * Some high-level widgets+ , stringEntry, stringDisplay, stringDisplay'+ , showDisplay, showDisplay'+ , islider, isliderDyn, isliderDisplay, isliderDisplay'+ , checkBoxEntry, checkBoxDisplay, checkBoxDisplay'+ , title+ -- * Explicit layout+ , fromTop, fromBottom, fromLeft, fromRight, flipLayout+ -- * Misc tools+ , mkWidget+ , onLayoutT, mapLayout+ ) where++import Control.Applicative+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Arrow (first)++import Graphics.UI.WX hiding (textEntry)+import qualified Graphics.UI.WX as WX++import Control.Compose () -- for Monad (IO a) instance+import Control.DataDriven++import Graphics.UI.Phooey.Imperative+import Graphics.UI.Phooey.TagT (Unop,UUnop,mkTag,mapTag)+import Graphics.UI.Phooey.LayoutT+++{----------------------------------------------------------+ The UI monad+----------------------------------------------------------}++-- | The UI monad+type UI = ReaderT Win (WriterT Upd (LayoutT IO))++-- | Sources of values (data-driven)+type Source = DataDriven IO++-- | IO-based updater+type Upd = Updater IO -- == IO ()++-- | IO-based sink+type Snk a = Sink IO a++-- | Run a 'UI' with window title \"Monadic Phooey GUI\".+runUI :: UI (Source ()) -> IO ()+runUI = runNamedUI "Monadic Phooey GUI"++-- | Run a 'UI' with given window title.+runNamedUI :: String -> UI (Source ()) -> IO ()+runNamedUI name = runL name . ((liftM runDD' . runWriterT) .) . runReaderT+ where+ runDD' :: (Source (), Upd) -> Upd+ 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' = 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' name = runNamedUI name . liftM joinDD+++{----------------------------------------------------------+ 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 (Source ())+-- | Alternative output widget type+type OWidget' a = UI (Snk a)++-- | Combine input & output widget types+type IOWidget a = (IWidget a, OWidget a, OWidget' a)++-- | Type of widget-making functions+type MkWidget widget a b =+ Unop Layout -> (Win -> [Prop widget] -> IO widget) -> Attr widget a -> b++-- | 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 <- mkWid win [ attr := initial ]+ onCmd <- mkNews wid+ return (wid, (dd onCmd (get wid attr), mempty))++type IWidgetDyn a b = Source a -> IWidget b++type MkIWidgetDyn widget a b =+ Unop Layout+ -> (Win -> [Prop widget] -> IO (widget, Snk a))+ -> Attr widget b+ -> IWidgetDyn a b++-- | 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 ->+ do (wid,snkA) <- mkWid win [ attr := initial ]+ onCmd <- mkNews wid+ return ( wid+ , ( dd onCmd (get wid attr)+ , runDD (mapSrc (>>= snkA) src) ) )++-- OWidget is convenient for a monad interface. For building an+-- applicative functor, we'll want the the alternative OWidget' style.++-- | Make a high-level output widget+owidget :: Widget widget => MkWidget widget a (OWidget a)+owidget layf mkWid attr src =+ liftM (joinDD . (<$> src)) (owidget' layf mkWid attr)++-- | Make a high-level output widget+owidget' :: Widget widget => MkWidget widget a (OWidget' a)+owidget' layf mkWid attr = mkWidget layf $ \ win ->+ do wid <- mkWid win [ ]+ return (wid, (\ a -> set wid [ attr := a ], mempty))++-- | Convenience function combining 'iwidget', 'owidget', and 'owidget\''+iowidget :: (Commanding widget, Widget widget) => MkWidget widget a (IOWidget a)+iowidget layf mkWid attr =+ (iwidget layf mkWid attr, owidget layf mkWid attr, owidget' layf mkWid attr)+++{----------------------------------------------------------+ 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 WX.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+++-- | Slider widget with static initial value and dynamic bounds (min,max)+isliderDyn :: Source (Int,Int) -> IWidget Int+isliderDyn = iwidgetDyn hfill (flip hsliderDyn True) selection++-- | 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++-- | Wrap a title around a 'UI'+title :: String -> Unop (UI a)+title str = mapLayout (boxed str)+++{----------------------------------------------------------+ Layout+----------------------------------------------------------}++-- | Lay out from top to bottom+fromTop :: Unop (UI a)+fromTop = onLayoutT fromTopL++-- | Lay out from bottom to top+fromBottom :: Unop (UI a)+fromBottom = onLayoutT fromBottomL++-- | Lay out from left to right+fromLeft :: Unop (UI a)+fromLeft = onLayoutT fromLeftL++-- | Lay out from right to left+fromRight :: Unop (UI a)+fromRight = onLayoutT fromRightL++-- | Reverse layout+flipLayout :: Unop (UI a)+flipLayout = onLayoutT flipL+++{----------------------------------------------------------+ Misc tools+----------------------------------------------------------}++-- | Make a widget+mkWidget :: forall a widget. Widget widget+ => Unop Layout -- ^ filler: id, hfill, vfill, or fill+ -> (Win -> IO (widget, (a, Upd)))+ -> UI a+mkWidget layf f = ReaderT (WriterT . mkTag . panelWrap layf f')+ where+ f' :: Win -> IO (Maybe Layout, (a, Upd))+ f' w = liftM (first (Just . layf . widget)) (f w)+++-- | Tweak the 'LayoutT'+onLayoutT :: LayoutTOp IO -> Unop (UI a)+onLayoutT f = mapReaderT' (mapWriterT' f)++-- | Tweak the layout+mapLayout :: Unop Layout -> Unop (UI a)+mapLayout f = onLayoutT (mapTag f)+++-- Same defs as 'mapReaderT', 'mapWriterT', but different types++mapWriterT' :: UUnop m -> UUnop (WriterT w m)+mapWriterT' f m = WriterT $ f (runWriterT m)++mapReaderT' :: UUnop m -> UUnop (ReaderT w m)+mapReaderT' f m = ReaderT $ f . runReaderT m
− src/Graphics/UI/Phooey/MonadUI.hs
@@ -1,156 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--------------------------------------------------------------------------- |--- Module : Graphics.UI.Phooey.MonadUI--- Copyright : (c) Conal Elliott 2006--- License : LGPL--- --- Maintainer : conal@conal.net--- Stability : provisional--- Portability : portable--- --- A functional UI monad.-------------------------------------------------------------------------module Graphics.UI.Phooey.MonadUI- (- -- * The UI monad- UI, runUI, runNamedUI- -- * High-level widgets- , stringDisplay, showDisplay, textEntry, islider- , checkBoxDisplay, checkBoxEntry, title- -- * Tools for defining high-level widgets- , mkWidget- -- * Layout- , onLayoutT, mapLayout- ) where--import Control.Applicative-import Control.Monad.Reader-import Control.Monad.Trans-import Graphics.UI.WX hiding (textEntry)-import qualified Graphics.UI.WX as WX--import Graphics.UI.Phooey.Imperative-import Graphics.UI.Phooey.CallBackT-import Graphics.UI.Phooey.TagT (Unop,mkTag,mapTag)-import Graphics.UI.Phooey.LayoutT---{----------------------------------------------------------- The UI monad-----------------------------------------------------------}---- | The UI monad-type UI = CallBackT (ReaderT Win (LayoutT IO))--instance Functor UI where { fmap = (<$>) }-instance Applicative UI where { pure = return; (<*>) = ap }---- | Run a 'UI' with window title \"Monadic Phooey GUI\".-runUI :: UI (Source ()) -> IO ()-runUI = runNamedUI "Monadic Phooey GUI"---- | Run a 'UI' with given window title.-runNamedUI :: String -> UI (Source ()) -> IO ()-runNamedUI name = runL name . runReaderT . runCB (lift.lift)---{----------------------------------------------------------- High-level widgets-----------------------------------------------------------}---- | String display widget-stringDisplay :: Source String -> UI (Source ())-stringDisplay src = mkHWidget $ \ win ->- do ctl <- mkText win- return ( Just (hwidget ctl)- , (skip, munch, src >>= set1 ctl text))---- | Showable display widget-showDisplay :: Show a => Source a -> UI (Source ())-showDisplay src = stringDisplay (fmap show src)---- | Simple text input widget-textEntry :: UI (Source String)-textEntry = mkHWidget $ \ win ->- do ctl <- mkText win- return ( Just (hwidget ctl)- , (get ctl text, onCommand ctl, skip))--mkText :: WX.Window a -> IO (WX.TextCtrl ())-mkText win = WX.textEntry win []----- | Slider widget with static initial value and dynamic bounds (min,max)-islider :: Int -> Source (Int,Int) -> UI (Source Int)-islider initial bounds = mkHWidget $ \ win ->- do (ctl,snk) <- hsliderDyn win True [ selection := initial ]- return ( Just (hwidget ctl)- , (getSel ctl, onCommand ctl, bounds>>=snk) )---- | String display widget-checkBoxDisplay :: Source Bool -> UI (Source ())-checkBoxDisplay src = mkWidget id $ \ win ->- do ctl <- WX.checkBox win []- return ( Just (hwidget ctl)- , (skip, munch, src >>= set1 ctl checked) )---- | Simple checkbox input widget-checkBoxEntry :: Bool -> UI (Source Bool)-checkBoxEntry initial = mkWidget id $ \ win ->- do ctl <- WX.checkBox win [ checked := initial ]- return ( Just (hwidget ctl)- , (get ctl checked, onCommand ctl, skip) )---- TODO: factor out commonalities between textEntry & checkBoxEntry and--- between stringDisplay & checkBoxDisplay.----- | Wrap a title around a 'UI'-title :: String -> Unop (UI a)-title str = mapLayout (boxed str)---{----------------------------------------------------------- Tools for defining high-level widgets-----------------------------------------------------------}---- | Make a widget-mkWidget :: Unop Layout -- ^ id, hfill, vfill, or fill- -> (Win -> IO ( Maybe Layout- , (a, Sink Updater, Updater)))- -> UI a-mkWidget layf f = CB (mkRead (mkTag . panWrap layf f))---- | Make a widget with horizontal filling-mkHWidget :: (Win -> IO ( Maybe Layout- , (a, Sink Updater, Updater)))- -> UI a-mkHWidget = mkWidget hfill----- Wrap another panel and layout unop (probably id, hfill, vfill, or fill)--- to get desired stretchiness.-panWrap :: Unop Layout -> Unop (Win -> IO (Maybe Layout, b))-panWrap layf f w = do pan <- panel w []- (mbl,b) <- f pan- -- if we get a layout, use it for the panel.- maybe skip (set1 pan layout) mbl- return (Just (layf (widget pan)), b)---- | Tweak the 'LayoutT'-onLayoutT :: LayoutTOp IO -> Unop (UI a)-onLayoutT f (CB reader) = CB (mkRead (f . runReaderT reader))---- | Tweak the layout-mapLayout :: Unop Layout -> Unop (UI a)-mapLayout f = onLayoutT (mapTag f)------- Misc unexported--mkRead :: Monad m => (r -> m a) -> ReaderT r m a-mkRead f = do r <- ask- lift (f r)
src/Graphics/UI/Phooey/TagT.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-}+{-# OPTIONS -fglasgow-exts #-} ---------------------------------------------------------------------- -- |@@ -16,7 +16,7 @@ module Graphics.UI.Phooey.TagT ( -- * Convenient function synonyms- Unop, Binop+ Unop, UUnop, Binop -- * The /tagging/ monad transformer (or tagged-value maker) , TagT(..), runTag -- * Transforming tagged-value makers@@ -36,7 +36,9 @@ type Unop a = a -> a type Binop a = a -> a -> a +type UUnop f = forall a. Unop (f a) + {---------------------------------------------------------- The /tagging/ monad transformer / tagged-value maker. Tags may be present or absent and are combined according to@@ -54,8 +56,8 @@ instance Monad m => Monad (TagT tag m) where return a = lift (return a)- wta >>= f = T (do (ta,a) <- unT wta- (tb,b) <- unT (f a)+ wta >>= f = T (do ~(ta,a) <- unT wta+ ~(tb,b) <- unT (f a) op <- ask return (mb op ta tb, b)) where@@ -64,6 +66,9 @@ instance MonadFix m => MonadFix (TagT tag m) where mfix f = T (mfix (\ ~(_,a) -> unT (f a)))++instance Monad m => Functor (TagT tag m) where+ fmap f ui = ui >>= return . f {----------------------------------------------------------
src/Graphics/UI/Phooey/tst.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS -fglasgow-exts #-} -main :: IO ()-main = putStrLn (reverse "Hello World!")+-- Build an arrow out of two +newtype AFF (~>) f src a b = FF (f (src a ~> src b))
− src/MonadExamples.hs
@@ -1,27 +0,0 @@-{-# OPTIONS #-} - ----------------------------------------------------------------------- --- | --- Module : MonadExamples --- Copyright : (c) Conal Elliott 2007 --- License : LGPL --- --- Maintainer : conal@conal.net --- Stability : experimental --- Portability : portable --- --- Monadic UI examples ----------------------------------------------------------------------- - -module MonadExamples where - -import Control.Monad (liftM2) - -import Graphics.UI.Phooey.Imperative (Source) -import Graphics.UI.Phooey.MonadUI - -ui1 :: UI (Source ()) -ui1 = title "Shopping List" $ - do a <- title "apples" (islider 3 (return (0,10))) - b <- title "bananas" (islider 7 (return (0,10))) - title "total" (showDisplay (liftM2 (+) a b))