module FRP.UISF.UISF (
UISF,
getTime, getCTX, getEvents, getFocusData, getMousePosition,
mkUISF, mkUISF', expandUISF, compressUISF, transformUISF,
initialIOAction,
uisfSourceE, uisfSinkE, uisfPipeE,
toUISF, convertToUISF, asyncUISF,
leftRight, rightLeft, topDown, bottomUp,
conjoin, unconjoin,
setLayout, setSize, pad,
runUI, runUI'
) where
#if __GLASGOW_HASKELL__ >= 610
import Control.Category
import Prelude hiding ((.))
#endif
import Control.Arrow
import Control.Arrow.Operations
import FRP.UISF.SOE
import FRP.UISF.UIMonad
import FRP.UISF.Types.MSF
import FRP.UISF.AuxFunctions (Automaton, Time, toMSF, toRealTimeMSF,
async, SEvent, ArrowTime (..))
import Control.Monad (when)
import qualified Graphics.UI.GLFW as GLFW (sleep, SpecialKey (..))
import Control.Concurrent.MonadIO
import Control.DeepSeq
type UISF = MSF UI
instance ArrowCircuit UISF where
delay i = MSF (h i) where h i x = seq i $ return (i, MSF (h x))
instance ArrowTime UISF where
time = getTime
getTime :: UISF () Time
getTime = mkUISF (\_ (_,f,t,_) -> (nullLayout, False, f, nullAction, nullCD, t))
getCTX :: UISF () CTX
getCTX = mkUISF (\_ (c,f,_,_) -> (nullLayout, False, f, nullAction, nullCD, c))
getEvents :: UISF () UIEvent
getEvents = mkUISF (\_ (_,f,_,e) -> (nullLayout, False, f, nullAction, nullCD, e))
getFocusData :: UISF () Focus
getFocusData = mkUISF (\_ (_,f,_,_) -> (nullLayout, False, f, nullAction, nullCD, f))
getMousePosition :: UISF () Point
getMousePosition = proc _ -> do
e <- getEvents -< ()
rec p' <- delay (0,0) -< p
let p = case e of
MouseMove pt -> pt
_ -> p'
returnA -< p
mkUISF :: (a -> (CTX, Focus, Time, UIEvent) -> (Layout, DirtyBit, Focus, Action, ControlData, b)) -> UISF a b
mkUISF f = pipe (\a -> UI (return . f a))
mkUISF' :: (a -> (CTX, Focus, Time, UIEvent) -> IO (Layout, DirtyBit, Focus, Action, ControlData, b)) -> UISF a b
mkUISF' = pipe . (UI .)
expandUISF :: UISF a b -> a -> (CTX, Focus, Time, UIEvent) -> IO (Layout, DirtyBit, Focus, Action, ControlData, (b, UISF a b))
expandUISF (MSF f) = unUI . f
compressUISF :: (a -> (CTX, Focus, Time, UIEvent) -> IO (Layout, DirtyBit, Focus, Action, ControlData, (b, UISF a b))) -> UISF a b
compressUISF f = MSF (UI . f)
transformUISF :: (UI (c, UISF b c) -> UI (c, UISF b c)) -> UISF b c -> UISF b c
transformUISF f (MSF sf) = MSF $ \a -> do
(c, nextSF) <- f (sf a)
return (c, transformUISF f nextSF)
initialIOAction :: IO x -> (x -> UISF a b) -> UISF a b
initialIOAction = initialAction . liftIO
uisfSourceE :: IO c -> UISF (SEvent ()) (SEvent c)
uisfSourceE = (delay Nothing >>>) . sourceE . liftIO
uisfSinkE :: (b -> IO ()) -> UISF (SEvent b) (SEvent ())
uisfSinkE = (delay Nothing >>>) . sinkE . (liftIO .)
uisfPipeE :: (b -> IO c) -> UISF (SEvent b) (SEvent c)
uisfPipeE = (delay Nothing >>>) . pipeE . (liftIO .)
toUISF :: Automaton a b -> UISF a b
toUISF = toMSF
convertToUISF :: NFData b => Double -> Double -> Automaton a b -> UISF a [(b, Time)]
convertToUISF clockrate buffer sf = proc a -> do
t <- time -< ()
toRealTimeMSF clockrate buffer addThreadID sf -< (a, t)
asyncUISF :: NFData b => Automaton a b -> UISF (SEvent a) (SEvent b)
asyncUISF = async addThreadID
topDown, bottomUp, leftRight, rightLeft, conjoin, unconjoin :: UISF a b -> UISF a b
topDown = modifyFlow (\ctx -> ctx {flow = TopDown})
bottomUp = modifyFlow (\ctx -> ctx {flow = BottomUp})
leftRight = modifyFlow (\ctx -> ctx {flow = LeftRight})
rightLeft = modifyFlow (\ctx -> ctx {flow = RightLeft})
conjoin = modifyFlow (\ctx -> ctx {isConjoined = True})
unconjoin = modifyFlow (\ctx -> ctx {isConjoined = False})
modifyFlow :: (CTX -> CTX) -> UISF a b -> UISF a b
modifyFlow h = transformUISF (modifyFlow' h)
where modifyFlow' :: (CTX -> CTX) -> UI a -> UI a
modifyFlow' h (UI f) = UI g where g (c,s,t,i) = f (h c,s,t,i)
setLayout :: Layout -> UISF a b -> UISF a b
setLayout l = transformUISF (setLayout' l)
where setLayout' :: Layout -> UI a -> UI a
setLayout' d (UI f) = UI aux
where
aux inps = do
(_, db, foc, a, ts, v) <- f inps
return (d, db, foc, a, ts, v)
setSize :: Dimension -> UISF a b -> UISF a b
setSize (w,h) = setLayout $ makeLayout (Fixed w) (Fixed h)
pad :: (Int, Int, Int, Int) -> UISF a b -> UISF a b
pad args = transformUISF (pad' args)
where pad' :: (Int, Int, Int, Int) -> UI a -> UI a
pad' (w,n,e,s) (UI f) = UI aux
where
aux (ctx@(CTX i _ c), foc, t, inp) = do
rec (l, db, foc', a, ts, v) <- f (CTX i ((x + w, y + n),(bw,bh)) c, foc, t, inp)
let d = l { hFixed = hFixed l + w + e, vFixed = vFixed l + n + s }
((x,y),(bw,bh)) = bounds ctx
return (d, db, foc', a, ts, v)
defaultSize :: Dimension
defaultSize = (300, 300)
defaultCTX :: Dimension -> CTX
defaultCTX size = CTX TopDown ((0,0), size) False
defaultFocus :: Focus
defaultFocus = (0, SetFocusTo 0)
resetFocus :: (WidgetID, FocusInfo) -> (WidgetID, FocusInfo)
resetFocus (n,SetFocusTo i) = (0, SetFocusTo $ (i+n) `rem` n)
resetFocus (_,_) = (0,NoFocus)
runUI' :: String -> UISF () () -> IO ()
runUI' = runUI defaultSize
runUI :: Dimension -> String -> UISF () () -> IO ()
runUI windowSize title sf = runGraphics $ do
w <- openWindowEx title (Just (0,0)) (Just windowSize) drawBufferedGraphic
(events, addEv) <- makeStream
let pollEvents = windowUser w addEv
t0 <- timeGetTime
pollEvents
let render :: Bool -> [UIEvent] -> Focus -> Stream UI () -> [ThreadId] -> IO [ThreadId]
render drawit' (inp:inps) lastFocus uistream tids = do
wSize <- getMainWindowSize
t <- timeGetTime
let rt = t t0
let ctx = defaultCTX wSize
(_, dirty, foc, (graphic, sound), tids', (_, uistream')) <- (unUI $ stream uistream) (ctx, lastFocus, rt, inp)
sound
setGraphic' w graphic
let drawit = dirty || drawit'
newtids = tids'++tids
foc' = resetFocus foc
foc' `seq` newtids `seq` case inp of
NoUIEvent -> do
when drawit $ setDirty w
quit <- pollEvents
if quit then return newtids
else render False inps foc' uistream' newtids
_ -> render drawit inps foc' uistream' newtids
render _ [] _ _ tids = return tids
tids <- render True events defaultFocus (streamMSF sf (repeat ())) []
GLFW.sleep 0.5
mapM_ killThread tids
windowUser :: Window -> (UIEvent -> IO ()) -> IO Bool
windowUser w addEv = do
quit <- getEvents
addEv NoUIEvent
return quit
where
getEvents :: IO Bool
getEvents = do
mev <- maybeGetWindowEvent 0.001 w
case mev of
Nothing -> return False
Just e -> case e of
Closed -> return True
_ -> addEv e >> getEvents
makeStream :: IO ([a], a -> IO ())
makeStream = do
ch <- newChan
contents <- getChanContents ch
return (contents, writeChan ch)