WidgetRattus 0.3 → 0.4

raw patch · 15 files changed

+209/−141 lines, 15 filesdep +timedep ~ghcdep ~ghc-bootPVP ok

version bump matches the API change (PVP)

Dependencies added: time

Dependency ranges changed: ghc, ghc-boot

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• WidgetRattus.cabal +6/−5
• docs/paper.pdf binary
• examples/gui/src/Stopwatch.hs +70/−0
• examples/gui/src/Timer.hs +1/−4
• src/WidgetRattus.hs +4/−3
• src/WidgetRattus/Channels.hs +0/−79
• src/WidgetRattus/Future.hs +0/−22
• src/WidgetRattus/InternalPrimitives.hs +66/−2
• src/WidgetRattus/Plugin/ScopeCheck.hs +2/−1
• src/WidgetRattus/Plugin/Utils.hs +2/−1
• src/WidgetRattus/Primitives.hs +8/−0
• src/WidgetRattus/Signal.hs +12/−23
• src/WidgetRattus/Time.hs +24/−0
• src/WidgetRattus/Widgets.hs +7/−1

@@ -1,3 +1,10 @@+# 0.4++- The C monad can now be discharged under the O modality via delayC.+- The C monad can now also query the current time.+- Remove Producer class.+- Remove Channels module; channels primitives are now in Primitives module.+ # 0.3  - Include the Widgets library.

@@ -1,6 +1,6 @@ cabal-version:       1.18 name:                WidgetRattus-version:             0.3+version:             0.4 category:            FRP synopsis:            An asynchronous modal FRP language for GUI programming description:@@ -44,10 +44,10 @@                        WidgetRattus.Signal                        WidgetRattus.Future                        WidgetRattus.Strict+                       WidgetRattus.Time                        WidgetRattus.Plugin                        WidgetRattus.Primitives                        WidgetRattus.InternalPrimitives-                       WidgetRattus.Channels                        WidgetRattus.Plugin.Annotation                        WidgetRattus.Widgets                                               @@ -64,14 +64,15 @@                        WidgetRattus.Derive   build-depends:       base >=4.16 && <5,                        containers >= 0.6.5 && < 0.8,-                       ghc >= 9.2 && < 9.7,-                       ghc-boot >= 9.2 && < 9.7,+                       ghc >= 9.2 && < 9.9,+                       ghc-boot >= 9.2 && < 9.9,                        hashtables >= 1.3.1 && < 1.4,                        simple-affine-space >= 0.2.1 && < 0.3,                        transformers >= 0.5.6 && < 0.7,                        template-haskell >= 2.17 && < 2.23,                        text >= 1.2 && < 3,-                       monomer >= 1.4 && < 2+                       monomer >= 1.4 && < 2,+                       time >= 1.10 && < 2   hs-source-dirs:      src   default-language:    Haskell2010   ghc-options:         -W

binary file changed (592894 → 597005 bytes)

