phooey 1.4 → 2.0
raw patch · 8 files changed
+199/−174 lines, 8 filesdep +reactivedep −DataDriven
Dependencies added: reactive
Dependencies removed: DataDriven
Files
- CHANGES +1/−0
- phooey.cabal +6/−3
- src/Examples/Applicative.hs +12/−3
- src/Examples/Monad.hs +65/−61
- src/Graphics/UI/Phooey/Applicative.hs +7/−15
- src/Graphics/UI/Phooey/Imperative.hs +8/−4
- src/Graphics/UI/Phooey/Monad.hs +49/−41
- src/Graphics/UI/Phooey/WinEvents.hs +51/−47
CHANGES view
@@ -2,6 +2,7 @@ == Version 1.4 == +* Switched from DataDriven to reactive. * Exposed a few more functions * WinEvents: motion' and motionDiff' carry key modifiers (shift, control, etc) * Menu-related functions in WinEvents
phooey.cabal view
@@ -1,5 +1,5 @@ Name: phooey-Version: 1.4+Version: 2.0 Synopsis: Functional user interfaces Category: User Interfaces Description:@@ -10,6 +10,8 @@ . Try out the examples in @src\/Examples\/@. .+ Because this library uses reactive, compile apps with @-threaded@.+ . See also . * The project wiki page <http://haskell.org/haskellwiki/phooey>@@ -33,13 +35,14 @@ Stability: provisional Hs-Source-Dirs: src Extensions: CPP, Arrows-Build-Depends: base, array, mtl, wx, wxcore, TypeCompose>=0.2, DataDriven+Build-Depends: base, array, mtl, wx, wxcore, TypeCompose>=0.2, reactive Exposed-Modules: - Graphics.UI.Phooey.WinEvents Graphics.UI.Phooey.Imperative+ Graphics.UI.Phooey.WinEvents Graphics.UI.Phooey.Monad Graphics.UI.Phooey.Applicative Extra-Source-Files: Examples.Monad Examples.Applicative ghc-options: -O -Wall+
src/Examples/Applicative.hs view
@@ -2,7 +2,7 @@ -- | -- Module : Examples.Applicative -- Copyright : (c) Conal Elliott 2007--- License : LGPL+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental@@ -15,12 +15,14 @@ import Control.Applicative import Data.Monoid+import System.Time -- TypeCompose import Data.Title--- DataDriven-import Data.Source+-- reactive+import Data.Reactive +-- phooey import Graphics.UI.Phooey.Applicative h :: UI String@@ -55,3 +57,10 @@ where i = title "x" $ fslider (0,10) (3 :: Float) o = title "square root" $ fsliderDisplay (0,4)+++calendarTime :: Double -> UI CalendarTime+calendarTime secs = timedPoll secs (getClockTime >>= toCalendarTime)++clock :: UI Action+clock = stringDisplay <*> (calendarTimeToString <$> calendarTime 1)
src/Examples/Monad.hs view
@@ -7,7 +7,7 @@ -- | -- Module : Examples.Monad -- Copyright : (c) Conal Elliott 2007--- License : LGPL+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental@@ -36,12 +36,12 @@ import Control.Compose (Unop,Binop) import Data.Title --- DataDriven-import Data.Event-import Data.Source+-- reactive+import Data.Reactive -- Phooey import Graphics.UI.Phooey.Monad+import Graphics.UI.Phooey.WinEvents {---------------------------------------------------------- Simplest examples@@ -187,6 +187,7 @@ upDown :: Num a => UIE (a -> a) upDown = smallButton (+1) "up" `mappend` smallButton (subtract 1) "down" +-- More explicit implementation of the same. upDown' :: Num a => UIE (a -> a) upDown' = do up <- smallButton (+1) "up" down <- smallButton (subtract 1) "down"@@ -197,8 +198,13 @@ counter = title "Counter" $ fromLeft $ do e <- upDown -- Apply each increment/decrement cumulatively- 0 `accumS` e >>= showDisplay+ showDisplay (0 `accumR` e) +-- Point-free variation+counter' :: UI ()+counter' = title "Counter" $ fromLeft $+ showDisplay =<< (0 `accumR`) <$> upDown+ -- 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@@ -220,8 +226,7 @@ counter2 :: UI () counter2 = title "Counter" $ fromLeft $ do ud <- upDown2- n <- (fmap.fmap) getSum (monoidS ud)- showDisplay n+ showDisplay $ fmap getSum (monoidR ud) {----------------------------------------------------------@@ -260,18 +265,9 @@ 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-+showKeys key = title "keys pressed" $ stringDisplay $ fmap reverse chars+ where chars = "" `accumR` fmap (:) key+ -- The calculator state is a number being formed and a continuation. type CState = (Int, Unop Int)@@ -305,15 +301,9 @@ 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+showCalc key = title "result" $ showDisplay $ fmap fst states+ where+ states = startCS `accumR` fmap cmd key ---- Redo with monoids@@ -322,7 +312,7 @@ testKeys2 :: UI () testKeys2 = title "Calculator key test - monoid version" $ do key <- calcKeys- str <- monoidS (fmap (:[]) key)+ let str = monoidR (fmap (:[]) key) title "chars" $ stringDisplay str -- Hm. I think the strings get combined in the worst possible way, by@@ -333,8 +323,8 @@ calc2 :: UI () calc2 = title "Calculator - monoid version" $ do key <- calcKeys- endos <- monoidS (fmap (Endo . cmd) key)- let n = fmap (fst . ($ startCS) . appEndo) endos+ let endos = monoidR (fmap (Endo . cmd) key)+ n = fmap (fst . ($ startCS) . appEndo) endos title "result" $ showDisplay n -- As mentioned above, I expect this @calc2@ to be very wasteful,@@ -355,60 +345,74 @@ ---- Tests: move to Test.hs + {---------------------------------------------------------- Tests ----------------------------------------------------------} -test = mapM_ runUI [t0,t1,t2,t3,t4,t5,t6]+test = mapM_ runUI [t0,t1,t3,t5,t6,t7] -- basic counter t0 = do up <- button (+1) "up"- n <- 0 `accumS` up- showDisplay n+ showDisplay $ 0 `accumR` up -- "up" only works the first time t1 = do up <- button (+1) "up"- n <- 0 `accumS` once up- showDisplay n+ showDisplay $ 0 `accumR` once up --- "up" works until "stop"-t2 = do stop <- button () "stop"- up <- button (+1) "up"- n <- 0 `accumS` (up `before` stop)- showDisplay n+-- -- "up" works until "stop"+-- t2 = do stop <- button () "stop"+-- up <- button (+1) "up"+-- showDisplay $ 0 `accumR` (up `before` stop) -- 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+ showDisplay $ countR (poke `mappend` dont) --- 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+-- style variation+t3' = do buttons <- button () "poke me" `mappend` button () "don't poke me"+ showDisplay $ countR buttons -- 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+ showDisplay $ 0 `accumR` (up `mappend` down) -- value pairs t6 = do up <- button (+1) "up"- e <- 0 `accumE` up- showDisplay =<< 0 `stepper` e- e' <- withPrevE e- showDisplay =<< (10,10) `stepper` e'+ let e = 0 `accumE` up+ showDisplay $ 0 `stepper` e+ let 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'+ let e = 0 `accumE` up+ showDisplay $ 0 `stepper` e+ let e' = withPrevE (pure 0 `mappend` e)+ showDisplay $ (10,10) `stepper` e' +t8 = do y <- button () "yes"+ n <- button () "no"+ showDisplay $ flipFlop y n++t9 = testWidget (leftDragAccum WX.vecZero) >>= showDisplay++t10 = testWidget mbMouse >>= showDisplay+t11 = testWidget clickPos >>= showDisplay++clickPos :: WioS (Maybe Point)+clickPos win = do ld <- leftDown win+ mp <- mbMouse win+ return $ Nothing `stepper` (ld `snapshot_` mp)++clickT :: WioS Int+clickT win = do ld <- leftDown win+ return $ 0 `stepper` (ld `snapshot_` t)+ where+ t = 1 `stepper` pure 2++t12 = testWidget clickT >>= showDisplay+t13 = showDisplay $ 1 `stepper` pure 2+t14 = showDisplay $ 1 `stepper` (pure () `snapshot_` pure 2)
src/Graphics/UI/Phooey/Applicative.hs view
@@ -6,7 +6,7 @@ -- | -- Module : Graphics.UI.Phooey.Applicative -- Copyright : (c) Conal Elliott 2007--- License : LGPL+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental@@ -27,9 +27,10 @@ , stringEntry, stringDisplay, showDisplay , islider, isliderDisplay , fslider, fsliderDisplay- , checkBoxEntry, checkBoxDisplay, choices, timedPoll, cache+ , checkBoxEntry, checkBoxDisplay, choices+ , timedPoll -- * Explicit layout- , fromTop, fromBottom, fromLeft, fromRight, flipLayout+ , fromTop, fromBottom, fromLeft, fromRight ) where -- Base@@ -39,11 +40,10 @@ import Control.Compose import Data.Title --- DataDriven-import Data.Event (Action,Sink)-import Data.Source (Source)+-- reactive+import Data.Reactive --- Phooey+-- phooey import qualified Graphics.UI.Phooey.Monad as M @@ -134,11 +134,7 @@ 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) @@ -161,10 +157,6 @@ -- | Lay out from right to left fromRight :: Unop (UI a) fromRight = inO M.fromRight---- | Reverse layout-flipLayout :: Unop (UI a)-flipLayout = inO M.flipLayout -----
src/Graphics/UI/Phooey/Imperative.hs view
@@ -2,7 +2,7 @@ -- | -- Module : Graphics.UI.Phooey.Imperative -- Copyright : (c) Conal Elliott 2006--- License : LGPL+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : provisional@@ -14,7 +14,8 @@ module Graphics.UI.Phooey.Imperative ( -- * Widget & layout tools- above, leftOf, empty', hwidget,lhwidget ,hsliderDyn+ above, below, leftOf, rightOf, empty'+ , hwidget,lhwidget ,hsliderDyn -- * Simple abstraction around widget containers and frames , Win, Wio, runWio )@@ -29,10 +30,13 @@ Widget & layout tools -----------------------------------------------------------------------} --- | Binary layout combinator-above, leftOf :: Layout -> Layout -> Layout+-- | Binary layout combinators+above, below, leftOf, rightOf :: Layout -> Layout -> Layout la `above` lb = fill (column 0 [la,lb]) la `leftOf` lb = fill (row 0 [la,lb])++below = flip above+rightOf = flip leftOf -- | A stretchy empty layout empty' :: Layout
src/Graphics/UI/Phooey/Monad.hs view
@@ -10,7 +10,7 @@ -- | -- Module : Graphics.UI.Phooey.Monad -- Copyright : (c) Conal Elliott 2006--- License : LGPL+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : provisional@@ -27,10 +27,10 @@ CxLayout, UI, UI', biUI, inUI, toUI, fromUI , UIE, UIS , runUI, runNamedUI, act- , accumE, accumS, monoidE, monoidS+ -- , accumE, accumS, monoidE, monoidS -- * Tools for high-level widgets , IWidget, OWidget, OWidget', IOWidget, MkWidget, widgetL- , iwidget, iwidget', owidget, owidget', iowidget+ , iwidget, iwidget', owidget, owidget', iowidget, testWidget -- * Some high-level widgets , stringEntry, stringDisplay, stringDisplay' , showDisplay, showDisplay'@@ -38,9 +38,10 @@ , fslider, fsliderDisplay, fsliderDisplay' , checkBoxEntry, checkBoxDisplay, checkBoxDisplay' , button, button', smallButton- , choices, timedPoll, cache+ , choices+ , timedPoll -- * Explicit layout- , fromTop, fromBottom, fromLeft, fromRight, flipLayout+ , fromTop, fromBottom, fromLeft, fromRight ) where import Control.Applicative@@ -55,20 +56,21 @@ -- wxHaskell import Graphics.UI.WX hiding (Event,button,smallButton) import qualified Graphics.UI.WX as WX+import qualified Graphics.UI.WXCore as WXC -- TypeCompose-import Control.Compose (Unop,(:.)(..))+import Control.Compose (Unop,Binop) import Data.CxMonoid import Data.Bijection import Data.Title --- DataDriven-import Data.Source-import Data.Event+-- reactive+import Data.Reactive -- Phooey-import Graphics.UI.Phooey.Imperative (Win,empty',above,leftOf,hwidget)-import Graphics.UI.Phooey.WinEvents (attrSource,getAttr,setAttr,wEvent_)+import Graphics.UI.Phooey.Imperative+ (Win,empty',above,below,leftOf,rightOf)+import Graphics.UI.Phooey.WinEvents (attrSource,getAttr,setAttr,wEvent_,WioS) {---------------------------------------------------------- The UI monad@@ -139,8 +141,8 @@ win <- panel f [] (((),cxl),acts) <- fromUI ui win set win [ layout := unCxMonoid cxl (empty',above) ]- set f [ layout := hwidget win, visible := True ]- runDDJoin acts+ set f [ layout := fill (widget win), visible := True ]+ forkR acts -- | Move an action source into position to be executed act :: UI (Source Action) -> UI ()@@ -211,6 +213,12 @@ iowidget filler mkWid attr = (iwidget filler mkWid attr, owidget filler mkWid attr, owidget' filler mkWid attr) +-- | For testing out WinEvents+testWidget :: WioS a -> UI (Source a)+testWidget wios = toUI $ \ win ->+ do pan <- panel win [ size := Size 20 20 ]+ s <- wios pan+ return ((s, widgetL fill pan), mempty) {---------------------------------------------------------- Some high-level widgets@@ -265,7 +273,7 @@ fslider (lo,hi) initial = toUI $ \ win -> do pan <- panel win [ ] pbg <- get pan bgcolor- cval <- textEntry pan [ clientSize :~ \ (Size _ h) -> Size 40 h+ cval <- textEntry pan [ clientSize :~ \ (Size _ h) -> Size 50 h , bgcolor := pbg ] slid <- hslider pan False (toI lo) (toI hi)@@ -276,7 +284,7 @@ isrc <- attrSource command selection slid let fsrc = fmap toF isrc -- update the value display when it changes- runDDJoin $ (setAttr text cval . show) <$> fsrc+ forkR $ (setText cval . show) <$> fsrc return ((fsrc, widgetL hfill pan), mempty) where toI x = round ((x - lo) * scale)@@ -284,6 +292,13 @@ scale = steps / (hi - lo) steps = 3000 :: a ++-- Set the text attribute, and make sure the beginning is visible+setText :: TextCtrl a -> String -> IO ()+setText ctl str =+ do setAttr text ctl str+ WXC.textCtrlSetInsertionPoint ctl 0+ -- TODO: some factoring between fslider and fsliderDisplay'. -- | Fractional slider@@ -295,7 +310,7 @@ fsliderDisplay' (lo,hi) = toUI $ \ win -> do pan <- panel win [ ] pbg <- get pan bgcolor- cval <- textEntry pan [ clientSize :~ \ (Size _ h) -> Size 40 h+ cval <- textEntry pan [ clientSize :~ \ (Size _ h) -> Size 50 h , bgcolor := pbg , on keyboard := mempty -- ignore input ]@@ -303,7 +318,7 @@ 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 ]+ setText cval (show x) return ((update, widgetL hfill pan), mempty) where toI x = round ((x - lo) * scale)@@ -346,15 +361,10 @@ 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)---- | 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)+ (ev,snk) <- mkEvent+ set tim [ on command := poll >>= snk ]+ a0 <- poll+ return ((a0 `stepper` ev, mempty), mempty) -- type UI' a = Win -> IO ((a, CxLayout), Source Action) @@ -371,18 +381,20 @@ -- | 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)+ do ctl <- WX.button win props+ press <- wEvent_ command ctl+ return ( (replace a press, 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)+ press <- wEvent_ command ctl+ return ( (replace a press, widgetL fill ctl) , mempty) --- TODO: rewrite button' in >=> style. See how it looks.+-- TODO: rewrite button', smallButton in >=> style. See how it looks. @@ -390,13 +402,14 @@ Layout ----------------------------------------------------------} -fromTop, fromBottom, fromLeft, fromRight, flipLayout :: Unop (UI a)-fromLeft = withCxMonoid (empty',leftOf)-fromTop = withCxMonoid (empty',above)-flipLayout = compCxMonoid (second flip)+fromTop, fromBottom, fromLeft, fromRight :: Unop (UI a)+fromTop = withDir above+fromBottom = withDir below+fromLeft = withDir leftOf+fromRight = withDir rightOf -fromBottom = flipLayout . fromTop-fromRight = flipLayout . fromLeft+withDir :: Binop Layout -> Unop (UI a)+withDir op = withCxMonoid (empty',op) withCxMonoid :: MonoidDict Layout -> Unop (UI a) withCxMonoid dict = compCxMonoid (const dict)@@ -409,8 +422,3 @@ onCxLayout' :: Unop (MonoidDict Layout -> Layout) -> Unop (UI a) onCxLayout' f' = onCxLayout (CxMonoid . f' . unCxMonoid)---{----------------------------------------------------------- Misc-----------------------------------------------------------}
src/Graphics/UI/Phooey/WinEvents.hs view
@@ -8,7 +8,7 @@ -- | -- Module : Graphics.UI.Phooey.WinEvents -- Copyright : (c) Conal Elliott 2007--- License : LGPL+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental@@ -51,20 +51,19 @@ import Data.Monoid (mappend) import System.IO.Unsafe (unsafePerformIO) -- for pixelArray +-- import Control.Concurrent.STM+ -- 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 Graphics.UI.WX hiding (image,mouse,enter,leave,motion,size,drag,Event,Reactive) 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+-- reactive+import Data.Reactive import Graphics.UI.Phooey.Imperative @@ -74,29 +73,31 @@ -- | 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+wEvent :: WX.Event ctl (Sink a) -> ctl -> IO (Event a)+wEvent wxe ctl = do (e,snk) <- mkEvent+ modifyAttr (on wxe) ctl (`mappend` snk)+ return e -- 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) ()+wEvent_ :: WX.Event ctl Action -> ctl -> IO (Event ())+wEvent_ wxe ctl = do (e,snk) <- mkEvent+ modifyAttr (on wxe) ctl (`mappend` snk ())+ return e +-- TODO: refactor wEvent & wEvent_ & maybe attrSource+ -- | 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)+-- 'inAttr' when @change ==@ 'command'.+attrSource :: WX.Event ctl Action -> 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)+ do (e,snk) <- mkEvent+ modifyAttr (on change) ctl (`mappend` (get ctl attr >>= snk))+ x0 <- get ctl attr+ return $ x0 `stepper` e + {---------------------------------------------------------- Attributes ----------------------------------------------------------}@@ -120,7 +121,7 @@ ----------------------------------------------------------} -- | Window-based computations, universal over Reactive types-type WiU a = forall ctl. Reactive ctl => ctl -> a+type WiU a = forall ctl. WX.Reactive ctl => ctl -> a -- | Control-based events type WiE a = WiU (Event a) -- | Control-Based sources@@ -145,31 +146,34 @@ | 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+mouseE :: String -> (EventMouse -> Maybe a) -> WioE a+mouseE str f ctl = do e <- wEvent WX.mouse ctl+ return (trace str $ joinMaybes (fmap f e)) -- | Mouse enters control-enter :: WiE ()+enter :: WioE () enter = mouseE "enter" enterF where enterF (MouseEnter {}) = Just () ; enterF _ = Nothing -- | Mouse leaves control-leave :: WiE ()+leave :: WioE () leave = mouseE "leave" leaveF where leaveF (MouseLeave {}) = Just () ; leaveF _ = Nothing +-- WioU-lifted flipFlop+flipFlop' :: WioE a -> WioE b -> WioS Bool+flipFlop' a b = liftA2 (liftA2 flipFlop) a b+ -- | Whether the mouse is in the control inside :: WioS Bool-inside ctl =- False `stepper`- (replace True (enter ctl) `mappend` replace False (leave ctl))+inside = flipFlop' enter leave -- | 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' :: WioE (Point,Modifiers) motion' = mouseE "motion" motionF where motionF (MouseMotion p mods) = Just (p,mods)@@ -183,13 +187,13 @@ -- | 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'+motion :: WioE Point+motion = (fmap.fmap.fmap) fst motion' -- | Mouse motion as difference vectors. Includes 'Modifiers'. motionDiff' :: WioE (Vector,Modifiers)-motionDiff' ctl = (fmap.fmap) f (withPrevE (motion' ctl))+motionDiff' ctl = (fmap.fmap) f (withPrevE <$> motion' ctl) where f ((v1,m1),(v0,_)) = (v1 `vecBetween` v0, m1) @@ -198,25 +202,25 @@ motionDiff = (fmap.fmap.fmap) fst motionDiff' -- | Left button down-leftDown :: WiE Point+leftDown :: WioE Point leftDown = mouseE "leftDown" leftDownF where leftDownF (MouseLeftDown wxp _) = Just wxp ; leftDownF _ = Nothing -- | Left button up-leftUp :: WiE Point+leftUp :: WioE Point leftUp = mouseE "leftUp" leftUpF where leftUpF (MouseLeftUp wxp _) = Just wxp ; leftUpF _ = Nothing -- | Right button down-rightDown :: WiE Point+rightDown :: WioE Point rightDown = mouseE "rightDown" rightDownF where rightDownF (MouseRightDown wxp _) = Just wxp ; rightDownF _ = Nothing -- | Right button up-rightUp :: WiE Point+rightUp :: WioE Point rightUp = mouseE "rightUp" rightUpF where rightUpF (MouseRightUp wxp _) = Just wxp ; rightUpF _ = Nothing@@ -226,7 +230,7 @@ Sources ----------------------------------------------------------} -size :: (Reactive ctl, Sized ctl) => ctl -> IO (Source Size)+size :: (WX.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@@ -235,22 +239,22 @@ -- | Whether the left button is down leftIsDown :: WioS Bool-leftIsDown ctl = flipFlop (leftDown ctl) (leftUp ctl)+leftIsDown = flipFlop' leftDown leftUp -- | Mouse location source. Starts at point zero mouse :: WioS Point-mouse ctl = pointZero `stepper` motion ctl+mouse ctl = (pointZero `stepper`) <$> motion ctl -- | Mouse location source, when in the control mbMouse :: WioS (Maybe Point)-mbMouse ctl = maybeSource (motion ctl) (leave ctl)+mbMouse = liftA2 (liftA2 maybeR) motion leave -- | 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))+ return $ v0 `accumR` (vecAdd <$> (diff `whenE` isDown)) {---------------------------------------------------------- Image display@@ -332,10 +336,10 @@ -- | 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+ do (e,snk) <- mkEvent sequence_ [ do it <- menuItem m [text := name]- runDDJoin $ setAttr enabled it <$> ables- set w [ on (menu it) := sink a ]+ forkR $ setAttr enabled it <$> ables+ set w [ on (menu it) := snk a ] | (name,ables,a) <- choices ] return e @@ -366,7 +370,7 @@ menuH' :: Window w -> Menu () -> [LTree String a] -> IO (Event a) menuH' w top trees =- do (sink,e) <- refEvent+ do (e,sink) <- mkEvent 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 ]