module FRP.UISF.UISF (
UISF(..),
uisfSource, uisfSink, uisfPipe,
uisfSourceE, uisfSinkE, uisfPipeE,
getTime, getCTX, getEvents, getFocusData, addTerminationProc, getMousePosition,
mkUISF,
asyncUISFE, asyncUISFV,
leftRight, rightLeft, topDown, bottomUp,
conjoin, unconjoin,
setLayout, setSize, pad,
UIParams (..), defaultUIParams,
runUI, runUI'
) where
#if __GLASGOW_HASKELL__ >= 610
import Control.Category
import Prelude hiding ((.), id)
#endif
import Control.Arrow
import Control.Arrow.Operations
import FRP.UISF.SOE
import FRP.UISF.UITypes
import FRP.UISF.AuxFunctions (Automaton, Time, evMap,
SEvent, ArrowTime (..), ArrowIO (..),
asyncE, asyncV)
import Control.Monad (when)
import qualified Graphics.UI.GLFW as GLFW (sleep)
import Control.Concurrent
import Control.DeepSeq
import Data.IORef
import Control.Exception
data UISF b c = UISF
{ uisfLayout :: Flow -> Layout,
uisfFun :: (CTX, Focus, Time, UIEvent, b) ->
IO (DirtyBit, Focus, Graphic, TerminationProc, c, UISF b c) }
instance Category UISF where
id = UISF (const nullLayout) fun where fun (_,foc,_,_,b) = return (False, foc, nullGraphic, nullTP, b, id)
UISF gl g . UISF fl f = UISF layout fun where
layout flow = mergeLayout flow (fl flow) (gl flow)
fun (ctx, foc, t, e, b) =
let (fctx, gctx) = divideCTX ctx (fl $ flow ctx) (gl $ flow ctx)
in do (fdb, foc', fg, ftp, c, uisff') <- f (fctx, foc, t, e, b)
(gdb, foc'', gg, gtp, d, uisfg') <- g (gctx, foc', t, e, c)
let graphic = mergeGraphics ctx (fg, (fl $ flow ctx) ) (gg, (gl $ flow ctx) )
tp = mergeTP ftp gtp
dirtybit = ((||) $! fdb) $! gdb
return (dirtybit, foc'', graphic, tp, d, uisfg' . uisff')
instance Arrow UISF where
arr f = UISF (const nullLayout) fun where fun (_,foc,_,_,b) = return (False, foc, nullGraphic, nullTP, f b, arr f)
first (UISF fl f) = UISF fl fun where
fun (ctx, foc, t, e, (b, d)) = do
(db, foc', g, tp, c, uisff') <- f (ctx, foc, t, e, b)
return (db, foc', g, tp, (c,d), first uisff')
instance ArrowLoop UISF where
loop (UISF fl f) = UISF fl fun where
fun (ctx, foc, t, e, b) = do
rec (db, foc', g, tp, (c,d), uisff') <- f (ctx, foc, t, e, (b,d))
return (db, foc', g, tp, c, loop uisff')
instance ArrowChoice UISF where
left uisf = left' True uisf where
left' lastLeft ~(UISF fl f) = UISF fl fun where
fun (ctx, foc, t, e, x) = case x of
Left b -> do (db, foc', g, tp, c, uisff') <- f (ctx, foc, t, e, b)
return (db || lastLeft, foc', g, tp, Left c, left' True uisff')
Right d -> return (lastLeft, foc, nullGraphic, nullTP, Right d, left' False $ UISF (const nullLayout) f)
uisff ||| uisfg = choice' True (uisfLayout uisff) uisff uisfg where
choice' lastLeft layout uisff uisfg = UISF layout fun where
fun (ctx, foc, t, e, x) = case x of
Left b -> do (db, foc', g, tp, d, uisff') <- uisfFun uisff (ctx, foc, t, e, b)
return (db || lastLeft, foc', g, tp, d, choice' True (uisfLayout uisff') uisff' uisfg)
Right c -> do (db, foc', g, tp, d, uisfg') <- uisfFun uisfg (ctx, foc, t, e, c)
return (db || not lastLeft, foc', g, tp, d, choice' False (uisfLayout uisfg') uisff uisfg')
instance ArrowCircuit UISF where
delay i = UISF (const nullLayout) (fun i) where
fun i (_,foc,_,_,b) = seq i $ return (False, foc, nullGraphic, nullTP, i, UISF (const nullLayout) (fun b))
instance ArrowIO UISF where
liftAIO f = UISF (const nullLayout) fun where
fun (_,foc,_,_,b) = f b >>= (\c -> return (False, foc, nullGraphic, nullTP, c, liftAIO f))
initialAIO iod f = UISF (const nullLayout) fun where
fun inps = do
d <- iod
(db, foc', g, tp, c, uisff') <- uisfFun (f d) inps
return (db, foc', g, tp, c, uisff')
instance ArrowTime UISF where
time = getTime
uisfSource :: IO b -> UISF () b
uisfSource = liftAIO . const
uisfSink :: (a -> IO ()) -> UISF a ()
uisfSink = liftAIO
uisfPipe :: (a -> IO b) -> UISF a b
uisfPipe = liftAIO
uisfSourceE :: IO b -> UISF (SEvent ()) (SEvent b)
uisfSourceE = evMap . uisfSource
uisfSinkE :: (a -> IO ()) -> UISF (SEvent a) (SEvent ())
uisfSinkE = evMap . uisfSink
uisfPipeE :: (a -> IO b) -> UISF (SEvent a) (SEvent b)
uisfPipeE = evMap . uisfPipe
getTime :: UISF () Time
getTime = mkUISF nullLayout (\(_,f,t,_,_) -> (False, f, nullGraphic, nullTP, t))
getCTX :: UISF () CTX
getCTX = mkUISF nullLayout (\(c,f,_,_,_) -> (False, f, nullGraphic, nullTP, c))
getEvents :: UISF () UIEvent
getEvents = mkUISF nullLayout (\(_,f,_,e,_) -> (False, f, nullGraphic, nullTP, e))
getFocusData :: UISF () Focus
getFocusData = mkUISF nullLayout (\(_,f,_,_,_) -> (False, f, nullGraphic, nullTP, f))
addTerminationProc :: IO () -> UISF a a
addTerminationProc p = UISF (const nullLayout) fun where
fun (_,f,_,_,b) = return (False, f, nullGraphic, Just p, b, UISF (const nullLayout) fun2)
fun2 (_,f,_,_,b) = return (False, f, nullGraphic, Nothing, b, UISF (const nullLayout) fun2)
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 :: Layout -> ((CTX, Focus, Time, UIEvent, a) -> (DirtyBit, Focus, Graphic, TerminationProc, b)) -> UISF a b
mkUISF l f = UISF (const l) fun where
fun inps = let (db, foc, g, tp, b) = f inps in return (db, foc, g, tp, b, mkUISF l f)
asyncUISFV :: NFData b => Double -> Double -> Automaton (->) a b -> UISF a [(b, Time)]
asyncUISFV clockrate buffer sf = proc a -> do
t <- time -< ()
asyncV clockrate buffer (addTerminationProc . killThread) sf -< (a, t)
asyncUISFE :: NFData b => Automaton (->) a b -> UISF (SEvent a) (SEvent b)
asyncUISFE = asyncE (addTerminationProc . killThread)
topDown, bottomUp, leftRight, rightLeft, conjoin, unconjoin :: UISF a b -> UISF a b
topDown = modifyFlow TopDown
bottomUp = modifyFlow BottomUp
leftRight = modifyFlow LeftRight
rightLeft = modifyFlow RightLeft
conjoin = modifyCTX (\ctx -> ctx {isConjoined = True})
unconjoin = modifyCTX (\ctx -> ctx {isConjoined = False})
modifyFlow :: Flow -> UISF a b -> UISF a b
modifyFlow newFlow (UISF l f) = UISF (const $ l newFlow) h where
h (ctx, foc, t, e, b) = do
(db, foc', g, tp, c, uisf) <- f (ctx {flow = newFlow}, foc, t, e, b)
return (db, foc', g, tp, c, modifyFlow newFlow uisf)
modifyCTX :: (CTX -> CTX) -> UISF a b -> UISF a b
modifyCTX mod (UISF l f) = UISF l h where
h (ctx, foc, t, e, b) = do
(db, foc', g, tp, c, uisf) <- f (mod ctx, foc, t, e, b)
return (db, foc', g, tp, c, modifyCTX mod uisf)
setLayout :: Layout -> UISF a b -> UISF a b
setLayout l (UISF _ f) = UISF (const l) h where
h (ctx, foc, t, e, b) = do
(db, foc', g, tp, c, uisf) <- f (ctx, foc, t, e, b)
return (db, foc', g, tp, c, setLayout l uisf)
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@(w,n,e,s) (UISF fl f) = UISF layout h where
layout ctx = let l = fl ctx in l { hFixed = hFixed l + w + e, vFixed = vFixed l + n + s }
h (ctx, foc, t, e, b) = let ((x,y),(bw,bh)) = bounds ctx in do
(db, foc', g, tp, c, uisf) <- f (ctx {bounds = ((x + w, y + n),(bw,bh))}, foc, t, e, b)
return (db, foc', g, tp, c, pad args uisf)
data UIParams = UIParams {
uiInitialize :: IO ()
, uiClose :: IO ()
, uiTitle :: String
, uiSize :: Dimension
, uiInitFlow :: Flow
, uiTickDelay :: Double
}
defaultUIParams :: UIParams
defaultUIParams = UIParams {
uiInitialize = return (),
uiClose = return (),
uiTitle = "User Interface",
uiSize = (300, 300),
uiInitFlow = TopDown,
uiTickDelay = 0.001
}
defaultCTX :: Flow -> Dimension -> CTX
defaultCTX flow size = CTX flow ((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' :: UISF () () -> IO ()
runUI' = runUI defaultUIParams
runUI :: UIParams -> UISF () () -> IO ()
runUI p sf = do
tref <- newIORef Nothing
uiInitialize p
w <- openWindowEx (uiTitle p) (Just (0,0)) (Just $ uiSize p) drawBufferedGraphic
finally (go tref w) (terminate tref w)
where
terminate tref w = do
closeWindow w
tproc <- readIORef tref
case tproc of
Nothing -> return ()
Just t -> t
uiClose p
go tref w = runGraphics $ do
(events, addEv) <- makeStream
let pollEvents = windowUser (uiTickDelay p) w addEv
t0 <- timeGetTime
pollEvents
let render :: Bool -> [UIEvent] -> Focus -> UISF () () -> IO ()
render drawit' (inp:inps) lastFocus uisf = do
wSize <- getMainWindowSize
t <- timeGetTime
let rt = t t0
let ctx = defaultCTX (uiInitFlow p) wSize
(dirty, foc, graphic, tproc', _, uisf') <- uisfFun uisf (ctx, lastFocus, rt, inp, ())
setGraphic' w graphic
let drawit = dirty || drawit'
foc' = resetFocus foc
atomicModifyIORef' tref (\tproc -> (mergeTP tproc' tproc, ()))
foc' `seq` case inp of
NoUIEvent -> do
when drawit $ setDirty w
quit <- pollEvents
if quit then return ()
else render False inps foc' uisf'
_ -> render drawit inps foc' uisf'
render _ [] _ _ = return ()
render True events defaultFocus sf
GLFW.sleep 0.5
windowUser :: Double -> Window -> (UIEvent -> IO ()) -> IO Bool
windowUser tickDelay w addEv = do
quit <- getEvents
addEv NoUIEvent
return quit
where
getEvents :: IO Bool
getEvents = do
mev <- maybeGetWindowEvent tickDelay 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)