haskell_match 0.1.0 → 0.2.0

data/ext/haskell_match/src/ruby/native.rs

@@ -0,0 +1,227 @@
+//! The functions of the `HaskellMatch::Native` module, declared with
+//! `#[rubymodule]`: parsing `data` declarations and Haskell source, the type
+//! scopes, and the recursion settings.
+//!
+//! Each function takes Rust types (a wrong argument raises `TypeError`, an
+//! integer out of range `RangeError`, a well-typed argument with a bad value
+//! `ArgumentError`) and returns a `Result`, whose `Err` is raised once the
+//! function's values have been dropped.  `HaskellMatch::Native.rbs` is the
+//! module's RBS declaration.
+
+use rutie::derive::FromArgument;
+use rutie::{AnyException, Array, Object};
+
+use super::error::argument_error;
+use crate::core::types::ConSpec;
+
+/// One constructor of a parsed `data` declaration: name, arity, record
+/// field names (or `nil`) and field types.
+pub type ParsedCon = (String, usize, Option<Vec<String>>, Vec<String>);
+
+/// A parsed `data` declaration: type name, type variables, constructors and
+/// the classes it derives.
+pub type ParsedData = (String, Vec<String>, Vec<ParsedCon>, Vec<String>);
+
+/// What `constructor_info_in` reports: type name, arity and record field
+/// names (or `nil`).
+pub type ConInfo = (String, usize, Option<Vec<String>>);
+
+/// A `[name, arity, fields_or_nil, class]` row of `register_type_in`.
+fn constructor_spec(row: &Array) -> Result<ConSpec, AnyException> {
+    if row.length() != 4 {
+        return Err(argument_error(
+            "constructor spec must be [name, arity, fields, class]",
+        ));
+    }
+    let name = String::hold(row.at(0))?;
+    let arity = usize::hold(row.at(1))?;
+    let fields = <Option<Vec<String>>>::hold(row.at(2))?;
+    let klass = row.at(3);
+    if klass.is_nil() {
+        return Err(argument_error("constructor class must not be nil"));
+    }
+    Ok(ConSpec {
+        name,
+        arity,
+        fields,
+        handle: klass.value().value,
+    })
+}
+
+#[rubymodule(path = "HaskellMatch::Native")]
+pub mod functions {
+    use rutie::rubysys::gc::rb_gc_register_mark_object;
+    use rutie::types::Value;
+    use rutie::{AnyException, Array};
+
+    use super::{constructor_spec, ConInfo, ParsedCon, ParsedData};
+    use crate::core::parser::parse_pattern;
+    use crate::core::pretty::render_pat;
+    use crate::core::resolve::resolve_clause;
+    use crate::ruby::error::{argument_error, HmError};
+    use crate::ruby::state;
+
+    /// `Native.parse_data(decl)` ->
+    /// `[name, tyvars, [[con, arity, fields_or_nil, types], ...], deriving]`
+    pub fn parse_data(decl: &str) -> Result<ParsedData, HmError> {
+        let d = crate::core::parser::parse_data(decl)?;
+        let cons: Vec<ParsedCon> = d
+            .cons
+            .into_iter()
+            .map(|c| (c.name, c.arity, c.fields, c.types))
+            .collect();
+        Ok((d.name, d.tyvars, cons, d.deriving))
+    }
+
+    /// `Native.new_scope` -> a type scope seeded from the global registry.
+    pub fn new_scope() -> usize {
+        let mut scopes = state::scopes();
+        let seed = scopes[0].clone();
+        scopes.push(seed);
+        scopes.len() - 1
+    }
+
+    /// `Native.import_scope_in(dst, src, names_or_nil)` -> the type names
+    /// imported: every user type of `src` (or those named) that `dst` does
+    /// not already declare identically.
+    pub fn import_scope_in(
+        dst: usize,
+        src: usize,
+        names: Option<Vec<String>>,
+    ) -> Result<Vec<String>, AnyException> {
+        let mut scopes = state::scopes();
+        if src >= scopes.len() || dst >= scopes.len() {
+            return Err(argument_error("unknown type scope"));
+        }
+        let types = scopes[src].user_types();
+        let env = &mut scopes[dst];
+        let mut imported = Vec::new();
+        for (name, cons) in types {
+            if let Some(wanted) = &names {
+                if !wanted.contains(&name) {
+                    continue;
+                }
+            }
+            if !env.has_same_type(&name, &cons) {
+                env.register(&name, &cons)?;
+            }
+            imported.push(name);
+        }
+        Ok(imported)
+    }
+
+    /// `Native.register_type_in(name, [[con, arity, fields_or_nil, class], ...], scope)`
+    pub fn register_type_in(
+        name: &str,
+        specs: Vec<Array>,
+        scope: usize,
+    ) -> Result<(), AnyException> {
+        let mut cons = Vec::with_capacity(specs.len());
+        for row in &specs {
+            cons.push(constructor_spec(row)?);
+        }
+        let mut scopes = state::scopes();
+        let env = state::scope_env(&mut scopes, scope)?;
+        env.register(name, &cons)?;
+        for c in &cons {
+            // Keep constructor classes alive for as long as the process
+            // runs: compiled matchers refer to them by VALUE.
+            unsafe { rb_gc_register_mark_object(Value::from(c.handle)) };
+        }
+        Ok(())
+    }
+
+    /// `Native.render_pattern_in(src, scope)` -> the pattern's canonical
+    /// Haskell rendering (checking it along the way).
+    pub fn render_pattern_in(src: &str, scope: usize) -> Result<String, AnyException> {
+        let raw = parse_pattern(src)?;
+        let mut scopes = state::scopes();
+        let env = state::scope_env(&mut scopes, scope)?;
+        let (pats, bindings) = resolve_clause(env, &[raw])?;
+        Ok(render_pat(env, &pats[0], &bindings.names))
+    }
+
+    /// `Native.constructors_in(type_name, scope)` -> the constructor names,
+    /// or `nil` for an unknown type.
+    pub fn constructors_in(name: &str, scope: usize) -> Result<Option<Vec<String>>, AnyException> {
+        let mut scopes = state::scopes();
+        let env = state::scope_env(&mut scopes, scope)?;
+        Ok(env.lookup_type(name).map(|t| {
+            env.ty(t)
+                .cons
+                .iter()
+                .map(|c| env.con(*c).name.clone())
+                .collect()
+        }))
+    }
+
+    /// `Native.constructor_info_in(name, scope)` ->
+    /// `[type_name, arity, fields_or_nil]`, or `nil` for an unknown
+    /// constructor.
+    pub fn constructor_info_in(name: &str, scope: usize) -> Result<Option<ConInfo>, AnyException> {
+        let mut scopes = state::scopes();
+        let env = state::scope_env(&mut scopes, scope)?;
+        Ok(env.lookup_con(name).map(|c| {
+            let con = env.con(c);
+            (env.ty(con.ty).name.clone(), con.arity, con.fields.clone())
+        }))
+    }
+
+    /// `Native.parse_haskell(source)` -> the module's AST as JSON.
+    pub fn parse_haskell(source: &str) -> Result<String, HmError> {
+        let module = crate::core::hs::parse_module(source)?;
+        Ok(crate::core::hs::json::module(&module))
+    }
+
+    /// `Native.stack_segment` -> levels between Fiber segments (0: disabled).
+    pub fn stack_segment() -> usize {
+        state::stack_segment()
+    }
+
+    /// `Native.stack_segment = levels`
+    #[ruby(name = "stack_segment=")]
+    pub fn set_stack_segment(levels: i64) -> Result<i64, AnyException> {
+        if levels < 0 {
+            return Err(argument_error(
+                "stack_segment must be a non-negative Integer (0 disables segmentation)",
+            ));
+        }
+        state::set_stack_segment(levels as usize);
+        Ok(levels)
+    }
+
+    /// `Native.max_depth` -> deepest allowed nesting (0: unlimited).
+    pub fn max_depth() -> usize {
+        state::max_depth()
+    }
+
+    /// `Native.max_depth = levels`
+    #[ruby(name = "max_depth=")]
+    pub fn set_max_depth(levels: i64) -> Result<i64, AnyException> {
+        if levels < 0 {
+            return Err(argument_error(
+                "max_depth must be a non-negative Integer (0 means unlimited)",
+            ));
+        }
+        state::set_max_depth(levels as usize);
+        Ok(levels)
+    }
+
+    /// `Native.depth_push` -> the new nesting depth (raises
+    /// `StackOverflowError` past `max_depth`); `Native.depth_pop` undoes it.
+    /// Used by deep-mode functions, whose body invocation happens in Ruby.
+    pub fn depth_push() -> Result<usize, HmError> {
+        state::depth_push()
+    }
+
+    /// `Native.depth_pop`
+    pub fn depth_pop() {
+        state::depth_pop();
+    }
+
+    /// `Native.rbs` -> the module's RBS declaration.
+    #[ruby(name = "rbs")]
+    pub fn signature() -> String {
+        rbs()
+    }
+}

