Namespacing support

cabal.project

@@ -3,6 +3,7 @@ packages:
   packages/diagnostician-terminal
   packages/diagnostician-html
   packages/fnotation
+  packages/yclept
   packages/coln-compiler
 if !os(wasi)
   packages:

justfile

@@ -14,7 +14,7 @@ check package:
 fix package:
     just -f packages/{{package}}/justfile fix
 
-check-haskell: (check "coln-compiler") (check "coln-cli") (check "coln-repl") (check "coln-ls") (check "fnotation") (check "diagnostician")
+check-haskell: (check "coln-compiler") (check "coln-cli") (check "coln-repl") (check "coln-ls") (check "fnotation") (check "diagnostician") (check "yclept")
 
 check-rust: (check "coln-store") (check "coln-query") (check "coln-batch") (check "coln-flir-rs")
 
@@ -25,7 +25,7 @@ check-licenses:
 
 check-all: check-haskell check-rust check-typescript
 
-fix-haskell: (fix "coln-compiler") (fix "coln-cli") (fix "coln-repl") (fix "coln-ls") (fix "fnotation") (fix "diagnostician")
+fix-haskell: (fix "coln-compiler") (fix "coln-cli") (fix "coln-repl") (fix "coln-ls") (fix "fnotation") (fix "diagnostician") (fix "yclept")
 
 fix-licenses:
     git ls-files -z '*.[hrt]s' {{ generated_file_pathspecs }} | xargs -0 reuse annotate -c "Coln contributors" -l "Apache-2.0 OR MIT"

packages/yclept/README.md

@@ -0,0 +1,4 @@
+# yclept
+
+Based on the OCaml [`yuujinchou`](../../ocaml) library: name pattern
+combinators for hierarchical names.

packages/yclept/justfile

@@ -0,0 +1 @@
+import '../../build-support/haskell.just'

packages/yclept/src/Yclept.hs

@@ -0,0 +1,27 @@
+-- SPDX-FileCopyrightText: 2026 Coln contributors
+--
+-- SPDX-License-Identifier: Apache-2.0 OR MIT
+
+{- | Name pattern combinators for hierarchical names — based on the OCaml
+  @yuujinchou@ library.
+
+This is a documentation landing module: it deliberately exports nothing,
+because the submodules share many names (@empty@, @union@, @singleton@, …)
+and are designed to be imported /qualified/, like "Data.Map":
+
+> import qualified Yclept.Bwd as Bwd
+> import qualified Yclept.Trie as Trie
+> import qualified Yclept.Trie.Untagged as UntaggedTrie
+> import qualified Yclept.Language as Language
+> import qualified Yclept.Modifier as Modifier
+> import qualified Yclept.Scope as Scope
+
+The pieces:
+
+* "Yclept.Bwd": backward (snoc) lists, used for path prefixes.
+* "Yclept.Trie" and "Yclept.Trie.Untagged": the trie data structure.
+* "Yclept.Language": the modifier DSL.
+* "Yclept.Modifier": the modifier engine and its 'Yclept.Modifier.Handlers' bundle.
+* "Yclept.Scope": the lexical-scope engine.
+-}
+module Yclept () where

packages/yclept/src/Yclept/Bwd.hs

