smirk (empty) → 0.1.0.0
raw patch · 19 files changed
+2266/−0 lines, 19 filesdep +basedep +bytestringdep +containers
Dependencies added: base, bytestring, containers, hspec, megaparsec, mono-traversable, parser-combinators, smirk, template-haskell, text, vector
Files
- CHANGELOG.md +23/−0
- LICENSE +73/−0
- README.md +222/−0
- smirk.cabal +99/−0
- src/Smirk.hs +115/−0
- src/Smirk/Core/AST.hs +96/−0
- src/Smirk/Core/Bytecode.hs +51/−0
- src/Smirk/Core/Compiler.hs +150/−0
- src/Smirk/Core/Parser.hs +226/−0
- src/Smirk/Core/Quote.hs +174/−0
- src/Smirk/Engine/Sequence.hs +147/−0
- src/Smirk/Engine/VM.hs +348/−0
- src/Smirk/Glob.hs +244/−0
- test/GlobSpec.hs +70/−0
- test/ParserSpec.hs +42/−0
- test/QuoteSpec.hs +35/−0
- test/SequenceSpec.hs +56/−0
- test/Spec.hs +16/−0
- test/VMSpec.hs +79/−0
+ CHANGELOG.md view
@@ -0,0 +1,23 @@+# Changelog for `smirk`++All notable changes to `smirk` will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the Haskell Package Versioning Policy (PVP).++## [0.1.0.0] — 2026-10-24++### Added+- **`Smirk.Core.AST`**: Core abstract syntax tree supporting full PCRE constructs: character literals, character classes, escape sequences, concatenation, alternation, bounded/unbounded repetition (greedy, lazy, possessive), lookaround assertions, and named capture groups.+- **`Smirk.Core.Bytecode` & `Smirk.Core.Compiler`**: Bytecode instruction set and non-backtracking VM compilation engine.+- **`Smirk.Engine.VM`**: Resumable, step-bounded virtual machine execution model (`Fuel`, `StepBudget`, `OutOfFuel`, `MatchContinuation`). Provides ironclad Regular Expression Denial of Service (ReDoS) defense by enforcing strict upper bounds on thread state transitions.+- **`Smirk.Engine.Sequence`**: Sequence polymorphism via `mono-traversable`'s `Element seq ~ Char`, supporting `Data.Text.Text`, `Data.ByteString.ByteString`, `[Char]`, `Data.Sequence.Seq Char`, and `Data.Vector.Vector Char`.+- **`Smirk.Core.Quote`**: Compile-time QuasiQuoters:+ - `[re|...|]`: Static PCRE pattern compilation with stage-1 AST validation.+ - `[ed|s/foo/bar/g|]`: Sed-style stream editor substitution syntax.+- **`Smirk.Glob`**: Native POSIX and Git-style globbing with `compileWildcard` and `[glob|...|]` QuasiQuoter.+- Split architecture into modular packages:+ - `smirk`: Pure core engine and quasiquoters.+ - `smirk-effectful`: Algebraic effect interface via `effectful`.+ - `smirk-polysemy`: Extensible effect interface via `polysemy`.+- Canonical tooling overlay via `gachi`: Sarutahiko RFC 2822 commit attribution trailers, 5-gate physical verification runner (`bin/smirk-verify`), and comprehensive documentation corpus.
+ LICENSE view
@@ -0,0 +1,73 @@+Apache License+Version 2.0, January 2004+http://www.apache.org/licenses/++TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++1. Definitions.++"License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document.++"Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License.++"Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity.++"You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License.++"Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files.++"Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types.++"Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below).++"Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof.++"Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution."++"Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work.++2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form.++3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed.++4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions:++ (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License.++ You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License.++5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions.++6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file.++7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License.++8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages.++9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability.++END OF TERMS AND CONDITIONS++APPENDIX: How to apply the Apache License to your work.++To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives.++Copyright [yyyy] [name of copyright owner]++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.
+ README.md view
@@ -0,0 +1,222 @@+# Smirk (;-P / ;-) — Pure Native Resumable PCRE Engine in Haskell++**Smirk** is a 100% native Haskell Perl-Compatible Regular Expression (PCRE) engine. It provides high-assurance, pure functional regular expression matching, step-bounded ReDoS immunity, pausable/resumable continuations, sequence polymorphism, and first-class algebraic effect handlers without C dependencies, buffer allocations, or FFI overhead.++---++## The Name & Emoticon Grounding++The library's name and symbol—**Smirk** (**;-P** / **;-)**)—express cheeky, playful defiance:+- In the security and system reliability world, regular expression engines are notorious for disastrous catastrophic backtracking—the dreaded **ReDoS** (Regular Expression Denial of Service) attack, where a pathological string like `aaaaaaaaaaaaaaaaaaaaaaaaaaaaa!` against `(a+)+$` locks a CPU core in exponential $\mathcal{O}(2^N)$ backtracking for hours or days.+- In mainstream Haskell, developers were traditionally forced to link against foreign C libraries (`libpcre` / `libpcre2`) via FFI bindings, compromising memory safety, complicating static linking and cross-compilation, and inviting segmentation faults on unbounded recursion.+- **Smirk** smirks at both traps: by executing bytecode over an explicit, heap-allocated Pike-style backtracking state machine under a strict **Fuel / Step Budget**, Smirk guarantees that execution never locks a runtime thread, never overflows the C call stack, and can pause, yield an intact continuation, and resume on demand.++---++## Core Motivation & Architecture++### The Problem with C FFI and Unbounded Backtracking++1. **Foreign Function Interface (FFI) Vulnerabilities:** Traditional Haskell bindings to C PCRE libraries introduce native build dependencies, cross-compilation obstacles, and potential memory leaks across C string marshalling boundaries.+2. **Catastrophic Backtracking (ReDoS):** When processing untrusted user input (e.g. web forms, query filters, search strings), standard regex engines can enter exponential search loops that freeze application threads.+3. **Container Inflexibility:** Most regex libraries force data into strict `ByteString` or `Text`, forcing expensive allocations when scanning `[Char]`, finger-tree `Seq Char`, or `Vector Char`.+4. **Effect Monolithic Coupling:** Extensible effect users often find regex libraries tightly coupled to a single effect framework, pulling in heavy dependencies.++### The Smirk Solution++`smirk` resolves these challenges through five architectural pillars:++1. **100% Pure Haskell Pike Virtual Machine:** Patterns are compiled into linear bytecode vectors (`Opcode`), evaluated by a step-stepped virtual machine with an explicit heap-allocated backtracking stack.+2. **Fuel-Bounded Execution & ReDoS Defense:** Every instruction execution consumes 1 unit of `Fuel` (`StepBudget !Int`). If the budget is exhausted, the engine yields `OutOfFuel` along with a `MatchContinuation`.+3. **Pausable & Resumable Continuations:** Match evaluations can be paused, inspected, serialized, and resumed via `resumeMatch` with an replenished fuel budget.+4. **Sequence Polymorphism:** Through the `RegexTarget` abstraction, matching operates zero-copy across `Text`, `ByteString`, `[Char]`, `Seq Char`, and `Vector Char`.+5. **Decoupled 3-Package Architecture:** The core engine is completely independent of effect libraries; dedicated packages provide zero-overhead bindings for `effectful` and `polysemy`.++---++## Multi-Package Catalog++The repository is structured into four independent, modular Cabal packages:++| Package | Directory | Description | Hackage Status |+| :--- | :--- | :--- | :--- |+| **`smirk`** | [`./`](.) | Core engine: Megaparsec PCRE parser, AST, bytecode compiler, Pike VM, sequence polymorphism, glob engine, and QuasiQuoters (`[re|...|]`, `[ed|...|]`, `[glob|...|]`). Zero effect dependencies. | Ready (0.1.0.0) |+| **`smirk-effectful`** | [`../smirk-effectful/`](../smirk-effectful/) | First-class algebraic effect (`RegexEngine`) for the `effectful` ecosystem, featuring pure and fuel-bounded interpreters. Depends only on `smirk` and `effectful`. | Ready (0.1.0.0) |+| **`smirk-polysemy`** | [`../smirk-polysemy/`](../smirk-polysemy/) | Extensible effect (`RegexEngine`) for the `polysemy` ecosystem, featuring pure and fuel-bounded interpreters. Depends only on `smirk` and `polysemy`. | Ready (0.1.0.0) |+| **`smirk-penelope`** | [`../smirk-penelope/`](../smirk-penelope/) | Algebraic effect façade (`RegexEngine`) for the `penelope` effect system, featuring zero-cost vector-dispatched interpreters over flat Polytropos row vectors. | Ready (0.1.0.0) |++---++## Key Subsystems & Worked Examples++### 1. Basic PCRE Matching & Capture Groups++```haskell+{-# LANGUAGE OverloadedStrings #-}++import Smirk++main :: IO ()+main = do+ case compileRegex "(?<protocol>https?)://(?<domain>[a-z.]+)" of+ Left err -> putStrLn ("Compile error: " ++ show err)+ Right reg -> do+ case execMatch reg ("Visit https://haskell.org today!" :: Text) of+ Nothing -> putStrLn "No match found"+ Just res -> do+ print (matchedSlice res) -- "https://haskell.org"+ print (matchOffset res, matchLength res) -- (6, 19)+ print (namedGroups res) -- fromList [("domain","haskell.org"),("protocol","https")]+```++### 2. Compile-Time QuasiQuoters (`[re|...|]` & `[ed|...|]`)++QuasiQuoters validate regex syntax and stream editor templates at compile time:++```haskell+{-# LANGUAGE QuasiQuotes #-}++import Smirk++-- 1. Compile-time verified pattern:+let pattern = [re|\b[A-Za-z0-9._%+-]+@[A-Za-z0-9.-]+\.[A-Z|a-z]{2,}\b|]++-- 2. Stream editor find-and-replace:+let editor = [ed|foo([0-9]+)///bar${1}|]+let replaced = applyEditor editor "foo42 and foo99"+-- replaced == "bar42 and bar99"+```++### 3. Step-Bounded Execution & ReDoS Defense++Defend against pathological catastrophic backtracking patterns by enforcing a step budget:++```haskell+import Smirk++let pathological = compileRegex "(a+)+$"+let target = "aaaaaaaaaaaaaaaaaaaaaaaaaaaa!" :: Text++case pathological of+ Right reg ->+ -- Restrict execution to at most 10,000 VM instruction steps:+ case execMatchWithFuel reg target (StepBudget 10000) of+ Matched _ -> putStrLn "Matched"+ NoMatch -> putStrLn "Did not match"+ OutOfFuel cont -> do+ putStrLn "ReDoS detected! Step budget exceeded without locking CPU."+ -- Optionally resume later with additional fuel:+ case resumeMatch cont (StepBudget 5000) of+ OutOfFuel _ -> putStrLn "Still out of fuel; safely aborting."+ _ -> putStrLn "Finished."+```++### 4. Sequence Polymorphism across Haskell Containers++Match uniformly across different sequence representations without converting to `Text`:++```haskell+import qualified Data.ByteString.Char8 as BS+import qualified Data.Sequence as Seq+import qualified Data.Vector as V+import Smirk++let reg = [re|[0-9]+|]++-- Strict ByteString:+testMatch reg (BS.pack "port 8080") -- True++-- Standard String ([Char]):+testMatch reg "port 8080" -- True++-- Data.Sequence.Seq Char:+testMatch reg (Seq.fromList "port 8080") -- True++-- Data.Vector.Vector Char:+testMatch reg (V.fromList "port 8080") -- True+```++### 5. Effectful Integration (`smirk-effectful`)++```haskell+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeApplications #-}++import Effectful+import Smirk (re)+import Smirk.Effect.Effectful++lookupPort :: (RegexEngine :> es) => Text -> Eff es (Maybe Text)+lookupPort input = do+ mMatch <- matchRegex [re|port:([0-9]+)|] input+ pure (fmap matchedSlice mMatch)+```++### 6. Polysemy Integration (`smirk-polysemy`)++```haskell+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeApplications #-}++import Polysemy+import Smirk (re)+import Smirk.Effect.Polysemy++lookupPort :: (Member RegexEngine r) => Text -> Sem r (Maybe Text)+lookupPort input = do+ mMatch <- matchRegex [re|port:([0-9]+)|] input+ pure (fmap matchedSlice mMatch)+```++### 7. Native Filesystem Globbing (`[glob|...|]`)++```haskell+{-# LANGUAGE QuasiQuotes #-}++import Smirk++let g = [glob|src/**/*.{hs,lhs}|]+matchGlob g "src/Smirk/Core/AST.hs" -- True+matchGlob g "test/Spec.hs" -- False+```++---++## Documentation Corpus & Reading Order++The technical documentation corpus is structured for progressive disclosure:++1. [`docs/INDEX.md`](../../docs/INDEX.md) — Comprehensive corpus inventory, audience reading paths, and package catalog.+2. [`docs/TUTORIAL.md`](../../docs/TUTORIAL.md) — Detailed hands-on tutorial with worked examples across all 7 subsystems.+3. [`docs/NEWBIE_GUIDE.md`](../../docs/NEWBIE_GUIDE.md) — Fast symbol navigation table and 15-minute quickstart.+4. [`docs/MAINTAINER_GUIDE.md`](../../docs/MAINTAINER_GUIDE.md) — Architectural invariants (I1–I8), verification gates, and triage runbooks.+5. [`docs/notes/SMIRK_DESIGN.md`](../../docs/notes/SMIRK_DESIGN.md) — Canonical design monograph detailing decisions D1–D10.+6. [`docs/notes/DOC_STRATEGY.md`](../../docs/notes/DOC_STRATEGY.md) — Documentation strategy, precedence rule, and lifecycle.+7. [`docs/notes/COMMIT_ATTRIBUTION.md`](../../docs/notes/COMMIT_ATTRIBUTION.md) — Linux kernel RFC 2822 trailer format standards.+8. [`AGENTS.md`](../../AGENTS.md) — Advisory operational rules and navigation funnels for AI coding assistants.++---++## Physical Verification Discipline++Before any commit or release, all 5 physical verification gates must pass cleanly:++```bash+./bin/smirk-verify+```++1. **Gate 1: HLint Static Analysis:** Zero hints allowed across all source packages (`.hlint.yaml`).+2. **Gate 2: Full Cabal Test Suite:** All test suites pass across all packages (`cabal test all`).+3. **Gate 3: Tagref Cross-Reference Gate:** Zero dangling references and zero duplicate tags (`bin/smirk-tagref`).+4. **Gate 4: Markdown Link Integrity Gate:** Every relative link and heading anchor resolves (`bin/smirk-linkcheck`).+5. **Gate 5: CLOC Comment Density Gate:** Comment density satisfies documentation thresholds (`bin/smirk-cloc`).++---++## License & Attribution++- Licensed under the **Apache License 2.0** (`LICENSE`).+- Copyright (c) 2026 Nadia Yvette Chambers.+- AI assistant contributions follow the RFC 2822 trailer format (`Assisted-by:`). See [`docs/notes/COMMIT_ATTRIBUTION.md`](../../docs/notes/COMMIT_ATTRIBUTION.md).
+ smirk.cabal view
@@ -0,0 +1,99 @@+cabal-version: 3.0+name: smirk+version: 0.1.0.0+synopsis: Pure, effectful, resumable, step-budgeted PCRE interpreter for Haskell+description:+ Smirk (;-P / ;-) is a pure, native Haskell PCRE regular expression engine+ featuring step-bounded execution (ReDoS defense), pausable/resumable matching,+ dual algebraic effect interpreters (effectful & polysemy), and mono-traversable+ sequence polymorphism (Text, ByteString, Seq, Vector, NonEmpty).+license: Apache-2.0+license-file: LICENSE+author: Nadia Yvette Chambers+maintainer: Nadia Chambers <nadia.yvette.chambers@ik.me>+homepage: https://github.com/NadiaYvette/smirk+bug-reports: https://github.com/NadiaYvette/smirk/issues+category: Text, Regex, Effects+build-type: Simple+extra-doc-files:+ README.md+ , CHANGELOG.md+ , LICENSE++source-repository head+ type: git+ location: https://github.com/NadiaYvette/smirk.git+ subdir: packages/smirk++common common-options+ default-language: GHC2021+ default-extensions:+ DataKinds+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ DuplicateRecordFields+ GADTs+ GeneralizedNewtypeDeriving+ LambdaCase+ MultiParamTypeClasses+ OverloadedRecordDot+ OverloadedStrings+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ ghc-options:+ -Wall+ -Wcompat+ -Widentities+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wpartial-fields+ -Wredundant-constraints++library+ import: common-options+ hs-source-dirs: src+ exposed-modules:+ Smirk+ Smirk.Core.AST+ Smirk.Core.Parser+ Smirk.Core.Bytecode+ Smirk.Core.Compiler+ Smirk.Core.Quote+ Smirk.Engine.Sequence+ Smirk.Engine.VM+ Smirk.Glob+ build-depends:+ base >= 4.16 && < 5,+ containers >= 0.6 && < 1,+ bytestring >= 0.11 && < 1,+ megaparsec >= 9.0 && < 10,+ mono-traversable >= 1.0 && < 2,+ parser-combinators >= 1.3 && < 2,+ template-haskell >= 2.18 && < 3,+ text >= 2.0 && < 3,+ vector >= 0.12 && < 1++test-suite smirk-test+ import: common-options+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules:+ ParserSpec+ VMSpec+ SequenceSpec+ QuoteSpec+ GlobSpec+ build-depends:+ base >= 4.16 && < 5,+ bytestring >= 0.11 && < 1,+ containers >= 0.6 && < 1,+ hspec >= 2.10 && < 3,+ smirk,+ text >= 2.0 && < 3,+ vector >= 0.12 && < 1
+ src/Smirk.hs view
@@ -0,0 +1,115 @@+{- |+Module : Smirk+Description : Pure, effectful, resumable, step-budgeted PCRE interpreter for Haskell+Copyright : (c) Nadia Yvette Chambers, 2026+License : Apache-2.0++@Smirk@ (;-P / ;-) is a pure, native Haskell PCRE regular expression engine+featuring step-bounded execution (ReDoS defense), pausable/resumable matching,+and @mono-traversable@ sequence polymorphism.++=== Key Architectural Pillars++1. __Step-Bounded Execution & ReDoS Defense:__ Every pattern evaluation can be+ constrained by a discrete 'Fuel' step budget ('StepBudget' or 'Unlimited'). If thread+ state evaluations exceed the threshold, evaluation halts safely and yields+ 'OutOfFuel' along with a resumable 't:MatchContinuation'.++2. __Sequence Polymorphism:__ Pattern matching operates uniformly across any+ data type implementing 'RegexTarget', including strict 'Text', @ByteString@,+ 'String', @Seq Char@, and @Vector Char@.++3. __Compile-Time QuasiQuoters:__ Static pattern validation via @[re|...|]@,+ stream editor substitution via @[ed|s/find/replace/g|]@, and shell/glob+ matching via @[glob|...|]@.++4. __Modular Effect Handlers:__ Algebraic effect bindings for @effectful@+ (@smirk-effectful@), @polysemy@ (@smirk-polysemy@), and @penelope@ (@smirk-penelope@).+-}+module Smirk+ ( -- * Core Types & API+ Regex (..)+ , compileRegex+ , compileRegexWithFlags+ , Flags (..)+ , defaultFlags+ , testMatch+ , execMatch+ , execMatchWithFuel++ -- * Glob Matching+ , compileGlob+ , compileGlobWithOptions+ , compileWildcard+ , GlobOptions (..)+ , defaultGlobOptions+ , wildcardGlobOptions+ , matchGlob++ -- * QuasiQuoters & Editors+ , re+ , ed+ , glob+ , Editor (..)+ , applyEditor++ -- * AST & Compiler+ , AST (..)+ , Opcode (..)+ , Program+ , parsePCRE+ , parsePCREWithFlags+ , compileAST+ , compileToRegex++ -- * Execution & VM+ , RegexTarget (..)+ , Fuel (..)+ , MatchResult (..)+ , MatchStatus (..)+ , MatchContinuation (..)+ , runMatch+ , runMatchAt+ , resumeMatch+ , findAllMatches+ ) where++import Data.Text (Text)++import Smirk.Core.AST+import Smirk.Core.Bytecode+import Smirk.Core.Compiler+import Smirk.Core.Parser+import Smirk.Core.Quote+import Smirk.Engine.Sequence+import Smirk.Engine.VM+import Smirk.Glob++-- | Compile a PCRE regular expression string into a runnable 't:Regex'.+-- Returns a parse error description as 'Left' on failure.+compileRegex :: Text -> Either Text Regex+compileRegex = compileRegexWithFlags defaultFlags++-- | Compile a PCRE regular expression string with explicit compilation 't:Flags'.+compileRegexWithFlags :: Flags -> Text -> Either Text Regex+compileRegexWithFlags flags input = do+ ast <- parsePCREWithFlags flags input+ pure (compileToRegex input ast)++-- | Test if a target sequence matches a regular expression.+-- Returns 'True' if a match is found anywhere in the target sequence.+testMatch :: RegexTarget s => Regex -> s -> Bool+testMatch reg target = case runMatch reg target Unlimited of+ Matched _ -> True+ _ -> False++-- | Execute regex search returning the first 't:MatchResult', if any.+execMatch :: RegexTarget s => Regex -> s -> Maybe (MatchResult s)+execMatch reg target = case runMatch reg target Unlimited of+ Matched res -> Just res+ _ -> Nothing++-- | Execute regex search bounded by a specific step budget.+-- Returns 'OutOfFuel' with a continuation if the step threshold is exceeded.+execMatchWithFuel :: RegexTarget s => Regex -> s -> Fuel -> MatchStatus s+execMatchWithFuel = runMatch
+ src/Smirk/Core/AST.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE DeriveGeneric #-}++{- |+Module : Smirk.Core.AST+Description : Abstract Syntax Tree representation of PCRE regular expressions+Copyright : (c) Nadia Yvette Chambers, 2026+License : Apache-2.0++Defines the typed Abstract Syntax Tree (AST) for PCRE regular expressions,+supporting literals, character classes, anchors, sequences, alternations,+bounded repetitions with greediness controls, named/numbered capture groups,+and lookaround assertions.+-}+module Smirk.Core.AST+ ( AST (..)+ , CharClass (..)+ , CharRange (..)+ , Anchor (..)+ , RepKind (..)+ , LookDir (..)+ , Flags (..)+ , defaultFlags+ ) where++import Data.Text (Text)+import GHC.Generics (Generic)++-- | Regex compilation and matching flags controlling parser and VM semantics.+data Flags = Flags+ { caseInsensitive :: !Bool -- ^ (?i) Case-insensitive character matching+ , dotAll :: !Bool -- ^ (?s) Dot matches newline characters as well+ , multiline :: !Bool -- ^ (?m) ^ and $ match at beginning and end of each line+ } deriving (Eq, Show, Generic)++-- | Default flags (standard PCRE mode: case-sensitive, no dotAll, no multiline).+defaultFlags :: Flags+defaultFlags = Flags+ { caseInsensitive = False+ , dotAll = False+ , multiline = False+ }++-- | Character range within a character set ([a-z], [0-9]).+data CharRange+ = RangeSingle !Char -- ^ Single character: @a@+ | RangeBetween !Char !Char -- ^ Inclusive character range: @a@ to @z@+ deriving (Eq, Show, Generic)++-- | Character classes and custom character sets.+data CharClass+ = ClassAny -- ^ @.@ (any character, subject to dotAll)+ | ClassDigit -- ^ @\\d@ (ASCII or Unicode decimal digit)+ | ClassNotDigit -- ^ @\\D@ (any character that is not a digit)+ | ClassWord -- ^ @\\w@ (word character: alphanumeric plus underscore)+ | ClassNotWord -- ^ @\\W@ (non-word character)+ | ClassSpace -- ^ @\\s@ (whitespace character)+ | ClassNotSpace -- ^ @\\S@ (non-whitespace character)+ | ClassSet ![CharRange] !Bool -- ^ @[a-z0-9]@ or negated @[^a-z]@ (negated when True)+ deriving (Eq, Show, Generic)++-- | Position and boundary assertions that do not consume characters.+data Anchor+ = AnchorStart -- ^ @^@ (start of input or start of line in multiline mode)+ | AnchorEnd -- ^ @$@ (end of input or end of line in multiline mode)+ | AnchorWordBoundary -- ^ @\\b@ (word boundary transition)+ | AnchorNotWordBoundary -- ^ @\\B@ (non-word boundary transition)+ deriving (Eq, Show, Generic)++-- | Repetition greediness and backtracking strategy.+data RepKind+ = RepGreedy -- ^ Standard greedy repetition (match as much as possible)+ | RepLazy -- ^ Non-greedy / reluctant repetition (match as little as possible)+ | RepPossessive -- ^ Possessive repetition (do not backtrack over matched elements)+ deriving (Eq, Show, Generic)++-- | Lookaround assertion direction.+data LookDir+ = Lookahead -- ^ Lookahead assertion: inspecting suffix after current position+ | Lookbehind -- ^ Lookbehind assertion: inspecting prefix before current position+ deriving (Eq, Show, Generic)++-- | Typed PCRE Abstract Syntax Tree nodes.+data AST+ = Lit !Char -- ^ Exact literal character match+ | Class !CharClass -- ^ Character class or set match+ | AnchorAssert !Anchor -- ^ Zero-width boundary anchor assertion+ | Seq ![AST] -- ^ Sequential concatenation of sub-expressions+ | Alt ![AST] -- ^ Ordered alternation between sub-expressions+ | Repeat !Int !(Maybe Int) !RepKind !AST -- ^ Repetition with min count, optional max count, greediness kind, and child AST+ | Group !(Maybe Text) !(Maybe Int) !AST -- ^ Capturing group with optional name, 1-based index, and inner AST+ | NonCapturing !AST -- ^ Non-capturing group: @(?:...)@+ | Lookaround !LookDir !Bool !AST -- ^ Zero-width lookaround assertion: direction, positive/negative, and inner AST+ | BackRef !Int -- ^ Numbered backreference: @\\1@+ | NamedBackRef !Text -- ^ Named backreference: @\\k<name>@+ | Empty -- ^ Empty / epsilon AST node+ deriving (Eq, Show, Generic)
+ src/Smirk/Core/Bytecode.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DeriveGeneric #-}++{- |+Module : Smirk.Core.Bytecode+Description : Virtual machine bytecode instruction set and compiled program structures+Copyright : (c) Nadia Yvette Chambers, 2026+License : Apache-2.0++Defines the low-level virtual machine bytecode instruction set ('Opcode')+used by the Pike-style non-backtracking / thread-stepped VM in 'Smirk.Engine.VM'.+Includes relative jumping, nondeterministic thread branching ('OpSplit'),+capture slot registers ('OpSaveStart', 'OpSaveEnd'), and lookaround subprograms.+-}+module Smirk.Core.Bytecode+ ( Opcode (..)+ , Program+ , Regex (..)+ ) where++import Data.Map.Strict (Map)+import Data.Text (Text)+import Data.Vector (Vector)+import GHC.Generics (Generic)++import Smirk.Core.AST (Anchor, CharClass)++-- | Low-level bytecode instruction for the Smirk regex virtual machine.+data Opcode+ = OpChar !Char -- ^ Match a single literal character+ | OpClass !CharClass -- ^ Match a character class or set+ | OpAnchor !Anchor -- ^ Assert a zero-width anchor condition+ | OpSplit !Int !Int -- ^ Fork execution: try relative offset 1, alternative at offset 2+ | OpJump !Int -- ^ Unconditional relative jump by specified offset+ | OpSaveStart !Int -- ^ Save current input position as start of capture group $n$+ | OpSaveEnd !Int -- ^ Save current input position as end of capture group $n$+ | OpAssertLookahead !(Vector Opcode) !Bool -- ^ Zero-width lookahead assertion: subprogram and polarity+ | OpAssertLookbehind !(Vector Opcode) !Bool -- ^ Zero-width lookbehind assertion: subprogram and polarity+ | OpMatchBackRef !Int -- ^ Match dynamic slice previously captured by group $n$+ | OpMatch -- ^ Successful match reached; terminate thread+ deriving (Eq, Show, Generic)++-- | Compiled bytecode sequence indexed as a contiguous vector.+type Program = Vector Opcode++-- | Complete compiled regular expression ready for VM execution.+data Regex = Regex+ { originalPattern :: !Text -- ^ Original PCRE source pattern string+ , program :: !Program -- ^ Compiled bytecode instruction vector+ , groupNames :: !(Map Text Int) -- ^ Mapping from named capture groups to 1-based indices+ , maxGroupIndex :: !Int -- ^ Highest capture group index allocated in the pattern+ } deriving (Eq, Show, Generic)
+ src/Smirk/Core/Compiler.hs view
@@ -0,0 +1,150 @@+{- |+Module : Smirk.Core.Compiler+Description : AST to Bytecode compilation with jump resolution and capture group indexing+Copyright : (c) Nadia Yvette Chambers, 2026+License : Apache-2.0++Compiles the high-level PCRE 'AST' into a flat vector of bytecode instructions+('Opcode') ready for execution by the Pike VM. Resolves relative jump offsets,+generates nondeterministic thread branches for repetitions and alternations,+and assigns sequential 1-based indices to named and unnamed capture groups.+-}+module Smirk.Core.Compiler+ ( compileAST+ , compileToRegex+ , assignGroupIndices+ ) where++import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import Data.Text (Text)+import qualified Data.Vector as V++import Smirk.Core.AST+import Smirk.Core.Bytecode++-- | Compile an AST into a high-level 't:Regex' record ready for execution.+-- Wraps the program in top-level capture group 0 (@OpSaveStart 0@ / @OpSaveEnd 0@)+-- and terminates with @OpMatch@.+compileToRegex :: Text -> AST -> Regex+compileToRegex patternStr rawAST =+ let (numberedAST, groupMap, maxIdx) = assignGroupIndices rawAST+ progOps = OpSaveStart 0 : compileAST numberedAST ++ [OpSaveEnd 0, OpMatch]+ in Regex+ { originalPattern = patternStr+ , program = V.fromList progOps+ , groupNames = groupMap+ , maxGroupIndex = maxIdx+ }++-- | Sequentially assign 1-based capture group indices in left-to-right order.+-- Returns the modified AST with assigned group indices, the name-to-index map,+-- and the maximum allocated index.+assignGroupIndices :: AST -> (AST, Map Text Int, Int)+assignGroupIndices rootAST =+ let (ast', (finalIdx, groupMap)) = go rootAST (1, Map.empty)+ in (ast', groupMap, finalIdx - 1)+ where+ go :: AST -> (Int, Map Text Int) -> (AST, (Int, Map Text Int))+ go ast (nextIdx, m) = case ast of+ Group mName _ inner ->+ let thisIdx = nextIdx+ m' = case mName of+ Just n -> Map.insert n thisIdx m+ Nothing -> m+ (inner', st') = go inner (thisIdx + 1, m')+ in (Group mName (Just thisIdx) inner', st')+ Seq items ->+ let (items', st') = foldr (\item (accItems, accSt) ->+ let (item', accSt') = go item accSt+ in (item' : accItems, accSt')+ ) ([], (nextIdx, m)) (reverse items)+ in (Seq (reverse items'), st')+ Alt branches ->+ let (branches', st') = foldr (\b (accB, accSt) ->+ let (b', accSt') = go b accSt+ in (b' : accB, accSt')+ ) ([], (nextIdx, m)) (reverse branches)+ in (Alt (reverse branches'), st')+ Repeat minN mMax kind inner ->+ let (inner', st') = go inner (nextIdx, m)+ in (Repeat minN mMax kind inner', st')+ NonCapturing inner ->+ let (inner', st') = go inner (nextIdx, m)+ in (NonCapturing inner', st')+ Lookaround dir isPos inner ->+ let (inner', st') = go inner (nextIdx, m)+ in (Lookaround dir isPos inner', st')+ other -> (other, (nextIdx, m))++-- | Compile an AST node to a flat list of opcodes with relative jump resolution.+compileAST :: AST -> [Opcode]+compileAST = \case+ Empty -> []+ Lit c -> [OpChar c]+ Class cls -> [OpClass cls]+ AnchorAssert a -> [OpAnchor a]+ Seq items -> concatMap compileAST items+ Alt branches -> compileAlt branches+ Repeat minN mMax kind inner -> compileRepeat minN mMax kind inner+ Group _ (Just idx) inner -> OpSaveStart idx : compileAST inner ++ [OpSaveEnd idx]+ Group _ Nothing inner -> compileAST inner+ NonCapturing inner -> compileAST inner+ Lookaround Lookahead isPos inner ->+ let subProg = V.fromList (compileAST inner ++ [OpMatch])+ in [OpAssertLookahead subProg isPos]+ Lookaround Lookbehind isPos inner ->+ let subProg = V.fromList (compileAST inner ++ [OpMatch])+ in [OpAssertLookbehind subProg isPos]+ BackRef idx -> [OpMatchBackRef idx]+ NamedBackRef _ -> []++compileAlt :: [AST] -> [Opcode]+compileAlt [] = []+compileAlt [singleBranch] = compileAST singleBranch+compileAlt (b1 : bs) =+ let code1 = compileAST b1+ code2 = compileAlt bs+ len1 = length code1+ len2 = length code2+ splitOp = OpSplit 1 (1 + len1 + 1)+ jumpToEnd = OpJump (len2 + 1)+ in splitOp : code1 ++ jumpToEnd : code2++compileRepeat :: Int -> Maybe Int -> RepKind -> AST -> [Opcode]+compileRepeat 0 (Just 1) RepGreedy inner =+ let body = compileAST inner+ len = length body+ in OpSplit 1 (len + 1) : body+compileRepeat 0 (Just 1) RepLazy inner =+ let body = compileAST inner+ len = length body+ in OpSplit (len + 1) 1 : body+compileRepeat 0 Nothing RepGreedy inner =+ let body = compileAST inner+ len = length body+ loop = OpSplit 1 (len + 2) : body ++ [OpJump (- (len + 1))]+ in loop+compileRepeat 0 Nothing RepLazy inner =+ let body = compileAST inner+ len = length body+ loop = OpSplit (len + 2) 1 : body ++ [OpJump (- (len + 1))]+ in loop+compileRepeat 1 Nothing RepGreedy inner =+ let body = compileAST inner+ len = length body+ in body ++ [OpSplit (- len) 1]+compileRepeat 1 Nothing RepLazy inner =+ let body = compileAST inner+ len = length body+ in body ++ [OpSplit 1 (- len)]+compileRepeat minN mMax kind inner =+ let exact = concat (replicate minN (compileAST inner))+ extra = case mMax of+ Nothing -> compileRepeat 0 Nothing kind inner+ Just maxN | maxN > minN ->+ let remN = maxN - minN+ single = compileRepeat 0 (Just 1) kind inner+ in concat (replicate remN single)+ _ -> []+ in exact ++ extra
+ src/Smirk/Core/Parser.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : Smirk.Core.Parser+Description : Recursive descent PCRE parser based on Megaparsec+Copyright : (c) Nadia Yvette Chambers, 2026+License : Apache-2.0++Implements a standard recursive descent parser for Perl-Compatible Regular+Expressions (PCRE) using Megaparsec.++=== Operator Precedence Hierarchy++1. __Alternation ('pAlternation'):__ Lowest precedence; separated by @|@.+2. __Concatenation ('pSequence'):__ Sequential concatenation of terms.+3. __Repetition ('pRepeatItem'):__ Suffix quantifiers: @*@, @+@, @?@, @{m,n}@,+ with optional greediness modifiers (@?@ for lazy, @+@ for possessive).+4. __Atoms ('pAtom'):__ Groups, character classes, anchors, backreferences,+ escaped characters, and character literals.+-}+module Smirk.Core.Parser+ ( -- * High-Level Parsing API+ parsePCRE+ , parsePCREWithFlags+ , ParserError++ -- * Grammar Combinators+ , Parser+ , pRegex+ , pAlternation+ , pSequence+ , pRepeatItem+ , pRepetition+ , pAtom+ , pGroup+ , pNamedGroup+ , pClassSet+ , pRangeItem+ , pBackRef+ , pEscaped+ , pLiteral+ ) where++import Control.Monad (void)+import Data.Char (isDigit)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Void (Void)+import Text.Megaparsec+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L++import Smirk.Core.AST++-- | Megaparsec parser type over strict Text with Void error components.+type Parser = Parsec Void Text++-- | Pretty-printable Megaparsec error bundle type.+type ParserError = ParseErrorBundle Text Void++-- | Parse a PCRE regular expression string using default compilation flags.+-- Returns 'Right' 'AST' on success, or 'Left' errorMessage on failure.+parsePCRE :: Text -> Either Text AST+parsePCRE = parsePCREWithFlags defaultFlags++-- | Parse a PCRE regular expression string with explicit initial flags.+parsePCREWithFlags :: Flags -> Text -> Either Text AST+parsePCREWithFlags initFlags input =+ case runParser (pRegex initFlags) "pcre" input of+ Left err -> Left (T.pack $ errorBundlePretty err)+ Right ast -> Right ast++-- | Top-level regular expression parser consuming to end-of-input.+pRegex :: Flags -> Parser AST+pRegex _initFlags = do+ res <- pAlternation+ eof+ pure res++-- | Parse an alternation branch (@branch1 | branch2 | ...@).+pAlternation :: Parser AST+pAlternation = do+ branches <- sepBy1 pSequence (char '|')+ pure $ case branches of+ [singleBranch] -> singleBranch+ multiple -> Alt multiple++-- | Parse a sequence of concatenated items (@item1 item2 ...@).+pSequence :: Parser AST+pSequence = do+ items <- many pRepeatItem+ pure $ case items of+ [] -> Empty+ [singleItem] -> singleItem+ multiple -> Seq multiple++-- | Parse an atom with an optional repetition suffix.+pRepeatItem :: Parser AST+pRepeatItem = do+ atom <- pAtom+ mRep <- optional pRepetition+ pure $ case mRep of+ Nothing -> atom+ Just (minN, maxN, kind) -> Repeat minN maxN kind atom++-- | Parse repetition quantifiers: @*@, @+@, @?@, or range @{min,max}@,+-- accompanied by an optional greediness modifier (@?@ for lazy, @+@ for possessive).+pRepetition :: Parser (Int, Maybe Int, RepKind)+pRepetition = do+ (minN, maxN) <- pRepRange+ kind <- pRepModifier+ pure (minN, maxN, kind)+ where+ -- Basic repetition range+ pRepRange =+ (char '*' >> pure (0, Nothing))+ <|> (char '+' >> pure (1, Nothing))+ <|> (char '?' >> pure (0, Just 1))+ <|> pBraceRep++ -- Bounded repetition syntax: {n}, {n,}, or {n,m}+ pBraceRep = between (char '{') (char '}') $ do+ n <- L.decimal+ mComma <- optional (char ',')+ case mComma of+ Nothing -> pure (n, Just n)+ Just _ -> do+ mMax <- optional L.decimal+ pure (n, mMax)++ -- Greediness modifier: default is greedy, '?' is lazy, '+' is possessive+ pRepModifier =+ (char '?' >> pure RepLazy)+ <|> (char '+' >> pure RepPossessive)+ <|> pure RepGreedy++-- | Parse an atomic expression: group, class set, dot, anchor, backreference, or literal.+pAtom :: Parser AST+pAtom =+ pGroup+ <|> pClassSet+ <|> pDot+ <|> pAnchor+ <|> pBackRef+ <|> pEscaped+ <|> pLiteral++-- | Parse @.@ matching any character (subject to dotAll flag).+pDot :: Parser AST+pDot = char '.' >> pure (Class ClassAny)++-- | Parse zero-width position anchors: @^@, @$@, @\\b@, @\\B@.+pAnchor :: Parser AST+pAnchor =+ (char '^' >> pure (AnchorAssert AnchorStart))+ <|> (char '$' >> pure (AnchorAssert AnchorEnd))+ <|> (string "\\b" >> pure (AnchorAssert AnchorWordBoundary))+ <|> (string "\\B" >> pure (AnchorAssert AnchorNotWordBoundary))++-- | Parse parenthesized group constructs, handling both capturing and non-capturing/lookaround variants.+pGroup :: Parser AST+pGroup = between (char '(') (char ')') $ do+ mSpecial <- optional (char '?')+ case mSpecial of+ Nothing -> Group Nothing Nothing <$> pAlternation+ Just _ ->+ (string ":" >> (NonCapturing <$> pAlternation))+ <|> (string "=" >> (Lookaround Lookahead True <$> pAlternation))+ <|> (string "!" >> (Lookaround Lookahead False <$> pAlternation))+ <|> (string "<=" >> (Lookaround Lookbehind True <$> pAlternation))+ <|> (string "<!" >> (Lookaround Lookbehind False <$> pAlternation))+ <|> pNamedGroup++-- | Parse a named capture group: @(?<name>pattern)@.+pNamedGroup :: Parser AST+pNamedGroup = do+ void (char '<')+ name <- takeWhile1P (Just "group name") (/= '>')+ void (char '>')+ Group (Just name) Nothing <$> pAlternation++-- | Parse a bracketed character set: @[abc]@, @[a-z0-9]@, or negated @[^a-z]@.+pClassSet :: Parser AST+pClassSet = between (char '[') (char ']') $ do+ negated <- (char '^' >> pure True) <|> pure False+ ranges <- many pRangeItem+ pure $ Class (ClassSet ranges negated)++-- | Parse a character range within a set: either @a-z@ or a single character @a@.+pRangeItem :: Parser CharRange+pRangeItem = try pBetweenRange <|> pSingleChar+ where+ pBetweenRange = do+ startC <- noneOf [']', '-']+ void (char '-')+ endC <- noneOf [']']+ pure $ RangeBetween startC endC+ pSingleChar = RangeSingle <$> noneOf [']']++-- | Parse a numbered backreference: @\\1@, @\\2@, etc.+pBackRef :: Parser AST+pBackRef = try $ do+ void (char '\\')+ d <- satisfy isDigit+ pure $ BackRef (read [d])++-- | Parse an escape sequence: character classes (\d, \w, \s) or control characters (\n, \t, \r).+pEscaped :: Parser AST+pEscaped = do+ void (char '\\')+ c <- anySingle+ pure $ case c of+ 'd' -> Class ClassDigit+ 'D' -> Class ClassNotDigit+ 'w' -> Class ClassWord+ 'W' -> Class ClassNotWord+ 's' -> Class ClassSpace+ 'S' -> Class ClassNotSpace+ 'n' -> Lit '\n'+ 'r' -> Lit '\r'+ 't' -> Lit '\t'+ other -> Lit other++-- | Parse a plain literal character, disallowing special PCRE metacharacters.+pLiteral :: Parser AST+pLiteral = Lit <$> noneOf ("^$\\.*+?()[]{}|" :: String)
+ src/Smirk/Core/Quote.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++{- |+Module : Smirk.Core.Quote+Description : Compile-time QuasiQuoters for PCRE expressions and search-and-replace editors+Copyright : (c) Nadia Yvette Chambers, 2026+License : Apache-2.0++Provides Template Haskell QuasiQuoters that validate regular expressions and+stream-editor replacement templates at compile time, eliminating runtime parse+failures and overhead.++=== Available QuasiQuoters++* '[re|...|]': Compile-time validated PCRE regular expressions.+* '[ed|search///replace|]': Compile-time validated sed-style stream editor.+-}+module Smirk.Core.Quote+ ( -- * QuasiQuoters+ re+ , ed++ -- * Editor Definition & Application+ , Editor (..)+ , applyEditor+ , replaceMatch+ ) where++import Data.Char (isDigit)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Language.Haskell.TH+import Language.Haskell.TH.Quote++import Smirk.Core.Bytecode (Regex)+import Smirk.Core.Compiler (compileToRegex)+import Smirk.Core.Parser (parsePCRE)+import Smirk.Engine.Sequence (RegexTarget (..))+import Smirk.Engine.VM (MatchResult (..), findAllMatches)++-- | QuasiQuoter for compile-time verified PCRE regular expressions.+-- Rejects invalid PCRE patterns at compile time with descriptive syntax errors.+--+-- === Example+--+-- @+-- let r = [re|(?<protocol>https?)://(?<domain>[a-z.]+)|]+-- @+re :: QuasiQuoter+re = QuasiQuoter+ { quoteExp = quoteRegexExp+ , quotePat = error "Smirk.re: Pattern matching quasiquote not supported"+ , quoteType = error "Smirk.re: Type quasiquote not supported"+ , quoteDec = error "Smirk.re: Declaration quasiquote not supported"+ }++-- | Compile-time expression quoter for regex patterns.+quoteRegexExp :: String -> Q Exp+quoteRegexExp patternStr =+ case parsePCRE (T.pack patternStr) of+ Left err -> fail ("Smirk regex compile error: " <> T.unpack err)+ Right _ ->+ [| case parsePCRE (T.pack $(stringE patternStr)) of+ Right ast -> compileToRegex (T.pack $(stringE patternStr)) ast+ Left e -> error ("Smirk regex internal error: " <> T.unpack e)+ |]++-- | Structured find-and-replace editor record.+data Editor s = Editor+ { editRegex :: !Regex -- ^ Compiled search regular expression+ , editReplacement :: !Text -- ^ Replacement template string+ , editGlobal :: !Bool -- ^ If True, replace all non-overlapping occurrences; if False, first only+ } deriving (Eq, Show, Generic)++-- | QuasiQuoter for compile-time verified search-and-replace editors using @///@ delimiters.+--+-- Format: @[ed|search_pattern///replacement_string|]@ or @[ed|search///replace///1|]@ (for single replacement).+--+-- === Example+--+-- @+-- let edScript = [ed|foo([0-9]+)///bar${1}|]+-- applyEditor edScript "foo42" == "bar42"+-- @+ed :: QuasiQuoter+ed = QuasiQuoter+ { quoteExp = quoteEditorExp+ , quotePat = error "Smirk.ed: Pattern matching quasiquote not supported"+ , quoteType = error "Smirk.ed: Type quasiquote not supported"+ , quoteDec = error "Smirk.ed: Declaration quasiquote not supported"+ }++-- | Compile-time expression quoter for search-and-replace editor templates.+quoteEditorExp :: String -> Q Exp+quoteEditorExp rawStr =+ case T.splitOn "///" (T.pack rawStr) of+ [searchPat, replaceStr] -> validateAndBuild searchPat replaceStr True+ [searchPat, replaceStr, opts] ->+ let isGlobal = not ("1" `T.isInfixOf` opts)+ in validateAndBuild searchPat replaceStr isGlobal+ _ ->+ fail "Smirk.ed: Expected format [ed|search_pattern///replacement_template|]"+ where+ validateAndBuild searchPat replaceStr isGlobal =+ case parsePCRE searchPat of+ Left err -> fail ("Smirk editor search regex error: " <> T.unpack err)+ Right _ ->+ [| Editor+ { editRegex = case parsePCRE (T.pack $(stringE (T.unpack searchPat))) of+ Right ast -> compileToRegex (T.pack $(stringE (T.unpack searchPat))) ast+ Left e -> error ("Smirk editor search regex error: " <> T.unpack e)+ , editReplacement = T.pack $(stringE (T.unpack replaceStr))+ , editGlobal = $([| isGlobal |])+ }+ |]++-- | Apply an 't:Editor' transformation to a target sequence.+-- Finds matching slices and substitutes them according to the replacement template.+applyEditor :: RegexTarget s => Editor s -> s -> s+applyEditor editor target =+ let matches = findAllMatches editor.editRegex target+ selectedMatches = if editor.editGlobal then matches else take 1 matches+ in if null selectedMatches+ then target+ else+ let pieces = reconstructSlices target 0 selectedMatches editor.editReplacement+ in seqFromText (T.concat pieces)++-- | Reconstruct a sequence by interleaving untouched slices with substituted replacements.+reconstructSlices :: RegexTarget s => s -> Int -> [MatchResult s] -> Text -> [Text]+reconstructSlices target curIdx [] _ =+ let remLen = seqLength target - curIdx+ in [seqToText (seqSlice curIdx remLen target)]+reconstructSlices target curIdx (m : ms) replTemplate =+ let prefixLen = m.matchOffset - curIdx+ prefix = seqToText (seqSlice curIdx prefixLen target)+ replaced = replaceMatch m replTemplate+ nextIdx = m.matchOffset + m.matchLength+ in prefix : replaced : reconstructSlices target nextIdx ms replTemplate++-- | Expand capture group variables (${1}, ${name}, \1, $0, $&) in a replacement template.+replaceMatch :: RegexTarget s => MatchResult s -> Text -> Text+replaceMatch res = go+ where+ go txt+ | T.null txt = ""+ | "${" `T.isPrefixOf` txt =+ let rest = T.drop 2 txt+ (varName, after) = T.breakOn "}" rest+ varVal = lookupVar (T.unpack varName)+ in if "}" `T.isPrefixOf` after+ then varVal <> go (T.drop 1 after)+ else "${" <> go rest+ | "\\" `T.isPrefixOf` txt && T.length txt >= 2 =+ let digitChar = T.index txt 1+ in if isDigit digitChar+ then lookupVar [digitChar] <> go (T.drop 2 txt)+ else "\\" <> go (T.drop 1 txt)+ | "$&" `T.isPrefixOf` txt || "$0" `T.isPrefixOf` txt =+ seqToText res.matchedSlice <> go (T.drop 2 txt)+ | otherwise =+ let (chunk, rest) = T.break (\c -> c == '$' || c == '\\') txt+ in if T.null chunk+ then T.take 1 txt <> go (T.drop 1 txt)+ else chunk <> go rest++ lookupVar str = case reads str :: [(Int, String)] of+ [(idx, "")] -> maybe "" seqToText (Map.lookup idx res.captureGroups)+ _ -> maybe "" seqToText (Map.lookup (T.pack str) res.namedGroups)
+ src/Smirk/Engine/Sequence.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}++{- |+Module : Smirk.Engine.Sequence+Description : Sequence polymorphism abstraction for zero-copy and generic regex matching+Copyright : (c) Nadia Yvette Chambers, 2026+License : Apache-2.0++Provides the 'RegexTarget' typeclass, establishing a uniform sequence abstraction+across multiple standard Haskell container representations without boxing or+intermediate conversions.++=== Supported Sequence Targets++* 'Data.Text.Text': Standard UTF-8 strict text with $O(1)$ length/slicing.+* 'Data.ByteString.ByteString': Raw ASCII/UTF-8 byte sequences with zero-copy slicing.+* '[Char]': Standard Haskell linked lists of characters (lazy string processing).+* 'Data.Sequence.Seq Char': Finger-tree based sequences with logarithmic indexing.+* 'Data.Vector.Vector Char': Contiguous boxed/unboxed arrays of characters.+-}+module Smirk.Engine.Sequence+ ( RegexTarget (..)+ ) where++import qualified Data.ByteString as BS+import Data.Char (chr)+import qualified Data.Sequence as Seq+import Data.Sequence (Seq)+import qualified Data.Text as T+import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import qualified Data.Vector as V+import Data.Vector (Vector)++-- | Abstract sequence interface required by the regex virtual machine.+-- Allows the VM execution loop to index characters, measure length, and extract+-- matched sub-slices without coupling to a concrete string representation.+class RegexTarget s where+ -- | Total length (number of characters) in the sequence.+ seqLength :: s -> Int++ -- | Safely retrieve the character at the specified 0-based offset.+ -- Returns 'Nothing' if the index is out of bounds.+ seqIndex :: s -> Int -> Maybe Char++ -- | Extract a contiguous sub-slice given an offset and length.+ seqSlice :: Int -> Int -> s -> s++ -- | Convert the sequence (or a matched slice) to strict 'Text' for formatting.+ seqToText :: s -> Text++ -- | Construct a sequence from strict 'Text'.+ seqFromText :: Text -> s++-- | Instance for strict 'Text' (standard high-performance string representation).+instance RegexTarget Text where+ seqLength = T.length+ {-# INLINE seqLength #-}++ seqIndex t i+ | i >= 0 && i < T.length t = Just (T.index t i)+ | otherwise = Nothing+ {-# INLINE seqIndex #-}++ seqSlice off len t = T.take len (T.drop off t)+ {-# INLINE seqSlice #-}++ seqToText = id+ {-# INLINE seqToText #-}++ seqFromText = id+ {-# INLINE seqFromText #-}++-- | Instance for strict 'BS.ByteString' (interprets bytes as ASCII / Latin-1 codepoints).+instance RegexTarget BS.ByteString where+ seqLength = BS.length+ {-# INLINE seqLength #-}++ seqIndex bs i+ | i >= 0 && i < BS.length bs = Just (chr (fromIntegral (BS.index bs i)))+ | otherwise = Nothing+ {-# INLINE seqIndex #-}++ seqSlice off len bs = BS.take len (BS.drop off bs)+ {-# INLINE seqSlice #-}++ seqToText = TE.decodeUtf8Lenient+ {-# INLINE seqToText #-}++ seqFromText = TE.encodeUtf8+ {-# INLINE seqFromText #-}++-- | Instance for standard linked list of characters ('[Char]' / 'String').+instance RegexTarget [Char] where+ seqLength = length+ {-# INLINE seqLength #-}++ seqIndex xs i+ | i >= 0 = case drop i xs of+ (c:_) -> Just c+ [] -> Nothing+ | otherwise = Nothing+ {-# INLINE seqIndex #-}++ seqSlice off len xs = take len (drop off xs)+ {-# INLINE seqSlice #-}++ seqToText = T.pack+ {-# INLINE seqToText #-}++ seqFromText = T.unpack+ {-# INLINE seqFromText #-}++-- | Instance for finger-tree based 'Seq' collections.+instance RegexTarget (Seq Char) where+ seqLength = Seq.length+ {-# INLINE seqLength #-}++ seqIndex sq i = Seq.lookup i sq+ {-# INLINE seqIndex #-}++ seqSlice off len sq = Seq.take len (Seq.drop off sq)+ {-# INLINE seqSlice #-}++ seqToText sq = T.pack (foldr (:) [] sq)+ {-# INLINE seqToText #-}++ seqFromText t = Seq.fromList (T.unpack t)+ {-# INLINE seqFromText #-}++-- | Instance for contiguous 'Vector' arrays.+instance RegexTarget (Vector Char) where+ seqLength = V.length+ {-# INLINE seqLength #-}++ seqIndex v i = v V.!? i+ {-# INLINE seqIndex #-}++ seqSlice off len v = V.slice off (min len (V.length v - off)) v+ {-# INLINE seqSlice #-}++ seqToText v = T.pack (V.toList v)+ {-# INLINE seqToText #-}++ seqFromText t = V.fromList (T.unpack t)+ {-# INLINE seqFromText #-}
+ src/Smirk/Engine/VM.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedRecordDot #-}++{- |+Module : Smirk.Engine.VM+Description : Resumable, fuel-budgeted Pike-style regex virtual machine with ReDoS defense+Copyright : (c) Nadia Yvette Chambers, 2026+License : Apache-2.0++Implements the bytecode virtual machine for Smirk. The engine executes a Pike-style+nondeterministic state machine with an explicit backtracking continuation stack.++=== Architectural Invariants++* __ReDoS Immunity via Step-Bounding:__ Every instruction transition increments+ the consumed step counter. When running under 'StepBudget', exceeding the limit+ immediately yields 'OutOfFuel' with an intact 't:MatchContinuation', completely+ preventing algorithmic complexity attacks.+* __Pausable & Resumable Continuation:__ Suspended computations retain the entire+ thread state, backtrack stack, and program counters, enabling interactive or+ time-sliced regex execution.+* __Sequence Polymorphism:__ Character lookups and slice extractions are dispatched+ via the 'RegexTarget' class without intermediate string conversions.+-}+module Smirk.Engine.VM+ ( -- * Fuel & Budgeting+ Fuel (..)+ , MatchResult (..)+ , MatchStatus (..)+ , MatchContinuation (..)++ -- * Execution Entry Points+ , runMatch+ , runMatchAt+ , resumeMatch+ , findAllMatches++ -- * Internal VM Engine+ , ThreadState (..)+ , stepVM+ , matchClass+ , matchAnchor+ ) where++import Data.Char (isAlphaNum, isDigit, isSpace)+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+import Data.Text (Text)+import qualified Data.Vector as V+import GHC.Generics (Generic)++import Smirk.Core.AST (Anchor (..), CharClass (..), CharRange (..))+import Smirk.Core.Bytecode (Opcode (..), Regex (..))+import Smirk.Engine.Sequence (RegexTarget (..))++{- Note [Pike VM State Machine and Backtracking Stack]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+[tag:note-pike-vm-state-machine]+Smirk's execution engine operates as a bytecode virtual machine. The compiled+program comprises instructions like OpChar, OpSplit, OpJump, OpSaveStart, and+OpSaveEnd.++Nondeterminism from repetitions (.*, .+) and alternations (a|b) is modeled+via OpSplit d1 d2. Branch 1 is pursued immediately while Branch 2 is pushed+onto an explicit backtrack stack. If a thread encounters a character mismatch,+it pops the next alternate thread from the stack.++Unlike traditional recursive backtracking which consumes unbounded C call stack+frames and exposes the runtime to stack overflows, Smirk stores thread states in+an explicit heap-allocated list [ThreadState], bounded by the step fuel.+-}++{- Note [Fuel-Bounded Step Budget and ReDoS Defense]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+[tag:note-fuel-step-budget]+Regular Expression Denial of Service (ReDoS) occurs when malicious or pathological+inputs trigger superlinear (e.g. O(2^N)) backtracking iterations over ambiguous+grammars like (a+)+$.++To neutralize this threat, Smirk introduces the 'Fuel' budget:+1. Every iteration of 'stepVM' consumes exactly 1 unit of fuel.+2. If steps >= budget, the machine halts immediately and packages the active thread+ and backtrack stack into 'OutOfFuel (MatchContinuation ...)'.+3. The host application can inspect the partial progress, abort, or allocate more+ fuel to resume via 'resumeMatch'.+-}++-- | Execution fuel budget for step bounding and ReDoS prevention.+data Fuel+ = StepBudget !Int -- ^ Bounded execution: halt after N instruction steps+ | Unlimited -- ^ Unbounded execution: run to completion or exhaustion+ deriving (Eq, Show, Generic)++-- | Successful regular expression match result with full capture offsets.+data MatchResult s = MatchResult+ { matchedSlice :: !s -- ^ Exact matched slice of the input+ , matchOffset :: !Int -- ^ 0-based character offset where match begins+ , matchLength :: !Int -- ^ Total length (in characters) of the matched slice+ , captureGroups :: !(Map Int s) -- ^ Numbered capture groups (1-indexed)+ , namedGroups :: !(Map Text s) -- ^ Named capture groups mapped to slices+ , stepsConsumed :: !Int -- ^ Total VM steps executed to find this match+ } deriving (Eq, Show, Generic)++-- | Pausable and resumable execution continuation captured when fuel is exhausted.+data MatchContinuation s = MatchContinuation+ { savedRegex :: !Regex -- ^ The compiled regex being evaluated+ , savedTarget :: !s -- ^ The target sequence+ , savedStartIndex :: !Int -- ^ Outer search loop start offset+ , currentThread :: !ThreadState -- ^ Active thread state at suspension point+ , backtrackStack :: ![ThreadState] -- ^ Pending alternative branches+ , currentSteps :: !Int -- ^ Total steps executed up to suspension+ }++-- | Verdict of a matching operation.+data MatchStatus s+ = Matched !(MatchResult s) -- ^ A match was successfully found+ | NoMatch -- ^ The pattern does not match the target+ | OutOfFuel !(MatchContinuation s) -- ^ Fuel budget exhausted; resumable++-- | Internal VM thread execution state.+data ThreadState = ThreadState+ { pc :: !Int -- ^ Program counter: index into program vector+ , strIdx :: !Int -- ^ Current position in target character sequence+ , saves :: !(Map Int (Int, Maybe Int)) -- ^ Capture registers: group idx -> (start, optional end)+ } deriving (Eq, Show, Generic)++-- | Execute regex search across a sequence starting from index 0.+runMatch :: RegexTarget s => Regex -> s -> Fuel -> MatchStatus s+runMatch regex target = runMatchAt regex target 0++-- | Execute regex search starting from a specific character offset.+runMatchAt :: RegexTarget s => Regex -> s -> Int -> Fuel -> MatchStatus s+runMatchAt regex target startIdx fuel =+ let len = seqLength target+ in if startIdx > len+ then NoMatch+ else+ let initialThread = ThreadState 0 startIdx Map.empty+ in stepVM regex target startIdx initialThread [] 0 fuel++-- | Resume a previously suspended match with additional fuel.+resumeMatch :: RegexTarget s => MatchContinuation s -> Fuel -> MatchStatus s+resumeMatch cont =+ stepVM+ cont.savedRegex+ cont.savedTarget+ cont.savedStartIndex+ cont.currentThread+ cont.backtrackStack+ cont.currentSteps++-- | Find all non-overlapping matches across the target sequence.+findAllMatches :: RegexTarget s => Regex -> s -> [MatchResult s]+findAllMatches regex target = go 0+ where+ go off+ | off > seqLength target = []+ | otherwise = case runMatchAt regex target off Unlimited of+ Matched res ->+ let nextOff = max (off + 1) (res.matchOffset + res.matchLength)+ in res : go nextOff+ _ -> []++-- | Core backtracking execution step loop.+-- Evaluates one instruction and advances the thread or backtracks to an alternate branch.+stepVM+ :: RegexTarget s+ => Regex+ -> s+ -> Int -- ^ Outer loop start index+ -> ThreadState -- ^ Current active thread+ -> [ThreadState] -- ^ Backtrack stack+ -> Int -- ^ Steps consumed so far+ -> Fuel -- ^ Fuel limit+ -> MatchStatus s+stepVM regex target startIdx th stack steps fuel =+ case fuel of+ StepBudget budget | steps >= budget ->+ OutOfFuel MatchContinuation+ { savedRegex = regex+ , savedTarget = target+ , savedStartIndex = startIdx+ , currentThread = th+ , backtrackStack = stack+ , currentSteps = steps+ }+ _ ->+ let prog = regex.program+ pc' = th.pc+ in if pc' < 0 || pc' >= V.length prog+ then backtrackOrNextStart regex target startIdx stack (steps + 1) fuel+ else case prog V.! pc' of+ OpChar expected ->+ case seqIndex target th.strIdx of+ Just c | c == expected ->+ stepVM regex target startIdx th { pc = pc' + 1, strIdx = th.strIdx + 1 } stack (steps + 1) fuel+ _ -> backtrackOrNextStart regex target startIdx stack (steps + 1) fuel++ OpClass cls ->+ case seqIndex target th.strIdx of+ Just c | matchClass cls c ->+ stepVM regex target startIdx th { pc = pc' + 1, strIdx = th.strIdx + 1 } stack (steps + 1) fuel+ _ -> backtrackOrNextStart regex target startIdx stack (steps + 1) fuel++ OpAnchor anchor ->+ if matchAnchor anchor th.strIdx target+ then stepVM regex target startIdx th { pc = pc' + 1 } stack (steps + 1) fuel+ else backtrackOrNextStart regex target startIdx stack (steps + 1) fuel++ OpSplit d1 d2 ->+ let branch2 = th { pc = pc' + d2 }+ branch1 = th { pc = pc' + d1 }+ in stepVM regex target startIdx branch1 (branch2 : stack) (steps + 1) fuel++ OpJump d ->+ stepVM regex target startIdx th { pc = pc' + d } stack (steps + 1) fuel++ OpSaveStart idx ->+ let saves' = Map.insert idx (th.strIdx, Nothing) th.saves+ in stepVM regex target startIdx th { pc = pc' + 1, saves = saves' } stack (steps + 1) fuel++ OpSaveEnd idx ->+ let saves' = Map.adjust (\(s, _) -> (s, Just th.strIdx)) idx th.saves+ in stepVM regex target startIdx th { pc = pc' + 1, saves = saves' } stack (steps + 1) fuel++ OpAssertLookahead subProg isPos ->+ let subRegex = regex { program = subProg }+ subMatched = case runMatchAt subRegex target th.strIdx (StepBudget 1000) of+ Matched _ -> True+ _ -> False+ in if subMatched == isPos+ then stepVM regex target startIdx th { pc = pc' + 1 } stack (steps + 1) fuel+ else backtrackOrNextStart regex target startIdx stack (steps + 1) fuel++ OpAssertLookbehind subProg isPos ->+ let subRegex = regex { program = subProg }+ subMatched = any (\prevOff ->+ case runMatchAt subRegex target prevOff (StepBudget 1000) of+ Matched res -> res.matchOffset + res.matchLength == th.strIdx+ _ -> False+ ) [max 0 (th.strIdx - 20) .. th.strIdx]+ in if subMatched == isPos+ then stepVM regex target startIdx th { pc = pc' + 1 } stack (steps + 1) fuel+ else backtrackOrNextStart regex target startIdx stack (steps + 1) fuel++ OpMatchBackRef idx ->+ case Map.lookup idx th.saves of+ Just (st, Just en) ->+ let refLen = en - st+ refSlice = seqSlice st refLen target+ targetSlice = seqSlice th.strIdx refLen target+ in if seqToText refSlice == seqToText targetSlice+ then stepVM regex target startIdx th { pc = pc' + 1, strIdx = th.strIdx + refLen } stack (steps + 1) fuel+ else backtrackOrNextStart regex target startIdx stack (steps + 1) fuel+ _ -> backtrackOrNextStart regex target startIdx stack (steps + 1) fuel++ OpMatch ->+ Matched (buildResult regex target th (steps + 1))++-- | Backtrack to next pending thread on stack, or advance outer search loop.+backtrackOrNextStart+ :: RegexTarget s+ => Regex+ -> s+ -> Int+ -> [ThreadState]+ -> Int+ -> Fuel+ -> MatchStatus s+backtrackOrNextStart regex target startIdx stack steps fuel =+ case stack of+ (nextTh : rest) ->+ stepVM regex target startIdx nextTh rest steps fuel+ [] ->+ case regex.program V.!? 0 of+ Just (OpSaveStart 0) ->+ case regex.program V.!? 1 of+ Just (OpAnchor AnchorStart) -> NoMatch+ _ -> advanceStart+ _ -> advanceStart+ where+ advanceStart =+ let nextStart = startIdx + 1+ in if nextStart <= seqLength target+ then+ let freshThread = ThreadState 0 nextStart Map.empty+ in stepVM regex target nextStart freshThread [] steps fuel+ else NoMatch++-- | Construct a final 't:MatchResult' from the terminating thread registers.+buildResult :: RegexTarget s => Regex -> s -> ThreadState -> Int -> MatchResult s+buildResult regex target th steps =+ let (mOff, mLen) = case Map.lookup 0 th.saves of+ Just (st, Just en) -> (st, en - st)+ Just (st, Nothing) -> (st, th.strIdx - st)+ Nothing -> (0, th.strIdx)+ fullSlice = seqSlice mOff mLen target+ caps = Map.fromList+ [ (idx, seqSlice st (en - st) target)+ | (idx, (st, Just en)) <- Map.toList th.saves+ , idx /= 0+ ]+ namedCaps = Map.fromList+ [ (name, capSlice)+ | (name, idx) <- Map.toList regex.groupNames+ , Just capSlice <- [Map.lookup idx caps]+ ]+ in MatchResult+ { matchedSlice = fullSlice+ , matchOffset = mOff+ , matchLength = mLen+ , captureGroups = caps+ , namedGroups = namedCaps+ , stepsConsumed = steps+ }++-- | Test if a character satisfies a character class specification.+matchClass :: CharClass -> Char -> Bool+matchClass cls c = case cls of+ ClassAny -> c /= '\n'+ ClassDigit -> isDigit c+ ClassNotDigit -> not (isDigit c)+ ClassWord -> isAlphaNum c || c == '_'+ ClassNotWord -> not (isAlphaNum c || c == '_')+ ClassSpace -> isSpace c+ ClassNotSpace -> not (isSpace c)+ ClassSet ranges negated ->+ let inRanges = any (inRange c) ranges+ in if negated then not inRanges else inRanges+ where+ inRange ch (RangeSingle s) = ch == s+ inRange ch (RangeBetween s e) = ch >= s && ch <= e++-- | Assert if a boundary condition holds at a specific character position.+matchAnchor :: RegexTarget s => Anchor -> Int -> s -> Bool+matchAnchor anchor idx target = case anchor of+ AnchorStart -> idx == 0+ AnchorEnd -> idx == seqLength target+ AnchorWordBoundary ->+ let prevIsWord = case seqIndex target (idx - 1) of+ Just p -> isAlphaNum p || p == '_'+ Nothing -> False+ currIsWord = case seqIndex target idx of+ Just cur -> isAlphaNum cur || cur == '_'+ Nothing -> False+ in prevIsWord /= currIsWord+ AnchorNotWordBoundary ->+ not (matchAnchor AnchorWordBoundary idx target)
+ src/Smirk/Glob.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++{- |+Module : Smirk.Glob+Description : Native POSIX and Git-style globbing engine with compile-time QuasiQuoters+Copyright : (c) Nadia Yvette Chambers, 2026+License : Apache-2.0++Implements native globbing and wildcard pattern compilation directly on top of+Smirk's PCRE engine and AST compiler.++=== Supported Glob Syntax++* Single-level wildcards: @*@ matches any characters except directory separators (@/@).+* Recursive path wildcards: @**@ matches across directory hierarchies.+* Single-character wildcard: @?@ matches any single non-separator character.+* Character ranges: @[a-z]@, @[0-9]@, with negation @[!a-z]@ or @[^a-z]@.+* Alternation braces: @{src,test}/**/*.hs@.+* Escape sequences: @\\*@, @\\?@, @\\[@, @\\{@.+-}+module Smirk.Glob+ ( -- * Glob Compilation & Matching+ compileGlob+ , compileGlobWithOptions+ , compileWildcard+ , GlobOptions (..)+ , defaultGlobOptions+ , wildcardGlobOptions+ , globToAST+ , matchGlob++ -- * Compile-time QuasiQuoter+ , glob++ -- * Parser Combinators+ , GlobParser+ , pGlob+ , pGlobItem+ ) where++import Control.Monad (void)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Void (Void)+import GHC.Generics (Generic)+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Text.Megaparsec+import Text.Megaparsec.Char++import Smirk.Core.AST+import Smirk.Core.Bytecode (Regex)+import Smirk.Core.Compiler (compileToRegex)+import Smirk.Engine.Sequence (RegexTarget)+import Smirk.Engine.VM (MatchStatus (..), runMatch, Fuel (Unlimited))++-- | Configuration options for glob compilation.+data GlobOptions = GlobOptions+ { matchPathSeparators :: !Bool -- ^ If True, '*' does not cross '/' boundaries and '**' is recursive+ , caseSensitive :: !Bool -- ^ If True, matching is case-sensitive+ } deriving (Eq, Show, Generic)++-- | Standard filesystem glob configuration (POSIX/Git style).+-- Enforces that '*' stops at '/' boundaries and '**' matches arbitrarily deep subdirectories.+defaultGlobOptions :: GlobOptions+defaultGlobOptions = GlobOptions+ { matchPathSeparators = True+ , caseSensitive = True+ }++-- | Unconstrained wildcard configuration (for tool names, namespaces, e.g. "mcp__*").+-- Allows '*' to match any character including directory separators.+wildcardGlobOptions :: GlobOptions+wildcardGlobOptions = GlobOptions+ { matchPathSeparators = False+ , caseSensitive = True+ }++-- | Megaparsec parser type for glob strings over strict Text.+type GlobParser = Parsec Void Text++-- | Compile a filesystem glob pattern (e.g. "src/**/*.hs", "test/Spec?.hs")+-- into an anchored Smirk 'Regex' using 'defaultGlobOptions'.+compileGlob :: Text -> Either Text Regex+compileGlob = compileGlobWithOptions defaultGlobOptions++-- | Compile an unconstrained wildcard pattern where '*' matches all characters.+compileWildcard :: Text -> Either Text Regex+compileWildcard = compileGlobWithOptions wildcardGlobOptions++-- | Compile a glob pattern with explicit 't:GlobOptions'.+compileGlobWithOptions :: GlobOptions -> Text -> Either Text Regex+compileGlobWithOptions opts input = do+ ast <- globToAST opts input+ pure (compileToRegex input ast)++-- | Convert a glob pattern string into a typed Smirk 'AST'.+globToAST :: GlobOptions -> Text -> Either Text AST+globToAST opts input =+ case runParser (pGlob opts) "glob" input of+ Left err -> Left (T.pack $ errorBundlePretty err)+ Right ast -> Right ast++-- | Test if a target sequence matches a compiled glob regex.+matchGlob :: RegexTarget s => Regex -> s -> Bool+matchGlob regex target =+ case runMatch regex target Unlimited of+ Matched _ -> True+ _ -> False++-- | Top-level glob parser wrapping items between start and end anchors.+pGlob :: GlobOptions -> GlobParser AST+pGlob opts = do+ items <- many (pGlobItem opts)+ eof+ pure $ Seq (AnchorAssert AnchorStart : items ++ [AnchorAssert AnchorEnd])++-- | Parse individual glob items: recursive wildcards, single wildcards, braces, classes, escapes.+pGlobItem :: GlobOptions -> GlobParser AST+pGlobItem opts =+ pSlashDoubleStarSlash opts+ <|> pDoubleStar opts+ <|> pSingleStar opts+ <|> pQuestionMark opts+ <|> pBraceExpansion opts+ <|> pCharClass+ <|> pEscapedChar+ <|> pLiteralChar++-- | Parse @/**/@ representing zero or more directory levels.+pSlashDoubleStarSlash :: GlobOptions -> GlobParser AST+pSlashDoubleStarSlash opts+ | opts.matchPathSeparators = try $ do+ void (string "/**/")+ pure $ Alt+ [ Lit '/'+ , Seq [Lit '/', Repeat 0 Nothing RepGreedy (Class ClassAny), Lit '/']+ ]+ | otherwise = empty++-- | Parse @**/@ or terminal @**@ recursive wildcard.+pDoubleStar :: GlobOptions -> GlobParser AST+pDoubleStar opts+ | opts.matchPathSeparators = try $ do+ void (string "**/")+ pure $ Alt+ [ Empty+ , Seq [Repeat 0 Nothing RepGreedy (Class ClassAny), Lit '/']+ ]+ <|> (string "**" >> pure (Repeat 0 Nothing RepGreedy (Class ClassAny)))+ | otherwise = string "**" >> pure (Repeat 0 Nothing RepGreedy (Class ClassAny))++-- | Parse single-level @*@ wildcard matching within directory boundaries.+pSingleStar :: GlobOptions -> GlobParser AST+pSingleStar opts+ | opts.matchPathSeparators =+ char '*' >> pure (Repeat 0 Nothing RepGreedy (Class (ClassSet [RangeSingle '/'] True)))+ | otherwise =+ char '*' >> pure (Repeat 0 Nothing RepGreedy (Class ClassAny))++-- | Parse @?@ matching any single character except directory separator.+pQuestionMark :: GlobOptions -> GlobParser AST+pQuestionMark opts+ | opts.matchPathSeparators =+ char '?' >> pure (Class (ClassSet [RangeSingle '/'] True))+ | otherwise =+ char '?' >> pure (Class ClassAny)++-- | Parse brace expansion @{a,b,c}@ into an alternation.+pBraceExpansion :: GlobOptions -> GlobParser AST+pBraceExpansion opts = between (char '{') (char '}') $ do+ branches <- sepBy1 (many (pBraceInnerItem opts)) (char ',')+ pure $ Alt (map Seq branches)++-- | Parse inner items within a brace expansion.+pBraceInnerItem :: GlobOptions -> GlobParser AST+pBraceInnerItem opts =+ pSlashDoubleStarSlash opts+ <|> pDoubleStar opts+ <|> pSingleStar opts+ <|> pQuestionMark opts+ <|> pCharClass+ <|> pEscapedChar+ <|> (Lit <$> noneOf ("*?{}[],;/\\" :: String))+ <|> (char '/' >> pure (Lit '/'))+ <|> (char ';' >> pure (Lit ';'))++-- | Parse character classes with optional negation: @[a-z]@, @[!0-9]@, @[^A-Z]@.+pCharClass :: GlobParser AST+pCharClass = between (char '[') (char ']') $ do+ negated <- (char '!' >> pure True) <|> (char '^' >> pure True) <|> pure False+ ranges <- many pRange+ pure $ Class (ClassSet ranges negated)+ where+ pRange = try pBetween <|> pSingle+ pBetween = do+ s <- noneOf [']', '-']+ void (char '-')+ e <- noneOf [']']+ pure $ RangeBetween s e+ pSingle = RangeSingle <$> noneOf [']']++-- | Parse an escaped character: @\\*@, @\\?@, etc.+pEscapedChar :: GlobParser AST+pEscapedChar = do+ void (char '\\')+ Lit <$> anySingle++-- | Parse literal characters that do not carry special glob syntax meaning.+pLiteralChar :: GlobParser AST+pLiteralChar =+ (Lit <$> noneOf ("*?{}[],;/\\" :: String))+ <|> (char '/' >> pure (Lit '/'))+ <|> (char ',' >> pure (Lit ','))+ <|> (char ';' >> pure (Lit ';'))++-- | QuasiQuoter for compile-time verified glob patterns.+--+-- === Example+--+-- @+-- let r = [glob|src\/**\/*.hs|]+-- matchGlob r "src/Smirk/Core/AST.hs" == True+-- @+glob :: QuasiQuoter+glob = QuasiQuoter+ { quoteExp = quoteGlobExp+ , quotePat = error "Smirk.glob: Pattern matching quasiquote not supported"+ , quoteType = error "Smirk.glob: Type quasiquote not supported"+ , quoteDec = error "Smirk.glob: Declaration quasiquote not supported"+ }++-- | Compile-time expression quoter for glob strings.+quoteGlobExp :: String -> Q Exp+quoteGlobExp globStr =+ case compileGlob (T.pack globStr) of+ Left err -> fail ("Smirk glob compile error: " <> T.unpack err)+ Right _ ->+ [| case compileGlob (T.pack $(stringE globStr)) of+ Right r -> r+ Left e -> error ("Smirk glob internal error: " <> T.unpack e)+ |]
+ test/GlobSpec.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module GlobSpec (spec) where++import qualified Data.ByteString as BS+import Data.Text (Text)+import Test.Hspec++import Smirk++spec :: Spec+spec = describe "Smirk.Glob" $ do+ describe "Filesystem Globs (compileGlob)" $ do+ it "matches single level wildcards with *" $ do+ case compileGlob "src/*.hs" of+ Right g -> do+ matchGlob g ("src/Main.hs" :: Text) `shouldBe` True+ matchGlob g ("src/Smirk/Core.hs" :: Text) `shouldBe` False+ Left err -> expectationFailure (show err)++ it "matches recursive directories with **" $ do+ case compileGlob "src/**/*.hs" of+ Right g -> do+ matchGlob g ("src/Main.hs" :: Text) `shouldBe` True+ matchGlob g ("src/Smirk/Core/AST.hs" :: Text) `shouldBe` True+ matchGlob g ("test/Spec.hs" :: Text) `shouldBe` False+ Left err -> expectationFailure (show err)++ it "matches single character with ?" $ do+ case compileGlob "file?.txt" of+ Right g -> do+ matchGlob g ("file1.txt" :: Text) `shouldBe` True+ matchGlob g ("fileA.txt" :: Text) `shouldBe` True+ matchGlob g ("file10.txt" :: Text) `shouldBe` False+ Left err -> expectationFailure (show err)++ it "matches brace alternatives" $ do+ case compileGlob "{src,test}/**/*.hs" of+ Right g -> do+ matchGlob g ("src/Smirk.hs" :: Text) `shouldBe` True+ matchGlob g ("src/Smirk/Core/AST.hs" :: Text) `shouldBe` True+ matchGlob g ("test/Spec.hs" :: Text) `shouldBe` True+ matchGlob g ("app/Main.hs" :: Text) `shouldBe` False+ Left err -> expectationFailure (show err)++ it "matches character ranges and negation" $ do+ case compileGlob "doc-[0-9].[!a-z]" of+ Right g -> do+ matchGlob g ("doc-1.1" :: Text) `shouldBe` True+ matchGlob g ("doc-1.a" :: Text) `shouldBe` False+ Left err -> expectationFailure (show err)++ describe "Unconstrained Wildcards (compileWildcard)" $ do+ it "matches general tool names and namespaces across any delimiter" $ do+ case (compileWildcard "mcp__*", compileWildcard "git_*", compileWildcard "fs:*") of+ (Right wMcp, Right wGit, Right wColon) -> do+ matchGlob wMcp ("mcp__github__search_repos" :: Text) `shouldBe` True+ matchGlob wMcp ("local_tool" :: Text) `shouldBe` False+ matchGlob wGit ("git_commit" :: Text) `shouldBe` True+ matchGlob wColon ("fs:read_file" :: Text) `shouldBe` True+ _ -> expectationFailure "Failed to compile wildcards"++ describe "[glob|...|] Compile-Time QuasiQuoter" $ do+ it "validates and compiles glob pattern at compile time" $ do+ let g = [glob|src/**/*.hs|]+ matchGlob g ("src/Smirk/Glob.hs" :: Text) `shouldBe` True+ matchGlob g ("src/Smirk/Glob.hs" :: String) `shouldBe` True+ matchGlob g ("src/Smirk/Glob.hs" :: BS.ByteString) `shouldBe` True+ matchGlob g ("doc/README.md" :: Text) `shouldBe` False
+ test/ParserSpec.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}++module ParserSpec (spec) where++import Test.Hspec++import Smirk.Core.AST+import Smirk.Core.Parser++spec :: Spec+spec = describe "Smirk.Core.Parser" $ do+ it "parses simple literal sequence" $ do+ let res = parsePCRE "smirk"+ case res of+ Right (Seq [Lit 's', Lit 'm', Lit 'i', Lit 'r', Lit 'k']) -> pure ()+ other -> expectationFailure $ "Expected Seq of chars but got: " <> show other++ it "parses character classes and digits" $ do+ let res = parsePCRE "[a-z0-9]+\\s*\\d+"+ case res of+ Right (Seq [ Repeat 1 Nothing RepGreedy (Class (ClassSet [RangeBetween 'a' 'z', RangeBetween '0' '9'] False))+ , Repeat 0 Nothing RepGreedy (Class ClassSpace)+ , Repeat 1 Nothing RepGreedy (Class ClassDigit)+ ]) -> pure ()+ other -> expectationFailure $ "Unexpected AST: " <> show other++ it "parses named capture groups and lookahead assertions" $ do+ let res = parsePCRE "(?<user>[a-zA-Z]+)(?=@domain\\.com)"+ case res of+ Right (Seq [ Group (Just "user") Nothing (Repeat 1 Nothing RepGreedy (Class (ClassSet [RangeBetween 'a' 'z', RangeBetween 'A' 'Z'] False)))+ , Lookaround Lookahead True (Seq [Lit '@', Lit 'd', Lit 'o', Lit 'm', Lit 'a', Lit 'i', Lit 'n', Lit '.', Lit 'c', Lit 'o', Lit 'm'])+ ]) -> pure ()+ other -> expectationFailure $ "Unexpected AST: " <> show other++ it "parses backreferences" $ do+ let res = parsePCRE "([a-z]+)-\\1"+ case res of+ Right (Seq [ Group Nothing Nothing (Repeat 1 Nothing RepGreedy (Class (ClassSet [RangeBetween 'a' 'z'] False)))+ , Lit '-'+ , BackRef 1+ ]) -> pure ()+ other -> expectationFailure $ "Unexpected AST: " <> show other
+ test/QuoteSpec.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module QuoteSpec (spec) where++import qualified Data.Map.Strict as Map+import Data.Text (Text)+import Test.Hspec++import Smirk++spec :: Spec+spec = describe "Smirk.Core.Quote ([re|...|] & [ed|...|])" $ do+ describe "[re|...|] Compile-Time QuasiQuoter" $ do+ it "matches compile-time validated PCRE regular expression" $ do+ let regex = [re|(?<greeting>hello|hi)\s+(?<target>[a-zA-Z]+)|]+ case execMatch regex ("hello world, smirk says hi" :: Text) of+ Just res -> do+ res.matchedSlice `shouldBe` "hello world"+ res.namedGroups `shouldBe` Map.fromList [("greeting", "hello"), ("target", "world")]+ Nothing -> expectationFailure "Expected QuasiQuoted regex to match"++ describe "[ed|...|] Compile-Time Search-and-Replace Editor" $ do+ it "replaces patterns with capture substitutions" $ do+ let editor = [ed|foo([0-9]+)///bar${1}|]+ input = ("foo10 and foo20" :: Text)+ result = applyEditor editor input+ result `shouldBe` "bar10 and bar20"++ it "replaces with full match $& variable" $ do+ let editor = [ed|\b[a-z]{4}\b///[$&]|]+ input = ("test code with text" :: Text)+ result = applyEditor editor input+ result `shouldBe` "[test] [code] [with] [text]"
+ test/SequenceSpec.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module SequenceSpec (spec) where++import qualified Data.ByteString as BS+import qualified Data.Map.Strict as Map+import qualified Data.Sequence as Seq+import Data.Text (Text)+import qualified Data.Vector as V+import Test.Hspec++import Smirk++spec :: Spec+spec = describe "Smirk.Engine.Sequence" $ do+ let reg = [re|(?<num>\d+)-(?<word>[a-z]+)|]++ it "matches against Data.Text" $ do+ let input = ("item 42-smirk in text" :: Text)+ case execMatch reg input of+ Just res -> do+ res.matchedSlice `shouldBe` "42-smirk"+ res.namedGroups `shouldBe` Map.fromList [("num", "42"), ("word", "smirk")]+ Nothing -> expectationFailure "Expected Text match"++ it "matches against Data.ByteString" $ do+ let input = ("item 42-smirk in text" :: BS.ByteString)+ case execMatch reg input of+ Just res -> do+ res.matchedSlice `shouldBe` "42-smirk"+ res.namedGroups `shouldBe` Map.fromList [("num", "42"), ("word", "smirk")]+ Nothing -> expectationFailure "Expected ByteString match"++ it "matches against String ([Char])" $ do+ let input = ("item 42-smirk in text" :: String)+ case execMatch reg input of+ Just res -> do+ res.matchedSlice `shouldBe` "42-smirk"+ res.namedGroups `shouldBe` Map.fromList [("num", "42"), ("word", "smirk")]+ Nothing -> expectationFailure "Expected String match"++ it "matches against Data.Sequence.Seq Char" $ do+ let input = Seq.fromList ("item 42-smirk in text" :: String)+ case execMatch reg input of+ Just res -> do+ res.matchedSlice `shouldBe` Seq.fromList "42-smirk"+ Nothing -> expectationFailure "Expected Seq match"++ it "matches against Data.Vector.Vector Char" $ do+ let input = V.fromList ("item 42-smirk in text" :: String)+ case execMatch reg input of+ Just res -> do+ res.matchedSlice `shouldBe` V.fromList "42-smirk"+ Nothing -> expectationFailure "Expected Vector match"
+ test/Spec.hs view
@@ -0,0 +1,16 @@+module Main (main) where++import Test.Hspec+import qualified ParserSpec+import qualified VMSpec+import qualified SequenceSpec+import qualified QuoteSpec+import qualified GlobSpec++main :: IO ()+main = hspec $ do+ ParserSpec.spec+ VMSpec.spec+ SequenceSpec.spec+ QuoteSpec.spec+ GlobSpec.spec
+ test/VMSpec.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++module VMSpec (spec) where++import qualified Data.Map.Strict as Map+import Data.Text (Text)+import Test.Hspec++import Smirk++spec :: Spec+spec = describe "Smirk.Engine.VM" $ do+ it "matches simple literal patterns" $ do+ case compileRegex "smirk" of+ Right reg -> case execMatch reg ("a smirk ;-) in text" :: Text) of+ Just res -> do+ res.matchedSlice `shouldBe` "smirk"+ res.matchOffset `shouldBe` 2+ res.matchLength `shouldBe` 5+ Nothing -> expectationFailure "Expected match for 'smirk'"+ Left err -> expectationFailure (show err)++ it "extracts numbered and named capture groups" $ do+ case compileRegex "(?<protocol>https?)://(?<domain>[a-z.]+)" of+ Right reg -> case execMatch reg ("visit https://haskell.org today" :: Text) of+ Just res -> do+ res.matchedSlice `shouldBe` "https://haskell.org"+ Map.lookup 1 res.captureGroups `shouldBe` Just "https"+ Map.lookup 2 res.captureGroups `shouldBe` Just "haskell.org"+ Map.lookup "protocol" res.namedGroups `shouldBe` Just "https"+ Map.lookup "domain" res.namedGroups `shouldBe` Just "haskell.org"+ Nothing -> expectationFailure "Expected capture groups match"+ Left err -> expectationFailure (show err)++ it "matches positive and negative lookahead assertions" $ do+ case (compileRegex "\\w+(?=@example\\.com)", compileRegex "\\w+(?!@example\\.com)") of+ (Right regPos, Right regNeg) -> do+ case execMatch regPos ("alice@example.com" :: Text) of+ Just res -> res.matchedSlice `shouldBe` "alice"+ Nothing -> expectationFailure "Expected positive lookahead match"++ case execMatch regNeg ("bob@other.com" :: Text) of+ Just res -> res.matchedSlice `shouldBe` "bob"+ Nothing -> expectationFailure "Expected negative lookahead match"+ _ -> expectationFailure "Failed to compile lookahead regexes"++ it "matches backreferences" $ do+ case compileRegex "([a-z]+) \\1" of+ Right reg -> do+ case execMatch reg ("the the repeat" :: Text) of+ Just res -> res.matchedSlice `shouldBe` "the the"+ Nothing -> expectationFailure "Expected backreference match"++ case execMatch reg ("the other word" :: Text) of+ Just _ -> expectationFailure "Should not match different words"+ Nothing -> pure ()+ Left err -> expectationFailure (show err)++ it "enforces step bounding and safely yields OutOfFuel on ReDoS patterns" $ do+ case compileRegex "(a+)+b" of+ Right redosReg -> do+ let evilInput = ("aaaaaaaaaaaaaaac" :: Text)+ case execMatchWithFuel redosReg evilInput (StepBudget 50) of+ OutOfFuel cont -> do+ cont.currentSteps `shouldSatisfy` (>= 50)+ case resumeMatch cont (StepBudget 100) of+ OutOfFuel cont2 -> cont2.currentSteps `shouldSatisfy` (>= 100)+ _ -> expectationFailure "Expected OutOfFuel again on continued ReDoS"+ _ -> expectationFailure "Expected OutOfFuel on initial ReDoS run"+ Left err -> expectationFailure (show err)++ it "finds all non-overlapping matches in input" $ do+ case compileRegex "\\d+" of+ Right reg -> do+ let matches = findAllMatches reg ("10 apples, 20 oranges, 35 bananas" :: Text)+ length matches `shouldBe` 3+ map (\m -> m.matchedSlice) matches `shouldBe` ["10", "20", "35"]+ Left err -> expectationFailure (show err)