@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS -fplugin=WidgetRattus.Plugin #-}++{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+++import WidgetRattus++import WidgetRattus.Signal+import WidgetRattus.Widgets+import Prelude hiding (map, const, zipWith, zip, filter, getLine, putStrLn,null)+import Data.Text hiding (filter, map, all)++sampleInterval :: O ()+sampleInterval = timer 20000++currentTime :: C (Sig Time)+currentTime = do+     t <- time +     return (t ::: mkSig (box (delayC $ delay (let _ = adv sampleInterval in time))))+     ++++elapsedTime :: C (NominalDiffTime -> Sig NominalDiffTime)+elapsedTime =  do t <- time+                  return (\ s -> run s t)+     where run :: NominalDiffTime -> Time -> Sig NominalDiffTime+           run start t = +               start ::: delayC (delay (+                    let _ = adv sampleInterval +                    in do t' <- time+                          return (run (start + (t' `diffTime` t)) t')))++window :: C VStack+window = do+    startBtn <- mkButton (const ("Start" :: Text))+    stopBtn <- mkButton (const ("Stop" :: Text))+    let startDelay = btnOnClick startBtn+    let startSig :: O (Sig (NominalDiffTime -> Sig NominalDiffTime)) +         = mkSig' (box (delay (let _ = adv (unbox startDelay) in elapsedTime)))++    let stopDelay = btnOnClick stopBtn+    let stopSig :: O (Sig (NominalDiffTime -> Sig NominalDiffTime)) +         = mkSig (box (delay (let _ = adv (unbox stopDelay) in const)))++    +    let inputSig :: O (Sig (NominalDiffTime -> Sig NominalDiffTime))+         = interleave (box (\ x _ -> x)) startSig stopSig+++    let stopWatchSig :: Sig NominalDiffTime+         = switchR (const 0) inputSig++    timeLabName <- mkLabel (const ("Current Time:" :: Text))+    swLabName <- mkLabel (const ("Elapsed Time:" :: Text))+++    timeLab <- currentTime >>= mkLabel+    stopWatchLab <- mkLabel stopWatchSig+    buttons <- mkConstHStack (startBtn :* stopBtn)+    time <- mkConstHStack (timeLabName :* timeLab)+    sw <- mkConstHStack (swLabName :* stopWatchLab)++    mkConstVStack (time :* sw :* buttons)++main :: IO ()+main = runApplication window

@@ -13,11 +13,8 @@ import Data.Text hiding (filter, map, all)  -everySecond :: Box (O())-everySecond = timer 1000000- everySecondSig :: O (Sig ())-everySecondSig = mkSig everySecond+everySecondSig = mkSig (box (timer 1000000))  nats :: (Int :* Int) -> Sig (Int :* Int) nats (n :* max) = stop 