data/ext/haskell_match/src/ruby/state.rs

@@ -0,0 +1,91 @@
+//! Process-wide state shared by the module functions and the matcher: the
+//! type scopes, the recursion settings and the per-thread nesting depth.
+
+use std::cell::Cell;
+use std::sync::atomic::{AtomicUsize, Ordering};
+use std::sync::{LazyLock, Mutex, MutexGuard};
+
+use rutie::AnyException;
+
+use super::error::{argument_error, HmError};
+use crate::core::types::TypeEnv;
+
+/// Type scopes: index 0 is the global registry; every other scope is a
+/// snapshot of the global one at its creation plus its own declarations
+/// (a compiled Haskell module gets one, like a Haskell module namespace).
+static SCOPES: LazyLock<Mutex<Vec<TypeEnv>>> = LazyLock::new(|| Mutex::new(vec![TypeEnv::new()]));
+
+/// The type scopes, locked.
+pub fn scopes() -> MutexGuard<'static, Vec<TypeEnv>> {
+    SCOPES.lock().unwrap_or_else(|p| p.into_inner())
+}
+
+/// The type environment of scope `id`.
+pub fn scope_env(scopes: &mut [TypeEnv], id: usize) -> Result<&mut TypeEnv, AnyException> {
+    scopes
+        .get_mut(id)
+        .ok_or_else(|| argument_error(&format!("unknown type scope {}", id)))
+}
+
+thread_local! {
+    /// Nesting depth of native calls on this thread.
+    static DEPTH: Cell<usize> = const { Cell::new(0) };
+}
+
+/// Every this many nested native calls, the next clause body runs in a fresh
+/// Fiber.  Each Fiber brings its own VM stack and machine stack, so chained
+/// segments make the recursion depth a matter of memory rather than of
+/// Ruby's fixed stack size.  0 disables segmentation.
+static STACK_SEGMENT: AtomicUsize = AtomicUsize::new(DEFAULT_STACK_SEGMENT);
+const DEFAULT_STACK_SEGMENT: usize = 100;
+
+/// Maximum nesting depth of native calls before `StackOverflowError` is
+/// raised, so a runaway recursion fails instead of consuming all memory
+/// (GHC has the same kind of limit).  0 means unlimited.
+static MAX_DEPTH: AtomicUsize = AtomicUsize::new(DEFAULT_MAX_DEPTH);
+const DEFAULT_MAX_DEPTH: usize = 250_000;
+
+pub fn stack_segment() -> usize {
+    STACK_SEGMENT.load(Ordering::Relaxed)
+}
+
+pub fn set_stack_segment(levels: usize) {
+    STACK_SEGMENT.store(levels, Ordering::Relaxed);
+}
+
+pub fn max_depth() -> usize {
+    MAX_DEPTH.load(Ordering::Relaxed)
+}
+
+pub fn set_max_depth(levels: usize) {
+    MAX_DEPTH.store(levels, Ordering::Relaxed);
+}
+
+/// The nesting depth of native calls on this thread.
+pub fn depth() -> usize {
+    DEPTH.with(|d| d.get())
+}
+
+pub fn set_depth(depth: usize) {
+    DEPTH.with(|d| d.set(depth));
+}
+
+/// Count one more nesting level and return the new depth, or the
+/// `StackOverflowError` for a recursion past `max_depth`.
+pub fn depth_push() -> Result<usize, HmError> {
+    let depth = depth();
+    let max = max_depth();
+    if max > 0 && depth >= max {
+        return Err(HmError::StackOverflow(format!(
+            "recursion deeper than HaskellMatch.max_depth ({}); use tail calls, defer, or raise the limit",
+            max
+        )));
+    }
+    set_depth(depth + 1);
+    Ok(depth + 1)
+}
+
+/// Undo one `depth_push`.
+pub fn depth_pop() {
+    DEPTH.with(|d| d.set(d.get().saturating_sub(1)));
+}

