AsyncRattus 0.2.1 → 0.2.2

raw patch · 10 files changed

+613/−60 lines, 10 filesdep ~containersdep ~ghcdep ~ghc-bootPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: containers, ghc, ghc-boot

API changes (from Hackage documentation)

Files

• AsyncRattus.cabal +4/−4
• CHANGELOG.md +27/−1
• src/AsyncRattus/Plugin/Dependency.hs +114/−15
• src/AsyncRattus/Plugin/ScopeCheck.hs +244/−26
• src/AsyncRattus/Plugin/SingleTick.hs +4/−1
• src/AsyncRattus/Plugin/Strictify.hs +30/−2
• src/AsyncRattus/Plugin/Transform.hs +1/−1
• src/AsyncRattus/Plugin/Utils.hs +56/−9
• src/AsyncRattus/Strict.hs +9/−0
• test/WellTyped.hs +124/−1

@@ -1,6 +1,6 @@ cabal-version:       1.18 name:                AsyncRattus-version:             0.2.1+version:             0.2.2 category:            FRP synopsis:            An asynchronous modal FRP language description:@@ -140,9 +140,9 @@                        AsyncRattus.Plugin.Transform                        AsyncRattus.Plugin.PrimExpr   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

@@ -1,5 +1,31 @@-# 0.2.1+# 0.2.2 + - Support GHC 9.10, 9.12, and 9.14.+ - Fix the multiplicity of the binder that the plugin generates for+   `delay`.+ - Scope checking now accounts for pattern matching with existential+   types. Given a constructor `MkFoo :: Stable a => !a -> Foo`, the+   definition `fun (MkFoo x) = box x` now type checks.+ - Newtypes are now recognised as stable if their underlying type is+   stable.+ - The strictness checker no longer warns about the lazy arguments of+   `fromString`, `fromList`/`fromListN` and `Data.Text.pack`. These+   functions consume their argument immediately, so it cannot cause a+   space leak.+ - `Item l`, the type family of the `IsList` class, is now recognised+   as strict whenever `l` is.+ - New strict sum type `:+` in `AsyncRattus.Strict`.+ - New `Functor` instance for `Maybe'`.++# 0.2.1.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.++# 0.2.1+======= - More signal combinators  # 0.2.0.2

@@ -9,7 +9,8 @@ -- (mutual) recursive. To this end, this module also provides -- functions to compute, bound variables and variable occurrences. -module AsyncRattus.Plugin.Dependency (dependency, HasBV (..),printBinds) where+module AsyncRattus.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

@@ -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@@ -369,7 +509,8 @@     | Just p <- isPrim v =         case p of           Unbox -> return True-          _ -> printMessageCheck SevError ("Defining an alias for " <> ppr v <> " is not allowed")+          _ -> printMessageCheck SevError ("The primitive " <> ppr v <> " must be applied directly to an argument." +                $$ "It cannot be assigned to a variable or passed as an argument, e.g. when using the $ operator.")     | otherwise = case getScope v of              Hidden reason -> printMessageCheck SevError reason              Visible -> return True@@ -436,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@@ -454,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@@ -468,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@@ -492,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@@ -516,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@@ -530,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@@ -574,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})@@ -589,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 @@ -759,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@@ -797,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 ()

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

@@ -27,10 +27,14 @@ checkStrictData ss (Tick (SourceNote span _) e) =    checkStrictData (ss{srcSpan = fromRealSrcSpan span}) e checkStrictData ss (App e1 e2)-  | isPushCallStack e1 = return ()+  | ignoreArgument e1 = return ()   | otherwise = do      when (not (isType e2) && tcIsLiftedTypeKind(typeKind (exprType e2))-        && not (isStrict (exprType e2)) && not (isDeepseqForce e2) && not (isLit e2))+        && 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@@ -51,6 +55,30 @@     _ -> 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) ->+      ((mod == "GHC.Exts" || mod == "GHC.IsList") && (name == "fromList" || name == "fromListN")) ||+      ((mod == "Data.String" || mod == "GHC.Data.String") && name == "fromString") ||+      (mod == "GHC.Stack.Types" && name == "pushCallStack") ||+      ((mod == "Data.Text" || mod == "Data.Text.Internal") && name == "pack")+    _ -> False+ignoreArgument (App x _) = ignoreArgument x+ignoreArgument _ = False  isDeepseqForce :: CoreExpr -> Bool isDeepseqForce (App (App (App (Var v) _) _) _) =

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