@@ -7,10 +7,10 @@ module WidgetRattus (   -- * Asynchronous Rattus language primitives   module WidgetRattus.Primitives,-  -- * Channels API-  module WidgetRattus.Channels,   -- * Strict data types   module WidgetRattus.Strict,+  -- * Time+  module WidgetRattus.Time,   -- * Derive class instance declarations   module WidgetRattus.Derive,   -- * Annotation@@ -24,7 +24,8 @@ import WidgetRattus.Strict import WidgetRattus.Primitives import WidgetRattus.Derive-import WidgetRattus.Channels+import WidgetRattus.Time+  mapO :: Box (a -> b) -> O a -> O b mapO f later = delay (unbox f (adv later))

@@ -1,79 +0,0 @@-{-# OPTIONS -fplugin=WidgetRattus.Plugin #-}--{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module WidgetRattus.Channels (-  timer,-  Producer (..),-  chan,-  C (..),-  delayC,-  wait,-  Chan-) where-import WidgetRattus.InternalPrimitives--import WidgetRattus.Plugin.Annotation-import WidgetRattus.Strict-import System.IO.Unsafe-import Data.IORef-import Unsafe.Coerce---- | A type @p@ satisfying @Producer p a@ is essentially a signal that--- produces values of type @a@ but it might not produce such values at--- each tick.-class Producer p a | p -> a where-  -- | Get the current value of the producer if any.-  getCurrent :: p -> Maybe' a-  -- | Get the next state of the producer. Morally, the type of this-  -- method should be-  ---  -- > getNext :: p -> (exists q. Producer q a => O q)-  ---  -- We encode the existential type using continuation-passing style.-  getNext :: p -> (forall q. Producer q a => O q -> b) -> b--instance Producer p a => Producer (O p) a where-  getCurrent _ = Nothing'-  getNext p cb = cb p--instance Producer p a => Producer (Box p) a where-  getCurrent p = getCurrent (unbox p)-  getNext p cb = getNext (unbox p) cb--newtype C a = C {unC :: IO a} deriving (Functor, Applicative, Monad)--chan :: C (Chan a)-chan = C (Chan <$> atomicModifyIORef nextFreshChannel (\ x -> (x - 1, x)))--delayC :: O (C a) -> C (O a)-delayC d = return (delay (unsafePerformIO (unC (adv d))))--{-# ANN wait AllowRecursion #-}-wait :: Chan a -> O a-wait (Chan ch) = Delay (singletonClock ch) (lookupInp ch) --{-# NOINLINE nextFreshChannel #-}-nextFreshChannel :: IORef InputChannelIdentifier-nextFreshChannel = unsafePerformIO (newIORef (-1))----{-# ANN lookupInp AllowRecursion #-}-lookupInp :: InputChannelIdentifier -> InputValue -> a-lookupInp _ (OneInput _ v) = unsafeCoerce v-lookupInp ch (MoreInputs ch' v more) = if ch' == ch then unsafeCoerce v else lookupInp ch more---- | @timer n@ produces a delayed computation that ticks every @n@--- milliseconds. In particular @mkSig (timer n)@ is a signal that--- produces a new value every #n# milliseconds.-timer :: Int -> Box (O ())-timer d = Box (Delay (singletonClock (d `max` 10)) (\ _ -> ()))

@@ -42,28 +42,6 @@ import WidgetRattus.Signal (Sig(..)) import Prelude hiding (map, filter, zipWith) -newtype OneShot a = OneShot (F a)--instance Producer (OneShot a) a where-  getCurrent (OneShot (Now x)) = Just' x-  getCurrent (OneShot (Wait _)) = Nothing'--  getNext (OneShot (Now _)) cb = cb (never :: O (OneShot a))-  getNext (OneShot (Wait x)) cb = cb (delay (OneShot (adv x)))--instance Producer p a => Producer (F p) a where-  getCurrent (Now x) = getCurrent x-  getCurrent (Wait _) = Nothing'-  -  getNext (Now x) cb = getNext x cb-  getNext (Wait x) cb = cb x--instance Producer (SigF a) a where-  getCurrent (x :>: _) = Just' x-  getNext (_ :>: xs) cb = cb xs--- -- | @F a@ will produces a value of type @a@ after zero or more ticks -- of some clocks data F a = Now !a | Wait !(O (F a))

@@ -1,6 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module WidgetRattus.InternalPrimitives where @@ -12,7 +13,11 @@ import System.IO.Unsafe import System.Mem.Weak import Control.Monad+import Unsafe.Coerce +import Data.Time.Clock+import Data.Time.Calendar.OrdinalDate+ -- An input channel is identified by an integer. The programmer should not know about it. type InputChannelIdentifier = Int @@ -32,11 +37,9 @@  data InputValue where   OneInput :: !InputChannelIdentifier -> !a -> InputValue-  MoreInputs :: !InputChannelIdentifier -> !a -> !InputValue -> InputValue  inputInClock :: InputValue -> Clock -> Bool inputInClock (OneInput ch _) cl = channelMember ch cl-inputInClock (MoreInputs ch _ more) cl = channelMember ch cl || inputInClock more cl   -- | The "later" type modality. A value @v@ of type @O 𝜏@ consists of@@ -48,6 +51,7 @@  data O a = Delay !Clock (InputValue -> a) + -- | The return type of the 'select' primitive. data Select a b = Fst !a !(O b) | Snd !(O a) !b | Both !a !b @@ -252,7 +256,67 @@ promote :: Continuous a => a -> Box a promote x = promoteInternal x ++-- Channels++newtype C a = C {unC :: InputValue -> IO a} ++instance Functor C where+  fmap f (C g) = C (\inp -> fmap f (g inp))++instance Applicative C where+  pure x = C (\ _ -> pure x)++  C f <*> C g = C (\inp -> f inp <*> g inp)+++instance Monad C where+  return = pure+  C f >>= g = C (\inp -> f inp >>= (\ x -> unC (g x) inp))+ newtype Chan a = Chan InputChannelIdentifier++chan :: C (Chan a)+chan = C (\ _ -> Chan <$> atomicModifyIORef nextFreshChannel (\ x -> (x - 1, x)))++delayC :: O (C a) -> O a+delayC (Delay c f) = Delay c (\ inp -> advC' (f inp) inp)+++{-# NOINLINE advC' #-}+advC' :: C a -> InputValue -> a+advC' (C c) inp =  unsafePerformIO (c inp)++wait :: Chan a -> O a+wait (Chan ch) = Delay (singletonClock ch) (\(OneInput _ v) -> unsafeCoerce v)++{-# NOINLINE nextFreshChannel #-}+nextFreshChannel :: IORef InputChannelIdentifier+nextFreshChannel = unsafePerformIO (newIORef (-1))+++-- | @timer n@ produces a delayed computation that ticks every @n@+-- milliseconds. In particular @mkSig (timer n)@ is a signal that+-- produces a new value every #n# milliseconds.+timer :: Int -> O ()+timer d = Delay (singletonClock (d `max` 10)) (\ _ -> ())++-- | A strict version of UTCTime+data Time = Time+  { -- | The day component+    timeDay :: !Day,+    -- | The time component+    timeDayTime :: !DiffTime+  }+  deriving (Eq, Ord)++instance Show Time where+  show (Time d t) = show (UTCTime d t)++time :: C Time+time = C $ \ _ ->  do UTCTime d t <- getCurrentTime+                      return $ Time d t+  {-# RULES   "unbox/box"    forall x. unbox (box x) = x

@@ -369,7 +369,8 @@     | Just p <- isPrim v =         case p of           Unbox -> return True-          _ -> printMessageCheck SevError ("Defining an alias for " <> ppr v <> " is not allowed")+          _ -> printMessageCheck SevError ("The primitive " <> ppr v <> " must be applied directly to an argument." +                $$ "It cannot be assigned to a variable or passed as an argument, e.g. when using the $ operator.")     | otherwise = case getScope v of              Hidden reason -> printMessageCheck SevError reason              Visible -> return True

@@ -167,7 +167,7 @@ unionVar = getVarFromModule "WidgetRattus.InternalPrimitives" "clockUnion"  rattModules :: Set FastString-rattModules = Set.fromList ["WidgetRattus.InternalPrimitives","WidgetRattus.Channels"]+rattModules = Set.fromList ["WidgetRattus.InternalPrimitives"]  getModuleFS :: Module -> FastString getModuleFS = moduleNameFS . moduleName@@ -276,6 +276,7 @@                 where check con = case dataConInstSig con args of                         (_, _,tys) -> and (map (isStableRec c (d+1) pr') tys)               TupleTyCon {} -> null args+              NewTyCon {nt_rhs = ty} -> isStableRec c (d+1) pr' ty               _ -> False         _ -> False 

@@ -17,5 +17,13 @@   ,never   ,Stable   ,Continuous+  ,chan+  ,Chan+  ,C+  ,delayC+  ,timer+  ,wait+  ,Time(..)+  ,time   ) where import WidgetRattus.InternalPrimitives

@@ -27,7 +27,7 @@   , mapInterleave   , interleaveAll   , mkSig-  , mkBoxSig+  , mkSig'   , current   , future   , const@@ -65,16 +65,6 @@ -- | @Sig a@ is a stream of values of type @a@. data Sig a = !a ::: !(O (Sig a)) -instance Producer (Sig a) a where-  getCurrent p = Just' (current p)-  getNext p cb = cb (future p)--newtype SigMaybe a = SigMaybe (Sig (Maybe' a))--instance Producer (SigMaybe a) a where-  getCurrent (SigMaybe p) = current p-  getNext (SigMaybe p) cb = cb (delay (SigMaybe (adv (future p))))- -- | Get the current value of a signal. current :: Sig a -> a current (x ::: _) = x@@ -96,11 +86,14 @@ mkSig :: Box (O a) -> O (Sig a) mkSig b = delay (adv (unbox b) ::: mkSig b) --- | Variant of 'mkSig' that returns a boxed delayed signal-mkBoxSig :: Box (O a) -> Box (O (Sig a))-mkBoxSig b = box (mkSig b) +-- | Turns a boxed delayed computation into a delayed signal.+mkSig' :: Box (O (C a)) -> O (Sig a)+mkSig' b = delayC $ delay (do a <- adv (unbox b)+                              return (a ::: mkSig' b)) ++ -- | Construct a constant signal that never updates. const :: a -> Sig a const x = x ::: never@@ -120,9 +113,7 @@ scanC :: (Stable b) => Box(b -> a -> C b) -> b -> Sig a -> C (Sig b) scanC f acc (a ::: as) = do     acc' <- unbox f acc a-    fut <- delayC $ delay (scanC f acc' (adv as))-    return (acc' ::: fut)-  where +    return (acc' ::: delayC (delay (scanC f acc' (adv as))))          -- | Like 'scan', but uses a delayed signal. scanAwait :: (Stable b) => Box (b -> a -> b) -> b -> O (Sig a) -> Sig b@@ -130,10 +121,8 @@  -- | A variant of 'scanAwait' that works with the 'C' monad. -scanAwaitC :: (Stable b) => Box (b -> a -> C b) -> b -> O (Sig a) -> C (Sig b)-scanAwaitC f acc as = do -    fut <- delayC $ delay (scanC f acc (adv as))-    return (acc ::: fut)+scanAwaitC :: (Stable b) => Box (b -> a -> C b) -> b -> O (Sig a) -> Sig b+scanAwaitC f acc as = acc ::: delayC (delay (scanC f acc (adv as)))  -- | 'scanMap' is a composition of 'map' and 'scan': --@@ -402,7 +391,7 @@   where int cur (x ::: xs)           | x == zeroVector = cur ::: delay (int cur (adv xs))           | otherwise = cur ::: delay (-              case select xs (unbox (timer dt)) of+              case select xs (timer dt) of                 Fst xs' _ -> int cur xs'                 Snd xs' _ -> int (dtf *^ (cur ^+^ x)) (x ::: xs')                 Both (x' ::: xs') _ ->  int (dtf *^ (cur ^+^ x')) (x'::: xs'))@@ -426,7 +415,7 @@                         (let x' ::: xs' = adv xs                          in der ((x' ^-^ x) ^/ dtf) x (x' ::: xs'))     | otherwise = d ::: delay (-        case select xs (unbox (timer dt)) of+        case select xs (timer dt) of           Fst xs' _ -> der d last xs'           Snd xs' _ -> der ((x ^-^ last) ^/ dtf) x (x ::: xs')           Both (x' ::: xs') _ ->  der ((x' ^-^ last) ^/ dtf) x' (x' ::: xs'))

@@ -0,0 +1,24 @@+{-# OPTIONS -fplugin=WidgetRattus.Plugin #-}++++module WidgetRattus.Time (+  Time(..),+  time,+  addTime,+  diffTime,+  module Data.Time.Clock+  )+  where+import WidgetRattus.Primitives++import Data.Time.Clock+import WidgetRattus.Plugin++{-# ANN addTime AllowLazyData #-}+addTime :: NominalDiffTime -> Time -> Time+addTime diff (Time d t) = let UTCTime d' t' = addUTCTime diff (UTCTime d t) in Time d' t'++{-# ANN diffTime AllowLazyData #-}+diffTime :: Time -> Time -> NominalDiffTime+diffTime (Time d1 t1) (Time d2 t2) = diffUTCTime (UTCTime d1 t1) (UTCTime d2 t2)

@@ -76,7 +76,13 @@ instance Displayable Int where         display x = toText x +instance Displayable Time where+      display = toText +instance Displayable NominalDiffTime where+      display = toText ++ -- Functions for constructing Async Rattus widgets.  mkButton :: (Displayable a) => Sig a -> C Button mkButton t = do@@ -198,7 +204,7 @@ {-# ANN runApplication AllowLazyData #-} runApplication :: IsWidget a => C a -> IO () runApplication (C w) = do-    w' <- w+    w' <- w (OneInput 0 ())     M.startApp (AppModel w' emptyClock) handler builder config     where builder _ (AppModel w _) = mkWidgetNode w `M.styleBasic` [M.padding 3]           handler _ _ (AppModel w cl) (AppEvent (Chan ch) d) =