free-foil 0.3.3 → 0.4.0

raw patch · 39 files changed

+6335/−1568 lines, 39 filesdep +QuickCheckdep +binarydep +bytestringdep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, binary, bytestring

Dependency ranges changed: containers

API changes (from Hackage documentation)

Files

• ChangeLog.md +56/−0
• README.md +11/−0
• bench/alphaequiv/Main.hs +83/−0
• bench/restriction/Main.hs +160/−0
• free-foil.cabal +77/−7
• src/Control/Monad/Foil.hs +40/−3
• src/Control/Monad/Foil/Blocks.hs +396/−0
• src/Control/Monad/Foil/Example.hs +20/−0
• src/Control/Monad/Foil/Internal.hs +2380/−1416
• src/Control/Monad/Foil/Internal/ValidNameBinders.hs +14/−0
• src/Control/Monad/Foil/Registry.hs +229/−0
• src/Control/Monad/Foil/Relative.hs +9/−1
• src/Control/Monad/Foil/TH/MkFoilData.hs +4/−0
• src/Control/Monad/Foil/TH/MkFromFoil.hs +4/−0
• src/Control/Monad/Foil/TH/MkInstancesFoil.hs +11/−6
• src/Control/Monad/Foil/TH/MkToFoil.hs +10/−0
• src/Control/Monad/Foil/Telescope.hs +254/−0
• src/Control/Monad/Free/Foil.hs +615/−50
• src/Control/Monad/Free/Foil/Annotated.hs +31/−17
• src/Control/Monad/Free/Foil/Artifact.hs +342/−0
• src/Control/Monad/Free/Foil/Binary.hs +74/−0
• src/Control/Monad/Free/Foil/Binary/TH.hs +105/−0
• src/Control/Monad/Free/Foil/Example.hs +28/−0
• src/Control/Monad/Free/Foil/TH/Convert.hs +12/−0
• src/Control/Monad/Free/Foil/TH/MkFreeFoil.hs +321/−44
• src/Control/Monad/Free/Foil/TH/PatternSynonyms.hs +2/−0
• src/Control/Monad/Free/Foil/TH/Signature.hs +2/−0
• src/Data/ZipMatchK.hs +14/−0
• src/Data/ZipMatchK/Generic.hs +45/−11
• src/Data/ZipMatchK/Mappings.hs +16/−0
• src/Data/ZipMatchK/TH.hs +20/−12
• test/Control/Monad/Foil/BlocksSpec.hs +141/−0
• test/Control/Monad/Foil/NameRangeSpec.hs +172/−0
• test/Control/Monad/Foil/PatternTransportSpec.hs +165/−0
• test/Control/Monad/Foil/SinkableSpec.hs +65/−0
• test/Control/Monad/Free/Foil/AlphaEquivSpec.hs +178/−0
• test/Control/Monad/Free/Foil/SupportSpec.hs +205/−0
• test/Control/Monad/Free/Foil/TH/MkFreeFoilSpec/Syntax.hs +1/−1
• test/SpecHook.hs +23/−0

@@ -1,5 +1,59 @@ # CHANGELOG for `free-foil` +# Unreleased++# 0.4.0 — 2026-08-29++A release about *units*: checking a module independently of its neighbours, linking the results without renaming, and storing a checked one on disk. Scope restriction, a family of $O(1)$ sinks, and a linear α-equivalence rename path come with it.++Changed:++- **Clients of `mkFreeFoil` must delete their own `Foil.CoSinkable` instances** for the generated binding types, since `mkFreeFoil` now generates a concrete one ([#87](https://github.com/fizruk/free-foil/pull/87), [#82](https://github.com/fizruk/free-foil/issues/82)). `SinkableK`, `HasNameBinders`, and `UnifiablePattern` remain the client's.++- **`withPattern`'s continuation now also receives the scope the pattern extends to**, and so do those of `withRefreshedPattern`, `withFreshPattern`, and `withRefreshedPattern'` ([#88](https://github.com/fizruk/free-foil/pull/88), [#84](https://github.com/fizruk/free-foil/issues/84)). Add the argument, and drop the `extendScopePattern` that recomputed it.++- **`mkFreeFoilConversions` now requires `Bifoldable` on each signature**, for the `tryToX` it generates. `deriveBifoldable` if a signature lacks it.++- `freeVarsOf` and `freeVarsOfScopedAST` no longer repeat a variable, and return names in ascending order of their identifiers rather than in the order the term mentions them.++- `rawFreshName` allocates `0` over a scope whose maximum is negative, leaving the negative range to explicit policy, and reports a scope holding `maxBound` as exhausted. Nothing changes on a scope without negative names.++- `convertToAST` and `convertToScopedAST` are deprecated in favour of `unsafeConvertToAST` and `unsafeConvertToScopedAST`, and `sinkContainer` in favour of `sink1`.++- `containers >= 0.6.8` is required, for `Data.IntSet.fromRange`. `binary` and `bytestring` are new dependencies, both boot libraries.++New:++- **Reserved name ranges, and linking.** `withFreshIn` allocates inside a `NameRange`, so units drawing from disjoint reservations cannot collide. `Control.Monad.Foil.Blocks` tracks that as `ExtWithin` evidence and links two units with `withDisjointUnion`, one sweep over their range sets. `checkExtScope` and `checkScopeUnion` re-mint it for a unit loaded from a cache, and are documented as a trust boundary ([#58](https://github.com/fizruk/free-foil/pull/58)).++- **Deterministic stripes.** `Control.Monad.Foil.Registry` gives each unit its own run of the name line, `registerUnit` handing out the `StripeIndex` that every reservation for that unit is derived from. A `RegionLayout` does the same for the locals of each declaration, so an edit to one file moves no name in another ([#78](https://github.com/fizruk/free-foil/pull/78), [#80](https://github.com/fizruk/free-foil/pull/80)).++- **Scope restriction.** `NameSet`, `withRestrictedScope`, `supportOf`, `withRelevantScope`, and `withThinnedNameBinderList`: a term's support, the scope it really inhabits, and a chain of binders thinned against a set of names ([#56](https://github.com/fizruk/free-foil/pull/56)).++- **Serialisation.** `Control.Monad.Free.Foil.Binary` has opt-in orphan `Binary` instances for the syntax, and `Control.Monad.Free.Foil.Artifact` the checks that loading a stored unit rests on, with relocation of its constants ([#68](https://github.com/fizruk/free-foil/pull/68), [#69](https://github.com/fizruk/free-foil/pull/69)). Decoding mints scope evidence, so both are a trust boundary.++- **Patterns carrying scope-indexed payloads.** `PatternTransport` is the sanctioned way to rebuild one, and the generic implementation now refuses such a pattern with a type error rather than mis-refreshing it silently ([#71](https://github.com/fizruk/free-foil/pull/71)). `Control.Monad.Foil.Telescope` is the worked example, and `unifyPatternsIn` with the new `AlphaEquiv` class lets payloads take part in α-equivalence ([#72](https://github.com/fizruk/free-foil/pull/72), [#79](https://github.com/fizruk/free-foil/pull/79)).++- **Conversions that report rather than crash.** `tryConvertToAST` gives the first unresolved identifier together with what was in scope there, in one pass, and `unresolvedNames` pays a second pass for all of them ([#55](https://github.com/fizruk/free-foil/pull/55)). `tryConvertToASTWith` resolves an identifier to a whole term, for constants and abbreviations ([#57](https://github.com/fizruk/free-foil/pull/57)); `convertFromASTWith` names free and bound variables separately, which a raw name alone cannot ([#59](https://github.com/fizruk/free-foil/pull/59)); and `toXIn` and its siblings allocate within a given range, so the same source elaborates to the same term ([#60](https://github.com/fizruk/free-foil/pull/60)).++- **A family of $O(1)$ sinks.** `sink1` through a `Functor` and `sink2` through a `Bifunctor`, with rewrite rules and hlint hints steering the elementwise forms towards them ([#66](https://github.com/fizruk/free-foil/pull/66)).++- `nameBinderListOf`, the `Id` and `RawName` synonyms, and `mapWithName` are exported. The `restriction` and `alphaequiv` benchmarks are new.++Performance:++- `alphaEquiv` threads the verdict's renamings down the recursion instead of applying them, which turns a quadratic rename path linear: 353 ms to 211 µs on two α-equivalent 2000-binder chains ([#81](https://github.com/fizruk/free-foil/pull/81)).++- `substitute` short-circuits the empty substitution ([#80](https://github.com/fizruk/free-foil/pull/80)).++- The binder and substitution operations are `INLINABLE`, so a downstream `SPECIALIZE` reaches through them, and the free foil's `Var` unpacks its name ([#86](https://github.com/fizruk/free-foil/pull/86), [#83](https://github.com/fizruk/free-foil/issues/83)).++Documentation:++- Every exported entity carries a `@since`, and CI fails if a new one lacks it.++- The haddocks and the READMEs are proofread. The README's documentation links pointed at a version of the GitHub Pages haddocks that no longer exists, and point at Hackage now.+ # 0.3.3 — 2026-07-20  A bugfix and documentation release. Upgrading from 0.3.2 needs no work.@@ -214,3 +268,5 @@ # 0.0.1 — 2024-06-08  First release, corresponding to the ICCQ 2024 paper.++

@@ -1,2 +1,13 @@ # free-foil+ Efficient Type-Safe Capture-Avoiding Substitution for Free (Scoped Monads).++This package provides a scope-safe representation for syntax with binders. Scopes are tracked in a phantom type index, so that capture-avoidance is a property the type checker enforces rather than a discipline the programmer keeps. It builds on the foil of Maclaurin, Radul, and Paszke, extends it with patterns, and adds free scoped monads, so that substitution, α-equivalence, and conversion to and from a raw syntax are implemented once for every language whose syntax is given as a signature bifunctor.++- `Control.Monad.Foil` — names, scopes, binders, and the `Sinkable`/`CoSinkable` classes.+- `Control.Monad.Free.Foil` — the free foil: `AST binder sig n`, substitution, α-equivalence, supports, and conversions.+- `Control.Monad.Foil.TH` and `Control.Monad.Free.Foil.TH` — Template Haskell that generates the scope-safe syntax from a raw (BNFC-generated) one.+- `Control.Monad.Foil.Blocks` and `Control.Monad.Foil.Registry` — reserved ranges of names, for units that are checked independently and linked afterwards.+- `Control.Monad.Free.Foil.Binary` and `Control.Monad.Free.Foil.Artifact` — serialisation of a checked unit, and the checks that loading one rests on.++See the [repository README](https://github.com/fizruk/free-foil#readme) for the design and the papers behind it, and the [documentation on Hackage](https://hackage.haskell.org/package/free-foil) for the modules themselves.

@@ -0,0 +1,83 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DeriveTraversable   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}++-- | What the rename branches of 'alphaEquivScoped' cost.+--+-- The zipmatchk benchmark compares a term against itself, so the binders+-- always coincide and 'unifyPatternsIn' answers 'SameNameBinders': the+-- fast path, no renaming. This benchmark forces the other branches: @t2@+-- is α-equivalent to @t1@ but every binder carries a different raw name+-- (it is built under a dummy binder and then 'unsinkAST'-ed back to the+-- empty scope), so every level takes a Rename* branch. An eager+-- implementation materialised a renamed copy of the whole remaining body+-- per level, which is quadratic in the depth of the chain; with the+-- renaming threaded down the recursion, all three columns must stay+-- linear and within a small factor of one another.+module Main (main) where++import           Data.Bifunctor.TH+import           Data.Maybe              (fromMaybe)+import           Test.Tasty.Bench++import qualified Control.Monad.Foil      as Foil+import           Control.Monad.Free.Foil+import           Data.ZipMatchK.TH       (deriveZipMatchK)++data LamSig scope term+  = App term term+  | Lam scope+  deriving (Functor, Foldable, Traversable)++deriveBifunctor ''LamSig+deriveBifoldable ''LamSig+deriveBitraversable ''LamSig+deriveZipMatchK ''LamSig++type Term = AST Foil.NameBinder LamSig++-- | λx1. λx2. … λxn. xn, allocated in the given scope.+chainIn :: Foil.Distinct n => Foil.Scope n -> Int -> Foil.Name n -> Term n+chainIn _scope 0 x = Var x+chainIn scope k _x = Foil.withFresh scope $ \binder ->+  let scope' = Foil.extendScope binder scope+   in Node (Lam (ScopedAST binder (chainIn scope' (k - 1) (Foil.nameOf binder))))++-- | The chain over the empty scope: binders 0, 1, …, n−1.+plain :: Int -> Term Foil.VoidS+plain n = Foil.withFresh Foil.emptyScope $ \b0 ->+  let scope0 = Foil.extendScope b0 Foil.emptyScope+   in Node (Lam (ScopedAST b0 (chainIn scope0 (n - 1) (Foil.nameOf b0))))++-- | The same chain built under one dummy binder and cut back down:+-- binders 1, 2, …, n, so every level differs from 'plain' by exactly one.+shifted :: Int -> Term Foil.VoidS+shifted n = Foil.withFresh Foil.emptyScope $ \dummy ->+  let scope1 = Foil.extendScope dummy Foil.emptyScope+      t = Foil.withFresh scope1 $ \b1 ->+            let scope2 = Foil.extendScope b1 scope1+             in Node (Lam (ScopedAST b1 (chainIn scope2 (n - 1) (Foil.nameOf b1))))+   in fromMaybe (error "the chain uses the dummy binder")+        (unsinkAST Foil.emptyScope t)++sized :: Int -> Benchmark+sized n =+  let t1 = plain n+      t2 = shifted n+   in if not (alphaEquiv Foil.emptyScope t1 t2)+        then error "the two chains are not alpha-equivalent"+        else bgroup (show n <> " nested binders")+               [ bench "same binders (fast path)" $+                   whnf (alphaEquiv Foil.emptyScope t1) t1+               , bench "all binders differ (rename path)" $+                   whnf (alphaEquiv Foil.emptyScope t1) t2+               , bench "all binders differ, alphaEquivRefreshed" $+                   whnf (alphaEquivRefreshed Foil.emptyScope t1) t2+               ]++main :: IO ()+main = defaultMain [ sized n | n <- [250, 500, 1000, 2000] ]

@@ -0,0 +1,160 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DeriveTraversable   #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE PatternSynonyms     #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Restriction benchmark: cutting a chain of binders down to the ones a term+-- actually uses, the two ways it can be done.+--+-- This is the operation a parametrised module performs when it discharges a+-- declaration over the parameters it uses, and it is where the library's+-- account of /restriction/ is put under pressure. The question is the same+-- either way — which of these binders can the term do without? — and there are+-- two answers:+--+-- * ask once. 'supportOf' computes the term's free names in one traversal, and+--   'Foil.withThinnedNameBinderList' cuts the chain down to that set in one+--   step, so the term is walked once whatever the number of binders;+--+-- * ask per binder. 'unsinkAST' answers for one binder at a time, and each call+--   recomputes the term's support, so the term is walked once per binder.+--+-- The second is the shorter thing to write, and it is what a language+-- implementation reaches for first. The benchmark is here to say what it costs:+-- the two should separate linearly in the number of binders, and the point at+-- which they do is worth knowing, since a module with three parameters is the+-- common case and one with fourteen is not unheard of.+--+-- Both directions report the same number, and the benchmark checks that they+-- agree before timing them, so a change that breaks one is not silently+-- measured against the other.+module Main (main) where++import           Data.Bifoldable         (Bifoldable (..))+import           Data.List               (foldl')+import           Data.List.NonEmpty      (NonEmpty (..), nonEmpty)+import           Test.Tasty.Bench++import qualified Control.Monad.Foil      as Foil+import           Control.Monad.Free.Foil (AST (..), ScopedAST (..), pattern Var,+                                          supportOf, unsinkAST)++-- * A signature to build terms over++-- | Application and λ, which is all a term needs to have free variables and+-- binders in it.+data LamSig scope term+  = App term term+  | Lam scope+  deriving (Functor, Foldable, Traversable)++instance Bifoldable LamSig where+  bifoldMap f g = \case+    App l r -> g l <> g r+    Lam body -> f body++-- | Terms whose binders are single names, which is what a parameter block is.+type Term = AST Foil.NameBinder LamSig++-- * The workload++-- | A chain of @n@ binders over the empty scope.+--+-- The continuation is handed the innermost scope, the chain, and the scope+-- before each binder, innermost first.+withChain+  :: forall r. Int+  -> (forall l. Foil.Distinct l+        => Foil.NameBinderList Foil.VoidS l -> r)+  -> r+withChain total cont = go total Foil.emptyScope Foil.NameBinderListEmpty+  where+    go :: forall i. Foil.Distinct i+       => Int -> Foil.Scope i -> Foil.NameBinderList Foil.VoidS i -> r+    go 0 _scope chain = cont chain+    go k scope chain =+      Foil.withFresh scope $ \binder ->+        go (k - 1) (Foil.extendScope binder scope) (Foil.snocNameBinderList chain binder)++-- | A term over the given names, of a size the caller controls.+--+-- The names are used in a left-nested application spine, repeated until the+-- term has @uses@ leaves. Which names appear decides how far the chain can be+-- thinned; how many leaves there are decides what a traversal of the term+-- costs, and the two are what the benchmark varies.+spine :: Int -> NonEmpty (Foil.Name l) -> Term l+spine uses (first :| rest) = foldl' apply (Var first) (map Var more)+  where+    apply f x = Node (App f x)+    more = take (max 0 (uses - 1)) (cycle (first : rest))++-- * The two directions++-- | Ask once: one 'supportOf', then one thinning.+thinOnce :: Foil.Distinct l => Foil.NameBinderList Foil.VoidS l -> Term l -> Int+thinOnce chain term =+  Foil.withThinnedNameBinderList (supportOf term) chain $ \thinned ->+    length (Foil.namesOfPattern thinned)++-- | Ask per binder: peel the chain from the inside out, asking 'unsinkAST' at+-- each binder whether the term can do without it, and abstracting over it when+-- it cannot.+--+-- This is the shape the alternative really has, and the reason it costs what it+-- costs: the term is /rebuilt/ as the peeling goes, so each 'unsinkAST' faces a+-- different (and larger) term and has to compute its support afresh. Asking the+-- same question about one fixed term would let the compiler share that+-- computation, and then the two directions would be indistinguishable — which+-- is what a first version of this benchmark measured, and why it is written out+-- like this instead.+askPerBinder+  :: forall n l. Foil.Distinct n+  => Foil.Scope n -> Foil.NameBinderList n l -> Term l -> Int+askPerBinder scope binders term = fst (peel scope binders term)+  where+    peel :: forall m i. Foil.Distinct m+         => Foil.Scope m -> Foil.NameBinderList m i -> Term i -> (Int, Term m)+    peel _scope' Foil.NameBinderListEmpty inner = (0, inner)+    peel scope' (Foil.NameBinderListCons binder rest) inner =+      case (Foil.assertDistinct binder, Foil.assertExt binder) of+        (Foil.Distinct, Foil.Ext) ->+          let (kept, body) = peel (Foil.extendScope binder scope') rest inner+           in case unsinkAST scope' body of+                Just dropped -> (kept, dropped)+                Nothing      -> (kept + 1, Node (Lam (ScopedAST binder body)))++-- | Both directions, at one size, with the answers checked against each other.+--+-- @binders@ is how many the chain has, @keep@ how many of them the term names,+-- and @uses@ how many leaves the term has.+sizedBench :: Int -> Int -> Int -> Benchmark+sizedBench binders keep uses =+  withChain binders $ \chain ->+    case nonEmpty (take keep (Foil.namesOfPattern chain)) of+      Nothing -> error "a benchmark size must use at least one binder"+      Just names ->+        let term = spine uses names+            once = thinOnce chain term+            perBinder = askPerBinder Foil.emptyScope chain term+         in if once /= perBinder+              then error ("the two directions disagree: " <> show (once, perBinder))+              else bgroup (show binders <> " binders, " <> show keep <> " used, "+                            <> show uses <> " leaves")+                     [ bench "thin once"      (whnf (thinOnce chain) term)+                     , bench "ask per binder"+                         (whnf (askPerBinder Foil.emptyScope chain) term)+                     ]++main :: IO ()+main = defaultMain+  -- The term is held at one size while the chain grows, so what separates the+  -- two directions is the number of binders and nothing else.+  [ bgroup "a fixed term, a growing parameter block"+      [ sizedBench binders 2 64 | binders <- [1, 3, 7, 14, 32] ]+  -- And the other way round: a fixed block, a growing term.+  , bgroup "a fixed parameter block, a growing term"+      [ sizedBench 8 2 uses | uses <- [16, 64, 256, 1024] ]+  ]

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           free-foil-version:        0.3.3+version:        0.4.0 synopsis:       Efficient Type-Safe Capture-Avoiding Substitution for Free (Scoped Monads) description:    Please see the README on GitHub at <https://github.com/fizruk/free-foil#readme> category:       Parsing@@ -29,10 +29,13 @@ library   exposed-modules:       Control.Monad.Foil+      Control.Monad.Foil.Blocks       Control.Monad.Foil.Example       Control.Monad.Foil.Internal       Control.Monad.Foil.Internal.ValidNameBinders+      Control.Monad.Foil.Registry       Control.Monad.Foil.Relative+      Control.Monad.Foil.Telescope       Control.Monad.Foil.TH       Control.Monad.Foil.TH.MkFoilData       Control.Monad.Foil.TH.MkFromFoil@@ -41,6 +44,9 @@       Control.Monad.Foil.TH.Util       Control.Monad.Free.Foil       Control.Monad.Free.Foil.Annotated+      Control.Monad.Free.Foil.Artifact+      Control.Monad.Free.Foil.Binary+      Control.Monad.Free.Foil.Binary.TH       Control.Monad.Free.Foil.Example       Control.Monad.Free.Foil.TH       Control.Monad.Free.Foil.TH.Convert@@ -62,7 +68,9 @@       array >=0.5.3.0 && <0.6     , base >=4.19 && <5     , bifunctors >=5.5 && <5.7-    , containers >=0.6 && <0.9+    , binary >=0.8+    , bytestring >=0.11+    , containers >=0.6.8 && <0.9     , deepseq >=1.4 && <1.6     , kind-generics >=0.5.0 && <0.6     , template-haskell >=2.21.0.0 && <2.24@@ -80,7 +88,9 @@       array >=0.5.3.0 && <0.6     , base >=4.19 && <5     , bifunctors >=5.5 && <5.7-    , containers >=0.6 && <0.9+    , binary >=0.8+    , bytestring >=0.11+    , containers >=0.6.8 && <0.9     , deepseq >=1.4 && <1.6     , doctest-parallel     , free-foil@@ -93,23 +103,33 @@   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:+      Control.Monad.Foil.BlocksSpec       Control.Monad.Foil.NameMapSpec+      Control.Monad.Foil.NameRangeSpec+      Control.Monad.Foil.PatternTransportSpec+      Control.Monad.Foil.SinkableSpec       Control.Monad.Foil.UnifiablePatternSpec       Control.Monad.Foil.UnifyNameBindersSpec+      Control.Monad.Free.Foil.AlphaEquivSpec       Control.Monad.Free.Foil.AnnotatedSpec+      Control.Monad.Free.Foil.SupportSpec       Control.Monad.Free.Foil.TH.MkFreeFoilSpec       Control.Monad.Free.Foil.TH.MkFreeFoilSpec.Config       Control.Monad.Free.Foil.TH.MkFreeFoilSpec.Syntax       Data.ZipMatchK.THSpec+      SpecHook       Paths_free_foil   hs-source-dirs:       test   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N   build-depends:-      array >=0.5.3.0 && <0.6+      QuickCheck+    , array >=0.5.3.0 && <0.6     , base >=4.19 && <5     , bifunctors >=5.5 && <5.7-    , containers >=0.6 && <0.9+    , binary >=0.8+    , bytestring >=0.11+    , containers     , deepseq >=1.4 && <1.6     , free-foil     , hspec@@ -120,6 +140,29 @@     , text >=1.2.3.1 && <2.2   default-language: Haskell2010 +benchmark alphaequiv+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_free_foil+  hs-source-dirs:+      bench/alphaequiv+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -optP-Wno-nonportable-include-path -O2 -rtsopts+  build-depends:+      array >=0.5.3.0 && <0.6+    , base >=4.19 && <5+    , bifunctors >=5.5 && <5.7+    , binary >=0.8+    , bytestring >=0.11+    , containers >=0.6.8 && <0.9+    , deepseq >=1.4 && <1.6+    , free-foil+    , kind-generics >=0.5.0 && <0.6+    , tasty-bench+    , template-haskell >=2.21.0.0 && <2.24+    , text >=1.2.3.1 && <2.2+  default-language: Haskell2010+ benchmark normalize   type: exitcode-stdio-1.0   main-is: Main.hs@@ -132,7 +175,9 @@       array >=0.5.3.0 && <0.6     , base >=4.19 && <5     , bifunctors >=5.5 && <5.7-    , containers >=0.6 && <0.9+    , binary >=0.8+    , bytestring >=0.11+    , containers >=0.6.8 && <0.9     , deepseq >=1.4 && <1.6     , free-foil     , kind-generics >=0.5.0 && <0.6@@ -141,6 +186,29 @@     , text >=1.2.3.1 && <2.2   default-language: Haskell2010 +benchmark restriction+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_free_foil+  hs-source-dirs:+      bench/restriction+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -optP-Wno-nonportable-include-path -O2 -rtsopts+  build-depends:+      array >=0.5.3.0 && <0.6+    , base >=4.19 && <5+    , bifunctors >=5.5 && <5.7+    , binary >=0.8+    , bytestring >=0.11+    , containers >=0.6.8 && <0.9+    , deepseq >=1.4 && <1.6+    , free-foil+    , kind-generics >=0.5.0 && <0.6+    , tasty-bench+    , template-haskell >=2.21.0.0 && <2.24+    , text >=1.2.3.1 && <2.2+  default-language: Haskell2010+ benchmark zipmatchk   type: exitcode-stdio-1.0   main-is: Main.hs@@ -154,7 +222,9 @@       array >=0.5.3.0 && <0.6     , base >=4.19 && <5     , bifunctors >=5.5 && <5.7-    , containers >=0.6 && <0.9+    , binary >=0.8+    , bytestring >=0.11+    , containers >=0.6.8 && <0.9     , deepseq >=1.4 && <1.6     , free-foil     , kind-generics >=0.5.0 && <0.6

@@ -9,10 +9,10 @@ -- [«Free Foil: Generating Efficient and Scope-Safe Abstract Syntax»](https://arxiv.org/abs/2405.16384). -- -- Since the representation of scopes and substitutions--- is either 'IntMap' or 'IntSet', many of the operations+-- is either @IntMap@ or @IntSet@, many of the operations -- have a worst-case complexity of \(O(\min(n,W))\).--- This means that the operation can become linear in the size of the scope \(n\) with a maximum of \(W\)--- — the number of bits in an 'Int' (32 or 64).+-- This means that the operation can become linear in the size of the scope \(n\) with a+-- maximum of \(W\), the number of bits in an 'Int' (32 or 64). module Control.Monad.Foil (   -- * Safe scopes, names, and binders   S(..),@@ -26,20 +26,51 @@   nameOf,   namesOfPattern,   nameId,+  Id,+  RawName,   withFreshBinder,   withFresh,+  NameRange(..),+  fullNameRange,+  withFreshIn,+  tryWithFreshIn,   withFreshPattern,   withRefreshed,+  withRefreshedIn,   withRefreshedPattern,   withRefreshedPattern',   unsinkName,   unsinkNamePattern,+  -- * Sets of names and scope restriction+  NameSet,+  emptyNameSet,+  nameSetSingleton,+  nameSetInsert,+  nameSetMember,+  nameSetNull,+  nameSetSize,+  nameSetToList,+  nameSetFromList,+  nameSetOfPattern,+  scopeToNameSet,+  nameSetSubsetOfScope,+  unsinkNameSet,+  withRestrictedScope,   -- * Safe (co)sinking and renaming   SinkableK(..),   Sinkable(..),   CoSinkable(..),+  -- ** Transporting a pattern's payloads+  PatternTransport,+  verbatimTransport,+  transportUnderBinder,+  transportPayload,+  transportName,   HasNameBinders(getNameBinders),   sink,+  sink1,+  sink2,+  sinkabilityProof2,   sinkContainer,   extendRenaming,   extendNameBinderRenaming,@@ -50,6 +81,7 @@   Substitution,   lookupSubst,   identitySubst,+  nullSubst,   voidSubst,   addSubst,   addSubstPattern,@@ -62,6 +94,7 @@   andThenUnifyNameBinders,   UnifiablePattern(..),   UnifiableInPattern(..),+  AlphaEquiv(..),   NameBinders,   emptyNameBinders,   mergeNameBinders,@@ -70,6 +103,7 @@   -- * Name maps   NameMap,   emptyNameMap,+  mapWithName,   lookupName,   addNameBinder,   popNameBinder,@@ -78,11 +112,14 @@   addNameBinders,   addNameBinderList,   withFreshNameBinderList,+  withFreshNameBinderListIn,   NameBinderList(..),   nameBindersList,+  nameBinderListOf,   fromNameBindersList,   snocNameBinderList,   concatNameBinderLists,+  withThinnedNameBinderList,   -- * Constraints   Ext,   ExtEvidence(..),

@@ -0,0 +1,396 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Reserved name blocks, and linking of independently checked scopes.+--+-- Each unit of a module system allocates its names inside its own+-- reservation (a 'NameRange', via 'withFreshIn'), so that units checked+-- independently can be linked afterwards without renaming. 'ExtWithin' is+-- the evidence for that: scope @l@ extends scope @n@ only within a set of+-- reserved ranges. Note that the ranges bound the /extension/ and not the+-- scope, so the names of @n@ itself (typically, a unit's imports) may lie+-- anywhere.+--+-- Two units that extend a common scope within disjoint reservations have+-- disjoint extensions. 'withDisjointUnion' links them by comparing the+-- reservations rather than the scopes, and hands the continuation the+-- extension evidence for both sides, a 'ScopeUnion' witness that the result+-- is the union and nothing more, and the union's own evidence, so that a+-- linked unit is itself linkable. Evidence composes along a chain of units+-- with 'composeExtWithin'. To link more than two units, or to re-attach a+-- unit loaded from a cache, rebuild the union scope and mint the evidence+-- again with 'checkExtScope' and 'checkScopeUnion'.+--+-- 'checkExtScope' and 'checkScopeUnion' are a trust boundary. They compare+-- raw names across independently built scopes, which is meaningful only+-- under a deterministic reservation policy. Everything else in this module+-- either tests what it claims or constructs it.+module Control.Monad.Foil.Blocks (+  -- * Extension-within-a-range evidence+  ExtWithin,+  extWithinRanges,+  extWithinRefl,+  extWithinStep,+  composeExtWithin,+  -- * Blocks in use+  Block,+  beginBlock,+  resumeBlock,+  blockRange,+  blockExt,+  withFreshInBlock,+  -- * Bulk extension of a scope by a range+  withExtendScopeRange,+  -- * Linking+  ScopeUnion,+  withDisjointUnion,+  checkScopeUnion,+  checkExtScope,+  unionNameMaps,+) where++import           Data.List                   (sortOn)+import qualified Data.IntMap                 as IntMap+import qualified Data.IntSet                 as IntSet+import           Unsafe.Coerce               (unsafeCoerce)++import           Control.Monad.Foil.Internal++-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XFlexibleContexts+-- >>> import Control.Monad.Foil.Internal++-- | Evidence that scope @l@ extends scope @n@ only within a set of reserved+-- ranges: every name of @l@ that is not a name of @n@ lies inside one of+-- them.+--+-- The evidence is built alongside allocation, with 'extWithinRefl' at the+-- start of a unit and 'extWithinStep' at each binder, and composes along a+-- chain of scopes with 'composeExtWithin'. Its runtime content is the+-- ranges, sorted and disjoint.+--+-- @since 0.4.0+data ExtWithin (n :: S) (l :: S) = UnsafeExtWithin [NameRange]++-- | The reservations an 'ExtWithin' is evidence about: sorted, disjoint,+-- adjacent ranges coalesced, empty ones dropped.+--+-- @since 0.4.0+extWithinRanges :: ExtWithin n l -> [NameRange]+extWithinRanges (UnsafeExtWithin ranges) = ranges++-- | A scope extends itself within any range: the extension is empty.+--+-- Note that this does /not/ say the range is disjoint from the scope. It is+-- 'withExtendScopeRange' that checks that, because it allocates blindly.+--+-- @since 0.4.0+extWithinRefl :: NameRange -> ExtWithin n n+extWithinRefl range = UnsafeExtWithin (normaliseRanges [range])++-- | Extend the evidence across one more binder, if its name lies inside one+-- of the ranges. One membership test per range.+--+-- A binder allocated by 'withFreshIn' at one of these ranges always passes.+-- A binder allocated elsewhere, by 'withFresh' or 'withRefreshed', is+-- rejected with 'Nothing' unless it happens to land inside them, so the+-- evidence cannot be extended past a name that escapes the reservations.+--+-- >>> let range = NameRange 100 199+-- >>> withFreshIn range emptyScope (\b -> fmap extWithinRanges (extWithinStep b (extWithinRefl range)))+-- Just [NameRange {nameRangeLo = 100, nameRangeHi = 199}]+--+-- @since 0.4.0+extWithinStep :: NameBinder l l' -> ExtWithin n l -> Maybe (ExtWithin n l')+extWithinStep binder (UnsafeExtWithin ranges)+  | any (\(NameRange lo hi) -> lo <= x && x <= hi) ranges = Just (UnsafeExtWithin ranges)+  | otherwise = Nothing+  where+    x = nameId (nameOf binder)++-- | Compose evidence along a chain of scopes: if @m@ extends @n@ only within+-- one set of ranges and @l@ extends @m@ only within another, then @l@+-- extends @n@ only within their union.+--+-- The bound is the union of the two sets and not their hull, so a+-- reservation lying between them stays linkable. Adjacent ranges are+-- coalesced, so a chain of units with consecutive stripes collapses back to+-- a single range.+--+-- >>> extWithinRanges (composeExtWithin (extWithinRefl (NameRange 0 9)) (extWithinRefl (NameRange 30 39)))+-- [NameRange {nameRangeLo = 0, nameRangeHi = 9},NameRange {nameRangeLo = 30, nameRangeHi = 39}]+-- >>> extWithinRanges (composeExtWithin (extWithinRefl (NameRange 0 9)) (extWithinRefl (NameRange 10 19)))+-- [NameRange {nameRangeLo = 0, nameRangeHi = 19}]+--+-- @since 0.4.0+composeExtWithin :: ExtWithin n m -> ExtWithin m l -> ExtWithin n l+composeExtWithin (UnsafeExtWithin rs1) (UnsafeExtWithin rs2) =+  UnsafeExtWithin (normaliseRanges (rs1 <> rs2))++-- | Sort ranges, drop empty ones, and coalesce overlapping or adjacent ones.+normaliseRanges :: [NameRange] -> [NameRange]+normaliseRanges = go . sortOn nameRangeLo . filter nonEmpty+  where+    nonEmpty (NameRange lo hi) = lo <= hi+    go (NameRange lo1 hi1 : r2@(NameRange lo2 hi2) : rs)+      | lo2 <= hi1                      = go (NameRange lo1 (max hi1 hi2) : rs)+      | hi1 /= maxBound, lo2 == hi1 + 1 = go (NameRange lo1 hi2 : rs)+      | otherwise = NameRange lo1 hi1 : go (r2 : rs)+    go rs = rs++-- | Whether two sorted sets of disjoint ranges share a name. One sweep.+rangeSetsOverlap :: [NameRange] -> [NameRange] -> Bool+rangeSetsOverlap (r1@(NameRange lo1 hi1) : rs1) (r2@(NameRange lo2 hi2) : rs2)+  | hi1 < lo2 = rangeSetsOverlap rs1 (r2 : rs2)+  | hi2 < lo1 = rangeSetsOverlap (r1 : rs1) rs2+  | otherwise = True+rangeSetsOverlap _ _ = False++-- | A reservation in use: the range fresh names are allocated from, paired+-- with the evidence that everything allocated since the base scope @c@ lies+-- within the unit's ranges.+--+-- The allocation range is always among the evidence's ranges, so stepping+-- the evidence at a freshly allocated name cannot fail and 'withFreshInBlock'+-- is total. The two components are not redundant: the evidence is a+-- normalised set bounding the whole extension, and once units are composed+-- the range to allocate from can no longer be read off it.+--+-- @since 0.0.1+data Block (c :: S) (l :: S) = UnsafeBlock !NameRange (ExtWithin c l)++-- | Start a unit: no names allocated yet, so the evidence is trivial.+--+-- @since 0.4.0+beginBlock :: NameRange -> Block c c+beginBlock range = UnsafeBlock range (extWithinRefl range)++-- | Resume allocating from a range once the evidence has grown past what a+-- 'Block' tracked by itself, after composing in a loaded unit's evidence+-- with 'composeExtWithin'. This is what lets an interactive unit keep+-- allocating in its own reservation over the enlarged scope.+--+-- The allocation range must lie inside one of the evidence's ranges. The+-- ranges are normalised, so covering is containment in a single one, and+-- 'Nothing' says the range is not covered.+--+-- >>> let grown = composeExtWithin (extWithinRefl (NameRange 0 9)) (extWithinRefl (NameRange 10 19))+-- >>> fmap blockRange (resumeBlock (NameRange 0 9) grown)+-- Just (NameRange {nameRangeLo = 0, nameRangeHi = 9})+-- >>> fmap blockRange (resumeBlock (NameRange 30 39) grown)+-- Nothing+--+-- @since 0.4.0+resumeBlock :: NameRange -> ExtWithin c l -> Maybe (Block c l)+resumeBlock range@(NameRange lo hi) ext+  | lo > hi = Nothing+  | any covers (extWithinRanges ext) = Just (UnsafeBlock range ext)+  | otherwise = Nothing+  where+    covers (NameRange lo' hi') = lo' <= lo && hi <= hi'++-- | The range 'withFreshInBlock' allocates from.+--+-- @since 0.4.0+blockRange :: Block c l -> NameRange+blockRange (UnsafeBlock range _) = range++-- | The evidence accumulated so far: what a finished unit hands to+-- 'withDisjointUnion', or to 'composeExtWithin' for the next unit of a+-- chain.+--+-- @since 0.4.0+blockExt :: Block c l -> ExtWithin c l+blockExt (UnsafeBlock _ ext) = ext++-- | Allocate a fresh name in the block's range, stepping the evidence in+-- the same motion. Fails with 'error' only on an exhausted range, exactly+-- as 'withFreshIn' does.+--+-- >>> withFreshInBlock (beginBlock (NameRange 7 9)) emptyScope (\b block -> (nameId (nameOf b), extWithinRanges (blockExt block)))+-- (7,[NameRange {nameRangeLo = 7, nameRangeHi = 9}])+--+-- @since 0.4.0+withFreshInBlock+  :: Distinct l+  => Block c l  -- ^ The block to allocate from.+  -> Scope l    -- ^ The ambient scope.+  -> (forall l'. DExt l l' => NameBinder l l' -> Block c l' -> r)+  -> r+withFreshInBlock (UnsafeBlock range ext) scope cont =+  withFreshIn range scope $ \binder ->+    case extWithinStep binder ext of+      Just ext' -> cont binder (UnsafeBlock range ext')+      Nothing   -> error "impossible: withFreshIn allocated outside its own range"++-- | Extend a scope with the first @k@ names of a range, in one step.+--+-- This is the bulk form of a unit's allocation, for loading a cached unit+-- whose extension is known to be @k@ consecutive names, or for pre-allocating+-- a unit's names before checking its bodies. The range part of the scope must+-- be empty, which is checked, so the extension is fresh by construction.+-- 'Nothing' reports an occupied range, and also a range with fewer than @k@+-- names.+--+-- The continuation receives the extended scope, the binders in ascending+-- order (for extending a 'NameMap' in the same step), and the 'ExtWithin'+-- evidence. The scope extension is a dense 'IntSet.fromRange', \(O(k/W)\).+--+-- >>> withExtendScopeRange emptyScope (NameRange 100 199) 3 (\_ binders _ -> rawNameBinderList binders)+-- Just [100,101,102]+--+-- @since 0.4.0+withExtendScopeRange+  :: forall c r. Distinct c+  => Scope c      -- ^ The scope to extend (typically, a unit's imports).+  -> NameRange    -- ^ The unit's reservation.+  -> Int          -- ^ How many names to allocate.+  -> (forall n. DExt c n => Scope n -> NameBinderList c n -> ExtWithin c n -> r)+  -> Maybe r+withExtendScopeRange (UnsafeScope scope) range@(NameRange lo hi) k cont+  | k < 0                        = Nothing+  | rangeOccupied                = Nothing+  | toInteger k > rangeCapacity  = Nothing+  | otherwise =+      Just (unsafeExtendedWithin (UnsafeScope scope') binders (UnsafeExtWithin (normaliseRanges [range])) cont)+  where+    rangeOccupied = case IntSet.lookupGE lo scope of+      Just y  -> y <= hi+      Nothing -> False+    rangeCapacity = max 0 (toInteger hi - toInteger lo + 1)+    scope'+      | k == 0    = scope+      | otherwise = IntSet.union scope (IntSet.fromRange (lo, lo + (k - 1)))+    binders :: forall n. NameBinderList c n+    binders = go (if k == 0 then [] else [lo .. lo + (k - 1)])+      where+        go :: forall m m'. [RawName] -> NameBinderList m m'+        go []       = unsafeCoerce NameBinderListEmpty+        go (x : xs) = NameBinderListCons (UnsafeNameBinder (UnsafeName x)) (go xs)++-- | Unsafely mint the evidence for an extension built by this module.+--+-- Sound when the scope really is the given base extended by the binders, and+-- the binders' names lie inside the evidence's range and are fresh in the+-- base. The callers here check or construct all three.+unsafeExtendedWithin+  :: forall c n r+   . Scope n -> NameBinderList c n -> ExtWithin c n+  -> (DExt c n => Scope n -> NameBinderList c n -> ExtWithin c n -> r)+  -> r+unsafeExtendedWithin scope binders ext cont =+  case unsafeDistinct @n of+    Distinct -> case unsafeExt @c @n of+      Ext -> cont scope binders ext++-- | Link two scopes that extend a common scope @c@ within their respective+-- reservations. The evidence check is one sweep over the two range sets;+-- the scope union is one 'IntSet.union'.+--+-- 'Nothing' when the two range sets overlap. The test is soundness and not+-- an optimisation. The extensions @n \\ c@ and @m \\ c@ lie inside their+-- respective range sets, so their disjointness is what guarantees that no+-- raw name denotes two different variables in the union. The names the two+-- scopes share are exactly the names of @c@, identified rather than renamed+-- apart, which is what linking two units over a common import must do.+--+-- The continuation receives both extension facts at once, a 'ScopeUnion'+-- witness (which 'unionNameMaps' requires), and the union's own 'ExtWithin',+-- so that a linked unit is itself linkable and a whole build folds through+-- this one function. It also receives @'Ext' c k@, which a caller cannot+-- derive on the spot.+--+-- @since 0.4.0+withDisjointUnion+  :: forall c n m r. (Distinct n, Distinct m)+  => ExtWithin c n  -- ^ Evidence for the first unit.+  -> ExtWithin c m  -- ^ Evidence for the second unit.+  -> Scope n        -- ^ The first unit's scope.+  -> Scope m        -- ^ The second unit's scope.+  -> (forall k. (Ext n k, Ext m k, Ext c k, Distinct k)+        => Scope k -> ScopeUnion n m k -> ExtWithin c k -> r)+  -> Maybe r+withDisjointUnion (UnsafeExtWithin rs1) (UnsafeExtWithin rs2) (UnsafeScope s1) (UnsafeScope s2) cont+  | rangeSetsOverlap rs1 rs2 = Nothing+  | otherwise           = Just (unsafeUnion (UnsafeScope (IntSet.union s1 s2)))+  where+    unsafeUnion :: forall k. Scope k -> r+    unsafeUnion scope =+      case unsafeDistinct @k of+        Distinct -> case unsafeExt @n @k of+          Ext -> case unsafeExt @m @k of+            Ext -> case unsafeExt @c @k of+              -- Each side extends the base within its own ranges, so the+              -- names of c are in n and in m, hence in the union. This is+              -- handed to the continuation as a given because deriving it+              -- from Ext c n and Ext n k leaves the solver two candidate+              -- paths and it commits to neither.+              Ext -> cont scope UnsafeScopeUnion+                          (UnsafeExtWithin (normaliseRanges (rs1 <> rs2)))++-- | Evidence that scope @k@ is /precisely/ the union of scopes @n@ and @m@:+-- every name of @n@ and of @m@ is a name of @k@, and nothing else is.+--+-- The extension constraints @('Ext' n k, 'Ext' m k)@ state only the first+-- half, since a strict superset of the union satisfies them too. The second+-- half is what totality of a merged 'NameMap' rests on, so 'unionNameMaps'+-- demands this witness. It comes from 'withDisjointUnion', which builds the+-- union, or from 'checkScopeUnion', which tests for it.+--+-- @since 0.4.0+data ScopeUnion (n :: S) (m :: S) (k :: S) = UnsafeScopeUnion++-- | Test that a scope is precisely the union of two others, and produce the+-- witness if so. \(O(n+m)\).+--+-- This is the union witness for the re-attachment path, where the union+-- scope was rebuilt rather than handed down by 'withDisjointUnion'. Like+-- 'checkExtScope', it compares raw names across independently built scopes,+-- and is meaningful only under a deterministic reservation policy.+--+-- @since 0.4.0+checkScopeUnion :: Scope n -> Scope m -> Scope k -> Maybe (ScopeUnion n m k)+checkScopeUnion (UnsafeScope s1) (UnsafeScope s2) (UnsafeScope s3)+  | IntSet.union s1 s2 == s3 = Just UnsafeScopeUnion+  | otherwise                = Nothing++-- | Test that every name of one scope is a name of another, and mint the+-- extension evidence if so. \(O(n+m)\) ('IntSet.isSubsetOf').+--+-- __This is a trust boundary.__ The test compares raw names, and raw names+-- from independently built scopes need not mean the same variable. The type+-- system tracks meaning through binders, and this function goes around it+-- deliberately, to re-attach a scope built elsewhere: in an earlier run, in+-- a cache, or in a parallel session. It is sound only under the external+-- discipline that a raw name has one global meaning, which a deterministic+-- reservation policy provides. Nothing here checks that discipline, and the+-- caller's allocator is what has to.+--+-- @since 0.4.0+checkExtScope :: Scope n -> Scope l -> Maybe (ExtEvidence n l)+checkExtScope (UnsafeScope s1) (UnsafeScope s2)+  | s1 `IntSet.isSubsetOf` s2 = Just unsafeExt+  | otherwise                 = Nothing++-- | Union of two total maps into a map on the union of their scopes.+-- Left-biased, like 'IntMap.union'.+--+-- The witness is what makes the result total on @k@. The inputs are total on+-- @n@ and @m@, and 'ScopeUnion' says that @k@ holds their names and no+-- others. (It also determines @k@, which an extension constraint alone would+-- leave open.)+--+-- What no witness can say is that the two maps agree on the names their+-- scopes share. Linked units agree there when the shared part comes from the+-- same checked imports, and the left bias then only ever chooses between+-- equal entries.+--+-- @since 0.4.0+unionNameMaps :: ScopeUnion n m k -> NameMap n a -> NameMap m a -> NameMap k a+unionNameMaps UnsafeScopeUnion (NameMap m1) (NameMap m2) = NameMap (IntMap.union m1 m2)

@@ -14,6 +14,8 @@ -- >>> import Control.Monad.Foil  -- | Untyped \(\lambda\)-terms in scope @n@.+--+-- @since 0.0.1 data Expr n where   -- | Variables are names in scope @n@: \(x\)   VarE :: Name n -> Expr n@@ -59,6 +61,8 @@  -- | Substitution for untyped \(\lambda\)-terms. -- The foil helps implement this function without forgetting scope extensions and renaming.+--+-- @since 0.0.1 substitute :: Distinct o => Scope o -> Substitution Expr i o -> Expr i -> Expr o substitute scope subst = \case     VarE name -> lookupSubst subst name@@ -73,6 +77,8 @@ -- -- >>> whnf emptyScope (AppE (churchN 2) (churchN 2)) -- λx1. (λx0. λx1. (x0 (x0 x1)) (λx0. λx1. (x0 (x0 x1)) x1))+--+-- @since 0.0.1 whnf :: Distinct n => Scope n -> Expr n -> Expr n whnf scope = \case   AppE fun arg ->@@ -87,6 +93,8 @@ -- -- >>> whnf' (AppE (churchN 2) (churchN 2)) -- λx1. (λx0. λx1. (x0 (x0 x1)) (λx0. λx1. (x0 (x0 x1)) x1))+--+-- @since 0.0.1 whnf' :: Expr VoidS -> Expr VoidS whnf' = whnf emptyScope @@ -94,6 +102,8 @@ -- -- >>> nf emptyScope (AppE (churchN 2) (churchN 2)) -- λx1. λx2. (x1 (x1 (x1 (x1 x2))))+--+-- @since 0.0.1 nf :: Distinct n => Scope n -> Expr n -> Expr n nf scope expr = case expr of   LamE binder body ->@@ -116,10 +126,14 @@ -- -- >>> nf' (AppE (churchN 2) (churchN 2)) -- λx1. λx2. (x1 (x1 (x1 (x1 x2))))+--+-- @since 0.0.1 nf' :: Expr VoidS -> Expr VoidS nf' = nf emptyScope  -- | Pretty print a name.+--+-- @since 0.0.1 ppName :: Name n -> String ppName name = "x" <> show (nameId name) @@ -127,6 +141,8 @@ -- -- >>> ppExpr (churchN 3) -- "\955x0. \955x1. (x0 (x0 (x0 x1)))"+--+-- @since 0.0.1 ppExpr :: Expr n -> String ppExpr = \case   VarE name -> ppName name@@ -134,6 +150,8 @@   LamE binder body -> "λ" <> ppName (nameOf binder) <> ". " <> ppExpr body  -- | A helper for constructing \(\lambda\)-abstractions.+--+-- @since 0.0.1 lam :: Distinct n => Scope n -> (forall l. DExt n l => Scope l -> NameBinder n l -> Expr l) -> Expr n lam scope mkBody = withFresh scope $ \x ->   let scope' = extendScope x scope@@ -146,6 +164,8 @@ -- -- >>> churchN 3 -- λx0. λx1. (x0 (x0 (x0 x1)))+--+-- @since 0.0.1 churchN :: Int -> Expr VoidS churchN n =   lam emptyScope $ \sx nx ->

@@ -39,1422 +39,2386 @@ -- [«Free Foil: Generating Efficient and Scope-Safe Abstract Syntax»](https://arxiv.org/abs/2405.16384). -- -- Since the representation of scopes and substitutions--- is either 'IntMap' or 'IntSet', many of the operations--- have a worst-case complexity of \(O(\min(n,W))\).--- This means that the operation can become linear in the size of the scope \(n\) with a maximum of \(W\)--- — the number of bits in an 'Int' (32 or 64).-module Control.Monad.Foil.Internal where--import           Control.DeepSeq    (NFData (..))-import           Data.Bifunctor-import           Data.Coerce        (coerce)-import           Data.Functor.Compose (Compose (..))-import           Data.IntMap-import qualified Data.IntMap        as IntMap-import           Data.IntSet-import qualified Data.IntSet        as IntSet-import           Data.Kind          (Type)-import qualified Data.Type.Equality as Type-import           Generics.Kind-import           Unsafe.Coerce--import Control.Monad.Foil.Internal.ValidNameBinders---- $setup--- >>> :set -XDataKinds--- >>> :set -XFlexibleContexts--- >>> :set -Wno-simplifiable-class-constraints--- >>> import qualified Data.Map as Map---- * Safe types and operations---- | 'S' is a data kind of scope indices.-data S-  = VoidS -- ^ 'VoidS' is the only explicit scope available to the users, representing an empty scope.-          -- All other scopes are represented with type variables,-          -- bound in rank-2 polymophic functions like 'withFreshBinder'.---- | A safe scope, indexed by a type-level scope index 'n'.-newtype Scope (n :: S) = UnsafeScope RawScope-  deriving newtype NFData---- | A name in a safe scope, indexed by a type-level scope index 'n'.-newtype Name (n :: S) = UnsafeName RawName-  deriving newtype (NFData, Eq, Ord, Show)---- | Convert 'Name' into an identifier.--- This may be useful for printing and debugging.-nameId :: Name l -> Id-nameId (UnsafeName i) = i---- | A name binder is a name that extends scope @n@ to a (larger) scope @l@.-newtype NameBinder (n :: S) (l :: S) =-  UnsafeNameBinder (Name l)-    deriving newtype (NFData, Eq, Ord, Show)---- | An empty scope (without any names).-emptyScope :: Scope VoidS-emptyScope = UnsafeScope IntSet.empty---- | A runtime check for potential name capture.-member :: Name l -> Scope n -> Bool-member (UnsafeName name) (UnsafeScope s) = rawMember name s---- ** Extending scopes---- | \(O(\min(n,W))\).--- Extend a scope with one name (safely).--- Note that as long as the foil is used as intended,--- the name binder is guaranteed to introduce a name--- that does not appear in the initial scope.-extendScope :: NameBinder n l -> Scope n -> Scope l-extendScope (UnsafeNameBinder (UnsafeName name)) (UnsafeScope scope) =-  UnsafeScope (IntSet.insert name scope)---- | Extend scope with variables inside a pattern.--- This is a more flexible version of 'extendScope'.-extendScopePattern-  :: (Distinct n, CoSinkable pattern)-  => pattern n l -> Scope n -> Scope l-extendScopePattern pat scope = withPattern-  (\_scope' binder k ->-    unsafeAssertFresh binder $ \binder' ->-      k (ExtendScope (extendScope binder)) binder')-  idExtendScope-  compExtendScope-  scope-  pat-  (\(ExtendScope extend) _ -> extend scope)---- | Auxiliary data structure for scope extension. Used in 'extendScopePattern'.-newtype ExtendScope n l (o :: S) (o' :: S) = ExtendScope (Scope n -> Scope l)---- | Identity scope extension (no extension).-idExtendScope :: ExtendScope n n o o'-idExtendScope = ExtendScope id---- | Compose scope extensions.-compExtendScope-  :: ExtendScope n i o o'-  -> ExtendScope i l o' o''-  -> ExtendScope n l o o''-compExtendScope (ExtendScope f) (ExtendScope g)-  = ExtendScope (g . f)---- ** Collecting new names---- | Extract name from a name binder.-nameOf :: NameBinder n l -> Name l-nameOf (UnsafeNameBinder name) = name---- | Extract names from a pattern.--- This is a more flexible version of 'namesOf'.-namesOfPattern-  :: forall pattern n l. (Distinct n, CoSinkable pattern) => pattern n l -> [Name l]-namesOfPattern pat = withPattern @_ @n-  (\_scope' binder k ->-    unsafeAssertFresh binder $ \binder' ->-      k (NamesOf [nameOf binder]) binder')-  idNamesOf compNamesOf (error "impossible") pat-  (\(NamesOf names) _ -> names)---- | Auxiliary structure collecting names in scope @l@ that extend scope @n@.--- Used in 'namesOfPattern'.-newtype NamesOf (n :: S) l (o :: S) (o' :: S) = NamesOf [Name l]---- | Empty list of names in scope @n@.-idNamesOf :: NamesOf n n o o'-idNamesOf = NamesOf []---- | Concatenation of names, resulting in a list of names in @l@ that extend scope @n@.-compNamesOf :: NamesOf n i o o' -> NamesOf i l o' o'' -> NamesOf n l o o''-compNamesOf (NamesOf xs) (NamesOf ys) =-  NamesOf (coerce xs ++ ys)---- ** Refreshing binders---- | Allocate a fresh binder for a given scope.-withFreshBinder-  :: Scope n-  -> (forall l. NameBinder n l -> r) -> r-withFreshBinder (UnsafeScope scope) cont =-  cont binder-  where-    binder = UnsafeNameBinder (UnsafeName (rawFreshName scope))---- | Safely produce a fresh name binder with respect to a given scope.-withFresh-  :: Distinct n => Scope n-  -> (forall l. DExt n l => NameBinder n l -> r) -> r-withFresh scope cont = withFreshBinder scope (`unsafeAssertFresh` cont)---- | Rename a given pattern into a fresh version of it to extend a given scope.------ This is similar to 'withRefreshPattern', except here renaming always takes place.-withFreshPattern-  :: (Distinct o, CoSinkable pattern, Sinkable e, InjectName e)-  => Scope o      -- ^ Ambient scope.-  -> pattern n l  -- ^ Pattern to refresh (if it clashes with the ambient scope).-  -> (forall o'. DExt o o' => (Substitution e n o -> Substitution e l o') -> pattern o o' -> r)-  -- ^ Continuation, accepting the refreshed pattern.-  -> r-withFreshPattern scope pattern cont = withPattern-  (\scope' binder f -> withFresh scope'-    (\binder' -> f (WithRefreshedPattern (\subst -> addRename (sink subst) binder (nameOf binder'))) binder'))-  idWithRefreshedPattern-  compWithRefreshedPattern-  scope-  pattern-  (\(WithRefreshedPattern f) pattern' -> cont f pattern')---- | Safely rename (if necessary) a given name to extend a given scope.--- This is similar to 'withFresh', except if the name does not clash with--- the scope, it can be used immediately, without renaming.-withRefreshed-  :: Distinct o-  => Scope o    -- ^ Ambient scope.-  -> Name i     -- ^ Name to refresh (if it clashes with the ambient scope).-  -> (forall o'. DExt o o' => NameBinder o o' -> r)-  -- ^ Continuation, accepting the refreshed name.-  -> r-withRefreshed scope@(UnsafeScope rawScope) name@(UnsafeName rawName) cont-  | IntSet.member rawName rawScope = withFresh scope cont-  | otherwise = unsafeAssertFresh (UnsafeNameBinder name) cont---- | Safely rename (if necessary) a given pattern to extend a given scope.--- This is similar to 'withFreshPattern', except if a name in the pattern--- does not clash with the scope, it can be used immediately, without renaming.------ This is a more general version of 'withRefreshed'.------ Note that there is deliberately no fast path for the case when /every/ binder--- of the pattern is already fresh in the ambient scope. It is tempting to test--- all binders at once and, when none clashes, hand the continuation @sink@--- instead of a renaming composed per binder. That would be unsound.------ Even when a binder is not renamed, the per-binder step is not the identity:--- 'addRename' /deletes/ the name from the substitution, which is how the binder--- shadows an outer binding of the same raw name. For skipping that delete to be--- harmless we would need the substitution's domain to avoid the pattern's binder--- names, but the substitution's domain lives in the pattern's own scope @n@,--- while freshness is tested against the unrelated ambient scope @o@.------ The two can indeed disagree, because 'sink' is a coercion and does not rename:--- a term built in a small scope keeps its binder names when it is placed in a--- larger one, so a binder can share a raw name with its own enclosing scope. The--- @whnf@ examples in @Language.LambdaPi.Impl.FreeFoilTH@ show a @λ x1@ nested--- inside another @λ x1@ arising from ordinary evaluation. Handing such a caller--- @sink@ would apply its substitution to a name the pattern binds — that is,--- capture the bound variable.-withRefreshedPattern-  :: (Distinct o, CoSinkable pattern, Sinkable e, InjectName e)-  => Scope o      -- ^ Ambient scope.-  -> pattern n l  -- ^ Pattern to refresh (if it clashes with the ambient scope).-  -> (forall o'. DExt o o' => (Substitution e n o -> Substitution e l o') -> pattern o o' -> r)-  -- ^ Continuation, accepting the refreshed pattern.-  -> r-withRefreshedPattern scope pattern cont = withPattern-  (\scope' binder f -> withRefreshed scope' (nameOf binder)-    (\binder' -> f (WithRefreshedPattern (\subst -> addRename (sink subst) binder (nameOf binder'))) binder'))-  idWithRefreshedPattern-  compWithRefreshedPattern-  scope-  pattern-  (\(WithRefreshedPattern f) pattern' -> cont f pattern')---- | Refresh (if needed) bound variables introduced in a pattern.------ This is a version of 'withRefreshedPattern' that uses functional renamings instead of 'Substitution'.------ Like 'withRefreshedPattern', this has no all-binders-already-fresh fast path,--- and for the same reason. Here shadowing is handled by 'unsinkName' rather than--- by a delete: a name the pattern binds is routed to 'injectName' and never--- reaches the caller's renaming, whether or not the binder was refreshed.-withRefreshedPattern'-  :: (CoSinkable pattern, Distinct o, InjectName e, Sinkable e)-  => Scope o-  -> pattern n l-  -> (forall o'. DExt o o' => ((Name n -> e o) -> Name l -> e o') -> pattern o o' -> r) -> r-withRefreshedPattern' scope pattern cont = withPattern-  (\scope' binder f -> withRefreshed scope' (nameOf binder)-    (\binder' ->-      let k subst name = case unsinkName binder name of-              Nothing    -> injectName (nameOf binder')-              Just name' -> sink (subst name')-       in f (WithRefreshedPattern' k) binder'))-  idWithRefreshedPattern'-  compWithRefreshedPattern'-  scope-  pattern-  (\(WithRefreshedPattern' f) pattern' -> cont f pattern')---- | Unsafely declare that a given name (binder)--- is already fresh in any scope @n'@.-unsafeAssertFresh :: forall n l n' l' r. NameBinder n l-  -> (DExt n' l' => NameBinder n' l' -> r) -> r-unsafeAssertFresh binder cont =-  case unsafeDistinct @l' of-    Distinct -> case unsafeExt @n' @l' of-      Ext -> cont (unsafeCoerce binder)---- | Auxiliary structure to accumulate substitution extensions--- produced when refreshing a pattern.--- Used in 'withRefreshedPattern' and 'withFreshPattern'.-newtype WithRefreshedPattern e n l o o' = WithRefreshedPattern (Substitution e n o -> Substitution e l o')---- | Trivial substitution (coercion via 'sink').-idWithRefreshedPattern :: (Sinkable e, DExt o o') => WithRefreshedPattern e n n o o'-idWithRefreshedPattern = WithRefreshedPattern sink---- | Composition of substitution extensions.-compWithRefreshedPattern-  :: (DExt o o', DExt o' o'')-  => WithRefreshedPattern e n i o o'-  -> WithRefreshedPattern e i l o' o''-  -> WithRefreshedPattern e n l o o''-compWithRefreshedPattern (WithRefreshedPattern f) (WithRefreshedPattern g) =-  WithRefreshedPattern (g . f)---- | Auxiliary structure to accumulate substitution extensions--- produced when refreshing a pattern.--- Similar to 'WithRefreshedPattern', except here substitutions are represented as functions.--- Used in 'withRefreshedPattern''.-newtype WithRefreshedPattern' e n l (o :: S) (o' :: S) = WithRefreshedPattern' ((Name n -> e o) -> Name l -> e o')---- | Trivial substitution extension (coercion via 'sink').-idWithRefreshedPattern' :: (Sinkable e, DExt o o') => WithRefreshedPattern' e n n o o'-idWithRefreshedPattern' = WithRefreshedPattern' (\f n -> sink (f n))---- | Composition of substitution extensions.-compWithRefreshedPattern'-  :: (DExt o o', DExt o' o'')-  => WithRefreshedPattern' e n i o o'-  -> WithRefreshedPattern' e i l o' o''-  -> WithRefreshedPattern' e n l o o''-compWithRefreshedPattern' (WithRefreshedPattern' f) (WithRefreshedPattern' g) =-  WithRefreshedPattern' (g . f)---- ** Extracting proofs from binders and patterns---- | Evidence that scope @n@ contains distinct names.-data DistinctEvidence (n :: S) where-  Distinct :: Distinct n => DistinctEvidence n---- | Evidence that scope @l@ extends scope @n@.-data ExtEvidence (n :: S) (l :: S) where-  Ext :: Ext n l => ExtEvidence n l---- | A distinct scope extended with a 'NameBinder' is also distinct.-assertDistinct :: (Distinct n, CoSinkable pattern) => pattern n l -> DistinctEvidence l-assertDistinct _ = unsafeDistinct---- | A distinct scope extended with a 'NameBinder' is also distinct.-assertExt :: CoSinkable pattern => pattern n l -> ExtEvidence n l-assertExt _ = unsafeExt---- | Unsafely declare that scope @n@ is distinct.--- Used in 'unsafeAssertFresh'.-unsafeDistinct :: DistinctEvidence n-unsafeDistinct = unsafeCoerce (Distinct :: DistinctEvidence VoidS)---- | Unsafely declare that scope @l@ extends scope @n@.--- Used in 'unsafeAssertFresh'.-unsafeExt :: ExtEvidence n l-unsafeExt = unsafeCoerce (Ext :: ExtEvidence VoidS VoidS)---- ** Unsinking names---- | Try coercing the name back to the (smaller) scope,--- given a binder that extends that scope.-unsinkName :: NameBinder n l -> Name l -> Maybe (Name n)-unsinkName binder name@(UnsafeName raw)-  | nameOf binder == name = Nothing-  | otherwise = Just (UnsafeName raw)---- | Check if a name in the extended context--- is introduced in a pattern or comes from the outer scope @n@.------ This is a generalization of 'unsinkName'.-unsinkNamePattern-  :: forall pattern n l. (Distinct n, CoSinkable pattern)-  => pattern n l -> Name l -> Maybe (Name n)-unsinkNamePattern pat = withPattern @_ @n-  (\_scope' binder k ->-      unsafeAssertFresh binder $ \binder' ->-        k (UnsinkName (unsinkName binder)) binder')-  idUnsinkName-  compUnsinkName-  (error "impossible")  -- scope is not used, but has to be provided in general-  pat-  (\(UnsinkName unsink) _ -> unsink)---- | Auxiliary structure for unsinking names.--- Used in 'unsinkNamePattern'.-newtype UnsinkName n l (o :: S) (o' :: S) = UnsinkName (Name l -> Maybe (Name n))---- | Trivial unsinking. If no scope extension took place, any name is free (since it cannot be bound by anything).-idUnsinkName :: UnsinkName n n o o'-idUnsinkName = UnsinkName Just---- | Composition of unsinking for nested binders/patterns.-compUnsinkName-  :: UnsinkName n i o o'-  -> UnsinkName i l o' o''-  -> UnsinkName n l o o''-compUnsinkName (UnsinkName f) (UnsinkName g)-  = UnsinkName (\name -> g name >>= f)---- * Unification of binders---- | Unification result for two binders,--- extending some common scope to scopes @l@ and @r@ respectively.------ Due to the implementation of the foil, we can often rename binders efficiently,--- by renaming binders only in one of the two unified terms.-data UnifyNameBinders (pattern :: S -> S -> Type) n l r where-  -- | Binders are the same, proving that type parameters @l@ and @r@-  -- are in fact equivalent.-  SameNameBinders-    :: NameBinders n l  -- ^ /Unordered/ set of binders in the unified pattern (from any of the original patterns).-    -> UnifyNameBinders pattern n l l-  -- | It is possible to safely rename the left binder-  -- to match the right one.-  RenameLeftNameBinder-    :: NameBinders n r                    -- ^ /Unordered/ set of binders in the unified pattern (the binders from the right pattern).-    -> (NameBinder n l -> NameBinder n r) -- ^ Binder renaming for the left pattern.-    -> UnifyNameBinders pattern n l r-  -- | It is possible to safely rename the right binder-  -- to match the left one.-  RenameRightNameBinder-    :: NameBinders n l                    -- ^ /Unordered/ set of binders in the unified pattern (the binders from the left pattern).-    -> (NameBinder n r -> NameBinder n l) -- ^ Binder renaming for the right pattern.-    -> UnifyNameBinders pattern n l r-  -- | It is necessary to rename both binders.-  RenameBothBinders-    :: NameBinders n lr                     -- ^ /Unordered/ set of binders in the unified pattern-    -> (NameBinder n l -> NameBinder n lr)  -- ^ Binder renaming for the left pattern.-    -> (NameBinder n r -> NameBinder n lr)  -- ^ Binder renaming for the right pattern.-    -> UnifyNameBinders pattern n l r-  -- | Cannot unify to (sub)patterns.-  NotUnifiable :: UnifyNameBinders pattern n l r---- | Unify binders either by asserting that they are the same,--- or by providing a /safe/ renaming function to convert one binder to another.------ When the binders differ, the one with the /larger/ name is renamed towards the--- one with the smaller name. The direction is deliberate, but it is not what makes--- the renaming safe, and it is worth being explicit about that, since the choice--- looks arbitrary and has been "fixed" downstream before.------ The renaming returned here is not applied by substituting names blindly: callers--- push it through a term with 'Control.Monad.Foil.Relative.liftRM', which refreshes--- a binder whenever it would capture. So the target name may perfectly well be used--- by a binder /inside/ the term being renamed — a term built in a small scope keeps--- its small binder names when 'sink' places it in a larger one, so binder names do--- not always grow with depth — and the result is still correct. See--- @Control.Monad.Foil.UnifyNameBindersSpec@ for the term that exercises exactly--- this.-unifyNameBinders-  :: forall i l r pattern. Distinct i-  => NameBinder i l -- ^ Left pattern.-  -> NameBinder i r -- ^ Right pattern.-  -> UnifyNameBinders pattern i l r-unifyNameBinders l@(UnsafeNameBinder (UnsafeName i1)) r@(UnsafeNameBinder (UnsafeName i2))-  | i1 == i2  = case assertDistinct l of-      Distinct -> unsafeCoerce (SameNameBinders (nameBindersSingleton l))  -- equal names extend scopes equally-  | i1 < i2   = RenameRightNameBinder (nameBindersSingleton l) $ \(UnsafeNameBinder (UnsafeName i'')) ->-      if i'' == i2 then UnsafeNameBinder (UnsafeName i1) else UnsafeNameBinder (UnsafeName i'')-  | otherwise = RenameLeftNameBinder (nameBindersSingleton r) $ \(UnsafeNameBinder (UnsafeName i')) ->-      if i'  == i1 then UnsafeNameBinder (UnsafeName i2) else UnsafeNameBinder (UnsafeName i')---- | Unsafely merge results of unification for nested binders/patterns.--- Used in 'andThenUnifyPatterns'.-unsafeMergeUnifyBinders :: UnifyNameBinders pattern a a' a'' -> UnifyNameBinders pattern a''' b' b'' -> UnifyNameBinders pattern a b' b''-unsafeMergeUnifyBinders = \case--  SameNameBinders x -> \case-    SameNameBinders y -> SameNameBinders (x `unsafeMergeNameBinders` y)-    RenameLeftNameBinder y f -> RenameLeftNameBinder (x `unsafeMergeNameBinders` y) (unsafeCoerce f)-    RenameRightNameBinder y g -> RenameRightNameBinder (x `unsafeMergeNameBinders` y) (unsafeCoerce g)-    RenameBothBinders y f g -> RenameBothBinders (x `unsafeMergeNameBinders` y) (unsafeCoerce f) (unsafeCoerce g)-    NotUnifiable -> NotUnifiable--  RenameLeftNameBinder x f -> \case-    SameNameBinders y -> RenameLeftNameBinder (x `unsafeMergeNameBinders` y) (unsafeCoerce f)-    RenameLeftNameBinder y g -> RenameLeftNameBinder (x `unsafeMergeNameBinders` y) (unsafeCoerce f . unsafeCoerce g)-    RenameRightNameBinder y g -> RenameBothBinders (x `unsafeMergeNameBinders` y) (unsafeCoerce f) (unsafeCoerce g)-    RenameBothBinders y f' g -> RenameBothBinders (x `unsafeMergeNameBinders` y) (unsafeCoerce f . unsafeCoerce f') (unsafeCoerce g)-    NotUnifiable -> NotUnifiable--  RenameRightNameBinder x g -> \case-    SameNameBinders y -> RenameRightNameBinder (x `unsafeMergeNameBinders` y) (unsafeCoerce g)-    RenameLeftNameBinder y f -> RenameBothBinders (x `unsafeMergeNameBinders` y) (unsafeCoerce f) (unsafeCoerce g)-    RenameRightNameBinder y g' -> RenameRightNameBinder (x `unsafeMergeNameBinders` y) (unsafeCoerce g . unsafeCoerce g')-    RenameBothBinders y f g' -> RenameBothBinders (x `unsafeMergeNameBinders` y) (unsafeCoerce f) (unsafeCoerce g . unsafeCoerce g')-    NotUnifiable -> NotUnifiable--  RenameBothBinders x f g -> \case-    SameNameBinders y -> RenameBothBinders (x `unsafeMergeNameBinders` y) (unsafeCoerce f) (unsafeCoerce g)-    RenameLeftNameBinder y f' -> RenameBothBinders (x `unsafeMergeNameBinders` y) (unsafeCoerce f . unsafeCoerce f') (unsafeCoerce g)-    RenameRightNameBinder y g' -> RenameBothBinders (x `unsafeMergeNameBinders` y) (unsafeCoerce f) (unsafeCoerce g . unsafeCoerce g')-    RenameBothBinders y f' g' -> RenameBothBinders (x `unsafeMergeNameBinders` y) (unsafeCoerce f . unsafeCoerce f') (unsafeCoerce g . unsafeCoerce g')-    NotUnifiable -> NotUnifiable--  NotUnifiable -> const (NotUnifiable)---- | Chain unification of nested patterns.-andThenUnifyPatterns-  :: (UnifiablePattern pattern, Distinct l, Distinct l')-  => UnifyNameBinders pattern n l l'    -- ^ Unifying action for some outer patterns.-  -> (pattern l r, pattern l' r')       -- ^ Two nested patterns (cannot be unified directly since they extend different scopes).-  -> UnifyNameBinders pattern n r r'-andThenUnifyPatterns u (l, r) = unsafeMergeUnifyBinders u (unifyPatterns (unsafeCoerce l) r)---- | Chain unification of nested patterns with 'NameBinder's.-andThenUnifyNameBinders-  :: (UnifiablePattern pattern, Distinct l, Distinct l')-  => UnifyNameBinders pattern n l l'    -- ^ Unifying action for some outer patterns.-  -> (NameBinder l r, NameBinder l' r') -- ^ Two nested binders (cannot be unified directly since they extend different scopes).-  -> UnifyNameBinders pattern n r r'-andThenUnifyNameBinders u (l, r) = unsafeMergeUnifyBinders u (unifyNameBinders (unsafeCoerce l) r)---- | An /unordered/ collection of 'NameBinder's, that together extend scope @n@ to scope @l@.------ For an ordered version see 'NameBinderList'.-newtype NameBinders (n :: S) (l :: S) = UnsafeNameBinders IntSet---- | /Unsafely/ merge sets of binders (via set union).-unsafeMergeNameBinders :: NameBinders a b -> NameBinders c d -> NameBinders n l-unsafeMergeNameBinders (UnsafeNameBinders x) (UnsafeNameBinders y) = UnsafeNameBinders (x <> y)---- | An empty set of binders keeps the scope as is.-emptyNameBinders :: NameBinders n n-emptyNameBinders = UnsafeNameBinders IntSet.empty---- | Composition of sets of binders.-mergeNameBinders :: NameBinders n i -> NameBinders i l -> NameBinders n l-mergeNameBinders = unsafeMergeNameBinders---- | A singleton name binder set.-nameBindersSingleton :: NameBinder n l -> NameBinders n l-nameBindersSingleton binder = UnsafeNameBinders (IntSet.singleton (nameId (nameOf binder)))---- | An /ordered/ collection (list) of 'NameBinder's, that together extend scope @n@ to scope @l@.------ For an unordered version see 'NameBinders'.-data NameBinderList n l where-  -- | An empty list of binders keeps the scope as is.-  NameBinderListEmpty :: NameBinderList n n-  -- | A non-empty list of binders.-  NameBinderListCons-    :: NameBinder n i       -- ^ Outermost binder.-    -> NameBinderList i l   -- ^ Remaining list of binders.-    -> NameBinderList n l---- | Convert an unordered set of name binders into an ordered list (with some order).-nameBindersList :: NameBinders n l -> NameBinderList n l-nameBindersList (UnsafeNameBinders names) = go (IntSet.toList names)-  where-    go []     = unsafeCoerce NameBinderListEmpty-    go (x:xs) = NameBinderListCons (UnsafeNameBinder (UnsafeName x)) (go xs)---- | Add a binder to the end of an (ordered) list of binders.------ Note that 'NameBinderListCons' adds a binder to the /front/ of the list, which--- is the outermost position. This adds one to the innermost position instead.-snocNameBinderList :: NameBinderList n i -> NameBinder i l -> NameBinderList n l-snocNameBinderList NameBinderListEmpty binder =-  NameBinderListCons binder NameBinderListEmpty-snocNameBinderList (NameBinderListCons binder binders) binder' =-  NameBinderListCons binder (snocNameBinderList binders binder')---- | Concatenate two (ordered) lists of binders, the second extending the scope--- that the first extends to.-concatNameBinderLists :: NameBinderList n i -> NameBinderList i l -> NameBinderList n l-concatNameBinderLists NameBinderListEmpty binders = binders-concatNameBinderLists (NameBinderListCons binder binders) binders' =-  NameBinderListCons binder (concatNameBinderLists binders binders')---- | Convert an ordered list of name binders into an unordered set.-fromNameBindersList :: NameBinderList n l -> NameBinders n l-fromNameBindersList = UnsafeNameBinders . IntSet.fromList . go-  where-    go :: NameBinderList n l -> [RawName]-    go NameBinderListEmpty                 = []-    go (NameBinderListCons binder binders) = nameId (nameOf binder) : go binders--instance CoSinkable NameBinders where-  coSinkabilityProof _rename (UnsafeNameBinders names) cont =-    cont unsafeCoerce (UnsafeNameBinders names)--  withPattern withBinder unit comp scope binders cont =-    withPattern withBinder unit comp scope (nameBindersList binders) $ \f binders' ->-      cont f (fromNameBindersList binders')--instance CoSinkable NameBinderList where-  coSinkabilityProof rename NameBinderListEmpty cont = cont rename NameBinderListEmpty-  coSinkabilityProof rename (NameBinderListCons binder binders) cont =-    coSinkabilityProof rename binder $ \rename' binder' ->-      coSinkabilityProof rename' binders $ \rename'' binders' ->-        cont rename'' (NameBinderListCons binder' binders')--  withPattern withBinder unit comp scope binders cont = case binders of-    NameBinderListEmpty -> cont unit NameBinderListEmpty-    NameBinderListCons x xs ->-      withBinder scope x $ \f x' ->-        let scope' = extendScopePattern x' scope-        in withPattern withBinder unit comp scope' xs $ \f' xs' ->-            cont (comp f f') (NameBinderListCons x' xs')---- ** Pattern combinators---- | An empty pattern type specifies zero possibilities for patterns.------ This type can be used to specify that patterns are not possible.-data V2 (n :: S) (l :: S)---- | Since 'V2' values logically don't exist, this witnesses the logical reasoning tool of "ex falso quodlibet".-absurd2 :: V2 n l -> a-absurd2 v2 = case v2 of {}--instance CoSinkable V2 where-  coSinkabilityProof _ v2 _ = absurd2 v2-  withPattern _ _ _ _ v2 _ = absurd2 v2-instance UnifiablePattern V2 where-  unifyPatterns = absurd2---- | A unit pattern type corresponds to a wildcard pattern.-data U2 (n :: S) (l :: S) where-  U2 :: U2 n n  -- ^ Wildcard patten does not modify the scope.--instance CoSinkable U2 where-  coSinkabilityProof rename U2 cont = cont rename U2-  withPattern _withBinder unit _combine _scope U2 cont = cont unit U2-instance UnifiablePattern U2 where-  unifyPatterns U2 U2 = SameNameBinders emptyNameBinders---- ** Unifiable patterns---- | A pattern type is unifiable if it is possible to match two--- patterns and decide how to rename binders.------ Note that the default implementation compares patterns only up to their--- binders; see 'unifyPatterns' for what that does and does not distinguish.-class CoSinkable pattern => UnifiablePattern pattern where-  -- | Unify two patterns and decide which binders need to be renamed.-  unifyPatterns :: Distinct n => pattern n l -> pattern n r -> UnifyNameBinders pattern n l r--  -- | The default implementation flattens both patterns to their binders (via-  -- 'nameBinderListOf') and unifies the resulting 'NameBinderList's. It therefore-  -- compares only the /number and order/ of binders, and ignores-  ---  -- * the constructor, so two patterns built from /different/ constructors with-  --   the same number of binders unify;-  -- * non-binding fields (locations, sorts, literals), whatever their values;-  -- * the nesting of sub-patterns, so @(x, (y, z))@ unifies with @((x, y), z)@.-  ---  -- For most languages this is the intended notion of α-equivalence: what the-  -- body of a binding construct can refer to is precisely the pattern's binders,-  -- in order. Since α-equivalence is defined in terms of 'unifyPatterns', this-  -- also means that terms differing only in such a pattern are α-equivalent.-  ---  -- If your patterns carry data that is semantically relevant, this default is-  -- not what you want and you should write the instance by hand — see the-  -- @UnifiablePattern Pattern@ instance in @Language.LambdaPi.Impl.Foil@ for a-  -- structural one. Use 'UnifiableInPattern' to compare non-binding fields, which-  -- also lets you deliberately ignore some of them (as-  -- @Language.LambdaPi.Impl.FreeFoilTH@ does for BNFC source positions).-  ---  -- The behaviour described here is pinned down in-  -- @Control.Monad.Foil.UnifiablePatternSpec@.-  default unifyPatterns-    :: (CoSinkable pattern, Distinct n)-    => pattern n l -> pattern n r -> UnifyNameBinders pattern n l r-  unifyPatterns l r = coerce (unifyPatterns (nameBinderListOf l) (nameBinderListOf r))--instance UnifiablePattern NameBinderList where-  unifyPatterns NameBinderListEmpty NameBinderListEmpty = SameNameBinders emptyNameBinders-  unifyPatterns (NameBinderListCons x xs) (NameBinderListCons y ys) =-    case (assertDistinct x, assertDistinct y) of-      (Distinct, Distinct) -> unifyNameBinders x y `andThenUnifyPatterns` (xs, ys)-  -- Lists of different lengths are not unifiable. This case is reachable-  -- whenever a language has patterns that bind different numbers of names ---  -- a wildcard and a variable, say -- since the default 'unifyPatterns'-  -- flattens every pattern to a 'NameBinderList'. Note that this module sets-  -- @-Wno-incomplete-patterns@, so its absence was not reported.-  unifyPatterns _ _ = NotUnifiable---- | Unification of values in patterns.--- By default, 'Eq' instance is used, but it may be useful to ignore--- some data in pattens (such as location annotations).-class UnifiableInPattern a where-  -- | Unify non-binding components of a pattern.-  unifyInPattern :: a -> a -> Bool-  default unifyInPattern :: Eq a => a -> a -> Bool-  unifyInPattern = (==)--instance UnifiablePattern NameBinder where-  unifyPatterns = unifyNameBinders---- | The easiest way to compare two patterns is to check if they are the same.--- This function is labelled /unsafe/, since we generally are interested in proper α-equivalence--- instead of direct equality.-unsafeEqPattern :: (UnifiablePattern pattern, Distinct n) => pattern n l -> pattern n' l' -> Bool-unsafeEqPattern l r =-  case unifyPatterns l (unsafeCoerce r) of-    SameNameBinders{} -> True-    _                 -> False---- * Safe sinking---- | Sinking an expression from scope @n@ into a (usualy extended) scope @l@,--- given the renaming (injection from scope @n@ to scope @l@).-class Sinkable (e :: S -> Type) where-  -- | An implementation of this method that typechecks-  -- proves to the compiler that the expression is indeed-  -- 'Sinkable'. However, instead of this implementation, 'sink'-  -- should be used at all call sites for efficiency.-  sinkabilityProof-    :: (Name n -> Name l)   -- ^ Map names from scope @n@ to a (possibly larger) scope @l@.-    -> e n                  -- ^ Expression with free variables in scope @n@.-    -> e l--  default sinkabilityProof-    :: (GenericK e, GSinkableK (RepK e)) => (Name n -> Name l) -> e n -> e l-  sinkabilityProof rename = toK . gsinkabilityProof1 rename . fromK---- | Sinking a 'Name' is as simple as applying the renaming.-instance Sinkable Name where-  sinkabilityProof rename = rename---- | A container of sinkable expressions is sinkable, elementwise.------ The point of this instance is 'sinkContainer': since the proof typechecks,--- sinking the whole container is a coercion, and does not walk its spine.-instance (Functor f, Sinkable e) => Sinkable (Compose f e) where-  sinkabilityProof rename (Compose xs) = Compose (fmap (sinkabilityProof rename) xs)---- | Efficient version of 'sinkabilityProof'.--- In fact, once 'sinkabilityProof' typechecks,--- it is safe to 'sink' by coercion.--- See Section 3.5 in [«The Foil: Capture-Avoiding Substitution With No Sharp Edges»](https://doi.org/10.1145/3587216.3587224) for the details.-sink :: (Sinkable e, DExt n l) => e n -> e l-sink = unsafeCoerce---- | Sink an entire container of sinkable expressions, in \(O(1)\).------ The soundness argument for 'sink' extends to a container of sinkables — an--- 'Data.IntMap.IntMap' of terms, a 'Data.Map.Map' keyed by something else, a--- list of them — so there is no need to walk the spine with @'fmap' 'sink'@, and--- entering a binder need not be \(O(size)\).------ >>> :{--- sinkEnv :: DExt n l => Map.Map String (Name n) -> Map.Map String (Name l)--- sinkEnv = sinkContainer--- :}------ Two things this does /not/ cover:------ * A 'Scope' is __not__ sinkable, and must not be sunk: it is the set of names---   /in/ scope @n@, and it has to grow when a binder is entered (see 'extendScope').--- * A 'NameMap' must stay __total__ on the names in scope ('lookupName' errors---   otherwise), so sinking one has to be paired with adding the new binder's---   entry (see 'addNameBinder').-sinkContainer :: (Functor f, Sinkable e, DExt n l) => f (e n) -> f (e l)-sinkContainer = getCompose . sink . Compose---- | Extend renaming when going under a 'CoSinkable' pattern (generalized binder).--- Note that the scope under pattern is independent of the codomain of the renaming.------ This function is used to go under binders when implementing 'sinkabilityProof'--- and is both a generalization of 'extendRenamingNameBinder' and an efficient implementation of 'coSinkabilityProof'.-extendRenaming-  :: CoSinkable pattern-  => (Name n -> Name n')  -- ^ Map names from scope @n@ to a (possibly larger) scope @n'@.-  -> pattern n l          -- ^ A pattern that extends scope @n@ to another scope @l@.-  -> (forall l'. (Name l -> Name l') -> pattern n' l' -> r )-  -- ^ A continuation, accepting an extended renaming from @l@ to @l'@ (which itself extends @n'@)-  -- and a (possibly refreshed) pattern that extends @n'@ to @l'@.-  -> r-extendRenaming _ pattern cont =-  cont unsafeCoerce (unsafeCoerce pattern)---- | Extend renaming of binders when going under a 'CoSinkable' pattern (generalized binder).--- Note that the scope under pattern is independent of the codomain of the renaming.-extendNameBinderRenaming-  :: CoSinkable pattern-  => (NameBinder i n -> NameBinder i n')  -- ^ Map names from scope @n@ to a (possibly larger) scope @n'@.-  -> pattern n l          -- ^ A pattern that extends scope @n@ to another scope @l@.-  -> (forall l'. (NameBinder n' l -> NameBinder n' l') -> pattern n' l' -> r )-  -- ^ A continuation, accepting an extended renaming from @l@ to @l'@ (which itself extends @n'@)-  -- and a (possibly refreshed) pattern that extends @n'@ to @l'@.-  -> r-extendNameBinderRenaming _ pattern cont =-  cont unsafeCoerce (unsafeCoerce pattern)---- | Safely compose renamings of name binders.--- The underlying implementation is-composeNameBinderRenamings-  :: (NameBinder n i -> NameBinder n i')    -- ^ Rename binders extending scope @n@ from @i@ to @i'@.-  -> (NameBinder i' l -> NameBinder i' l')  -- ^ Rename binders extending scope @i'@ from @l@ to @l'@.-  -> (NameBinder n l -> NameBinder n l')-composeNameBinderRenamings = unsafeCoerce (flip (.))---- | Convert renaming of name binders into renaming of names in the inner scopes.-fromNameBinderRenaming :: (NameBinder n l -> NameBinder n l') -> Name l -> Name l'-fromNameBinderRenaming = coerce---- | Extend renaming when going under a 'NameBinder'.--- Note that the scope under binder is independent of the codomain of the renaming.------ Semantically, this function may need to rename the binder (resulting in the new scope @l'@),--- to make sure it does not clash with scope @n'@.--- However, as it turns out, the foil makes it safe--- to implement this function as a coercion.--- See Appendix A in [«The Foil: Capture-Avoiding Substitution With No Sharp Edges»](https://doi.org/10.1145/3587216.3587224) for the details.------ This function is used to go under binders when implementing 'sinkabilityProof'.--- A generalization of this function is 'extendRenaming' (which is an efficient version of 'coSinkabilityProof').-extendRenamingNameBinder-  :: (Name n -> Name n')  -- ^ Map names from scope @n@ to a (possibly larger) scope @n'@.-  -> NameBinder n l       -- ^ A name binder that extends scope @n@ to another scope @l@.-  -> (forall l'. (Name l -> Name l') -> NameBinder n' l' -> r )-  -- ^ A continuation, accepting an extended renaming from @l@ to @l'@ (which itself extends @n'@)-  -- and a (possibly refreshed) binder that extends @n'@ to @l'@.-  -> r-extendRenamingNameBinder _ (UnsafeNameBinder name) cont =-  cont unsafeCoerce (UnsafeNameBinder name)---- | 'CoSinkable' is to patterns (generalized binders)--- what 'Sinkable' is to expressions.------ See Section 2.3 of [«Free Foil: Generating Efficient and Scope-Safe Abstract Syntax»](https://arxiv.org/abs/2405.16384) for more details.-class CoSinkable (pattern :: S -> S -> Type) where-  -- | An implementation of this method that typechecks-  -- proves to the compiler that the pattern is indeed-  -- 'CoSinkable'. However, instead of this implementation,-  -- 'extendRenaming' should be used at all call sites for efficiency.-  coSinkabilityProof-    :: (Name n -> Name n')  -- ^ Map names from scope @n@ to a (possibly larger) scope @n'@.-    -> pattern n l          -- ^ A pattern that extends scope @n@ to another scope @l@.-    -> (forall l'. (Name l -> Name l') -> pattern n' l' -> r)-    -- ^ A continuation, accepting an extended renaming from @l@ to @l'@ (which itself extends @n'@)-    -- and a (possibly refreshed) pattern that extends @n'@ to @l'@.-    -> r-  default coSinkabilityProof-    :: (GenericK pattern, GSinkableK (RepK pattern))-    => (Name n -> Name n')-    -> pattern n l-    -> (forall l'. (Name l -> Name l') -> pattern n' l' -> r)-    -> r-  coSinkabilityProof rename p cont = gsinkabilityProof2 rename (fromK @_ @pattern p) $ \rename' p' ->-    cont rename' (toK @_ @pattern p')--  -- | Generalized processing of a pattern.-  ---  -- You can see 'withPattern' as a CPS-style traversal over the binders in a pattern.-  withPattern-    :: Distinct o-    => (forall x y z r'. Distinct z => Scope z -> NameBinder x y -> (forall z'. DExt z z' => f x y z z' -> NameBinder z z' -> r') -> r')-    -- ^ Processing of a single 'NameBinder', this will be applied to each binder in a pattern.-    -> (forall x z z'. DExt z z' => f x x z z')-    -- ^ Result in case no binders are present. This can be seen as scope-indexed 'mempty'.-    -> (forall x y y' z z' z''. (DExt z z', DExt z' z'') => f x y z z' -> f y y' z' z'' -> f x y' z z'')-    -- ^ Composition of results for nested binders/patterns. This can be seen as scope-indexed 'mappend'.-    -> Scope o-    -- ^ Ambient scope.-    -> pattern n l-    -- ^ Pattern to process.-    -> (forall o'. DExt o o' => f n l o o' -> pattern o o' -> r)-    -- ^ Continuation, accepting result for the entire pattern and a (possibly refreshed) pattern.-    -> r-  default withPattern-    :: (Distinct o, GenericK pattern, GValidNameBinders pattern (RepK pattern), GHasNameBinders (RepK pattern))-    => (forall x y z r'. Distinct z => Scope z -> NameBinder x y -> (forall z'. DExt z z' => f x y z z' -> NameBinder z z' -> r') -> r')-    -> (forall x z z'. DExt z z' => f x x z z')-    -> (forall x y y' z z' z''. (DExt z z', DExt z' z'') => f x y z z' -> f y y' z' z'' -> f x y' z z'')-    -> Scope o-    -> pattern n l-    -> (forall o'. DExt o o' => f n l o o' -> pattern o o' -> r)-    -> r-  withPattern = gunsafeWithPatternViaHasNameBinders---- | Auxiliary data structure for collecting name binders. Used in 'nameBinderListOf'.-newtype WithNameBinderList r n l (o :: S) (o' :: S) = WithNameBinderList (NameBinderList l r -> NameBinderList n r)---- | Empty list of name binders (identity).-idWithNameBinderList :: DExt o o' => WithNameBinderList r n n o o'-idWithNameBinderList = WithNameBinderList id---- | Concatenating lists of name binders (compose).-compWithNameBinderList-  :: (DExt o o', DExt o' o'')-  => WithNameBinderList r n i o o'-  -> WithNameBinderList r i l o' o''-  -> WithNameBinderList r n l o o''-compWithNameBinderList (WithNameBinderList f) (WithNameBinderList g) =-  WithNameBinderList (f . g)---- | Collect name binders of a generalized pattern into a name binder list,--- which can be more easily traversed.-nameBinderListOf :: (CoSinkable binder) => binder n l -> NameBinderList n l-nameBinderListOf pat = withPattern-  (\_scope' binder k ->-    unsafeAssertFresh binder $ \binder' ->-      k (WithNameBinderList (NameBinderListCons binder)) binder')-  idWithNameBinderList-  compWithNameBinderList-  emptyScope-  pat-  (\(WithNameBinderList f) _ -> f NameBinderListEmpty)--instance CoSinkable NameBinder where-  coSinkabilityProof _rename (UnsafeNameBinder name) cont =-    cont unsafeCoerce (UnsafeNameBinder name)--  withPattern f _ _ = f---- * Safe substitions---- | A substitution is a mapping from names in scope @i@--- to expressions @e o@ in scope @o@.-newtype Substitution (e :: S -> Type) (i :: S) (o :: S) =-  UnsafeSubstitution (IntMap (e o))---- | Apply substitution to a given name.-lookupSubst :: InjectName e => Substitution e i o -> Name i -> e o-lookupSubst (UnsafeSubstitution env) (UnsafeName name) =-    case IntMap.lookup name env of-        Just ex -> ex-        Nothing -> injectName (UnsafeName name)---- | Identity substitution maps all names to expresion-variables.-identitySubst-  :: InjectName e => Substitution e i i-identitySubst = UnsafeSubstitution IntMap.empty---- | An empty substitution from an empty scope.-voidSubst :: Substitution e VoidS n-voidSubst = UnsafeSubstitution IntMap.empty---- | Extend substitution with a particular mapping.-addSubst-  :: Substitution e i o-  -> NameBinder i i'-  -> e o-  -> Substitution e i' o-addSubst (UnsafeSubstitution env) (UnsafeNameBinder (UnsafeName name)) ex-  = UnsafeSubstitution (IntMap.insert name ex env)--addSubstPattern-  :: CoSinkable binder-  => Substitution e i o-  -> binder i i'-  -> [e o]-  -> Substitution e i' o-addSubstPattern subst pat = addSubstList subst (nameBinderListOf pat)--addSubstList-  :: Substitution e i o-  -> NameBinderList i i'-  -> [e o]-  -> Substitution e i' o-addSubstList subst NameBinderListEmpty _ = subst-addSubstList subst (NameBinderListCons binder binders) (x:xs) =-  addSubstList (addSubst subst binder x) binders xs-addSubstList _ _ [] = error "cannot add a binder to Substitution since the value list does not have enough elements"---- | Add variable renaming to a substitution.------ When the binder is mapped to its own name, the name is /deleted/ from the--- substitution rather than mapped to itself. This is an optimization, but it is--- not only an optimization: it is also how the binder shadows an outer binding--- of the same raw name, so the delete cannot be skipped even when nothing is--- being renamed. See 'withRefreshedPattern' for why that rules out an--- all-binders-fresh fast path.-addRename :: InjectName e => Substitution e i o -> NameBinder i i' -> Name o -> Substitution e i' o-addRename s@(UnsafeSubstitution env) b@(UnsafeNameBinder (UnsafeName name1)) n@(UnsafeName name2)-    | name1 == name2 = UnsafeSubstitution (IntMap.delete name1 env)-    | otherwise = addSubst s b (injectName n)---- | Substitutions are sinkable as long as corresponding expressions are.-instance (Sinkable e) => Sinkable (Substitution e i) where-  sinkabilityProof rename (UnsafeSubstitution env) =-    UnsafeSubstitution (fmap (sinkabilityProof rename) env)---- * 'Name' maps---- | A /total/ map from names in scope @n@ to elements of type @a@.-newtype NameMap (n :: S) a = NameMap { getNameMap :: IntMap a } deriving (Functor, Foldable, Traversable)---- | An empty map belongs in the empty scope.-emptyNameMap :: NameMap VoidS a-emptyNameMap = NameMap IntMap.empty---- | Convert a 'NameMap' of expressions into a 'Substitution'.-nameMapToSubstitution :: NameMap i (e o) -> Substitution e i o-nameMapToSubstitution (NameMap m) = (UnsafeSubstitution m)---- | Convert a 'NameMap' of expressions into a 'Scope'.-nameMapToScope :: NameMap n a -> Scope n-nameMapToScope (NameMap m) = UnsafeScope (IntMap.keysSet m)---- | Extend a map with multiple mappings (by repeatedly applying 'addNameBinder').------ Note that the input list is expected to have __at least__ the same number of elements--- as there are binders in the input pattern (generalized binder).-addNameBinders :: CoSinkable binder => binder n l -> [a] -> NameMap n a -> NameMap l a-addNameBinders pat = addNameBinderList (nameBinderListOf pat)---- | Extend a map with multiple mappings (by repeatedly applying 'addNameBinder').------ Note that the input list is expected to have __at least__ the same number of elements--- as there are binders in the input name binder list.------ See also 'addNameBinders' for a generalized version.-addNameBinderList :: NameBinderList n l -> [a] -> NameMap n a -> NameMap l a-addNameBinderList NameBinderListEmpty _ = id-addNameBinderList (NameBinderListCons binder binders) (x:xs) =-  addNameBinderList binders xs . addNameBinder binder x-addNameBinderList _ [] = error "cannot add a binder to NameMap since the value list does not have enough elements"---- | Looking up a name should always succeed.------ Note that since 'Name' is 'Sinkable', you can lookup a name from scope @n@ in a 'NameMap' for scope @l@ whenever @l@ extends @n@.-lookupName :: Name n -> NameMap n a -> a-lookupName name (NameMap m) =-  case IntMap.lookup (nameId name) m of-    Nothing -> error "impossible: unknown name in a NameMap"-    Just x  -> x---- | Extending a map with a single mapping.------ Note that the scope parameter of the result differs from the initial map.-addNameBinder :: NameBinder n l -> a -> NameMap n a -> NameMap l a-addNameBinder name x (NameMap m) = NameMap (IntMap.insert (nameId (nameOf name)) x m)---- | Remove the mapping for a binder, shrinking the map back to the outer scope.------ This is the inverse of 'addNameBinder', and is what a type checker wants when--- it leaves a binder it has entered.-popNameBinder :: NameBinder n l -> NameMap l a -> NameMap n a-popNameBinder binder (NameMap m) = NameMap (IntMap.delete (nameId (nameOf binder)) m)---- | Allocate a fresh binder for each element of a list, binding each element to--- its binder in the map.------ The continuation receives the extended scope, the binders in the order of the--- input list, and the extended map. This is the list-shaped counterpart of--- 'withFresh', and saves a caller from threading the scope, the binders, and the--- map through a recursion by hand.-withFreshNameBinderList-  :: forall n a r. Distinct n-  => [a]                  -- ^ A value to bind to each fresh binder.-  -> Scope n              -- ^ The ambient scope.-  -> NameMap n a          -- ^ The map to extend.-  -> (forall l. DExt n l => Scope l -> NameBinderList n l -> NameMap l a -> r)-  -> r-withFreshNameBinderList xs0 scope0 nameMap0 cont =-    go xs0 scope0 NameBinderListEmpty nameMap0 cont-  where-    go :: forall i r'. Distinct i-       => [a] -> Scope i -> NameBinderList n i -> NameMap i a-       -> (forall l. DExt n l => Scope l -> NameBinderList n l -> NameMap l a -> r')-       -> r'-    go [] scope binders nameMap cont' =-      case (assertDistinct binders, assertExt binders) of-        (Distinct, Ext) -> cont' scope binders nameMap-    go (x:xs) scope binders nameMap cont' =-      withFresh scope $ \binder ->-        go xs-           (extendScope binder scope)-           (snocNameBinderList binders binder)-           (addNameBinder binder x nameMap)-           cont'---- * Raw types and operations---- | We will use 'Int' for efficient representation of identifiers.-type Id = Int---- | Raw name is simply an identifier.-type RawName = Id---- | A raw scope is a set of raw names.-type RawScope = IntSet---- | \(O(\min(n, W))\).--- Generate a fresh raw name that--- does not appear in a given raw scope.-rawFreshName :: RawScope -> RawName-rawFreshName scope | IntSet.null scope = 0-                   | otherwise = IntSet.findMax scope + 1---- | Check if a raw name is contained in a raw scope.-rawMember :: RawName -> RawScope -> Bool-rawMember = IntSet.member---- * Constraints---- | Every scope is a (trivial) extension of itself.------ __Important__: this class exists to assist tracking scope extensions--- for type variables of kind 'S'.--- Users of the foil are not supposed to implement any instances of 'ExtEndo'.-class ExtEndo (n :: S)---- | Some scopes are extensions of other scopes.------ __Important__: this class exists to assist tracking scope extensions--- for type variables of kind 'S'.--- Users of the foil are not supposed to implement any instances of 'Ext'.-class (ExtEndo n => ExtEndo l ) => Ext (n :: S) (l :: S)-instance ( ExtEndo n => ExtEndo l ) => Ext n l---- | Scopes with distinct names.------ __Important__: this class exists to explicitly--- mark scopes with distinct names.--- Users of the foil are not supposed to implement any instances of 'Distinct'.-class Distinct (n :: S)-instance Distinct VoidS---- | Scope extensions with distinct names.-type DExt n l = (Distinct l, Ext n l)---- | Instances of this typeclass possess the ability to inject names.--- Usually, this is a variable data constructor.-class InjectName (e :: S -> Type) where-  -- | Inject names into expressions.-  injectName :: Name n -> e n---- * Kind-polymorphic sinkability--data RenamingsK (as :: LoT k) (bs :: LoT k) where-  RNil :: RenamingsK LoT0 LoT0-  RCons :: (Name a -> Name b) -> RenamingsK as bs -> RenamingsK (a :&&: as) (b :&&: bs)-  RSkip :: RenamingsK as bs -> RenamingsK (k :&&: as) (k :&&: bs)--class SinkableK (f :: S -> k) where-  sinkabilityProofK-    :: forall as bs r.-       RenamingsK as bs-    -> f :@@: as-    -> (forall cs. RenamingsK as cs -> f :@@: cs -> r)-    -> r-  default sinkabilityProofK :: forall as bs r.-      (GenericK f, GSinkableK (RepK f))-    => RenamingsK as bs-    -> f :@@: as-    -> (forall cs. RenamingsK as cs -> f :@@: cs -> r)-    -> r-  sinkabilityProofK rename e cont =-    gsinkabilityProofK rename (fromK @_ @f e) $ \rename' e' ->-      cont rename' (toK @_ @f e')--sinkK :: GSinkableK f => RenamingsK xs as -> RenamingsK xs bs -> f :@@: as -> f :@@: bs-sinkK _ _ = unsafeCoerce--instance SinkableK Name where-  sinkabilityProofK renameK@(RCons rename RNil) name cont = cont renameK (rename name)-instance SinkableK NameBinder where-  sinkabilityProofK (RCons _ RNil) (UnsafeNameBinder name) cont =-    cont (RCons unsafeCoerce RNil) (UnsafeNameBinder name)-instance SinkableK NameBinders where-  sinkabilityProofK (RCons _ RNil) (UnsafeNameBinders s) cont =-    cont (RCons unsafeCoerce RNil) (UnsafeNameBinders s)--instance GenericK NameBinderList where-  type RepK NameBinderList = ((Var0 :~~: Var1) :=>: U1) :+: Exists S-    (Field (NameBinder :$: Var1 :@: Var0) :*: Field (NameBinderList :$: Var0 :@: Var2))-  toK (L1 (SuchThat U1))                   = NameBinderListEmpty-  toK (R1 (Exists (Field x :*: Field xs))) = NameBinderListCons x xs-  fromK NameBinderListEmpty       = L1 (SuchThat U1)-  fromK (NameBinderListCons x xs) = R1 (Exists (Field x :*: Field xs))--instance GenericK V2 where-  type RepK V2 = V1-  toK _v1 = error "absurd: Generics.Kind.V1"-  fromK = absurd2--instance GenericK U2 where-  type RepK U2 = ((Var0 :~~: Var1) :=>: U1)-  toK (SuchThat U1) = U2-  fromK U2 = SuchThat U1--instance SinkableK NameBinderList-instance SinkableK V2-instance SinkableK U2--sinkabilityProof1 :: SinkableK f => (Name n -> Name n') -> f n -> f n'-sinkabilityProof1 rename e = sinkabilityProofK (RCons rename RNil) e $ \_ e' -> unsafeCoerce e'--gsinkabilityProof1 :: GSinkableK f => (Name n -> Name n') -> f (n :&&: LoT0) -> f (n' :&&: LoT0)-gsinkabilityProof1 rename e = gsinkabilityProofK (RCons rename RNil) e $ \_ e' -> unsafeCoerce e'--gsinkabilityProof2-  :: forall f n n' l r. GSinkableK f-  => (Name n -> Name n') -> f (n :&&: l :&&: LoT0)-  -> (forall l'. (Name l -> Name l') -> f (n' :&&: l' :&&: LoT0) -> r)-  -> r-gsinkabilityProof2 rename e cont =-  gsinkabilityProofK (RCons rename (RCons id RNil)) e $ \case-    RCons (_ :: Name n -> Name n'') (RCons rename' RNil) -> \e' ->-      case unsafeCoerce (Type.Refl :: n' Type.:~: n') :: n' Type.:~: n'' of-        Type.Refl -> cont rename' e'--gsinkabilityProofK' :: GSinkableK f => RenamingsK as bs -> f as -> f bs-gsinkabilityProofK' renameK e = gsinkabilityProofK renameK e $ \_ e' -> unsafeCoerce e'--class GSinkableK p where-  gsinkabilityProofK-    :: forall as bs r.-       RenamingsK as bs-    -> p as-    -> (forall cs. RenamingsK as cs -> p cs -> r)-    -> r--gsinkK :: GSinkableK f => RenamingsK xs as -> RenamingsK xs bs -> f as -> f bs-gsinkK _ _ = unsafeCoerce--instance GSinkableK V1 where-  gsinkabilityProofK irename _v1 cont =-    cont irename (error "absurd: Generics.Kind.V1")--instance GSinkableK U1 where-  gsinkabilityProofK irename U1 cont =-    cont irename U1--instance GSinkableK f => GSinkableK (M1 i c f) where-  gsinkabilityProofK irename (M1 x) cont =-    gsinkabilityProofK irename x $ \irename' x' ->-      cont irename' (M1 x')--instance (GSinkableK f, GSinkableK g) => GSinkableK (f :+: g) where-  gsinkabilityProofK irename (L1 x) cont =-    gsinkabilityProofK irename x $ \irename' x' ->-      cont irename' (L1 x')-  gsinkabilityProofK irename (R1 x) cont =-    gsinkabilityProofK irename x $ \irename' x' ->-      cont irename' (R1 x')--instance (GSinkableK f, GSinkableK g) => GSinkableK (f :*: g) where-  gsinkabilityProofK irename (x :*: y) cont =-    gsinkabilityProofK irename x $ \irename' x' ->-      gsinkabilityProofK irename' y $ \irename'' y' ->-        cont irename'' (gsinkK irename' irename'' x' :*: y')--instance GSinkableK f => GSinkableK (Exists S f) where-  gsinkabilityProofK irename (Exists x) cont =-    gsinkabilityProofK (RCons id irename) x $ \case-      RCons _ irename' -> \x' ->-        cont irename' (Exists x')--instance {-# OVERLAPPABLE #-} GSinkableK f => GSinkableK (Exists k f) where-  gsinkabilityProofK irename (Exists x) cont =-    gsinkabilityProofK (RSkip irename) x $ \case-      RSkip irename' -> \x' ->-        cont irename' (Exists x')--instance GSinkableK f => GSinkableK ((a :~~: b) :=>: f) where-  gsinkabilityProofK irename (SuchThat x) cont =-    gsinkabilityProofK irename x $ \(irename' :: RenamingsK as cs) x' ->-      -- this is sort of safe...-      case unsafeCoerce (Type.Refl :: Interpret a cs Type.:~: Interpret a cs) :: Interpret a cs Type.:~: Interpret b cs of-        Type.Refl -> cont irename' (SuchThat x')--instance GSinkableK (Field (Kon a)) where-  gsinkabilityProofK irename (Field x) cont =-    cont irename (Field x)--instance GSinkableK (Field (Var a)) where-  gsinkabilityProofK irename (Field x) cont =-    cont irename (Field (unsafeCoerce x)) -- FIXME: unsafeCoerce?--instance (SinkableK f, ExtractRenamingK i) => GSinkableK (Field (Kon f :@: Var i)) where-  gsinkabilityProofK irename (Field x) cont =-    sinkabilityProofK (RCons (extractRenamingK @_ @i irename) RNil) x $ \case-      RCons rename' RNil -> \x' ->-        cont (putBackRenamingK @_ @i rename' irename) (Field (unsafeCoerce x')) -- unsafeCoerce?--instance SinkableK (f a) => GSinkableK (Field (Kon f :@: Kon a :@: Var0)) where-  gsinkabilityProofK irename@(RCons _ RNil) (Field x) cont =-    sinkabilityProofK irename x $ \rename' x' ->-      cont rename' (Field x')--instance SinkableK (f a b) => GSinkableK (Field (Kon f :@: Kon a :@: Kon b :@: Var0)) where-  gsinkabilityProofK irename@(RCons _ RNil) (Field x) cont =-    sinkabilityProofK irename x $ \rename' x' ->-      cont rename' (Field x')--class ExtractRenamingK (i :: TyVar k S) where-  extractRenamingK :: forall (as :: LoT k) (bs :: LoT k).-    RenamingsK as bs -> Name (Interpret (Var i) as) -> Name (Interpret (Var i) bs)-  putBackRenamingK :: forall c (as :: LoT k) (bs :: LoT k).-       (Name (Interpret (Var i) as) -> Name c)-    -> RenamingsK as bs-    -> RenamingsK as (PutBackLoT i c bs)--instance ExtractRenamingK VZ where-  extractRenamingK (RCons f _fs) = f-  putBackRenamingK f (RCons _ gs) = RCons f gs--instance ExtractRenamingK x => ExtractRenamingK (VS x) where-  extractRenamingK (RCons _f fs) = extractRenamingK @_ @x fs-  putBackRenamingK f (RCons g gs) = RCons g (putBackRenamingK @_ @x f gs)--extractTwoRenamingsK :: forall k (i :: TyVar k S) (j :: TyVar k S) (as :: LoT k) (bs :: LoT k).-    (ExtractRenamingK i, ExtractRenamingK j)-  => RenamingsK as bs-  -> RenamingsK-      (Interpret (Var i) as :&&: Interpret (Var j) as :&&: LoT0)-      (Interpret (Var i) bs :&&: Interpret (Var j) bs :&&: LoT0)-extractTwoRenamingsK irename =-  (RCons (extractRenamingK @_ @i irename) (RCons (extractRenamingK @_ @j irename) RNil))--putBackTwoRenamingsK :: forall k (i :: TyVar k S) (j :: TyVar k S) c1 c2 (as :: LoT k) (bs :: LoT k).-    (ExtractRenamingK i, ExtractRenamingK j)-  => RenamingsK-      (Interpret (Var i) as :&&: Interpret (Var j) as :&&: LoT0)-      (c1 :&&: c2 :&&: LoT0)-  -> RenamingsK as bs-  -> RenamingsK as (PutBackLoT j c2 (PutBackLoT i c1 bs))-putBackTwoRenamingsK (RCons f1 (RCons f2 RNil)) rename-  = putBackRenamingK @_ @j f2 (putBackRenamingK @_ @i f1 rename)--instance (SinkableK f, ExtractRenamingK i, ExtractRenamingK j) => GSinkableK (Field (Kon f :@: Var (i :: TyVar k S) :@: Var (j :: TyVar k S))) where-  gsinkabilityProofK irename (Field x) cont =-    sinkabilityProofK (extractTwoRenamingsK @_ @i @j irename) x $ \rename' x' ->-      case rename' of-        RCons _ (RCons _ RNil) ->-          cont (putBackTwoRenamingsK @_ @i @j rename' irename)-              (Field (unsafeCoerce x'))  -- FIXME: can we do better than unsafeCoerce?--instance (Functor f, GSinkableK (Field x)) => GSinkableK (Field (Kon f :@: x)) where-  gsinkabilityProofK irename (Field x) cont =-    cont irename (Field (fmap-      (unField . gsinkabilityProofK' @(Field x) irename . Field)-      x))--instance (Bifunctor f, GSinkableK (Field x), GSinkableK (Field y)) => GSinkableK (Field (Kon f :@: x :@: y)) where-  gsinkabilityProofK irename (Field x) cont =-    cont irename (Field (bimap-      (unField . gsinkabilityProofK' @(Field x) irename . Field)-      (unField . gsinkabilityProofK' @(Field y) irename . Field)-      x))---- * Kind-polymorphic types with binders---- ** Generic version of 'withPattern'---- | Generic generalized processing of a pattern via 'GHasNameBinders'.------ This can be used as a default implementation of 'withPattern'.-gunsafeWithPatternViaHasNameBinders-  :: forall pattern f o n l r.-      (Distinct o, GenericK pattern, GValidNameBinders pattern (RepK pattern), GHasNameBinders (RepK pattern))-  => (forall x y z r'. Distinct z => Scope z -> NameBinder x y -> (forall z'. DExt z z' => f x y z z' -> NameBinder z z' -> r') -> r')-  -- ^ Processing of a single 'NameBinder', this will be applied to each binder in a pattern.-  -> (forall x z z'. DExt z z' => f x x z z')-  -- ^ Result in case no binders are present. This can be seen as scope-indexed 'mempty'.-  -> (forall x y y' z z' z''. (DExt z z', DExt z' z'') => f x y z z' -> f y y' z' z'' -> f x y' z z'')-  -- ^ Composition of results for nested binders/patterns. This can be seen as scope-indexed 'mappend'.-  -> Scope o-  -- ^ Ambient scope.-  -> pattern n l-  -- ^ Pattern to process.-  -> (forall o'. DExt o o' => f n l o o' -> pattern o o' -> r)-  -- ^ Continuation, accepting result for the entire pattern and a (possibly refreshed) pattern.-  -> r-gunsafeWithPatternViaHasNameBinders withBinder id_ comp_ scope pat cont =-  withPattern withBinder id_ comp_ scope (ggetNameBinders pat) $ \result binders ->-    cont result (gunsafeSetNameBinders (unsafeCoerce pat) binders) -- FIXME: safer version---- ** Manipulating nested 'NameBinder's--- | If @'HasNameBinders' f@, then @f n l@ is expected to act as a binder,--- introducing into scope @n@ some local variables, extending it to scope @l@.--- This class allows to extract and modify the set of binders.-class HasNameBinders f where-  -- | Extract a set of binders from a pattern.-  getNameBinders :: f n l -> NameBinders n l-  getNameBinders = UnsafeNameBinders . IntSet.fromList . getNameBindersRaw--  -- | Replace binders in a pattern.-  ---  -- This function is unsafe, because it does not check if the new set of binders-  -- has the same size. It can therefore crash at runtime.-  ---  -- You should probably not use this.-  -- This is only used for 'gunsafeWithPatternViaHasNameBinders', which is then safe to use.-  unsafeSetNameBinders :: f n l -> NameBinders n l' -> f n l'-  unsafeSetNameBinders e (UnsafeNameBinders m) = fst (reallyUnsafeSetNameBindersRaw e (IntSet.toList m))--  -- | Extract 'RawName's of all binders occurring in a pattern.-  getNameBindersRaw :: f n l -> [RawName]-  default getNameBindersRaw :: forall n l. (GenericK f, GHasNameBinders (RepK f)) => f n l -> [RawName]-  getNameBindersRaw = ggetNameBindersRaw . fromK @_ @f @(n :&&: l :&&: LoT0)--  -- | This is a version of 'unsafeSetNameBinders'-  -- that takes in a list of 'RawName's.-  ---  -- It does not check if the given list has enough elements.-  -- It does not check if the raw names are fresh in the scope @n@.-  -- It does not check if the raw names given are distinct.-  ---  -- You should never use this. This is only used for generic implementation of 'HasNameBinders'.-  reallyUnsafeSetNameBindersRaw :: f n l -> [RawName] -> (f n l', [RawName])-  default reallyUnsafeSetNameBindersRaw :: forall n l l'. (GenericK f, GValidNameBinders f (RepK f), GHasNameBinders (RepK f)) => f n l -> [RawName] -> (f n l', [RawName])-  reallyUnsafeSetNameBindersRaw e names =-    let (e', names') = greallyUnsafeSetNameBindersRaw (fromK @_ @f @(n :&&: l :&&: LoT0) e) names-     in (toK @_ @f @(n :&&: l' :&&: LoT0) e', names')--instance HasNameBinders NameBinder where-  getNameBindersRaw (UnsafeNameBinder (UnsafeName name)) = [name]-  reallyUnsafeSetNameBindersRaw _ (name:names) = (UnsafeNameBinder (UnsafeName name), names)--instance HasNameBinders NameBinderList---- ** Generic--ggetNameBinders :: forall f n l. (GenericK f, GHasNameBinders (RepK f)) => f n l -> NameBinders n l-ggetNameBinders = UnsafeNameBinders . IntSet.fromList . ggetNameBindersRaw . fromK @_ @f @(n :&&: l :&&: LoT0)--gunsafeSetNameBinders :: forall f n l l'. (GenericK f, GValidNameBinders f (RepK f), GHasNameBinders (RepK f)) => f n l -> NameBinders n l' -> f n l'-gunsafeSetNameBinders e (UnsafeNameBinders m) = toK @_ @f @(n :&&: l' :&&: LoT0) $-  fst (greallyUnsafeSetNameBindersRaw (fromK @_ @f @(n :&&: l :&&: LoT0) e) (IntSet.toList m))--class GHasNameBinders f where-  ggetNameBindersRaw :: f as -> [RawName]-  greallyUnsafeSetNameBindersRaw :: f as -> [RawName] -> (f bs, [RawName])--instance GHasNameBinders V1 where-  ggetNameBindersRaw _ = error "absurd: Generics.Kind.V1"-  greallyUnsafeSetNameBindersRaw _ _ = error "absurd: Generics.Kind.V1"-instance GHasNameBinders U1 where-  ggetNameBindersRaw U1 = []-  greallyUnsafeSetNameBindersRaw U1 names = (U1, names)--instance (GHasNameBinders f, GHasNameBinders g) => GHasNameBinders (f :+: g) where-  ggetNameBindersRaw (L1 x) = ggetNameBindersRaw x-  ggetNameBindersRaw (R1 x) = ggetNameBindersRaw x--  greallyUnsafeSetNameBindersRaw (L1 x) names = first L1 (greallyUnsafeSetNameBindersRaw x names)-  greallyUnsafeSetNameBindersRaw (R1 x) names = first R1 (greallyUnsafeSetNameBindersRaw x names)---- | FIXME: this is, perhaps, the most "unsafe" place for the user--- since it does not reject "parallel" binders:------    data BadPattern n l = BadPattern (NameBinder n l) (NameBinder n l)------ This instance will treat both binders in the same way as "nested":------    data GoodPattern n l = forall i. GoodPattern (NameBinder n i) (NameBinder i l)------ However, Template Haskell code at the moment will never generate "parallel" binders,--- and the very user is unlikely to misuse this instance, since "parallel" binders--- require extra effort to support it.------ Still, it would be better to detect and reject any "parallel" or otherwise improper binders.+-- is either @IntMap@ or @IntSet@, many of the operations+-- have a worst-case complexity of \(O(\min(n,W))\).+-- This means that the operation can become linear in the size of the scope \(n\) with a+-- maximum of \(W\), the number of bits in an 'Int' (32 or 64).+module Control.Monad.Foil.Internal where++import           Control.DeepSeq    (NFData (..))+import           Data.Bifunctor+import           Data.Coerce        (coerce)+import           Data.Functor.Compose (Compose (..))+import           Data.Bifunctor.Tannen (Tannen (..))+import           Data.IntMap+import qualified Data.IntMap        as IntMap+import qualified Data.Map+import           Data.IntSet+import qualified Data.IntSet        as IntSet+import           Data.Kind          (Type)+import qualified Data.Type.Equality as Type+import           Generics.Kind+import           Unsafe.Coerce++import Control.Monad.Foil.Internal.ValidNameBinders++-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XFlexibleContexts+-- >>> :set -Wno-simplifiable-class-constraints+-- >>> import qualified Data.Map as Map+-- >>> import qualified Data.IntSet as IntSet+-- >>> import Data.Bifunctor.Tannen++-- * Safe types and operations++-- | 'S' is a data kind of scope indices.+--+-- @since 0.0.1+data S+  = VoidS -- ^ 'VoidS' is the only explicit scope available to the users, representing an empty scope.+          -- All other scopes are represented with type variables,+          -- bound in rank-2 polymophic functions like 'withFreshBinder'.++-- | A safe scope, indexed by a type-level scope index @n@.+--+-- @since 0.0.1+newtype Scope (n :: S) = UnsafeScope RawScope+  deriving newtype NFData++-- | A name in a safe scope, indexed by a type-level scope index @n@.+--+-- @since 0.0.1+newtype Name (n :: S) = UnsafeName RawName+  deriving newtype (NFData, Eq, Ord, Show)++-- | Convert 'Name' into an identifier.+-- This may be useful for printing and debugging.+--+-- @since 0.0.1+nameId :: Name l -> Id+nameId (UnsafeName i) = i++-- | A name binder is a name that extends scope @n@ to a (larger) scope @l@.+--+-- @since 0.0.1+newtype NameBinder (n :: S) (l :: S) =+  UnsafeNameBinder (Name l)+    deriving newtype (NFData, Eq, Ord, Show)++-- | An empty scope (without any names).+--+-- @since 0.0.1+emptyScope :: Scope VoidS+emptyScope = UnsafeScope IntSet.empty++-- | A runtime check for potential name capture.+--+-- @since 0.0.1+member :: Name l -> Scope n -> Bool+member (UnsafeName name) (UnsafeScope s) = rawMember name s++-- ** Extending scopes++-- | \(O(\min(n,W))\).+-- Extend a scope with one name (safely).+-- Note that as long as the foil is used as intended,+-- the name binder is guaranteed to introduce a name+-- that does not appear in the initial scope.+--+-- @since 0.0.1+{-# INLINABLE extendScope #-}+extendScope :: NameBinder n l -> Scope n -> Scope l+extendScope (UnsafeNameBinder (UnsafeName name)) (UnsafeScope scope) =+  UnsafeScope (IntSet.insert name scope)++-- | Extend scope with variables inside a pattern.+-- This is a more flexible version of 'extendScope'.+--+-- @since 0.0.1+{-# INLINABLE extendScopePattern #-}+extendScopePattern+  :: (Distinct n, CoSinkable pattern)+  => pattern n l -> Scope n -> Scope l+extendScopePattern pat scope = withPattern+  (\_scope' binder k ->+    unsafeAssertFresh binder $ \binder' ->+      k (ExtendScope (extendScope binder)) binder')+  idExtendScope+  compExtendScope+  scope+  pat+  (\(ExtendScope extend) _ _ -> extend scope)++-- | Auxiliary data structure for scope extension. Used in 'extendScopePattern'.+--+-- @since 0.1.0+newtype ExtendScope n l (o :: S) (o' :: S) = ExtendScope (Scope n -> Scope l)++-- | Identity scope extension (no extension).+--+-- @since 0.1.0+idExtendScope :: ExtendScope n n o o'+idExtendScope = ExtendScope id++-- | Compose scope extensions.+--+-- @since 0.1.0+compExtendScope+  :: ExtendScope n i o o'+  -> ExtendScope i l o' o''+  -> ExtendScope n l o o''+compExtendScope (ExtendScope f) (ExtendScope g)+  = ExtendScope (g . f)++-- ** Collecting new names++-- | Extract name from a name binder.+--+-- @since 0.0.1+nameOf :: NameBinder n l -> Name l+nameOf (UnsafeNameBinder name) = name++-- | Extract names from a pattern.+-- This is a more flexible version of 'nameOf'.+--+-- @since 0.1.0+namesOfPattern+  :: forall pattern n l. (Distinct n, CoSinkable pattern) => pattern n l -> [Name l]+namesOfPattern pat = withPattern @_ @n+  (\_scope' binder k ->+    unsafeAssertFresh binder $ \binder' ->+      k (NamesOf [nameOf binder]) binder')+  idNamesOf compNamesOf (error "impossible") pat+  (\(NamesOf names) _ _ -> names)++-- | Auxiliary structure collecting names in scope @l@ that extend scope @n@.+-- Used in 'namesOfPattern'.+--+-- @since 0.1.0+newtype NamesOf (n :: S) l (o :: S) (o' :: S) = NamesOf [Name l]++-- | Empty list of names in scope @n@.+--+-- @since 0.1.0+idNamesOf :: NamesOf n n o o'+idNamesOf = NamesOf []++-- | Concatenation of names, resulting in a list of names in @l@ that extend scope @n@.+--+-- @since 0.1.0+compNamesOf :: NamesOf n i o o' -> NamesOf i l o' o'' -> NamesOf n l o o''+compNamesOf (NamesOf xs) (NamesOf ys) =+  NamesOf (coerce xs ++ ys)++-- ** Refreshing binders++-- | Allocate a fresh binder for a given scope.+--+-- @since 0.0.1+{-# INLINABLE withFreshBinder #-}+withFreshBinder+  :: Scope n+  -> (forall l. NameBinder n l -> r) -> r+withFreshBinder (UnsafeScope scope) cont =+  cont binder+  where+    binder = UnsafeNameBinder (UnsafeName (rawFreshName scope))++-- | Safely produce a fresh name binder with respect to a given scope.+--+-- @since 0.0.1+{-# INLINABLE withFresh #-}+withFresh+  :: Distinct n => Scope n+  -> (forall l. DExt n l => NameBinder n l -> r) -> r+withFresh scope cont = withFreshBinder scope (`unsafeAssertFresh` cont)++-- | Safely produce a fresh name binder, allocated within a given range.+--+-- The binder is fresh with respect to the whole ambient scope, not merely to+-- its part inside the range. Indeed, the allocated name lies in the range and+-- is greater than every scope member there, while a scope member outside the+-- range cannot be equal to a name inside it (see 'rawFreshNameIn'). Thus the+-- usual freshness evidence applies, and no invariant beyond the scope itself+-- is required.+--+-- This is the primitive behind allocation policies such as per-module name+-- blocks: reserve disjoint ranges for independently checked units, and the+-- names allocated for them can never collide.+--+-- Fails with 'error' when the range is exhausted. Use 'tryWithFreshIn' to+-- handle exhaustion instead.+--+-- >>> withFreshIn (NameRange 100 199) emptyScope (nameId . nameOf)+-- 100+--+-- @since 0.4.0+withFreshIn+  :: Distinct n+  => NameRange  -- ^ The reservation to allocate from.+  -> Scope n    -- ^ The ambient scope.+  -> (forall l. DExt n l => NameBinder n l -> r) -> r+withFreshIn range scope cont =+  case tryWithFreshIn range scope cont of+    Just r  -> r+    Nothing -> error ("withFreshIn: exhausted " <> show range)++-- | A version of 'withFreshIn' that reports an exhausted range with 'Nothing'+-- instead of failing. A driver that hands out ranges can then report which+-- unit ran out of its reservation.+--+-- @since 0.4.0+tryWithFreshIn+  :: Distinct n+  => NameRange  -- ^ The reservation to allocate from.+  -> Scope n    -- ^ The ambient scope.+  -> (forall l. DExt n l => NameBinder n l -> r) -> Maybe r+tryWithFreshIn range (UnsafeScope rawScope) cont =+  case rawFreshNameIn range rawScope of+    Nothing   -> Nothing+    Just name -> Just (unsafeAssertFresh (UnsafeNameBinder (UnsafeName name)) cont)++-- | Rename a given pattern into a fresh version of it to extend a given scope.+--+-- This is similar to 'withRefreshedPattern', except here renaming always takes place.+--+-- @since 0.1.0+withFreshPattern+  :: (Distinct o, CoSinkable pattern, Sinkable e, InjectName e)+  => Scope o      -- ^ Ambient scope.+  -> pattern n l  -- ^ Pattern to refresh (if it clashes with the ambient scope).+  -> (forall o'. DExt o o' => (Substitution e n o -> Substitution e l o') -> pattern o o' -> Scope o' -> r)+  -- ^ Continuation, accepting the refreshed pattern and the extended scope.+  -> r+withFreshPattern scope pattern cont = withPattern+  (\scope' binder f -> withFresh scope'+    (\binder' -> f (WithRefreshedPattern (\subst -> addRename (sink subst) binder (nameOf binder'))) binder'))+  idWithRefreshedPattern+  compWithRefreshedPattern+  scope+  pattern+  (\(WithRefreshedPattern f) pattern' scope' -> cont f pattern' scope')++-- | Safely rename (if necessary) a given name to extend a given scope.+-- This is similar to 'withFresh', except if the name does not clash with+-- the scope, it can be used immediately, without renaming.+--+-- @since 0.0.1+{-# INLINABLE withRefreshed #-}+withRefreshed+  :: Distinct o+  => Scope o    -- ^ Ambient scope.+  -> Name i     -- ^ Name to refresh (if it clashes with the ambient scope).+  -> (forall o'. DExt o o' => NameBinder o o' -> r)+  -- ^ Continuation, accepting the refreshed name.+  -> r+withRefreshed scope@(UnsafeScope rawScope) name@(UnsafeName rawName) cont+  | IntSet.member rawName rawScope = withFresh scope cont+  | otherwise = unsafeAssertFresh (UnsafeNameBinder name) cont++-- | A version of 'withRefreshed' that allocates the replacement name within+-- a given range when the candidate is taken. A client that reserves regions+-- of the raw-name line (per-module stripes, a region for locals) uses this+-- so that a rename cannot stray into someone else's reservation.+--+-- @since 0.4.0+withRefreshedIn+  :: Distinct o+  => NameRange  -- ^ The reservation to allocate a replacement from.+  -> Scope o    -- ^ Ambient scope.+  -> Name i     -- ^ Name to refresh (if it clashes with the ambient scope).+  -> (forall o'. DExt o o' => NameBinder o o' -> r)+  -- ^ Continuation, accepting the refreshed name.+  -> r+withRefreshedIn range scope@(UnsafeScope rawScope) name@(UnsafeName rawName) cont+  | IntSet.member rawName rawScope = withFreshIn range scope cont+  | otherwise = unsafeAssertFresh (UnsafeNameBinder name) cont++-- | Safely rename (if necessary) a given pattern to extend a given scope.+-- This is similar to 'withFreshPattern', except if a name in the pattern+-- does not clash with the scope, it can be used immediately, without renaming.+--+-- This is a more general version of 'withRefreshed'.+--+-- The continuation also receives the scope extended with the refreshed+-- pattern: the traversal computes it along the way, so the caller does not+-- recompute it with 'extendScopePattern' (a second traversal of the same+-- pattern). The same holds for 'withFreshPattern' and 'withRefreshedPattern''.+--+-- Note that there is deliberately no fast path for the case when /every/ binder+-- of the pattern is already fresh in the ambient scope. It is tempting to test+-- all binders at once and, when none clashes, hand the continuation @sink@+-- instead of a renaming composed per binder. That would be unsound.+--+-- Even when a binder is not renamed, the per-binder step is not the identity:+-- 'addRename' /deletes/ the name from the substitution, which is how the binder+-- shadows an outer binding of the same raw name. For skipping that delete to be+-- harmless we would need the substitution's domain to avoid the pattern's binder+-- names, but the substitution's domain lives in the pattern's own scope @n@,+-- while freshness is tested against the unrelated ambient scope @o@.+--+-- The two can indeed disagree, because 'sink' is a coercion and does not+-- rename: a term built in a small scope keeps its binder names when it is+-- placed in a larger one, so a binder can share a raw name with its own+-- enclosing scope. Ordinary evaluation produces such terms, with a @λ x1@+-- nested inside another @λ x1@. Handing such a caller @sink@ would apply its+-- substitution to a name the pattern binds, which is to say capture the bound+-- variable.+--+-- @since 0.0.1+{-# INLINABLE withRefreshedPattern #-}+withRefreshedPattern+  :: (Distinct o, CoSinkable pattern, Sinkable e, InjectName e)+  => Scope o      -- ^ Ambient scope.+  -> pattern n l  -- ^ Pattern to refresh (if it clashes with the ambient scope).+  -> (forall o'. DExt o o' => (Substitution e n o -> Substitution e l o') -> pattern o o' -> Scope o' -> r)+  -- ^ Continuation, accepting the refreshed pattern and the extended scope.+  -> r+withRefreshedPattern scope pattern cont = withPattern+  (\scope' binder f -> withRefreshed scope' (nameOf binder)+    (\binder' -> f (WithRefreshedPattern (\subst -> addRename (sink subst) binder (nameOf binder'))) binder'))+  idWithRefreshedPattern+  compWithRefreshedPattern+  scope+  pattern+  (\(WithRefreshedPattern f) pattern' scope' -> cont f pattern' scope')++-- | Refresh (if needed) bound variables introduced in a pattern.+--+-- This is a version of 'withRefreshedPattern' that uses functional renamings instead of 'Substitution'.+--+-- Like 'withRefreshedPattern', this has no all-binders-already-fresh fast path,+-- and for the same reason. Here shadowing is handled by 'unsinkName' rather than+-- by a delete: a name the pattern binds is routed to 'injectName' and never+-- reaches the caller's renaming, whether or not the binder was refreshed.+--+-- @since 0.1.0+withRefreshedPattern'+  :: (CoSinkable pattern, Distinct o, InjectName e, Sinkable e)+  => Scope o+  -> pattern n l+  -> (forall o'. DExt o o' => ((Name n -> e o) -> Name l -> e o') -> pattern o o' -> Scope o' -> r) -> r+withRefreshedPattern' scope pattern cont = withPattern+  (\scope' binder f -> withRefreshed scope' (nameOf binder)+    (\binder' ->+      let k subst name = case unsinkName binder name of+              Nothing    -> injectName (nameOf binder')+              Just name' -> sink (subst name')+       in f (WithRefreshedPattern' k) binder'))+  idWithRefreshedPattern'+  compWithRefreshedPattern'+  scope+  pattern+  (\(WithRefreshedPattern' f) pattern' scope' -> cont f pattern' scope')++-- | Unsafely declare that a given name (binder)+-- is already fresh in any scope @n'@.+--+-- @since 0.0.1+{-# INLINABLE unsafeAssertFresh #-}+unsafeAssertFresh :: forall n l n' l' r. NameBinder n l+  -> (DExt n' l' => NameBinder n' l' -> r) -> r+unsafeAssertFresh binder cont =+  case unsafeDistinct @l' of+    Distinct -> case unsafeExt @n' @l' of+      Ext -> cont (unsafeCoerce binder)++-- | Auxiliary structure to accumulate substitution extensions+-- produced when refreshing a pattern.+-- Used in 'withRefreshedPattern' and 'withFreshPattern'.+--+-- @since 0.1.0+newtype WithRefreshedPattern e n l o o' = WithRefreshedPattern (Substitution e n o -> Substitution e l o')++-- | Trivial substitution (coercion via 'sink').+--+-- @since 0.1.0+idWithRefreshedPattern :: (Sinkable e, DExt o o') => WithRefreshedPattern e n n o o'+idWithRefreshedPattern = WithRefreshedPattern sink++-- | Composition of substitution extensions.+--+-- @since 0.1.0+compWithRefreshedPattern+  :: (DExt o o', DExt o' o'')+  => WithRefreshedPattern e n i o o'+  -> WithRefreshedPattern e i l o' o''+  -> WithRefreshedPattern e n l o o''+compWithRefreshedPattern (WithRefreshedPattern f) (WithRefreshedPattern g) =+  WithRefreshedPattern (g . f)++-- | Auxiliary structure to accumulate substitution extensions+-- and the extended scope produced when refreshing a pattern.+-- Similar to 'WithRefreshedPattern', except here substitutions are represented as functions.+-- Used in 'withRefreshedPattern''.+--+-- @since 0.1.0+newtype WithRefreshedPattern' e n l (o :: S) (o' :: S) = WithRefreshedPattern' ((Name n -> e o) -> Name l -> e o')++-- | Trivial substitution extension (coercion via 'sink').+--+-- @since 0.1.0+idWithRefreshedPattern' :: (Sinkable e, DExt o o') => WithRefreshedPattern' e n n o o'+idWithRefreshedPattern' = WithRefreshedPattern' (\f n -> sink (f n))++-- | Composition of substitution extensions.+--+-- @since 0.1.0+compWithRefreshedPattern'+  :: (DExt o o', DExt o' o'')+  => WithRefreshedPattern' e n i o o'+  -> WithRefreshedPattern' e i l o' o''+  -> WithRefreshedPattern' e n l o o''+compWithRefreshedPattern' (WithRefreshedPattern' f) (WithRefreshedPattern' g) =+  WithRefreshedPattern' (g . f)++-- ** Extracting proofs from binders and patterns++-- | Evidence that scope @n@ contains distinct names.+--+-- @since 0.0.1+data DistinctEvidence (n :: S) where+  Distinct :: Distinct n => DistinctEvidence n++-- | Evidence that scope @l@ extends scope @n@.+--+-- @since 0.0.1+data ExtEvidence (n :: S) (l :: S) where+  Ext :: Ext n l => ExtEvidence n l++-- | A distinct scope extended with a 'NameBinder' is also distinct.+--+-- @since 0.0.1+assertDistinct :: (Distinct n, CoSinkable pattern) => pattern n l -> DistinctEvidence l+assertDistinct _ = unsafeDistinct++-- | A distinct scope extended with a 'NameBinder' is also distinct.+--+-- @since 0.0.3+assertExt :: CoSinkable pattern => pattern n l -> ExtEvidence n l+assertExt _ = unsafeExt++-- | Unsafely declare that scope @n@ is distinct.+-- Used in 'unsafeAssertFresh'.+--+-- @since 0.0.1+unsafeDistinct :: DistinctEvidence n+unsafeDistinct = unsafeCoerce (Distinct :: DistinctEvidence VoidS)++-- | Unsafely declare that scope @l@ extends scope @n@.+-- Used in 'unsafeAssertFresh'.+--+-- @since 0.0.1+unsafeExt :: ExtEvidence n l+unsafeExt = unsafeCoerce (Ext :: ExtEvidence VoidS VoidS)++-- ** Unsinking names++-- | Try coercing the name back to the (smaller) scope,+-- given a binder that extends that scope.+--+-- @since 0.0.1+unsinkName :: NameBinder n l -> Name l -> Maybe (Name n)+unsinkName binder name@(UnsafeName raw)+  | nameOf binder == name = Nothing+  | otherwise = Just (UnsafeName raw)++-- | Check if a name in the extended context+-- is introduced in a pattern or comes from the outer scope @n@.+--+-- This is a generalization of 'unsinkName'.+--+-- @since 0.1.0+unsinkNamePattern+  :: forall pattern n l. (Distinct n, CoSinkable pattern)+  => pattern n l -> Name l -> Maybe (Name n)+unsinkNamePattern pat = withPattern @_ @n+  (\_scope' binder k ->+      unsafeAssertFresh binder $ \binder' ->+        k (UnsinkName (unsinkName binder)) binder')+  idUnsinkName+  compUnsinkName+  (error "impossible")  -- scope is not used, but has to be provided in general+  pat+  (\(UnsinkName unsink) _ _ -> unsink)++-- | Auxiliary structure for unsinking names.+-- Used in 'unsinkNamePattern'.+--+-- @since 0.1.0+newtype UnsinkName n l (o :: S) (o' :: S) = UnsinkName (Name l -> Maybe (Name n))++-- | Trivial unsinking. If no scope extension took place, any name is free (since it cannot be bound by anything).+--+-- @since 0.1.0+idUnsinkName :: UnsinkName n n o o'+idUnsinkName = UnsinkName Just++-- | Composition of unsinking for nested binders/patterns.+--+-- @since 0.1.0+compUnsinkName+  :: UnsinkName n i o o'+  -> UnsinkName i l o' o''+  -> UnsinkName n l o o''+compUnsinkName (UnsinkName f) (UnsinkName g)+  = UnsinkName (\name -> g name >>= f)++-- * Sets of names, and scope restriction+--+-- The foil accounts for scope /extension/: 'NameBinder' adds names, 'Ext' is+-- the erasable evidence, and 'sink' is a coercion. Restriction is the other+-- direction, and it needs no new constraint class. Read from the other end,+-- @'Ext' m n@ /is/ the statement that every name of @m@ is a name of @n@, and+-- the runtime witness of it is the smaller 'Scope'.+--+-- What restriction does need is a way to talk about a /subset/ of the names in+-- scope, which is 'NameSet', and a way to cut a scope down to one, which is+-- 'withRestrictedScope'. Unlike extension, restriction cannot be a pure+-- coercion. 'sink' is sound because a term\'s support is contained in its+-- scope, and the converse has no such invariant, so it has to be tested.++-- | A set of names of scope @n@.+--+-- This is not a 'Scope': a 'Scope' is /all/ the names in scope, and the foil+-- relies on that (it is what freshness is tested against, and what 'Distinct'+-- speaks about). A 'NameSet' is any subset of them, such as the names a term+-- uses or the assumptions a declaration depends on, and carries no such+-- invariant.+--+-- '<>' is union and 'mempty' is empty, so a 'NameSet' can be accumulated with+-- 'foldMap'.+--+-- @since 0.4.0+newtype NameSet (n :: S) = UnsafeNameSet RawScope+  deriving newtype (NFData, Eq, Semigroup, Monoid)++-- | An empty set of names.+--+-- @since 0.4.0+emptyNameSet :: NameSet n+emptyNameSet = UnsafeNameSet IntSet.empty++-- | \(O(1)\). A set of one name.+--+-- @since 0.4.0+nameSetSingleton :: Name n -> NameSet n+nameSetSingleton (UnsafeName name) = UnsafeNameSet (IntSet.singleton name)++-- | \(O(\min(n,W))\). Add a name to a set.+--+-- @since 0.4.0+nameSetInsert :: Name n -> NameSet n -> NameSet n+nameSetInsert (UnsafeName name) (UnsafeNameSet names) =+  UnsafeNameSet (IntSet.insert name names)++-- | \(O(\min(n,W))\). Is this name in the set?+--+-- @since 0.4.0+nameSetMember :: Name n -> NameSet n -> Bool+nameSetMember (UnsafeName name) (UnsafeNameSet names) = IntSet.member name names++-- | Is the set empty?+--+-- @since 0.4.0+nameSetNull :: NameSet n -> Bool+nameSetNull (UnsafeNameSet names) = IntSet.null names++-- | How many names are in the set?+--+-- @since 0.4.0+nameSetSize :: NameSet n -> Int+nameSetSize (UnsafeNameSet names) = IntSet.size names++-- | The names in the set, in ascending order of their identifiers.+--+-- @since 0.4.0+nameSetToList :: NameSet n -> [Name n]+nameSetToList (UnsafeNameSet names) = Prelude.map UnsafeName (IntSet.toAscList names)++-- | A set of the given names.+--+-- @since 0.4.0+nameSetFromList :: [Name n] -> NameSet n+nameSetFromList names = UnsafeNameSet (IntSet.fromList (Prelude.map nameId names))++-- | A set of names sinks like anything else: rename each of its names.+--+-- As always, the proof is what makes 'sink' a coercion here, and a coercion is+-- what it has to be for a support computed under a binder to be usable in the+-- scope outside it without rebuilding the set.+instance Sinkable NameSet where+  sinkabilityProof rename = nameSetFromList . Prelude.map rename . nameSetToList++-- | All the names in a scope.+--+-- @since 0.4.0+scopeToNameSet :: Scope n -> NameSet n+scopeToNameSet (UnsafeScope names) = UnsafeNameSet names++-- | The names a pattern binds.+--+-- @since 0.4.0+nameSetOfPattern :: CoSinkable binder => binder n l -> NameSet l+nameSetOfPattern binder = UnsafeNameSet bound+  where+    UnsafeNameBinders bound = fromNameBindersList (nameBinderListOf binder)++-- | \(O(\min(n,W))\). Does the scope contain every name in the set?+--+-- This is the test that restriction of a term comes down to, so it is the one+-- place a restriction is paid for: compare a term\'s support against the scope+-- it is to be restricted to.+--+-- @since 0.4.0+nameSetSubsetOfScope :: NameSet l -> Scope n -> Bool+nameSetSubsetOfScope (UnsafeNameSet names) (UnsafeScope scope) =+  names `IntSet.isSubsetOf` scope++-- | Drop the names a pattern binds, taking a set of names of the inner scope to+-- a set of names of the outer one.+--+-- This is 'unsinkNamePattern' for a whole set at once, and \(O(\min(n,W))\)+-- rather than one membership test per name. Removing the pattern\'s names is+-- right even when one of them shares a raw name with the enclosing scope: inside+-- the pattern that raw name denotes the binder, so no occurrence of it there is+-- an occurrence of the outer name.+--+-- @since 0.4.0+unsinkNameSet :: CoSinkable binder => binder n l -> NameSet l -> NameSet n+unsinkNameSet binder (UnsafeNameSet names) = UnsafeNameSet (names IntSet.\\ bound)+  where+    UnsafeNameBinders bound = fromNameBindersList (nameBinderListOf binder)++-- | Cut a scope down to a subset of its names.+--+-- The names must be names of @n@; nothing checks it, which is why this is the+-- only entry point and takes a 'NameSet' rather than a bare @IntSet@. The+-- continuation gets @'Ext' m n@, so anything living in the smaller scope can be+-- 'sink'ed back into the larger one for free, and @'Distinct' m@, since a subset+-- of distinct names is distinct.+--+-- __Note on allocation.__ A name allocated from the restricted scope is fresh+-- with respect to @m@ and /not/ to @n@, so it may collide with a name of @n@+-- that the restriction dropped. This is sound, since @'Ext' m n@ gives no way+-- to move a term of @n@ into a scope extending @m@. It does mean that a+-- restricted scope is for inspecting and restricting terms, and not a base to+-- build new binders on and then mix with the original scope.+--+-- @since 0.4.0+withRestrictedScope+  :: forall n r. Distinct n+  => NameSet n+  -- ^ Names to keep. Must be names of @n@.+  -> (forall m. (Ext m n, Distinct m) => Scope m -> r)+  -> r+withRestrictedScope (UnsafeNameSet names) cont =+  unsafeAssertRestricted @n (UnsafeScope names) cont++-- | Unsafely declare that a scope is a restriction of scope @n@.+-- Used in 'withRestrictedScope'.+--+-- @since 0.4.0+unsafeAssertRestricted+  :: forall n m r. Scope m -> ((Ext m n, Distinct m) => Scope m -> r) -> r+unsafeAssertRestricted scope cont =+  case unsafeDistinct @m of+    Distinct -> case unsafeExt @m @n of+      Ext -> cont scope++-- * Unification of binders++-- | Unification result for two binders,+-- extending some common scope to scopes @l@ and @r@ respectively.+--+-- Due to the implementation of the foil, we can often rename binders efficiently,+-- by renaming binders only in one of the two unified terms.+--+-- @since 0.0.3+data UnifyNameBinders (pattern :: S -> S -> Type) n l r where+  -- | Binders are the same, proving that type parameters @l@ and @r@+  -- are in fact equivalent.+  SameNameBinders+    :: NameBinders n l  -- ^ /Unordered/ set of binders in the unified pattern (from any of the original patterns).+    -> UnifyNameBinders pattern n l l+  -- | It is possible to safely rename the left binder+  -- to match the right one.+  RenameLeftNameBinder+    :: NameBinders n r                    -- ^ /Unordered/ set of binders in the unified pattern (the binders from the right pattern).+    -> (NameBinder n l -> NameBinder n r) -- ^ Binder renaming for the left pattern.+    -> UnifyNameBinders pattern n l r+  -- | It is possible to safely rename the right binder+  -- to match the left one.+  RenameRightNameBinder+    :: NameBinders n l                    -- ^ /Unordered/ set of binders in the unified pattern (the binders from the left pattern).+    -> (NameBinder n r -> NameBinder n l) -- ^ Binder renaming for the right pattern.+    -> UnifyNameBinders pattern n l r+  -- | It is necessary to rename both binders.+  RenameBothBinders+    :: NameBinders n lr                     -- ^ /Unordered/ set of binders in the unified pattern+    -> (NameBinder n l -> NameBinder n lr)  -- ^ Binder renaming for the left pattern.+    -> (NameBinder n r -> NameBinder n lr)  -- ^ Binder renaming for the right pattern.+    -> UnifyNameBinders pattern n l r+  -- | Cannot unify to (sub)patterns.+  NotUnifiable :: UnifyNameBinders pattern n l r++-- | Unify binders either by asserting that they are the same,+-- or by providing a /safe/ renaming function to convert one binder to another.+--+-- When the binders differ, the one with the /larger/ name is renamed towards the+-- one with the smaller name. The direction is deliberate, but it is not what+-- makes the renaming safe.+--+-- The renaming returned here is not applied by substituting names blindly.+-- Callers push it through a term with+-- 'Control.Monad.Foil.Relative.liftRM', which refreshes a binder whenever it+-- would capture. So the target name may well be used by a binder /inside/ the+-- term being renamed, and the result is still correct. Binder names do not+-- always grow with depth: a term built in a small scope keeps its small binder+-- names when 'sink' places it in a larger one.+--+-- @since 0.0.3+unifyNameBinders+  :: forall i l r pattern. Distinct i+  => NameBinder i l -- ^ Left pattern.+  -> NameBinder i r -- ^ Right pattern.+  -> UnifyNameBinders pattern i l r+unifyNameBinders l@(UnsafeNameBinder (UnsafeName i1)) r@(UnsafeNameBinder (UnsafeName i2))+  | i1 == i2  = case assertDistinct l of+      Distinct -> unsafeCoerce (SameNameBinders (nameBindersSingleton l))  -- equal names extend scopes equally+  | i1 < i2   = RenameRightNameBinder (nameBindersSingleton l) $ \(UnsafeNameBinder (UnsafeName i'')) ->+      if i'' == i2 then UnsafeNameBinder (UnsafeName i1) else UnsafeNameBinder (UnsafeName i'')+  | otherwise = RenameLeftNameBinder (nameBindersSingleton r) $ \(UnsafeNameBinder (UnsafeName i')) ->+      if i'  == i1 then UnsafeNameBinder (UnsafeName i2) else UnsafeNameBinder (UnsafeName i')++-- | Unsafely merge results of unification for nested binders/patterns.+-- Used in 'andThenUnifyPatterns'.+--+-- @since 0.1.0+unsafeMergeUnifyBinders :: UnifyNameBinders pattern a a' a'' -> UnifyNameBinders pattern a''' b' b'' -> UnifyNameBinders pattern a b' b''+unsafeMergeUnifyBinders = \case++  SameNameBinders x -> \case+    SameNameBinders y -> SameNameBinders (x `unsafeMergeNameBinders` y)+    RenameLeftNameBinder y f -> RenameLeftNameBinder (x `unsafeMergeNameBinders` y) (unsafeCoerce f)+    RenameRightNameBinder y g -> RenameRightNameBinder (x `unsafeMergeNameBinders` y) (unsafeCoerce g)+    RenameBothBinders y f g -> RenameBothBinders (x `unsafeMergeNameBinders` y) (unsafeCoerce f) (unsafeCoerce g)+    NotUnifiable -> NotUnifiable++  RenameLeftNameBinder x f -> \case+    SameNameBinders y -> RenameLeftNameBinder (x `unsafeMergeNameBinders` y) (unsafeCoerce f)+    RenameLeftNameBinder y g -> RenameLeftNameBinder (x `unsafeMergeNameBinders` y) (unsafeCoerce f . unsafeCoerce g)+    RenameRightNameBinder y g -> RenameBothBinders (x `unsafeMergeNameBinders` y) (unsafeCoerce f) (unsafeCoerce g)+    RenameBothBinders y f' g -> RenameBothBinders (x `unsafeMergeNameBinders` y) (unsafeCoerce f . unsafeCoerce f') (unsafeCoerce g)+    NotUnifiable -> NotUnifiable++  RenameRightNameBinder x g -> \case+    SameNameBinders y -> RenameRightNameBinder (x `unsafeMergeNameBinders` y) (unsafeCoerce g)+    RenameLeftNameBinder y f -> RenameBothBinders (x `unsafeMergeNameBinders` y) (unsafeCoerce f) (unsafeCoerce g)+    RenameRightNameBinder y g' -> RenameRightNameBinder (x `unsafeMergeNameBinders` y) (unsafeCoerce g . unsafeCoerce g')+    RenameBothBinders y f g' -> RenameBothBinders (x `unsafeMergeNameBinders` y) (unsafeCoerce f) (unsafeCoerce g . unsafeCoerce g')+    NotUnifiable -> NotUnifiable++  RenameBothBinders x f g -> \case+    SameNameBinders y -> RenameBothBinders (x `unsafeMergeNameBinders` y) (unsafeCoerce f) (unsafeCoerce g)+    RenameLeftNameBinder y f' -> RenameBothBinders (x `unsafeMergeNameBinders` y) (unsafeCoerce f . unsafeCoerce f') (unsafeCoerce g)+    RenameRightNameBinder y g' -> RenameBothBinders (x `unsafeMergeNameBinders` y) (unsafeCoerce f) (unsafeCoerce g . unsafeCoerce g')+    RenameBothBinders y f' g' -> RenameBothBinders (x `unsafeMergeNameBinders` y) (unsafeCoerce f . unsafeCoerce f') (unsafeCoerce g . unsafeCoerce g')+    NotUnifiable -> NotUnifiable++  NotUnifiable -> const (NotUnifiable)++-- | Chain unification of nested patterns.+--+-- @since 0.1.0+andThenUnifyPatterns+  :: (UnifiablePattern pattern, Distinct l, Distinct l')+  => UnifyNameBinders pattern n l l'    -- ^ Unifying action for some outer patterns.+  -> (pattern l r, pattern l' r')       -- ^ Two nested patterns (cannot be unified directly since they extend different scopes).+  -> UnifyNameBinders pattern n r r'+andThenUnifyPatterns u (l, r) = unsafeMergeUnifyBinders u (unifyPatterns (unsafeCoerce l) r)++-- | Chain unification of nested patterns with 'NameBinder's.+--+-- @since 0.1.0+andThenUnifyNameBinders+  :: (UnifiablePattern pattern, Distinct l, Distinct l')+  => UnifyNameBinders pattern n l l'    -- ^ Unifying action for some outer patterns.+  -> (NameBinder l r, NameBinder l' r') -- ^ Two nested binders (cannot be unified directly since they extend different scopes).+  -> UnifyNameBinders pattern n r r'+andThenUnifyNameBinders u (l, r) = unsafeMergeUnifyBinders u (unifyNameBinders (unsafeCoerce l) r)++-- | An /unordered/ collection of 'NameBinder's, that together extend scope @n@ to scope @l@.+--+-- For an ordered version see 'NameBinderList'.+--+-- @since 0.1.0+newtype NameBinders (n :: S) (l :: S) = UnsafeNameBinders IntSet++-- | /Unsafely/ merge sets of binders (via set union).+--+-- @since 0.1.0+unsafeMergeNameBinders :: NameBinders a b -> NameBinders c d -> NameBinders n l+unsafeMergeNameBinders (UnsafeNameBinders x) (UnsafeNameBinders y) = UnsafeNameBinders (x <> y)++-- | An empty set of binders keeps the scope as is.+--+-- @since 0.1.0+emptyNameBinders :: NameBinders n n+emptyNameBinders = UnsafeNameBinders IntSet.empty++-- | Composition of sets of binders.+--+-- @since 0.1.0+mergeNameBinders :: NameBinders n i -> NameBinders i l -> NameBinders n l+mergeNameBinders = unsafeMergeNameBinders++-- | A singleton name binder set.+--+-- @since 0.1.0+nameBindersSingleton :: NameBinder n l -> NameBinders n l+nameBindersSingleton binder = UnsafeNameBinders (IntSet.singleton (nameId (nameOf binder)))++-- | An /ordered/ collection (list) of 'NameBinder's, that together extend scope @n@ to scope @l@.+--+-- For an unordered version see 'NameBinders'.+--+-- @since 0.1.0+data NameBinderList n l where+  -- | An empty list of binders keeps the scope as is.+  NameBinderListEmpty :: NameBinderList n n+  -- | A non-empty list of binders.+  NameBinderListCons+    :: NameBinder n i       -- ^ Outermost binder.+    -> NameBinderList i l   -- ^ Remaining list of binders.+    -> NameBinderList n l++-- | Convert an unordered set of name binders into an ordered list (with some order).+--+-- @since 0.1.0+nameBindersList :: NameBinders n l -> NameBinderList n l+nameBindersList (UnsafeNameBinders names) = go (IntSet.toList names)+  where+    go []     = unsafeCoerce NameBinderListEmpty+    go (x:xs) = NameBinderListCons (UnsafeNameBinder (UnsafeName x)) (go xs)++-- | The raw names a list of binders binds, outermost first.+--+-- @since 0.4.0+rawNameBinderList :: NameBinderList n l -> [RawName]+rawNameBinderList NameBinderListEmpty = []+rawNameBinderList (NameBinderListCons binder binders) =+  nameId (nameOf binder) : rawNameBinderList binders++-- | Keep only those binders of a list whose names are in a given set.+--+-- This is the /thinning/ of a chain of binders, and it is what turns a support+-- into a smaller chain in one step. The alternative, asking+-- 'Control.Monad.Free.Foil.unsinkAST' at+-- every binder whether the term can do without it, walks the term once per+-- binder, whereas a caller can compute the support once and thin against it.+--+-- The thinned scope @m@ is produced rather than given, because there is nothing+-- to give: a term\'s relevant scope (see @withRelevantScope@) is a subset of+-- @l@ and generally not an extension of @n@, since a term need not use+-- everything already in scope. What comes back is @n@ extended by the binders+-- that survived, with @Ext n m@ and @Ext m l@ to place it between the two.+--+-- The set is taken as given. For a chain whose binders carry types, or anything+-- else living in the intermediate scopes, the caller has to close the set under+-- whatever those mention before thinning by it, since dropping a binder that a+-- surviving binder\'s type refers to would leave that type unplaceable. The+-- library cannot do that closure, having no view of what a binder carries.+--+-- @since 0.4.0+withThinnedNameBinderList+  :: forall n l r. Distinct n+  => NameSet l            -- ^ Names to keep, closed under whatever the binders carry.+  -> NameBinderList n l   -- ^ The chain to thin.+  -> (forall m. (Ext n m, Ext m l, Distinct m) => NameBinderList n m -> r)+  -> r+withThinnedNameBinderList (UnsafeNameSet keep) binders cont =+    unsafeAssertThinned @n @l+      (go (Prelude.filter (`IntSet.member` keep) (rawNameBinderList binders))) cont+  where+    go :: forall m m'. [RawName] -> NameBinderList m m'+    go []       = unsafeCoerce NameBinderListEmpty+    go (x : xs) = NameBinderListCons (UnsafeNameBinder (UnsafeName x)) (go xs)++-- | Unsafely place a chain of binders between two scopes.+--+-- Sound for a chain thinned out of @n@ to @l@: its names are those of @n@ plus+-- some of the binders between @n@ and @l@, so it extends @n@, is extended by+-- @l@, and is distinct because @l@ was.+--+-- @since 0.4.0+unsafeAssertThinned+  :: forall n l m r+   . NameBinderList n m+  -> ((Ext n m, Ext m l, Distinct m) => NameBinderList n m -> r)+  -> r+unsafeAssertThinned binders cont =+  case unsafeDistinct @m of+    Distinct -> case unsafeExt @n @m of+      Ext -> case unsafeExt @m @l of+        Ext -> cont binders++-- | Add a binder to the end of an (ordered) list of binders.+--+-- Note that 'NameBinderListCons' adds a binder to the /front/ of the list, which+-- is the outermost position. This adds one to the innermost position instead.+--+-- @since 0.3.1+snocNameBinderList :: NameBinderList n i -> NameBinder i l -> NameBinderList n l+snocNameBinderList NameBinderListEmpty binder =+  NameBinderListCons binder NameBinderListEmpty+snocNameBinderList (NameBinderListCons binder binders) binder' =+  NameBinderListCons binder (snocNameBinderList binders binder')++-- | Concatenate two (ordered) lists of binders, the second extending the scope+-- that the first extends to.+--+-- @since 0.3.1+concatNameBinderLists :: NameBinderList n i -> NameBinderList i l -> NameBinderList n l+concatNameBinderLists NameBinderListEmpty binders = binders+concatNameBinderLists (NameBinderListCons binder binders) binders' =+  NameBinderListCons binder (concatNameBinderLists binders binders')++-- | Convert an ordered list of name binders into an unordered set.+--+-- @since 0.1.0+fromNameBindersList :: NameBinderList n l -> NameBinders n l+fromNameBindersList = UnsafeNameBinders . IntSet.fromList . go+  where+    go :: NameBinderList n l -> [RawName]+    go NameBinderListEmpty                 = []+    go (NameBinderListCons binder binders) = nameId (nameOf binder) : go binders++instance CoSinkable NameBinders where+  coSinkabilityProof _rename (UnsafeNameBinders names) cont =+    cont unsafeCoerce (UnsafeNameBinders names)++  withPattern withBinder unit comp scope binders cont =+    withPattern withBinder unit comp scope (nameBindersList binders) $ \f binders' scope' ->+      cont f (fromNameBindersList binders') scope'++instance CoSinkable NameBinderList where+  coSinkabilityProof rename NameBinderListEmpty cont = cont rename NameBinderListEmpty+  coSinkabilityProof rename (NameBinderListCons binder binders) cont =+    coSinkabilityProof rename binder $ \rename' binder' ->+      coSinkabilityProof rename' binders $ \rename'' binders' ->+        cont rename'' (NameBinderListCons binder' binders')++  withPattern withBinder unit comp scope binders cont = case binders of+    NameBinderListEmpty -> cont unit NameBinderListEmpty scope+    NameBinderListCons x xs ->+      withBinder scope x $ \f x' ->+        let scope' = extendScope x' scope+        in withPattern withBinder unit comp scope' xs $ \f' xs' scope'' ->+            cont (comp f f') (NameBinderListCons x' xs') scope''++-- ** Pattern combinators++-- | An empty pattern type specifies zero possibilities for patterns.+--+-- This type can be used to specify that patterns are not possible.+--+-- @since 0.1.0+data V2 (n :: S) (l :: S)++-- | Since 'V2' values logically don't exist, this witnesses the logical reasoning tool of "ex falso quodlibet".+--+-- @since 0.1.0+absurd2 :: V2 n l -> a+absurd2 v2 = case v2 of {}++instance CoSinkable V2 where+  coSinkabilityProof _ v2 _ = absurd2 v2+  withPattern _ _ _ _ v2 _ = absurd2 v2+instance UnifiablePattern V2 where+  unifyPatterns = absurd2++-- | A unit pattern type corresponds to a wildcard pattern.+--+-- @since 0.1.0+data U2 (n :: S) (l :: S) where+  U2 :: U2 n n  -- ^ Wildcard patten does not modify the scope.++instance CoSinkable U2 where+  coSinkabilityProof rename U2 cont = cont rename U2+  withPattern _withBinder unit _combine scope U2 cont = cont unit U2 scope+instance UnifiablePattern U2 where+  unifyPatterns U2 U2 = SameNameBinders emptyNameBinders++-- ** Unifiable patterns++-- | A pattern type is unifiable if it is possible to match two+-- patterns and decide how to rename binders.+--+-- Note that the default implementation compares patterns only up to their+-- binders. See 'unifyPatterns' for what that does and does not distinguish.+--+-- @since 0.0.1+class CoSinkable pattern => UnifiablePattern pattern where+  -- | Unify two patterns and decide which binders need to be renamed.+  --+  -- @since 0.1.0+  unifyPatterns :: Distinct n => pattern n l -> pattern n r -> UnifyNameBinders pattern n l r++  -- | The default implementation flattens both patterns to their binders (via+  -- 'nameBinderListOf') and unifies the resulting 'NameBinderList's. It therefore+  -- compares only the /number and order/ of binders, and ignores+  --+  -- * the constructor, so two patterns built from /different/ constructors with+  --   the same number of binders unify;+  -- * non-binding fields (locations, sorts, literals), whatever their values;+  -- * the nesting of sub-patterns, so @(x, (y, z))@ unifies with @((x, y), z)@.+  --+  -- For most languages this is the intended notion of α-equivalence: what the+  -- body of a binding construct can refer to is precisely the pattern's binders,+  -- in order. Since α-equivalence is defined in terms of 'unifyPatterns', this+  -- also means that terms differing only in such a pattern are α-equivalent.+  --+  -- A pattern that carries semantically relevant data needs the instance+  -- written by hand instead. Use 'UnifiableInPattern' to compare non-binding+  -- fields, which also lets an instance ignore some of them deliberately, as a+  -- generated instance does for BNFC source positions.+  --+  -- A field that is /scope-indexed/, such as a telescope step's type, cannot be+  -- compared here at all, since comparing it up to α needs the ambient scope+  -- and this method is given only 'Distinct'. Write 'unifyPatternsIn' for that,+  -- and leave this one as the binder-only approximation.+  default unifyPatterns+    :: (CoSinkable pattern, Distinct n)+    => pattern n l -> pattern n r -> UnifyNameBinders pattern n l r+  unifyPatterns l r = coerce (unifyPatterns (nameBinderListOf l) (nameBinderListOf r))++  -- | Unify two patterns with the ambient scope at hand.+  --+  -- Everything in the library that compares patterns and holds a scope goes+  -- through this method, α-equivalence included, so this is the one to+  -- implement when the comparison needs a scope. Comparing the payloads of a+  -- pattern that carries them does: 'alphaEquivIn' asks for a 'Scope'.+  --+  -- Note that the verdict speaks about binders, so an instance comparing+  -- payloads has to apply the renaming the verdict prescribes before it+  -- compares them, exactly as 'Control.Monad.Free.Foil.alphaEquivScoped'+  -- applies it to the body of a scoped term. Two telescopes @(A : 𝕌) (x : A)@+  -- and @(B : 𝕌) (y : B)@ are α-equivalent, and their second payloads are only+  -- equal once the first binders have been identified.+  --+  -- The default ignores the scope and answers with 'unifyPatterns'. An instance+  -- that overrides this one should leave 'unifyPatterns' in place as the+  -- binder-only approximation rather than remove it. That is what+  -- 'unsafeEqPattern' and any caller without a scope will get, and it may be+  -- more permissive than this one, never less.+  unifyPatternsIn+    :: Distinct n+    => Scope n -> pattern n l -> pattern n r -> UnifyNameBinders pattern n l r+  unifyPatternsIn _scope = unifyPatterns++instance UnifiablePattern NameBinderList where+  unifyPatterns NameBinderListEmpty NameBinderListEmpty = SameNameBinders emptyNameBinders+  unifyPatterns (NameBinderListCons x xs) (NameBinderListCons y ys) =+    case (assertDistinct x, assertDistinct y) of+      (Distinct, Distinct) -> unifyNameBinders x y `andThenUnifyPatterns` (xs, ys)+  -- Lists of different lengths are not unifiable. This case is reachable+  -- whenever a language has patterns that bind different numbers of names --+  -- a wildcard and a variable, say -- since the default 'unifyPatterns'+  -- flattens every pattern to a 'NameBinderList'. Note that this module sets+  -- @-Wno-incomplete-patterns@, so its absence was not reported.+  unifyPatterns _ _ = NotUnifiable++-- | Comparison of scope-indexed values up to α, in a known scope.+--+-- 'unifyPatterns' is given only 'Distinct', which is enough to line up binders+-- and not enough to compare anything living in a scope. A pattern that carries+-- a payload needs this to compare its payloads against another's, which is what+-- 'unifyPatternsIn' is for.+--+-- @since 0.4.0+class AlphaEquiv (e :: S -> Type) where+  -- | Are two values of one scope α-equivalent?+  --+  -- @since 0.4.0+  alphaEquivIn :: Distinct n => Scope n -> e n -> e n -> Bool++-- | A name is α-equivalent only to itself.+instance AlphaEquiv Name where+  alphaEquivIn _scope = (==)++-- | Unification of values in patterns.+-- By default, 'Eq' instance is used, but it may be useful to ignore+-- some data in pattens (such as location annotations).+--+-- @since 0.1.0+class UnifiableInPattern a where+  -- | Unify non-binding components of a pattern.+  --+  -- @since 0.1.0+  unifyInPattern :: a -> a -> Bool+  default unifyInPattern :: Eq a => a -> a -> Bool+  unifyInPattern = (==)++instance UnifiablePattern NameBinder where+  unifyPatterns = unifyNameBinders++-- | The easiest way to compare two patterns is to check if they are the same.+-- This function is labelled /unsafe/, since we generally are interested in proper α-equivalence+-- instead of direct equality.+--+-- @since 0.1.0+unsafeEqPattern :: (UnifiablePattern pattern, Distinct n) => pattern n l -> pattern n' l' -> Bool+unsafeEqPattern l r =+  case unifyPatterns l (unsafeCoerce r) of+    SameNameBinders{} -> True+    _                 -> False++-- * Safe sinking++-- | Sinking an expression from scope @n@ into a (usualy extended) scope @l@,+-- given the renaming (injection from scope @n@ to scope @l@).+--+-- @since 0.0.1+class Sinkable (e :: S -> Type) where+  -- | An implementation of this method that typechecks+  -- proves to the compiler that the expression is indeed+  -- 'Sinkable'. However, instead of this implementation, 'sink'+  -- should be used at all call sites for efficiency.+  sinkabilityProof+    :: (Name n -> Name l)   -- ^ Map names from scope @n@ to a (possibly larger) scope @l@.+    -> e n                  -- ^ Expression with free variables in scope @n@.+    -> e l++  default sinkabilityProof+    :: (GenericK e, GSinkableK (RepK e)) => (Name n -> Name l) -> e n -> e l+  sinkabilityProof rename = toK . gsinkabilityProof1 rename . fromK++-- | Sinking a 'Name' is as simple as applying the renaming.+instance Sinkable Name where+  sinkabilityProof rename = rename++-- | A container of sinkable expressions is sinkable, elementwise.+--+-- The point of this instance is 'sinkContainer': since the proof typechecks,+-- sinking the whole container is a coercion, and does not walk its spine.+instance (Functor f, Sinkable e) => Sinkable (Compose f e) where+  sinkabilityProof rename (Compose xs) = Compose (fmap (sinkabilityProof rename) xs)++-- | Efficient version of 'sinkabilityProof'.+-- In fact, once 'sinkabilityProof' typechecks,+-- it is safe to 'sink' by coercion.+-- See Section 3.5 in [«The Foil: Capture-Avoiding Substitution With No Sharp Edges»](https://doi.org/10.1145/3587216.3587224) for the details.+--+-- 'sink' is the base of a family of \(O(1)\) coercions, named after+-- "Data.Functor.Classes": 'sink1' sinks through one 'Functor' layer and+-- 'sink2' through a 'Bifunctor', each justified by a lifted sinkability+-- proof of its own.+--+-- Tuples and records need no private @unsafeCoerce@ helpers either. A pair+-- of sinkables is a 'sink2' ('Data.Bifunctor.Tannen.Tannen' for a whole+-- container of them), and a pair whose first component is scope-free is a+-- 'sink1' through @'Compose' f ((,) a)@. A record of sinkable fields derives+-- 'Sinkable' through 'Generics.Kind.TH.deriveGenericK' and empty 'SinkableK'+-- and 'Sinkable' instances, after which the whole record sinks in one+-- coercion. A record holding the 'Scope' itself is rightly refused, since+-- there is no @SinkableK Scope@: the scope must grow when a binder is+-- entered, so keep it beside the sinkable part and not inside it.+--+-- __Do not map 'sink' over a container.__ @'fmap' 'sink'@ walks the whole+-- spine to apply a per-element coercion, where 'sink1' is one coercion.+-- Rewrite rules turn the elementwise forms into the corresponding family+-- member where they fire, but they are best-effort (they need optimisation+-- on, and 'fmap' at a known functor is often resolved to the instance+-- method first), so write the family member directly.+--+-- @since 0.0.1+sink :: (Sinkable e, DExt n l) => e n -> e l+sink = unsafeCoerce+{-# INLINE [0] sink #-}++-- The phase gates on 'sink' and 'sink2' keep them from inlining before+-- these can match. The map rules activate at phase 1, once list fusion has+-- backed out and rewritten unfused pipelines back to 'map' (the same trick+-- as base's @map/coerce@). The sink2 rules finish what "bimap/sink" starts:+-- @map (bimap sink sink)@ first becomes @map sink2@, and a functor around a+-- 'Bifunctor' is a 'Bifunctor' again ('Tannen'), so that map is one+-- coercion too.+--+-- These rules mirror the hlint hints in @.hlint.yaml@; keep the two lists+-- in step. The one deliberate difference: @sink '<$>'@ has a hint but no+-- rule, since the operator inlines to 'fmap' before rules run and+-- "fmap/sink" covers it, while hlint matches surface syntax.+{-# RULES+"map/sink" [1]    Prelude.map sink      = sink1+"fmap/sink"       fmap sink             = sink1+"IntMap.map/sink" Data.IntMap.map sink  = sink1+"Map.map/sink"    Data.Map.map sink     = sink1+"bimap/sink"      bimap sink sink       = sink2+"map/sink2" [1]   Prelude.map sink2     = \xs -> runTannen (sink2 (Tannen xs))+"fmap/sink2"      fmap sink2            = \xs -> runTannen (sink2 (Tannen xs))+  #-}++-- | Sink an entire container of sinkable expressions, in \(O(1)\): 'sink'+-- lifted through one 'Functor' layer, justified by the 'Sinkable' instance+-- of 'Compose'.+--+-- The soundness argument for 'sink' extends to a container of sinkables, such+-- as an 'Data.IntMap.IntMap' of terms, a 'Data.Map.Map' keyed by something+-- else, or a list of them. So there is no need to walk the spine with+-- @'fmap' 'sink'@, and entering a binder need not be \(O(size)\).+--+-- >>> :{+-- sinkEnv :: DExt n l => Map.Map String (Name n) -> Map.Map String (Name l)+-- sinkEnv = sink1+-- :}+--+-- A nested container is one 'Compose' away: @f (g (e n))@ is+-- @'Compose' f g (e n)@, and the composition is again a 'Functor', so+-- 'sink1' covers it too.+--+-- Two things this does /not/ cover:+--+-- * A 'Scope' is __not__ sinkable, and must not be sunk: it is the set of names+--   /in/ scope @n@, and it has to grow when a binder is entered (see 'extendScope').+-- * A 'NameMap' must stay __total__ on the names in scope ('lookupName' errors+--   otherwise), so sinking one has to be paired with adding the new binder's+--   entry (see 'addNameBinder').+--+-- @since 0.4.0+sink1 :: (Functor f, Sinkable e, DExt n l) => f (e n) -> f (e l)+sink1 = getCompose . sink . Compose++-- | The name 'sink1' had before the family existed.+--+-- @since 0.3.2+sinkContainer :: (Functor f, Sinkable e, DExt n l) => f (e n) -> f (e l)+sinkContainer = sink1+{-# DEPRECATED sinkContainer "Use sink1, its name in the sink family" #-}++-- | The sinkability proof lifted through a 'Bifunctor', with one renaming+-- per slot. Once this typechecks, sinking both slots at once is a coercion;+-- 'sink2' is to this proof exactly what 'sink' is to 'sinkabilityProof'.+--+-- @since 0.4.0+sinkabilityProof2+  :: (Bifunctor p, Sinkable e1, Sinkable e2)+  => (Name n -> Name n')    -- ^ Map names of scope @n@ into scope @n'@.+  -> (Name m -> Name m')    -- ^ Map names of scope @m@ into scope @m'@.+  -> p (e1 n) (e2 m)+  -> p (e1 n') (e2 m')+sinkabilityProof2 rename1 rename2 =+  bimap (sinkabilityProof rename1) (sinkabilityProof rename2)++-- | Sink both slots of a 'Bifunctor' of sinkables, in \(O(1)\), the two+-- scopes moving independently: the shape of 'Data.Functor.Classes.liftEq2',+-- with a coercion in place of each of the two functions.+--+-- >>> :{+-- sinkBoth :: (DExt n n', DExt m m') => (Name n, Name m) -> (Name n', Name m')+-- sinkBoth = sink2+-- :}+--+-- A container of such pairs is a 'Bifunctor' again, via+-- 'Data.Bifunctor.Tannen.Tannen', so a list of pairs of names, the shape an+-- α-equivalence test threads, also sinks in one coercion:+--+-- >>> :{+-- sinkPairs :: (DExt n n', DExt m m') => [(Name n, Name m)] -> [(Name n', Name m')]+-- sinkPairs = runTannen . sink2 . Tannen+-- :}+--+-- @since 0.4.0+sink2+  :: (Bifunctor p, Sinkable e1, Sinkable e2, DExt n n', DExt m m')+  => p (e1 n) (e2 m) -> p (e1 n') (e2 m')+sink2 = unsafeCoerce+{-# INLINE [0] sink2 #-}++-- | Extend renaming when going under a 'CoSinkable' pattern (generalized binder).+-- Note that the scope under pattern is independent of the codomain of the renaming.+--+-- This function is used to go under binders when implementing 'sinkabilityProof'+-- and is both a generalization of 'extendRenamingNameBinder' and an efficient implementation of 'coSinkabilityProof'.+--+-- @since 0.0.1+extendRenaming+  :: CoSinkable pattern+  => (Name n -> Name n')  -- ^ Map names from scope @n@ to a (possibly larger) scope @n'@.+  -> pattern n l          -- ^ A pattern that extends scope @n@ to another scope @l@.+  -> (forall l'. (Name l -> Name l') -> pattern n' l' -> r )+  -- ^ A continuation, accepting an extended renaming from @l@ to @l'@ (which itself extends @n'@)+  -- and a (possibly refreshed) pattern that extends @n'@ to @l'@.+  -> r+extendRenaming _ pattern cont =+  cont unsafeCoerce (unsafeCoerce pattern)++-- | Extend renaming of binders when going under a 'CoSinkable' pattern (generalized binder).+-- Note that the scope under pattern is independent of the codomain of the renaming.+--+-- @since 0.0.3+extendNameBinderRenaming+  :: CoSinkable pattern+  => (NameBinder i n -> NameBinder i n')  -- ^ Map names from scope @n@ to a (possibly larger) scope @n'@.+  -> pattern n l          -- ^ A pattern that extends scope @n@ to another scope @l@.+  -> (forall l'. (NameBinder n' l -> NameBinder n' l') -> pattern n' l' -> r )+  -- ^ A continuation, accepting an extended renaming from @l@ to @l'@ (which itself extends @n'@)+  -- and a (possibly refreshed) pattern that extends @n'@ to @l'@.+  -> r+extendNameBinderRenaming _ pattern cont =+  cont unsafeCoerce (unsafeCoerce pattern)++-- | Safely compose renamings of name binders.+-- The underlying implementation is+--+-- @since 0.0.3+composeNameBinderRenamings+  :: (NameBinder n i -> NameBinder n i')    -- ^ Rename binders extending scope @n@ from @i@ to @i'@.+  -> (NameBinder i' l -> NameBinder i' l')  -- ^ Rename binders extending scope @i'@ from @l@ to @l'@.+  -> (NameBinder n l -> NameBinder n l')+composeNameBinderRenamings = unsafeCoerce (flip (.))++-- | Convert renaming of name binders into renaming of names in the inner scopes.+--+-- @since 0.0.3+fromNameBinderRenaming :: (NameBinder n l -> NameBinder n l') -> Name l -> Name l'+fromNameBinderRenaming = coerce++-- | Extend renaming when going under a 'NameBinder'.+-- Note that the scope under binder is independent of the codomain of the renaming.+--+-- Semantically, this function may need to rename the binder (resulting in the new scope @l'@),+-- to make sure it does not clash with scope @n'@.+-- However, as it turns out, the foil makes it safe+-- to implement this function as a coercion.+-- See Appendix A in [«The Foil: Capture-Avoiding Substitution With No Sharp Edges»](https://doi.org/10.1145/3587216.3587224) for the details.+--+-- This function is used to go under binders when implementing 'sinkabilityProof'.+-- A generalization of this function is 'extendRenaming' (which is an efficient version of 'coSinkabilityProof').+--+-- @since 0.0.1+extendRenamingNameBinder+  :: (Name n -> Name n')  -- ^ Map names from scope @n@ to a (possibly larger) scope @n'@.+  -> NameBinder n l       -- ^ A name binder that extends scope @n@ to another scope @l@.+  -> (forall l'. (Name l -> Name l') -> NameBinder n' l' -> r )+  -- ^ A continuation, accepting an extended renaming from @l@ to @l'@ (which itself extends @n'@)+  -- and a (possibly refreshed) binder that extends @n'@ to @l'@.+  -> r+extendRenamingNameBinder _ (UnsafeNameBinder name) cont =+  cont unsafeCoerce (UnsafeNameBinder name)++-- | 'CoSinkable' is to patterns (generalized binders)+-- what 'Sinkable' is to expressions.+--+-- See Section 2.3 of [«Free Foil: Generating Efficient and Scope-Safe Abstract Syntax»](https://arxiv.org/abs/2405.16384) for more details.+--+-- @since 0.0.1+class CoSinkable (pattern :: S -> S -> Type) where+  -- | An implementation of this method that typechecks+  -- proves to the compiler that the pattern is indeed+  -- 'CoSinkable'. However, instead of this implementation,+  -- 'extendRenaming' should be used at all call sites for efficiency.+  coSinkabilityProof+    :: (Name n -> Name n')  -- ^ Map names from scope @n@ to a (possibly larger) scope @n'@.+    -> pattern n l          -- ^ A pattern that extends scope @n@ to another scope @l@.+    -> (forall l'. (Name l -> Name l') -> pattern n' l' -> r)+    -- ^ A continuation, accepting an extended renaming from @l@ to @l'@ (which itself extends @n'@)+    -- and a (possibly refreshed) pattern that extends @n'@ to @l'@.+    -> r+  default coSinkabilityProof+    :: (GenericK pattern, GSinkableK (RepK pattern))+    => (Name n -> Name n')+    -> pattern n l+    -> (forall l'. (Name l -> Name l') -> pattern n' l' -> r)+    -> r+  coSinkabilityProof rename p cont = gsinkabilityProof2 rename (fromK @_ @pattern p) $ \rename' p' ->+    cont rename' (toK @_ @pattern p')++  -- | Generalized processing of a pattern.+  --+  -- You can see 'withPattern' as a CPS-style traversal over the binders in a pattern.+  --+  -- == Patterns that carry scoped payloads+  --+  -- Note that the ambient scope @o@ and the pattern's own scope @n@ are+  -- unrelated: 'nameBinderListOf' passes 'emptyScope' and 'namesOfPattern'+  -- passes no scope at all. The only thing relating the two is the pair of+  -- binders each step of the traversal produces, the one the pattern has and+  -- the one the callback hands back.+  --+  -- A pattern whose fields are all binders and plain data does not notice this,+  -- and can take the default implementation. A pattern carrying a field indexed+  -- by /its own scope/, such as the type of a telescope's step, does notice: to+  -- rebuild that field at @o@ it needs a renaming, and the only honest one is+  -- the identity on the raw names the pattern does not bind, corrected at the+  -- binders that were refreshed. That renaming is 'PatternTransport', and such+  -- a pattern should implement 'withPattern' by hand, threading one through the+  -- traversal. See 'transportPayload' for the whole recipe.+  --+  -- The default implementation cannot do this, since it goes through+  -- 'unsafeSetNameBinders', which replaces the binders and leaves every other+  -- field as it stands: a payload mentioning a refreshed binder would keep the+  -- name that binder used to have. Rather than answer wrongly, it refuses: a+  -- field indexed by a scope is a type error in the generic implementation,+  -- naming the field and pointing here.+  withPattern+    :: Distinct o+    => (forall x y z r'. Distinct z => Scope z -> NameBinder x y -> (forall z'. DExt z z' => f x y z z' -> NameBinder z z' -> r') -> r')+    -- ^ Processing of a single 'NameBinder', this will be applied to each binder in a pattern.+    -> (forall x z z'. DExt z z' => f x x z z')+    -- ^ Result in case no binders are present. This can be seen as scope-indexed 'mempty'.+    -> (forall x y y' z z' z''. (DExt z z', DExt z' z'') => f x y z z' -> f y y' z' z'' -> f x y' z z'')+    -- ^ Composition of results for nested binders/patterns. This can be seen as scope-indexed 'mappend'.+    -> Scope o+    -- ^ Ambient scope.+    -> pattern n l+    -- ^ Pattern to process.+    -> (forall o'. DExt o o' => f n l o o' -> pattern o o' -> Scope o' -> r)+    -- ^ Continuation, accepting the result for the entire pattern, a (possibly refreshed) pattern, and the scope extended by that pattern.+    -> r+  default withPattern+    :: (Distinct o, GenericK pattern, GValidNameBinders pattern (RepK pattern), GHasNameBinders (RepK pattern))+    => (forall x y z r'. Distinct z => Scope z -> NameBinder x y -> (forall z'. DExt z z' => f x y z z' -> NameBinder z z' -> r') -> r')+    -> (forall x z z'. DExt z z' => f x x z z')+    -> (forall x y y' z z' z''. (DExt z z', DExt z' z'') => f x y z z' -> f y y' z' z'' -> f x y' z z'')+    -> Scope o+    -> pattern n l+    -> (forall o'. DExt o o' => f n l o o' -> pattern o o' -> Scope o' -> r)+    -> r+  withPattern = gunsafeWithPatternViaHasNameBinders++-- ** Transporting a pattern's payloads++-- | The renaming that carries a pattern's payloads into the ambient scope of+-- 'withPattern'.+--+-- A pattern may carry fields indexed by its own scope, the standard example+-- being a telescope, where each step has a type in the scope the steps before+-- it extend to. Rebuilding such a pattern at the ambient scope means rebuilding+-- those fields there too, and 'withPattern' hands the instance no renaming for+-- it. This is that renaming, accumulated as the traversal goes.+--+-- It is abstract on purpose: the only ways to build one are 'verbatimTransport'+-- and 'transportUnderBinder', which together are exactly what a correct+-- 'withPattern' does.+--+-- Soundness rests on what 'withPattern' is allowed to do. It replaces binders+-- and nothing else, so a raw name the pattern does not bind means in @o@ what+-- it meant in @n@, and the identity on raw names is a renaming from the one to+-- the other. That is the same coercion 'extendRenaming' and 'unsafeAssertFresh'+-- already perform.+--+-- @since 0.4.0+data PatternTransport (n :: S) (o :: S)+  = TransportVerbatim+    -- ^ No binder was refreshed, so raw names are unchanged throughout.+  | TransportRenamed (Name n -> Name o)+    -- ^ Some binder was refreshed, so payloads have to be traversed.++-- | The transport to start a 'withPattern' traversal with, before any binder+-- has been seen.+--+-- @since 0.4.0+verbatimTransport :: PatternTransport n o+verbatimTransport = TransportVerbatim++-- | Extend a transport by one binder of the pattern.+--+-- The names of the inner scope are the binder's own, which goes to whatever the+-- refreshed binder introduces, and the names of the outer scope, which the+-- transport so far already answers for.+--+-- @since 0.4.0+transportUnderBinder+  :: PatternTransport n o+  -> NameBinder n i    -- ^ The binder as the pattern has it.+  -> NameBinder o o'   -- ^ The binder 'withPattern' handed back.+  -> PatternTransport i o'+transportUnderBinder transport binder binder'+  | TransportVerbatim <- transport, unchanged = TransportVerbatim+  | otherwise = TransportRenamed $ \name ->+      if nameId name == nameId (nameOf binder)+        then nameOf binder'+        else unsafeCoerce (transportName transport (unsafeCoerce name))+  where+    unchanged = nameId (nameOf binder) == nameId (nameOf binder')++-- | Carry a payload along a transport.+--+-- The 'Sinkable' instance does the walking, and only when it has to. While no+-- binder has been refreshed the payload is taken over as it stands, so the+-- traversals that never rename ('extendScopePattern', 'namesOfPattern',+-- 'nameBinderListOf') do not walk payloads at all.+--+-- The whole recipe for a payload-carrying pattern, at a telescope of labelled+-- steps:+--+-- > instance Sinkable e => CoSinkable (Telescope label e) where+-- >   withPattern withBinder unit comp = go verbatimTransport+-- >     where+-- >       go _transport _scope TelescopeEmpty cont = cont unit TelescopeEmpty+-- >       go transport scope (TelescopeCons label payload binder rest) cont =+-- >         withBinder scope binder $ \fbinder binder' ->+-- >           go (transportUnderBinder transport binder binder')+-- >              (extendScope binder' scope) rest $ \frest rest' ->+-- >             cont (comp fbinder frest)+-- >               (TelescopeCons label (transportPayload transport payload)+-- >                              binder' rest')+--+-- Note which transport each payload takes: the one accumulated /before/ its own+-- binder, since that is the scope the payload lives in.+--+-- @since 0.4.0+transportPayload :: Sinkable e => PatternTransport n o -> e n -> e o+transportPayload TransportVerbatim         = unsafeCoerce+transportPayload (TransportRenamed rename) = sinkabilityProof rename++-- | Carry a single name along a transport.+--+-- @since 0.4.0+transportName :: PatternTransport n o -> Name n -> Name o+transportName TransportVerbatim         = unsafeCoerce+transportName (TransportRenamed rename) = rename++-- | Auxiliary data structure for collecting name binders. Used in 'nameBinderListOf'.+--+-- @since 0.2.0+newtype WithNameBinderList r n l (o :: S) (o' :: S) = WithNameBinderList (NameBinderList l r -> NameBinderList n r)++-- | Empty list of name binders (identity).+--+-- @since 0.2.0+idWithNameBinderList :: DExt o o' => WithNameBinderList r n n o o'+idWithNameBinderList = WithNameBinderList id++-- | Concatenating lists of name binders (compose).+--+-- @since 0.2.0+compWithNameBinderList+  :: (DExt o o', DExt o' o'')+  => WithNameBinderList r n i o o'+  -> WithNameBinderList r i l o' o''+  -> WithNameBinderList r n l o o''+compWithNameBinderList (WithNameBinderList f) (WithNameBinderList g) =+  WithNameBinderList (f . g)++-- | Collect name binders of a generalized pattern into a name binder list,+-- which can be more easily traversed.+--+-- @since 0.2.0+nameBinderListOf :: (CoSinkable binder) => binder n l -> NameBinderList n l+nameBinderListOf pat = withPattern+  (\_scope' binder k ->+    unsafeAssertFresh binder $ \binder' ->+      k (WithNameBinderList (NameBinderListCons binder)) binder')+  idWithNameBinderList+  compWithNameBinderList+  emptyScope+  pat+  (\(WithNameBinderList f) _ _ -> f NameBinderListEmpty)++instance CoSinkable NameBinder where+  coSinkabilityProof _rename (UnsafeNameBinder name) cont =+    cont unsafeCoerce (UnsafeNameBinder name)++  withPattern withBinder _ _ scope binder cont =+    withBinder scope binder $ \f binder' ->+      cont f binder' (extendScope binder' scope)++-- * Safe substitions++-- | A substitution is a mapping from names in scope @i@+-- to expressions @e o@ in scope @o@.+--+-- @since 0.0.1+newtype Substitution (e :: S -> Type) (i :: S) (o :: S) =+  UnsafeSubstitution (IntMap (e o))++-- | Apply substitution to a given name.+--+-- @since 0.0.1+{-# INLINABLE lookupSubst #-}+lookupSubst :: InjectName e => Substitution e i o -> Name i -> e o+lookupSubst (UnsafeSubstitution env) (UnsafeName name) =+    case IntMap.lookup name env of+        Just ex -> ex+        Nothing -> injectName (UnsafeName name)++-- | Identity substitution maps all names to expresion-variables.+--+-- @since 0.0.1+identitySubst+  :: InjectName e => Substitution e i i+identitySubst = UnsafeSubstitution IntMap.empty++-- | Whether a substitution maps every name to itself (see 'addRename',+-- which deletes identity renames, so this is one null test).+--+-- @since 0.4.0+nullSubst :: Substitution e i o -> Bool+nullSubst (UnsafeSubstitution env) = IntMap.null env++-- | An empty substitution from an empty scope.+--+-- @since 0.2.0+voidSubst :: Substitution e VoidS n+voidSubst = UnsafeSubstitution IntMap.empty++-- | Extend substitution with a particular mapping.+--+-- @since 0.0.1+{-# INLINABLE addSubst #-}+addSubst+  :: Substitution e i o+  -> NameBinder i i'+  -> e o+  -> Substitution e i' o+addSubst (UnsafeSubstitution env) (UnsafeNameBinder (UnsafeName name)) ex+  = UnsafeSubstitution (IntMap.insert name ex env)++-- | Extend a substitution with a value for each binder of a pattern, in the+-- order the pattern binds them.+--+-- @since 0.2.0+addSubstPattern+  :: CoSinkable binder+  => Substitution e i o+  -> binder i i'+  -> [e o]+  -> Substitution e i' o+addSubstPattern subst pat = addSubstList subst (nameBinderListOf pat)++-- | Extend a substitution with a value for each binder of a chain, in order.+-- Fails with 'error' when the list of values is too short.+--+-- @since 0.2.0+addSubstList+  :: Substitution e i o+  -> NameBinderList i i'+  -> [e o]+  -> Substitution e i' o+addSubstList subst NameBinderListEmpty _ = subst+addSubstList subst (NameBinderListCons binder binders) (x:xs) =+  addSubstList (addSubst subst binder x) binders xs+addSubstList _ _ [] = error "cannot add a binder to Substitution since the value list does not have enough elements"++-- | Add variable renaming to a substitution.+--+-- When the binder is mapped to its own name, the name is /deleted/ from the+-- substitution rather than mapped to itself. This is an optimization, but it is+-- not only an optimization: it is also how the binder shadows an outer binding+-- of the same raw name, so the delete cannot be skipped even when nothing is+-- being renamed. See 'withRefreshedPattern' for why that rules out an+-- all-binders-fresh fast path.+--+-- @since 0.0.1+{-# INLINABLE addRename #-}+addRename :: InjectName e => Substitution e i o -> NameBinder i i' -> Name o -> Substitution e i' o+addRename s@(UnsafeSubstitution env) b@(UnsafeNameBinder (UnsafeName name1)) n@(UnsafeName name2)+    | name1 == name2 = UnsafeSubstitution (IntMap.delete name1 env)+    | otherwise = addSubst s b (injectName n)++-- | Substitutions are sinkable as long as corresponding expressions are.+instance (Sinkable e) => Sinkable (Substitution e i) where+  sinkabilityProof rename (UnsafeSubstitution env) =+    UnsafeSubstitution (fmap (sinkabilityProof rename) env)++-- * 'Name' maps++-- | A /total/ map from names in scope @n@ to elements of type @a@.+--+-- @since 0.0.1+newtype NameMap (n :: S) a = NameMap { getNameMap :: IntMap a } deriving (Functor, Foldable, Traversable)++-- | An empty map belongs in the empty scope.+--+-- @since 0.0.1+emptyNameMap :: NameMap VoidS a+emptyNameMap = NameMap IntMap.empty++-- | Map over a 'NameMap', with the name each value belongs to.+--+-- This is the keyed version of the derived 'Functor' instance. It cannot change+-- which names the map is defined on, so a map that was total stays total, which+-- is what makes it a safe way to build a 'Substitution' out of one: see+-- 'nameMapToSubstitution'.+--+-- @since 0.4.0+mapWithName :: (Name n -> a -> b) -> NameMap n a -> NameMap n b+mapWithName f (NameMap m) = NameMap (IntMap.mapWithKey (f . UnsafeName) m)++-- | Convert a 'NameMap' of expressions into a 'Substitution'.+--+-- @since 0.2.0+nameMapToSubstitution :: NameMap i (e o) -> Substitution e i o+nameMapToSubstitution (NameMap m) = (UnsafeSubstitution m)++-- | Convert a 'NameMap' of expressions into a 'Scope'.+--+-- @since 0.3.0+nameMapToScope :: NameMap n a -> Scope n+nameMapToScope (NameMap m) = UnsafeScope (IntMap.keysSet m)++-- | Extend a map with multiple mappings (by repeatedly applying 'addNameBinder').+--+-- Note that the input list is expected to have __at least__ the same number of elements+-- as there are binders in the input pattern (generalized binder).+--+-- @since 0.2.0+addNameBinders :: CoSinkable binder => binder n l -> [a] -> NameMap n a -> NameMap l a+addNameBinders pat = addNameBinderList (nameBinderListOf pat)++-- | Extend a map with multiple mappings (by repeatedly applying 'addNameBinder').+--+-- Note that the input list is expected to have __at least__ the same number of elements+-- as there are binders in the input name binder list.+--+-- See also 'addNameBinders' for a generalized version.+--+-- @since 0.2.0+addNameBinderList :: NameBinderList n l -> [a] -> NameMap n a -> NameMap l a+addNameBinderList NameBinderListEmpty _ = id+addNameBinderList (NameBinderListCons binder binders) (x:xs) =+  addNameBinderList binders xs . addNameBinder binder x+addNameBinderList _ [] = error "cannot add a binder to NameMap since the value list does not have enough elements"++-- | Looking up a name should always succeed.+--+-- Note that since 'Name' is 'Sinkable', a name of scope @n@ can be looked up in a 'NameMap' for scope @l@ whenever @l@ extends @n@.+--+-- @since 0.0.1+lookupName :: Name n -> NameMap n a -> a+lookupName name (NameMap m) =+  case IntMap.lookup (nameId name) m of+    Nothing -> error "impossible: unknown name in a NameMap"+    Just x  -> x++-- | Extending a map with a single mapping.+--+-- Note that the scope parameter of the result differs from the initial map.+--+-- @since 0.0.1+addNameBinder :: NameBinder n l -> a -> NameMap n a -> NameMap l a+addNameBinder name x (NameMap m) = NameMap (IntMap.insert (nameId (nameOf name)) x m)++-- | Remove the mapping for a binder, shrinking the map back to the outer scope.+--+-- This is the inverse of 'addNameBinder', and is what a type checker wants when+-- it leaves a binder it has entered.+--+-- @since 0.3.1+popNameBinder :: NameBinder n l -> NameMap l a -> NameMap n a+popNameBinder binder (NameMap m) = NameMap (IntMap.delete (nameId (nameOf binder)) m)++-- | Allocate a fresh binder for each element of a list, binding each element to+-- its binder in the map.+--+-- The continuation receives the extended scope, the binders in the order of the+-- input list, and the extended map. This is the list-shaped counterpart of+-- 'withFresh', and saves a caller from threading the scope, the binders, and the+-- map through a recursion by hand.+--+-- @since 0.3.1+withFreshNameBinderList+  :: forall n a r. Distinct n+  => [a]                  -- ^ A value to bind to each fresh binder.+  -> Scope n              -- ^ The ambient scope.+  -> NameMap n a          -- ^ The map to extend.+  -> (forall l. DExt n l => Scope l -> NameBinderList n l -> NameMap l a -> r)+  -> r+withFreshNameBinderList = withFreshNameBinderListIn fullNameRange++-- | A version of 'withFreshNameBinderList' that allocates within a given+-- range (see 'withFreshIn'). This is the bulk form of range-guarded+-- allocation: pre-allocating the names of a whole unit at once and+-- allocating them one at a time are the same operation at different+-- granularity, so both extend the scope index faithfully.+--+-- Fails with 'error' when the range is exhausted.+--+-- @since 0.4.0+withFreshNameBinderListIn+  :: forall n a r. Distinct n+  => NameRange            -- ^ The reservation to allocate from.+  -> [a]                  -- ^ A value to bind to each fresh binder.+  -> Scope n              -- ^ The ambient scope.+  -> NameMap n a          -- ^ The map to extend.+  -> (forall l. DExt n l => Scope l -> NameBinderList n l -> NameMap l a -> r)+  -> r+withFreshNameBinderListIn range xs0 scope0 nameMap0 cont =+    go xs0 scope0 NameBinderListEmpty nameMap0 cont+  where+    go :: forall i r'. Distinct i+       => [a] -> Scope i -> NameBinderList n i -> NameMap i a+       -> (forall l. DExt n l => Scope l -> NameBinderList n l -> NameMap l a -> r')+       -> r'+    go [] scope binders nameMap cont' =+      case (assertDistinct binders, assertExt binders) of+        (Distinct, Ext) -> cont' scope binders nameMap+    go (x:xs) scope binders nameMap cont' =+      withFreshIn range scope $ \binder ->+        go xs+           (extendScope binder scope)+           (snocNameBinderList binders binder)+           (addNameBinder binder x nameMap)+           cont'++-- * Raw types and operations++-- | We will use 'Int' for efficient representation of identifiers.+--+-- @since 0.0.1+type Id = Int++-- | Raw name is simply an identifier.+--+-- @since 0.0.1+type RawName = Id++-- | A raw scope is a set of raw names.+--+-- @since 0.0.1+type RawScope = IntSet++-- | \(O(\min(n, W))\).+-- Generate a fresh raw name that+-- does not appear in a given raw scope.+-- The guard keeps allocation out of the negative range: names below zero+-- are reserved for interned constants, allocated by an explicit policy+-- ('withFreshIn' at a negative range) and never by this successor. Without+-- the guard, a scope holding only negative names would hand out the+-- successor of its maximum, which is a "fresh" name inside the constants'+-- region and may collide with a constant not in this scope. A scope that+-- holds 'maxBound' is reported as exhausted rather than wrapped past,+-- since the wrapped successor lands on an arbitrary small name that may+-- well be taken.+--+-- @since 0.0.1+rawFreshName :: RawScope -> RawName+rawFreshName scope+  | IntSet.null scope = 0+  | otherwise = case IntSet.findMax scope of+      m | m == maxBound -> error "rawFreshName: name space exhausted"+        | otherwise     -> max 0 (m + 1)++-- | An inclusive reservation of a contiguous range of raw names.+--+-- A range is a bound on an allocator (see 'withFreshIn'), not a set of names:+-- its runtime content is two 'Int's. A range with @lo > hi@ is empty.+--+-- @since 0.4.0+data NameRange = NameRange+  { nameRangeLo :: !RawName  -- ^ The smallest name of the reservation.+  , nameRangeHi :: !RawName  -- ^ The largest name of the reservation (inclusive).+  } deriving (Eq, Show)++-- | The range of all non-negative names.+--+-- On a scope without negative members, allocation within 'fullNameRange'+-- agrees with 'rawFreshName'. The two diverge on a scope with negative+-- members: 'rawFreshName' allocates right above the maximum, wherever that+-- lands, while 'fullNameRange' clamps allocation to non-negative names.+--+-- @since 0.4.0+fullNameRange :: NameRange+fullNameRange = NameRange 0 maxBound++-- | \(O(\min(n, W))\).+-- Generate a fresh raw name within a given range: the successor of the+-- largest scope member inside the range, or the range's low end when no+-- scope member lies inside the range. Returns 'Nothing' when the range is+-- exhausted (or empty to begin with).+--+-- The resulting name is fresh with respect to the /whole/ scope: it differs+-- from scope members inside the range by being greater, and from members+-- outside the range by being inside it.+--+-- >>> rawFreshNameIn (NameRange 10 19) (IntSet.fromList [-5, 3, 12, 100])+-- Just 13+-- >>> rawFreshNameIn (NameRange 10 19) (IntSet.fromList [42])+-- Just 10+-- >>> rawFreshNameIn (NameRange 10 19) (IntSet.fromList [3, 19])+-- Nothing+--+-- Note that the implementation must not increment either bound of the range:+-- @'IntSet.lookupLT' (hi + 1)@ would wrap around at @hi = maxBound@, and+-- @x + 1@ would wrap around at @x = hi = maxBound@. Both are guarded here,+-- and the property tests pin both cases.+--+-- @since 0.4.0+rawFreshNameIn :: NameRange -> RawScope -> Maybe RawName+rawFreshNameIn (NameRange lo hi) scope+  | lo > hi   = Nothing+  | otherwise = case IntSet.lookupLE hi scope of+      Just x | x >= lo -> if x < hi then Just (x + 1) else Nothing+      _                -> Just lo++-- | Check if a raw name is contained in a raw scope.+--+-- @since 0.0.1+rawMember :: RawName -> RawScope -> Bool+rawMember = IntSet.member++-- * Constraints++-- | Every scope is a (trivial) extension of itself.+--+-- __Important__: this class exists to assist tracking scope extensions+-- for type variables of kind 'S'.+-- Users of the foil are not supposed to implement any instances of 'ExtEndo'.+--+-- @since 0.0.1+class ExtEndo (n :: S)++-- | Some scopes are extensions of other scopes.+--+-- __Important__: this class exists to assist tracking scope extensions+-- for type variables of kind 'S'.+-- Users of the foil are not supposed to implement any instances of 'Ext'.+--+-- @since 0.0.1+class (ExtEndo n => ExtEndo l ) => Ext (n :: S) (l :: S)+instance ( ExtEndo n => ExtEndo l ) => Ext n l++-- | Scopes with distinct names.+--+-- __Important__: this class exists to explicitly+-- mark scopes with distinct names.+-- Users of the foil are not supposed to implement any instances of 'Distinct'.+--+-- @since 0.0.1+class Distinct (n :: S)+instance Distinct VoidS++-- | Scope extensions with distinct names.+--+-- @since 0.0.1+type DExt n l = (Distinct l, Ext n l)++-- | Instances of this typeclass possess the ability to inject names.+-- Usually, this is a variable data constructor.+--+-- @since 0.0.1+class InjectName (e :: S -> Type) where+  -- | Inject names into expressions.+  --+  -- @since 0.0.1+  injectName :: Name n -> e n++-- * Kind-polymorphic sinkability++-- | One renaming per scope index of a kind-polymorphic type, which is what+-- 'sinkabilityProofK' threads through a value.+--+-- @since 0.3.0+data RenamingsK (as :: LoT k) (bs :: LoT k) where+  RNil :: RenamingsK LoT0 LoT0+  RCons :: (Name a -> Name b) -> RenamingsK as bs -> RenamingsK (a :&&: as) (b :&&: bs)+  RSkip :: RenamingsK as bs -> RenamingsK (k :&&: as) (k :&&: bs)++-- | 'Sinkable' for a type with any number of scope indices, and the class a+-- pattern derives to obtain the foil's traversals. An instance is normally+-- empty, leaving the generic implementation to walk the+-- 'Generics.Kind.RepK' of the type.+--+-- @since 0.3.0+class SinkableK (f :: S -> k) where+  -- | Rename every scope index of a value, in continuation-passing style.+  --+  -- @since 0.3.0+  sinkabilityProofK+    :: forall as bs r.+       RenamingsK as bs+    -> f :@@: as+    -> (forall cs. RenamingsK as cs -> f :@@: cs -> r)+    -> r+  default sinkabilityProofK :: forall as bs r.+      (GenericK f, GSinkableK (RepK f))+    => RenamingsK as bs+    -> f :@@: as+    -> (forall cs. RenamingsK as cs -> f :@@: cs -> r)+    -> r+  sinkabilityProofK rename e cont =+    gsinkabilityProofK rename (fromK @_ @f e) $ \rename' e' ->+      cont rename' (toK @_ @f e')++-- | Move a value between two scope index lists reached from a common one, as+-- a coercion.+--+-- @since 0.3.0+sinkK :: GSinkableK f => RenamingsK xs as -> RenamingsK xs bs -> f :@@: as -> f :@@: bs+sinkK _ _ = unsafeCoerce++instance SinkableK Name where+  sinkabilityProofK renameK@(RCons rename RNil) name cont = cont renameK (rename name)+instance SinkableK NameBinder where+  sinkabilityProofK (RCons _ RNil) (UnsafeNameBinder name) cont =+    cont (RCons unsafeCoerce RNil) (UnsafeNameBinder name)+instance SinkableK NameBinders where+  sinkabilityProofK (RCons _ RNil) (UnsafeNameBinders s) cont =+    cont (RCons unsafeCoerce RNil) (UnsafeNameBinders s)++instance GenericK NameBinderList where+  type RepK NameBinderList = ((Var0 :~~: Var1) :=>: U1) :+: Exists S+    (Field (NameBinder :$: Var1 :@: Var0) :*: Field (NameBinderList :$: Var0 :@: Var2))+  toK (L1 (SuchThat U1))                   = NameBinderListEmpty+  toK (R1 (Exists (Field x :*: Field xs))) = NameBinderListCons x xs+  fromK NameBinderListEmpty       = L1 (SuchThat U1)+  fromK (NameBinderListCons x xs) = R1 (Exists (Field x :*: Field xs))++instance GenericK V2 where+  type RepK V2 = V1+  toK _v1 = error "absurd: Generics.Kind.V1"+  fromK = absurd2++instance GenericK U2 where+  type RepK U2 = ((Var0 :~~: Var1) :=>: U1)+  toK (SuchThat U1) = U2+  fromK U2 = SuchThat U1++instance SinkableK NameBinderList+instance SinkableK V2+instance SinkableK U2++-- | 'sinkabilityProofK' at a type with exactly one scope index.+--+-- @since 0.3.0+sinkabilityProof1 :: SinkableK f => (Name n -> Name n') -> f n -> f n'+sinkabilityProof1 rename e = sinkabilityProofK (RCons rename RNil) e $ \_ e' -> unsafeCoerce e'++-- | 'gsinkabilityProofK' at a representation with one scope index.+--+-- @since 0.3.0+gsinkabilityProof1 :: GSinkableK f => (Name n -> Name n') -> f (n :&&: LoT0) -> f (n' :&&: LoT0)+gsinkabilityProof1 rename e = gsinkabilityProofK (RCons rename RNil) e $ \_ e' -> unsafeCoerce e'++-- | 'gsinkabilityProofK' at a representation with two scope indices, the+-- shape of a pattern: the outer scope is renamed by the given function, and+-- the inner one by the renaming handed to the continuation.+--+-- @since 0.3.0+gsinkabilityProof2+  :: forall f n n' l r. GSinkableK f+  => (Name n -> Name n') -> f (n :&&: l :&&: LoT0)+  -> (forall l'. (Name l -> Name l') -> f (n' :&&: l' :&&: LoT0) -> r)+  -> r+gsinkabilityProof2 rename e cont =+  gsinkabilityProofK (RCons rename (RCons id RNil)) e $ \case+    RCons (_ :: Name n -> Name n'') (RCons rename' RNil) -> \e' ->+      case unsafeCoerce (Type.Refl :: n' Type.:~: n') :: n' Type.:~: n'' of+        Type.Refl -> cont rename' e'++-- | 'gsinkabilityProofK' where the resulting index list is known, so that no+-- continuation is needed.+--+-- @since 0.3.0+gsinkabilityProofK' :: GSinkableK f => RenamingsK as bs -> f as -> f bs+gsinkabilityProofK' renameK e = gsinkabilityProofK renameK e $ \_ e' -> unsafeCoerce e'++-- | 'SinkableK' on the "Generics.Kind" representation of a type, which is+-- what the default 'sinkabilityProofK' goes through.+--+-- @since 0.3.0+class GSinkableK p where+  -- | Rename every scope index of a representation.+  --+  -- @since 0.3.0+  gsinkabilityProofK+    :: forall as bs r.+       RenamingsK as bs+    -> p as+    -> (forall cs. RenamingsK as cs -> p cs -> r)+    -> r++-- | 'sinkK' on a representation.+--+-- @since 0.3.0+gsinkK :: GSinkableK f => RenamingsK xs as -> RenamingsK xs bs -> f as -> f bs+gsinkK _ _ = unsafeCoerce++instance GSinkableK V1 where+  gsinkabilityProofK irename _v1 cont =+    cont irename (error "absurd: Generics.Kind.V1")++instance GSinkableK U1 where+  gsinkabilityProofK irename U1 cont =+    cont irename U1++instance GSinkableK f => GSinkableK (M1 i c f) where+  gsinkabilityProofK irename (M1 x) cont =+    gsinkabilityProofK irename x $ \irename' x' ->+      cont irename' (M1 x')++instance (GSinkableK f, GSinkableK g) => GSinkableK (f :+: g) where+  gsinkabilityProofK irename (L1 x) cont =+    gsinkabilityProofK irename x $ \irename' x' ->+      cont irename' (L1 x')+  gsinkabilityProofK irename (R1 x) cont =+    gsinkabilityProofK irename x $ \irename' x' ->+      cont irename' (R1 x')++instance (GSinkableK f, GSinkableK g) => GSinkableK (f :*: g) where+  gsinkabilityProofK irename (x :*: y) cont =+    gsinkabilityProofK irename x $ \irename' x' ->+      gsinkabilityProofK irename' y $ \irename'' y' ->+        cont irename'' (gsinkK irename' irename'' x' :*: y')++instance GSinkableK f => GSinkableK (Exists S f) where+  gsinkabilityProofK irename (Exists x) cont =+    gsinkabilityProofK (RCons id irename) x $ \case+      RCons _ irename' -> \x' ->+        cont irename' (Exists x')++instance {-# OVERLAPPABLE #-} GSinkableK f => GSinkableK (Exists k f) where+  gsinkabilityProofK irename (Exists x) cont =+    gsinkabilityProofK (RSkip irename) x $ \case+      RSkip irename' -> \x' ->+        cont irename' (Exists x')++instance GSinkableK f => GSinkableK ((a :~~: b) :=>: f) where+  gsinkabilityProofK irename (SuchThat x) cont =+    gsinkabilityProofK irename x $ \(irename' :: RenamingsK as cs) x' ->+      -- this is sort of safe...+      case unsafeCoerce (Type.Refl :: Interpret a cs Type.:~: Interpret a cs) :: Interpret a cs Type.:~: Interpret b cs of+        Type.Refl -> cont irename' (SuchThat x')++instance GSinkableK (Field (Kon a)) where+  gsinkabilityProofK irename (Field x) cont =+    cont irename (Field x)++instance GSinkableK (Field (Var a)) where+  gsinkabilityProofK irename (Field x) cont =+    cont irename (Field (unsafeCoerce x)) -- FIXME: unsafeCoerce?++instance (SinkableK f, ExtractRenamingK i) => GSinkableK (Field (Kon f :@: Var i)) where+  gsinkabilityProofK irename (Field x) cont =+    sinkabilityProofK (RCons (extractRenamingK @_ @i irename) RNil) x $ \case+      RCons rename' RNil -> \x' ->+        cont (putBackRenamingK @_ @i rename' irename) (Field (unsafeCoerce x')) -- unsafeCoerce?++instance SinkableK (f a) => GSinkableK (Field (Kon f :@: Kon a :@: Var0)) where+  gsinkabilityProofK irename@(RCons _ RNil) (Field x) cont =+    sinkabilityProofK irename x $ \rename' x' ->+      cont rename' (Field x')++instance SinkableK (f a b) => GSinkableK (Field (Kon f :@: Kon a :@: Kon b :@: Var0)) where+  gsinkabilityProofK irename@(RCons _ RNil) (Field x) cont =+    sinkabilityProofK irename x $ \rename' x' ->+      cont rename' (Field x')++-- | Reading one scope index out of a list of them, and putting a renaming+-- back at that position. This is what lets a generic traversal work on the+-- index a field actually mentions.+--+-- @since 0.3.0+class ExtractRenamingK (i :: TyVar k S) where+  -- | The renaming at this index.+  --+  -- @since 0.3.0+  extractRenamingK :: forall (as :: LoT k) (bs :: LoT k).+    RenamingsK as bs -> Name (Interpret (Var i) as) -> Name (Interpret (Var i) bs)+  -- | Replace the renaming at this index.+  --+  -- @since 0.3.0+  putBackRenamingK :: forall c (as :: LoT k) (bs :: LoT k).+       (Name (Interpret (Var i) as) -> Name c)+    -> RenamingsK as bs+    -> RenamingsK as (PutBackLoT i c bs)++instance ExtractRenamingK VZ where+  extractRenamingK (RCons f _fs) = f+  putBackRenamingK f (RCons _ gs) = RCons f gs++instance ExtractRenamingK x => ExtractRenamingK (VS x) where+  extractRenamingK (RCons _f fs) = extractRenamingK @_ @x fs+  putBackRenamingK f (RCons g gs) = RCons g (putBackRenamingK @_ @x f gs)++-- | 'extractRenamingK' at two indices at once, as a pattern's traversal needs.+--+-- @since 0.3.0+extractTwoRenamingsK :: forall k (i :: TyVar k S) (j :: TyVar k S) (as :: LoT k) (bs :: LoT k).+    (ExtractRenamingK i, ExtractRenamingK j)+  => RenamingsK as bs+  -> RenamingsK+      (Interpret (Var i) as :&&: Interpret (Var j) as :&&: LoT0)+      (Interpret (Var i) bs :&&: Interpret (Var j) bs :&&: LoT0)+extractTwoRenamingsK irename =+  (RCons (extractRenamingK @_ @i irename) (RCons (extractRenamingK @_ @j irename) RNil))++-- | 'putBackRenamingK' at two indices at once.+--+-- @since 0.3.0+putBackTwoRenamingsK :: forall k (i :: TyVar k S) (j :: TyVar k S) c1 c2 (as :: LoT k) (bs :: LoT k).+    (ExtractRenamingK i, ExtractRenamingK j)+  => RenamingsK+      (Interpret (Var i) as :&&: Interpret (Var j) as :&&: LoT0)+      (c1 :&&: c2 :&&: LoT0)+  -> RenamingsK as bs+  -> RenamingsK as (PutBackLoT j c2 (PutBackLoT i c1 bs))+putBackTwoRenamingsK (RCons f1 (RCons f2 RNil)) rename+  = putBackRenamingK @_ @j f2 (putBackRenamingK @_ @i f1 rename)++instance (SinkableK f, ExtractRenamingK i, ExtractRenamingK j) => GSinkableK (Field (Kon f :@: Var (i :: TyVar k S) :@: Var (j :: TyVar k S))) where+  gsinkabilityProofK irename (Field x) cont =+    sinkabilityProofK (extractTwoRenamingsK @_ @i @j irename) x $ \rename' x' ->+      case rename' of+        RCons _ (RCons _ RNil) ->+          cont (putBackTwoRenamingsK @_ @i @j rename' irename)+              (Field (unsafeCoerce x'))  -- FIXME: can we do better than unsafeCoerce?++instance (Functor f, GSinkableK (Field x)) => GSinkableK (Field (Kon f :@: x)) where+  gsinkabilityProofK irename (Field x) cont =+    cont irename (Field (fmap+      (unField . gsinkabilityProofK' @(Field x) irename . Field)+      x))++instance (Bifunctor f, GSinkableK (Field x), GSinkableK (Field y)) => GSinkableK (Field (Kon f :@: x :@: y)) where+  gsinkabilityProofK irename (Field x) cont =+    cont irename (Field (bimap+      (unField . gsinkabilityProofK' @(Field x) irename . Field)+      (unField . gsinkabilityProofK' @(Field y) irename . Field)+      x))++-- * Kind-polymorphic types with binders++-- ** Generic version of 'withPattern'++-- | Generic generalized processing of a pattern via 'GHasNameBinders'.+--+-- This can be used as a default implementation of 'withPattern'.+--+-- @since 0.3.0+gunsafeWithPatternViaHasNameBinders+  :: forall pattern f o n l r.+      (Distinct o, GenericK pattern, GValidNameBinders pattern (RepK pattern), GHasNameBinders (RepK pattern))+  => (forall x y z r'. Distinct z => Scope z -> NameBinder x y -> (forall z'. DExt z z' => f x y z z' -> NameBinder z z' -> r') -> r')+  -- ^ Processing of a single 'NameBinder', this will be applied to each binder in a pattern.+  -> (forall x z z'. DExt z z' => f x x z z')+  -- ^ Result in case no binders are present. This can be seen as scope-indexed 'mempty'.+  -> (forall x y y' z z' z''. (DExt z z', DExt z' z'') => f x y z z' -> f y y' z' z'' -> f x y' z z'')+  -- ^ Composition of results for nested binders/patterns. This can be seen as scope-indexed 'mappend'.+  -> Scope o+  -- ^ Ambient scope.+  -> pattern n l+  -- ^ Pattern to process.+  -> (forall o'. DExt o o' => f n l o o' -> pattern o o' -> Scope o' -> r)+  -- ^ Continuation, accepting the result for the entire pattern, a (possibly refreshed) pattern, and the scope extended by that pattern.+  -> r+gunsafeWithPatternViaHasNameBinders withBinder id_ comp_ scope pat cont =+  withPattern withBinder id_ comp_ scope (ggetNameBinders pat) $ \result binders scope' ->+    cont result (gunsafeSetNameBinders (unsafeCoerce pat) binders) scope' -- FIXME: safer version++-- ** Manipulating nested 'NameBinder's+-- | If @'HasNameBinders' f@, then @f n l@ is expected to act as a binder,+-- introducing into scope @n@ some local variables, extending it to scope @l@.+-- This class allows to extract and modify the set of binders.+--+-- @since 0.3.0+class HasNameBinders f where+  -- | Extract a set of binders from a pattern.+  --+  -- @since 0.3.0+  getNameBinders :: f n l -> NameBinders n l+  getNameBinders = UnsafeNameBinders . IntSet.fromList . getNameBindersRaw++  -- | Replace binders in a pattern.+  --+  -- This function is unsafe, because it does not check if the new set of binders+  -- has the same size. It can therefore crash at runtime.+  --+  -- You should probably not use this.+  -- This is only used for 'gunsafeWithPatternViaHasNameBinders', which is then safe to use.+  --+  -- @since 0.3.0+  unsafeSetNameBinders :: f n l -> NameBinders n l' -> f n l'+  unsafeSetNameBinders e (UnsafeNameBinders m) = fst (reallyUnsafeSetNameBindersRaw e (IntSet.toList m))++  -- | Extract 'RawName's of all binders occurring in a pattern.+  --+  -- @since 0.3.0+  getNameBindersRaw :: f n l -> [RawName]+  default getNameBindersRaw :: forall n l. (GenericK f, GHasNameBinders (RepK f)) => f n l -> [RawName]+  getNameBindersRaw = ggetNameBindersRaw . fromK @_ @f @(n :&&: l :&&: LoT0)++  -- | This is a version of 'unsafeSetNameBinders'+  -- that takes in a list of 'RawName's.+  --+  -- It does not check if the given list has enough elements.+  -- It does not check if the raw names are fresh in the scope @n@.+  -- It does not check if the raw names given are distinct.+  --+  -- You should never use this. This is only used for generic implementation of 'HasNameBinders'.+  --+  -- @since 0.3.0+  reallyUnsafeSetNameBindersRaw :: f n l -> [RawName] -> (f n l', [RawName])+  default reallyUnsafeSetNameBindersRaw :: forall n l l'. (GenericK f, GValidNameBinders f (RepK f), GHasNameBinders (RepK f)) => f n l -> [RawName] -> (f n l', [RawName])+  reallyUnsafeSetNameBindersRaw e names =+    let (e', names') = greallyUnsafeSetNameBindersRaw (fromK @_ @f @(n :&&: l :&&: LoT0) e) names+     in (toK @_ @f @(n :&&: l' :&&: LoT0) e', names')++instance HasNameBinders NameBinder where+  getNameBindersRaw (UnsafeNameBinder (UnsafeName name)) = [name]+  reallyUnsafeSetNameBindersRaw _ (name:names) = (UnsafeNameBinder (UnsafeName name), names)++instance HasNameBinders NameBinderList++-- ** Generic++-- | 'getNameBinders' through the generic representation.+--+-- @since 0.3.0+ggetNameBinders :: forall f n l. (GenericK f, GHasNameBinders (RepK f)) => f n l -> NameBinders n l+ggetNameBinders = UnsafeNameBinders . IntSet.fromList . ggetNameBindersRaw . fromK @_ @f @(n :&&: l :&&: LoT0)++-- | 'unsafeSetNameBinders' through the generic representation.+--+-- @since 0.3.0+gunsafeSetNameBinders :: forall f n l l'. (GenericK f, GValidNameBinders f (RepK f), GHasNameBinders (RepK f)) => f n l -> NameBinders n l' -> f n l'+gunsafeSetNameBinders e (UnsafeNameBinders m) = toK @_ @f @(n :&&: l' :&&: LoT0) $+  fst (greallyUnsafeSetNameBindersRaw (fromK @_ @f @(n :&&: l :&&: LoT0) e) (IntSet.toList m))++-- | 'HasNameBinders' on the "Generics.Kind" representation of a pattern.+--+-- @since 0.3.0+class GHasNameBinders f where+  -- | The raw names the representation binds, in order.+  --+  -- @since 0.3.0+  ggetNameBindersRaw :: f as -> [RawName]++  -- | Replace those names, returning what is left of the list.+  --+  -- @since 0.3.0+  greallyUnsafeSetNameBindersRaw :: f as -> [RawName] -> (f bs, [RawName])++instance GHasNameBinders V1 where+  ggetNameBindersRaw _ = error "absurd: Generics.Kind.V1"+  greallyUnsafeSetNameBindersRaw _ _ = error "absurd: Generics.Kind.V1"+instance GHasNameBinders U1 where+  ggetNameBindersRaw U1 = []+  greallyUnsafeSetNameBindersRaw U1 names = (U1, names)++instance (GHasNameBinders f, GHasNameBinders g) => GHasNameBinders (f :+: g) where+  ggetNameBindersRaw (L1 x) = ggetNameBindersRaw x+  ggetNameBindersRaw (R1 x) = ggetNameBindersRaw x++  greallyUnsafeSetNameBindersRaw (L1 x) names = first L1 (greallyUnsafeSetNameBindersRaw x names)+  greallyUnsafeSetNameBindersRaw (R1 x) names = first R1 (greallyUnsafeSetNameBindersRaw x names)++-- | __A caveat.__ This instance treats the two factors as /nested/ binders,+-- and does not reject /parallel/ ones:+--+-- > data BadPattern n l = BadPattern (NameBinder n l) (NameBinder n l)+--+-- The intended shape is a chain, in which each binder extends the scope the+-- next one starts from:+--+-- > data GoodPattern n l = forall i. GoodPattern (NameBinder n i) (NameBinder i l)+--+-- Template Haskell never generates parallel binders, and writing one by hand+-- takes deliberate effort, so this is unlikely to be reached by accident.+-- Detecting and rejecting such a pattern would still be better. instance (GHasNameBinders f, GHasNameBinders g) => GHasNameBinders (f :*: g) where   ggetNameBindersRaw (x :*: y) = ggetNameBindersRaw x <> ggetNameBindersRaw y   greallyUnsafeSetNameBindersRaw (x :*: y) names =

@@ -77,6 +77,20 @@       :$$: 'Text "  " :<>: ShowKindedScope oo n ll       :$$: ShowLocalizeError msg icon ifield pattern oo ll       )+  GInnerScopeOfAtom msg icon ifield pattern (Kon f :@: (i :: Atom d s)) oo n ll =+    TypeError+      ('Text "A field of the binder/pattern is indexed by a Foil scope"+      :$$: 'Text "  " :<>: 'ShowType f :<>: 'Text " " :<>: ShowKindedScope oo i ll+      :$$: 'Text "A field like this is a payload and not a binder: it does not extend"+      :$$: 'Text "the scope, it lives in one. The generic implementation of withPattern"+      :$$: 'Text "cannot rebuild it, because it replaces the binders and leaves every"+      :$$: 'Text "other field as it stands, so a payload naming one of the pattern's own"+      :$$: 'Text "binders would keep the name that binder had before it was refreshed."+      :$$: 'Text "Write the CoSinkable instance by hand for this type, threading a"+      :$$: 'Text "PatternTransport through withPattern; see the recipe in the"+      :$$: 'Text "documentation of Control.Monad.Foil.transportPayload."+      :$$: ShowLocalizeError msg icon ifield pattern oo ll+      )   GInnerScopeOfAtom msg icon ifield pattern atom oo n ll = n  type SameInnerScope :: ErrorMessage -> Nat -> (s -> s -> Type) -> Atom k s -> Atom k s -> Atom k s

@@ -0,0 +1,229 @@+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Deterministic stripe assignment for separately checked units.+--+-- Each unit of a module system allocates its top-level names inside its own+-- reservation (see "Control.Monad.Foil.Blocks"), and the assignment of+-- reservations has to be /deterministic/: a unit's declarations are numbered+-- @base@, @base + 1@, and so on in declaration order, whatever else is+-- checked around it. Determinism is what makes raw names cacheable, since a+-- unit checked today and a unit loaded tomorrow then agree name for name. It+-- is also what discharges the trust obligation of+-- 'Control.Monad.Foil.Blocks.checkExtScope'.+--+-- The registry is that assignment: an append-only map from unit names to+-- stripe indices, handing out the next index on first use. A build persists+-- it beside the build products, since a cached artifact survives a change+-- elsewhere in the build exactly when the assignment does not move.+--+-- Where the stripes lie on the raw-name line is a 'StripeLayout' and a+-- policy of the client. The library is region-agnostic, and the allocator+-- admits negative names.+module Control.Monad.Foil.Registry (+  -- * Stripe indices+  StripeIndex (..),+  -- * Layouts+  StripeSize (..),+  StripeLayout (..),+  stripesBelowZero,+  stripesAbove,+  -- * Local-region layouts+  RegionWidth (..),+  RegionsPerUnit (..),+  RegionLayout (..),+  regionsAbove,+  -- * The registry+  Registry,+  emptyRegistry,+  registrySize,+  registerUnit,+) where++import           Data.Binary                 (Binary)+import           Data.Map                    (Map)+import qualified Data.Map                    as Map++import           Control.Monad.Foil.Internal (NameRange (..), RawName)++-- $setup+-- >>> import Control.Monad.Foil.Internal++-- | A stripe's position in the registry: which run of names a unit draws+-- from. Its own type, so that a stripe index cannot be confused with a name,+-- a count, or an offset.+--+-- @since 0.4.0+newtype StripeIndex = StripeIndex Int+  deriving newtype (Eq, Ord, Show, Read, Binary)++-- | How many names a unit may declare: the width of every stripe a layout+-- hands out. Its own type, so that a size cannot be confused with a name, an+-- index, or a base.+--+-- @since 0.4.0+newtype StripeSize = StripeSize Int+  deriving newtype (Eq, Ord, Show, Read)++-- | Where stripe @i@ lies on the raw-name line.+--+-- The library does not choose: whether stripes descend below zero, ascend+-- from some base, or interleave with other reservations is a policy of the+-- client, and everything in "Control.Monad.Foil.Blocks" works from the+-- resulting 'NameRange's alone. A layout should give disjoint ranges to+-- distinct indices. Nothing checks this here, but+-- 'Control.Monad.Foil.Blocks.withDisjointUnion' refuses the overlap at the+-- point where it would do harm.+--+-- @since 0.4.0+newtype StripeLayout = StripeLayout+  { stripeRange :: StripeIndex -> NameRange+  }++-- | Stripe @i@ is the @i@-th run of @size@ names below zero, counting+-- downwards, so stripe 0 is @[-size .. -1]@. Within a stripe, allocation+-- still ascends (see 'Control.Monad.Foil.withFreshIn'), so declaration order+-- is ascending name order.+--+-- This layout leaves the whole non-negative range free for a client's local+-- names.+--+-- >>> stripeRange (stripesBelowZero (StripeSize 100)) (StripeIndex 0)+-- NameRange {nameRangeLo = -100, nameRangeHi = -1}+-- >>> stripeRange (stripesBelowZero (StripeSize 100)) (StripeIndex 2)+-- NameRange {nameRangeLo = -300, nameRangeHi = -201}+--+-- @since 0.4.0+stripesBelowZero :: StripeSize -> StripeLayout+stripesBelowZero (StripeSize size) = StripeLayout $ \(StripeIndex i) ->+  let hi = negate (i * size) - 1+   in NameRange (hi - size + 1) hi++-- | Stripe @i@ is the @i@-th run of @size@ names at or above a base,+-- counting upwards, so stripe 0 is @[base .. base + size - 1]@.+--+-- >>> stripeRange (stripesAbove 0 (StripeSize 100)) (StripeIndex 1)+-- NameRange {nameRangeLo = 100, nameRangeHi = 199}+--+-- @since 0.4.0+stripesAbove+  :: RawName     -- ^ The base: the low end of stripe 0.+  -> StripeSize+  -> StripeLayout+stripesAbove base (StripeSize size) = StripeLayout $ \(StripeIndex i) ->+  let lo = base + i * size+   in NameRange lo (lo + size - 1)++-- | Which stripe each unit's declarations live in, by the unit's name.+--+-- Append-only: a name, once registered, keeps its stripe for the lifetime of+-- the registry, and the next stripe index is always the registry's size.+--+-- @since 0.4.0+type Registry name = Map name StripeIndex++-- | The registry before any unit has ever been checked.+--+-- @since 0.4.0+emptyRegistry :: Registry name+emptyRegistry = Map.empty++-- | How many units have been registered, which is also the next free stripe.+--+-- @since 0.4.0+registrySize :: Registry name -> Int+registrySize = Map.size++-- | The stripe index of a unit, assigning the next one on first use.+--+-- Registration hands out the index and not a range. A unit's index+-- determines /every/ reservation derived for it: its stripe under a+-- 'StripeLayout', and its runs of local names under a 'RegionLayout'. The+-- layouts interpret the index, rather than being consulted here.+--+-- >>> let layout = stripesBelowZero (StripeSize 10)+-- >>> let (r1, iA) = registerUnit "A" emptyRegistry+-- >>> stripeRange layout iA+-- NameRange {nameRangeLo = -10, nameRangeHi = -1}+-- >>> stripeRange layout (snd (registerUnit "B" r1))+-- NameRange {nameRangeLo = -20, nameRangeHi = -11}+--+-- Registration is idempotent, which is the determinism a cache rests on:+--+-- >>> snd (registerUnit "A" r1) == iA+-- True+--+-- @since 0.4.0+registerUnit+  :: Ord name+  => name -> Registry name -> (Registry name, StripeIndex)+registerUnit name registry = case Map.lookup name registry of+  Just i  -> (registry, i)+  Nothing ->+    let i = StripeIndex (Map.size registry)+     in (Map.insert name i registry, i)++-- * Local-region layouts++-- | How far apart consecutive local-region floors sit within a unit's runs.+-- This is spacing, not a hard width: a run is open-ended above its floor,+-- and a scope-driven allocator would have to hold this many names /in scope+-- at once/ to reach the next floor.+--+-- @since 0.4.0+newtype RegionWidth = RegionWidth Int+  deriving newtype (Eq, Ord, Show, Read)++-- | How many runs of local names a unit may hold before its runs would+-- spill into the next unit's. A spill is not unsound for a client that+-- refreshes on clash. It only forfeits the disjointness described under+-- 'RegionLayout' for the runs past the cap.+--+-- @since 0.4.0+newtype RegionsPerUnit = RegionsPerUnit Int+  deriving newtype (Eq, Ord, Show, Read)++-- | Where a unit's runs of /local/ names lie: one open-ended region per+-- declaration (or command) of the unit, advanced with 'nextRegion' as the+-- unit's declarations are processed.+--+-- Stripes make a unit's top-level names disjoint from every other unit's,+-- and runs of local regions do the same for the names a checker invents+-- /inside/ a declaration. A term stored under one declaration then never+-- collides with another declaration's live locals when it is reopened, so a+-- refreshing substitution takes its no-rename fast path throughout.+--+-- The first run is derived from the unit's stripe index rather than from a+-- counter shared across units, so a unit's elaboration depends only on the+-- unit itself and editing a neighbour moves no name. That is the+-- determinism a cache rests on.+--+-- The trade-off is that local names carry large offsets. A client that+-- shows raw indices directly may prefer a single flat region, and accept+-- the transient renames instead.+--+-- @since 0.4.0+data RegionLayout = RegionLayout+  { firstRegionOf :: StripeIndex -> NameRange+    -- ^ The run of the unit's first declaration.+  , nextRegion    :: NameRange -> NameRange+    -- ^ The next declaration's run.+  }++-- | Runs ascending from a base: the unit with stripe index @i@ starts its+-- runs at @base + i * perUnit * width@, and each declaration's floor sits+-- @width@ above the previous one. The top of every run is open.+--+-- >>> let locals = regionsAbove 0 (RegionsPerUnit 0x10) (RegionWidth 0x100)+-- >>> nameRangeLo (firstRegionOf locals (StripeIndex 2))+-- 8192+-- >>> nameRangeLo (nextRegion locals (firstRegionOf locals (StripeIndex 2)))+-- 8448+--+-- @since 0.4.0+regionsAbove :: RawName -> RegionsPerUnit -> RegionWidth -> RegionLayout+regionsAbove base (RegionsPerUnit perUnit) (RegionWidth w) = RegionLayout+  { firstRegionOf = \(StripeIndex i) ->+      NameRange (base + i * perUnit * w) maxBound+  , nextRegion = \(NameRange lo _) -> NameRange (lo + w) maxBound+  }

@@ -7,8 +7,12 @@ import           Data.Kind          (Type)  -- | Relative monads, restricted to types indexed by scopes in kind 'S'.+--+-- @since 0.0.1 class RelMonad (f :: S -> Type) (m :: S -> Type) where   -- | Relative version of 'return'.+  --+  -- @since 0.0.1   rreturn :: f a -> m a    -- | Relative version of '>>='.@@ -21,8 +25,12 @@   -- Technically, it is also possible add similar components for @a@ parameter.   -- Also, we could probably treat types in 'S' as singletons and extract distinct scopes that way,   -- preserving the more general type signature for 'rbind'.+  --+  -- @since 0.0.1   rbind :: Distinct b => Scope b -> m a -> (f a -> m b) -> m b --- | Relative version of 'liftM' (an 'fmap' restricted to 'Monad').+-- | Relative version of @liftM@ (an 'fmap' restricted to 'Monad').+--+-- @since 0.0.3 liftRM :: (RelMonad f m, Distinct b) => Scope b -> (f a -> f b) -> m a -> m b liftRM scope f m = rbind scope m (rreturn . f)

@@ -12,6 +12,8 @@ import Control.Monad.Foil.TH.Util  -- | Generate scope-safe variants given names of types for the raw representation.+--+-- @since 0.0.1 mkFoilData   :: Name -- ^ Type name for raw terms.   -> Name -- ^ Type name for raw variable identifiers.@@ -68,6 +70,8 @@         toTermParam _bangType = _bangType  -- | Generate just the scope-safe patterns.+--+-- @since 0.1.0 mkFoilPattern   :: Name -- ^ Type name for raw variable identifiers.   -> Name -- ^ Type name for raw patterns.

@@ -13,6 +13,8 @@ import Control.Monad.Foil.TH.Util  -- | Generate conversion functions from raw to scope-safe representation.+--+-- @since 0.0.1 mkFromFoil   :: Name -- ^ Type name for raw terms.   -> Name -- ^ Type name for raw variable identifiers.@@ -232,6 +234,8 @@         toMatch RecGadtC{} = error "Record GADT constructors (RecGadtC) are not supported yet!"  -- | Generate conversion function from raw to scope-safe pattern.+--+-- @since 0.1.0 mkFromFoilPattern   :: Name -- ^ Type name for raw variable identifiers.   -> Name -- ^ Type name for raw patterns.

@@ -12,6 +12,8 @@ import           Data.List                  (nub)  -- | Generate 'Foil.Sinkable' and 'Foil.CoSinkable' instances.+--+-- @since 0.0.1 mkInstancesFoil   :: Name -- ^ Type name for raw terms.   -> Name -- ^ Type name for raw variable identifiers.@@ -79,6 +81,8 @@             xi = mkName ("x" ++ show i)  -- | Generate 'Foil.Sinkable' and 'Foil.CoSinkable' instances.+--+-- @since 0.1.0 deriveCoSinkable   :: Name -- ^ Type name for raw variable identifiers.   -> Name -- ^ Type name for raw patterns.@@ -150,19 +154,18 @@         conParamPatterns = zipWith mkConParamPattern params [1..]         mkConParamPattern _ i = VarP (mkName ("x" ++ show i)) -        go _i _scope' rename' p [] = AppE (AppE (VarE cont) rename') p+        go _i scope' rename' p [] = AppE (AppE (AppE (VarE cont) rename') p) (VarE scope')         go i scope' rename' p ((_bang, PeelConT tyName _tyParams) : conParams)           | tyName == nameT || tyName == patternT =               AppE                 (foldl AppE (VarE 'Foil.withPattern) [VarE withNameBinder, VarE id', VarE comp, VarE scope', VarE xi])-                (LamE [VarP renamei, VarP xi']-                  (LetE [ValD (VarP scopei) (NormalB (AppE (AppE (VarE 'Foil.extendScopePattern) (VarE xi')) (VarE scope'))) []]-                    (go (i + 1) scopei (foldl AppE (VarE comp) [rename', VarE renamei]) (AppE p (VarE xi')) conParams)))+                (LamE [VarP renamei, VarP xi', VarP scopei]+                  (go (i + 1) scopei (foldl AppE (VarE comp) [rename', VarE renamei]) (AppE p (VarE xi')) conParams))           where             xi = mkName ("x" ++ show i)             xi' = mkName ("x" ++ show i ++ "'")             renamei = mkName ("f" ++ show i)-            scopei = mkName ("_scope" ++ show i)+            scopei = mkName ("scope" ++ show i)         go i scope' rename' p (_ : conPatterns) =           go (i + 1) scope' rename' (AppE p (VarE xi)) conPatterns           where@@ -171,7 +174,9 @@ -- | Generate a structural 'Foil.UnifiablePattern' instance, comparing -- constructors and non-binding fields rather than only the binders. ----- This deriver does not work and has no call sites; see the deprecation note.+-- This deriver does not work and has no call sites. See the deprecation note.+--+-- @since 0.1.0 deriveUnifiablePattern   :: Name -- ^ Type name for raw variable identifiers.   -> Name -- ^ Type name for raw patterns.

@@ -16,6 +16,8 @@ import Control.Monad.Foil.TH.Util  -- | Generate conversion functions from raw to scope-safe representation.+--+-- @since 0.0.1 mkToFoil   :: Name -- ^ Type name for raw terms.   -> Name -- ^ Type name for raw variable identifiers.@@ -33,6 +35,8 @@     )  -- | Generate a function to extend scope with variables from a given pattern.+--+-- @since 0.0.1 mkExtendScopeFoilPattern   :: Name -- ^ Type name for raw variable identifiers.   -> Name -- ^ Type name for raw patterns.@@ -99,6 +103,8 @@         toMatch RecGadtC{} = error "Record GADT constructors (RecGadtC) are not supported yet!"  -- | Generate a function to extend scope with variables from a given pattern.+--+-- @since 0.0.1 mkWithRefreshedFoilPattern   :: Name -- ^ Type name for raw variable identifiers.   -> Name -- ^ Type name for raw patterns.@@ -221,6 +227,8 @@         toMatch RecGadtC{} = error "Record GADT constructors (RecGadtC) are not supported yet!"  -- | Generate a conversion function from raw terms to scope-safe terms.+--+-- @since 0.0.1 mkToFoilTerm   :: Name -- ^ Type name for raw terms.   -> Name -- ^ Type name for raw variable identifiers.@@ -462,6 +470,8 @@         toMatch RecGadtC{} = error "Record GADT constructors (RecGadtC) are not supported yet!"  -- | Generate a conversion function from raw terms to scope-safe terms.+--+-- @since 0.1.0 mkToFoilPattern   :: Name -- ^ Type name for raw variable identifiers.   -> Name -- ^ Type name for raw patterns.

@@ -0,0 +1,254 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE InstanceSigs        #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | The labelled telescope: a chain of binders, each carrying a label and a+-- payload in the scope before it.+--+-- This is the pattern behind a module's parameter block, a record signature,+-- or an algebraic theory: @(A : 𝕌) (m : A → A → A)@ is a two-step+-- telescope whose second payload mentions the first binder. Because a+-- telescope is a pattern ('CoSinkable', 'UnifiablePattern'), scope extension,+-- the names of a block, and α-equivalence of blocks come from the pattern+-- machinery, with the payloads compared through 'AlphaEquiv'.+--+-- What this module does not fix is what a payload /is/. The payload type is a+-- parameter, and the operations that need to look inside one, such as the+-- support a dependency closure needs, take the looking function as an+-- argument. A client instantiates the labels and payloads to its own types.+-- To close a declaration over the fields it uses, apply 'closeOverTelescope'+-- and then 'withThinnedNameBinderList'.+module Control.Monad.Foil.Telescope where++import           Control.Monad.Foil.Internal+import           Control.Monad.Foil.Relative (RelMonad, liftRM)++-- | A labelled telescope: a chain of binders, each carrying a label and a+-- payload in the scope before it.+--+-- The payload of a step lives in the scope the steps before it extend to, which+-- is what makes this a telescope rather than a list. For a module's parameters+-- the label is how the parameter is spelled and the payload is its type, so+-- that @(A : 𝕌) (m : A → A → A)@ is a two-step telescope whose second payload+-- mentions the first binder.+--+-- See 'NameBinderList', which this follows almost line for line.+--+-- @since 0.4.0+data Telescope label e n l where+  TelescopeEmpty :: Telescope label e n n+  TelescopeCons+    :: label                        -- ^ How the step is labelled.+    -> e n                          -- ^ Its payload, in the scope before it.+    -> NameBinder n i          -- ^ The binder it introduces.+    -> Telescope label e i l        -- ^ The steps after it.+    -> Telescope label e n l++-- | A telescope is a pattern, so the foil's own machinery walks it.+--+-- 'coSinkabilityProof' typechecks only because a payload is sunk by the+-- renaming of the scope /before/ its binder, rather than by the extended one.+--+-- 'withPattern' has to be written out rather than derived. The generic+-- implementation refuses a pattern with a field indexed by a scope, since it+-- would leave a payload that names a refreshed binder pointing at the name+-- that binder used to have. This instance follows the recipe in+-- 'transportPayload': a 'PatternTransport' threaded through the traversal,+-- with each payload moved by the transport accumulated /before/ its own+-- binder, that being the scope the payload lives in.+instance Sinkable e => CoSinkable (Telescope label e) where+  coSinkabilityProof rename TelescopeEmpty cont = cont rename TelescopeEmpty+  coSinkabilityProof rename (TelescopeCons label payload binder rest) cont =+    coSinkabilityProof rename binder $ \rename' binder' ->+      coSinkabilityProof rename' rest $ \rename'' rest' ->+        cont rename''+          (TelescopeCons label (sinkabilityProof rename payload) binder' rest')++  withPattern+    :: forall f o n l r. Distinct o+    => (forall x y z r'. Distinct z+          => Scope z+          -> NameBinder x y+          -> (forall z'. DExt z z' => f x y z z' -> NameBinder z z' -> r')+          -> r')+    -> (forall x z z'. DExt z z' => f x x z z')+    -> (forall x y y' z z' z''. (DExt z z', DExt z' z'')+          => f x y z z' -> f y y' z' z'' -> f x y' z z'')+    -> Scope o+    -> Telescope label e n l+    -> (forall o'. DExt o o' => f n l o o' -> Telescope label e o o' -> Scope o' -> r)+    -> r+  withPattern withBinder unit comp = go verbatimTransport+    where+      go :: forall n' l' o' r'. Distinct o'+         => PatternTransport n' o'+         -> Scope o'+         -> Telescope label e n' l'+         -> (forall o''. DExt o' o''+               => f n' l' o' o'' -> Telescope label e o' o'' -> Scope o'' -> r')+         -> r'+      go _transport scope TelescopeEmpty cont = cont unit TelescopeEmpty scope+      go transport scope (TelescopeCons label payload binder rest) cont =+        withBinder scope binder $ \fbinder binder' ->+          go (transportUnderBinder transport binder binder')+             (extendScope binder' scope)+             rest $ \frest rest' scope'' ->+            cont (comp fbinder frest)+              (TelescopeCons label (transportPayload transport payload) binder' rest')+              scope''++-- | Two telescopes unify when their binders line up and their payloads agree.+--+-- Labels are ignored, which is what α-equivalence should do with a label: a+-- parameter's spelling is no more relevant than a bound variable's. Payloads+-- are not, since two telescopes agreeing on binders may well disagree on types.+--+-- 'unifyPatterns' is the binder-only approximation, which is all a caller+-- without a scope can be given. 'unifyPatternsIn' is the real answer, and+-- it is what the library's α-equivalence calls.+instance (Sinkable e, AlphaEquiv e, RelMonad Name e)+    => UnifiablePattern (Telescope label e) where+  unifyPatterns TelescopeEmpty TelescopeEmpty =+    SameNameBinders emptyNameBinders+  unifyPatterns (TelescopeCons _ _ x xs) (TelescopeCons _ _ y ys) =+    case (assertDistinct x, assertDistinct y) of+      (Distinct, Distinct) ->+        unifyNameBinders x y `andThenUnifyPatterns` (xs, ys)+  -- Telescopes of different lengths bind different numbers of names.+  unifyPatterns _ _ = NotUnifiable++  unifyPatternsIn scope tele1 tele2+    | payloadsAgree scope tele1 tele2 verdict = verdict+    | otherwise                               = NotUnifiable+    where+      verdict = unifyPatterns tele1 tele2++-- | The payloads of a telescope, each moved into its innermost scope.+--+-- Sinking is free, so putting them all in one scope costs nothing and lets a+-- renaming be applied to the whole block at once.+--+-- @since 0.4.0+telescopePayloads+  :: (Sinkable e, Distinct l) => Telescope label e n l -> [e l]+telescopePayloads = map paramType . telescopeParams++-- | Do the payloads of two telescopes agree, under the way their binders were+-- unified?+--+-- The verdict speaks about binders only, so the renaming it prescribes has to+-- be applied before the payloads are compared, which is exactly what+-- 'Control.Monad.Free.alphaEquivScoped' does to the body of a scoped term.+-- Comparing them as they stand would report @(A : 𝕌) (x : A)@ and+-- @(B : 𝕌) (y : B)@ as different, since the second payloads name different+-- binders until the first ones have been identified.+--+-- @since 0.4.0+payloadsAgree+  :: forall label e n l r.+     (Sinkable e, AlphaEquiv e, RelMonad Name e, Distinct n)+  => Scope n+  -> Telescope label e n l+  -> Telescope label e n r+  -> UnifyNameBinders (Telescope label e) n l r+  -> Bool+payloadsAgree scope tele1 tele2 verdict =+  case (assertDistinct tele1, assertDistinct tele2) of+    (Distinct, Distinct) ->+      let payloads1 = telescopePayloads tele1+          payloads2 = telescopePayloads tele2+       in case verdict of+            NotUnifiable -> False+            -- The binders are the same, so the payloads already compare.+            SameNameBinders{} ->+              agree (extendScopePattern tele1 scope) payloads1 payloads2+            -- The left telescope's binders become the right's, so its payloads+            -- have to follow them before they can be compared.+            RenameLeftNameBinder _ renameL ->+              let scope' = extendScopePattern tele2 scope+               in agree scope' (map (rename scope' renameL) payloads1) payloads2+            RenameRightNameBinder _ renameR ->+              let scope' = extendScopePattern tele1 scope+               in agree scope' payloads1 (map (rename scope' renameR) payloads2)+            -- Neither side's binders survive, so both blocks move to the+            -- unified ones.+            RenameBothBinders binders renameL renameR ->+              case assertDistinct binders of+                Distinct ->+                  let scope' = extendScopePattern binders scope+                   in agree scope' (map (rename scope' renameL) payloads1)+                                   (map (rename scope' renameR) payloads2)+  where+    -- Lengths cannot disagree here: a verdict other than 'NotUnifiable'+    -- says the two telescopes bind the same number of names.+    agree :: forall m. Distinct m => Scope m -> [e m] -> [e m] -> Bool+    agree scope' xs ys = and (zipWith (alphaEquivIn scope') xs ys)++    rename+      :: forall i m. Distinct m+      => Scope m -> (NameBinder n i -> NameBinder n m) -> e i -> e m+    rename scope' f = liftRM scope' (fromNameBinderRenaming f)++-- | One step of a telescope, with everything about it moved into the innermost+-- scope.+--+-- Sinking is free, so this is the convenient form for anything that has to+-- compare parameters with the names of a term checked under all of them.+--+-- @since 0.4.0+data Param label e l = Param+  { paramLabel :: label+  , paramName  :: Name l+  , paramType  :: e l+  }++-- | The steps of a telescope, outermost first.+--+-- @since 0.4.0+telescopeParams+  :: (Sinkable e, Distinct l)+  => Telescope label e n l -> [Param label e l]+telescopeParams TelescopeEmpty = []+telescopeParams (TelescopeCons label ty binder rest) =+  case (assertExt binder, assertExt rest) of+    (Ext, Ext) ->+      Param label (sink (nameOf binder)) (sink ty)+        : telescopeParams rest++-- | The chain of binders a telescope forms.+--+-- This is 'nameBinderListOf' at a telescope, written out. The general one+-- goes through 'withPattern' and so rebuilds the telescope only to throw it+-- away, which is worth avoiding on the checking path.+--+-- @since 0.4.0+telescopeBinders :: Telescope label e n l -> NameBinderList n l+telescopeBinders TelescopeEmpty = NameBinderListEmpty+telescopeBinders (TelescopeCons _ _ binder rest) =+  NameBinderListCons binder (telescopeBinders rest)++-- | Close a set of parameters under the parameters their payloads need.+--+-- Keeping a parameter puts its payload into the result, so whatever that+-- payload mentions has to be kept too. A payload mentions only the parameters+-- before it, so working from the inside out settles it in one pass.+--+-- The support of a payload is the caller's to supply, since the library does+-- not know what a payload is. For terms of the free foil it is+-- 'Control.Monad.Free.Foil.supportOf'.+--+-- @since 0.4.0+closeOverTelescope+  :: Distinct l+  => (e l -> NameSet l)  -- ^ The support of a payload.+  -> [Param label e l] -> NameSet l -> NameSet l+closeOverTelescope supportOfPayload params wanted = foldr close wanted params+  where+    close p keep+      | nameSetMember (paramName p) keep = keep <> supportOfPayload (paramType p)+      | otherwise                        = keep+

@@ -2,6 +2,9 @@ {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE TypeFamilies         #-} {-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveFoldable        #-}+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE DeriveTraversable     #-} {-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-}@@ -31,13 +34,16 @@ import qualified Generics.Kind as Kind import Generics.Kind (GenericK(..), Field, Exists, Var0, Var1, (:$:), Atom((:@:), Kon), (:+:), (:*:)) import           Data.Coerce                 (coerce)+import           Data.IntMap.Strict          (IntMap)+import qualified Data.IntMap.Strict          as IntMap import           Data.Map                    (Map) import qualified Data.Map                    as Map-import           Data.Maybe                  (mapMaybe) import           GHC.Generics                (Generic) import           Unsafe.Coerce               (unsafeCoerce)  -- | Scoped term under a (single) name binder.+--+-- @since 0.0.1 data ScopedAST binder sig n where   ScopedAST :: binder n l -> AST binder sig l -> ScopedAST binder sig n @@ -46,9 +52,11 @@  -- | A term, generated by a signature 'Bifunctor' @sig@, -- with (free) variables in scope @n@.+--+-- @since 0.0.1 data AST binder sig n where   -- | A (free) variable in scope @n@.-  Var :: Foil.Name n -> AST binder sig n+  Var :: {-# UNPACK #-} !(Foil.Name n) -> AST binder sig n   -- | A non-variable syntactic construction specified by the signature 'Bifunctor' @sig@.   Node :: sig (ScopedAST binder sig n) (AST binder sig n) -> AST binder sig n @@ -82,6 +90,8 @@ -- * Substitution  -- | Substitution for free (scoped monads).+--+-- @since 0.0.1 {-# INLINABLE substitute #-} substitute   :: (Bifunctor sig, Foil.Distinct o, Foil.CoSinkable binder, Foil.SinkableK binder)@@ -89,14 +99,27 @@   -> Foil.Substitution (AST binder sig) i o   -> AST binder sig i   -> AST binder sig o-substitute scope subst = \case-  Var name -> Foil.lookupSubst subst name-  Node node -> Node (bimap f (substitute scope subst) node)+substitute scope subst term+  -- An empty substitution maps every name to itself ('addRename' deletes+  -- identity renames), so the result is the very term, and the coercion is+  -- the one 'Foil.sink' performs. Substitutions go empty often: opening a+  -- scoped term with its own binder's name is an identity rename, and under+  -- a deterministic allocation policy a refreshed binder usually keeps its+  -- name, deleting its entry. Binders that shadow the ambient scope are+  -- left as they stand, as on the no-clash path below. A caller that wants+  -- them refreshed asks 'substituteRefreshed'.+  | Foil.nullSubst subst = unsafeCoerce term+  | otherwise = go term   where+    -- The substitution is known non-empty here, and it can only change+    -- under a binder, so the walk between binders is unchecked and each+    -- binder entry re-enters 'substitute', testing emptiness exactly once.+    go = \case+      Var name -> Foil.lookupSubst subst name+      Node node -> Node (bimap f go node)     f (ScopedAST binder body) =-      Foil.withRefreshedPattern scope binder $ \extendSubst binder' ->+      Foil.withRefreshedPattern scope binder $ \extendSubst binder' scope' ->         let subst' = extendSubst (Foil.sink subst)-            scope' = Foil.extendScopePattern binder' scope             body' = substitute scope' subst' body         in ScopedAST binder' body' @@ -108,6 +131,8 @@ -- > substituteRefreshed scope subst = refreshAST scope . subtitute scope subst -- -- In general, 'substitute' is more efficient since it does not always refresh binders.+--+-- @since 0.0.3 {-# INLINABLE substituteRefreshed #-} substituteRefreshed   :: (Bifunctor sig, Foil.Distinct o, Foil.CoSinkable binder, Foil.SinkableK binder)@@ -120,9 +145,8 @@   Node node -> Node (bimap f (substituteRefreshed scope subst) node)   where     f (ScopedAST binder body) =-      Foil.withFreshPattern scope binder $ \extendSubst binder' ->+      Foil.withFreshPattern scope binder $ \extendSubst binder' scope' ->         let subst' = extendSubst (Foil.sink subst)-            scope' = Foil.extendScopePattern binder' scope             body' = substituteRefreshed scope' subst' body         in ScopedAST binder' body' @@ -137,12 +161,13 @@     where       g x = Foil.rbind scope x subst       g' (ScopedAST binder body) =-        Foil.withRefreshedPattern' scope binder $ \extendSubst binder' ->-          let scope' = Foil.extendScopePattern binder' scope-              subst' = extendSubst subst+        Foil.withRefreshedPattern' scope binder $ \extendSubst binder' scope' ->+          let subst' = extendSubst subst            in ScopedAST binder' (Foil.rbind scope' body subst')  -- | Substitution for a single generalized pattern.+--+-- @since 0.2.0 substitutePattern   :: (Bifunctor sig, Foil.Distinct o, Foil.CoSinkable binder', Foil.CoSinkable binder, Foil.SinkableK binder)   => Foil.Scope o                           -- ^ Resulting scope.@@ -159,6 +184,8 @@ -- * \(\alpha\)-equivalence  -- | Refresh (force) all binders in a term, minimizing the used indices.+--+-- @since 0.0.3 {-# INLINABLE refreshAST #-} refreshAST   :: (Bifunctor sig, Foil.Distinct n, Foil.CoSinkable binder, Foil.SinkableK binder)@@ -170,22 +197,26 @@   Node t -> Node (bimap (refreshScopedAST scope) (refreshAST scope) t)  -- | Similar to `refreshAST`, but for scoped terms.+--+-- @since 0.0.3 {-# INLINABLE refreshScopedAST #-} refreshScopedAST :: (Bifunctor sig, Foil.Distinct n, Foil.CoSinkable binder, Foil.SinkableK binder)   => Foil.Scope n   -> ScopedAST binder sig n   -> ScopedAST binder sig n refreshScopedAST scope (ScopedAST binder body) =-  Foil.withFreshPattern scope binder $ \extendSubst binder' ->-    let scope' = Foil.extendScopePattern binder' scope-        subst = extendSubst (Foil.sink Foil.identitySubst)+  Foil.withFreshPattern scope binder $ \extendSubst binder' scope' ->+    let subst = extendSubst (Foil.sink Foil.identitySubst)     in ScopedAST binder' (substituteRefreshed scope' subst body)  -- | \(\alpha\)-equivalence check for two terms in one scope -- via normalization of bound identifiers (via 'refreshAST'). ----- Compared to 'alphaEquiv', this function may perform some unnecessary--- changes of bound variables when the binders are the same on both sides.+-- Compared to 'alphaEquiv', this function renames every binder on both sides+-- unconditionally, so it does strictly more work. It remains as an+-- independent implementation of the same test.+--+-- @since 0.0.3 {-# INLINABLE alphaEquivRefreshed #-} alphaEquivRefreshed   :: (Bitraversable sig, ZipMatchK sig, Foil.Distinct n, Foil.UnifiablePattern binder, Foil.SinkableK binder)@@ -195,11 +226,23 @@   -> Bool alphaEquivRefreshed scope t1 t2 = refreshAST scope t1 `unsafeEqAST` refreshAST scope t2 +-- | A term is a scope-indexed value that can be compared up to α, which is what+-- a pattern carrying terms as payloads needs of them.+instance (Bitraversable sig, ZipMatchK sig, Foil.UnifiablePattern binder, Foil.SinkableK binder)+    => Foil.AlphaEquiv (AST binder sig) where+  alphaEquivIn = alphaEquiv+ -- | \(\alpha\)-equivalence check for two terms in one scope -- via unification of bound variables (via 'unifyNameBinders'). ----- Compared to 'alphaEquivRefreshed', this function might skip unnecessary--- changes of bound variables when both binders in two matching scoped terms coincide.+-- When two matching binders coincide, comparison continues with no work at+-- all. When they differ, the prescribed renaming is /threaded down the+-- recursion/ (see 'alphaEquivEnv') and consulted at variables only, so+-- nothing is ever copied. Applying the renaming eagerly instead would+-- materialise a renamed copy of the remaining body at every mismatched+-- binder, which is quadratic on a chain of them.+--+-- @since 0.0.3 {-# INLINABLE alphaEquiv #-} alphaEquiv   :: (Bitraversable sig, ZipMatchK sig, Foil.Distinct n, Foil.UnifiablePattern binder, Foil.SinkableK binder)@@ -217,9 +260,15 @@ alphaEquiv _ _ _ = False  -- | Same as 'alphaEquiv' but for scoped terms.+--+-- While the binders of the two sides coincide, this runs with no renaming+-- state at all. The first pair that differs switches to 'alphaEquivEnv',+-- which threads the renamings down and switches back when they empty out.+--+-- @since 0.0.3 {-# INLINABLE alphaEquivScoped #-} alphaEquivScoped-  :: (Bitraversable sig, ZipMatchK sig, Foil.Distinct n, Foil.UnifiablePattern binder, Foil.SinkableK binder)+  :: forall sig binder n. (Bitraversable sig, ZipMatchK sig, Foil.Distinct n, Foil.UnifiablePattern binder, Foil.SinkableK binder)   => Foil.Scope n   -> ScopedAST binder sig n   -> ScopedAST binder sig n@@ -227,42 +276,208 @@ alphaEquivScoped scope   (ScopedAST binder1 body1)   (ScopedAST binder2 body2) =-    case Foil.unifyPatterns binder1 binder2 of-      -- if binders are the same, then we can safely compare bodies+    case Foil.unifyPatternsIn scope binder1 binder2 of+      -- the binders coincide: compare the bodies as they stand       Foil.SameNameBinders{} ->  -- after seeing this we know that body scopes are the same         case Foil.assertDistinct binder1 of           Foil.Distinct ->             let scope1 = Foil.extendScopePattern binder1 scope             in alphaEquiv scope1 body1 body2-      -- if we can safely rename first binder into second+      -- the left binder is renamed towards the right one       Foil.RenameLeftNameBinder _ rename1to2 ->         case Foil.assertDistinct binder2 of           Foil.Distinct ->             let scope2 = Foil.extendScopePattern binder2 scope-            in alphaEquiv scope2 (Foil.liftRM scope2 (Foil.fromNameBinderRenaming rename1to2) body1) body2-      -- if we can safely rename second binder into first+                pairs = [ (Foil.nameId x, renamedId rename1to2 x)+                        | x <- Foil.namesOfPattern binder1 ]+            in enterEnv pairs scope2 body1 body2+      -- the right binder is renamed towards the left one       Foil.RenameRightNameBinder _ rename2to1 ->         case Foil.assertDistinct binder1 of           Foil.Distinct ->             let scope1 = Foil.extendScopePattern binder1 scope-            in alphaEquiv scope1 body1 (Foil.liftRM scope1 (Foil.fromNameBinderRenaming rename2to1) body2)-      -- if we need to rename both patterns+                pairs = [ (renamedId rename2to1 y, Foil.nameId y)+                        | y <- Foil.namesOfPattern binder2 ]+            in enterEnv pairs scope1 body1 body2+      -- both are renamed towards a unified pattern: pair the two sides'+      -- names through the unified name each maps to       Foil.RenameBothBinders binder' rename1 rename2 ->         case Foil.assertDistinct binder' of           Foil.Distinct ->             let scope' = Foil.extendScopePattern binder' scope-            in alphaEquiv scope'-                (Foil.liftRM scope' (Foil.fromNameBinderRenaming rename1) body1)-                (Foil.liftRM scope' (Foil.fromNameBinderRenaming rename2) body2)+                leftU = IntMap.fromList+                  [ (renamedId rename1 x, Foil.nameId x)+                  | x <- Foil.namesOfPattern binder1 ]+                rightU = IntMap.fromList+                  [ (renamedId rename2 y, Foil.nameId y)+                  | y <- Foil.namesOfPattern binder2 ]+                pairs = IntMap.elems (IntMap.intersectionWith (,) leftU rightU)+            in enterEnv pairs scope' body1 body2       -- if we cannot unify patterns then scopes are not alpha-equivalent       Foil.NotUnifiable -> False+  where+    enterEnv+      :: forall m l1 l2. Foil.Distinct m+      => [(Int, Int)] -> Foil.Scope m+      -> AST binder sig l1 -> AST binder sig l2 -> Bool+    enterEnv pairs scope' = bindPairs 0 IntMap.empty IntMap.empty pairs scope' +-- | The raw name a verdict's renaming assigns to a pattern's name.+--+-- @since 0.4.0+renamedId :: (Foil.NameBinder n a -> Foil.NameBinder n b) -> Foil.Name a -> Int+renamedId rename = Foil.nameId . Foil.nameOf . rename . Foil.UnsafeNameBinder++-- | Bind the paired names of a binder pair. A pair whose names coincide+-- shadows both sides identically and is deleted from the environments. A pair+-- whose names differ binds both to one fresh level. Continues with+-- 'alphaEquivEnv' on the bodies.+--+-- @since 0.4.0+bindPairs+  :: forall sig binder m l1 l2. (Bitraversable sig, ZipMatchK sig, Foil.Distinct m, Foil.UnifiablePattern binder, Foil.SinkableK binder)+  => Int -> IntMap Int -> IntMap Int -> [(Int, Int)]+  -> Foil.Scope m+  -> AST binder sig l1 -> AST binder sig l2 -> Bool+bindPairs lvl envL envR pairs scope body1 body2 = case pairs of+  [] -> alphaEquivEnv lvl envL envR scope body1 body2+  ((x, y) : rest)+    | x == y    -> bindPairs lvl (IntMap.delete x envL) (IntMap.delete y envR) rest scope body1 body2+    | otherwise -> bindPairs (lvl + 1) (IntMap.insert x lvl envL) (IntMap.insert y lvl envR) rest scope body1 body2++-- | The renaming-threading worker behind 'alphaEquiv': compare two terms+-- under partial renamings of their names into shared /levels/.+--+-- Each environment maps a raw name to the level of the binder pair that bound+-- it on the comparison path, and a name outside its environment stands for+-- itself. A variable occurrence then compares as a level against a level, or+-- as a raw name against a raw name, and the two can never be conflated. This+-- is what makes threading sound where applying a raw renaming at the variables+-- would not be, since a renamed name could collide with one that passes+-- through unchanged and happens to share the target spelling. Levels are also+-- why no capture check is needed: a level is never a name, so there is nothing+-- for a binder to capture.+--+-- A binder pair whose names coincide /deletes/ those names from both+-- environments, the pair shadowing both sides identically. When the+-- environments empty out the comparison drops back to the stateless+-- 'alphaEquiv', so only the region of the terms below a mismatched binder,+-- and above the point where the mismatch is shadowed away, pays for the+-- threading at all.+--+-- The indices of the two terms are deliberately independent, in the style+-- of 'unsafeEqAST': the terms are never renamed into a common scope, so+-- no common index exists to give them.+--+-- @since 0.4.0+{-# INLINABLE alphaEquivEnv #-}+alphaEquivEnv+  :: forall sig binder n n1 n2. (Bitraversable sig, ZipMatchK sig, Foil.Distinct n, Foil.UnifiablePattern binder, Foil.SinkableK binder)+  => Int          -- ^ Next fresh level.+  -> IntMap Int   -- ^ Left renaming: raw name to the level that bound it.+  -> IntMap Int   -- ^ Right renaming.+  -> Foil.Scope n -- ^ Scope along the unified path (consulted by 'Foil.unifyPatternsIn').+  -> AST binder sig n1+  -> AST binder sig n2+  -> Bool+alphaEquivEnv lvl envL envR scope t1 t2+  | IntMap.null envL && IntMap.null envR =+      -- The renamings have emptied out (or never held anything): the+      -- terms coincide raw-for-raw from here on, so compare them where+      -- they stand. The coercion brings both indices to the scope's,+      -- which is the unified path the comparison speaks of.+      alphaEquiv scope (unsafeCoerce t1 :: AST binder sig n) (unsafeCoerce t2 :: AST binder sig n)+  | otherwise = case (t1, t2) of+      (Var x, Var y) ->+        case (IntMap.lookup (Foil.nameId x) envL, IntMap.lookup (Foil.nameId y) envR) of+          (Just k1, Just k2) -> k1 == k2+          (Nothing, Nothing) -> Foil.nameId x == Foil.nameId y+          _                  -> False+      (Node l, Node r) ->+        case zipMatchWith2+               (unit . alphaEquivScopedEnv lvl envL envR scope)+               (unit . alphaEquivEnv lvl envL envR scope) l r of+          Nothing -> False+          Just _  -> True+      _ -> False+  where+    unit f x = if f x then Just () else Nothing++-- | The scoped half of 'alphaEquivEnv': get the verdict from+-- 'Foil.unifyPatternsIn', extend the environments as it prescribes, and+-- recurse into the bodies as they stand.+--+-- @since 0.4.0+{-# INLINABLE alphaEquivScopedEnv #-}+alphaEquivScopedEnv+  :: forall sig binder n n1 n2. (Bitraversable sig, ZipMatchK sig, Foil.Distinct n, Foil.UnifiablePattern binder, Foil.SinkableK binder)+  => Int+  -> IntMap Int+  -> IntMap Int+  -> Foil.Scope n+  -> ScopedAST binder sig n1+  -> ScopedAST binder sig n2+  -> Bool+alphaEquivScopedEnv lvl envL envR scope scoped1 scoped2 =+  -- The scoped terms are compared where they stand; the coercion only+  -- brings their indices to the scope's, which is the unified path the+  -- environments and the verdicts speak of.+  case (unsafeCoerce scoped1 :: ScopedAST binder sig n, unsafeCoerce scoped2 :: ScopedAST binder sig n) of+    (ScopedAST binder1 body1, ScopedAST binder2 body2) ->+      case Foil.unifyPatternsIn scope binder1 binder2 of+        -- the binders coincide: the pair shadows both sides identically+        Foil.SameNameBinders{} ->+          case Foil.assertDistinct binder1 of+            Foil.Distinct ->+              let scope' = Foil.extendScopePattern binder1 scope+                  names = map Foil.nameId (Foil.namesOfPattern binder1)+                  envL' = deleteAll names envL+                  envR' = deleteAll names envR+               in alphaEquivEnv lvl envL' envR' scope' body1 body2+        -- the left binder is renamed towards the right one+        Foil.RenameLeftNameBinder _ rename1to2 ->+          case Foil.assertDistinct binder2 of+            Foil.Distinct ->+              let scope' = Foil.extendScopePattern binder2 scope+                  pairs = [ (Foil.nameId x, renamedId rename1to2 x)+                          | x <- Foil.namesOfPattern binder1 ]+               in bindPairs lvl envL envR pairs scope' body1 body2+        -- the right binder is renamed towards the left one+        Foil.RenameRightNameBinder _ rename2to1 ->+          case Foil.assertDistinct binder1 of+            Foil.Distinct ->+              let scope' = Foil.extendScopePattern binder1 scope+                  pairs = [ (renamedId rename2to1 y, Foil.nameId y)+                          | y <- Foil.namesOfPattern binder2 ]+               in bindPairs lvl envL envR pairs scope' body1 body2+        -- both are renamed towards a unified pattern: pair the two sides'+        -- names through the unified name each maps to+        Foil.RenameBothBinders binder' rename1 rename2 ->+          case Foil.assertDistinct binder' of+            Foil.Distinct ->+              let scope' = Foil.extendScopePattern binder' scope+                  leftU = IntMap.fromList+                    [ (renamedId rename1 x, Foil.nameId x)+                    | x <- Foil.namesOfPattern binder1 ]+                  rightU = IntMap.fromList+                    [ (renamedId rename2 y, Foil.nameId y)+                    | y <- Foil.namesOfPattern binder2 ]+                  pairs = IntMap.elems (IntMap.intersectionWith (,) leftU rightU)+               in bindPairs lvl envL envR pairs scope' body1 body2+        Foil.NotUnifiable -> False+  where+    deleteAll names env = case names of+      []       -> env+      (i : is) -> deleteAll is (IntMap.delete i env)+ -- ** Unsafe equality checks  -- | /Unsafe/ equality check for two terms. -- This check ignores the possibility that two terms might have different -- scope extensions under binders (which might happen due to substitution -- under a binder in absence of name conflicts).+--+-- @since 0.0.3 {-# INLINABLE unsafeEqAST #-} unsafeEqAST   :: (Bitraversable sig, ZipMatchK sig, Foil.UnifiablePattern binder, Foil.Distinct n, Foil.Distinct l)@@ -279,6 +494,8 @@ unsafeEqAST _ _ = False  -- | A version of 'unsafeEqAST' for scoped terms.+--+-- @since 0.0.3 {-# INLINABLE unsafeEqScopedAST #-} unsafeEqScopedAST   :: (Bitraversable sig, ZipMatchK sig, Foil.UnifiablePattern binder, Foil.Distinct n, Foil.Distinct l)@@ -295,8 +512,189 @@  -- ** Convert to free foil --- | Convert a raw term into a scope-safe term.-convertToAST+-- | An identifier a raw term mentions that the names given for conversion do+-- not account for.+--+-- Note what this does and does not carry. It cannot carry a position: the+-- conversion functions are generic in the raw term and only ever see it through+-- @toSig@, so a source location, if the syntax has one, is not theirs to read.+-- What they do know, and a caller checking names beforehand does not, is which+-- names were in scope /at the occurrence/, the binders passed on the way down+-- included. That is what a \"did you mean\" needs.+--+-- @since 0.4.0+data UnresolvedName rawIdent = UnresolvedName+  { unresolvedIdent   :: rawIdent+    -- ^ The identifier that did not resolve.+  , unresolvedInScope :: [rawIdent]+    -- ^ What was in scope where it occurred.+  } deriving (Eq, Show, Functor, Foldable, Traversable)++-- | The identifiers a raw term mentions that a set of names cannot resolve, in+-- the order they occur.+--+-- This is 'unsafeConvertToAST' with the conversion left out, so it descends+-- under binders in the same way and accounts for what they bind.+--+-- @since 0.4.0+unresolvedNames+  :: forall sig binder rawIdent rawTerm rawPattern rawScopedTerm n.+     (Foil.Distinct n, Bifoldable sig, Ord rawIdent, Foil.CoSinkable binder)+  => (rawTerm -> Either rawIdent (sig (rawPattern, rawScopedTerm) rawTerm))+  -- ^ Unpeel one syntax node (or a variable) from a raw term.+  -> (forall x z. Foil.Distinct x+      => Foil.Scope x+      -> Map rawIdent (Foil.Name x)+      -> rawPattern+      -> (forall y. Foil.DExt x y+          => binder x y+          -> Map rawIdent (Foil.Name y)+          -> z)+      -> z)+  -- ^ Convert raw pattern into a scope-safe pattern.+  -> (rawScopedTerm -> rawTerm)+  -- ^ Extract a term from a scoped term (or crash).+  -> Foil.Scope n+  -- ^ Resulting scope of the constructed term.+  -> Map rawIdent (Foil.Name n)+  -- ^ Known names of free variables in scope @n@.+  -> rawTerm+  -- ^ Raw term.+  -> [UnresolvedName rawIdent]+unresolvedNames toSig fromRawPattern getScopedTerm = go+  where+    go :: forall x. Foil.Distinct x+       => Foil.Scope x -> Map rawIdent (Foil.Name x) -> rawTerm -> [UnresolvedName rawIdent]+    go scope names t = case toSig t of+      Left x+        | Map.member x names -> []+        | otherwise          -> [UnresolvedName x (Map.keys names)]+      Right node -> bifoldMap (goScoped scope names) (go scope names) node++    goScoped :: forall x. Foil.Distinct x+             => Foil.Scope x -> Map rawIdent (Foil.Name x)+             -> (rawPattern, rawScopedTerm) -> [UnresolvedName rawIdent]+    goScoped scope names (pat, scopedTerm) =+      fromRawPattern scope names pat $ \binder' names' ->+        go (Foil.extendScopePattern binder' scope) names' (getScopedTerm scopedTerm)++-- | Convert a raw term into a scope-safe term, reporting the first identifier+-- that does not resolve.+--+-- One pass, short-circuiting at the first failure, so a term that resolves+-- costs no more than 'unsafeConvertToAST' does. The report is complete for+-- that one identifier, since 'unresolvedInScope' is built where the conversion+-- fails and is never computed on the way through.+--+-- A caller wanting /every/ unresolved identifier rather than the first pays a+-- second pass for it, with 'unresolvedNames'. The successful path stays fast+-- that way, and a failure can afford to be walked again for a better message.+--+-- @since 0.4.0+tryConvertToAST+  :: forall sig binder rawIdent rawTerm rawPattern rawScopedTerm n.+     (Foil.Distinct n, Bitraversable sig, Ord rawIdent,+      Foil.CoSinkable binder, Foil.SinkableK binder)+  => (rawTerm -> Either rawIdent (sig (rawPattern, rawScopedTerm) rawTerm))+  -- ^ Unpeel one syntax node (or a variable) from a raw term.+  -> (forall x z. Foil.Distinct x+      => Foil.Scope x+      -> Map rawIdent (Foil.Name x)+      -> rawPattern+      -> (forall y. Foil.DExt x y+          => binder x y+          -> Map rawIdent (Foil.Name y)+          -> z)+      -> z)+  -- ^ Convert raw pattern into a scope-safe pattern.+  -> (rawScopedTerm -> rawTerm)+  -- ^ Extract a term from a scoped term (or crash).+  -> Foil.Scope n+  -- ^ Resulting scope of the constructed term.+  -> Map rawIdent (Foil.Name n)+  -- ^ Known names of free variables in scope @n@.+  -> rawTerm+  -- ^ Raw term.+  -> Either (UnresolvedName rawIdent) (AST binder sig n)+tryConvertToAST toSig fromRawPattern getScopedTerm scope names =+  tryConvertToASTWith toSig fromRawPattern getScopedTerm scope names Map.empty++-- | Convert a raw term into a scope-safe term, resolving some identifiers to+-- whole terms rather than to variables.+--+-- The extra table is what a language with /constants/ needs: an identifier that+-- denotes a top-level declaration, a primitive, or an abbreviation stands for+-- something that is not a variable, and resolving it during conversion is the+-- only place where the binders are known. Doing it in a pass of one's own means+-- writing a binder-aware traversal of the raw syntax by hand.+--+-- Variables win: the table of names is consulted first, so a binder shadows an+-- entry here, and an entry here shadows nothing. The table is sunk when going+-- under a binder, exactly as the names are, so its entries may mention anything+-- in scope where conversion started and need not be closed.+--+-- @since 0.4.0+tryConvertToASTWith+  :: forall sig binder rawIdent rawTerm rawPattern rawScopedTerm n.+     (Foil.Distinct n, Bitraversable sig, Ord rawIdent,+      Foil.CoSinkable binder, Foil.SinkableK binder)+  => (rawTerm -> Either rawIdent (sig (rawPattern, rawScopedTerm) rawTerm))+  -- ^ Unpeel one syntax node (or a variable) from a raw term.+  -> (forall x z. Foil.Distinct x+      => Foil.Scope x+      -> Map rawIdent (Foil.Name x)+      -> rawPattern+      -> (forall y. Foil.DExt x y+          => binder x y+          -> Map rawIdent (Foil.Name y)+          -> z)+      -> z)+  -- ^ Convert raw pattern into a scope-safe pattern.+  -> (rawScopedTerm -> rawTerm)+  -- ^ Extract a term from a scoped term (or crash).+  -> Foil.Scope n+  -- ^ Resulting scope of the constructed term.+  -> Map rawIdent (Foil.Name n)+  -- ^ Known names of free variables in scope @n@.+  -> Map rawIdent (AST binder sig n)+  -- ^ Identifiers that denote a term rather than a variable.+  -> rawTerm+  -- ^ Raw term.+  -> Either (UnresolvedName rawIdent) (AST binder sig n)+tryConvertToASTWith toSig fromRawPattern getScopedTerm = go+  where+    go :: forall x. Foil.Distinct x+       => Foil.Scope x -> Map rawIdent (Foil.Name x)+       -> Map rawIdent (AST binder sig x) -> rawTerm+       -> Either (UnresolvedName rawIdent) (AST binder sig x)+    go scope names terms t = case toSig t of+      Left x -> case Map.lookup x names of+        Just name -> Right (Var name)+        Nothing   -> case Map.lookup x terms of+          Just term -> Right term+          Nothing   -> Left (UnresolvedName x (Map.keys names <> Map.keys terms))+      Right node ->+        Node <$> bitraverse (goScoped scope names terms) (go scope names terms) node++    goScoped :: forall x. Foil.Distinct x+             => Foil.Scope x -> Map rawIdent (Foil.Name x)+             -> Map rawIdent (AST binder sig x)+             -> (rawPattern, rawScopedTerm)+             -> Either (UnresolvedName rawIdent) (ScopedAST binder sig x)+    goScoped scope names terms (pat, scopedTerm) =+      fromRawPattern scope names pat $ \binder' names' ->+        ScopedAST binder'+          <$> go (Foil.extendScopePattern binder' scope) names'+                 (Foil.sink1 terms) (getScopedTerm scopedTerm)++-- | Convert a raw term into a scope-safe term, calling 'error' on an+-- identifier that does not resolve.+--+-- Prefer 'tryConvertToAST', which reports such identifiers. This is for callers+-- that have already established that every name resolves.+--+-- @since 0.4.0+unsafeConvertToAST   :: (Foil.Distinct n, Bifunctor sig, Ord rawIdent, Foil.CoSinkable binder)   => (rawTerm -> Either rawIdent (sig (rawPattern, rawScopedTerm) rawTerm))   -- ^ Unpeel one syntax node (or a variable) from a raw term.@@ -319,7 +717,7 @@   -> rawTerm   -- ^ Raw term.   -> AST binder sig n-convertToAST toSig fromRawPattern getScopedTerm scope names t =+unsafeConvertToAST toSig fromRawPattern getScopedTerm scope names t =   case toSig t of     Left x ->       case Map.lookup x names of@@ -327,12 +725,14 @@         Just name -> Var name     Right node -> Node $       bimap-        (convertToScopedAST toSig fromRawPattern getScopedTerm scope names)-        (convertToAST toSig fromRawPattern getScopedTerm scope names)+        (unsafeConvertToScopedAST toSig fromRawPattern getScopedTerm scope names)+        (unsafeConvertToAST toSig fromRawPattern getScopedTerm scope names)         node --- | Same as 'convertToAST' but for scoped terms.-convertToScopedAST+-- | Same as 'unsafeConvertToAST' but for scoped terms.+--+-- @since 0.4.0+unsafeConvertToScopedAST   :: (Foil.Distinct n, Bifunctor sig, Ord rawIdent, Foil.CoSinkable binder)   => (rawTerm -> Either rawIdent (sig (rawPattern, rawScopedTerm) rawTerm))   -- ^ Unpeel one syntax node (or a variable) from a raw term.@@ -355,14 +755,62 @@   -> (rawPattern, rawScopedTerm)   -- ^ A pair of a pattern and a corresponding scoped term.   -> ScopedAST binder sig n-convertToScopedAST toSig fromRawPattern getScopedTerm scope names (pat, scopedTerm) =+unsafeConvertToScopedAST toSig fromRawPattern getScopedTerm scope names (pat, scopedTerm) =   fromRawPattern scope names pat $ \binder' names' ->     let scope' = Foil.extendScopePattern binder' scope-     in ScopedAST binder' (convertToAST toSig fromRawPattern getScopedTerm scope' names' (getScopedTerm scopedTerm))+     in ScopedAST binder' (unsafeConvertToAST toSig fromRawPattern getScopedTerm scope' names' (getScopedTerm scopedTerm)) +-- | Convert a raw term into a scope-safe term.+--+-- @since 0.0.3+convertToAST+  :: (Foil.Distinct n, Bifunctor sig, Ord rawIdent, Foil.CoSinkable binder)+  => (rawTerm -> Either rawIdent (sig (rawPattern, rawScopedTerm) rawTerm))+  -> (forall x z. Foil.Distinct x+      => Foil.Scope x+      -> Map rawIdent (Foil.Name x)+      -> rawPattern+      -> (forall y. Foil.DExt x y+          => binder x y+          -> Map rawIdent (Foil.Name y)+          -> z)+      -> z)+  -> (rawScopedTerm -> rawTerm)+  -> Foil.Scope n+  -> Map rawIdent (Foil.Name n)+  -> rawTerm+  -> AST binder sig n+convertToAST = unsafeConvertToAST+{-# DEPRECATED convertToAST "Renamed to unsafeConvertToAST, since it calls error on an unresolved identifier. Use tryConvertToAST to report them instead." #-}++-- | Same as 'convertToAST' but for scoped terms.+--+-- @since 0.0.3+convertToScopedAST+  :: (Foil.Distinct n, Bifunctor sig, Ord rawIdent, Foil.CoSinkable binder)+  => (rawTerm -> Either rawIdent (sig (rawPattern, rawScopedTerm) rawTerm))+  -> (forall x z. Foil.Distinct x+      => Foil.Scope x+      -> Map rawIdent (Foil.Name x)+      -> rawPattern+      -> (forall y. Foil.DExt x y+          => binder x y+          -> Map rawIdent (Foil.Name y)+          -> z)+      -> z)+  -> (rawScopedTerm -> rawTerm)+  -> Foil.Scope n+  -> Map rawIdent (Foil.Name n)+  -> (rawPattern, rawScopedTerm)+  -> ScopedAST binder sig n+convertToScopedAST = unsafeConvertToScopedAST+{-# DEPRECATED convertToScopedAST "Renamed to unsafeConvertToScopedAST, since it calls error on an unresolved identifier." #-}+ -- ** Convert from free foil  -- | Convert a scope-safe term back into a raw term.+--+-- @since 0.0.3 convertFromAST   :: Bifunctor sig   => (sig (rawPattern, rawScopedTerm) rawTerm -> rawTerm)@@ -387,6 +835,8 @@       node  -- | Same as 'convertFromAST' but for scoped terms.+--+-- @since 0.0.3 convertFromScopedAST   :: Bifunctor sig   => (sig (rawPattern, rawScopedTerm) rawTerm -> rawTerm)@@ -407,22 +857,137 @@     ( makePattern binder     , makeScoped (convertFromAST fromSig fromVar makePattern makeScoped f body)) +-- | Convert a scope-safe term back into a raw term, naming the variables that+-- occur /free in the whole term/ separately from the bound ones.+--+-- 'convertFromAST' applies one naming function to every variable it meets,+-- bound or free, and gives it only a raw name. That is often not enough, since+-- raw names are not unique across scope indices: a binder inside a term may+-- share one with a name of the ambient scope, so naming by raw name alone can+-- print a bound variable as whatever the ambient scope calls that name.+--+-- Keeping the typed name is what distinguishes them, and 'Foil.unsinkNamePattern'+-- is the operation for it: composing one per binder on the way down builds a+-- @'Foil.Name' x -> 'Maybe' ('Foil.Name' n)@ that answers exactly the question.+--+-- @since 0.4.0+convertFromASTWith+  :: forall sig binder rawIdent rawTerm rawPattern rawScopedTerm n.+     (Bifunctor sig, Foil.Distinct n, Foil.CoSinkable binder)+  => (sig (rawPattern, rawScopedTerm) rawTerm -> rawTerm)+  -- ^ Peel back one layer of syntax.+  -> (rawIdent -> rawTerm)+  -- ^ Convert identifier into a raw variable term.+  -> (forall x y. binder x y -> rawPattern)+  -- ^ Convert scope-safe pattern into a raw pattern.+  -> (rawTerm -> rawScopedTerm)+  -- ^ Wrap raw term into a scoped term.+  -> (Foil.Name n -> rawIdent)+  -- ^ Name a variable that is free in the whole term.+  -> (Int -> rawIdent)+  -- ^ Name a bound variable, from its underlying integer identifier.+  -> AST binder sig n+  -- ^ Scope-safe term.+  -> rawTerm+convertFromASTWith fromSig fromVar makePattern makeScoped freeName boundName =+    go Just+  where+    go :: forall x. Foil.Distinct x+       => (Foil.Name x -> Maybe (Foil.Name n)) -> AST binder sig x -> rawTerm+    go unsink = \case+      Var x -> fromVar $ case unsink x of+        Just name -> freeName name+        Nothing   -> boundName (Foil.nameId x)+      Node node -> fromSig (bimap (goScoped unsink) (go unsink) node)++    goScoped :: forall x. Foil.Distinct x+             => (Foil.Name x -> Maybe (Foil.Name n))+             -> ScopedAST binder sig x -> (rawPattern, rawScopedTerm)+    goScoped unsink (ScopedAST binder body) =+      case Foil.assertDistinct binder of+        Foil.Distinct ->+          ( makePattern binder+          , makeScoped+              (go (\name -> Foil.unsinkNamePattern binder name >>= unsink) body) )+ -- ** Unsinking AST +-- | The support of a term: exactly the names that occur free in it.+--+-- This is the annotation that co-de-Bruijn syntax carries intrinsically and+-- that the foil, having global names and therefore free weakening, does not.+-- Computing it is \(O(size)\); a client that restricts often should cache it.+--+-- @since 0.4.0+supportOf+  :: (Foil.Distinct n, Foil.CoSinkable binder, Bifoldable sig)+  => AST binder sig n -> Foil.NameSet n+supportOf = \case+  Var name  -> Foil.nameSetSingleton name+  Node node -> bifoldMap supportOfScopedAST supportOf node++-- | The support of a scoped term, in the scope /outside/ its binder.+--+-- @since 0.4.0+supportOfScopedAST+  :: (Foil.Distinct n, Foil.CoSinkable binder, Bifoldable sig)+  => ScopedAST binder sig n -> Foil.NameSet n+supportOfScopedAST (ScopedAST binder body) =+  case Foil.assertDistinct binder of+    Foil.Distinct -> Foil.unsinkNameSet binder (supportOf body)++-- | Cut a term down to the scope of exactly the names it uses.+--+-- This is the a-priori form of restriction, and the cheap one: the term+-- inhabits the smaller scope /by construction/, so nothing is tested and+-- nothing can fail. @'Foil.Ext' m n@ comes back with it, so the term can be+-- 'Foil.sink'ed to where it came from for free.+--+-- Verifying a declared dependency, such as a @uses@ clause or a module's+-- parameters, is this plus a comparison: compute the scope a term really+-- inhabits, and check the declared one against it.+--+-- @since 0.4.0+withRelevantScope+  :: (Foil.Distinct n, Foil.CoSinkable binder, Bifoldable sig)+  => AST binder sig n+  -> (forall m. (Foil.Ext m n, Foil.Distinct m)+      => Foil.Scope m -> AST binder sig m -> r)+  -> r+withRelevantScope term cont =+  Foil.withRestrictedScope (supportOf term) $ \scope ->+    cont scope (unsafeCoerce term)+ -- | Unsink an AST from a larger scope to a smaller scope.-unsinkAST :: (Foil.Distinct l, Foil.CoSinkable binder, Bifoldable sig) => Foil.Scope n -> AST binder sig l -> Maybe (AST binder sig n)+--+-- This is the a-posteriori form, and the one that has to be paid for: the+-- term's support is computed and compared against the scope. When it succeeds+-- the term itself is untouched, since restriction of a term that does inhabit+-- the smaller scope is a coercion.+--+-- @since 0.3.0+unsinkAST+  :: (Foil.Distinct l, Foil.CoSinkable binder, Bifoldable sig)+  => Foil.Scope n -> AST binder sig l -> Maybe (AST binder sig n) unsinkAST scope term-  | all (`Foil.member` scope) (freeVarsOf term) = Just (unsafeCoerce term)+  | Foil.nameSetSubsetOfScope (supportOf term) scope = Just (unsafeCoerce term)   | otherwise = Nothing  -- | Get the free variables of an AST.-freeVarsOf :: (Foil.Distinct n, Foil.CoSinkable binder, Bifoldable sig) => AST binder sig n -> [Foil.Name n]-freeVarsOf = \case-  Var name -> [name]-  Node node -> bifoldMap freeVarsOfScopedAST freeVarsOf node+--+-- These come from 'supportOf', so they are distinct and in ascending order of+-- their identifiers.+--+-- @since 0.3.0+freeVarsOf+  :: (Foil.Distinct n, Foil.CoSinkable binder, Bifoldable sig)+  => AST binder sig n -> [Foil.Name n]+freeVarsOf = Foil.nameSetToList . supportOf --- | Get the free variables of a scoped AST.-freeVarsOfScopedAST :: (Foil.Distinct n, Foil.CoSinkable binder, Bifoldable sig) => ScopedAST binder sig n -> [Foil.Name n]-freeVarsOfScopedAST (ScopedAST binder body) =-  case Foil.assertDistinct binder of-    Foil.Distinct -> mapMaybe (Foil.unsinkNamePattern binder) (freeVarsOf body)+-- | Get the free variables of a scoped AST, in the scope outside its binder.+--+-- @since 0.3.0+freeVarsOfScopedAST+  :: (Foil.Distinct n, Foil.CoSinkable binder, Bifoldable sig)+  => ScopedAST binder sig n -> [Foil.Name n]+freeVarsOfScopedAST = Foil.nameSetToList . supportOfScopedAST

@@ -21,12 +21,12 @@ -- -- The annotation is a /functor of the term/, and that is what lets it depend on -- the node's scope. In @'AST' binder sig n@ the signature's term parameter /is/--- the AST at the node's own scope, so an annotation built from it holds terms in--- that scope — which is what a type annotation in a dependent language needs.+-- the AST at the node's own scope, so an annotation built from it holds terms+-- in that scope, which is what a type annotation in a dependent language needs. -- An annotation that ignores the term (a source position, say) is @'Const' a@. -- -- Whether two annotations must agree for their nodes to match is a property of--- @ann@, not of 'AnnSig'. Two examples, and they are the two you will want:+-- @ann@, and not of 'AnnSig'. Two examples: -- -- An annotation that ignores the term (a source position) and /is/ compared: --@@ -46,16 +46,18 @@ -- >     Just (TypeOf (do { a <- l; b <- r; f a b })) -- -- __The instance must return 'Just' unconditionally, and lazily.__ Matching is--- annotation-blind, so it must succeed whatever the annotations are; the paired--- annotation is a thunk the (annotation-skipping) 'Bifoldable' never forces. A--- /strict/ shape — @TypeOf '<$>' f l r@, or anything that yields 'Nothing' when--- @f@ fails — is a footgun twice over: it breaks blindness (two nodes with--- different types would fail to match), and it /diverges/ for a finite or--- lazily-bottomed annotation (a universe tower ending in 'error', say), because--- forcing the annotation runs off the end. This is why the held term is a 'Maybe':--- a plain @term@ field would have no value to pair when @f@ fails, forcing a--- bottom into the result.+-- annotation-blind, so it must succeed whatever the annotations are, and the+-- paired annotation is a thunk that the annotation-skipping 'Bifoldable' never+-- forces. --+-- A /strict/ shape, such as @TypeOf '<$>' f l r@ or anything else that yields+-- 'Nothing' when @f@ fails, goes wrong twice over. It breaks blindness, since+-- two nodes with different types would then fail to match. And it /diverges/+-- for a finite or lazily-bottomed annotation (a universe tower ending in+-- 'error', say), because forcing the annotation runs off the end. This is why+-- the held term is a 'Maybe': a plain @term@ field would have no value to pair+-- when @f@ fails, forcing a bottom into the result.+-- -- __Do not reach for the generic instance here.__ It compares the annotation's -- /shape/, so a node carrying a memoised normal form would fail to match the same -- node without one. (Nor is 'zipMatchViaChooseLeft' available: an annotation@@ -63,8 +65,8 @@ -- pick a side.) -- -- __Note the asymmetry__ in the instances below: 'Bifunctor' and 'Bitraversable'--- traverse the annotation, but 'Bifoldable' does /not/. This is deliberate — see--- 'AnnSig'.+-- traverse the annotation, but 'Bifoldable' does /not/. This is deliberate.+-- See 'AnnSig'. module Control.Monad.Free.Foil.Annotated (   AnnSig(..),   AnnAST,@@ -99,6 +101,8 @@ -- 'Control.Monad.Free.Foil.freeVarsOf', which is also 'Bifoldable', does not see -- variables occurring inside annotations. Use 'freeVarsOfAnnotated' when those -- matter.+--+-- @since 0.3.2 data AnnSig (ann :: Type -> Type) (sig :: Type -> Type -> Type) scope term   = AnnSig (ann term) (sig scope term)   deriving (GHC.Generic)@@ -128,20 +132,26 @@ -- -- The generic default would rebuild the "Generics.Kind" view of every node on -- every comparison, and comparing terms is most of what a typechecker does, so--- for an annotated signature — where it lands on the hottest path — that is a+-- for an annotated signature, where it lands on the hottest path, that is a -- measurable cost. 'Data.ZipMatchK.TH.deriveZipMatchK2' generates the -- written-out instance instead: the annotation matched with the term zipper (an--- annotation is a functor of the term), the inner signature with both. Write--- @deriveZipMatchK2 ''YourAnnSig@ for a bespoke annotated signature.+-- annotation is a functor of the term), and the inner signature with both.+-- Write @deriveZipMatchK2 ''YourAnnSig@ for a bespoke annotated signature. deriveZipMatchK2 ''AnnSig  -- | An annotated scope-safe term.+--+-- @since 0.3.2 type AnnAST binder ann sig = AST binder (AnnSig ann sig)  -- | An annotated scope-safe term under a binder.+--+-- @since 0.3.2 type AnnScopedAST binder ann sig = ScopedAST binder (AnnSig ann sig)  -- | An annotated node.+--+-- @since 0.3.2 pattern AnnNode   :: ann (AnnAST binder ann sig n)   -> sig (AnnScopedAST binder ann sig n) (AnnAST binder ann sig n)@@ -152,6 +162,8 @@  -- | The annotation of a term, unless it is a variable (which is not a node, so it -- carries none).+--+-- @since 0.3.2 annotationOf :: AnnAST binder ann sig n -> Maybe (ann (AnnAST binder ann sig n)) annotationOf = \case   Var _         -> Nothing@@ -162,6 +174,8 @@ -- -- 'Control.Monad.Free.Foil.freeVarsOf' misses the latter, since 'Bifoldable' skips -- the annotation (see 'AnnSig').+--+-- @since 0.3.2 freeVarsOfAnnotated   :: (Foil.Distinct n, Foil.CoSinkable binder, Bifoldable sig, Foldable ann)   => AnnAST binder ann sig n -> [Foil.Name n]

@@ -0,0 +1,342 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | Serialisation support for checked units: stored terms, spelling tables,+-- name-range metadata, and relocation.+--+-- The machinery here assumes only that a unit's /interned constants/ and its+-- /locals/ (the names its binders bind) occupy disjoint name ranges, and it+-- checks that assumption from the recorded metadata rather than taking it on+-- faith. A stored term is then meaningful verbatim: a local keeps its raw id,+-- and a constant is resolved through a spelling table on load.+--+-- One policy that provides the disjointness globally and by construction is+-- to keep constants below zero and locals at or above, which is what the+-- guarded successor allocator protects.+--+-- What loading trusts, and what it checks, is the client's decision, and the+-- functions here supply the checkable facts. 'checkStoredLayout' judges the+-- recorded ranges and 'constantRelocation' judges the constants, both from+-- metadata alone, so no stored term is ever walked for checking. Only+-- 'relocateConstants' walks a term, and only when a constant actually moved.+module Control.Monad.Free.Foil.Artifact (+  -- * Errors+  ArtifactError (..),+  prettyArtifactError,+  -- * Stored terms+  StoredTerm (..),+  storeTerm,+  decodeStored,+  -- * Spelling tables and locals+  termSpellings,+  localsOf,+  spanOfNames,+  -- * Range metadata and its checks+  StoredLayout (..),+  nameRangeSize,+  nameRangeContains,+  nameRangesOverlap,+  checkStoredLayout,+  -- * Relocation+  constantRelocation,+  relocateConstants,+) where++import           Data.Binary                    (Binary, get)+import qualified Data.Binary                    as Binary+import           Data.Binary.Get                (runGetOrFail)+import           Data.Bifoldable                (Bifoldable, bifoldMap)+import           Data.Bifunctor                 (Bifunctor, bimap)+import qualified Data.ByteString.Lazy           as BSL+import qualified Data.IntMap                    as IntMap+import qualified Data.IntSet                    as IntSet+import           Data.Map                       (Map)+import qualified Data.Map                       as Map+import           GHC.Generics                   (Generic)+import           Unsafe.Coerce                  (unsafeCoerce)++import           Control.Monad.Foil.Internal+import           Control.Monad.Free.Foil        (AST (..), ScopedAST (..),+                                                 supportOf)+import           Control.Monad.Free.Foil.Binary ()++-- $setup+-- >>> import Control.Monad.Foil (NameRange (..))+-- >>> import qualified Data.Map as Map++-- * Errors++-- | What the machinery here can report. The type is parametric in the+-- spelling, as the tables are, and a 'Functor' over it.+--+-- @since 0.4.0+data ArtifactError ident+  = MalformedStoredTerm String+      -- ^ The bytes did not decode. The message is the decoder's.+  | OverlappingRegions NameRange NameRange+      -- ^ The recorded constants and locals ranges share a name.+  | SpellingForLocal RawName+      -- ^ The spelling table names something inside the locals region.+  | WrongDeclarationCount NameRange Int+      -- ^ The constants range does not hold one name per declaration.+  | UnknownConstant ident+      -- ^ A spelling the loading world does not know.+  | ConstantAmongLocals ident RawName+      -- ^ A relocation target inside the locals region, where the verbatim+      -- locals could capture it.+  deriving (Eq, Show, Functor)++-- | Render an error, given a renderer for the spellings.+--+-- @since 0.4.0+prettyArtifactError :: (ident -> String) -> ArtifactError ident -> String+prettyArtifactError prettyIdent = \case+  MalformedStoredTerm msg -> "malformed stored term: " <> msg+  OverlappingRegions _ _ -> "the constants and locals regions overlap"+  SpellingForLocal i -> "a spelling for local " <> show i+  WrongDeclarationCount range count ->+    "the constants range holds " <> show (nameRangeSize range)+      <> " names for " <> show count <> " declarations"+  UnknownConstant x -> "not in scope: " <> prettyIdent x+  ConstantAmongLocals x _ ->+    "constant " <> prettyIdent x <> " would land in the locals region"++-- * Stored terms++-- | A term as stored: canonical bytes. Equality of stored terms is byte+-- equality, which is what a canonical-artifact property tests.+--+-- @since 0.4.0+newtype StoredTerm = StoredTerm { storedBytes :: BSL.ByteString }+  deriving (Eq, Show, Generic, Binary)++-- | Store a term verbatim, through the instances of+-- "Control.Monad.Free.Foil.Binary".+--+-- The disjoint layout is what makes verbatim enough. A constant's spelling+-- goes into the unit's table ('termSpellings'), and a local needs no+-- table: its id is expected to be canonical, which it is when elaboration+-- allocates locals in a region of their own.+--+-- @since 0.4.0+storeTerm :: Binary (AST binder sig n) => AST binder sig n -> StoredTerm+storeTerm = StoredTerm . Binary.encode++-- | Decode a stored term's bytes: the instances alone, no meaning yet.+-- Meaning is given per unit, by 'constantRelocation' and+-- 'relocateConstants'.+--+-- @since 0.4.0+decodeStored+  :: Binary (AST binder sig n)+  => StoredTerm -> Either (ArtifactError ident) (AST binder sig n)+decodeStored (StoredTerm bytes) =+  case runGetOrFail get bytes of+    Left (_, _, err) -> Left (MalformedStoredTerm err)+    Right (rest, _, term)+      | not (BSL.null rest) -> Left (MalformedStoredTerm "trailing bytes")+      | otherwise -> Right term++-- * Spelling tables and locals++-- | The spelling-table entries a term needs. Its free variables are exactly+-- its constants, provided the stored declaration is closed over everything+-- local. Each is mapped to its spelling from the display table.+--+-- Note that the table should cover the referenced constants and only+-- those. A table of everything in scope would let an unused import dirty a+-- dependant's content hash, and would differ between build schedules.+--+-- @since 0.4.0+termSpellings+  :: (Distinct n, CoSinkable binder, Bifoldable sig)+  => NameMap n ident      -- ^ Spellings of the top-level names.+  -> AST binder sig n+  -> Map RawName ident+termSpellings display t = Map.fromList+  [ (nameId x, lookupName x display)+  | x <- nameSetToList (supportOf t)+  ]++-- | The names a term's binders bind: what a unit's locals range covers.+-- Note that 'supportOf' cannot see them, since they are bound and not free.+--+-- @since 0.4.0+localsOf+  :: (Bifoldable sig, HasNameBinders binder)+  => AST binder sig n -> [RawName]+localsOf = \case+  Var _    -> []+  Node sig -> bifoldMap scopedLocals localsOf sig+  where+    scopedLocals (ScopedAST pat body) =+      binderNames pat <> localsOf body+    binderNames pat = case getNameBinders pat of+      UnsafeNameBinders ids -> IntSet.toList ids++-- | The tightest range covering the given names, or 'Nothing' for none.+-- The caller picks its own convention for the empty range.+--+-- >>> spanOfNames [7, 3, 5]+-- Just (NameRange {nameRangeLo = 3, nameRangeHi = 7})+--+-- @since 0.4.0+spanOfNames :: [RawName] -> Maybe NameRange+spanOfNames [] = Nothing+spanOfNames ids = Just (NameRange (minimum ids) (maximum ids))++-- * Range metadata and its checks++-- | A unit's recorded name layout: the actual names of its own constants, and+-- of its locals. The two travel together, so that they cannot be mixed up with+-- the ranges of the loading world. An artifact records them as one field, and+-- the checks and the relocation consume them as one value.+--+-- @since 0.4.0+data StoredLayout = StoredLayout+  { storedConstants :: NameRange+  , storedLocals    :: NameRange+  }+  deriving (Eq, Show, Generic, Binary)++-- | How many names a range holds.+--+-- >>> nameRangeSize (NameRange 3 5)+-- 3+--+-- @since 0.4.0+nameRangeSize :: NameRange -> Int+nameRangeSize (NameRange lo hi) = max 0 (hi - lo + 1)++-- | Whether a raw name lies in a range.+--+-- @since 0.4.0+nameRangeContains :: NameRange -> RawName -> Bool+nameRangeContains (NameRange lo hi) i = lo <= i && i <= hi++-- | Whether two ranges share a name. An empty range overlaps nothing.+--+-- >>> nameRangesOverlap (NameRange 0 4) (NameRange 4 9)+-- True+-- >>> nameRangesOverlap (NameRange 0 4) (NameRange 5 9)+-- False+--+-- @since 0.4.0+nameRangesOverlap :: NameRange -> NameRange -> Bool+nameRangesOverlap (NameRange lo1 hi1) (NameRange lo2 hi2) =+  lo1 <= hi1 && lo2 <= hi2 && lo1 <= hi2 && lo2 <= hi1++-- | The checks a unit's recorded layout admits, judged from metadata alone.+-- The constants and locals ranges must not overlap, no spelling may be+-- recorded for a local, and the constants range must hold exactly one name+-- per declaration, since allocation is dense from the range's low end.+--+-- >>> layout = StoredLayout (NameRange (-10) (-9)) (NameRange 0 5)+-- >>> checkStoredLayout layout (Map.fromList [(-20, "P.base")]) 2+-- Right ()+-- >>> checkStoredLayout layout (Map.fromList [(3, "q")]) 2+-- Left (SpellingForLocal 3)+--+-- @since 0.4.0+checkStoredLayout+  :: StoredLayout         -- ^ The unit's recorded layout.+  -> Map RawName ident    -- ^ Its spelling table.+  -> Int                  -- ^ Its declaration count.+  -> Either (ArtifactError ident) ()+checkStoredLayout (StoredLayout constants locals) table declCount+  | nameRangesOverlap constants locals =+      Left (OverlappingRegions constants locals)+  | (i : _) <- filter (nameRangeContains locals) (Map.keys table) =+      Left (SpellingForLocal i)+  | nameRangeSize constants /= declCount =+      Left (WrongDeclarationCount constants declCount)+  | otherwise = Right ()++-- * Relocation++-- | What a unit's constants need in the loading world, judged once, from+-- the spelling table alone. 'Nothing' says every constant already has the+-- id its spelling means here, which is the fast path, on which no term is+-- walked at all. Otherwise the result is the renaming to apply. Its domain+-- is a scope of the unit's world, which no longer exists, so its index is+-- the caller's phantom.+--+-- The unit's own constants (table entries inside the recorded range) do+-- not consult the world: they are being loaded right now, in the same+-- order they were allocated, so their relocation is the affine shift+-- between the recorded range and the one this run assigned. Their new+-- names are thereby minted ahead of their allocation, which the caller's+-- trust covers. An imported constant resolves by its spelling, and one this+-- world does not know is reported. Finally, no relocation target may land+-- among the locals, since verbatim locals rest on the two never meeting.+--+-- @since 0.4.0+constantRelocation+  :: Ord ident+  => StoredLayout         -- ^ The unit's recorded layout.+  -> NameRange            -- ^ The range this run assigned to the unit.+  -> Map RawName ident    -- ^ Its spelling table.+  -> Map ident (Name n')  -- ^ What each spelling means here.+  -> Either (ArtifactError ident) (Maybe (NameMap old (Name n')))+constantRelocation (StoredLayout old locals) (NameRange newLo _) table globals = do+  entries <- Map.foldrWithKey step (Right []) table+  pure $+    if any (\(i, name) -> nameId name /= i) entries+      then Just (NameMap (IntMap.fromList entries))+      else Nothing+  where+    NameRange oldLo _ = old+    shift = newLo - oldLo+    step i spelling acc = do+      rest <- acc+      name <-+        if nameRangeContains old i+          then Right (UnsafeName (i + shift))+          else case Map.lookup spelling globals of+            Nothing   -> Left (UnknownConstant spelling)+            Just name -> Right name+      if nameRangeContains locals (nameId name)+        then Left (ConstantAmongLocals spelling (nameId name))+        else pure ((i, name) : rest)++-- | Rename every constant reference through the map, moving the term from+-- the unit's world into the loading one. This is the restriction to+-- constants of a general renaming @'Name' n -> 'Name' n'@.+-- 'sinkabilityProof' embodies the general renaming, but its efficient+-- implementations degenerate the renaming to a coercion under binders,+-- which is sound only for inclusions, whereas this walk carries an arbitrary+-- map through.+--+-- The invariant that lets the walk ignore the binders is the disjointness+-- the recorded layout certifies: every name in the map's domain is a+-- constant, and a binder binds locals, so no binder can shadow a name in+-- the domain and no local can be in it. Note that this covers imported+-- constants too, since 'checkStoredLayout' refuses a spelling for any name+-- among the locals. Thus the map never needs extending under a binder, and+-- locals and patterns cross by coercion. A constant outside the map (bytes+-- referencing something the spelling table does not cover) is re-minted+-- unchanged, trusted like everything else about the term. Note that a map+-- that is the identity on raw ids would make the whole walk a coercion,+-- which is why 'constantRelocation' reports it as no relocation at all.+--+-- @since 0.4.0+relocateConstants+  :: forall binder sig n n'. Bifunctor sig+  => NameMap n (Name n') -> AST binder sig n -> AST binder sig n'+relocateConstants (NameMap moved) = walk+  where+    walk :: forall o o'. AST binder sig o -> AST binder sig o'+    walk = \case+      Var x -> case IntMap.lookup (nameId x) moved of+        Just new -> Var (UnsafeName (nameId new))+        Nothing  -> Var (UnsafeName (nameId x))+      Node sig -> Node (bimap walkScoped walk sig)++    walkScoped :: forall o o'. ScopedAST binder sig o -> ScopedAST binder sig o'+    walkScoped (ScopedAST pat body) = ScopedAST (unsafeCoerce pat) (walk body)

@@ -0,0 +1,74 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# OPTIONS_GHC -Wno-orphans #-}+-- | 'Binary' instances for the scope-safe syntax: the wire view of a term+-- is the term itself, raw ids and all.+--+-- The instances are deliberately orphans in a module of their own, so that+-- they are opt-in: importing this module is what brings them into scope,+-- and nothing else in the library does. (The dependency this costs is+-- @binary@, a GHC boot library.)+--+-- Note that decoding /mints/ scope evidence: a 'Foil.Name' comes back at+-- whatever scope index the context asks for, and the existential scope+-- under a binder is chosen arbitrarily. Thus the instances are a trust+-- boundary, in the sense of 'Control.Monad.Foil.Blocks.checkExtScope'. The+-- bytes are meaningful only under the discipline of the layer that wrote+-- them, and that layer is expected to validate what it can on the way in.+-- In particular, it should resolve the references it made+-- world-independent, and check that the names it left verbatim lie where its+-- allocation policy says. "Control.Monad.Free.Foil.Artifact" supplies those+-- checks.+module Control.Monad.Free.Foil.Binary () where++import           Data.Binary                 (Binary (..))+import           Data.Binary.Get             (Get, getWord8)+import           Data.Binary.Put             (putWord8)++import           Control.Monad.Foil.Internal+import           Control.Monad.Free.Foil     (AST (..), ScopedAST (..))++-- | The raw id and nothing else. See the module documentation for what+-- decoding trusts.+instance Binary (Name n) where+  put (UnsafeName raw) = put raw+  get = UnsafeName <$> get++-- | See the 'Binary' instance of 'Name'.+instance Binary (NameBinder n l) where+  put (UnsafeNameBinder name) = put name+  get = UnsafeNameBinder <$> get++-- | The two bounds. A range carries no scope index, so nothing is minted:+-- this instance is layout metadata for the serialising layer.+instance Binary NameRange where+  put (NameRange lo hi) = put lo <> put hi+  get = NameRange <$> get <*> get++-- | The binder and the body, one after the other. Decoding mints the scope+-- under the binder. See the module documentation.+instance (forall x y. Binary (binder x y), forall l. Binary (AST binder sig l))+    => Binary (ScopedAST binder sig n) where+  put (ScopedAST binder body) = put binder <> put body+  get = do+    binder <- get :: Get (binder n n)+    body <- get+    pure (ScopedAST binder body)++-- | A tag byte, then the name or the node.+instance ( forall x y. Binary (binder x y)+         , forall scope term. (Binary scope, Binary term) => Binary (sig scope term)+         ) => Binary (AST binder sig n) where+  put (Var x)     = putWord8 0 <> put x+  put (Node node) = putWord8 1 <> put node+  get = getWord8 >>= \case+    0   -> Var <$> get+    1   -> Node <$> get+    tag -> fail ("unknown AST tag " <> show tag)

@@ -0,0 +1,105 @@+{-# LANGUAGE TemplateHaskell #-}+-- | Derive the 'Binary' instance a client's pattern (binder) type needs,+-- alongside the hand-written instances of "Control.Monad.Free.Foil.Binary".+--+-- A pattern type is a GADT over two scope indices, so its instance cannot+-- come from "GHC.Generics". What the deriver writes is the shape one would+-- write by hand: one tag byte per constructor in declaration order, then+-- the fields in order. Decoding happens /at the diagonal/, with every+-- scope index of a constructor instantiated to the same variable, which any+-- chain of binder indices admits. A single coercion then moves the result to+-- the requested indices. That coercion mints scope evidence, so a derived+-- instance is part of the same trust boundary as the library's own. See the+-- module documentation of "Control.Monad.Free.Foil.Binary".+module Control.Monad.Free.Foil.Binary.TH (deriveBinaryPattern) where++import           Control.Monad       (unless, zipWithM)+import           Data.Binary         (Binary (..))+import           Data.Binary.Get     (Get, getWord8)+import           Data.Binary.Put     (putWord8)+import qualified Data.Map            as Map+import           Language.Haskell.TH+import           Unsafe.Coerce       (unsafeCoerce)++-- | @'deriveBinaryPattern' ''Pattern@ writes+-- @instance (Binary p1, …) => Binary (Pattern p1 … n l)@ for a pattern+-- type of kind @… -> S -> S -> Type@ whose fields are parameters, name+-- binders, or nested patterns.+--+-- @since 0.4.0+deriveBinaryPattern :: Name -> Q [Dec]+deriveBinaryPattern tyName = do+  info <- reify tyName+  (tvs, cons) <- case info of+    TyConI (DataD _ _ tvs _ cons _)    -> pure (tvs, cons)+    TyConI (NewtypeD _ _ tvs _ con _)  -> pure (tvs, [con])+    _ -> fail ("deriveBinaryPattern: " <> show tyName <> " is not a data type")+  unless (length tvs >= 2) $+    fail "deriveBinaryPattern: expected a type of kind ... -> S -> S -> Type"+  params <- mapM (\i -> newName ("p" <> show (i :: Int))) [1 .. length tvs - 2]+  nVar <- newName "n"+  lVar <- newName "l"+  ctors <- concat <$> mapM flatten cons+  unless (length ctors <= 256) $+    fail "deriveBinaryPattern: more than 256 constructors"+  putClauses <- zipWithM (putClause) [0 ..] ctors+  getMatches <- zipWithM (getMatch params nVar) [0 ..] ctors+  tagName <- newName "tag"+  let headTy = foldl AppT (ConT tyName) (map VarT (params <> [nVar, lVar]))+      context = [AppT (ConT ''Binary) (VarT p) | p <- params]+      failMatch = Match WildP+        (NormalB (AppE (VarE 'fail) (LitE (StringL "unknown pattern tag")))) []+      getBody = InfixE (Just (VarE 'getWord8)) (VarE '(>>=))+        (Just (LamE [VarP tagName]+          (CaseE (VarE tagName) (getMatches <> [failMatch]))))+  pure+    [ InstanceD Nothing context (AppT (ConT ''Binary) headTy)+        [ FunD 'put putClauses+        , ValD (VarP 'get) (NormalB getBody) []+        ]+    ]+  where+    flatten (ForallC _ _ con)   = flatten con+    flatten (GadtC names bts t) = pure [(c, map snd bts, t) | c <- names]+    flatten _ =+      fail "deriveBinaryPattern: expected GADT constructors (a pattern's indices vary per constructor)"++    putClause tag (cname, fields, _) = do+      args <- mapM (\i -> newName ("x" <> show (i :: Int))) [1 .. length fields]+      let puts = AppE (VarE 'putWord8) (LitE (IntegerL tag))+                   : [AppE (VarE 'put) (VarE a) | a <- args]+      pure (Clause [ConP cname [] (map VarP args)]+                   (NormalB (AppE (VarE 'mconcat) (ListE puts))) [])++    -- Decode at the diagonal: the constructor's own scope variables (the+    -- result indices and any intermediates) all become @n@, and its+    -- parameter variables become the instance's parameters. The chain of a+    -- pattern's indices always admits the diagonal. Each field's 'get' is+    -- annotated with the substituted type, pinning the intermediates.+    getMatch params nVar tag (cname, fields, result) = do+      let (_, resultArgs) = unfoldApps result+          paramPairs =+            [ (v, VarT p)+            | (VarT v, p) <- zip (take (length params) resultArgs) params ]+          subst = Map.fromList paramPairs+          substTy t = case t of+            VarT v    -> Map.findWithDefault (VarT nVar) v subst+            AppT f x  -> AppT (substTy f) (substTy x)+            SigT x k  -> SigT (substTy x) k+            ParensT x -> ParensT (substTy x)+            _         -> t+          getField ft = SigE (VarE 'get) (AppT (ConT ''Get) (substTy ft))+          chain = case fields of+            [] -> AppE (VarE 'pure) (ConE cname)+            (f : fs) -> foldl+              (\acc ft -> InfixE (Just acc) (VarE '(<*>)) (Just (getField ft)))+              (InfixE (Just (ConE cname)) (VarE '(<$>)) (Just (getField f)))+              fs+          diagTy = AppT (ConT ''Get) (substTy result)+          body = AppE (AppE (VarE 'fmap) (VarE 'unsafeCoerce)) (SigE chain diagTy)+      pure (Match (LitP (IntegerL tag)) (NormalB body) [])++    unfoldApps = go []+      where+        go args (AppT f x) = go (x : args) f+        go args t          = (t, args)

@@ -17,6 +17,8 @@ -- >>> import Control.Monad.Foil  -- | Untyped \(\lambda\)-terms in scope @n@.+--+-- @since 0.0.1 data ExprF scope term   -- | Application of one term to another: \((t_1, t_2)\)   = AppF term term@@ -25,14 +27,24 @@   deriving (Functor) deriveBifunctor ''ExprF +-- | Application of one term to another.+--+-- @since 0.0.1 pattern AppE :: AST binder ExprF n -> AST binder ExprF n -> AST binder ExprF n pattern AppE x y = Node (AppF x y) +-- | A \(\lambda\)-abstraction, binding a pattern in a term of the extended+-- scope.+--+-- @since 0.0.1 pattern LamE :: binder n l -> AST binder ExprF l -> AST binder ExprF n pattern LamE binder body = Node (LamF (ScopedAST binder body))  {-# COMPLETE Var, AppE, LamE #-} +-- | A scope-safe \(\lambda\)-term with one name per binder.+--+-- @since 0.0.1 type Expr = AST NameBinder ExprF  -- | Use 'ppExpr' to show \(\lambda\)-terms.@@ -43,6 +55,8 @@ -- -- >>> whnf emptyScope (AppE (churchN 2) (churchN 2)) -- λx1. (λx0. λx1. (x0 (x0 x1)) (λx0. λx1. (x0 (x0 x1)) x1))+--+-- @since 0.0.1 whnf :: Distinct n => Scope n -> Expr n -> Expr n whnf scope = \case   AppE fun arg ->@@ -57,6 +71,8 @@ -- -- >>> whnf' (AppE (churchN 2) (churchN 2)) -- λx1. (λx0. λx1. (x0 (x0 x1)) (λx0. λx1. (x0 (x0 x1)) x1))+--+-- @since 0.0.1 whnf' :: Expr VoidS -> Expr VoidS whnf' = whnf emptyScope @@ -64,6 +80,8 @@ -- -- >>> nf emptyScope (AppE (churchN 2) (churchN 2)) -- λx1. λx2. (x1 (x1 (x1 (x1 x2))))+--+-- @since 0.0.1 nf :: Distinct n => Scope n -> Expr n -> Expr n nf scope expr = case expr of   LamE binder body ->@@ -86,10 +104,14 @@ -- -- >>> nf' (AppE (churchN 2) (churchN 2)) -- λx1. λx2. (x1 (x1 (x1 (x1 x2))))+--+-- @since 0.0.1 nf' :: Expr VoidS -> Expr VoidS nf' = nf emptyScope  -- | Pretty print a name.+--+-- @since 0.0.1 ppName :: Name n -> String ppName name = "x" <> show (nameId name) @@ -97,6 +119,8 @@ -- -- >>> ppExpr (churchN 3) -- "\955x0. \955x1. (x0 (x0 (x0 x1)))"+--+-- @since 0.0.1 ppExpr :: Expr n -> String ppExpr = \case   Var name -> ppName name@@ -104,6 +128,8 @@   LamE binder body -> "λ" <> ppName (nameOf binder) <> ". " <> ppExpr body  -- | A helper for constructing \(\lambda\)-abstractions.+--+-- @since 0.0.1 lam :: Distinct n => Scope n -> (forall l. DExt n l => Scope l -> NameBinder n l -> Expr l) -> Expr n lam scope mkBody = withFresh scope $ \x ->   let scope' = extendScope x scope@@ -116,6 +142,8 @@ -- -- >>> churchN 3 -- λx0. λx1. (x0 (x0 (x0 x1)))+--+-- @since 0.0.1 churchN :: Int -> Expr VoidS churchN n =   lam emptyScope $ \sx nx ->

@@ -12,6 +12,8 @@  -- | Generate helpers for conversion to scope-safe representation. -- Includes 'mkConvertToSig', 'mkGetPatternBinder', and 'mkGetScopedTerm'.+--+-- @since 0.0.3 mkConvertToFreeFoil   :: Name -- ^ Type name for raw terms.   -> Name -- ^ Type name for raw variable identifiers.@@ -26,6 +28,8 @@  -- | Generate helpers for conversion from scope-safe representation. -- Includes 'mkConvertFromSig'.+--+-- @since 0.0.3 mkConvertFromFreeFoil   :: Name -- ^ Type name for raw terms.   -> Name -- ^ Type name for raw variable identifiers.@@ -39,6 +43,8 @@ -- * Individual generators  -- | Generate conversion helper that goes unpeels one node from a raw term.+--+-- @since 0.0.3 mkConvertToSig   :: Name -- ^ Type name for raw terms.   -> Name -- ^ Type name for raw variable identifiers.@@ -109,6 +115,8 @@           ]  -- | Generate conversion helper that peels back one node to a raw term.+--+-- @since 0.0.3 mkConvertFromSig   :: Name -- ^ Type name for raw terms.   -> Name -- ^ Type name for raw variable identifiers.@@ -169,6 +177,8 @@           ]  -- | Generate a helper that extracts at most one binder from a pattern.+--+-- @since 0.0.3 mkGetPatternBinder   :: Name -- ^ Type name for raw variable identifiers.   -> Name -- ^ Type name for raw patterns.@@ -221,6 +231,8 @@           ]  -- | Generate a helper that extracts a term from a scoped term.+--+-- @since 0.0.3 mkGetScopedTerm   :: Name -- ^ Type name for raw terms.   -> Name -- ^ Type name for raw scoped terms.

@@ -20,8 +20,9 @@ import           Control.Monad.Foil.TH.Util import qualified Control.Monad.Free.Foil    as Foil import           Data.Bifunctor+import           Data.Char                  (toUpper) import           Data.List                  (find, unzip4, (\\), nub)-import           Data.Maybe                 (catMaybes, listToMaybe, mapMaybe,+import           Data.Maybe                 (fromMaybe, isJust, catMaybes, listToMaybe, mapMaybe,                                              maybeToList) import Data.Map (Map) import qualified Data.Map as Map@@ -30,6 +31,8 @@ -- | Config for the Template Haskell generation of data types, -- pattern synonyms, and conversion functions for the Free Foil representation, -- based on a raw recursive representation.+--+-- @since 0.2.0 data FreeFoilConfig = FreeFoilConfig   { rawQuantifiedNames        :: [Name]   -- ^ Names of raw types that may include other binders and terms as components.@@ -65,6 +68,8 @@ -- for the Template Haskell generation of data types, -- pattern synonyms, and conversion functions for the Free Foil representation, -- based on a raw recursive representation.+--+-- @since 0.2.0 data FreeFoilTermConfig = FreeFoilTermConfig   { rawIdentName          :: Name     -- ^ The type name for the identifiers.@@ -108,6 +113,11 @@     -- Normally, this is something like @(\(ScopedTerm term) -> term)@.   } +-- | Capitalize the first letter, so that @toTerm'@ gives @tryToTerm'@.+capitalizeFirst :: String -> String+capitalizeFirst []       = []+capitalizeFirst (c : cs) = toUpper c : cs+ toFreeFoilName :: FreeFoilConfig -> Name -> Name toFreeFoilName FreeFoilConfig{..} name = mkName (freeFoilNameModifier (nameBase name)) @@ -117,6 +127,16 @@ toFreeFoilNameTo :: FreeFoilConfig -> Name -> Name toFreeFoilNameTo FreeFoilConfig{..} name = mkName (freeFoilConvertToName (nameBase name)) +-- | The name of the range-parametric sibling of a generated definition+-- (see 'Foil.withFreshIn'): @toPatternIn@ beside @toPattern@.+toNameIn :: Name -> Name+toNameIn name = mkName (nameBase name ++ "In")++-- | The name of the naming-parametric sibling of a generated definition:+-- @fromPatternWith@ beside @fromPattern@.+toNameWith :: Name -> Name+toNameWith name = mkName (nameBase name ++ "With")+ toFreeFoilScopedName :: FreeFoilConfig -> Name -> Name toFreeFoilScopedName FreeFoilConfig{..} name = mkName (freeFoilScopeNameModifier (nameBase name)) @@ -351,6 +371,167 @@   PeelConT typeName _ | Just _ <- lookupScopeName typeName freeFoilTermConfigs -> True   _ -> False +-- | What a raw binding constructor's field becomes in the scope-safe binding+-- type. Mirrors the classification in 'toFreeFoilBindingCon': an identifier+-- becomes a 'Foil.NameBinder' and threads the scope; a binding type becomes a+-- nested binding type and threads the scope; anything else is a payload that+-- binds nothing.+data BindingFieldSort = FieldBinder | FieldPattern | FieldPayload+  deriving (Eq)++bindingFieldSortOf :: FreeFoilConfig -> Type -> BindingFieldSort+bindingFieldSortOf FreeFoilConfig{..} = \case+  PeelConT typeName _typeParams+    | typeName `elem` map rawIdentName freeFoilTermConfigs -> FieldBinder+    | Just _ <- lookupBindingName typeName freeFoilTermConfigs -> FieldPattern+  _ -> FieldPayload++-- | Does this field introduce binders (and so thread the scope)?+isBindingFieldSort :: BindingFieldSort -> Bool+isBindingFieldSort = \case+  FieldPayload -> False+  _ -> True++-- | Does this raw payload type mention anything that converts to a+-- scope-indexed type in the binding type (a term, a scoped term, an+-- identifier, or a nested binding under a type constructor)? Such a payload+-- cannot be rebuilt by the generated 'Foil.CoSinkable' instance, rebuilding it+-- at another scope being what 'Foil.transportPayload' exists for. Generation+-- refuses such a payload, matching the GenericK-side refusal for derived+-- patterns.+mentionsScopeIndexed :: FreeFoilConfig -> Type -> Bool+mentionsScopeIndexed FreeFoilConfig{..} = go+  where+    isIndexedName typeName = or+      [ typeName `elem` rawQuantifiedNames+      , typeName `elem` map rawIdentName freeFoilTermConfigs+      , isJust (lookupTermName typeName freeFoilTermConfigs)+      , isJust (lookupSubTermName typeName freeFoilTermConfigs)+      , isJust (lookupScopeName typeName freeFoilTermConfigs)+      , isJust (lookupSubScopeName typeName freeFoilTermConfigs)+      , isJust (lookupBindingName typeName freeFoilTermConfigs)+      ]+    go = \case+      PeelConT typeName typeParams -> isIndexedName typeName || any go typeParams+      AppT f x -> go f || go x+      SigT t _ -> go t+      ParensT t -> go t+      _ -> False++-- | The constructors of a raw type as (name, field types), with every+-- constructor syntax flattened to the same shape.+flattenCons :: [Con] -> [(Name, [Type])]+flattenCons = concatMap go+  where+    go = \case+      NormalC name types -> [(name, map snd types)]+      RecC name types -> [(name, map (\(_, _, t) -> t) types)]+      InfixC l name r -> [(name, [snd l, snd r])]+      GadtC names types _retType -> [ (name, map snd types) | name <- names ]+      RecGadtC names types _retType -> [ (name, map (\(_, _, t) -> t) types) | name <- names ]+      ForallC _ _ con -> go con++-- | One 'Foil.coSinkabilityProof' clause for a generated binding constructor:+--+-- > coSinkabilityProof rename (Con x1 x2 x3) cont =+-- >   coSinkabilityProof rename x1 $ \rename' x1' ->+-- >     coSinkabilityProof rename' x2 $ \rename'' x2' ->+-- >       cont rename'' (Con x1' x2' x3)+--+-- Binder and nested-pattern fields thread the renaming left to right (each via+-- its own 'Foil.CoSinkable' instance); payload fields pass through untouched.+mkCoSinkabilityProofClause :: FreeFoilConfig -> (Name, [Type]) -> Q Clause+mkCoSinkabilityProofClause config (rawConName, rawFieldTypes) = do+  let conName = toConName config rawConName+      sorts = map (bindingFieldSortOf config) rawFieldTypes+      -- Underscore-prefix the binders the clause will not use, so that the+      -- generated code triggers no -Wunused-matches in the client module.+      hasBinding = any isBindingFieldSort sorts+  rename <- newName (if hasBinding then "rename" else "_rename")+  cont <- newName "cont"+  xs <- mapM (\i -> newName ("x" <> show i)) [1 .. length sorts]+  -- fields collects the rebuilt constructor arguments in order (as a+  -- difference list, since each step appends on the right).+  let go renameCur [] fields =+        return (VarE cont `AppE` VarE renameCur+                  `AppE` foldl AppE (ConE conName) (fields []))+      go renameCur ((FieldPayload, x) : rest) fields =+        go renameCur rest (fields . (VarE x :))+      go renameCur ((_, x) : rest) fields = do+        x' <- newName (nameBase x <> "'")+        renameNext <- newName "rename'"+        body <- go renameNext rest (fields . (VarE x' :))+        return (VarE 'Foil.coSinkabilityProof `AppE` VarE renameCur `AppE` VarE x+                  `AppE` LamE [VarP renameNext, VarP x'] body)+  body <- go rename (zip sorts xs) id+  return (Clause [VarP rename, ConP conName [] (map VarP xs), VarP cont] (NormalB body) [])++-- | One 'Foil.withPattern' clause for a generated binding constructor:+--+-- > withPattern withBinder unit_ comp_ scope (Con x1 x2 x3) cont =+-- >   withBinder scope x1 $ \f1 x1' ->+-- >     let scope' = extendScope x1' scope+-- >     in withPattern withBinder unit_ comp_ scope' x2 $ \f2 x2' scope'' ->+-- >          cont (comp_ f1 f2) (Con x1' x2' x3) scope''+--+-- A 'Foil.NameBinder' field is processed with @withBinder@ directly and+-- extends the ambient scope for the fields to its right; a nested binding+-- field recurses through its own 'Foil.withPattern', which hands the extended+-- scope to its continuation. Results compose left to right with @comp_@; the+-- final continuation receives the scope after the whole constructor, and a+-- constructor that binds nothing hands @unit_@ and the ambient scope over.+mkWithPatternClause :: FreeFoilConfig -> (Name, [Type]) -> Q Clause+mkWithPatternClause config (rawConName, rawFieldTypes) = do+  let conName = toConName config rawConName+      sorts = map (bindingFieldSortOf config) rawFieldTypes+      -- Underscore-prefix the binders the clause will not use, so that the+      -- generated code triggers no -Wunused-matches in the client module: a+      -- nested binding field keeps everything alive (its recursive call takes+      -- unit_ and comp_ along), otherwise usage depends on how many fields+      -- bind at all.+      nBinding = length (filter isBindingFieldSort sorts)+      hasNested = FieldPattern `elem` sorts+      usedIf b n = if b then n else '_' : n+  withBinder <- newName (usedIf (nBinding > 0) "withBinder")+  unit_ <- newName (usedIf (nBinding == 0 || hasNested) "unit_")+  comp_ <- newName (usedIf (nBinding >= 2 || hasNested) "comp_")+  scope <- newName "scope"+  cont <- newName "cont"+  xs <- mapM (\i -> newName ("x" <> show i)) [1 .. length sorts]+  -- acc is the composition of the binder results so far (Nothing before the+  -- first one), composed left to right as each field is passed; fields+  -- collects the rebuilt constructor arguments in order (as a difference+  -- list, since each step appends on the right).+  let go scopeCur acc [] fields =+        return (VarE cont `AppE` fromMaybe (VarE unit_) acc+                  `AppE` foldl AppE (ConE conName) (fields [])+                  `AppE` VarE scopeCur)+      go scopeCur acc ((FieldPayload, x) : rest) fields =+        go scopeCur acc rest (fields . (VarE x :))+      go scopeCur acc ((sort, x) : rest) fields = do+        x' <- newName (nameBase x <> "'")+        f <- newName "f"+        scopeNext <- newName "scope'"+        let acc' = case acc of+              Nothing -> VarE f+              Just a  -> VarE comp_ `AppE` a `AppE` VarE f+        body <- go scopeNext (Just acc') rest (fields . (VarE x' :))+        return $ case sort of+          FieldBinder ->+            VarE withBinder `AppE` VarE scopeCur `AppE` VarE x+              `AppE` LamE [VarP f, VarP x']+                  (LetE [ValD (VarP scopeNext)+                           (NormalB (VarE 'Foil.extendScope `AppE` VarE x' `AppE` VarE scopeCur)) []]+                     body)+          _ ->+            VarE 'Foil.withPattern `AppE` VarE withBinder `AppE` VarE unit_+              `AppE` VarE comp_ `AppE` VarE scopeCur `AppE` VarE x+              `AppE` LamE [VarP f, VarP x', VarP scopeNext] body+  body <- go scope Nothing (zip sorts xs) id+  return (Clause+    [VarP withBinder, VarP unit_, VarP comp_, VarP scope, ConP conName [] (map VarP xs), VarP cont]+    (NormalB body) [])+ termConToPat :: Name -> FreeFoilConfig -> FreeFoilTermConfig -> Con -> Q [([Name], Pat, Pat, [Exp])] termConToPat rawTypeName config@FreeFoilConfig{..} FreeFoilTermConfig{..} = go   where@@ -446,8 +627,8 @@       ForallC _params _ctx con -> go con       RecGadtC conNames argTypes retType -> go (GadtC conNames (map removeName argTypes) retType) -termConToPatBinding :: Name -> FreeFoilConfig -> FreeFoilTermConfig -> Con -> Q [([Name], Pat, Pat, [Exp])]-termConToPatBinding rawTypeName config@FreeFoilConfig{..} FreeFoilTermConfig{..} = go+termConToPatBinding :: Name -> Name -> FreeFoilConfig -> FreeFoilTermConfig -> Con -> Q [([Name], Pat, Pat, [Exp])]+termConToPatBinding named rawTypeName config@FreeFoilConfig{..} FreeFoilTermConfig{..} = go   where     rawRetType = error "impossible happened!" @@ -456,11 +637,11 @@       PeelConT typeName _params         | typeName == rawIdentName -> do             x <- newName "x"-            return ([x], [VarP x], [VarP x], [VarE intToRawIdentName `AppE` (VarE 'Foil.nameId `AppE` (VarE 'Foil.nameOf `AppE` VarE x))])+            return ([x], [VarP x], [VarP x], [VarE named `AppE` (VarE 'Foil.nameId `AppE` (VarE 'Foil.nameOf `AppE` VarE x))])         | Just _ <- lookupBindingName typeName freeFoilTermConfigs -> do-            let funName = toFreeFoilNameFrom config typeName+            let funName = toNameWith (toFreeFoilNameFrom config typeName)             x <- newName "x"-            return ([x], [VarP x], [VarP x], [VarE funName `AppE` VarE x])+            return ([x], [VarP x], [VarP x], [VarE funName `AppE` VarE named `AppE` VarE x])         | Just _ <- lookupScopeName typeName freeFoilTermConfigs -> do             binder <- newName "binder"             body <- newName "body"@@ -662,15 +843,15 @@       ForallC _params _ctx con -> go con       RecGadtC conNames argTypes retType -> go (GadtC conNames (map removeName argTypes) retType) -toFreeFoilClauseFromBinding :: FreeFoilConfig -> FreeFoilTermConfig -> Type -> Con -> Q [Clause]-toFreeFoilClauseFromBinding config termConfig@FreeFoilTermConfig{..} rawRetType = go+toFreeFoilClauseFromBinding :: Name -> FreeFoilConfig -> FreeFoilTermConfig -> Type -> Con -> Q [Clause]+toFreeFoilClauseFromBinding named config termConfig@FreeFoilTermConfig{..} rawRetType = go   where     go = \case       GadtC conNames rawArgTypes rawRetType' -> concat <$> do         forM (conNames \\ [rawVarConName]) $ \conName -> do-          [(_vars, _pat, pat, exps)] <- termConToPatBinding rawBindingName config termConfig+          [(_vars, _pat, pat, exps)] <- termConToPatBinding named rawBindingName config termConfig             (GadtC [conName] rawArgTypes rawRetType')    -- FIXME: unsafe matching!-          return [ Clause [pat] (NormalB (foldl AppE (ConE conName) exps)) [] ]+          return [ Clause [VarP named, pat] (NormalB (foldl AppE (ConE conName) exps)) [] ]        NormalC conName types -> go (GadtC [conName] types rawRetType)       RecC conName types -> go (NormalC conName (map removeName types))@@ -701,10 +882,13 @@ --  3. Scope-safe patterns. --  4. Signatures for terms, subterms, and scoped subterms. --  5. Pattern synonyms for terms, subterms, and scoped subterms.+--+-- @since 0.2.0 mkFreeFoil :: FreeFoilConfig -> Q [Dec] mkFreeFoil config@FreeFoilConfig{..} = concat <$> sequence   [ mapM mkQuantifiedType rawQuantifiedNames   , mapM mkBindingType freeFoilTermConfigs+  , concat <$> mapM mkPatternCoSinkable freeFoilTermConfigs   , concat <$> mapM mkSignatureTypes freeFoilTermConfigs   , concat <$> mapM mkPatternSynonyms freeFoilTermConfigs   ]@@ -750,6 +934,36 @@         ("/Generated/ with '" ++ show 'mkFreeFoil ++ "'. A binding type, scope-safe version of '" ++ show rawBindingName ++ "'.")       return (DataD [] bindingName newParams Nothing newCons []) +    -- A concrete 'Foil.CoSinkable' instance for the generated binding type,+    -- one clause per constructor, delegating to the fields' instances. The+    -- GenericK default routes every binder operation through a generic+    -- representation traversal, which costs a measurable constant per binder+    -- at runtime (see issue #82); the concrete instance removes it, and a+    -- client no longer declares (or hand-writes) the instance itself.+    mkPatternCoSinkable FreeFoilTermConfig{..} = do+      (tvars, cons) <- reifyDataOrNewtype rawBindingName+      let bindingName = toFreeFoilName config rawBindingName+          bindingT = PeelConT bindingName (map (VarT . tvarName) tvars)+          flatCons = flattenCons cons+      forM_ flatCons $ \(conName, fieldTypes) ->+        forM_ fieldTypes $ \fieldType ->+          case bindingFieldSortOf config fieldType of+            FieldPayload | mentionsScopeIndexed config fieldType -> fail $ unlines+              [ "mkFreeFoil: cannot generate a CoSinkable instance for " <> show bindingName+              , "  constructor " <> show conName <> " has a payload of raw type " <> pprint fieldType+              , "  which becomes scope-indexed; write the instance by hand"+              , "  (transportPayload is the sanctioned way to rebuild such a field)"+              ]+            _ -> return ()+      coSinkClauses <- mapM (mkCoSinkabilityProofClause config) flatCons+      withPatClauses <- mapM (mkWithPatternClause config) flatCons+      return+        [ InstanceD Nothing [] (AppT (ConT ''Foil.CoSinkable) bindingT)+            [ FunD 'Foil.coSinkabilityProof coSinkClauses+            , FunD 'Foil.withPattern withPatClauses+            ]+        ]+     mkSignatureTypes termConfig@FreeFoilTermConfig{..} = do       sig <- mkSignatureType termConfig rawTermName       subsigs <- concat <$> mapM (mkSignatureType termConfig) (rawSubTermNames <> rawSubScopeNames)@@ -805,6 +1019,8 @@ --  2. Conversions for scope-safe terms, scoped terms, subterms, scoped subterms. --  3. CPS-style conversions for scope-safe patterns. --  4. Helpers for signatures of terms, subterms, and scoped subterms.+--+-- @since 0.2.0 mkFreeFoilConversions :: FreeFoilConfig -> Q [Dec] mkFreeFoilConversions config@FreeFoilConfig{..} = concat <$> sequence   [ concat <$> mapM mkConvertFrom freeFoilTermConfigs@@ -907,15 +1123,24 @@      mkConvertFromBinding termConfig@FreeFoilTermConfig{..} = do       (tvars, cons) <- reifyDataOrNewtype rawBindingName+      (itvars, _cons) <- reifyDataOrNewtype rawIdentName+      named <- newName "_named"       let funName = toFreeFoilNameFrom config rawBindingName+          funWithName = toNameWith funName           rawRetType = PeelConT rawBindingName (map (VarT . tvarName) tvars)+          rawIdentType = PeelConT rawIdentName (map (VarT . tvarName) (take (length itvars) tvars)) -- FIXME: undocumented hack :(           bindingType = toFreeFoilType SortBinder config (VarT outerScope) (VarT innerScope) rawRetType-      clauses <- concat <$> mapM (toFreeFoilClauseFromBinding config termConfig rawRetType) cons+      clauses <- concat <$> mapM (toFreeFoilClauseFromBinding named config termConfig rawRetType) cons+      addModFinalizer $ putDoc (DeclDoc funWithName)+        ("/Generated/ with '" ++ show 'mkFreeFoil ++ "'. Convert a scope-safe to a raw binding, naming the binders from their indices with the given function. The same function must name the bound-variable references, or a reference comes out free of its own binder.")       addModFinalizer $ putDoc (DeclDoc funName)-        ("/Generated/ with '" ++ show 'mkFreeFoil ++ "'. Convert a scope-safe to a raw binding.")+        ("/Generated/ with '" ++ show 'mkFreeFoil ++ "'. Convert a scope-safe to a raw binding, with the display naming.")       return-        [ SigD funName (bindingType --> rawRetType)-        , FunD funName clauses ]+        [ SigD funWithName ((ConT ''Int --> rawIdentType) --> bindingType --> rawRetType)+        , FunD funWithName clauses+        , SigD funName (bindingType --> rawRetType)+        , FunD funName [ Clause [] (NormalB (VarE funWithName `AppE` VarE intToRawIdentName)) [] ]+        ]      mkConvertTo termConfig@FreeFoilTermConfig{..} = concat <$> sequence       [ mkConvertToSig SortTerm termConfig rawTermName@@ -961,25 +1186,67 @@           funBindingName = toFreeFoilNameTo config rawBindingName           rawTermType = PeelConT rawTermName (map (VarT . tvarName) tvars)           termType =  toFreeFoilType SortTerm config (VarT outerScope) (VarT innerScope) rawTermType+          tryFunName = mkName ("try" ++ capitalizeFirst (nameBase funName))+          tryWithFunName = mkName (nameBase tryFunName ++ "With")+          unresolvedType = ConT ''Foil.UnresolvedName `AppT` rawIdentType+          tryTermType = ConT ''Either `AppT` unresolvedType `AppT` termType+          convertArgs f = VarE f+            `AppE` VarE funSigName+            `AppE` VarE funBindingName+            `AppE` VarE rawScopeToTermName+          convertArgsIn f range = VarE f+            `AppE` VarE funSigName+            `AppE` (VarE (toNameIn funBindingName) `AppE` VarE range)+            `AppE` VarE rawScopeToTermName       addModFinalizer $ putDoc (DeclDoc funName)-        ("/Generated/ with '" ++ show 'mkFreeFoil ++ "'. Convert from scope-safe to raw representation.")-      return-        [ SigD funName $+        ("/Generated/ with '" ++ show 'mkFreeFoil ++ "'. Convert from raw to scope-safe representation, calling 'error' on an identifier that does not resolve. See '" ++ nameBase tryFunName ++ "'.")+      addModFinalizer $ putDoc (DeclDoc tryFunName)+        ("/Generated/ with '" ++ show 'mkFreeFoil ++ "'. Convert from raw to scope-safe representation, reporting the first identifier that does not resolve.")+      addModFinalizer $ putDoc (DeclDoc tryWithFunName)+        ("/Generated/ with '" ++ show 'mkFreeFoil ++ "'. Same as '" ++ nameBase tryFunName ++ "', except that some identifiers may resolve to a whole term rather than to a variable.")+      range <- newName "range"+      let mkSig body =             ForallT               (PlainTV outerScope SpecifiedSpec : map (SpecifiedSpec <$) tvars)               [ ConT ''Foil.Distinct `AppT` VarT outerScope-              , ConT ''Ord `AppT` rawIdentType ] $+              , ConT ''Ord `AppT` rawIdentType ]+              body+          plainSigTail =                 (ConT ''Foil.Scope `AppT` VarT outerScope)                 --> (ConT ''Map `AppT` rawIdentType `AppT` (ConT ''Foil.Name `AppT` VarT outerScope))                 --> rawTermType                 --> termType-        , FunD funName [-            Clause [] (NormalB-              (VarE 'Foil.convertToAST-                `AppE` VarE funSigName-                `AppE` VarE funBindingName-                `AppE` VarE rawScopeToTermName)) []+          trySigTail =+                (ConT ''Foil.Scope `AppT` VarT outerScope)+                --> (ConT ''Map `AppT` rawIdentType `AppT` (ConT ''Foil.Name `AppT` VarT outerScope))+                --> rawTermType+                --> tryTermType+          tryWithSigTail =+                (ConT ''Foil.Scope `AppT` VarT outerScope)+                --> (ConT ''Map `AppT` rawIdentType `AppT` (ConT ''Foil.Name `AppT` VarT outerScope))+                --> (ConT ''Map `AppT` rawIdentType `AppT` termType)+                --> rawTermType+                --> tryTermType+      forM_ [funName, tryFunName, tryWithFunName] $ \name ->+        addModFinalizer $ putDoc (DeclDoc (toNameIn name))+          ("/Generated/ with '" ++ show 'mkFreeFoil ++ "'. Same as '" ++ nameBase name ++ "', except that the binders introduced by the conversion are allocated within the given range; see 'Foil.withFreshIn'.")+      return $+        [ SigD funName (mkSig plainSigTail)+        , FunD funName [ Clause [] (NormalB (convertArgs 'Foil.unsafeConvertToAST)) [] ]+        , SigD tryFunName (mkSig trySigTail)+        , FunD tryFunName [ Clause [] (NormalB (convertArgs 'Foil.tryConvertToAST)) [] ]+        , SigD tryWithFunName (mkSig tryWithSigTail)+        , FunD tryWithFunName [ Clause [] (NormalB (convertArgs 'Foil.tryConvertToASTWith)) [] ]+        ] ++ concat+        [ [ SigD inName (mkSig (ConT ''Foil.NameRange --> sigTail))+          , FunD inName [ Clause [VarP range] (NormalB (convertArgsIn f range)) [] ]           ]+        | (name, sigTail, f) <-+            [ (funName, plainSigTail, 'Foil.unsafeConvertToAST)+            , (tryFunName, trySigTail, 'Foil.tryConvertToAST)+            , (tryWithFunName, tryWithSigTail, 'Foil.tryConvertToASTWith)+            ]+        , let inName = toNameIn name         ]      mkConvertToSig sort termConfig@FreeFoilTermConfig{..} rawName = do@@ -1015,14 +1282,8 @@           safeType = toFreeFoilType SortBinder config (VarT outerScope) (VarT innerScope) rawBindingType       clauses <- concat <$> mapM (bindingConToClause rawBindingType config termConfig) cons       r <- newName "r"-      addModFinalizer $ putDoc (DeclDoc funName)-        ("/Generated/ with '" ++ show 'mkFreeFoil ++ "'. Convert from raw to scope-safe binding (CPS-style).")-      return-        [ SigD funName $-            ForallT-              (PlainTV outerScope SpecifiedSpec : map (SpecifiedSpec <$) tvars ++ [PlainTV r SpecifiedSpec])-              [ ConT ''Foil.Distinct `AppT` VarT outerScope-              , ConT ''Ord `AppT` rawIdentType ] $+      let funInName = toNameIn funName+          bindingSigTail =                 (ConT ''Foil.Scope `AppT` VarT outerScope)                 --> (ConT ''Map `AppT` rawIdentType `AppT` (ConT ''Foil.Name `AppT` VarT outerScope))                 --> rawBindingType@@ -1032,7 +1293,22 @@                         --> (ConT ''Map `AppT` rawIdentType `AppT` (ConT ''Foil.Name `AppT` VarT innerScope))                         --> VarT r)                 --> VarT r-        , FunD funName clauses ]+          bindingForall body =+            ForallT+              (PlainTV outerScope SpecifiedSpec : map (SpecifiedSpec <$) tvars ++ [PlainTV r SpecifiedSpec])+              [ ConT ''Foil.Distinct `AppT` VarT outerScope+              , ConT ''Ord `AppT` rawIdentType ]+              body+      addModFinalizer $ putDoc (DeclDoc funInName)+        ("/Generated/ with '" ++ show 'mkFreeFoil ++ "'. Convert from raw to scope-safe binding (CPS-style), allocating the binders within a given range; see 'Foil.withFreshIn'.")+      addModFinalizer $ putDoc (DeclDoc funName)+        ("/Generated/ with '" ++ show 'mkFreeFoil ++ "'. Convert from raw to scope-safe binding (CPS-style). This is '" ++ nameBase funInName ++ "' at 'Foil.fullNameRange'.")+      return+        [ SigD funInName (bindingForall (ConT ''Foil.NameRange --> bindingSigTail))+        , FunD funInName clauses+        , SigD funName (bindingForall bindingSigTail)+        , FunD funName [ Clause [] (NormalB (VarE funInName `AppE` VarE 'Foil.fullNameRange)) [] ]+        ]      mkConvertToQuantified rawName = do       (tvars, cons) <- reifyDataOrNewtype rawName@@ -1230,18 +1506,18 @@ bindingConToClause :: Type -> FreeFoilConfig -> FreeFoilTermConfig -> Con -> Q [Clause] bindingConToClause rawType config FreeFoilTermConfig{..} = go   where-    goArgTypes :: Name -> Name -> [Type] -> Q ([Pat], [Exp], Exp -> Exp, Name)-    goArgTypes _scope env [] = return ([], [], id, env)-    goArgTypes scope env (t:ts) = case t of+    goArgTypes :: Name -> Name -> Name -> [Type] -> Q ([Pat], [Exp], Exp -> Exp, Name)+    goArgTypes _range _scope env [] = return ([], [], id, env)+    goArgTypes range scope env (t:ts) = case t of       PeelConT typeName _params         | typeName == rawIdentName -> do             x <- newName "_x"             x' <- newName "_x'"             scope' <- newName "_scope"             env' <- newName "_env"-            (pats, exps, wrap, env'') <- goArgTypes scope' env' ts+            (pats, exps, wrap, env'') <- goArgTypes range scope' env' ts             return (VarP x : pats, VarE x' : exps, \e ->-              VarE 'Foil.withFresh `AppE` VarE scope `AppE`+              VarE 'Foil.withFreshIn `AppE` VarE range `AppE` VarE scope `AppE`                 LamE [VarP x']                   (LetE [ ValD (VarP scope') (NormalB (VarE 'Foil.extendScope `AppE` VarE x' `AppE` VarE scope)) []                         , ValD (VarP env') (NormalB (VarE 'Map.insert `AppE` VarE x `AppE` (VarE 'Foil.nameOf `AppE` VarE x') `AppE` (VarE 'fmap `AppE` VarE 'Foil.sink `AppE` VarE env))) []]@@ -1251,29 +1527,30 @@             x' <- newName "_x'"             scope' <- newName "_scope"             env' <- newName "_env"-            let funName = toFreeFoilNameTo config typeName-            (pats, exps, wrap, env'') <- goArgTypes scope' env' ts+            let funName = toNameIn (toFreeFoilNameTo config typeName)+            (pats, exps, wrap, env'') <- goArgTypes range scope' env' ts             return (VarP x : pats, VarE x' : exps, \e ->-              VarE funName `AppE` VarE scope `AppE` VarE env `AppE` VarE x `AppE`+              VarE funName `AppE` VarE range `AppE` VarE scope `AppE` VarE env `AppE` VarE x `AppE`                 LamE [VarP x', VarP env']                   (LetE [ ValD (VarP scope') (NormalB (VarE 'Foil.extendScopePattern `AppE` VarE x' `AppE` VarE scope)) []]                     (wrap e)), env'')       _ -> do         x <- newName "_x"-        (pats, exps, wrap, env') <- goArgTypes scope env ts+        (pats, exps, wrap, env') <- goArgTypes range scope env ts         return (VarP x : pats, VarE x : exps, wrap, env')      go :: Con -> Q [Clause]     go = \case       GadtC conNames rawArgTypes _rawRetType -> concat <$> do+        range <- newName "_range"         scope <- newName "_scope"         env <- newName "_env"         cont <- newName "_cont"         forM conNames $ \conName -> do           let newConName = toConName config conName-          (pats, exps, wrap, env') <- goArgTypes scope env (map snd rawArgTypes)+          (pats, exps, wrap, env') <- goArgTypes range scope env (map snd rawArgTypes)           return-            [ Clause [VarP scope, VarP env, ConP conName [] pats, VarP cont]+            [ Clause [VarP range, VarP scope, VarP env, ConP conName [] pats, VarP cont]                 (NormalB (wrap (VarE cont `AppE` foldl AppE (ConE newConName) exps `AppE` VarE env'))) [] ]       NormalC conName types -> go (GadtC [conName] types rawType)       RecC conName types -> go (NormalC conName (map removeName types))