packages feed

WidgetRattus 0.4 → 0.5

raw patch · 19 files changed

+1599/−118 lines, 19 filesdep ~containersdep ~ghcdep ~ghc-boot

Dependency ranges changed: containers, ghc, ghc-boot, template-haskell

Files

CHANGELOG.md view
@@ -1,3 +1,44 @@+# 0.5++ - Include push-pull-style behaviours and events (modules+   `WidgetRattus.Behaviour` and `WidgetRattus.Event`) along with a+   variant of the widget library based on behaviours and events+   (module `WidgetRattus.PushPull.Widgets`).+ - Rename `trigger`, `triggerM`, `triggerAwait`, and `triggerAwaitM`+   in `WidgetRattus.Signal` to `sample`, `sampleM`, `sampleAwait`,+   and `sampleAwaitM`, respectively, and `trigger` and `triggerAwait`+   in `WidgetRattus.Future` to `sample` and `sampleAwait`.+ - Support GHC 9.10, 9.12, and 9.14. With GHC 9.10 and later, monomer+   and some of its dependencies need `allow-newer` for `containers`+   (see README).+ - Fix the multiplicity of the binder that the plugin generates for+   `delay`.+ - Scope checking now also accounts for `Stable` constraints brought+   into scope by patterns that the type checker wraps in a coercion,+   e.g. when matching on a constructor of a data family instance.+ - New signal combinators `parallel` and `parallelWith`, and their+   variants `parallelAwait` and `parallelWithAwait` for delayed+   signals.+ - New function `chanSig` in `WidgetRattus.Signal`, which turns a+   channel into a delayed signal.+ - New function `withTime` in `WidgetRattus`, which gives a delayed+   computation access to the time at which it ticks.+ - New type synonym `DTime` and operator `<->` in `WidgetRattus.Time`+   for time differences.+ - New strict sum type `:+` in `WidgetRattus.Strict`.+ - New `Functor` instance for `Maybe'`.++# 0.4.0.1++ - The constraint solver for stable types can now handle data types+   with existential variables that have a `Stable` constraint, e.g. a+   GADT with constructor `MkFoo :: Stable a => !a -> Foo` is now+   recognised as stable.+ - Scope checking of variable now accounts for pattern matching with+   existential types. So pattern matching against the type `Foo`+   defined above accounts for the stable constraint. For instance, a+   function definition `fun (MkFoo x) = box x` now type checks.+ # 0.4  - The C monad can now be discharged under the O modality via delayC.
WidgetRattus.cabal view
@@ -1,6 +1,6 @@ cabal-version:       1.18 name:                WidgetRattus-version:             0.4+version:             0.5 category:            FRP synopsis:            An asynchronous modal FRP language for GUI programming description:@@ -43,6 +43,8 @@   exposed-modules:     WidgetRattus                        WidgetRattus.Signal                        WidgetRattus.Future+                       WidgetRattus.Behaviour+                       WidgetRattus.Event                        WidgetRattus.Strict                        WidgetRattus.Time                        WidgetRattus.Plugin@@ -50,6 +52,7 @@                        WidgetRattus.InternalPrimitives                        WidgetRattus.Plugin.Annotation                        WidgetRattus.Widgets+                       WidgetRattus.PushPull.Widgets                                                  other-modules:       WidgetRattus.Plugin.ScopeCheck                        WidgetRattus.Plugin.SingleTick@@ -63,13 +66,13 @@                        WidgetRattus.Widgets.InternalTypes                        WidgetRattus.Derive   build-depends:       base >=4.16 && <5,-                       containers >= 0.6.5 && < 0.8,-                       ghc >= 9.2 && < 9.9,-                       ghc-boot >= 9.2 && < 9.9,+                       containers >= 0.6.5 && < 0.9,+                       ghc >= 9.2 && < 9.15,+                       ghc-boot >= 9.2 && < 9.15,                        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,+                       template-haskell >= 2.17 && < 2.25,                        text >= 1.2 && < 3,                        monomer >= 1.4 && < 2,                        time >= 1.10 && < 2
examples/gui/src/Calculator.hs view
@@ -68,7 +68,7 @@     -- operator @op@. @n@ is the value of @numberSig@ just before     -- clicking an operator button, and op is taken from opSig     let operand :: Sig (Maybe' (Int :* Op))-         = Nothing' ::: triggerAwaitM (box (\op n -> Just' (n :* op))) opSig (buffer 0 numberSig)+         = Nothing' ::: sampleAwaitM (box (\op n -> Just' (n :* op))) opSig (buffer 0 numberSig)      -- The result signal consisting of a number n that is the result     -- of the current computation, an operator op that still needs to
examples/gui/src/Stopwatch.hs view
@@ -24,10 +24,10 @@   -elapsedTime :: C (NominalDiffTime -> Sig NominalDiffTime)+elapsedTime :: C (DTime -> Sig DTime) elapsedTime =  do t <- time                   return (\ s -> run s t)-     where run :: NominalDiffTime -> Time -> Sig NominalDiffTime+     where run :: DTime -> Time -> Sig DTime            run start t =                 start ::: delayC (delay (                     let _ = adv sampleInterval @@ -39,19 +39,19 @@     startBtn <- mkButton (const ("Start" :: Text))     stopBtn <- mkButton (const ("Stop" :: Text))     let startDelay = btnOnClick startBtn-    let startSig :: O (Sig (NominalDiffTime -> Sig NominalDiffTime)) +    let startSig :: O (Sig (DTime -> Sig DTime))           = mkSig' (box (delay (let _ = adv (unbox startDelay) in elapsedTime)))      let stopDelay = btnOnClick stopBtn-    let stopSig :: O (Sig (NominalDiffTime -> Sig NominalDiffTime)) +    let stopSig :: O (Sig (DTime -> Sig DTime))           = mkSig (box (delay (let _ = adv (unbox stopDelay) in const)))      -    let inputSig :: O (Sig (NominalDiffTime -> Sig NominalDiffTime))+    let inputSig :: O (Sig (DTime -> Sig DTime))          = interleave (box (\ x _ -> x)) startSig stopSig  -    let stopWatchSig :: Sig NominalDiffTime+    let stopWatchSig :: Sig DTime          = switchR (const 0) inputSig      timeLabName <- mkLabel (const ("Current Time:" :: Text))
src/WidgetRattus.hs view
@@ -16,7 +16,8 @@   -- * Annotation   WidgetRattus(..),   -- * other-  mapO+  mapO,+  withTime   )   where @@ -29,3 +30,8 @@  mapO :: Box (a -> b) -> O a -> O b mapO f later = delay (unbox f (adv later))++++withTime :: O (Time -> a) -> O a+withTime df = delayC (delay (adv df <$> time))
+ src/WidgetRattus/Behaviour.hs view
@@ -0,0 +1,262 @@+{-# OPTIONS -fplugin=WidgetRattus.Plugin #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}++module WidgetRattus.Behaviour where++import WidgetRattus+import WidgetRattus.InternalPrimitives (Continuous (..), O (Delay), adv', advC', clockUnion, inputInClock)+import WidgetRattus.Signal hiding (const, integral, jump, map, switch, zipWith)+import Prelude hiding (const, map, zipWith)++data Pull a where+  K :: !a -> Pull a+  Fun :: (Stable s) => !s -> !(Box (s -> Time -> (a :* Maybe' s))) -> Pull a++continuous ''Pull++at :: Pull a -> Time -> a+at (K a) _ =  a+at (Fun s f) t = let (a :* _) = unbox f s t in a++mapP :: Box (a -> b) -> Pull a -> Pull b+mapP f (K a) = K (unbox f a)+mapP f (Fun s f') = Fun s (box (\s t -> let (a :* s') = unbox f' s t in (unbox f a :* s')))++delayCF :: O(a -> C b) -> O(a -> b)+delayCF (Delay c f) = Delay c (\inp a -> advC' (f inp a) inp)++newtype Beh a = Beh (Sig (Pull a))++unwrap :: Beh a -> Sig (Pull a)+unwrap (Beh a) = a++cont :: Box (Time -> a) -> Beh a+cont f = Beh (Fun () (box (\ _ t -> (unbox f t :* Just' ()))) ::: never)++const :: a -> Beh a+const x = Beh (K x ::: never)++timeB :: Beh Time+timeB = cont (box id)++mapB :: Box (a -> b) -> Beh a -> Beh b+mapB f (Beh (x ::: xs)) = Beh (mapP f x ::: delay (unwrap $ mapB f (Beh (adv xs))))++sampleInterval :: O ()+sampleInterval = timer 20000++discretize :: Beh a -> C (Sig a)+discretize b = discretizeT b <$> time++discretizeT :: Beh a -> Time -> Sig a+discretizeT (Beh (K x ::: xs)) _ = x ::: withTime (delay (discretizeT (Beh (adv xs))))+discretizeT (Beh (Fun s f ::: xs)) t = discretizeFun s f xs t+  where+    discretizeFun :: (Stable s) => s -> Box (s -> Time -> (a :* Maybe' s)) -> O (Sig (Pull a)) -> Time -> Sig a+    discretizeFun s f xs t = cur ::: rest where+      (cur :* s') = unbox f s t+      rest = case s' of +               Nothing' -> withTime (delay (discretizeT (Beh (adv xs))))+               Just' s'' -> withTime $ delay+                    ( case select xs sampleInterval of+                        Fst  x     _ -> discretizeT (Beh x)+                        Snd  beh'  _ -> discretizeT (Beh (Fun s'' f ::: beh'))+                        Both x     _ -> discretizeT (Beh x)+                    )+              +++elapsedTime :: C (Beh DTime)+elapsedTime = do+  startTime <- time+  return $ Beh (Fun () (box (\s currentTime -> diffTime currentTime startTime :* Just' s)) ::: never)++switch :: Beh a -> O (Beh a) -> Beh a+switch (Beh (x ::: xs)) d =+  Beh $+    x+      ::: delay+        ( case select xs d of+            Fst xs' d' -> unwrap $ switch (Beh xs') d'+            Snd _ (Beh d') -> d'+            Both _ (Beh d') -> d'+        )++-- | This function is a variant of combines the values of two signals+-- using the function argument. @zipWith f xs ys@ produces a new value+-- @unbox f x y@ whenever @xs@ or @ys@ produce a new value, where @x@+-- and @y@ are the current values of @xs@ and @ys@, respectively.+--+-- Example:+--+-- >                      xs:  1 2 3     2+-- >                      ys:  1     0 5 2+-- > zipWith (box (+)) xs ys:  2 3 4 3 8 4+zipWith :: (Stable a, Stable b) => Box (a -> b -> c) -> Beh a -> Beh b -> Beh c+zipWith f (Beh (x ::: xs)) (Beh (y ::: ys)) =+  Beh+    ( app x y+        ::: delay+          ( let (Beh rest) =+                  ( case select xs ys of+                      Fst xs' lys -> zipWith f (Beh xs') (Beh (y ::: lys))+                      Snd lxs ys' -> zipWith f (Beh (x ::: lxs)) (Beh ys')+                      Both xs' ys' -> zipWith f (Beh xs') (Beh ys')+                  )+             in rest+          )+    )+  where+    app (K x') (K y') = K (unbox f x' y')+    app (Fun xs x') (Fun ys y') =+      Fun+        (xs :* ys)+        ( box+            ( \(s :* s') t ->+                let (a :* xs') = unbox x' s t+                    (b :* ys') = unbox y' s' t+                    left = unbox f a b+                 in case (xs' :* ys') of+                      (Just' xs'' :* Just' ys'') -> left :* Just' (xs'' :* ys'')+                      _ -> left :* Nothing'+            )+        )+    app (Fun xs x') (K y') =+      Fun+        xs+        ( box+            ( \s t ->+                let (a :* xs') = unbox x' s t+                    left = unbox f a y'+                 in left :* xs'+            )+        )+    app (K x') (Fun ys y') =+      Fun+        ys+        ( box+            ( \s t ->+                let (b :* ys') = unbox y' s t+                    left = unbox f x' b+                 in left :* ys'+            )+        )++-- | Variant of 'zipWith' with three behaviours.+zipWith3 :: forall a b c d. (Stable a, Stable b, Stable c) => Box (a -> b -> c -> d) -> Beh a -> Beh b -> Beh c -> Beh d+zipWith3 f as bs cs = zipWith (box (\f' x -> unbox f' x)) cds cs+  where+    cds :: Beh (Box (c -> d))+    cds = zipWith (box (\a b -> box (\c -> unbox f a b c))) as bs++stop :: Box (a -> Bool) -> Beh a -> Beh a+stop p (Beh b) = Beh (run b)+  where+    run (K x ::: xs) = K x ::: if unbox p x then never else delay (run (adv xs))+    run (Fun s f ::: xs) =+      Fun+        s+        ( box+            ( \s' t ->+                let (a :* s'') = unbox f s' t+                 in let b = unbox p a+                     in (if b then a :* Nothing' else a :* s'')+            )+        )+        ::: delay (run (adv xs))++stopWith :: Box (a -> Maybe' a) -> Beh a -> Beh a+stopWith p (Beh b) = Beh (run b)+  where+    run (K x ::: xs) =+      case unbox p x of+        Just' a -> K a ::: never+        Nothing' -> K x ::: delay (run (adv xs))+    run (Fun s f ::: xs) =+      Fun+        s+        ( box+            ( \s' t ->+                let (a :* s'') = unbox f s' t+                 in case unbox p a of+                      Just' a' -> a' :* Nothing'+                      Nothing' -> a :* s''+            )+        )+        ::: delay (run (adv xs))++integral ::  Float  -> Beh Float -> C (Beh Float)+integral cur (Beh xs) = Beh <$> int xs cur <$> time where+  int :: Sig (Pull Float) -> Float -> Time -> Sig (Pull Float)+  int (K a ::: xs) cur t = curF ::: rest where+    rest = withTime ( delay (\t' -> int (adv xs) (cur + a * (t' <-> t)) t'))+    curF = Fun () (box (\s t' -> cur + a * (t' <-> t) :* Just' s))++  int (Fun s f ::: xs) cur t = intFun s f xs cur t where+    intFun :: forall s. (Stable s) => s -> Box (s -> Time -> (Float :* Maybe' s)) -> O (Sig (Pull Float)) -> Float -> Time -> Sig (Pull Float)+    intFun s f xs cur t = curF ::: rest where+      rest = withTime (delay (\ t'-> int (adv xs) (cur + (fst' (unbox f s t')) * (t' <-> t)) t'))+      curF = Fun (cur :* t :* Left' s)+                       (box ( \(lv :* lt :* ls) t' -> +                          let v :* s' = case ls of Right' v  -> v :* Right' v+                                                   Left' ls' -> case unbox f ls' t' of +                                                              v :* Nothing' -> v :* Right' v+                                                              v :* Just' s -> v :* Left' s+                          in lv + v * (t' <-> lt) :* Just' (lv + v * (t' <-> lt) :* t' :* s')))++++derivative :: Beh Float -> C (Beh Float)+derivative (Beh (x ::: xs)) = (\t ->  Beh (der (at x t) (x ::: xs) t)) <$> time where+    der :: Float -> Sig (Pull Float) -> Time -> Sig (Pull Float)+    der last (Fun s f ::: xs) t = derFun last s f xs t+      where+        derFun :: forall s. (Stable s) => Float -> s -> Box (s -> Time -> (Float :* Maybe' s)) -> O (Sig (Pull Float)) -> Time -> (Sig (Pull Float))+        derFun last s f xs t = curF ::: rest where+          rest = withTime ( delay (\ t' -> der (fst' (unbox f s t')) (adv xs) t'))+          curF =+                Fun (last :* t :* s) $ box+                    ( \(last :* t :* s) t' -> case unbox f s t of+                              v :* Just' s' -> (v - last) / (t' <-> t) :* Just' (v :* t' :* s')+                              _ :* Nothing' -> 0 :* Nothing')+    der last (K x ::: xs) t = curF ::: rest where+      rest = withTime (delay (der x (adv xs)))+      curF = Fun (last :* t) $ box (\(last :* t) t' -> (x - last) / (t' <-> t) :* Just' (x :* t'))++instance (Continuous a) => Continuous (Beh a) where+  progressInternal inp (Beh (x ::: xs@(Delay cl _))) =+    if inputInClock inp cl+      then Beh (adv' xs inp)+      else progressInternal inp (Beh (x ::: xs))+  progressAndNext inp (Beh (x ::: xs@(Delay cl _))) =+    if inputInClock inp cl+      then let n = adv' xs inp in (Beh n, nextProgress n)+      else let (n, cl') = progressAndNext inp x in (Beh (n ::: xs), cl `clockUnion` cl')+  nextProgress (Beh (x ::: (Delay cl _))) = nextProgress x `clockUnion` cl++-- Prevent functions from being inlined too early for the rewrite+-- rules to fire.++{-# NOINLINE [1] mapB #-}++{-# NOINLINE [1] const #-}++{-# NOINLINE [1] switch #-}++{-# RULES+"beh.map/beh.map" forall f g xs.+  mapB f (mapB g xs) =+    mapB (box (unbox f . unbox g)) xs+"beh.const/beh.map" forall (f :: (Stable b) => Box (a -> b)) x.+  mapB f (const x) =+    let x' = unbox f x in const x'+"beh.const/beh.switch" forall x xs.+  switch (const x) xs =+    Beh (K x ::: delay (unwrap (adv xs)))+  #-}
+ src/WidgetRattus/Event.hs view
@@ -0,0 +1,287 @@+{-# OPTIONS -fplugin=WidgetRattus.Plugin #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE ScopedTypeVariables #-}++module WidgetRattus.Event where++import WidgetRattus.Behaviour++import WidgetRattus+import WidgetRattus.Signal hiding (buffer, interleave, interleaveAll, map, scan, switchR, switchS)+import qualified WidgetRattus.Signal as Sig+import Prelude hiding (filter, map)++data Ev a+  = Dense !(O (Sig a))+  | Sparse !(O (Sig (Maybe' a)))++mkEv :: Box (O a) -> Ev a+mkEv = Dense . run where+    run :: Box (O a) -> O (Sig a)+    run a = delay (adv (unbox a) ::: run a)++mkEv' :: Box (O (C a)) -> Ev a+mkEv' = Dense . run where+    run :: Box (O (C a)) -> O (Sig a)+    run b = delayC (delay ((::: run b) <$> adv (unbox b)))+++mapEC :: forall a b . Box (a -> C b) -> Ev a -> Ev b+mapEC f (Dense sig) = Dense (run sig) where+    run :: O (Sig a) -> O (Sig b)+    run sig = delayC ( delay ( do let x ::: xs = adv sig+                                  x' <- unbox f x +                                  return (x' ::: run xs) ))+mapEC f (Sparse sig) = Sparse (run sig) where+    run :: O (Sig (Maybe' a)) -> O (Sig (Maybe' b))+    run sig = delayC (delay (do case adv sig of+                                  Nothing' ::: xs -> return (Nothing' ::: run xs)+                                  Just' x ::: xs -> (\ x' -> Just' x' ::: run xs) <$> unbox f x))++mapE :: forall a b . Box (a -> b) -> Ev a -> Ev b+mapE f (Dense sig) = Dense (run sig) where+    run :: O (Sig a) -> O (Sig b)+    run sig = delay ( let x ::: xs = adv sig+                      in unbox f x ::: run xs )+mapE f (Sparse sig) = Sparse (run sig) where+    run :: O (Sig (Maybe' a)) -> O (Sig (Maybe' b))+    run sig = delay ( let x ::: xs = adv sig+                      in (unbox f <$> x) ::: run xs)++discr :: (Stable a) => a -> Ev a -> Beh a+discr initial event =+  Beh (K initial ::: delay (unwrap (adv (aux initial event))))+  where+    aux :: (Stable a) => a -> Ev a -> O (Beh a)+    aux _ (Dense ev) =+      delay (let (x ::: xs) = adv ev in Beh (K x ::: delay (unwrap (adv (aux x (Dense xs))))))+    aux initial (Sparse ev) =+      delay+        ( let (x ::: xs) = adv ev+           in case x of+                Just' x' ->+                  Beh (K x' ::: delay (unwrap (adv (aux x' (Sparse xs)))))+                Nothing' -> Beh (K initial ::: delay (unwrap (adv (aux initial (Sparse xs)))))+        )++sample :: (Stable b) => Box (a -> b -> c) -> Ev a -> Beh b -> Ev c+sample f (Sparse ev) (Beh beh) = Sparse (run ev beh) where+  run as (b ::: bs) = withTime $ delay+    ( let d = select as bs+      in \ t -> case d of+        Fst (Just' a'' ::: as') bs' -> Just' (unbox f a'' (at b t)) ::: run as' (b ::: bs')+        Fst (Nothing' ::: as') bs' -> Nothing' ::: run as' (b ::: bs')+        Snd as' bs' -> Nothing' ::: run as' bs'+        Both (Just' a'' ::: as') (b' ::: bs') -> Just' (unbox f a'' (at b' t)) ::: run as' (b' ::: bs')+        Both (Nothing' ::: as') (b' ::: bs') -> Nothing' ::: run as' (b' ::: bs'))+sample f (Dense ev) (Beh beh) = Sparse (run ev beh) where+  run as (b ::: bs) =  withTime $ delay+    ( let d = select as bs+      in \ t -> case d of+          Fst (a' ::: as') bs' -> Just' (unbox f a' (at b t)) ::: run as' (b ::: bs')+          Snd as' bs' -> Nothing' ::: run as' bs'+          Both (a' ::: as') (b' ::: bs') -> Just' (unbox f a' (at b' t)) ::: run as' (b' ::: bs') )++interleave :: Box (a -> a -> a) -> Ev a -> Ev a -> Ev a+interleave f (Dense xs) (Dense ys) = Dense (run xs ys) where+  run xs ys = delay ( case select xs ys of+            Fst (x ::: xs') ys' -> x ::: run xs' ys'+            Snd xs' (y ::: ys') -> y ::: run xs' ys'+            Both (x ::: xs') (y ::: ys') -> unbox f x y ::: run xs' ys' )+interleave f (Sparse xs) (Sparse ys) = Sparse (run xs ys) where+  run xs ys = delay ( case select xs ys of+          Fst (x ::: xs') ys' -> x ::: run xs' ys'+          Snd xs' (y ::: ys') -> y ::: run xs' ys'+          Both (Just' x ::: xs') (Nothing' ::: ys') -> Just' x ::: run xs' ys'+          Both (Nothing' ::: xs') (y ::: ys') -> y ::: run xs' ys'+          Both (Just' x ::: xs') (Just' y ::: ys') -> Just' (unbox f x y) ::: run xs' ys')+interleave f (Sparse xs) (Dense ys) = Sparse (run xs ys) where+  run xs ys = delay ( case select xs ys of+          Fst (x ::: xs') ys' -> x ::: run xs' ys'+          Snd xs' (y ::: ys') -> Just' y ::: run xs' ys'+          Both (Nothing' ::: xs') (y ::: ys') -> Just' y ::: run xs' ys'+          Both (Just' x ::: xs') (y ::: ys') -> Just' (unbox f x y) ::: run xs' ys')++interleave f (Dense xs) (Sparse ys) = Sparse (run xs ys) where+  run xs ys = delay ( case select xs ys of+          Fst (x ::: xs') ys' -> Just' x ::: run xs' ys'+          Snd xs' (y ::: ys') -> y ::: run xs' ys'+          Both (x ::: xs') (Nothing' ::: ys') -> Just' x ::: run xs' ys'+          Both (x ::: xs') (Just' y ::: ys') -> Just' (unbox f x y) ::: run xs' ys')+++{-# ANN interleaveAll AllowRecursion #-}+interleaveAll :: Box (a -> a -> a) -> List (Ev a) -> Ev a+interleaveAll _ Nil = error "interleaveAll: List must be nonempty"+interleaveAll _ [s] = s+interleaveAll f (x :! xs) = interleave f x (interleaveAll f xs)++scan :: Stable b => Box (b -> a -> b) -> b -> Ev a -> Ev b+scan f acc (Dense ev) = Dense (delay (Sig.scan f acc (adv ev))) where+scan f acc (Sparse ev) = Sparse (delay (scanSparse f acc (adv ev))) where++scanSparse :: Stable b => Box (b -> a -> b) -> b -> Sig (Maybe' a) -> Sig (Maybe' b)+scanSparse f acc (Just' x ::: xs) = let acc' = unbox f acc x in Just' acc' ::: delay (scanSparse f acc' (adv xs))+scanSparse f acc (Nothing' ::: xs) = Nothing' ::: delay (scanSparse f acc (adv xs))++filterMap :: Box (a -> Maybe' b) -> Ev a -> Ev b+filterMap f (Dense ev) = Sparse (run ev) where+  run ev = delay (let (x ::: xs) = adv ev in unbox f x ::: run xs)+filterMap f (Sparse ev) = Sparse (run ev) where+  run ev = delay (case adv ev of+                Just' x' ::: xs -> unbox f x' ::: run xs+                Nothing' ::: xs -> Nothing' ::: run xs)++-- filter f = filterMap (box (\x -> if unbox f x then Just' x else Nothing'))++filter :: Box (a -> Bool) -> Ev a -> Ev a+filter p (Dense ev) = Sparse (run ev) where+  run ev = delay (let x ::: xs = adv ev +                  in (if unbox p x then Just' x else Nothing') ::: run xs)+filter p (Sparse ev) = Sparse (run ev) where+  run ev = delay (case adv ev of +                    Nothing' ::: xs -> Nothing' ::: run xs+                    Just' x  ::: xs -> (if unbox p x then Just' x else Nothing') ::: run xs)+  +  +switchS :: (Stable a) => Beh a -> O (a -> Beh a) -> Beh a+switchS (Beh (x ::: xs)) d = Beh (x ::: withTime (delay (+              let ticker = select xs d+              in \ t -> case ticker of+                            Fst xs' d' -> unwrap $ switchS (Beh xs') d'+                            Snd _ f -> unwrap $ f (at x t)+                            Both _ f -> unwrap $ f (at x t))))++switchS' :: (Stable a) => Beh a -> O (a -> C (Beh a)) -> Beh a+switchS' (Beh (x ::: xs)) d = Beh (x ::: delayC (delay+              ( let ticker = select xs d+                 in do+                      t <- time+                      let result =+                            ( case ticker of+                                Fst xs' d' -> do+                                  return $ switchS' (Beh xs') d'+                                Snd _ f -> f (at x t)+                                Both _ f -> f (at x t)+                            )+                      unwrap <$> result+              )+          ))++switchSM :: (Stable a) => Beh a -> O (Maybe' (a -> Beh a)) -> Beh a+switchSM (Beh (x ::: xs)) d =+  let rest =+        delayC+          ( delay+              ( let ticker = select xs d+                 in do+                      t <- time+                      return+                        ( case ticker of+                            Fst xs' d' -> unwrap $ switchSM (Beh xs') d'+                            Snd _ (Just' f) -> unwrap $ f (at x t)+                            Snd xs' Nothing' -> x ::: xs'+                            Both _ (Just' f) -> unwrap $ f (at x t)+                            Both xs' Nothing' -> xs'+                        )+              )+          )+   in Beh (x ::: rest)++switchSM' :: (Stable a) => Beh a -> O (Maybe' (a -> C (Beh a))) -> Beh a+switchSM' (Beh (x ::: xs)) d =+  let rest =+        delayC+          ( delay+              ( let ticker = select xs d+                 in do+                      t <- time+                      let result =+                            ( case ticker of+                                Fst xs' d' -> do return $ switchSM' (Beh xs') d'+                                Snd _ (Just' f) -> f (at x t)+                                Snd xs' Nothing' -> do return $ Beh (x ::: xs')+                                Both _ (Just' f) -> f (at x t)+                                Both xs' Nothing' -> do return $ Beh xs'+                            )++                      unwrap <$> result+              )+          )+   in Beh (x ::: rest)++switchR :: (Stable a) => Beh a -> Ev (a -> Beh a) -> Beh a+switchR beh (Dense steps) =+  switchS beh (delay (let step ::: steps' = adv steps in (\x -> switchR (step x) (Dense steps'))))+switchR beh (Sparse steps) =+  switchSM+    beh+    ( delay+        ( let step ::: steps' = adv steps+           in case step of+                Just' a -> Just' (\x -> switchR (a x) (Sparse steps'))+                Nothing' -> Nothing'+        )+    )++switchRC :: (Stable a) => Beh a -> Ev (a -> C (Beh a)) -> Beh a+switchRC beh (Dense steps) =+  switchS'+    beh+    ( delay+        ( let step ::: steps' = adv steps+           in ( \x -> do+                  x' <- step x+                  return $ switchRC x' (Dense steps')+              )+        )+    )+switchRC beh (Sparse steps) =+  switchSM'+    beh+    ( delay+        ( let step ::: steps' = adv steps+           in case step of+                Just' a ->+                  Just'+                    ( \x -> do+                        x' <- a x+                        return $ switchRC x' (Sparse steps')+                    )+                Nothing' -> Nothing'+        )+    )++buffer :: (Stable a) => a -> Ev a -> Ev a+buffer x (Dense ys) = Dense (delay (let (y ::: ys') = adv ys in (x ::: let (Dense rest) = buffer y (Dense ys') in rest)))+buffer x (Sparse ys) =+  Dense+    ( delay+        ( let (y ::: ys') = adv ys+           in case y of+                Just' y' -> x ::: let (Dense rest) = buffer y' (Sparse ys') in rest+                Nothing' -> x ::: let (Dense rest) = buffer x (Sparse ys') in rest+        )+    )++-- Prevent functions from being inlined too early for the rewrite+-- rules to fire.++{-# NOINLINE [1] mapE #-}++{-# NOINLINE [1] filter #-}++{-# RULES+"ev.map/ev.map" forall f g xs.+  mapE f (mapE g xs) =+    mapE (box (unbox f . unbox g)) xs+"ev.map/ev.filter" forall f g xs.+  mapE f (filter g xs) =+    filterMap (box (\x -> if unbox g x then Just' (unbox f x) else Nothing')) xs+"ev.filter/ev.map" forall f g xs.+  filter f (mapE g xs) =+    filterMap (box (\x -> if (unbox f . unbox g) x then Just' $ unbox g x else Nothing')) xs+"ev.filter/ev.filter" forall f g xs.+  filter f (filter g xs) =+    filterMap (box (\x -> if unbox f x && unbox g x then Just' x else Nothing')) xs+  #-}
src/WidgetRattus/Future.hs view
@@ -25,8 +25,8 @@   , filterMapAwait   , filterAwait   , filter-  , trigger-  , triggerAwait+  , sample+  , sampleAwait   , map   , mapAwait   , zipWith@@ -146,26 +146,26 @@ filter :: Box (a -> Bool) -> SigF a -> F (SigF a) filter p = filterMap (box (\ x -> if unbox p x then Just' x else Nothing')) -trigger :: Stable b => Box (a -> b -> c) -> SigF a -> SigF b -> SigF c-trigger f (a :>: as) (b :>: bs) =+sample :: Stable b => Box (a -> b -> c) -> SigF a -> SigF b -> SigF c+sample f (a :>: as) (b :>: bs) =   unbox f a b :>:-  delay (uncurry' (trigger' b f) (adv (sync as bs)))+  delay (uncurry' (sample' b f) (adv (sync as bs))) -triggerAwait :: Stable b => Box (a -> b -> c) -> F (SigF a) -> SigF b -> F (SigF c)-triggerAwait f (Now (a :>: as)) (b :>: bs)-  = Now (unbox f a b :>: delay (uncurry' (trigger' b f) (adv (sync as bs))))-triggerAwait f (Wait as) (b :>: bs)-  = Wait (delay (uncurry' (trigger' b f) (adv (sync as bs))))+sampleAwait :: Stable b => Box (a -> b -> c) -> F (SigF a) -> SigF b -> F (SigF c)+sampleAwait f (Now (a :>: as)) (b :>: bs)+  = Now (unbox f a b :>: delay (uncurry' (sample' b f) (adv (sync as bs))))+sampleAwait f (Wait as) (b :>: bs)+  = Wait (delay (uncurry' (sample' b f) (adv (sync as bs)))) -trigger' :: Stable b => b -> Box (a -> b -> c) -> F (SigF a) -> F (SigF b) -> F (SigF c)-trigger' b f (Now (a :>: as)) (Wait bs) =-  Now (unbox f a b :>: delay (uncurry' (trigger' b f) (adv (sync as bs))))-trigger' _ f (Now (a :>: as)) (Now (b :>: bs)) =-  Now (unbox f a b :>: delay (uncurry' (trigger' b f) (adv (sync as bs))))-trigger' b f (Wait as) (Wait bs) =-  Wait (delay (uncurry' (trigger' b f) (adv (sync as bs))))-trigger' _ f (Wait as) (Now (b :>: bs)) =-  Wait (delay (uncurry' (trigger' b f) (adv (sync as bs))))+sample' :: Stable b => b -> Box (a -> b -> c) -> F (SigF a) -> F (SigF b) -> F (SigF c)+sample' b f (Now (a :>: as)) (Wait bs) =+  Now (unbox f a b :>: delay (uncurry' (sample' b f) (adv (sync as bs))))+sample' _ f (Now (a :>: as)) (Now (b :>: bs)) =+  Now (unbox f a b :>: delay (uncurry' (sample' b f) (adv (sync as bs))))+sample' b f (Wait as) (Wait bs) =+  Wait (delay (uncurry' (sample' b f) (adv (sync as bs))))+sample' _ f (Wait as) (Now (b :>: bs)) =+  Wait (delay (uncurry' (sample' b f) (adv (sync as bs))))   mapAwait :: Box (a -> b) -> F (SigF a) -> F (SigF b)
src/WidgetRattus/Plugin/Dependency.hs view
@@ -9,7 +9,8 @@ -- (mutual) recursive. To this end, this module also provides -- functions to compute, bound variables and variable occurrences. -module WidgetRattus.Plugin.Dependency (dependency, HasBV (..),printBinds) where+module WidgetRattus.Plugin.Dependency+  (dependency, HasBV (..), printBinds, Binds, bindsToList) where   import GHC.Plugins@@ -30,6 +31,7 @@ #endif  +import Data.List.NonEmpty (NonEmpty) import Data.Set (Set) import qualified Data.Set as Set import Data.Graph@@ -39,11 +41,25 @@   --- | Compute the dependencies of a bag of bindings, returning a list--- of the strongly-connected components.-dependency :: Bag (LHsBindLR GhcTc GhcTc) -> [SCC (LHsBindLR GhcTc GhcTc, Set Var)]+-- | The collection of bindings that GHC uses in 'LHsBinds'. Up to GHC+-- 9.10 this is a 'Bag', from GHC 9.12 onwards it is a plain list.+#if __GLASGOW_HASKELL__ >= 912+type Binds = []++bindsToList :: Binds a -> [a]+bindsToList = id+#else+type Binds = Bag++bindsToList :: Binds a -> [a]+bindsToList = bagToList+#endif++-- | Compute the dependencies of a collection of bindings, returning a+-- list of the strongly-connected components.+dependency :: Binds (LHsBindLR GhcTc GhcTc) -> [SCC (LHsBindLR GhcTc GhcTc, Set Var)] dependency binds = map AcyclicSCC noDeps ++ catMaybes (map filterJust (stronglyConnComp (concat deps)))-  where (deps,noDeps) = partitionEithers $ map mkDep $ bagToList binds+  where (deps,noDeps) = partitionEithers $ map mkDep $ bindsToList binds         mkDep :: GenLocated l (HsBindLR GhcTc GhcTc) ->                  Either [(Maybe (GenLocated l (HsBindLR GhcTc GhcTc), Set Var), Name, [Name])]                  (GenLocated l (HsBindLR GhcTc GhcTc), Set Var)@@ -102,7 +118,11 @@ getRecFieldRhs = hsRecFieldArg #endif +#if __GLASGOW_HASKELL__ >= 914+getConBV (PrefixCon ps) = getBV ps+#else getConBV (PrefixCon _ ps) = getBV ps+#endif getConBV (InfixCon p p') = getBV p `Set.union` getBV p' getConBV (RecCon (HsRecFields {rec_flds = fs})) = foldl run Set.empty fs       where run s (L _ f) = getBV (getRecFieldRhs f) `Set.union` s@@ -119,13 +139,19 @@ instance HasBV (Pat GhcTc) where   getBV (VarPat _ (L _ v)) = Set.singleton v   getBV (LazyPat _ p) = getBV p-#if __GLASGOW_HASKELL__ >= 906+#if __GLASGOW_HASKELL__ >= 910+  getBV (AsPat _ (L _ v) p) = Set.insert v (getBV p)+#elif __GLASGOW_HASKELL__ >= 906   getBV (AsPat _ (L _ v) _ p) = Set.insert v (getBV p) #else   getBV (AsPat _ (L _ v) p) = Set.insert v (getBV p) #endif   getBV (BangPat _ p) = getBV p   getBV (ListPat _ ps) = getBV ps+#if __GLASGOW_HASKELL__ >= 912+  -- or-patterns cannot bind variables, but we traverse them anyway+  getBV (OrPat _ ps) = foldMap getBV ps+#endif   getBV (TuplePat _ ps _) = getBV ps   getBV (SumPat _ p _ _) = getBV p   getBV (ViewPat _ _ p) = getBV p@@ -138,9 +164,12 @@       HsUntypedSplice _ _ v _ ->  Set.singleton v       HsQuasiQuote _ p p' _ _ -> Set.fromList [p,p']       _ -> Set.empty-#else+#elif __GLASGOW_HASKELL__ < 914       HsUntypedSpliceExpr _ e -> getFV e       HsQuasiQuote _ v _  -> Set.singleton v+#else+      HsUntypedSpliceExpr _ e -> getFV e+      HsQuasiQuote _ (L _ v) _  -> Set.singleton v #endif    getBV (NPlusKPat _ (L _ v) _ _ _ _) = Set.singleton v@@ -148,13 +177,19 @@   getBV (XPat p) = getBV p   getBV (WildPat {}) = Set.empty   getBV (LitPat {}) = Set.empty-#if __GLASGOW_HASKELL__ >= 904  +#if __GLASGOW_HASKELL__ >= 910+  getBV (ParPat _ p) = getBV p+#elif __GLASGOW_HASKELL__ >= 904     getBV (ParPat _ _ p _) = getBV p #else   getBV (ParPat _ p) = getBV p #endif   getBV (ConPat {pat_args = con}) = getConBV con   getBV (SigPat _ p _) = getBV p+#if __GLASGOW_HASKELL__ >= 910+  getBV (EmbTyPat _ _) = Set.empty+  getBV (InvisPat _ _) = Set.empty+#endif  #if __GLASGOW_HASKELL__ < 904 instance HasBV NoExtCon where@@ -175,6 +210,11 @@ instance HasFV a => HasFV [a] where   getFV es = foldMap getFV es +-- GHC 9.14 turned a number of syntax lists (e.g. the guarded RHSs of+-- a binding) into non-empty lists.+instance HasFV a => HasFV (NonEmpty a) where+  getFV es = foldMap getFV es+ instance HasFV a => HasFV (Bag a) where   getFV es = foldMap getFV es @@ -238,7 +278,11 @@ instance HasFV a => HasFV (StmtLR GhcTc GhcTc a) where   getFV (LastStmt _ e _ _) = getFV e   getFV (BindStmt _ _ e) = getFV e+#if __GLASGOW_HASKELL__ >= 912+  getFV (XStmtLR (ApplicativeStmt _ args _)) = foldMap (getFV . snd) args+#else   getFV (ApplicativeStmt _ args _) = foldMap (getFV . snd) args+#endif   getFV (BodyStmt _ e _ _) = getFV e   getFV (LetStmt _ bs) = getFV bs   getFV (ParStmt _ stms e _) = getFV stms `Set.union` getFV e@@ -273,22 +317,30 @@  instance HasFV (HsCmd GhcTc) where   getFV (HsCmdArrApp _ e1 e2 _ _) = getFV e1 `Set.union` getFV e2+#if __GLASGOW_HASKELL__ >= 912+  getFV (HsCmdArrForm _ e _ cmd) = getFV e `Set.union` getFV cmd+#else   getFV (HsCmdArrForm _ e _ _ cmd) = getFV e `Set.union` getFV cmd+#endif   getFV (HsCmdApp _ e1 e2) = getFV e1 `Set.union` getFV e2+#if __GLASGOW_HASKELL__ >= 910+  getFV (HsCmdLam _ _ mg) = getFV mg+#else   getFV (HsCmdLam _ l) = getFV l+#endif   getFV (HsCmdCase _ _ mg) = getFV mg   getFV (HsCmdIf _ _ e1 e2 e3) = getFV e1 `Set.union` getFV e2 `Set.union` getFV e3   getFV (HsCmdDo _ cmd) = getFV cmd-#if __GLASGOW_HASKELL__ >= 904+#if __GLASGOW_HASKELL__ >= 910+  getFV (HsCmdPar _ cmd) = getFV cmd+  getFV (HsCmdLet _ bs _) = getFV bs+#elif __GLASGOW_HASKELL__ >= 904   getFV (HsCmdPar _ _ cmd _) = getFV cmd   getFV (HsCmdLet _ _ bs _ _) = getFV bs+  getFV (HsCmdLamCase _ _ mg) = getFV mg #else   getFV (HsCmdPar _ cmd) = getFV cmd   getFV (HsCmdLet _ bs _) = getFV bs-#endif-#if __GLASGOW_HASKELL__ >= 904-  getFV (HsCmdLamCase _ _ mg) = getFV mg-#else   getFV (HsCmdLamCase _ mg) = getFV mg #endif   getFV (XCmd e) = getFV e@@ -309,12 +361,21 @@  instance HasFV (HsExpr GhcTc) where   getFV (HsVar _ v) = getFV v+#if __GLASGOW_HASKELL__ >= 914+  getFV HsHole {} = Set.empty+#else   getFV HsUnboundVar {} = Set.empty+#endif   getFV HsOverLabel {} = Set.empty   getFV HsIPVar {} = Set.empty   getFV HsOverLit {} = Set.empty   getFV HsLit {} = Set.empty+#if __GLASGOW_HASKELL__ >= 910+  getFV (HsLam _ _ mg) = getFV mg+  getFV (HsEmbTy _ _) = Set.empty+#else   getFV (HsLam _ mg) = getFV mg+#endif   getFV (HsApp _ e1 e2) = getFV e1 `Set.union` getFV e2         getFV (OpApp _ e1 e2 e3) = getFV e1 `Set.union` getFV e2 `Set.union` getFV e3   getFV (NegApp _ e _) = getFV e@@ -340,7 +401,23 @@   getFV (HsProc _ _ e) = getFV e   getFV (HsStatic _ e) = getFV e   getFV (XExpr e) = getFV e-#if __GLASGOW_HASKELL__ >= 904+#if __GLASGOW_HASKELL__ >= 912+  getFV (HsPar _ e) = getFV e+  getFV (HsLet _ bs e) = getFV bs `Set.union` getFV e+  getFV (HsTypedBracket _ e) = getFV e+  getFV (HsUntypedBracket _ e) = getFV e+  -- type syntax that may occur in term position+  getFV (HsForAll _ _ e) = getFV e+  getFV (HsQual _ ctxt e) = getFV ctxt `Set.union` getFV e+  getFV (HsFunArr _ arr e1 e2) =+    getFV arr `Set.union` getFV e1 `Set.union` getFV e2+#elif __GLASGOW_HASKELL__ >= 910+  getFV (HsPar _ e) = getFV e+  getFV (HsLet _ bs e) = getFV bs `Set.union` getFV e+  getFV HsRecSel {} = Set.empty+  getFV (HsTypedBracket _ e) = getFV e+  getFV (HsUntypedBracket _ e) = getFV e+#elif __GLASGOW_HASKELL__ >= 904   getFV (HsPar _ _ e _) = getFV e     getFV (HsLamCase _ _ mg) = getFV mg   getFV (HsLet _ _ bs _ e) = getFV bs `Set.union` getFV e@@ -360,7 +437,10 @@   getFV HsTcBracketOut {} = Set.empty #endif -#if __GLASGOW_HASKELL__ >= 906+#if __GLASGOW_HASKELL__ >= 910+  getFV (HsAppType _ e _) = getFV e+  getFV (ExprWithTySig _ e _) = getFV e+#elif __GLASGOW_HASKELL__ >= 906   getFV (HsAppType _ e _ _) = getFV e   getFV (ExprWithTySig _ e _) = getFV e   #else@@ -372,8 +452,17 @@   instance HasFV XXExprGhcTc where+#if __GLASGOW_HASKELL__ >= 912+  getFV (WrapExpr _ e) = getFV e+  getFV HsRecSelTc {} = Set.empty+#else   getFV (WrapExpr e) = getFV e+#endif+#if __GLASGOW_HASKELL__ >= 910+  getFV (ExpandedThingTc _ e) = getFV e+#else   getFV (ExpansionExpr (HsExpanded _e1 e2)) = getFV e2+#endif #if __GLASGOW_HASKELL__ >= 904     getFV (HsTick _ e) = getFV e   getFV (HsBinTick _ _ e) = getFV e@@ -383,3 +472,13 @@  instance HasFV (e GhcTc) => HasFV (HsWrap e) where   getFV (HsWrap _ e) = getFV e++#if __GLASGOW_HASKELL__ >= 914+instance HasFV (HsMultAnnOf (GenLocated SrcSpanAnnA (HsExpr GhcTc)) GhcTc) where+  getFV (HsExplicitMult _ e) = getFV e+  getFV _ = Set.empty+#elif __GLASGOW_HASKELL__ >= 912+instance HasFV (HsArrowOf (GenLocated SrcSpanAnnA (HsExpr GhcTc)) GhcTc) where+  getFV (HsExplicitMult _ e) = getFV e+  getFV _ = Set.empty+#endif
src/WidgetRattus/Plugin/ScopeCheck.hs view
@@ -34,6 +34,11 @@ import GHC.Hs.Expr import GHC.Hs.Pat import GHC.Hs.Binds+#if __GLASGOW_HASKELL__ >= 914+import GHC.Hs.Type (HsMultAnnOf (..))+#elif __GLASGOW_HASKELL__ >= 912+import GHC.Hs.Type (HsArrowOf (..))+#endif  import Data.Graph import qualified Data.Set as Set@@ -150,7 +155,19 @@   -- addition returns the the set of variables bound by it.   checkBind :: GetCtxt => a -> CheckM (Bool,Set Var) +-- | This class is used to collect the 'Stable' constraints that a+-- piece of syntax brings into scope by pattern matching.+class BoundStable a where+  -- | 'getBoundStable' returns all type variables that have obtained a+  -- 'Stable' constraint (by virtue of pattern matching against a+  -- GADT). For example, given a constructor @MkFoo :: Stable a => !a+  -- -> Foo@, the pattern matching in the following function+  -- definition produces a stable constraint on the type of @x@:+  --+  -- > fun (MkFoo x) = box x+  getBoundStable :: a -> Set Var + -- | set the current context. setCtxt :: Ctxt -> (GetCtxt => a) -> a  setCtxt c a = let ?ctxt = c in a@@ -165,11 +182,20 @@   -getLocAnn' :: SrcSpanAnn' b -> SrcSpan+-- | The annotation component of a located piece of syntax. GHC 9.10+-- dropped the @SrcSpanAnn'@ wrapper and instead keeps the source span+-- in the 'EpAnn' annotation itself.+#if __GLASGOW_HASKELL__ >= 910+type LocAnn = EpAnn+#else+type LocAnn = SrcSpanAnn'+#endif++getLocAnn' :: LocAnn b -> SrcSpan getLocAnn' = locA  -updateLoc :: SrcSpanAnn' b -> (GetCtxt => a) -> (GetCtxt => a)+updateLoc :: LocAnn b -> (GetCtxt => a) -> (GetCtxt => a) updateLoc src = modifyCtxt (\c -> c {srcLoc = getLocAnn' src})  @@ -191,10 +217,113 @@   +instance BoundStable a => BoundStable [a] where+  getBoundStable = foldMap getBoundStable++-- GHC 9.14 turned a number of syntax lists (e.g. the guarded RHSs of+-- a binding) into non-empty lists.+instance BoundStable a => BoundStable (NonEmpty a) where+  getBoundStable = foldMap getBoundStable++instance BoundStable a => BoundStable (Bag a) where+  getBoundStable = foldMap getBoundStable++instance BoundStable a => BoundStable (GenLocated l a) where+  getBoundStable (L _ x) = getBoundStable x++instance BoundStable a => BoundStable (RecFlag, a) where+  getBoundStable (_, x) = getBoundStable x++instance BoundStable (SCC a) where+  getBoundStable _ = Set.empty++-- Expressions and commands do not bind stable constraints themselves;+-- the constraints are brought into scope by the patterns around them.+instance BoundStable (HsExpr GhcTc) where+  getBoundStable _ = Set.empty++instance BoundStable (HsCmd GhcTc) where+  getBoundStable _ = Set.empty++#if __GLASGOW_HASKELL__ < 904+instance BoundStable CoPat where+  getBoundStable CoPat {co_pat_inner = p} = getBoundStable p+#else+instance BoundStable XXPatGhcTc where+  getBoundStable CoPat {co_pat_inner = p} = getBoundStable p+  getBoundStable (ExpansionPat _ p) = getBoundStable p+#endif++instance BoundStable (Pat GhcTc) where+  getBoundStable (ConPat {pat_con_ext = ConPatTc {cpt_dicts = dicts}}) =+    Set.fromList (mapMaybe (isStableConstr . varType) dicts)+  getBoundStable (LazyPat _ p) = getBoundStable p+#if __GLASGOW_HASKELL__ >= 910+  getBoundStable (AsPat _ _ p) = getBoundStable p+#elif __GLASGOW_HASKELL__ >= 906+  getBoundStable (AsPat _ _ _ p) = getBoundStable p+#else+  getBoundStable (AsPat _ _ p) = getBoundStable p+#endif+#if __GLASGOW_HASKELL__ >= 910+  getBoundStable (ParPat _ p) = getBoundStable p+#elif __GLASGOW_HASKELL__ >= 904+  getBoundStable (ParPat _ _ p _) = getBoundStable p+#else+  getBoundStable (ParPat _ p) = getBoundStable p+#endif+  getBoundStable (BangPat _ p) = getBoundStable p+  getBoundStable (ListPat _ p) = getBoundStable p+#if __GLASGOW_HASKELL__ >= 912+  getBoundStable (OrPat _ ps) = foldMap getBoundStable ps+#endif+  getBoundStable (TuplePat _ p _) = getBoundStable p+  getBoundStable (SumPat _ p _ _) = getBoundStable p+  getBoundStable (ViewPat _ _ p) = getBoundStable p+  getBoundStable (SigPat _ p _) = getBoundStable p+  getBoundStable (XPat p) = getBoundStable p+  getBoundStable (SplicePat {}) = Set.empty+  getBoundStable (VarPat {}) = Set.empty+  getBoundStable (WildPat {}) = Set.empty+  getBoundStable (LitPat {}) = Set.empty+  getBoundStable (NPat {}) = Set.empty+  getBoundStable (NPlusKPat {}) = Set.empty+#if __GLASGOW_HASKELL__ >= 910+  getBoundStable (EmbTyPat _ _) = Set.empty+  getBoundStable (InvisPat _ _) = Set.empty+#endif++instance BoundStable (HsBindLR GhcTc GhcTc) where+  getBoundStable (PatBind {pat_lhs = lhs}) = getBoundStable lhs+  getBoundStable _ = Set.empty++instance BoundStable (HsLocalBindsLR GhcTc GhcTc) where+  getBoundStable (HsValBinds _ bs) = getBoundStable bs+  getBoundStable HsIPBinds {} = Set.empty+  getBoundStable EmptyLocalBinds {} = Set.empty++instance BoundStable (HsValBindsLR GhcTc GhcTc) where+  getBoundStable (ValBinds _ bs _) = getBoundStable bs+  getBoundStable (XValBindsLR (NValBinds binds _)) = getBoundStable binds++instance BoundStable a => BoundStable (StmtLR GhcTc GhcTc a) where+  getBoundStable (BindStmt _ p _) = getBoundStable p+  getBoundStable (LetStmt _ bs) = getBoundStable bs+  getBoundStable LastStmt {} = Set.empty+  getBoundStable BodyStmt {} = Set.empty+  getBoundStable ParStmt {} = Set.empty+  getBoundStable TransStmt {} = Set.empty+#if __GLASGOW_HASKELL__ >= 912+  getBoundStable (XStmtLR ApplicativeStmt {}) = Set.empty+#else+  getBoundStable ApplicativeStmt {} = Set.empty+#endif+  getBoundStable RecStmt {} = Set.empty+ instance Scope a => Scope (GenLocated SrcSpan a) where   check (L l x) =  (\c -> c {srcLoc = l}) `modifyCtxt` check x -instance Scope a => Scope (GenLocated (SrcSpanAnn' b) a) where+instance Scope a => Scope (GenLocated (LocAnn b) a) where   check (L l x) =  updateLoc l $ check x    instance Scope a => Scope (Bag a) where@@ -203,12 +332,19 @@ instance Scope a => Scope [a] where   check ls = fmap and (mapM check ls) +-- GHC 9.14 turned a number of syntax lists (e.g. the guarded RHSs of+-- a binding) into non-empty lists.+instance Scope a => Scope (NonEmpty a) where+  check ls = fmap and (mapM check ls) + instance Scope (Match GhcTc (GenLocated SrcAnno (HsExpr GhcTc))) where-  check Match{m_pats=ps,m_grhss=rhs} = addVars (getBV ps) `modifyCtxt` check rhs+  check Match{m_pats=ps,m_grhss=rhs} =+    (addVars (getBV ps) . addStable (getBoundStable ps)) `modifyCtxt` check rhs  instance Scope (Match GhcTc (GenLocated SrcAnno (HsCmd GhcTc))) where-  check Match{m_pats=ps,m_grhss=rhs} = addVars (getBV ps) `modifyCtxt` check rhs+  check Match{m_pats=ps,m_grhss=rhs} =+    (addVars (getBV ps) . addStable (getBoundStable ps)) `modifyCtxt` check rhs   instance Scope (MatchGroup GhcTc (GenLocated SrcAnno (HsExpr GhcTc))) where@@ -223,33 +359,37 @@   checkBind (LastStmt _ b _ _) =  ( , Set.empty) <$> check b   checkBind (BindStmt _ p b) = do     let vs = getBV p-    let c' = addVars vs ?ctxt+    let c' = (addVars vs . addStable (getBoundStable p)) ?ctxt     r <- setCtxt c' (check b)     return (r,vs)   checkBind (BodyStmt _ b _ _) = ( , Set.empty) <$> check b   checkBind (LetStmt _ bs) = checkBind bs   checkBind ParStmt{} = notSupported "monad comprehensions"   checkBind TransStmt{} = notSupported "monad comprehensions"+#if __GLASGOW_HASKELL__ >= 912+  checkBind (XStmtLR ApplicativeStmt{}) = notSupported "applicative do notation"+#else   checkBind ApplicativeStmt{} = notSupported "applicative do notation"+#endif   checkBind RecStmt{} = notSupported "recursive do notation" -instance ScopeBind a => ScopeBind [a] where+instance (BoundStable a, ScopeBind a) => ScopeBind [a] where   checkBind [] = return (True,Set.empty)   checkBind (x:xs) = do     (r,vs) <- checkBind x-    (r',vs') <- addVars vs `modifyCtxt` (checkBind xs)+    (r',vs') <- (addVars vs . addStable (getBoundStable x)) `modifyCtxt` (checkBind xs)     return (r && r',vs `Set.union` vs')  instance ScopeBind a => ScopeBind (GenLocated SrcSpan a) where   checkBind (L l x) =  (\c -> c {srcLoc = l}) `modifyCtxt` checkBind x -instance ScopeBind a => ScopeBind (GenLocated (SrcSpanAnn' b) a) where+instance ScopeBind a => ScopeBind (GenLocated (LocAnn b) a) where   checkBind (L l x) =  updateLoc l $ checkBind x  instance Scope a => Scope (GRHS GhcTc a) where   check (GRHS _ gs b) = do     (r, vs) <- checkBind gs-    r' <- addVars vs `modifyCtxt`  (check b)+    r' <- (addVars vs . addStable (getBoundStable gs)) `modifyCtxt`  (check b)     return (r && r')  checkRec :: GetCtxt => LHsBindLR GhcTc GhcTc -> CheckM Bool@@ -267,7 +407,7 @@ #else checkPatBind' (XHsBindsLR AbsBinds {abs_binds = binds}) =  #endif-  liftM and (mapM checkPatBind (bagToList binds))+  liftM and (mapM checkPatBind (bindsToList binds))  checkPatBind' _ = return True @@ -321,10 +461,10 @@   -- Check nested bindings-instance ScopeBind (RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))) where-  checkBind (NonRecursive, bs)  = checkBind $ bagToList bs+instance ScopeBind (RecFlag, Binds (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))) where+  checkBind (NonRecursive, bs)  = checkBind $ bindsToList bs   checkBind (Recursive, bs) = checkRecursiveBinds bs' (foldMap getAllBV bs')-    where bs' = bagToList bs+    where bs' = bindsToList bs   instance ScopeBind (HsLocalBindsLR GhcTc GhcTc) where@@ -337,13 +477,13 @@ instance Scope (GRHSs GhcTc (GenLocated SrcAnno (HsExpr GhcTc))) where   check GRHSs{grhssGRHSs = rhs, grhssLocalBinds = lbinds} = do     (l,vs) <- checkBind lbinds-    r <- addVars vs `modifyCtxt` (check rhs)+    r <- (addVars vs . addStable (getBoundStable lbinds)) `modifyCtxt` (check rhs)     return (r && l)  instance Scope (GRHSs GhcTc (GenLocated SrcAnno (HsCmd GhcTc))) where   check GRHSs{grhssGRHSs = rhs, grhssLocalBinds = lbinds} = do     (l,vs) <- checkBind lbinds-    r <- addVars vs `modifyCtxt` (check rhs)+    r <- (addVars vs . addStable (getBoundStable lbinds)) `modifyCtxt` (check rhs)     return (r && l)  instance Show Var where@@ -437,8 +577,28 @@                             <> " There is a delay, but its scope is interrupted by " <> tickHidden hr <> ".")       Select -> printMessageCheck SevError ("select must be fully applied")     _ -> liftM2 (&&) (check e1)  (check e2)+#if __GLASGOW_HASKELL__ >= 914+  check HsHole{} = return True+#else   check HsUnboundVar{}  = return True-#if __GLASGOW_HASKELL__ >= 904+#endif+#if __GLASGOW_HASKELL__ >= 912+  check (HsPar _ e) = check e+  check HsTypedBracket{} = notSupported "MetaHaskell"+  check HsUntypedBracket{} = notSupported "MetaHaskell"+  check HsEmbTy{} = return True+  -- type syntax that may occur in term position+  check (HsForAll _ _ e) = check e+  check (HsQual _ ctxt e) = (&&) <$> check ctxt <*> check e+  check (HsFunArr _ arr e1 e2) =+    and <$> sequence [check arr, check e1, check e2]+#elif __GLASGOW_HASKELL__ >= 910+  check (HsPar _ e) = check e+  check HsRecSel{} = return True+  check HsTypedBracket{} = notSupported "MetaHaskell"+  check HsUntypedBracket{} = notSupported "MetaHaskell"+  check HsEmbTy{} = return True+#elif __GLASGOW_HASKELL__ >= 904   check (HsPar _ _ e _) = check e   check (HsLamCase _ _ mg) = check mg   check HsRecSel{} = return True@@ -455,13 +615,15 @@   check HsRnBracketOut{} = notSupported "MetaHaskell"   check HsTcBracketOut{} = notSupported "MetaHaskell" #endif-#if __GLASGOW_HASKELL__ >= 904+#if __GLASGOW_HASKELL__ >= 910+  check (HsLet _ bs e) = do+#elif __GLASGOW_HASKELL__ >= 904   check (HsLet _ _ bs _ e) = do #else   check (HsLet _ bs e) = do #endif     (l,vs) <- checkBind bs-    r <- addVars vs `modifyCtxt` (check e)+    r <- (addVars vs . addStable (getBoundStable bs)) `modifyCtxt` (check e)     return (r && l)             check HsOverLabel{} = return True@@ -469,7 +631,11 @@   check HsOverLit{} = return True     check HsLit{} = return True   check (OpApp _ e1 e2 e3) = and <$> mapM check [e1,e2,e3]+#if __GLASGOW_HASKELL__ >= 910+  check (HsLam _ _ mg) = check mg+#else   check (HsLam _ mg) = check mg+#endif   check (HsCase _ e1 e2) = (&&) <$> check e1 <*> check e2   check (SectionL _ e1 e2) = (&&) <$> check e1 <*> check e2   check (SectionR _ e1 e2) = (&&) <$> check e1 <*> check e2@@ -493,7 +659,10 @@   check (HsStatic _ e) = check e   check (HsDo _ _ e) = fst <$> checkBind e   check (XExpr e) = check e-#if __GLASGOW_HASKELL__ >= 906+#if __GLASGOW_HASKELL__ >= 910+  check (HsAppType _ e _) = check e+  check (ExprWithTySig _ e _) = check e+#elif __GLASGOW_HASKELL__ >= 906   check (HsAppType _ e _ _) = check e   check (ExprWithTySig _ e _) = check e #else@@ -517,8 +686,17 @@   instance Scope XXExprGhcTc where+#if __GLASGOW_HASKELL__ >= 912+  check (WrapExpr _ e) = check e+  check HsRecSelTc{} = return True+#else   check (WrapExpr (HsWrap _ e)) = check e+#endif+#if __GLASGOW_HASKELL__ >= 910+  check (ExpandedThingTc _ e) = check e+#else   check (ExpansionExpr (HsExpanded _ e)) = check e+#endif #if __GLASGOW_HASKELL__ >= 904   check ConLikeTc{} = return True   check (HsTick _ e) = check e@@ -531,20 +709,29 @@ instance Scope (HsCmd GhcTc) where   check (HsCmdArrApp _ e1 e2 _ _) = (&&) <$> check e1 <*> check e2   check (HsCmdDo _ e) = fst <$> checkBind e+#if __GLASGOW_HASKELL__ >= 912+  check (HsCmdArrForm _ e1 _ e2) = (&&) <$> check e1 <*> check e2+#else   check (HsCmdArrForm _ e1 _ _ e2) = (&&) <$> check e1 <*> check e2+#endif   check (HsCmdApp _ e1 e2) = (&&) <$> check e1 <*> check e2+#if __GLASGOW_HASKELL__ >= 910+  check (HsCmdLam _ _ e) = check e+  check (HsCmdPar _ e) = check e+  check (HsCmdLet _ bs e) = do+#elif __GLASGOW_HASKELL__ >= 904   check (HsCmdLam _ e) = check e-#if __GLASGOW_HASKELL__ >= 904   check (HsCmdPar _ _ e _) = check e   check (HsCmdLamCase _ _ e) = check e     check (HsCmdLet _ _ bs _ e) = do #else+  check (HsCmdLam _ e) = check e   check (HsCmdPar _ e) = check e   check (HsCmdLamCase _ e) = check e   check (HsCmdLet _ bs e) = do #endif     (l,vs) <- checkBind bs-    r <- addVars vs `modifyCtxt` (check e)+    r <- (addVars vs . addStable (getBoundStable bs)) `modifyCtxt` (check e)     return (r && l)    check (HsCmdCase _ e1 e2) = (&&) <$> check e1 <*> check e2@@ -575,6 +762,16 @@   check (Present _ e) = check e   check Missing{} = return True +#if __GLASGOW_HASKELL__ >= 914+instance Scope (HsMultAnnOf (GenLocated SrcSpanAnnA (HsExpr GhcTc)) GhcTc) where+  check (HsExplicitMult _ e) = check e+  check _ = return True+#elif __GLASGOW_HASKELL__ >= 912+instance Scope (HsArrowOf (GenLocated SrcSpanAnnA (HsExpr GhcTc)) GhcTc) where+  check (HsExplicitMult _ e) = check e+  check _ = return True+#endif+ instance Scope (HsBindLR GhcTc GhcTc) where #if __GLASGOW_HASKELL__ >= 904   check (XHsBindsLR AbsBinds {abs_binds = binds, abs_ev_vars  = ev})@@ -590,7 +787,8 @@     where mod c = c { stableTypes= stableTypes c `Set.union`                       Set.fromList (stableConstrFromWrapper' wrapper)  `Set.union`                       Set.fromList (extractStableConstr (varType v))}-  check PatBind{pat_lhs = lhs, pat_rhs=rhs} = addVars (getBV lhs) `modifyCtxt` check rhs+  check PatBind{pat_lhs = lhs, pat_rhs=rhs} =+    (addVars (getBV lhs) . addStable (getBoundStable lhs)) `modifyCtxt` check rhs   check VarBind{var_rhs = rhs} = check rhs   check PatSynBind {} = return True -- pattern synonyms are not supported @@ -760,23 +958,37 @@ isPrimExpr (L _ e) = isPrimExpr' e where   isPrimExpr' :: GetCtxt => HsExpr GhcTc -> Maybe (Prim,Var)   isPrimExpr' (HsVar _ (L _ v)) = fmap (,v) (isPrim v)-#if __GLASGOW_HASKELL__ >= 906+#if __GLASGOW_HASKELL__ >= 910+  isPrimExpr' (HsAppType _ e _) = isPrimExpr e+#elif __GLASGOW_HASKELL__ >= 906   isPrimExpr' (HsAppType _ e _ _) = isPrimExpr e #else   isPrimExpr' (HsAppType _ e _) = isPrimExpr e #endif +#if __GLASGOW_HASKELL__ >= 912+  isPrimExpr' (XExpr (WrapExpr _ e)) = isPrimExpr' e+#else   isPrimExpr' (XExpr (WrapExpr (HsWrap _ e))) = isPrimExpr' e+#endif+#if __GLASGOW_HASKELL__ >= 910+  isPrimExpr' (XExpr (ExpandedThingTc _ e)) = isPrimExpr' e+#else   isPrimExpr' (XExpr (ExpansionExpr (HsExpanded _ e))) = isPrimExpr' e+#endif   isPrimExpr' (HsPragE _ _ e) = isPrimExpr e #if __GLASGOW_HASKELL__ < 904   isPrimExpr' (HsTick _ _ e) = isPrimExpr e   isPrimExpr' (HsBinTick _ _ _ e) = isPrimExpr e   isPrimExpr' (HsPar _ e) = isPrimExpr e-#else+#elif __GLASGOW_HASKELL__ < 910   isPrimExpr' (XExpr (HsTick _ e)) = isPrimExpr e   isPrimExpr' (XExpr (HsBinTick _ _ e)) = isPrimExpr e   isPrimExpr' (HsPar _ _ e _) = isPrimExpr e+#else+  isPrimExpr' (XExpr (HsTick _ e)) = isPrimExpr e+  isPrimExpr' (XExpr (HsBinTick _ _ e)) = isPrimExpr e+  isPrimExpr' (HsPar _ e) = isPrimExpr e #endif    isPrimExpr' _ = Nothing@@ -798,6 +1010,11 @@ -- | Add variables to the current context. addVars :: Set Var -> Ctxt -> Ctxt addVars vs c = c{current = vs `Set.union` current c }++-- | Add the given type variables to the set of type variables that+-- are known to be stable.+addStable :: Set Var -> Ctxt -> Ctxt+addStable vs c = c{stableTypes = vs `Set.union` stableTypes c }  -- | Print a message with the current location. printMessage' :: GetCtxt => Severity -> SDoc ->  CheckM ()
src/WidgetRattus/Plugin/SingleTick.hs view
@@ -17,7 +17,10 @@ import Prelude hiding ((<>)) import Control.Monad.Trans.Writer.Strict import Control.Monad.Trans.Class-import Data.List+-- since base 4.20 (GHC 9.10) foldl' is exported by Prelude+#if __GLASGOW_HASKELL__ < 910+import Data.List (foldl')+#endif  -- | Transform the given expression from the multi-tick calculus into -- the single tick calculus form.
src/WidgetRattus/Plugin/Strictify.hs view
@@ -30,7 +30,11 @@   | ignoreArgument e1 = return ()   | otherwise = do      when (not (isType e2) && tcIsLiftedTypeKind(typeKind (exprType e2))-        && not (isStrict (exprType e2)) && not (isDeepseqForce e2) && not (isLit e2))+        && not (isStrict (exprType e2)) && not (isDeepseqForce e2) && not (isLit e2)+        -- since GHC 9.14 the HasCallStack dictionary is built by+        -- applying the IP constructor to a 'pushCallStack' call, so the+        -- call stack plumbing turns up in argument position as well+        && not (isPushCallStack e2))           (printMessage SevWarning (srcSpan ss)                (text "The use of lazy type " <> ppr (exprType e2) <> " may lead to memory leaks. Use Control.DeepSeq.force on lazy types."))     checkStrictData ss e1@@ -44,14 +48,34 @@ isLit _ = False  +isPushCallStack :: CoreExpr -> Bool+isPushCallStack (Var v) =+  case getNameModule v of+    Just (name, mod) -> mod == "GHC.Stack.Types" && name == "pushCallStack"+    _ -> False+isPushCallStack (App x _) = isPushCallStack x+isPushCallStack _ = False++-- | Check whether the given expression is in head position of an+-- application whose arguments should not be checked for+-- strictness. This covers the desugaring of @OverloadedLists@+-- ('fromList', 'fromListN') and @OverloadedStrings@ ('fromString'),+-- the construction of 'Data.Text.Text' literals, and the call stack+-- plumbing for 'GHC.Stack.HasCallStack'. In each of these cases the+-- lazy argument is immediately consumed by a function that we know+-- does not retain it, so it cannot cause a space leak.+--+-- Note that the module names below are the ones after normalisation+-- by 'baseModuleName', which maps the @GHC.Internal.*@ modules that+-- GHC 9.10 and later use back to their pre-9.10 names. ignoreArgument :: CoreExpr -> Bool ignoreArgument (Var v) =   case getNameModule v of-    Just (name, mod) -> +    Just (name, mod) ->       ((mod == "GHC.Exts" || mod == "GHC.IsList") && (name == "fromList" || name == "fromListN")) ||-      (mod == "Data.String" && name == "fromString") ||+      ((mod == "Data.String" || mod == "GHC.Data.String") && name == "fromString") ||       (mod == "GHC.Stack.Types" && name == "pushCallStack") ||-      (mod == "Data.Text.Internal" && name == "pack")+      ((mod == "Data.Text" || mod == "Data.Text.Internal") && name == "pack")     _ -> False ignoreArgument (App x _) = ignoreArgument x ignoreArgument _ = False
src/WidgetRattus/Plugin/Transform.hs view
@@ -51,7 +51,7 @@     bigDelayVar <- bigDelay     inputValueV <- inputValueVar     let inputValueType = mkTyConTy inputValueV -    inpVar <- mkSysLocalM (fsLit "inpV") inputValueType inputValueType+    inpVar <- mkSysLocalM (fsLit "inpV") manyDataConTy inputValueType     let ctx' = ctx {fresh = Just inpVar}     (newExpr, maybePrimInfo) <- transform' ctx' e'     let primInfo = fromJust maybePrimInfo
src/WidgetRattus/Plugin/Utils.hs view
@@ -62,6 +62,9 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Char+#if __GLASGOW_HASKELL__ >= 910+import Data.List (stripPrefix)+#endif import Data.Maybe  @@ -185,9 +188,33 @@ getNameModule v = do   let name = getName v   mod <- nameModule_maybe name-  return (getOccFS name,moduleNameFS (moduleName mod))+  return (getOccFS name, baseModuleName (moduleNameFS (moduleName mod)))  +-- | Since GHC 9.10 most modules of the @base@ library have been moved+-- into the @ghc-internal@ package, where they are called+-- @GHC.Internal.X@ instead of @GHC.X@ (e.g. @IORef@ is now defined in+-- @GHC.Internal.IORef@). This function maps such module names back to+-- their pre-9.10 names so that the rest of the plugin can recognise+-- them independently of the GHC version.+baseModuleName :: FastString -> FastString+#if __GLASGOW_HASKELL__ >= 910+baseModuleName mod = case stripPrefix "GHC.Internal." (unpackFS mod) of+  Just rest -> mkFastString ("GHC." ++ rest)+  Nothing -> mod+#else+baseModuleName = id+#endif+++-- | Check whether the given module is the one that defines 'Integer'.+-- Up to GHC 9.12 that is @GHC.Num.Integer@ from the @ghc-bignum@+-- package. Since GHC 9.14 it lives in @ghc-internal@, which+-- 'baseModuleName' maps to @GHC.Bignum.Integer@.+isIntegerModule :: FastString -> Bool+isIntegerModule mod = mod == "GHC.Num.Integer" || mod == "GHC.Bignum.Integer"++ -- | The set of stable built-in types. ghcStableTypes :: Set FastString ghcStableTypes = Set.fromList ["Word", "Word8", "Word16","Word32", "Word64","Int","Int8","Int16","Int32","Int64","Bool","Float","Double","Char", "IO"]@@ -257,7 +284,7 @@       case getNameModule con of         Nothing -> False         Just (name,mod)-          | mod == "GHC.Num.Integer" && name == "Integer" -> True+          | isIntegerModule mod && name == "Integer" -> True           | mod == "Data.Text.Internal" && name == "Text" -> True           -- If it's a Rattus type constructor check if it's a box           | isRattModule mod && (name == "Box" || name == "Chan") -> True@@ -274,13 +301,25 @@                   and  (map check cons)                 | otherwise -> False                 where check con = case dataConInstSig con args of-                        (_, _,tys) -> and (map (isStableRec c (d+1) pr') tys)+                        (_, constraints,tys) -> +                          let c' = Set.union c (getStableConstraints constraints)+                          in and (map (isStableRec c' (d+1) pr') tys)               TupleTyCon {} -> null args               NewTyCon {nt_rhs = ty} -> isStableRec c (d+1) pr' ty               _ -> False         _ -> False -+-- Takes a list of constraints @cs@, and returns a set of all type+-- variables @v@ for which the constraint @Stable v@ occurs in @cs@.+getStableConstraints :: [Type] -> Set Var+getStableConstraints ts = Set.fromList (mapMaybe conv ts)+  where conv :: Type -> Maybe Var+        conv t = case splitTyConApp_maybe t of+                  Just (c, [arg]) -> +                    case getNameModule c of+                      Just (name,mod) | name == "Stable" && isRattModule mod -> getTyVar_maybe arg+                      _ -> Nothing+                  _ -> Nothing  isStrict :: Type -> Bool isStrict t = isStrictRec 0 Set.empty t@@ -308,8 +347,12 @@       case getNameModule con of         Nothing -> False         Just (name,mod)-          | (mod == "GHC.Internal.IsList" || mod == "GHC.IsList" || mod == "GHC.Exts") && name == "Item" -> all (isStrictRec (d+1) pr') args-          | mod == "GHC.Num.Integer" && name == "Integer" -> True+          -- 'Item' is the type family of the 'IsList' class. If it+          -- has not been reduced (because the list type is still a+          -- type variable), we approximate it by its argument.+          | (mod == "GHC.IsList" || mod == "GHC.Exts") && name == "Item" ->+            all (isStrictRec (d+1) pr') args+          | isIntegerModule mod && name == "Integer" -> True           | mod == "Data.Text.Internal" && name == "Text" -> True           | mod == "GHC.IORef" && name == "IORef" -> True           | mod == "GHC.MVar" && name == "MVar" -> True@@ -360,7 +403,7 @@     _ -> False  mkSysLocalFromVar :: MonadUnique m => FastString -> Var -> m Id-mkSysLocalFromVar lit v = mkSysLocalM lit (varMult v) (varType v)+mkSysLocalFromVar lit v = mkSysLocalM lit (idMult v) (varType v)   mkSysLocalFromExpr :: MonadUnique m => FastString -> CoreExpr -> m Id mkSysLocalFromExpr lit e = mkSysLocalM lit oneDataConTy (exprType e)
+ src/WidgetRattus/PushPull/Widgets.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE GADTs #-}+{-# OPTIONS -fplugin=WidgetRattus.Plugin #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+module WidgetRattus.PushPull.Widgets where++import WidgetRattus.Behaviour+import WidgetRattus.Event+import WidgetRattus+import qualified WidgetRattus.Widgets.InternalTypes as WR+import qualified WidgetRattus.Widgets as WR+import WidgetRattus.Widgets (Displayable)+import Data.Text hiding (zipWith)+import WidgetRattus.Signal (Sig ((:::)), map)+import Prelude hiding (max,const,zipWith)+import qualified Prelude ++++class (Continuous a, WR.IsWidget (DiscrWidget a)) => IsWidget a where+  type DiscrWidget a+  mkDiscrWidget :: a -> C (DiscrWidget a)+++  mkWidget :: a -> Widget+  mkWidget w = Widget w (const True)++  setEnabled :: a -> Beh Bool -> Widget+  setEnabled = Widget+++data Widget where+  Widget :: IsWidget a => !a -> !(Beh Bool) -> Widget+++continuous ''Widget+instance IsWidget Widget where+  type DiscrWidget Widget = WR.Widget+  mkDiscrWidget (Widget w beh) = do+    beh' <- discretize beh+    w' <- mkDiscrWidget w+    return (WR.Widget w' beh')+  +  mkWidget w = w+  setEnabled (Widget w _) e = Widget w e++class Widgets ws where+      toWidgetList :: ws -> C (List WR.Widget)++instance {-# OVERLAPPABLE #-} IsWidget w => Widgets w where+      toWidgetList w = do+        w' <- mkDiscrWidget w+        return [ WR.mkWidget w' ]++instance {-# OVERLAPPING #-} (Widgets w, Widgets v) => Widgets (w :* v) where+      toWidgetList (w :* v) = do+        left <- toWidgetList w+        right <- toWidgetList v+        return $ left +++ right+++instance {-# OVERLAPPING #-} (Widgets w) => Widgets (List w) where+      toWidgetList w = do+        toWidgetList w++-- instance {-# OVERLAPPABLE #-} (WR.IsWidget a, Continuous a) => IsWidget a where+--   type DiscrWidget a = a+--   mkDiscrWidget a = return a++-- HStack +data HStack where+      HStack :: WR.IsWidget a => !(Beh (List a)) -> HStack+++continuous ''HStack++instance IsWidget HStack where+  type DiscrWidget HStack = WR.HStack+  mkDiscrWidget (HStack ws) = do+    ws' <- discretize ws+    return (WR.HStack ws')++mkHStack :: WR.IsWidget a => Beh(List a) -> C HStack+mkHStack wl = do+      return (HStack wl)++mkConstHStack :: Widgets ws => ws -> C HStack+mkConstHStack w = do+  ws <- toWidgetList w+  mkHStack $ const ws++-- VStack+data VStack where+  VStack :: WR.IsWidget a => !(Beh (List a)) -> VStack++continuous ''VStack+instance IsWidget VStack where+  type DiscrWidget VStack = WR.VStack+  mkDiscrWidget (VStack ws) = do+    ws' <- discretize ws+    return (WR.VStack ws')++mkVStack :: WR.IsWidget a => Beh(List a) -> C VStack+mkVStack wl = do+      return (VStack wl)++mkConstVStack :: Widgets ws => ws -> C VStack+mkConstVStack w = do+  ws <- toWidgetList w+  mkVStack $ const ws+++-- TextDropDown+data TextDropdown =+  TextDropdown {tddCurr :: !(Beh Text), tddEvent :: !(Chan Text), tddList :: !(Beh (List Text))}++continuous ''TextDropdown+instance IsWidget TextDropdown where+  type DiscrWidget TextDropdown = WR.TextDropdown+  mkDiscrWidget (TextDropdown cur ev list) = do+    cur' <- discretize cur+    list' <- discretize list+    return (WR.TextDropdown cur' ev list')++mkTextDropdown :: Beh (List Text) -> Text -> C TextDropdown+mkTextDropdown opts initial = do+  c <- chan+  let beh = discr initial $ mkEv (box (wait c))+  return $ TextDropdown beh c opts+++-- Popup+data Popup =+  Popup {popCurr :: !(Beh Bool), popEvent :: !(Chan Bool), popChild :: !(Beh WR.Widget)}++continuous ''Popup+instance IsWidget Popup where+      type DiscrWidget Popup = WR.Popup+      mkDiscrWidget (Popup curr ch child) = do+        curr' <- discretize curr+        child' <- discretize child+        return (WR.Popup curr' ch child')++mkPopup :: Ev Bool -> Beh WR.Widget -> C Popup+mkPopup initialVisibility w = do+      c <- chan+      let changeEvent = mkEv (box (wait c))+      let visibility = discr False $ interleave (box Prelude.const) initialVisibility changeEvent+      return Popup{popCurr = visibility, popEvent = c, popChild = w}+++-- Slider+data Slider =+  Slider {sldCurr :: !(Beh Int), sldEvent :: !(Chan Int), sldMin :: !(Beh Int), sldMax :: !(Beh Int)}++continuous ''Slider+instance IsWidget Slider where+  type DiscrWidget Slider = WR.Slider+  mkDiscrWidget (Slider curr ev min max) = do+    curr' <- discretize curr+    min' <- discretize min+    max' <- discretize max+    return (WR.Slider curr' ev min' max')++mkSlider :: Int -> Beh Int -> Beh Int -> C Slider+mkSlider start min max = do+  c <- chan+  let curr = discr start $ mkEv (box (wait c))+  return $ Slider curr c min max+++-- Button+data Button where+  Button :: (Displayable a) => {btnClick :: !(Chan ()), btnContent :: !(Beh a)} -> Button++continuous ''Button+instance IsWidget Button where+  type DiscrWidget Button = WR.Button+  mkDiscrWidget (Button click b) = do+    w <- discretize b+    return (WR.Button w click)++mkButton :: (Displayable a) => Beh a -> C Button+mkButton t = do+   c <- chan+   return $ Button c t+++-- Label+data Label where+      Label :: (Displayable a) => {labText :: !(Beh a)} -> Label++continuous ''Label+instance IsWidget Label where+  type DiscrWidget Label = WR.Label+  mkDiscrWidget (Label t) = do+    t' <- discretize t+    return (WR.Label t')++mkLabel :: (Displayable a) => Beh a -> C Label+mkLabel t = do+  return $ Label t+++-- TextField+data TextField = TextField {tfContent :: !(Beh Text), tfInput :: !(Chan Text)}++continuous ''TextField+instance IsWidget TextField where+  type DiscrWidget TextField = WR.TextField+  mkDiscrWidget (TextField b inp) = do+    txt <- discretize b+    return (WR.TextField txt inp)++mkTextField :: Text -> C TextField+mkTextField txt = do+  c <- chan+  let (Dense d) = mkEv (box (wait c))+  let beh = Beh $ WidgetRattus.Signal.map (box K) (txt ::: d)+  return $ TextField beh c++-- ProgressBar+mkProgressBar :: Beh Int -> Beh Int -> Beh Int -> C Slider+mkProgressBar min max curr = do+      c <- chan+      let boundedCurrent = zipWith (box Prelude.min) curr max+      return Slider{sldCurr = boundedCurrent, sldEvent = c, sldMin = min, sldMax = max}++btnOnClick :: Button -> Box(O())+btnOnClick b =+      let ch = btnClick b+      in box (wait ch)++btnOnClickEv :: Button -> Ev ()+btnOnClickEv b = mkEv (btnOnClick b)+++tfInputEv :: TextField -> Ev Text+tfInputEv tf =+  let ch = tfInput tf+  in mkEv (box (wait ch))++setInputBehTF :: TextField -> Beh Text -> TextField+setInputBehTF tf b =+  tf{tfContent = b}++sliderEv :: Slider -> Ev Int+sliderEv s =+  let ch = sldEvent s+  in mkEv (box (wait ch))++mkConstText :: String -> Beh Text+mkConstText s = const (pack s)++runApplication :: IsWidget a => C a -> IO()+runApplication w =+  WR.runApplication ( do+        w' <- w+        mkDiscrWidget w'+    )
src/WidgetRattus/Signal.hs view
@@ -16,10 +16,10 @@   , switch   , switchS   , switchR-  , trigger-  , triggerAwait-  , triggerM-  , triggerAwaitM+  , sample+  , sampleAwait+  , sampleM+  , sampleAwaitM   , buffer   , bufferAwait   , switchAwait@@ -28,6 +28,7 @@   , interleaveAll   , mkSig   , mkSig'+  , chanSig   , current   , future   , const@@ -43,6 +44,10 @@   , zipWith   , zipWith3   , zip+  , parallelWith+  , parallelWithAwait+  , parallel+  , parallelAwait   , cond   , update   , integral@@ -82,6 +87,9 @@ mapAwait :: Box (a -> b) -> O (Sig a) -> O (Sig b) mapAwait f d = delay (map f (adv d)) +chanSig :: Chan a -> O (Sig a)+chanSig c = delay (adv (wait c) ::: chanSig c)+ -- | Turns a boxed delayed computation into a delayed signal. mkSig :: Box (O a) -> O (Sig a) mkSig b = delay (adv (unbox b) ::: mkSig b)@@ -166,9 +174,9 @@ -- Example: -- -- >           xs: 1 2 3 4 5   6 7 8   9--- >           ys:         1 2   3 4 5 6+-- >           ys:       1 2   3 4 5 6 -- >--- > switch xs ys: 1 2 3 1 2 4   3 4 5 6+-- > switch xs ys: 1 2 3 1 2   3 4 5 6 switch :: Sig a -> O (Sig a) -> Sig a switch (x ::: xs) d = x ::: delay (case select xs d of                                      Fst   xs'  d'  -> switch xs' d'@@ -294,8 +302,69 @@ zip :: (Stable a, Stable b) => Sig a -> Sig b -> Sig (a:*b) zip = zipWith (box (:*)) --- | This function is a variant of 'trigger' that works on a delayed--- input signal. To this end, 'triggerAwait' takes an additional++-- | This is a variant of 'zipWith', but the values passed to the+-- function may not exist if the corresponding source signal has not+-- ticked.+--+-- Example:+--+-- >                            xs:  1            2          3+-- >                            ys:  1                       0            5+-- >+-- > parallelWith (box (:*)) xs ys:  (J 1 :* J 1) (J 2 :* N) (J 3 :* J 0) (N :* J 5)++parallelWith :: Box (Maybe' a -> Maybe' b -> c) -> Sig a -> Sig b -> Sig c+parallelWith f (x ::: xs) (y ::: ys) =+   unbox f (Just' x) (Just' y) ::: parallelWithAwait f xs ys++-- | This is a variant of `parallelWith` for delayed signals.+--+-- Example:+--+-- >                                 xs:    2          3+-- >                                 ys:               0            5+-- >+-- > parallelWithAwait (box (:*)) xs ys:    (J 2 :* N) (J 3 :* J 0) (N :* J 5)+parallelWithAwait :: Box (Maybe' a -> Maybe' b -> c) -> O (Sig a) -> O (Sig b) -> O (Sig c)+parallelWithAwait f xs ys = delay (+  case select xs ys of+     Fst (x ::: xs')   ys'        -> unbox f (Just' x)  (Nothing') ::: parallelWithAwait f xs' ys'+     Snd xs'          (y ::: ys') -> unbox f (Nothing') (Just' y)  ::: parallelWithAwait f xs' ys'+     Both (x ::: xs') (y ::: ys') -> unbox f (Just' x)  (Just' y)  ::: parallelWithAwait f xs' ys')++-- | This is a variant of 'zip', but the signal of pairs only contain+-- values if the corresponding source signal ticked.+--+-- Example:+--+-- >             xs:  1            2          3+-- >             ys:  1                       0            5+-- >+-- > parallel xs ys:  (J 1 :* J 1) (J 2 :* N) (J 3 :* J 0) (N :* J 5)++parallel :: Sig a -> Sig b -> Sig (Maybe' a :* Maybe' b)+parallel (x ::: xs) (y ::: ys) =+   (Just' x :* Just' y) ::: parallelAwait xs ys++-- | This is a variant of `parallel` for delayed signals.+--+-- Example:+--+-- >                  xs:    2          3+-- >                  ys:               0            5+-- >+-- > parallelAwait xs ys:    (J 2 :* N) (J 3 :* J 0) (N :* J 5)++parallelAwait :: O (Sig a) -> O (Sig b) -> O (Sig (Maybe' a :* Maybe' b))+parallelAwait xs ys = delay (+  case select xs ys of+     Fst (x ::: xs')   ys'        -> (Just' x  :* Nothing') ::: parallelAwait xs' ys'+     Snd xs'          (y ::: ys') -> (Nothing' :* Just' y)  ::: parallelAwait xs' ys'+     Both (x ::: xs') (y ::: ys') -> (Just' x  :* Just' y)  ::: parallelAwait xs' ys')++-- | This function is a variant of 'sample' that works on a delayed+-- input signal. To this end, 'sampleAwait' takes an additional -- argument that is the initial value of output signal. -- -- Example:@@ -303,17 +372,17 @@ -- >                             xs:    1     0 5 2 -- >                             ys:  5 1 2 3     2 -- >--- > triggerAwait (box (+)) 0 xy ys:  0 2 2 2 3 8 4+-- > sampleAwait (box (+)) 0 xy ys:  0 2 2 2 3 8 4 -triggerAwait :: (Stable b, Stable c) => Box (a -> b -> c) -> c -> O (Sig a) -> Sig b -> Sig c-triggerAwait f c as (b ::: bs) = c :::+sampleAwait :: (Stable b, Stable c) => Box (a -> b -> c) -> c -> O (Sig a) -> Sig b -> Sig c+sampleAwait f c as (b ::: bs) = c :::     delay (case select as bs of-            Fst (a' ::: as') bs' -> triggerAwait f (unbox f a' b) as' (b ::: bs')-            Snd as' bs' -> triggerAwait f c as' bs'-            Both (a' ::: as') (b' ::: bs') -> triggerAwait f (unbox f a' b') as' (b' ::: bs'))+            Fst (a' ::: as') bs' -> sampleAwait f (unbox f a' b) as' (b ::: bs')+            Snd as' bs' -> sampleAwait f c as' bs'+            Both (a' ::: as') (b' ::: bs') -> sampleAwait f (unbox f a' b') as' (b' ::: bs'))  --- | This function is a variant of 'triggerAwait' that only produces a+-- | This function is a variant of 'sampleAwait' that only produces a -- value when the first signal ticks; otherwise it produces -- @Nothing'@. --@@ -322,19 +391,19 @@ -- >                             xs:    1     0 5 2 -- >                             ys:  5 1 2 3     2 -- >--- > triggerAwaitM (box plus) xy ys:    2 N N 3 8 4 where plus x y =+-- > sampleAwaitM (box plus) xy ys:    2 N N 3 8 4 where plus x y = -- Just' (x+y) -triggerAwaitM :: Stable b => Box (a -> b -> Maybe' c) -> O (Sig a) -> Sig b -> O (Sig (Maybe' c))-triggerAwaitM f as (b ::: bs) = +sampleAwaitM :: Stable b => Box (a -> b -> Maybe' c) -> O (Sig a) -> Sig b -> O (Sig (Maybe' c))+sampleAwaitM f as (b ::: bs) =      delay (case select as bs of-            Fst (a' ::: as') bs' -> unbox f a' b ::: triggerAwaitM f as' (b ::: bs')-            Snd as' bs' -> Nothing' ::: triggerAwaitM f as' bs'-            Both (a' ::: as') (b' ::: bs') -> unbox f a' b' ::: triggerAwaitM f as' (b' ::: bs'))+            Fst (a' ::: as') bs' -> unbox f a' b ::: sampleAwaitM f as' (b ::: bs')+            Snd as' bs' -> Nothing' ::: sampleAwaitM f as' bs'+            Both (a' ::: as') (b' ::: bs') -> unbox f a' b' ::: sampleAwaitM f as' (b' ::: bs'))  -- | This function is a variant of 'zipWith'. Whereas @zipWith f xs -- ys@ produces a new value whenever @xs@ or @ys@ produce a new value,--- @trigger f xs ys@ only produces a new value when xs produces a new+-- @sample f xs ys@ only produces a new value when xs produces a new -- value, otherwise it just repeats the previous value. -- -- Example:@@ -343,12 +412,12 @@ -- >                      ys:  1 2 3     2 -- > -- > zipWith (box (+)) xs ys:  2 3 4 3 8 4--- > trigger (box (+)) xy ys:  2 2 2 3 8 4+-- > sample (box (+)) xy ys:  2 2 2 3 8 4 -trigger :: (Stable b, Stable c) => Box (a -> b -> c) -> Sig a -> Sig b -> Sig c-trigger f (a:::as) bs@(b ::: _) = triggerAwait f (unbox f a b) as bs+sample :: (Stable b, Stable c) => Box (a -> b -> c) -> Sig a -> Sig b -> Sig c+sample f (a:::as) bs@(b ::: _) = sampleAwait f (unbox f a b) as bs --- | This function is a variant of 'trigger' that only produces a+-- | This function is a variant of 'sample' that only produces a -- value when the first signal ticks; otherwise it produces -- @Nothing'@. --@@ -358,18 +427,19 @@ -- >                      ys:  1 2 3     2 -- > -- > zipWith (box plus) xs ys:  2 3 4 3 8 4--- > trigger (box plus) xy ys:  2 N N 3 8 4+-- > sample (box plus) xy ys:  2 N N 3 8 4 -- where -- > plus x y = Just' (x+y) -triggerM :: Stable b => Box (a -> b -> Maybe' c) -> Sig a -> Sig b -> Sig (Maybe' c)-triggerM f (a:::as) bs@(b ::: _) = unbox f a b ::: triggerAwaitM f as bs+sampleM :: Stable b => Box (a -> b -> Maybe' c) -> Sig a -> Sig b -> Sig (Maybe' c)+sampleM f (a:::as) bs@(b ::: _) = unbox f a b ::: sampleAwaitM f as bs   -- Buffer takes an initial value and a signal as input and returns a signal that -- is always one tick behind the input signal. buffer :: Stable a => a -> Sig a -> Sig a buffer x (y ::: ys) = x ::: delay (buffer y (adv ys))+  -- Like buffer but works for delayed signals bufferAwait :: Stable a => a -> O (Sig a) -> O (Sig a)
src/WidgetRattus/Strict.hs view
@@ -32,6 +32,7 @@     mapMaybe',     concatMap',     (:*)(..),+    (:+)(..),     Maybe'(..),     maybe',     fromMaybe',@@ -50,9 +51,14 @@ import WidgetRattus.Derive import WidgetRattus.Plugin.Annotation import GHC.Exts (IsList(..))-import Data.Text hiding (foldl, singleton)+import Data.Text (Text, pack, unpack, splitOn) import Text.Read (readMaybe) ++infixr 3 :++-- | Strict sum type.+data a :+ b = Left' !a | Right' !b deriving (Show, Eq)+ infixr 2 :* -- | Strict pair type. data a :* b = !a :* !b@@ -247,6 +253,12 @@ data Maybe' a = Just' !a | Nothing' deriving (Show, Eq, Ord)  continuous ''Maybe'++instance Functor Maybe' where+  fmap f (Just' x) = Just' (f x)+  fmap _ Nothing'  = Nothing'++  -- | takes a default value, a function, and a 'Maybe'' value.  If the -- 'Maybe'' value is 'Nothing'', the function returns the default
src/WidgetRattus/Time.hs view
@@ -4,9 +4,11 @@  module WidgetRattus.Time (   Time(..),+  DTime,   time,   addTime,   diffTime,+  (<->),   module Data.Time.Clock   )   where@@ -15,10 +17,15 @@ import Data.Time.Clock import WidgetRattus.Plugin +type DTime = NominalDiffTime+ {-# ANN addTime AllowLazyData #-}-addTime :: NominalDiffTime -> Time -> Time+addTime :: DTime -> 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 -> Time -> DTime diffTime (Time d1 t1) (Time d2 t2) = diffUTCTime (UTCTime d1 t1) (UTCTime d2 t2)++(<->) :: Time -> Time -> Float+t' <-> t = fromRational (toRational (diffTime t' t))
test/WellTyped.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE StrictData #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} {-# OPTIONS -fplugin=WidgetRattus.Plugin #-}  module Main (module Main) where@@ -8,6 +12,8 @@ import WidgetRattus.Signal import Data.Set as Set import Data.Text+import qualified Data.String as Str+import qualified GHC.Exts as Exts  boxedInt :: Box Int boxedInt = box 8@@ -143,5 +149,137 @@  unusedAdv' :: O () -> O () unusedAdv' d = delay (let _ = adv d in ())+++-- check whether the Stable constraint solver handles GADTs correctly.++data Pull a where+  Fun :: Stable s => !s -> !(Box(s -> Int -> (s :* a))) -> Pull a+++newtype Beh a = Beh (Sig (Pull a))++funTest :: Pull a -> O () -> O (Pull a)+funTest fun@(Fun x f) d = delay (let _ = adv d in x `seq` fun)++funTest2 :: Pull a -> O () -> O (Pull a)+funTest2 fun d = case fun of (!(Fun x f)) -> delay (let _ = adv d in x `seq` fun)++funTest3 :: C (Pull a) -> O () -> C (O (Pull a))+funTest3 fun d = do Fun x f <-  fun +                    fun' <- fun+                    return (delay (let _ = adv d in x `seq` fun'))++funTest4 :: Pull a -> O () -> C (O (Pull a))+funTest4 fun@(Fun x f) d = do let (x':* v) = unbox f x 0+                              return (delay (let _ = adv d in x' `seq` fun))++++funTest5 :: Pull a -> O () -> O (Pull a)+funTest5 fun@(Fun x f) d = delay (let _ = adv d in x' `seq` fun)+  where (x':* v) = unbox f x 0+++funTest6 :: Pull a -> O () -> O (Pull a)+funTest6 fun@(Fun x f) d = let (x':* v) = unbox f x 0 in delay (let _ = adv d in x' `seq` fun)++-- the stable constraint must reach a pattern guard+funTestGuard :: Pull a -> O () -> O (Pull a)+funTestGuard fun d+  | Fun x _ <- fun = delay (let _ = adv d in x `seq` fun)++-- ... and a bind statement in do notation+{-# ANN funTestBind AllowLazyData #-}+funTestBind :: Maybe (Pull a) -> O () -> Maybe (O (Pull a))+funTestBind fun d = do Fun x _ <- fun+                       fun' <- fun+                       return (delay (let _ = adv d in x `seq` fun'))++-- ... and a match on a constructor of a data family instance, which+-- the type checker wraps in a coercion pattern+data family Fam a+data instance Fam Int where+  MkFam :: Stable s => !s -> Fam Int++funTestFamily :: Fam Int -> O () -> O ()+funTestFamily (MkFam x) d = delay (let _ = adv d in x `seq` ())++++funTestWorkaround :: Pull a -> O () -> O (Pull a)+funTestWorkaround fun@(Fun x f) d = foo x fun+  where foo :: Stable s => s -> (Pull a) -> O (Pull a)+        foo x fun = delay (let _ = adv d in x `seq` fun)++zipFun :: Box (a -> b -> c) -> Pull a -> Pull b -> Pull c+zipFun f (Fun sa fa) (Fun sb fb) = Fun (sa :* sb) +  (box (\ (sa' :* sb') t -> +          let (sa'' :* a) = unbox fa sa' t+              (sb'' :* b) = unbox fb sb' t+          in ((sa'' :* sb'') :* unbox f a b) ))+                      ++zipWithBeh :: (Stable a, Stable b) => Box (a -> b -> c) -> Beh a -> Beh b -> Beh c+zipWithBeh f (Beh as) (Beh bs) = Beh (run as bs) where+  run (a ::: as) (b ::: bs) = zipFun f a b ::: delay +     (case select as bs of+        Fst as' lbs -> run as' (b ::: lbs)+        Snd las bs' -> run (a ::: las) bs'+        Both as' bs' -> run as' bs')+++-- check that newtypes over stable types are recognised as stable++newtype Count = Count Int++newtypeStable :: Count -> O () -> O Count+newtypeStable x d = delay (let _ = adv d in x)+++-- check the strict sum type++strictSum :: Int :+ Bool -> Int+strictSum (Left' n) = n+strictSum (Right' b) = if b then 1 else 0++strictSumStable :: Int :+ Bool -> O () -> O (Int :+ Bool)+strictSumStable x d = delay (let _ = adv d in x)+++-- check the Functor instance of Maybe'++incMaybe' :: Maybe' Int -> Maybe' Int+incMaybe' = fmap (+1)+++-- The definitions below must not produce a "may lead to memory leaks"+-- warning: the lazy arguments of fromString, fromList/fromListN and+-- Data.Text.pack are consumed immediately and are not retained. Note+-- that the arguments must not be literals, since those are already+-- exempt from the check.++-- fromListN, as inserted by OverloadedLists+intSet :: Set Int+intSet = [1,2,3]++-- fromList, the method of the IsList class+setFromList :: [Int] -> Set Int+setFromList xs = Exts.fromList xs++-- fromString, the method of the IsString class+textFromString :: String -> Text+textFromString s = Str.fromString s++-- Data.Text.pack+packedText :: String -> Text+packedText s = pack s+++-- 'Item l' must be recognised as strict whenever 'l' is.++itemStrict :: IsList l => l -> Item l -> List (Item l)+itemStrict _ x = x :! Nil+  main = putStrLn "This file should just type check"