WinEvents.hs

{-# 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     :  BSD3
-- 
-- 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

-- import Control.Concurrent.STM

-- TypeCompose
import Data.Pair (Pair(..))
import Data.Title

-- wxHaskell
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

-- reactive
import Data.Reactive

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 -> 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 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 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


{----------------------------------------------------------
    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. WX.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) -> WioE a
mouseE str f ctl = do e <- wEvent WX.mouse ctl
                      return (trace str $ joinMaybes (fmap f e))

-- | Mouse enters control
enter :: WioE ()
enter = mouseE "enter" enterF
 where
   enterF (MouseEnter {}) = Just () ; enterF _ = Nothing

-- | Mouse leaves control
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 = 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' :: 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

-- | Mouse motion event.  Includes wxHaskell motion, enter, leave, and
-- left/right/middle-drag.  Simplified version of 'motion\'', which also
-- includes key 'Modifiers'.
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)
 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 :: WioE Point
leftDown = mouseE "leftDown" leftDownF
 where
   leftDownF (MouseLeftDown wxp _) = Just wxp ; leftDownF _ = Nothing

-- | Left button up
leftUp :: WioE Point
leftUp = mouseE "leftUp" leftUpF
 where
   leftUpF (MouseLeftUp wxp _) = Just wxp ; leftUpF _ = Nothing

-- | Right button down
rightDown :: WioE Point
rightDown = mouseE "rightDown" rightDownF
 where
   rightDownF (MouseRightDown wxp _) = Just wxp ; rightDownF _ = Nothing

-- | Right button up
rightUp :: WioE Point
rightUp = mouseE "rightUp" rightUpF
 where
   rightUpF (MouseRightUp wxp _) = Just wxp ; rightUpF _ = Nothing


{----------------------------------------------------------
    Sources
----------------------------------------------------------}

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
-- 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 = flipFlop' leftDown leftUp

-- | 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 = 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
     return $ v0 `accumR` (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 (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

-- | 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 (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 ]
         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?