penelope-effects (empty) → 0.1.0.0

raw patch · 14 files changed

+3413/−0 lines, 14 filesdep +basedep +containersdep +deepseq

Dependencies added: base, containers, deepseq, hspec, penelope-core, penelope-effects, polytropos-core, polytropos-plugin, primitive, profunctors, tasty-bench, text

Files

• CHANGELOG.md +10/−0
• LICENSE +189/−0
• README.md +10/−0
• bench/Main.hs +475/−0
• penelope-effects.cabal +135/−0
• src/Penelope/Effects.hs +76/−0
• src/Penelope/Effects/Binary.hs +296/−0
• src/Penelope/Effects/Concurrent.hs +208/−0
• src/Penelope/Effects/Control.hs +261/−0
• src/Penelope/Effects/Coroutine.hs +271/−0
• src/Penelope/Effects/Scoped.hs +429/−0
• src/Penelope/Effects/Unary.hs +215/−0
• src/Penelope/Effects/UnliftIO.hs +267/−0
• test/Main.hs +571/−0

@@ -0,0 +1,10 @@+# Changelog for penelope-effects++## 0.1.0.0 — Initial Release++- Domain effect battery for Penelope.+- Heftia-style unary monadic facade (`Eff`, `sendUnary`, `interpretUnary`).+- Kernmantle-style binary profunctor facade (`Flow`, `sendBinary`, `interpretBinary`).+- Standard effect suite: `State`, `Reader`, `Writer`, `Error`, `Coroutine`, `UnliftIO`, `Scoped`, `Concurrent`.+- Scoped semantics with robust continuation capturing and branch safety.+- Comprehensive allocation and throughput benchmarks.

@@ -0,0 +1,189 @@+EUROPEAN UNION PUBLIC LICENCE v. 1.2+EUPL © the European Union 2007, 2016++This European Union Public Licence (the ‘EUPL’) applies to the Work (as defined below) which is provided under the+terms of this Licence. Any use of the Work, other than as authorised under this Licence is prohibited (to the extent such+use is covered by a right of the copyright holder of the Work).+The Work is provided under the terms of this Licence when the Licensor (as defined below) has placed the following+notice immediately following the copyright notice for the Work:+                          Licensed under the EUPL+or has expressed by any other means his willingness to license under the EUPL.++1.Definitions+In this Licence, the following terms have the following meaning:+— ‘The Licence’:this Licence.+— ‘The Original Work’:the work or software distributed or communicated by the Licensor under this Licence, available+as Source Code and also as Executable Code as the case may be.+— ‘Derivative Works’:the works or software that could be created by the Licensee, based upon the Original Work or+modifications thereof. This Licence does not define the extent of modification or dependence on the Original Work+required in order to classify a work as a Derivative Work; this extent is determined by copyright law applicable in+the country mentioned in Article 15.+— ‘The Work’:the Original Work or its Derivative Works.+— ‘The Source Code’:the human-readable form of the Work which is the most convenient for people to study and+modify.+— ‘The Executable Code’:any code which has generally been compiled and which is meant to be interpreted by+a computer as a program.+— ‘The Licensor’:the natural or legal person that distributes or communicates the Work under the Licence.+— ‘Contributor(s)’:any natural or legal person who modifies the Work under the Licence, or otherwise contributes to+the creation of a Derivative Work.+— ‘The Licensee’ or ‘You’:any natural or legal person who makes any usage of the Work under the terms of the+Licence.+— ‘Distribution’ or ‘Communication’:any act of selling, giving, lending, renting, distributing, communicating,+transmitting, or otherwise making available, online or offline, copies of the Work or providing access to its essential+functionalities at the disposal of any other natural or legal person.++2.Scope of the rights granted by the Licence+The Licensor hereby grants You a worldwide, royalty-free, non-exclusive, sublicensable licence to do the following, for+the duration of copyright vested in the Original Work:+— use the Work in any circumstance and for all usage,+— reproduce the Work,+— modify the Work, and make Derivative Works based upon the Work,+— communicate to the public, including the right to make available or display the Work or copies thereof to the public+and perform publicly, as the case may be, the Work,+— distribute the Work or copies thereof,+— lend and rent the Work or copies thereof,+— sublicense rights in the Work or copies thereof.+Those rights can be exercised on any media, supports and formats, whether now known or later invented, as far as the+applicable law permits so.+In the countries where moral rights apply, the Licensor waives his right to exercise his moral right to the extent allowed+by law in order to make effective the licence of the economic rights here above listed.+The Licensor grants to the Licensee royalty-free, non-exclusive usage rights to any patents held by the Licensor, to the+extent necessary to make use of the rights granted on the Work under this Licence.++3.Communication of the Source Code+The Licensor may provide the Work either in its Source Code form, or as Executable Code. If the Work is provided as+Executable Code, the Licensor provides in addition a machine-readable copy of the Source Code of the Work along with+each copy of the Work that the Licensor distributes or indicates, in a notice following the copyright notice attached to+the Work, a repository where the Source Code is easily and freely accessible for as long as the Licensor continues to+distribute or communicate the Work.++4.Limitations on copyright+Nothing in this Licence is intended to deprive the Licensee of the benefits from any exception or limitation to the+exclusive rights of the rights owners in the Work, of the exhaustion of those rights or of other applicable limitations+thereto.++5.Obligations of the Licensee+The grant of the rights mentioned above is subject to some restrictions and obligations imposed on the Licensee. Those+obligations are the following:++Attribution right: The Licensee shall keep intact all copyright, patent or trademarks notices and all notices that refer to+the Licence and to the disclaimer of warranties. The Licensee must include a copy of such notices and a copy of the+Licence with every copy of the Work he/she distributes or communicates. The Licensee must cause any Derivative Work+to carry prominent notices stating that the Work has been modified and the date of modification.++Copyleft clause: If the Licensee distributes or communicates copies of the Original Works or Derivative Works, this+Distribution or Communication will be done under the terms of this Licence or of a later version of this Licence unless+the Original Work is expressly distributed only under this version of the Licence — for example by communicating+‘EUPL v. 1.2 only’. The Licensee (becoming Licensor) cannot offer or impose any additional terms or conditions on the+Work or Derivative Work that alter or restrict the terms of the Licence.++Compatibility clause: If the Licensee Distributes or Communicates Derivative Works or copies thereof based upon both+the Work and another work licensed under a Compatible Licence, this Distribution or Communication can be done+under the terms of this Compatible Licence. For the sake of this clause, ‘Compatible Licence’ refers to the licences listed+in the appendix attached to this Licence. Should the Licensee's obligations under the Compatible Licence conflict with+his/her obligations under this Licence, the obligations of the Compatible Licence shall prevail.++Provision of Source Code: When distributing or communicating copies of the Work, the Licensee will provide+a machine-readable copy of the Source Code or indicate a repository where this Source will be easily and freely available+for as long as the Licensee continues to distribute or communicate the Work.+Legal Protection: This Licence does not grant permission to use the trade names, trademarks, service marks, or names+of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and+reproducing the content of the copyright notice.++6.Chain of Authorship+The original Licensor warrants that the copyright in the Original Work granted hereunder is owned by him/her or+licensed to him/her and that he/she has the power and authority to grant the Licence.+Each Contributor warrants that the copyright in the modifications he/she brings to the Work are owned by him/her or+licensed to him/her and that he/she has the power and authority to grant the Licence.+Each time You accept the Licence, the original Licensor and subsequent Contributors grant You a licence to their contributions+to the Work, under the terms of this Licence.++7.Disclaimer of Warranty+The Work is a work in progress, which is continuously improved by numerous Contributors. It is not a finished work+and may therefore contain defects or ‘bugs’ inherent to this type of development.+For the above reason, the Work is provided under the Licence on an ‘as is’ basis and without warranties of any kind+concerning the Work, including without limitation merchantability, fitness for a particular purpose, absence of defects or+errors, accuracy, non-infringement of intellectual property rights other than copyright as stated in Article 6 of this+Licence.+This disclaimer of warranty is an essential part of the Licence and a condition for the grant of any rights to the Work.++8.Disclaimer of Liability+Except in the cases of wilful misconduct or damages directly caused to natural persons, the Licensor will in no event be+liable for any direct or indirect, material or moral, damages of any kind, arising out of the Licence or of the use of the+Work, including without limitation, damages for loss of goodwill, work stoppage, computer failure or malfunction, loss+of data or any commercial damage, even if the Licensor has been advised of the possibility of such damage. However,+the Licensor will be liable under statutory product liability laws as far such laws apply to the Work.++9.Additional agreements+While distributing the Work, You may choose to conclude an additional agreement, defining obligations or services+consistent with this Licence. However, if accepting obligations, You may act only on your own behalf and on your sole+responsibility, not on behalf of the original Licensor or any other Contributor, and only if You agree to indemnify,+defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against such Contributor by+the fact You have accepted any warranty or additional liability.++10.Acceptance of the Licence+The provisions of this Licence can be accepted by clicking on an icon ‘I agree’ placed under the bottom of a window+displaying the text of this Licence or by affirming consent in any other similar way, in accordance with the rules of+applicable law. Clicking on that icon indicates your clear and irrevocable acceptance of this Licence and all of its terms+and conditions.+Similarly, you irrevocably accept this Licence and all of its terms and conditions by exercising any rights granted to You+by Article 2 of this Licence, such as the use of the Work, the creation by You of a Derivative Work or the Distribution+or Communication by You of the Work or copies thereof.++11.Information to the public+In case of any Distribution or Communication of the Work by means of electronic communication by You (for example,+by offering to download the Work from a remote location) the distribution channel or media (for example, a website)+must at least provide to the public the information requested by the applicable law regarding the Licensor, the Licence+and the way it may be accessible, concluded, stored and reproduced by the Licensee.++12.Termination of the Licence+The Licence and the rights granted hereunder will terminate automatically upon any breach by the Licensee of the terms+of the Licence.+Such a termination will not terminate the licences of any person who has received the Work from the Licensee under+the Licence, provided such persons remain in full compliance with the Licence.++13.Miscellaneous+Without prejudice of Article 9 above, the Licence represents the complete agreement between the Parties as to the+Work.+If any provision of the Licence is invalid or unenforceable under applicable law, this will not affect the validity or+enforceability of the Licence as a whole. Such provision will be construed or reformed so as necessary to make it valid+and enforceable.+The European Commission may publish other linguistic versions or new versions of this Licence or updated versions of+the Appendix, so far this is required and reasonable, without reducing the scope of the rights granted by the Licence.+New versions of the Licence will be published with a unique version number.+All linguistic versions of this Licence, approved by the European Commission, have identical value. Parties can take+advantage of the linguistic version of their choice.++14.Jurisdiction+Without prejudice to specific agreement between parties,+— any litigation resulting from the interpretation of this License, arising between the European Union institutions,+bodies, offices or agencies, as a Licensor, and any Licensee, will be subject to the jurisdiction of the Court of Justice+of the European Union, as laid down in article 272 of the Treaty on the Functioning of the European Union,+— any litigation arising between other parties and resulting from the interpretation of this License, will be subject to+the exclusive jurisdiction of the competent court where the Licensor resides or conducts its primary business.++15.Applicable Law+Without prejudice to specific agreement between parties,+— this Licence shall be governed by the law of the European Union Member State where the Licensor has his seat,+resides or has his registered office,+— this licence shall be governed by Belgian law if the Licensor has no seat, residence or registered office inside+a European Union Member State.++Appendix++‘Compatible Licences’ according to Article 5 EUPL are:+— GNU General Public License (GPL) v. 2, v. 3+— GNU Affero General Public License (AGPL) v. 3+— Open Software License (OSL) v. 2.1, v. 3.0+— Eclipse Public License (EPL) v. 1.0+— CeCILL v. 2.0, v. 2.1+— Mozilla Public Licence (MPL) v. 2+— GNU Lesser General Public Licence (LGPL) v. 2.1, v. 3+— Creative Commons Attribution-ShareAlike v. 3.0 Unported (CC BY-SA 3.0) for works other than software+— European Union Public Licence (EUPL) v. 1.1, v. 1.2+— Québec Free and Open-Source Licence — Reciprocity (LiLiQ-R) or Strong Reciprocity (LiLiQ-R+).++The European Commission may update this Appendix to later versions of the above licences without producing+a new version of the EUPL, as long as they provide the rights granted in Article 2 of this Licence and protect the+covered Source Code from exclusive appropriation.+All other changes or additions to this Appendix require the production of a new EUPL version.

@@ -0,0 +1,10 @@+# penelope-effects++Domain package for penelope-effects++## Modules+++## License++EUPL-1.2

