phooey (empty) → 0.1

raw patch · 16 files changed

+1084/−0 lines, 16 filesdep +arrowsdep +basedep +mtlbuild-type:Customsetup-changed

Dependencies added: arrows, base, mtl, wx, wxcore

Files

CHANGES +13/−0
Makefile +13/−0
README +28/−0
Setup.lhs +3/−0
phooey.cabal +46/−0
src/Examples.hs +80/−0
src/Graphics/UI/Phooey.hs +152/−0
src/Graphics/UI/Phooey/AmA.hs +54/−0
src/Graphics/UI/Phooey/ArrowUI.hs +130/−0
src/Graphics/UI/Phooey/CallBackT.hs +66/−0
src/Graphics/UI/Phooey/Imperative.hs +147/−0
src/Graphics/UI/Phooey/LayoutT.hs +99/−0
src/Graphics/UI/Phooey/MonadUI.hs +130/−0
src/Graphics/UI/Phooey/TagT.hs +117/−0
src/Graphics/UI/Phooey/Test.hs +3/−0
src/Graphics/UI/Phooey/tst.hs +3/−0

+ CHANGES view

@@ -0,0 +1,13 @@+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

@@ -0,0 +1,13 @@+# 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

+ README view

@@ -0,0 +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.

+ Setup.lhs view

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain

+ phooey.cabal view

@@ -0,0 +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!
+  .
+  &#169; 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

@@ -0,0 +1,80 @@+{-# 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

+ src/Graphics/UI/Phooey.hs view

@@ -0,0 +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 &#177;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

@@ -0,0 +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)

+ src/Graphics/UI/Phooey/ArrowUI.hs view

@@ -0,0 +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)

+ src/Graphics/UI/Phooey/CallBackT.hs view

@@ -0,0 +1,66 @@+{-# 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

+ src/Graphics/UI/Phooey/Imperative.hs view

@@ -0,0 +1,147 @@+{-# 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

@@ -0,0 +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

+ src/Graphics/UI/Phooey/MonadUI.hs view

@@ -0,0 +1,130 @@+{-# 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)

+ src/Graphics/UI/Phooey/TagT.hs view

@@ -0,0 +1,117 @@+{-# 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

+ src/Graphics/UI/Phooey/Test.hs view

@@ -0,0 +1,3 @@+import Graphics.UI.WX
+main = io >> io where io = start (frame [] >> return ())
+

+ src/Graphics/UI/Phooey/tst.hs view

@@ -0,0 +1,3 @@+
+main :: IO ()
+main = putStrLn (reverse "Hello World!")