WidgetRattus 0.1.1 → 0.2

raw patch · 6 files changed

+69/−35 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• WidgetRattus.cabal +1/−1
• src/AsyncRattus/Derive.hs +27/−4
• src/AsyncRattus/InternalPrimitives.hs +17/−1
• src/AsyncRattus/Plugin/Strictify.hs +10/−24
• src/AsyncRattus/Signal.hs +9/−5

@@ -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

@@ -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:

@@ -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) []

@@ -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

@@ -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) _) _) _) =

@@ -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.