phooey 1.2 → 1.4
raw patch · 17 files changed
+1310/−1156 lines, 17 filesdep +DataDrivendep +arraydep −arrowsdep ~TypeComposesetup-changed
Dependencies added: DataDriven, array
Dependencies removed: arrows
Dependency ranges changed: TypeCompose
Files
- CHANGES +93/−51
- Makefile +5/−5
- Setup.lhs +2/−2
- TODO +11/−0
- phooey.cabal +3/−7
- src/Examples/Applicative.hs +57/−172
- src/Examples/Arrow.hs +0/−116
- src/Examples/Examples.hs +21/−21
- src/Examples/Imperative.hs +0/−70
- src/Examples/Monad.hs +346/−91
- src/Graphics/UI/Phooey/Applicative.hs +56/−38
- src/Graphics/UI/Phooey/Arrow.hs +0/−138
- src/Graphics/UI/Phooey/Imperative.hs +12/−41
- src/Graphics/UI/Phooey/LayoutT.hs +0/−116
- src/Graphics/UI/Phooey/Monad.hs +260/−167
- src/Graphics/UI/Phooey/TagT.hs +0/−121
- src/Graphics/UI/Phooey/WinEvents.hs +444/−0
CHANGES view
@@ -1,60 +1,102 @@-Version 1.2:-* Renamed "Upd" to "Act" in Monad.hs-* Added "commandNews" in Imperative.hs-* Tweaked for compatibility with TypeCompose-0.1+% [Phooey](http://haskell.org/haskellwiki/Phooey) changes -Version 1.1:-* Added src/Examples/Applicative.hs. I'd accidentally omitted it.-* Imperative.hs: renamed "mkNews" to "commandNews" and added a more- general function called "mkNews".+== Version 1.4 == -Version 1.0:-* Uses new TypeCompose package, which includes a simple implementation of- data-driven computation.-* New Applicative functor interface.-* Eliminated the catch-all Phooey.hs module. Now import any one of- Graphics.UI.Phooey.{Monad,Applicative,Arrow}. -* renamed "textEntry" to "stringEntry"-* added "isliderDisplay"-* Phooey.Monad has two different styles of output widgets, made by owidget- and owidget'. The latter is used to implement Phooey.Applicative.-* Self- and mutually-recursive widgets now work again in Phooey.Monad.- They still hang in Phooey.Arrow.+* Exposed a few more functions+* WinEvents: motion' and motionDiff' carry key modifiers (shift, control, etc)+* Menu-related functions in WinEvents+* wxHaskell attributes as Pair+* Several tests for events & sources: t1, ...+* Changed examples to track Event/Source changes, especially with accumulation.+* Calculator now shows keys pressed as well as result+* Optional debugging output for mouse events. -Version 0.3.1:-* Fixed dos-style line breaks in src/MonadExamples.hs-* Fixed Functor UI def (broke the circularity)+## Version 1.3 ## -Version 0.3:-* Finished renaming "CallbackT" to "CallBackT" (thanks to Michal Palka for- catching the inconsistency).-* Renamed AmA.hs to AFA.hs. AFA is more general in that it works with- applicative functors instead of monads.-* ArrowUI.title now defined in terms of ArrowMonad.title.-* Added src/MonadExamples.hs-* Changed type of MonadUI.runUI. Now takes a UI (Source ()) instead of UI- (). The new type is more convenient for use.-* Relaxed type of LayoutT.runL, to accommodate the new MonadUI.runUI type.-* Makefile tweaks to fit cabal-make changes.+This version is mostly a simplification and sync'ing with changes to+DataDriven (previously part of TypeCompose) and TV. -Version 0.2.1:-* Changed all files to *nix-style line endings.++ Several new examples in Examples.Monad, including the classic+ calculator.++ Removed modules `TagT`,`LayoutT` and `Arrow` from `Graphics.UI.Phooey`.++ Removed `Examples.Arrow`.++ Simplified `Phooey.Monad`.++ Removed `isliderDyn` & examples, for simplicity. I'd like to find more+ compelling examples of dynamic UIs and recursive UIs.++ Replaced `title` functions with `title` method from `Title` class in+ [TypeCompose].++ Fixed [Examples.Applicative](src/Examples/Applicative.hs).++ Added [WinEvents](src/Graphics/UI/Phooey/WinEvents.hs): with high-level+ interfaces to [wxHaskell] events. -Changes in version 0.2:+## Version 1.2 ## -* Finally fixed a long-standing stretching bug. When widgets are abutted- horizontally, they now all stretch together.++ Renamed "Upd" to "Act" in Monad.hs++ Added "commandNews" in Imperative.hs++ Tweaked for compatibility with [TypeCompose] 0.1 -Changes in version 0.1:+## Version 1.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 .++ Added [Examples.Applicative](src/Examples/Applicative.hs). I'd+ accidentally omitted it.++ In [Imperative](src/Graphics/UI/Phooey/Imperative.hs): renamed "mkNews"+ to "commandNews" and added a more general function called "mkNews".++## Version 1.0 ##+++ Uses new TypeCompose package, which includes a simple implementation of+ data-driven computation.++ New Applicative functor interface.++ Eliminated the catch-all Phooey.hs module. Now import any one of+ Graphics.UI.Phooey.{Monad,Applicative,Arrow}. ++ renamed "textEntry" to "stringEntry"++ added "isliderDisplay"++ Phooey.Monad has two different styles of output widgets, made by owidget+ and owidget'. The latter is used to implement Phooey.Applicative.++ Self- and mutually-recursive widgets now work again in Phooey.Monad.+ They still hang in Phooey.Arrow.++## Version 0.3.1 ##+++ Fixed dos-style line breaks in src/MonadExamples.hs++ Fixed Functor UI def (broke the circularity)++## Version 0.3 ##+++ Finished renaming "CallbackT" to "CallBackT" (thanks to Michal Palka for+ catching the inconsistency).++ Renamed AmA.hs to AFA.hs. AFA is more general in that it works with+ applicative functors instead of monads.++ ArrowUI.title now defined in terms of ArrowMonad.title.++ Added src/MonadExamples.hs++ Changed type of MonadUI.runUI. Now takes a UI (Source ()) instead of UI+ (). The new type is more convenient for use.++ Relaxed type of LayoutT.runL, to accommodate the new MonadUI.runUI type.++ Makefile tweaks to fit cabal-make changes.++## Version 0.2.1 ##+++ Changed all files to *nix-style line endings.++## Version 0.2 ##+++ Finally fixed a long-standing stretching bug. When widgets are abutted+ horizontally, they now all stretch together.++## 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 .+++[TypeCompose]: http://haskell.org/haskellwiki/TypeCompose+[wxHaskell]: http://haskell.org/haskellwiki/wxHaskell
Makefile view
@@ -1,9 +1,9 @@ # For special configuration, especially for docs. Otherwise see README. -haddock-interfaces=\- http://haskell.org/ghc/docs/latest/html/libraries/base,c:/ghc/ghc-6.6/doc/html/libraries/base/base.haddock \- http://haskell.org/ghc/docs/latest/html/libraries/mtl,c:/ghc/ghc-6.6/doc/html/libraries/mtl/mtl.haddock \- http://darcs.haskell.org/packages/TypeCompose/doc/html,c:/Haskell/packages/TypeCompose-0.1/doc/html/TypeCompose.haddock \- http://wxhaskell.sourceforge.net/doc,c:/Haskell/wxhaskell/out/doc/wxhaskell.haddock+# haddock-interfaces=\+# http://haskell.org/ghc/docs/latest/html/libraries/base,c:/ghc/ghc-6.6/doc/html/libraries/base/base.haddock \+# http://haskell.org/ghc/docs/latest/html/libraries/mtl,c:/ghc/ghc-6.6/doc/html/libraries/mtl/mtl.haddock \+# http://darcs.haskell.org/packages/TypeCompose/doc/html,c:/Haskell/packages/TypeCompose-0.2/doc/html/TypeCompose.haddock \+# http://wxhaskell.sourceforge.net/doc,c:/Haskell/wxhaskell/out/doc/wxhaskell.haddock include ../my-cabal-make.inc
Setup.lhs view
@@ -1,3 +1,3 @@-#!/usr/bin/env runhaskell -> import Distribution.Simple +#!/usr/bin/env runhaskell+> import Distribution.Simple > main = defaultMain
TODO view
@@ -0,0 +1,11 @@+% [Phooey](http://haskell.org/haskellwiki/Phooey) To Do+++ Even out the stretching between sub-layouts. I nest binary layout+ operators, and I think the stretch space is divided in two each time.+ Look for *associative* layout operators. I may have to make my own+ layout data type that holds lists of layouts, so I can append them.+ Right now, I just make rows, columns, boxed, and widget (with fill), so+ the data type could reflect those tools.+++ Consider rewriting `Phooey.Monad` to use mtl-style operations instead of+ working on `UI'`.
phooey.cabal view
@@ -1,5 +1,5 @@ Name: phooey-Version: 1.2+Version: 1.4 Synopsis: Functional user interfaces Category: User Interfaces Description:@@ -33,17 +33,13 @@ Stability: provisional Hs-Source-Dirs: src Extensions: CPP, Arrows-Build-Depends: base, mtl, arrows, TypeCompose>=0.1, wx, wxcore+Build-Depends: base, array, mtl, wx, wxcore, TypeCompose>=0.2, DataDriven Exposed-Modules: + Graphics.UI.Phooey.WinEvents Graphics.UI.Phooey.Imperative- Graphics.UI.Phooey.TagT- Graphics.UI.Phooey.LayoutT Graphics.UI.Phooey.Monad Graphics.UI.Phooey.Applicative- Graphics.UI.Phooey.Arrow Extra-Source-Files:- Examples.Imperative Examples.Monad Examples.Applicative- Examples.Arrow ghc-options: -O -Wall
src/Examples/Applicative.hs view
@@ -1,172 +1,57 @@-{-# OPTIONS #-} - ----------------------------------------------------------------------- --- | --- Module : Examples.Applicative --- Copyright : (c) Conal Elliott 2007 --- License : LGPL --- --- Maintainer : conal@conal.net --- Stability : experimental --- Portability : portable --- --- Applicative-style Phooey examples. Use 'runUI' ----------------------------------------------------------------------- - -module Examples.Applicative where - -import Control.Applicative -import Control.Monad.Fix (fix) - -import Graphics.UI.Phooey.Applicative - --- For oPair etc -import Control.DataDriven (Sink,Updater) -import Data.Monoid - -h :: UI String -h = pure "Hello World!" - -sl0 :: IWidget Int -sl0 = islider (0,10) - -uia,uib :: UI Upd -uia = stringDisplay <*> h -uib = showDisplay <*> sl0 3 - - -ui1 :: UI Upd -ui1 = title "Shopping List" $ fruit <**> total - -apples, bananas, fruit :: UI Int -apples = title "apples" (sl0 3) -bananas = title "bananas" (sl0 7) - -fruit = liftA2 (+) apples bananas - --- With overloading, we could say --- fruit = apples + bananas - -total :: Num a => OWidget a -total = title "total" showDisplay - - -pair :: Applicative f => f a -> f b -> f (a,b) -pair = liftA2 (,) - -lo,hi :: UI Int -lo = title "lo" $ sl0 2 -hi = title "hi" $ sl0 8 - -val :: UI Int -val = title "val" $ isliderDyn (pair lo hi) 5 - --- Note that the "val" title is around the lo & hi sliders as well. I --- guess that layout reflects the purpose of the lo & hi sliders. I don't --- know how to get a "val" title on just the dynamically-bounded slider. -ui2 :: UI Upd -ui2 = (fact <$> val) <**> title "factorial" showDisplay - --- minor variation -ui2' = val <**> - pure fact <**> - title "factorial" showDisplay - --- Variation - -fact :: Int -> Int -fact n = product [1 .. n] - - -o1 :: UI (Snk (Int -> Int -> Int)) -o1 = oLambda apples (oLambda bananas total) - -ui4 :: UI Upd -ui4 = o1 <*> pure (+) - --- Experiments. None of these functions is specific to UI - --- iPair :: Applicative ui => ui a -> ui b -> ui (a,b) --- iPair = liftA2 (,) -- fromLeft - --- oPair :: (Applicative ui, Applicative src, Monoid (Updater src)) --- => ui (Sink src a) -> ui (Sink src b) -> ui (Sink src (a,b)) --- oPair = liftA2 oPair' -- fromLeft - --- -- Suggested use: m = src () --- oLambda :: Applicative ui --- => ui a -> ui (b -> m) -> ui ((a->b) -> m) --- oLambda = liftA2 oLambda' -- fromTop - --- -- Monoid variant for oPair - --- oPairM :: (Applicative ui, Monoid m) --- => ui (a -> m) -> ui (b -> m) -> ui ((a,b) -> m) --- oPairM = liftA2 oPairM' - --- oPairM' :: Monoid m => (a -> m) -> (b -> m) -> ((a,b) -> m) --- oPairM' oa ob (a,b) = oa a `mappend` ob b -- fromLeft - -iPair :: UI a -> UI b -> UI (a,b) -iPair a b = fromLeft (liftA2 (,) a b) - -oPair :: (Monoid (Updater src), Applicative src) -- e.g., src == IO - => UI (Sink src a) -> UI (Sink src b) -> UI (Sink src (a,b)) -oPair a b = fromLeft (liftA2 oPair' a b) - -oPair' :: (Monoid (Updater src), Applicative src) - => Sink src a -> Sink src b -> Sink src (a,b) -oPair' oa ob (a,b) = oa a `mappend` ob b - --- Suggested use: m = src () -oLambda :: UI a -> UI (b -> m) -> UI ((a->b) -> m) -oLambda a b = fromTop (liftA2 oLambda' a b) - -oLambda' :: a -> (b -> m) -> ((a->b) -> m) -oLambda' ia ob f = ob (f ia) - - -o2 :: UI (Snk ((Int,Int) -> Int)) -o2 = oLambda (iPair apples bananas) total - -ui5 :: UI Upd -ui5 = o2 <*> pure (uncurry (+)) - -o3 :: UI (Snk ((Int,Int) -> (Int,Int))) -o3 = oLambda (iPair sli sli) (oPair slo slo) - where - sli = sl0 5 - slo = isliderDisplay (0,10) - -ui6 :: UI Upd -ui6 = o3 <*> pure (\ (a,b) -> (b,a)) - - ----- Recursive: - --- ffix :: Functor f => f (a->a) -> f a --- ffix = fmap fix - --- or --- ffix :: (m a -> m a) -> m a --- ffix = fix - -unPair :: Functor f => f (a, b) -> (f a, f b) -unPair p = (fmap fst p, fmap snd p) - -ui7 :: UI (Int,Int) -ui7 = fix f - where f :: UI (Int,Int) -> UI (Int,Int) - f bounds = liftA2 (,) - (isliderDyn (pair (pure 0) hi) 3) - (isliderDyn (pair lo (pure 10)) 8) - where - ~(lo,hi) = unPair bounds - -ui8 :: UI Upd -ui8 = total <*> fmap (uncurry (+)) ui7 - -ui9 :: UI Upd -ui9 = fix f *> pure mempty - where f :: UI Int -> UI Int - f val = isliderDyn (pair ((subtract 5) <$> val) ((+ 5) <$> val)) 10 +----------------------------------------------------------------------+-- |+-- Module : Examples.Applicative+-- Copyright : (c) Conal Elliott 2007+-- License : LGPL+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- Portability : portable+-- +-- Applicative-style Phooey examples. Use 'runUI'+----------------------------------------------------------------------++module Examples.Applicative where++import Control.Applicative+import Data.Monoid++-- TypeCompose+import Data.Title+-- DataDriven+import Data.Source++import Graphics.UI.Phooey.Applicative++h :: UI String+h = pure "Hello World!"++sl0 :: IWidget Int+sl0 = islider (0,10)++uia,uib :: UI Action+uia = stringDisplay <*> h+uib = showDisplay <*> sl0 3+++ui1 :: UI Action+ui1 = title "Shopping List" $ fruit <**> total++apples, bananas, fruit :: UI Int+apples = title "apples" (sl0 3)+bananas = title "bananas" (sl0 7)++fruit = liftA2 (+) apples bananas++-- With Num overloading, we could say+-- fruit = apples + bananas++total :: Num a => OWidget a+total = title "total" showDisplay+++sqrt1 :: UI Action+sqrt1 = (sqrt <$> i) <**> o+ where+ i = title "x" $ fslider (0,10) (3 :: Float)+ o = title "square root" $ fsliderDisplay (0,4)
− src/Examples/Arrow.hs
@@ -1,116 +0,0 @@-{-# OPTIONS -fglasgow-exts -farrows #-}-------------------------------------------------------------------------- |--- Module : Examples.Arrow--- Copyright : (c) Conal Elliott 2006--- License : LGPL--- --- Maintainer : conal@conal.net--- Stability : experimental--- Portability : portable--- --- Phooey examples. Run them with 'runUI'-------------------------------------------------------------------------module Examples.Arrow where--import Control.Arrow-import Graphics.UI.Phooey.Arrow---- Simple shopping list--sl0 :: IWidget Int-sl0 = islider (0,10)--ui1 :: UI () ()-ui1 = title "Shopping List" $- proc () -> do- a <- title "apples" $ sl0 3 -< ()- b <- title "bananas" $ sl0 7 -< ()- title "total" showDisplay -< a+b---lo,hi :: UI () Int-lo = title "lo" (sl0 3)-hi = title "hi" (sl0 8)---- Dynamic bounds-ui2 = proc () -> do- l <- lo -< ()- h <- hi -< ()- v <- title "val" $ isliderDyn 5 -< (l,h)- title "factorial" showDisplay -< fact v--bounds :: UI () (Int,Int)-bounds = lo &&& hi--bounds' = proc () -> do - l <- lo -< ()- h <- hi -< ()- returnA -< (l,h)- --val :: UI () Int-val = title "val" $ (lo &&& hi) >>> isliderDyn 5--val' = bounds >>> title "val" (isliderDyn 5)--ui2' = val' >>> pure fact >>> title "factorial" showDisplay--ui2'' = (fact ^<< val') >>> title "factorial" showDisplay---fact n = product [1 .. n]----- In the two examples above, visual layout is implicitly chosen to be--- top-down, following the order in which the components are declared in--- the arrow expressions. This choice may be overridden, as in the--- following examples.--uiB1 = fromBottom ui1-uiL1 = fromLeft ui1-uiR1 = fromRight ui1--ui3 = fromBottom $- proc () -> do- (a,b) <- fromRight fruit -< (0,10)- title "total" showDisplay -< a+b- where - fruit = title "apples" (isliderDyn 3) &&&- title "bananas" (isliderDyn 7)----- Recursive examples. These ones just hang. Investigate.---uir1 = proc () -> do- rec lo <- title "lo" (isliderDyn 3) -< (0,hi)- hi <- title "hi" (isliderDyn 8) -< (lo,10)- val <- title "val" (isliderDyn 5) -< (lo,hi)- title "factorial" showDisplay -< fact val- returnA -< ()--uir2 = proc () -> do- rec val <- title "val" (isliderDyn 6) -< (val-5,val+5)- title "squared" showDisplay -< val*val--uir3 = proc () -> do- s <- title "message" (stringEntry "") -< ()- title "reversed" stringDisplay -< reverse s----- -- Simpler example for testing--- uia = proc () -> do--- n <- sl0 5 -< ()--- showDisplay -< fact n---- uia' = fromLeft uia---- uib :: UI () ()--- uib = title "Shopping List" $--- proc () -> do--- a <- title "apples" (sl0 3) -< ()--- b <- title "bananas" (sl0 7) -< ()--- title "sum" showDisplay -< a+b--- title "product" showDisplay -< a*b
src/Examples/Examples.hs view
@@ -1,21 +1,21 @@-{-# OPTIONS #-} - ----------------------------------------------------------------------- --- | --- Module : Examples.Examples --- Copyright : (c) Conal Elliott 2007 --- License : LGPL --- --- Maintainer : conal@conal.net --- Stability : experimental --- Portability : portable --- --- Imports example modules for easy error-checking ----------------------------------------------------------------------- - -module Examples.Examples where - -import qualified Examples.Imperative as Imp -import qualified Examples.Monad as Mon -import qualified Examples.Applicative as App -import qualified Examples.Arrow as Arr +{-# OPTIONS #-}++----------------------------------------------------------------------+-- |+-- Module : Examples.Examples+-- Copyright : (c) Conal Elliott 2007+-- License : LGPL+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- Portability : portable+-- +-- Imports example modules for easy error-checking+----------------------------------------------------------------------++module Examples.Examples where++-- import qualified Examples.Imperative as Imp+import qualified Examples.Monad as Mon+import qualified Examples.Applicative as App+-- import qualified Examples.Arrow as Arr
− src/Examples/Imperative.hs
@@ -1,70 +0,0 @@-{-# OPTIONS #-} - ----------------------------------------------------------------------- --- | --- Module : Examples.Imperative --- Copyright : (c) Conal Elliott 2007 --- License : LGPL --- --- Maintainer : conal@conal.net --- Stability : experimental --- Portability : portable --- --- Imperative Phooey examples ----------------------------------------------------------------------- - -module Examples.Imperative where - -import Graphics.UI.Phooey.Imperative - -import Graphics.UI.WX - - -runUI0 :: IO () -runUI0 = start $ - do f <- frame [ visible := False, text := "ui0" ] - pan <- panel f [] - count <- hslider pan True 0 10 [ selection := 3 ] - countSub <- mkNews count - double <- textEntry pan [ ] - triple <- textEntry pan [ ] - - let updDouble = do n <- get count selection - set double [ text := show (2*n) ] - let updTriple = do n <- get count selection - set triple [ text := show (3*n) ] - countSub updDouble - countSub updTriple - updDouble - updTriple - set pan [ layout := - boxed "Shopping List" $ - fill $ column 0 - [ lhwidget "count" count - , lhwidget "double" double {-""-} - , lhwidget "triple" triple ] ] - set f [ layout := hwidget pan, visible := True ] - -runUI1 :: IO () -runUI1 = start $ - do f <- frame [ visible := False, text := "ui1" ] - pan <- panel f [] - apples <- hslider pan True 0 10 [ selection := 3 ] - newsA <- mkNews apples - bananas <- hslider pan True 0 10 [ selection := 7 ] - newsB <- mkNews bananas - total <- textEntry pan [ ] - let updTot = do a <- get apples selection - b <- get bananas selection - set total [ text := show (a+b) ] - newsA updTot - newsB updTot - updTot - set pan [ layout := - boxed "Shopping List" $ - fill $ column 0 - [ lhwidget "apples" apples - , lhwidget "bananas" bananas {-""-} - , lhwidget "total" total ] ] - set f [ layout := hwidget pan, visible := True ] -
src/Examples/Monad.hs view
@@ -1,5 +1,8 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE TypeSynonymInstances, RecursiveDo #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts #-} + ---------------------------------------------------------------------- -- | -- Module : Examples.Monad@@ -8,152 +11,404 @@ -- -- Maintainer : conal@conal.net -- Stability : experimental--- Portability : portable+-- Portability : RecursiveDo -- --- Monadic-style Phooey examples. Use 'runUI'+-- Monadic-style Phooey examples. Use 'runUI' or 'runNamedUI'. ---------------------------------------------------------------------- module Examples.Monad where import Control.Applicative-import Control.Monad (liftM2)-import Control.Monad.Fix-import Data.Monoid (mappend,mempty)+import Data.Monoid+import Char (isDigit,ord)+import Maybe (fromJust) +import System.Time++-- mtl+import Control.Monad.Trans++-- wxHaskell+import Graphics.UI.WX hiding (Event,(.+.),key,button,smallButton,row)+import qualified Graphics.UI.WX as WX++-- TypeCompose+import Control.Compose (Unop,Binop)+import Data.Title++-- DataDriven+import Data.Event+import Data.Source++-- Phooey import Graphics.UI.Phooey.Monad +{----------------------------------------------------------+ Simplest examples+----------------------------------------------------------} --- h :: UI (Source String)--- h = return (pure "Hello World!")+h :: UIS String+h = return (pure "Hello World!") --- uia,uib :: UI (Source ())--- uia = stringDisplay =<< h--- uib = showDisplay =<< sl0 3+strs :: UIS String+strs = choices (words "Make things as simple as possible but not simpler") "simple" +strsU :: UI ()+strsU = stringDisplay =<< strs -ui1 :: UI (Source ())-ui1 = title "Shopping List" $- do a <- title "apples" $ islider (0,10) 3- b <- title "bananas" $ islider (0,10) 7- title "total" $ showDisplay (liftA2 (+) a b)+strLen :: UI ()+strLen = do str <- strs+ showDisplay (fmap length str) --- Refactoring+uia,uib :: UI ()+uia = stringDisplay =<< h+uib = showDisplay =<< islider (0,10) 3 +shopping1 :: UI ()+shopping1 = title "Shopping List" $+ do a <- title "apples" $ islider (0,10) 3+ b <- title "bananas" $ islider (0,10) 7+ title "total" $ showDisplay (liftA2 (+) a b)++area1 :: UI ()+area1 = do w <- title "width" $ fslider (0,10) (3 :: Float)+ h <- title "height" $ fslider (0,10) 7+ title "area" $ showDisplay (liftA2 (*) w h)++sqrt1 :: UI ()+sqrt1 = do x <- title "x" $ fslider (0,10) (3 :: Float)+ title "square root" $ fsliderDisplay (0,4) (sqrt <$> x)+++---- Refactoring+ sl0 :: IWidget Int sl0 = islider (0,10) -apples, bananas :: UI (Source Int)+apples, bananas :: UIS Int apples = title "apples" $ sl0 3 bananas = title "bananas" $ sl0 7 total :: Num a => OWidget a total = title "total" . showDisplay -ui1x :: UI (Source ())-ui1x = title "Shopping List" $- do a <- apples- b <- bananas- total (liftA2 (+) a b)+shopping2 :: UI ()+shopping2 = title "Shopping List" $+ do a <- apples+ b <- bananas+ total (liftA2 (+) a b) -fruit :: UI (Source Int)-fruit = liftM2 (liftA2 (+)) apples bananas+-- Sum UIs+infixl 6 .+. -ui1y :: UI (Source ())-ui1y = title "Shopping List" $ fruit >>= total+(.+.) :: Num a => UIS a -> UIS a -> UIS a+(.+.) = liftA2 (liftA2 (+)) +fruit :: UIS Int+fruit = apples .+. bananas +shopping3 :: UI ()+shopping3 = title "Shopping List" $ fruit >>= total++-- Small variation: title the fruit instead of the total+shopping3' :: UI ()+shopping3' = title "Shopping List" fruit >>= total+ -- In the two examples above, visual layout is implicitly chosen to be -- top-down, following the order in which the components are declared in -- the arrow expressions. This choice may be overridden, as in the -- following examples. -uiB1 = fromBottom ui1-uiL1 = fromLeft ui1-uiR1 = fromRight ui1+shoppingB = fromBottom shopping3+shoppingL = fromLeft shopping3+shoppingR = fromRight shopping3 +-- Mix & match layout+shopping4 = fromBottom $+ title "Shopping List" $+ fromRight fruit >>= total -ui3 = fromBottom $- title "Shopping List" $- fromRight fruit >>= total +{----------------------------------------------------------+ Subtotals -- suggested by Mads Lindstroem+----------------------------------------------------------} --- Experiments with multiple displays-uix = do n <- sl0 3- liftM2 mappend- (showDisplay (liftA (*2) n))- (showDisplay (liftA (*3) n))+-- more items+shovels, rakes, tools :: UIS Int+shovels = title "shovels" $ sl0 2+rakes = title "rakes" $ sl0 5+tools = shovels .+. rakes --- Dynamic+basket1 :: UI ()+basket1 = title "Shopping List" $+ do f <- fruit+ title "Fruit" $ showDisplay f+ t <- tools+ title "Tools" $ showDisplay t+ title "Basket" $ showDisplay $ liftA2 (+) f t -ui2 :: UI (Source ())-ui2 = do l <- title "lo" $ sl0 3- h <- title "hi" $ sl0 8- v <- title "val" $ isliderDyn (pair l h) 5- title "factorial" $ showDisplay (liftA fact v)+-- Abstract out the pattern above. Display and pass along an+-- "intermediate result", following an idea of Mads.+ir :: Show a => String -> UIS a -> UIS a+ir str ui = do x <- ui+ title str $ showDisplay x+ return x -fact :: Int -> Int-fact n = product [1 .. n]+-- with ir+basket2 :: UI ()+basket2 = title "Shopping List" $+ do f <- ir "Fruit" fruit+ t <- ir "Tools" tools+ title "Basket" $ showDisplay $ liftA2 (+) f t --- Refactor+-- refactored+basket3 :: UI ()+basket3 = title "Shopping List" $+ ir "Fruit" fruit .+. ir "Tools" tools+ >>= title "Basket" . showDisplay -lo,hi :: UI (Source Int)-lo = title "lo" $ sl0 3-hi = title "hi" $ sl0 8+-- A handy pattern: vertical arrangement with title & subtotal.+subtotal :: Show a => String -> UIS a -> UIS a+subtotal ttl ui = fromTop $ title ttl $ ir "subtotal" ui -bounds :: UI (Source (Int,Int))-bounds = liftM2 pair lo hi+-- Place shopping sub-lists and grand total alongside each other+basket4 :: UI ()+basket4 = title "Shopping List" $+ fromLeft $ subtotal "Fruit" fruit .+. subtotal "Tools" tools+ >>= title "Grand total" . showDisplay -val :: UI (Source Int)-val = do b <- bounds- title "val" $ isliderDyn b 5 --- Alternative style, in which the "val" title is around the lo & hi--- sliders as well. This layout reflects the purpose of the lo & hi--- sliders.+{----------------------------------------------------------+ Classic up/down counter example. See+ <http://haskell.org/haskellwiki/Phooey#Counter>+----------------------------------------------------------} -val' = title "val" $- do b <- bounds- isliderDyn b 5+-- Value-changer. Increment on "up" & decrement on "down"+upDown :: Num a => UIE (a -> a)+upDown = smallButton (+1) "up" `mappend` smallButton (subtract 1) "down" -ui2' = do v <- val'- title "factorial" $ showDisplay (liftA fact v)+upDown' :: Num a => UIE (a -> a)+upDown' = do up <- smallButton (+1) "up"+ down <- smallButton (subtract 1) "down"+ return (up `mappend` down) +-- The counter.+counter :: UI ()+counter = title "Counter" $ fromLeft $+ do e <- upDown+ -- Apply each increment/decrement cumulatively+ 0 `accumS` e >>= showDisplay --- Recursive+-- Note: I could purely accumulate the @a -> a@, and even do so very+-- elegantly as the endomorphism monoid ('Endo'), so as not to have to+-- specify the identity ('mempty') and composition ('mappend'). Whenever the+-- endomorphism changes, it would get applied to the initial value, which+-- would be frightfully expensive. In a sense, the approach above+-- exploits associativity of composition for efficiency.+-- +-- Mitch Wand used this associativity trick very effectively in his paper+-- "Continuation-Based Program Transformation Strategies". He also came+-- up with alternative representations for the continuations. Oh! I+-- could do that here. The continuation is adding a number. Use the+-- 'Sum' monoid instead of 'Endo', and we'll have an efficient, evaluated+-- representation of that continuation, namely a single number to be+-- added. -uir1 :: UI (Source ())-uir1 = mdo l <- title "lo" $ isliderDyn (pair (pure 0) h) 3- h <- title "hi" $ isliderDyn (pair l (pure 10)) 8- v <- title "val" $ isliderDyn (pair l h) 5- title "factorial" $ showDisplay (liftA fact v)+upDown2 :: Num a => UIE (Sum a)+upDown2 = smallButton (Sum 1) "up" `mappend` smallButton (Sum (-1)) "down" --- Refactor+counter2 :: UI ()+counter2 = title "Counter" $ fromLeft $+ do ud <- upDown2+ n <- (fmap.fmap) getSum (monoidS ud)+ showDisplay n -boundsR :: UI (Source (Int,Int))-boundsR = mfix boundsF- where- boundsF lh = liftM2 pair- (title "lo" $ isliderDyn (pair (pure 0) h) 3)- (title "hi" $ isliderDyn (pair l (pure 10)) 8)- where- (l,h) = unPair lh -unPair :: Functor f => f (a, b) -> (f a, f b)-unPair p = (fmap fst p, fmap snd p)+{----------------------------------------------------------+ Calculator, from "Lightweight GUIs for Functional Programming".+ See <http://haskell.org/haskellwiki/Phooey#Calculator>+----------------------------------------------------------} -valR :: UI (Source Int)-valR = do b <- boundsR- title "val" $ isliderDyn b 5+-- Single calculator key+key :: Char -> UIE Char+key c = button' c [ outerSize := sz 50 50, text := [c] ] -uir1' = do v <- valR- title "factorial" $ showDisplay (liftA fact v)+-- Handy+mconcatMap :: Monoid b => (a -> b) -> [a] -> b+mconcatMap f = mconcat . map f +-- Row of keys. Uses the Monoid instances for UI and Event +row :: [Char] -> UIE Char+row = fromLeft . mconcatMap key -uir2 = mdo v <- title "val" (isliderDyn (liftA (plusMinus 5) v) 6)- title "squared" (showDisplay (liftA square v))+-- Rows of keys.+rows :: [[Char]] -> UIE Char+rows = fromTop . mconcatMap row++-- The whole keyboard. Four rows of four keys each+calcKeys :: UIE Char+calcKeys = rows [ "123+"+ , "456-"+ , "789*"+ , "C0=/" ]+++-- Test calcKeys, accumulating the string of keys pressed. Each char c+-- gets replaced by (c :), which get successively applied via 'accumS'.+testKeys :: UI ()+testKeys = title "Calculator key test" $+ calcKeys >>= showKeys+ +showKeys :: Event Char -> UI ()+showKeys key =+ do chars <- "" `accumS` fmap (:) key+ title "keys pressed" $ stringDisplay $ fmap reverse chars++-- -- Test calcKeys, accumulating the string of keys pressed. Each char c+-- -- gets replaced by (c :), which get successively applied via 'accumS'.+-- testKeys :: UI ()+-- testKeys = title "Calculator key test" $+-- do key <- calcKeys+-- chars <- "" `accumS` fmap (:) key+-- title "chars" $ stringDisplay $ fmap reverse chars+++-- The calculator state is a number being formed and a continuation.+type CState = (Int, Unop Int)++-- Start state+startCS :: CState+startCS = (0, id)++-- Interpret a character as a state transition.+cmd :: Char -> Unop CState+cmd 'C' _ = startCS+cmd '=' (d,k) = (k d, const (k d))+cmd c (d,k) | isDigit c = (10*d + ord c - ord '0', k)+ | otherwise = (0, op c (k d))++-- TODO: Try formulating the state as a monoid. Use Endo for the+-- continuation and for the state transition.++-- Operation associated with a key+op :: Char -> Binop Int+op c = fromJust (lookup c ops) where- plusMinus n x = (x-n,x+n)- square y = y*y+ ops :: [(Char, Binop Int)]+ ops = [('+',(+)), ('-',(-)), ('*',(*)), ('/',div)] -pair :: Applicative f => f a -> f b -> f (a,b)-pair = liftA2 (,)+-- The calculator+calc :: UI ()+calc = title "Calculator" $+ do key <- calcKeys+ showKeys key+ showCalc key++showCalc :: Event Char -> UI ()+showCalc key = do states <- startCS `accumS` fmap cmd key+ title "result" $ showDisplay $ fmap fst states++-- -- The calculator+-- calc :: UI ()+-- calc = title "Calculator" $+-- do e <- calcF+-- states <- startCS `accumS` e+-- title "result" $ showDisplay $ fmap fst states+++---- Redo with monoids++-- With the @String@ monoid+testKeys2 :: UI ()+testKeys2 = title "Calculator key test - monoid version" $+ do key <- calcKeys+ str <- monoidS (fmap (:[]) key)+ title "chars" $ stringDisplay str++-- Hm. I think the strings get combined in the worst possible way, by+-- repeated snoc'ing, which is probably on the same order as the Endo+-- composition.++-- With the @Endo CState@ monoid+calc2 :: UI ()+calc2 = title "Calculator - monoid version" $+ do key <- calcKeys+ endos <- monoidS (fmap (Endo . cmd) key)+ let n = fmap (fst . ($ startCS) . appEndo) endos+ title "result" $ showDisplay n++-- As mentioned above, I expect this @calc2@ to be very wasteful,+-- accumulating and re-applying longer & longer composition chains as it+-- goes. Applying Mitch Wand's lovely trick, what's a data representation+-- for the subset of @CState -> CState@ that comes from compositions of+-- @cmd@?+++-- Timed polling++calendarTime :: Double -> UI (Source CalendarTime)+calendarTime secs = timedPoll secs (getClockTime >>= toCalendarTime)++clock :: UI ()+clock = (fmap.fmap) calendarTimeToString (calendarTime 1) >>= stringDisplay+++---- Tests: move to Test.hs++{----------------------------------------------------------+ Tests+----------------------------------------------------------}++test = mapM_ runUI [t0,t1,t2,t3,t4,t5,t6]++-- basic counter+t0 = do up <- button (+1) "up"+ n <- 0 `accumS` up+ showDisplay n++-- "up" only works the first time+t1 = do up <- button (+1) "up"+ n <- 0 `accumS` once up+ showDisplay n++-- "up" works until "stop"+t2 = do stop <- button () "stop"+ up <- button (+1) "up"+ n <- 0 `accumS` (up `before` stop)+ showDisplay n++-- two buttons: each increments+t3 = do poke <- button () "poke me"+ dont <- button () "don't poke me"+ ec <- countE (poke `mappend` dont)+ n <- 0 `stepper` ec+ showDisplay n++-- different rendering of t0+-- TODO: rewrite accumS this way. or explain why not.+t4 = do up <- button (+1) "up"+ ec <- 0 `accumE` up+ n <- 0 `stepper` ec+ showDisplay n++-- up/down+t5 = do up <- button (+1) "up"+ down <- button (subtract 1) "down"+ ec <- 0 `accumE` (up `mappend` down)+ n <- 0 `stepper` ec+ showDisplay n++-- value pairs+t6 = do up <- button (+1) "up"+ e <- 0 `accumE` up+ showDisplay =<< 0 `stepper` e+ e' <- withPrevE e+ showDisplay =<< (10,10) `stepper` e'++-- prime withPrev with 0+t7 = do up <- button (+1) "up"+ e <- 0 `accumE` up+ showDisplay =<< 0 `stepper` e+ e' <- withPrevE (pure 0 `mappend` e)+ showDisplay =<< (10,10) `stepper` e'+
src/Graphics/UI/Phooey/Applicative.hs view
@@ -1,4 +1,6 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE TypeSynonymInstances, TypeOperators #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts #-} ---------------------------------------------------------------------- -- |@@ -8,7 +10,7 @@ -- -- Maintainer : conal@conal.net -- Stability : experimental--- Portability : portable+-- Portability : TypeSynonymInstances -- -- UIs as applicative functors. This module is a very simple layering -- over "Graphics.UI.Phooey.Monad". It serves to hide the 'Source' types@@ -18,27 +20,31 @@ module Graphics.UI.Phooey.Applicative ( -- * The UI applicative functor- UI, runUI, runNamedUI, Act, Snk+ UI, runUI, runNamedUI, Action, Sink -- * Tools for high-level widgets- , IWidget, OWidget+ , IWidget, OWidget, iwidget, owidget -- * Some high-level widgets , stringEntry, stringDisplay, showDisplay- , islider, isliderDyn, isliderDisplay- , checkBoxEntry, checkBoxDisplay- , title+ , islider, isliderDisplay+ , fslider, fsliderDisplay+ , checkBoxEntry, checkBoxDisplay, choices, timedPoll, cache -- * Explicit layout , fromTop, fromBottom, fromLeft, fromRight, flipLayout ) where -import Control.Monad.Reader-import Control.Applicative+-- Base+import Control.Applicative (pure)++-- TypeCompose import Control.Compose+import Data.Title -import Graphics.UI.Phooey.LayoutT-import Graphics.UI.Phooey.TagT+-- DataDriven+import Data.Event (Action,Sink)+import Data.Source (Source) +-- Phooey import qualified Graphics.UI.Phooey.Monad as M-import Graphics.UI.Phooey.Monad (Source,Act,Snk) {----------------------------------------------------------@@ -46,15 +52,17 @@ ----------------------------------------------------------} -- | The UI applicative functor.-type UI = O M.UI Source+type UI = M.UI :. Source --- | Run a 'UI' with window title \"Monadic Phooey GUI\".-runUI :: UI Act -> IO ()+-- | Run a 'UI' with window title \"Applicative Phooey GUI\".+runUI :: UI Action -> IO () runUI = runNamedUI "Applicative Phooey GUI" -- | Run a 'UI' with given window title.-runNamedUI :: String -> UI Act -> IO ()-runNamedUI name = M.runNamedUI' name . unO+runNamedUI :: String -> UI Action -> IO ()+runNamedUI name =+ -- convert the @UI (Source Action)@ to a @UI ()@ and run.+ M.runNamedUI name . M.act . unO {----------------------------------------------------------@@ -65,7 +73,7 @@ type IWidget a = a -> UI a -- | Output widget. Yields a sink of values-type OWidget a = UI (Snk a)+type OWidget a = UI (Sink a) -- | Make an input widget iwidget :: M.IWidget a -> IWidget a@@ -73,7 +81,7 @@ -- | Make an output widget owidget :: M.OWidget' a -> OWidget a-owidget mwid = O (fmap pure mwid)+owidget = O . fmap pure {----------------------------------------------------------@@ -93,18 +101,21 @@ showDisplay = owidget M.showDisplay' --- | Slider input widget with static bounds+-- | Slider input widget islider :: (Int,Int) -> IWidget Int islider bounds = iwidget (M.islider bounds) +-- | Slider input widget over fractional values+fslider :: RealFrac a => (a,a) -> IWidget a+fslider bounds = iwidget (M.fslider bounds)+ -- | Slider output widget with static bounds isliderDisplay :: (Int,Int) -> OWidget Int isliderDisplay bounds = owidget (M.isliderDisplay' bounds) --- | Slider widget with dynamic bounds.-isliderDyn :: UI (Int,Int) -> IWidget Int-isliderDyn (O bounds) initial = O $- bounds >>= flip M.isliderDyn initial+-- | Slider input widget over fractional values+fsliderDisplay :: RealFrac a => (a,a) -> OWidget a+fsliderDisplay bounds = owidget (M.fsliderDisplay' bounds) -- | Boolean input widget checkBoxEntry :: IWidget Bool@@ -114,39 +125,46 @@ checkBoxDisplay :: OWidget Bool checkBoxDisplay = owidget M.checkBoxDisplay' --- | Wrap a title around a 'UI'-title :: String -> Unop (UI a)-title str = inO (M.title str)- -- mapLayout (boxed str)+-- | Input from a \"menu\" of choices.+choices :: [String] -> IWidget String+choices strings = iwidget (M.choices strings) +-- | Input from a timer and a means of polling. Interval is in seconds.+-- If 'poll' is expensive, then apply 'cache' to the resulting UI.+timedPoll :: Double -> IO a -> UI a+timedPoll secs poll = O (M.timedPoll secs poll)++-- | Cache a source, presumably with an expensive polling action+cache :: UI a -> UI a+cache = inO M.cache+++-- Wrap a title around a 'UI'+instance Title_f UI where title_f str = inO (title_f str)+ {---------------------------------------------------------- Layout ----------------------------------------------------------} --- | Tweak the 'LayoutT'-onLayoutT :: LayoutTOp IO -> Unop (UI a)-onLayoutT f = inO (M.onLayoutT f)- -- | Lay out from top to bottom fromTop :: Unop (UI a)+fromTop = inO M.fromTop -- | Lay out from bottom to top fromBottom :: Unop (UI a)+fromBottom = inO M.fromBottom -- | Lay out from left to right fromLeft :: Unop (UI a)+fromLeft = inO M.fromLeft -- | Lay out from right to left fromRight :: Unop (UI a)+fromRight = inO M.fromRight -- | Reverse layout flipLayout :: Unop (UI a)--fromTop = onLayoutT fromTopL-fromBottom = onLayoutT fromBottomL-fromLeft = onLayoutT fromLeftL-fromRight = onLayoutT fromRightL-flipLayout = onLayoutT flipL+flipLayout = inO M.flipLayout -----
− src/Graphics/UI/Phooey/Arrow.hs
@@ -1,138 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--------------------------------------------------------------------------- |--- Module : Graphics.UI.Phooey.Arrow--- Copyright : (c) Conal Elliott 2006--- License : LGPL--- --- Maintainer : conal@conal.net--- Stability : provisional--- Portability : portable--- --- A functional UI arrow. See explanation and examples in--- "Graphics.UI.Phooey".-------------------------------------------------------------------------module Graphics.UI.Phooey.Arrow- ( - -- * The UI arrow- UI(..), runUI, runNamedUI- -- * High-level widgets- , IWidget, OWidget- , stringDisplay, showDisplay, stringEntry, islider, isliderDyn- , checkBoxDisplay, checkBoxEntry, title- -- * Explicit layout- , fromTop, fromBottom, fromLeft, fromRight, flipLayout- -- * Internal (extensibility)- , ui, sourceOp, onLayoutT- ) where---import Control.Arrow-import Data.Monoid--import Graphics.UI.Phooey.TagT (Unop)-import Graphics.UI.Phooey.LayoutT-import qualified Graphics.UI.Phooey.Monad as M--import Control.Compose--{----------------------------------------------------------- The UI arrow-----------------------------------------------------------}---- | The UI arrow-newtype UI i o = UI ((ArrowAp (Kleisli M.UI) M.Source) i o)- deriving (Arrow,ArrowLoop)---- | Run a 'UI' with window title \"Phooey Arrow GUI\".-runUI :: UI () () -> IO ()-runUI = runNamedUI "Phooey Arrow GUI"---- | Run a 'UI' with given window title.-runNamedUI :: String -> UI () () -> IO ()-runNamedUI str (UI (ArrowAp (Kleisli f))) = M.runNamedUI str (f mempty)---- runNamedUI str (UI (ArrowAp (Kleisli f))) = M.runNamedUI str (f mempty)---- | Wrap up monadic UI function as a 'UI'-ui :: (M.Source i -> M.UI (M.Source o)) -> UI i o-ui = UI . ArrowAp . Kleisli---{----------------------------------------------------------- High-level widgets-----------------------------------------------------------}---- | Input widget type (with initial value)-type IWidget a = a -> UI () a--- | Output widget type-type OWidget a = UI a ()---- | String display widget-stringDisplay :: OWidget String-stringDisplay = ui M.stringDisplay---- | Showable display widget-showDisplay :: Show a => OWidget a-showDisplay = pure show >>> stringDisplay- -- or: ui M.showDisplay---- | Simple text input widget-stringEntry :: IWidget String-stringEntry initial = ui (const (M.stringEntry initial))---- | Slider widget with initial value and /static/ bounds (min,max)-islider :: (Int,Int) -> IWidget Int-islider bounds initial = ui (const (M.islider bounds initial))---- | Slider widget with static initial value and /dynamic/ bounds (min,max)-isliderDyn :: Int -> UI (Int,Int) Int-isliderDyn initial = ui (flip M.isliderDyn initial)---- | String display widget-checkBoxDisplay :: UI Bool ()-checkBoxDisplay = ui M.checkBoxDisplay---- | Simple checkbox input widget-checkBoxEntry :: Bool -> UI () Bool-checkBoxEntry initial = ui (const (M.checkBoxEntry initial))---- | Wrap a title around a 'UI'-title :: String -> Unop (UI a b)-title str = sourceOp (M.title str)---{----------------------------------------------------------- Layout-----------------------------------------------------------}---- | Lay out from top to bottom-fromTop :: Unop (UI a b)-fromTop = onLayoutT fromTopL---- | Lay out from bottom to top-fromBottom :: Unop (UI a b)-fromBottom = onLayoutT fromBottomL---- | Lay out from left to right-fromLeft :: Unop (UI a b)-fromLeft = onLayoutT fromLeftL---- | Lay out from right to left-fromRight :: Unop (UI a b)-fromRight = onLayoutT fromRightL---- | Reverse layout-flipLayout :: Unop (UI a b)-flipLayout = onLayoutT flipL------- Misc unexported--sourceOp :: Unop (M.UI (M.Source b)) -> Unop (UI a b)-sourceOp f (UI (ArrowAp (Kleisli g))) = ui (f . g)--onLayoutT :: LayoutTOp IO -> Unop (UI a b)-onLayoutT f = sourceOp (M.onLayoutT f)
src/Graphics/UI/Phooey/Imperative.hs view
@@ -1,5 +1,3 @@-{-# OPTIONS #-}- ---------------------------------------------------------------------- -- | -- Module : Graphics.UI.Phooey.Imperative@@ -16,7 +14,7 @@ module Graphics.UI.Phooey.Imperative ( -- * Widget & layout tools- hwidget,lhwidget ,hsliderDyn, mkNews, commandNews+ above, leftOf, empty', hwidget,lhwidget ,hsliderDyn -- * Simple abstraction around widget containers and frames , Win, Wio, runWio )@@ -25,26 +23,20 @@ import Graphics.UI.WX import Graphics.UI.WXCore (sliderGetMin,sliderGetMax,sliderSetRange) -import Data.IORef-import Control.Monad (join)-import Data.Monoid (mappend) import Control.Instances () -- For Monoid (IO a) instance {----------------------------------------------------------------------- Widget & layout tools -----------------------------------------------------------------------} --- -- | Get the current 'selection' value of a widget--- getSel :: Selection ctl => ctl -> IO Int--- getSel ctl = get ctl selection---- -- | Set a single attribute--- set1 :: w -> Attr w a -> a -> IO ()--- set1 w attr val = set w [ attr := val ]+-- | Binary layout combinator+above, leftOf :: Layout -> Layout -> Layout+la `above` lb = fill (column 0 [la,lb])+la `leftOf` lb = fill (row 0 [la,lb]) --- -- | Set the 'command' callback--- onCommand :: Commanding ctl => ctl -> IO () -> IO ()--- onCommand ctl io = set ctl [ on command := io ]+-- | A stretchy empty layout+empty' :: Layout+empty' = fill empty -- | Horizontally-filled widget layout hwidget :: Widget w => w -> Layout@@ -77,36 +69,15 @@ when (lo <= x && x <= hi) (set ctl [ selection := x ]) --- | Make a \"news\" publisher given a function that (destructively) assigns--- a single action to be executed upon some event. The publisher can--- remember any number of actions (the "subscribers").-mkNews :: (IO () -> IO ()) -> IO (IO () -> IO ())-mkNews setNotify = - do ref <- newIORef (return ()) -- contains subscribed actions- setNotify (join (readIORef ref))- return $ modifyIORef ref . mappend --- | Make a \"news\" publisher for a widget's command.-commandNews :: Commanding wid => wid -> IO (IO () -> IO ())-commandNews wid = mkNews (\ act -> set wid [ on command := act ])---- cmdNews wid = --- do -- putStrLn "mkNews"--- ref <- newIORef (return ()) -- contains subscribed actions--- set wid [ on command := join (readIORef ref) ]--- return $ modifyIORef ref . mappend---- TODO: perform action only when the value actually changes. I get an--- extra kick on grabbing a slider and two extra on releasing. Is there a--- way to eliminate them?-- {----------------------------------------------------------------------- Wio -- simple abstraction around widget containers and frames -----------------------------------------------------------------------} -type Win = Panel () -- ^ Container of widgets-type Wio = Win -> IO Layout -- ^ Consumes container and yield layout+-- | Container of widgets+type Win = Panel ()+-- | Consumes container and yield layout+type Wio = Win -> IO Layout -- | Run a 'Wio': handle frame & widget creation, and apply layout. runWio :: String -> Wio -> IO ()
− src/Graphics/UI/Phooey/LayoutT.hs
@@ -1,116 +0,0 @@-{-# 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- -- * Miscellany- , panelWrap- ) where--import Data.Maybe (fromMaybe)-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 ())) -> IO ()-runL name f = runWio name $ \ win -> - do ~(l,upd) <- runLayout (f win)- upd- return l---{----------------------------------------------------------- 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---{----------------------------------------------------------- Miscellany-----------------------------------------------------------}---- | Wrap another panel and layout unop (probably id, hfill, vfill, or fill)--- to get desired stretchiness.-panelWrap :: Unop Layout -> Unop (Win -> IO (Maybe Layout, b))-panelWrap layf f w = do pan <- panel w []- ~(mbl,b) <- f pan- -- if we get a layout, use it for the panel.- maybe (return ()) (\ l -> set pan [ layout := l ]) mbl- return (Just (layf (widget pan)), b)
src/Graphics/UI/Phooey/Monad.hs view
@@ -1,5 +1,11 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleContexts+ , UndecidableInstances, ScopedTypeVariables #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-}++ ---------------------------------------------------------------------- -- | -- Module : Graphics.UI.Phooey.Monad@@ -18,184 +24,192 @@ module Graphics.UI.Phooey.Monad ( -- * The UI monad- UI, Source, Act, Snk, runUI, runNamedUI, runUI', runNamedUI'+ CxLayout, UI, UI', biUI, inUI, toUI, fromUI+ , UIE, UIS+ , runUI, runNamedUI, act+ , accumE, accumS, monoidE, monoidS -- * Tools for high-level widgets- , IWidget, OWidget, OWidget', IOWidget, MkWidget- , iwidget, owidget, owidget', iowidget+ , IWidget, OWidget, OWidget', IOWidget, MkWidget, widgetL+ , iwidget, iwidget', owidget, owidget', iowidget -- * Some high-level widgets , stringEntry, stringDisplay, stringDisplay' , showDisplay, showDisplay'- , islider, isliderDyn, isliderDisplay, isliderDisplay'+ , islider, isliderDisplay, isliderDisplay'+ , fslider, fsliderDisplay, fsliderDisplay' , checkBoxEntry, checkBoxDisplay, checkBoxDisplay'- , title+ , button, button', smallButton+ , choices, timedPoll, cache -- * Explicit layout , fromTop, fromBottom, fromLeft, fromRight, flipLayout- -- * Misc tools- , mkWidget- , onLayoutT, mapLayout ) where import Control.Applicative+import Control.Arrow ((>>>),first,second)+import Data.Maybe (fromJust)+import Data.List (elemIndex)++-- mtl import Control.Monad.Reader import Control.Monad.Writer-import Control.Arrow (first) -import Graphics.UI.WX hiding (textEntry)+-- wxHaskell+import Graphics.UI.WX hiding (Event,button,smallButton) import qualified Graphics.UI.WX as WX -import Control.Compose () -- for Monad (IO a) instance-import Control.DataDriven+-- TypeCompose+import Control.Compose (Unop,(:.)(..))+import Data.CxMonoid+import Data.Bijection+import Data.Title -import Graphics.UI.Phooey.Imperative-import Graphics.UI.Phooey.TagT (Unop,UUnop,mkTag,mapTag)-import Graphics.UI.Phooey.LayoutT+-- DataDriven+import Data.Source+import Data.Event +-- Phooey+import Graphics.UI.Phooey.Imperative (Win,empty',above,leftOf,hwidget)+import Graphics.UI.Phooey.WinEvents (attrSource,getAttr,setAttr,wEvent_) {---------------------------------------------------------- The UI monad ----------------------------------------------------------} +-- | Context-dependent layout+type CxLayout = CxMonoid Layout++instance Title Layout where title = boxed+ -- | The UI monad-type UI = ReaderT Win (WriterT Act (LayoutT IO))+type UI = ReaderT Win (WriterT CxLayout (WriterT (Source Action) IO)) --- | Sources of values (data-driven)-type Source = DataDriven IO+-- | Source-valued UI+type UIS a = UI (Source a) --- | IO-based action-type Act = Action IO -- == IO ()+-- | Event-valued UI+type UIE a = UI (Event a) --- | IO-based sink-type Snk a = Sink IO a+-- Standard monad-as-applicative instance+instance Applicative UI where { pure = return ; (<*>) = ap } --- | Run a 'UI' with window title \"Monadic Phooey GUI\".-runUI :: UI (Source ()) -> IO ()-runUI = runNamedUI "Monadic Phooey GUI"+-- Standard AF-as-monoid instance+instance Monoid o => Monoid (UI o) where+ mempty = pure mempty+ mappend = liftA2 mappend --- | Run a 'UI' with given window title.-runNamedUI :: String -> UI (Source ()) -> IO ()-runNamedUI name = runL name . ((liftM runDD' . runWriterT) .) . runReaderT- where- runDD' :: (Source (), Act) -> Act- runDD' (src, delayed) = runDD src >> delayed -- or delayed first?+-- | Convenient variation of 'UI'+type UI' a = Win -> IO ((a, CxLayout), Source Action) --- | Run a 'UI' with window title \"Monadic Phooey GUI\" -- alternative version-runUI' :: UI (Source Act) -> Act-runUI' = runNamedUI' "Monadic Phooey GUI"+-- Convenient bijection+biReaderT :: (r -> m a) :<->: ReaderT r m a +biReaderT = Bi ReaderT runReaderT --- | Run a 'UI' with given window title -- alternative version. Works--- with \"alternative\"-style outputs.-runNamedUI' :: String -> UI (Source Act) -> Act-runNamedUI' name = runNamedUI name . liftM joinDD+biWriterT :: m (a, w) :<->: WriterT w m a +biWriterT = Bi WriterT runWriterT +-- | Bijection for convenient manipulation. +biUI :: UI' a :<->: UI a+biUI = bimap (biWriterT >>> biWriterT) >>> biReaderT -{----------------------------------------------------------- Tools for high-level widgets-----------------------------------------------------------}+-- In biUI, the bimap is for the (->) Win, and each biWriterT un/wraps a WriterT. --- | Input widget type (with initial value)-type IWidget a = a -> UI (Source a)--- | Output widget type-type OWidget a = Source a -> UI (Source ())--- | Alternative output widget type-type OWidget' a = UI (Snk a)+-- Separate biUI into separately typed pieces. --- | Combine input & output widget types-type IOWidget a = (IWidget a, OWidget a, OWidget' a)+-- TODO: look for alternatives. --- | Type of widget-making functions-type MkWidget widget a b =- Unop Layout -> (Win -> [Prop widget] -> IO widget) -> Attr widget a -> b+-- | Make from representation+toUI :: UI' a -> UI a+toUI = biTo biUI --- iwidgetSource :: Commanding widget =>--- (Win -> [Prop widget] -> IO widget) -- ^ widget maker--- -> Attr widget a -- ^ widget attribute--- -> a -- ^ initial value--- -> Win -- ^ parent--- -> IO (widget, Source a)--- iwidgetSource mkWid attr initial win =--- do wid <- mkWid win [ attr := initial ]--- news <- commandNews wid--- return (wid, dd news (get wid attr))+-- | Extract representation+fromUI :: UI b -> UI' b+fromUI = biFrom biUI --- | Make a (data-driven) value source for a given widget and attribute.-commandSource :: Commanding widget =>- widget -- ^ widget- -> Attr widget a -- ^ attribute- -> IO (Source a)-commandSource wid attr = fmap (dd (get wid attr)) (commandNews wid)+-- | Apply a unary function inside the 'UI' representation.+inUI :: (UI' a -> UI' b) -> (UI a -> UI b)+inUI = (toUI .) . (. fromUI) --- commandSource wid attr =--- do news <- commandNews wid--- return (dd news (get wid attr))+-- | Run a 'UI' with window title \"Monadic Phooey GUI\".+runUI :: UI () -> IO ()+runUI = runNamedUI "Monadic Phooey GUI" +-- | Run a 'UI' with given window title.+runNamedUI :: String -> UI () -> IO ()+runNamedUI name ui = start $+ do f <- frame [ visible := False, text := name ]+ win <- panel f []+ (((),cxl),acts) <- fromUI ui win+ set win [ layout := unCxMonoid cxl (empty',above) ]+ set f [ layout := hwidget win, visible := True ]+ runDDJoin acts --- | Make a high-level input widget-iwidget :: (Commanding widget, Widget widget) => MkWidget widget a (IWidget a)+-- | Move an action source into position to be executed+act :: UI (Source Action) -> UI ()+act = inUI $ (fmap.fmap) doit+ where+ doit ((io, l), acts) = (((),l), acts `mappend` io) --- iwidget layf mkWid attr initial = mkWidget layf $ \ win ->--- do (wid, src) <- iwidgetSource mkWid attr initial win--- return (wid, (src,mempty)) --- iwidget layf mkWid attr initial =--- mkWidget layf (fmap tag . iwidgetSource mkWid attr initial)--- where--- tag (wid, src) = (wid, (src,mempty)) --- mkWidget layf (second (flip (,) mempty) (iwidgetSource mkWid attr initial))+{----------------------------------------------------------+ Tools for high-level widgets+----------------------------------------------------------} -iwidget layf mkWid attr initial = mkWidget layf $ \ win ->- do wid <- mkWid win [ attr := initial ]- src <- commandSource wid attr- return (wid, (src,mempty))+-- | Input widget type (with initial value)+type IWidget a = a -> UI (Source a)+-- | Output widget type+type OWidget a = Source a -> UI ()+-- | Alternative output widget type+type OWidget' a = UI (Sink a) --- iwidget layf mkWid attr initial = mkWidget layf $ \ win ->--- do wid <- mkWid win [ attr := initial ]--- news <- commandNews wid--- return (wid, (dd news (get wid attr), mempty))+-- | Combine input & output widget types+type IOWidget a = (IWidget a, OWidget a, OWidget' a) -type IWidgetDyn a b = Source a -> IWidget b+-- | Utility type for making widgets+type MkWidget ctl a b =+ Unop Layout -> (Win -> [Prop ctl] -> IO ctl) -> Attr ctl a -> b -type MkIWidgetDyn widget a b =- Unop Layout- -> (Win -> [Prop widget] -> IO (widget, Snk a))- -> Attr widget b- -> IWidgetDyn a b+widgetL :: Widget w => Unop Layout -> w -> CxLayout+widgetL filler ctl = CxMonoid (const (filler (widget ctl))) --- | Slider widget with static initial value and dynamic bounds (min,max)-iwidgetDyn :: (Commanding widget, Widget widget) => MkIWidgetDyn widget a b+-- | Make an input widget. See alos 'iwidget\''.+iwidget :: (Commanding ctl, Widget ctl) => MkWidget ctl a (IWidget a)+iwidget = iwidget' command -iwidgetDyn layf mkWid attr srcA initial = mkWidget layf $ \ win ->- do (wid,snkA) <- mkWid win [ attr := initial ]- src <- commandSource wid attr- return ( wid- , ( src- , runDD (mapCur (>>= snkA) srcA) ) )+-- | Make an input widget with a given update event. If the update is+-- 'commanding' you can use 'iwidget'.+iwidget' :: Widget ctl => WX.Event ctl (IO ()) -> MkWidget ctl a (IWidget a)+iwidget' ev filler mkWid attr initial = toUI $ \ win ->+ do ctl <- mkWid win [ attr := initial ]+ src <- attrSource ev attr ctl+ -- In the case of 'choices', the creation-time attribute set is not+ -- enough, so set it here again.+ set ctl [ attr := initial ]+ -- and invoke any event handlers+ join $ getAttr (on ev) ctl+ return ((src, widgetL filler ctl), mempty) --- iwidgetDyn layf mkWid attr src initial = mkWidget layf $ \ win ->--- do (wid,snkA) <- mkWid win [ attr := initial ]--- news <- commandNews wid--- return ( wid--- , ( dd news (get wid attr)--- , runDD (mapGet (>>= snkA) src) ) )+-- TODO: look in WinEvents for helpers. --- OWidget is convenient for a monad interface. For building an--- applicative functor, we'll want the the alternative OWidget' style.+-- | Tweaks output style+outFun :: OWidget' a -> OWidget a+outFun ui src =+ -- Apply sinks to values & move to actions+ act $ fmap (<$> src) ui -- | Make a high-level output widget owidget :: Widget widget => MkWidget widget a (OWidget a)-owidget layf mkWid attr src =- liftM (joinDD . (<$> src)) (owidget' layf mkWid attr)+owidget filler mkWid attr = outFun (owidget' filler mkWid attr) --- | Make a high-level output widget-owidget' :: Widget widget => MkWidget widget a (OWidget' a)-owidget' layf mkWid attr = mkWidget layf $ \ win ->- do wid <- mkWid win [ ]- return (wid, (\ a -> set wid [ attr := a ], mempty))+-- | Output widget, alternative style+owidget' :: Widget ctl => MkWidget ctl a (OWidget' a)+owidget' filler mkWid attr = toUI $ \ win ->+ do ctl <- mkWid win [ ]+ return ((setAttr attr ctl, widgetL filler ctl), mempty) -- | Convenience function combining 'iwidget', 'owidget', and 'owidget\'' iowidget :: (Commanding widget, Widget widget) => MkWidget widget a (IOWidget a)-iowidget layf mkWid attr =- (iwidget layf mkWid attr, owidget layf mkWid attr, owidget' layf mkWid attr)+iowidget filler mkWid attr =+ (iwidget filler mkWid attr, owidget filler mkWid attr, owidget' filler mkWid attr) {----------------------------------------------------------@@ -211,7 +225,7 @@ -- | Alternative string output widget stringDisplay' :: OWidget' String -(stringEntry,stringDisplay,stringDisplay') = iowidget hfill WX.textEntry text+(stringEntry,stringDisplay,stringDisplay') = iowidget hfill textEntry text -- | Showable output widget showDisplay :: Show a => OWidget a@@ -245,10 +259,62 @@ thd3 (_,_,c) = c --- | Slider widget with static initial value and dynamic bounds (min,max)-isliderDyn :: Source (Int,Int) -> IWidget Int-isliderDyn = iwidgetDyn hfill (flip hsliderDyn True) selection +-- | Fractional slider, alternative interface+fslider :: forall a. RealFrac a => (a,a) -> IWidget a+fslider (lo,hi) initial = toUI $ \ win ->+ do pan <- panel win [ ]+ pbg <- get pan bgcolor+ cval <- textEntry pan [ clientSize :~ \ (Size _ h) -> Size 40 h+ , bgcolor := pbg+ ]+ slid <- hslider pan False (toI lo) (toI hi)+ [ selection := toI initial+ , size :~ \ (Size _ h) -> (Size 80 h)]+ set pan [ layout := row 5 [ widget cval, label (show lo)+ , fill $ widget slid, label (show hi) ] ]+ isrc <- attrSource command selection slid+ let fsrc = fmap toF isrc+ -- update the value display when it changes+ runDDJoin $ (setAttr text cval . show) <$> fsrc+ return ((fsrc, widgetL hfill pan), mempty)+ where+ toI x = round ((x - lo) * scale)+ toF i = fromIntegral i / scale + lo+ scale = steps / (hi - lo)+ steps = 3000 :: a++-- TODO: some factoring between fslider and fsliderDisplay'.++-- | Fractional slider+fsliderDisplay :: forall a. RealFrac a => (a,a) -> OWidget a+fsliderDisplay = outFun . fsliderDisplay'++-- | Fractional slider, alternative interface+fsliderDisplay' :: forall a. RealFrac a => (a,a) -> OWidget' a+fsliderDisplay' (lo,hi) = toUI $ \ win ->+ do pan <- panel win [ ]+ pbg <- get pan bgcolor+ cval <- textEntry pan [ clientSize :~ \ (Size _ h) -> Size 40 h+ , bgcolor := pbg+ , on keyboard := mempty -- ignore input+ ]+ slid <- hslider pan False (toI lo) (toI hi) [ enabled := False ]+ set pan [ layout := row 5 [ widget cval, label (show lo)+ , fill $ widget slid, label (show hi) ] ]+ let update x = do set slid [ selection := toI x ]+ set cval [ text := show x ]+ return ((update, widgetL hfill pan), mempty)+ where+ toI x = round ((x - lo) * scale)+ scale = steps / (hi - lo)+ steps = 3000 :: a++-- -- | Alternative output widget type+-- type OWidget' a = UI (Sink a)+++ -- | Boolean input widget checkBoxEntry :: IWidget Bool @@ -260,64 +326,91 @@ (checkBoxEntry,checkBoxDisplay,checkBoxDisplay') = iowidget hfill WX.checkBox checked --- | Wrap a title around a 'UI'-title :: String -> Unop (UI a)-title str = mapLayout (boxed str)+-- | Input from a \"menu\" of string choices.+choices :: [String] -> IWidget String+choices strings dflt = iwidget' select hfill combo text' dflt+ where+ combo w props =+ do ctl <- comboBox w props+ mapM_ (appendText ctl) strings+ -- I don't know why the following line is required+ -- set ctl [ text' := dflt ]+ return ctl+ text' = newAttr "choiceSelection"+ (\ w -> fmap (strings !!) (getAttr selection w))+ (\ w str -> setAttr selection w (fromJust (elemIndex str strings))) -{----------------------------------------------------------- Layout-----------------------------------------------------------}+-- | Input from a timer and a means of polling. Interval is in seconds.+-- If 'poll' is expensive, then apply 'cache' to the resulting UI.+timedPoll :: Double -> IO a -> UI (Source a)+timedPoll secs poll = toUI $ \ w ->+ do tim <- timer w [ interval := round (1000 * secs) ]+ return ((O (wEvent_ command tim, poll), mempty), mempty) --- | Lay out from top to bottom-fromTop :: Unop (UI a)-fromTop = onLayoutT fromTopL+-- | Cache a source, presumably with an expensive polling action+cache :: UI (Source a) -> UI (Source a)+cache = inUI cache'+ where+ cache' ui' w = do ((src,cxl),acts) <- ui' w+ cached <- cacheS src+ return ((cached,cxl),acts) --- | Lay out from bottom to top-fromBottom :: Unop (UI a)-fromBottom = onLayoutT fromBottomL+-- type UI' a = Win -> IO ((a, CxLayout), Source Action) --- | Lay out from left to right-fromLeft :: Unop (UI a)-fromLeft = onLayoutT fromLeftL --- | Lay out from right to left-fromRight :: Unop (UI a)-fromRight = onLayoutT fromRightL --- | Reverse layout-flipLayout :: Unop (UI a)-flipLayout = onLayoutT flipL+-- Wrap a title around a 'UI'+instance Title_f UI where title_f str = onCxLayout' (boxed str .) +-- | Simple button with value & label. Use 'button\'' for custom properties.+button :: a -> String -> UI (Event a)+button a txt = button' a [ text := txt ]++-- | Button with value & properties. If you just want a label, use 'button'.+button' :: a -> [Prop (Button ())] -> UI (Event a)+button' a props = toUI $ \ win ->+ do ctl <- WX.button win props+ return ( (replace a (wEvent_ command ctl), widgetL fill ctl)+ , mempty)++-- | Minimal size button with value & label+smallButton :: a -> String -> UI (Event a)+smallButton a txt = toUI $ \ win ->+ do ctl <- WX.smallButton win [ text := txt ]+ return ( (replace a (wEvent_ command ctl), widgetL fill ctl)+ , mempty)++-- TODO: rewrite button' in >=> style. See how it looks.+++ {----------------------------------------------------------- Misc tools+ Layout ----------------------------------------------------------} --- | Make a widget-mkWidget :: forall a widget. Widget widget- => Unop Layout -- ^ filler: id, hfill, vfill, or fill- -> (Win -> IO (widget, (a, Act)))- -> UI a-mkWidget layf f = ReaderT (WriterT . mkTag . panelWrap layf f')- where- f' :: Win -> IO (Maybe Layout, (a, Act))- f' w = liftM (first (Just . layf . widget)) (f w)+fromTop, fromBottom, fromLeft, fromRight, flipLayout :: Unop (UI a)+fromLeft = withCxMonoid (empty',leftOf)+fromTop = withCxMonoid (empty',above)+flipLayout = compCxMonoid (second flip) +fromBottom = flipLayout . fromTop+fromRight = flipLayout . fromLeft --- | Tweak the 'LayoutT'-onLayoutT :: LayoutTOp IO -> Unop (UI a)-onLayoutT f = mapReaderT' (mapWriterT' f)+withCxMonoid :: MonoidDict Layout -> Unop (UI a)+withCxMonoid dict = compCxMonoid (const dict) --- | Tweak the layout-mapLayout :: Unop Layout -> Unop (UI a)-mapLayout f = onLayoutT (mapTag f)+compCxMonoid :: Unop (MonoidDict Layout) -> Unop (UI a)+compCxMonoid f = onCxLayout' (. f) +onCxLayout :: Unop CxLayout -> Unop (UI a)+onCxLayout f = inUI $ (fmap.fmap.first.second) f --- Same defs as 'mapReaderT', 'mapWriterT', but different types+onCxLayout' :: Unop (MonoidDict Layout -> Layout) -> Unop (UI a)+onCxLayout' f' = onCxLayout (CxMonoid . f' . unCxMonoid) -mapWriterT' :: UUnop m -> UUnop (WriterT w m)-mapWriterT' f m = WriterT $ f (runWriterT m) -mapReaderT' :: UUnop m -> UUnop (ReaderT w m)-mapReaderT' f m = ReaderT $ f . runReaderT m+{----------------------------------------------------------+ Misc+----------------------------------------------------------}
− src/Graphics/UI/Phooey/TagT.hs
@@ -1,121 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--------------------------------------------------------------------------- |--- 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, UUnop, 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--type UUnop f = forall a. Unop (f a)---{----------------------------------------------------------- The /tagging/ monad transformer / tagged-value maker.- Tags may be present or absent and are combined according to- 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)))--instance Monad m => Functor (TagT tag m) where- fmap f ui = ui >>= return . f---{----------------------------------------------------------- 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/WinEvents.hs view
@@ -0,0 +1,444 @@+{-# LANGUAGE Rank2Types #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts -fno-warn-orphans #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++----------------------------------------------------------------------+-- |+-- Module : Graphics.UI.Phooey.WinEvents+-- Copyright : (c) Conal Elliott 2007+-- License : LGPL+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- Portability : ???+-- +-- Wrap window toolkit as 'Event's & 'Source's+-- TODO: Move out of phooey+----------------------------------------------------------------------++module Graphics.UI.Phooey.WinEvents+ (+ -- * 'Event's from wxHaskell-style events+ wEvent, wEvent_, attrSource+ -- * Attributes+ , InAttr, OutAttr, inAttr, outAttr+ -- * Window-based computations+ , WiU, WiE, WiS+ , WioU, Wio, WioE, WioS+ -- ** Events+ , mouseE, enter, leave, inside+ , motion, motion', motionDiff, motionDiff'+ , leftDown, leftUp, rightDown, rightUp+ -- ** Sources+ , size, leftIsDown, mouse, mbMouse, leftDragAccum+ -- * Image display+ , image, arrayImage+ -- * Making widgets with sources & sinks+ , MkCtl, mkMkCtl, MkIn, MkOut, attrMkIn, attrMkOut+ -- * Menus+ , LTree(..), lookupLTree, lookupLTrees+ , titledItem, menuEvent, menuEvent', allEnabled, menuH, menuH'+ -- * Misc+ , mkStatus, getAttr, setAttr, modifyAttr, mapAttr'+ ) where+++import Control.Applicative+import Data.Array+import Control.Monad (msum)+import Data.Monoid (mappend)+import System.IO.Unsafe (unsafePerformIO) -- for pixelArray++-- TypeCompose+import Control.Compose (Unop)+import Data.Pair (Pair(..))+import Data.Title++-- wxHaskell+import Graphics.UI.WX hiding (image,mouse,enter,leave,motion,size,drag,Event)+import qualified Graphics.UI.WX as WX+import qualified Graphics.UI.WXCore as WXC++-- DataDriven+import Data.Event+import Data.Source+-- import Data.UndoEvent -- in transition++import Graphics.UI.Phooey.Imperative++{----------------------------------------------------------+ 'Event's from wxHaskell-style events+----------------------------------------------------------}++-- | Make an 'Event' out of a wxHaskell-style event, which must be+-- /readable/ and writeable.+wEvent :: WX.Event ctl (Sink a) -> ctl -> Event a+wEvent wxe ctl = mkEvent $ modifyAttr (on wxe) ctl++-- modifyAttr :: Attr w a -> w -> Sink (a -> a)++-- | Like 'wEvent' but for wxHaskell-style events that don't take data.+wEvent_ :: WX.Event ctl (IO ()) -> ctl -> Event ()+wEvent_ wxe ctl = -- error "wEvent_ undefined"+ mkEvent $ modifyAttr (on wxe) ctl . h'+ where+ -- h :: Unop Action -> Unop (Sink ())+ -- h f snk = const (f (snk ()))+ h' :: Unop (Sink ()) -> Unop Action+ h' g act = g (const act) ()++-- | Wrap an attribute & control as a value source. Specializes to+-- 'inAttr' when @change == command@.+attrSource :: WX.Event ctl (IO ()) -> Attr ctl a -> ctl -> IO (Source a)+attrSource change attr ctl =+ do let ev = wEvent_ change ctl+ x <- get ctl attr -- initial value+ x `stepper` (ev `snapget_` get ctl attr)++{----------------------------------------------------------+ Attributes+----------------------------------------------------------}++-- | Wrapped input attribute+type InAttr ctl a = ctl -> IO (Source a)+-- | Wrapped input attribute+type OutAttr ctl a = ctl -> IO (Source (Sink a))++-- | Convert a wxHaskell-style input attribute+inAttr :: Commanding ctl => Attr ctl a -> InAttr ctl a+inAttr = attrSource command++-- | Convert a wxHaskell-style input attribute+outAttr :: Attr ctl a -> OutAttr ctl a+outAttr attr ctl = (pure.pure) $ setAttr attr ctl+++{----------------------------------------------------------+ Window-based computations+----------------------------------------------------------}++-- | Window-based computations, universal over Reactive types+type WiU a = forall ctl. Reactive ctl => ctl -> a+-- | Control-based events+type WiE a = WiU (Event a)+-- | Control-Based sources+type WiS a = WiU (Source a)++-- | Window&IO-based computations, universal over widow types+type WioU a = forall ctl. Window ctl -> IO a+-- | Control-based events+type WioE a = WioU (Event a)+-- | Control-Based sources+type WioS a = WioU (Source a)++{----------------------------------------------------------+ Events+----------------------------------------------------------}++debugEvents :: Bool+debugEvents = False++trace :: String -> Event a -> Event a+trace str | debugEvents = traceE (const str)+ | otherwise = id++-- | Filter mouse events+mouseE :: String -> (EventMouse -> Maybe a) -> WiE a+mouseE str f ctl = trace str $ (justE . fmap f) $ wEvent WX.mouse ctl++-- | Mouse enters control+enter :: WiE ()+enter = mouseE "enter" enterF+ where+ enterF (MouseEnter {}) = Just () ; enterF _ = Nothing++-- | Mouse leaves control+leave :: WiE ()+leave = mouseE "leave" leaveF+ where+ leaveF (MouseLeave {}) = Just () ; leaveF _ = Nothing++-- | Whether the mouse is in the control+inside :: WioS Bool+inside ctl =+ False `stepper`+ (replace True (enter ctl) `mappend` replace False (leave ctl))++-- | Mouse motion event. Includes wxHaskell motion, enter, leave, and+-- left/right/middle-drag. Both point and modifiers. See also 'motion',+-- which omits modifiers.+motion' :: WiE (Point,Modifiers)+motion' = mouseE "motion" motionF+ where+ motionF (MouseMotion p mods) = Just (p,mods)+ motionF (MouseEnter p mods) = Just (p,mods)+ motionF (MouseLeave p mods) = Just (p,mods)+ motionF (MouseLeftDrag p mods) = Just (p,mods)+ motionF (MouseRightDrag p mods) = Just (p,mods)+ motionF (MouseMiddleDrag p mods) = Just (p,mods)+ motionF _ = Nothing++-- | Mouse motion event. Includes wxHaskell motion, enter, leave, and+-- left/right/middle-drag. Simplified version of 'motion\'', which also+-- includes key 'Modifiers'.+motion :: WiE Point+motion = (fmap.fmap) fst motion'+++-- | Mouse motion as difference vectors. Includes 'Modifiers'.+motionDiff' :: WioE (Vector,Modifiers)+motionDiff' ctl = (fmap.fmap) f (withPrevE (motion' ctl))+ where+ f ((v1,m1),(v0,_)) = (v1 `vecBetween` v0, m1)++-- | Mouse motion as difference vectors. Simplified from 'motionDiff\''.+motionDiff :: WioE Vector+motionDiff = (fmap.fmap.fmap) fst motionDiff'++-- | Left button down+leftDown :: WiE Point+leftDown = mouseE "leftDown" leftDownF+ where+ leftDownF (MouseLeftDown wxp _) = Just wxp ; leftDownF _ = Nothing++-- | Left button up+leftUp :: WiE Point+leftUp = mouseE "leftUp" leftUpF+ where+ leftUpF (MouseLeftUp wxp _) = Just wxp ; leftUpF _ = Nothing++-- | Right button down+rightDown :: WiE Point+rightDown = mouseE "rightDown" rightDownF+ where+ rightDownF (MouseRightDown wxp _) = Just wxp ; rightDownF _ = Nothing++-- | Right button up+rightUp :: WiE Point+rightUp = mouseE "rightUp" rightUpF+ where+ rightUpF (MouseRightUp wxp _) = Just wxp ; rightUpF _ = Nothing+++{----------------------------------------------------------+ Sources+----------------------------------------------------------}++size :: (Reactive ctl, Sized ctl) => ctl -> IO (Source Size)+size = attrSource resize WX.size++-- I don't know what I'll really want for mouse position behavior. For+-- now, a maybe-valued source, being Nothing when the mouse is outside of+-- the window.++-- | Whether the left button is down+leftIsDown :: WioS Bool+leftIsDown ctl = flipFlop (leftDown ctl) (leftUp ctl)++-- | Mouse location source. Starts at point zero+mouse :: WioS Point+mouse ctl = pointZero `stepper` motion ctl++-- | Mouse location source, when in the control+mbMouse :: WioS (Maybe Point)+mbMouse ctl = maybeSource (motion ctl) (leave ctl)++-- | Accumulation of mouse movements while left-dragging+leftDragAccum :: Vector -> WioS Vector+leftDragAccum v0 ctl =+ do diff <- motionDiff ctl+ isDown <- leftIsDown ctl+ accumS v0 (fmap vecAdd (diff `whenE` isDown))++{----------------------------------------------------------+ Image display+----------------------------------------------------------}++-- | Write-only image attribute.+image :: Attr (Window w) (WXC.Image ())+image = writeAttr "image"+ (\ ctl img -> do set ctl [on paint := paintImage img]+ repaint ctl )+ where+ paintImage :: WXC.Image () -> DC () -> Rect -> IO ()+ paintImage img = \ dc _ ->+ drawImage dc img (WX.Point 0 0) []+++-- Is there any reason for imageCreateFromPixelArray to be in IO?+arrayImage :: Array WX.Point Color -> WXC.Image ()+arrayImage = unsafePerformIO . imageCreateFromPixelArray+++{----------------------------------------------------------+ Making widgets with sources & sinks+----------------------------------------------------------}++-- | Control\/widget maker+type MkCtl ctl a = Win -> [Prop ctl] -> IO (ctl, Attr ctl a)++-- | More conventional but less general interface to 'MkCtl'+mkMkCtl :: Attr ctl a -> (Win -> [Prop ctl] -> IO ctl) -> MkCtl ctl a+mkMkCtl attr = (fmap.fmap.fmap) (flip (,) attr)++-- | Make an input control+type MkIn ctl a = a -> Win -> IO (ctl, (Source a, Source (Sink a)))++-- TODO: Consider +-- +-- type MkIn a = a -> Win -> IO (Layout, Source a)+-- +-- and similarly for 'MkOut'. If so, move WinIO & WinIO' from Eros.+-- +-- Somehow accommodate the use of selectE & setToolTip in Eros.++-- | Attribute-based input control+attrMkIn:: Commanding ctl =>+ MkCtl ctl a -> [Prop ctl] -> MkIn ctl a+attrMkIn mk props = \ a win ->+ do (ctl,attr) <- mk win props+ set ctl [ attr := a ]+ src <- inAttr attr ctl+ return (ctl, (src, pure $ setAttr attr ctl))+++-- | Make an output control+type MkOut ctl a = Win -> IO (ctl, Source (Sink a))++-- | Attribute-based output control+attrMkOut :: MkCtl ctl a -> [Prop ctl] -> MkOut ctl a+attrMkOut mk props = \ win ->+ do (ctl,attr) <- mk win props+ snks <- outAttr attr ctl+ return (ctl, snks)+++{----------------------------------------------------------+ Menus+----------------------------------------------------------}++-- Non-hierarchical menus. Phase out these ones.++-- | Make an event that interfaces as a menu. The bool sources say when+-- each menu item is enabled+menuEvent :: Window w -> [Prop (Menu ())] -> [(String, Source Bool, a)] -> IO (Menu (), Event a)+menuEvent w props choices =+ do m <- menuPane props+ e <- menuEvent' w m choices+ return (m,e)++-- | Like 'menuEvent', but you supply your own menu to fill. +menuEvent' :: Window w -> Menu () -> [(String, Source Bool, a)] -> IO (Event a)+menuEvent' w m choices =+ do (sink,e) <- refEvent+ sequence_ [ do it <- menuItem m [text := name]+ runDDJoin $ setAttr enabled it <$> ables+ set w [ on (menu it) := sink a ]+ | (name,ables,a) <- choices ]+ return e++-- | Convenience for use with 'menuEvent'. Fill in @pure True@ for+-- whether-enabled sources.+allEnabled :: [(String,a)] -> [(String,Source Bool,a)]+allEnabled = fmap (\ (n,tw) -> (n,pure True,tw))++-- | Trees with labels at each internal node and leaf, plus data at the leaves.+data LTree k a = TItem k a+ | TChildren k [LTree k a]++-- | Titled LTree item. Use name for 'title' and 'TItem'+titledItem :: Title a => String -> a -> LTree String a+titledItem name utv = TItem name (title name utv)++instance Functor (LTree k) where+ fmap f (TItem k a) = TItem k (f a)+ fmap f (TChildren k ts) = TChildren k (map (fmap f) ts)+++-- | Hierarchical menu from +menuH :: Window w -> [Prop (Menu ())] -> [LTree String a] -> IO (Menu (), Event a)+menuH w props trees =+ do top <- menuPane props+ e <- menuH' w top trees+ return (top,e)++menuH' :: Window w -> Menu () -> [LTree String a] -> IO (Event a)+menuH' w top trees =+ do (sink,e) <- refEvent+ let -- populate :: Menu () -> LTree String a -> IO ()+ populate m (TItem k a) = do it <- menuItem m [text := k]+ set w [ on (menu it) := sink a ]+ populate m (TChildren k ts) = do sub <- menuPane [text := k]+ menuSub m sub []+ populates sub ts+ populates m = mapM_ (populate m)+ populates top trees+ return e++-- | Find the first item with the given label+lookupLTree :: Eq key => key -> LTree key a -> Maybe a+lookupLTree k (TItem k' a) | k' == k = Just a+ | otherwise = Nothing+lookupLTree k (TChildren _ ts) = lookupLTrees k ts++lookupLTrees :: Eq key => key -> [LTree key a] -> Maybe a+lookupLTrees k = msum . map (lookupLTree k)++{----------------------------------------------------------+ Misc GUI+----------------------------------------------------------}++-- Make a status field and return way to write to it+mkStatus :: Frame w -> [Prop StatusField] -> IO (Sink String)+mkStatus w props = do status <- statusField props+ set w [ statusbar := [status] ]+ return $ \ str -> set status [ text := str ]++-- | Get attribute. Just a flipped 'get'. Handy for partial application.+getAttr :: Attr w a -> w -> IO a+getAttr = flip get++-- | Set a single attribute. Handy for partial application.+setAttr :: Attr w a -> w -> Sink a+setAttr attr ctl x = set ctl [ attr := x ]++-- | Modify a single attribute. Handy for partial application.+modifyAttr :: Attr w a -> w -> Sink (a -> a)+modifyAttr attr ctl f = do -- putStrLn $ "modifyAttr " ++ attrName attr+ set ctl [ attr :~ f ]+++-- From Graphics.UI.WX.Attributes source:+-- +-- (@mapAttr get set attr@) maps an attribute of @Attr w a@ to+-- @Attr w b@ where (@get :: a -> b@) is used when the attribute is+-- requested and (@set :: a -> b -> a@) is applied to current+-- value when the attribute is set.++-- | Variant of 'mapAttr', in which the functions have access to control+mapAttr' :: String -> (w -> a -> IO b) -> (w -> a -> b -> IO a)+ -> Attr w a -> Attr w b+mapAttr' name getf setf attr =+ makeAttr name getter' setter' updater'+ where+ getter' w = do a <- get w attr; getf w a+ setter' w b = do a <- get w attr; a' <- setf w a b; set w [attr := a']+ updater' w f = do a <- getter' w; setter' w (f a); getter' w++-- -- unused+-- cond :: Applicative f => f Bool -> f a -> f a -> f a+-- cond = liftA3 (\ a b c -> if a then b else c)+++---- Experiment: attribute pairing. Orphan instance++instance Pair (Attr ctl) where+ a `pair` b = newAttr ("("++attrName a++","++attrName b++")")+ (liftA2 pair (getAttr a) (getAttr b))+ (\ w (u,v) -> setAttr a w u >> setAttr b w v)++-- newAttr :: String -> (w -> IO a) -> (w -> a -> IO ()) -> Attr w a++-- what about Lambda?