module Graphics.UI.Phooey.WinEvents
(
wEvent, wEvent_, attrSource
, InAttr, OutAttr, inAttr, outAttr
, WiU, WiE, WiS
, WioU, Wio, WioE, WioS
, mouseE, enter, leave, inside
, motion, motion', motionDiff, motionDiff'
, leftDown, leftUp, rightDown, rightUp
, size, leftIsDown, mouse, mbMouse, leftDragAccum
, image, arrayImage
, MkCtl, mkMkCtl, MkIn, MkOut, attrMkIn, attrMkOut
, LTree(..), lookupLTree, lookupLTrees
, titledItem, menuEvent, menuEvent', allEnabled, menuH, menuH'
, 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)
import Data.Pair (Pair(..))
import Data.Title
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
import Data.Reactive
import Graphics.UI.Phooey.Imperative
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
wEvent_ :: WX.Event ctl Action -> ctl -> IO (Event ())
wEvent_ wxe ctl = do (e,snk) <- mkEvent
modifyAttr (on wxe) ctl (`mappend` snk ())
return e
attrSource :: WX.Event ctl Action -> Attr ctl a -> ctl -> IO (Source a)
attrSource change attr ctl =
do (e,snk) <- mkEvent
modifyAttr (on change) ctl (`mappend` (get ctl attr >>= snk))
x0 <- get ctl attr
return $ x0 `stepper` e
type InAttr ctl a = ctl -> IO (Source a)
type OutAttr ctl a = ctl -> IO (Source (Sink a))
inAttr :: Commanding ctl => Attr ctl a -> InAttr ctl a
inAttr = attrSource command
outAttr :: Attr ctl a -> OutAttr ctl a
outAttr attr ctl = (pure.pure) $ setAttr attr ctl
type WiU a = forall ctl. WX.Reactive ctl => ctl -> a
type WiE a = WiU (Event a)
type WiS a = WiU (Source a)
type WioU a = forall ctl. Window ctl -> IO a
type WioE a = WioU (Event a)
type WioS a = WioU (Source a)
debugEvents :: Bool
debugEvents = False
trace :: String -> Event a -> Event a
trace str | debugEvents = traceE (const str)
| otherwise = id
mouseE :: String -> (EventMouse -> Maybe a) -> WioE a
mouseE str f ctl = do e <- wEvent WX.mouse ctl
return (trace str $ joinMaybes (fmap f e))
enter :: WioE ()
enter = mouseE "enter" enterF
where
enterF (MouseEnter {}) = Just () ; enterF _ = Nothing
leave :: WioE ()
leave = mouseE "leave" leaveF
where
leaveF (MouseLeave {}) = Just () ; leaveF _ = Nothing
flipFlop' :: WioE a -> WioE b -> WioS Bool
flipFlop' a b = liftA2 (liftA2 flipFlop) a b
inside :: WioS Bool
inside = flipFlop' enter leave
motion' :: WioE (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
motion :: WioE Point
motion = (fmap.fmap.fmap) fst motion'
motionDiff' :: WioE (Vector,Modifiers)
motionDiff' ctl = (fmap.fmap) f (withPrevE <$> motion' ctl)
where
f ((v1,m1),(v0,_)) = (v1 `vecBetween` v0, m1)
motionDiff :: WioE Vector
motionDiff = (fmap.fmap.fmap) fst motionDiff'
leftDown :: WioE Point
leftDown = mouseE "leftDown" leftDownF
where
leftDownF (MouseLeftDown wxp _) = Just wxp ; leftDownF _ = Nothing
leftUp :: WioE Point
leftUp = mouseE "leftUp" leftUpF
where
leftUpF (MouseLeftUp wxp _) = Just wxp ; leftUpF _ = Nothing
rightDown :: WioE Point
rightDown = mouseE "rightDown" rightDownF
where
rightDownF (MouseRightDown wxp _) = Just wxp ; rightDownF _ = Nothing
rightUp :: WioE Point
rightUp = mouseE "rightUp" rightUpF
where
rightUpF (MouseRightUp wxp _) = Just wxp ; rightUpF _ = Nothing
size :: (WX.Reactive ctl, Sized ctl) => ctl -> IO (Source Size)
size = attrSource resize WX.size
leftIsDown :: WioS Bool
leftIsDown = flipFlop' leftDown leftUp
mouse :: WioS Point
mouse ctl = (pointZero `stepper`) <$> motion ctl
mbMouse :: WioS (Maybe Point)
mbMouse = liftA2 (liftA2 maybeR) motion leave
leftDragAccum :: Vector -> WioS Vector
leftDragAccum v0 ctl =
do diff <- motionDiff ctl
isDown <- leftIsDown ctl
return $ v0 `accumR` (vecAdd <$> (diff `whenE` isDown))
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) []
arrayImage :: Array WX.Point Color -> WXC.Image ()
arrayImage = unsafePerformIO . imageCreateFromPixelArray
type MkCtl ctl a = Win -> [Prop ctl] -> IO (ctl, Attr ctl a)
mkMkCtl :: Attr ctl a -> (Win -> [Prop ctl] -> IO ctl) -> MkCtl ctl a
mkMkCtl attr = (fmap.fmap.fmap) (flip (,) attr)
type MkIn ctl a = a -> Win -> IO (ctl, (Source a, Source (Sink a)))
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))
type MkOut ctl a = Win -> IO (ctl, Source (Sink a))
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)
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)
menuEvent' :: Window w -> Menu () -> [(String, Source Bool, a)] -> IO (Event a)
menuEvent' w m choices =
do (e,snk) <- mkEvent
sequence_ [ do it <- menuItem m [text := name]
forkR $ setAttr enabled it <$> ables
set w [ on (menu it) := snk a ]
| (name,ables,a) <- choices ]
return e
allEnabled :: [(String,a)] -> [(String,Source Bool,a)]
allEnabled = fmap (\ (n,tw) -> (n,pure True,tw))
data LTree k a = TItem k a
| TChildren k [LTree k a]
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)
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 (e,sink) <- mkEvent
let
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
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)
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 ]
getAttr :: Attr w a -> w -> IO a
getAttr = flip get
setAttr :: Attr w a -> w -> Sink a
setAttr attr ctl x = set ctl [ attr := x ]
modifyAttr :: Attr w a -> w -> Sink (a -> a)
modifyAttr attr ctl f = do
set ctl [ attr :~ f ]
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
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)