atomy 0.1.1

data/kernel/patterns.ay

@@ -0,0 +1,256 @@
+namespace(atomy)
+
+module(Atomy::Patterns):
+  export:
+    class(RuntimeClass < Pattern):
+      initialize(@body, @name) := #ok
+
+      construct(g) := do:
+        get(g)
+        @body construct(g)
+        @body compile(g)
+        g send(#name, 0)
+        g send(#new, 2)
+
+      (== b) :=
+        b kind-of?(RuntimeClass) &&
+          @body == b body &&
+          @name == b name
+
+      target(g) :=
+        @body compile(g)
+
+      matches?(g) := do:
+        Atomy const-from-string(g, @name)
+        g swap
+        g kind-of
+
+    class(Predicate < Pattern):
+      initialize(@pattern, @test) := #ok
+
+      construct(g) := do:
+        get(g)
+        @pattern construct(g)
+        @test construct(g)
+        g send(#new, 2)
+
+      (== b) :=
+        b kind-of?(Predicate) &&
+          @pattern == b pattern &&
+          @test == b test
+
+      target(g) := @pattern target(g)
+
+      matches?(g) := do:
+        mismatch = g new-label
+        done = g new-label
+
+        g dup
+        @pattern matches?(g)
+        g gif(mismatch)
+
+        `{ ~@test } bytecode(g)
+        g send(#block, 0)
+        g swap
+        g send(#call-on-instance, 1)
+        g goto(done)
+
+        mismatch set!
+        g pop
+        g push-false
+
+        done set!
+
+      deconstruct(g, locals = Hash new) :=
+        @pattern deconstruct(g, locals)
+
+      local-names := @pattern local-names
+
+      bindings := @pattern bindings
+
+    class(With < Pattern):
+      initialize(@expression, @pattern) := #ok
+
+      construct(g) := do:
+        get(g)
+        @expression construct(g)
+        @pattern construct(g)
+        g send(#new, 2)
+
+      (== b) :=
+        b kind-of?(With) &&
+          @expression == b expression &&
+          @pattern == b pattern
+
+      target(g) := Any new target(g)
+
+      matches?(g) := do:
+        `{ ~@expression } bytecode(g)
+        g send(#block, 0)
+        g swap
+        g send(#call-on-instance, 1)
+        @pattern matches?(g)
+
+      deconstruct(g, locals = Hash new) := do:
+        `{ ~@expression } bytecode(g)
+        g send(#block, 0)
+        g swap
+        g send(#call-on-instance, 1)
+        @pattern deconstruct(g, locals)
+
+      local-names := @pattern local-names
+
+      bindings := @pattern bindings
+
+    class(And < Pattern):
+      initialize(@a, @b) := #ok
+
+      construct(g) := do:
+        get(g)
+        @a construct(g)
+        @b construct(g)
+        g send(#new, 2)
+
+      (== b) :=
+        b kind-of?(And) &&
+          @a == b a &&
+          @b == b b
+
+      target(g) :=
+        @a target(g)
+
+      matches?(g) := do:
+        mismatch = g new-label
+        done = g new-label
+
+        g dup
+        @a matches?(g)
+        g gif(mismatch)
+
+        @b matches?(g)
+        g dup
+        g git(done)
+
+        mismatch set!
+        g pop
+        g push-false
+
+        done set!
+
+      deconstruct(g, locals = Hash new) := do:
+        g dup
+        @a deconstruct(g, locals)
+        @b deconstruct(g, locals)
+
+      local-names := [@a local-names + @b local-names] uniq
+
+    class(Or < Pattern):
+      initialize(@a, @b) := #ok
+
+      construct(g) := do:
+        get(g)
+        @a construct(g)
+        @b construct(g)
+        g send(#new, 2)
+
+      (== b) :=
+        b kind-of?(Or) &&
+          @a == b a &&
+          @b == b b
+
+      target(g) :=
+        @a target(g)
+
+      matches?(g) := do:
+        matched = g new-label
+        done = g new-label
+
+        g dup
+        @a matches?(g)
+        g git(matched)
+
+        @b matches?(g)
+        g dup
+        g gif(done)
+
+        matched set!
+        g pop
+        g push-true
+
+        done set!
+
+      deconstruct(g, locals = #[]) := do:
+        b = g new-label
+        done = g new-label
+
+        g dup
+        g dup
+        @a matches?(g)
+        g gif(b)
+
+        @a deconstruct(g, locals)
+        g pop
+        g goto(done)
+
+        b set!
+        g pop
+        @b deconstruct(g, locals)
+
+        done set!
+
+      local-names := [@a local-names + @b local-names] uniq
+
+
+-- base patterns
+module(Atomy::AST):
+  export:
+    Variable pattern :=
+      Atomy::Patterns::Named new $:
+        @name
+        Atomy::Patterns::Any new
+
+    Primitive pattern :=
+      Atomy::Patterns::Match new(@value)
+
+    List pattern :=
+      Atomy::Patterns::List new $:
+        @elements collect [e]: e to-pattern
+
+    Constant pattern :=
+      Atomy::Patterns::Constant new(self)
+
+    ScopedConstant pattern :=
+      Atomy::Patterns::Constant new(self)
+
+    ToplevelConstant pattern :=
+      Atomy::Patterns::Constant new(self)
+
+    Quote pattern :=
+      Atomy::Patterns::Quote new(@expression)
+
+    Block pattern :=
+      Atomy::Patterns::SingletonClass new(self)
+
+    Particle pattern :=
+      Atomy::Patterns::Particle new(@name to-sym)
+
+    QuasiQuote pattern :=
+      Atomy::Patterns::QuasiQuote new(self)
+
+    Send pattern :=
+      if(@block)
+        then:
+          Atomy::Patterns::Named new $:
+            @method-name
+            @block contents [0] to-pattern
+        else:
+          Atomy::Patterns::Attribute new $:
+            @receiver
+            @method-name
+            @arguments
+
+    String pattern :=
+      Atomy::Patterns::Match new(@value)
+
+    Node pattern :=
+      raise("unknown pattern: " + self inspect)

data/kernel/precision.ay

@@ -0,0 +1,148 @@
+namespace(atomy)
+
+export:
+  module(Atomy::Patterns):
+    -- pattern precision hierarchy, from least precise to most
+    [ [ Any, BlockPass, Splat, Attribute,
+        NamedClass, NamedGlobal, NamedInstance
+      ]
+
+      [Constant, SingletonClass, RuntimeClass]
+
+      [HeadTail]
+
+      [List, QuasiQuote, Particle]
+
+      [Match, Quote]
+    ] each-with-index [ps, i]:
+        ps each [a]:
+          a send(#define-method, #precision):
+            i
+
+    Pattern precision := 0
+
+    Named precision := @pattern precision
+
+    Predicate precision :=
+      @pattern precision + 1
+
+    (a: Pattern) <=> (b: Pattern) :=
+      a precision <=> b precision
+
+    (a: BlockPass) <=> (b: BlockPass) :=
+      a pattern <=> b pattern
+
+    -- if one constant is a subclass of another, it is
+    -- higher precision.
+    (a: Constant) <=> (b: Constant) :=
+      condition:
+        (a ancestors nil? || b ancestors nil?) ->
+          0
+
+        (a ancestors first == b ancestors first) ->
+          0
+
+        b ancestors include?(a ancestors first) ->
+          -1
+
+        a ancestors include?(b ancestors first) ->
+          1
+
+        otherwise ->
+          0
+
+    (a: HeadTail) <=> (b: HeadTail) :=
+      Atomy::Patterns
+        compare([a head, a tail], [b head, b tail])
+
+    (a: List) <=> (b: List) :=
+      Atomy::Patterns
+        compare(a patterns, b patterns)
+
+    (a: Splat) <=> (b: Splat) :=
+      a pattern <=> b pattern
+
+    (a: Default) <=> (b: Default) :=
+      a pattern <=> b pattern
+    (d: Default) <=> (p: Pattern) := d pattern <=> p
+    (p: Pattern) <=> (d: Default) := p <=> d pattern
+
+    (a: Named) <=> (b: Named) :=
+      a pattern <=> b pattern
+    (n: Named) <=> (p: Pattern) :=
+      n pattern <=> p
+    (p: Pattern) <=> (n: Named) :=
+      p <=> n pattern
+
+
+    -- equivalence ignores named patterns
+    (a: Named) =~ (b: Named) :=
+      a pattern =~ b pattern
+    Named =~ (p: Pattern) := pattern =~ p
+    Pattern =~ (n: Named) := (=~ n pattern)
+
+    Any =~ Any := true
+
+    (a: BlockPass) =~ (b: BlockPass) :=
+      a pattern =~ b pattern
+
+    (a: Constant) =~ (b: Constant) :=
+      a constant =~ b constant
+
+    (a: Default) =~ (b: Default) :=
+      a pattern =~ b pattern
+    Default =~ (p: Pattern) := pattern =~ p
+    Pattern =~ (n: Default) := (=~ n pattern)
+
+    (a: HeadTail) =~ (b: HeadTail) :=
+      a head =~ b head && a tail =~ b tail
+
+    (a: List) =~ (b: List) :=
+      a patterns zip(b patterns) all? [[a, b]]:
+        when(a nil? || b nil?):
+          return(false)
+
+        a =~ b
+
+    (a: Match) =~ (b: Match) :=
+      a value == b value
+
+    (a: SingletonClass) =~ (b: SingletonClass) :=
+      a body == b body
+
+    NamedClass =~ NamedClass := true
+
+    NamedGlobal =~ NamedGlobal := true
+
+    NamedInstance =~ NamedInstance := true
+
+    (a: Particle) =~ (b: Particle) :=
+      a value == b value
+
+    (a: QuasiQuote) =~ (b: QuasiQuote) :=
+      -- TODO: go through quotes.
+      a expression == b expression
+
+    (a: Quote) =~ (b: Quote) :=
+      a expression == b expression
+
+    (a: Splat) =~ (b: Splat) :=
+      a pattern =~ b pattern
+
+    (a: Attribute) =~ (b: Attribute) :=
+      a receiver == b receiver &&
+        a name == b name &&
+        a arguments == b arguments
+
+    Pattern =~ Pattern := false
+
+
+    -- helper for comparing aggregate patterns like lists
+    { self } compare(xs, ys) := do:
+      total = 0
+
+      xs zip(ys) [[x, y]]:
+        unless(x nil? || y nil?):
+          total += x <=> y
+
+      total <=> 0

data/kernel/pretty.ay

@@ -0,0 +1,283 @@
+namespace(atomy/pretty)
+
+dynamic(multiline?, false)
+dynamic(context, #top)
+dynamic(colored?, false)
+
+comma-delim(ds) :=
+  hsep(comma punctuate(ds))
+
+ident(n) := text(n [0, 1] + n [1 .. -1] tr("_", "-") gsub("_ns_", "/"))
+
+module(Atomy::AST):
+  Block unamb := pretty
+  ClassVariable unamb := pretty
+  Constant unamb := pretty
+  GlobalVariable unamb := pretty
+  (InlinedBody ? @contents size < 2) unamb := pretty
+  InstanceVariable unamb := pretty
+  List unamb := pretty
+  Particle unamb := pretty
+  Primitive unamb := pretty
+  QuasiQuote unamb := pretty
+  Quote unamb := pretty
+  ScopedConstant unamb := pretty
+  Send unamb :=
+    if(from?(#binary, #send))
+      then: pretty
+      else: Doc parens(pretty)
+  Splice unamb := pretty
+  String unamb := pretty
+  ToplevelConstant unamb := pretty
+  Unary unamb := pretty
+  Unquote unamb := pretty
+  Variable unamb := pretty
+  Node unamb := Doc parens(pretty)
+  _ unamb := pretty
+
+from(*where, &y) :=
+  let(context = where flatten, &y)
+
+from?(*where) :=
+  [^context, where] match:
+    [(a: Array), (b: Array)] ->
+      a any? [x]: b include?(x)
+    [(a: Array), b] ->
+      a include?(b)
+    [a, (b: Array)] ->
+      b include?(a)
+    [a, b] ->
+      a == b
+
+export-to(atomy):
+  String pretty := super colored(#yellow)
+  Integer pretty := super colored(#blue)
+  Float pretty := super colored(#blue)
+  TrueClass pretty := super colored(#green)
+  FalseClass pretty := super colored(#red)
+  NilClass pretty := super colored(#black)
+  Object pretty := Doc text(inspect)
+
+  Object show := pretty render
+
+  Doc pretty := self
+
+  Array pretty :=
+    doc: brackets(comma-delim(self all-pretty))
+
+  Particle pretty := doc:
+    wildcard = [c]:
+      if(c equal?(_undefined))
+        then: '_
+        else: c
+
+    operator? = self message to-s !~ r"^[a-z_]"
+
+    args = self arguments collect(&#(wildcard [_]))
+
+    msg+args =
+      if(operator?)
+        then:
+          text(self message to-s) <+> args first unamb
+        else:
+          ident(self message to-s) <>
+            parens(comma-delim(args all-pretty))
+
+    partial =
+      if(self receiver equal?(_undefined))
+        then:
+          if(operator?)
+            then: parens(msg+args)
+            else: msg+args
+        else: parens(self receiver unamb <+> msg+args)
+
+    text("#") <> partial
+
+  Particle to-s := show
+
+  Symbol pretty := do:
+    s = to-s
+    if(s =~ r"^[\p{Ll}_]([\p{L}\d\p{S}!@#%&*\-_\\:.\/\?])*$"(u))
+      then: Doc text("#") <> Doc ident(s)
+      else: Doc text("#") <> s pretty
+
+  Hash pretty := doc:
+    text("#") <>
+      brackets $:
+        comma-delim $:
+          self to-a collect [[k, v]]:
+            k unamb <+> text("->") <+> v unamb
+
+  module(Atomy::AST):
+    Assign pretty :=
+      from(#assign):
+        doc: @lhs unamb <+> text("=") <+> @rhs unamb
+
+    BinarySend pretty :=
+      from(#binary):
+        doc: @lhs unamb <+> text(@operator) <+> @rhs unamb
+
+    Block pretty :=
+      doc:
+        args =
+          if(@arguments empty?)
+            then: empty
+            else: brackets(from(#list): comma-delim(@arguments all-pretty))
+
+        contents = from(#list): comma-delim(@contents all-pretty)
+        if(from?(#send-block) && from?(#top))
+          then: args <> colon <+> contents
+          else: args <+> lbrace <+> contents <+> rbrace
+
+    BlockPass pretty :=
+      from(#unary):
+        doc: text("&") <> @body unamb
+
+    Class pretty := doc:
+      sub =
+        if(@superclass kind-of?(Primitive) && @superclass value == #nil)
+          then: empty
+          else: text("<") <+> from(#binary): @superclass unamb
+
+      name =
+        @name match:
+          Rubinius::AST::ClassName -> text(@name) name to-s
+          _ -> @name unamb
+
+      body = lbrace <+> semi-delim(@body) expressions <+> rbrace
+
+      text("class") <> text("(") <> name <+> sub <> text(")") <+> body
+
+    ClassVariable pretty := doc: ident(name to-s)
+
+    Constant pretty := doc: text(@identifier)
+
+    Define pretty :=
+      from(#define):
+        doc: @lhs unamb <+> text(":=") <+> @body unamb
+
+    GlobalVariable pretty := doc: ident(name to-s)
+
+    InstanceVariable pretty := doc: ident(name to-s)
+
+    List pretty :=
+      from(#list):
+        doc: brackets(comma-delim(@elements all-pretty))
+
+    Macro pretty := doc:
+      text("macro") <+> parens(@pattern pretty) <+> @body pretty
+
+    Particle pretty := doc: text("#") <> ident(@name)
+
+    Primitive pretty := doc:
+      @value match:
+        -- TODO: glitch with #doc/#onto
+        #"self" -> text("self")
+        #true -> text("true")
+        #false -> text("false")
+        #nil -> text("nil")
+        x -> text(x inspect)
+
+    QuasiQuote pretty :=
+      from(#unary):
+        doc: text("`") <> @expression unamb
+
+    Quote pretty :=
+      from(#unary):
+        doc: text("'") <> @expression unamb
+
+    ScopedConstant pretty :=
+      from(#scoped-constant):
+        doc:
+          @parent unamb <> text("::") <> text(@identifier)
+
+    Send pretty :=
+      doc:
+        block =
+          from(#send-block, ^context):
+            if(@block) then: @block unamb; else: empty
+
+        with-block = [x]:
+          condition:
+            ^multiline? && @block is-a?(Block) -> do:
+              cs = from(#top): vcat(@block contents all-pretty) nest(2)
+              if(from?(#top))
+                then: x <> colon // cs
+                else: x <+> lbrace // cs // rbrace
+
+            from?(#top) && @block is-a?(Block) && @block arguments empty? ->
+              x <> block
+
+            otherwise ->
+              x <+> block
+
+        args =
+          from(#list):
+            if(@arguments empty?)
+              then: empty
+              else: parens(comma-delim(@arguments all-pretty))
+
+        condition:
+          @receiver kind-of?(Primitive) && @receiver value == #"self" ->
+            with-block [ident(@method-name) <> args]
+
+          otherwise ->
+            with-block [
+              from(#send) { @receiver unamb } <+>
+                ident(@method-name) <> args
+            ]
+
+    Splice pretty :=
+      from(#unary):
+        doc: text("~*") <> @expression unamb
+
+    String pretty := Doc text(@value inspect)
+
+    ToplevelConstant pretty := doc: text("::") <> text(@identifier)
+
+    Unary pretty :=
+      from(#unary):
+        doc: text(@operator) <> @receiver unamb
+
+    Unquote pretty :=
+      from(#unary):
+        doc: text("~") <> @expression unamb
+
+    Variable pretty := doc: ident(@name)
+
+    InlinedBody pretty := doc:
+      if(^multiline?)
+        then:
+          from(#top): vcat(@expressions all-pretty)
+        else:
+          from(#list): comma-delim(@expressions all-pretty)
+
+    Or pretty := `(~@a || ~@b) pretty
+
+    And pretty := `(~@a && ~@b) pretty
+
+    Ensure pretty := doc:
+      @body pretty <+> text("ensuring:") <+> @ensure pretty
+
+
+Array all-pretty := collect [x]: x pretty
+
+Doc colored(color) := do:
+  -- only makes sense to colorize if we're outputting to a terminal
+  unless(^output-port tty? && ^colored?):
+    return(self)
+
+  codes =
+    [ #black
+      #red
+      #green
+      #yellow
+      #blue
+      #magenta
+      #cyan
+      #white
+    ] zip((0 .. 7) to-a)
+
+  hash = Hash [codes]
+
+  Doc text("\e[9" + hash [color] to-s + "m") <> self <> Doc text("\e[0m")