haskell_match 0.1.0

data/lib/haskell_match/dsl.rb

@@ -0,0 +1,71 @@
+# frozen_string_literal: true
+
+module HaskellMatch
+  # Mixin providing `fn`, `case_of`, `pattern`, `data` and `hdef`.
+  #
+  #   class Calculator
+  #     extend HaskellMatch::DSL
+  #     include Maybe
+  #
+  #     hdef :or_zero do
+  #       on("Just x")  { |x| x }
+  #       on("Nothing") { 0 }
+  #     end
+  #   end
+  module DSL
+    def fn(name = nil, **options, &definition)
+      HaskellMatch.fn(name, **options, &definition)
+    end
+
+    def case_of(*values, **options, &definition)
+      HaskellMatch.case_of(*values, **options, &definition)
+    end
+
+    def pattern(source = nil, **options, &block)
+      HaskellMatch.pattern(source, **options, &block)
+    end
+
+    def data(decl, **options)
+      HaskellMatch.data(decl, **options)
+    end
+
+    # Define an instance method (when extended onto a class or module) or a
+    # singleton method (when `self` is any other object) by clauses.  Clause
+    # bodies and guards run with `self` set to the receiver.
+    def hdef(name, exhaustive: HaskellMatch.exhaustive, overlapping: HaskellMatch.overlapping,
+             scope: Native::GLOBAL_SCOPE, &definition)
+      raise ArgumentError, "hdef needs a block with on(...) clauses" unless definition
+
+      builder = ClauseBuilder.collect(definition)
+      clauses = builder.clauses
+      matcher, _bodies, _guards = Compiler.compile(name, clauses, exhaustive: exhaustive, overlapping: overlapping,
+                                                                   scope: scope, resolver: builder.constant_resolver)
+      names = matcher.names
+      guards = clauses.map { |c| c.guard.equal?(ClauseBuilder::OTHERWISE) ? nil : c.guard }
+      plans = clauses.each_with_index.map do |c, i|
+        [BindingPlan.adapt(c.body, names[i], i, "body", name),
+         (guards[i] && BindingPlan.adapt(guards[i], names[i], i, "guard", name))]
+      end
+      has_guards = guards.any?
+
+      impl = lambda do |receiver, args|
+        guard_procs = nil
+        if has_guards
+          guard_procs = plans.map do |_, g|
+            next nil unless g
+
+            ->(*vals) { receiver.instance_exec(*vals, &g) }
+          end
+        end
+        index, values = matcher.select_with(args, guard_procs)
+        raise MatchError, "Non-exhaustive patterns in #{name}" if index.nil?
+
+        receiver.instance_exec(*values, &plans[index][0])
+      end
+
+      target = is_a?(Module) ? self : singleton_class
+      target.define_method(name) { |*args| impl.call(self, args) }
+      name
+    end
+  end
+end

data/lib/haskell_match/errors.rb

