diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/WidgetRattus.cabal b/WidgetRattus.cabal --- a/WidgetRattus.cabal +++ b/WidgetRattus.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: WidgetRattus -version: 0.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 diff --git a/examples/gui/src/Calculator.hs b/examples/gui/src/Calculator.hs --- a/examples/gui/src/Calculator.hs +++ b/examples/gui/src/Calculator.hs @@ -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 diff --git a/examples/gui/src/Stopwatch.hs b/examples/gui/src/Stopwatch.hs --- a/examples/gui/src/Stopwatch.hs +++ b/examples/gui/src/Stopwatch.hs @@ -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)) diff --git a/src/WidgetRattus.hs b/src/WidgetRattus.hs --- a/src/WidgetRattus.hs +++ b/src/WidgetRattus.hs @@ -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)) diff --git a/src/WidgetRattus/Behaviour.hs b/src/WidgetRattus/Behaviour.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Behaviour.hs @@ -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))) + #-} diff --git a/src/WidgetRattus/Event.hs b/src/WidgetRattus/Event.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/Event.hs @@ -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 + #-} diff --git a/src/WidgetRattus/Future.hs b/src/WidgetRattus/Future.hs --- a/src/WidgetRattus/Future.hs +++ b/src/WidgetRattus/Future.hs @@ -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) diff --git a/src/WidgetRattus/Plugin/Dependency.hs b/src/WidgetRattus/Plugin/Dependency.hs --- a/src/WidgetRattus/Plugin/Dependency.hs +++ b/src/WidgetRattus/Plugin/Dependency.hs @@ -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 diff --git a/src/WidgetRattus/Plugin/ScopeCheck.hs b/src/WidgetRattus/Plugin/ScopeCheck.hs --- a/src/WidgetRattus/Plugin/ScopeCheck.hs +++ b/src/WidgetRattus/Plugin/ScopeCheck.hs @@ -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 () diff --git a/src/WidgetRattus/Plugin/SingleTick.hs b/src/WidgetRattus/Plugin/SingleTick.hs --- a/src/WidgetRattus/Plugin/SingleTick.hs +++ b/src/WidgetRattus/Plugin/SingleTick.hs @@ -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. diff --git a/src/WidgetRattus/Plugin/Strictify.hs b/src/WidgetRattus/Plugin/Strictify.hs --- a/src/WidgetRattus/Plugin/Strictify.hs +++ b/src/WidgetRattus/Plugin/Strictify.hs @@ -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 diff --git a/src/WidgetRattus/Plugin/Transform.hs b/src/WidgetRattus/Plugin/Transform.hs --- a/src/WidgetRattus/Plugin/Transform.hs +++ b/src/WidgetRattus/Plugin/Transform.hs @@ -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 diff --git a/src/WidgetRattus/Plugin/Utils.hs b/src/WidgetRattus/Plugin/Utils.hs --- a/src/WidgetRattus/Plugin/Utils.hs +++ b/src/WidgetRattus/Plugin/Utils.hs @@ -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) diff --git a/src/WidgetRattus/PushPull/Widgets.hs b/src/WidgetRattus/PushPull/Widgets.hs new file mode 100644 --- /dev/null +++ b/src/WidgetRattus/PushPull/Widgets.hs @@ -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' + ) diff --git a/src/WidgetRattus/Signal.hs b/src/WidgetRattus/Signal.hs --- a/src/WidgetRattus/Signal.hs +++ b/src/WidgetRattus/Signal.hs @@ -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) diff --git a/src/WidgetRattus/Strict.hs b/src/WidgetRattus/Strict.hs --- a/src/WidgetRattus/Strict.hs +++ b/src/WidgetRattus/Strict.hs @@ -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 diff --git a/src/WidgetRattus/Time.hs b/src/WidgetRattus/Time.hs --- a/src/WidgetRattus/Time.hs +++ b/src/WidgetRattus/Time.hs @@ -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)) diff --git a/test/WellTyped.hs b/test/WellTyped.hs --- a/test/WellTyped.hs +++ b/test/WellTyped.hs @@ -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"