data/lib/haskell_match/version.rb

@@ -1,5 +1,5 @@
 # frozen_string_literal: true
 
 module HaskellMatch
-  VERSION = "0.1.0"
+  VERSION = "0.2.0"
 end

metadata

@@ -1,7 +1,7 @@
 --- !ruby/object:Gem::Specification
 name: haskell_match
 version: !ruby/object:Gem::Version
-  version: 0.1.0
+  version: 0.2.0
 platform: ruby
 authors:
 - Daniel P. Clark
@@ -9,6 +9,20 @@ bindir: bin
 cert_chain: []
 date: 1980-01-02 00:00:00.000000000 Z
 dependencies:
+- !ruby/object:Gem::Dependency
+  name: fiddle
+  requirement: !ruby/object:Gem::Requirement
+    requirements:
+    - - "~>"
+      - !ruby/object:Gem::Version
+        version: '1.1'
+  type: :runtime
+  prerelease: false
+  version_requirements: !ruby/object:Gem::Requirement
+    requirements:
+    - - "~>"
+      - !ruby/object:Gem::Version
+        version: '1.1'
 - !ruby/object:Gem::Dependency
   name: minitest
   requirement: !ruby/object:Gem::Requirement
@@ -74,8 +88,11 @@ files:
 - ext/haskell_match/src/core/typecheck.rs
 - ext/haskell_match/src/core/types.rs
 - ext/haskell_match/src/lib.rs
+- ext/haskell_match/src/ruby/error.rs
 - ext/haskell_match/src/ruby/mod.rs
+- ext/haskell_match/src/ruby/native.rs
 - ext/haskell_match/src/ruby/runtime.rs
+- ext/haskell_match/src/ruby/state.rs
 - lib/haskell_match.rb
 - lib/haskell_match/binding_plan.rb
 - lib/haskell_match/case_of.rb