diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -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 . diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 diff --git a/README b/README --- a/README +++ b/README @@ -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. diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO diff --git a/phooey.cabal b/phooey.cabal --- a/phooey.cabal +++ b/phooey.cabal @@ -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 - . - * Use of Phooey for composable interfaces in the TV library: - - . - 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 + . + * Use of Phooey for composable interfaces in the TV library: + + . + 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 diff --git a/src/Examples.hs b/src/Examples.hs --- a/src/Examples.hs +++ b/src/Examples.hs @@ -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 diff --git a/src/Graphics/UI/Phooey.hs b/src/Graphics/UI/Phooey.hs --- a/src/Graphics/UI/Phooey.hs +++ b/src/Graphics/UI/Phooey.hs @@ -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. - -@ <>@ - -@ - 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. - -@ <>@ - -@ - 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: - -@ <>@ - -@ <>@ - -@ - 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. - -@ <>@ - -@ - 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@. - -@ <>@ - -@ - 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. - -@ <>@ - -@ - 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. + +@ <>@ + +@ + 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. + +@ <>@ + +@ + 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: + +@ <>@ + +@ <>@ + +@ + 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. + +@ <>@ + +@ + 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@. + +@ <>@ + +@ + 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. + +@ <>@ + +@ + 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 diff --git a/src/Graphics/UI/Phooey/AmA.hs b/src/Graphics/UI/Phooey/AmA.hs --- a/src/Graphics/UI/Phooey/AmA.hs +++ b/src/Graphics/UI/Phooey/AmA.hs @@ -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) diff --git a/src/Graphics/UI/Phooey/ArrowUI.hs b/src/Graphics/UI/Phooey/ArrowUI.hs --- a/src/Graphics/UI/Phooey/ArrowUI.hs +++ b/src/Graphics/UI/Phooey/ArrowUI.hs @@ -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) diff --git a/src/Graphics/UI/Phooey/CallBackT.hs b/src/Graphics/UI/Phooey/CallBackT.hs --- a/src/Graphics/UI/Phooey/CallBackT.hs +++ b/src/Graphics/UI/Phooey/CallBackT.hs @@ -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 diff --git a/src/Graphics/UI/Phooey/Imperative.hs b/src/Graphics/UI/Phooey/Imperative.hs --- a/src/Graphics/UI/Phooey/Imperative.hs +++ b/src/Graphics/UI/Phooey/Imperative.hs @@ -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 ] + diff --git a/src/Graphics/UI/Phooey/LayoutT.hs b/src/Graphics/UI/Phooey/LayoutT.hs --- a/src/Graphics/UI/Phooey/LayoutT.hs +++ b/src/Graphics/UI/Phooey/LayoutT.hs @@ -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 diff --git a/src/Graphics/UI/Phooey/MonadUI.hs b/src/Graphics/UI/Phooey/MonadUI.hs --- a/src/Graphics/UI/Phooey/MonadUI.hs +++ b/src/Graphics/UI/Phooey/MonadUI.hs @@ -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) diff --git a/src/Graphics/UI/Phooey/TagT.hs b/src/Graphics/UI/Phooey/TagT.hs --- a/src/Graphics/UI/Phooey/TagT.hs +++ b/src/Graphics/UI/Phooey/TagT.hs @@ -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 diff --git a/src/Graphics/UI/Phooey/Test.hs b/src/Graphics/UI/Phooey/Test.hs --- a/src/Graphics/UI/Phooey/Test.hs +++ b/src/Graphics/UI/Phooey/Test.hs @@ -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 ()) + diff --git a/src/Graphics/UI/Phooey/tst.hs b/src/Graphics/UI/Phooey/tst.hs --- a/src/Graphics/UI/Phooey/tst.hs +++ b/src/Graphics/UI/Phooey/tst.hs @@ -1,3 +1,3 @@ - -main :: IO () -main = putStrLn (reverse "Hello World!") + +main :: IO () +main = putStrLn (reverse "Hello World!")