UISF 0.2.0.0 → 0.3.0.0
raw patch · 15 files changed
+799/−897 lines, 15 filesdep −monadIO
Dependencies removed: monadIO
Files
- FRP/UISF.hs +8/−8
- FRP/UISF/AuxFunctions.hs +205/−166
- FRP/UISF/Examples/Crud.hs +1/−1
- FRP/UISF/Examples/Examples.hs +9/−9
- FRP/UISF/Examples/Pinochle.hs +12/−14
- FRP/UISF/Examples/SevenGuis.lhs +12/−11
- FRP/UISF/Examples/fft.hs +3/−5
- FRP/UISF/SOE.hs +1/−1
- FRP/UISF/Types/MSF.hs +0/−170
- FRP/UISF/UIMonad.hs +0/−312
- FRP/UISF/UISF.hs +240/−162
- FRP/UISF/UITypes.hs +273/−0
- FRP/UISF/Widget.hs +30/−32
- ReadMe.txt +1/−1
- UISF.cabal +4/−5
FRP/UISF.hs view
@@ -1,12 +1,12 @@ module FRP.UISF ( -- UI functions UISF - , runUI' -- :: String -> UISF () () -> IO () - , runUI -- :: Dimension -> String -> UISF () () -> IO () - , convertToUISF -- :: NFData b => Double -> Double -> SF a b -> UISF a ([b], Bool) - , asyncUISF -- :: NFData b => Automaton a b -> UISF (ASyncInput a) (ASyncOutput b) - , AsyncInput (..) -- data AsyncInput a = AINoValue | AIClearBuffer | AIValue a - , AsyncOutput (..) -- data AsyncOutput b = AONoValue | AOCalculating Int | AOValue b + , UIParams (..) -- data UIParams = UIParams { ... } + , defaultUIParams -- :: UIParams + , runUI' -- :: UISF () () -> IO () + , runUI -- :: UIParams -> UISF () () -> IO () + , asyncUISFV -- :: NFData b => Double -> Double -> Automaton a b -> UISF a ([b], Bool) + , asyncUISFE -- :: NFData b => Automaton a b -> UISF (SEvent a) (SEvent b) , Dimension -- type Dimension = (Int, Int) , topDown, bottomUp, leftRight, rightLeft -- :: UISF a b -> UISF a b , setSize -- :: Dimension -> UISF a b -> UISF a b @@ -28,7 +28,7 @@ , radio -- :: [String] -> Int -> UISF () Int , hSlider, vSlider -- :: RealFrac a => (a, a) -> a -> UISF () a , hiSlider, viSlider -- :: Integral a => a -> (a, a) -> a -> UISF () a - , realtimeGraph -- :: RealFrac a => Layout -> Time -> Color -> UISF (Time, [(a,Time)]) () + , realtimeGraph -- :: RealFrac a => Layout -> Time -> Color -> UISF [(a,Time)] () , histogram -- :: RealFrac a => Layout -> UISF (Event [a]) () , histogramWithScale -- :: RealFrac a => Layout -> UISF (SEvent [(a,String)]) () , listbox -- :: (Eq a, Show a) => UISF ([a], Int) Int @@ -42,7 +42,7 @@ , module Control.Arrow ) where -import FRP.UISF.UIMonad +import FRP.UISF.UITypes import FRP.UISF.UISF import FRP.UISF.Widget import FRP.UISF.SOE (Color (..))
FRP/UISF/AuxFunctions.hs view
@@ -9,56 +9,54 @@ -- -- Auxiliary functions for use with UISF or other arrows. -{-# LANGUAGE Arrows, ScopedTypeVariables #-} +{-# LANGUAGE Arrows, ScopedTypeVariables, TupleSections #-} module FRP.UISF.AuxFunctions ( -- * Types SEvent, Time, DeltaT, ArrowTime, time, + ArrowIO, liftAIO, initialAIO, -- * Useful SF Utilities (Mediators) constA, constSF, edge, accum, unique, hold, now, mergeE, (~++), - concatA, foldA, foldSF, + concatA, runDynamic, foldA, foldSF, + maybeA, evMap, -- * Delays and Timers delay, -- | delay is a unit delay. It is exactly the delay from ArrowCircuit. vdelay, fdelay, - vdelayC, fdelayC, + vcdelay, fcdelay, timer, genEvents, -- * Event buffer - BufferEvent (..), Tempo, BufferControl, eventBuffer, + Tempo, BufferOperation(..), eventBuffer, eventBuffer', -- (=>>), (->>), (.|.), -- snapshot, snapshot_, -- * Signal Function Conversions -- $conversions - -- ** Types - Automaton(..), toAutomaton, msfiToAutomaton, + -- *** Types + Automaton(..), -- *** Conversions -- $conversions2 - toMSF, toRealTimeMSF, - async, AsyncInput(..), AsyncOutput(..) + asyncC, asyncV, asyncE, asyncC' ) where -import Prelude +import Prelude hiding ((.), id) +import Control.Category import Control.Arrow import Control.Arrow.Operations -import Data.Sequence (Seq, empty, (<|), (|>), (><), +import Control.Arrow.Transformer.Automaton +import Data.Sequence (empty, (<|), (|>), (><), viewl, ViewL(..), viewr, ViewR(..)) import qualified Data.Sequence as Seq import Data.Maybe (listToMaybe) --- For use with MSF Conversions -import Control.Monad.Fix -import FRP.UISF.Types.MSF -import Data.Functor.Identity - -import Control.Concurrent.MonadIO -import Data.IORef.MonadIO +import Control.Concurrent +import Data.IORef import Data.Foldable (toList) import Control.DeepSeq @@ -80,6 +78,10 @@ class ArrowTime a where time :: a () Time +class Arrow a => ArrowIO a where + liftAIO :: (b -> IO c) -> a b c + initialAIO :: IO d -> (d -> a b c) -> a b c + -------------------------------------- -- Useful SF Utilities (Mediators) -------------------------------------- @@ -108,6 +110,8 @@ rec b <- delay x -< maybe b ($b) f returnA -< b +-- | The signal function unique will produce an event each time its input +-- signal changes. unique :: Eq e => ArrowCircuit a => a e (SEvent e) unique = proc e -> do prev <- delay Nothing -< Just e @@ -165,17 +169,30 @@ d <- h -< bs returnA -< merge c d +runDynamic :: ArrowChoice a => a b c -> a [b] [c] +runDynamic = foldA (:) [] + -- | For folding results of a list of signal functions -foldSF :: Arrow a => (b -> c -> c) -> c -> [a () b] -> a () c -foldSF f b sfs = - foldr g (constA b) sfs where - g sfa sfb = - proc () -> do - s1 <- sfa -< () - s2 <- sfb -< () - returnA -< f s1 s2 +foldSF :: Arrow a => (b -> c -> c) -> c -> [a () b] -> a () c +foldSF f c sfs = let inps = replicate (length sfs) () in + constA inps >>> concatA sfs >>> arr (foldr f c) +--foldSF f b sfs = +-- foldr g (constA b) sfs where +-- g sfa sfb = +-- proc () -> do +-- s1 <- sfa -< () +-- s2 <- sfb -< () +-- returnA -< f s1 s2 +maybeA :: ArrowChoice a => a () c -> a b c -> a (Maybe b) c +maybeA nothing just = proc eb -> do + case eb of + Just b -> just -< b + Nothing -> nothing -< () +evMap :: ArrowChoice a => a b c -> a (SEvent b) (SEvent c) +evMap a = maybeA (constA Nothing) (a >>> arr Just) + -------------------------------------- -- Delays and Timers -------------------------------------- @@ -217,13 +234,13 @@ (t0,e0) :< qs -> if t-d >= t0 then (Just e0, qs) else (Nothing, q) returnA -< ret --- | fdelayC is a continuous version of fdelay. It takes an initial value +-- | fcdelay is a continuous version of fdelay. It takes an initial value -- to emit for the first dt seconds. After that, the delay will always -- be accurate, but some data may be ommitted entirely. As such, it is --- not advisable to use fdelayC for event streams where every event must +-- not advisable to use fcdelay for event streams where every event must -- be processed (that's what fdelay is for). -fdelayC :: (ArrowTime a, ArrowCircuit a) => b -> DeltaT -> a b b -fdelayC i dt = proc v -> do +fcdelay :: (ArrowTime a, ArrowCircuit a) => b -> DeltaT -> a b b +fcdelay i dt = proc v -> do t <- time -< () rec q <- delay empty -< q' |> (t+dt, v) -- this list has pairs of (emission time, value) let (ready, rest) = Seq.spanl ((<= t) . fst) q @@ -232,12 +249,12 @@ _ :> (t', v') -> (v', (t',v') <| rest) returnA -< ret --- | vdelayC is a continuous version of vdelay. It will always emit the +-- | vcdelay is a continuous version of vdelay. It will always emit the -- value that was produced dt seconds earlier (erring on the side of an -- older value if necessary). Be warned that this version of delay can -- both omit some data entirely and emit the same data multiple times. -- As such, it is usually inappropriate for events (use vdelay). --- vdelayC takes a 'maxDT' argument that stands for the maximum delay +-- vcdelay takes a 'maxDT' argument that stands for the maximum delay -- time that it can handle. This is to prevent a space leak. -- -- Implementation note: Rather than keep a single buffer, we keep two @@ -247,8 +264,8 @@ -- delay amount variably changes, values are moved back and forth between -- these two sequences as necessary. -- This should provide a slight performance boost. -vdelayC :: (ArrowTime a, ArrowCircuit a) => DeltaT -> b -> a (DeltaT, b) b -vdelayC maxDT i = proc (dt, v) -> do +vcdelay :: (ArrowTime a, ArrowCircuit a) => DeltaT -> b -> a (DeltaT, b) b +vcdelay maxDT i = proc (dt, v) -> do t <- time -< () rec (qlow, qhigh) <- delay (empty,empty) -< (dropMostWhileL ((< t-maxDT) . fst) qlow', qhigh' |> (t, v)) @@ -310,24 +327,24 @@ -- Event buffer -------------------------------------- --- | The BufferEvent data type is used in tandem with 'BufferControl' --- to provide the right control information to 'eventBuffer'. -data BufferEvent b = - Clear -- ^ Erase the buffer - | SkipAhead DeltaT -- ^ Skip ahead a certain amount of time in the buffer - | AddData [(DeltaT, b)] -- ^ Merge data into the buffer - | AddDataToEnd [(DeltaT, b)] -- ^ Add data to the end of the buffer - -- | Tempo is just a Double. type Tempo = Double --- | BufferControl has a Buffer event, a bool saying whether to Play (true) or --- Pause (false), and a tempo multiplier. -type BufferControl b = (SEvent (BufferEvent b), Bool, Tempo) +-- | The BufferOperation data type wraps up the data and operational commands +-- to control an 'eventbuffer'. +data BufferOperation b = + NoBOp -- ^ No Buffer Operation + | ClearBuffer -- ^ Erase the buffer + | SkipAheadInBuffer DeltaT -- ^ Skip ahead a certain amount of time in the buffer + | MergeInBuffer [(DeltaT, b)] -- ^ Merge data into the buffer + | AppendToBuffer [(DeltaT, b)] -- ^ Append data to the end of the buffer + | SetBufferPlayStatus Bool (BufferOperation b) -- ^ Set a new play status (True = Playing, False = Paused) + | SetBufferTempo Tempo (BufferOperation b) -- ^ Set the buffer's tempo -- | eventBuffer allows for a timed series of events to be prepared and --- emitted. The streaming input is a BufferControl, described above. --- Just as MIDI files have events timed based +-- emitted. The streaming input is a BufferOperation, described above. +-- Note that the default play status is playing and the default tempo +-- is 1. Just as MIDI files have events timed based -- on ticks since the last event, the events here are timed based on -- seconds since the last event. If an event is to occur 0.0 seconds -- after the last event, then it is assumed to be played at the same @@ -335,14 +352,19 @@ -- at the same timestep. In addition to any events emitted, a -- streaming Bool is emitted that is True if the buffer is empty and -- False if the buffer is full (meaning that events will still come). -eventBuffer :: (ArrowTime a, ArrowCircuit a) => a (BufferControl b) (SEvent [b], Bool) -eventBuffer = proc (bc, doPlay, tempo) -> do - t <- time -< () +eventBuffer :: (ArrowTime a, ArrowCircuit a) => a (BufferOperation b) (SEvent [b], Bool) +eventBuffer = arr (,()) >>> second time >>> eventBuffer' + +eventBuffer' :: ArrowCircuit a => a (BufferOperation b, Time) (SEvent [b], Bool) +eventBuffer' = proc (bo', t) -> do + let (bo, doPlay', tempo') = collapseBO bo' + doPlay <- hold True -< doPlay' + tempo <- hold 1 -< tempo' rec tprev <- delay 0 -< t --used to calculate dt, the change in time buffer <- delay [] -< buffer''' --the buffer let dt = tempo * (t-tprev) --dt will never be negative buffer' = if doPlay then subTime buffer dt else buffer - buffer'' = maybe buffer' (update buffer') bc --update the buffer based on the control + buffer'' = update buffer' bo --update the buffer based on the operation (nextMsgs, buffer''') = if doPlay then getNextEvent buffer'' --get any events that are ready else (Nothing, buffer'') returnA -< (nextMsgs, null buffer''') @@ -356,11 +378,13 @@ nextEs = map snd es in if null buffer then (Nothing, []) else (Just nextEs, rest) - update :: [(DeltaT, b)] -> BufferEvent b -> [(DeltaT, b)] - update _ Clear = [] - update b (SkipAhead dt) = skipAhead b dt - update b (AddData b') = merge b b' - update b (AddDataToEnd b') = b ++ b' + update :: [(DeltaT, b)] -> BufferOperation b -> [(DeltaT, b)] + update b NoBOp = b + update _ ClearBuffer = [] + update b (SkipAheadInBuffer dt) = skipAhead b dt + update b (MergeInBuffer b') = merge b b' + update b (AppendToBuffer b') = b ++ b' + update _ _ = error "The impossible happened in eventBuffer" merge :: [(DeltaT, b)] -> [(DeltaT, b)] -> [(DeltaT, b)] merge b [] = b merge [] b = b @@ -373,8 +397,13 @@ skipAhead ((bt,b):bs) dt = if bt < dt then skipAhead bs (dt-bt) else (bt-dt,b):bs + collapseBO :: BufferOperation b -> (BufferOperation b, Maybe Bool, Maybe Tempo) + collapseBO (SetBufferPlayStatus b bo) = let (o, _, t) = collapseBO bo in (o, Just b, t) + collapseBO (SetBufferTempo t bo) = let (o, b, _) = collapseBO bo in (o, b, Just t) + collapseBO bo = (bo, Nothing, Nothing) + -------------------------------------- -- Yampa-style utilities -------------------------------------- @@ -398,7 +427,7 @@ -------------------------------------- -- $conversions --- Due to the internal monad (specifically, because it could be IO), MSFs are +-- Due to the internal IO, ArrowIO arrows are -- not necessarily pure. Thus, when we run them, we say that they run \"in -- real time\". This means that the time between two samples can vary and is -- inherently unpredictable. @@ -406,38 +435,15 @@ -- However, sometimes we have a pure computation that we would like to run -- on a simulated clock. This computation will expect to produce values at -- specific intervals, and because it's pure, that expectation can sort of be --- satisfied. --- --- The three functions in this section are three different ways to handle --- this case. toMSF simply lifts the pure computation and \"hopes\" --- that the timing works the way you want. As expected, this is not --- recommended. async lets the pure computation compute in its own thread, --- but it puts no restrictions on speed. toRealTimeMSF takes a signal rate --- argument and attempts to mediate between real and virtual time. +-- satisfied. For this, we would use asynchV (V for virtual). -- --- Rather than use MSF Identity as our default pure function, we present --- the Automaton type: -newtype Automaton a b = Automaton (a -> (b, Automaton a b)) - --- | toAutomaton lifts a pure function to an Automaton. -toAutomaton :: (a -> b) -> Automaton a b -toAutomaton f = g where g = Automaton $ \a -> (f a, g) - --- | msfiToAutomaton lifts a pure MSF (i.e. one in the Identity monad) to --- an Automaton. -msfiToAutomaton :: MSF Identity a b -> Automaton a b -msfiToAutomaton (MSF msf) = Automaton $ second msfiToAutomaton . runIdentity . msf +-- The other functions in this section are for other forms of asynchrony. +-- There is one for Event-based asynchrony and two for continuous. -- $conversions2 --- The following two functions are for lifting Automatons to MSFs. The first --- one is a quick and dirty solution, and the second one appropriately --- converts a simulated time Automaton into a real time one. - --- | This function should be avoided, as it directly converts the automaton --- with no real regard for time. -toMSF :: Monad m => Automaton a b -> MSF m a b -toMSF (Automaton f) = MSF $ return . second toMSF . f +-- The following function is for lifting an Automaton to an ArrowIO by +-- appropriately converting the "simulated time" Automaton into realtime. -- | The clockrate is the simulated rate of the input signal function. -- The buffer is the amount of time the given signal function is @@ -452,49 +458,37 @@ -- Note also that the caller can check the time stamp on the element -- at the end of the list to see if the inner, \"simulated\" signal -- function is performing as fast as it should. -toRealTimeMSF :: forall m a b . (Monad m, MonadIO m, MonadFix m, NFData b) => - Double -- ^ Clockrate - -> DeltaT -- ^ Amount of time to buffer - -> (ThreadId -> m ()) -- ^ The thread handler - -> Automaton a b -- ^ The automaton to convert to realtime - -> MSF m (a, Time) [(b, Time)] -toRealTimeMSF clockrate buffer threadHandler sf = MSF initFun - where - -- initFun creates some refs and threads and is never used again. - -- All future processing is done in sfFun and the spawned worker thread. - initFun :: (a, Double) -> m ([(b, Double)], MSF m (a, Double) [(b, Double)]) - initFun (a, t) = do - inp <- newIORef a - out <- newIORef empty - timevar <- newEmptyMVar - tid <- liftIO $ forkIO $ worker inp out timevar 1 1 sf - threadHandler tid - sfFun inp out timevar (a, t) - -- sfFun communicates with the worker thread, sending it the input values - -- and collecting from it the output values. - sfFun :: IORef a -> IORef (Seq (b, Double)) -> MVar Double - -> (a, Double) -> m ([(b, Double)], MSF m (a, Double) [(b, Double)]) - sfFun inp out timevar (a, t) = do - writeIORef inp a -- send the worker the new input - tryPutMVar timevar t -- update the time for the worker - b <- atomicModifyIORef out $ Seq.spanl (\(_,t0) -> t >= t0) --collect ready results - return (toList b, MSF (sfFun inp out timevar)) - -- worker processes the inner, "simulated" signal function. - worker :: IORef a -> IORef (Seq (b, Double)) -> MVar Double - -> DeltaT -> Integer -> Automaton a b -> IO () - worker inp out timevar t count (Automaton sf) = do - a <- readIORef inp -- get the latest input - let (b, sf') = sf a -- do the calculation - s <- deepseq b $ atomicModifyIORef out (\s -> (s |> (b, fromIntegral count/clockrate), s)) - t' <- if Seq.length s > 0 && snd (seqLastElem s) >= t+buffer then takeMVar timevar else return t - worker inp out timevar t' (count+1) sf' - seqLastElem s = Seq.index s (Seq.length s - 1) +asyncV :: (ArrowIO a, NFData c) => + Double -- ^ Clockrate + -> DeltaT -- ^ Amount of time to buffer + -> (ThreadId -> a () ()) -- ^ The thread handler + -> (Automaton (->) b c) -- ^ The automaton to convert to realtime + -> a (b, Time) [(c, Time)] +asyncV clockrate buffer threadHandler sf = initialAIO iod darr where + iod = do + inp <- newEmptyMVar + out <- newIORef empty + timevar <- newEmptyMVar + tid <- forkIO $ worker inp out timevar 1 1 sf + return (tid, inp, out, timevar) + darr (tid, inp, out, timevar) = proc (b,t) -> do + _ <- threadHandler tid -< () + _ <- liftAIO (\b -> tryTakeMVar inp >> putMVar inp b) -< b -- send the worker the new input + _ <- liftAIO (tryPutMVar timevar) -< t -- update the time for the worker + c <- liftAIO (atomicModifyIORef out) -< Seq.spanl (\(_,t0) -> t >= t0) --collect ready results + returnA -< toList c + -- worker processes the inner, "simulated" signal function. + worker inp out timevar t count (Automaton sf) = do + b <- readMVar inp -- get the latest input + let (c, sf') = sf b -- do the calculation + s <- deepseq c $ atomicModifyIORef out (\s -> (s |> (c, fromIntegral count/clockrate), s)) + t' <- if Seq.length s > 0 && snd (seqLastElem s) >= t+buffer then takeMVar timevar else return t + worker inp out timevar t' (count+1) sf' + seqLastElem s = Seq.index s (Seq.length s - 1) -data AsyncInput a = AINoValue | AIClearBuffer | AIValue a -data AsyncOutput b = AONoValue | AOCalculating Int | AOValue b --- | The async function takes a pure signal function (an Automaton) and converts +-- | The asyncE function takes a pure signal function (an Automaton) and converts -- it into an asynchronous signal function usable in a MonadIO signal -- function context. The output MSF takes events of type a, feeds them to -- the asynchronously running input SF, and returns events with the output @@ -504,46 +498,91 @@ -- nothing, and the output stream is either a result value, a AOCalculating -- indicating that the asynchronous function is calculating and giving the -- buffer size, or nothing. -async :: forall m a b. (Monad m, MonadIO m, MonadFix m, NFData b) => - (ThreadId -> m ()) -- ^ The thread handler - -> Automaton a b -- ^ The automaton to convert to asynchronize - -> MSF m (AsyncInput a) (AsyncOutput b) -async threadHandler sf = delay AINoValue >>> MSF initFun - where - -- initFun creates some refs and threads and is never used again. - -- All future processing is done in sfFun and the spawned worker thread. - initFun :: (AsyncInput a) -> m ((AsyncOutput b), MSF m (AsyncInput a) (AsyncOutput b)) - initFun ea = do - inp <- newIORef empty - out <- newIORef empty - proceed <- newEmptyMVar - tid <- liftIO $ forkIO $ worker proceed inp out sf - threadHandler tid - sfFun 0 proceed inp out ea - -- sfFun communicates with the worker thread, sending it the input values - -- and collecting from it the output values. - sfFun :: Int -> MVar () -> IORef (Seq a) -> IORef (Seq b) - -> (AsyncInput a) -> m ((AsyncOutput b), MSF m (AsyncInput a) (AsyncOutput b)) - sfFun count proceed inp out ea = do - count' <- case ea of - AIValue a -> atomicModifyIORef inp (\is -> (is |> a, ())) >> tryPutMVar proceed () >> return (count+1) - AIClearBuffer -> atomicModifyIORef inp (\_ -> (empty, ())) >> tryTakeMVar proceed >> return 0 - AINoValue -> return count - b <- atomicModifyIORef out seqRestHead -- collect any ready results - let (b', count'') = maybe (Nothing, count') (\x -> (Just x, count'-1)) b - b'' = maybe (if count'' <= 0 then AONoValue else AOCalculating count'') AOValue b' - return (b'', MSF (sfFun count'' proceed inp out)) - -- worker processes the inner, "simulated" signal function. - worker :: MVar () -> IORef (Seq a) -> IORef (Seq b) -> Automaton a b -> IO () - worker proceed inp out (Automaton sf) = do - ea <- atomicModifyIORef inp seqRestHead - case ea of - Nothing -> takeMVar proceed >> worker proceed inp out (Automaton sf) - Just a -> do - let (b, sf') = sf a -- do the calculation - deepseq b $ atomicModifyIORef out (\s -> (s |> b, ())) - worker proceed inp out sf' - seqRestHead s = case viewl s of - EmptyL -> (s, Nothing) - a :< s' -> (s', Just a) +asyncE :: (ArrowIO a, ArrowLoop a, ArrowCircuit a, ArrowChoice a, NFData c) => + (ThreadId -> a () ()) -- ^ The thread handler + -> (Automaton (->) b c) -- ^ The automaton to convert to asynchronize + -> a (SEvent b) (SEvent c) +asyncE threadHandler sf = {- delay AINoValue >>> -} initialAIO iod darr where + iod = do + inp <- newIORef empty + out <- newIORef empty + proceed <- newEmptyMVar + tid <- forkIO $ worker proceed inp out sf + return (tid, proceed, inp, out) + -- count should start at 0 + darr (tid, proceed, inp, out) = proc eb -> do + _ <- threadHandler tid -< () + case eb of + Just b -> + liftAIO (\b -> atomicModifyIORef inp (\s -> (s |> b, ())) >> tryPutMVar proceed ()) -< b + Nothing -> returnA -< False + c <- liftAIO (const $ atomicModifyIORef out seqRestHead) -< () + returnA -< c + -- worker processes the inner, "simulated" signal function. + -- worker :: MVar () -> IORef (Seq a) -> IORef (Seq b) -> Automaton a b -> IO () + worker proceed inp out (Automaton sf) = do + eb <- atomicModifyIORef inp seqRestHead + case eb of + Nothing -> takeMVar proceed >> worker proceed inp out (Automaton sf) + Just b -> do + let (c, sf') = sf b -- do the calculation + deepseq c $ atomicModifyIORef out (\s -> (s |> c, ())) + worker proceed inp out sf' + seqRestHead s = case viewl s of + EmptyL -> (s, Nothing) + a :< s' -> (s', Just a) + +-- | asyncC is the continuous async function. +asyncC :: (ArrowIO a, NFData c) => + (ThreadId -> a () ()) -- ^ The thread handler + -> (Automaton (->) b c) -- ^ The automaton to convert to realtime + -> a b [c] +--asyncC th sf = asyncC' th (const . return $ (), return) (first sf) +asyncC threadHandler sf = initialAIO iod darr where + iod = do + inp <- newEmptyMVar + out <- newIORef empty + tid <- forkIO $ worker inp out sf + return (tid, inp, out) + darr (tid, inp, out) = proc b -> do + _ <- threadHandler tid -< () + _ <- liftAIO (\b -> tryTakeMVar inp >> putMVar inp b) -< b -- send the worker the new input + c <- liftAIO (\_ -> atomicModifyIORef out (\s -> (empty,s))) -< () --collect ready results + returnA -< toList c + -- worker processes the inner, "simulated" signal function. + worker inp out (Automaton sf) = do + b <- readMVar inp -- get the latest input + let (c, sf') = sf b -- do the calculation + deepseq c $ atomicModifyIORef out (\s -> (s |> c, ())) + worker inp out sf' + + + + +-- | A version of asyncC that does actions on either end of the automaton +asyncC' :: (ArrowIO a, ArrowLoop a, ArrowCircuit a, ArrowChoice a, NFData b) => + (ThreadId -> a () ()) -- ^ The thread handler + -> (b -> IO d, e -> IO ()) -- ^ Effectful input and output channels for the automaton + -> (Automaton (->) (b,d) (c,e)) -- ^ The automaton to convert to asynchronize + -> a b [c] +asyncC' threadHandler (iAction, oAction) sf = initialAIO iod darr where + iod = do + inp <- newIORef undefined + start <- newEmptyMVar + out <- newIORef empty + tid <- forkIO $ takeMVar start >> worker inp out sf + return (tid, inp, out, start) + darr (tid, inp, out, start) = proc b -> do + _ <- threadHandler tid -< () + _ <- liftAIO $ (\b -> deepseq b $ writeIORef inp b) -< b -- send the worker the new input + c <- initialAIO (putMVar start ()) (const $ liftAIO (\_ -> atomicModifyIORef' out (\s -> (empty,s)))) -< () --collect ready results + returnA -< toList c + -- worker processes the inner, "simulated" signal function. + worker inp out (Automaton sf) = do + b <- readIORef inp -- get the latest input + d <- iAction b + let ((c,e), sf') = sf (b,d) -- do the calculation + oAction e + atomicModifyIORef' out (\s -> (s |> c, ())) + worker inp out sf'
FRP/UISF/Examples/Crud.hs view
@@ -41,7 +41,7 @@ -- | This function will run the crud GUI with the default names. -crud = runUI (350, 400) "CRUD" (crudUISF defaultnames) +crud = runUI (defaultUIParams {uiSize=(350, 400), uiTitle="CRUD"}) (crudUISF defaultnames) -- | main = crud main = crud
FRP/UISF/Examples/Examples.hs view
@@ -12,7 +12,6 @@ import FRP.UISF.SOE (withColor', rgb, polygon) import Numeric (showHex)-import Data.Maybe (listToMaybe, catMaybes) -- | This example displays the time from the start of the GUI application. timeEx :: UISF () ()@@ -21,7 +20,7 @@ -- | This example shows off buttons and state by presenting a plus and -- minus button with a counter that is adjusted by them. buttonEx :: UISF () ()-buttonEx = title "Buttons" $ proc _ -> do+buttonEx = title "Buttons" $ topDown $ proc _ -> do (x,y) <- leftRight (proc _ -> do x <- edge <<< button "+" -< () y <- edge <<< button "-" -< ()@@ -34,7 +33,7 @@ -- | This example shows off the checkbox widgets. checkboxEx :: UISF () ()-checkboxEx = title "Checkboxes" $ proc _ -> do+checkboxEx = title "Checkboxes" $ topDown $ proc _ -> do x <- checkbox "Monday" False -< () y <- checkbox "Tuesday" True -< () z <- checkbox "Wednesday" True -< ()@@ -46,13 +45,13 @@ -- | This example shows off the radio button widget. radioButtonEx :: UISF () ()-radioButtonEx = title "Radio Buttons" $ radio list 0 >>> arr (list!!) >>> displayStr+radioButtonEx = title "Radio Buttons" $ topDown $ radio list 0 >>> arr (list!!) >>> displayStr where list = ["apple", "orange", "banana"] -- | This example shows off integral sliders (horizontal in the case). shoppinglist :: UISF () ()-shoppinglist = title "Shopping List" $ proc _ -> do+shoppinglist = title "Shopping List" $ topDown $ proc _ -> do a <- title "apples" $ hiSlider 1 (0,10) 3 -< () b <- title "bananas" $ hiSlider 1 (0,10) 7 -< () title "total" $ display -< (a + b)@@ -82,7 +81,8 @@ -- that text is transferred to the display widget below when the button -- is pressed. textboxdemo :: UISF () ()-textboxdemo = proc _ -> do+textboxdemo = setLayout (makeLayout (Stretchy 150) (Fixed 100)) $ + title "Saving Text" $ topDown $ proc _ -> do str <- leftRight $ label "Text: " >>> textboxE "" -< Nothing b <- button "Save text to below" -< () rec str' <- delay "" -< if b then str else str'@@ -95,7 +95,7 @@ -- behavior built in to the GUI. Pressing tab cycles through focuable -- elements, and pressing shift-tab cycles in reverse. main :: IO ()-main = runUI (500,500) "UI Demo" $ - (leftRight $ (bottomUp $ timeEx >>> buttonEx) >>> checkboxEx >>> radioButtonEx) >>>- (leftRight $ shoppinglist >>> colorDemo) >>> textboxdemo+main = runUI (defaultUIParams {uiSize=(500, 500)}) $ + (leftRight $ (bottomUp $ timeEx >>> buttonEx) >>> (topDown $ checkboxEx >>> arr id) >>> radioButtonEx) >>>+ (leftRight $ shoppinglist >>> colorDemo) >>> textboxdemo >>> arr id
FRP/UISF/Examples/Pinochle.hs view
@@ -15,6 +15,8 @@ -- make sure to use "ghc --make -main-is FRP.UISF.Examples.Pinochle -O2 pinochle.hs" for best performance +-- TODO: Perhaps make the "calculate meld" button disabled when it is mid-calculation + {-# LANGUAGE Arrows, BangPatterns #-} module FRP.UISF.Examples.Pinochle where import FRP.UISF hiding (accum) @@ -98,7 +100,7 @@ ------------------------------------------------------------- -- The main running function -main = runUI (800,700) "Pinochole Assistant" pinochleSF +main = runUI (defaultUIParams {uiSize=(800, 700), uiTitle="Pinochle Assistant"}) pinochleSF pinochleSF :: UISF () () pinochleSF = proc _ -> do @@ -124,24 +126,20 @@ _ -> Nothing restr <- checkbox "Restrict trump suit?" False -< () b <- edge <<< button "Calculate meld from kitty" -< () - kre <- (asyncUISF $ toAutomaton $ uncurry $ uncurry kittyResult) -< toAsyncInput $ + kre <- (asyncUISFE $ arr $ uncurry $ uncurry kittyResult) -< fmap (const ((hand, kittenSizeStr), if restr then Just trump else Nothing)) b - k <- hold [] -< case (clearEv, kre) of - (Just _, _) -> Just [] - (Nothing, AOValue (r,_)) -> Just r - (Nothing, AOCalculating _) -> Just ["Calculating ..."] + k <- hold [] -< case (clearEv, kre, b) of + (Just _, _, _) -> Just [] + (Nothing, Just (r,_), _) -> Just r + (Nothing, _, Just _) -> Just ["Calculating ..."] _ -> Nothing displayStrList -< k - histogramWithScale (makeLayout (Stretchy 10) (Fixed 150)) -< case (clearEv, kre) of - (Just _, _) -> Just [] - (_, AOValue (_,m)) -> Just $ prepHistogramData m - (_, AOCalculating _) -> Just [] + histogramWithScale (makeLayout (Stretchy 10) (Fixed 150)) -< case (clearEv, kre, b) of + (Just _, _, _) -> Just [] + (_, Just (_,m), _) -> Just $ prepHistogramData m + (_, _, Just _) -> Just [] _ -> Nothing returnA -< () - -toAsyncInput :: SEvent a -> AsyncInput a -toAsyncInput (Just a) = AIValue a -toAsyncInput Nothing = AINoValue prepHistogramData :: Map.Map Int Int -> [(Double, String)]
FRP/UISF/Examples/SevenGuis.lhs view
@@ -67,7 +67,7 @@ to pass it to runUI. > counter :: IO ()-> counter = runUI (250,24) "Counter" counterSF+> counter = runUI (defaultUIParams {uiSize=(250, 24), uiTitle="Counter"}) counterSF > gui1 = counter @@ -107,7 +107,7 @@ > updateF = fmap (\c -> show $ round $ c * (9/5) + 32) cNum > returnA -< () >-> tempConvert = runUI (400,24) "Temp Converter" tempCovertSF+> tempConvert = runUI (defaultUIParams {uiSize=(400, 24), uiTitle="Temp Converter"}) tempCovertSF > gui2 = tempConvert @@ -136,7 +136,7 @@ > timeInputTextbox :: TimeLocale -> String -> String -> UISF () (SEvent UTCTime) > timeInputTextbox tl format start = leftRight $ proc _ -> do-> t <- delay "" <<< textboxE start -< Nothing+> t <- textboxE start -< Nothing > let ret = readTimeMaybe tl format t > case ret of > Just _ -> returnA -< ret@@ -158,7 +158,7 @@ > flightBookerSF :: TimeLocale -> UTCTime -> UISF () () > flightBookerSF tl currentTime = proc _ -> do-> choice <- delay 0 <<< radio ["one-way flight","return flight"] 0 -< ()+> choice <- radio ["one-way flight","return flight"] 0 -< () > t1 <- timeInputTextbox tl format (formatTime tl format currentTime) -< () > t2 <- case choice of > 1 -> timeInputTextbox tl format (formatTime tl format currentTime) -< ()@@ -182,7 +182,8 @@ > verifyGreater (Just t1) (Just t2) = t1 < t2 > verifyGreater _ _ = False > -> flightBooker = getCurrentTime >>= \time -> runUI (800,200) "Flight Booker" (flightBookerSF defaultTimeLocale time)+> flightBooker = getCurrentTime >>= \time -> runUI (defaultUIParams {uiSize=(800, 200), uiTitle="Flight Booker"}) +> (flightBookerSF defaultTimeLocale time) > gui3 = flightBooker @@ -230,7 +231,7 @@ > _ -> e + dt > returnA -< () > -> timerGUI = runUI (800,200) "Timer" timerGUISF+> timerGUI = runUI (defaultUIParams {uiSize=(800, 200), uiTitle="Timer"}) timerGUISF > gui4 = timerGUI @@ -343,7 +344,7 @@ > filterFun str name = and (map (\s -> isInfixOf s (map toLower $ show name)) (words (map toLower str))) > lst `at` index = if index >= length lst || index < 0 then NameEntry "" "" else lst!!index > -> crud = runUI (450, 400) "CRUD" (crudSF defaultnames)+> crud = runUI (defaultUIParams {uiSize=(450, 400), uiTitle="CRUD"}) (crudSF defaultnames) > gui5 = crud @@ -474,7 +475,7 @@ > (edge <<< button "Redo") -< () > updatesOld <- delay [] -< updates > redoListOld <- delay [] -< redoList-> (leftClicks, rightClicks) <- delay (Nothing, Nothing) <<< circleCanvas -< +> (leftClicks, rightClicks) <- circleCanvas -< > if doUpdate then Just (undoListToCircles updates) else Nothing > let (updates', redoList) = case (undo, redo, leftClicks) of > (Just _, _, _) -> performUndo updatesOld redoListOld@@ -500,7 +501,7 @@ > (minorU, majorU, cancel) <- if isAdjustActive > then do > leftRight (label "Adjust Diameter of circle at" >>> display) -< getCenter adjustC-> newR <- hSlider (2,200) defaultRadius -< ()+> newR <- hSlider (2,200) defaultRadius -< () -- fmap getRadius rightClicks > newRU <- unique -< newR > (setButton, cancelButton) <- leftRight $ (edge <<< button "Set") &&& > (edge <<< button "Cancel") -< ()@@ -511,11 +512,11 @@ > (Nothing, Just _, _) -> removeMinor updates' > (Nothing, Nothing, Just r) -> addMinor adjustC r updates' > _ -> updates'-> let doUpdate = isJust undo || isJust redo || isJust leftClicks || isJust rightClicks +> let doUpdate = isJust undo || isJust redo || isJust leftClicks > || isJust minorU || isJust majorU || isJust cancel > returnA -< () > where defaultRadius = 30 > -> circleDraw = runUI (450, 400) "Circle Draw" circleDrawSF+> circleDraw = runUI (defaultUIParams {uiSize=(450, 400), uiTitle="Circle Draw"}) circleDrawSF > gui6 = circleDraw
FRP/UISF/Examples/fft.hs view
@@ -21,9 +21,7 @@ import Data.Maybe (listToMaybe, catMaybes) import qualified Data.Map as Map -import FRP.UISF.Types.MSF import Data.Array.Unboxed -import Data.Functor.Identity @@ -60,7 +58,7 @@ -- Table-driven oscillator -osc :: Table -> Double -> MSF Identity Double Double +osc :: ArrowCircuit a => Table -> Double -> a Double Double osc table sr = proc freq -> do rec let delta = 1 / sr * freq @@ -126,7 +124,7 @@ returnA -< () where sr = 1000 -- signal rate - myAutomaton = msfiToAutomaton $ proc (f1, f2) -> do + myAutomaton = proc (f1, f2) -> do s1 <- osc tab1 sr -< f1 s2 <- osc tab2 sr -< f2 let s = (s1 + s2)/2 @@ -135,4 +133,4 @@ -- This test is run separately from the others. main :: IO () -main = runUI (500,600) "FFT Example" fftEx +main = runUI (defaultUIParams {uiSize=(500, 600), uiTitle="FFT Example"}) fftEx
FRP/UISF/SOE.hs view
@@ -163,7 +163,7 @@ let charCallback c Press = do ks <- readIORef keyState atomically $ writeTChan eChan Key{ char = c, modifiers = ks, isDown = True} - charCallBack c Release = return () -- This never happens + charCallback c Release = return () -- This never happens let keyCallBack (CharKey c) Press = do -- ks <- readIORef keyState -- atomically $ writeTChan eChan Key{ char = c, modifiers = ks, isDown = True}
− FRP/UISF/Types/MSF.hs
@@ -1,170 +0,0 @@------------------------------------------------------------------------------ --- | --- Module : FRP.UISF.Types.MSF --- Copyright : (c) Daniel Winograd-Cort 2014 --- License : see the LICENSE file in the distribution --- --- Maintainer : dwc@cs.yale.edu --- Stability : experimental --- --- MSF is a monadic signal function. - -{-# LANGUAGE CPP, RecursiveDo, FlexibleInstances, MultiParamTypeClasses, OverlappingInstances #-} - -module FRP.UISF.Types.MSF where - -#if __GLASGOW_HASKELL__ >= 610 -import Control.Category -import Prelude hiding ((.)) -#endif -import Control.Arrow -import Control.Arrow.Operations -import Control.Monad.Fix - --- | The MSF data type describes a monadic signal function. --- Essentially, it is a Kleisli automaton, but we define it --- explicitly here. -data MSF m a b = MSF { msfFun :: (a -> m (b, MSF m a b)) } - - -#if __GLASGOW_HASKELL__ >= 610 -instance Monad m => Category (MSF m) where - id = MSF h where h x = return (x, MSF h) - MSF g . MSF f = MSF (h f g) - where h f g x = do (y, MSF f') <- f x - (z, MSF g') <- g y - return (z, MSF (h f' g')) - -instance Monad m => Arrow (MSF m) where - arr f = MSF h - where h x = return (f x, MSF h) - first (MSF f) = MSF (h f) - where h f (x, z) = do (y, MSF f') <- f x - return ((y, z), MSF (h f')) - f &&& g = MSF (h f g) - where - h f g x = do - (y, f') <- msfFun f x - (z, g') <- msfFun g x - return ((y, z), MSF (h f' g')) - f *** g = MSF (h f g) - where - h f g x = do - (y, f') <- msfFun f (fst x) - (z, g') <- msfFun g (snd x) - return ((y, z), MSF (h f' g')) -#else -instance Monad m => Arrow (MSF m) where - arr f = MSF h - where h x = return (f x, MSF h) - MSF f >>> MSF g = MSF (h f g) - where h f g x = do (y, MSF f') <- f x - (z, MSF g') <- g y - return (z, MSF (h f' g')) - first (MSF f) = MSF (h f) - where h f (x, z) = do (y, MSF f') <- f x - return ((y, z), MSF (h f')) - f &&& g = MSF (h f g) - where - h f g x = do - (y, f') <- msfFun f x - (z, g') <- msfFun g x - return ((y, z), MSF (h f' g')) - f *** g = MSF (h f g) - where - h f g x = do - (y, f') <- msfFun f (fst x) - (z, g') <- msfFun g (snd x) - return ((y, z), MSF (h f' g')) -#endif - -instance MonadFix m => ArrowLoop (MSF m) where - loop (MSF f) = MSF (h f) - where h f x = do rec ((y, z), MSF f') <- f (x, z) - return (y, MSF (h f')) - -instance Monad m => ArrowChoice (MSF m) where - left msf = MSF (h msf) - where h msf x = case x of - Left x' -> do (y, msf') <- msfFun msf x' - return (Left y, MSF (h msf')) - Right y -> return (Right y, MSF (h msf)) - f ||| g = MSF (h f g) - where h f g x = case x of - Left b -> do (d, f') <- msfFun f b - return (d, MSF (h f' g)) - Right c -> do (d, g') <- msfFun g c - return (d, MSF (h f g')) - - -instance MonadFix m => ArrowCircuit (MSF m) where - delay i = MSF (h i) where h i x = return (i, MSF (h x)) - --- * MSF Constructors - --- $ The source, sink, and pipe functions allow one to lift a monadic --- action to the MSF data type. -source :: Monad m => m c -> MSF m () c -sink :: Monad m => (b -> m ()) -> MSF m b () -pipe :: Monad m => (b -> m c) -> MSF m b c -source f = MSF h where h _ = f >>= return . (\x -> (x, MSF h)) -sink f = MSF h where h x = f x >> return ((), MSF h) -pipe f = MSF h where h x = f x >>= return . (\x -> (x, MSF h)) - --- $ The sourceE, sinkE, and pipeE functions allow one to lift a monadic --- action to the MSF data type in event form. -sourceE :: Monad m => m c -> MSF m (Maybe ()) (Maybe c) -sinkE :: Monad m => (b -> m ()) -> MSF m (Maybe b) (Maybe ()) -pipeE :: Monad m => (b -> m c) -> MSF m (Maybe b) (Maybe c) -sourceE f = MSF h where h = maybe (return (Nothing, MSF h)) (\_ -> f >>= return . (\c -> (Just c, MSF h))) -sinkE f = MSF h where h = maybe (return (Nothing, MSF h)) (\b -> f b >> return (Just (), MSF h)) -pipeE f = MSF h where h = maybe (return (Nothing, MSF h)) (\b -> f b >>= return . (\c -> (Just c, MSF h))) - --- | This function first performs a monadic action and then uses the --- result of that action to complete the MSF. -initialAction :: Monad m => m x -> (x -> MSF m a b) -> MSF m a b -initialAction mx f = MSF $ \a -> do - x <- mx - msfFun (f x) a - --- | This function creates a MSF source based on an infinite list. -listSource :: Monad m => [c] -> MSF m () c -listSource cs = MSF (h cs) where h (c:cs) _ = return (c, MSF (h cs)) - --- * Running MSF - --- | This steps through the given MSF using the [a] as inputs. --- The result is [b] in the monad. -stepMSF :: Monad m => MSF m a b -> [a] -> m [b] -stepMSF _ [] = return [] -stepMSF (MSF f) (x:xs) = do - (y, f') <- f x - ys <- stepMSF f' xs - return (y:ys) - --- | This is the same as 'stepMSF' but additionally returns the --- next computation. -stepMSF' :: Monad m => MSF m a b -> [a] -> m ([b], MSF m a b) -stepMSF' g [] = return ([], g) -stepMSF' (MSF f) (x:xs) = do - (y, f') <- f x - (ys, g) <- stepMSF' f' xs - return (y:ys, g) - --- | The stream data type is used to \"stream\" the results of --- running an MSF. -data Stream m b = Stream { stream :: m (b, Stream m b) } --- | Given an input list of values, this produces a stream of --- results that can be unwound as necessary. -streamMSF :: Monad m => MSF m a b -> [a] -> Stream m b -streamMSF (MSF f) (x:xs) = Stream $ do - (y, f') <- f x - return (y, streamMSF f' xs) - --- | This function runs the MSF on a single value. -runMSF :: Monad m => a -> MSF m a b -> m b -runMSF a f = run f where run (MSF f) = do f a >>= run . snd - --- | This function runs an MSF that takes unit input for a single value. -runMSF' :: Monad m => MSF m () b -> m b -runMSF' = runMSF ()
− FRP/UISF/UIMonad.hs
@@ -1,312 +0,0 @@------------------------------------------------------------------------------ --- | --- Module : FRP.UISF.UIMonad --- Copyright : (c) Daniel Winograd-Cort 2014 --- License : see the LICENSE file in the distribution --- --- Maintainer : dwc@cs.yale.edu --- Stability : experimental --- --- A simple Graphical User Interface with concepts borrowed from Phooey --- by Conal Elliot. - -{-# LANGUAGE RecursiveDo #-} - -module FRP.UISF.UIMonad where - -import FRP.UISF.SOE -import FRP.UISF.AuxFunctions (Time) - -import Control.Applicative -import Control.Monad (ap) -import Control.Monad.Fix -import Control.Concurrent.MonadIO - - ------------------------------------------------------------- --- * UI Type Definition ------------------------------------------------------------- - --- | A UI widget runs under a given context and any focus information from --- earlier widgets and maps input signals to outputs, which consists of 6 parts: --- --- - its layout, --- --- - whether the widget needs to be redrawn, --- --- - any focus information that needs to be conveyed to future widgets --- --- - the action (to render graphics or/and sounds), --- --- - any new ThreadIds to keep track of (for proper shutdown when finished), --- --- - and the parametrized output type. - -newtype UI a = UI - { unUI :: (CTX, Focus, Time, UIEvent) -> - IO (Layout, DirtyBit, Focus, Action, ControlData, a) } - --- For reexporting: --- | Lifts an \'IO a\' to a \'UI a\' -ioToUI :: IO a -> UI a -ioToUI = liftIO - ------------------------------------------------------------- --- * Control Data ------------------------------------------------------------- - --- | The control data is simply a list of Thread Ids. -type ControlData = [ThreadId] - --- | No new thread ids. -nullCD :: ControlData -nullCD = [] - --- | A thread handler for the UI monad. -addThreadID :: ThreadId -> UI () -addThreadID t = UI (\(_,f,_,_) -> return (nullLayout, False, f, nullAction, [t], ())) - --- | A method for merging to control data objects. -mergeCD :: ControlData -> ControlData -> ControlData -mergeCD = (++) - - ------------------------------------------------------------- --- * Rendering Context ------------------------------------------------------------- - --- | A rendering context specifies the following: - -data CTX = CTX - { flow :: Flow - -- ^ A layout direction to flow widgets. - - , bounds :: Rect - -- ^ A rectangle bound of current drawing area to render a UI - -- component. It specifies the max size of a widget, not the - -- actual size. It's up to each individual widget to decide - -- where in this bound to put itself. - - , isConjoined :: Bool - -- ^ A flag to tell whether we are in a conjoined state or not. - -- A conjoined context will duplicate itself for subcomponents - -- rather than splitting. This can be useful for making compound - -- widgets when one widget takes up space and the other performs - -- some side effect having to do with that space. - } - --- | Flow determines widget ordering. -data Flow = TopDown | BottomUp | LeftRight | RightLeft deriving (Eq, Show) --- | A dimension specifies size. -type Dimension = (Int, Int) --- | A rectangle has a corner point and a dimension. -type Rect = (Point, Dimension) - - ------------------------------------------------------------- --- * UI Layout ------------------------------------------------------------- - --- $ctc The layout of a widget provides data to calculate its actual size --- in a given context. --- Layout calculation makes use of lazy evaluation to do everything in one pass. --- Although the UI function maps from Context to Layout, all of the fields of --- Layout must be independent of the Context so that they are avaiable before --- the UI function is even evaluated. - --- | Layouts for individual widgets typically come in a few standard flavors, --- so we have this convenience function for their creation. --- This function takes layout information for first the horizontal --- dimension and then the vertical. -makeLayout :: LayoutType -> -- ^ Horizontal Layout information - LayoutType -> -- ^ Vertical Layout information - Layout -makeLayout (Fixed h) (Fixed v) = Layout 0 0 h v h v -makeLayout (Stretchy minW) (Fixed v) = Layout 1 0 0 v minW v -makeLayout (Fixed h) (Stretchy minH) = Layout 0 1 h 0 h minH -makeLayout (Stretchy minW) (Stretchy minH) = Layout 1 1 0 0 minW minH - --- | A dimension can either be: -data LayoutType = - Stretchy { minSize :: Int } - -- ^ Stretchy with a minimum size in pixels - | Fixed { fixedSize :: Int } - -- ^ Fixed with a size measured in pixels - --- | The null layout is useful for \"widgets\" that do not appear or --- take up space on the screen. -nullLayout = Layout 0 0 0 0 0 0 - - --- | More complicated layouts can be manually constructed with direct --- access to the Layout data type. --- --- 1. hFill and vFill specify how much stretching space (in comparative --- units) in the horizontal and vertical directions should be --- allocated for this widget. --- --- 2. hFixed and vFixed specify how much non-stretching space (in pixels) --- of width and height should be allocated for this widget. --- --- 3. minW and minH specify minimum values (in pixels) of width and height --- for the widget's dimensions. - -data Layout = Layout - { hFill :: Int - , vFill :: Int - , hFixed :: Int - , vFixed :: Int - , minW :: Int - , minH :: Int - } deriving (Eq, Show) - - - ------------------------------------------------------------- --- * Context and Layout Functions ------------------------------------------------------------- - ---------------- --- divideCTX -- ---------------- --- | Divides the CTX according to the ratio of a widget's layout and the --- overall layout of the widget that receives this CTX. Therefore, the --- first layout argument should basically be a sublayout of the second. - -divideCTX :: CTX -> Layout -> Layout -> (CTX, CTX) -divideCTX ctx@(CTX a ((x, y), (w, h)) c) - ~(Layout m n u v minw minh) ~(Layout m' n' u' v' minw' minh') = - if c then (ctx, ctx) else - case a of - TopDown -> (CTX a ((x, y), (w'', h')) c, - CTX a ((x, y + h'), (w, h - h')) c) - BottomUp -> (CTX a ((x, y + h - h'), (w'', h')) c, - CTX a ((x, y), (w, h - h')) c) - LeftRight -> (CTX a ((x, y), (w', h'')) c, - CTX a ((x + w', y), (w - w', h)) c) - RightLeft -> (CTX a ((x + w - w', y), (w', h'')) c, - CTX a ((x, y), (w - w', h)) c) - where - w' = max minw (m * div' (w - u') m' + u) - h' = max minh (n * div' (h - v') n' + v) - w'' = max minw (if m == 0 then u else w) - h'' = max minh (if n == 0 then v else h) - div' b 0 = 0 - div' b d = div b d - - ------------------ --- mergeLayout -- ------------------ --- | Merge two layouts into one. - -mergeLayout a (Layout n m u v minw minh) (Layout n' m' u' v' minw' minh') = - case a of - TopDown -> Layout (max' n n') (m + m') (max u u') (v + v') (max minw minw') (minh + minh') - BottomUp -> Layout (max' n n') (m + m') (max u u') (v + v') (max minw minw') (minh + minh') - LeftRight -> Layout (n + n') (max' m m') (u + u') (max v v') (minw + minw') (max minh minh') - RightLeft -> Layout (n + n') (max' m m') (u + u') (max v v') (minw + minw') (max minh minh') - where - max' 0 0 = 0 - max' _ _ = 1 - - ------------------------------------------------------------- --- * Action and System State ------------------------------------------------------------- - --- | Actions include both Graphics and Sound output. Even though both --- are indeed just IO monads, we separate them because Sound output --- must be immediately delivered, while graphics can wait until the --- next screen refresh. -type Action = (Graphic, Sound) --- | A type synonym for sounds. -type Sound = IO () - --- | This is used when there is no sound produced. -nullSound = return () :: Sound --- | This is used when no Action happens at all. -nullAction = (nullGraphic, nullSound) :: Action --- | Convert a Sound to an Action with no Graphic. -justSoundAction :: Sound -> Action -justSoundAction s = (nullGraphic, s) --- | Convert a Graphic to an Action with no Sound. -justGraphicAction :: Graphic -> Action -justGraphicAction g = (g, nullSound) - --- | Merge two actions into one. -mergeAction (g, s) (g', s') = (overGraphic g' g, s >> s') - --- | Use a context to bound the graphical effects of an action. -scissorAction :: CTX -> Action -> Action -scissorAction ctx (g, s) = (scissorGraphic (bounds ctx) g, s) - - --- The Focus and DirtyBit types are for system state. - --- | The Focus type helps focusable widgets communicate with each --- other about which widget is in focus. It consists of a WidgetID --- and a FocusInfo. -type Focus = (WidgetID, FocusInfo) - --- | The WidgetID for any given widget is dynamic based --- on how many focusable widgets are active at the moment. It is designed --- basically as a counter that focusable widgets will automatically (via the --- focusable function) increment. -type WidgetID = Int - --- | The FocusInfo means one of the following: -data FocusInfo = - HasFocus - -- ^ Indicates that this widget is a subwidget of - -- a widget that is in focus. Thus, this widget too is in focus, and - -- this widget should pass HasFocus forward. - | NoFocus - -- ^ Indicates that there is no focus information to - -- communicate between widgets. - | SetFocusTo WidgetID - -- ^ Indicates that the widget whose id is given - -- should take focus. That widget should then pass NoFocus onward. - deriving (Show, Eq) - --- | The dirty bit is a bit to indicate if the widget needs to be redrawn. -type DirtyBit = Bool - ------------------------------------------------------------- --- Monadic Instances ------------------------------------------------------------- - -instance Functor UI where - fmap f ui = ui >>= return . f - -instance Applicative UI where - pure = return - (<*>) = ap - -instance Monad UI where - return i = UI (\(_,foc,_,_) -> return (nullLayout, False, foc, nullAction, nullCD, i)) - - (UI m) >>= f = UI (\(ctx, foc, t, inp) -> do - rec let (ctx1, ctx2) = divideCTX ctx l1 layout - (l1, db1, foc1, a1, cd1, v1) <- m (ctx1, foc, t, inp) - (l2, db2, foc2, a2, cd2, v2) <- unUI (f v1) (ctx2, foc1, t, inp) - let action = (if l1 == nullLayout || l2 == nullLayout then id - else scissorAction ctx) $ mergeAction a1 a2 - layout = mergeLayout (flow ctx) l1 l2 - cd = mergeCD cd1 cd2 - dirtybit = ((||) $! db1) $! db2 - return (layout, dirtybit, foc2, action, cd, v2)) - --- UIs are also instances of MonadFix so that we can define value --- level recursion. - -instance MonadFix UI where - mfix f = UI aux - where - aux (ctx, foc, t, inp) = u - where u = do rec (l, db, foc', a, cd, r) <- unUI (f r) (ctx, foc, t, inp) - return (l, db, foc', a, cd, r) - -instance MonadIO UI where - liftIO a = UI (\(_,foc,_,_) -> a >>= (\v -> return (nullLayout, False, foc, nullAction, nullCD, v))) -
FRP/UISF/UISF.hs view
@@ -13,79 +13,176 @@ {-# LANGUAGE ScopedTypeVariables, Arrows, RecursiveDo, CPP, OverlappingInstances, FlexibleInstances, TypeSynonymInstances #-} module FRP.UISF.UISF ( - UISF, + UISF(..), + uisfSource, uisfSink, uisfPipe, + uisfSourceE, uisfSinkE, uisfPipeE, -- * UISF Getters - getTime, getCTX, getEvents, getFocusData, getMousePosition, + getTime, getCTX, getEvents, getFocusData, addTerminationProc, getMousePosition, -- * UISF constructors, transformers, and converters -- $ctc - mkUISF, mkUISF', expandUISF, compressUISF, transformUISF, - initialIOAction, - uisfSourceE, uisfSinkE, uisfPipeE, + mkUISF, -- * UISF Lifting -- $lifting - toUISF, convertToUISF, asyncUISF, + asyncUISFE, asyncUISFV, --asyncUISFC, -- * Layout Transformers -- $lt leftRight, rightLeft, topDown, bottomUp, conjoin, unconjoin, setLayout, setSize, pad, -- * Execute UI Program + UIParams (..), defaultUIParams, runUI, runUI' ) where #if __GLASGOW_HASKELL__ >= 610 import Control.Category -import Prelude hiding ((.)) +import Prelude hiding ((.), id) #endif import Control.Arrow import Control.Arrow.Operations import FRP.UISF.SOE -import FRP.UISF.UIMonad +import FRP.UISF.UITypes -import FRP.UISF.Types.MSF -import FRP.UISF.AuxFunctions (Automaton, Time, toMSF, toRealTimeMSF, - SEvent, ArrowTime (..), - async, AsyncInput (..), AsyncOutput (..)) +import FRP.UISF.AuxFunctions (Automaton, Time, evMap, + SEvent, ArrowTime (..), ArrowIO (..), + asyncE, asyncV) import Control.Monad (when) -import qualified Graphics.UI.GLFW as GLFW (sleep, SpecialKey (..)) -import Control.Concurrent.MonadIO +import qualified Graphics.UI.GLFW as GLFW (sleep) +import Control.Concurrent import Control.DeepSeq +import Data.IORef +import Control.Exception --- | The main UI signal function, built from the UI monad and MSF. -type UISF = MSF UI +------------------------------------------------------------ +-- UISF Declaration and Instances +------------------------------------------------------------ +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') + -- TODO: custom defs for &&& and *** may improve performance, but they'll end up + -- looking like the ugly compose definition above. Maybe I can find a way to + -- abstract the behavior out so that it's all in one place. + +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 = MSF (h i) where h i x = seq i $ return (i, MSF (h x)) - -- We probably want this to be a deepseq, but changing the types is a pain. + 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 ------------------------------------------------------------ --- * UISF Getters +-- * UISF IO Lifters ------------------------------------------------------------ +-- | Lift an IO source to UISF. +uisfSource :: IO b -> UISF () b +uisfSource = liftAIO . const + +-- | Lift an IO sink to UISF. +uisfSink :: (a -> IO ()) -> UISF a () +uisfSink = liftAIO + +-- | Lift an IO pipe to UISF. +uisfPipe :: (a -> IO b) -> UISF a b +uisfPipe = liftAIO + +-- | Lift an IO source to an event-based UISF. +uisfSourceE :: IO b -> UISF (SEvent ()) (SEvent b) +uisfSourceE = evMap . uisfSource + +-- | Lift an IO sink to an event-based UISF. +uisfSinkE :: (a -> IO ()) -> UISF (SEvent a) (SEvent ()) +uisfSinkE = evMap . uisfSink + +-- | Lift an IO pipe to an event-based UISF. +uisfPipeE :: (a -> IO b) -> UISF (SEvent a) (SEvent b) +uisfPipeE = evMap . uisfPipe + + +------------------------------------------------------------ +-- * UISF Getters and Convenience Constructor +------------------------------------------------------------ + -- | Get the time signal from a UISF getTime :: UISF () Time -getTime = mkUISF (\_ (_,f,t,_) -> (nullLayout, False, f, nullAction, nullCD, t)) +getTime = mkUISF nullLayout (\(_,f,t,_,_) -> (False, f, nullGraphic, nullTP, t)) -- | Get the context signal from a UISF getCTX :: UISF () CTX -getCTX = mkUISF (\_ (c,f,_,_) -> (nullLayout, False, f, nullAction, nullCD, c)) +getCTX = mkUISF nullLayout (\(c,f,_,_,_) -> (False, f, nullGraphic, nullTP, c)) -- | Get the UIEvent signal from a UISF getEvents :: UISF () UIEvent -getEvents = mkUISF (\_ (_,f,_,e) -> (nullLayout, False, f, nullAction, nullCD, e)) +getEvents = mkUISF nullLayout (\(_,f,_,e,_) -> (False, f, nullGraphic, nullTP, e)) -- | Get the focus data from a UISF getFocusData :: UISF () Focus -getFocusData = mkUISF (\_ (_,f,_,_) -> (nullLayout, False, f, nullAction, nullCD, f)) +getFocusData = mkUISF nullLayout (\(_,f,_,_,_) -> (False, f, nullGraphic, nullTP, f)) +-- | A thread handler for UISF. +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) + -- | Get the mouse position from a UISF getMousePosition :: UISF () Point getMousePosition = proc _ -> do @@ -96,72 +193,16 @@ _ -> p' returnA -< p - ------------------------------------------------------------- --- * UISF constructors, transformers, and converters ------------------------------------------------------------- - --- $ctc These fuctions are various shortcuts for creating UISFs. --- The types pretty much say it all for how they work. - -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)) -{-# INLINE expandUISF #-} -expandUISF (MSF f) = unUI . f - -compressUISF :: (a -> (CTX, Focus, Time, UIEvent) -> IO (Layout, DirtyBit, Focus, Action, ControlData, (b, UISF a b))) -> UISF a b -{-# INLINE compressUISF #-} -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) - --- | Apply the given IO action when this UISF is first run and use its --- result to produce the UISF to run -initialIOAction :: IO x -> (x -> UISF a b) -> UISF a b -initialIOAction = initialAction . liftIO - --- source, sink, and pipe functions --- DWC Note: I don't feel comfortable with how generic these are. --- Also, the continuous ones can't work. --- --- uisfSource :: IO c -> UISF () c --- uisfSink :: (b -> IO ()) -> UISF b () --- uisfPipe :: (b -> IO c) -> UISF b c --- uisfSource = source . liftIO --- uisfSink = sink . (liftIO .) --- uisfPipe = pipe . (liftIO .) - --- | Generate a source UISF from the IO action. -uisfSourceE :: IO c -> UISF (SEvent ()) (SEvent c) -uisfSourceE = (delay Nothing >>>) . sourceE . liftIO - --- | Generate a sink UISF from the IO action. -uisfSinkE :: (b -> IO ()) -> UISF (SEvent b) (SEvent ()) -uisfSinkE = (delay Nothing >>>) . sinkE . (liftIO .) - --- | Generate a pipe UISF from the IO action. -uisfPipeE :: (b -> IO c) -> UISF (SEvent b) (SEvent c) -uisfPipeE = (delay Nothing >>>) . pipeE . (liftIO .) - +-- | This function creates a UISF with the given parameters. +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) ------------------------------------------------------------ -- * UISF Lifting ------------------------------------------------------------ - --- $lifting The following two functions are for lifting SFs to UISFs. - --- | This is a quick and dirty solution that ignores timing issues. -toUISF :: Automaton a b -> UISF a b -toUISF = toMSF +-- $lifting The following two functions are for lifting Automatons to UISFs. -- | This is the standard one that appropriately keeps track of -- simulated time vs real time. @@ -178,15 +219,15 @@ -- Note also that the caller can check the time stamp on the element -- at the end of the list to see if the inner, "simulated" signal -- function is performing as fast as it should. -convertToUISF :: NFData b => Double -> Double -> Automaton a b -> UISF a [(b, Time)] -convertToUISF clockrate buffer sf = proc a -> do +asyncUISFV :: NFData b => Double -> Double -> Automaton (->) a b -> UISF a [(b, Time)] +asyncUISFV clockrate buffer sf = proc a -> do t <- time -< () - toRealTimeMSF clockrate buffer addThreadID sf -< (a, t) + asyncV clockrate buffer (addTerminationProc . killThread) sf -< (a, t) -- | We can also lift a signal function to a UISF asynchronously. -asyncUISF :: NFData b => Automaton a b -> UISF (AsyncInput a) (AsyncOutput b) -asyncUISF = async addThreadID +asyncUISFE :: NFData b => Automaton (->) a b -> UISF (SEvent a) (SEvent b) +asyncUISFE = asyncE (addTerminationProc . killThread) ------------------------------------------------------------ @@ -196,29 +237,34 @@ -- $lt These functions are UISF transformers that modify the context. 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}) +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 :: (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) +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) + -- | Set a new layout for this widget. 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) +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) -- | A convenience function for setLayout, setSize sets the layout to a -- fixed size (in pixels). @@ -227,82 +273,114 @@ -- | Add space padding around a widget. 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) +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) ------------------------------------------------------------ -- * Execute UI Program ------------------------------------------------------------ -defaultSize :: Dimension -defaultSize = (300, 300) -defaultCTX :: Dimension -> CTX -defaultCTX size = CTX TopDown ((0,0), size) False +-- | The UIParams data type provides an interface for modifying some +-- of the settings for runUI without forcing runUI to take a zillion +-- arguments. Typical usage will be to modify the below defaultUIParams +-- using record syntax. +data UIParams = UIParams { + uiInitialize :: IO () -- ^ An initialization action. + , uiClose :: IO () -- ^ A termination action. + , uiTitle :: String -- ^ The UI window's title. + , uiSize :: Dimension -- ^ The size of the UI window. + , uiInitFlow :: Flow -- ^ The initial Flow setting. + , uiTickDelay :: Double -- ^ How long the UI will sleep between clock + -- ticks if no events are detected. This + -- should be probably be set to O(milliseconds), + -- but it can be set to 0 for better performance + -- (but also higher CPU usage) +} + +-- | This is the default UIParams value and what is used in runUI'. +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) --- | Run the UISF with the default size (300 x 300). -runUI' :: String -> UISF () () -> IO () -runUI' = runUI defaultSize +-- | Run the UISF with the default settings. +runUI' :: UISF () () -> IO () +runUI' = runUI defaultUIParams --- | Run the UISF -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 - -- poll events before we start to make sure event queue isn't empty - 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) - -- always output sound - sound - -- and delay graphical output when event queue is not empty - setGraphic' w graphic - let drawit = dirty || drawit' - newtids = tids'++tids - foc' = resetFocus foc - foc' `seq` newtids `seq` case inp of - -- Timer only comes in when we are done processing user events - NoUIEvent -> do - -- output graphics - 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 ())) [] - -- wait a little while before all Midi messages are flushed - GLFW.sleep 0.5 - mapM_ killThread tids +-- | Run the UISF with the given parameters. +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 + --mapM_ killThread tids + uiClose p + go tref w = runGraphics $ do + (events, addEv) <- makeStream + let pollEvents = windowUser (uiTickDelay p) w addEv + -- poll events before we start to make sure event queue isn't empty + 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, ()) + -- delay graphical output when event queue is not empty + setGraphic' w graphic + let drawit = dirty || drawit' + foc' = resetFocus foc + atomicModifyIORef' tref (\tproc -> (mergeTP tproc' tproc, ())) + foc' `seq` case inp of + -- Timer only comes in when we are done processing user events + NoUIEvent -> do + -- output graphics + 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 + -- wait a little while before all Midi messages are flushed + GLFW.sleep 0.5 -windowUser :: Window -> (UIEvent -> IO ()) -> IO Bool -windowUser w addEv = do +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 0.001 w + mev <- maybeGetWindowEvent tickDelay w case mev of Nothing -> return False Just e -> case e of
+ FRP/UISF/UITypes.hs view
@@ -0,0 +1,273 @@+----------------------------------------------------------------------------- +-- | +-- Module : FRP.UISF.UIMonad +-- Copyright : (c) Daniel Winograd-Cort 2014 +-- License : see the LICENSE file in the distribution +-- +-- Maintainer : dwc@cs.yale.edu +-- Stability : experimental + +{-# LANGUAGE RecursiveDo #-} + +module FRP.UISF.UITypes where + +import FRP.UISF.SOE +import FRP.UISF.AuxFunctions (mergeE) + +------------------------------------------------------------ +-- * UI Types +------------------------------------------------------------ + +-- $uitypes +-- Widgets are arrows that map multiple inputs to multiple outputs. +-- Additionally, they have a relatively static layout argument that, +-- while it can change over time, is not dependent on any of its +-- inputs at any given moment. +-- +-- On the input end, a widget will accept: +-- +-- - a graphical context, +-- +-- - some information about which widget is in focus (for the purposes +-- of routing key presses and mouse clicks and potentially for drawing +-- the widget differently), +-- +-- - and the current time. +-- +-- On the output end, a widget will produce from these inputs: +-- +-- - an indicator of whether the widget needs to be redrawn, +-- +-- - any focus information that needs to be conveyed to future widgets, +-- +-- - the graphics to render to display this widget, +-- +-- - and any new ThreadIds to keep track of (for proper shutdown when finished). +-- +-- Additionally, as widgets are generic arrows, there will be a parameterized +-- inputs and output type. +-- +-- In this file, we will declare the various types to make creating the overall +-- UI possible. For the widget type itself, see UISF in FRP.UISF.UISF. + + +------------------------------------------------------------ +-- * Control Data +------------------------------------------------------------ + +-- | The control data is simply a list of Thread Ids. +type TerminationProc = Maybe (IO ()) + +-- | No new thread ids. +nullTP :: TerminationProc +nullTP = Nothing + +-- | A method for merging to control data objects. +mergeTP :: TerminationProc -> TerminationProc -> TerminationProc +mergeTP = mergeE (>>) + + +------------------------------------------------------------ +-- * Rendering Context +------------------------------------------------------------ + +-- | A rendering context specifies the following: + +data CTX = CTX + { flow :: Flow + -- ^ A layout direction to flow widgets. + + , bounds :: Rect + -- ^ A rectangle bound of current drawing area to render a UI + -- component. It specifies the max size of a widget, not the + -- actual size. It's up to each individual widget to decide + -- where in this bound to put itself. + + , isConjoined :: Bool + -- ^ A flag to tell whether we are in a conjoined state or not. + -- A conjoined context will duplicate itself for subcomponents + -- rather than splitting. This can be useful for making compound + -- widgets when one widget takes up space and the other performs + -- some side effect having to do with that space. + } deriving Show + +-- | Flow determines widget ordering. +data Flow = TopDown | BottomUp | LeftRight | RightLeft deriving (Eq, Show) +-- | A dimension specifies size. +type Dimension = (Int, Int) +-- | A rectangle has a corner point and a dimension. +type Rect = (Point, Dimension) + + +------------------------------------------------------------ +-- * UI Layout +------------------------------------------------------------ + +-- $ctc The layout of a widget provides data to calculate its actual size +-- in a given context. +-- Layout calculation makes use of lazy evaluation to do everything in one pass. +-- Although the UI function maps from Context to Layout, all of the fields of +-- Layout must be independent of the Context so that they are avaiable before +-- the UI function is even evaluated. + +-- | Layouts for individual widgets typically come in a few standard flavors, +-- so we have this convenience function for their creation. +-- This function takes layout information for first the horizontal +-- dimension and then the vertical. +makeLayout :: LayoutType -> -- ^ Horizontal Layout information + LayoutType -> -- ^ Vertical Layout information + Layout +makeLayout (Fixed h) (Fixed v) = Layout 0 0 h v 0 0 +makeLayout (Stretchy minW) (Fixed v) = Layout 1 0 0 v minW 0 +makeLayout (Fixed h) (Stretchy minH) = Layout 0 1 h 0 0 minH +makeLayout (Stretchy minW) (Stretchy minH) = Layout 1 1 0 0 minW minH + +-- | A dimension can either be: +data LayoutType = + Stretchy { minSize :: Int } + -- ^ Stretchy with a minimum size in pixels + | Fixed { fixedSize :: Int } + -- ^ Fixed with a size measured in pixels + +-- | The null layout is useful for \"widgets\" that do not appear or +-- take up space on the screen. +nullLayout = Layout 0 0 0 0 0 0 + + +-- | More complicated layouts can be manually constructed with direct +-- access to the Layout data type. +-- +-- 1. hFill and vFill specify how much stretching space (in comparative +-- units) in the horizontal and vertical directions should be +-- allocated for this widget. +-- +-- 2. hFixed and vFixed specify how much non-stretching space (in pixels) +-- of width and height should be allocated for this widget. +-- +-- 3. minW and minH specify minimum values (in pixels) of width and height +-- for the widget's stretchy dimensions. + +data Layout = Layout + { hFill :: Int + , vFill :: Int + , hFixed :: Int + , vFixed :: Int + , minW :: Int + , minH :: Int + } deriving (Eq, Show) + + + +------------------------------------------------------------ +-- * Context and Layout Functions +------------------------------------------------------------ + +--------------- +-- divideCTX -- +--------------- +-- | Divides the CTX among the two given layouts. + +divideCTX :: CTX -> Layout -> Layout -> (CTX, CTX) +divideCTX ctx@(CTX a ((x, y), (w, h)) c) + ~(Layout wFill hFill wFixed hFixed wMin hMin) + ~(Layout wFill' hFill' wFixed' hFixed' wMin' hMin') = + if c then (ctx, ctx) else + case a of + TopDown -> (CTX a ((x, y), (w1T, h1T)) c, + CTX a ((x, y + h1T), (w2T, h2T)) c) + BottomUp -> (CTX a ((x, y + h - h1T), (w1T, h1T)) c, + CTX a ((x, y + h - h1T - h2T), (w2T, h2T)) c) + LeftRight -> (CTX a ((x, y), (w1L, h1L)) c, + CTX a ((x + w1L, y), (w2L, h2L)) c) + RightLeft -> (CTX a ((x + w - w1L, y), (w1L, h1L)) c, + CTX a ((x + w - w1L - w2L, y), (w2L, h2L)) c) + where + -- The commented out code here forces the contexts to match exactly + -- what the layout requests. The code in place matches to the first + -- layout and then gives the rest of the context to the second. + -- A more robust design may require a special "filler" layout that + -- is not stretchy but will accept any leftover pixels. We could + -- then have a filler widget that is essentially (arr id) with this + -- special layout. + wportion fill = div' (fill * (w - wFixed - wFixed')) (wFill + wFill') + (w1L,w2L) = let w1 = wFixed + max wMin (wportion wFill) + w2 = wFixed' + max wMin' (wportion wFill') + in (w1, w-w1) --if w1+w2 > w then (w1, w-w1) else (w1, w2) + h1L = h --max hMin (if hFill == 0 then hFixed else h) + h2L = h --max hMin' (if hFill' == 0 then hFixed' else h) + hportion fill = div' (fill * (h - hFixed - hFixed')) (hFill + hFill') + (h1T,h2T) = let h1 = hFixed + max hMin (hportion hFill) + h2 = hFixed' + max hMin' (hportion hFill') + in (h1, h-h1) --if h1+h2 > h then (h1, h-h1) else (h1, h2) + w1T = w --max wMin (if wFill == 0 then wFixed else w) + w2T = w --max wMin' (if wFill' == 0 then wFixed' else w) + div' b 0 = 0 + div' b d = div b d + + +----------------- +-- mergeLayout -- +----------------- +-- | Merge two layouts into one. + +mergeLayout :: Flow -> Layout -> Layout -> Layout +mergeLayout a (Layout n m u v minw minh) (Layout n' m' u' v' minw' minh') = + case a of + TopDown -> Layout (max' n n') (m + m') (max u u') (v + v') (max minw minw') (minh + minh') + BottomUp -> Layout (max' n n') (m + m') (max u u') (v + v') (max minw minw') (minh + minh') + LeftRight -> Layout (n + n') (max' m m') (u + u') (max v v') (minw + minw') (max minh minh') + RightLeft -> Layout (n + n') (max' m m') (u + u') (max v v') (minw + minw') (max minh minh') + where + max' 0 0 = 0 + max' _ _ = 1 + + +------------------------------------------------------------ +-- * Graphics and System State +------------------------------------------------------------ + +-- | Merging two graphics can be achieved with overGraphic, but +-- the mergeGraphic function additionally constrains the graphics +-- based on their layouts and the context. +-- TODO: Make sure this works as well as it should +mergeGraphics :: CTX -> (Graphic, Layout) -> (Graphic, Layout) -> Graphic +mergeGraphics ctx (g1, l1) (g2, l2) = case (l1 == nullLayout, l2 == nullLayout) of + (True, True) -> nullGraphic + (True, False) -> g2 + (False, True) -> g1 + (False, False) -> overGraphic g2 g1 + + +-- The Focus and DirtyBit types are for system state. + +-- | The Focus type helps focusable widgets communicate with each +-- other about which widget is in focus. It consists of a WidgetID +-- and a FocusInfo. +type Focus = (WidgetID, FocusInfo) + +-- | The WidgetID for any given widget is dynamic based +-- on how many focusable widgets are active at the moment. It is designed +-- basically as a counter that focusable widgets will automatically (via the +-- focusable function) increment. +type WidgetID = Int + +-- | The FocusInfo means one of the following: +data FocusInfo = + HasFocus + -- ^ Indicates that this widget is a subwidget of + -- a widget that is in focus. Thus, this widget too is in focus, and + -- this widget should pass HasFocus forward. + | NoFocus + -- ^ Indicates that there is no focus information to + -- communicate between widgets. + | SetFocusTo WidgetID + -- ^ Indicates that the widget whose id is given + -- should take focus. That widget should then pass NoFocus onward. + deriving (Show, Eq) + +-- | The dirty bit is a bit to indicate if the widget needs to be redrawn. +type DirtyBit = Bool + + + +
FRP/UISF/Widget.hs view
@@ -21,7 +21,7 @@ module FRP.UISF.Widget where import FRP.UISF.SOE -import FRP.UISF.UIMonad +import FRP.UISF.UITypes import FRP.UISF.UISF import FRP.UISF.AuxFunctions (SEvent, Time, timer, edge, delay, constA, concatA) @@ -144,8 +144,7 @@ -- textbox when an event occurs. textboxE :: String -> UISF (SEvent String) String textboxE startingVal = proc ms -> do - rec s' <- delay startingVal -< ts - let s = maybe s' id ms + rec s <- delay startingVal -< ts ts <- textbox -< maybe s id ms returnA -< ts @@ -154,20 +153,18 @@ ----------- -- | Title frames a UI by borders, and displays a static title text. title :: String -> UISF a b -> UISF a b -title l uisf = compressUISF (modsf uisf) - where - (tw, th) = (length l * 8, 16) - drawit ((x, y), (w, h)) g = - withColor Black (text (x + 10, y) l) - // withColor' bg (block ((x + 8, y), (tw + 4, th))) - // box marked ((x, y + 8), (w, h - 16)) - // g - modsf sf a (CTX _ bbx@((x,y), (w,h)) _,f,t,inp) = do - (l,db,f',action,ts,(v,nextSF)) <- expandUISF sf a (CTX TopDown ((x + 4, y + 20), (w - 8, h - 32)) - False, f, t, inp) - let d = l { hFixed = hFixed l + 8, vFixed = vFixed l + 36, - minW = max (tw + 20) (minW l), minH = max 36 (minH l) } - return (d, db, f', first (drawit bbx) action, ts, (v,compressUISF (modsf nextSF))) +title str (UISF fl f) = UISF layout h where + (tw, th) = (length str * 8, 16) + drawit ((x, y), (w, h)) = + withColor Black (text (x + 10, y) str) + // withColor' bg (block ((x + 8, y), (tw + 4, th))) + // box marked ((x, y + 8), (w, h - 16)) + layout ctx = let l = fl ctx in l { hFixed = hFixed l + tw, vFixed = vFixed l + 36 } + -- ,minW = max (tw + 20) (minW l), minH = max 36 (minH l) } + h (CTX flow bbx@((x,y), (w,h)) cj,foc,t,inp, a) = + let ctx' = CTX flow ((x + 4, y + 20), (w - 8, h - 32)) cj + in do (db, foc', g, cd, b, uisf) <- f (ctx', foc, t, inp, a) + return (db, foc', drawit bbx // g, cd, b, title str uisf) ------------ @@ -407,7 +404,7 @@ -- | The realtimeGraph widget creates a graph of the data with trailing values. -- It takes a dimension parameter, the length of the history of the graph -- measured in time, and a color for the graphed line. --- The signal function then takes an input stream of time as well as +-- The signal function then takes an input stream of -- (value,time) event pairs, but since there can be zero or more points -- at once, we use [] rather than 'SEvent' for the type. -- The values in the (value,time) event pairs should be between -1 and 1. @@ -439,7 +436,7 @@ process (Just a) _ _ _ = ((), Just a, True) draw (xy, (w, h)) _ = translateGraphic xy . mymap (polyline . mkPts) where mkPts l = zip (reverse $ xs $ length l) (map adjust . normalize . reverse $ l) - xs n = [0,(w `div` (n-1))..w] + xs n = let k = n-1 in 0 : map (\x -> truncate $ fromIntegral (w*x) / fromIntegral k) [1..k] adjust i = buffer + truncate (fromIntegral (h - 2*buffer) * (1 - i)) normalize lst = map (/m) lst where m = maximum lst buffer = truncate $ fromIntegral h / 10 @@ -456,7 +453,9 @@ process (Just a) _ _ _ = ((), Just a, True) draw (xy, (w, h)) _ = mymap (polyline . mkPts) mkScale where mkPts l = zip (reverse $ xs $ length l) (map adjust . normalize . reverse $ l) - xs n = [sidebuffer,(sidebuffer+((w-sidebuffer*2) `div` (n-1)))..(w-sidebuffer)] + xs n = let k = n-1 + w' = w - sidebuffer * 2 + in sidebuffer : map (\x -> sidebuffer + (truncate $ fromIntegral (w'*x) / fromIntegral k)) [1..k] adjust i = bottombuffer + truncate (fromIntegral (h - topbuffer - bottombuffer) * (1 - i)) normalize lst = map (/m) lst where m = maximum lst topbuffer = truncate $ fromIntegral h / 10 @@ -483,7 +482,7 @@ -- The layout is the static layout that this widget will use. It -- cannot be dependent on any streaming arguments, but a layout can have -- \"stretchy\" sides so that it can expand/shrink to fit an area. Learn --- more about making layouts in 'UIMonad's UI Layout section -- specifically, +-- more about making layouts in 'UIType's UI Layout section -- specifically, -- check out the 'makeLayout' function and the 'LayoutType' data type. -- -- The computation is where the logic of the widget is held. This @@ -508,15 +507,14 @@ -> UISF a b mkWidget i layout comp draw = proc a -> do rec s <- delay i -< s' - (b, s') <- mkUISF aux -< (a, s) + (b, s') <- mkUISF layout aux -< (a, s) returnA -< b - --loop $ second (delay i) >>> arr (uncurry inj) >>> mkUISF aux where - aux (a,s) (ctx,f,t,e) = (layout, db, f, justGraphicAction g, nullCD, (b, s')) + aux (ctx,f,t,e,(a,s)) = (db, f, g, nullTP, (b, s')) where rect = bounds ctx (b, s', db) = comp a s rect e - g = draw rect (snd f == HasFocus) s' + g = scissorGraphic rect $ draw rect (snd f == HasFocus) s' -- | Occasionally, one may want to display a non-interactive graphic in -- the UI. 'mkBasicWidget' facilitates this. It takes a layout and a @@ -524,8 +522,8 @@ mkBasicWidget :: Layout -- ^ layout -> (Rect -> Graphic) -- ^ drawing routine -> UISF a a -mkBasicWidget layout draw = mkUISF $ \a (ctx, f, _, _) -> - (layout, False, f, justGraphicAction (draw $ bounds ctx), nullCD, a) +mkBasicWidget layout draw = mkUISF layout $ \(ctx, f, _, _, a) -> + (False, f, draw $ bounds ctx, nullTP, a) -- | The toggle is useful in the creation of both 'checkbox'es and 'radio' @@ -683,12 +681,12 @@ -- it to see any mouse button clicks and keystrokes when it is actually -- in focus. focusable :: UISF a b -> UISF a b -focusable widget = proc x -> do +focusable (UISF layout f) = proc x -> do rec hasFocus <- delay False -< hasFocus' - (y, hasFocus') <- compressUISF (h widget) -< (x, hasFocus) + (y, hasFocus') <- UISF layout (h f) -< (x, hasFocus) returnA -< y where - h w (a, hasFocus) (ctx, (myid,focus),t, inp) = do + h fun (ctx, (myid,focus),t, inp, (a, hasFocus)) = do lshift <- isKeyPressed LSHIFT rshift <- isKeyPressed RSHIFT let isShift = lshift || rshift @@ -709,8 +707,8 @@ SKey _ _ _ -> NoUIEvent _ -> inp) redraw = hasFocus /= hasFocus' - (l, db, _, act, tids, (b, w')) <- expandUISF w a (ctx, (myid,focus'), t, inp') - return (l, db || redraw, (myid+1,f), act, tids, ((b, hasFocus'), compressUISF (h w'))) + (db, _, g, cd, b, UISF newLayout fun') <- fun (ctx, (myid,focus'), t, inp', a) + return (db || redraw, (myid+1,f), g, cd, (b, hasFocus'), UISF newLayout (h fun')) -- | Although mouse button clicks and keystrokes will be available once a -- widget marks itself as focusable, the widget may also simply want to
ReadMe.txt view
@@ -17,7 +17,7 @@ ==== Getting the Source ==== ============================ -Currently (10/26/2013), the most up-to-date version of UISF is +Currently (1/10/2015), the most up-to-date version of UISF is available through GitHub at: https://github.com/dwincort/UISF
UISF.cabal view
@@ -1,9 +1,9 @@ name: UISF -version: 0.2.0.0 +version: 0.3.0.0 Cabal-Version: >= 1.8 license: BSD3 license-file: License -copyright: Copyright (c) 2014 Daniel Winograd-Cort +copyright: Copyright (c) 2015 Daniel Winograd-Cort category: GUI stability: experimental build-type: Simple @@ -30,10 +30,9 @@ exposed-modules: FRP.UISF.Examples.Crud, FRP.UISF.Examples.Examples, - FRP.UISF.Types.MSF, FRP.UISF.AuxFunctions, FRP.UISF.SOE, - FRP.UISF.UIMonad, + FRP.UISF.UITypes, FRP.UISF.UISF, FRP.UISF.Widget, FRP.UISF @@ -41,4 +40,4 @@ build-depends: base >= 4 && < 5, containers, transformers, arrows >= 0.4, GLFW >= 0.5, OpenGL >= 2.8, - monadIO >= 0.10, deepseq >= 1.3, stm >= 2.4 + deepseq >= 1.3, stm >= 2.4