@@ -0,0 +1,85 @@
+# frozen_string_literal: true
+
+module HaskellMatch
+  # Base class for every error raised by haskell_match.
+  class Error < StandardError; end
+
+  # Raised while compiling patterns (definition time).
+  class CompileError < Error; end
+
+  # Malformed pattern text.
+  class PatternSyntaxError < CompileError
+    # Reformat the native "msg (column N in \"src\")" into a message that
+    # shows the pattern with a caret under the column.
+    def self.with_caret(message)
+      m = message.match(/\A(.*) \(column (\d+) in (".*")\)\z/m)
+      return message unless m
+
+      src = begin
+        eval(m[3]) # rubocop:disable Security/Eval -- a Rust-escaped string literal
+      rescue SyntaxError, StandardError
+        return message
+      end
+      col = m[2].to_i
+      "#{m[1]}\n    #{src}\n    #{' ' * [col - 1, 0].max}^"
+    end
+  end
+
+  # A constructor name that no registered data type declares.
+  class UnknownConstructorError < CompileError; end
+
+  # A constructor applied to the wrong number of arguments.
+  class ArityError < CompileError; end
+
+  # Patterns of different types in the same position.
+  class PatternTypeError < CompileError; end
+
+  # The same variable bound twice in one clause.
+  class DuplicateVariableError < CompileError; end
+
+  # Record pattern problems (unknown field, positional constructor, ...).
+  class FieldError < CompileError; end
+
+  # Malformed `data` declaration.
+  class DataDeclarationError < CompileError; end
+
+  # Clauses of one function with different numbers of arguments.
+  class ClauseArityError < CompileError; end
+
+  # The clauses do not cover every possible value (GHC: -Wincomplete-patterns).
+  class NonExhaustiveError < CompileError
+    attr_reader :missing
+
+    def initialize(message, missing = [])
+      super(message)
+      @missing = missing
+    end
+  end
+
+  # A clause can never be selected (GHC: -Woverlapping-patterns).
+  class RedundantClauseError < CompileError
+    attr_reader :clauses
+
+    def initialize(message, clauses = [])
+      super(message)
+      @clauses = clauses
+    end
+  end
+
+  # Problems with the Ruby side of a definition (bad block parameters, ...).
+  class DefinitionError < CompileError; end
+
+  # Raised at match time.
+  class MatchError < Error; end
+
+  # A value is not of the type the patterns expect (what Haskell's type
+  # checker would have rejected statically).
+  class TypeMismatchError < MatchError; end
+
+  # An irrefutable (`~`) pattern failed to destructure after its clause was
+  # selected.
+  class IrrefutablePatternError < MatchError; end
+
+  # Recursion through compiled functions exceeded `HaskellMatch.max_depth`.
+  class StackOverflowError < Error; end
+end

data/lib/haskell_match/field_types.rb

