Skip to content

Commit

Permalink
Improve documentation in free-foil
Browse files Browse the repository at this point in the history
  • Loading branch information
fizruk committed Jun 19, 2024
1 parent 7b3319e commit 61908f3
Show file tree
Hide file tree
Showing 3 changed files with 50 additions and 40 deletions.
2 changes: 1 addition & 1 deletion haskell/free-foil/src/Control/Monad/Foil.hs
Original file line number Diff line number Diff line change
Expand Up @@ -28,7 +28,7 @@ module Control.Monad.Foil (
withFresh,
withRefreshed,
unsinkName,
-- * Safe (co)sinking
-- * Safe (co)sinking and renaming
Sinkable(..),
CoSinkable(..),
sink,
Expand Down
2 changes: 2 additions & 0 deletions haskell/free-foil/src/Control/Monad/Foil/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -177,6 +177,8 @@ data UnifyNameBinders n l r where
-- to match the left one.
RenameRightNameBinder :: (NameBinder n r -> NameBinder n l) -> UnifyNameBinders 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.
unifyNameBinders
:: forall i l r.
NameBinder i l
Expand Down
86 changes: 47 additions & 39 deletions haskell/free-foil/src/Control/Monad/Free/Foil.hs
Original file line number Diff line number Diff line change
Expand Up @@ -58,6 +58,8 @@ instance Bifunctor sig => Foil.Sinkable (AST sig) where
instance Foil.InjectName (AST sig) where
injectName = Var

-- * Substitution

-- | Substitution for free (scoped monads).
substitute
:: (Bifunctor sig, Foil.Distinct o)
Expand Down Expand Up @@ -118,6 +120,8 @@ instance Bifunctor sig => Foil.RelMonad Foil.Name (AST sig) where
Just n -> Foil.sink (subst n)
in ScopedAST binder' (Foil.rbind scope' body subst')

-- * \(\alpha\)-equivalence

-- | Refresh (force) all binders in a term, minimizing the used indices.
refreshAST
:: (Bifunctor sig, Foil.Distinct n)
Expand All @@ -139,45 +143,6 @@ refreshScopedAST scope (ScopedAST binder body) =
subst = Foil.addRename (Foil.sink Foil.identitySubst) binder (Foil.nameOf binder')
in ScopedAST binder' (substituteRefreshed scope' subst body)

-- | Perform one-level matching for the two terms.
class ZipMatch sig where
zipMatch
:: sig scope term
-> sig scope' term'
-> Maybe (sig (scope, scope') (term, term'))

instance (ZipMatch f, ZipMatch g) => ZipMatch (Sum f g) where
zipMatch (L2 f) (L2 f') = L2 <$> zipMatch f f'
zipMatch (R2 g) (R2 g') = R2 <$> zipMatch g g'
zipMatch _ _ = Nothing

-- | /Unsafe/ equality check for two terms.
-- This check ignores the possibility that two terms might have different
-- scope extensions under binders (which might happen due to substitution
-- under a binder in absence of name conflicts).
unsafeEqAST
:: (Bifoldable sig, ZipMatch sig)
=> AST sig n
-> AST sig l
-> Bool
unsafeEqAST (Var x) (Var y) = x == coerce y
unsafeEqAST (Node t1) (Node t2) =
case zipMatch t1 t2 of
Nothing -> False
Just tt -> getAll (bifoldMap (All . uncurry unsafeEqScopedAST) (All . uncurry unsafeEqAST) tt)
unsafeEqAST _ _ = False

-- | A version of 'unsafeEqAST' for scoped terms.
unsafeEqScopedAST
:: (Bifoldable sig, ZipMatch sig)
=> ScopedAST sig n
-> ScopedAST sig l
-> Bool
unsafeEqScopedAST (ScopedAST binder1 body1) (ScopedAST binder2 body2) = and
[ binder1 == coerce binder2
, body1 `unsafeEqAST` body2
]

-- | \(\alpha\)-equivalence check for two terms in one scope
-- via normalization of bound identifiers (via 'refreshAST').
--
Expand Down Expand Up @@ -238,3 +203,46 @@ alphaEquivScoped scope
Foil.Distinct ->
let scope1 = Foil.extendScope binder1 scope
in alphaEquiv scope1 body1 (Foil.liftRM scope1 (Foil.fromNameBinderRenaming rename2to1) body2)

-- ** Unsafe equality checks

-- | /Unsafe/ equality check for two terms.
-- This check ignores the possibility that two terms might have different
-- scope extensions under binders (which might happen due to substitution
-- under a binder in absence of name conflicts).
unsafeEqAST
:: (Bifoldable sig, ZipMatch sig)
=> AST sig n
-> AST sig l
-> Bool
unsafeEqAST (Var x) (Var y) = x == coerce y
unsafeEqAST (Node t1) (Node t2) =
case zipMatch t1 t2 of
Nothing -> False
Just tt -> getAll (bifoldMap (All . uncurry unsafeEqScopedAST) (All . uncurry unsafeEqAST) tt)
unsafeEqAST _ _ = False

-- | A version of 'unsafeEqAST' for scoped terms.
unsafeEqScopedAST
:: (Bifoldable sig, ZipMatch sig)
=> ScopedAST sig n
-> ScopedAST sig l
-> Bool
unsafeEqScopedAST (ScopedAST binder1 body1) (ScopedAST binder2 body2) = and
[ binder1 == coerce binder2
, body1 `unsafeEqAST` body2
]

-- ** Syntactic matching (unification)

-- | Perform one-level matching for the two (non-variable) terms.
class ZipMatch sig where
zipMatch
:: sig scope term -- ^ Left non-variable term.
-> sig scope' term' -- ^ Right non-variable term.
-> Maybe (sig (scope, scope') (term, term'))

instance (ZipMatch f, ZipMatch g) => ZipMatch (Sum f g) where
zipMatch (L2 f) (L2 f') = L2 <$> zipMatch f f'
zipMatch (R2 g) (R2 g') = R2 <$> zipMatch g g'
zipMatch _ _ = Nothing

0 comments on commit 61908f3

Please sign in to comment.