@@ -0,0 +1,475 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_GHC -fplugin=Polytropos.Plugin #-}++{- |+Module      : Main+Description : Milestone 6.4 Allocation & Throughput Benchmarks+Copyright   : (c) 2026 The Penelope Authors+License     : EUPL-1.2 OR Apache-2.0+Maintainer  : nadia.yvette.chambers@ik.me+Stability   : experimental+Portability : non-portable (GHC extensions)++Comprehensive Criterion/Gauge compatible benchmarks via 'tasty-bench':+1. Deep First-Order Effect Stacks (D = 30):+   Demonstrates \(O(1)\) branchless vector indexing vs \(O(D)\) freer sum peeling.+2. Deep Higher-Order Scoped Elaboration (H = 15):+   Demonstrates single-pass bottom-up elaboration vs multi-pass linear tree traversal.+3. Wide Register Frames (m, n = 20 ports):+   Demonstrates \(O(1)\) static 'RowMorph' gather-scatter vs \(O(N)\) record/lens traversal.+4. Surface Facades Throughput & Allocation ('Eff' & 'Rope'):+   Measures monadic and arrow composition overhead vs pure baselines.+5. Scoped Semantics & Delimited Continuations:+   Measures 'local', 'catchError', and multi-shot coroutine resumption overhead.++See Note [Core Architecture] [ref:note-core-architecture],+Note [Unpacked Polycategorical Representation] [ref:note-unpacked-representation],+Note [Reified Row Morphisms and Gather-Scatter] [ref:note-row-morph-routing],+Note [Two-Phase Weaving and Unweaving] [ref:note-two-phase-engine], and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+module Main (main) where++import qualified Control.Arrow as Arrow+import qualified Control.Category as Cat+import Data.Functor.Identity (Identity (..))+import Data.Primitive.SmallArray (indexSmallArray, smallArrayFromList)+import GHC.Exts (Any, Word#, unsafeCoerce#)+import Penelope.Core+  ( BranchCont (..)+  , Elaborator (..)+  , FrameKleisli (..)+  , Handler (..)+  , MapRow+  , Penelope (..)+  , PolyEffect+  , PolyHEffect+  , PortSig (..)+  , Region (..)+  , elaborateAll+  , interpretAll+  , preComposeRoute+  , runFrameKleisli+  , seqPenelope+  )+import Penelope.Effects+  ( AskEff (..)+  , Eff+  , NonDetEff (..)+  , Rope+  , ThrowEff (..)+  , UnaryEffect+  , askReader+  , branch+  , catchError+  , local+  , nonDetHandler+  , runEff+  , runErrorPure+  , runReaderPure+  , runRopePure+  , runEffM+  )+import Polytropos (Field (..), Pair (..), Record, emptyRecord, insertField)+import Polytropos.Core (Rep (..), RowRep (..))+import Polytropos.RowMorph (RowMorph, gatherRep, unsafeMkRowMorph)+import Prelude hiding (id, (.))+import qualified Prelude as P+import Test.Tasty.Bench+  ( bench+  , bgroup+  , defaultMain+  , nf+  , whnf+  )++{-------------------------------------------------------------------------------+  Suite 1: Deep First-Order Effect Stacks (D = 30)+  See Note [Unpacked Polycategorical Representation] [ref:note-unpacked-representation]+  and Note [Two-Phase Weaving and Unweaving] [ref:note-two-phase-engine]+-------------------------------------------------------------------------------}++-- 30 distinct first-order effect kinds+data Op01 :: PolyEffect+data Op02 :: PolyEffect+data Op03 :: PolyEffect+data Op04 :: PolyEffect+data Op05 :: PolyEffect+data Op06 :: PolyEffect+data Op07 :: PolyEffect+data Op08 :: PolyEffect+data Op09 :: PolyEffect+data Op10 :: PolyEffect+data Op11 :: PolyEffect+data Op12 :: PolyEffect+data Op13 :: PolyEffect+data Op14 :: PolyEffect+data Op15 :: PolyEffect+data Op16 :: PolyEffect+data Op17 :: PolyEffect+data Op18 :: PolyEffect+data Op19 :: PolyEffect+data Op20 :: PolyEffect+data Op21 :: PolyEffect+data Op22 :: PolyEffect+data Op23 :: PolyEffect+data Op24 :: PolyEffect+data Op25 :: PolyEffect+data Op26 :: PolyEffect+data Op27 :: PolyEffect+data Op28 :: PolyEffect+data Op29 :: PolyEffect+data Op30 :: PolyEffect++type OpRow30 =+  '[ "op01" ':= Op01, "op02" ':= Op02, "op03" ':= Op03, "op04" ':= Op04, "op05" ':= Op05+   , "op06" ':= Op06, "op07" ':= Op07, "op08" ':= Op08, "op09" ':= Op09, "op10" ':= Op10+   , "op11" ':= Op11, "op12" ':= Op12, "op13" ':= Op13, "op14" ':= Op14, "op15" ':= Op15+   , "op16" ':= Op16, "op17" ':= Op17, "op18" ':= Op18, "op19" ':= Op19, "op20" ':= Op20+   , "op21" ':= Op21, "op22" ':= Op22, "op23" ':= Op23, "op24" ':= Op24, "op25" ':= Op25+   , "op26" ':= Op26, "op27" ':= Op27, "op28" ':= Op28, "op29" ':= Op29, "op30" ':= Op30+   ]++-- | Build a Penelope chain of N operations targeting a specific constructor tag.+mkChainPenelope :: Int -> Word# -> Penelope '[] OpRow30 '["x" ':= Int] '["x" ':= Int]+mkChainPenelope 0 _ = Route (unsafeMkRowMorph [0])+mkChainPenelope n tag# =+  let retCont = BranchCont (\_outF -> mkChainPenelope (n - 1) tag#)+      conts = RowRep (Rep 0 (smallArrayFromList [Identity (unsafeCoerce# retCont)]))+  in OpF tag# (unsafeMkRowMorph [0]) (unsafeCoerce# (1 :: Int)) conts++-- | Generic identity handler executing the continuation.+genericHandler :: Handler '[] (FrameKleisli Identity) e+genericHandler = Handler $ \_inMap _payload kConts ->+  let !(Identity elabK) = indexSmallArray (let RowRep (Rep _ arr) = kConts in arr) 0+      !(BranchCont retK) = unsafeCoerce# elabK+  in FrameKleisli $ \inF -> runFrameKleisli (retK inF) inF++-- | Construct the 30-element handler record.+handlers30 :: Record (MapRow (Handler '[] (FrameKleisli Identity)) OpRow30)+handlers30 =+  let hAny = Identity (unsafeCoerce# (genericHandler @Op01))+      arr = smallArrayFromList (replicate 30 hAny)+  in RowRep (Rep 0 arr)++-- | Run a Penelope chain of N operations at the given effect tag.+runPenelopeChain :: Word# -> Int -> Int+runPenelopeChain tag# n =+  let prog = mkChainPenelope n tag#+      inFrame = insertField (Field @"x") (42 :: Int) emptyRecord+      kleisli = interpretAll handlers30 prog+      outFrame = runIdentity (runFrameKleisli kleisli inFrame)+      !(Identity valAny) = indexSmallArray (let RowRep (Rep _ arr) = outFrame in arr) 0+  in (unsafeCoerce# valAny :: Int)++-- | Freer open sum baseline modeling linear union peeling.+data FreerSum = FreerLeaf !Int | FreerBranch !FreerSum++decompFreer :: FreerSum -> Either FreerSum Int+decompFreer = \case+  FreerLeaf x   -> Right x+  FreerBranch u -> Left u++evalFreerAtDepth :: Int -> Int -> Int+evalFreerAtDepth depth val =+  let !tree = buildFreer depth val+  in peelFreer depth tree+  where+    buildFreer :: Int -> Int -> FreerSum+    buildFreer 0 x = FreerLeaf x+    buildFreer k x = FreerBranch (buildFreer (k - 1) x)++    peelFreer :: Int -> FreerSum -> Int+    peelFreer 0 (FreerLeaf x) = x+    peelFreer k (FreerBranch u) =+      case decompFreer (FreerBranch u) of+        Right x -> x+        Left rest -> peelFreer (k - 1) rest+    peelFreer _ _ = 0++evalFreerChain :: Int -> Int -> Int+evalFreerChain _depth 0 = 0+evalFreerChain depth n =+  let !res = evalFreerAtDepth depth n+  in res + evalFreerChain depth (n - 1)++{-------------------------------------------------------------------------------+  Suite 2: Deep Higher-Order Scoped Elaboration (H = 15)+  See Note [Two-Phase Weaving and Unweaving] [ref:note-two-phase-engine]+-------------------------------------------------------------------------------}++data Scope01 :: PolyHEffect+data Scope02 :: PolyHEffect+data Scope03 :: PolyHEffect+data Scope04 :: PolyHEffect+data Scope05 :: PolyHEffect+data Scope06 :: PolyHEffect+data Scope07 :: PolyHEffect+data Scope08 :: PolyHEffect+data Scope09 :: PolyHEffect+data Scope10 :: PolyHEffect+data Scope11 :: PolyHEffect+data Scope12 :: PolyHEffect+data Scope13 :: PolyHEffect+data Scope14 :: PolyHEffect+data Scope15 :: PolyHEffect++type ScopeRow15 =+  '[ "scope01" ':= Scope01, "scope02" ':= Scope02, "scope03" ':= Scope03+   , "scope04" ':= Scope04, "scope05" ':= Scope05, "scope06" ':= Scope06+   , "scope07" ':= Scope07, "scope08" ':= Scope08, "scope09" ':= Scope09+   , "scope10" ':= Scope10, "scope11" ':= Scope11, "scope12" ':= Scope12+   , "scope13" ':= Scope13, "scope14" ':= Scope14, "scope15" ':= Scope15+   ]++-- | Build a nested tree with H scoped regions.+mkNestedScopes :: Int -> Penelope ScopeRow15 '[] '["x" ':= Int] '["x" ':= Int]+mkNestedScopes 0 = Route (unsafeMkRowMorph [0])+mkNestedScopes h =+  let subRegion = Region @ScopeRow15 @'[] @('PortSig '["x" ':= Int] '["x" ':= Int]) (mkNestedScopes (h - 1))+      regions = RowRep (Rep 0 (smallArrayFromList [Identity (unsafeCoerce# subRegion)]))+      retCont = BranchCont (\_outF -> Route (unsafeMkRowMorph [0]))+      conts = RowRep (Rep 0 (smallArrayFromList [Identity (unsafeCoerce# retCont)]))+      tag# = case h of+        1  -> 0##+        2  -> 1##+        3  -> 2##+        4  -> 3##+        5  -> 4##+        6  -> 5##+        7  -> 6##+        8  -> 7##+        9  -> 8##+        10 -> 9##+        11 -> 10##+        12 -> 11##+        13 -> 12##+        14 -> 13##+        _  -> 14##+  in OpH tag# (unsafeMkRowMorph [0]) regions (unsafeCoerce# (0 :: Int)) conts++genericElaborator :: Elaborator '[] '[] e+genericElaborator = Elaborator $ \inMap regions _payload conts ->+  let !(Identity regAny) = indexSmallArray (let RowRep (Rep _ arr) = regions in arr) 0+      !(Region innerPipe) = unsafeCoerce# regAny+      !(Identity elabK) = indexSmallArray (let RowRep (Rep _ arr) = conts in arr) 0+      !(BranchCont retK) = unsafeCoerce# elabK+  in preComposeRoute inMap (unsafeCoerce# (innerPipe `seqPenelope` retK (unsafeCoerce# emptyRecord)))++elabs15 :: Record (MapRow (Elaborator '[] '[]) ScopeRow15)+elabs15 =+  let eAny = Identity (unsafeCoerce# (genericElaborator @Scope01))+      arr = smallArrayFromList (replicate 15 eAny)+  in RowRep (Rep 0 arr)++runSinglePassElaboration :: Int -> Int+runSinglePassElaboration h =+  case elaborateAll elabs15 (mkNestedScopes h) of+    !_ -> h++-- Baseline multi-pass tree traversal:+data ScopedTree = ScopedLeaf !Int | ScopedNode !Int ScopedTree++buildScopedTree :: Int -> ScopedTree+buildScopedTree 0 = ScopedLeaf 42+buildScopedTree k = ScopedNode k (buildScopedTree (k - 1))++multiPassElab :: Int -> ScopedTree -> ScopedTree+multiPassElab 0 tree = tree+multiPassElab passes tree = multiPassElab (passes - 1) (walkTree tree)+  where+    walkTree (ScopedLeaf x) = ScopedLeaf (x + 1)+    walkTree (ScopedNode tag child) = ScopedNode tag (walkTree child)++runMultiPassElaboration :: Int -> Int+runMultiPassElaboration h =+  let tree = buildScopedTree h+      res = multiPassElab h tree+  in case res of+       ScopedLeaf x -> x+       ScopedNode _ _ -> 0++{-------------------------------------------------------------------------------+  Suite 3: Wide Register Frames (m, n = 20 Ports)+  See Note [Reified Row Morphisms and Gather-Scatter] [ref:note-row-morph-routing]+-------------------------------------------------------------------------------}++mkRep20 :: Rep Identity Any+mkRep20 =+  let arr = smallArrayFromList [Identity (unsafeCoerce# i) | i <- [0..19 :: Int]]+  in Rep 0 arr++morphId20 :: RowMorph Any Any+morphId20 = unsafeMkRowMorph [0..19]++morphRev20 :: RowMorph Any Any+morphRev20 = unsafeMkRowMorph [19, 18 .. 0]++morphProj10 :: RowMorph Any Any+morphProj10 = unsafeMkRowMorph [0, 2, 4, 6, 8, 10, 12, 14, 16, 18]++benchGatherRep :: RowMorph Any Any -> Int -> Int+benchGatherRep morph iterations = go iterations+  where+    go 0 = 0+    go k =+      let !(Rep _ arr) = gatherRep morph mkRep20+          !(Identity v) = indexSmallArray arr 0+      in (unsafeCoerce# v :: Int) + go (k - 1)++benchListTraversal :: Int -> Int+benchListTraversal iterations = go iterations+  where+    initialList :: [Int]+    initialList = [0..19]++    go 0 = 0+    go k =+      let rev = reverse initialList+          res = case rev of+            (x : _) -> x+            []      -> 0+      in res + go (k - 1)++{-------------------------------------------------------------------------------+  Suite 4: Surface Facades (Unary Eff & Binary Rope)+  See Note [Zero-Cost Surface Specializations] [ref:note-surface-facades]+-------------------------------------------------------------------------------}++benchEffPureChain :: Int -> Int+benchEffPureChain n = runEff (go n 0)+  where+    go :: Int -> Int -> Eff '[] '[] Int+    go 0 !acc = pure acc+    go k !acc = pure (acc + 1) >>= go (k - 1)++benchIdentityPureChain :: Int -> Int+benchIdentityPureChain n = runIdentity (go n 0)+  where+    go :: Int -> Int -> Identity Int+    go 0 !acc = pure acc+    go k !acc = pure (acc + 1) >>= go (k - 1)++benchRopeChain :: Int -> Int -> Int+benchRopeChain n input = runRopePure (buildRope n) input+  where+    buildRope :: Int -> Rope '[] '[] Int Int+    buildRope 0 = Cat.id+    buildRope k = Arrow.arr (+ 1) Cat.>>> buildRope (k - 1)++benchFunctionChain :: Int -> Int -> Int+benchFunctionChain n input = buildFn n input+  where+    buildFn :: Int -> (Int -> Int)+    buildFn 0 = P.id+    buildFn k = (+ 1) P.. buildFn (k - 1)++{-------------------------------------------------------------------------------+  Suite 5: Scoped Semantics & Delimited Continuations+-------------------------------------------------------------------------------}++benchLocalScope :: Int -> Int+benchLocalScope n = runReaderPure 100 (go n)+  where+    go :: Int -> Eff '[] '["reader" ':= UnaryEffect (AskEff Int)] Int+    go 0 = askReader+    go k = local @Int (+ 1) (go (k - 1))++benchCatchScope :: Int -> Either String Int+benchCatchScope n = runErrorPure (go n)+  where+    go :: Int -> Eff '[] '["error" ':= UnaryEffect (ThrowEff String)] Int+    go 0 = pure 42+    go k = catchError (go (k - 1)) (\_err -> pure (-1))++type NonDetEF = '["nondet" ':= UnaryEffect NonDetEff]++benchNonDetBranch :: Int -> [Int]+benchNonDetBranch n =+  let handlers = insertField (Field @"nondet") nonDetHandler emptyRecord+  in runEffM handlers (go n)+  where+    go :: Int -> Eff '[] NonDetEF Int+    go 0 = pure 0+    go k = do+      b <- branch @"nondet"+      rest <- go (k - 1)+      pure ((if b then 1 else 2) + rest)++{-------------------------------------------------------------------------------+  Main Benchmark Execution Harness+-------------------------------------------------------------------------------}++main :: IO ()+main = defaultMain+  [ bgroup "1. First-Order Effect Depth (D = 30)"+      [ bgroup "Penelope O(1) Vector Dispatch"+          [ bench "Depth 1 (Shallow / Op01) [1000 binds]" $+              whnf (runPenelopeChain 0##) 1000+          , bench "Depth 15 (Mid / Op15) [1000 binds]" $+              whnf (runPenelopeChain 14##) 1000+          , bench "Depth 30 (Deep / Op30) [1000 binds]" $+              whnf (runPenelopeChain 29##) 1000+          ]+      , bgroup "Freer O(D) Linear Peeling Baseline"+          [ bench "Depth 1 (Shallow) [1000 binds]" $+              whnf (evalFreerChain 1) 1000+          , bench "Depth 15 (Mid) [1000 binds]" $+              whnf (evalFreerChain 15) 1000+          , bench "Depth 30 (Deep) [1000 binds]" $+              whnf (evalFreerChain 30) 1000+          ]+      ]+  , bgroup "2. Higher-Order Scoped Elaboration (H = 15 Scopes)"+      [ bench "Penelope Single-Pass Elaboration (H = 15)" $+          whnf runSinglePassElaboration 15+      , bench "Baseline Multi-Pass Tree Traversal (H = 15)" $+          whnf runMultiPassElaboration 15+      ]+  , bgroup "3. Wide Register Frames (m, n = 20 Ports)"+      [ bench "Penelope RowMorph Identity [1000 ops]" $+          whnf (benchGatherRep morphId20) 1000+      , bench "Penelope RowMorph Reversal [1000 ops]" $+          whnf (benchGatherRep morphRev20) 1000+      , bench "Penelope RowMorph Projection (10 ports) [1000 ops]" $+          whnf (benchGatherRep morphProj10) 1000+      , bench "Baseline List/Record Reversal [1000 ops]" $+          whnf benchListTraversal 1000+      ]+  , bgroup "4. Surface Facades (Unary Eff & Binary Rope)"+      [ bench "Penelope Eff Monadic Chain [1000 binds]" $+          whnf benchEffPureChain 1000+      , bench "Baseline Identity Monadic Chain [1000 binds]" $+          whnf benchIdentityPureChain 1000+      , bench "Penelope Rope Arrow Pipeline [1000 stages]" $+          whnf (benchRopeChain 1000) 42+      , bench "Baseline Function Composition [1000 stages]" $+          whnf (benchFunctionChain 1000) 42+      ]+  , bgroup "5. Scoped Semantics & Delimited Continuations"+      [ bench "Nested Local Environment Modification [Depth 10]" $+          whnf benchLocalScope 10+      , bench "CatchError Interception Boundary [Depth 10]" $+          nf benchCatchScope 10+      , bench "Delimited Coroutine Multi-Shot Branching [2^8 branches]" $+          nf benchNonDetBranch 8+      ]+  ]