@@ -0,0 +1,140 @@
+# frozen_string_literal: true
+
+module HaskellMatch
+  # A constructor argument of the wrong type (`HaskellMatch.data` with
+  # `check_types: true`).
+  class FieldTypeError < Error; end
+
+  # Optional run-time checks of the field types written in a `data`
+  # declaration:
+  #
+  #   HaskellMatch.data "Person = Person { name :: String, age :: Int }", check_types: true
+  #   Person.new("Al", "3")   # raises FieldTypeError: field 'age' expects Int, got "3" (String)
+  #
+  # Checks follow the declared Haskell type: `Int`/`Integer` take Integers,
+  # `Double`/`Float` any Numeric, `String` a String (or a list of
+  # characters), `Char` a one-character String, `Bool` true/false, `[a]` any
+  # list (Array, String, LazyList, Enumerator), `(a, b)` an Array of that
+  # size with each element checked, `a -> b` anything callable, a declared
+  # data type (`Maybe a`, `Shape`) a value of that type, any other
+  # capitalised name a Ruby class or module of that name (`Hash`, `Time`,
+  # `MyApp::Money`) when one exists, and a type variable anything.
+  module FieldTypes
+    module_function
+
+    # Wrap `klass`'s constructor so each field is checked against `types`.
+    def install(klass, types, scope)
+      checkers = types.map { |t| checker(t, scope) }
+      return if checkers.all?(&:nil?)
+
+      names = klass.members
+      cname = klass.constructor_name
+      klass.define_method(:initialize) do |**kw|
+        names.each_with_index do |n, i|
+          next unless kw.key?(n)
+
+          check = checkers[i]
+          next if check.nil? || check.call(kw[n])
+
+          raise FieldTypeError,
+                "#{cname}: field '#{n}' expects #{types[i]}, got #{kw[n].inspect} (#{kw[n].class})"
+        end
+        super(**kw)
+      end
+    end
+
+    LIST = ->(v) { v.is_a?(Array) || v.is_a?(String) || v.is_a?(LazyList) || v.is_a?(Enumerator) }
+
+    # A predicate for Haskell type text, or nil when the type is unchecked.
+    def checker(text, scope = Native::GLOBAL_SCOPE)
+      t = strip_parens(text.to_s.strip)
+      return nil if t.empty?
+      return ->(v) { v.respond_to?(:call) } if split_top(t, "->").size > 1
+
+      return ->(v) { v == [] } if t == "()"
+      if t.start_with?("(") && t.end_with?(")")
+        parts = split_top(t[1..-2], ",")
+        if parts.size > 1
+          subs = parts.map { |part| checker(part, scope) }
+          return lambda { |v|
+            v.is_a?(Array) && v.size == subs.size && subs.each_with_index.all? { |c, i| c.nil? || c.call(v[i]) }
+          }
+        end
+      end
+      return LIST if t.start_with?("[") && t.end_with?("]")
+      return nil if t.match?(/\A[a-z]/) # a type variable
+
+      head = t.split(/\s+/).first.sub(/\A!/, "")
+      case head
+      when "Int", "Integer", "Word", "Int8", "Int16", "Int32", "Int64", "Word8", "Word16", "Word32", "Word64", "Natural"
+        ->(v) { v.is_a?(Integer) }
+      when "Double", "Float", "Rational", "Num", "Real", "Fractional"
+        ->(v) { v.is_a?(Numeric) }
+      when "String", "Text"
+        ->(v) { v.is_a?(String) || v.is_a?(Array) || v.is_a?(LazyList) }
+      when "Char"
+        ->(v) { v.is_a?(String) && v.length == 1 }
+      when "Bool"
+        ->(v) { v == true || v == false }
+      when "Symbol"
+        ->(v) { v.is_a?(Symbol) }
+      else
+        mod = HaskellMatch.type_module(head, scope)
+        return ->(v) { mod === v } if mod # rubocop:disable Style/CaseEquality
+
+        const = ruby_constant(head)
+        const.is_a?(Module) ? ->(v) { v.is_a?(const) } : nil
+      end
+    end
+
+    def ruby_constant(name)
+      Object.const_get(name)
+    rescue NameError
+      nil
+    end
+
+    # `(T)` -> `T`, when the parentheses wrap the whole text.
+    def strip_parens(t)
+      while t.start_with?("(") && t.end_with?(")") && split_top(t[1..-2], ",").size == 1 && balanced?(t[1..-2])
+        t = t[1..-2].strip
+      end
+      t
+    end
+
+    def balanced?(t)
+      depth = 0
+      t.each_char do |c|
+        depth += 1 if "([".include?(c)
+        depth -= 1 if ")]".include?(c)
+        return false if depth.negative?
+      end
+      depth.zero?
+    end
+
+    # Split on `sep` at bracket depth zero.
+    def split_top(t, sep)
+      parts = []
+      depth = 0
+      cur = +""
+      i = 0
+      while i < t.length
+        c = t[i]
+        if "([".include?(c)
+          depth += 1
+        elsif ")]".include?(c)
+          depth -= 1
+        end
+        if depth.zero? && t[i, sep.length] == sep && !(sep == "," && i.zero?)
+          parts << cur.strip
+          cur = +""
+          i += sep.length
+          next
+        end
+        cur << c
+        i += 1
+      end
+      parts << cur.strip
+      parts
+    end
+  end
+end

data/lib/haskell_match/function.rb

