diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/WidgetRattus.cabal b/WidgetRattus.cabal --- a/WidgetRattus.cabal +++ b/WidgetRattus.cabal @@ -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 diff --git a/src/AsyncRattus/Channels.hs b/src/AsyncRattus/Channels.hs --- a/src/AsyncRattus/Channels.hs +++ b/src/AsyncRattus/Channels.hs @@ -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 diff --git a/src/AsyncRattus/Derive.hs b/src/AsyncRattus/Derive.hs --- a/src/AsyncRattus/Derive.hs +++ b/src/AsyncRattus/Derive.hs @@ -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 diff --git a/src/AsyncRattus/InternalPrimitives.hs b/src/AsyncRattus/InternalPrimitives.hs --- a/src/AsyncRattus/InternalPrimitives.hs +++ b/src/AsyncRattus/InternalPrimitives.hs @@ -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 diff --git a/src/AsyncRattus/Signal.hs b/src/AsyncRattus/Signal.hs --- a/src/AsyncRattus/Signal.hs +++ b/src/AsyncRattus/Signal.hs @@ -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 diff --git a/src/AsyncRattus/Strict.hs b/src/AsyncRattus/Strict.hs --- a/src/AsyncRattus/Strict.hs +++ b/src/AsyncRattus/Strict.hs @@ -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