@@ -0,0 +1,47 @@
+-- SPDX-FileCopyrightText: 2026 Coln contributors
+--
+-- SPDX-License-Identifier: Apache-2.0 OR MIT
+
+{- | Backward (snoc) lists, a port of the OCaml @bwd@ library.
+
+A backward list grows at the /right/ end: @'Emp' ':<' \"x\" ':<' \"y\"@
+represents the sequence @x, y@ and 'toList' yields @[\"x\", \"y\"]@.
+-}
+module Yclept.Bwd (
+  Bwd (..),
+  (#<),
+  (<:),
+  (<@),
+  toList,
+  length,
+) where
+
+import Data.Foldable (length, toList)
+import Prelude hiding (length)
+
+-- | A backward list.  The constructor ':<' is snoc: @xs ':<' x@.
+data Bwd a
+  = Emp
+  | Bwd a :< a
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+infixl 5 :<
+infixl 5 #<
+infixl 5 <:
+infixl 5 <@
+
+-- | Snoc a single element (OCaml @( #< )@).
+(#<) :: Bwd a -> a -> Bwd a
+(#<) = (:<)
+
+{- | Snoc a single element (OCaml @( <: )@); an alias of '#<' kept for parity
+with the OCaml @bwd@ API.
+-}
+(<:) :: Bwd a -> a -> Bwd a
+(<:) = (:<)
+
+{- | Append a forward list onto the right end of a backward list
+(OCaml @( <\@ )@).
+-}
+(<@) :: Bwd a -> [a] -> Bwd a
+(<@) = foldl (:<)

packages/yclept/src/Yclept/Language.hs

@@ -0,0 +1,125 @@
+-- SPDX-FileCopyrightText: 2026 Coln contributors
+--
+-- SPDX-License-Identifier: Apache-2.0 OR MIT
+
+{- | The modifier language, a port of the OCaml @Language@ / @LanguageSigs@.
+
+A @'Language' h@ value is an abstract syntax tree describing how to transform
+a trie; it is executed by "Yclept.Modifier".  Build values with the smart
+constructors ('all', 'only', 'renaming', …); the raw constructors are also
+exported so the engine (and clients who wish to) can pattern-match.
+
+Intended to be imported qualified:
+
+> import qualified Yclept.Language as Language
+-}
+module Yclept.Language (
+  Language (..),
+
+  -- * Builders
+  all,
+  id,
+  only,
+  in_,
+  none,
+  except,
+  renaming,
+  seq,
+  union,
+  hook,
+
+  -- * Debugging
+  dump,
+) where
+
+import Data.Functor.Classes (Eq1 (..))
+import Data.List (intercalate)
+import Data.Text qualified as Text
+import Prelude hiding (all, id, seq)
+
+import Yclept.Trie (Path)
+
+-- | The abstract type of modifiers, parametrised by the type of hook labels.
+data Language h
+  = MAssertNonempty
+  | MIn Path (Language h)
+  | MRenaming Path Path
+  | MSeq [Language h]
+  | MUnion [Language h]
+  | MHook h
+  deriving (Eq, Show, Functor, Foldable, Traversable)
+
+{- | Structural equality with a supplied hook comparison (the OCaml @equal@).
+The ordinary 'Eq' instance is @'liftEq' '=='@.
+-}
+instance Eq1 Language where
+  liftEq _ MAssertNonempty MAssertNonempty = True
+  liftEq eqh (MIn p1 m1) (MIn p2 m2) = p1 == p2 && liftEq eqh m1 m2
+  liftEq _ (MRenaming a1 b1) (MRenaming a2 b2) = a1 == a2 && b1 == b2
+  liftEq eqh (MSeq xs) (MSeq ys) = liftEq (liftEq eqh) xs ys
+  liftEq eqh (MUnion xs) (MUnion ys) = liftEq (liftEq eqh) xs ys
+  liftEq eqh (MHook h1) (MHook h2) = eqh h1 h2
+  liftEq _ _ _ = False
+
+{- | Keep the content of the current tree, performing @not_found@ if it is
+empty.  Equivalent to @'only' []@.
+-}
+all :: Language h
+all = MAssertNonempty
+
+{- | The identity modifier (@'seq' []@); like 'all' but without the emptiness
+check.
+-}
+id :: Language h
+id = seq []
+
+{- | Keep the subtree rooted at @path@, dropping everything else; performs
+@not_found@ if that subtree is empty.
+-}
+only :: Path -> Language h
+only p = MSeq [MIn p MAssertNonempty, MRenaming p [], MRenaming [] p]
+
+-- | Run a modifier on the subtree rooted at @path@, leaving the rest intact.
+in_ :: Path -> Language h -> Language h
+in_ = MIn
+
+-- | Drop everything, performing @not_found@ if the tree was already empty.
+none :: Language h
+none = MSeq [MAssertNonempty, MUnion []]
+
+-- | Drop the subtree rooted at @p@ (@'in_' p 'none'@).
+except :: Path -> Language h
+except p = in_ p none
+
+{- | Relocate the subtree at @path@ to @path'@, dropping any existing bindings
+under @path'@; performs @not_found@ if the source subtree is empty.
+-}
+renaming :: Path -> Path -> Language h
+renaming p p' = MSeq [MIn p MAssertNonempty, MRenaming p p']
+
+-- | Run the modifiers in order (@'seq' []@ is 'id').
+seq :: [Language h] -> Language h
+seq = MSeq
+
+-- | Union of the results of the given modifiers; collisions trigger @shadow@.
+union :: [Language h] -> Language h
+union = MUnion
+
+-- | Apply the hook labelled @h@ to the whole tree (performs the @hook@ effect).
+hook :: h -> Language h
+hook = MHook
+
+-- | Dump the internal representation for debugging, given a printer for hooks.
+dump :: (h -> String) -> Language h -> String
+dump dumpHook = go
+ where
+  go MAssertNonempty = "assert-nonempty"
+  go (MIn p m) = "in(" ++ dumpPath p ++ "; " ++ go m ++ ")"
+  go (MRenaming p1 p2) = "renaming(" ++ dumpPath p1 ++ "; " ++ dumpPath p2 ++ ")"
+  go (MSeq ms) = "seq(" ++ intercalate "; " (map go ms) ++ ")"
+  go (MUnion ms) = "union(" ++ intercalate "; " (map go ms) ++ ")"
+  go (MHook h) = "hook(" ++ dumpHook h ++ ")"
+
+dumpPath :: Path -> String
+dumpPath [] = "root"
+dumpPath segs = "path(" ++ intercalate ", " (map (show . Text.unpack) segs) ++ ")"

packages/yclept/src/Yclept/Modifier.hs

@@ -0,0 +1,119 @@
+-- SPDX-FileCopyrightText: 2026 Coln contributors
+--
+-- SPDX-License-Identifier: Apache-2.0 OR MIT
+{-# LANGUAGE OverloadedRecordDot #-}
+
+{- | The modifier engine, a port of the OCaml @Modifier@ / @ModifierSigs@.
+
+The OCaml engine performs three /overridable/ algebraic effects —
+@not_found@, @shadow@, and @hook@.  Here those become the fields of an
+explicit __bundle of handlers__, 'Handlers', which is polymorphic over a base
+monad @m@.  Every engine function ('modify', 'union', …) takes a bundle and
+runs in @m@.
+
+Because the OCaml effect handlers were installed dynamically and could be
+overridden per-region (via @run@ / @try_with@), the ceremony around them
+dissolves here: to \"override\" a handler you simply pass a different bundle
+(e.g. @hs { shadow = … }@).  The @Perform@ / @try_with@ machinery therefore
+lives at the scope layer ("Yclept.Scope"), which threads the current
+bundle through a reader environment.
+
+The four OCaml @Param@ types become the type variables @d@ (data), @t@
+(tag), @h@ (hook), and @c@ (context); the @Make(Param)@ functor is just this
+parametric polymorphism.
+-}
+module Yclept.Modifier (
+  -- * The bundle of handlers
+  Handlers (..),
+  silence,
+
+  -- * The engine
+  modify,
+
+  -- * Re-exposed union operations (using the @shadow@ handler)
+  union,
+  unionSubtree,
+  unionSingleton,
+  unionRoot,
+) where
+
+import Control.Monad (foldM)
+
+import Yclept.Bwd ((<@))
+import Yclept.Language (Language (..))
+import Yclept.Trie (BwdPath, Trie)
+import Yclept.Trie qualified as Trie
+
+{- | A bundle of handlers for the three overridable modifier effects, in a base
+monad @m@.  @d@\/@t@ are the data\/tag, @h@ the hook label, @c@ the context.
+-}
+data Handlers m d t h c = Handlers
+  { notFound :: Maybe c -> BwdPath -> m ()
+  {- ^ Called when a modifier expected at least one binding under a prefix but
+  found none.
+  -}
+  , shadow :: Maybe c -> BwdPath -> (d, t) -> (d, t) -> m (d, t)
+  {- ^ Called to reconcile two bindings @x@ (earlier) and @y@ (later) at the
+  same path during a union.
+  -}
+  , hook :: Maybe c -> BwdPath -> h -> Trie d t -> m (Trie d t)
+  -- ^ Called to run a custom hook on a subtree.
+  }
+
+{- | The handlers that silence every effect: @not_found@ does nothing, @shadow@
+keeps the later binding, @hook@ returns its input unchanged.
+-}
+silence :: (Applicative m) => Handlers m d t h c
+silence =
+  Handlers
+    { notFound = \_ _ -> pure ()
+    , shadow = \_ _ _ y -> pure y
+    , hook = \_ _ _ t -> pure t
+    }
+
+{- | @'modify' hs ctx prefix m t@ runs the modifier @m@ on the trie @t@, using
+the handler bundle @hs@ for effects.  @ctx@ is the context passed to
+handlers; @prefix@ is prepended to any path reported to them (use @'Emp'@
+for none).
+-}
+modify :: (Monad m) => Handlers m d t h c -> Maybe c -> BwdPath -> Language h -> Trie d t -> m (Trie d t)
+modify hs ctx = go
+ where
+  go prefix m t =
+    case m of
+      MAssertNonempty -> do
+        if Trie.isEmpty t then hs.notFound ctx prefix else pure ()
+        pure t
+      MIn p m' ->
+        Trie.updateSubtreeM p (go (prefix <@ p) m') t
+      MRenaming p1 p2 ->
+        let (sub, remaining) = Trie.detachSubtree p1 t
+         in pure (Trie.updateSubtree p2 (const sub) remaining)
+      MSeq ms ->
+        foldM (\acc m' -> go prefix m' acc) t ms
+      MUnion ms ->
+        foldM
+          ( \ts m' -> do
+              ti <- go prefix m' t
+              union hs ctx prefix ts ti
+          )
+          Trie.empty
+          ms
+      MHook h ->
+        hs.hook ctx prefix h t
+
+-- | Re-exposed 'Trie.union' whose merger is the @shadow@ handler.
+union :: (Monad m) => Handlers m d t h c -> Maybe c -> BwdPath -> Trie d t -> Trie d t -> m (Trie d t)
+union hs ctx prefix = Trie.unionM prefix (hs.shadow ctx)
+
+-- | Re-exposed 'Trie.unionSubtree' using the @shadow@ handler.
+unionSubtree :: (Monad m) => Handlers m d t h c -> Maybe c -> BwdPath -> Trie d t -> (Trie.Path, Trie d t) -> m (Trie d t)
+unionSubtree hs ctx prefix = Trie.unionSubtreeM prefix (hs.shadow ctx)
+
+-- | Re-exposed 'Trie.unionSingleton' using the @shadow@ handler.
+unionSingleton :: (Monad m) => Handlers m d t h c -> Maybe c -> BwdPath -> Trie d t -> (Trie.Path, (d, t)) -> m (Trie d t)
+unionSingleton hs ctx prefix = Trie.unionSingletonM prefix (hs.shadow ctx)
+
+-- | Re-exposed 'Trie.unionRoot' using the @shadow@ handler.
+unionRoot :: (Monad m) => Handlers m d t h c -> Maybe c -> BwdPath -> Trie d t -> (d, t) -> m (Trie d t)
+unionRoot hs ctx prefix = Trie.unionRootM prefix (hs.shadow ctx)