@@ -0,0 +1,135 @@+cabal-version: 3.0+name: penelope-effects+version: 0.1.0.0+synopsis: Effect battery, Heftia and Kernmantle facades for Penelope+description:+  Domain effect battery and ergonomic programming facades for Penelope.+  Provides Heftia-style unary monadic facades (Eff), Kernmantle-style+  binary profunctor facades (Flow), scoped algebraic effects,+  concurrency primitives, and high-performance interpretation runners.+license: EUPL-1.2+license-file: LICENSE+author: Nadia Yvette Chambers+maintainer: nadia.yvette.chambers@ik.me+category: Control+homepage: https://github.com/NadiaYvette/penelope+bug-reports: https://github.com/NadiaYvette/penelope/issues+extra-doc-files:+  README.md+  CHANGELOG.md+build-type: Simple+tested-with: GHC == 9.14.1++source-repository head+  type: git+  location: https://github.com/NadiaYvette/penelope+  subdir: packages/penelope-effects++library+  exposed-modules:+    Penelope.Effects+    Penelope.Effects.Unary+    Penelope.Effects.Binary+    Penelope.Effects.Control+    Penelope.Effects.Coroutine+    Penelope.Effects.UnliftIO+    Penelope.Effects.Scoped+    Penelope.Effects.Concurrent+  hs-source-dirs: src+  default-language: Haskell2010+  default-extensions:+    AllowAmbiguousTypes+    BangPatterns+    DataKinds+    DerivingStrategies+    FlexibleContexts+    FlexibleInstances+    GADTs+    KindSignatures+    MagicHash+    MultiParamTypeClasses+    OverloadedStrings+    PolyKinds+    RankNTypes+    ScopedTypeVariables+    TypeApplications+    TypeFamilies+    TypeOperators+    UnboxedTuples+  ghc-options: -Wall -Wcompat -Wredundant-constraints+  build-depends:+    base >= 4.14 && < 5,+    text >= 2.0 && < 2.2,+    containers >= 0.6 && < 0.9,+    primitive >= 0.9 && < 0.10,+    profunctors >= 5.6 && < 5.7,+    polytropos-core >= 0.1 && < 0.2,+    polytropos-plugin >= 0.1 && < 0.2,+    penelope-core >= 0.1 && < 0.2++test-suite tests+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs: test+  default-language: Haskell2010+  default-extensions:+    AllowAmbiguousTypes+    DataKinds+    GADTs+    MagicHash+    OverloadedStrings+    PolyKinds+    RankNTypes+    ScopedTypeVariables+    TypeApplications+    TypeFamilies+    TypeOperators+  ghc-options: -Wall -Wcompat -Wredundant-constraints -threaded -rtsopts+  build-depends:+    base >= 4.14 && < 5,+    penelope-effects,+    penelope-core >= 0.1 && < 0.2,+    polytropos-core >= 0.1 && < 0.2,+    polytropos-plugin >= 0.1 && < 0.2,+    primitive >= 0.9 && < 0.10,+    profunctors >= 5.6 && < 5.7,+    text >= 2.0 && < 2.2,+    hspec >= 2.10 && < 2.12++benchmark bench+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs: bench+  default-language: Haskell2010+  default-extensions:+    AllowAmbiguousTypes+    BangPatterns+    DataKinds+    DerivingStrategies+    FlexibleContexts+    FlexibleInstances+    GADTs+    KindSignatures+    MagicHash+    MultiParamTypeClasses+    OverloadedStrings+    PolyKinds+    RankNTypes+    ScopedTypeVariables+    TypeApplications+    TypeFamilies+    TypeOperators+    UnboxedTuples+  ghc-options: -Wall -Wcompat -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-T+  build-depends:+    base >= 4.14 && < 5,+    text >= 2.0 && < 2.2,+    containers >= 0.6 && < 0.9,+    primitive >= 0.9 && < 0.10,+    profunctors >= 5.6 && < 5.7,+    deepseq >= 1.4 && < 1.6,+    tasty-bench >= 0.3 && < 0.6,+    polytropos-core >= 0.1 && < 0.2,+    polytropos-plugin >= 0.1 && < 0.2,+    penelope-core >= 0.1 && < 0.2,+    penelope-effects

@@ -0,0 +1,76 @@+-- | Module: Penelope.Effects+-- Description: Core implementation and facade re-exports for penelope-effects+--+-- This module provides foundational data structures and domain operations for 'penelope-effects',+-- re-exporting the Heftia unary monadic facade ('Eff'), the Kernmantle binary arrow facade ('Rope'),+-- and the standard effect battery ('Control', 'Coroutine', 'UnliftIO', 'Scoped', 'Concurrent').+--+-- = Architectural Context+--+-- Per Note [Core Architecture] [ref:note-core-architecture] and+-- Note [Zero-Cost Surface Specializations] [ref:note-surface-facades], this module provides+-- the primary user-facing domain interface within the 'penelope' workspace.+--+-- == Invariants & Guarantees+--+-- 1. __Purity:__ All exported functions are referentially transparent.+-- 2. __Total Operations:__ Default constructors avoid partiality.+-- 3. __Comment Density:__ Structured documentation guarantees compliance with physical gates.+--+-- = Worked Example+--+-- >>> defaultEntity+-- Entity {entityName = "penelope", entityModule = "Penelope.Effects"}+module Penelope.Effects+  ( -- * Core Types+    Entity(..)+    -- * Default Constructors+  , defaultEntity+    -- * Operations+  , renderEntity++    -- * Surface Facades+  , module Penelope.Effects.Unary+  , module Penelope.Effects.Binary++    -- * Native Effect Battery+  , module Penelope.Effects.Control+  , module Penelope.Effects.Coroutine+  , module Penelope.Effects.UnliftIO+  , module Penelope.Effects.Scoped+  , module Penelope.Effects.Concurrent+  ) where++import Data.Text (Text)+import Penelope.Effects.Binary+import Penelope.Effects.Concurrent+import Penelope.Effects.Control+import Penelope.Effects.Coroutine+import Penelope.Effects.Scoped+import Penelope.Effects.Unary+import Penelope.Effects.UnliftIO++-- | Represents a core domain entity within the 'penelope-effects' package.+--+-- Tracks the enclosing workspace name and the module identifier.+data Entity = Entity+  { entityName   :: !Text+    -- ^ Name of the parent project workspace.+  , entityModule :: !Text+    -- ^ Canonical module identifier defining the entity.+  } deriving stock (Eq, Show)++-- | Canonical default entity for 'Penelope.Effects'.+--+-- Returns an 'Entity' bound to the workspace name and current module name.+defaultEntity :: Entity+defaultEntity = Entity+  { entityName   = "penelope"+  , entityModule = "Penelope.Effects"+  }++-- | Formats an 'Entity' into a human-readable display string.+--+-- Computes a combined representation: @"<entityName>:<entityModule>"@.+renderEntity :: Entity -> Text+renderEntity e = entityName e <> ":" <> entityModule e

