phooey 0.1 → 0.2.1
raw patch · 16 files changed
+1105/−1081 lines, 16 files
Files
- CHANGES +20/−13
- Makefile +14/−13
- README +28/−28
- TODO +0/−0
- phooey.cabal +46/−46
- src/Examples.hs +88/−80
- src/Graphics/UI/Phooey.hs +152/−152
- src/Graphics/UI/Phooey/AmA.hs +54/−54
- src/Graphics/UI/Phooey/ArrowUI.hs +130/−130
- src/Graphics/UI/Phooey/CallBackT.hs +57/−66
- src/Graphics/UI/Phooey/Imperative.hs +148/−147
- src/Graphics/UI/Phooey/LayoutT.hs +99/−99
- src/Graphics/UI/Phooey/MonadUI.hs +147/−130
- src/Graphics/UI/Phooey/TagT.hs +116/−117
- src/Graphics/UI/Phooey/Test.hs +3/−3
- src/Graphics/UI/Phooey/tst.hs +3/−3
CHANGES view
@@ -1,13 +1,20 @@-Changes in version 0.1: - -* Web-located references to other libraries (base, mtl, arrows.) -* Colorized source code links (thanks to hscolour). -* "User Comments", for adding add comments and questions. -* New home (wiki) page: http://haskell.org/haskellwiki/Phooey -* Switched from monadLib to mtl, for easier installation -* Added this "CHANGES" file -* Text input (textEntry) -* Fixed all of the module intro comments -* Boolean input/output (checkBoxEntry, checkBoxDisplay) -* runNamedUI for explicit window title (rather "Phooey GUI") -* Phooey is now used in TV: http://haskell.org/haskellwiki/Phooey . +Version 0.2.1:+* Changed all files to *nix-style line endings.++Changes in version 0.2:++* Finally fixed a long-standing stretching bug. When widgets are abutted horizontally, they now all stretch together.++Changes in version 0.1:++* Web-located references to other libraries (base, mtl, arrows.)+* Colorized source code links (thanks to hscolour).+* "User Comments", for adding add comments and questions.+* New home (wiki) page: http://haskell.org/haskellwiki/Phooey+* Switched from monadLib to mtl, for easier installation+* Added this "CHANGES" file+* Text input (textEntry)+* Fixed all of the module intro comments+* Boolean input/output (checkBoxEntry, checkBoxDisplay)+* runNamedUI for explicit window title (rather "Phooey GUI")+* Phooey is now used in TV: http://haskell.org/haskellwiki/Phooey .
Makefile view
@@ -1,13 +1,14 @@-# See README for Cabal-based building. Other fancy stuff (like haddock) here. - -user = conal -package = phooey - -haddock_args=\ - --no-use-packages \ - --haddock-arg=--read-interface=http://haskell.org/ghc/docs/latest/html/libraries/base,c:/ghc/ghc-6.6/doc/html/libraries/base/base.haddock \ - --haddock-arg=--read-interface=http://haskell.org/ghc/docs/latest/html/libraries/mtl,c:/ghc/ghc-6.6/doc/html/libraries/mtl/mtl.haddock \ - --haddock-arg=--read-interface=http://wxhaskell.sourceforge.net/doc,c:/Haskell/wxhaskell/out/doc/wxhaskell.haddock \ - # enough, already! - -include ../my-cabal-make.inc +# See README for Cabal-based building. Other fancy stuff (like haddock) here.++user = conal+package = phooey++configure_args=--disable-use-packages --haddock-args="\+ --read-interface=http://haskell.org/ghc/docs/latest/html/libraries/base,c:/ghc/ghc-6.6/doc/html/libraries/base/base.haddock \+ --read-interface=http://haskell.org/ghc/docs/latest/html/libraries/mtl,c:/ghc/ghc-6.6/doc/html/libraries/mtl/mtl.haddock \+ --read-interface=http://wxhaskell.sourceforge.net/doc,c:/Haskell/wxhaskell/out/doc/wxhaskell.haddock \+ $(source_args)\+ $(comments_args)\+ "++include ../my-cabal-make.inc
README view
@@ -1,28 +1,28 @@-Phooey is a library for functional user intefaces. It's currently built -on wxHaskell, but could probably be tweaked to run on top of other -imperative UI libraries. For a fuller description and link to -documentation, please see the Haskell wiki page: - - http://haskell.org/haskellwiki/phooey - -You can configure, build, and install all in the usual way with Cabal -commands. - - runhaskell Setup.lhs configure - runhaskell Setup.lhs build - runhaskell Setup.lhs install - -See src/Examples.hs for examples. - -The dependencies are recorded in phooey.cabal. Besides base, you'll need -"mtl", "arrows" and the wxHaskell packages "wx" and "wxcore". I've tested -Phooey with wxHaskell built on wxWidgets-2.4.2 and on wxWidgets-2.6.3. -Both work, but wxWidgets-2.4.2 is much friendlier with ghci, as it lets -you run more than one wxHaskell app (Phooey app) per ghci session. With -wxWidgets-2.6.3, the ghci process will crash if you try to run two GUIs. -(True also for ghc-compiled code, but rarely problematic.) Since there is -no known fix for for this crashing problem, I recommend wxWidgets-2.4.2. - -If you find that Phooey doesn't work with some version of base, mtl, -arrows, wx, or wxcore, please let me know, and I'll update phooey.cabal -accordingly. +Phooey is a library for functional user intefaces. It's currently built+on wxHaskell, but could probably be tweaked to run on top of other+imperative UI libraries. For a fuller description and link to+documentation, please see the Haskell wiki page:++ http://haskell.org/haskellwiki/phooey++You can configure, build, and install all in the usual way with Cabal+commands.++ runhaskell Setup.lhs configure+ runhaskell Setup.lhs build+ runhaskell Setup.lhs install++See src/Examples.hs for examples.++The dependencies are recorded in phooey.cabal. Besides base, you'll need+"mtl", "arrows" and the wxHaskell packages "wx" and "wxcore". I've tested+Phooey with wxHaskell built on wxWidgets-2.4.2 and on wxWidgets-2.6.3.+Both work, but wxWidgets-2.4.2 is much friendlier with ghci, as it lets+you run more than one wxHaskell app (Phooey app) per ghci session. With+wxWidgets-2.6.3, the ghci process will crash if you try to run two GUIs.+(True also for ghc-compiled code, but rarely problematic.) Since there is+no known fix for for this crashing problem, I recommend wxWidgets-2.4.2.++If you find that Phooey doesn't work with some version of base, mtl,+arrows, wx, or wxcore, please let me know, and I'll update phooey.cabal+accordingly.
+ TODO view
phooey.cabal view
@@ -1,46 +1,46 @@-Name: phooey -Version: 0.1 -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. - . - Try out the examples in @src\/Examples.hs@. - . - See also - . - * The project wiki page <http://haskell.org/haskellwiki/phooey> - . - * Use of Phooey for composable interfaces in the TV library: - <http://haskell.org/haskellwiki/TV> - . - 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! - . - © 2006 by Conal Elliott; BSD3 license. -Author: Conal Elliott -Maintainer: conal@conal.net -Homepage: http://haskell.org/haskellwiki/Phooey -Copyright: (c) 2006 by Conal Elliott -License: BSD3 -Stability: provisional -Hs-Source-Dirs: src -Extensions: CPP Arrows, UndecidableInstances -Build-Depends: base, mtl, arrows, 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.AmA - Graphics.UI.Phooey.ArrowUI -Extra-Source-Files: - Examples -ghc-options: -O -Wall +Name: phooey+Version: 0.2.1+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.+ .+ Try out the examples in @src\/Examples.hs@.+ .+ See also+ .+ * The project wiki page <http://haskell.org/haskellwiki/phooey>+ .+ * Use of Phooey for composable interfaces in the TV library:+ <http://haskell.org/haskellwiki/TV>+ .+ 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!+ .+ © 2006 by Conal Elliott; BSD3 license.+Author: Conal Elliott +Maintainer: conal@conal.net+Homepage: http://haskell.org/haskellwiki/Phooey+Copyright: (c) 2006 by Conal Elliott+License: BSD3+Stability: provisional+Hs-Source-Dirs: src+Extensions: CPP Arrows, UndecidableInstances+Build-Depends: base, mtl, arrows, 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.AmA+ Graphics.UI.Phooey.ArrowUI+Extra-Source-Files:+ Examples+ghc-options: -O -Wall
src/Examples.hs view
@@ -1,80 +1,88 @@-{-# 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 +{-# 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/Graphics/UI/Phooey.hs view
@@ -1,152 +1,152 @@-{-# 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 +{-# 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/AmA.hs view
@@ -1,54 +1,54 @@-{-# OPTIONS #-} - ----------------------------------------------------------------------- --- | --- Module : Graphics.UI.Phooey.AmA --- 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 a monad --- and an arrow. (Hence the name "AmA".) 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), the --- function nothing can be known about @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.AmA where - -import Control.Arrow -import Control.Monad (liftM,liftM2) - --- newtype AmA (~>) src i o = AmA (src i ~> src o) - --- Workaround for haddock limitation --- newtype AmA arr src i o = AmA (src i `arr` src o) -newtype AmA arr src i o = AmA (arr (src i) (src o)) - -instance {-""-} (Arrow arr, Monad src) - => Arrow (AmA arr src) where - pure f = AmA (pure (liftM f)) - AmA ab >>> AmA bc = AmA (ab >>> bc) - first (AmA a) = - AmA (pure splitM >>> first a >>> pure mergeM) - -instance {-""-} (ArrowLoop arr, Monad src) - => ArrowLoop (AmA arr src) where - -- loop :: UI (b,d) (c,d) -> UI b c - loop (AmA k) = - AmA (loop (pure mergeM >>> k >>> pure splitM)) - -mergeM :: Monad m => (m a, m c) -> m (a,c) -mergeM ~(ma,mc) = liftM2 (,) ma mc - -splitM :: Monad m => m (a,b) -> (m a, m b) -splitM m = (liftM fst m, liftM snd m) +{-# OPTIONS #-}++----------------------------------------------------------------------+-- |+-- Module : Graphics.UI.Phooey.AmA+-- 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 a monad+-- and an arrow. (Hence the name "AmA".) 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), the+-- function nothing can be known about @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.AmA where++import Control.Arrow+import Control.Monad (liftM,liftM2)++-- newtype AmA (~>) src i o = AmA (src i ~> src o)++-- Workaround for haddock limitation+-- newtype AmA arr src i o = AmA (src i `arr` src o)+newtype AmA arr src i o = AmA (arr (src i) (src o))++instance {-""-} (Arrow arr, Monad src)+ => Arrow (AmA arr src) where+ pure f = AmA (pure (liftM f))+ AmA ab >>> AmA bc = AmA (ab >>> bc)+ first (AmA a) =+ AmA (pure splitM >>> first a >>> pure mergeM)++instance {-""-} (ArrowLoop arr, Monad src)+ => ArrowLoop (AmA arr src) where+ -- loop :: UI (b,d) (c,d) -> UI b c+ loop (AmA k) =+ AmA (loop (pure mergeM >>> k >>> pure splitM))++mergeM :: Monad m => (m a, m c) -> m (a,c)+mergeM ~(ma,mc) = liftM2 (,) ma mc++splitM :: Monad m => m (a,b) -> (m a, m b)+splitM m = (liftM fst m, liftM snd m)
src/Graphics/UI/Phooey/ArrowUI.hs view
@@ -1,130 +1,130 @@-{-# 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.WX (Layout,boxed) - -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.AmA - - -{---------------------------------------------------------- - The UI arrow -----------------------------------------------------------} - --- | The UI arrow -newtype UI i o = UI (AmA (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 (AmA (Kleisli f))) = M.runUI str (f skip >> return ()) - --- | Wrap up monadic UI function as a 'UI' -ui :: (Source i -> M.UI (Source o)) -> UI i o -ui = UI . AmA . 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 = mapLayoutU (boxed 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 (AmA (Kleisli g))) = ui (f . g) - -mapLayoutU :: Unop Layout -> Unop (UI a b) -mapLayoutU f = sourceOp (M.mapLayout f) - -onLayoutT :: LayoutTOp IO -> Unop (UI a b) -onLayoutT f = sourceOp (M.onLayoutT f) +{-# 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.WX (Layout,boxed)++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.AmA+++{----------------------------------------------------------+ The UI arrow+----------------------------------------------------------}++-- | The UI arrow+newtype UI i o = UI (AmA (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 (AmA (Kleisli f))) = M.runUI str (f skip >> return ())++-- | Wrap up monadic UI function as a 'UI'+ui :: (Source i -> M.UI (Source o)) -> UI i o+ui = UI . AmA . 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 = mapLayoutU (boxed 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 (AmA (Kleisli g))) = ui (f . g)++mapLayoutU :: Unop Layout -> Unop (UI a b)+mapLayoutU f = sourceOp (M.mapLayout f)++onLayoutT :: LayoutTOp IO -> Unop (UI a b)+onLayoutT f = sourceOp (M.onLayoutT f)
src/Graphics/UI/Phooey/CallBackT.hs view
@@ -1,66 +1,57 @@-{-# 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 --- import Control.Monad.Fix -import Control.Monad.Reader -import Control.Monad.Trans - --- import Monads hiding (get) - - -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 (do on upd - upd) - return a +{-# 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
@@ -1,147 +1,148 @@-{-# OPTIONS #-} - ----------------------------------------------------------------------- --- | --- Module : Graphics.UI.Phooey.Imperative --- Copyright : (c) Conal Elliott 2006 --- License : LGPL --- --- Maintainer : conal@conal.net --- Stability : provisional --- Portability : portable --- --- Some imperative UI tools. ----------------------------------------------------------------------- - -module Graphics.UI.Phooey.Imperative - ( - -- * Producers & consumers of values - Source,Sink,Updater, skip, munch, set1 - -- * Widget & layout tools - , getSel, onCommand, hwidget,lhwidget ,hsliderDyn - -- * Wio - , 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 ] - - -{----------------------------------------------------------------------- - Widget & layout tools ------------------------------------------------------------------------} - --- | 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 ] - --- | Horizontally-filled widget layout -hwidget :: Widget w => w -> Layout -hwidget = hfill . widget - --- | Labeled, horizontally-filled widget layout -lhwidget :: Widget w => String -> w -> Layout -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)) -hsliderDyn win showBounds props = - do -- The reason for +- 1000 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 - return (ctl, setBounds ctl) - where - setBounds ctl (lo',hi') = - do sliderSetRange ctl lo' hi' - val <- getSel ctl - when (val < lo') (setVal ctl lo') - when (val > hi') (setVal ctl hi') - setVal ctl x = - do lo <- sliderGetMin ctl - hi <- sliderGetMax ctl - when (lo <= x && x <= hi) - (set ctl [ selection := x ]) - -{----------------------------------------------------------------------- - Wio -- simple abstraction around widget containers and frames ------------------------------------------------------------------------} - -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. -runWio :: String -> Wio -> IO () -runWio name wio = start $ - 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 ] - +{-# OPTIONS #-}++----------------------------------------------------------------------+-- |+-- Module : Graphics.UI.Phooey.Imperative+-- Copyright : (c) Conal Elliott 2006+-- License : LGPL+-- +-- Maintainer : conal@conal.net+-- Stability : provisional+-- Portability : portable+-- +-- Some imperative UI tools.+----------------------------------------------------------------------++module Graphics.UI.Phooey.Imperative+ (+ -- * Producers & consumers of values+ Source,Sink,Updater, skip, munch, set1+ -- * Widget & layout tools+ , getSel, onCommand, hwidget,lhwidget ,hsliderDyn+ -- * Wio+ , 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 ]+++{-----------------------------------------------------------------------+ Widget & layout tools+-----------------------------------------------------------------------}++-- | 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 ]++-- | Horizontally-filled widget layout+hwidget :: Widget w => w -> Layout+hwidget = hfill . widget++-- | Labeled, horizontally-filled widget layout+lhwidget :: Widget w => String -> w -> Layout+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))+hsliderDyn win showBounds props =+ do -- The reason for +- 1000 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+ return (ctl, setBounds ctl)+ where+ setBounds ctl (lo',hi') =+ do sliderSetRange ctl lo' hi'+ val <- getSel ctl+ when (val < lo') (setVal ctl lo')+ when (val > hi') (setVal ctl hi')+ setVal ctl x =+ do lo <- sliderGetMin ctl+ hi <- sliderGetMax ctl+ when (lo <= x && x <= hi)+ (set ctl [ selection := x ])++{-----------------------------------------------------------------------+ Wio -- simple abstraction around widget containers and frames+-----------------------------------------------------------------------}++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.+runWio :: String -> Wio -> IO ()+runWio name wio = start $+ 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
@@ -1,99 +1,99 @@-{-# OPTIONS -fglasgow-exts #-} - ----------------------------------------------------------------------- --- | --- Module : Graphics.UI.Phooey.LayoutT --- Copyright : (c) Conal Elliott 2006 --- License : LGPL --- --- Maintainer : conal@conal.net --- Stability : provisional --- Portability : portable --- --- A monad transformer for managing GUI layout. --- Specializes 'TagT' to layouts as tag values. ----------------------------------------------------------------------- - -module Graphics.UI.Phooey.LayoutT - ( - -- * The /layout manager/ monad transformer (or laid-out value makers) - LayoutT, runLayout, runL, LayoutTOp - -- * 'LayoutT' combinators - , flipL , fromTopL, fromBottomL, fromLeftL, fromRightL - -- , above, beside, fempty , setLayoutL - ) where - -import Data.Maybe (fromMaybe) -import Control.Monad (liftM) -import Graphics.UI.WX - -import Graphics.UI.Phooey.Imperative (Win, runWio) -import Graphics.UI.Phooey.TagT - -{---------------------------------------------------------- - /Layout manager/ monad transformer (or laid-out value makers) -----------------------------------------------------------} - --- | /Layout manager/ monad transformer (or laid-out value maker) -type LayoutT m = TagT Layout m - --- | /Run/ a 'LayoutT'. -runLayout :: Monad m => LayoutT m a -> m (Layout,a) -runLayout 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 ()) -> IO () -runL name f = runWio name $ \ win -> - liftM fst (runLayout (f win)) - - -{---------------------------------------------------------- - Layout combinators -----------------------------------------------------------} - --- | Layout combiner -type LayoutTOp m = TagTOp Layout m - --- | Identity for 'above' and 'beside'. -fempty :: Layout -fempty = fill empty - --- | Temporarily /replace/ the layout combiner -setLayoutL :: Monad m => Binop Layout - -> Unop (LayoutT m a) -setLayoutL = setTagComb - - --- | Lay out from top to bottom -fromTopL :: Monad m => Unop (LayoutT m a) -fromTopL = setLayoutL above - --- | Lay out from bottom to top -fromBottomL :: Monad m => Unop (LayoutT m a) -fromBottomL = setLayoutL (flip above) - --- | Lay out from left to right -fromLeftL :: Monad m => Unop (LayoutT m a) -fromLeftL = setLayoutL beside - --- | Lay out from right to left -fromRightL :: Monad m => Unop (LayoutT m a) -fromRightL = setLayoutL (flip beside) - --- | Temporarily /reverse/ the layout combiner -flipL :: Monad m => Unop (LayoutT m a) -flipL = flipTagComb - - --- Layout binops used above -above, beside :: Binop Layout -la `above` lb = hfill (column 0 [la,lb]) -la `beside` lb = vfill (row 0 [la,lb]) - --- The following definitions are simpler, but they don't work! I get --- 'fromTopL' and 'fromLeftL', so it seems that 'flipTagComb' doesn't work. - --- fromBottomL = flipL . fromTopL --- fromRightL = flipL . fromLeftL +{-# OPTIONS -fglasgow-exts #-}++----------------------------------------------------------------------+-- |+-- Module : Graphics.UI.Phooey.LayoutT+-- Copyright : (c) Conal Elliott 2006+-- License : LGPL+-- +-- Maintainer : conal@conal.net+-- Stability : provisional+-- Portability : portable+-- +-- A monad transformer for managing GUI layout.+-- Specializes 'TagT' to layouts as tag values.+----------------------------------------------------------------------++module Graphics.UI.Phooey.LayoutT+ ( + -- * The /layout manager/ monad transformer (or laid-out value makers)+ LayoutT, runLayout, runL, LayoutTOp+ -- * 'LayoutT' combinators+ , flipL , fromTopL, fromBottomL, fromLeftL, fromRightL+ -- , above, beside, fempty , setLayoutL+ ) where++import Data.Maybe (fromMaybe)+import Control.Monad (liftM)+import Graphics.UI.WX++import Graphics.UI.Phooey.Imperative (Win, runWio)+import Graphics.UI.Phooey.TagT++{----------------------------------------------------------+ /Layout manager/ monad transformer (or laid-out value makers)+----------------------------------------------------------}++-- | /Layout manager/ monad transformer (or laid-out value maker)+type LayoutT m = TagT Layout m++-- | /Run/ a 'LayoutT'.+runLayout :: Monad m => LayoutT m a -> m (Layout,a)+runLayout 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 ()) -> IO ()+runL name f = runWio name $ \ win ->+ liftM fst (runLayout (f win))+++{----------------------------------------------------------+ Layout combinators+----------------------------------------------------------}++-- | Layout combiner+type LayoutTOp m = TagTOp Layout m++-- | Identity for 'above' and 'beside'.+fempty :: Layout+fempty = fill empty++-- | Temporarily /replace/ the layout combiner+setLayoutL :: Monad m => Binop Layout+ -> Unop (LayoutT m a)+setLayoutL = setTagComb+++-- | Lay out from top to bottom+fromTopL :: Monad m => Unop (LayoutT m a)+fromTopL = setLayoutL above++-- | Lay out from bottom to top+fromBottomL :: Monad m => Unop (LayoutT m a)+fromBottomL = setLayoutL (flip above)++-- | Lay out from left to right+fromLeftL :: Monad m => Unop (LayoutT m a)+fromLeftL = setLayoutL beside++-- | Lay out from right to left+fromRightL :: Monad m => Unop (LayoutT m a)+fromRightL = setLayoutL (flip beside)++-- | Temporarily /reverse/ the layout combiner+flipL :: Monad m => Unop (LayoutT m a)+flipL = flipTagComb+++-- Layout binops used above+above, beside :: Binop Layout+la `above` lb = fill (column 0 [la,lb])+la `beside` lb = fill (row 0 [la,lb])++-- The following definitions are simpler, but they don't work! I get+-- 'fromTopL' and 'fromLeftL', so it seems that 'flipTagComb' doesn't work.++-- fromBottomL = flipL . fromTopL+-- fromRightL = flipL . fromLeftL
src/Graphics/UI/Phooey/MonadUI.hs view
@@ -1,130 +1,147 @@-{-# 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 - -- * High-level widgets - , stringDisplay, showDisplay, textEntry, islider - , checkBoxDisplay, checkBoxEntry, title - -- * Tools for defining high-level widgets - , mkWidget - -- * Layout - , onLayoutT, mapLayout - ) where - --- import Monads hiding (set,get) -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)) - --- | Run a 'UI'. -runUI :: String -> UI () -> IO () -runUI name = runL name . runReaderT . runCB (lift.lift) - - -{---------------------------------------------------------- - High-level widgets -----------------------------------------------------------} - -mkText win = WX.textEntry win [] - --- | String display widget -stringDisplay :: Source String -> UI (Source ()) -stringDisplay src = mkWidget $ \ 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 = mkWidget $ \ win -> - do ctl <- mkText win - return ( Just (hwidget ctl) - , (get ctl text, onCommand ctl, skip)) - --- | Slider widget with static initial value and dynamic bounds (min,max) -islider :: Int -> Source (Int,Int) -> UI (Source Int) -islider initial bounds = mkWidget $ \ 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 $ \ 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 $ \ 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 :: (Win -> IO ( Maybe Layout - , (a, Sink Updater, Updater))) - -> UI a -mkWidget f = CB (mkRead (mkTag . f)) - --- | 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) +{-# 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+ -- * High-level widgets+ , stringDisplay, showDisplay, textEntry, islider+ , checkBoxDisplay, checkBoxEntry, title+ -- * Tools for defining high-level widgets+ , mkWidget+ -- * Layout+ , onLayoutT, mapLayout+ ) where++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))++-- | Run a 'UI'.+runUI :: String -> UI () -> IO ()+runUI name = runL name . runReaderT . runCB (lift.lift)+++{----------------------------------------------------------+ High-level widgets+----------------------------------------------------------}++mkText :: WX.Window a -> IO (WX.TextCtrl ())+mkText win = WX.textEntry win []++-- | 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))++-- | 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,117 +1,116 @@-{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-} - ----------------------------------------------------------------------- --- | --- Module : Graphics.UI.Phooey.TagT --- Copyright : (c) Conal Elliott 2006 --- License : LGPL --- --- Maintainer : conal@conal.net --- Stability : provisional --- Portability : portable --- --- A /tagging/ monad transformer ----------------------------------------------------------------------- - -module Graphics.UI.Phooey.TagT - ( - -- * Convenient function synonyms - Unop, Binop - -- * The /tagging/ monad transformer (or tagged-value maker) - , TagT(..), runTag - -- * Transforming tagged-value makers - , TagTOp, mapTag, mkTag - -- * Tag-combiner tweakers - , updateTagComb, setTagComb, flipTagComb - ) where - --- import Control.Monad.Fix -import Control.Monad.Reader -import Control.Monad.Trans -import Control.Arrow (first) - -{---------------------------------------------------------- - Convenient function synonyms -----------------------------------------------------------} - -type Unop a = a -> a -type Binop a = a -> a -> a - - -{---------------------------------------------------------- - The /tagging/ monad transformer / tagged-value maker. - Tags may be present or absent and are combined according to - a contextual 'Binop'. -----------------------------------------------------------} - -newtype TagT tag m a = - T { unT :: ReaderT (Binop tag) m (Maybe tag,a) } - --- | Run a 'TagT' -runTag :: Binop tag -- ^ the tag combiner - -> TagT tag m a - -> m (Maybe tag,a) -runTag op (T r) = runReaderT r op - -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) - op <- ask - return (mb op ta tb, b)) - where - mb op (Just a) (Just b) = Just (a `op` b) - mb _ mba mbb = mba `mplus` mbb - -instance MonadFix m => MonadFix (TagT tag m) where - mfix f = T (mfix (\ ~(_,a) -> unT (f a))) - - -{---------------------------------------------------------- - Transforming tagged-value makers -----------------------------------------------------------} - --- | Transforming tagged-value makers into others -type TagTOp tag m = forall a. Unop (TagT tag m a) - --- | Tag changer -mapTag :: Monad m => Unop tag -> TagTOp tag m -mapTag f (T reader) = T (liftM (first (fmap f)) reader) - --- | Make a tagged-value maker from a tag and a value -mkTag :: Monad m => m (Maybe tag,a) -> TagT tag m a -mkTag m = T (lift m) - -{---------------------------------------------------------- - Tag-combiner tweakers -----------------------------------------------------------} - --- | Temporarily /update/ the tag combiner -updateTagComb :: Monad m => - Unop (Binop tag) - -> Unop (TagT tag m a) -updateTagComb h (T r) = T (local h r) - --- Augment the context for the duration of a computation. --- Maybe rename and put back in MonadLib --- updateR :: RunReaderM m i => (i->i) -> m a -> m a --- updateR f m = do r <- ask --- local (f r) m - - --- | Temporarily /replace/ the tag combiner -setTagComb :: Monad m => Binop tag -> Unop (TagT tag m a) -setTagComb op = updateTagComb (const op) - --- | Temporarily /reverse/ the tag combiner -flipTagComb :: Monad m => Unop (TagT tag m a) -flipTagComb = updateTagComb flip - -instance MonadTrans (TagT tag) where - lift m = T (lift (do a <- m - return (Nothing,a))) - --- instance BaseM m b => BaseM (TagT tag m) b where --- inBase m = lift (inBase m) - --- Add more transformer instances +{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-}++----------------------------------------------------------------------+-- |+-- Module : Graphics.UI.Phooey.TagT+-- Copyright : (c) Conal Elliott 2006+-- License : LGPL+-- +-- Maintainer : conal@conal.net+-- Stability : provisional+-- Portability : portable+-- +-- A /tagging/ monad transformer+----------------------------------------------------------------------++module Graphics.UI.Phooey.TagT+ (+ -- * Convenient function synonyms+ Unop, Binop+ -- * The /tagging/ monad transformer (or tagged-value maker)+ , TagT(..), runTag+ -- * Transforming tagged-value makers+ , TagTOp, mapTag, mkTag+ -- * Tag-combiner tweakers+ , updateTagComb, setTagComb, flipTagComb+ ) where++import Control.Monad.Reader+import Control.Monad.Trans+import Control.Arrow (first)++{----------------------------------------------------------+ Convenient function synonyms+----------------------------------------------------------}++type Unop a = a -> a+type Binop a = a -> a -> a+++{----------------------------------------------------------+ The /tagging/ monad transformer / tagged-value maker.+ Tags may be present or absent and are combined according to+ a contextual 'Binop'.+----------------------------------------------------------}++newtype TagT tag m a =+ T { unT :: ReaderT (Binop tag) m (Maybe tag,a) }++-- | Run a 'TagT'+runTag :: Binop tag -- ^ the tag combiner+ -> TagT tag m a+ -> m (Maybe tag,a)+runTag op (T r) = runReaderT r op++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)+ op <- ask+ return (mb op ta tb, b))+ where+ mb op (Just a) (Just b) = Just (a `op` b)+ mb _ mba mbb = mba `mplus` mbb++instance MonadFix m => MonadFix (TagT tag m) where+ mfix f = T (mfix (\ ~(_,a) -> unT (f a)))+++{----------------------------------------------------------+ Transforming tagged-value makers+----------------------------------------------------------}++-- | Transforming tagged-value makers into others+type TagTOp tag m = forall a. Unop (TagT tag m a)++-- | Tag changer+mapTag :: Monad m => Unop tag -> TagTOp tag m+mapTag f (T reader) = T (liftM (first (fmap f)) reader)++-- | Make a tagged-value maker from a tag and a value+mkTag :: Monad m => m (Maybe tag,a) -> TagT tag m a+mkTag m = T (lift m)++{----------------------------------------------------------+ Tag-combiner tweakers+----------------------------------------------------------}++-- | Temporarily /update/ the tag combiner+updateTagComb :: Monad m =>+ Unop (Binop tag)+ -> Unop (TagT tag m a)+updateTagComb h (T r) = T (local h r)++-- Augment the context for the duration of a computation.+-- Maybe rename and put back in MonadLib+-- updateR :: RunReaderM m i => (i->i) -> m a -> m a+-- updateR f m = do r <- ask+-- local (f r) m+++-- | Temporarily /replace/ the tag combiner+setTagComb :: Monad m => Binop tag -> Unop (TagT tag m a)+setTagComb op = updateTagComb (const op)++-- | Temporarily /reverse/ the tag combiner+flipTagComb :: Monad m => Unop (TagT tag m a)+flipTagComb = updateTagComb flip++instance MonadTrans (TagT tag) where+ lift m = T (lift (do a <- m+ return (Nothing,a)))++-- instance BaseM m b => BaseM (TagT tag m) b where+-- inBase m = lift (inBase m)++-- Add more transformer instances
src/Graphics/UI/Phooey/Test.hs view
@@ -1,3 +1,3 @@-import Graphics.UI.WX -main = io >> io where io = start (frame [] >> return ()) - +import Graphics.UI.WX+main = io >> io where io = start (frame [] >> return ())+
src/Graphics/UI/Phooey/tst.hs view
@@ -1,3 +1,3 @@- -main :: IO () -main = putStrLn (reverse "Hello World!") ++main :: IO ()+main = putStrLn (reverse "Hello World!")