@@ -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  @@ -138,9 +141,11 @@ getNamedThingFromModuleAndOccName :: String -> OccName -> CoreM TyThing getNamedThingFromModuleAndOccName moduleName occName = do   origNameCache <- origNameCache-  let [mod] = filter ((moduleName ==) . unpackFS . getModuleFS) (moduleEnvKeys origNameCache)-  let name = fromJust $ lookupOrigNameCache origNameCache mod occName-  lookupThing name+  case filter ((moduleName ==) . unpackFS . getModuleFS) (moduleEnvKeys origNameCache) of+    mod : _ -> lookupThing $ fromJust $ lookupOrigNameCache origNameCache mod occName+    [] -> error ("internal error: cannot find module " ++ moduleName ++ " in the name cache; "+                 ++ "the modules in the name cache are: "+                 ++ show (map (unpackFS . getModuleFS) (moduleEnvKeys origNameCache)))  getVarFromModule :: String -> String -> CoreM Var getVarFromModule moduleName = fmap tyThingId . getNamedThingFromModuleAndOccName moduleName . mkOccName Occurrence.varName@@ -185,9 +190,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 +286,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" -> True@@ -274,12 +303,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@@ -307,7 +349,12 @@       case getNameModule con of         Nothing -> False         Just (name,mod)-          | 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@@ -358,7 +405,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)

@@ -32,6 +32,7 @@     mapMaybe',     concatMap',     (:*)(..),+    (:+)(..),     Maybe'(..),     maybe',     fromMaybe',@@ -46,6 +47,10 @@ import Data.VectorSpace import GHC.Exts (IsList(..)) +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@@ -234,6 +239,10 @@  -- | Strict variant of 'Maybe'. data Maybe' a = Just' !a | Nothing' deriving (Show, Eq, Ord)++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

@@ -1,5 +1,7 @@ {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE StrictData #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-} {-# OPTIONS -fplugin=AsyncRattus.Plugin #-}  module Main (module Main) where@@ -8,6 +10,8 @@ import AsyncRattus.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 +147,124 @@  unusedAdv' :: O () -> O () unusedAdv' d = delay (let _ = adv d in ())+++-- check whether the Stable constraint solver handles GADTs correctly.++data Fun a where+  Fun :: Stable s => !s -> !(Box(s -> Int -> (s :* a))) -> Fun a++newtype Beh a = Beh (Sig (Fun a))++zipFun :: Box (a -> b -> c) -> Fun a -> Fun b -> Fun 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 scope checking accounts for the Stable constraint that+-- pattern matching on an existential/GADT constructor brings into+-- scope. In each case the existentially bound x must remain in scope+-- under the delay.++-- match in a function definition+funTest :: Fun a -> O () -> O (Fun a)+funTest fun@(Fun x _) d = delay (let _ = adv d in x `seq` fun)++-- match in a case expression+funTest2 :: Fun a -> O () -> O (Fun a)+funTest2 fun = case fun of Fun x _ -> \ d -> delay (let _ = adv d in x `seq` fun)++-- the stable constraint must reach a where-bound pattern binding+funTest5 :: Fun a -> O () -> O (Fun a)+funTest5 fun@(Fun x f) d = delay (let _ = adv d in x' `seq` fun)+  where (x' :* _) = unbox f x 0++-- ... and a let-bound pattern binding+funTest6 :: Fun a -> O () -> O (Fun a)+funTest6 fun@(Fun x f) d =+  let (x' :* _) = unbox f x 0 in delay (let _ = adv d in x' `seq` fun)++-- ... and a pattern guard+funTestGuard :: Fun a -> O () -> O (Fun 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 (Fun a) -> O () -> Maybe (O (Fun a))+funTestBind fun d = do Fun x _ <- fun+                       fun' <- fun+                       return (delay (let _ = adv d in x `seq` fun'))++-- this workaround was previously needed to get the above to compile+funTestWorkaround :: Fun a -> O () -> O (Fun a)+funTestWorkaround fun@(Fun x _) d = foo x fun+  where foo :: Stable s => s -> Fun a -> O (Fun a)+        foo y g = delay (let _ = adv d in y `seq` g)+++-- 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"