diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +# 0.2 + +Extend continuous types so that they can track their channel +dependencies. + # 0.1.1 Multiple channels can fire simultaneously now. This makes filter 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.1 +version: 0.2 category: FRP synopsis: An asynchronous modal FRP language description: diff --git a/src/AsyncRattus/Derive.hs b/src/AsyncRattus/Derive.hs --- a/src/AsyncRattus/Derive.hs +++ b/src/AsyncRattus/Derive.hs @@ -80,15 +80,38 @@ preCond = map (mkClassP ''Continuous . (: [])) argNames classType = AppT (ConT ''Continuous) complType let constrs' = concatMap normalCon' constrs - promDecl <- funD 'progressInternal (promClauses constrs') - return [mkInstanceD preCond classType [promDecl]] - where promClauses = map genPromClause - genPromClause (constr, args,_) = do + progressAndNextDecl <- funD 'progressAndNext (map genProgressAndNext constrs') + progressInternalDecl <- funD 'progressInternal (map genProgressInternal constrs') + nextProgressDecl <- funD 'nextProgress (map genNextProgress constrs') + return [mkInstanceD preCond classType [progressAndNextDecl,progressInternalDecl,nextProgressDecl]] + where genProgressAndNext (constr, args,_) = do let n = length args varNs <- newNames n "x" + varNsR <- newNames n "y" + varNsS <- newNames n "z" varIn <- newName "_inp" let pat = ConP constr [] $ map VarP varNs + + progressInternalExp <- [|progressAndNext|] + let lets = zipWith3 (\ x y z -> ValD (TupP [VarP y, VarP z]) (NormalB (progressInternalExp `AppE` VarE varIn `AppE` VarE x)) []) varNs varNsR varNsS + clockUnionExp <- [|clockUnion|] + result <- appsE ( conE constr : (map varE varNsR)) + clock <- if n == 0 then [|emptyClock|] else return (foldl1 (\ x y -> (clockUnionExp `AppE` x) `AppE` y) (map VarE varNsS)) + let body = LetE lets (TupE [Just result, Just clock]) + return $ Clause [VarP varIn, pat] (NormalB body) [] + genProgressInternal (constr, args,_) = do + let n = length args + varNs <- newNames n "x" + varIn <- newName "_inp" + let pat = ConP constr [] $ map VarP varNs allVars = map varE varNs inpVar = varE varIn body <- appsE ( conE constr : (map (\ x -> [|progressInternal $inpVar $x|]) allVars)) return $ Clause [VarP varIn, pat] (NormalB body) [] + genNextProgress (constr, args,_) = do + let n = length args + varNs <- newNames n "x" + let pat = ConP constr [] $ map VarP varNs + allVars = map varE varNs + body <- if n == 0 then [|emptyClock|] else foldl1 (\ x y -> [|clockUnion $x $y|]) ((map (\ x -> [|nextProgress $x|]) allVars)) + return $ Clause [pat] (NormalB body) [] diff --git a/src/AsyncRattus/InternalPrimitives.hs b/src/AsyncRattus/InternalPrimitives.hs --- a/src/AsyncRattus/InternalPrimitives.hs +++ b/src/AsyncRattus/InternalPrimitives.hs @@ -21,6 +21,9 @@ singletonClock :: InputChannelIdentifier -> Clock singletonClock = IntSet.singleton +emptyClock :: Clock +emptyClock = IntSet.empty + clockUnion :: Clock -> Clock -> Clock clockUnion = IntSet.union @@ -129,7 +132,7 @@ -- implement the constant signal @x ::: never@ of type @Sig a@ for any @x :: -- a@. never :: O a -never = Delay IntSet.empty (error "Trying to adv on the 'never' delayed computation") +never = Delay emptyClock (error "Trying to adv on the 'never' delayed computation") -- | A type is @Stable@ if it is a strict type and the later modality -- @O@ and function types only occur under @Box@. @@ -184,13 +187,26 @@ class Continuous p where + -- | Computes the same as 'progressInternal' and 'nextProgress'. In + -- particular @progressAndNext inp v = (progressInternal inp v, + -- nextProgress (progressInternal inp v))@. + progressAndNext :: InputValue -> p -> (p , Clock) + + -- | Progresses the continuous value, given the input value from + -- some channel progressInternal :: InputValue -> p -> p + -- | Computes the set of channels that the continuous value is + -- depending on. That is if @nextProgress v = cl@ and a new input + -- @inp@ on channel @ch@ arrives, then @progressInternal inp v = v@. + nextProgress :: p -> Clock promoteInternal :: p -> Box p promoteInternal = defaultPromote -- For stable types we can circumvent the "promote store". instance {-# OVERLAPPABLE #-} Stable a => Continuous a where + progressAndNext _ x = (x , emptyClock) progressInternal _ x = x + nextProgress _ = emptyClock promoteInternal = Box data ContinuousData where diff --git a/src/AsyncRattus/Plugin/Strictify.hs b/src/AsyncRattus/Plugin/Strictify.hs --- a/src/AsyncRattus/Plugin/Strictify.hs +++ b/src/AsyncRattus/Plugin/Strictify.hs @@ -27,9 +27,7 @@ checkStrictData ss (Tick (SourceNote span _) e) = checkStrictData (ss{srcSpan = fromRealSrcSpan span}) e checkStrictData ss (App e1 e2) - | isPushCallStack e1 = return () - | isFromList e1 = return () - | isFromString e1 = return () + | ignoreArgument e1 = return () | otherwise = do when (not (isType e2) && tcIsLiftedTypeKind(typeKind (exprType e2)) && not (isStrict (exprType e2)) && not (isDeepseqForce e2) && not (isLit e2)) @@ -46,29 +44,17 @@ isLit _ = False -isFromList :: CoreExpr -> Bool -isFromList (Var v) = - case getNameModule v of - Just (name, mod) -> (mod == "GHC.Exts" || mod == "GHC.IsList") && (name == "fromList" || name == "fromListN") - _ -> False -isFromList (App x _) = isFromList x -isFromList _ = False - -isFromString :: CoreExpr -> Bool -isFromString (Var v) = - case getNameModule v of - Just (name, mod) -> mod == "Data.String" && name == "fromString" - _ -> False -isFromString (App x _) = isFromString x -isFromString _ = False - -isPushCallStack :: CoreExpr -> Bool -isPushCallStack (Var v) = +ignoreArgument :: CoreExpr -> Bool +ignoreArgument (Var v) = case getNameModule v of - Just (name, mod) -> mod == "GHC.Stack.Types" && name == "pushCallStack" + Just (name, mod) -> + ((mod == "GHC.Exts" || mod == "GHC.IsList") && (name == "fromList" || name == "fromListN")) || + (mod == "Data.String" && name == "fromString") || + (mod == "GHC.Stack.Types" && name == "pushCallStack") || + (mod == "Data.Text.Internal" && name == "pack") _ -> False -isPushCallStack (App x _) = isPushCallStack x -isPushCallStack _ = False +ignoreArgument (App x _) = ignoreArgument x +ignoreArgument _ = False isDeepseqForce :: CoreExpr -> Bool isDeepseqForce (App (App (App (Var v) _) _) _) = diff --git a/src/AsyncRattus/Signal.hs b/src/AsyncRattus/Signal.hs --- a/src/AsyncRattus/Signal.hs +++ b/src/AsyncRattus/Signal.hs @@ -329,8 +329,8 @@ | otherwise = cur ::: delay ( case select xs (unbox (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')) + Snd xs' _ -> int (dtf *^ (cur ^+^ x)) (x ::: xs') + Both (x' ::: xs') _ -> int (dtf *^ (cur ^+^ x')) (x'::: xs')) -- sampling interval in seconds dtf :: a dtf = fromRational (fromIntegral dt % 1000000) @@ -353,14 +353,18 @@ | otherwise = d ::: delay ( case select xs (unbox (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')) + Snd xs' _ -> der ((x ^-^ last) ^/ dtf) x (x ::: xs') + Both (x' ::: xs') _ -> der ((x' ^-^ last) ^/ dtf) x' (x' ::: xs')) instance Continuous a => Continuous (Sig a) where progressInternal inp (x ::: xs@(Delay cl _)) = - if inputInClock inp cl then adv' xs inp + if inputInClock inp cl then (adv' xs inp) else progressInternal inp x ::: xs + progressAndNext inp (x ::: xs@(Delay cl _)) = + if inputInClock inp cl then let n = adv' xs inp in (n, nextProgress n) + else let (n , cl') = progressAndNext inp x in (n ::: xs , cl `clockUnion` cl') + nextProgress (x ::: (Delay cl _)) = nextProgress x `clockUnion` cl -- Prevent functions from being inlined too early for the rewrite -- rules to fire.