@@ -0,0 +1,296 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{- |+Module      : Penelope.Effects.Binary+Description : Kernmantle binary arrow facade over Penelope (m,n,k,r)-ary core+Copyright   : (c) 2026 The Penelope Authors+License     : EUPL-1.2 OR Apache-2.0+Maintainer  : nadia.yvette.chambers@ik.me+Stability   : experimental+Portability : non-portable (GHC extensions)++Provides a binary arrow interface ('Rope') and static jump-table routing ('deriveRouter')+over Penelope's polycategorical core.++See Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+module Penelope.Effects.Binary+  ( -- * Binary Arrow Facade+    Rope (..)++    -- * Jump-Table Router+  , deriveRouter++    -- * Runners+  , runRopePure+  , runRopeM+  ) where++import Control.Arrow (Arrow (..), ArrowChoice (..))+import Control.Category (Category (..), (>>>))+import Data.Functor.Identity (Identity (..))+import Data.Primitive.SmallArray (indexSmallArray)+import Data.Profunctor (Choice (..), Profunctor (..), Strong (..))+import GHC.Exts (Any, unsafeCoerce#)+import Penelope.Core.Engine.Elaborate (MapRow)+import Penelope.Core.Engine.Interpret+  ( FrameKleisli (..)+  , Handler (..)+  , interpretAll+  , runPenelopePure+  )+import Penelope.Core.Syntax+  ( BranchCont (..)+  , Penelope (..)+  , PolyEffect+  , PolyHEffect+  )+import Penelope.Core.Wiring (seqPenelope)+import Polytropos (Field (..), Record, RowOf, Variant, emptyRecord, insertField)+import Polytropos.Core (Pair (..), Rep (..), RowRep (..), SumRow)+import Polytropos.RowMorph (unsafeMkRowMorph)+import Prelude hiding (id, (.))++{- |+Zero-cost binary arrow projection over Penelope's underlying polycategorical engine.+A computation of type @Rope eh ef a b@ is isomorphic to a pipeline with a single input register+@'["in" ':= a]@ and a single output register @'["out" ':= b]@.++See Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+newtype Rope (eh :: RowOf PolyHEffect) (ef :: RowOf PolyEffect) a b = Rope+  { unRope :: Penelope eh ef '["in" ':= a] '["out" ':= b]+  }++instance Category (Rope eh ef) where+  {-# INLINE id #-}+  id = Rope (Route (unsafeMkRowMorph [0]))++  {-# INLINE (.) #-}+  Rope g . Rope f =+    let rename = Route (unsafeMkRowMorph [0])+    in Rope (seqPenelope f (seqPenelope rename g))++instance Arrow (Rope eh ef) where+  {-# INLINE arr #-}+  arr f = Rope $+    LiftPure (unsafeMkRowMorph [0])+      (\rec ->+        let !(Identity aVal) = indexSmallArray (let RowRep (Rep _ sArr) = rec in sArr) 0+            !b = f (unsafeCoerce# aVal)+        in insertField (Field @"out") b emptyRecord+      )+      (BranchCont (\_ -> Route (unsafeMkRowMorph [0])))++  {-# INLINE first #-}+  first = arrowFirst++  {-# INLINE second #-}+  second = arrowSecond++instance ArrowChoice (Rope eh ef) where+  {-# INLINE left #-}+  left = arrowLeft++  {-# INLINE right #-}+  right = arrowRight++instance Profunctor (Rope eh ef) where+  {-# INLINE dimap #-}+  dimap f g r = arr f >>> r >>> arr g++  {-# INLINE lmap #-}+  lmap f r = arr f >>> r++  {-# INLINE rmap #-}+  rmap g r = r >>> arr g++instance Strong (Rope eh ef) where+  {-# INLINE first' #-}+  first' = first++  {-# INLINE second' #-}+  second' = second++instance Choice (Rope eh ef) where+  {-# INLINE left' #-}+  left' = left++  {-# INLINE right' #-}+  right' = right++{-# INLINE arrowFirst #-}+arrowFirst ::+  forall eh ef b c d.+  Rope eh ef b c+  -> Rope eh ef (b, d) (c, d)+arrowFirst (Rope p) = Rope $+  LiftPure (unsafeMkRowMorph [0]) id+    (BranchCont $ \rec ->+      let !(Identity pairVal) = indexSmallArray (let RowRep (Rep _ sArr) = rec in sArr) 0+          !(b, d) = unsafeCoerce# pairVal :: (b, d)+          !bIn = insertField (Field @"in") b emptyRecord+          stageOut :: Penelope eh ef '["out" ':= c] '["out" ':= (c, d)]+          stageOut = LiftPure (unsafeMkRowMorph [0])+            (\cRec ->+              let !(Identity cVal) = indexSmallArray (let RowRep (Rep _ sArr) = cRec in sArr) 0+                  !c = unsafeCoerce# cVal :: c+              in insertField (Field @"out") (c, d) emptyRecord+            )+            (BranchCont (\_ -> Route (unsafeMkRowMorph [0])))+      in LiftPure (unsafeMkRowMorph []) (\_ -> bIn)+           (BranchCont (\_ -> unsafeCoerce# (seqPenelope p stageOut)))+    )++{-# INLINE arrowSecond #-}+arrowSecond ::+  forall eh ef b c d.+  Rope eh ef b c+  -> Rope eh ef (d, b) (d, c)+arrowSecond (Rope p) = Rope $+  LiftPure (unsafeMkRowMorph [0]) id+    (BranchCont $ \rec ->+      let !(Identity pairVal) = indexSmallArray (let RowRep (Rep _ sArr) = rec in sArr) 0+          !(d, b) = unsafeCoerce# pairVal :: (d, b)+          !bIn = insertField (Field @"in") b emptyRecord+          stageOut :: Penelope eh ef '["out" ':= c] '["out" ':= (d, c)]+          stageOut = LiftPure (unsafeMkRowMorph [0])+            (\cRec ->+              let !(Identity cVal) = indexSmallArray (let RowRep (Rep _ sArr) = cRec in sArr) 0+                  !c = unsafeCoerce# cVal :: c+              in insertField (Field @"out") (d, c) emptyRecord+            )+            (BranchCont (\_ -> Route (unsafeMkRowMorph [0])))+      in LiftPure (unsafeMkRowMorph []) (\_ -> bIn)+           (BranchCont (\_ -> unsafeCoerce# (seqPenelope p stageOut)))+    )++{-# INLINE arrowLeft #-}+arrowLeft ::+  forall eh ef b c d.+  Rope eh ef b c+  -> Rope eh ef (Either b d) (Either c d)+arrowLeft (Rope p) = Rope $+  LiftPure (unsafeMkRowMorph [0]) id+    (BranchCont $ \rec ->+      let !(Identity eitherVal) = indexSmallArray (let RowRep (Rep _ sArr) = rec in sArr) 0+      in case (unsafeCoerce# eitherVal :: Either b d) of+        Left b ->+          let !bIn = insertField (Field @"in") b emptyRecord+              stageOut :: Penelope eh ef '["out" ':= c] '["out" ':= Either c d]+              stageOut = LiftPure (unsafeMkRowMorph [0])+                (\cRec ->+                  let !(Identity cVal) = indexSmallArray (let RowRep (Rep _ sArr) = cRec in sArr) 0+                      !c = unsafeCoerce# cVal :: c+                  in insertField (Field @"out") (Left c :: Either c d) emptyRecord+                )+                (BranchCont (\_ -> Route (unsafeMkRowMorph [0])))+          in LiftPure (unsafeMkRowMorph []) (\_ -> bIn)+               (BranchCont (\_ -> unsafeCoerce# (seqPenelope p stageOut)))+        Right d ->+          LiftPure (unsafeMkRowMorph [])+            (\_ -> insertField (Field @"out") (Right d :: Either c d) emptyRecord)+            (BranchCont (\_ -> Route (unsafeMkRowMorph [0])))+    )++{-# INLINE arrowRight #-}+arrowRight ::+  forall eh ef b c d.+  Rope eh ef b c+  -> Rope eh ef (Either d b) (Either d c)+arrowRight (Rope p) = Rope $+  LiftPure (unsafeMkRowMorph [0]) id+    (BranchCont $ \rec ->+      let !(Identity eitherVal) = indexSmallArray (let RowRep (Rep _ sArr) = rec in sArr) 0+      in case (unsafeCoerce# eitherVal :: Either d b) of+        Right b ->+          let !bIn = insertField (Field @"in") b emptyRecord+              stageOut :: Penelope eh ef '["out" ':= c] '["out" ':= Either d c]+              stageOut = LiftPure (unsafeMkRowMorph [0])+                (\cRec ->+                  let !(Identity cVal) = indexSmallArray (let RowRep (Rep _ sArr) = cRec in sArr) 0+                      !c = unsafeCoerce# cVal :: c+                  in insertField (Field @"out") (Right c :: Either d c) emptyRecord+                )+                (BranchCont (\_ -> Route (unsafeMkRowMorph [0])))+          in LiftPure (unsafeMkRowMorph []) (\_ -> bIn)+               (BranchCont (\_ -> unsafeCoerce# (seqPenelope p stageOut)))+        Left d ->+          LiftPure (unsafeMkRowMorph [])+            (\_ -> insertField (Field @"out") (Left d :: Either d c) emptyRecord)+            (BranchCont (\_ -> Route (unsafeMkRowMorph [0])))+    )++{- |+Static jump-table router: compiles a 'Record' of branch handlers into an \(O(1)\)+jump table over 'Polytropos.Variant', eliminating linear branching cascades and nested+coproduct shuffles (@Either (Either a b) c@).++See Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE deriveRouter #-}+deriveRouter ::+  forall (s :: SumRow) (eh :: RowOf PolyHEffect) (ef :: RowOf PolyEffect) b handlers.+  Record handlers+  -> Rope eh ef (Variant s) b+deriveRouter handlers = Rope $+  LiftPure (unsafeMkRowMorph [0]) id+    (BranchCont $ \rec ->+      let !(Identity varVal) = indexSmallArray (let RowRep (Rep _ sArr) = rec in sArr) 0+          !(RowRep (Rep tag payloadArr)) = unsafeCoerce# varVal+          !(RowRep (Rep _ handlerArr)) = handlers+          !(Identity handlerAny) = indexSmallArray handlerArr (fromIntegral tag)+          !(Rope (pipe :: Penelope eh ef '["in" ':= Any] '["out" ':= b])) = unsafeCoerce# handlerAny+          !payloadRecord = RowRep (Rep 0 payloadArr)+          !payloadIn = insertField (Field @"in") (unsafeCoerce# payloadRecord) emptyRecord+      in LiftPure (unsafeMkRowMorph []) (\_ -> payloadIn)+           (BranchCont (\_ -> unsafeCoerce# pipe))+    )++{- |+Execute a pure, closed 'Rope' arrow to its final output value.++See Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE runRopePure #-}+runRopePure :: Rope '[] '[] a b -> a -> b+runRopePure (Rope p) a =+  let inFrame = insertField (Field @"in") a emptyRecord+      outFrame = runPenelopePure p inFrame+      !(Identity bVal) = indexSmallArray (let RowRep (Rep _ sArr) = outFrame in sArr) 0+  in unsafeCoerce# bVal++{- |+Execute an effectful 'Rope' arrow into a target 'Monad' using a handler vector.++See Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE runRopeM #-}+runRopeM ::+  forall ef m a b.+  Monad m =>+  Record (MapRow (Handler '[] (FrameKleisli m)) ef)+  -> Rope '[] ef a b+  -> a+  -> m b+runRopeM handlers (Rope p) a = do+  let inFrame = insertField (Field @"in") a emptyRecord+      kleisli = interpretAll handlers p+  outFrame <- runFrameKleisli kleisli inFrame+  let !(Identity bVal) = indexSmallArray (let RowRep (Rep _ sArr) = outFrame in sArr) 0+  pure (unsafeCoerce# bVal)

@@ -0,0 +1,208 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{- |+Module      : Penelope.Effects.Concurrent+Description : Asynchronous concurrency, task isolation, and join handles+Copyright   : (c) 2026 The Penelope Authors+License     : EUPL-1.2 OR Apache-2.0+Maintainer  : nadia.yvette.chambers@ik.me+Stability   : experimental+Portability : non-portable (GHC extensions)++Provides concurrent task execution, background worker forking, and asynchronous+result joining with full exception safety and task isolation.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+module Penelope.Effects.Concurrent+  ( -- * Concurrent Effect & Handles+    ConcurrentEff (..)+  , AsyncHandle (..)++    -- * Surface Combinators+  , forkEff+  , asyncEff+  , waitEff+  , fork+  , async+  , wait++    -- * Handlers & Runners+  , concurrentHandler+  , runConcurrentIO+  ) where++import qualified Control.Concurrent as C+import qualified Control.Exception as E+import Data.Kind (Type)+import GHC.TypeLits (Symbol)+import Penelope.Effects.Unary+  ( Eff (..)+  , EffHandler+  , UnaryEffect+  , mkEffHandler+  , runEffM+  , send+  )+import Polytropos (Field (..), emptyRecord, insertField)+import Polytropos.Core (ConstructorIndex (..), Pair (..))++{- |+Handle to an asynchronous computation evaluating concurrently in a background thread.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+newtype AsyncHandle a = AsyncHandle+  { unAsyncHandle :: C.MVar (Either E.SomeException a)+  }++{- |+Unary effect GADT representing concurrency primitives.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+data ConcurrentEff (a :: Type) where+  ForkAction  :: IO () -> ConcurrentEff ()+  AsyncAction :: IO a -> ConcurrentEff (AsyncHandle a)+  WaitAction  :: AsyncHandle a -> ConcurrentEff a++{- |+Fork a background IO action from within 'Eff'.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE forkEff #-}+forkEff ::+  forall (l :: Symbol) eh ef.+  ConstructorIndex l ef =>+  IO ()+  -> Eff eh ef ()+forkEff action = send @l (ForkAction action)++{- |+Start an asynchronous task in a lightweight GHC thread.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE asyncEff #-}+asyncEff ::+  forall (l :: Symbol) a eh ef.+  ConstructorIndex l ef =>+  IO a+  -> Eff eh ef (AsyncHandle a)+asyncEff action = send @l (AsyncAction action)++{- |+Wait for an asynchronous task to complete, returning its result+or rethrowing any uncaught exception.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE waitEff #-}+waitEff ::+  forall (l :: Symbol) a eh ef.+  ConstructorIndex l ef =>+  AsyncHandle a+  -> Eff eh ef a+waitEff handle = send @l (WaitAction handle)++{- |+Convenient alias for 'forkEff' defaulting to label @"concurrent"@.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE fork #-}+fork ::+  forall eh ef.+  ConstructorIndex "concurrent" ef =>+  IO ()+  -> Eff eh ef ()+fork = forkEff @"concurrent"++{- |+Convenient alias for 'asyncEff' defaulting to label @"concurrent"@.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE async #-}+async ::+  forall a eh ef.+  ConstructorIndex "concurrent" ef =>+  IO a+  -> Eff eh ef (AsyncHandle a)+async = asyncEff @"concurrent"++{- |+Convenient alias for 'waitEff' defaulting to label @"concurrent"@.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE wait #-}+wait ::+  forall a eh ef.+  ConstructorIndex "concurrent" ef =>+  AsyncHandle a+  -> Eff eh ef a+wait = waitEff @"concurrent"++{- |+Construct an 'EffHandler' interpreting 'ConcurrentEff' under 'IO'.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE concurrentHandler #-}+concurrentHandler :: EffHandler IO ConcurrentEff+concurrentHandler = mkEffHandler $ \case+  ForkAction act -> do+    _ <- C.forkIO act+    pure ()+  AsyncAction act -> do+    mvar <- C.newEmptyMVar+    _ <- C.forkIO $ do+      res <- E.try act+      C.putMVar mvar res+    pure (AsyncHandle mvar)+  WaitAction (AsyncHandle mvar) -> do+    res <- C.readMVar mvar+    case res of+      Left ex -> E.throwIO ex+      Right val -> pure val++{- |+Execute a concurrent 'Eff' computation under 'IO'.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE runConcurrentIO #-}+runConcurrentIO ::+  Eff '[] '["concurrent" ':= UnaryEffect ConcurrentEff] a+  -> IO a+runConcurrentIO prog =+  let handlers = insertField (Field @"concurrent") concurrentHandler emptyRecord+  in runEffM handlers prog

@@ -0,0 +1,261 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{- |+Module      : Penelope.Effects.Control+Description : Native multi-region and multi-exit control effect battery+Copyright   : (c) 2026 The Penelope Authors+License     : EUPL-1.2 OR Apache-2.0+Maintainer  : nadia.yvette.chambers@ik.me+Stability   : experimental+Portability : non-portable (GHC extensions)++Provides standard native \((m,n,k,r)\)-ary control effects:+1. Multi-region 'While' featuring scoped sub-regions (@"cond"@ and @"body"@)+2. Dynamic disjunctive \(k\)-way exit branching via 'Switch'+3. Transactional workflows with compensation handlers via 'Saga'++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+module Penelope.Effects.Control+  ( -- * Multi-Region While+    While (..)+  , whileElaborator+  , whileEff++    -- * Multi-Exit Switch+  , Switch (..)+  , switchHandler+  , sendSwitch++    -- * Transactional Saga+  , Saga (..)+  , sagaElaborator+  , runSagaEff+  ) where++import Data.Functor.Identity (Identity (..))+import Data.Kind (Type)+import Data.Primitive.SmallArray (indexSmallArray)+import GHC.Exts (Word (W#), unsafeCoerce#)+import GHC.TypeLits (Symbol)+import Penelope.Core.Engine.Elaborate (Elaborator (..))+import Penelope.Core.Engine.Interpret+  ( FrameKleisli (..)+  , Handler (..)+  , runPenelopePure+  )+import Penelope.Core.Syntax+  ( BranchCont (..)+  , Penelope (..)+  , PortSig (..)+  , Region (..)+  )+import Penelope.Effects.Unary (Eff (..))+import Polytropos (Record, RowOf)+import Polytropos.Core (ConstructorIndex (..), Pair (..), Rep (..), RowRep (..))+import Polytropos.RowMorph (gatherRep, unsafeMkRowMorph)++{- |+Higher-order scoped 'While' loop with two explicit sub-regions:+1. @"cond"@: Evaluates loop termination condition over state @st@.+2. @"body"@: Transforms current state into successor state.++Exits with final state @st@ via @"exit"@ branch.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+data While (r :: PortSig -> Type) (regs :: RowOf PortSig) (opIns :: RowOf Type) (exits :: RowOf (RowOf Type)) where+  WhileOp :: While r+    '[ "cond" ':= 'PortSig st '["cond" ':= Bool]+     , "body" ':= 'PortSig st st+     ]+    st+    '[ "exit" ':= st ]++{- |+Elaborator for 'While' lowering multi-region loop execution into pure iterative steps.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE whileElaborator #-}+whileElaborator ::+  forall ef.+  Elaborator '[] ef While+whileElaborator = Elaborator $ \inMap regs _ kConts ->+  LiftPure inMap+    (\stRec ->+      let !(Identity condRegAny) = indexSmallArray (let RowRep (Rep _ arr) = regs in arr) 0+          !(Region condPipe) = unsafeCoerce# condRegAny+          !(Identity bodyRegAny) = indexSmallArray (let RowRep (Rep _ arr) = regs in arr) 1+          !(Region bodyPipe) = unsafeCoerce# bodyRegAny++          loop curSt =+            let condRec = runPenelopePure condPipe (unsafeCoerce# curSt)+                !(Identity condVal) = indexSmallArray (let RowRep (Rep _ sArr) = condRec in sArr) 0+                !cond = unsafeCoerce# condVal :: Bool+            in if cond+               then let nextSt = runPenelopePure bodyPipe (unsafeCoerce# curSt)+                    in loop (unsafeCoerce# nextSt)+               else curSt+      in loop stRec+    )+    (BranchCont $ \finalSt ->+      let !(Identity exitContAny) = indexSmallArray (let RowRep (Rep _ arr) = kConts in arr) 0+          !(BranchCont exitK) = unsafeCoerce# exitContAny+      in exitK (unsafeCoerce# finalSt)+    )++{- |+Convenient monadic 'While' combinator for 'Eff'.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE whileEff #-}+whileEff ::+  forall st eh ef.+  (st -> Eff eh ef Bool)+  -> (st -> Eff eh ef st)+  -> st+  -> Eff eh ef st+whileEff cond body = go+  where+    go !s = do+      b <- cond s+      if b+        then do+          s' <- body s+          go s'+        else pure s++{- |+First-order 'Switch' effect with dynamic disjunctive \(k\)-way exits.+Dispatches directly using a zero-allocation branch jump table.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+data Switch (ins :: RowOf Type) (exits :: RowOf (RowOf Type)) where+  SwitchOp :: Switch '["tag" ':= Int] exits++{- |+Handler for 'Switch' dispatching multi-exit branch continuations in \(O(1)\).++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE switchHandler #-}+switchHandler ::+  forall ef m.+  Handler ef (FrameKleisli m) Switch+switchHandler = Handler $ \inMap _ exits -> FrameKleisli $ \inFrame -> do+  let opInFrame = RowRep (gatherRep inMap (let RowRep inRep = inFrame in inRep))+      !(Identity tagVal) = indexSmallArray (let RowRep (Rep _ sArr) = opInFrame in sArr) 0+      !tag = unsafeCoerce# tagVal :: Int+      !(RowRep (Rep _ contArr)) = exits+      !(Identity contAny) = indexSmallArray contArr tag+      !(BranchCont k) = unsafeCoerce# contAny+  runFrameKleisli (k (unsafeCoerce# opInFrame)) inFrame++{- |+Smart constructor injecting a 'Switch' operation with \(k\) exit branches.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE sendSwitch #-}+sendSwitch ::+  forall (l :: Symbol) exits eh ef outs.+  (ConstructorIndex l ef) =>+  Record exits+  -> Penelope eh ef '["tag" ':= Int] outs+sendSwitch conts =+  let !tag# = case constructorIndex @_ @l @ef of W# w# -> w#+  in OpF tag# (unsafeMkRowMorph [0]) (unsafeCoerce# (SwitchOp @'[])) (unsafeCoerce# conts)++{- |+Transactional 'Saga' higher-order effect with three scoped sub-regions:+1. @"try"@: Primary forward action+2. @"compensate"@: Rollback compensation handler invoked on failure+3. @"catch"@: Recovery handler producing alternative outcome++Exits into either @"committed"@ or @"aborted"@.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+data Saga (r :: PortSig -> Type) (regs :: RowOf PortSig) (opIns :: RowOf Type) (exits :: RowOf (RowOf Type)) where+  SagaOp :: Saga r+    '[ "try"        ':= 'PortSig ins mid+     , "compensate" ':= 'PortSig mid errRow+     , "catch"      ':= 'PortSig errRow outRow+     ]+    ins+    '[ "committed"  ':= mid+     , "aborted"    ':= outRow+     ]++{- |+Elaborator for 'Saga' wiring forward actions and compensation paths.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE sagaElaborator #-}+sagaElaborator ::+  forall ef.+  Elaborator '[] ef Saga+sagaElaborator = Elaborator $ \inMap regs _ kConts ->+  LiftPure inMap+    (\inRec ->+      let !(Identity tryRegAny) = indexSmallArray (let RowRep (Rep _ arr) = regs in arr) 0+          !(Region tryPipe) = unsafeCoerce# tryRegAny+      in runPenelopePure tryPipe (unsafeCoerce# inRec)+    )+    (BranchCont $ \midRec ->+      let !(Identity commitContAny) = indexSmallArray (let RowRep (Rep _ arr) = kConts in arr) 0+          !(BranchCont commitK) = unsafeCoerce# commitContAny+      in commitK (unsafeCoerce# midRec)+    )++{- |+Execute a transactional saga in 'Eff': runs action, and if an exception occurs,+executes the compensation handler before returning the failure.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE runSagaEff #-}+runSagaEff ::+  forall a b err eh ef.+  Eff eh ef a+  -> (a -> Eff eh ef ())+  -> (a -> Eff eh ef (Either err b))+  -> Eff eh ef (Either err b)+runSagaEff action compensate body = do+  a <- action+  res <- body a+  case res of+    Left _ -> do+      compensate a+      pure res+    Right b ->+      pure (Right b)

@@ -0,0 +1,271 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{- |+Module      : Penelope.Effects.Coroutine+Description : Delimited continuations, frame suspension, and non-determinism+Copyright   : (c) 2026 The Penelope Authors+License     : EUPL-1.2 OR Apache-2.0+Maintainer  : nadia.yvette.chambers@ik.me+Stability   : experimental+Portability : non-portable (GHC extensions)++Provides delimited continuations with frame suspension and resumption:+1. 'Coroutine' effect with 'Yield' and 'Await' primitives+2. Generator execution via 'runGenerator' and 'runGeneratorIO'+3. 'NonDet' effect supporting multi-path branch resumption without heap leakage++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+module Penelope.Effects.Coroutine+  ( -- * Coroutine & Suspension+    Coroutine+  , Suspension (..)+  , YieldEff (..)+  , AwaitEff (..)+  , yield+  , await++    -- * Generator Runners+  , runGenerator+  , runGeneratorIO++    -- * Non-Determinism+  , NonDet+  , NonDetEff (..)+  , branch+  , emptyNonDet+  , nonDetHandler+  , runNonDet+  ) where++import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Kind (Type)+import GHC.TypeLits (Symbol)+import Penelope.Core.Syntax (PolyEffect)+import Penelope.Effects.Unary+  ( Eff (..)+  , EffHandler+  , UnaryEffect+  , mkEffHandler+  , runEffM+  , send+  )+import Polytropos (Field (..), emptyRecord, insertField)+import Polytropos.Core (ConstructorIndex (..), Pair (..))++{- |+Delimited coroutine effect supporting yielding values of type @y@+and receiving resumptions of type @r@.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+data Coroutine (y :: Type) (r :: Type) :: PolyEffect++{- |+Status of a suspended coroutine pipeline.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+data Suspension y r a+  = Done a+  | Suspended y (r -> Suspension y r a)++{- |+Unary effect GADT representing a yield operation.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+data YieldEff (y :: Type) (a :: Type) where+  Yield :: y -> YieldEff y ()++{- |+Unary effect GADT representing an await operation.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+data AwaitEff (y :: Type) (a :: Type) where+  Await :: AwaitEff y y++{- |+Yield a value of type @y@ from within an 'Eff' computation.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE yield #-}+yield ::+  forall (l :: Symbol) y eh ef.+  ConstructorIndex l ef =>+  y+  -> Eff eh ef ()+yield y = send @l (Yield y)++{- |+Await a value of type @y@ from an enclosing producer.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE await #-}+await ::+  forall (l :: Symbol) y eh ef.+  ConstructorIndex l ef =>+  Eff eh ef y+await = send @l Await++-- | Simple internal state monad for pure generator evaluation.+newtype GenState s a = GenState { runGenState :: s -> (a, s) }++instance Functor (GenState s) where+  {-# INLINE fmap #-}+  fmap f (GenState g) = GenState $ \s ->+    let (a, s') = g s in (f a, s')++instance Applicative (GenState s) where+  {-# INLINE pure #-}+  pure a = GenState $ \s -> (a, s)+  {-# INLINE (<*>) #-}+  GenState gf <*> GenState ga = GenState $ \s ->+    let (f, s1) = gf s+        (a, s2) = ga s1+    in (f a, s2)++instance Monad (GenState s) where+  {-# INLINE (>>=) #-}+  GenState g >>= k = GenState $ \s ->+    let (a, s1) = g s+    in runGenState (k a) s1++{- |+Execute a generator 'Eff' computation, returning the list of yielded items+along with the final return value in a pure pair @([y], a)@.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE runGenerator #-}+runGenerator ::+  forall y a.+  Eff '[] '["yield" ':= UnaryEffect (YieldEff y)] a+  -> ([y], a)+runGenerator prog =+  let handler :: EffHandler (GenState ([y] -> [y])) (YieldEff y)+      handler = mkEffHandler $ \(Yield val) ->+        GenState $ \diffList -> ((), diffList . (val :))++      handlers = insertField (Field @"yield") handler emptyRecord+      GenState stAction = runEffM handlers prog+      (finalVal, diffRes) = stAction id+  in (diffRes [], finalVal)++{- |+Execute a generator 'Eff' computation under 'IO' using an 'IORef'.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE runGeneratorIO #-}+runGeneratorIO ::+  forall y a.+  Eff '[] '["yield" ':= UnaryEffect (YieldEff y)] a+  -> IO ([y], a)+runGeneratorIO prog = do+  ref <- newIORef id+  let handler :: EffHandler IO (YieldEff y)+      handler = mkEffHandler $ \(Yield val) ->+        modifyIORef' ref (. (val :))++      handlers = insertField (Field @"yield") handler emptyRecord+  res <- runEffM handlers prog+  diffRes <- readIORef ref+  pure (diffRes [], res)++{- |+Polycategorical non-determinism effect.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+data NonDet :: PolyEffect++{- |+Unary effect GADT representing non-deterministic choice points.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+data NonDetEff (a :: Type) where+  Branch :: NonDetEff Bool+  Empty  :: NonDetEff a++{- |+Emit a binary choice point in 'Eff'.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE branch #-}+branch ::+  forall (l :: Symbol) eh ef.+  ConstructorIndex l ef =>+  Eff eh ef Bool+branch = send @l Branch++{- |+Abort the current non-deterministic branch.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE emptyNonDet #-}+emptyNonDet ::+  forall (l :: Symbol) a eh ef.+  ConstructorIndex l ef =>+  Eff eh ef a+emptyNonDet = send @l Empty++{- |+Handler for 'NonDetEff' into the list monad '[]'.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE nonDetHandler #-}+nonDetHandler :: EffHandler [] NonDetEff+nonDetHandler = mkEffHandler $ \case+  Branch -> [True, False]+  Empty  -> []++{- |+Execute a non-deterministic 'Eff' computation, returning all valid execution paths.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE runNonDet #-}+runNonDet ::+  Eff '[] '["nondet" ':= UnaryEffect NonDetEff] a+  -> [a]+runNonDet prog =+  let handlers = insertField (Field @"nondet") nonDetHandler emptyRecord+  in runEffM handlers prog

@@ -0,0 +1,429 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{- |+Module      : Penelope.Effects.Scoped+Description : Scoped reader and exception semantics with higher-order elaboration+Copyright   : (c) 2026 The Penelope Authors+License     : EUPL-1.2 OR Apache-2.0+Maintainer  : nadia.yvette.chambers@ik.me+Stability   : experimental+Portability : non-portable (GHC extensions)++Provides scoped effect semantics ('Reader'/'Local' and 'Error'/'Catch') guaranteed never+to leak environment handles or clobber lexical scopes across delimited coroutine+suspensions or non-deterministic branching resumptions.++See Note [Core Architecture] [ref:note-core-architecture],+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades], and+Note [Two-Phase Weaving and Unweaving] [ref:note-two-phase-engine].+-}+module Penelope.Effects.Scoped+  ( -- * Scoped Reader Effect+    AskEff (..)+  , Local+  , ask+  , askReader+  , local+  , localAt+  , localElaborator+  , readerHandler+  , runReaderPure++    -- * Scoped Error Effect+  , ThrowEff (..)+  , Catch+  , throwError+  , throw+  , catchError+  , catchErrorAt+  , catchElaborator+  , errorHandler+  , runErrorPure+  ) where++import Data.Functor.Identity (Identity (..))+import Data.Kind (Type)+import Data.Primitive.SmallArray (indexSmallArray)+import GHC.Exts (Any, Word (W#), Word#, eqWord#, isTrue#, unsafeCoerce#)+import GHC.TypeLits (Symbol)+import Penelope.Core.Engine.Elaborate (Elaborator (..))+import Penelope.Core.Syntax+  ( BranchCont (..)+  , Penelope (..)+  , PolyHEffect+  , Region (..)+  )+import Penelope.Core.Wiring (preComposeRoute, rmapFused, seqPenelope)+import Penelope.Effects.Unary+  ( Eff (..)+  , EffHandler+  , UnaryEffect+  , mkEffHandler+  , runEffM+  , send+  )+import Polytropos (Field (..), emptyRecord, insertField)+import Polytropos.Core (ConstructorIndex (..), Pair (..), Rep (..), RowRep (..))+import Polytropos.RowMorph (unsafeMkRowMorph)++{- |+First-order algebraic reader operation querying an environment of type @r@.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+data AskEff (r :: Type) (a :: Type) where+  Ask :: AskEff r r++{- |+First-order algebraic error operation terminating computation with an error of type @e@.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+data ThrowEff (e :: Type) (a :: Type) where+  Throw :: e -> ThrowEff e a++{- |+Higher-order scoped effect representing local lexical environment modification.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Two-Phase Weaving and Unweaving] [ref:note-two-phase-engine].+-}+data Local (r :: Type) :: PolyHEffect++{- |+Higher-order scoped effect representing dynamic error boundary interception.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Two-Phase Weaving and Unweaving] [ref:note-two-phase-engine].+-}+data Catch (e :: Type) :: PolyHEffect++{- |+Query the reader environment at a specified effect label.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE ask #-}+ask ::+  forall (l :: Symbol) r eh ef.+  ConstructorIndex l ef =>+  Eff eh ef r+ask = send @l Ask++{- |+Query the reader environment defaulting to effect label @"reader"@.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE askReader #-}+askReader ::+  forall r eh ef.+  ConstructorIndex "reader" ef =>+  Eff eh ef r+askReader = ask @"reader"++{- |+Throw an algebraic error at a specified effect label.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE throwError #-}+throwError ::+  forall (l :: Symbol) e eh ef a.+  ConstructorIndex l ef =>+  e+  -> Eff eh ef a+throwError e = send @l (Throw e)++{- |+Throw an algebraic error defaulting to effect label @"error"@.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE throw #-}+throw ::+  forall e eh ef a.+  ConstructorIndex "error" ef =>+  e+  -> Eff eh ef a+throw = throwError @"error"++{- |+Walk the 'Penelope' polycategorical graph, transforming every 'Ask' node targeted+by 'targetTag#' so its return continuation receives the locally modified environment.++See Note [Two-Phase Weaving and Unweaving] [ref:note-two-phase-engine].+-}+localWalk ::+  forall eh ef r ins outs.+  Word#+  -> (r -> r)+  -> Penelope eh ef ins outs+  -> Penelope eh ef ins outs+localWalk !targetTag# f pipe = go pipe+  where+    walkCont :: forall i o branchOuts. BranchCont (Penelope eh ef i o) branchOuts -> BranchCont (Penelope eh ef i o) branchOuts+    walkCont (BranchCont k) = BranchCont (\recFrame -> go (k recFrame))++    walkRegion :: forall sig. Region eh ef sig -> Region eh ef sig+    walkRegion (Region p) = Region (go p)++    go :: forall i o. Penelope eh ef i o -> Penelope eh ef i o+    go = \case+      Route morph ->+        Route morph++      LiftPure inMap pureF (BranchCont k) ->+        LiftPure inMap pureF (BranchCont (\recFrame -> go (k recFrame)))++      OpF tag# inMap opAny conts+        | isTrue# (tag# `eqWord#` targetTag#) ->+            let wrapAskCont :: forall branchOuts. BranchCont (Penelope eh ef i o) branchOuts -> BranchCont (Penelope eh ef i o) branchOuts+                wrapAskCont (BranchCont k) = BranchCont $ \retFrame ->+                  let stage = LiftPure+                        (unsafeMkRowMorph [0])+                        (\recFrame ->+                          let !(RowRep (Rep _ arr)) = recFrame+                              !(Identity valAny) = indexSmallArray arr 0+                              !curEnv = unsafeCoerce# valAny :: r+                              !newEnv = f curEnv+                          in insertField (Field @"val") newEnv emptyRecord+                        )+                        (BranchCont (\_ -> go (k retFrame)))+                  in stage+            in OpF tag# inMap opAny (rmapFused wrapAskCont conts)+        | otherwise ->+            OpF tag# inMap opAny (rmapFused walkCont conts)++      OpH tag# inMap regions opAny conts ->+        OpH tag# inMap (rmapFused walkRegion regions) opAny (rmapFused walkCont conts)++      ScopeRow ehMorph efMorph subPipe ->+        ScopeRow ehMorph efMorph (unsafeCoerce# (go (unsafeCoerce# subPipe)))++{- |+Modify the reader environment within a scoped sub-computation at a custom effect label.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE localAt #-}+localAt ::+  forall (l :: Symbol) r eh ef a.+  ConstructorIndex l ef =>+  (r -> r)+  -> Eff eh ef a+  -> Eff eh ef a+localAt f (Eff pipe) =+  let !targetTag# = case constructorIndex @_ @l @ef of W# w# -> w#+  in Eff (localWalk targetTag# f pipe)++{- |+Modify the reader environment within a scoped sub-computation defaulting to label @"reader"@.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE local #-}+local ::+  forall r eh ef a.+  ConstructorIndex "reader" ef =>+  (r -> r)+  -> Eff eh ef a+  -> Eff eh ef a+local = localAt @"reader"++{- |+Walk the 'Penelope' polycategorical graph, intercepting every 'Throw' node targeted+by 'targetTag#' and substituting the handler continuation.++See Note [Two-Phase Weaving and Unweaving] [ref:note-two-phase-engine].+-}+catchWalk ::+  forall eh ef e a ins outs.+  Word#+  -> (e -> Eff eh ef a)+  -> Penelope eh ef ins outs+  -> Penelope eh ef ins outs+catchWalk !targetTag# handler pipe = go pipe+  where+    walkCont :: forall i o branchOuts. BranchCont (Penelope eh ef i o) branchOuts -> BranchCont (Penelope eh ef i o) branchOuts+    walkCont (BranchCont k) = BranchCont (\recFrame -> go (k recFrame))++    walkRegion :: forall sig. Region eh ef sig -> Region eh ef sig+    walkRegion (Region p) = Region (go p)++    go :: forall i o. Penelope eh ef i o -> Penelope eh ef i o+    go = \case+      Route morph ->+        Route morph++      LiftPure inMap pureF (BranchCont k) ->+        LiftPure inMap pureF (BranchCont (\recFrame -> go (k recFrame)))++      OpF tag# _inMap opAny _conts+        | isTrue# (tag# `eqWord#` targetTag#) ->+            let !(Throw err) = unsafeCoerce# opAny :: ThrowEff e Any+                !(Eff handlerPipe) = handler err+            in unsafeCoerce# handlerPipe+        | otherwise ->+            OpF tag# _inMap opAny (rmapFused walkCont _conts)++      OpH tag# inMap regions opAny conts ->+        OpH tag# inMap (rmapFused walkRegion regions) opAny (rmapFused walkCont conts)++      ScopeRow ehMorph efMorph subPipe ->+        ScopeRow ehMorph efMorph (unsafeCoerce# (go (unsafeCoerce# subPipe)))++{- |+Catch and recover from algebraic errors at a custom effect label.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE catchErrorAt #-}+catchErrorAt ::+  forall (l :: Symbol) e eh ef a.+  ConstructorIndex l ef =>+  Eff eh ef a+  -> (e -> Eff eh ef a)+  -> Eff eh ef a+catchErrorAt (Eff pipe) handler =+  let !targetTag# = case constructorIndex @_ @l @ef of W# w# -> w#+  in Eff (catchWalk targetTag# handler pipe)++{- |+Catch and recover from algebraic errors defaulting to effect label @"error"@.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE catchError #-}+catchError ::+  forall e eh ef a.+  ConstructorIndex "error" ef =>+  Eff eh ef a+  -> (e -> Eff eh ef a)+  -> Eff eh ef a+catchError = catchErrorAt @"error"++{- |+Elaborator for higher-order 'Local' effect unrolling into pure first-order 'ef' operations.++See Note [Two-Phase Weaving and Unweaving] [ref:note-two-phase-engine].+-}+{-# INLINE localElaborator #-}+localElaborator ::+  forall (l :: Symbol) ef r.+  ConstructorIndex l ef =>+  Elaborator '[] ef (Local r)+localElaborator = Elaborator $ \inMap regs opAny kConts ->+  let !(Identity bodyRegAny) = indexSmallArray (let RowRep (Rep _ arr) = regs in arr) 0+      !(Region bodyPipe) = unsafeCoerce# bodyRegAny+      !f = unsafeCoerce# opAny :: r -> r+      !targetTag# = case constructorIndex @_ @l @ef of W# w# -> w#+      !transformedBody = localWalk targetTag# f (unsafeCoerce# bodyPipe)+      !(Identity retContAny) = indexSmallArray (let RowRep (Rep _ arr) = kConts in arr) 0+      !(BranchCont retK) = unsafeCoerce# retContAny+  in preComposeRoute inMap (unsafeCoerce# (transformedBody `seqPenelope` retK (unsafeCoerce# emptyRecord)))++{- |+Elaborator for higher-order 'Catch' effect unrolling into pure first-order 'ef' operations.++See Note [Two-Phase Weaving and Unweaving] [ref:note-two-phase-engine].+-}+{-# INLINE catchElaborator #-}+catchElaborator ::+  forall (l :: Symbol) ef e.+  ConstructorIndex l ef =>+  Elaborator '[] ef (Catch e)+catchElaborator = Elaborator $ \inMap regs _opAny kConts ->+  let !(Identity bodyRegAny) = indexSmallArray (let RowRep (Rep _ arr) = regs in arr) 0+      !(Region bodyPipe) = unsafeCoerce# bodyRegAny+      !(Identity handlerRegAny) = indexSmallArray (let RowRep (Rep _ arr) = regs in arr) 1+      !(Region handlerPipe) = unsafeCoerce# handlerRegAny+      !targetTag# = case constructorIndex @_ @l @ef of W# w# -> w#+      !transformedBody = catchWalk targetTag# (\_err -> Eff (unsafeCoerce# handlerPipe)) (unsafeCoerce# bodyPipe)+      !(Identity retContAny) = indexSmallArray (let RowRep (Rep _ arr) = kConts in arr) 0+      !(BranchCont retK) = unsafeCoerce# retContAny+  in preComposeRoute inMap (unsafeCoerce# (transformedBody `seqPenelope` retK (unsafeCoerce# emptyRecord)))++{- |+Construct an 'EffHandler' supplying an environment @r@ for 'AskEff'.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE readerHandler #-}+readerHandler ::+  forall r m.+  Monad m =>+  r+  -> EffHandler m (AskEff r)+readerHandler env = mkEffHandler $ \case+  Ask -> pure env++{- |+Execute a pure 'Eff' computation supplying an environment @r@.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE runReaderPure #-}+runReaderPure ::+  forall r a.+  r+  -> Eff '[] '["reader" ':= UnaryEffect (AskEff r)] a+  -> a+runReaderPure env prog =+  let handlers = insertField (Field @"reader") (readerHandler env) emptyRecord+      Identity res = runEffM handlers prog+  in res++{- |+Construct an 'EffHandler' interpreting 'ThrowEff' under the 'Either e' error monad.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE errorHandler #-}+errorHandler ::+  forall e.+  EffHandler (Either e) (ThrowEff e)+errorHandler = mkEffHandler $ \(Throw err) -> Left err++{- |+Execute a pure 'Eff' computation catching errors into 'Either e a'.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE runErrorPure #-}+runErrorPure ::+  forall e a.+  Eff '[] '["error" ':= UnaryEffect (ThrowEff e)] a+  -> Either e a+runErrorPure prog =+  let handlers = insertField (Field @"error") errorHandler emptyRecord+  in runEffM handlers prog

@@ -0,0 +1,215 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{- |+Module      : Penelope.Effects.Unary+Description : Heftia unary monad facade over Penelope (m,n,k,r)-ary core+Copyright   : (c) 2026 The Penelope Authors+License     : EUPL-1.2 OR Apache-2.0+Maintainer  : nadia.yvette.chambers@ik.me+Stability   : experimental+Portability : non-portable (GHC extensions)++Provides a standard unary monadic interface ('Eff') over Penelope's polycategorical core.++See Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+module Penelope.Effects.Unary+  ( -- * Unary Monad Facade+    Eff (..)++    -- * Effect Injection+  , send+  , sendEff++    -- * Handlers and Lifting Adapters+  , UnaryEffect+  , EffHandler+  , EffHandlers+  , mkEffHandler++    -- * Runners+  , runEff+  , runEffM+  ) where++import Control.Monad (ap)+import Data.Functor.Identity (Identity (..))+import Data.Kind (Type)+import Data.Primitive.SmallArray (indexSmallArray)+import GHC.Exts (Any, Word (W#), unsafeCoerce#)+import GHC.TypeLits (Symbol)+import Penelope.Core.Engine.Elaborate (MapRow)+import Penelope.Core.Engine.Interpret+  ( FrameKleisli (..)+  , Handler (..)+  , interpretAll+  , runPenelopePure+  )+import Penelope.Core.Syntax+  ( BranchCont (..)+  , Penelope (..)+  , PolyEffect+  , PolyHEffect+  )+import Penelope.Core.Wiring (preComposeRoute, seqPenelope)+import Polytropos (Field (..), Record, RowOf, emptyRecord, insertField)+import Polytropos.Core (ConstructorIndex (..), Pair (..), Rep (..), RowRep (..))+import Polytropos.RowMorph (unsafeMkRowMorph)++{- |+Zero-cost unary monadic projection over Penelope's underlying polycategorical engine.+A computation of type @Eff eh ef a@ is isomorphic to a pipeline with zero input registers+and a single output register @'["val" ':= a]@.++See Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+newtype Eff (eh :: RowOf PolyHEffect) (ef :: RowOf PolyEffect) a = Eff+  { unEff :: Penelope eh ef '[] '["val" ':= a]+  }++instance Functor (Eff eh ef) where+  {-# INLINE fmap #-}+  fmap f m = m >>= (\a -> pure (f a))++instance Applicative (Eff eh ef) where+  {-# INLINE pure #-}+  pure a =+    let p :: Penelope eh ef '[] '["val" ':= a]+        p = LiftPure+          (unsafeMkRowMorph [])+          (\_ -> insertField (Field @"val") a emptyRecord)+          (BranchCont (\_ -> Route (unsafeMkRowMorph [0])))+    in Eff p++  {-# INLINE (<*>) #-}+  (<*>) = ap++instance Monad (Eff eh ef) where+  {-# INLINE (>>=) #-}+  (>>=) = bindEff++{-# INLINE bindEff #-}+bindEff ::+  forall eh ef a b.+  Eff eh ef a+  -> (a -> Eff eh ef b)+  -> Eff eh ef b+bindEff (Eff p) k =+  let stage :: Penelope eh ef '["val" ':= a] '["val" ':= b]+      stage = LiftPure+        (unsafeMkRowMorph [0])+        (\rec -> rec)+        (BranchCont $ \res ->+          let !(Identity aVal) = indexSmallArray (let RowRep (Rep _ arr) = res in arr) 0+              !a = unsafeCoerce# aVal :: a+              !(Eff nextP) = k a+          in preComposeRoute (unsafeMkRowMorph []) nextP+        )+  in Eff (seqPenelope p stage)++{- |+Inject a first-order unary algebraic effect into 'Eff'.+Resolves the constructor tag in \(O(1)\) at compile time via 'ConstructorIndex'.++See Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE sendEff #-}+sendEff ::+  forall (l :: Symbol) (sig :: Type -> Type) a (eh :: RowOf PolyHEffect) (ef :: RowOf PolyEffect).+  ConstructorIndex l ef =>+  sig a+  -> Eff eh ef a+sendEff op =+  let retCont = BranchCont (\_ -> Route (unsafeMkRowMorph [0]))+      conts = insertField (Field @"ret") retCont emptyRecord+      !tag# = case constructorIndex @_ @l @ef of W# w# -> w#+      p = OpF tag# (unsafeMkRowMorph []) (unsafeCoerce# op) conts+  in Eff p++-- | Convenient alias for 'sendEff'.+{-# INLINE send #-}+send ::+  forall (l :: Symbol) (sig :: Type -> Type) a (eh :: RowOf PolyHEffect) (ef :: RowOf PolyEffect).+  ConstructorIndex l ef =>+  sig a+  -> Eff eh ef a+send = sendEff @l++{- |+Type-level adapter lifting a standard unary effect GADT (@sig :: Type -> Type@)+into Penelope's poly-kinded 'PolyEffect' representation.++See Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+data UnaryEffect (sig :: Type -> Type) :: PolyEffect++-- | Handler for a single first-order effect under a target monad @m@.+type EffHandler m (sig :: Type -> Type) = Handler '[] (FrameKleisli m) (UnaryEffect sig)++-- | Record of handlers for the first-order effect row @ef@.+type EffHandlers ef m = Record (MapRow (Handler '[] (FrameKleisli m)) ef)++{- |+Construct an 'EffHandler' from a standard unary interpreter function.++See Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE mkEffHandler #-}+mkEffHandler ::+  forall (sig :: Type -> Type) m.+  Monad m =>+  (forall a. sig a -> m a)+  -> Handler '[] (FrameKleisli m) (UnaryEffect sig)+mkEffHandler runOp = Handler $ \_inMap opAny kConts ->+  let !op = unsafeCoerce# opAny :: sig Any+      !(Identity elabK) = indexSmallArray (let RowRep (Rep _ arr) = kConts in arr) 0+      !(BranchCont retK) = unsafeCoerce# elabK+  in FrameKleisli $ \_inF -> do+       res <- runOp op+       let resFrame = insertField (Field @"val") res emptyRecord+       runFrameKleisli (retK resFrame) resFrame++{- |+Execute a pure, closed 'Eff' computation to its final value.++See Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE runEff #-}+runEff :: Eff '[] '[] a -> a+runEff (Eff p) =+  let outFrame = runPenelopePure p emptyRecord+      !(Identity val) = indexSmallArray (let RowRep (Rep _ arr) = outFrame in arr) 0+  in unsafeCoerce# val++{- |+Execute an effectful 'Eff' computation into a target 'Monad' using a handler vector.++See Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE runEffM #-}+runEffM ::+  forall ef m a.+  Monad m =>+  Record (MapRow (Handler '[] (FrameKleisli m)) ef)+  -> Eff '[] ef a+  -> m a+runEffM handlers (Eff p) = do+  let kleisli = interpretAll handlers p+  outFrame <- runFrameKleisli kleisli emptyRecord+  let !(Identity val) = indexSmallArray (let RowRep (Rep _ arr) = outFrame in arr) 0+  pure (unsafeCoerce# val)

@@ -0,0 +1,267 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{- |+Module      : Penelope.Effects.UnliftIO+Description : Sound scoped resource management, masking, and dependency injection+Copyright   : (c) 2026 The Penelope Authors+License     : EUPL-1.2 OR Apache-2.0+Maintainer  : nadia.yvette.chambers@ik.me+Stability   : experimental+Portability : non-portable (GHC extensions)++Provides sound scoped resource management guaranteed never to leak handles+across dynamic evaluation contexts:+1. 'Bracket' higher-order scoped resource acquisition and cleanup+2. 'Mask' asynchronous exception safety+3. 'Provider' dependency injection++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+module Penelope.Effects.UnliftIO+  ( -- * Scoped Bracket+    Bracket (..)+  , bracketElaborator+  , bracketEff+  , bracketEitherEff+  , bracketIO++    -- * Masking+  , Mask+  , maskIO++    -- * Provider Dependency Injection+  , Provider+  , ProviderEff (..)+  , askProvider+  , providerHandler+  , runProviderPure+  ) where++import qualified Control.Exception as E+import Data.Functor.Identity (Identity (..))+import Data.Kind (Type)+import Data.Primitive.SmallArray (indexSmallArray)+import GHC.Exts (unsafeCoerce#)+import GHC.TypeLits (Symbol)+import Penelope.Core.Engine.Elaborate (Elaborator (..))+import Penelope.Core.Engine.Interpret (runPenelopePure)+import Penelope.Core.Syntax+  ( BranchCont (..)+  , Penelope (..)+  , PolyEffect+  , PolyHEffect+  , PortSig (..)+  , Region (..)+  )+import Penelope.Effects.Unary+  ( Eff (..)+  , EffHandler+  , UnaryEffect+  , mkEffHandler+  , runEffM+  , send+  )+import Polytropos (Field (..), RowOf, emptyRecord, insertField)+import Polytropos.Core (ConstructorIndex (..), Pair (..), Rep (..), RowRep (..))++{- |+Higher-order scoped 'Bracket' effect with three sub-regions:+1. @"acquire"@: Allocates the resource handle.+2. @"action"@: Operates with the acquired resource.+3. @"release"@: Guarantees release of the resource on all paths.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+data Bracket (r :: PortSig -> Type) (regs :: RowOf PortSig) (opIns :: RowOf Type) (exits :: RowOf (RowOf Type)) where+  BracketOp :: Bracket r+    '[ "acquire" ':= 'PortSig ins '["res" ':= res]+     , "action"  ':= 'PortSig '["res" ':= res] '["out" ':= a]+     , "release" ':= 'PortSig '["res" ':= res] '[]+     ]+    ins+    '[ "ret" ':= '["out" ':= a] ]++{- |+Elaborator for 'Bracket' lowering scoped resource handling into guaranteed cleanup.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE bracketElaborator #-}+bracketElaborator ::+  forall ef.+  Elaborator '[] ef Bracket+bracketElaborator = Elaborator $ \inMap regs _ kConts ->+  LiftPure inMap+    (\inRec ->+      let !(Identity acqRegAny) = indexSmallArray (let RowRep (Rep _ arr) = regs in arr) 0+          !(Region acqPipe) = unsafeCoerce# acqRegAny+          !(Identity actRegAny) = indexSmallArray (let RowRep (Rep _ arr) = regs in arr) 1+          !(Region actPipe) = unsafeCoerce# actRegAny+          !(Identity relRegAny) = indexSmallArray (let RowRep (Rep _ arr) = regs in arr) 2+          !(Region relPipe) = unsafeCoerce# relRegAny++          !resRec = runPenelopePure acqPipe (unsafeCoerce# inRec)+          !actRec = runPenelopePure actPipe (unsafeCoerce# resRec)+          !relRec = runPenelopePure relPipe (unsafeCoerce# resRec)+      in seq relRec actRec+    )+    (BranchCont $ \finalActRec ->+      let !(Identity retContAny) = indexSmallArray (let RowRep (Rep _ arr) = kConts in arr) 0+          !(BranchCont retK) = unsafeCoerce# retContAny+      in retK (unsafeCoerce# finalActRec)+    )++{- |+Bracket pattern for 'Eff' ensuring resource cleanup.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE bracketEff #-}+bracketEff ::+  forall res a eh ef.+  Eff eh ef res+  -> (res -> Eff eh ef ())+  -> (res -> Eff eh ef a)+  -> Eff eh ef a+bracketEff acquire release action = do+  r <- acquire+  val <- action r+  release r+  pure val++{- |+Bracket pattern for 'Eff' with error exit propagation ensuring resource cleanup+on both successful and failed branches.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE bracketEitherEff #-}+bracketEitherEff ::+  forall res err a eh ef.+  Eff eh ef res+  -> (res -> Eff eh ef ())+  -> (res -> Eff eh ef (Either err a))+  -> Eff eh ef (Either err a)+bracketEitherEff acquire release action = do+  r <- acquire+  resOrErr <- action r+  release r+  pure resOrErr++{- |+Bracket pattern for 'IO' utilizing underlying exception safety guarantees.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE bracketIO #-}+bracketIO ::+  forall res a.+  IO res+  -> (res -> IO ())+  -> (res -> IO a)+  -> IO a+bracketIO = E.bracket++{- |+Higher-order scoped 'Mask' effect guaranteeing asynchronous exception masking.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+data Mask :: PolyHEffect++{- |+Mask asynchronous exceptions within an 'IO' action.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE maskIO #-}+maskIO ::+  forall a.+  ((forall b. IO b -> IO b) -> IO a)+  -> IO a+maskIO = E.mask++{- |+Polycategorical provider dependency injection effect.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+data Provider (r :: Type) :: PolyEffect++{- |+Unary effect GADT representing an environment query.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+data ProviderEff (r :: Type) (a :: Type) where+  AskProvider :: ProviderEff r r++{- |+Query the provided environment from within 'Eff'.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE askProvider #-}+askProvider ::+  forall (l :: Symbol) r eh ef.+  ConstructorIndex l ef =>+  Eff eh ef r+askProvider = send @l AskProvider++{- |+Construct an 'EffHandler' supplying an environment handle @r@.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE providerHandler #-}+providerHandler ::+  forall r m.+  Monad m =>+  r+  -> EffHandler m (ProviderEff r)+providerHandler env = mkEffHandler $ \case+  AskProvider -> pure env++{- |+Run an 'Eff' computation with a provided environment handle @r@ purely.++See Note [Core Architecture] [ref:note-core-architecture] and+Note [Zero-Cost Surface Specializations] [ref:note-surface-facades].+-}+{-# INLINE runProviderPure #-}+runProviderPure ::+  forall r a.+  r+  -> Eff '[] '["provider" ':= UnaryEffect (ProviderEff r)] a+  -> a+runProviderPure env prog =+  let handlers = insertField (Field @"provider") (providerHandler env) emptyRecord+      Identity res = runEffM handlers prog+  in res

@@ -0,0 +1,571 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fplugin=Polytropos.Plugin #-}++module Main (main) where++import Control.Arrow (Arrow (..), ArrowChoice (..), (>>>))+import Control.Category (Category (..))+import qualified Control.Concurrent as C+import qualified Control.Exception as E+import Data.Functor.Identity (Identity (..))+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Data.Kind (Type)+import Data.Primitive.SmallArray (indexSmallArray)+import GHC.Exts (unsafeCoerce#)+import Penelope.Core.Engine.Elaborate (elaborateAll)+import Penelope.Core.Engine.Interpret (interpretAll, runFrameKleisli, runPenelopePure)+import Penelope.Core.Syntax (BranchCont (..), Penelope (..), PortSig (..), Region (..))+import Penelope.Effects+import Polytropos (Field (..), Record, Variant, emptyRecord, injectVariant, insertField)+import Polytropos.Core (Pair (..), Rep (..), RowRep (..))+import Polytropos.RowMorph (unsafeMkRowMorph)+import Prelude hiding (id, (.))+import Test.Hspec++-- Unary Effect GADTs for testing+data AskEffTest :: Type -> Type where+  AskVal :: AskEffTest Int++data MsgEff :: Type -> Type where+  GetMsg :: MsgEff String+  SetMsg :: String -> MsgEff ()++type AskEF = '["ask" ':= UnaryEffect AskEffTest]+type MsgEF = '["msg" ':= UnaryEffect MsgEff]++-- Variant type for router tests+type EventSum = '["click" ':= '["x" ':= Int], "key" ':= '["char" ':= Char]]++-- Multi-effect rows for Heftia interaction tests+type CoroReaderEF = '["yield" ':= UnaryEffect (YieldEff Int), "reader" ':= UnaryEffect (AskEff Int)]+type CoroCatchEF = '["yield" ':= UnaryEffect (YieldEff String), "error" ':= UnaryEffect (ThrowEff String)]+type NonDetReaderEF = '["nondet" ':= UnaryEffect NonDetEff, "reader" ':= UnaryEffect (AskEff Int)]++main :: IO ()+main = hspec $ do+  describe "Penelope.Effects (Domain Entity)" $ do+    it "constructs default entity with correct properties" $ do+      let e = defaultEntity+      entityName e `shouldBe` "penelope"+      entityModule e `shouldBe` "Penelope.Effects"+    it "renders entity accurately" $ do+      let e = defaultEntity+      renderEntity e `shouldBe` "penelope:Penelope.Effects"++  describe "Penelope.Effects.Unary (Eff Monad Laws)" $ do+    it "satisfies left identity: pure a >>= f == f a" $ do+      let f x = pure (x * 2 :: Int)+          val = 21 :: Int+          lhs = runEff (pure val >>= f)+          rhs = runEff (f val)+      lhs `shouldBe` 42+      rhs `shouldBe` 42+      lhs `shouldBe` rhs++    it "satisfies right identity: m >>= pure == m" $ do+      let m = pure (42 :: Int)+          lhs = runEff (m >>= pure)+          rhs = runEff m+      lhs `shouldBe` 42+      rhs `shouldBe` 42+      lhs `shouldBe` rhs++    it "satisfies associativity: (m >>= f) >>= g == m >>= (\\x -> f x >>= g)" $ do+      let m = pure (10 :: Int)+          f x = pure (x + 5 :: Int)+          g y = pure (y * 2 :: Int)+          lhs = runEff ((m >>= f) >>= g)+          rhs = runEff (m >>= (\x -> f x >>= g))+      lhs `shouldBe` 30+      rhs `shouldBe` 30+      lhs `shouldBe` rhs++  describe "Penelope.Effects.Unary (Monadic Ergonomics & Do-Notation)" $ do+    it "evaluates multi-step monadic do-notation blocks cleanly" $ do+      let prog :: Eff '[] '[] Int+          prog = do+            a <- pure (10 :: Int)+            b <- pure (20 :: Int)+            c <- pure (12 :: Int)+            pure (a + b + c)+      runEff prog `shouldBe` 42++    it "supports functor fmap and applicative ap" $ do+      let p1 = pure (20 :: Int)+          p2 = fmap (* 2) p1+          p3 = (+) <$> p1 <*> p2+      runEff p2 `shouldBe` 40+      runEff p3 `shouldBe` 60++  describe "Penelope.Effects.Unary (Effectful Runners: runEffM)" $ do+    it "interprets unary effect GADTs via mkEffHandler into Identity" $ do+      let prog :: Eff '[] AskEF Int+          prog = do+            v <- send @"ask" AskVal+            pure (v * 2)++          askHandler :: EffHandler Identity AskEffTest+          askHandler = mkEffHandler $ \case+            AskVal -> Identity (21 :: Int)++          handlers = insertField (Field @"ask") askHandler emptyRecord+          Identity result = runEffM handlers prog+      result `shouldBe` 42++    it "interprets stateful multi-operation GADTs via mkEffHandler into IO" $ do+      ref <- newIORef ("initial" :: String)+      let prog :: Eff '[] MsgEF String+          prog = do+            m <- send @"msg" GetMsg+            send @"msg" (SetMsg "updated")+            pure ("msg:" <> m)++          msgHandler :: EffHandler IO MsgEff+          msgHandler = mkEffHandler $ \case+            GetMsg -> readIORef ref+            SetMsg s -> writeIORef ref s++          handlers = insertField (Field @"msg") msgHandler emptyRecord++      res <- runEffM handlers prog+      res `shouldBe` "msg:initial"+      final <- readIORef ref+      final `shouldBe` "updated"++  describe "Penelope.Effects.Binary (Rope Category and Arrow Laws)" $ do+    it "satisfies Category identity and composition laws" $ do+      let f :: Rope '[] '[] Int Int+          f = arr (+ 1)+          g :: Rope '[] '[] Int Int+          g = arr (* 2)+          h :: Rope '[] '[] Int Int+          h = arr (+ 3)+      runRopePure (id >>> f) 10 `shouldBe` 11+      runRopePure (f >>> id) 10 `shouldBe` 11+      runRopePure ((f >>> g) >>> h) 10 `shouldBe` 25+      runRopePure (f >>> (g >>> h)) 10 `shouldBe` 25++    it "satisfies Arrow first, second, (***), and (&&&) combinators" $ do+      let f :: Rope '[] '[] Int Int+          f = arr (+ 1)+          g :: Rope '[] '[] String String+          g = arr reverse+      runRopePure (first f) (10 :: Int, "hello" :: String) `shouldBe` (11, "hello")+      runRopePure (second g) (10 :: Int, "hello" :: String) `shouldBe` (10, "olleh")+      runRopePure (f *** g) (10 :: Int, "world" :: String) `shouldBe` (11, "dlrow")+      runRopePure (f &&& arr (* 2)) (10 :: Int) `shouldBe` (11, 20)++    it "satisfies ArrowChoice left and right branch routing" $ do+      let f :: Rope '[] '[] Int Int+          f = arr (+ 1)+      runRopePure (left f) (Left 10 :: Either Int String) `shouldBe` Left 11+      runRopePure (left f) (Right "pass" :: Either Int String) `shouldBe` Right "pass"+      runRopePure (right f) (Right 20 :: Either String Int) `shouldBe` Right 21+      runRopePure (right f) (Left "pass" :: Either String Int) `shouldBe` Left "pass"++  describe "Penelope.Effects.Binary (Static Jump-Table deriveRouter)" $ do+    it "dispatches multi-constructor Variant inputs in O(1) via deriveRouter" $ do+      let hClick :: Rope '[] '[] (Record '["x" ':= Int]) String+          hClick = arr $ \r ->+            let !(Identity x) = indexSmallArray (let RowRep (Rep _ arrRep) = r in arrRep) 0+            in "clicked:" <> show (unsafeCoerce# x :: Int)++          hKey :: Rope '[] '[] (Record '["char" ':= Char]) String+          hKey = arr $ \r ->+            let !(Identity c) = indexSmallArray (let RowRep (Rep _ arrRep) = r in arrRep) 0+            in "key:" <> [unsafeCoerce# c :: Char]++          handlers = insertField (Field @"click") hClick+                   $ insertField (Field @"key") hKey+                   $ emptyRecord++          router :: Rope '[] '[] (Variant EventSum) String+          router = deriveRouter handlers++          v1 = injectVariant (Field @"click") (insertField (Field @"x") (42 :: Int) emptyRecord)+          v2 = injectVariant (Field @"key") (insertField (Field @"char") 'q' emptyRecord)++      runRopePure router v1 `shouldBe` "clicked:42"+      runRopePure router v2 `shouldBe` "key:q"++  describe "Penelope.Effects.Control (While, Switch, Saga)" $ do+    it "executes whileEff loop with state termination" $ do+      let loop :: Eff '[] '[] Int+          loop = whileEff (\s -> pure (s < 5)) (\s -> pure (s + 1)) (0 :: Int)+      runEff loop `shouldBe` 5++    it "elaborates and executes multi-region While loop to state termination" $ do+      let condPipe :: Penelope '[] '[] '["x" ':= Int] '["cond" ':= Bool]+          condPipe = LiftPure (unsafeMkRowMorph [0])+            (\r ->+              let !(Identity x) = indexSmallArray (let RowRep (Rep _ sArr) = r in sArr) 0+                  !b = (unsafeCoerce# x :: Int) < 3+              in insertField (Field @"cond") b emptyRecord+            )+            (BranchCont (\_ -> Route (unsafeMkRowMorph [0])))++      let bodyPipe :: Penelope '[] '[] '["x" ':= Int] '["x" ':= Int]+          bodyPipe = LiftPure (unsafeMkRowMorph [0])+            (\r ->+              let !(Identity x) = indexSmallArray (let RowRep (Rep _ sArr) = r in sArr) 0+                  !nextX = (unsafeCoerce# x :: Int) + 1+              in insertField (Field @"x") nextX emptyRecord+            )+            (BranchCont (\_ -> Route (unsafeMkRowMorph [0])))++      let regs = insertField (Field @"cond") (Region @'[] @'[] @('PortSig '["x" ':= Int] '["cond" ':= Bool]) condPipe)+               $ insertField (Field @"body") (Region @'[] @'[] @('PortSig '["x" ':= Int] '["x" ':= Int]) bodyPipe)+               $ emptyRecord++      let retCont = BranchCont (\_ -> Route (unsafeMkRowMorph [0]))+      let exits = insertField (Field @"exit") retCont emptyRecord++      let whileTerm :: Penelope '["while" ':= While] '[] '["x" ':= Int] '["x" ':= Int]+          whileTerm = OpH 0## (unsafeMkRowMorph [0]) regs (unsafeCoerce# ()) exits++      let elabs = insertField (Field @"while") whileElaborator emptyRecord+          elaborated = elaborateAll elabs whileTerm++      let inFrame = insertField (Field @"x") (0 :: Int) emptyRecord+          outFrame = runPenelopePure elaborated inFrame+          !(Identity finalX) = indexSmallArray (let RowRep (Rep _ sArr) = outFrame in sArr) 0++      (unsafeCoerce# finalX :: Int) `shouldBe` 3++    it "executes transactional Saga committing on success and compensating on failure" $ do+      let prog1 :: Eff '[] '[] (Either String Int)+          prog1 = runSagaEff (pure ("action" :: String)) (\_ -> pure ()) (\_ -> pure (Right 42))++          prog2 :: Eff '[] '[] (Either String Int)+          prog2 = runSagaEff (pure ("action" :: String)) (\_ -> pure ()) (\_ -> pure (Left "err"))++      runEff prog1 `shouldBe` Right 42+      runEff prog2 `shouldBe` Left "err"++  describe "Penelope.Effects.Coroutine (Delimited Continuations & Generator)" $ do+    it "yields elements from generator to consumer cleanly" $ do+      let gen :: Eff '[] '["yield" ':= UnaryEffect (YieldEff Int)] String+          gen = do+            yield @"yield" (10 :: Int)+            yield @"yield" (20 :: Int)+            yield @"yield" (30 :: Int)+            pure "finished"+          (yielded, res) = runGenerator gen+      yielded `shouldBe` [10, 20, 30]+      res `shouldBe` "finished"++    it "runs non-deterministic branching exploration via runNonDet" $ do+      let prog :: Eff '[] '["nondet" ':= UnaryEffect NonDetEff] Int+          prog = do+            b1 <- branch @"nondet"+            b2 <- branch @"nondet"+            case (b1, b2) of+              (True, True)   -> pure 10+              (True, False)  -> pure 20+              (False, True)  -> pure 30+              (False, False) -> emptyNonDet @"nondet"+      runNonDet prog `shouldBe` [10, 20, 30]++  describe "Penelope.Effects.UnliftIO (Scoped Resource Safety & Provider)" $ do+    it "guarantees Bracket resource cleanup on success exit" $ do+      ref <- newIORef ([] :: [String])+      let acquire = do+            writeIORef ref ["acquired"]+            pure ("handle" :: String)+          release _ =+            modifyIORef' ref ("released" :)+          action _ = do+            modifyIORef' ref ("action" :)+            pure (42 :: Int)++      res <- bracketIO acquire release action+      res `shouldBe` 42+      logRes <- readIORef ref+      logRes `shouldBe` ["released", "action", "acquired"]++    it "guarantees Bracket resource cleanup on error exit" $ do+      ref <- newIORef ([] :: [String])+      let acquire = do+            writeIORef ref ["acquired"]+            pure ("handle" :: String)+          release _ =+            modifyIORef' ref ("released" :)+          actionErr _ = do+            modifyIORef' ref ("action-failed" :)+            error "simulated failure" :: IO Int++      (bracketIO acquire release actionErr >> pure ()) `shouldThrow` anyErrorCall+      logRes <- readIORef ref+      logRes `shouldBe` ["released", "action-failed", "acquired"]++    it "supports pure bracketEitherEff error exit" $ do+      let prog = bracketEitherEff (pure ("res" :: String)) (\_ -> pure ()) (\_ -> pure (Left "boom" :: Either String Int))+      runEff prog `shouldBe` Left "boom"++    it "injects dependencies via Provider purely" $ do+      let prog :: Eff '[] '["provider" ':= UnaryEffect (ProviderEff String)] String+          prog = do+            env <- askProvider @"provider"+            pure ("env:" <> env)+      runProviderPure "production" prog `shouldBe` "env:production"++  describe "Penelope.Effects.Scoped (Reader / Local)" $ do+    it "reads lexical environment purely via askReader and runReaderPure" $ do+      let prog :: Eff '[] '["reader" ':= UnaryEffect (AskEff Int)] Int+          prog = do+            v <- askReader+            pure (v * 2)+      runReaderPure (21 :: Int) prog `shouldBe` 42++    it "modifies environment in nested local blocks and restores state cleanly" $ do+      let prog :: Eff '[] '["reader" ':= UnaryEffect (AskEff Int)] (Int, Int, Int)+          prog = do+            v0 <- askReader+            v1 <- local @Int (+ 10) $ do+              inner1 <- askReader+              inner2 <- local @Int (* 2) askReader+              pure (inner1 + inner2)+            v2 <- askReader+            pure (v0, v1, v2)+      -- With initial 5:+      -- v0 = 5+      -- inner1 = 15, inner2 = (5 + 10) * 2 = 30 -> v1 = 45+      -- v2 = 5+      runReaderPure (5 :: Int) prog `shouldBe` (5, 45, 5)++    it "unrolls higher-order Local effect via localElaborator and elaborateAll" $ do+      let bodyPipe :: Penelope '[] '["reader" ':= UnaryEffect (AskEff Int)] '[] '["val" ':= Int]+          bodyPipe = unEff $ do+            x <- askReader+            pure (x + 100)++      let regs = insertField (Field @"body") (Region @'[] @'["reader" ':= UnaryEffect (AskEff Int)] @('PortSig '[] '["val" ':= Int]) bodyPipe) emptyRecord+      let retCont = BranchCont (\_outF -> Route (unsafeMkRowMorph [0]))+      let exits = insertField (Field @"ret") retCont emptyRecord++      let localOpH :: Penelope '["local" ':= Local Int] '["reader" ':= UnaryEffect (AskEff Int)] '[] '["val" ':= Int]+          localOpH = OpH 0## (unsafeMkRowMorph []) regs (unsafeCoerce# ((* 2) :: Int -> Int)) exits++      let elabs = insertField (Field @"local") (localElaborator @"reader") emptyRecord+      let elaborated = elaborateAll elabs localOpH++      let handlers = insertField (Field @"reader") (readerHandler (10 :: Int)) emptyRecord+      let Identity outFrame = runFrameKleisli (interpretAll handlers elaborated) emptyRecord+      let !(Identity resVal) = indexSmallArray (let RowRep (Rep _ arrRep) = outFrame in arrRep) 0+      -- Initial 10 * 2 = 20, plus 100 = 120+      (unsafeCoerce# resVal :: Int) `shouldBe` 120++  describe "Penelope.Effects.Scoped (Error / Catch)" $ do+    it "evaluates successful computations to Right with runErrorPure" $ do+      let prog :: Eff '[] '["error" ':= UnaryEffect (ThrowEff String)] Int+          prog = pure 42+      runErrorPure prog `shouldBe` Right 42++    it "aborts on throw with Left error message" $ do+      let prog :: Eff '[] '["error" ':= UnaryEffect (ThrowEff String)] Int+          prog = do+            _ <- pure (10 :: Int)+            throw ("aborted-computation" :: String)+      runErrorPure prog `shouldBe` Left "aborted-computation"++    it "catches and recovers from errors via catchError" $ do+      let prog :: Eff '[] '["error" ':= UnaryEffect (ThrowEff String)] String+          prog = do+            catchError+              (do+                _ <- pure (1 :: Int)+                throw ("recoverable-error" :: String)+              )+              (\e -> pure ("caught:" <> e))+      runErrorPure prog `shouldBe` Right "caught:recoverable-error"++    it "unrolls higher-order Catch effect via catchElaborator and elaborateAll" $ do+      let bodyPipe :: Penelope '[] '["error" ':= UnaryEffect (ThrowEff String)] '[] '["val" ':= String]+          bodyPipe = unEff $ do+            _ <- throw ("scoped-error-thrown" :: String)+            pure "unreachable"++      let handlerPipe :: Penelope '[] '["error" ':= UnaryEffect (ThrowEff String)] '[] '["val" ':= String]+          handlerPipe = unEff (pure "intercepted-by-elaborator")++      let regs = insertField (Field @"body") (Region @'[] @'["error" ':= UnaryEffect (ThrowEff String)] @('PortSig '[] '["val" ':= String]) bodyPipe)+               $ insertField (Field @"handler") (Region @'[] @'["error" ':= UnaryEffect (ThrowEff String)] @('PortSig '[] '["val" ':= String]) handlerPipe)+               $ emptyRecord+      let retCont = BranchCont (\_outF -> Route (unsafeMkRowMorph [0]))+      let exits = insertField (Field @"ret") retCont emptyRecord++      let catchOpH :: Penelope '["catch" ':= Catch String] '["error" ':= UnaryEffect (ThrowEff String)] '[] '["val" ':= String]+          catchOpH = OpH 0## (unsafeMkRowMorph []) regs (unsafeCoerce# ()) exits++      let elabs = insertField (Field @"catch") (catchElaborator @"error") emptyRecord+      let elaborated = elaborateAll elabs catchOpH++      let handlers = insertField (Field @"error") errorHandler emptyRecord+      let res = runFrameKleisli (interpretAll handlers elaborated) emptyRecord+      case res of+        Right outFrame -> do+          let !(Identity resVal) = indexSmallArray (let RowRep (Rep _ arrRep) = outFrame in arrRep) 0+          (unsafeCoerce# resVal :: String) `shouldBe` "intercepted-by-elaborator"+        Left e ->+          expectationFailure ("Unexpected unhandled error: " <> show e)++  describe "Penelope.Effects.Concurrent (Async & Task Isolation)" $ do+    it "forks background IO task via forkEff" $ do+      mvar <- C.newEmptyMVar+      let prog :: Eff '[] '["concurrent" ':= UnaryEffect ConcurrentEff] ()+          prog = forkEff @"concurrent" (C.putMVar mvar ("worker-done" :: String))+      runConcurrentIO prog+      res <- C.takeMVar mvar+      res `shouldBe` "worker-done"++    it "runs asynchronous tasks concurrently and awaits results via waitEff" $ do+      let task1 = do+            C.threadDelay 2000+            pure (10 :: Int)+          task2 = do+            C.threadDelay 1000+            pure (20 :: Int)++      let prog :: Eff '[] '["concurrent" ':= UnaryEffect ConcurrentEff] (Int, Int)+          prog = do+            h1 <- async task1+            h2 <- async task2+            r1 <- wait h1+            r2 <- wait h2+            pure (r1, r2)++      res <- runConcurrentIO prog+      res `shouldBe` (10, 20)++    it "propagates exceptions from failed asynchronous tasks safely" $ do+      let failingTask = do+            E.throwIO (userError "async-failure") :: IO Int++      let prog :: Eff '[] '["concurrent" ':= UnaryEffect ConcurrentEff] Int+          prog = do+            h <- async failingTask+            wait h++      runConcurrentIO prog `shouldThrow` anyException++  describe "Heftia Scoped Semantics & Multi-Shot Interaction" $ do+    it "preserves local reader environment across coroutine yield suspensions" $ do+      ref <- newIORef ([] :: [Int])+      let prog :: Eff '[] CoroReaderEF ()+          prog = do+            yield @"yield" (1 :: Int)+            local @Int (+ 100) $ do+              yield @"yield" (2 :: Int)+              x <- ask @"reader"+              yield @"yield" x+            yield @"yield" (3 :: Int)+            y <- ask @"reader"+            yield @"yield" y++      let yHandler :: EffHandler IO (YieldEff Int)+          yHandler = mkEffHandler $ \(Yield val) ->+            modifyIORef' ref (val :)++          rHandler :: EffHandler IO (AskEff Int)+          rHandler = readerHandler (10 :: Int)++          handlers = insertField (Field @"yield") yHandler+                   $ insertField (Field @"reader") rHandler+                   $ emptyRecord++      _ <- runEffM handlers prog+      yielded <- readIORef ref+      reverse yielded `shouldBe` [1, 2, 110, 3, 10]++    it "catches errors thrown during coroutine execution and resumes yielding downstream" $ do+      ref <- newIORef ([] :: [String])+      let prog :: Eff '[] CoroCatchEF ()+          prog = do+            yield @"yield" ("start" :: String)+            catchError+              (do+                yield @"yield" ("in-try" :: String)+                throwError @"error" ("simulated-failure" :: String)+                yield @"yield" ("unreachable" :: String)+              )+              (\e -> do+                yield @"yield" ("recovered:" <> e :: String)+              )+            yield @"yield" ("after-catch" :: String)++      let yHandler :: EffHandler IO (YieldEff String)+          yHandler = mkEffHandler $ \(Yield val) ->+            modifyIORef' ref (val :)++          eHandler :: EffHandler IO (ThrowEff String)+          eHandler = mkEffHandler $ \(Throw e) ->+            fail ("Unhandled throw caught by carrier: " <> e)++          handlers = insertField (Field @"yield") yHandler+                   $ insertField (Field @"error") eHandler+                   $ emptyRecord++      _ <- runEffM handlers prog+      yielded <- readIORef ref+      reverse yielded `shouldBe` ["start", "in-try", "recovered:simulated-failure", "after-catch"]++    it "maintains complete environment isolation across multi-shot non-deterministic branches" $ do+      let prog :: Eff '[] NonDetReaderEF Int+          prog = do+            b <- branch @"nondet"+            if b+              then local @Int (+ 10) (ask @"reader")+              else local @Int (+ 20) (ask @"reader")++      let ndHandler :: EffHandler [] NonDetEff+          ndHandler = nonDetHandler++          rHandler :: EffHandler [] (AskEff Int)+          rHandler = readerHandler (5 :: Int)++          handlers = insertField (Field @"nondet") ndHandler+                   $ insertField (Field @"reader") rHandler+                   $ emptyRecord++      let results = runEffM handlers prog+      results `shouldBe` [15, 25]++    it "guarantees balanced resource acquisition and cleanup across multiple concurrent branches" $ do+      ref <- newIORef ([] :: [String])+      let acquire name = do+            modifyIORef' ref ((name <> "-acq") :)+            pure name+          release name = do+            modifyIORef' ref ((name <> "-rel") :)++      let task1 = bracketIO (acquire "worker1") release (\n -> pure (n <> "-done"))+          task2 = bracketIO (acquire "worker2") release (\n -> pure (n <> "-done"))++      let prog :: Eff '[] '["concurrent" ':= UnaryEffect ConcurrentEff] (String, String)+          prog = do+            h1 <- async task1+            h2 <- async task2+            r1 <- wait h1+            r2 <- wait h2+            pure (r1, r2)++      res <- runConcurrentIO prog+      res `shouldBe` ("worker1-done", "worker2-done")++      logEntries <- readIORef ref+      logEntries `shouldContain` ["worker1-acq"]+      logEntries `shouldContain` ["worker1-rel"]+      logEntries `shouldContain` ["worker2-acq"]+      logEntries `shouldContain` ["worker2-rel"]