{-# OPTIONS_GHC -Wno-missing-methods #-}  -- disabled to avoid overlapping type instances
{-# OPTIONS_GHC -Wno-overlapping-patterns -Wno-inaccessible-code #-}  -- disabled because I think GHC is wrong
{-# LANGUAGE AllowAmbiguousTypes        #-}
{-# LANGUAGE BlockArguments             #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE EmptyCase                  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE InstanceSigs               #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE QuantifiedConstraints      #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# LANGUAGE DefaultSignatures          #-}
-- | Main definitions of the foil that can be
-- reused for specific implementations.
-- This is an internal module, so it also contains implementation details of the foil.
--
-- The original description of this approach
-- is described in the IFL 2022 paper by Maclaurin, Radul, and Paszke
-- [«The Foil: Capture-Avoiding Substitution With No Sharp Edges»](https://doi.org/10.1145/3587216.3587224).
-- This module also introduces 'CoSinkable' class,
-- generalizing handling of patterns, as described in
-- [«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.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 Scope n -> ()
(Scope n -> ()) -> NFData (Scope n)
forall a. (a -> ()) -> NFData a
forall (n :: S). Scope n -> ()
$crnf :: forall (n :: S). Scope n -> ()
rnf :: Scope n -> ()
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 (Name n -> ()
(Name n -> ()) -> NFData (Name n)
forall a. (a -> ()) -> NFData a
forall (n :: S). Name n -> ()
$crnf :: forall (n :: S). Name n -> ()
rnf :: Name n -> ()
NFData, Name n -> Name n -> Bool
(Name n -> Name n -> Bool)
-> (Name n -> Name n -> Bool) -> Eq (Name n)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (n :: S). Name n -> Name n -> Bool
$c== :: forall (n :: S). Name n -> Name n -> Bool
== :: Name n -> Name n -> Bool
$c/= :: forall (n :: S). Name n -> Name n -> Bool
/= :: Name n -> Name n -> Bool
Eq, Eq (Name n)
Eq (Name n) =>
(Name n -> Name n -> Ordering)
-> (Name n -> Name n -> Bool)
-> (Name n -> Name n -> Bool)
-> (Name n -> Name n -> Bool)
-> (Name n -> Name n -> Bool)
-> (Name n -> Name n -> Name n)
-> (Name n -> Name n -> Name n)
-> Ord (Name n)
Name n -> Name n -> Bool
Name n -> Name n -> Ordering
Name n -> Name n -> Name n
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (n :: S). Eq (Name n)
forall (n :: S). Name n -> Name n -> Bool
forall (n :: S). Name n -> Name n -> Ordering
forall (n :: S). Name n -> Name n -> Name n
$ccompare :: forall (n :: S). Name n -> Name n -> Ordering
compare :: Name n -> Name n -> Ordering
$c< :: forall (n :: S). Name n -> Name n -> Bool
< :: Name n -> Name n -> Bool
$c<= :: forall (n :: S). Name n -> Name n -> Bool
<= :: Name n -> Name n -> Bool
$c> :: forall (n :: S). Name n -> Name n -> Bool
> :: Name n -> Name n -> Bool
$c>= :: forall (n :: S). Name n -> Name n -> Bool
>= :: Name n -> Name n -> Bool
$cmax :: forall (n :: S). Name n -> Name n -> Name n
max :: Name n -> Name n -> Name n
$cmin :: forall (n :: S). Name n -> Name n -> Name n
min :: Name n -> Name n -> Name n
Ord, RawName -> Name n -> ShowS
[Name n] -> ShowS
Name n -> String
(RawName -> Name n -> ShowS)
-> (Name n -> String) -> ([Name n] -> ShowS) -> Show (Name n)
forall a.
(RawName -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
forall (n :: S). RawName -> Name n -> ShowS
forall (n :: S). [Name n] -> ShowS
forall (n :: S). Name n -> String
$cshowsPrec :: forall (n :: S). RawName -> Name n -> ShowS
showsPrec :: RawName -> Name n -> ShowS
$cshow :: forall (n :: S). Name n -> String
show :: Name n -> String
$cshowList :: forall (n :: S). [Name n] -> ShowS
showList :: [Name n] -> ShowS
Show)

-- | Convert 'Name' into an identifier.
-- This may be useful for printing and debugging.
--
-- @since 0.0.1
nameId :: Name l -> Id
nameId :: forall (l :: S). Name l -> RawName
nameId (UnsafeName RawName
i) = RawName
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 (NameBinder n l -> ()
(NameBinder n l -> ()) -> NFData (NameBinder n l)
forall a. (a -> ()) -> NFData a
forall (n :: S) (l :: S). NameBinder n l -> ()
$crnf :: forall (n :: S) (l :: S). NameBinder n l -> ()
rnf :: NameBinder n l -> ()
NFData, NameBinder n l -> NameBinder n l -> Bool
(NameBinder n l -> NameBinder n l -> Bool)
-> (NameBinder n l -> NameBinder n l -> Bool)
-> Eq (NameBinder n l)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (n :: S) (l :: S). NameBinder n l -> NameBinder n l -> Bool
$c== :: forall (n :: S) (l :: S). NameBinder n l -> NameBinder n l -> Bool
== :: NameBinder n l -> NameBinder n l -> Bool
$c/= :: forall (n :: S) (l :: S). NameBinder n l -> NameBinder n l -> Bool
/= :: NameBinder n l -> NameBinder n l -> Bool
Eq, Eq (NameBinder n l)
Eq (NameBinder n l) =>
(NameBinder n l -> NameBinder n l -> Ordering)
-> (NameBinder n l -> NameBinder n l -> Bool)
-> (NameBinder n l -> NameBinder n l -> Bool)
-> (NameBinder n l -> NameBinder n l -> Bool)
-> (NameBinder n l -> NameBinder n l -> Bool)
-> (NameBinder n l -> NameBinder n l -> NameBinder n l)
-> (NameBinder n l -> NameBinder n l -> NameBinder n l)
-> Ord (NameBinder n l)
NameBinder n l -> NameBinder n l -> Bool
NameBinder n l -> NameBinder n l -> Ordering
NameBinder n l -> NameBinder n l -> NameBinder n l
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (n :: S) (l :: S). Eq (NameBinder n l)
forall (n :: S) (l :: S). NameBinder n l -> NameBinder n l -> Bool
forall (n :: S) (l :: S).
NameBinder n l -> NameBinder n l -> Ordering
forall (n :: S) (l :: S).
NameBinder n l -> NameBinder n l -> NameBinder n l
$ccompare :: forall (n :: S) (l :: S).
NameBinder n l -> NameBinder n l -> Ordering
compare :: NameBinder n l -> NameBinder n l -> Ordering
$c< :: forall (n :: S) (l :: S). NameBinder n l -> NameBinder n l -> Bool
< :: NameBinder n l -> NameBinder n l -> Bool
$c<= :: forall (n :: S) (l :: S). NameBinder n l -> NameBinder n l -> Bool
<= :: NameBinder n l -> NameBinder n l -> Bool
$c> :: forall (n :: S) (l :: S). NameBinder n l -> NameBinder n l -> Bool
> :: NameBinder n l -> NameBinder n l -> Bool
$c>= :: forall (n :: S) (l :: S). NameBinder n l -> NameBinder n l -> Bool
>= :: NameBinder n l -> NameBinder n l -> Bool
$cmax :: forall (n :: S) (l :: S).
NameBinder n l -> NameBinder n l -> NameBinder n l
max :: NameBinder n l -> NameBinder n l -> NameBinder n l
$cmin :: forall (n :: S) (l :: S).
NameBinder n l -> NameBinder n l -> NameBinder n l
min :: NameBinder n l -> NameBinder n l -> NameBinder n l
Ord, RawName -> NameBinder n l -> ShowS
[NameBinder n l] -> ShowS
NameBinder n l -> String
(RawName -> NameBinder n l -> ShowS)
-> (NameBinder n l -> String)
-> ([NameBinder n l] -> ShowS)
-> Show (NameBinder n l)
forall a.
(RawName -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
forall (n :: S) (l :: S). RawName -> NameBinder n l -> ShowS
forall (n :: S) (l :: S). [NameBinder n l] -> ShowS
forall (n :: S) (l :: S). NameBinder n l -> String
$cshowsPrec :: forall (n :: S) (l :: S). RawName -> NameBinder n l -> ShowS
showsPrec :: RawName -> NameBinder n l -> ShowS
$cshow :: forall (n :: S) (l :: S). NameBinder n l -> String
show :: NameBinder n l -> String
$cshowList :: forall (n :: S) (l :: S). [NameBinder n l] -> ShowS
showList :: [NameBinder n l] -> ShowS
Show)

-- | An empty scope (without any names).
--
-- @since 0.0.1
emptyScope :: Scope VoidS
emptyScope :: Scope 'VoidS
emptyScope = RawScope -> Scope 'VoidS
forall (n :: S). RawScope -> Scope n
UnsafeScope RawScope
IntSet.empty

-- | A runtime check for potential name capture.
--
-- @since 0.0.1
member :: Name l -> Scope n -> Bool
member :: forall (l :: S) (n :: S). Name l -> Scope n -> Bool
member (UnsafeName RawName
name) (UnsafeScope RawScope
s) = RawName -> RawScope -> Bool
rawMember RawName
name RawScope
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 :: forall (n :: S) (l :: S). NameBinder n l -> Scope n -> Scope l
extendScope (UnsafeNameBinder (UnsafeName RawName
name)) (UnsafeScope RawScope
scope) =
  RawScope -> Scope l
forall (n :: S). RawScope -> Scope n
UnsafeScope (RawName -> RawScope -> RawScope
IntSet.insert RawName
name RawScope
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 :: forall (n :: S) (pattern :: S -> S -> *) (l :: S).
(Distinct n, CoSinkable pattern) =>
pattern n l -> Scope n -> Scope l
extendScopePattern pattern n l
pat Scope n
scope = (forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     ExtendScope x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S).
    DExt z z' =>
    ExtendScope x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (DExt z z', DExt z' z'') =>
    ExtendScope x y z z'
    -> ExtendScope y y' z' z'' -> ExtendScope x y' z z'')
-> Scope n
-> pattern n l
-> (forall (o' :: S).
    DExt n o' =>
    ExtendScope n l n o' -> pattern n o' -> Scope o' -> Scope l)
-> Scope l
forall (o :: S) (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
Distinct o =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (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' :: S).
    DExt o o' =>
    f n l o o' -> pattern o o' -> Scope o' -> r)
-> r
forall (pattern :: S -> S -> *) (o :: S)
       (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
(CoSinkable pattern, Distinct o) =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (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' :: S).
    DExt o o' =>
    f n l o o' -> pattern o o' -> Scope o' -> r)
-> r
withPattern
  (\Scope z
_scope' NameBinder x y
binder forall (z' :: S).
DExt z z' =>
ExtendScope x y z z' -> NameBinder z z' -> r'
k ->
    NameBinder x y
-> (DExt z (ZonkAny 37) => NameBinder z (ZonkAny 37) -> r') -> r'
forall (n :: S) (l :: S) (n' :: S) (l' :: S) r.
NameBinder n l -> (DExt n' l' => NameBinder n' l' -> r) -> r
unsafeAssertFresh NameBinder x y
binder ((DExt z (ZonkAny 37) => NameBinder z (ZonkAny 37) -> r') -> r')
-> (DExt z (ZonkAny 37) => NameBinder z (ZonkAny 37) -> r') -> r'
forall a b. (a -> b) -> a -> b
$ \NameBinder z (ZonkAny 37)
binder' ->
      ExtendScope x y z (ZonkAny 37) -> NameBinder z (ZonkAny 37) -> r'
forall (z' :: S).
DExt z z' =>
ExtendScope x y z z' -> NameBinder z z' -> r'
k ((Scope x -> Scope y) -> ExtendScope x y z (ZonkAny 37)
forall (n :: S) (l :: S) (o :: S) (o' :: S).
(Scope n -> Scope l) -> ExtendScope n l o o'
ExtendScope (NameBinder x y -> Scope x -> Scope y
forall (n :: S) (l :: S). NameBinder n l -> Scope n -> Scope l
extendScope NameBinder x y
binder)) NameBinder z (ZonkAny 37)
binder')
  ExtendScope x x z z'
forall (n :: S) (o :: S) (o' :: S). ExtendScope n n o o'
forall (x :: S) (z :: S) (z' :: S).
DExt z z' =>
ExtendScope x x z z'
idExtendScope
  ExtendScope x y z z'
-> ExtendScope y y' z' z'' -> ExtendScope x y' z z''
forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S) (z'' :: S).
(DExt z z', DExt z' z'') =>
ExtendScope x y z z'
-> ExtendScope y y' z' z'' -> ExtendScope x y' z z''
forall (n :: S) (i :: S) (o :: S) (o' :: S) (l :: S) (o'' :: S).
ExtendScope n i o o'
-> ExtendScope i l o' o'' -> ExtendScope n l o o''
compExtendScope
  Scope n
scope
  pattern n l
pat
  (\(ExtendScope Scope n -> Scope l
extend) pattern n o'
_ Scope o'
_ -> Scope n -> Scope l
extend Scope n
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 :: forall (n :: S) (o :: S) (o' :: S). ExtendScope n n o o'
idExtendScope = (Scope n -> Scope n) -> ExtendScope n n o o'
forall (n :: S) (l :: S) (o :: S) (o' :: S).
(Scope n -> Scope l) -> ExtendScope n l o o'
ExtendScope Scope n -> Scope n
forall a. a -> a
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 :: forall (n :: S) (i :: S) (o :: S) (o' :: S) (l :: S) (o'' :: S).
ExtendScope n i o o'
-> ExtendScope i l o' o'' -> ExtendScope n l o o''
compExtendScope (ExtendScope Scope n -> Scope i
f) (ExtendScope Scope i -> Scope l
g)
  = (Scope n -> Scope l) -> ExtendScope n l o o''
forall (n :: S) (l :: S) (o :: S) (o' :: S).
(Scope n -> Scope l) -> ExtendScope n l o o'
ExtendScope (Scope i -> Scope l
g (Scope i -> Scope l) -> (Scope n -> Scope i) -> Scope n -> Scope l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scope n -> Scope i
f)

-- ** Collecting new names

-- | Extract name from a name binder.
--
-- @since 0.0.1
nameOf :: NameBinder n l -> Name l
nameOf :: forall (n :: S) (l :: S). NameBinder n l -> Name l
nameOf (UnsafeNameBinder Name l
name) = Name l
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 :: forall (pattern :: S -> S -> *) (n :: S) (l :: S).
(Distinct n, CoSinkable pattern) =>
pattern n l -> [Name l]
namesOfPattern pattern n l
pat = forall (pattern :: S -> S -> *) (o :: S)
       (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
(CoSinkable pattern, Distinct o) =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (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' :: S).
    DExt o o' =>
    f n l o o' -> pattern o o' -> Scope o' -> r)
-> r
withPattern @_ @n
  (\Scope z
_scope' NameBinder x y
binder forall (z' :: S).
DExt z z' =>
NamesOf x y z z' -> NameBinder z z' -> r'
k ->
    NameBinder x y
-> (DExt z (ZonkAny 35) => NameBinder z (ZonkAny 35) -> r') -> r'
forall (n :: S) (l :: S) (n' :: S) (l' :: S) r.
NameBinder n l -> (DExt n' l' => NameBinder n' l' -> r) -> r
unsafeAssertFresh NameBinder x y
binder ((DExt z (ZonkAny 35) => NameBinder z (ZonkAny 35) -> r') -> r')
-> (DExt z (ZonkAny 35) => NameBinder z (ZonkAny 35) -> r') -> r'
forall a b. (a -> b) -> a -> b
$ \NameBinder z (ZonkAny 35)
binder' ->
      NamesOf x y z (ZonkAny 35) -> NameBinder z (ZonkAny 35) -> r'
forall (z' :: S).
DExt z z' =>
NamesOf x y z z' -> NameBinder z z' -> r'
k ([Name y] -> NamesOf x y z (ZonkAny 35)
forall (n :: S) (l :: S) (o :: S) (o' :: S).
[Name l] -> NamesOf n l o o'
NamesOf [NameBinder x y -> Name y
forall (n :: S) (l :: S). NameBinder n l -> Name l
nameOf NameBinder x y
binder]) NameBinder z (ZonkAny 35)
binder')
  NamesOf x x z z'
forall (n :: S) (o :: S) (o' :: S). NamesOf n n o o'
forall (x :: S) (z :: S) (z' :: S). DExt z z' => NamesOf x x z z'
idNamesOf NamesOf x y z z' -> NamesOf y y' z' z'' -> NamesOf x y' z z''
forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S) (z'' :: S).
(DExt z z', DExt z' z'') =>
NamesOf x y z z' -> NamesOf y y' z' z'' -> NamesOf x y' z z''
forall (n :: S) (i :: S) (o :: S) (o' :: S) (l :: S) (o'' :: S).
NamesOf n i o o' -> NamesOf i l o' o'' -> NamesOf n l o o''
compNamesOf (String -> Scope n
forall a. HasCallStack => String -> a
error String
"impossible") pattern n l
pat
  (\(NamesOf [Name l]
names) pattern n o'
_ Scope o'
_ -> [Name l]
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 :: forall (n :: S) (o :: S) (o' :: S). NamesOf n n o o'
idNamesOf = [Name n] -> NamesOf n n o o'
forall (n :: S) (l :: S) (o :: S) (o' :: S).
[Name l] -> NamesOf n l o o'
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 :: forall (n :: S) (i :: S) (o :: S) (o' :: S) (l :: S) (o'' :: S).
NamesOf n i o o' -> NamesOf i l o' o'' -> NamesOf n l o o''
compNamesOf (NamesOf [Name i]
xs) (NamesOf [Name l]
ys) =
  [Name l] -> NamesOf n l o o''
forall (n :: S) (l :: S) (o :: S) (o' :: S).
[Name l] -> NamesOf n l o o'
NamesOf ([Name i] -> [Name l]
forall a b. Coercible a b => a -> b
coerce [Name i]
xs [Name l] -> [Name l] -> [Name l]
forall a. [a] -> [a] -> [a]
++ [Name l]
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 :: forall (n :: S) r.
Scope n -> (forall (l :: S). NameBinder n l -> r) -> r
withFreshBinder (UnsafeScope RawScope
scope) forall (l :: S). NameBinder n l -> r
cont =
  NameBinder n (ZonkAny 31) -> r
forall (l :: S). NameBinder n l -> r
cont NameBinder n (ZonkAny 31)
binder
  where
    binder :: NameBinder n (ZonkAny 31)
binder = Name (ZonkAny 31) -> NameBinder n (ZonkAny 31)
forall (n :: S) (l :: S). Name l -> NameBinder n l
UnsafeNameBinder (RawName -> Name (ZonkAny 31)
forall (n :: S). RawName -> Name n
UnsafeName (RawScope -> RawName
rawFreshName RawScope
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 :: forall (n :: S) r.
Distinct n =>
Scope n -> (forall (l :: S). DExt n l => NameBinder n l -> r) -> r
withFresh Scope n
scope forall (l :: S). DExt n l => NameBinder n l -> r
cont = Scope n -> (forall (l :: S). NameBinder n l -> r) -> r
forall (n :: S) r.
Scope n -> (forall (l :: S). NameBinder n l -> r) -> r
withFreshBinder Scope n
scope (NameBinder n l
-> (DExt n (ZonkAny 32) => NameBinder n (ZonkAny 32) -> r) -> r
forall (n :: S) (l :: S) (n' :: S) (l' :: S) r.
NameBinder n l -> (DExt n' l' => NameBinder n' l' -> r) -> r
`unsafeAssertFresh` DExt n (ZonkAny 32) => NameBinder n (ZonkAny 32) -> r
NameBinder n (ZonkAny 32) -> r
forall (l :: S). DExt n l => NameBinder n l -> r
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 :: forall (n :: S) r.
Distinct n =>
NameRange
-> Scope n
-> (forall (l :: S). DExt n l => NameBinder n l -> r)
-> r
withFreshIn NameRange
range Scope n
scope forall (l :: S). DExt n l => NameBinder n l -> r
cont =
  case NameRange
-> Scope n
-> (forall (l :: S). DExt n l => NameBinder n l -> r)
-> Maybe r
forall (n :: S) r.
Distinct n =>
NameRange
-> Scope n
-> (forall (l :: S). DExt n l => NameBinder n l -> r)
-> Maybe r
tryWithFreshIn NameRange
range Scope n
scope NameBinder n l -> r
forall (l :: S). DExt n l => NameBinder n l -> r
cont of
    Just r
r  -> r
r
    Maybe r
Nothing -> String -> r
forall a. HasCallStack => String -> a
error (String
"withFreshIn: exhausted " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> NameRange -> String
forall a. Show a => a -> String
show NameRange
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 :: forall (n :: S) r.
Distinct n =>
NameRange
-> Scope n
-> (forall (l :: S). DExt n l => NameBinder n l -> r)
-> Maybe r
tryWithFreshIn NameRange
range (UnsafeScope RawScope
rawScope) forall (l :: S). DExt n l => NameBinder n l -> r
cont =
  case NameRange -> RawScope -> Maybe RawName
rawFreshNameIn NameRange
range RawScope
rawScope of
    Maybe RawName
Nothing   -> Maybe r
forall a. Maybe a
Nothing
    Just RawName
name -> r -> Maybe r
forall a. a -> Maybe a
Just (NameBinder (ZonkAny 28) (ZonkAny 27)
-> (DExt n (ZonkAny 26) => NameBinder n (ZonkAny 26) -> r) -> r
forall (n :: S) (l :: S) (n' :: S) (l' :: S) r.
NameBinder n l -> (DExt n' l' => NameBinder n' l' -> r) -> r
unsafeAssertFresh (Name (ZonkAny 27) -> NameBinder (ZonkAny 28) (ZonkAny 27)
forall (n :: S) (l :: S). Name l -> NameBinder n l
UnsafeNameBinder (RawName -> Name (ZonkAny 27)
forall (n :: S). RawName -> Name n
UnsafeName RawName
name)) DExt n (ZonkAny 26) => NameBinder n (ZonkAny 26) -> r
NameBinder n (ZonkAny 26) -> r
forall (l :: S). DExt n l => NameBinder n l -> r
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 :: forall (o :: S) (pattern :: S -> S -> *) (e :: S -> *) (n :: S)
       (l :: S) r.
(Distinct o, CoSinkable pattern, Sinkable e, InjectName e) =>
Scope o
-> pattern n l
-> (forall (o' :: S).
    DExt o o' =>
    (Substitution e n o -> Substitution e l o')
    -> pattern o o' -> Scope o' -> r)
-> r
withFreshPattern Scope o
scope pattern n l
pattern forall (o' :: S).
DExt o o' =>
(Substitution e n o -> Substitution e l o')
-> pattern o o' -> Scope o' -> r
cont = (forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     WithRefreshedPattern e x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S).
    DExt z z' =>
    WithRefreshedPattern e x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (DExt z z', DExt z' z'') =>
    WithRefreshedPattern e x y z z'
    -> WithRefreshedPattern e y y' z' z''
    -> WithRefreshedPattern e x y' z z'')
-> Scope o
-> pattern n l
-> (forall (o' :: S).
    DExt o o' =>
    WithRefreshedPattern e n l o o' -> pattern o o' -> Scope o' -> r)
-> r
forall (o :: S) (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
Distinct o =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (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' :: S).
    DExt o o' =>
    f n l o o' -> pattern o o' -> Scope o' -> r)
-> r
forall (pattern :: S -> S -> *) (o :: S)
       (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
(CoSinkable pattern, Distinct o) =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (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' :: S).
    DExt o o' =>
    f n l o o' -> pattern o o' -> Scope o' -> r)
-> r
withPattern
  (\Scope z
scope' NameBinder x y
binder forall (z' :: S).
DExt z z' =>
WithRefreshedPattern e x y z z' -> NameBinder z z' -> r'
f -> Scope z
-> (forall (l :: S). DExt z l => NameBinder z l -> r') -> r'
forall (n :: S) r.
Distinct n =>
Scope n -> (forall (l :: S). DExt n l => NameBinder n l -> r) -> r
withFresh Scope z
scope'
    (\NameBinder z l
binder' -> WithRefreshedPattern e x y z l -> NameBinder z l -> r'
forall (z' :: S).
DExt z z' =>
WithRefreshedPattern e x y z z' -> NameBinder z z' -> r'
f ((Substitution e x z -> Substitution e y l)
-> WithRefreshedPattern e x y z l
forall (e :: S -> *) (n :: S) (l :: S) (o :: S) (o' :: S).
(Substitution e n o -> Substitution e l o')
-> WithRefreshedPattern e n l o o'
WithRefreshedPattern (\Substitution e x z
subst -> Substitution e x l
-> NameBinder x y -> Name l -> Substitution e y l
forall (e :: S -> *) (i :: S) (o :: S) (i' :: S).
InjectName e =>
Substitution e i o
-> NameBinder i i' -> Name o -> Substitution e i' o
addRename (Substitution e x z -> Substitution e x l
forall (e :: S -> *) (n :: S) (l :: S).
(Sinkable e, DExt n l) =>
e n -> e l
sink Substitution e x z
subst) NameBinder x y
binder (NameBinder z l -> Name l
forall (n :: S) (l :: S). NameBinder n l -> Name l
nameOf NameBinder z l
binder'))) NameBinder z l
binder'))
  WithRefreshedPattern e x x z z'
forall (x :: S) (z :: S) (z' :: S).
DExt z z' =>
WithRefreshedPattern e x x z z'
forall (e :: S -> *) (o :: S) (o' :: S) (n :: S).
(Sinkable e, DExt o o') =>
WithRefreshedPattern e n n o o'
idWithRefreshedPattern
  WithRefreshedPattern e x y z z'
-> WithRefreshedPattern e y y' z' z''
-> WithRefreshedPattern e x y' z z''
forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S) (z'' :: S).
(DExt z z', DExt z' z'') =>
WithRefreshedPattern e x y z z'
-> WithRefreshedPattern e y y' z' z''
-> WithRefreshedPattern e x y' z z''
forall (o :: S) (o' :: S) (o'' :: S) (e :: S -> *) (n :: S)
       (i :: S) (l :: S).
(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
  Scope o
scope
  pattern n l
pattern
  (\(WithRefreshedPattern Substitution e n o -> Substitution e l o'
f) pattern o o'
pattern' Scope o'
scope' -> (Substitution e n o -> Substitution e l o')
-> pattern o o' -> Scope o' -> r
forall (o' :: S).
DExt o o' =>
(Substitution e n o -> Substitution e l o')
-> pattern o o' -> Scope o' -> r
cont Substitution e n o -> Substitution e l o'
f pattern o o'
pattern' Scope o'
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 :: forall (o :: S) (i :: S) r.
Distinct o =>
Scope o
-> Name i
-> (forall (o' :: S). DExt o o' => NameBinder o o' -> r)
-> r
withRefreshed scope :: Scope o
scope@(UnsafeScope RawScope
rawScope) name :: Name i
name@(UnsafeName RawName
rawName) forall (o' :: S). DExt o o' => NameBinder o o' -> r
cont
  | RawName -> RawScope -> Bool
IntSet.member RawName
rawName RawScope
rawScope = Scope o
-> (forall (o' :: S). DExt o o' => NameBinder o o' -> r) -> r
forall (n :: S) r.
Distinct n =>
Scope n -> (forall (l :: S). DExt n l => NameBinder n l -> r) -> r
withFresh Scope o
scope NameBinder o l -> r
forall (o' :: S). DExt o o' => NameBinder o o' -> r
cont
  | Bool
otherwise = NameBinder (ZonkAny 34) i
-> (DExt o (ZonkAny 33) => NameBinder o (ZonkAny 33) -> r) -> r
forall (n :: S) (l :: S) (n' :: S) (l' :: S) r.
NameBinder n l -> (DExt n' l' => NameBinder n' l' -> r) -> r
unsafeAssertFresh (Name i -> NameBinder (ZonkAny 34) i
forall (n :: S) (l :: S). Name l -> NameBinder n l
UnsafeNameBinder Name i
name) DExt o (ZonkAny 33) => NameBinder o (ZonkAny 33) -> r
NameBinder o (ZonkAny 33) -> r
forall (o' :: S). DExt o o' => NameBinder o o' -> r
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 :: forall (o :: S) (i :: S) r.
Distinct o =>
NameRange
-> Scope o
-> Name i
-> (forall (o' :: S). DExt o o' => NameBinder o o' -> r)
-> r
withRefreshedIn NameRange
range scope :: Scope o
scope@(UnsafeScope RawScope
rawScope) name :: Name i
name@(UnsafeName RawName
rawName) forall (o' :: S). DExt o o' => NameBinder o o' -> r
cont
  | RawName -> RawScope -> Bool
IntSet.member RawName
rawName RawScope
rawScope = NameRange
-> Scope o
-> (forall (o' :: S). DExt o o' => NameBinder o o' -> r)
-> r
forall (n :: S) r.
Distinct n =>
NameRange
-> Scope n
-> (forall (l :: S). DExt n l => NameBinder n l -> r)
-> r
withFreshIn NameRange
range Scope o
scope NameBinder o l -> r
forall (o' :: S). DExt o o' => NameBinder o o' -> r
cont
  | Bool
otherwise = NameBinder (ZonkAny 30) i
-> (DExt o (ZonkAny 29) => NameBinder o (ZonkAny 29) -> r) -> r
forall (n :: S) (l :: S) (n' :: S) (l' :: S) r.
NameBinder n l -> (DExt n' l' => NameBinder n' l' -> r) -> r
unsafeAssertFresh (Name i -> NameBinder (ZonkAny 30) i
forall (n :: S) (l :: S). Name l -> NameBinder n l
UnsafeNameBinder Name i
name) DExt o (ZonkAny 29) => NameBinder o (ZonkAny 29) -> r
NameBinder o (ZonkAny 29) -> r
forall (o' :: S). DExt o o' => NameBinder o o' -> r
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 :: forall (o :: S) (pattern :: S -> S -> *) (e :: S -> *) (n :: S)
       (l :: S) r.
(Distinct o, CoSinkable pattern, Sinkable e, InjectName e) =>
Scope o
-> pattern n l
-> (forall (o' :: S).
    DExt o o' =>
    (Substitution e n o -> Substitution e l o')
    -> pattern o o' -> Scope o' -> r)
-> r
withRefreshedPattern Scope o
scope pattern n l
pattern forall (o' :: S).
DExt o o' =>
(Substitution e n o -> Substitution e l o')
-> pattern o o' -> Scope o' -> r
cont = (forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     WithRefreshedPattern e x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S).
    DExt z z' =>
    WithRefreshedPattern e x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (DExt z z', DExt z' z'') =>
    WithRefreshedPattern e x y z z'
    -> WithRefreshedPattern e y y' z' z''
    -> WithRefreshedPattern e x y' z z'')
-> Scope o
-> pattern n l
-> (forall (o' :: S).
    DExt o o' =>
    WithRefreshedPattern e n l o o' -> pattern o o' -> Scope o' -> r)
-> r
forall (o :: S) (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
Distinct o =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (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' :: S).
    DExt o o' =>
    f n l o o' -> pattern o o' -> Scope o' -> r)
-> r
forall (pattern :: S -> S -> *) (o :: S)
       (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
(CoSinkable pattern, Distinct o) =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (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' :: S).
    DExt o o' =>
    f n l o o' -> pattern o o' -> Scope o' -> r)
-> r
withPattern
  (\Scope z
scope' NameBinder x y
binder forall (z' :: S).
DExt z z' =>
WithRefreshedPattern e x y z z' -> NameBinder z z' -> r'
f -> Scope z
-> Name y
-> (forall (o' :: S). DExt z o' => NameBinder z o' -> r')
-> r'
forall (o :: S) (i :: S) r.
Distinct o =>
Scope o
-> Name i
-> (forall (o' :: S). DExt o o' => NameBinder o o' -> r)
-> r
withRefreshed Scope z
scope' (NameBinder x y -> Name y
forall (n :: S) (l :: S). NameBinder n l -> Name l
nameOf NameBinder x y
binder)
    (\NameBinder z o'
binder' -> WithRefreshedPattern e x y z o' -> NameBinder z o' -> r'
forall (z' :: S).
DExt z z' =>
WithRefreshedPattern e x y z z' -> NameBinder z z' -> r'
f ((Substitution e x z -> Substitution e y o')
-> WithRefreshedPattern e x y z o'
forall (e :: S -> *) (n :: S) (l :: S) (o :: S) (o' :: S).
(Substitution e n o -> Substitution e l o')
-> WithRefreshedPattern e n l o o'
WithRefreshedPattern (\Substitution e x z
subst -> Substitution e x o'
-> NameBinder x y -> Name o' -> Substitution e y o'
forall (e :: S -> *) (i :: S) (o :: S) (i' :: S).
InjectName e =>
Substitution e i o
-> NameBinder i i' -> Name o -> Substitution e i' o
addRename (Substitution e x z -> Substitution e x o'
forall (e :: S -> *) (n :: S) (l :: S).
(Sinkable e, DExt n l) =>
e n -> e l
sink Substitution e x z
subst) NameBinder x y
binder (NameBinder z o' -> Name o'
forall (n :: S) (l :: S). NameBinder n l -> Name l
nameOf NameBinder z o'
binder'))) NameBinder z o'
binder'))
  WithRefreshedPattern e x x z z'
forall (x :: S) (z :: S) (z' :: S).
DExt z z' =>
WithRefreshedPattern e x x z z'
forall (e :: S -> *) (o :: S) (o' :: S) (n :: S).
(Sinkable e, DExt o o') =>
WithRefreshedPattern e n n o o'
idWithRefreshedPattern
  WithRefreshedPattern e x y z z'
-> WithRefreshedPattern e y y' z' z''
-> WithRefreshedPattern e x y' z z''
forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S) (z'' :: S).
(DExt z z', DExt z' z'') =>
WithRefreshedPattern e x y z z'
-> WithRefreshedPattern e y y' z' z''
-> WithRefreshedPattern e x y' z z''
forall (o :: S) (o' :: S) (o'' :: S) (e :: S -> *) (n :: S)
       (i :: S) (l :: S).
(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
  Scope o
scope
  pattern n l
pattern
  (\(WithRefreshedPattern Substitution e n o -> Substitution e l o'
f) pattern o o'
pattern' Scope o'
scope' -> (Substitution e n o -> Substitution e l o')
-> pattern o o' -> Scope o' -> r
forall (o' :: S).
DExt o o' =>
(Substitution e n o -> Substitution e l o')
-> pattern o o' -> Scope o' -> r
cont Substitution e n o -> Substitution e l o'
f pattern o o'
pattern' Scope o'
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' :: forall (pattern :: S -> S -> *) (o :: S) (e :: S -> *) (n :: S)
       (l :: S) r.
(CoSinkable pattern, Distinct o, InjectName e, Sinkable e) =>
Scope o
-> pattern n l
-> (forall (o' :: S).
    DExt o o' =>
    ((Name n -> e o) -> Name l -> e o')
    -> pattern o o' -> Scope o' -> r)
-> r
withRefreshedPattern' Scope o
scope pattern n l
pattern forall (o' :: S).
DExt o o' =>
((Name n -> e o) -> Name l -> e o')
-> pattern o o' -> Scope o' -> r
cont = (forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     WithRefreshedPattern' e x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S).
    DExt z z' =>
    WithRefreshedPattern' e x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (DExt z z', DExt z' z'') =>
    WithRefreshedPattern' e x y z z'
    -> WithRefreshedPattern' e y y' z' z''
    -> WithRefreshedPattern' e x y' z z'')
-> Scope o
-> pattern n l
-> (forall (o' :: S).
    DExt o o' =>
    WithRefreshedPattern' e n l o o' -> pattern o o' -> Scope o' -> r)
-> r
forall (o :: S) (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
Distinct o =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (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' :: S).
    DExt o o' =>
    f n l o o' -> pattern o o' -> Scope o' -> r)
-> r
forall (pattern :: S -> S -> *) (o :: S)
       (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
(CoSinkable pattern, Distinct o) =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (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' :: S).
    DExt o o' =>
    f n l o o' -> pattern o o' -> Scope o' -> r)
-> r
withPattern
  (\Scope z
scope' NameBinder x y
binder forall (z' :: S).
DExt z z' =>
WithRefreshedPattern' e x y z z' -> NameBinder z z' -> r'
f -> Scope z
-> Name y
-> (forall (o' :: S). DExt z o' => NameBinder z o' -> r')
-> r'
forall (o :: S) (i :: S) r.
Distinct o =>
Scope o
-> Name i
-> (forall (o' :: S). DExt o o' => NameBinder o o' -> r)
-> r
withRefreshed Scope z
scope' (NameBinder x y -> Name y
forall (n :: S) (l :: S). NameBinder n l -> Name l
nameOf NameBinder x y
binder)
    (\NameBinder z o'
binder' ->
      let k :: (Name x -> e z) -> Name y -> e o'
k Name x -> e z
subst Name y
name = case NameBinder x y -> Name y -> Maybe (Name x)
forall (n :: S) (l :: S).
NameBinder n l -> Name l -> Maybe (Name n)
unsinkName NameBinder x y
binder Name y
name of
              Maybe (Name x)
Nothing    -> Name o' -> e o'
forall (n :: S). Name n -> e n
forall (e :: S -> *) (n :: S). InjectName e => Name n -> e n
injectName (NameBinder z o' -> Name o'
forall (n :: S) (l :: S). NameBinder n l -> Name l
nameOf NameBinder z o'
binder')
              Just Name x
name' -> e z -> e o'
forall (e :: S -> *) (n :: S) (l :: S).
(Sinkable e, DExt n l) =>
e n -> e l
sink (Name x -> e z
subst Name x
name')
       in WithRefreshedPattern' e x y z o' -> NameBinder z o' -> r'
forall (z' :: S).
DExt z z' =>
WithRefreshedPattern' e x y z z' -> NameBinder z z' -> r'
f (((Name x -> e z) -> Name y -> e o')
-> WithRefreshedPattern' e x y z o'
forall (e :: S -> *) (n :: S) (l :: S) (o :: S) (o' :: S).
((Name n -> e o) -> Name l -> e o')
-> WithRefreshedPattern' e n l o o'
WithRefreshedPattern' (Name x -> e z) -> Name y -> e o'
k) NameBinder z o'
binder'))
  WithRefreshedPattern' e x x z z'
forall (x :: S) (z :: S) (z' :: S).
DExt z z' =>
WithRefreshedPattern' e x x z z'
forall (e :: S -> *) (o :: S) (o' :: S) (n :: S).
(Sinkable e, DExt o o') =>
WithRefreshedPattern' e n n o o'
idWithRefreshedPattern'
  WithRefreshedPattern' e x y z z'
-> WithRefreshedPattern' e y y' z' z''
-> WithRefreshedPattern' e x y' z z''
forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S) (z'' :: S).
(DExt z z', DExt z' z'') =>
WithRefreshedPattern' e x y z z'
-> WithRefreshedPattern' e y y' z' z''
-> WithRefreshedPattern' e x y' z z''
forall (o :: S) (o' :: S) (o'' :: S) (e :: S -> *) (n :: S)
       (i :: S) (l :: S).
(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'
  Scope o
scope
  pattern n l
pattern
  (\(WithRefreshedPattern' (Name n -> e o) -> Name l -> e o'
f) pattern o o'
pattern' Scope o'
scope' -> ((Name n -> e o) -> Name l -> e o')
-> pattern o o' -> Scope o' -> r
forall (o' :: S).
DExt o o' =>
((Name n -> e o) -> Name l -> e o')
-> pattern o o' -> Scope o' -> r
cont (Name n -> e o) -> Name l -> e o'
f pattern o o'
pattern' Scope o'
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 :: forall (n :: S) (l :: S) (n' :: S) (l' :: S) r.
NameBinder n l -> (DExt n' l' => NameBinder n' l' -> r) -> r
unsafeAssertFresh NameBinder n l
binder DExt n' l' => NameBinder n' l' -> r
cont =
  case forall (n :: S). DistinctEvidence n
unsafeDistinct @l' of
    DistinctEvidence l'
Distinct -> case forall (n :: S) (l :: S). ExtEvidence n l
unsafeExt @n' @l' of
      ExtEvidence n' l'
Ext -> DExt n' l' => NameBinder n' l' -> r
NameBinder n' l' -> r
cont (NameBinder n l -> NameBinder n' l'
forall a b. a -> b
unsafeCoerce NameBinder n l
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 :: forall (e :: S -> *) (o :: S) (o' :: S) (n :: S).
(Sinkable e, DExt o o') =>
WithRefreshedPattern e n n o o'
idWithRefreshedPattern = (Substitution e n o -> Substitution e n o')
-> WithRefreshedPattern e n n o o'
forall (e :: S -> *) (n :: S) (l :: S) (o :: S) (o' :: S).
(Substitution e n o -> Substitution e l o')
-> WithRefreshedPattern e n l o o'
WithRefreshedPattern Substitution e n o -> Substitution e n o'
forall (e :: S -> *) (n :: S) (l :: S).
(Sinkable e, DExt n l) =>
e n -> e l
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 :: forall (o :: S) (o' :: S) (o'' :: S) (e :: S -> *) (n :: S)
       (i :: S) (l :: S).
(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 Substitution e n o -> Substitution e i o'
f) (WithRefreshedPattern Substitution e i o' -> Substitution e l o''
g) =
  (Substitution e n o -> Substitution e l o'')
-> WithRefreshedPattern e n l o o''
forall (e :: S -> *) (n :: S) (l :: S) (o :: S) (o' :: S).
(Substitution e n o -> Substitution e l o')
-> WithRefreshedPattern e n l o o'
WithRefreshedPattern (Substitution e i o' -> Substitution e l o''
g (Substitution e i o' -> Substitution e l o'')
-> (Substitution e n o -> Substitution e i o')
-> Substitution e n o
-> Substitution e l o''
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Substitution e n o -> Substitution e i o'
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' :: forall (e :: S -> *) (o :: S) (o' :: S) (n :: S).
(Sinkable e, DExt o o') =>
WithRefreshedPattern' e n n o o'
idWithRefreshedPattern' = ((Name n -> e o) -> Name n -> e o')
-> WithRefreshedPattern' e n n o o'
forall (e :: S -> *) (n :: S) (l :: S) (o :: S) (o' :: S).
((Name n -> e o) -> Name l -> e o')
-> WithRefreshedPattern' e n l o o'
WithRefreshedPattern' (\Name n -> e o
f Name n
n -> e o -> e o'
forall (e :: S -> *) (n :: S) (l :: S).
(Sinkable e, DExt n l) =>
e n -> e l
sink (Name n -> e o
f Name n
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' :: forall (o :: S) (o' :: S) (o'' :: S) (e :: S -> *) (n :: S)
       (i :: S) (l :: S).
(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' (Name n -> e o) -> Name i -> e o'
f) (WithRefreshedPattern' (Name i -> e o') -> Name l -> e o''
g) =
  ((Name n -> e o) -> Name l -> e o'')
-> WithRefreshedPattern' e n l o o''
forall (e :: S -> *) (n :: S) (l :: S) (o :: S) (o' :: S).
((Name n -> e o) -> Name l -> e o')
-> WithRefreshedPattern' e n l o o'
WithRefreshedPattern' ((Name i -> e o') -> Name l -> e o''
g ((Name i -> e o') -> Name l -> e o'')
-> ((Name n -> e o) -> Name i -> e o')
-> (Name n -> e o)
-> Name l
-> e o''
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name n -> e o) -> Name i -> e o'
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 :: forall (n :: S) (pattern :: S -> S -> *) (l :: S).
(Distinct n, CoSinkable pattern) =>
pattern n l -> DistinctEvidence l
assertDistinct pattern n l
_ = DistinctEvidence l
forall (n :: S). DistinctEvidence n
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 :: forall (pattern :: S -> S -> *) (n :: S) (l :: S).
CoSinkable pattern =>
pattern n l -> ExtEvidence n l
assertExt pattern n l
_ = ExtEvidence n l
forall (n :: S) (l :: S). ExtEvidence n l
unsafeExt

-- | Unsafely declare that scope @n@ is distinct.
-- Used in 'unsafeAssertFresh'.
--
-- @since 0.0.1
unsafeDistinct :: DistinctEvidence n
unsafeDistinct :: forall (n :: S). DistinctEvidence n
unsafeDistinct = DistinctEvidence 'VoidS -> DistinctEvidence n
forall a b. a -> b
unsafeCoerce (DistinctEvidence 'VoidS
forall (n :: S). Distinct n => DistinctEvidence n
Distinct :: DistinctEvidence VoidS)

-- | Unsafely declare that scope @l@ extends scope @n@.
-- Used in 'unsafeAssertFresh'.
--
-- @since 0.0.1
unsafeExt :: ExtEvidence n l
unsafeExt :: forall (n :: S) (l :: S). ExtEvidence n l
unsafeExt = ExtEvidence 'VoidS 'VoidS -> ExtEvidence n l
forall a b. a -> b
unsafeCoerce (ExtEvidence 'VoidS 'VoidS
forall (n :: S) (l :: S). Ext n l => ExtEvidence n l
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 :: forall (n :: S) (l :: S).
NameBinder n l -> Name l -> Maybe (Name n)
unsinkName NameBinder n l
binder name :: Name l
name@(UnsafeName RawName
raw)
  | NameBinder n l -> Name l
forall (n :: S) (l :: S). NameBinder n l -> Name l
nameOf NameBinder n l
binder Name l -> Name l -> Bool
forall a. Eq a => a -> a -> Bool
== Name l
name = Maybe (Name n)
forall a. Maybe a
Nothing
  | Bool
otherwise = Name n -> Maybe (Name n)
forall a. a -> Maybe a
Just (RawName -> Name n
forall (n :: S). RawName -> Name n
UnsafeName RawName
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 :: forall (pattern :: S -> S -> *) (n :: S) (l :: S).
(Distinct n, CoSinkable pattern) =>
pattern n l -> Name l -> Maybe (Name n)
unsinkNamePattern pattern n l
pat = forall (pattern :: S -> S -> *) (o :: S)
       (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
(CoSinkable pattern, Distinct o) =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (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' :: S).
    DExt o o' =>
    f n l o o' -> pattern o o' -> Scope o' -> r)
-> r
withPattern @_ @n
  (\Scope z
_scope' NameBinder x y
binder forall (z' :: S).
DExt z z' =>
UnsinkName x y z z' -> NameBinder z z' -> r'
k ->
      NameBinder x y
-> (DExt z (ZonkAny 36) => NameBinder z (ZonkAny 36) -> r') -> r'
forall (n :: S) (l :: S) (n' :: S) (l' :: S) r.
NameBinder n l -> (DExt n' l' => NameBinder n' l' -> r) -> r
unsafeAssertFresh NameBinder x y
binder ((DExt z (ZonkAny 36) => NameBinder z (ZonkAny 36) -> r') -> r')
-> (DExt z (ZonkAny 36) => NameBinder z (ZonkAny 36) -> r') -> r'
forall a b. (a -> b) -> a -> b
$ \NameBinder z (ZonkAny 36)
binder' ->
        UnsinkName x y z (ZonkAny 36) -> NameBinder z (ZonkAny 36) -> r'
forall (z' :: S).
DExt z z' =>
UnsinkName x y z z' -> NameBinder z z' -> r'
k ((Name y -> Maybe (Name x)) -> UnsinkName x y z (ZonkAny 36)
forall (n :: S) (l :: S) (o :: S) (o' :: S).
(Name l -> Maybe (Name n)) -> UnsinkName n l o o'
UnsinkName (NameBinder x y -> Name y -> Maybe (Name x)
forall (n :: S) (l :: S).
NameBinder n l -> Name l -> Maybe (Name n)
unsinkName NameBinder x y
binder)) NameBinder z (ZonkAny 36)
binder')
  UnsinkName x x z z'
forall (n :: S) (o :: S) (o' :: S). UnsinkName n n o o'
forall (x :: S) (z :: S) (z' :: S).
DExt z z' =>
UnsinkName x x z z'
idUnsinkName
  UnsinkName x y z z'
-> UnsinkName y y' z' z'' -> UnsinkName x y' z z''
forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S) (z'' :: S).
(DExt z z', DExt z' z'') =>
UnsinkName x y z z'
-> UnsinkName y y' z' z'' -> UnsinkName x y' z z''
forall (n :: S) (i :: S) (o :: S) (o' :: S) (l :: S) (o'' :: S).
UnsinkName n i o o'
-> UnsinkName i l o' o'' -> UnsinkName n l o o''
compUnsinkName
  (String -> Scope n
forall a. HasCallStack => String -> a
error String
"impossible")  -- scope is not used, but has to be provided in general
  pattern n l
pat
  (\(UnsinkName Name l -> Maybe (Name n)
unsink) pattern n o'
_ Scope o'
_ -> Name l -> Maybe (Name n)
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 :: forall (n :: S) (o :: S) (o' :: S). UnsinkName n n o o'
idUnsinkName = (Name n -> Maybe (Name n)) -> UnsinkName n n o o'
forall (n :: S) (l :: S) (o :: S) (o' :: S).
(Name l -> Maybe (Name n)) -> UnsinkName n l o o'
UnsinkName Name n -> Maybe (Name n)
forall a. a -> Maybe a
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 :: forall (n :: S) (i :: S) (o :: S) (o' :: S) (l :: S) (o'' :: S).
UnsinkName n i o o'
-> UnsinkName i l o' o'' -> UnsinkName n l o o''
compUnsinkName (UnsinkName Name i -> Maybe (Name n)
f) (UnsinkName Name l -> Maybe (Name i)
g)
  = (Name l -> Maybe (Name n)) -> UnsinkName n l o o''
forall (n :: S) (l :: S) (o :: S) (o' :: S).
(Name l -> Maybe (Name n)) -> UnsinkName n l o o'
UnsinkName (\Name l
name -> Name l -> Maybe (Name i)
g Name l
name Maybe (Name i) -> (Name i -> Maybe (Name n)) -> Maybe (Name n)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name i -> Maybe (Name n)
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 (NameSet n -> ()
(NameSet n -> ()) -> NFData (NameSet n)
forall a. (a -> ()) -> NFData a
forall (n :: S). NameSet n -> ()
$crnf :: forall (n :: S). NameSet n -> ()
rnf :: NameSet n -> ()
NFData, NameSet n -> NameSet n -> Bool
(NameSet n -> NameSet n -> Bool)
-> (NameSet n -> NameSet n -> Bool) -> Eq (NameSet n)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (n :: S). NameSet n -> NameSet n -> Bool
$c== :: forall (n :: S). NameSet n -> NameSet n -> Bool
== :: NameSet n -> NameSet n -> Bool
$c/= :: forall (n :: S). NameSet n -> NameSet n -> Bool
/= :: NameSet n -> NameSet n -> Bool
Eq, NonEmpty (NameSet n) -> NameSet n
NameSet n -> NameSet n -> NameSet n
(NameSet n -> NameSet n -> NameSet n)
-> (NonEmpty (NameSet n) -> NameSet n)
-> (forall b. Integral b => b -> NameSet n -> NameSet n)
-> Semigroup (NameSet n)
forall b. Integral b => b -> NameSet n -> NameSet n
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall (n :: S). NonEmpty (NameSet n) -> NameSet n
forall (n :: S). NameSet n -> NameSet n -> NameSet n
forall (n :: S) b. Integral b => b -> NameSet n -> NameSet n
$c<> :: forall (n :: S). NameSet n -> NameSet n -> NameSet n
<> :: NameSet n -> NameSet n -> NameSet n
$csconcat :: forall (n :: S). NonEmpty (NameSet n) -> NameSet n
sconcat :: NonEmpty (NameSet n) -> NameSet n
$cstimes :: forall (n :: S) b. Integral b => b -> NameSet n -> NameSet n
stimes :: forall b. Integral b => b -> NameSet n -> NameSet n
Semigroup, Semigroup (NameSet n)
NameSet n
Semigroup (NameSet n) =>
NameSet n
-> (NameSet n -> NameSet n -> NameSet n)
-> ([NameSet n] -> NameSet n)
-> Monoid (NameSet n)
[NameSet n] -> NameSet n
NameSet n -> NameSet n -> NameSet n
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall (n :: S). Semigroup (NameSet n)
forall (n :: S). NameSet n
forall (n :: S). [NameSet n] -> NameSet n
forall (n :: S). NameSet n -> NameSet n -> NameSet n
$cmempty :: forall (n :: S). NameSet n
mempty :: NameSet n
$cmappend :: forall (n :: S). NameSet n -> NameSet n -> NameSet n
mappend :: NameSet n -> NameSet n -> NameSet n
$cmconcat :: forall (n :: S). [NameSet n] -> NameSet n
mconcat :: [NameSet n] -> NameSet n
Monoid)

-- | An empty set of names.
--
-- @since 0.4.0
emptyNameSet :: NameSet n
emptyNameSet :: forall (n :: S). NameSet n
emptyNameSet = RawScope -> NameSet n
forall (n :: S). RawScope -> NameSet n
UnsafeNameSet RawScope
IntSet.empty

-- | \(O(1)\). A set of one name.
--
-- @since 0.4.0
nameSetSingleton :: Name n -> NameSet n
nameSetSingleton :: forall (n :: S). Name n -> NameSet n
nameSetSingleton (UnsafeName RawName
name) = RawScope -> NameSet n
forall (n :: S). RawScope -> NameSet n
UnsafeNameSet (RawName -> RawScope
IntSet.singleton RawName
name)

-- | \(O(\min(n,W))\). Add a name to a set.
--
-- @since 0.4.0
nameSetInsert :: Name n -> NameSet n -> NameSet n
nameSetInsert :: forall (n :: S). Name n -> NameSet n -> NameSet n
nameSetInsert (UnsafeName RawName
name) (UnsafeNameSet RawScope
names) =
  RawScope -> NameSet n
forall (n :: S). RawScope -> NameSet n
UnsafeNameSet (RawName -> RawScope -> RawScope
IntSet.insert RawName
name RawScope
names)

-- | \(O(\min(n,W))\). Is this name in the set?
--
-- @since 0.4.0
nameSetMember :: Name n -> NameSet n -> Bool
nameSetMember :: forall (n :: S). Name n -> NameSet n -> Bool
nameSetMember (UnsafeName RawName
name) (UnsafeNameSet RawScope
names) = RawName -> RawScope -> Bool
IntSet.member RawName
name RawScope
names

-- | Is the set empty?
--
-- @since 0.4.0
nameSetNull :: NameSet n -> Bool
nameSetNull :: forall (n :: S). NameSet n -> Bool
nameSetNull (UnsafeNameSet RawScope
names) = RawScope -> Bool
IntSet.null RawScope
names

-- | How many names are in the set?
--
-- @since 0.4.0
nameSetSize :: NameSet n -> Int
nameSetSize :: forall (n :: S). NameSet n -> RawName
nameSetSize (UnsafeNameSet RawScope
names) = RawScope -> RawName
IntSet.size RawScope
names

-- | The names in the set, in ascending order of their identifiers.
--
-- @since 0.4.0
nameSetToList :: NameSet n -> [Name n]
nameSetToList :: forall (n :: S). NameSet n -> [Name n]
nameSetToList (UnsafeNameSet RawScope
names) = (RawName -> Name n) -> [RawName] -> [Name n]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map RawName -> Name n
forall (n :: S). RawName -> Name n
UnsafeName (RawScope -> [RawName]
IntSet.toAscList RawScope
names)

-- | A set of the given names.
--
-- @since 0.4.0
nameSetFromList :: [Name n] -> NameSet n
nameSetFromList :: forall (n :: S). [Name n] -> NameSet n
nameSetFromList [Name n]
names = RawScope -> NameSet n
forall (n :: S). RawScope -> NameSet n
UnsafeNameSet ([RawName] -> RawScope
IntSet.fromList ((Name n -> RawName) -> [Name n] -> [RawName]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map Name n -> RawName
forall (l :: S). Name l -> RawName
nameId [Name n]
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 :: forall (n :: S) (l :: S).
(Name n -> Name l) -> NameSet n -> NameSet l
sinkabilityProof Name n -> Name l
rename = [Name l] -> NameSet l
forall (n :: S). [Name n] -> NameSet n
nameSetFromList ([Name l] -> NameSet l)
-> (NameSet n -> [Name l]) -> NameSet n -> NameSet l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name n -> Name l) -> [Name n] -> [Name l]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map Name n -> Name l
rename ([Name n] -> [Name l])
-> (NameSet n -> [Name n]) -> NameSet n -> [Name l]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSet n -> [Name n]
forall (n :: S). NameSet n -> [Name n]
nameSetToList

-- | All the names in a scope.
--
-- @since 0.4.0
scopeToNameSet :: Scope n -> NameSet n
scopeToNameSet :: forall (n :: S). Scope n -> NameSet n
scopeToNameSet (UnsafeScope RawScope
names) = RawScope -> NameSet n
forall (n :: S). RawScope -> NameSet n
UnsafeNameSet RawScope
names

-- | The names a pattern binds.
--
-- @since 0.4.0
nameSetOfPattern :: CoSinkable binder => binder n l -> NameSet l
nameSetOfPattern :: forall (binder :: S -> S -> *) (n :: S) (l :: S).
CoSinkable binder =>
binder n l -> NameSet l
nameSetOfPattern binder n l
binder = RawScope -> NameSet l
forall (n :: S). RawScope -> NameSet n
UnsafeNameSet RawScope
bound
  where
    UnsafeNameBinders RawScope
bound = NameBinderList n l -> NameBinders n l
forall (n :: S) (l :: S). NameBinderList n l -> NameBinders n l
fromNameBindersList (binder n l -> NameBinderList n l
forall (binder :: S -> S -> *) (n :: S) (l :: S).
CoSinkable binder =>
binder n l -> NameBinderList n l
nameBinderListOf binder n l
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 :: forall (l :: S) (n :: S). NameSet l -> Scope n -> Bool
nameSetSubsetOfScope (UnsafeNameSet RawScope
names) (UnsafeScope RawScope
scope) =
  RawScope
names RawScope -> RawScope -> Bool
`IntSet.isSubsetOf` RawScope
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 :: forall (binder :: S -> S -> *) (n :: S) (l :: S).
CoSinkable binder =>
binder n l -> NameSet l -> NameSet n
unsinkNameSet binder n l
binder (UnsafeNameSet RawScope
names) = RawScope -> NameSet n
forall (n :: S). RawScope -> NameSet n
UnsafeNameSet (RawScope
names RawScope -> RawScope -> RawScope
IntSet.\\ RawScope
bound)
  where
    UnsafeNameBinders RawScope
bound = NameBinderList n l -> NameBinders n l
forall (n :: S) (l :: S). NameBinderList n l -> NameBinders n l
fromNameBindersList (binder n l -> NameBinderList n l
forall (binder :: S -> S -> *) (n :: S) (l :: S).
CoSinkable binder =>
binder n l -> NameBinderList n l
nameBinderListOf binder n l
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 :: forall (n :: S) r.
Distinct n =>
NameSet n
-> (forall (m :: S). (Ext m n, Distinct m) => Scope m -> r) -> r
withRestrictedScope (UnsafeNameSet RawScope
names) forall (m :: S). (Ext m n, Distinct m) => Scope m -> r
cont =
  forall (n :: S) (m :: S) r.
Scope m -> ((Ext m n, Distinct m) => Scope m -> r) -> r
unsafeAssertRestricted @n (RawScope -> Scope (ZonkAny 25)
forall (n :: S). RawScope -> Scope n
UnsafeScope RawScope
names) (Ext (ZonkAny 25) n, Distinct (ZonkAny 25)) =>
Scope (ZonkAny 25) -> r
Scope (ZonkAny 25) -> r
forall (m :: S). (Ext m n, Distinct m) => Scope m -> r
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 :: forall (n :: S) (m :: S) r.
Scope m -> ((Ext m n, Distinct m) => Scope m -> r) -> r
unsafeAssertRestricted Scope m
scope (Ext m n, Distinct m) => Scope m -> r
cont =
  case forall (n :: S). DistinctEvidence n
unsafeDistinct @m of
    DistinctEvidence m
Distinct -> case forall (n :: S) (l :: S). ExtEvidence n l
unsafeExt @m @n of
      ExtEvidence m n
Ext -> (Ext m n, Distinct m) => Scope m -> r
Scope m -> r
cont Scope m
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 :: forall (i :: S) (l :: S) (r :: S) (pattern :: S -> S -> *).
Distinct i =>
NameBinder i l -> NameBinder i r -> UnifyNameBinders pattern i l r
unifyNameBinders l :: NameBinder i l
l@(UnsafeNameBinder (UnsafeName RawName
i1)) r :: NameBinder i r
r@(UnsafeNameBinder (UnsafeName RawName
i2))
  | RawName
i1 RawName -> RawName -> Bool
forall a. Eq a => a -> a -> Bool
== RawName
i2  = case NameBinder i l -> DistinctEvidence l
forall (n :: S) (pattern :: S -> S -> *) (l :: S).
(Distinct n, CoSinkable pattern) =>
pattern n l -> DistinctEvidence l
assertDistinct NameBinder i l
l of
      DistinctEvidence l
Distinct -> UnifyNameBinders (ZonkAny 39) i l l
-> UnifyNameBinders pattern i l r
forall a b. a -> b
unsafeCoerce (NameBinders i l -> UnifyNameBinders (ZonkAny 39) i l l
forall (n :: S) (l :: S) (pattern :: S -> S -> *).
NameBinders n l -> UnifyNameBinders pattern n l l
SameNameBinders (NameBinder i l -> NameBinders i l
forall (n :: S) (l :: S). NameBinder n l -> NameBinders n l
nameBindersSingleton NameBinder i l
l))  -- equal names extend scopes equally
  | RawName
i1 RawName -> RawName -> Bool
forall a. Ord a => a -> a -> Bool
< RawName
i2   = NameBinders i l
-> (NameBinder i r -> NameBinder i l)
-> UnifyNameBinders pattern i l r
forall (n :: S) (l :: S) (r :: S) (pattern :: S -> S -> *).
NameBinders n l
-> (NameBinder n r -> NameBinder n l)
-> UnifyNameBinders pattern n l r
RenameRightNameBinder (NameBinder i l -> NameBinders i l
forall (n :: S) (l :: S). NameBinder n l -> NameBinders n l
nameBindersSingleton NameBinder i l
l) ((NameBinder i r -> NameBinder i l)
 -> UnifyNameBinders pattern i l r)
-> (NameBinder i r -> NameBinder i l)
-> UnifyNameBinders pattern i l r
forall a b. (a -> b) -> a -> b
$ \(UnsafeNameBinder (UnsafeName RawName
i'')) ->
      if RawName
i'' RawName -> RawName -> Bool
forall a. Eq a => a -> a -> Bool
== RawName
i2 then Name l -> NameBinder i l
forall (n :: S) (l :: S). Name l -> NameBinder n l
UnsafeNameBinder (RawName -> Name l
forall (n :: S). RawName -> Name n
UnsafeName RawName
i1) else Name l -> NameBinder i l
forall (n :: S) (l :: S). Name l -> NameBinder n l
UnsafeNameBinder (RawName -> Name l
forall (n :: S). RawName -> Name n
UnsafeName RawName
i'')
  | Bool
otherwise = NameBinders i r
-> (NameBinder i l -> NameBinder i r)
-> UnifyNameBinders pattern i l r
forall (n :: S) (r :: S) (l :: S) (pattern :: S -> S -> *).
NameBinders n r
-> (NameBinder n l -> NameBinder n r)
-> UnifyNameBinders pattern n l r
RenameLeftNameBinder (NameBinder i r -> NameBinders i r
forall (n :: S) (l :: S). NameBinder n l -> NameBinders n l
nameBindersSingleton NameBinder i r
r) ((NameBinder i l -> NameBinder i r)
 -> UnifyNameBinders pattern i l r)
-> (NameBinder i l -> NameBinder i r)
-> UnifyNameBinders pattern i l r
forall a b. (a -> b) -> a -> b
$ \(UnsafeNameBinder (UnsafeName RawName
i')) ->
      if RawName
i'  RawName -> RawName -> Bool
forall a. Eq a => a -> a -> Bool
== RawName
i1 then Name r -> NameBinder i r
forall (n :: S) (l :: S). Name l -> NameBinder n l
UnsafeNameBinder (RawName -> Name r
forall (n :: S). RawName -> Name n
UnsafeName RawName
i2) else Name r -> NameBinder i r
forall (n :: S) (l :: S). Name l -> NameBinder n l
UnsafeNameBinder (RawName -> Name r
forall (n :: S). RawName -> Name n
UnsafeName RawName
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 :: forall (pattern :: S -> S -> *) (a :: S) (a' :: S) (a'' :: S)
       (a''' :: S) (b' :: S) (b'' :: S).
UnifyNameBinders pattern a a' a''
-> UnifyNameBinders pattern a''' b' b''
-> UnifyNameBinders pattern a b' b''
unsafeMergeUnifyBinders = \case

  SameNameBinders NameBinders a a'
x -> \case
    SameNameBinders NameBinders a''' b'
y -> NameBinders a b' -> UnifyNameBinders pattern a b' b'
forall (n :: S) (l :: S) (pattern :: S -> S -> *).
NameBinders n l -> UnifyNameBinders pattern n l l
SameNameBinders (NameBinders a a'
x NameBinders a a' -> NameBinders a''' b' -> NameBinders a b'
forall (a :: S) (b :: S) (c :: S) (d :: S) (n :: S) (l :: S).
NameBinders a b -> NameBinders c d -> NameBinders n l
`unsafeMergeNameBinders` NameBinders a''' b'
y)
    RenameLeftNameBinder NameBinders a''' b''
y NameBinder a''' b' -> NameBinder a''' b''
f -> NameBinders a b''
-> (NameBinder a b' -> NameBinder a b'')
-> UnifyNameBinders pattern a b' b''
forall (n :: S) (r :: S) (l :: S) (pattern :: S -> S -> *).
NameBinders n r
-> (NameBinder n l -> NameBinder n r)
-> UnifyNameBinders pattern n l r
RenameLeftNameBinder (NameBinders a a'
x NameBinders a a' -> NameBinders a''' b'' -> NameBinders a b''
forall (a :: S) (b :: S) (c :: S) (d :: S) (n :: S) (l :: S).
NameBinders a b -> NameBinders c d -> NameBinders n l
`unsafeMergeNameBinders` NameBinders a''' b''
y) ((NameBinder a''' b' -> NameBinder a''' b'')
-> NameBinder a b' -> NameBinder a b''
forall a b. a -> b
unsafeCoerce NameBinder a''' b' -> NameBinder a''' b''
f)
    RenameRightNameBinder NameBinders a''' b'
y NameBinder a''' b'' -> NameBinder a''' b'
g -> NameBinders a b'
-> (NameBinder a b'' -> NameBinder a b')
-> UnifyNameBinders pattern a b' b''
forall (n :: S) (l :: S) (r :: S) (pattern :: S -> S -> *).
NameBinders n l
-> (NameBinder n r -> NameBinder n l)
-> UnifyNameBinders pattern n l r
RenameRightNameBinder (NameBinders a a'
x NameBinders a a' -> NameBinders a''' b' -> NameBinders a b'
forall (a :: S) (b :: S) (c :: S) (d :: S) (n :: S) (l :: S).
NameBinders a b -> NameBinders c d -> NameBinders n l
`unsafeMergeNameBinders` NameBinders a''' b'
y) ((NameBinder a''' b'' -> NameBinder a''' b')
-> NameBinder a b'' -> NameBinder a b'
forall a b. a -> b
unsafeCoerce NameBinder a''' b'' -> NameBinder a''' b'
g)
    RenameBothBinders NameBinders a''' lr
y NameBinder a''' b' -> NameBinder a''' lr
f NameBinder a''' b'' -> NameBinder a''' lr
g -> NameBinders a (ZonkAny 8)
-> (NameBinder a b' -> NameBinder a (ZonkAny 8))
-> (NameBinder a b'' -> NameBinder a (ZonkAny 8))
-> UnifyNameBinders pattern a b' b''
forall (n :: S) (k :: S) (l :: S) (r :: S)
       (pattern :: S -> S -> *).
NameBinders n k
-> (NameBinder n l -> NameBinder n k)
-> (NameBinder n r -> NameBinder n k)
-> UnifyNameBinders pattern n l r
RenameBothBinders (NameBinders a a'
x NameBinders a a'
-> NameBinders a''' lr -> NameBinders a (ZonkAny 8)
forall (a :: S) (b :: S) (c :: S) (d :: S) (n :: S) (l :: S).
NameBinders a b -> NameBinders c d -> NameBinders n l
`unsafeMergeNameBinders` NameBinders a''' lr
y) ((NameBinder a''' b' -> NameBinder a''' lr)
-> NameBinder a b' -> NameBinder a (ZonkAny 8)
forall a b. a -> b
unsafeCoerce NameBinder a''' b' -> NameBinder a''' lr
f) ((NameBinder a''' b'' -> NameBinder a''' lr)
-> NameBinder a b'' -> NameBinder a (ZonkAny 8)
forall a b. a -> b
unsafeCoerce NameBinder a''' b'' -> NameBinder a''' lr
g)
    UnifyNameBinders pattern a''' b' b''
NotUnifiable -> UnifyNameBinders pattern a b' b''
forall (pattern :: S -> S -> *) (n :: S) (l :: S) (r :: S).
UnifyNameBinders pattern n l r
NotUnifiable

  RenameLeftNameBinder NameBinders a a''
x NameBinder a a' -> NameBinder a a''
f -> \case
    SameNameBinders NameBinders a''' b'
y -> NameBinders a b''
-> (NameBinder a b' -> NameBinder a b'')
-> UnifyNameBinders pattern a b' b''
forall (n :: S) (r :: S) (l :: S) (pattern :: S -> S -> *).
NameBinders n r
-> (NameBinder n l -> NameBinder n r)
-> UnifyNameBinders pattern n l r
RenameLeftNameBinder (NameBinders a a''
x NameBinders a a'' -> NameBinders a''' b' -> NameBinders a b''
forall (a :: S) (b :: S) (c :: S) (d :: S) (n :: S) (l :: S).
NameBinders a b -> NameBinders c d -> NameBinders n l
`unsafeMergeNameBinders` NameBinders a''' b'
y) ((NameBinder a a' -> NameBinder a a'')
-> NameBinder a b' -> NameBinder a b''
forall a b. a -> b
unsafeCoerce NameBinder a a' -> NameBinder a a''
f)
    RenameLeftNameBinder NameBinders a''' b''
y NameBinder a''' b' -> NameBinder a''' b''
g -> NameBinders a b''
-> (NameBinder a b' -> NameBinder a b'')
-> UnifyNameBinders pattern a b' b''
forall (n :: S) (r :: S) (l :: S) (pattern :: S -> S -> *).
NameBinders n r
-> (NameBinder n l -> NameBinder n r)
-> UnifyNameBinders pattern n l r
RenameLeftNameBinder (NameBinders a a''
x NameBinders a a'' -> NameBinders a''' b'' -> NameBinders a b''
forall (a :: S) (b :: S) (c :: S) (d :: S) (n :: S) (l :: S).
NameBinders a b -> NameBinders c d -> NameBinders n l
`unsafeMergeNameBinders` NameBinders a''' b''
y) ((NameBinder a a' -> NameBinder a a'')
-> ZonkAny 9 -> NameBinder a b''
forall a b. a -> b
unsafeCoerce NameBinder a a' -> NameBinder a a''
f (ZonkAny 9 -> NameBinder a b'')
-> (NameBinder a b' -> ZonkAny 9)
-> NameBinder a b'
-> NameBinder a b''
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NameBinder a''' b' -> NameBinder a''' b'')
-> NameBinder a b' -> ZonkAny 9
forall a b. a -> b
unsafeCoerce NameBinder a''' b' -> NameBinder a''' b''
g)
    RenameRightNameBinder NameBinders a''' b'
y NameBinder a''' b'' -> NameBinder a''' b'
g -> NameBinders a (ZonkAny 10)
-> (NameBinder a b' -> NameBinder a (ZonkAny 10))
-> (NameBinder a b'' -> NameBinder a (ZonkAny 10))
-> UnifyNameBinders pattern a b' b''
forall (n :: S) (k :: S) (l :: S) (r :: S)
       (pattern :: S -> S -> *).
NameBinders n k
-> (NameBinder n l -> NameBinder n k)
-> (NameBinder n r -> NameBinder n k)
-> UnifyNameBinders pattern n l r
RenameBothBinders (NameBinders a a''
x NameBinders a a''
-> NameBinders a''' b' -> NameBinders a (ZonkAny 10)
forall (a :: S) (b :: S) (c :: S) (d :: S) (n :: S) (l :: S).
NameBinders a b -> NameBinders c d -> NameBinders n l
`unsafeMergeNameBinders` NameBinders a''' b'
y) ((NameBinder a a' -> NameBinder a a'')
-> NameBinder a b' -> NameBinder a (ZonkAny 10)
forall a b. a -> b
unsafeCoerce NameBinder a a' -> NameBinder a a''
f) ((NameBinder a''' b'' -> NameBinder a''' b')
-> NameBinder a b'' -> NameBinder a (ZonkAny 10)
forall a b. a -> b
unsafeCoerce NameBinder a''' b'' -> NameBinder a''' b'
g)
    RenameBothBinders NameBinders a''' lr
y NameBinder a''' b' -> NameBinder a''' lr
f' NameBinder a''' b'' -> NameBinder a''' lr
g -> NameBinders a (ZonkAny 11)
-> (NameBinder a b' -> NameBinder a (ZonkAny 11))
-> (NameBinder a b'' -> NameBinder a (ZonkAny 11))
-> UnifyNameBinders pattern a b' b''
forall (n :: S) (k :: S) (l :: S) (r :: S)
       (pattern :: S -> S -> *).
NameBinders n k
-> (NameBinder n l -> NameBinder n k)
-> (NameBinder n r -> NameBinder n k)
-> UnifyNameBinders pattern n l r
RenameBothBinders (NameBinders a a''
x NameBinders a a''
-> NameBinders a''' lr -> NameBinders a (ZonkAny 11)
forall (a :: S) (b :: S) (c :: S) (d :: S) (n :: S) (l :: S).
NameBinders a b -> NameBinders c d -> NameBinders n l
`unsafeMergeNameBinders` NameBinders a''' lr
y) ((NameBinder a a' -> NameBinder a a'')
-> ZonkAny 12 -> NameBinder a (ZonkAny 11)
forall a b. a -> b
unsafeCoerce NameBinder a a' -> NameBinder a a''
f (ZonkAny 12 -> NameBinder a (ZonkAny 11))
-> (NameBinder a b' -> ZonkAny 12)
-> NameBinder a b'
-> NameBinder a (ZonkAny 11)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NameBinder a''' b' -> NameBinder a''' lr)
-> NameBinder a b' -> ZonkAny 12
forall a b. a -> b
unsafeCoerce NameBinder a''' b' -> NameBinder a''' lr
f') ((NameBinder a''' b'' -> NameBinder a''' lr)
-> NameBinder a b'' -> NameBinder a (ZonkAny 11)
forall a b. a -> b
unsafeCoerce NameBinder a''' b'' -> NameBinder a''' lr
g)
    UnifyNameBinders pattern a''' b' b''
NotUnifiable -> UnifyNameBinders pattern a b' b''
forall (pattern :: S -> S -> *) (n :: S) (l :: S) (r :: S).
UnifyNameBinders pattern n l r
NotUnifiable

  RenameRightNameBinder NameBinders a a'
x NameBinder a a'' -> NameBinder a a'
g -> \case
    SameNameBinders NameBinders a''' b'
y -> NameBinders a b'
-> (NameBinder a b'' -> NameBinder a b')
-> UnifyNameBinders pattern a b' b''
forall (n :: S) (l :: S) (r :: S) (pattern :: S -> S -> *).
NameBinders n l
-> (NameBinder n r -> NameBinder n l)
-> UnifyNameBinders pattern n l r
RenameRightNameBinder (NameBinders a a'
x NameBinders a a' -> NameBinders a''' b' -> NameBinders a b'
forall (a :: S) (b :: S) (c :: S) (d :: S) (n :: S) (l :: S).
NameBinders a b -> NameBinders c d -> NameBinders n l
`unsafeMergeNameBinders` NameBinders a''' b'
y) ((NameBinder a a'' -> NameBinder a a')
-> NameBinder a b'' -> NameBinder a b'
forall a b. a -> b
unsafeCoerce NameBinder a a'' -> NameBinder a a'
g)
    RenameLeftNameBinder NameBinders a''' b''
y NameBinder a''' b' -> NameBinder a''' b''
f -> NameBinders a (ZonkAny 13)
-> (NameBinder a b' -> NameBinder a (ZonkAny 13))
-> (NameBinder a b'' -> NameBinder a (ZonkAny 13))
-> UnifyNameBinders pattern a b' b''
forall (n :: S) (k :: S) (l :: S) (r :: S)
       (pattern :: S -> S -> *).
NameBinders n k
-> (NameBinder n l -> NameBinder n k)
-> (NameBinder n r -> NameBinder n k)
-> UnifyNameBinders pattern n l r
RenameBothBinders (NameBinders a a'
x NameBinders a a'
-> NameBinders a''' b'' -> NameBinders a (ZonkAny 13)
forall (a :: S) (b :: S) (c :: S) (d :: S) (n :: S) (l :: S).
NameBinders a b -> NameBinders c d -> NameBinders n l
`unsafeMergeNameBinders` NameBinders a''' b''
y) ((NameBinder a''' b' -> NameBinder a''' b'')
-> NameBinder a b' -> NameBinder a (ZonkAny 13)
forall a b. a -> b
unsafeCoerce NameBinder a''' b' -> NameBinder a''' b''
f) ((NameBinder a a'' -> NameBinder a a')
-> NameBinder a b'' -> NameBinder a (ZonkAny 13)
forall a b. a -> b
unsafeCoerce NameBinder a a'' -> NameBinder a a'
g)
    RenameRightNameBinder NameBinders a''' b'
y NameBinder a''' b'' -> NameBinder a''' b'
g' -> NameBinders a b'
-> (NameBinder a b'' -> NameBinder a b')
-> UnifyNameBinders pattern a b' b''
forall (n :: S) (l :: S) (r :: S) (pattern :: S -> S -> *).
NameBinders n l
-> (NameBinder n r -> NameBinder n l)
-> UnifyNameBinders pattern n l r
RenameRightNameBinder (NameBinders a a'
x NameBinders a a' -> NameBinders a''' b' -> NameBinders a b'
forall (a :: S) (b :: S) (c :: S) (d :: S) (n :: S) (l :: S).
NameBinders a b -> NameBinders c d -> NameBinders n l
`unsafeMergeNameBinders` NameBinders a''' b'
y) ((NameBinder a a'' -> NameBinder a a')
-> ZonkAny 14 -> NameBinder a b'
forall a b. a -> b
unsafeCoerce NameBinder a a'' -> NameBinder a a'
g (ZonkAny 14 -> NameBinder a b')
-> (NameBinder a b'' -> ZonkAny 14)
-> NameBinder a b''
-> NameBinder a b'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NameBinder a''' b'' -> NameBinder a''' b')
-> NameBinder a b'' -> ZonkAny 14
forall a b. a -> b
unsafeCoerce NameBinder a''' b'' -> NameBinder a''' b'
g')
    RenameBothBinders NameBinders a''' lr
y NameBinder a''' b' -> NameBinder a''' lr
f NameBinder a''' b'' -> NameBinder a''' lr
g' -> NameBinders a (ZonkAny 15)
-> (NameBinder a b' -> NameBinder a (ZonkAny 15))
-> (NameBinder a b'' -> NameBinder a (ZonkAny 15))
-> UnifyNameBinders pattern a b' b''
forall (n :: S) (k :: S) (l :: S) (r :: S)
       (pattern :: S -> S -> *).
NameBinders n k
-> (NameBinder n l -> NameBinder n k)
-> (NameBinder n r -> NameBinder n k)
-> UnifyNameBinders pattern n l r
RenameBothBinders (NameBinders a a'
x NameBinders a a'
-> NameBinders a''' lr -> NameBinders a (ZonkAny 15)
forall (a :: S) (b :: S) (c :: S) (d :: S) (n :: S) (l :: S).
NameBinders a b -> NameBinders c d -> NameBinders n l
`unsafeMergeNameBinders` NameBinders a''' lr
y) ((NameBinder a''' b' -> NameBinder a''' lr)
-> NameBinder a b' -> NameBinder a (ZonkAny 15)
forall a b. a -> b
unsafeCoerce NameBinder a''' b' -> NameBinder a''' lr
f) ((NameBinder a a'' -> NameBinder a a')
-> ZonkAny 16 -> NameBinder a (ZonkAny 15)
forall a b. a -> b
unsafeCoerce NameBinder a a'' -> NameBinder a a'
g (ZonkAny 16 -> NameBinder a (ZonkAny 15))
-> (NameBinder a b'' -> ZonkAny 16)
-> NameBinder a b''
-> NameBinder a (ZonkAny 15)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NameBinder a''' b'' -> NameBinder a''' lr)
-> NameBinder a b'' -> ZonkAny 16
forall a b. a -> b
unsafeCoerce NameBinder a''' b'' -> NameBinder a''' lr
g')
    UnifyNameBinders pattern a''' b' b''
NotUnifiable -> UnifyNameBinders pattern a b' b''
forall (pattern :: S -> S -> *) (n :: S) (l :: S) (r :: S).
UnifyNameBinders pattern n l r
NotUnifiable

  RenameBothBinders NameBinders a lr
x NameBinder a a' -> NameBinder a lr
f NameBinder a a'' -> NameBinder a lr
g -> \case
    SameNameBinders NameBinders a''' b'
y -> NameBinders a (ZonkAny 17)
-> (NameBinder a b' -> NameBinder a (ZonkAny 17))
-> (NameBinder a b'' -> NameBinder a (ZonkAny 17))
-> UnifyNameBinders pattern a b' b''
forall (n :: S) (k :: S) (l :: S) (r :: S)
       (pattern :: S -> S -> *).
NameBinders n k
-> (NameBinder n l -> NameBinder n k)
-> (NameBinder n r -> NameBinder n k)
-> UnifyNameBinders pattern n l r
RenameBothBinders (NameBinders a lr
x NameBinders a lr
-> NameBinders a''' b' -> NameBinders a (ZonkAny 17)
forall (a :: S) (b :: S) (c :: S) (d :: S) (n :: S) (l :: S).
NameBinders a b -> NameBinders c d -> NameBinders n l
`unsafeMergeNameBinders` NameBinders a''' b'
y) ((NameBinder a a' -> NameBinder a lr)
-> NameBinder a b' -> NameBinder a (ZonkAny 17)
forall a b. a -> b
unsafeCoerce NameBinder a a' -> NameBinder a lr
f) ((NameBinder a a'' -> NameBinder a lr)
-> NameBinder a b'' -> NameBinder a (ZonkAny 17)
forall a b. a -> b
unsafeCoerce NameBinder a a'' -> NameBinder a lr
g)
    RenameLeftNameBinder NameBinders a''' b''
y NameBinder a''' b' -> NameBinder a''' b''
f' -> NameBinders a (ZonkAny 18)
-> (NameBinder a b' -> NameBinder a (ZonkAny 18))
-> (NameBinder a b'' -> NameBinder a (ZonkAny 18))
-> UnifyNameBinders pattern a b' b''
forall (n :: S) (k :: S) (l :: S) (r :: S)
       (pattern :: S -> S -> *).
NameBinders n k
-> (NameBinder n l -> NameBinder n k)
-> (NameBinder n r -> NameBinder n k)
-> UnifyNameBinders pattern n l r
RenameBothBinders (NameBinders a lr
x NameBinders a lr
-> NameBinders a''' b'' -> NameBinders a (ZonkAny 18)
forall (a :: S) (b :: S) (c :: S) (d :: S) (n :: S) (l :: S).
NameBinders a b -> NameBinders c d -> NameBinders n l
`unsafeMergeNameBinders` NameBinders a''' b''
y) ((NameBinder a a' -> NameBinder a lr)
-> ZonkAny 19 -> NameBinder a (ZonkAny 18)
forall a b. a -> b
unsafeCoerce NameBinder a a' -> NameBinder a lr
f (ZonkAny 19 -> NameBinder a (ZonkAny 18))
-> (NameBinder a b' -> ZonkAny 19)
-> NameBinder a b'
-> NameBinder a (ZonkAny 18)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NameBinder a''' b' -> NameBinder a''' b'')
-> NameBinder a b' -> ZonkAny 19
forall a b. a -> b
unsafeCoerce NameBinder a''' b' -> NameBinder a''' b''
f') ((NameBinder a a'' -> NameBinder a lr)
-> NameBinder a b'' -> NameBinder a (ZonkAny 18)
forall a b. a -> b
unsafeCoerce NameBinder a a'' -> NameBinder a lr
g)
    RenameRightNameBinder NameBinders a''' b'
y NameBinder a''' b'' -> NameBinder a''' b'
g' -> NameBinders a (ZonkAny 20)
-> (NameBinder a b' -> NameBinder a (ZonkAny 20))
-> (NameBinder a b'' -> NameBinder a (ZonkAny 20))
-> UnifyNameBinders pattern a b' b''
forall (n :: S) (k :: S) (l :: S) (r :: S)
       (pattern :: S -> S -> *).
NameBinders n k
-> (NameBinder n l -> NameBinder n k)
-> (NameBinder n r -> NameBinder n k)
-> UnifyNameBinders pattern n l r
RenameBothBinders (NameBinders a lr
x NameBinders a lr
-> NameBinders a''' b' -> NameBinders a (ZonkAny 20)
forall (a :: S) (b :: S) (c :: S) (d :: S) (n :: S) (l :: S).
NameBinders a b -> NameBinders c d -> NameBinders n l
`unsafeMergeNameBinders` NameBinders a''' b'
y) ((NameBinder a a' -> NameBinder a lr)
-> NameBinder a b' -> NameBinder a (ZonkAny 20)
forall a b. a -> b
unsafeCoerce NameBinder a a' -> NameBinder a lr
f) ((NameBinder a a'' -> NameBinder a lr)
-> ZonkAny 21 -> NameBinder a (ZonkAny 20)
forall a b. a -> b
unsafeCoerce NameBinder a a'' -> NameBinder a lr
g (ZonkAny 21 -> NameBinder a (ZonkAny 20))
-> (NameBinder a b'' -> ZonkAny 21)
-> NameBinder a b''
-> NameBinder a (ZonkAny 20)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NameBinder a''' b'' -> NameBinder a''' b')
-> NameBinder a b'' -> ZonkAny 21
forall a b. a -> b
unsafeCoerce NameBinder a''' b'' -> NameBinder a''' b'
g')
    RenameBothBinders NameBinders a''' lr
y NameBinder a''' b' -> NameBinder a''' lr
f' NameBinder a''' b'' -> NameBinder a''' lr
g' -> NameBinders a (ZonkAny 22)
-> (NameBinder a b' -> NameBinder a (ZonkAny 22))
-> (NameBinder a b'' -> NameBinder a (ZonkAny 22))
-> UnifyNameBinders pattern a b' b''
forall (n :: S) (k :: S) (l :: S) (r :: S)
       (pattern :: S -> S -> *).
NameBinders n k
-> (NameBinder n l -> NameBinder n k)
-> (NameBinder n r -> NameBinder n k)
-> UnifyNameBinders pattern n l r
RenameBothBinders (NameBinders a lr
x NameBinders a lr
-> NameBinders a''' lr -> NameBinders a (ZonkAny 22)
forall (a :: S) (b :: S) (c :: S) (d :: S) (n :: S) (l :: S).
NameBinders a b -> NameBinders c d -> NameBinders n l
`unsafeMergeNameBinders` NameBinders a''' lr
y) ((NameBinder a a' -> NameBinder a lr)
-> ZonkAny 23 -> NameBinder a (ZonkAny 22)
forall a b. a -> b
unsafeCoerce NameBinder a a' -> NameBinder a lr
f (ZonkAny 23 -> NameBinder a (ZonkAny 22))
-> (NameBinder a b' -> ZonkAny 23)
-> NameBinder a b'
-> NameBinder a (ZonkAny 22)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NameBinder a''' b' -> NameBinder a''' lr)
-> NameBinder a b' -> ZonkAny 23
forall a b. a -> b
unsafeCoerce NameBinder a''' b' -> NameBinder a''' lr
f') ((NameBinder a a'' -> NameBinder a lr)
-> ZonkAny 24 -> NameBinder a (ZonkAny 22)
forall a b. a -> b
unsafeCoerce NameBinder a a'' -> NameBinder a lr
g (ZonkAny 24 -> NameBinder a (ZonkAny 22))
-> (NameBinder a b'' -> ZonkAny 24)
-> NameBinder a b''
-> NameBinder a (ZonkAny 22)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NameBinder a''' b'' -> NameBinder a''' lr)
-> NameBinder a b'' -> ZonkAny 24
forall a b. a -> b
unsafeCoerce NameBinder a''' b'' -> NameBinder a''' lr
g')
    UnifyNameBinders pattern a''' b' b''
NotUnifiable -> UnifyNameBinders pattern a b' b''
forall (pattern :: S -> S -> *) (n :: S) (l :: S) (r :: S).
UnifyNameBinders pattern n l r
NotUnifiable

  UnifyNameBinders pattern a a' a''
NotUnifiable -> UnifyNameBinders pattern a b' b''
-> UnifyNameBinders pattern a''' b' b''
-> UnifyNameBinders pattern a b' b''
forall a b. a -> b -> a
const (UnifyNameBinders pattern a b' b''
forall (pattern :: S -> S -> *) (n :: S) (l :: S) (r :: S).
UnifyNameBinders pattern n l r
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 :: forall (pattern :: S -> S -> *) (l :: S) (l' :: S) (n :: S)
       (r :: S) (r' :: S).
(UnifiablePattern pattern, Distinct l, Distinct l') =>
UnifyNameBinders pattern n l l'
-> (pattern l r, pattern l' r') -> UnifyNameBinders pattern n r r'
andThenUnifyPatterns UnifyNameBinders pattern n l l'
u (pattern l r
l, pattern l' r'
r) = UnifyNameBinders pattern n l l'
-> UnifyNameBinders pattern l' r r'
-> UnifyNameBinders pattern n r r'
forall (pattern :: S -> S -> *) (a :: S) (a' :: S) (a'' :: S)
       (a''' :: S) (b' :: S) (b'' :: S).
UnifyNameBinders pattern a a' a''
-> UnifyNameBinders pattern a''' b' b''
-> UnifyNameBinders pattern a b' b''
unsafeMergeUnifyBinders UnifyNameBinders pattern n l l'
u (pattern l' r -> pattern l' r' -> UnifyNameBinders pattern l' r r'
forall (n :: S) (l :: S) (r :: S).
Distinct n =>
pattern n l -> pattern n r -> UnifyNameBinders pattern n l r
forall (pattern :: S -> S -> *) (n :: S) (l :: S) (r :: S).
(UnifiablePattern pattern, Distinct n) =>
pattern n l -> pattern n r -> UnifyNameBinders pattern n l r
unifyPatterns (pattern l r -> pattern l' r
forall a b. a -> b
unsafeCoerce pattern l r
l) pattern l' r'
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 :: forall (pattern :: S -> S -> *) (l :: S) (l' :: S) (n :: S)
       (r :: S) (r' :: S).
(UnifiablePattern pattern, Distinct l, Distinct l') =>
UnifyNameBinders pattern n l l'
-> (NameBinder l r, NameBinder l' r')
-> UnifyNameBinders pattern n r r'
andThenUnifyNameBinders UnifyNameBinders pattern n l l'
u (NameBinder l r
l, NameBinder l' r'
r) = UnifyNameBinders pattern n l l'
-> UnifyNameBinders pattern l' r r'
-> UnifyNameBinders pattern n r r'
forall (pattern :: S -> S -> *) (a :: S) (a' :: S) (a'' :: S)
       (a''' :: S) (b' :: S) (b'' :: S).
UnifyNameBinders pattern a a' a''
-> UnifyNameBinders pattern a''' b' b''
-> UnifyNameBinders pattern a b' b''
unsafeMergeUnifyBinders UnifyNameBinders pattern n l l'
u (NameBinder l' r
-> NameBinder l' r' -> UnifyNameBinders pattern l' r r'
forall (i :: S) (l :: S) (r :: S) (pattern :: S -> S -> *).
Distinct i =>
NameBinder i l -> NameBinder i r -> UnifyNameBinders pattern i l r
unifyNameBinders (NameBinder l r -> NameBinder l' r
forall a b. a -> b
unsafeCoerce NameBinder l r
l) NameBinder l' r'
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 :: forall (a :: S) (b :: S) (c :: S) (d :: S) (n :: S) (l :: S).
NameBinders a b -> NameBinders c d -> NameBinders n l
unsafeMergeNameBinders (UnsafeNameBinders RawScope
x) (UnsafeNameBinders RawScope
y) = RawScope -> NameBinders n l
forall (n :: S) (l :: S). RawScope -> NameBinders n l
UnsafeNameBinders (RawScope
x RawScope -> RawScope -> RawScope
forall a. Semigroup a => a -> a -> a
<> RawScope
y)

-- | An empty set of binders keeps the scope as is.
--
-- @since 0.1.0
emptyNameBinders :: NameBinders n n
emptyNameBinders :: forall (n :: S). NameBinders n n
emptyNameBinders = RawScope -> NameBinders n n
forall (n :: S) (l :: S). RawScope -> NameBinders n l
UnsafeNameBinders RawScope
IntSet.empty

-- | Composition of sets of binders.
--
-- @since 0.1.0
mergeNameBinders :: NameBinders n i -> NameBinders i l -> NameBinders n l
mergeNameBinders :: forall (n :: S) (i :: S) (l :: S).
NameBinders n i -> NameBinders i l -> NameBinders n l
mergeNameBinders = NameBinders n i -> NameBinders i l -> NameBinders n l
forall (a :: S) (b :: S) (c :: S) (d :: S) (n :: S) (l :: S).
NameBinders a b -> NameBinders c d -> NameBinders n l
unsafeMergeNameBinders

-- | A singleton name binder set.
--
-- @since 0.1.0
nameBindersSingleton :: NameBinder n l -> NameBinders n l
nameBindersSingleton :: forall (n :: S) (l :: S). NameBinder n l -> NameBinders n l
nameBindersSingleton NameBinder n l
binder = RawScope -> NameBinders n l
forall (n :: S) (l :: S). RawScope -> NameBinders n l
UnsafeNameBinders (RawName -> RawScope
IntSet.singleton (Name l -> RawName
forall (l :: S). Name l -> RawName
nameId (NameBinder n l -> Name l
forall (n :: S) (l :: S). NameBinder n l -> Name l
nameOf NameBinder n l
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 :: forall (n :: S) (l :: S). NameBinders n l -> NameBinderList n l
nameBindersList (UnsafeNameBinders RawScope
names) = [RawName] -> NameBinderList n l
forall {i :: S} {l :: S}. [RawName] -> NameBinderList i l
go (RawScope -> [RawName]
IntSet.toList RawScope
names)
  where
    go :: [RawName] -> NameBinderList i l
go []     = NameBinderList (ZonkAny 7) (ZonkAny 7) -> NameBinderList i l
forall a b. a -> b
unsafeCoerce NameBinderList (ZonkAny 7) (ZonkAny 7)
forall (n :: S). NameBinderList n n
NameBinderListEmpty
    go (RawName
x:[RawName]
xs) = NameBinder i i -> NameBinderList i l -> NameBinderList i l
forall (n :: S) (k :: S) (l :: S).
NameBinder n k -> NameBinderList k l -> NameBinderList n l
NameBinderListCons (Name i -> NameBinder i i
forall (n :: S) (l :: S). Name l -> NameBinder n l
UnsafeNameBinder (RawName -> Name i
forall (n :: S). RawName -> Name n
UnsafeName RawName
x)) ([RawName] -> NameBinderList i l
go [RawName]
xs)

-- | The raw names a list of binders binds, outermost first.
--
-- @since 0.4.0
rawNameBinderList :: NameBinderList n l -> [RawName]
rawNameBinderList :: forall (n :: S) (l :: S). NameBinderList n l -> [RawName]
rawNameBinderList NameBinderList n l
NameBinderListEmpty = []
rawNameBinderList (NameBinderListCons NameBinder n i
binder NameBinderList i l
binders) =
  Name i -> RawName
forall (l :: S). Name l -> RawName
nameId (NameBinder n i -> Name i
forall (n :: S) (l :: S). NameBinder n l -> Name l
nameOf NameBinder n i
binder) RawName -> [RawName] -> [RawName]
forall a. a -> [a] -> [a]
: NameBinderList i l -> [RawName]
forall (n :: S) (l :: S). NameBinderList n l -> [RawName]
rawNameBinderList NameBinderList i l
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 :: forall (n :: S) (l :: S) r.
Distinct n =>
NameSet l
-> NameBinderList n l
-> (forall (m :: S).
    (Ext n m, Ext m l, Distinct m) =>
    NameBinderList n m -> r)
-> r
withThinnedNameBinderList (UnsafeNameSet RawScope
keep) NameBinderList n l
binders forall (m :: S).
(Ext n m, Ext m l, Distinct m) =>
NameBinderList n m -> r
cont =
    forall (n :: S) (l :: S) (m :: S) r.
NameBinderList n m
-> ((Ext n m, Ext m l, Distinct m) => NameBinderList n m -> r) -> r
unsafeAssertThinned @n @l
      ([RawName] -> NameBinderList n (ZonkAny 42)
forall {i :: S} {l :: S}. [RawName] -> NameBinderList i l
go ((RawName -> Bool) -> [RawName] -> [RawName]
forall a. (a -> Bool) -> [a] -> [a]
Prelude.filter (RawName -> RawScope -> Bool
`IntSet.member` RawScope
keep) (NameBinderList n l -> [RawName]
forall (n :: S) (l :: S). NameBinderList n l -> [RawName]
rawNameBinderList NameBinderList n l
binders))) (Ext n (ZonkAny 42), Ext (ZonkAny 42) l, Distinct (ZonkAny 42)) =>
NameBinderList n (ZonkAny 42) -> r
NameBinderList n (ZonkAny 42) -> r
forall (m :: S).
(Ext n m, Ext m l, Distinct m) =>
NameBinderList n m -> r
cont
  where
    go :: forall m m'. [RawName] -> NameBinderList m m'
    go :: forall {i :: S} {l :: S}. [RawName] -> NameBinderList i l
go []       = NameBinderList (ZonkAny 40) (ZonkAny 40) -> NameBinderList m m'
forall a b. a -> b
unsafeCoerce NameBinderList (ZonkAny 40) (ZonkAny 40)
forall (n :: S). NameBinderList n n
NameBinderListEmpty
    go (RawName
x : [RawName]
xs) = NameBinder m (ZonkAny 41)
-> NameBinderList (ZonkAny 41) m' -> NameBinderList m m'
forall (n :: S) (k :: S) (l :: S).
NameBinder n k -> NameBinderList k l -> NameBinderList n l
NameBinderListCons (Name (ZonkAny 41) -> NameBinder m (ZonkAny 41)
forall (n :: S) (l :: S). Name l -> NameBinder n l
UnsafeNameBinder (RawName -> Name (ZonkAny 41)
forall (n :: S). RawName -> Name n
UnsafeName RawName
x)) ([RawName] -> NameBinderList (ZonkAny 41) m'
forall {i :: S} {l :: S}. [RawName] -> NameBinderList i l
go [RawName]
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 :: forall (n :: S) (l :: S) (m :: S) r.
NameBinderList n m
-> ((Ext n m, Ext m l, Distinct m) => NameBinderList n m -> r) -> r
unsafeAssertThinned NameBinderList n m
binders (Ext n m, Ext m l, Distinct m) => NameBinderList n m -> r
cont =
  case forall (n :: S). DistinctEvidence n
unsafeDistinct @m of
    DistinctEvidence m
Distinct -> case forall (n :: S) (l :: S). ExtEvidence n l
unsafeExt @n @m of
      ExtEvidence n m
Ext -> case forall (n :: S) (l :: S). ExtEvidence n l
unsafeExt @m @l of
        ExtEvidence m l
Ext -> (Ext n m, Ext m l, Distinct m) => NameBinderList n m -> r
NameBinderList n m -> r
cont NameBinderList n m
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 :: forall (n :: S) (i :: S) (l :: S).
NameBinderList n i -> NameBinder i l -> NameBinderList n l
snocNameBinderList NameBinderList n i
NameBinderListEmpty NameBinder i l
binder =
  NameBinder n l -> NameBinderList l l -> NameBinderList n l
forall (n :: S) (k :: S) (l :: S).
NameBinder n k -> NameBinderList k l -> NameBinderList n l
NameBinderListCons NameBinder n l
NameBinder i l
binder NameBinderList l l
forall (n :: S). NameBinderList n n
NameBinderListEmpty
snocNameBinderList (NameBinderListCons NameBinder n i
binder NameBinderList i i
binders) NameBinder i l
binder' =
  NameBinder n i -> NameBinderList i l -> NameBinderList n l
forall (n :: S) (k :: S) (l :: S).
NameBinder n k -> NameBinderList k l -> NameBinderList n l
NameBinderListCons NameBinder n i
binder (NameBinderList i i -> NameBinder i l -> NameBinderList i l
forall (n :: S) (i :: S) (l :: S).
NameBinderList n i -> NameBinder i l -> NameBinderList n l
snocNameBinderList NameBinderList i i
binders NameBinder i l
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 :: forall (n :: S) (i :: S) (l :: S).
NameBinderList n i -> NameBinderList i l -> NameBinderList n l
concatNameBinderLists NameBinderList n i
NameBinderListEmpty NameBinderList i l
binders = NameBinderList n l
NameBinderList i l
binders
concatNameBinderLists (NameBinderListCons NameBinder n i
binder NameBinderList i i
binders) NameBinderList i l
binders' =
  NameBinder n i -> NameBinderList i l -> NameBinderList n l
forall (n :: S) (k :: S) (l :: S).
NameBinder n k -> NameBinderList k l -> NameBinderList n l
NameBinderListCons NameBinder n i
binder (NameBinderList i i -> NameBinderList i l -> NameBinderList i l
forall (n :: S) (i :: S) (l :: S).
NameBinderList n i -> NameBinderList i l -> NameBinderList n l
concatNameBinderLists NameBinderList i i
binders NameBinderList i l
binders')

-- | Convert an ordered list of name binders into an unordered set.
--
-- @since 0.1.0
fromNameBindersList :: NameBinderList n l -> NameBinders n l
fromNameBindersList :: forall (n :: S) (l :: S). NameBinderList n l -> NameBinders n l
fromNameBindersList = RawScope -> NameBinders n l
forall (n :: S) (l :: S). RawScope -> NameBinders n l
UnsafeNameBinders (RawScope -> NameBinders n l)
-> (NameBinderList n l -> RawScope)
-> NameBinderList n l
-> NameBinders n l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RawName] -> RawScope
IntSet.fromList ([RawName] -> RawScope)
-> (NameBinderList n l -> [RawName])
-> NameBinderList n l
-> RawScope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameBinderList n l -> [RawName]
forall (n :: S) (l :: S). NameBinderList n l -> [RawName]
go
  where
    go :: NameBinderList n l -> [RawName]
    go :: forall (n :: S) (l :: S). NameBinderList n l -> [RawName]
go NameBinderList n l
NameBinderListEmpty                 = []
    go (NameBinderListCons NameBinder n i
binder NameBinderList i l
binders) = Name i -> RawName
forall (l :: S). Name l -> RawName
nameId (NameBinder n i -> Name i
forall (n :: S) (l :: S). NameBinder n l -> Name l
nameOf NameBinder n i
binder) RawName -> [RawName] -> [RawName]
forall a. a -> [a] -> [a]
: NameBinderList i l -> [RawName]
forall (n :: S) (l :: S). NameBinderList n l -> [RawName]
go NameBinderList i l
binders

instance CoSinkable NameBinders where
  coSinkabilityProof :: forall (n :: S) (n' :: S) (l :: S) r.
(Name n -> Name n')
-> NameBinders n l
-> (forall (l' :: S).
    (Name l -> Name l') -> NameBinders n' l' -> r)
-> r
coSinkabilityProof Name n -> Name n'
_rename (UnsafeNameBinders RawScope
names) forall (l' :: S). (Name l -> Name l') -> NameBinders n' l' -> r
cont =
    (Name l -> Name (ZonkAny 43)) -> NameBinders n' (ZonkAny 43) -> r
forall (l' :: S). (Name l -> Name l') -> NameBinders n' l' -> r
cont Name l -> Name (ZonkAny 43)
forall a b. a -> b
unsafeCoerce (RawScope -> NameBinders n' (ZonkAny 43)
forall (n :: S) (l :: S). RawScope -> NameBinders n l
UnsafeNameBinders RawScope
names)

  withPattern :: forall (o :: S) (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
Distinct o =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (DExt z z', DExt z' z'') =>
    f x y z z' -> f y y' z' z'' -> f x y' z z'')
-> Scope o
-> NameBinders n l
-> (forall (o' :: S).
    DExt o o' =>
    f n l o o' -> NameBinders o o' -> Scope o' -> r)
-> r
withPattern forall (x :: S) (y :: S) (z :: S) r'.
Distinct z =>
Scope z
-> NameBinder x y
-> (forall (z' :: S).
    DExt z z' =>
    f x y z z' -> NameBinder z z' -> r')
-> r'
withBinder forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z'
unit forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S) (z'' :: S).
(DExt z z', DExt z' z'') =>
f x y z z' -> f y y' z' z'' -> f x y' z z''
comp Scope o
scope NameBinders n l
binders forall (o' :: S).
DExt o o' =>
f n l o o' -> NameBinders o o' -> Scope o' -> r
cont =
    (forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (DExt z z', DExt z' z'') =>
    f x y z z' -> f y y' z' z'' -> f x y' z z'')
-> Scope o
-> NameBinderList n l
-> (forall (o' :: S).
    DExt o o' =>
    f n l o o' -> NameBinderList o o' -> Scope o' -> r)
-> r
forall (o :: S) (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
Distinct o =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (DExt z z', DExt z' z'') =>
    f x y z z' -> f y y' z' z'' -> f x y' z z'')
-> Scope o
-> NameBinderList n l
-> (forall (o' :: S).
    DExt o o' =>
    f n l o o' -> NameBinderList o o' -> Scope o' -> r)
-> r
forall (pattern :: S -> S -> *) (o :: S)
       (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
(CoSinkable pattern, Distinct o) =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (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' :: S).
    DExt o o' =>
    f n l o o' -> pattern o o' -> Scope o' -> r)
-> r
withPattern Scope z
-> NameBinder x y
-> (forall (z' :: S).
    DExt z z' =>
    f x y z z' -> NameBinder z z' -> r')
-> r'
forall (x :: S) (y :: S) (z :: S) r'.
Distinct z =>
Scope z
-> NameBinder x y
-> (forall (z' :: S).
    DExt z z' =>
    f x y z z' -> NameBinder z z' -> r')
-> r'
withBinder f x x z z'
forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z'
unit f x y z z' -> f y y' z' z'' -> f x y' z z''
forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S) (z'' :: S).
(DExt z z', DExt z' z'') =>
f x y z z' -> f y y' z' z'' -> f x y' z z''
comp Scope o
scope (NameBinders n l -> NameBinderList n l
forall (n :: S) (l :: S). NameBinders n l -> NameBinderList n l
nameBindersList NameBinders n l
binders) ((forall (o' :: S).
  DExt o o' =>
  f n l o o' -> NameBinderList o o' -> Scope o' -> r)
 -> r)
-> (forall (o' :: S).
    DExt o o' =>
    f n l o o' -> NameBinderList o o' -> Scope o' -> r)
-> r
forall a b. (a -> b) -> a -> b
$ \f n l o o'
f NameBinderList o o'
binders' Scope o'
scope' ->
      f n l o o' -> NameBinders o o' -> Scope o' -> r
forall (o' :: S).
DExt o o' =>
f n l o o' -> NameBinders o o' -> Scope o' -> r
cont f n l o o'
f (NameBinderList o o' -> NameBinders o o'
forall (n :: S) (l :: S). NameBinderList n l -> NameBinders n l
fromNameBindersList NameBinderList o o'
binders') Scope o'
scope'

instance CoSinkable NameBinderList where
  coSinkabilityProof :: forall (n :: S) (n' :: S) (l :: S) r.
(Name n -> Name n')
-> NameBinderList n l
-> (forall (l' :: S).
    (Name l -> Name l') -> NameBinderList n' l' -> r)
-> r
coSinkabilityProof Name n -> Name n'
rename NameBinderList n l
NameBinderListEmpty forall (l' :: S). (Name l -> Name l') -> NameBinderList n' l' -> r
cont = (Name l -> Name n') -> NameBinderList n' n' -> r
forall (l' :: S). (Name l -> Name l') -> NameBinderList n' l' -> r
cont Name n -> Name n'
Name l -> Name n'
rename NameBinderList n' n'
forall (n :: S). NameBinderList n n
NameBinderListEmpty
  coSinkabilityProof Name n -> Name n'
rename (NameBinderListCons NameBinder n i
binder NameBinderList i l
binders) forall (l' :: S). (Name l -> Name l') -> NameBinderList n' l' -> r
cont =
    (Name n -> Name n')
-> NameBinder n i
-> (forall (l' :: S). (Name i -> Name l') -> NameBinder n' l' -> r)
-> r
forall (n :: S) (n' :: S) (l :: S) r.
(Name n -> Name n')
-> NameBinder n l
-> (forall (l' :: S). (Name l -> Name l') -> NameBinder n' l' -> r)
-> r
forall (pattern :: S -> S -> *) (n :: S) (n' :: S) (l :: S) r.
CoSinkable pattern =>
(Name n -> Name n')
-> pattern n l
-> (forall (l' :: S). (Name l -> Name l') -> pattern n' l' -> r)
-> r
coSinkabilityProof Name n -> Name n'
rename NameBinder n i
binder ((forall (l' :: S). (Name i -> Name l') -> NameBinder n' l' -> r)
 -> r)
-> (forall (l' :: S). (Name i -> Name l') -> NameBinder n' l' -> r)
-> r
forall a b. (a -> b) -> a -> b
$ \Name i -> Name l'
rename' NameBinder n' l'
binder' ->
      (Name i -> Name l')
-> NameBinderList i l
-> (forall (l' :: S).
    (Name l -> Name l') -> NameBinderList l' l' -> r)
-> r
forall (n :: S) (n' :: S) (l :: S) r.
(Name n -> Name n')
-> NameBinderList n l
-> (forall (l' :: S).
    (Name l -> Name l') -> NameBinderList n' l' -> r)
-> r
forall (pattern :: S -> S -> *) (n :: S) (n' :: S) (l :: S) r.
CoSinkable pattern =>
(Name n -> Name n')
-> pattern n l
-> (forall (l' :: S). (Name l -> Name l') -> pattern n' l' -> r)
-> r
coSinkabilityProof Name i -> Name l'
rename' NameBinderList i l
binders ((forall (l' :: S).
  (Name l -> Name l') -> NameBinderList l' l' -> r)
 -> r)
-> (forall (l' :: S).
    (Name l -> Name l') -> NameBinderList l' l' -> r)
-> r
forall a b. (a -> b) -> a -> b
$ \Name l -> Name l'
rename'' NameBinderList l' l'
binders' ->
        (Name l -> Name l') -> NameBinderList n' l' -> r
forall (l' :: S). (Name l -> Name l') -> NameBinderList n' l' -> r
cont Name l -> Name l'
rename'' (NameBinder n' l' -> NameBinderList l' l' -> NameBinderList n' l'
forall (n :: S) (k :: S) (l :: S).
NameBinder n k -> NameBinderList k l -> NameBinderList n l
NameBinderListCons NameBinder n' l'
binder' NameBinderList l' l'
binders')

  withPattern :: forall (o :: S) (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
Distinct o =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (DExt z z', DExt z' z'') =>
    f x y z z' -> f y y' z' z'' -> f x y' z z'')
-> Scope o
-> NameBinderList n l
-> (forall (o' :: S).
    DExt o o' =>
    f n l o o' -> NameBinderList o o' -> Scope o' -> r)
-> r
withPattern forall (x :: S) (y :: S) (z :: S) r'.
Distinct z =>
Scope z
-> NameBinder x y
-> (forall (z' :: S).
    DExt z z' =>
    f x y z z' -> NameBinder z z' -> r')
-> r'
withBinder forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z'
unit forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S) (z'' :: S).
(DExt z z', DExt z' z'') =>
f x y z z' -> f y y' z' z'' -> f x y' z z''
comp Scope o
scope NameBinderList n l
binders forall (o' :: S).
DExt o o' =>
f n l o o' -> NameBinderList o o' -> Scope o' -> r
cont = case NameBinderList n l
binders of
    NameBinderList n l
NameBinderListEmpty -> f n l o o -> NameBinderList o o -> Scope o -> r
forall (o' :: S).
DExt o o' =>
f n l o o' -> NameBinderList o o' -> Scope o' -> r
cont f n l o o
f l l o o
forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z'
unit NameBinderList o o
forall (n :: S). NameBinderList n n
NameBinderListEmpty Scope o
scope
    NameBinderListCons NameBinder n i
x NameBinderList i l
xs ->
      Scope o
-> NameBinder n i
-> (forall (z' :: S).
    DExt o z' =>
    f n i o z' -> NameBinder o z' -> r)
-> r
forall (x :: S) (y :: S) (z :: S) r'.
Distinct z =>
Scope z
-> NameBinder x y
-> (forall (z' :: S).
    DExt z z' =>
    f x y z z' -> NameBinder z z' -> r')
-> r'
withBinder Scope o
scope NameBinder n i
x ((forall (z' :: S).
  DExt o z' =>
  f n i o z' -> NameBinder o z' -> r)
 -> r)
-> (forall (z' :: S).
    DExt o z' =>
    f n i o z' -> NameBinder o z' -> r)
-> r
forall a b. (a -> b) -> a -> b
$ \f n i o z'
f NameBinder o z'
x' ->
        let scope' :: Scope z'
scope' = NameBinder o z' -> Scope o -> Scope z'
forall (n :: S) (l :: S). NameBinder n l -> Scope n -> Scope l
extendScope NameBinder o z'
x' Scope o
scope
        in (forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (DExt z z', DExt z' z'') =>
    f x y z z' -> f y y' z' z'' -> f x y' z z'')
-> Scope z'
-> NameBinderList i l
-> (forall (o' :: S).
    DExt z' o' =>
    f i l z' o' -> NameBinderList z' o' -> Scope o' -> r)
-> r
forall (o :: S) (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
Distinct o =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (DExt z z', DExt z' z'') =>
    f x y z z' -> f y y' z' z'' -> f x y' z z'')
-> Scope o
-> NameBinderList n l
-> (forall (o' :: S).
    DExt o o' =>
    f n l o o' -> NameBinderList o o' -> Scope o' -> r)
-> r
forall (pattern :: S -> S -> *) (o :: S)
       (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
(CoSinkable pattern, Distinct o) =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (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' :: S).
    DExt o o' =>
    f n l o o' -> pattern o o' -> Scope o' -> r)
-> r
withPattern Scope z
-> NameBinder x y
-> (forall (z' :: S).
    DExt z z' =>
    f x y z z' -> NameBinder z z' -> r')
-> r'
forall (x :: S) (y :: S) (z :: S) r'.
Distinct z =>
Scope z
-> NameBinder x y
-> (forall (z' :: S).
    DExt z z' =>
    f x y z z' -> NameBinder z z' -> r')
-> r'
withBinder f x x z z'
forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z'
unit f x y z z' -> f y y' z' z'' -> f x y' z z''
forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S) (z'' :: S).
(DExt z z', DExt z' z'') =>
f x y z z' -> f y y' z' z'' -> f x y' z z''
comp Scope z'
scope' NameBinderList i l
xs ((forall (o' :: S).
  DExt z' o' =>
  f i l z' o' -> NameBinderList z' o' -> Scope o' -> r)
 -> r)
-> (forall (o' :: S).
    DExt z' o' =>
    f i l z' o' -> NameBinderList z' o' -> Scope o' -> r)
-> r
forall a b. (a -> b) -> a -> b
$ \f i l z' o'
f' NameBinderList z' o'
xs' Scope o'
scope'' ->
            f n l o o' -> NameBinderList o o' -> Scope o' -> r
forall (o' :: S).
DExt o o' =>
f n l o o' -> NameBinderList o o' -> Scope o' -> r
cont (f n i o z' -> f i l z' o' -> f n l o o'
forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S) (z'' :: S).
(DExt z z', DExt z' z'') =>
f x y z z' -> f y y' z' z'' -> f x y' z z''
comp f n i o z'
f f i l z' o'
f') (NameBinder o z' -> NameBinderList z' o' -> NameBinderList o o'
forall (n :: S) (k :: S) (l :: S).
NameBinder n k -> NameBinderList k l -> NameBinderList n l
NameBinderListCons NameBinder o z'
x' NameBinderList z' o'
xs') Scope o'
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 :: forall (n :: S) (l :: S) a. V2 n l -> a
absurd2 V2 n l
v2 = case V2 n l
v2 of {}

instance CoSinkable V2 where
  coSinkabilityProof :: forall (n :: S) (n' :: S) (l :: S) r.
(Name n -> Name n')
-> V2 n l
-> (forall (l' :: S). (Name l -> Name l') -> V2 n' l' -> r)
-> r
coSinkabilityProof Name n -> Name n'
_ V2 n l
v2 forall (l' :: S). (Name l -> Name l') -> V2 n' l' -> r
_ = V2 n l -> r
forall (n :: S) (l :: S) a. V2 n l -> a
absurd2 V2 n l
v2
  withPattern :: forall (o :: S) (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
Distinct o =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (DExt z z', DExt z' z'') =>
    f x y z z' -> f y y' z' z'' -> f x y' z z'')
-> Scope o
-> V2 n l
-> (forall (o' :: S).
    DExt o o' =>
    f n l o o' -> V2 o o' -> Scope o' -> r)
-> r
withPattern forall (x :: S) (y :: S) (z :: S) r'.
Distinct z =>
Scope z
-> NameBinder x y
-> (forall (z' :: S).
    DExt z z' =>
    f x y z z' -> NameBinder z z' -> r')
-> r'
_ forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z'
_ forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S) (z'' :: S).
(DExt z z', DExt z' z'') =>
f x y z z' -> f y y' z' z'' -> f x y' z z''
_ Scope o
_ V2 n l
v2 forall (o' :: S).
DExt o o' =>
f n l o o' -> V2 o o' -> Scope o' -> r
_ = V2 n l -> r
forall (n :: S) (l :: S) a. V2 n l -> a
absurd2 V2 n l
v2
instance UnifiablePattern V2 where
  unifyPatterns :: forall (n :: S) (l :: S) (r :: S).
Distinct n =>
V2 n l -> V2 n r -> UnifyNameBinders V2 n l r
unifyPatterns = V2 n l -> V2 n r -> UnifyNameBinders V2 n l r
forall (n :: S) (l :: S) a. V2 n l -> a
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 :: forall (n :: S) (n' :: S) (l :: S) r.
(Name n -> Name n')
-> U2 n l
-> (forall (l' :: S). (Name l -> Name l') -> U2 n' l' -> r)
-> r
coSinkabilityProof Name n -> Name n'
rename U2 n l
U2 forall (l' :: S). (Name l -> Name l') -> U2 n' l' -> r
cont = (Name l -> Name n') -> U2 n' n' -> r
forall (l' :: S). (Name l -> Name l') -> U2 n' l' -> r
cont Name n -> Name n'
Name l -> Name n'
rename U2 n' n'
forall (n :: S). U2 n n
U2
  withPattern :: forall (o :: S) (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
Distinct o =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (DExt z z', DExt z' z'') =>
    f x y z z' -> f y y' z' z'' -> f x y' z z'')
-> Scope o
-> U2 n l
-> (forall (o' :: S).
    DExt o o' =>
    f n l o o' -> U2 o o' -> Scope o' -> r)
-> r
withPattern forall (x :: S) (y :: S) (z :: S) r'.
Distinct z =>
Scope z
-> NameBinder x y
-> (forall (z' :: S).
    DExt z z' =>
    f x y z z' -> NameBinder z z' -> r')
-> r'
_withBinder forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z'
unit forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S) (z'' :: S).
(DExt z z', DExt z' z'') =>
f x y z z' -> f y y' z' z'' -> f x y' z z''
_combine Scope o
scope U2 n l
U2 forall (o' :: S).
DExt o o' =>
f n l o o' -> U2 o o' -> Scope o' -> r
cont = f n l o o -> U2 o o -> Scope o -> r
forall (o' :: S).
DExt o o' =>
f n l o o' -> U2 o o' -> Scope o' -> r
cont f n l o o
f l l o o
forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z'
unit U2 o o
forall (n :: S). U2 n n
U2 Scope o
scope
instance UnifiablePattern U2 where
  unifyPatterns :: forall (n :: S) (l :: S) (r :: S).
Distinct n =>
U2 n l -> U2 n r -> UnifyNameBinders U2 n l r
unifyPatterns U2 n l
U2 U2 n r
U2 = NameBinders n l -> UnifyNameBinders U2 n l l
forall (n :: S) (l :: S) (pattern :: S -> S -> *).
NameBinders n l -> UnifyNameBinders pattern n l l
SameNameBinders NameBinders n n
NameBinders n l
forall (n :: S). NameBinders n n
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 pattern n l
l pattern n r
r = UnifyNameBinders NameBinderList n l r
-> UnifyNameBinders pattern n l r
forall a b. Coercible a b => a -> b
coerce (NameBinderList n l
-> NameBinderList n r -> UnifyNameBinders NameBinderList n l r
forall (n :: S) (l :: S) (r :: S).
Distinct n =>
NameBinderList n l
-> NameBinderList n r -> UnifyNameBinders NameBinderList n l r
forall (pattern :: S -> S -> *) (n :: S) (l :: S) (r :: S).
(UnifiablePattern pattern, Distinct n) =>
pattern n l -> pattern n r -> UnifyNameBinders pattern n l r
unifyPatterns (pattern n l -> NameBinderList n l
forall (binder :: S -> S -> *) (n :: S) (l :: S).
CoSinkable binder =>
binder n l -> NameBinderList n l
nameBinderListOf pattern n l
l) (pattern n r -> NameBinderList n r
forall (binder :: S -> S -> *) (n :: S) (l :: S).
CoSinkable binder =>
binder n l -> NameBinderList n l
nameBinderListOf pattern n r
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 n
_scope = pattern n l -> pattern n r -> UnifyNameBinders pattern n l r
forall (n :: S) (l :: S) (r :: S).
Distinct n =>
pattern n l -> pattern n r -> UnifyNameBinders pattern n l r
forall (pattern :: S -> S -> *) (n :: S) (l :: S) (r :: S).
(UnifiablePattern pattern, Distinct n) =>
pattern n l -> pattern n r -> UnifyNameBinders pattern n l r
unifyPatterns

instance UnifiablePattern NameBinderList where
  unifyPatterns :: forall (n :: S) (l :: S) (r :: S).
Distinct n =>
NameBinderList n l
-> NameBinderList n r -> UnifyNameBinders NameBinderList n l r
unifyPatterns NameBinderList n l
NameBinderListEmpty NameBinderList n r
NameBinderListEmpty = NameBinders n l -> UnifyNameBinders NameBinderList n l l
forall (n :: S) (l :: S) (pattern :: S -> S -> *).
NameBinders n l -> UnifyNameBinders pattern n l l
SameNameBinders NameBinders n n
NameBinders n l
forall (n :: S). NameBinders n n
emptyNameBinders
  unifyPatterns (NameBinderListCons NameBinder n i
x NameBinderList i l
xs) (NameBinderListCons NameBinder n i
y NameBinderList i r
ys) =
    case (NameBinder n i -> DistinctEvidence i
forall (n :: S) (pattern :: S -> S -> *) (l :: S).
(Distinct n, CoSinkable pattern) =>
pattern n l -> DistinctEvidence l
assertDistinct NameBinder n i
x, NameBinder n i -> DistinctEvidence i
forall (n :: S) (pattern :: S -> S -> *) (l :: S).
(Distinct n, CoSinkable pattern) =>
pattern n l -> DistinctEvidence l
assertDistinct NameBinder n i
y) of
      (DistinctEvidence i
Distinct, DistinctEvidence i
Distinct) -> NameBinder n i
-> NameBinder n i -> UnifyNameBinders NameBinderList n i i
forall (i :: S) (l :: S) (r :: S) (pattern :: S -> S -> *).
Distinct i =>
NameBinder i l -> NameBinder i r -> UnifyNameBinders pattern i l r
unifyNameBinders NameBinder n i
x NameBinder n i
y UnifyNameBinders NameBinderList n i i
-> (NameBinderList i l, NameBinderList i r)
-> UnifyNameBinders NameBinderList n l r
forall (pattern :: S -> S -> *) (l :: S) (l' :: S) (n :: S)
       (r :: S) (r' :: S).
(UnifiablePattern pattern, Distinct l, Distinct l') =>
UnifyNameBinders pattern n l l'
-> (pattern l r, pattern l' r') -> UnifyNameBinders pattern n r r'
`andThenUnifyPatterns` (NameBinderList i l
xs, NameBinderList i r
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 NameBinderList n l
_ NameBinderList n r
_ = UnifyNameBinders NameBinderList n l r
forall (pattern :: S -> S -> *) (n :: S) (l :: S) (r :: S).
UnifyNameBinders pattern n l r
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 :: forall (n :: S). Distinct n => Scope n -> Name n -> Name n -> Bool
alphaEquivIn Scope n
_scope = Name n -> Name n -> Bool
forall a. Eq a => a -> a -> Bool
(==)

-- | 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 = a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==)

instance UnifiablePattern NameBinder where
  unifyPatterns :: forall (n :: S) (l :: S) (r :: S).
Distinct n =>
NameBinder n l
-> NameBinder n r -> UnifyNameBinders NameBinder n l r
unifyPatterns = NameBinder n l
-> NameBinder n r -> UnifyNameBinders NameBinder n l r
forall (i :: S) (l :: S) (r :: S) (pattern :: S -> S -> *).
Distinct i =>
NameBinder i l -> NameBinder i r -> UnifyNameBinders pattern i l r
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 :: forall (pattern :: S -> S -> *) (n :: S) (l :: S) (n' :: S)
       (l' :: S).
(UnifiablePattern pattern, Distinct n) =>
pattern n l -> pattern n' l' -> Bool
unsafeEqPattern pattern n l
l pattern n' l'
r =
  case pattern n l
-> pattern n (ZonkAny 6)
-> UnifyNameBinders pattern n l (ZonkAny 6)
forall (n :: S) (l :: S) (r :: S).
Distinct n =>
pattern n l -> pattern n r -> UnifyNameBinders pattern n l r
forall (pattern :: S -> S -> *) (n :: S) (l :: S) (r :: S).
(UnifiablePattern pattern, Distinct n) =>
pattern n l -> pattern n r -> UnifyNameBinders pattern n l r
unifyPatterns pattern n l
l (pattern n' l' -> pattern n (ZonkAny 6)
forall a b. a -> b
unsafeCoerce pattern n' l'
r) of
    SameNameBinders{} -> Bool
True
    UnifyNameBinders pattern n l (ZonkAny 6)
_                 -> Bool
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 Name n -> Name l
rename = RepK e (l ':&&: 'LoT0) -> e l
RepK e (l ':&&: 'LoT0) -> e :@@: (l ':&&: 'LoT0)
forall k (f :: k) (x :: LoT k). GenericK f => RepK f x -> f :@@: x
forall (x :: LoT (S -> *)). RepK e x -> e :@@: x
toK (RepK e (l ':&&: 'LoT0) -> e l)
-> (e n -> RepK e (l ':&&: 'LoT0)) -> e n -> e l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name n -> Name l)
-> RepK e (n ':&&: 'LoT0) -> RepK e (l ':&&: 'LoT0)
forall (f :: LoT (S -> *) -> *) (n :: S) (n' :: S).
GSinkableK f =>
(Name n -> Name n') -> f (n ':&&: 'LoT0) -> f (n' ':&&: 'LoT0)
gsinkabilityProof1 Name n -> Name l
rename (RepK e (n ':&&: 'LoT0) -> RepK e (l ':&&: 'LoT0))
-> (e n -> RepK e (n ':&&: 'LoT0)) -> e n -> RepK e (l ':&&: 'LoT0)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e n -> RepK e (n ':&&: 'LoT0)
(e :@@: (n ':&&: 'LoT0)) -> RepK e (n ':&&: 'LoT0)
forall k (f :: k) (x :: LoT k).
GenericK f =>
(f :@@: x) -> RepK f x
forall (x :: LoT (S -> *)). (e :@@: x) -> RepK e x
fromK

-- | Sinking a 'Name' is as simple as applying the renaming.
instance Sinkable Name where
  sinkabilityProof :: forall (n :: S) (l :: S). (Name n -> Name l) -> Name n -> Name l
sinkabilityProof Name n -> Name l
rename = Name n -> Name l
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 :: forall (n :: S) (l :: S).
(Name n -> Name l) -> Compose f e n -> Compose f e l
sinkabilityProof Name n -> Name l
rename (Compose f (e n)
xs) = f (e l) -> Compose f e l
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose ((e n -> e l) -> f (e n) -> f (e l)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Name n -> Name l) -> e n -> e l
forall (n :: S) (l :: S). (Name n -> Name l) -> e n -> e l
forall (e :: S -> *) (n :: S) (l :: S).
Sinkable e =>
(Name n -> Name l) -> e n -> e l
sinkabilityProof Name n -> Name l
rename) f (e n)
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 :: forall (e :: S -> *) (n :: S) (l :: S).
(Sinkable e, DExt n l) =>
e n -> e l
sink = e n -> e l
forall a b. a -> b
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 :: forall (f :: * -> *) (e :: S -> *) (n :: S) (l :: S).
(Functor f, Sinkable e, DExt n l) =>
f (e n) -> f (e l)
sink1 = Compose f e l -> f (e l)
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose f e l -> f (e l))
-> (f (e n) -> Compose f e l) -> f (e n) -> f (e l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose f e n -> Compose f e l
forall (e :: S -> *) (n :: S) (l :: S).
(Sinkable e, DExt n l) =>
e n -> e l
sink (Compose f e n -> Compose f e l)
-> (f (e n) -> Compose f e n) -> f (e n) -> Compose f e l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (e n) -> Compose f e n
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
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 :: forall (f :: * -> *) (e :: S -> *) (n :: S) (l :: S).
(Functor f, Sinkable e, DExt n l) =>
f (e n) -> f (e l)
sinkContainer = f (e n) -> f (e l)
forall (f :: * -> *) (e :: S -> *) (n :: S) (l :: S).
(Functor f, Sinkable e, DExt n l) =>
f (e n) -> f (e l)
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 :: forall (p :: * -> * -> *) (e1 :: S -> *) (e2 :: S -> *) (n :: S)
       (n' :: S) (m :: S) (m' :: S).
(Bifunctor p, Sinkable e1, Sinkable e2) =>
(Name n -> Name n')
-> (Name m -> Name m') -> p (e1 n) (e2 m) -> p (e1 n') (e2 m')
sinkabilityProof2 Name n -> Name n'
rename1 Name m -> Name m'
rename2 =
  (e1 n -> e1 n')
-> (e2 m -> e2 m') -> p (e1 n) (e2 m) -> p (e1 n') (e2 m')
forall a b c d. (a -> b) -> (c -> d) -> p a c -> p b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((Name n -> Name n') -> e1 n -> e1 n'
forall (n :: S) (l :: S). (Name n -> Name l) -> e1 n -> e1 l
forall (e :: S -> *) (n :: S) (l :: S).
Sinkable e =>
(Name n -> Name l) -> e n -> e l
sinkabilityProof Name n -> Name n'
rename1) ((Name m -> Name m') -> e2 m -> e2 m'
forall (n :: S) (l :: S). (Name n -> Name l) -> e2 n -> e2 l
forall (e :: S -> *) (n :: S) (l :: S).
Sinkable e =>
(Name n -> Name l) -> e n -> e l
sinkabilityProof Name m -> Name m'
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 :: forall (p :: * -> * -> *) (e1 :: S -> *) (e2 :: S -> *) (n :: S)
       (n' :: S) (m :: S) (m' :: S).
(Bifunctor p, Sinkable e1, Sinkable e2, DExt n n', DExt m m') =>
p (e1 n) (e2 m) -> p (e1 n') (e2 m')
sink2 = p (e1 n) (e2 m) -> p (e1 n') (e2 m')
forall a b. a -> b
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 :: forall (pattern :: S -> S -> *) (n :: S) (n' :: S) (l :: S) r.
CoSinkable pattern =>
(Name n -> Name n')
-> pattern n l
-> (forall (l' :: S). (Name l -> Name l') -> pattern n' l' -> r)
-> r
extendRenaming Name n -> Name n'
_ pattern n l
pattern forall (l' :: S). (Name l -> Name l') -> pattern n' l' -> r
cont =
  (Name l -> Name (ZonkAny 5)) -> pattern n' (ZonkAny 5) -> r
forall (l' :: S). (Name l -> Name l') -> pattern n' l' -> r
cont Name l -> Name (ZonkAny 5)
forall a b. a -> b
unsafeCoerce (pattern n l -> pattern n' (ZonkAny 5)
forall a b. a -> b
unsafeCoerce pattern n l
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 :: forall (pattern :: S -> S -> *) (i :: S) (n :: S) (n' :: S)
       (l :: S) r.
CoSinkable pattern =>
(NameBinder i n -> NameBinder i n')
-> pattern n l
-> (forall (l' :: S).
    (NameBinder n' l -> NameBinder n' l') -> pattern n' l' -> r)
-> r
extendNameBinderRenaming NameBinder i n -> NameBinder i n'
_ pattern n l
pattern forall (l' :: S).
(NameBinder n' l -> NameBinder n' l') -> pattern n' l' -> r
cont =
  (NameBinder n' l -> NameBinder n' (ZonkAny 4))
-> pattern n' (ZonkAny 4) -> r
forall (l' :: S).
(NameBinder n' l -> NameBinder n' l') -> pattern n' l' -> r
cont NameBinder n' l -> NameBinder n' (ZonkAny 4)
forall a b. a -> b
unsafeCoerce (pattern n l -> pattern n' (ZonkAny 4)
forall a b. a -> b
unsafeCoerce pattern n l
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 :: forall (n :: S) (i :: S) (i' :: S) (l :: S) (l' :: S).
(NameBinder n i -> NameBinder n i')
-> (NameBinder i' l -> NameBinder i' l')
-> NameBinder n l
-> NameBinder n l'
composeNameBinderRenamings = ((ZonkAny 1 -> ZonkAny 2)
 -> (ZonkAny 2 -> ZonkAny 3) -> ZonkAny 1 -> ZonkAny 3)
-> (NameBinder n i -> NameBinder n i')
-> (NameBinder i' l -> NameBinder i' l')
-> NameBinder n l
-> NameBinder n l'
forall a b. a -> b
unsafeCoerce (((ZonkAny 2 -> ZonkAny 3)
 -> (ZonkAny 1 -> ZonkAny 2) -> ZonkAny 1 -> ZonkAny 3)
-> (ZonkAny 1 -> ZonkAny 2)
-> (ZonkAny 2 -> ZonkAny 3)
-> ZonkAny 1
-> ZonkAny 3
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ZonkAny 2 -> ZonkAny 3)
-> (ZonkAny 1 -> ZonkAny 2) -> ZonkAny 1 -> ZonkAny 3
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.))

-- | 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 :: forall (n :: S) (l :: S) (l' :: S).
(NameBinder n l -> NameBinder n l') -> Name l -> Name l'
fromNameBinderRenaming = (NameBinder n l -> NameBinder n l') -> Name l -> Name l'
forall a b. Coercible a b => a -> b
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 :: forall (n :: S) (n' :: S) (l :: S) r.
(Name n -> Name n')
-> NameBinder n l
-> (forall (l' :: S). (Name l -> Name l') -> NameBinder n' l' -> r)
-> r
extendRenamingNameBinder Name n -> Name n'
_ (UnsafeNameBinder Name l
name) forall (l' :: S). (Name l -> Name l') -> NameBinder n' l' -> r
cont =
  (Name l -> Name l) -> NameBinder n' l -> r
forall (l' :: S). (Name l -> Name l') -> NameBinder n' l' -> r
cont Name l -> Name l
forall a b. a -> b
unsafeCoerce (Name l -> NameBinder n' l
forall (n :: S) (l :: S). Name l -> NameBinder n l
UnsafeNameBinder Name l
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 Name n -> Name n'
rename pattern n l
p forall (l' :: S). (Name l -> Name l') -> pattern n' l' -> r
cont = (Name n -> Name n')
-> RepK pattern (n ':&&: (l ':&&: 'LoT0))
-> (forall (l' :: S).
    (Name l -> Name l')
    -> RepK pattern (n' ':&&: (l' ':&&: 'LoT0)) -> r)
-> r
forall (f :: LoT (S -> S -> *) -> *) (n :: S) (n' :: S) (l :: S) r.
GSinkableK f =>
(Name n -> Name n')
-> f (n ':&&: (l ':&&: 'LoT0))
-> (forall (l' :: S).
    (Name l -> Name l') -> f (n' ':&&: (l' ':&&: 'LoT0)) -> r)
-> r
gsinkabilityProof2 Name n -> Name n'
rename (forall k (f :: k) (x :: LoT k).
GenericK f =>
(f :@@: x) -> RepK f x
fromK @_ @pattern pattern n l
pattern :@@: (n ':&&: (l ':&&: 'LoT0))
p) ((forall (l' :: S).
  (Name l -> Name l')
  -> RepK pattern (n' ':&&: (l' ':&&: 'LoT0)) -> r)
 -> r)
-> (forall (l' :: S).
    (Name l -> Name l')
    -> RepK pattern (n' ':&&: (l' ':&&: 'LoT0)) -> r)
-> r
forall a b. (a -> b) -> a -> b
$ \Name l -> Name l'
rename' RepK pattern (n' ':&&: (l' ':&&: 'LoT0))
p' ->
    (Name l -> Name l') -> pattern n' l' -> r
forall (l' :: S). (Name l -> Name l') -> pattern n' l' -> r
cont Name l -> Name l'
rename' (forall k (f :: k) (x :: LoT k). GenericK f => RepK f x -> f :@@: x
toK @_ @pattern RepK pattern (n' ':&&: (l' ':&&: 'LoT0))
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 = (forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (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' :: S).
    DExt o o' =>
    f n l o o' -> pattern o o' -> Scope o' -> r)
-> r
forall (pattern :: S -> S -> *) (f :: S -> S -> S -> S -> *)
       (o :: S) (n :: S) (l :: S) r.
(Distinct o, GenericK pattern,
 GValidNameBinders pattern (RepK pattern),
 GHasNameBinders (RepK pattern)) =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (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' :: S).
    DExt o o' =>
    f n l o o' -> pattern o o' -> Scope o' -> r)
-> r
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 :: forall (n :: S) (o :: S). PatternTransport n o
verbatimTransport = PatternTransport n o
forall (n :: S) (o :: S). PatternTransport n o
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 :: forall (n :: S) (o :: S) (i :: S) (o' :: S).
PatternTransport n o
-> NameBinder n i -> NameBinder o o' -> PatternTransport i o'
transportUnderBinder PatternTransport n o
transport NameBinder n i
binder NameBinder o o'
binder'
  | PatternTransport n o
TransportVerbatim <- PatternTransport n o
transport, Bool
unchanged = PatternTransport i o'
forall (n :: S) (o :: S). PatternTransport n o
TransportVerbatim
  | Bool
otherwise = (Name i -> Name o') -> PatternTransport i o'
forall (n :: S) (o :: S).
(Name n -> Name o) -> PatternTransport n o
TransportRenamed ((Name i -> Name o') -> PatternTransport i o')
-> (Name i -> Name o') -> PatternTransport i o'
forall a b. (a -> b) -> a -> b
$ \Name i
name ->
      if Name i -> RawName
forall (l :: S). Name l -> RawName
nameId Name i
name RawName -> RawName -> Bool
forall a. Eq a => a -> a -> Bool
== Name i -> RawName
forall (l :: S). Name l -> RawName
nameId (NameBinder n i -> Name i
forall (n :: S) (l :: S). NameBinder n l -> Name l
nameOf NameBinder n i
binder)
        then NameBinder o o' -> Name o'
forall (n :: S) (l :: S). NameBinder n l -> Name l
nameOf NameBinder o o'
binder'
        else Name o -> Name o'
forall a b. a -> b
unsafeCoerce (PatternTransport n o -> Name n -> Name o
forall (n :: S) (o :: S). PatternTransport n o -> Name n -> Name o
transportName PatternTransport n o
transport (Name i -> Name n
forall a b. a -> b
unsafeCoerce Name i
name))
  where
    unchanged :: Bool
unchanged = Name i -> RawName
forall (l :: S). Name l -> RawName
nameId (NameBinder n i -> Name i
forall (n :: S) (l :: S). NameBinder n l -> Name l
nameOf NameBinder n i
binder) RawName -> RawName -> Bool
forall a. Eq a => a -> a -> Bool
== Name o' -> RawName
forall (l :: S). Name l -> RawName
nameId (NameBinder o o' -> Name o'
forall (n :: S) (l :: S). NameBinder n l -> Name l
nameOf NameBinder o o'
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 :: forall (e :: S -> *) (n :: S) (o :: S).
Sinkable e =>
PatternTransport n o -> e n -> e o
transportPayload PatternTransport n o
TransportVerbatim         = e n -> e o
forall a b. a -> b
unsafeCoerce
transportPayload (TransportRenamed Name n -> Name o
rename) = (Name n -> Name o) -> e n -> e o
forall (n :: S) (l :: S). (Name n -> Name l) -> e n -> e l
forall (e :: S -> *) (n :: S) (l :: S).
Sinkable e =>
(Name n -> Name l) -> e n -> e l
sinkabilityProof Name n -> Name o
rename

-- | Carry a single name along a transport.
--
-- @since 0.4.0
transportName :: PatternTransport n o -> Name n -> Name o
transportName :: forall (n :: S) (o :: S). PatternTransport n o -> Name n -> Name o
transportName PatternTransport n o
TransportVerbatim         = Name n -> Name o
forall a b. a -> b
unsafeCoerce
transportName (TransportRenamed Name n -> Name o
rename) = Name n -> Name o
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 :: forall (o :: S) (o' :: S) (r :: S) (n :: S).
DExt o o' =>
WithNameBinderList r n n o o'
idWithNameBinderList = (NameBinderList n r -> NameBinderList n r)
-> WithNameBinderList r n n o o'
forall (r :: S) (n :: S) (l :: S) (o :: S) (o' :: S).
(NameBinderList l r -> NameBinderList n r)
-> WithNameBinderList r n l o o'
WithNameBinderList NameBinderList n r -> NameBinderList n r
forall a. a -> a
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 :: forall (o :: S) (o' :: S) (o'' :: S) (r :: S) (n :: S) (i :: S)
       (l :: S).
(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 NameBinderList i r -> NameBinderList n r
f) (WithNameBinderList NameBinderList l r -> NameBinderList i r
g) =
  (NameBinderList l r -> NameBinderList n r)
-> WithNameBinderList r n l o o''
forall (r :: S) (n :: S) (l :: S) (o :: S) (o' :: S).
(NameBinderList l r -> NameBinderList n r)
-> WithNameBinderList r n l o o'
WithNameBinderList (NameBinderList i r -> NameBinderList n r
f (NameBinderList i r -> NameBinderList n r)
-> (NameBinderList l r -> NameBinderList i r)
-> NameBinderList l r
-> NameBinderList n r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameBinderList l r -> NameBinderList i r
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 :: forall (binder :: S -> S -> *) (n :: S) (l :: S).
CoSinkable binder =>
binder n l -> NameBinderList n l
nameBinderListOf binder n l
pat = (forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     WithNameBinderList l x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S).
    DExt z z' =>
    WithNameBinderList l x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (DExt z z', DExt z' z'') =>
    WithNameBinderList l x y z z'
    -> WithNameBinderList l y y' z' z''
    -> WithNameBinderList l x y' z z'')
-> Scope 'VoidS
-> binder n l
-> (forall (o' :: S).
    DExt 'VoidS o' =>
    WithNameBinderList l n l 'VoidS o'
    -> binder 'VoidS o' -> Scope o' -> NameBinderList n l)
-> NameBinderList n l
forall (o :: S) (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
Distinct o =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (DExt z z', DExt z' z'') =>
    f x y z z' -> f y y' z' z'' -> f x y' z z'')
-> Scope o
-> binder n l
-> (forall (o' :: S).
    DExt o o' =>
    f n l o o' -> binder o o' -> Scope o' -> r)
-> r
forall (pattern :: S -> S -> *) (o :: S)
       (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
(CoSinkable pattern, Distinct o) =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (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' :: S).
    DExt o o' =>
    f n l o o' -> pattern o o' -> Scope o' -> r)
-> r
withPattern
  (\Scope z
_scope' NameBinder x y
binder forall (z' :: S).
DExt z z' =>
WithNameBinderList l x y z z' -> NameBinder z z' -> r'
k ->
    NameBinder x y
-> (DExt z (ZonkAny 38) => NameBinder z (ZonkAny 38) -> r') -> r'
forall (n :: S) (l :: S) (n' :: S) (l' :: S) r.
NameBinder n l -> (DExt n' l' => NameBinder n' l' -> r) -> r
unsafeAssertFresh NameBinder x y
binder ((DExt z (ZonkAny 38) => NameBinder z (ZonkAny 38) -> r') -> r')
-> (DExt z (ZonkAny 38) => NameBinder z (ZonkAny 38) -> r') -> r'
forall a b. (a -> b) -> a -> b
$ \NameBinder z (ZonkAny 38)
binder' ->
      WithNameBinderList l x y z (ZonkAny 38)
-> NameBinder z (ZonkAny 38) -> r'
forall (z' :: S).
DExt z z' =>
WithNameBinderList l x y z z' -> NameBinder z z' -> r'
k ((NameBinderList y l -> NameBinderList x l)
-> WithNameBinderList l x y z (ZonkAny 38)
forall (r :: S) (n :: S) (l :: S) (o :: S) (o' :: S).
(NameBinderList l r -> NameBinderList n r)
-> WithNameBinderList r n l o o'
WithNameBinderList (NameBinder x y -> NameBinderList y l -> NameBinderList x l
forall (n :: S) (k :: S) (l :: S).
NameBinder n k -> NameBinderList k l -> NameBinderList n l
NameBinderListCons NameBinder x y
binder)) NameBinder z (ZonkAny 38)
binder')
  WithNameBinderList l x x z z'
forall (x :: S) (z :: S) (z' :: S).
DExt z z' =>
WithNameBinderList l x x z z'
forall (o :: S) (o' :: S) (r :: S) (n :: S).
DExt o o' =>
WithNameBinderList r n n o o'
idWithNameBinderList
  WithNameBinderList l x y z z'
-> WithNameBinderList l y y' z' z''
-> WithNameBinderList l x y' z z''
forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S) (z'' :: S).
(DExt z z', DExt z' z'') =>
WithNameBinderList l x y z z'
-> WithNameBinderList l y y' z' z''
-> WithNameBinderList l x y' z z''
forall (o :: S) (o' :: S) (o'' :: S) (r :: S) (n :: S) (i :: S)
       (l :: S).
(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
  Scope 'VoidS
emptyScope
  binder n l
pat
  (\(WithNameBinderList NameBinderList l l -> NameBinderList n l
f) binder 'VoidS o'
_ Scope o'
_ -> NameBinderList l l -> NameBinderList n l
f NameBinderList l l
forall (n :: S). NameBinderList n n
NameBinderListEmpty)

instance CoSinkable NameBinder where
  coSinkabilityProof :: forall (n :: S) (n' :: S) (l :: S) r.
(Name n -> Name n')
-> NameBinder n l
-> (forall (l' :: S). (Name l -> Name l') -> NameBinder n' l' -> r)
-> r
coSinkabilityProof Name n -> Name n'
_rename (UnsafeNameBinder Name l
name) forall (l' :: S). (Name l -> Name l') -> NameBinder n' l' -> r
cont =
    (Name l -> Name l) -> NameBinder n' l -> r
forall (l' :: S). (Name l -> Name l') -> NameBinder n' l' -> r
cont Name l -> Name l
forall a b. a -> b
unsafeCoerce (Name l -> NameBinder n' l
forall (n :: S) (l :: S). Name l -> NameBinder n l
UnsafeNameBinder Name l
name)

  withPattern :: forall (o :: S) (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
Distinct o =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (DExt z z', DExt z' z'') =>
    f x y z z' -> f y y' z' z'' -> f x y' z z'')
-> Scope o
-> NameBinder n l
-> (forall (o' :: S).
    DExt o o' =>
    f n l o o' -> NameBinder o o' -> Scope o' -> r)
-> r
withPattern forall (x :: S) (y :: S) (z :: S) r'.
Distinct z =>
Scope z
-> NameBinder x y
-> (forall (z' :: S).
    DExt z z' =>
    f x y z z' -> NameBinder z z' -> r')
-> r'
withBinder forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z'
_ forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S) (z'' :: S).
(DExt z z', DExt z' z'') =>
f x y z z' -> f y y' z' z'' -> f x y' z z''
_ Scope o
scope NameBinder n l
binder forall (o' :: S).
DExt o o' =>
f n l o o' -> NameBinder o o' -> Scope o' -> r
cont =
    Scope o
-> NameBinder n l
-> (forall (z' :: S).
    DExt o z' =>
    f n l o z' -> NameBinder o z' -> r)
-> r
forall (x :: S) (y :: S) (z :: S) r'.
Distinct z =>
Scope z
-> NameBinder x y
-> (forall (z' :: S).
    DExt z z' =>
    f x y z z' -> NameBinder z z' -> r')
-> r'
withBinder Scope o
scope NameBinder n l
binder ((forall (z' :: S).
  DExt o z' =>
  f n l o z' -> NameBinder o z' -> r)
 -> r)
-> (forall (z' :: S).
    DExt o z' =>
    f n l o z' -> NameBinder o z' -> r)
-> r
forall a b. (a -> b) -> a -> b
$ \f n l o z'
f NameBinder o z'
binder' ->
      f n l o z' -> NameBinder o z' -> Scope z' -> r
forall (o' :: S).
DExt o o' =>
f n l o o' -> NameBinder o o' -> Scope o' -> r
cont f n l o z'
f NameBinder o z'
binder' (NameBinder o z' -> Scope o -> Scope z'
forall (n :: S) (l :: S). NameBinder n l -> Scope n -> Scope l
extendScope NameBinder o z'
binder' Scope o
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 :: forall (e :: S -> *) (i :: S) (o :: S).
InjectName e =>
Substitution e i o -> Name i -> e o
lookupSubst (UnsafeSubstitution IntMap (e o)
env) (UnsafeName RawName
name) =
    case RawName -> IntMap (e o) -> Maybe (e o)
forall a. RawName -> IntMap a -> Maybe a
IntMap.lookup RawName
name IntMap (e o)
env of
        Just e o
ex -> e o
ex
        Maybe (e o)
Nothing -> Name o -> e o
forall (n :: S). Name n -> e n
forall (e :: S -> *) (n :: S). InjectName e => Name n -> e n
injectName (RawName -> Name o
forall (n :: S). RawName -> Name n
UnsafeName RawName
name)

-- | Identity substitution maps all names to expresion-variables.
--
-- @since 0.0.1
identitySubst
  :: InjectName e => Substitution e i i
identitySubst :: forall (e :: S -> *) (i :: S). InjectName e => Substitution e i i
identitySubst = IntMap (e i) -> Substitution e i i
forall (e :: S -> *) (i :: S) (o :: S).
IntMap (e o) -> Substitution e i o
UnsafeSubstitution IntMap (e i)
forall a. IntMap a
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 :: forall (e :: S -> *) (i :: S) (o :: S). Substitution e i o -> Bool
nullSubst (UnsafeSubstitution IntMap (e o)
env) = IntMap (e o) -> Bool
forall a. IntMap a -> Bool
IntMap.null IntMap (e o)
env

-- | An empty substitution from an empty scope.
--
-- @since 0.2.0
voidSubst :: Substitution e VoidS n
voidSubst :: forall (e :: S -> *) (n :: S). Substitution e 'VoidS n
voidSubst = IntMap (e n) -> Substitution e 'VoidS n
forall (e :: S -> *) (i :: S) (o :: S).
IntMap (e o) -> Substitution e i o
UnsafeSubstitution IntMap (e n)
forall a. IntMap a
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 :: forall (e :: S -> *) (i :: S) (o :: S) (i' :: S).
Substitution e i o -> NameBinder i i' -> e o -> Substitution e i' o
addSubst (UnsafeSubstitution IntMap (e o)
env) (UnsafeNameBinder (UnsafeName RawName
name)) e o
ex
  = IntMap (e o) -> Substitution e i' o
forall (e :: S -> *) (i :: S) (o :: S).
IntMap (e o) -> Substitution e i o
UnsafeSubstitution (RawName -> e o -> IntMap (e o) -> IntMap (e o)
forall a. RawName -> a -> IntMap a -> IntMap a
IntMap.insert RawName
name e o
ex IntMap (e o)
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 :: forall (binder :: S -> S -> *) (e :: S -> *) (i :: S) (o :: S)
       (i' :: S).
CoSinkable binder =>
Substitution e i o -> binder i i' -> [e o] -> Substitution e i' o
addSubstPattern Substitution e i o
subst binder i i'
pat = Substitution e i o
-> NameBinderList i i' -> [e o] -> Substitution e i' o
forall (e :: S -> *) (i :: S) (o :: S) (i' :: S).
Substitution e i o
-> NameBinderList i i' -> [e o] -> Substitution e i' o
addSubstList Substitution e i o
subst (binder i i' -> NameBinderList i i'
forall (binder :: S -> S -> *) (n :: S) (l :: S).
CoSinkable binder =>
binder n l -> NameBinderList n l
nameBinderListOf binder i i'
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 :: forall (e :: S -> *) (i :: S) (o :: S) (i' :: S).
Substitution e i o
-> NameBinderList i i' -> [e o] -> Substitution e i' o
addSubstList Substitution e i o
subst NameBinderList i i'
NameBinderListEmpty [e o]
_ = Substitution e i o
Substitution e i' o
subst
addSubstList Substitution e i o
subst (NameBinderListCons NameBinder i i
binder NameBinderList i i'
binders) (e o
x:[e o]
xs) =
  Substitution e i o
-> NameBinderList i i' -> [e o] -> Substitution e i' o
forall (e :: S -> *) (i :: S) (o :: S) (i' :: S).
Substitution e i o
-> NameBinderList i i' -> [e o] -> Substitution e i' o
addSubstList (Substitution e i o -> NameBinder i i -> e o -> Substitution e i o
forall (e :: S -> *) (i :: S) (o :: S) (i' :: S).
Substitution e i o -> NameBinder i i' -> e o -> Substitution e i' o
addSubst Substitution e i o
subst NameBinder i i
binder e o
x) NameBinderList i i'
binders [e o]
xs
addSubstList Substitution e i o
_ NameBinderList i i'
_ [] = String -> Substitution e i' o
forall a. HasCallStack => String -> a
error String
"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 :: forall (e :: S -> *) (i :: S) (o :: S) (i' :: S).
InjectName e =>
Substitution e i o
-> NameBinder i i' -> Name o -> Substitution e i' o
addRename s :: Substitution e i o
s@(UnsafeSubstitution IntMap (e o)
env) b :: NameBinder i i'
b@(UnsafeNameBinder (UnsafeName RawName
name1)) n :: Name o
n@(UnsafeName RawName
name2)
    | RawName
name1 RawName -> RawName -> Bool
forall a. Eq a => a -> a -> Bool
== RawName
name2 = IntMap (e o) -> Substitution e i' o
forall (e :: S -> *) (i :: S) (o :: S).
IntMap (e o) -> Substitution e i o
UnsafeSubstitution (RawName -> IntMap (e o) -> IntMap (e o)
forall a. RawName -> IntMap a -> IntMap a
IntMap.delete RawName
name1 IntMap (e o)
env)
    | Bool
otherwise = Substitution e i o -> NameBinder i i' -> e o -> Substitution e i' o
forall (e :: S -> *) (i :: S) (o :: S) (i' :: S).
Substitution e i o -> NameBinder i i' -> e o -> Substitution e i' o
addSubst Substitution e i o
s NameBinder i i'
b (Name o -> e o
forall (n :: S). Name n -> e n
forall (e :: S -> *) (n :: S). InjectName e => Name n -> e n
injectName Name o
n)

-- | Substitutions are sinkable as long as corresponding expressions are.
instance (Sinkable e) => Sinkable (Substitution e i) where
  sinkabilityProof :: forall (n :: S) (l :: S).
(Name n -> Name l) -> Substitution e i n -> Substitution e i l
sinkabilityProof Name n -> Name l
rename (UnsafeSubstitution IntMap (e n)
env) =
    IntMap (e l) -> Substitution e i l
forall (e :: S -> *) (i :: S) (o :: S).
IntMap (e o) -> Substitution e i o
UnsafeSubstitution ((e n -> e l) -> IntMap (e n) -> IntMap (e l)
forall a b. (a -> b) -> IntMap a -> IntMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Name n -> Name l) -> e n -> e l
forall (n :: S) (l :: S). (Name n -> Name l) -> e n -> e l
forall (e :: S -> *) (n :: S) (l :: S).
Sinkable e =>
(Name n -> Name l) -> e n -> e l
sinkabilityProof Name n -> Name l
rename) IntMap (e n)
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 { forall (n :: S) a. NameMap n a -> IntMap a
getNameMap :: IntMap a } deriving ((forall a b. (a -> b) -> NameMap n a -> NameMap n b)
-> (forall a b. a -> NameMap n b -> NameMap n a)
-> Functor (NameMap n)
forall a b. a -> NameMap n b -> NameMap n a
forall a b. (a -> b) -> NameMap n a -> NameMap n b
forall (n :: S) a b. a -> NameMap n b -> NameMap n a
forall (n :: S) a b. (a -> b) -> NameMap n a -> NameMap n b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (n :: S) a b. (a -> b) -> NameMap n a -> NameMap n b
fmap :: forall a b. (a -> b) -> NameMap n a -> NameMap n b
$c<$ :: forall (n :: S) a b. a -> NameMap n b -> NameMap n a
<$ :: forall a b. a -> NameMap n b -> NameMap n a
Functor, (forall m. Monoid m => NameMap n m -> m)
-> (forall m a. Monoid m => (a -> m) -> NameMap n a -> m)
-> (forall m a. Monoid m => (a -> m) -> NameMap n a -> m)
-> (forall a b. (a -> b -> b) -> b -> NameMap n a -> b)
-> (forall a b. (a -> b -> b) -> b -> NameMap n a -> b)
-> (forall b a. (b -> a -> b) -> b -> NameMap n a -> b)
-> (forall b a. (b -> a -> b) -> b -> NameMap n a -> b)
-> (forall a. (a -> a -> a) -> NameMap n a -> a)
-> (forall a. (a -> a -> a) -> NameMap n a -> a)
-> (forall a. NameMap n a -> [a])
-> (forall a. NameMap n a -> Bool)
-> (forall a. NameMap n a -> RawName)
-> (forall a. Eq a => a -> NameMap n a -> Bool)
-> (forall a. Ord a => NameMap n a -> a)
-> (forall a. Ord a => NameMap n a -> a)
-> (forall a. Num a => NameMap n a -> a)
-> (forall a. Num a => NameMap n a -> a)
-> Foldable (NameMap n)
forall a. Eq a => a -> NameMap n a -> Bool
forall a. Num a => NameMap n a -> a
forall a. Ord a => NameMap n a -> a
forall m. Monoid m => NameMap n m -> m
forall a. NameMap n a -> Bool
forall a. NameMap n a -> RawName
forall a. NameMap n a -> [a]
forall a. (a -> a -> a) -> NameMap n a -> a
forall m a. Monoid m => (a -> m) -> NameMap n a -> m
forall b a. (b -> a -> b) -> b -> NameMap n a -> b
forall a b. (a -> b -> b) -> b -> NameMap n a -> b
forall (n :: S) a. Eq a => a -> NameMap n a -> Bool
forall (n :: S) a. Num a => NameMap n a -> a
forall (n :: S) a. Ord a => NameMap n a -> a
forall (n :: S) m. Monoid m => NameMap n m -> m
forall (n :: S) a. NameMap n a -> Bool
forall (n :: S) a. NameMap n a -> RawName
forall (n :: S) a. NameMap n a -> [a]
forall (n :: S) a. (a -> a -> a) -> NameMap n a -> a
forall (n :: S) m a. Monoid m => (a -> m) -> NameMap n a -> m
forall (n :: S) b a. (b -> a -> b) -> b -> NameMap n a -> b
forall (n :: S) a b. (a -> b -> b) -> b -> NameMap n a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> RawName)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall (n :: S) m. Monoid m => NameMap n m -> m
fold :: forall m. Monoid m => NameMap n m -> m
$cfoldMap :: forall (n :: S) m a. Monoid m => (a -> m) -> NameMap n a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> NameMap n a -> m
$cfoldMap' :: forall (n :: S) m a. Monoid m => (a -> m) -> NameMap n a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> NameMap n a -> m
$cfoldr :: forall (n :: S) a b. (a -> b -> b) -> b -> NameMap n a -> b
foldr :: forall a b. (a -> b -> b) -> b -> NameMap n a -> b
$cfoldr' :: forall (n :: S) a b. (a -> b -> b) -> b -> NameMap n a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> NameMap n a -> b
$cfoldl :: forall (n :: S) b a. (b -> a -> b) -> b -> NameMap n a -> b
foldl :: forall b a. (b -> a -> b) -> b -> NameMap n a -> b
$cfoldl' :: forall (n :: S) b a. (b -> a -> b) -> b -> NameMap n a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> NameMap n a -> b
$cfoldr1 :: forall (n :: S) a. (a -> a -> a) -> NameMap n a -> a
foldr1 :: forall a. (a -> a -> a) -> NameMap n a -> a
$cfoldl1 :: forall (n :: S) a. (a -> a -> a) -> NameMap n a -> a
foldl1 :: forall a. (a -> a -> a) -> NameMap n a -> a
$ctoList :: forall (n :: S) a. NameMap n a -> [a]
toList :: forall a. NameMap n a -> [a]
$cnull :: forall (n :: S) a. NameMap n a -> Bool
null :: forall a. NameMap n a -> Bool
$clength :: forall (n :: S) a. NameMap n a -> RawName
length :: forall a. NameMap n a -> RawName
$celem :: forall (n :: S) a. Eq a => a -> NameMap n a -> Bool
elem :: forall a. Eq a => a -> NameMap n a -> Bool
$cmaximum :: forall (n :: S) a. Ord a => NameMap n a -> a
maximum :: forall a. Ord a => NameMap n a -> a
$cminimum :: forall (n :: S) a. Ord a => NameMap n a -> a
minimum :: forall a. Ord a => NameMap n a -> a
$csum :: forall (n :: S) a. Num a => NameMap n a -> a
sum :: forall a. Num a => NameMap n a -> a
$cproduct :: forall (n :: S) a. Num a => NameMap n a -> a
product :: forall a. Num a => NameMap n a -> a
Foldable, Functor (NameMap n)
Foldable (NameMap n)
(Functor (NameMap n), Foldable (NameMap n)) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> NameMap n a -> f (NameMap n b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    NameMap n (f a) -> f (NameMap n a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> NameMap n a -> m (NameMap n b))
-> (forall (m :: * -> *) a.
    Monad m =>
    NameMap n (m a) -> m (NameMap n a))
-> Traversable (NameMap n)
forall (n :: S). Functor (NameMap n)
forall (n :: S). Foldable (NameMap n)
forall (n :: S) (m :: * -> *) a.
Monad m =>
NameMap n (m a) -> m (NameMap n a)
forall (n :: S) (f :: * -> *) a.
Applicative f =>
NameMap n (f a) -> f (NameMap n a)
forall (n :: S) (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NameMap n a -> m (NameMap n b)
forall (n :: S) (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NameMap n a -> f (NameMap n b)
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
NameMap n (m a) -> m (NameMap n a)
forall (f :: * -> *) a.
Applicative f =>
NameMap n (f a) -> f (NameMap n a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NameMap n a -> m (NameMap n b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NameMap n a -> f (NameMap n b)
$ctraverse :: forall (n :: S) (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NameMap n a -> f (NameMap n b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NameMap n a -> f (NameMap n b)
$csequenceA :: forall (n :: S) (f :: * -> *) a.
Applicative f =>
NameMap n (f a) -> f (NameMap n a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
NameMap n (f a) -> f (NameMap n a)
$cmapM :: forall (n :: S) (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NameMap n a -> m (NameMap n b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NameMap n a -> m (NameMap n b)
$csequence :: forall (n :: S) (m :: * -> *) a.
Monad m =>
NameMap n (m a) -> m (NameMap n a)
sequence :: forall (m :: * -> *) a.
Monad m =>
NameMap n (m a) -> m (NameMap n a)
Traversable)

-- | An empty map belongs in the empty scope.
--
-- @since 0.0.1
emptyNameMap :: NameMap VoidS a
emptyNameMap :: forall a. NameMap 'VoidS a
emptyNameMap = IntMap a -> NameMap 'VoidS a
forall (n :: S) a. IntMap a -> NameMap n a
NameMap IntMap a
forall a. IntMap a
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 :: forall (n :: S) a b.
(Name n -> a -> b) -> NameMap n a -> NameMap n b
mapWithName Name n -> a -> b
f (NameMap IntMap a
m) = IntMap b -> NameMap n b
forall (n :: S) a. IntMap a -> NameMap n a
NameMap ((RawName -> a -> b) -> IntMap a -> IntMap b
forall a b. (RawName -> a -> b) -> IntMap a -> IntMap b
IntMap.mapWithKey (Name n -> a -> b
f (Name n -> a -> b) -> (RawName -> Name n) -> RawName -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawName -> Name n
forall (n :: S). RawName -> Name n
UnsafeName) IntMap a
m)

-- | Convert a 'NameMap' of expressions into a 'Substitution'.
--
-- @since 0.2.0
nameMapToSubstitution :: NameMap i (e o) -> Substitution e i o
nameMapToSubstitution :: forall (i :: S) (e :: S -> *) (o :: S).
NameMap i (e o) -> Substitution e i o
nameMapToSubstitution (NameMap IntMap (e o)
m) = (IntMap (e o) -> Substitution e i o
forall (e :: S -> *) (i :: S) (o :: S).
IntMap (e o) -> Substitution e i o
UnsafeSubstitution IntMap (e o)
m)

-- | Convert a 'NameMap' of expressions into a 'Scope'.
--
-- @since 0.3.0
nameMapToScope :: NameMap n a -> Scope n
nameMapToScope :: forall (n :: S) a. NameMap n a -> Scope n
nameMapToScope (NameMap IntMap a
m) = RawScope -> Scope n
forall (n :: S). RawScope -> Scope n
UnsafeScope (IntMap a -> RawScope
forall a. IntMap a -> RawScope
IntMap.keysSet IntMap a
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 :: forall (binder :: S -> S -> *) (n :: S) (l :: S) a.
CoSinkable binder =>
binder n l -> [a] -> NameMap n a -> NameMap l a
addNameBinders binder n l
pat = NameBinderList n l -> [a] -> NameMap n a -> NameMap l a
forall (n :: S) (l :: S) a.
NameBinderList n l -> [a] -> NameMap n a -> NameMap l a
addNameBinderList (binder n l -> NameBinderList n l
forall (binder :: S -> S -> *) (n :: S) (l :: S).
CoSinkable binder =>
binder n l -> NameBinderList n l
nameBinderListOf binder n l
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 :: forall (n :: S) (l :: S) a.
NameBinderList n l -> [a] -> NameMap n a -> NameMap l a
addNameBinderList NameBinderList n l
NameBinderListEmpty [a]
_ = NameMap n a -> NameMap n a
NameMap n a -> NameMap l a
forall a. a -> a
id
addNameBinderList (NameBinderListCons NameBinder n i
binder NameBinderList i l
binders) (a
x:[a]
xs) =
  NameBinderList i l -> [a] -> NameMap i a -> NameMap l a
forall (n :: S) (l :: S) a.
NameBinderList n l -> [a] -> NameMap n a -> NameMap l a
addNameBinderList NameBinderList i l
binders [a]
xs (NameMap i a -> NameMap l a)
-> (NameMap n a -> NameMap i a) -> NameMap n a -> NameMap l a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameBinder n i -> a -> NameMap n a -> NameMap i a
forall (n :: S) (l :: S) a.
NameBinder n l -> a -> NameMap n a -> NameMap l a
addNameBinder NameBinder n i
binder a
x
addNameBinderList NameBinderList n l
_ [] = String -> NameMap n a -> NameMap l a
forall a. HasCallStack => String -> a
error String
"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 :: forall (n :: S) a. Name n -> NameMap n a -> a
lookupName Name n
name (NameMap IntMap a
m) =
  case RawName -> IntMap a -> Maybe a
forall a. RawName -> IntMap a -> Maybe a
IntMap.lookup (Name n -> RawName
forall (l :: S). Name l -> RawName
nameId Name n
name) IntMap a
m of
    Maybe a
Nothing -> String -> a
forall a. HasCallStack => String -> a
error String
"impossible: unknown name in a NameMap"
    Just a
x  -> a
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 :: forall (n :: S) (l :: S) a.
NameBinder n l -> a -> NameMap n a -> NameMap l a
addNameBinder NameBinder n l
name a
x (NameMap IntMap a
m) = IntMap a -> NameMap l a
forall (n :: S) a. IntMap a -> NameMap n a
NameMap (RawName -> a -> IntMap a -> IntMap a
forall a. RawName -> a -> IntMap a -> IntMap a
IntMap.insert (Name l -> RawName
forall (l :: S). Name l -> RawName
nameId (NameBinder n l -> Name l
forall (n :: S) (l :: S). NameBinder n l -> Name l
nameOf NameBinder n l
name)) a
x IntMap a
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 :: forall (n :: S) (l :: S) a.
NameBinder n l -> NameMap l a -> NameMap n a
popNameBinder NameBinder n l
binder (NameMap IntMap a
m) = IntMap a -> NameMap n a
forall (n :: S) a. IntMap a -> NameMap n a
NameMap (RawName -> IntMap a -> IntMap a
forall a. RawName -> IntMap a -> IntMap a
IntMap.delete (Name l -> RawName
forall (l :: S). Name l -> RawName
nameId (NameBinder n l -> Name l
forall (n :: S) (l :: S). NameBinder n l -> Name l
nameOf NameBinder n l
binder)) IntMap a
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 :: forall (n :: S) a r.
Distinct n =>
[a]
-> Scope n
-> NameMap n a
-> (forall (l :: S).
    DExt n l =>
    Scope l -> NameBinderList n l -> NameMap l a -> r)
-> r
withFreshNameBinderList = NameRange
-> [a]
-> Scope n
-> NameMap n a
-> (forall (l :: S).
    DExt n l =>
    Scope l -> NameBinderList n l -> NameMap l a -> r)
-> r
forall (n :: S) a r.
Distinct n =>
NameRange
-> [a]
-> Scope n
-> NameMap n a
-> (forall (l :: S).
    DExt n l =>
    Scope l -> NameBinderList n l -> NameMap l a -> r)
-> r
withFreshNameBinderListIn NameRange
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 :: forall (n :: S) a r.
Distinct n =>
NameRange
-> [a]
-> Scope n
-> NameMap n a
-> (forall (l :: S).
    DExt n l =>
    Scope l -> NameBinderList n l -> NameMap l a -> r)
-> r
withFreshNameBinderListIn NameRange
range [a]
xs0 Scope n
scope0 NameMap n a
nameMap0 forall (l :: S).
DExt n l =>
Scope l -> NameBinderList n l -> NameMap l a -> r
cont =
    [a]
-> Scope n
-> NameBinderList n n
-> NameMap n a
-> (forall (l :: S).
    DExt n l =>
    Scope l -> NameBinderList n l -> NameMap l a -> r)
-> r
forall (i :: S) r'.
Distinct i =>
[a]
-> Scope i
-> NameBinderList n i
-> NameMap i a
-> (forall (l :: S).
    DExt n l =>
    Scope l -> NameBinderList n l -> NameMap l a -> r')
-> r'
go [a]
xs0 Scope n
scope0 NameBinderList n n
forall (n :: S). NameBinderList n n
NameBinderListEmpty NameMap n a
nameMap0 Scope l -> NameBinderList n l -> NameMap l a -> r
forall (l :: S).
DExt n l =>
Scope l -> NameBinderList n l -> NameMap l a -> r
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 :: forall (i :: S) r'.
Distinct i =>
[a]
-> Scope i
-> NameBinderList n i
-> NameMap i a
-> (forall (l :: S).
    DExt n l =>
    Scope l -> NameBinderList n l -> NameMap l a -> r')
-> r'
go [] Scope i
scope NameBinderList n i
binders NameMap i a
nameMap forall (l :: S).
DExt n l =>
Scope l -> NameBinderList n l -> NameMap l a -> r'
cont' =
      case (NameBinderList n i -> DistinctEvidence i
forall (n :: S) (pattern :: S -> S -> *) (l :: S).
(Distinct n, CoSinkable pattern) =>
pattern n l -> DistinctEvidence l
assertDistinct NameBinderList n i
binders, NameBinderList n i -> ExtEvidence n i
forall (pattern :: S -> S -> *) (n :: S) (l :: S).
CoSinkable pattern =>
pattern n l -> ExtEvidence n l
assertExt NameBinderList n i
binders) of
        (DistinctEvidence i
Distinct, ExtEvidence n i
Ext) -> Scope i -> NameBinderList n i -> NameMap i a -> r'
forall (l :: S).
DExt n l =>
Scope l -> NameBinderList n l -> NameMap l a -> r'
cont' Scope i
scope NameBinderList n i
binders NameMap i a
nameMap
    go (a
x:[a]
xs) Scope i
scope NameBinderList n i
binders NameMap i a
nameMap forall (l :: S).
DExt n l =>
Scope l -> NameBinderList n l -> NameMap l a -> r'
cont' =
      NameRange
-> Scope i
-> (forall (l :: S). DExt i l => NameBinder i l -> r')
-> r'
forall (n :: S) r.
Distinct n =>
NameRange
-> Scope n
-> (forall (l :: S). DExt n l => NameBinder n l -> r)
-> r
withFreshIn NameRange
range Scope i
scope ((forall (l :: S). DExt i l => NameBinder i l -> r') -> r')
-> (forall (l :: S). DExt i l => NameBinder i l -> r') -> r'
forall a b. (a -> b) -> a -> b
$ \NameBinder i l
binder ->
        [a]
-> Scope l
-> NameBinderList n l
-> NameMap l a
-> (forall (l :: S).
    DExt n l =>
    Scope l -> NameBinderList n l -> NameMap l a -> r')
-> r'
forall (i :: S) r'.
Distinct i =>
[a]
-> Scope i
-> NameBinderList n i
-> NameMap i a
-> (forall (l :: S).
    DExt n l =>
    Scope l -> NameBinderList n l -> NameMap l a -> r')
-> r'
go [a]
xs
           (NameBinder i l -> Scope i -> Scope l
forall (n :: S) (l :: S). NameBinder n l -> Scope n -> Scope l
extendScope NameBinder i l
binder Scope i
scope)
           (NameBinderList n i -> NameBinder i l -> NameBinderList n l
forall (n :: S) (i :: S) (l :: S).
NameBinderList n i -> NameBinder i l -> NameBinderList n l
snocNameBinderList NameBinderList n i
binders NameBinder i l
binder)
           (NameBinder i l -> a -> NameMap i a -> NameMap l a
forall (n :: S) (l :: S) a.
NameBinder n l -> a -> NameMap n a -> NameMap l a
addNameBinder NameBinder i l
binder a
x NameMap i a
nameMap)
           Scope l -> NameBinderList n l -> NameMap l a -> r'
forall (l :: S).
DExt n l =>
Scope l -> NameBinderList n l -> NameMap l a -> r'
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 :: RawScope -> RawName
rawFreshName RawScope
scope
  | RawScope -> Bool
IntSet.null RawScope
scope = RawName
0
  | Bool
otherwise = case RawScope -> RawName
IntSet.findMax RawScope
scope of
      RawName
m | RawName
m RawName -> RawName -> Bool
forall a. Eq a => a -> a -> Bool
== RawName
forall a. Bounded a => a
maxBound -> String -> RawName
forall a. HasCallStack => String -> a
error String
"rawFreshName: name space exhausted"
        | Bool
otherwise     -> RawName -> RawName -> RawName
forall a. Ord a => a -> a -> a
max RawName
0 (RawName
m RawName -> RawName -> RawName
forall a. Num a => a -> a -> a
+ RawName
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
  { NameRange -> RawName
nameRangeLo :: !RawName  -- ^ The smallest name of the reservation.
  , NameRange -> RawName
nameRangeHi :: !RawName  -- ^ The largest name of the reservation (inclusive).
  } deriving (NameRange -> NameRange -> Bool
(NameRange -> NameRange -> Bool)
-> (NameRange -> NameRange -> Bool) -> Eq NameRange
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NameRange -> NameRange -> Bool
== :: NameRange -> NameRange -> Bool
$c/= :: NameRange -> NameRange -> Bool
/= :: NameRange -> NameRange -> Bool
Eq, RawName -> NameRange -> ShowS
[NameRange] -> ShowS
NameRange -> String
(RawName -> NameRange -> ShowS)
-> (NameRange -> String)
-> ([NameRange] -> ShowS)
-> Show NameRange
forall a.
(RawName -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: RawName -> NameRange -> ShowS
showsPrec :: RawName -> NameRange -> ShowS
$cshow :: NameRange -> String
show :: NameRange -> String
$cshowList :: [NameRange] -> ShowS
showList :: [NameRange] -> ShowS
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
fullNameRange = RawName -> RawName -> NameRange
NameRange RawName
0 RawName
forall a. Bounded a => a
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 -> RawScope -> Maybe RawName
rawFreshNameIn (NameRange RawName
lo RawName
hi) RawScope
scope
  | RawName
lo RawName -> RawName -> Bool
forall a. Ord a => a -> a -> Bool
> RawName
hi   = Maybe RawName
forall a. Maybe a
Nothing
  | Bool
otherwise = case RawName -> RawScope -> Maybe RawName
IntSet.lookupLE RawName
hi RawScope
scope of
      Just RawName
x | RawName
x RawName -> RawName -> Bool
forall a. Ord a => a -> a -> Bool
>= RawName
lo -> if RawName
x RawName -> RawName -> Bool
forall a. Ord a => a -> a -> Bool
< RawName
hi then RawName -> Maybe RawName
forall a. a -> Maybe a
Just (RawName
x RawName -> RawName -> RawName
forall a. Num a => a -> a -> a
+ RawName
1) else Maybe RawName
forall a. Maybe a
Nothing
      Maybe RawName
_                -> RawName -> Maybe RawName
forall a. a -> Maybe a
Just RawName
lo

-- | Check if a raw name is contained in a raw scope.
--
-- @since 0.0.1
rawMember :: RawName -> RawScope -> Bool
rawMember :: RawName -> RawScope -> Bool
rawMember = RawName -> RawScope -> Bool
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 RenamingsK as bs
rename f :@@: as
e forall (cs :: LoT (S -> k)). RenamingsK as cs -> (f :@@: cs) -> r
cont =
    RenamingsK as bs
-> RepK f as
-> (forall (cs :: LoT (S -> k)).
    RenamingsK as cs -> RepK f cs -> r)
-> r
forall {k} (p :: LoT k -> *) (as :: LoT k) (bs :: LoT k) r.
GSinkableK p =>
RenamingsK as bs
-> p as
-> (forall (cs :: LoT k). RenamingsK as cs -> p cs -> r)
-> r
forall (as :: LoT (S -> k)) (bs :: LoT (S -> k)) r.
RenamingsK as bs
-> RepK f as
-> (forall (cs :: LoT (S -> k)).
    RenamingsK as cs -> RepK f cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
rename (forall k (f :: k) (x :: LoT k).
GenericK f =>
(f :@@: x) -> RepK f x
fromK @_ @f f :@@: as
e) ((forall (cs :: LoT (S -> k)). RenamingsK as cs -> RepK f cs -> r)
 -> r)
-> (forall (cs :: LoT (S -> k)).
    RenamingsK as cs -> RepK f cs -> r)
-> r
forall a b. (a -> b) -> a -> b
$ \RenamingsK as cs
rename' RepK f cs
e' ->
      RenamingsK as cs -> (f :@@: cs) -> r
forall (cs :: LoT (S -> k)). RenamingsK as cs -> (f :@@: cs) -> r
cont RenamingsK as cs
rename' (forall k (f :: k) (x :: LoT k). GenericK f => RepK f x -> f :@@: x
toK @_ @f RepK f cs
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 :: forall {k} (f :: LoT k -> *) (xs :: LoT (LoT k -> *))
       (as :: LoT (LoT k -> *)) (bs :: LoT (LoT k -> *)).
GSinkableK f =>
RenamingsK xs as -> RenamingsK xs bs -> (f :@@: as) -> f :@@: bs
sinkK RenamingsK xs as
_ RenamingsK xs bs
_ = f (HeadLoT as) -> f (HeadLoT bs)
(f :@@: as) -> f :@@: bs
forall a b. a -> b
unsafeCoerce

instance SinkableK Name where
  sinkabilityProofK :: forall (as :: LoT (S -> *)) (bs :: LoT (S -> *)) r.
RenamingsK as bs
-> (Name :@@: as)
-> (forall (cs :: LoT (S -> *)).
    RenamingsK as cs -> (Name :@@: cs) -> r)
-> r
sinkabilityProofK renameK :: RenamingsK as bs
renameK@(RCons Name a -> Name b
rename RenamingsK as bs
RNil) Name :@@: as
name forall (cs :: LoT (S -> *)).
RenamingsK as cs -> (Name :@@: cs) -> r
cont = RenamingsK as bs -> (Name :@@: bs) -> r
forall (cs :: LoT (S -> *)).
RenamingsK as cs -> (Name :@@: cs) -> r
cont RenamingsK as bs
renameK (Name a -> Name b
rename Name :@@: as
Name a
name)
instance SinkableK NameBinder where
  sinkabilityProofK :: forall (as :: LoT (S -> S -> *)) (bs :: LoT (S -> S -> *)) r.
RenamingsK as bs
-> (NameBinder :@@: as)
-> (forall (cs :: LoT (S -> S -> *)).
    RenamingsK as cs -> (NameBinder :@@: cs) -> r)
-> r
sinkabilityProofK (RCons Name a -> Name b
_ RenamingsK as bs
RNil) (UnsafeNameBinder Name (HeadLoT 'LoT0)
name) forall (cs :: LoT (S -> S -> *)).
RenamingsK as cs -> (NameBinder :@@: cs) -> r
cont =
    RenamingsK as (ZonkAny 47 ':&&: 'LoT0)
-> (NameBinder :@@: (ZonkAny 47 ':&&: 'LoT0)) -> r
forall (cs :: LoT (S -> S -> *)).
RenamingsK as cs -> (NameBinder :@@: cs) -> r
cont ((Name a -> Name (ZonkAny 47))
-> RenamingsK 'LoT0 'LoT0
-> RenamingsK (a ':&&: 'LoT0) (ZonkAny 47 ':&&: 'LoT0)
forall {k} (k1 :: S) (as :: S) (bs :: LoT k) (k :: LoT k).
(Name k1 -> Name as)
-> RenamingsK bs k -> RenamingsK (k1 ':&&: bs) (as ':&&: k)
RCons Name a -> Name (ZonkAny 47)
forall a b. a -> b
unsafeCoerce RenamingsK 'LoT0 'LoT0
RenamingsK 'LoT0 'LoT0
RNil) (Name (HeadLoT 'LoT0) -> NameBinder (ZonkAny 47) (HeadLoT 'LoT0)
forall (n :: S) (l :: S). Name l -> NameBinder n l
UnsafeNameBinder Name (HeadLoT 'LoT0)
name)
instance SinkableK NameBinders where
  sinkabilityProofK :: forall (as :: LoT (S -> S -> *)) (bs :: LoT (S -> S -> *)) r.
RenamingsK as bs
-> (NameBinders :@@: as)
-> (forall (cs :: LoT (S -> S -> *)).
    RenamingsK as cs -> (NameBinders :@@: cs) -> r)
-> r
sinkabilityProofK (RCons Name a -> Name b
_ RenamingsK as bs
RNil) (UnsafeNameBinders RawScope
s) forall (cs :: LoT (S -> S -> *)).
RenamingsK as cs -> (NameBinders :@@: cs) -> r
cont =
    RenamingsK as (ZonkAny 46 ':&&: 'LoT0)
-> (NameBinders :@@: (ZonkAny 46 ':&&: 'LoT0)) -> r
forall (cs :: LoT (S -> S -> *)).
RenamingsK as cs -> (NameBinders :@@: cs) -> r
cont ((Name a -> Name (ZonkAny 46))
-> RenamingsK 'LoT0 'LoT0
-> RenamingsK (a ':&&: 'LoT0) (ZonkAny 46 ':&&: 'LoT0)
forall {k} (k1 :: S) (as :: S) (bs :: LoT k) (k :: LoT k).
(Name k1 -> Name as)
-> RenamingsK bs k -> RenamingsK (k1 ':&&: bs) (as ':&&: k)
RCons Name a -> Name (ZonkAny 46)
forall a b. a -> b
unsafeCoerce RenamingsK 'LoT0 'LoT0
RenamingsK 'LoT0 'LoT0
RNil) (RawScope -> NameBinders (ZonkAny 46) (HeadLoT 'LoT0)
forall (n :: S) (l :: S). RawScope -> NameBinders n l
UnsafeNameBinders RawScope
s)

instance GenericK NameBinderList where
  type RepK NameBinderList = ((Var0 :~~: Var1) :=>: U1) :+: Exists S
    (Field (NameBinder :$: Var1 :@: Var0) :*: Field (NameBinderList :$: Var0 :@: Var2))
  toK :: forall (x :: LoT (S -> S -> *)).
RepK NameBinderList x -> NameBinderList :@@: x
toK (L1 (SuchThat U1 x
U1))                   = NameBinderList :@@: x
NameBinderList (HeadLoT x) (HeadLoT x)
forall (n :: S). NameBinderList n n
NameBinderListEmpty
  toK (R1 (Exists (Field Interpret ((NameBinder :$: Var1) ':@: Var0) (t ':&&: x)
x :*: Field Interpret ((NameBinderList :$: Var0) ':@: Var2) (t ':&&: x)
xs))) = NameBinder (HeadLoT x) t
-> NameBinderList t (HeadLoT (TailLoT x))
-> NameBinderList (HeadLoT x) (HeadLoT (TailLoT x))
forall (n :: S) (k :: S) (l :: S).
NameBinder n k -> NameBinderList k l -> NameBinderList n l
NameBinderListCons Interpret ((NameBinder :$: Var1) ':@: Var0) (t ':&&: x)
NameBinder (HeadLoT x) t
x Interpret ((NameBinderList :$: Var0) ':@: Var2) (t ':&&: x)
NameBinderList t (HeadLoT (TailLoT x))
xs
  fromK :: forall (x :: LoT (S -> S -> *)).
(NameBinderList :@@: x) -> RepK NameBinderList x
fromK NameBinderList :@@: x
NameBinderList (HeadLoT x) (HeadLoT (TailLoT x))
NameBinderListEmpty       = (:=>:) (Var0 :~~: Var1) U1 x
-> (:+:)
     ((Var0 :~~: Var1) :=>: U1)
     (Exists
        S
        (Field ((NameBinder :$: Var1) ':@: Var0)
         :*: Field ((NameBinderList :$: Var0) ':@: Var2)))
     x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (U1 x -> (:=>:) (Var0 :~~: Var1) U1 x
forall {d} (c :: Atom d Constraint) (x :: LoT d) (f :: LoT d -> *).
Interpret c x =>
f x -> (:=>:) c f x
SuchThat U1 x
forall k (p :: k). U1 p
U1)
  fromK (NameBinderListCons NameBinder (HeadLoT x) i
x NameBinderList i (HeadLoT (TailLoT x))
xs) = Exists
  S
  (Field ((NameBinder :$: Var1) ':@: Var0)
   :*: Field ((NameBinderList :$: Var0) ':@: Var2))
  x
-> (:+:)
     ((Var0 :~~: Var1) :=>: U1)
     (Exists
        S
        (Field ((NameBinder :$: Var1) ':@: Var0)
         :*: Field ((NameBinderList :$: Var0) ':@: Var2)))
     x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 ((:*:)
  (Field ((NameBinder :$: Var1) ':@: Var0))
  (Field ((NameBinderList :$: Var0) ':@: Var2))
  (i ':&&: x)
-> Exists
     S
     (Field ((NameBinder :$: Var1) ':@: Var0)
      :*: Field ((NameBinderList :$: Var0) ':@: Var2))
     x
forall k (t :: k) d (f :: LoT (k -> d) -> *) (x :: LoT d).
f (t ':&&: x) -> Exists k f x
Exists (Interpret ((NameBinder :$: Var1) ':@: Var0) (i ':&&: x)
-> Field ((NameBinder :$: Var1) ':@: Var0) (i ':&&: x)
forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field Interpret ((NameBinder :$: Var1) ':@: Var0) (i ':&&: x)
NameBinder (HeadLoT x) i
x Field ((NameBinder :$: Var1) ':@: Var0) (i ':&&: x)
-> Field ((NameBinderList :$: Var0) ':@: Var2) (i ':&&: x)
-> (:*:)
     (Field ((NameBinder :$: Var1) ':@: Var0))
     (Field ((NameBinderList :$: Var0) ':@: Var2))
     (i ':&&: x)
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: Interpret ((NameBinderList :$: Var0) ':@: Var2) (i ':&&: x)
-> Field ((NameBinderList :$: Var0) ':@: Var2) (i ':&&: x)
forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field Interpret ((NameBinderList :$: Var0) ':@: Var2) (i ':&&: x)
NameBinderList i (HeadLoT (TailLoT x))
xs))

instance GenericK V2 where
  type RepK V2 = V1
  toK :: forall (x :: LoT (S -> S -> *)). RepK V2 x -> V2 :@@: x
toK RepK V2 x
_v1 = String -> V2 (HeadLoT x) (HeadLoT (TailLoT x))
forall a. HasCallStack => String -> a
error String
"absurd: Generics.Kind.V1"
  fromK :: forall (x :: LoT (S -> S -> *)). (V2 :@@: x) -> RepK V2 x
fromK = (V2 :@@: x) -> RepK V2 x
V2 (HeadLoT x) (HeadLoT (TailLoT x)) -> V1 x
forall (n :: S) (l :: S) a. V2 n l -> a
absurd2

instance GenericK U2 where
  type RepK U2 = ((Var0 :~~: Var1) :=>: U1)
  toK :: forall (x :: LoT (S -> S -> *)). RepK U2 x -> U2 :@@: x
toK (SuchThat U1 x
U1) = U2 :@@: x
U2 (HeadLoT x) (HeadLoT x)
forall (n :: S). U2 n n
U2
  fromK :: forall (x :: LoT (S -> S -> *)). (U2 :@@: x) -> RepK U2 x
fromK U2 :@@: x
U2 (HeadLoT x) (HeadLoT (TailLoT x))
U2 = U1 x -> (:=>:) (Var0 :~~: Var1) U1 x
forall {d} (c :: Atom d Constraint) (x :: LoT d) (f :: LoT d -> *).
Interpret c x =>
f x -> (:=>:) c f x
SuchThat U1 x
forall k (p :: k). U1 p
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 :: forall (f :: S -> *) (n :: S) (n' :: S).
SinkableK f =>
(Name n -> Name n') -> f n -> f n'
sinkabilityProof1 Name n -> Name n'
rename f n
e = RenamingsK (n ':&&: 'LoT0) (n' ':&&: 'LoT0)
-> (f :@@: (n ':&&: 'LoT0))
-> (forall (cs :: LoT (S -> *)).
    RenamingsK (n ':&&: 'LoT0) cs -> (f :@@: cs) -> f n')
-> f n'
forall k (f :: S -> k) (as :: LoT (S -> k)) (bs :: LoT (S -> k)) r.
SinkableK f =>
RenamingsK as bs
-> (f :@@: as)
-> (forall (cs :: LoT (S -> k)).
    RenamingsK as cs -> (f :@@: cs) -> r)
-> r
forall (as :: LoT (S -> *)) (bs :: LoT (S -> *)) r.
RenamingsK as bs
-> (f :@@: as)
-> (forall (cs :: LoT (S -> *)).
    RenamingsK as cs -> (f :@@: cs) -> r)
-> r
sinkabilityProofK ((Name n -> Name n')
-> RenamingsK 'LoT0 'LoT0
-> RenamingsK (n ':&&: 'LoT0) (n' ':&&: 'LoT0)
forall {k} (k1 :: S) (as :: S) (bs :: LoT k) (k :: LoT k).
(Name k1 -> Name as)
-> RenamingsK bs k -> RenamingsK (k1 ':&&: bs) (as ':&&: k)
RCons Name n -> Name n'
rename RenamingsK 'LoT0 'LoT0
RNil) f n
f :@@: (n ':&&: 'LoT0)
e ((forall (cs :: LoT (S -> *)).
  RenamingsK (n ':&&: 'LoT0) cs -> (f :@@: cs) -> f n')
 -> f n')
-> (forall (cs :: LoT (S -> *)).
    RenamingsK (n ':&&: 'LoT0) cs -> (f :@@: cs) -> f n')
-> f n'
forall a b. (a -> b) -> a -> b
$ \RenamingsK (n ':&&: 'LoT0) cs
_ f :@@: cs
e' -> f (HeadLoT cs) -> f n'
forall a b. a -> b
unsafeCoerce f (HeadLoT cs)
f :@@: cs
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 :: forall (f :: LoT (S -> *) -> *) (n :: S) (n' :: S).
GSinkableK f =>
(Name n -> Name n') -> f (n ':&&: 'LoT0) -> f (n' ':&&: 'LoT0)
gsinkabilityProof1 Name n -> Name n'
rename f (n ':&&: 'LoT0)
e = RenamingsK (n ':&&: 'LoT0) (n' ':&&: 'LoT0)
-> f (n ':&&: 'LoT0)
-> (forall (cs :: LoT (S -> *)).
    RenamingsK (n ':&&: 'LoT0) cs -> f cs -> f (n' ':&&: 'LoT0))
-> f (n' ':&&: 'LoT0)
forall {k} (p :: LoT k -> *) (as :: LoT k) (bs :: LoT k) r.
GSinkableK p =>
RenamingsK as bs
-> p as
-> (forall (cs :: LoT k). RenamingsK as cs -> p cs -> r)
-> r
forall (as :: LoT (S -> *)) (bs :: LoT (S -> *)) r.
RenamingsK as bs
-> f as
-> (forall (cs :: LoT (S -> *)). RenamingsK as cs -> f cs -> r)
-> r
gsinkabilityProofK ((Name n -> Name n')
-> RenamingsK 'LoT0 'LoT0
-> RenamingsK (n ':&&: 'LoT0) (n' ':&&: 'LoT0)
forall {k} (k1 :: S) (as :: S) (bs :: LoT k) (k :: LoT k).
(Name k1 -> Name as)
-> RenamingsK bs k -> RenamingsK (k1 ':&&: bs) (as ':&&: k)
RCons Name n -> Name n'
rename RenamingsK 'LoT0 'LoT0
RNil) f (n ':&&: 'LoT0)
e ((forall (cs :: LoT (S -> *)).
  RenamingsK (n ':&&: 'LoT0) cs -> f cs -> f (n' ':&&: 'LoT0))
 -> f (n' ':&&: 'LoT0))
-> (forall (cs :: LoT (S -> *)).
    RenamingsK (n ':&&: 'LoT0) cs -> f cs -> f (n' ':&&: 'LoT0))
-> f (n' ':&&: 'LoT0)
forall a b. (a -> b) -> a -> b
$ \RenamingsK (n ':&&: 'LoT0) cs
_ f cs
e' -> f cs -> f (n' ':&&: 'LoT0)
forall a b. a -> b
unsafeCoerce f cs
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 :: forall (f :: LoT (S -> S -> *) -> *) (n :: S) (n' :: S) (l :: S) r.
GSinkableK f =>
(Name n -> Name n')
-> f (n ':&&: (l ':&&: 'LoT0))
-> (forall (l' :: S).
    (Name l -> Name l') -> f (n' ':&&: (l' ':&&: 'LoT0)) -> r)
-> r
gsinkabilityProof2 Name n -> Name n'
rename f (n ':&&: (l ':&&: 'LoT0))
e forall (l' :: S).
(Name l -> Name l') -> f (n' ':&&: (l' ':&&: 'LoT0)) -> r
cont =
  RenamingsK (n ':&&: (l ':&&: 'LoT0)) (n' ':&&: (l ':&&: 'LoT0))
-> f (n ':&&: (l ':&&: 'LoT0))
-> (forall (cs :: LoT (S -> S -> *)).
    RenamingsK (n ':&&: (l ':&&: 'LoT0)) cs -> f cs -> r)
-> r
forall {k} (p :: LoT k -> *) (as :: LoT k) (bs :: LoT k) r.
GSinkableK p =>
RenamingsK as bs
-> p as
-> (forall (cs :: LoT k). RenamingsK as cs -> p cs -> r)
-> r
forall (as :: LoT (S -> S -> *)) (bs :: LoT (S -> S -> *)) r.
RenamingsK as bs
-> f as
-> (forall (cs :: LoT (S -> S -> *)).
    RenamingsK as cs -> f cs -> r)
-> r
gsinkabilityProofK ((Name n -> Name n')
-> RenamingsK (l ':&&: 'LoT0) (l ':&&: 'LoT0)
-> RenamingsK (n ':&&: (l ':&&: 'LoT0)) (n' ':&&: (l ':&&: 'LoT0))
forall {k} (k1 :: S) (as :: S) (bs :: LoT k) (k :: LoT k).
(Name k1 -> Name as)
-> RenamingsK bs k -> RenamingsK (k1 ':&&: bs) (as ':&&: k)
RCons Name n -> Name n'
rename ((Name l -> Name l)
-> RenamingsK 'LoT0 'LoT0
-> RenamingsK (l ':&&: 'LoT0) (l ':&&: 'LoT0)
forall {k} (k1 :: S) (as :: S) (bs :: LoT k) (k :: LoT k).
(Name k1 -> Name as)
-> RenamingsK bs k -> RenamingsK (k1 ':&&: bs) (as ':&&: k)
RCons Name l -> Name l
forall a. a -> a
id RenamingsK 'LoT0 'LoT0
RNil)) f (n ':&&: (l ':&&: 'LoT0))
e ((forall (cs :: LoT (S -> S -> *)).
  RenamingsK (n ':&&: (l ':&&: 'LoT0)) cs -> f cs -> r)
 -> r)
-> (forall (cs :: LoT (S -> S -> *)).
    RenamingsK (n ':&&: (l ':&&: 'LoT0)) cs -> f cs -> r)
-> r
forall a b. (a -> b) -> a -> b
$ \case
    RCons (Name n -> Name b
_ :: Name n -> Name n'') (RCons Name a -> Name b
rename' RenamingsK as bs
RNil) -> \f cs
e' ->
      case (n' :~: n') -> n' :~: b
forall a b. a -> b
unsafeCoerce (n' :~: n'
forall {k} (a :: k). a :~: a
Type.Refl :: n' Type.:~: n') :: n' Type.:~: n'' of
        n' :~: b
Type.Refl -> (Name l -> Name b) -> f (n' ':&&: (b ':&&: 'LoT0)) -> r
forall (l' :: S).
(Name l -> Name l') -> f (n' ':&&: (l' ':&&: 'LoT0)) -> r
cont Name l -> Name b
Name a -> Name b
rename' f cs
f (n' ':&&: (b ':&&: 'LoT0))
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' :: forall {k} (f :: LoT k -> *) (as :: LoT k) (bs :: LoT k).
GSinkableK f =>
RenamingsK as bs -> f as -> f bs
gsinkabilityProofK' RenamingsK as bs
renameK f as
e = RenamingsK as bs
-> f as
-> (forall (cs :: LoT k). RenamingsK as cs -> f cs -> f bs)
-> f bs
forall {k} (p :: LoT k -> *) (as :: LoT k) (bs :: LoT k) r.
GSinkableK p =>
RenamingsK as bs
-> p as
-> (forall (cs :: LoT k). RenamingsK as cs -> p cs -> r)
-> r
forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> f as
-> (forall (cs :: LoT k). RenamingsK as cs -> f cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
renameK f as
e ((forall (cs :: LoT k). RenamingsK as cs -> f cs -> f bs) -> f bs)
-> (forall (cs :: LoT k). RenamingsK as cs -> f cs -> f bs) -> f bs
forall a b. (a -> b) -> a -> b
$ \RenamingsK as cs
_ f cs
e' -> f cs -> f bs
forall a b. a -> b
unsafeCoerce f cs
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 :: forall {k} (f :: LoT k -> *) (xs :: LoT k) (as :: LoT k)
       (bs :: LoT k).
GSinkableK f =>
RenamingsK xs as -> RenamingsK xs bs -> f as -> f bs
gsinkK RenamingsK xs as
_ RenamingsK xs bs
_ = f as -> f bs
forall a b. a -> b
unsafeCoerce

instance GSinkableK V1 where
  gsinkabilityProofK :: forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> V1 as
-> (forall (cs :: LoT k). RenamingsK as cs -> V1 cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename V1 as
_v1 forall (cs :: LoT k). RenamingsK as cs -> V1 cs -> r
cont =
    RenamingsK as bs -> V1 bs -> r
forall (cs :: LoT k). RenamingsK as cs -> V1 cs -> r
cont RenamingsK as bs
irename (String -> V1 bs
forall a. HasCallStack => String -> a
error String
"absurd: Generics.Kind.V1")

instance GSinkableK U1 where
  gsinkabilityProofK :: forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> U1 as
-> (forall (cs :: LoT k). RenamingsK as cs -> U1 cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename U1 as
U1 forall (cs :: LoT k). RenamingsK as cs -> U1 cs -> r
cont =
    RenamingsK as bs -> U1 bs -> r
forall (cs :: LoT k). RenamingsK as cs -> U1 cs -> r
cont RenamingsK as bs
irename U1 bs
forall k (p :: k). U1 p
U1

instance GSinkableK f => GSinkableK (M1 i c f) where
  gsinkabilityProofK :: forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> M1 i c f as
-> (forall (cs :: LoT k). RenamingsK as cs -> M1 i c f cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename (M1 f as
x) forall (cs :: LoT k). RenamingsK as cs -> M1 i c f cs -> r
cont =
    RenamingsK as bs
-> f as
-> (forall (cs :: LoT k). RenamingsK as cs -> f cs -> r)
-> r
forall {k} (p :: LoT k -> *) (as :: LoT k) (bs :: LoT k) r.
GSinkableK p =>
RenamingsK as bs
-> p as
-> (forall (cs :: LoT k). RenamingsK as cs -> p cs -> r)
-> r
forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> f as
-> (forall (cs :: LoT k). RenamingsK as cs -> f cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename f as
x ((forall (cs :: LoT k). RenamingsK as cs -> f cs -> r) -> r)
-> (forall (cs :: LoT k). RenamingsK as cs -> f cs -> r) -> r
forall a b. (a -> b) -> a -> b
$ \RenamingsK as cs
irename' f cs
x' ->
      RenamingsK as cs -> M1 i c f cs -> r
forall (cs :: LoT k). RenamingsK as cs -> M1 i c f cs -> r
cont RenamingsK as cs
irename' (f cs -> M1 i c f cs
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 f cs
x')

instance (GSinkableK f, GSinkableK g) => GSinkableK (f :+: g) where
  gsinkabilityProofK :: forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> (:+:) f g as
-> (forall (cs :: LoT k). RenamingsK as cs -> (:+:) f g cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename (L1 f as
x) forall (cs :: LoT k). RenamingsK as cs -> (:+:) f g cs -> r
cont =
    RenamingsK as bs
-> f as
-> (forall (cs :: LoT k). RenamingsK as cs -> f cs -> r)
-> r
forall {k} (p :: LoT k -> *) (as :: LoT k) (bs :: LoT k) r.
GSinkableK p =>
RenamingsK as bs
-> p as
-> (forall (cs :: LoT k). RenamingsK as cs -> p cs -> r)
-> r
forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> f as
-> (forall (cs :: LoT k). RenamingsK as cs -> f cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename f as
x ((forall (cs :: LoT k). RenamingsK as cs -> f cs -> r) -> r)
-> (forall (cs :: LoT k). RenamingsK as cs -> f cs -> r) -> r
forall a b. (a -> b) -> a -> b
$ \RenamingsK as cs
irename' f cs
x' ->
      RenamingsK as cs -> (:+:) f g cs -> r
forall (cs :: LoT k). RenamingsK as cs -> (:+:) f g cs -> r
cont RenamingsK as cs
irename' (f cs -> (:+:) f g cs
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 f cs
x')
  gsinkabilityProofK RenamingsK as bs
irename (R1 g as
x) forall (cs :: LoT k). RenamingsK as cs -> (:+:) f g cs -> r
cont =
    RenamingsK as bs
-> g as
-> (forall (cs :: LoT k). RenamingsK as cs -> g cs -> r)
-> r
forall {k} (p :: LoT k -> *) (as :: LoT k) (bs :: LoT k) r.
GSinkableK p =>
RenamingsK as bs
-> p as
-> (forall (cs :: LoT k). RenamingsK as cs -> p cs -> r)
-> r
forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> g as
-> (forall (cs :: LoT k). RenamingsK as cs -> g cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename g as
x ((forall (cs :: LoT k). RenamingsK as cs -> g cs -> r) -> r)
-> (forall (cs :: LoT k). RenamingsK as cs -> g cs -> r) -> r
forall a b. (a -> b) -> a -> b
$ \RenamingsK as cs
irename' g cs
x' ->
      RenamingsK as cs -> (:+:) f g cs -> r
forall (cs :: LoT k). RenamingsK as cs -> (:+:) f g cs -> r
cont RenamingsK as cs
irename' (g cs -> (:+:) f g cs
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 g cs
x')

instance (GSinkableK f, GSinkableK g) => GSinkableK (f :*: g) where
  gsinkabilityProofK :: forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> (:*:) f g as
-> (forall (cs :: LoT k). RenamingsK as cs -> (:*:) f g cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename (f as
x :*: g as
y) forall (cs :: LoT k). RenamingsK as cs -> (:*:) f g cs -> r
cont =
    RenamingsK as bs
-> f as
-> (forall (cs :: LoT k). RenamingsK as cs -> f cs -> r)
-> r
forall {k} (p :: LoT k -> *) (as :: LoT k) (bs :: LoT k) r.
GSinkableK p =>
RenamingsK as bs
-> p as
-> (forall (cs :: LoT k). RenamingsK as cs -> p cs -> r)
-> r
forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> f as
-> (forall (cs :: LoT k). RenamingsK as cs -> f cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename f as
x ((forall (cs :: LoT k). RenamingsK as cs -> f cs -> r) -> r)
-> (forall (cs :: LoT k). RenamingsK as cs -> f cs -> r) -> r
forall a b. (a -> b) -> a -> b
$ \RenamingsK as cs
irename' f cs
x' ->
      RenamingsK as cs
-> g as
-> (forall (cs :: LoT k). RenamingsK as cs -> g cs -> r)
-> r
forall {k} (p :: LoT k -> *) (as :: LoT k) (bs :: LoT k) r.
GSinkableK p =>
RenamingsK as bs
-> p as
-> (forall (cs :: LoT k). RenamingsK as cs -> p cs -> r)
-> r
forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> g as
-> (forall (cs :: LoT k). RenamingsK as cs -> g cs -> r)
-> r
gsinkabilityProofK RenamingsK as cs
irename' g as
y ((forall (cs :: LoT k). RenamingsK as cs -> g cs -> r) -> r)
-> (forall (cs :: LoT k). RenamingsK as cs -> g cs -> r) -> r
forall a b. (a -> b) -> a -> b
$ \RenamingsK as cs
irename'' g cs
y' ->
        RenamingsK as cs -> (:*:) f g cs -> r
forall (cs :: LoT k). RenamingsK as cs -> (:*:) f g cs -> r
cont RenamingsK as cs
irename'' (RenamingsK as cs -> RenamingsK as cs -> f cs -> f cs
forall {k} (f :: LoT k -> *) (xs :: LoT k) (as :: LoT k)
       (bs :: LoT k).
GSinkableK f =>
RenamingsK xs as -> RenamingsK xs bs -> f as -> f bs
gsinkK RenamingsK as cs
irename' RenamingsK as cs
irename'' f cs
x' f cs -> g cs -> (:*:) f g cs
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g cs
y')

instance GSinkableK f => GSinkableK (Exists S f) where
  gsinkabilityProofK :: forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> Exists S f as
-> (forall (cs :: LoT k). RenamingsK as cs -> Exists S f cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename (Exists f (t ':&&: as)
x) forall (cs :: LoT k). RenamingsK as cs -> Exists S f cs -> r
cont =
    RenamingsK (t ':&&: as) (t ':&&: bs)
-> f (t ':&&: as)
-> (forall (cs :: LoT (S -> k)).
    RenamingsK (t ':&&: as) cs -> f cs -> r)
-> r
forall {k} (p :: LoT k -> *) (as :: LoT k) (bs :: LoT k) r.
GSinkableK p =>
RenamingsK as bs
-> p as
-> (forall (cs :: LoT k). RenamingsK as cs -> p cs -> r)
-> r
forall (as :: LoT (S -> k)) (bs :: LoT (S -> k)) r.
RenamingsK as bs
-> f as
-> (forall (cs :: LoT (S -> k)). RenamingsK as cs -> f cs -> r)
-> r
gsinkabilityProofK ((Name t -> Name t)
-> RenamingsK as bs -> RenamingsK (t ':&&: as) (t ':&&: bs)
forall {k} (k1 :: S) (as :: S) (bs :: LoT k) (k :: LoT k).
(Name k1 -> Name as)
-> RenamingsK bs k -> RenamingsK (k1 ':&&: bs) (as ':&&: k)
RCons Name t -> Name t
forall a. a -> a
id RenamingsK as bs
irename) f (t ':&&: as)
x ((forall (cs :: LoT (S -> k)).
  RenamingsK (t ':&&: as) cs -> f cs -> r)
 -> r)
-> (forall (cs :: LoT (S -> k)).
    RenamingsK (t ':&&: as) cs -> f cs -> r)
-> r
forall a b. (a -> b) -> a -> b
$ \case
      RCons Name a -> Name b
_ RenamingsK as bs
irename' -> \f cs
x' ->
        RenamingsK as bs -> Exists S f bs -> r
forall (cs :: LoT k). RenamingsK as cs -> Exists S f cs -> r
cont RenamingsK as bs
RenamingsK as bs
irename' (f (b ':&&: bs) -> Exists S f bs
forall k (t :: k) d (f :: LoT (k -> d) -> *) (x :: LoT d).
f (t ':&&: x) -> Exists k f x
Exists f cs
f (b ':&&: bs)
x')

instance {-# OVERLAPPABLE #-} GSinkableK f => GSinkableK (Exists k f) where
  gsinkabilityProofK :: forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> Exists k f as
-> (forall (cs :: LoT k). RenamingsK as cs -> Exists k f cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename (Exists f (t ':&&: as)
x) forall (cs :: LoT k). RenamingsK as cs -> Exists k f cs -> r
cont =
    RenamingsK (t ':&&: as) (t ':&&: bs)
-> f (t ':&&: as)
-> (forall (cs :: LoT (k -> k)).
    RenamingsK (t ':&&: as) cs -> f cs -> r)
-> r
forall {k} (p :: LoT k -> *) (as :: LoT k) (bs :: LoT k) r.
GSinkableK p =>
RenamingsK as bs
-> p as
-> (forall (cs :: LoT k). RenamingsK as cs -> p cs -> r)
-> r
forall (as :: LoT (k -> k)) (bs :: LoT (k -> k)) r.
RenamingsK as bs
-> f as
-> (forall (cs :: LoT (k -> k)). RenamingsK as cs -> f cs -> r)
-> r
gsinkabilityProofK (RenamingsK as bs -> RenamingsK (t ':&&: as) (t ':&&: bs)
forall {k} {k1} (as :: LoT k) (bs :: LoT k) (k :: k1).
RenamingsK as bs -> RenamingsK (k ':&&: as) (k ':&&: bs)
RSkip RenamingsK as bs
irename) f (t ':&&: as)
x ((forall (cs :: LoT (k -> k)).
  RenamingsK (t ':&&: as) cs -> f cs -> r)
 -> r)
-> (forall (cs :: LoT (k -> k)).
    RenamingsK (t ':&&: as) cs -> f cs -> r)
-> r
forall a b. (a -> b) -> a -> b
$ \case
      RSkip RenamingsK as bs
irename' -> \f cs
x' ->
        RenamingsK as bs -> Exists k f bs -> r
forall (cs :: LoT k). RenamingsK as cs -> Exists k f cs -> r
cont RenamingsK as bs
RenamingsK as bs
irename' (f (t ':&&: bs) -> Exists k f bs
forall k (t :: k) d (f :: LoT (k -> d) -> *) (x :: LoT d).
f (t ':&&: x) -> Exists k f x
Exists f cs
f (t ':&&: bs)
x')

instance GSinkableK f => GSinkableK ((a :~~: b) :=>: f) where
  gsinkabilityProofK :: forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> (:=>:) (a :~~: b) f as
-> (forall (cs :: LoT k).
    RenamingsK as cs -> (:=>:) (a :~~: b) f cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename (SuchThat f as
x) forall (cs :: LoT k).
RenamingsK as cs -> (:=>:) (a :~~: b) f cs -> r
cont =
    RenamingsK as bs
-> f as
-> (forall (cs :: LoT k). RenamingsK as cs -> f cs -> r)
-> r
forall {k} (p :: LoT k -> *) (as :: LoT k) (bs :: LoT k) r.
GSinkableK p =>
RenamingsK as bs
-> p as
-> (forall (cs :: LoT k). RenamingsK as cs -> p cs -> r)
-> r
forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> f as
-> (forall (cs :: LoT k). RenamingsK as cs -> f cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename f as
x ((forall (cs :: LoT k). RenamingsK as cs -> f cs -> r) -> r)
-> (forall (cs :: LoT k). RenamingsK as cs -> f cs -> r) -> r
forall a b. (a -> b) -> a -> b
$ \(RenamingsK as cs
irename' :: RenamingsK as cs) f cs
x' ->
      -- this is sort of safe...
      case (Interpret a cs :~: Interpret a cs)
-> Interpret a cs :~: Interpret b cs
forall a b. a -> b
unsafeCoerce (Interpret a cs :~: Interpret a cs
Interpret a cs :~: Interpret a cs
forall {k} (a :: k). a :~: a
Type.Refl :: Interpret a cs Type.:~: Interpret a cs) :: Interpret a cs Type.:~: Interpret b cs of
        Interpret a cs :~: Interpret b cs
Type.Refl -> RenamingsK as cs -> (:=>:) (a :~~: b) f cs -> r
forall (cs :: LoT k).
RenamingsK as cs -> (:=>:) (a :~~: b) f cs -> r
cont RenamingsK as cs
irename' (f cs -> (:=>:) (a :~~: b) f cs
forall {d} (c :: Atom d Constraint) (x :: LoT d) (f :: LoT d -> *).
Interpret c x =>
f x -> (:=>:) c f x
SuchThat f cs
x')

instance GSinkableK (Field (Kon a)) where
  gsinkabilityProofK :: forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> Field ('Kon a) as
-> (forall (cs :: LoT k).
    RenamingsK as cs -> Field ('Kon a) cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename (Field Interpret ('Kon a) as
x) forall (cs :: LoT k). RenamingsK as cs -> Field ('Kon a) cs -> r
cont =
    RenamingsK as bs -> Field ('Kon a) bs -> r
forall (cs :: LoT k). RenamingsK as cs -> Field ('Kon a) cs -> r
cont RenamingsK as bs
irename (Interpret ('Kon a) bs -> Field ('Kon a) bs
forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field Interpret ('Kon a) as
Interpret ('Kon a) bs
x)

instance GSinkableK (Field (Var a)) where
  gsinkabilityProofK :: forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> Field ('Var a) as
-> (forall (cs :: LoT k).
    RenamingsK as cs -> Field ('Var a) cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename (Field Interpret ('Var a) as
x) forall (cs :: LoT k). RenamingsK as cs -> Field ('Var a) cs -> r
cont =
    RenamingsK as bs -> Field ('Var a) bs -> r
forall (cs :: LoT k). RenamingsK as cs -> Field ('Var a) cs -> r
cont RenamingsK as bs
irename (Interpret ('Var a) bs -> Field ('Var a) bs
forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field (InterpretVar a as -> InterpretVar a bs
forall a b. a -> b
unsafeCoerce Interpret ('Var a) as
InterpretVar a as
x)) -- FIXME: unsafeCoerce?

instance (SinkableK f, ExtractRenamingK i) => GSinkableK (Field (Kon f :@: Var i)) where
  gsinkabilityProofK :: forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> Field ('Kon f ':@: 'Var i) as
-> (forall (cs :: LoT k).
    RenamingsK as cs -> Field ('Kon f ':@: 'Var i) cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename (Field Interpret ('Kon f ':@: 'Var i) as
x) forall (cs :: LoT k).
RenamingsK as cs -> Field ('Kon f ':@: 'Var i) cs -> r
cont =
    RenamingsK
  (InterpretVar i as ':&&: 'LoT0) (InterpretVar i bs ':&&: 'LoT0)
-> (f :@@: (InterpretVar i as ':&&: 'LoT0))
-> (forall (cs :: LoT (S -> *)).
    RenamingsK (InterpretVar i as ':&&: 'LoT0) cs -> (f :@@: cs) -> r)
-> r
forall k (f :: S -> k) (as :: LoT (S -> k)) (bs :: LoT (S -> k)) r.
SinkableK f =>
RenamingsK as bs
-> (f :@@: as)
-> (forall (cs :: LoT (S -> k)).
    RenamingsK as cs -> (f :@@: cs) -> r)
-> r
forall (as :: LoT (S -> *)) (bs :: LoT (S -> *)) r.
RenamingsK as bs
-> (f :@@: as)
-> (forall (cs :: LoT (S -> *)).
    RenamingsK as cs -> (f :@@: cs) -> r)
-> r
sinkabilityProofK ((Name (InterpretVar i as) -> Name (InterpretVar i bs))
-> RenamingsK 'LoT0 'LoT0
-> RenamingsK
     (InterpretVar i as ':&&: 'LoT0) (InterpretVar i bs ':&&: 'LoT0)
forall {k} (k1 :: S) (as :: S) (bs :: LoT k) (k :: LoT k).
(Name k1 -> Name as)
-> RenamingsK bs k -> RenamingsK (k1 ':&&: bs) (as ':&&: k)
RCons (forall k (i :: TyVar k S) (as :: LoT k) (bs :: LoT k).
ExtractRenamingK i =>
RenamingsK as bs
-> Name (Interpret ('Var i) as) -> Name (Interpret ('Var i) bs)
extractRenamingK @_ @i RenamingsK as bs
irename) RenamingsK 'LoT0 'LoT0
RNil) f :@@: (InterpretVar i as ':&&: 'LoT0)
Interpret ('Kon f ':@: 'Var i) as
x ((forall (cs :: LoT (S -> *)).
  RenamingsK (InterpretVar i as ':&&: 'LoT0) cs -> (f :@@: cs) -> r)
 -> r)
-> (forall (cs :: LoT (S -> *)).
    RenamingsK (InterpretVar i as ':&&: 'LoT0) cs -> (f :@@: cs) -> r)
-> r
forall a b. (a -> b) -> a -> b
$ \case
      RCons Name a -> Name b
rename' RenamingsK as bs
RNil -> \f :@@: cs
x' ->
        RenamingsK as (PutBackLoT i b bs)
-> Field ('Kon f ':@: 'Var i) (PutBackLoT i b bs) -> r
forall (cs :: LoT k).
RenamingsK as cs -> Field ('Kon f ':@: 'Var i) cs -> r
cont (forall k (i :: TyVar k S) (c :: S) (as :: LoT k) (bs :: LoT k).
ExtractRenamingK i =>
(Name (Interpret ('Var i) as) -> Name c)
-> RenamingsK as bs -> RenamingsK as (PutBackLoT i c bs)
putBackRenamingK @_ @i Name a -> Name b
Name (Interpret ('Var i) as) -> Name b
rename' RenamingsK as bs
irename) (Interpret ('Kon f ':@: 'Var i) (PutBackLoT i b bs)
-> Field ('Kon f ':@: 'Var i) (PutBackLoT i b bs)
forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field (f b -> f (InterpretVar i (PutBackLoT i b bs))
forall a b. a -> b
unsafeCoerce f b
f :@@: cs
x')) -- unsafeCoerce?

instance SinkableK (f a) => GSinkableK (Field (Kon f :@: Kon a :@: Var0)) where
  gsinkabilityProofK :: forall (as :: LoT (S -> xs)) (bs :: LoT (S -> xs)) r.
RenamingsK as bs
-> Field (('Kon f ':@: 'Kon a) ':@: Var0) as
-> (forall (cs :: LoT (S -> xs)).
    RenamingsK as cs -> Field (('Kon f ':@: 'Kon a) ':@: Var0) cs -> r)
-> r
gsinkabilityProofK irename :: RenamingsK as bs
irename@(RCons Name a -> Name b
_ RenamingsK as bs
RNil) (Field Interpret (('Kon f ':@: 'Kon a) ':@: Var0) as
x) forall (cs :: LoT (S -> xs)).
RenamingsK as cs -> Field (('Kon f ':@: 'Kon a) ':@: Var0) cs -> r
cont =
    RenamingsK as bs
-> (f a :@@: as)
-> (forall (cs :: LoT (S -> xs)).
    RenamingsK as cs -> (f a :@@: cs) -> r)
-> r
forall k (f :: S -> k) (as :: LoT (S -> k)) (bs :: LoT (S -> k)) r.
SinkableK f =>
RenamingsK as bs
-> (f :@@: as)
-> (forall (cs :: LoT (S -> k)).
    RenamingsK as cs -> (f :@@: cs) -> r)
-> r
forall (as :: LoT (S -> xs)) (bs :: LoT (S -> xs)) r.
RenamingsK as bs
-> (f a :@@: as)
-> (forall (cs :: LoT (S -> xs)).
    RenamingsK as cs -> (f a :@@: cs) -> r)
-> r
sinkabilityProofK RenamingsK as bs
irename f a :@@: as
Interpret (('Kon f ':@: 'Kon a) ':@: Var0) as
x ((forall (cs :: LoT (S -> xs)).
  RenamingsK as cs -> (f a :@@: cs) -> r)
 -> r)
-> (forall (cs :: LoT (S -> xs)).
    RenamingsK as cs -> (f a :@@: cs) -> r)
-> r
forall a b. (a -> b) -> a -> b
$ \RenamingsK as cs
rename' f a :@@: cs
x' ->
      RenamingsK as cs -> Field (('Kon f ':@: 'Kon a) ':@: Var0) cs -> r
forall (cs :: LoT (S -> xs)).
RenamingsK as cs -> Field (('Kon f ':@: 'Kon a) ':@: Var0) cs -> r
cont RenamingsK as cs
rename' (Interpret (('Kon f ':@: 'Kon a) ':@: Var0) cs
-> Field (('Kon f ':@: 'Kon a) ':@: Var0) cs
forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field f a :@@: cs
Interpret (('Kon f ':@: 'Kon a) ':@: Var0) cs
x')

instance SinkableK (f a b) => GSinkableK (Field (Kon f :@: Kon a :@: Kon b :@: Var0)) where
  gsinkabilityProofK :: forall (as :: LoT (S -> xs)) (bs :: LoT (S -> xs)) r.
RenamingsK as bs
-> Field ((('Kon f ':@: 'Kon a) ':@: 'Kon b) ':@: Var0) as
-> (forall (cs :: LoT (S -> xs)).
    RenamingsK as cs
    -> Field ((('Kon f ':@: 'Kon a) ':@: 'Kon b) ':@: Var0) cs -> r)
-> r
gsinkabilityProofK irename :: RenamingsK as bs
irename@(RCons Name a -> Name b
_ RenamingsK as bs
RNil) (Field Interpret ((('Kon f ':@: 'Kon a) ':@: 'Kon b) ':@: Var0) as
x) forall (cs :: LoT (S -> xs)).
RenamingsK as cs
-> Field ((('Kon f ':@: 'Kon a) ':@: 'Kon b) ':@: Var0) cs -> r
cont =
    RenamingsK as bs
-> (f a b :@@: as)
-> (forall (cs :: LoT (S -> xs)).
    RenamingsK as cs -> (f a b :@@: cs) -> r)
-> r
forall k (f :: S -> k) (as :: LoT (S -> k)) (bs :: LoT (S -> k)) r.
SinkableK f =>
RenamingsK as bs
-> (f :@@: as)
-> (forall (cs :: LoT (S -> k)).
    RenamingsK as cs -> (f :@@: cs) -> r)
-> r
forall (as :: LoT (S -> xs)) (bs :: LoT (S -> xs)) r.
RenamingsK as bs
-> (f a b :@@: as)
-> (forall (cs :: LoT (S -> xs)).
    RenamingsK as cs -> (f a b :@@: cs) -> r)
-> r
sinkabilityProofK RenamingsK as bs
irename f a b :@@: as
Interpret ((('Kon f ':@: 'Kon a) ':@: 'Kon b) ':@: Var0) as
x ((forall (cs :: LoT (S -> xs)).
  RenamingsK as cs -> (f a b :@@: cs) -> r)
 -> r)
-> (forall (cs :: LoT (S -> xs)).
    RenamingsK as cs -> (f a b :@@: cs) -> r)
-> r
forall a b. (a -> b) -> a -> b
$ \RenamingsK as cs
rename' f a b :@@: cs
x' ->
      RenamingsK as cs
-> Field ((('Kon f ':@: 'Kon a) ':@: 'Kon b) ':@: Var0) cs -> r
forall (cs :: LoT (S -> xs)).
RenamingsK as cs
-> Field ((('Kon f ':@: 'Kon a) ':@: 'Kon b) ':@: Var0) cs -> r
cont RenamingsK as cs
rename' (Interpret ((('Kon f ':@: 'Kon a) ':@: 'Kon b) ':@: Var0) cs
-> Field ((('Kon f ':@: 'Kon a) ':@: 'Kon b) ':@: Var0) cs
forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field f a b :@@: cs
Interpret ((('Kon f ':@: 'Kon a) ':@: 'Kon b) ':@: Var0) cs
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 :: forall (as :: LoT (S -> xs)) (bs :: LoT (S -> xs)).
RenamingsK as bs
-> Name (Interpret ('Var 'VZ) as) -> Name (Interpret ('Var 'VZ) bs)
extractRenamingK (RCons Name a -> Name b
f RenamingsK as bs
_fs) = Name a -> Name b
Name (Interpret ('Var 'VZ) as) -> Name (Interpret ('Var 'VZ) bs)
f
  putBackRenamingK :: forall (c :: S) (as :: LoT (S -> xs)) (bs :: LoT (S -> xs)).
(Name (Interpret ('Var 'VZ) as) -> Name c)
-> RenamingsK as bs -> RenamingsK as (PutBackLoT 'VZ c bs)
putBackRenamingK Name (Interpret ('Var 'VZ) as) -> Name c
f (RCons Name a -> Name b
_ RenamingsK as bs
gs) = (Name a -> Name c)
-> RenamingsK as bs -> RenamingsK (a ':&&: as) (c ':&&: bs)
forall {k} (k1 :: S) (as :: S) (bs :: LoT k) (k :: LoT k).
(Name k1 -> Name as)
-> RenamingsK bs k -> RenamingsK (k1 ':&&: bs) (as ':&&: k)
RCons Name a -> Name c
Name (Interpret ('Var 'VZ) as) -> Name c
f RenamingsK as bs
RenamingsK as bs
gs

instance ExtractRenamingK x => ExtractRenamingK (VS x) where
  extractRenamingK :: forall (as :: LoT (x -> xs)) (bs :: LoT (x -> xs)).
RenamingsK as bs
-> Name (Interpret ('Var ('VS x)) as)
-> Name (Interpret ('Var ('VS x)) bs)
extractRenamingK (RCons Name a -> Name b
_f RenamingsK as bs
fs) = forall k (i :: TyVar k S) (as :: LoT k) (bs :: LoT k).
ExtractRenamingK i =>
RenamingsK as bs
-> Name (Interpret ('Var i) as) -> Name (Interpret ('Var i) bs)
extractRenamingK @_ @x RenamingsK as bs
RenamingsK as bs
fs
  putBackRenamingK :: forall (c :: S) (as :: LoT (x -> xs)) (bs :: LoT (x -> xs)).
(Name (Interpret ('Var ('VS x)) as) -> Name c)
-> RenamingsK as bs -> RenamingsK as (PutBackLoT ('VS x) c bs)
putBackRenamingK Name (Interpret ('Var ('VS x)) as) -> Name c
f (RCons Name a -> Name b
g RenamingsK as bs
gs) = (Name a -> Name b)
-> RenamingsK as (PutBackLoT x c bs)
-> RenamingsK (a ':&&: as) (b ':&&: PutBackLoT x c bs)
forall {k} (k1 :: S) (as :: S) (bs :: LoT k) (k :: LoT k).
(Name k1 -> Name as)
-> RenamingsK bs k -> RenamingsK (k1 ':&&: bs) (as ':&&: k)
RCons Name a -> Name b
g (forall k (i :: TyVar k S) (c :: S) (as :: LoT k) (bs :: LoT k).
ExtractRenamingK i =>
(Name (Interpret ('Var i) as) -> Name c)
-> RenamingsK as bs -> RenamingsK as (PutBackLoT i c bs)
putBackRenamingK @_ @x Name (Interpret ('Var x) as) -> Name c
Name (Interpret ('Var ('VS x)) as) -> Name c
f RenamingsK as bs
RenamingsK as bs
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 :: 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 RenamingsK as bs
irename =
  ((Name (InterpretVar i as) -> Name (InterpretVar i bs))
-> RenamingsK
     (InterpretVar j as ':&&: 'LoT0) (InterpretVar j bs ':&&: 'LoT0)
-> RenamingsK
     (InterpretVar i as ':&&: (InterpretVar j as ':&&: 'LoT0))
     (InterpretVar i bs ':&&: (InterpretVar j bs ':&&: 'LoT0))
forall {k} (k1 :: S) (as :: S) (bs :: LoT k) (k :: LoT k).
(Name k1 -> Name as)
-> RenamingsK bs k -> RenamingsK (k1 ':&&: bs) (as ':&&: k)
RCons (forall k (i :: TyVar k S) (as :: LoT k) (bs :: LoT k).
ExtractRenamingK i =>
RenamingsK as bs
-> Name (Interpret ('Var i) as) -> Name (Interpret ('Var i) bs)
extractRenamingK @_ @i RenamingsK as bs
irename) ((Name (InterpretVar j as) -> Name (InterpretVar j bs))
-> RenamingsK 'LoT0 'LoT0
-> RenamingsK
     (InterpretVar j as ':&&: 'LoT0) (InterpretVar j bs ':&&: 'LoT0)
forall {k} (k1 :: S) (as :: S) (bs :: LoT k) (k :: LoT k).
(Name k1 -> Name as)
-> RenamingsK bs k -> RenamingsK (k1 ':&&: bs) (as ':&&: k)
RCons (forall k (i :: TyVar k S) (as :: LoT k) (bs :: LoT k).
ExtractRenamingK i =>
RenamingsK as bs
-> Name (Interpret ('Var i) as) -> Name (Interpret ('Var i) bs)
extractRenamingK @_ @j RenamingsK as bs
irename) RenamingsK 'LoT0 'LoT0
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 :: forall k (i :: TyVar k S) (j :: TyVar k S) (c1 :: S) (c2 :: S)
       (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 Name a -> Name b
f1 (RCons Name a -> Name b
f2 RenamingsK as bs
RNil)) RenamingsK as bs
rename
  = forall k (i :: TyVar k S) (c :: S) (as :: LoT k) (bs :: LoT k).
ExtractRenamingK i =>
(Name (Interpret ('Var i) as) -> Name c)
-> RenamingsK as bs -> RenamingsK as (PutBackLoT i c bs)
putBackRenamingK @_ @j Name a -> Name b
Name (Interpret ('Var j) as) -> Name b
f2 (forall k (i :: TyVar k S) (c :: S) (as :: LoT k) (bs :: LoT k).
ExtractRenamingK i =>
(Name (Interpret ('Var i) as) -> Name c)
-> RenamingsK as bs -> RenamingsK as (PutBackLoT i c bs)
putBackRenamingK @_ @i Name a -> Name b
Name (Interpret ('Var i) as) -> Name b
f1 RenamingsK as bs
rename)

instance (SinkableK f, ExtractRenamingK i, ExtractRenamingK j) => GSinkableK (Field (Kon f :@: Var (i :: TyVar k S) :@: Var (j :: TyVar k S))) where
  gsinkabilityProofK :: forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> Field (('Kon f ':@: 'Var i) ':@: 'Var j) as
-> (forall (cs :: LoT k).
    RenamingsK as cs
    -> Field (('Kon f ':@: 'Var i) ':@: 'Var j) cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename (Field Interpret (('Kon f ':@: 'Var i) ':@: 'Var j) as
x) forall (cs :: LoT k).
RenamingsK as cs
-> Field (('Kon f ':@: 'Var i) ':@: 'Var j) cs -> r
cont =
    RenamingsK
  (InterpretVar i as ':&&: (InterpretVar j as ':&&: 'LoT0))
  (InterpretVar i bs ':&&: (InterpretVar j bs ':&&: 'LoT0))
-> (f
    :@@: (InterpretVar i as ':&&: (InterpretVar j as ':&&: 'LoT0)))
-> (forall (cs :: LoT (S -> S -> *)).
    RenamingsK
      (InterpretVar i as ':&&: (InterpretVar j as ':&&: 'LoT0)) cs
    -> (f :@@: cs) -> r)
-> r
forall k (f :: S -> k) (as :: LoT (S -> k)) (bs :: LoT (S -> k)) r.
SinkableK f =>
RenamingsK as bs
-> (f :@@: as)
-> (forall (cs :: LoT (S -> k)).
    RenamingsK as cs -> (f :@@: cs) -> r)
-> r
forall (as :: LoT (S -> S -> *)) (bs :: LoT (S -> S -> *)) r.
RenamingsK as bs
-> (f :@@: as)
-> (forall (cs :: LoT (S -> S -> *)).
    RenamingsK as cs -> (f :@@: cs) -> r)
-> r
sinkabilityProofK (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 @_ @i @j RenamingsK as bs
irename) f :@@: (InterpretVar i as ':&&: (InterpretVar j as ':&&: 'LoT0))
Interpret (('Kon f ':@: 'Var i) ':@: 'Var j) as
x ((forall (cs :: LoT (S -> S -> *)).
  RenamingsK
    (InterpretVar i as ':&&: (InterpretVar j as ':&&: 'LoT0)) cs
  -> (f :@@: cs) -> r)
 -> r)
-> (forall (cs :: LoT (S -> S -> *)).
    RenamingsK
      (InterpretVar i as ':&&: (InterpretVar j as ':&&: 'LoT0)) cs
    -> (f :@@: cs) -> r)
-> r
forall a b. (a -> b) -> a -> b
$ \RenamingsK
  (InterpretVar i as ':&&: (InterpretVar j as ':&&: 'LoT0)) cs
rename' f :@@: cs
x' ->
      case RenamingsK
  (InterpretVar i as ':&&: (InterpretVar j as ':&&: 'LoT0)) cs
rename' of
        RCons Name a -> Name b
_ (RCons Name a -> Name b
_ RenamingsK as bs
RNil) ->
          RenamingsK as (PutBackLoT j b (PutBackLoT i b bs))
-> Field
     (('Kon f ':@: 'Var i) ':@: 'Var j)
     (PutBackLoT j b (PutBackLoT i b bs))
-> r
forall (cs :: LoT k).
RenamingsK as cs
-> Field (('Kon f ':@: 'Var i) ':@: 'Var j) cs -> r
cont (forall k (i :: TyVar k S) (j :: TyVar k S) (c1 :: S) (c2 :: S)
       (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 @_ @i @j RenamingsK
  (Interpret ('Var i) as ':&&: (Interpret ('Var j) as ':&&: 'LoT0))
  (b ':&&: (b ':&&: 'LoT0))
RenamingsK
  (InterpretVar i as ':&&: (InterpretVar j as ':&&: 'LoT0)) cs
rename' RenamingsK as bs
irename)
              (Interpret
  (('Kon f ':@: 'Var i) ':@: 'Var j)
  (PutBackLoT j b (PutBackLoT i b bs))
-> Field
     (('Kon f ':@: 'Var i) ':@: 'Var j)
     (PutBackLoT j b (PutBackLoT i b bs))
forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field (f b b
-> f (InterpretVar i (PutBackLoT j b (PutBackLoT i b bs)))
     (InterpretVar j (PutBackLoT j b (PutBackLoT i b bs)))
forall a b. a -> b
unsafeCoerce f b b
f :@@: cs
x'))  -- FIXME: can we do better than unsafeCoerce?

instance (Functor f, GSinkableK (Field x)) => GSinkableK (Field (Kon f :@: x)) where
  gsinkabilityProofK :: forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> Field ('Kon f ':@: x) as
-> (forall (cs :: LoT k).
    RenamingsK as cs -> Field ('Kon f ':@: x) cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename (Field Interpret ('Kon f ':@: x) as
x) forall (cs :: LoT k).
RenamingsK as cs -> Field ('Kon f ':@: x) cs -> r
cont =
    RenamingsK as bs -> Field ('Kon f ':@: x) bs -> r
forall (cs :: LoT k).
RenamingsK as cs -> Field ('Kon f ':@: x) cs -> r
cont RenamingsK as bs
irename (Interpret ('Kon f ':@: x) bs -> Field ('Kon f ':@: x) bs
forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field ((Interpret x as -> Interpret x bs)
-> f (Interpret x as) -> f (Interpret x bs)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      (Field x bs -> Interpret x bs
forall {d} (t :: Atom d (*)) (x :: LoT d).
Field t x -> Interpret t x
unField (Field x bs -> Interpret x bs)
-> (Interpret x as -> Field x bs)
-> Interpret x as
-> Interpret x bs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: LoT k -> *) (as :: LoT k) (bs :: LoT k).
GSinkableK f =>
RenamingsK as bs -> f as -> f bs
forall (f :: LoT k -> *) (as :: LoT k) (bs :: LoT k).
GSinkableK f =>
RenamingsK as bs -> f as -> f bs
gsinkabilityProofK' @(Field x) RenamingsK as bs
irename (Field x as -> Field x bs)
-> (Interpret x as -> Field x as) -> Interpret x as -> Field x bs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interpret x as -> Field x as
forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field)
      f (Interpret x as)
Interpret ('Kon f ':@: x) as
x))

instance (Bifunctor f, GSinkableK (Field x), GSinkableK (Field y)) => GSinkableK (Field (Kon f :@: x :@: y)) where
  gsinkabilityProofK :: forall (as :: LoT k) (bs :: LoT k) r.
RenamingsK as bs
-> Field (('Kon f ':@: x) ':@: y) as
-> (forall (cs :: LoT k).
    RenamingsK as cs -> Field (('Kon f ':@: x) ':@: y) cs -> r)
-> r
gsinkabilityProofK RenamingsK as bs
irename (Field Interpret (('Kon f ':@: x) ':@: y) as
x) forall (cs :: LoT k).
RenamingsK as cs -> Field (('Kon f ':@: x) ':@: y) cs -> r
cont =
    RenamingsK as bs -> Field (('Kon f ':@: x) ':@: y) bs -> r
forall (cs :: LoT k).
RenamingsK as cs -> Field (('Kon f ':@: x) ':@: y) cs -> r
cont RenamingsK as bs
irename (Interpret (('Kon f ':@: x) ':@: y) bs
-> Field (('Kon f ':@: x) ':@: y) bs
forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field ((Interpret x as -> Interpret x bs)
-> (Interpret y as -> Interpret y bs)
-> f (Interpret x as) (Interpret y as)
-> f (Interpret x bs) (Interpret y bs)
forall a b c d. (a -> b) -> (c -> d) -> f a c -> f b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap
      (Field x bs -> Interpret x bs
forall {d} (t :: Atom d (*)) (x :: LoT d).
Field t x -> Interpret t x
unField (Field x bs -> Interpret x bs)
-> (Interpret x as -> Field x bs)
-> Interpret x as
-> Interpret x bs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: LoT k -> *) (as :: LoT k) (bs :: LoT k).
GSinkableK f =>
RenamingsK as bs -> f as -> f bs
forall (f :: LoT k -> *) (as :: LoT k) (bs :: LoT k).
GSinkableK f =>
RenamingsK as bs -> f as -> f bs
gsinkabilityProofK' @(Field x) RenamingsK as bs
irename (Field x as -> Field x bs)
-> (Interpret x as -> Field x as) -> Interpret x as -> Field x bs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interpret x as -> Field x as
forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field)
      (Field y bs -> Interpret y bs
forall {d} (t :: Atom d (*)) (x :: LoT d).
Field t x -> Interpret t x
unField (Field y bs -> Interpret y bs)
-> (Interpret y as -> Field y bs)
-> Interpret y as
-> Interpret y bs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: LoT k -> *) (as :: LoT k) (bs :: LoT k).
GSinkableK f =>
RenamingsK as bs -> f as -> f bs
forall (f :: LoT k -> *) (as :: LoT k) (bs :: LoT k).
GSinkableK f =>
RenamingsK as bs -> f as -> f bs
gsinkabilityProofK' @(Field y) RenamingsK as bs
irename (Field y as -> Field y bs)
-> (Interpret y as -> Field y as) -> Interpret y as -> Field y bs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interpret y as -> Field y as
forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field)
      f (Interpret x as) (Interpret y as)
Interpret (('Kon f ':@: x) ':@: y) as
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 :: forall (pattern :: S -> S -> *) (f :: S -> S -> S -> S -> *)
       (o :: S) (n :: S) (l :: S) r.
(Distinct o, GenericK pattern,
 GValidNameBinders pattern (RepK pattern),
 GHasNameBinders (RepK pattern)) =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (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' :: S).
    DExt o o' =>
    f n l o o' -> pattern o o' -> Scope o' -> r)
-> r
gunsafeWithPatternViaHasNameBinders forall (x :: S) (y :: S) (z :: S) r'.
Distinct z =>
Scope z
-> NameBinder x y
-> (forall (z' :: S).
    DExt z z' =>
    f x y z z' -> NameBinder z z' -> r')
-> r'
withBinder forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z'
id_ forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S) (z'' :: S).
(DExt z z', DExt z' z'') =>
f x y z z' -> f y y' z' z'' -> f x y' z z''
comp_ Scope o
scope pattern n l
pat forall (o' :: S).
DExt o o' =>
f n l o o' -> pattern o o' -> Scope o' -> r
cont =
  (forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (DExt z z', DExt z' z'') =>
    f x y z z' -> f y y' z' z'' -> f x y' z z'')
-> Scope o
-> NameBinders n l
-> (forall (o' :: S).
    DExt o o' =>
    f n l o o' -> NameBinders o o' -> Scope o' -> r)
-> r
forall (o :: S) (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
Distinct o =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (DExt z z', DExt z' z'') =>
    f x y z z' -> f y y' z' z'' -> f x y' z z'')
-> Scope o
-> NameBinders n l
-> (forall (o' :: S).
    DExt o o' =>
    f n l o o' -> NameBinders o o' -> Scope o' -> r)
-> r
forall (pattern :: S -> S -> *) (o :: S)
       (f :: S -> S -> S -> S -> *) (n :: S) (l :: S) r.
(CoSinkable pattern, Distinct o) =>
(forall (x :: S) (y :: S) (z :: S) r'.
 Distinct z =>
 Scope z
 -> NameBinder x y
 -> (forall (z' :: S).
     DExt z z' =>
     f x y z z' -> NameBinder z z' -> r')
 -> r')
-> (forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z')
-> (forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S)
           (z'' :: S).
    (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' :: S).
    DExt o o' =>
    f n l o o' -> pattern o o' -> Scope o' -> r)
-> r
withPattern Scope z
-> NameBinder x y
-> (forall (z' :: S).
    DExt z z' =>
    f x y z z' -> NameBinder z z' -> r')
-> r'
forall (x :: S) (y :: S) (z :: S) r'.
Distinct z =>
Scope z
-> NameBinder x y
-> (forall (z' :: S).
    DExt z z' =>
    f x y z z' -> NameBinder z z' -> r')
-> r'
withBinder f x x z z'
forall (x :: S) (z :: S) (z' :: S). DExt z z' => f x x z z'
id_ f x y z z' -> f y y' z' z'' -> f x y' z z''
forall (x :: S) (y :: S) (y' :: S) (z :: S) (z' :: S) (z'' :: S).
(DExt z z', DExt z' z'') =>
f x y z z' -> f y y' z' z'' -> f x y' z z''
comp_ Scope o
scope (pattern n l -> NameBinders n l
forall (f :: S -> S -> *) (n :: S) (l :: S).
(GenericK f, GHasNameBinders (RepK f)) =>
f n l -> NameBinders n l
ggetNameBinders pattern n l
pat) ((forall (o' :: S).
  DExt o o' =>
  f n l o o' -> NameBinders o o' -> Scope o' -> r)
 -> r)
-> (forall (o' :: S).
    DExt o o' =>
    f n l o o' -> NameBinders o o' -> Scope o' -> r)
-> r
forall a b. (a -> b) -> a -> b
$ \f n l o o'
result NameBinders o o'
binders Scope o'
scope' ->
    f n l o o' -> pattern o o' -> Scope o' -> r
forall (o' :: S).
DExt o o' =>
f n l o o' -> pattern o o' -> Scope o' -> r
cont f n l o o'
result (pattern o (ZonkAny 0) -> NameBinders o o' -> pattern o o'
forall (f :: S -> S -> *) (n :: S) (l :: S) (l' :: S).
(GenericK f, GValidNameBinders f (RepK f),
 GHasNameBinders (RepK f)) =>
f n l -> NameBinders n l' -> f n l'
gunsafeSetNameBinders (pattern n l -> pattern o (ZonkAny 0)
forall a b. a -> b
unsafeCoerce pattern n l
pat) NameBinders o o'
binders) Scope o'
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 = RawScope -> NameBinders n l
forall (n :: S) (l :: S). RawScope -> NameBinders n l
UnsafeNameBinders (RawScope -> NameBinders n l)
-> (f n l -> RawScope) -> f n l -> NameBinders n l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RawName] -> RawScope
IntSet.fromList ([RawName] -> RawScope)
-> (f n l -> [RawName]) -> f n l -> RawScope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f n l -> [RawName]
forall (n :: S) (l :: S). f n l -> [RawName]
forall (f :: S -> S -> *) (n :: S) (l :: S).
HasNameBinders f =>
f n l -> [RawName]
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 f n l
e (UnsafeNameBinders RawScope
m) = (f n l', [RawName]) -> f n l'
forall a b. (a, b) -> a
fst (f n l -> [RawName] -> (f n l', [RawName])
forall (n :: S) (l :: S) (l' :: S).
f n l -> [RawName] -> (f n l', [RawName])
forall (f :: S -> S -> *) (n :: S) (l :: S) (l' :: S).
HasNameBinders f =>
f n l -> [RawName] -> (f n l', [RawName])
reallyUnsafeSetNameBindersRaw f n l
e (RawScope -> [RawName]
IntSet.toList RawScope
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 = RepK f (n ':&&: (l ':&&: 'LoT0)) -> [RawName]
forall {k} (f :: k -> *) (as :: k).
GHasNameBinders f =>
f as -> [RawName]
forall (as :: LoT (S -> S -> *)). RepK f as -> [RawName]
ggetNameBindersRaw (RepK f (n ':&&: (l ':&&: 'LoT0)) -> [RawName])
-> (f n l -> RepK f (n ':&&: (l ':&&: 'LoT0)))
-> f n l
-> [RawName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k) (x :: LoT k).
GenericK f =>
(f :@@: x) -> RepK f x
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 f n l
e [RawName]
names =
    let (RepK f (n ':&&: (l' ':&&: 'LoT0))
e', [RawName]
names') = RepK f (n ':&&: (l ':&&: 'LoT0))
-> [RawName] -> (RepK f (n ':&&: (l' ':&&: 'LoT0)), [RawName])
forall {k} (f :: k -> *) (as :: k) (bs :: k).
GHasNameBinders f =>
f as -> [RawName] -> (f bs, [RawName])
forall (as :: LoT (S -> S -> *)) (bs :: LoT (S -> S -> *)).
RepK f as -> [RawName] -> (RepK f bs, [RawName])
greallyUnsafeSetNameBindersRaw (forall k (f :: k) (x :: LoT k).
GenericK f =>
(f :@@: x) -> RepK f x
fromK @_ @f @(n :&&: l :&&: LoT0) f n l
f :@@: (n ':&&: (l ':&&: 'LoT0))
e) [RawName]
names
     in (forall k (f :: k) (x :: LoT k). GenericK f => RepK f x -> f :@@: x
toK @_ @f @(n :&&: l' :&&: LoT0) RepK f (n ':&&: (l' ':&&: 'LoT0))
e', [RawName]
names')

instance HasNameBinders NameBinder where
  getNameBindersRaw :: forall (n :: S) (l :: S). NameBinder n l -> [RawName]
getNameBindersRaw (UnsafeNameBinder (UnsafeName RawName
name)) = [RawName
name]
  reallyUnsafeSetNameBindersRaw :: forall (n :: S) (l :: S) (l' :: S).
NameBinder n l -> [RawName] -> (NameBinder n l', [RawName])
reallyUnsafeSetNameBindersRaw NameBinder n l
_ (RawName
name:[RawName]
names) = (Name l' -> NameBinder n l'
forall (n :: S) (l :: S). Name l -> NameBinder n l
UnsafeNameBinder (RawName -> Name l'
forall (n :: S). RawName -> Name n
UnsafeName RawName
name), [RawName]
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 :: forall (f :: S -> S -> *) (n :: S) (l :: S).
(GenericK f, GHasNameBinders (RepK f)) =>
f n l -> NameBinders n l
ggetNameBinders = RawScope -> NameBinders n l
forall (n :: S) (l :: S). RawScope -> NameBinders n l
UnsafeNameBinders (RawScope -> NameBinders n l)
-> (f n l -> RawScope) -> f n l -> NameBinders n l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RawName] -> RawScope
IntSet.fromList ([RawName] -> RawScope)
-> (f n l -> [RawName]) -> f n l -> RawScope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepK f (n ':&&: (l ':&&: 'LoT0)) -> [RawName]
forall {k} (f :: k -> *) (as :: k).
GHasNameBinders f =>
f as -> [RawName]
forall (as :: LoT (S -> S -> *)). RepK f as -> [RawName]
ggetNameBindersRaw (RepK f (n ':&&: (l ':&&: 'LoT0)) -> [RawName])
-> (f n l -> RepK f (n ':&&: (l ':&&: 'LoT0)))
-> f n l
-> [RawName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k) (x :: LoT k).
GenericK f =>
(f :@@: x) -> RepK f x
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 :: forall (f :: S -> S -> *) (n :: S) (l :: S) (l' :: S).
(GenericK f, GValidNameBinders f (RepK f),
 GHasNameBinders (RepK f)) =>
f n l -> NameBinders n l' -> f n l'
gunsafeSetNameBinders f n l
e (UnsafeNameBinders RawScope
m) = forall k (f :: k) (x :: LoT k). GenericK f => RepK f x -> f :@@: x
toK @_ @f @(n :&&: l' :&&: LoT0) (RepK f (n ':&&: (l' ':&&: 'LoT0))
 -> f :@@: (n ':&&: (l' ':&&: 'LoT0)))
-> RepK f (n ':&&: (l' ':&&: 'LoT0))
-> f :@@: (n ':&&: (l' ':&&: 'LoT0))
forall a b. (a -> b) -> a -> b
$
  (RepK f (n ':&&: (l' ':&&: 'LoT0)), [RawName])
-> RepK f (n ':&&: (l' ':&&: 'LoT0))
forall a b. (a, b) -> a
fst (RepK f (n ':&&: (l ':&&: 'LoT0))
-> [RawName] -> (RepK f (n ':&&: (l' ':&&: 'LoT0)), [RawName])
forall {k} (f :: k -> *) (as :: k) (bs :: k).
GHasNameBinders f =>
f as -> [RawName] -> (f bs, [RawName])
forall (as :: LoT (S -> S -> *)) (bs :: LoT (S -> S -> *)).
RepK f as -> [RawName] -> (RepK f bs, [RawName])
greallyUnsafeSetNameBindersRaw (forall k (f :: k) (x :: LoT k).
GenericK f =>
(f :@@: x) -> RepK f x
fromK @_ @f @(n :&&: l :&&: LoT0) f n l
f :@@: (n ':&&: (l ':&&: 'LoT0))
e) (RawScope -> [RawName]
IntSet.toList RawScope
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 :: forall (as :: k). V1 as -> [RawName]
ggetNameBindersRaw V1 as
_ = String -> [RawName]
forall a. HasCallStack => String -> a
error String
"absurd: Generics.Kind.V1"
  greallyUnsafeSetNameBindersRaw :: forall (as :: k) (bs :: k).
V1 as -> [RawName] -> (V1 bs, [RawName])
greallyUnsafeSetNameBindersRaw V1 as
_ [RawName]
_ = String -> (V1 bs, [RawName])
forall a. HasCallStack => String -> a
error String
"absurd: Generics.Kind.V1"
instance GHasNameBinders U1 where
  ggetNameBindersRaw :: forall (as :: k). U1 as -> [RawName]
ggetNameBindersRaw U1 as
U1 = []
  greallyUnsafeSetNameBindersRaw :: forall (as :: k) (bs :: k).
U1 as -> [RawName] -> (U1 bs, [RawName])
greallyUnsafeSetNameBindersRaw U1 as
U1 [RawName]
names = (U1 bs
forall k (p :: k). U1 p
U1, [RawName]
names)

instance (GHasNameBinders f, GHasNameBinders g) => GHasNameBinders (f :+: g) where
  ggetNameBindersRaw :: forall (as :: k). (:+:) f g as -> [RawName]
ggetNameBindersRaw (L1 f as
x) = f as -> [RawName]
forall (as :: k). f as -> [RawName]
forall {k} (f :: k -> *) (as :: k).
GHasNameBinders f =>
f as -> [RawName]
ggetNameBindersRaw f as
x
  ggetNameBindersRaw (R1 g as
x) = g as -> [RawName]
forall (as :: k). g as -> [RawName]
forall {k} (f :: k -> *) (as :: k).
GHasNameBinders f =>
f as -> [RawName]
ggetNameBindersRaw g as
x

  greallyUnsafeSetNameBindersRaw :: forall (as :: k) (bs :: k).
(:+:) f g as -> [RawName] -> ((:+:) f g bs, [RawName])
greallyUnsafeSetNameBindersRaw (L1 f as
x) [RawName]
names = (f bs -> (:+:) f g bs)
-> (f bs, [RawName]) -> ((:+:) f g bs, [RawName])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first f bs -> (:+:) f g bs
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f as -> [RawName] -> (f bs, [RawName])
forall (as :: k) (bs :: k). f as -> [RawName] -> (f bs, [RawName])
forall {k} (f :: k -> *) (as :: k) (bs :: k).
GHasNameBinders f =>
f as -> [RawName] -> (f bs, [RawName])
greallyUnsafeSetNameBindersRaw f as
x [RawName]
names)
  greallyUnsafeSetNameBindersRaw (R1 g as
x) [RawName]
names = (g bs -> (:+:) f g bs)
-> (g bs, [RawName]) -> ((:+:) f g bs, [RawName])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first g bs -> (:+:) f g bs
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g as -> [RawName] -> (g bs, [RawName])
forall (as :: k) (bs :: k). g as -> [RawName] -> (g bs, [RawName])
forall {k} (f :: k -> *) (as :: k) (bs :: k).
GHasNameBinders f =>
f as -> [RawName] -> (f bs, [RawName])
greallyUnsafeSetNameBindersRaw g as
x [RawName]
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 :: forall (as :: k). (:*:) f g as -> [RawName]
ggetNameBindersRaw (f as
x :*: g as
y) = f as -> [RawName]
forall (as :: k). f as -> [RawName]
forall {k} (f :: k -> *) (as :: k).
GHasNameBinders f =>
f as -> [RawName]
ggetNameBindersRaw f as
x [RawName] -> [RawName] -> [RawName]
forall a. Semigroup a => a -> a -> a
<> g as -> [RawName]
forall (as :: k). g as -> [RawName]
forall {k} (f :: k -> *) (as :: k).
GHasNameBinders f =>
f as -> [RawName]
ggetNameBindersRaw g as
y
  greallyUnsafeSetNameBindersRaw :: forall (as :: k) (bs :: k).
(:*:) f g as -> [RawName] -> ((:*:) f g bs, [RawName])
greallyUnsafeSetNameBindersRaw (f as
x :*: g as
y) [RawName]
names =
    let (f bs
x', [RawName]
names') = f as -> [RawName] -> (f bs, [RawName])
forall (as :: k) (bs :: k). f as -> [RawName] -> (f bs, [RawName])
forall {k} (f :: k -> *) (as :: k) (bs :: k).
GHasNameBinders f =>
f as -> [RawName] -> (f bs, [RawName])
greallyUnsafeSetNameBindersRaw f as
x [RawName]
names
        (g bs
y', [RawName]
names'') = g as -> [RawName] -> (g bs, [RawName])
forall (as :: k) (bs :: k). g as -> [RawName] -> (g bs, [RawName])
forall {k} (f :: k -> *) (as :: k) (bs :: k).
GHasNameBinders f =>
f as -> [RawName] -> (f bs, [RawName])
greallyUnsafeSetNameBindersRaw g as
y [RawName]
names'
     in (f bs
x' f bs -> g bs -> (:*:) f g bs
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g bs
y', [RawName]
names'')

instance GHasNameBinders f => GHasNameBinders (M1 i c f) where
  ggetNameBindersRaw :: forall (as :: k). M1 i c f as -> [RawName]
ggetNameBindersRaw (M1 f as
x) = f as -> [RawName]
forall (as :: k). f as -> [RawName]
forall {k} (f :: k -> *) (as :: k).
GHasNameBinders f =>
f as -> [RawName]
ggetNameBindersRaw f as
x
  greallyUnsafeSetNameBindersRaw :: forall (as :: k) (bs :: k).
M1 i c f as -> [RawName] -> (M1 i c f bs, [RawName])
greallyUnsafeSetNameBindersRaw (M1 f as
x) [RawName]
names =
    let (f bs
x', [RawName]
names') = f as -> [RawName] -> (f bs, [RawName])
forall (as :: k) (bs :: k). f as -> [RawName] -> (f bs, [RawName])
forall {k} (f :: k -> *) (as :: k) (bs :: k).
GHasNameBinders f =>
f as -> [RawName] -> (f bs, [RawName])
greallyUnsafeSetNameBindersRaw f as
x [RawName]
names
     in (f bs -> M1 i c f bs
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 f bs
x', [RawName]
names')

instance GHasNameBinders f => GHasNameBinders (Var i :~~: Var j :=>: f) where
  ggetNameBindersRaw :: forall (as :: LoT d). (:=>:) ('Var i :~~: 'Var j) f as -> [RawName]
ggetNameBindersRaw (SuchThat f as
x) = f as -> [RawName]
forall {k} (f :: k -> *) (as :: k).
GHasNameBinders f =>
f as -> [RawName]
forall (as :: LoT d). f as -> [RawName]
ggetNameBindersRaw f as
x

  greallyUnsafeSetNameBindersRaw :: forall as bs. (Var i :~~: Var j :=>: f) as -> [RawName] -> ((Var i :~~: Var j :=>: f) bs, [RawName])
  greallyUnsafeSetNameBindersRaw :: forall (as :: LoT d) (bs :: LoT d).
(:=>:) ('Var i :~~: 'Var j) f as
-> [RawName] -> ((:=>:) ('Var i :~~: 'Var j) f bs, [RawName])
greallyUnsafeSetNameBindersRaw (SuchThat f as
x) [RawName]
names =
    -- this is sort of safe...
    case (InterpretVar i bs :~: InterpretVar i bs)
-> InterpretVar i bs :~: InterpretVar j bs
forall a b. a -> b
unsafeCoerce (Interpret ('Var i) bs :~: Interpret ('Var i) bs
InterpretVar i bs :~: InterpretVar i bs
forall {k} (a :: k). a :~: a
Type.Refl :: Interpret (Var i) bs Type.:~: Interpret (Var i) bs) :: Interpret (Var i) bs Type.:~: Interpret (Var j) bs of
      Interpret ('Var i) bs :~: Interpret ('Var j) bs
Type.Refl ->
        let (f bs
x', [RawName]
names') = f as -> [RawName] -> (f bs, [RawName])
forall {k} (f :: k -> *) (as :: k) (bs :: k).
GHasNameBinders f =>
f as -> [RawName] -> (f bs, [RawName])
forall (as :: LoT d) (bs :: LoT d).
f as -> [RawName] -> (f bs, [RawName])
greallyUnsafeSetNameBindersRaw f as
x [RawName]
names
         in (f bs -> (:=>:) ('Var i :~~: 'Var j) f bs
forall {d} (c :: Atom d Constraint) (x :: LoT d) (f :: LoT d -> *).
Interpret c x =>
f x -> (:=>:) c f x
SuchThat f bs
x', [RawName]
names')

instance GHasNameBinders f => GHasNameBinders (Exists k f) where
  ggetNameBindersRaw :: forall (as :: LoT d). Exists k f as -> [RawName]
ggetNameBindersRaw (Exists f (t ':&&: as)
x) = f (t ':&&: as) -> [RawName]
forall {k} (f :: k -> *) (as :: k).
GHasNameBinders f =>
f as -> [RawName]
forall (as :: LoT (k -> d)). f as -> [RawName]
ggetNameBindersRaw f (t ':&&: as)
x
  greallyUnsafeSetNameBindersRaw :: forall (as :: LoT d) (bs :: LoT d).
Exists k f as -> [RawName] -> (Exists k f bs, [RawName])
greallyUnsafeSetNameBindersRaw (Exists f (t ':&&: as)
x) [RawName]
names =
    let (f (ZonkAny 45 ':&&: bs)
x', [RawName]
names') = f (t ':&&: as) -> [RawName] -> (f (ZonkAny 45 ':&&: bs), [RawName])
forall {k} (f :: k -> *) (as :: k) (bs :: k).
GHasNameBinders f =>
f as -> [RawName] -> (f bs, [RawName])
forall (as :: LoT (k -> d)) (bs :: LoT (k -> d)).
f as -> [RawName] -> (f bs, [RawName])
greallyUnsafeSetNameBindersRaw f (t ':&&: as)
x [RawName]
names
     in (f (ZonkAny 45 ':&&: bs) -> Exists k f bs
forall k (t :: k) d (f :: LoT (k -> d) -> *) (x :: LoT d).
f (t ':&&: x) -> Exists k f x
Exists f (ZonkAny 45 ':&&: bs)
x', [RawName]
names')

instance GHasNameBinders (Field (Kon a)) where
  ggetNameBindersRaw :: forall (as :: LoT d). Field ('Kon a) as -> [RawName]
ggetNameBindersRaw (Field Interpret ('Kon a) as
_x) = []
  greallyUnsafeSetNameBindersRaw :: forall (as :: LoT d) (bs :: LoT d).
Field ('Kon a) as -> [RawName] -> (Field ('Kon a) bs, [RawName])
greallyUnsafeSetNameBindersRaw (Field Interpret ('Kon a) as
x) [RawName]
names = (Interpret ('Kon a) bs -> Field ('Kon a) bs
forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field Interpret ('Kon a) as
Interpret ('Kon a) bs
x, [RawName]
names)

instance GHasNameBinders (Field (Var x)) where
  ggetNameBindersRaw :: forall (as :: LoT d). Field ('Var x) as -> [RawName]
ggetNameBindersRaw (Field Interpret ('Var x) as
_x) = []
  greallyUnsafeSetNameBindersRaw :: forall (as :: LoT d) (bs :: LoT d).
Field ('Var x) as -> [RawName] -> (Field ('Var x) bs, [RawName])
greallyUnsafeSetNameBindersRaw (Field Interpret ('Var x) as
x) [RawName]
names = (Interpret ('Var x) bs -> Field ('Var x) bs
forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field (InterpretVar x as -> InterpretVar x bs
forall a b. a -> b
unsafeCoerce Interpret ('Var x) as
InterpretVar x as
x), [RawName]
names)  -- FIXME: unsafeCoerce?

instance GHasNameBinders (Field (Kon f :@: Var i)) where
  ggetNameBindersRaw :: forall (as :: LoT d). Field ('Kon f ':@: 'Var i) as -> [RawName]
ggetNameBindersRaw (Field Interpret ('Kon f ':@: 'Var i) as
_x) = []
  greallyUnsafeSetNameBindersRaw :: forall (as :: LoT d) (bs :: LoT d).
Field ('Kon f ':@: 'Var i) as
-> [RawName] -> (Field ('Kon f ':@: 'Var i) bs, [RawName])
greallyUnsafeSetNameBindersRaw (Field Interpret ('Kon f ':@: 'Var i) as
x) [RawName]
names = (Interpret ('Kon f ':@: 'Var i) bs -> Field ('Kon f ':@: 'Var i) bs
forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field (f (InterpretVar i as) -> f (InterpretVar i bs)
forall a b. a -> b
unsafeCoerce f (InterpretVar i as)
Interpret ('Kon f ':@: 'Var i) as
x), [RawName]
names) -- FIXME: unsafeCoerce?

instance HasNameBinders f => GHasNameBinders (Field (Kon f :@: Var i :@: Var j)) where
  ggetNameBindersRaw :: forall (as :: LoT d).
Field (('Kon f ':@: 'Var i) ':@: 'Var j) as -> [RawName]
ggetNameBindersRaw (Field Interpret (('Kon f ':@: 'Var i) ':@: 'Var j) as
x) = f (InterpretVar i as) (InterpretVar j as) -> [RawName]
forall (n :: S) (l :: S). f n l -> [RawName]
forall (f :: S -> S -> *) (n :: S) (l :: S).
HasNameBinders f =>
f n l -> [RawName]
getNameBindersRaw f (InterpretVar i as) (InterpretVar j as)
Interpret (('Kon f ':@: 'Var i) ':@: 'Var j) as
x
  greallyUnsafeSetNameBindersRaw :: forall (as :: LoT d) (bs :: LoT d).
Field (('Kon f ':@: 'Var i) ':@: 'Var j) as
-> [RawName]
-> (Field (('Kon f ':@: 'Var i) ':@: 'Var j) bs, [RawName])
greallyUnsafeSetNameBindersRaw (Field Interpret (('Kon f ':@: 'Var i) ':@: 'Var j) as
x) [RawName]
names =
    let (f (InterpretVar i as) (ZonkAny 44)
x', [RawName]
names') = f (InterpretVar i as) (InterpretVar j as)
-> [RawName] -> (f (InterpretVar i as) (ZonkAny 44), [RawName])
forall (n :: S) (l :: S) (l' :: S).
f n l -> [RawName] -> (f n l', [RawName])
forall (f :: S -> S -> *) (n :: S) (l :: S) (l' :: S).
HasNameBinders f =>
f n l -> [RawName] -> (f n l', [RawName])
reallyUnsafeSetNameBindersRaw f (InterpretVar i as) (InterpretVar j as)
Interpret (('Kon f ':@: 'Var i) ':@: 'Var j) as
x [RawName]
names
     in (Interpret (('Kon f ':@: 'Var i) ':@: 'Var j) bs
-> Field (('Kon f ':@: 'Var i) ':@: 'Var j) bs
forall {d} (t :: Atom d (*)) (x :: LoT d).
Interpret t x -> Field t x
Field (f (InterpretVar i as) (ZonkAny 44)
-> f (InterpretVar i bs) (InterpretVar j bs)
forall a b. a -> b
unsafeCoerce f (InterpretVar i as) (ZonkAny 44)
x'), [RawName]
names') -- FIXME: safer version?