module WXFruit where
import qualified Graphics.UI.WX as WX
import qualified Graphics.UI.WXCore as WXCore
import FRP.Yampa
import FRP.Yampa.Utilities
import Control.Arrow
import Data.IORef
import System.Time
import Control.Category
import Prelude hiding (id, (.))
import qualified Prelude (id, (.))
data WXRawInput = WXRawInput {
wxMousePos :: WX.Point
}
data WXWidgetResp = WXWInit
| WXWButtonCreateResp (WX.Button ())
| WXWTextCreateResp (WX.StaticText ())
| WXWPictureCreateResp (WX.Panel ())
| WXWSliderCreateResp (WX.Slider ())
| WXWButtonCommandEvent
| WXWSliderCommandEvent Int
| WXWDeComp (Event WXWidgetResp,Event WXWidgetResp)
data WXWidgetReq = WXWButtonCreateReq WXButtonState
| WXWTextCreateReq WXTextState
| WXWPictureCreateReq WXPictureState
| WXWSliderCreateReq WXSliderState
| WXWButtonSetReq (WX.Button ()) WXButtonState
| WXWTextSetReq (WX.StaticText ()) WXTextState
| WXWPictureSetReq (WX.Panel ()) WXPictureState
| WXWSliderSetReq (WX.Slider ()) WXSliderState
| WXWComp Orientation (Event WXWidgetReq,Event WXWidgetReq)
data Orientation = Horiz | Vert
deriving (Eq)
type Widget a b = SF (WXRawInput,Event WXWidgetResp,a) (Event WXWidgetReq,b)
newtype WXGUI b c = WXGUI (Widget b c)
wxUnGUI :: WXGUI b c -> Widget b c
wxUnGUI (WXGUI w) = w
wxSF :: SF b c -> WXGUI b c
wxSF sf = WXGUI $ proc (_,_,b) -> do
c <- sf -< b
returnA -< (noEvent,c)
wxArr :: (b -> c) -> WXGUI b c
wxArr f = wxSF (arr f)
decompResp :: Event WXWidgetResp -> (Event WXWidgetResp,Event WXWidgetResp)
decompResp (Event WXWInit) = (Event WXWInit,Event WXWInit)
decompResp (Event (WXWDeComp (resp0,resp1))) = (resp0,resp1)
decompResp _ = (noEvent,noEvent)
compReq :: Orientation -> Event WXWidgetReq -> Event WXWidgetReq -> Event WXWidgetReq
compReq _ NoEvent NoEvent = noEvent
compReq orient req0 req1 = Event (WXWComp orient (req0,req1))
wxGComp :: Orientation -> WXGUI b c -> WXGUI c d -> WXGUI b d
wxGComp orient (WXGUI w1) (WXGUI w2) = WXGUI $ proc (inp,resp,b) -> do
let (resp1,resp2) = decompResp resp
(req1,c) <- w1 -< (inp,resp1,b)
(req2,d) <- w2 -< (inp,resp2,c)
returnA -< (compReq orient req1 req2,d)
wxComp :: WXGUI b c -> WXGUI c d -> WXGUI b d
wxComp = wxGComp Horiz
wxFirst :: WXGUI b c -> WXGUI (b,d) (c,d)
wxFirst (WXGUI w) = WXGUI $ proc (inp,resp,(b,d)) -> do
(req,c) <- w -< (inp,resp,b)
returnA -< (req,(c,d))
instance Arrow WXGUI where
arr = wxArr
first = wxFirst
instance Category WXGUI where
(.) = flip wxComp
id = arr Prelude.id
wxLoop :: WXGUI (b,d) (c,d) -> WXGUI b c
wxLoop (WXGUI w) = WXGUI $ proc (inp,resp,b) -> do
rec (req,(c,d)) <- w -< (inp,resp,(b,d))
returnA -< (req,c)
instance ArrowLoop WXGUI where
loop = wxLoop
newtype WXBox b c = WXBox (Orientation -> WXGUI b c)
wxBox :: WXGUI b c -> WXBox b c
wxBox w = WXBox (const w)
wxCompBox :: WXBox b c -> WXBox c d -> WXBox b d
wxCompBox (WXBox b1f) (WXBox b2f) = WXBox $
\orient -> wxGComp orient (b1f orient) (b2f orient)
wxFirstBox :: WXBox b c -> WXBox (b,d) (c,d)
wxFirstBox (WXBox bf) = WXBox $ \orient -> first (bf orient)
instance Arrow WXBox where
arr = wxBox . arr
first = wxFirstBox
instance Category WXBox where
(.) = flip wxCompBox
id = arr Prelude.id
wxLoopBox :: WXBox (b,d) (c,d) -> WXBox b c
wxLoopBox (WXBox bf) = WXBox $ \orient -> loop (bf orient)
instance ArrowLoop WXBox where
loop = wxLoopBox
wxBoxGUI :: Widget b c -> WXBox b c
wxBoxGUI = wxBox . WXGUI
wxBoxSF :: SF b c -> WXBox b c
wxBoxSF = wxBox . wxSF
wxHBox :: WXBox b c -> WXGUI b c
wxHBox (WXBox bf) = bf Horiz
wxVBox :: WXBox b c -> WXGUI b c
wxVBox (WXBox bf) = bf Vert
maybeChanged :: Eq a => a -> a -> Maybe ()
maybeChanged s s' = if s == s' then Nothing else Just ()
data WXButtonState = WXButtonState {
bsLabel :: String,
bsEnabled :: Bool
} deriving (Eq, Show)
type WXButtonConf = WXButtonState -> WXButtonState
btext :: String -> WXButtonConf
btext l bs = bs {bsLabel = l}
benabled :: Bool -> WXButtonConf
benabled e bs = bs {bsEnabled = e}
wxbutton :: WXButtonConf -> WXBox WXButtonConf (Event ())
wxbutton conf0 =
let
defState = WXButtonState {bsLabel = "Default", bsEnabled = True}
initState = conf0 defState
maybeCreate (WXWButtonCreateResp b) = Just (True,b)
maybeCreate _ = Nothing
maybeCommand WXWButtonCommandEvent = Just ()
maybeCommand _ = Nothing
in wxBoxGUI $ proc (_,resp,conf) -> do
rec state <- iPre initState -< conf state
stateChanged <- edgeBy maybeChanged initState -< state
(isCreated,button) <- hold (False,undefined) -< mapFilterE maybeCreate resp
let doCreate = if isCreated then noEvent else Event ()
let req = lMerge (tag doCreate (WXWButtonCreateReq state))
(tag stateChanged (WXWButtonSetReq button state))
let press = mapFilterE maybeCommand resp
returnA -< (req,press)
data WXTextState = WXTextState {
tsLabel :: String
} deriving (Eq, Show)
type WXTextConf = WXTextState -> WXTextState
ttext :: String -> WXTextConf
ttext l ts = ts {tsLabel = l}
wxtext :: WXTextConf -> WXBox WXTextConf ()
wxtext conf0 =
let
defState = WXTextState {tsLabel = "Default"}
initState = conf0 defState
maybeCreate (WXWTextCreateResp t) = Just (True,t)
maybeCreate _ = Nothing
in wxBoxGUI $ proc (_,resp,conf) -> do
rec state <- iPre initState -< conf state
stateChanged <- edgeBy maybeChanged initState -< state
(isCreated,text) <- hold (False,undefined) -< mapFilterE maybeCreate resp
let doCreate = if isCreated then noEvent else Event ()
let req = lMerge (tag doCreate (WXWTextCreateReq state))
(tag stateChanged (WXWTextSetReq text state))
returnA -< (req,())
data WXSliderState = WXSliderState {
ssMin :: Int,
ssMax :: Int,
ssOrientation :: Orientation,
ssSelection :: Int,
ssEnabled :: Bool
} deriving (Eq)
type WXSliderConf = WXSliderState -> WXSliderState
senabled :: Bool -> WXSliderConf
senabled e ss = ss {ssEnabled = e}
sselection :: Int -> WXSliderConf
sselection sel ss = ss {ssSelection = sel}
wxslider :: Orientation -> Int -> Int -> WXSliderConf -> WXBox WXSliderConf Int
wxslider orient min max conf0 =
let
defState = WXSliderState
{ssMin = min, ssMax = max, ssOrientation = orient,
ssSelection = 0, ssEnabled = True}
initState = conf0 defState
changeSel state (Event (WXWSliderCommandEvent sel)) =
state {ssSelection = sel}
changeSel state _ = state
maybeChangedInternal (_,state) (Event (WXWSliderCommandEvent _), state') =
if (state {ssSelection = ssSelection state'}) == state'
then Nothing
else Just ()
maybeChangedInternal (_,state) (_,state') =
maybeChanged state state'
maybeCreate (WXWSliderCreateResp s) = Just (True,s)
maybeCreate _ = Nothing
in wxBoxGUI $ proc (_,resp,conf) -> do
rec let newState = changeSel (conf state) resp
state <- iPre initState -< newState
stateChanged <- edgeBy maybeChangedInternal (noEvent,initState) -< (resp,state)
(isCreated,slider) <- hold (False,undefined) -< mapFilterE maybeCreate resp
let doCreate = if isCreated then noEvent else Event ()
let req = lMerge (tag doCreate (WXWSliderCreateReq state))
(tag stateChanged (WXWSliderSetReq slider state))
returnA -< (req,ssSelection state)
data WXPictureState = WXPictureState {
psSize :: WX.Size,
psPicture :: WXPicture
}
type WXPictureConf = WXPictureState -> WXPictureState
ppic :: WXPicture -> WXPictureConf
ppic pic ps = ps {psPicture = pic}
psize :: WX.Size -> WXPictureConf
psize size ps = ps {psSize = size}
wxpicture :: WXPictureConf -> WXBox WXPictureConf ()
wxpicture conf0 =
let
defState = WXPictureState {psSize = WX.sizeNull, psPicture = wxblank}
initState = conf0 defState
maybeCreate (WXWPictureCreateResp panel) = Just (True,panel)
maybeCreate _ = Nothing
in wxBoxGUI $ proc (_,resp,conf) -> do
rec state <- iPre initState -< conf state
(isCreated,panel) <- hold (False,undefined) -< mapFilterE maybeCreate resp
let doCreate = if isCreated then noEvent else Event ()
let req = lMerge (tag doCreate (WXWPictureCreateReq state))
(Event (WXWPictureSetReq panel state))
returnA -< (req,())
wxmouse :: WXBox () WX.Point
wxmouse = wxBoxGUI $ proc (inp,_,_) -> do
returnA -< (noEvent,wxMousePos inp)
type WXPicture = [WX.Prop (WX.DC ())] -> WX.DC () -> WX.Rect -> IO ()
wxblank :: WXPicture
wxblank _ _ _ = return ()
wxfill :: WXPicture
wxfill props dc rect = wxPicFill (wxrect rect) props dc rect
wxellipse :: WX.Rect -> WXPicture
wxellipse rect props dc _ = WX.ellipse dc rect props
wxrect :: WX.Rect -> WXPicture
wxrect rect props dc _ = WX.drawRect dc rect props
wxwrite :: String -> WX.Point -> WXPicture
wxwrite str pt props dc _ = WX.drawText dc str pt props
wxWithColor :: WX.Color -> WXPicture -> WXPicture
wxWithColor color pic props =
pic (props ++ [WX.color WX.:= color, WX.brushColor WX.:= color])
wxPicFill :: WXPicture -> WXPicture
wxPicFill pic props =
pic (props ++ [WX.brushKind WX.:= WX.BrushSolid])
wxPicOver :: WXPicture -> WXPicture -> WXPicture
wxPicOver pic1 pic2 props dc rect = do
pic2 props dc rect
pic1 props dc rect
data WXContents = WXCEmpty
| WXCLeaf WXWidget
| WXCComp Orientation WXContents WXContents
data WXWidget = WXButton (WX.Button ())
| WXText (WX.StaticText ())
| WXPicture (WX.Panel ())
| WXSlider (WX.Slider ())
type WXPath = [Bool]
contents2layout :: WXContents -> WX.Layout
contents2layout WXCEmpty = WX.empty
contents2layout (WXCLeaf (WXButton b)) = WX.widget b
contents2layout (WXCLeaf (WXText t)) = WX.widget t
contents2layout (WXCLeaf (WXPicture p)) = WX.widget p
contents2layout (WXCLeaf (WXSlider s)) = WX.widget s
contents2layout comp@(WXCComp orient c1 c2) =
(if orient == Horiz then WX.row else WX.column) 5 (c2lList orient comp)
c2lList :: Orientation -> WXContents -> [WX.Layout]
c2lList orient comp@(WXCComp orient' c1 c2) =
if orient == orient'
then (c2lList orient c1) ++ (c2lList orient c2)
else [contents2layout comp]
c2lList _ WXCEmpty = []
c2lList _ c = [contents2layout c]
removeContents :: WX.Frame () -> WXContents -> IO Bool
removeContents f WXCEmpty = return True
removeContents f (WXCLeaf (WXButton b)) = WXCore.windowDestroy b
removeContents f (WXCLeaf (WXText t)) = WXCore.windowDestroy t
removeContents f (WXCLeaf (WXSlider s)) = WXCore.windowDestroy s
removeContents f (WXCLeaf (WXPicture p)) = WXCore.windowDestroy p
removeContents f (WXCComp _ c0 c1) =
do removeContents f c0
removeContents f c1
type WXGUIState = (WX.Frame (),Int,WXContents)
type WXGUIRef = IORef WXGUIState
type WXRHandle = ReactHandle (WXRawInput,Event WXWidgetResp,()) (Event WXWidgetReq,())
startGUI :: String -> WXGUI () () -> IO ()
startGUI title (WXGUI g) = WX.start $ do
f <- WX.frame [WX.text WX.:= title]
epoch <- getCurrentTime
gsr <- newIORef (f,epoch,WXCEmpty)
rh <- reactInit (initSense f) (actuate gsr) g
timer <- WX.timer f [WX.interval WX.:= 30, WX.on WX.command WX.:= respond gsr rh noEvent]
return ()
getRawInput :: WX.Frame () -> IO WXRawInput
getRawInput f = do
mouse <- WXCore.windowGetMousePosition f
return WXRawInput {wxMousePos = mouse}
initSense :: WX.Frame () -> IO (WXRawInput,Event WXWidgetResp,())
initSense f = do
inp <- getRawInput f
return (inp,Event WXWInit,())
respond :: WXGUIRef -> WXRHandle -> Event WXWidgetResp -> IO ()
respond gsr rh resp = do
(f,prevt,c) <- readIORef gsr
inp <- getRawInput f
et <- getCurrentTime
(dtf,t) <- ensureTimeElapses prevt et getCurrentTime
writeIORef gsr (f,t,c)
react rh (dtf,Just (inp,resp,()))
return ()
actuate :: WXGUIRef -> WXRHandle -> Bool -> (Event WXWidgetReq,()) -> IO Bool
actuate gsr rh _ (wre,_) =
do
(f,t,prevc) <- readIORef gsr
(resp,c,cch) <- handleWidgetReq gsr rh f [] prevc wre
if cch
then do WX.set f [WX.layout WX.:= WX.margin 5 (contents2layout c)]
WX.windowReLayoutMinimal f
else return ()
writeIORef gsr (f,t,c)
case resp of
NoEvent -> return ()
_ -> respond gsr rh resp
return False
handleWidgetReq :: WXGUIRef -> WXRHandle -> WX.Frame ()
-> WXPath -> WXContents -> (Event WXWidgetReq)
-> IO (Event WXWidgetResp,WXContents,Bool)
handleWidgetReq _ _ _ _ c NoEvent = return (noEvent,c,False)
handleWidgetReq gsr rh f path c (Event (WXWButtonCreateReq bstate)) =
do let bprops = mkButtonProps gsr rh path bstate
b <- WX.smallButton f bprops
removeContents f c
return (Event (WXWButtonCreateResp b),WXCLeaf (WXButton b),True)
handleWidgetReq _ _ f path c (Event (WXWTextCreateReq tstate)) =
do let tprops = mkTextProps tstate
t <- WX.staticText f tprops
removeContents f c
return (Event (WXWTextCreateResp t),WXCLeaf (WXText t),True)
handleWidgetReq _ _ f path c (Event (WXWPictureCreateReq pstate)) =
do let pprops = mkPictureProps pstate
p <- WX.panel f pprops
removeContents f c
return (Event (WXWPictureCreateResp p),WXCLeaf (WXPicture p),True)
handleWidgetReq gsr rh f path c (Event (WXWSliderCreateReq sstate)) =
do
s <- (if ssOrientation sstate == Horiz then WX.hslider else WX.vslider)
f False (ssMin sstate) (ssMax sstate) []
let sprops = mkSliderProps gsr rh path s sstate
WX.set s sprops
removeContents f c
return (Event (WXWSliderCreateResp s),WXCLeaf (WXSlider s),True)
handleWidgetReq gsr rh f path c (Event (WXWButtonSetReq b bstate)) =
do let bprops = mkButtonProps gsr rh path bstate
WX.set b bprops
return (noEvent,c,False)
handleWidgetReq _ _ f path c (Event (WXWTextSetReq t tstate)) =
do let tprops = mkTextProps tstate
WX.set t tprops
return (noEvent,c,False)
handleWidgetReq _ _ f path c (Event (WXWPictureSetReq p pstate)) =
do let pprops = mkPictureProps pstate
WX.set p pprops
WX.repaint p
return (noEvent,c,False)
handleWidgetReq gsr rh f path c (Event (WXWSliderSetReq s sstate)) =
do
let sprops = mkSliderProps gsr rh path s sstate
WX.set s sprops
return (noEvent,c,False)
handleWidgetReq gsr rh f path c (Event (WXWComp orient (lreq,rreq))) =
do (lresp,lc',lcch) <- handleWidgetReq gsr rh f (True:path) (subCont True c) lreq
(rresp,rc',rcch) <- handleWidgetReq gsr rh f (False:path) (subCont False c) rreq
return (case (lresp,rresp) of
(NoEvent,NoEvent) -> noEvent
resp -> Event (WXWDeComp resp),
WXCComp orient lc' rc',lcch || rcch)
where subCont which (WXCComp _ l r) =
if which then l else r
subCont _ _ = WXCEmpty
mkButtonProps :: WXGUIRef -> WXRHandle -> WXPath -> WXButtonState
-> [WX.Prop (WX.Button ())]
mkButtonProps gsr rh path bs =
[WX.text WX.:= bsLabel bs, WX.enabled WX.:= bsEnabled bs,
WX.on WX.command WX.:= mkButtonCommand gsr rh path]
mkButtonCommand :: WXGUIRef -> WXRHandle -> WXPath -> IO ()
mkButtonCommand gsr rh path =
do let e = pathify (Event WXWButtonCommandEvent) path
respond gsr rh e
mkTextProps :: WXTextState -> [WX.Prop (WX.StaticText ())]
mkTextProps ts =
[WX.text WX.:= tsLabel ts]
mkSliderProps :: WXGUIRef -> WXRHandle -> WXPath
-> WX.Slider () -> WXSliderState -> [WX.Prop (WX.Slider ())]
mkSliderProps gsr rh path s ss =
[WX.enabled WX.:= ssEnabled ss, WX.selection WX.:= ssSelection ss,
WX.on WX.command WX.:= mkSliderCommand gsr rh path s]
mkSliderCommand :: WXGUIRef -> WXRHandle -> WXPath -> WX.Slider () -> IO ()
mkSliderCommand gsr rh path s =
do sel <- WX.get s WX.selection
let e = pathify (Event (WXWSliderCommandEvent sel)) path
respond gsr rh e
mkPictureProps :: WXPictureState -> [WX.Prop (WX.Panel ())]
mkPictureProps ps =
[WX.clientSize WX.:= psSize ps, WX.on WX.paint WX.:= psPicture ps []]
pathify :: Event WXWidgetResp -> WXPath -> Event WXWidgetResp
pathify e [] = e
pathify e (True:path) = pathify (Event (WXWDeComp (e,noEvent))) path
pathify e (False:path) = pathify (Event (WXWDeComp (noEvent,e))) path
getCurrentTime :: IO Int
getCurrentTime =
do (TOD sec psec) <- getClockTime
let usec = fromIntegral psec / 1000000
let msec = (fromIntegral ((sec ctEpoch) * 1000)) + (usec / 1000)
let imsec = round msec
return imsec
where
ctEpoch :: Integer
ctEpoch = 1037286000
ensureTimeElapses :: Int -> Int -> IO Int -> IO (Double,Int)
ensureTimeElapses t0 t1 getTime = do
let dt = t1 t0
dtf = (fromIntegral dt) / 1000
if (dtf > 0) then return (dtf,t1)
else do t' <- getTime
ensureTimeElapses t0 t' getTime