WidgetRattus 0.1.0.1 → 0.1.1

raw patch · 7 files changed

+110/−45 lines, 7 filesdep +WidgetRattusdep −AsyncRattusPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: WidgetRattus

Dependencies removed: AsyncRattus

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• WidgetRattus.cabal +3/−3
• src/AsyncRattus/Channels.hs +43/−15
• src/AsyncRattus/Derive.hs +11/−17
• src/AsyncRattus/InternalPrimitives.hs +12/−8
• src/AsyncRattus/Signal.hs +2/−2
• src/AsyncRattus/Strict.hs +34/−0

@@ -1,3 +1,8 @@+# 0.1.1++Multiple channels can fire simultaneously now. This makes filter+functions better behaved.+ # 0.1.0.1  Fix elaboration bug that cause a compiler panic

@@ -1,6 +1,6 @@ cabal-version:       1.18 name:                WidgetRattus-version:             0.1.0.1+version:             0.1.1 category:            FRP synopsis:            An asynchronous modal FRP language description:@@ -68,7 +68,7 @@   type:                exitcode-stdio-1.0   main-is:             test/IllTyped.hs   default-language:    Haskell2010-  build-depends:       AsyncRattus, base+  build-depends:       WidgetRattus, base   ghc-options:         -fplugin=AsyncRattus.Plugin  @@ -77,6 +77,6 @@   main-is:             WellTyped.hs   hs-source-dirs:      test   default-language:    Haskell2010-  build-depends:       AsyncRattus, base, containers, text+  build-depends:       WidgetRattus, base, containers, text   ghc-options:         -fplugin=AsyncRattus.Plugin 

