module FRP.UISF.UISF (
UISF(..),
uisfSource, uisfSink, uisfPipe,
uisfSourceE, uisfSinkE, uisfPipeE,
getDeltaTime, getCTX, withCTX, getEvents, getFocusData, addTerminationProc, getMousePosition,
mkUISF,
leftRight, rightLeft, topDown, bottomUp,
conjoin, unconjoin,
setLayout, setSize, pad,
UIParams, defaultUIParams,
uiInitialize, uiClose, uiTitle, uiSize, uiInitFlow, uiTickDelay, uiCloseOnEsc, uiBackground,
runUI, runUI'
) where
#if __GLASGOW_HASKELL__ >= 610
import Control.Category
import Prelude hiding ((.), id, mapM_)
#else
import Prelude hiding (mapM_)
#endif
import Control.Arrow
import Control.Arrow.Operations
import FRP.UISF.Graphics
import FRP.UISF.Render.GLUT
import FRP.UISF.UITypes
import FRP.UISF.AuxFunctions
(SEvent, Time, DeltaT, getDeltaT, accumTime, evMap)
import FRP.UISF.Asynchrony
(ArrowIO (..), Automaton, asyncE, asyncEOn, asyncV)
import Control.Monad (when, unless)
import Data.Foldable (mapM_)
import Control.Concurrent
import Control.DeepSeq
import Data.IORef
import Control.Exception
data UISF b c = UISF
{ uisfLayout :: Flow -> Layout,
uisfFun :: (CTX, Focus, DeltaT, 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, setDirty uisff')
setDirty (UISF l f) = UISF l h where
h inp = do
(_, foc', g, tp, c, uisf) <- f inp
return (True, foc', g, tp, c, uisf)
terminalAIO = addTerminationProc
instance ArrowReader DeltaT UISF where
readState = getDeltaTime
newReader (UISF l f) = UISF l h where
h (ctx, foc, dt, e, (b, dt')) = do
(db, foc', g, tp, c, uisf) <- f (ctx, foc, dt', e, b)
return (db, foc', g, tp, c, newReader uisf)
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
getDeltaTime :: UISF b DeltaT
getDeltaTime = mkUISF nullLayout (\(_,f,dt,_,_) -> (False, f, nullGraphic, nullTP, dt))
getCTX :: UISF () CTX
getCTX = mkUISF nullLayout (\(c,f,_,_,_) -> (False, f, nullGraphic, nullTP, c))
withCTX :: UISF (CTX,a) b -> UISF a b
withCTX (UISF l f) = UISF l h where
h (ctx, foc, t, e, b) = do
(db, foc', g, tp, c, uisf) <- f (ctx, foc, t, e, (ctx,b))
return (db, foc', g, tp, c, withCTX uisf)
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, DeltaT, 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)
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 { wFixed = wFixed l + w + e, hFixed = hFixed l + n + s }
h (ctx, foc, t, evt, b) = let ((x,y),(bw,bh)) = bounds ctx in do
(db, foc', g, tp, c, uisf) <- f (ctx {bounds = ((x + w, y + n),(bwwe,bhns))}, foc, t, evt, b)
return (db, foc', g, tp, c, pad args uisf)
data UIParams = UIParams {
uiInitialize :: IO ()
, uiClose :: IO ()
, uiTitle :: String
, uiSize :: Dimension
, uiInitFlow :: Flow
, uiTickDelay :: DeltaT
, uiCloseOnEsc :: Bool
, uiBackground :: RGB
}
instance Show UIParams where
show p = "{UIParams containing: title="++show (uiTitle p)++
", size="++show (uiSize p)++
", initial flow="++show (uiInitFlow p)++
", tick delay="++show (uiTickDelay p)++
", background color="++show (uiBackground p)++
(if uiCloseOnEsc p then ", and closes on ESC}" else ", and does not close on ESC}")
defaultUIParams :: UIParams
defaultUIParams = UIParams {
uiInitialize = return (),
uiClose = return (),
uiTitle = "User Interface",
uiSize = (300, 300),
uiInitFlow = TopDown,
uiTickDelay = 0.001,
uiCloseOnEsc = False,
uiBackground = colorToRGB LightBeige
}
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 <- openWindow (uiBackground p) (uiTitle p) (uiSize p)
finally (go tref w defaultFocus 0 sf) (terminate tref w)
where
terminate tref w = do
setGraphics w (nullGraphic, False)
mwindow <- getWindow w
mapM_ closeWindow mwindow
tproc <- readIORef tref
case tproc of
Nothing -> return ()
Just t -> t
uiClose p
go tref w lastFocus tprev uisf = do
mwindow <- getWindow w
case mwindow of
Nothing -> return ()
Just _ -> do
ev <- getNextEvent' w
let die = case ev of
(SKey KeyEsc _ True) -> True
_ -> False
unless (uiCloseOnEsc p && die) $ do
when (ev == NoUIEvent) (threadDelay $ truncate $ uiTickDelay p * 1000000)
wSize <- getWindowDim w
t <- getElapsedGUITime w
let ctx = defaultCTX (uiInitFlow p) wSize
(dirty, foc, graphic, tproc', _, uisf') <- uisfFun uisf (ctx, lastFocus, ttprev, ev, ())
let foc' = resetFocus foc
dirty' = case (snd lastFocus, snd foc') of
(_, SetFocusTo _) -> False
(SetFocusTo _, NoFocus) -> True
_ -> dirty
case dirty' of
True -> deepseq graphic $ setGraphics w (graphic, True)
False -> setGraphics w (graphic, False)
atomicModifyIORef' tref (\tproc -> (mergeTP tproc' tproc, ()))
go tref w foc' t uisf'
getNextEvent' w = do
e <- getNextEvent w
case e of
MouseMove _ -> do
e' <- peekNextEvent w
case e' of
MouseMove _ -> getNextEvent' w
_ -> return e
_ -> return e