@@ -0,0 +1,240 @@
+# frozen_string_literal: true
+
+module HaskellMatch
+  # A function defined by pattern-matching clauses.
+  #
+  #   length = HaskellMatch.fn(:length) do
+  #     on("[]")     { 0 }
+  #     on("(_:xs)") { |xs| 1 + length.(xs) }
+  #   end
+  #   length.([1, 2, 3])  # => 3
+  # Returned by {Function#tail} and {Function#defer}: tells the native `call`
+  # to continue with `function` applied to `args`, and (for `defer`) to pass
+  # the eventual result to `continuation`.  The native call keeps pending
+  # continuations on its own stack, so recursion written this way is bounded
+  # by memory rather than by Ruby's VM stack.
+  TailCall = Data.define(:function, :args, :continuation)
+
+  class Function < Native::Matcher
+    attr_reader :clauses
+
+    # Request a tail call: `recur.tail(n - 1, acc * n)` as the last
+    # expression of a clause body re-enters the function (or any other
+    # function) in constant stack space, like a tail call in Haskell.
+    def tail(*args)
+      TailCall.new(self, args, nil)
+    end
+
+    # Request a non-tail call whose result the block will receive:
+    # `length.defer(xs) { |n| 1 + n }` stands for `1 + length xs` and runs
+    # with the pending work kept off Ruby's stack, however deep it goes.
+    def defer(*args, &continuation)
+      raise ArgumentError, "defer needs a block to receive the result" unless continuation
+
+      TailCall.new(self, args, continuation)
+    end
+
+    # Build a function from clauses (use {HaskellMatch.fn}).  The native
+    # `new` compiles the patterns; the clause bodies and guards are then
+    # attached as instance variables the native `call` reads on every call.
+    #
+    # With `ractor: true` the clause bodies and guards are made shareable
+    # (`Ractor.make_shareable`), as is the function, so it can be sent to and
+    # called from other Ractors.  In that mode the definition block cannot
+    # call methods of the surrounding object, and local variables captured
+    # by the bodies must already be shareable; recursion goes through the
+    # function's name or `recur`, which work in both modes.
+    #
+    # With `deep: true` the function's `call` is implemented in Ruby (see
+    # {DeepCall}): about 100 ns slower per call, but deep recursion costs a
+    # tenth of the memory and the GC scans a fifth as much.  The default is
+    # {HaskellMatch.deep_by_default}.
+    def self.define(name, builder, exhaustive:, overlapping:, ractor: false, deep: HaskellMatch.deep_by_default,
+                    scope: Native::GLOBAL_SCOPE)
+      clauses = builder.clauses
+      clauses = make_shareable(clauses) if ractor
+      resolver = builder.respond_to?(:constant_resolver) ? builder.constant_resolver : nil
+      f, bodies, guards = Compiler.compile(name.to_s, clauses, exhaustive: exhaustive, overlapping: overlapping,
+                                                             klass: self, scope: scope, resolver: resolver)
+      f.instance_variable_set(:@scope, scope)
+      f.instance_variable_set(:@helpers, builder.helpers.freeze)
+      f.extend(DeepCall.module_for(f.arity)) if deep
+      f.send(:attach, clauses, bodies, guards)
+      builder.define_function(f, name.to_s)
+      Ractor.make_shareable(f) if ractor
+      f
+    end
+
+    def self.make_shareable(clauses)
+      raise DefinitionError, "ractor: true requires Ractor support in this Ruby" unless defined?(Ractor)
+
+      clauses.map do |c|
+        body = Ractor.make_shareable(c.body)
+        guard = if c.guard.nil? || c.guard.equal?(ClauseBuilder::OTHERWISE)
+                  c.guard
+                else
+                  Ractor.make_shareable(c.guard)
+                end
+        Clause.new(c.patterns, guard, body, c.location)
+      end
+    end
+    private_class_method :make_shareable
+
+    # call(*args) is native (or Ruby, in deep mode); these make a Function
+    # behave like a Proc.
+    def [](*args)
+      call(*args)
+    end
+
+    def ===(*args)
+      call(*args)
+    end
+
+    # Whether this function runs in deep mode (see {DeepCall}).
+    def deep?
+      false
+    end
+
+    # A lambda with the function's exact arity.  Built on first use (a
+    # shareable function cannot hold a reference back to itself).
+    def to_proc
+      return ProcBuilder.build(self, arity) if frozen?
+
+      @proc ||= ProcBuilder.build(self, arity)
+    end
+
+    def curry
+      to_proc.curry(arity)
+    end
+
+    # Composition, as for Procs: `(f >> g).(x)` is `g.(f.(x))` and
+    # `(f << g).(x)` is `f.(g.(x))` (Haskell's `g . f` and `f . g`).
+    def >>(other)
+      to_proc >> other
+    end
+
+    def <<(other)
+      to_proc << other
+    end
+
+    # The function as a curried Proc (memoised); what Haskell code receives
+    # when it passes a function as a value.
+    def curried
+      return to_proc if arity == 1
+      return @curried if defined?(@curried) && @curried
+
+      c = to_proc.curry(arity)
+      @curried = c unless frozen?
+      c
+    end
+
+    # Variables bound by each clause, in order.
+    def bindings
+      names
+    end
+
+    # The `where` helper functions defined inside this function, by name.
+    def helpers
+      @helpers || {}
+    end
+
+    # The type scope the patterns were compiled in.
+    def scope
+      @scope || Native::GLOBAL_SCOPE
+    end
+
+    # Human-readable dump of the compiled decision tree.
+    def decision_tree
+      tree
+    end
+
+    def inspect
+      "#<HaskellMatch::Function #{name}/#{arity}>"
+    end
+    alias to_s inspect
+
+    private
+
+    def attach(clauses, bodies, guards)
+      @clauses = clauses.freeze
+      @bodies = bodies.freeze
+      @guards = guards&.freeze
+      @proc = nil
+    end
+
+    # Builds the lambda returned by {Function#to_proc}.  It is created here,
+    # rather than inside the function, so its `self` is this (shareable)
+    # module and `Ractor.make_shareable` accepts it.
+    module ProcBuilder
+      def self.build(function, arity)
+        params = (1..arity).map { |i| "a#{i}" }.join(", ")
+        # a lambda with the function's exact arity
+        eval("->(#{params}) { function.call(#{params}) }", binding, __FILE__, __LINE__) # rubocop:disable Style/EvalWithLocation
+      end
+    end
+  end
+
+  class << self
+    attr_writer :exhaustive, :overlapping
+
+    # Every this many nested calls the next clause body runs in a fresh Fiber
+    # (with its own VM and machine stacks), so plain recursion is bounded by
+    # memory rather than by Ruby's stack size.  0 disables this.
+    def stack_segment
+      Native.stack_segment
+    end
+
+    def stack_segment=(levels)
+      Native.stack_segment = levels
+      DeepCall.segment = Native.stack_segment
+    end
+
+    # Whether functions use deep mode unless told otherwise (default false).
+    attr_writer :deep_by_default
+
+    def deep_by_default
+      @deep_by_default ? true : false
+    end
+
+    # Deepest allowed nesting of calls (0 = unlimited); beyond it
+    # {StackOverflowError} is raised rather than letting a runaway recursion
+    # take all memory.
+    def max_depth
+      Native.max_depth
+    end
+
+    def max_depth=(levels)
+      Native.max_depth = levels
+    end
+
+    # Default policy for non-exhaustive clause sets: :error (Haskell's
+    # behaviour, the default), :warn or :ignore.
+    def exhaustive
+      @exhaustive.nil? ? :error : @exhaustive
+    end
+
+    # Default policy for redundant clauses: :error (default), :warn or :ignore.
+    def overlapping
+      @overlapping.nil? ? :error : @overlapping
+    end
+
+    # Define a function by clauses.  See {Function}.
+    #
+    # Options:
+    # * `exhaustive:`  true/:error (default), :warn, or false/:ignore
+    # * `overlapping:` true/:error (default), :warn, or false/:ignore
+    # * `ractor:`      true to make the function Ractor-shareable (see {Function.define})
+    # * `deep:`        true for Ruby-level body invocation (cheap deep recursion)
+    # * `scope:`       the type scope the patterns resolve constructors in (see {HaskellMatch.new_scope})
+    def fn(name = nil, exhaustive: self.exhaustive, overlapping: self.overlapping, ractor: false,
+           deep: deep_by_default, scope: Native::GLOBAL_SCOPE, &definition)
+      raise ArgumentError, "HaskellMatch.fn needs a block with on(...) clauses" unless definition
+
+      options = { exhaustive: exhaustive, overlapping: overlapping, deep: deep, scope: scope }
+      builder = ClauseBuilder.collect(definition, ractor: ractor, options: options)
+      name ||= "anonymous function at #{definition.source_location&.join(':')}"
+      Function.define(name, builder, exhaustive: exhaustive, overlapping: overlapping, ractor: ractor, deep: deep,
+                                     scope: scope)
+    end
+  end
+end