@@ -30,7 +30,6 @@  import AsyncRattus.Plugin.Annotation import AsyncRattus.Strict-import qualified Control.Concurrent.Chan as Concurrent import Control.Monad import System.IO.Unsafe import Data.IORef@@ -70,18 +69,23 @@ 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) (\ (InputValue _ v) -> unsafeCoerce v)+wait (Chan ch) = Delay (singletonClock ch) (lookupInp ch)   {-# NOINLINE nextFreshChannel #-} nextFreshChannel :: IORef InputChannelIdentifier nextFreshChannel = unsafePerformIO (newIORef (-1))  -{-# NOINLINE input #-}-input :: Concurrent.Chan InputValue-input = unsafePerformIO newChan+{-# NOINLINE inputValue #-}+inputValue :: MVar (Maybe' InputValue)+inputValue = unsafePerformIO (newMVar Nothing') +{-# NOINLINE inputSem #-}+inputSem :: MVar ()+inputSem = unsafePerformIO newEmptyMVar+ data OutputChannel where   OutputChannel :: Producer p a => !(O p) -> !(a -> IO ()) -> OutputChannel @@ -101,9 +105,21 @@ -- function @cb@ is called with argument @v@. getInput :: IO (Box (O a) :* (a -> IO ())) getInput = do ch <- atomicModifyIORef nextFreshChannel (\ x -> (x - 1, x))-              return ((box (Delay (singletonClock ch) (\ (InputValue _ v) -> unsafeCoerce v)))-                       :* \ x -> writeChan input (InputValue ch x))+              return ((box (Delay (singletonClock ch) (lookupInp ch)))+                       :* \ x -> newInput ch x) ++newInput :: InputChannelIdentifier -> a -> IO ()+newInput ch x = do iv <- takeMVar inputValue+                   case iv of +                    Nothing' -> putMVar inputValue (Just' (OneInput ch x)) >> putMVar inputSem ()+                    Just' more -> putMVar inputValue (Just' (MoreInputs ch x more))++{-# 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+ {-# ANN setOutput' AllowLazyData #-} setOutput' :: Producer p a => (a -> IO ()) -> O p -> IO () setOutput' cb !sig = do@@ -111,7 +127,7 @@   let upd Nothing = (Just (ref :! Nil),())       upd (Just ls) = (Just (ref :! ls),())   let upd' ch Nothing = do-        forkIO (threadDelay ch >> writeChan input (InputValue ch ()))+        forkIO (threadDelay ch >> newInput ch ())         return (Just (ref :! Nil),())       upd' _ (Just ls) = return (Just (ref :! ls),())   let run pre ch =@@ -162,17 +178,29 @@       getNext new (setOutput' cb)  +{-# ANN getOutputsForInputs AllowRecursion #-}+{-# ANN getOutputsForInputs AllowLazyData #-}+getOutputsForInputs :: List (IORef (Maybe' OutputChannel)) -> InputValue -> IO (List (IORef (Maybe' OutputChannel)))+getOutputsForInputs acc (OneInput ch _) = do res <- H.lookup output ch+                                             case res of +                                              Nothing -> return acc+                                              Just ls -> H.delete output ch >> return (acc `union'` ls)+getOutputsForInputs acc (MoreInputs ch _ more) = do res <- H.lookup output ch+                                                    case res of +                                                      Nothing -> getOutputsForInputs acc more+                                                      Just ls -> H.delete output ch >> getOutputsForInputs (acc `union'` ls) more+ {-# ANN eventLoop AllowRecursion #-} {-# ANN eventLoop AllowLazyData #-}  eventLoop :: IO ()-eventLoop = do inp@(InputValue ch _) <- readChan input-               progressPromoteStoreAtomic inp-               res <- H.lookup output ch-               case res of-                 Nothing -> return ()-                 Just ls -> do-                   H.delete output ch+eventLoop = do _ <- takeMVar inputSem+               minp <- takeMVar inputValue+               putMVar inputValue Nothing'+               case minp of+                 Nothing' -> error "AsyncRattus.Channels.eventLoop unexpected state"+                 Just' inp -> do+                   ls <- getOutputsForInputs Nil inp                    mapM_ (update inp) ls                eventLoop 

@@ -38,25 +38,19 @@ {-| This function provides the name and the arity of the given data constructor, and if it is a GADT also its type. -}-normalCon :: Con -> (Name,[StrictType], Maybe Type)-normalCon (NormalC constr args) = (constr, args, Nothing)-normalCon (RecC constr args) = (constr, map (\(_,s,t) -> (s,t)) args, Nothing)-normalCon (InfixC a constr b) = (constr, [a,b], Nothing)+normalCon :: Con -> [(Name,[StrictType], Maybe Type)]+normalCon (NormalC constr args) = [(constr, args, Nothing)]+normalCon (RecC constr args) = [(constr, map (\(_,s,t) -> (s,t)) args, Nothing)]+normalCon (InfixC a constr b) = [(constr, [a,b], Nothing)] normalCon (ForallC _ _ constr) = normalCon constr-normalCon (GadtC (constr:_) args typ) = (constr,args,Just typ)+normalCon (GadtC (constr:_) args typ) = [(constr,args,Just typ)]+normalCon (RecGadtC (constr : _) args typ) = [(constr,map dropFst args,Just typ)]+  where dropFst (_,x,y) = (x,y) normalCon _ = error "missing case for 'normalCon'" -normalCon' :: Con -> (Name,[Type], Maybe Type)-normalCon' con = (n, map snd ts, t)-  where (n, ts, t) = normalCon con-      ---- | Same as normalCon' but expands type synonyms.-normalConExp :: Con -> Q (Name,[Type], Maybe Type)-normalConExp c = do-  let (n,ts,t) = normalCon' c-  return (n, ts,t)-+normalCon' :: Con -> [(Name,[Type], Maybe Type)]+normalCon' con = map conv (normalCon con)+  where conv (n, ts, t) = (n, map snd ts, t)    mkInstanceD :: Cxt -> Type -> [Dec] -> Dec mkInstanceD cxt ty decs = InstanceD Nothing cxt ty decs@@ -85,7 +79,7 @@       complType = foldl AppT (ConT name) argNames       preCond = map (mkClassP ''Continuous . (: [])) argNames       classType = AppT (ConT ''Continuous) complType-  constrs' <- mapM normalConExp constrs+  let constrs' = concatMap normalCon' constrs   promDecl <- funD 'progressInternal (promClauses constrs')   return [mkInstanceD preCond classType [promDecl]]       where promClauses = map genPromClause

@@ -9,7 +9,6 @@ import qualified Data.IntSet as IntSet import Data.IORef import Control.Concurrent.MVar-import Data.Maybe import System.IO.Unsafe import System.Mem.Weak import Control.Monad@@ -29,9 +28,14 @@ channelMember = IntSet.member  data InputValue where-  InputValue :: !InputChannelIdentifier -> !a -> InputValue+  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 -- two components: Its clock, denoted @cl(v)@, and a delayed -- computation that will produce a value of type @𝜏@ as soon as the@@ -112,13 +116,14 @@ select _ _ = asyncRattusError "select"  select' :: O a -> O b -> InputValue -> Select a b-select' a@(Delay clA inpFA) b@(Delay clB inpFB) inputValue@(InputValue chId _)-  = if chId `channelMember` clA then-      if chId `channelMember` clB then Both (inpFA inputValue) (inpFB inputValue)-      else Fst (inpFA inputValue) b-    else Snd a (inpFB inputValue)+select' a@(Delay clA inpFA) b@(Delay clB inpFB) inp+  = if inputInClock inp clA then+      if inputInClock inp clB then Both (inpFA inp) (inpFB inp)+      else Fst (inpFA inp) b+    else Snd a (inpFB inp)  + -- | The clock of @never :: O 𝜏@ will never tick, i.e. it will never -- produce a value of type @𝜏@. With 'never' we can for example -- implement the constant signal @x ::: never@ of type @Sig a@ for any @x ::@@ -219,7 +224,6 @@ progressPromoteStore :: InputValue -> IO () progressPromoteStore inp = do      xs <- atomicModifyIORef promoteStore (\x -> ([],x))-    putStrLn ("promote store size: " ++ show (length xs))     xs' <- filterM run xs     atomicModifyIORef promoteStore (\x -> (x ++ xs',()))   where run (ContinuousData x) = do

@@ -358,8 +358,8 @@   instance Continuous a => Continuous (Sig a) where-    progressInternal inp@(InputValue chId _) (x ::: xs@(Delay cl _)) = -        if channelMember chId cl then adv' xs inp+    progressInternal inp (x ::: xs@(Delay cl _)) = +        if inputInClock inp cl then adv' xs inp         else progressInternal inp x ::: xs  -- Prevent functions from being inlined too early for the rewrite

@@ -17,6 +17,13 @@     IsList(..),     init',     reverse',+    union',+    unionBy',+    nub',+    nubBy',+    filter',+    delete',+    deleteBy',     (+++),     listToMaybe',     map',@@ -161,6 +168,33 @@  case f x of   Nothing' -> rs   Just' r  -> r:!rs++union' :: (Eq a) => List a -> List a -> List a+union' = unionBy' (==)++unionBy' :: (a -> a -> Bool) -> List a -> List a -> List a+unionBy' eq xs ys =  xs +++ foldl (flip (deleteBy' eq)) (nubBy' eq ys) xs++delete' :: (Eq a) => a -> List a -> List a+delete' =  deleteBy' (==)++deleteBy' :: (a -> a -> Bool) -> a -> List a -> List a+deleteBy' _  _ Nil        = Nil+deleteBy' eq x (y :! ys)    = if x `eq` y then ys else y :! deleteBy' eq x ys+++nub' :: (Eq a) => List a -> List a+nub' =  nubBy' (==)++nubBy' :: (a -> a -> Bool) -> List a -> List a+nubBy' _ Nil             =  Nil+nubBy' eq (x:!xs)         =  x :! nubBy' eq (filter' (\ y -> not (eq x y)) xs)++filter' :: (a -> Bool) -> List a -> List a+filter' _ Nil    = Nil+filter' pred (x :! xs)+  | pred x         = x :! filter' pred xs+  | otherwise      = filter' pred xs  instance Foldable List where