diff --git a/atomo.cabal b/atomo.cabal
--- a/atomo.cabal
+++ b/atomo.cabal
@@ -1,5 +1,5 @@
name: atomo
-version: 0.3
+version: 0.4
synopsis: A highly dynamic, extremely simple, very fun programming
language.
description:
@@ -13,10 +13,12 @@
Neat stuff: first-class continuations, very metaprogramming and DSL
-friendly, message-passing concurrency, pattern-matching.
.
- Documentation:
+ Release Notes:
.
- Examples:
+ Documentation:
.
+ Examples:
+ .
IRC Channel:
homepage: http://atomo-lang.org/
license: BSD3
@@ -35,14 +37,23 @@
data-files: prelude/*.atomo
source-repository head
- type: hg
- location: http://bitbucket.org/alex/atomo
+ type: darcs
+ location: http://darcsden.com/alex/atomo
+flag lib
+ description: Install the Atomo library.
+ default: False
+
library
+ if !flag(lib)
+ buildable: False
+
hs-source-dirs: src
build-depends:
+ array,
base >= 4 && < 5,
+ bytestring,
containers,
directory,
filepath,
@@ -51,6 +62,7 @@
mtl,
parsec >= 3.0.0,
pretty,
+ regex-pcre,
template-haskell,
text >= 0.11.0.0,
time,
@@ -60,17 +72,21 @@
Atomo,
Atomo.Core,
Atomo.Environment,
+ Atomo.Format,
+ Atomo.Format.Parser,
+ Atomo.Format.Types,
Atomo.Helpers,
Atomo.Load,
+ Atomo.Lexer,
+ Atomo.Lexer.Base,
+ Atomo.Lexer.Primitive,
Atomo.Method,
Atomo.Parser,
Atomo.Parser.Base,
Atomo.Parser.Expr,
Atomo.Parser.Expand,
- Atomo.Parser.Primitive,
Atomo.Pattern,
Atomo.Pretty,
- Atomo.PrettyVM,
Atomo.QuasiQuotes,
Atomo.Run,
Atomo.Spawn,
@@ -97,7 +113,10 @@
Atomo.Kernel.Time,
Atomo.Kernel.Environment,
Atomo.Kernel.Continuation,
- Atomo.Kernel.Char,
+ Atomo.Kernel.Character,
+ Atomo.Kernel.Regexp,
+ Atomo.Kernel.Pretty,
+ Atomo.Kernel.Format,
Paths_atomo
@@ -107,10 +126,11 @@
ghc-prof-options: -prof -auto-all -caf-all
ghc-options: -Wall -threaded -fno-warn-unused-do-bind
- -funfolding-use-threshold=9999
build-depends:
+ array,
base >= 4 && < 5,
+ bytestring,
containers,
directory,
filepath,
@@ -120,6 +140,7 @@
mtl,
parsec >= 3.0.0,
pretty,
+ regex-pcre,
template-haskell,
text >= 0.11.0.0,
time,
diff --git a/prelude/association.atomo b/prelude/association.atomo
--- a/prelude/association.atomo
+++ b/prelude/association.atomo
@@ -1,8 +1,12 @@
Association = Object clone
a -> b := Association clone do: { from = a; to = b }
-(a: Association) show :=
- a from show .. " -> " .. a to show
+(a: Association) pretty :=
+ { a from pretty-parens <+> text: "->" <+> a to pretty-parens
+ } doc
+
+(a: Association) == (b: Association) :=
+ a from == b from && a to == b to
[] lookup: _ := @none
(a . as) lookup: k :=
diff --git a/prelude/block.atomo b/prelude/block.atomo
--- a/prelude/block.atomo
+++ b/prelude/block.atomo
@@ -15,7 +15,7 @@
n = start
while: { (n - diff - end) abs >= diff abs } do: {
- b call: [n]
+ b call: n
n = n + diff
}
} call/cc
diff --git a/prelude/boolean.atomo b/prelude/boolean.atomo
--- a/prelude/boolean.atomo
+++ b/prelude/boolean.atomo
@@ -1,4 +1,5 @@
-@no-true-branches describe-error := "no tests in condition: block were true"
+@no-true-branches describe-error :=
+ "no tests in condition: block were true"
False and: _ := False
True and: (b: Block) := b call
@@ -39,7 +40,7 @@
{ (cc yield: @ok) unless: test call
a call
} repeat
- } call/cc: [action in-context]
+ } call/cc: action in-context
(action: Block) while: (test: Block) :=
{ action in-context call
@@ -51,15 +52,12 @@
{ (cc yield: @ok) when: test call
a call
} repeat
- } call/cc: [action in-context]
+ } call/cc: action in-context
(action: Block) until: (test: Block) :=
{ action in-context call
until: test do: action
} call
-
-True show := "True"
-False show := "False"
otherwise := True
diff --git a/prelude/class-objects.atomo b/prelude/class-objects.atomo
new file mode 100644
--- /dev/null
+++ b/prelude/class-objects.atomo
@@ -0,0 +1,75 @@
+for-macro *modules* = []
+
+macro (module: (def: Dispatch))
+ { name = def names head
+ body = def targets at: 1
+ add-module: name as: body contents
+ body
+ '@ok
+ } call
+
+for-macro add-module: (name: String) as: (body: List) :=
+ super *modules* = *modules* set: name to: body
+
+macro (target include: (name: Dispatch))
+ include: name name on: target
+
+for-macro include: (name: String) on: target :=
+ *modules* (lookup: name) match: {
+ @none -> error: @(unknown-module: name)
+
+ @(ok: mod) ->
+ { block =
+ `Block new: (expand-body: mod on: `!top)
+ arguments: [`!top]
+
+ `(~target join: ~block with: ~target)
+ } call
+ }
+
+for-macro expand-body: (exprs: List) on: target :=
+ exprs map: { e | expand-expr: e on: target }
+
+for-macro expand-expr: `(~name := ~body) on: target :=
+ { with-me =
+ `Dispatch new: name particle
+ to: (name targets at: 0 put: `(me: { ~target }))
+ &optionals: name optionals
+
+ if: (initializer?: name particle)
+ then: { `(~with-me := ~target clone do: ~body) }
+ else: { `(~with-me := me join: { ~body }) }
+ } call
+
+for-macro expand-expr: `(include: ~(y: Dispatch)) on: target :=
+ include: y name on: target
+
+for-macro expand-expr: e on: _ := e
+
+for-macro initializer?: (name: Particle) :=
+ name type match: {
+ @single -> name == @new
+
+ @keyword ->
+ name names head == "new" ||
+ name names head starts-with?: "new."
+ }
+
+macro (class: (b: Block) &extends: Object)
+ `(~(class-create: b contents) call: ~extends clone)
+
+for-macro class-create: (body: List) :=
+ `Block new: (`(me = !o) . (expand-body: body on: `!o) .. [`!o])
+ arguments: [`!o]
+
+macro (class: (c: Dispatch))
+ { single = Particle new: c names head
+ name = `Dispatch new: single to: ['this]
+ body = c targets at: 1
+ pretty = `(pretty := Pretty text: ~(single name))
+ new = `Block new: (pretty . body contents)
+
+ `(if: (responds-to?: ~single)
+ then: { ~(class-create: body contents) call: ~name }
+ else: { ~name = class: ~new } in-context)
+ } call
diff --git a/prelude/comparable.atomo b/prelude/comparable.atomo
--- a/prelude/comparable.atomo
+++ b/prelude/comparable.atomo
@@ -1,5 +1,45 @@
+a matches?: b := a == b
+
+a <=> b :=
+ condition: {
+ a > b -> 1
+ a < b -> -1
+ otherwise -> 0
+ }
+
x max: y :=
if: (x > y) then: { x } else: { y }
x min: y :=
if: (x < y) then: { x } else: { y }
+
+for-macro regexp?: e :=
+ e type match: {
+ @primitive ->
+ (evaluate: e) is-a?: Regexp
+
+ @macro-quote ->
+ e name == "r"
+
+ _ -> False
+ }
+
+macro (x case-of: (bs: Block))
+ { chain = bs contents reduce-right:
+ { `(~test -> ~branch) x |
+ condition: {
+ regexp?: test ->
+ `((~test match: !v) match: {
+ @none -> ~x
+ @(ok: !b) -> !b bindings join: { ~branch }
+ })
+
+ test == '_ -> branch
+
+ otherwise ->
+ `(if: (~test matches?: !v) then: { ~branch } else: { ~x })
+ }
+ } with: '@ok
+
+ `({ !v | ~chain } call: ~x)
+ } call
diff --git a/prelude/condition.atomo b/prelude/condition.atomo
--- a/prelude/condition.atomo
+++ b/prelude/condition.atomo
@@ -1,4 +1,4 @@
-for-macro super Restart = Object clone
+Restart = Object clone
{ define: *handlers* as: []
define: *restarts* as: []
@@ -10,7 +10,7 @@
"!> " display
- Restart (get: read) jump: []
+ Restart (get: read) jump: ()
} call
}
@@ -35,34 +35,39 @@
Simple-Warning new: v :=
Simple-Warning clone (delegating-to: v) do: { value = v }
- (e: Simple-Error) show := ""
- (e: Simple-Warning) show := ""
+ (e: Simple-Error) pretty :=
+ { text: " e value pretty <> text: ">" } doc
+ (e: Simple-Warning) pretty :=
+ { text: " e value pretty <> text: ">" } doc
Restart show-options-for: e :=
- { $- (repeat: 78) print
- e describe-error
- (word-wrap: 74)
- lines
- (map: { l | "*** " .. l })
- unlines
- print
+ { { $- (repeat: 78) print
+ e describe-error
+ (word-wrap: 74)
+ lines
+ (map: { l | "*** " .. l })
+ unlines
+ print
- halt when: *restarts* _? empty?
+ halt when: *restarts* empty?
- "restarts:" print
+ "restarts:" print
- *restarts* _? (zip: (0 .. *restarts* _? length)) map:
- { choice |
- [index, name] = [choice to, choice from from]
- (" :" .. index show .. " -> " .. name name) print
- }
- } call
+ *restarts* (zip: (0 .. *restarts* length) (as: List)) map:
+ { [name, index] |
+ (" :" .. index show .. " -> " .. name from name) print
+ }
+ } call
+ } catch: { e |
+ "UH OH: error while showing error dialogue; dumping:\n " display
+ e dump
+ }
Restart get: (n: Integer) :=
- *restarts* _? (at: n) to
+ *restarts* (at: n) to
Restart new: (a: Block) in: (c: Continuation) :=
- { res = *restarts* _?
+ { res = *restarts*
Restart clone do:
{ jump: as := with: *restarts* as: res do: { c yield: (a call: as) }
action = a
@@ -70,7 +75,8 @@
}
} call
- (r: -> Restart) show := ""
+ (r: -> Restart) pretty :=
+ text: " r action pretty <> text: ">"
macro (action with-restarts: (restarts: Block))
{ rs = restarts contents map:
@@ -84,34 +90,44 @@
`(
{ cc action pairs |
restarts = pairs map:
- { a | a from -> (~Restart new: a to in: cc) }
+ { a | a from -> (Restart new: a to in: cc) }
action with-restarts: restarts
- } call/cc: [~action, ~(`List new: rs)]
+ } call/cc: (~action, ~(`List new: rs))
)
} call
+ macro (action with-restarts: (restarts: Block) bind: (handlers: Block))
+ `({ ~action with-restarts: ~restarts } bind: ~handlers)
+
(action: Block) with-restarts: (restarts: List) :=
modify: *restarts* as: { rs | restarts .. rs } do: action
- (super) signal: v :=
- { *handlers* _? map: { h | h (call: [v]) (call: [v]) }
+ { super } signal: v :=
+ { modify: *handlers* as: @id do: {
+ *handlers* map:
+ { h |
+ *handlers* =! *handlers* tail
+ h (call: v) (call: v)
+ }
+ }
+
@ok
} call
- (super) error: v := error: (Simple-Error new: v)
- (super) error: (e: Error) :=
+ { super } error: v := error: (Simple-Error new: v)
+ { super } error: (e: Error) :=
{ signal: e
- with-output-to: *error-output* _? do: {
- *debugger* _? run: e
+ with-output-to: *error-output* do: {
+ *debugger* run: e
}
} call
- (super) warning: v := warning: (Simple-Warning new: v)
- (super) warning: (w: Warning) :=
+ { super } warning: v := warning: (Simple-Warning new: v)
+ { super } warning: (w: Warning) :=
{ signal: w
- with-output-to: *error-output* _? do: {
+ with-output-to: *error-output* do: {
("WARNING: " .. w describe-error) print
}
@@ -120,10 +136,10 @@
muffle-warning -> @ok
}
- (super) restart: name := restart: name with: []
+ { super } restart: name := restart: name with: ()
- (super) restart: name with: (params: List) :=
- *restarts* _? (lookup: name) match: {
+ { super } restart: name with: params :=
+ *restarts* (lookup: name) match: {
@(ok: r) ->
r jump: params
@@ -131,10 +147,10 @@
error: @(unknown-restart: name)
}
- (super) find-restart: name :=
- *restarts* _? lookup: name
+ { super } find-restart: name :=
+ *restarts* lookup: name
- (super) with-handler: (h: Block) do: (action: Block) :=
+ { super } with-handler: (h: Block) do: (action: Block) :=
modify: *handlers* as: { hs | h . hs } do: action
macro (a bind: (bs: Block))
@@ -149,6 +165,6 @@
`({ h a |
with-handler: h do: a
- } call: [{ #c | super = super; #c match: ~handler }, ~a])
+ } call: ({ !c | super = super; !c match: ~handler }, ~a))
} call
} call
diff --git a/prelude/continuation.atomo b/prelude/continuation.atomo
--- a/prelude/continuation.atomo
+++ b/prelude/continuation.atomo
@@ -1,4 +1,4 @@
(v: Block) before: (b: Block) := v before: b after: { @ok }
(v: Block) after: (a: Block) := v before: { @ok } after: a
(init: Block) wrap: cleanup do: action :=
- { action call: [x] } before: { x = init call } in-context after: { cleanup call: [x] }
+ { action call: x } before: { x = init call } in-context after: { cleanup call: x }
diff --git a/prelude/core.atomo b/prelude/core.atomo
--- a/prelude/core.atomo
+++ b/prelude/core.atomo
@@ -2,7 +2,8 @@
operator right 1 ->
macro (x match: (ts: Block))
- `Match new: (ts contents map: { `(~p -> ~e) | p -> e expand }) on: x expand
+ `Match new: (ts contents map: { `(~p -> ~e) | (p, e) })
+ on: x expand
macro (p = e)
`Set new: p to: e
@@ -25,14 +26,41 @@
`NewDynamic new: [x -> y] do: `(~b call)
macro (with: (bs: List) do: action)
- `NewDynamic new: (bs contents map: { `(~a -> ~b) | a -> b }) do: `(~action call)
+ `NewDynamic new: (bs contents map: { `(~a -> ~b) | a -> b })
+ do: `(~action call)
macro (modify: param as: change do: action)
- `(with: ~param as: (~change call: [~param _?]) do: ~action)
+ `(with: ~param as: (~change call: ~param _?) do: ~action)
-macro (target slurp: filename)
+macro (target slurp: (filename: Primitive))
{ src = File read: (super evaluate: filename)
exprs = src parse-expressions
blk = `Block new: exprs
`(~blk call-in: ~target)
+ } call
+
+for-macro quote: s as: q &flags: [] :=
+ error: @(unknown-quoter: q for: s &flags: flags)
+
+for-macro quote: s as: @r &flags: [] :=
+ Regexp new: s &flags: (flags to: String)
+
+for-macro quote: s as: @w := s words
+
+for-macro quote: s as: @f := Formatter new: s
+
+for-macro quote: s as: @raw := s
+
+macro (a \ (b: Dispatch))
+ { set-head: y to: x :=
+ { head =
+ if: y targets head type (== @top)
+ then: { x }
+ else: { set-head: y targets head to: x }
+
+ `Dispatch new: y particle
+ to: (y targets at: 0 put: head)
+ } call
+
+ set-head: b to: a
} call
diff --git a/prelude/eco.atomo b/prelude/eco.atomo
--- a/prelude/eco.atomo
+++ b/prelude/eco.atomo
@@ -183,14 +183,14 @@
path = Eco path-to: pkg
- pkg contexts = pkg contexts << env super
+ pkg contexts << env super
env load: (path (Eco which-main: path))
pkg environment = env
when: name (in?: Eco loaded (map: @from)) not do:
- { Eco loaded = Eco loaded << (name -> pkg) }
+ { Eco loaded << (name -> pkg) }
env
} call
diff --git a/prelude/enumerable.atomo b/prelude/enumerable.atomo
new file mode 100644
--- /dev/null
+++ b/prelude/enumerable.atomo
@@ -0,0 +1,261 @@
+module: Enumerable: {
+ all?: test :=
+ { return |
+ collect: { v | (return yield: False) when: test (call: v) not }
+ True
+ } call/cc
+
+ any?: test :=
+ { return |
+ collect: { v | (return yield: True) when: test (call: v) not }
+ False
+ } call/cc
+
+ none? := all?: @(/= True)
+ none?: test := (any?: test) not
+
+ one? := count: @(== True) == 1
+ one?: test := count: test == 1
+
+ map: action := collect: action
+
+ count :=
+ { n = 0
+ collect: { super n += 1 }
+ n
+ } call
+
+ count: test :=
+ { n = 0
+ collect: { v | (super n += 1) when: (test in-context call: v) }
+ n
+ } call
+
+ cycle: action :=
+ { collect: { v | action in-context call: v }
+ } repeat
+
+ cycle: action times: (n: Integer) :=
+ { collect: { v | action in-context call: v }
+ } repeat: n
+
+ detect: test :=
+ { return |
+ collect: { v | (return yield: @(ok: v)) when: (test call: v) }
+ @none
+ } call/cc
+
+ detect: test or: default :=
+ { return |
+ collect: { v | (return yield: v) when: (test call: v) }
+ default
+ } call/cc
+
+ find: test := detect: test
+ find: test or: default := detect: test or: default
+
+ find-all: test :=
+ { result = []
+ collect: { v |
+ (super result << v) when: (test call: v)
+ }
+ result
+ } call
+
+ select: test := find-all: test
+ filter: test := find-all: test
+
+ reject: test :=
+ { result = []
+ collect: { v |
+ (super result << v) unless: (test call: v)
+ }
+ result
+ } call
+
+ partition: test :=
+ @(yes: (select: test) no: (reject: test))
+
+ find-index: test :=
+ { return |
+ n = 0
+ collect: { v |
+ (return yield: @(ok: n)) when: (test call: v)
+ super n += 1
+ }
+ @none
+ } call/cc
+
+ find-indices: test :=
+ { return |
+ is = []
+ n = 0
+ collect: { v |
+ (super is << n) when: (test call: v)
+ super n += 1
+ }
+ is
+ } call/cc
+
+ drop: n := (as: List) drop: n
+
+ drop-while: test := (as: List) drop-while: test
+
+ grep: pattern &do: { v | v } :=
+ { result = []
+ collect: { v |
+ (super super result << do call: v) when: (pattern === v)
+ }
+ result
+ } call
+
+ group-by: action :=
+ { result = []
+ collect: { v |
+ res = action call: v
+ result (lookup: res) match: {
+ @none ->
+ (super super result =
+ result set: res to: [v])
+
+ @(ok: vs) ->
+ (super super result =
+ result set: res to: (vs push: v))
+ }
+ }
+ result
+ } call
+
+ include?: v := any?: @(== v)
+ includes?: v := any?: @(== v)
+ member?: v := any?: @(== v)
+ contains?: v := any?: @(== v)
+
+ take: n := (as: List) take: n
+
+ first: n := take: n
+
+ take-while: test :=
+ { done |
+ result = []
+
+ collect: { v |
+ (done yield: result) unless: (test call: v)
+ super result << v
+ }
+
+ result
+ } call/cc
+
+ each: action :=
+ { collect: action in-context
+ me
+ } call
+
+ each-consecutive: n do: action :=
+ { next = me as: List
+ until: { next count < n } do: {
+ cur = next take: n
+ next = next tail
+ action in-context call: cur
+ }
+ me
+ } call
+
+ each-slice: n do: action :=
+ { next = me
+ { cur = next take: n
+ next = next drop: n
+ action in-context call: cur
+ } until: { next empty? }
+ me
+ } call
+
+ each-with-index: action :=
+ { n = 0
+ collect: { v |
+ action in-context call: (v, n)
+ super n += 1
+ }
+ me
+ } call
+
+ reverse-each: action :=
+ { (as: List) reverse each: action
+ me
+ } call
+
+ sort &comparison: @<=> :=
+ (as: List) sort &comparison: comparison
+ sort-by: something &comparison: @<=> :=
+ (as: List) sort-by: something &comparison: comparison
+
+ zip: b &zipper: @id :=
+ (as: List) zip: (b as: List) &zipper: zipper
+
+ first :=
+ { done |
+ collect: { v | done yield: v }
+ error: @empty
+ } call/cc
+
+ reduce: a &initial: @undefined :=
+ { collect: { v |
+ super initial =
+ if: (initial == @undefined)
+ then: { v }
+ else: { a call: (v, initial) }
+ }
+
+ if: (initial == @undefined)
+ then: { error: @empty }
+ else: { initial }
+ } call
+
+ inject: a &initial: @undefined :=
+ reduce: a &initial: initial
+
+ maximum &comparison: @<=> :=
+ reduce: { a b |
+ if: (comparison call: (a, b) > 0)
+ then: { a }
+ else: { b }
+ }
+
+ maximum-by: comparing :=
+ reduce: { a b |
+ if: (comparing call: a <=> comparing call: b > 0)
+ then: { a }
+ else: { b }
+ }
+
+ minimum &comparison: @<=> :=
+ reduce: { a b |
+ if: (comparison call: (a, b) < 0)
+ then: { a }
+ else: { b }
+ }
+
+ minimum-by: comparing :=
+ reduce: { a b |
+ if: (comparing call: a <=> comparing call: b < 0)
+ then: { a }
+ else: { b }
+ }
+
+ minimum-maximum &comparison: @<=> :=
+ @(minimium: (minimum &comparison: comparison)
+ maximum: (maximum &comparison: comparison))
+
+ minimum-maximum-by: comparing :=
+ @(minimum: (minimum-by: comparing)
+ maximum: (maximum-by: comparing))
+
+ as: List :=
+ { list = []
+ collect: { v | super list << v }
+ list
+ } call
+
+ entries := as: List
+}
diff --git a/prelude/errors.atomo b/prelude/errors.atomo
--- a/prelude/errors.atomo
+++ b/prelude/errors.atomo
@@ -11,8 +11,22 @@
] join: "\n"
}
-@(parse-error: d) describe-error :=
- "parse error:\n" .. (d indent: 2)
+@(parse-error: d at: @(source: n line: l column: c)) describe-error :=
+ { explain: x :=
+ x match: {
+ String -> x
+
+ @(unexpected: u) ->
+ "unexpected " .. u
+
+ @(expected: e) ->
+ "expected " .. e
+ }
+
+ [ "parse error (" .. n .. ":" .. l show .. ":" .. c show .. "):"
+ d (map: @(this explain: _)) unlines indent: 2
+ ] join: "\n"
+ } call
@(pattern: p did-not-match: v) describe-error :=
v show .. " did not match pattern: " .. p show
diff --git a/prelude/exception.atomo b/prelude/exception.atomo
--- a/prelude/exception.atomo
+++ b/prelude/exception.atomo
@@ -1,18 +1,18 @@
macro (action handle: (branches: Block))
{ handlers = branches contents map:
- { `(~c -> ~e) | `(~c -> #escape-handle yield: ~e)
+ { `(~c -> ~e) | `(~c -> !escape-handle yield: ~e)
}
- `({ #escape-handle | ~action bind: ~(`Block new: handlers) } call/cc)
+ `({ !escape-handle | ~action bind: ~(`Block new: handlers) } call/cc)
} call
macro (a handle: (b: Block) ensuring: (c: Block))
`({ ~a handle: ~b } ensuring: ~c)
-(action: Block) catch: (recover: Block) :=
+(action: Block) catch: recover :=
{ cc |
action bind: {
- Error -> { e | cc yield: (recover call: [e]) }
+ Error -> { e | cc yield: (recover call: e) }
}
} call/cc
@@ -23,4 +23,4 @@
action after: cleanup
v ensuring: p do: b :=
- { b call: [v] } ensuring: { p call: [v] }
+ { b call: v } ensuring: { p call: v }
diff --git a/prelude/list.atomo b/prelude/list.atomo
--- a/prelude/list.atomo
+++ b/prelude/list.atomo
@@ -1,7 +1,15 @@
@empty-list describe-error := "list is empty"
-(l: -> List) show :=
- "[" .. l (map: @show) (join: ", ") .. "]"
+macro (a << b) `(~a = ~a push: ~b)
+macro (a >> b) `(~b = ~b cons: ~a)
+
+(l: -> List) pretty :=
+ { brackets: (sep: (comma punctuate: (l map: @pretty)))
+ } doc
+
+(t: -> Tuple) pretty :=
+ { parens: (sep: (comma punctuate: (List (new: t) (map: @pretty))))
+ } doc
(l: List) each: (b: Block) :=
{ l map: b in-context
diff --git a/prelude/ordered.atomo b/prelude/ordered.atomo
new file mode 100644
--- /dev/null
+++ b/prelude/ordered.atomo
@@ -0,0 +1,55 @@
+module: Ordered: {
+ succ := shift: 1
+ pred := shift: -1
+
+ shift: diff := from-ordering: (ordering + diff)
+
+ to: x by: diff :=
+ condition: {
+ diff == 0 ->
+ error: @zero-diff
+
+ ((diff < 0 && ordering < x ordering) ||
+ diff > 0 && ordering > x ordering) ->
+ []
+
+ otherwise ->
+ me . ((shift: diff) to: x by: diff)
+ }
+
+ up-to: x := me to: x by: 1
+
+ down-to: x := me to: x by: -1
+}
+
+class: Integer: {
+ include: Ordered
+
+ ordering := me
+ from-ordering: n := n
+}
+
+class: Character: {
+ include: Ordered
+
+ ordering := ord
+ from-ordering: n := n chr
+}
+
+class: Double: {
+ include: Ordered
+
+ ordering := as: Integer
+ from-ordering: n := n as: Double
+
+ shift: (n: Double) := + n
+}
+
+class: Rational: {
+ include: Ordered
+
+ ordering := as: Integer
+ from-ordering: n := n as: Rational
+
+ shift: (n: Rational) := + n
+}
diff --git a/prelude/particle.atomo b/prelude/particle.atomo
--- a/prelude/particle.atomo
+++ b/prelude/particle.atomo
@@ -1,40 +1,53 @@
-(p: -> Particle) show :=
- p type match: {
- @keyword ->
- { operator?: str := str all?: @(in?: "~!@#$%^&*-_=+./\\|<>?:")
+{ operator?: str := str all?: @(in?: "~!@#$%^&*-_=+./\\|<>?:")
- keywordfy: str :=
- if: (operator?: str)
- then: { str }
- else: { str .. ":" }
-
- vs := p values map:
- { v |
- v match:
- { @none -> "_"
- @(ok: v) -> v show
+ keywordfy: str :=
+ if: (operator?: str)
+ then: { Pretty text: str }
+ else: { Pretty text: (str .. ":") }
+
+ slot: @none := Pretty text: "_"
+ slot: @(ok: v) := v pretty
+
+ (p: -> Particle) pretty :=
+ { optionals := hsep:
+ p optionals
+ (map: { o | char: $& <> text: o from name <> colon <+> slot: o to })
+
+ p type match: {
+ @keyword ->
+ { vs := p targets map: { v | slot: v }
+
+ initial :=
+ p targets head match: {
+ @none -> empty
+ @(ok: v) -> v pretty
}
- }
- initial :=
- vs head match: {
- "_" -> ""
- v -> v .. " "
- }
+ rest := hsep:
+ (p names zip: vs tail)
+ (map:
+ { [name, value] |
+ keywordfy: name <+> value
+ })
- rest :=
- (p names zip: vs tail)
- (map:
- { pair |
- keywordfy: pair from .. " " .. pair to
- })
- (join: " ")
+ if: (p targets (all?: @(== @none)) && p optionals empty?)
+ then: { char: $@ <> hcat: (p names map: { n | keywordfy: n }) }
+ else: { char: $@ <> parens: (initial <+> rest <+> optionals) }
+ } call
- if: p values (all?: @(== @none))
- then: { "@" .. p names (map: { n | keywordfy: n }) join }
- else: { "@(" .. initial .. rest .. ")" }
- } call
+ @single ->
+ condition: {
+ (p optionals empty? && p target == @none) ->
+ char: $@ <> text: p name
- @single ->
- ("@" .. p name)
- }
+ p target == @none ->
+ char: $@ <> parens: (text: p name <+> optionals)
+
+ otherwise ->
+ { @(ok: t) = p target
+ char: $@ <> parens: (t pretty <+> text: p name <+> optionals)
+ } call
+ }
+ }
+ } doc
+} call
diff --git a/prelude/ports.atomo b/prelude/ports.atomo
--- a/prelude/ports.atomo
+++ b/prelude/ports.atomo
@@ -18,7 +18,7 @@
String-Port = Port clone
-String-Port show := ""
+String-Port pretty := text: ""
String-Port new := String-Port new: ""
String-Port new: (c: String) :=
@@ -48,7 +48,7 @@
with-output-to: (fn: String) do: b :=
- { Port (new: fn mode: @write) } wrap: @close do:
+ { Port (new: fn &mode: @write) } wrap: @close do:
{ file |
with-output-to: file do: b
}
@@ -57,7 +57,7 @@
with: *output-port* as: p do: b
with-input-from: (fn: String) do: (b: Block) :=
- { Port (new: fn mode: @read) } wrap: @close do:
+ { Port (new: fn &mode: @read) } wrap: @close do:
{ file |
with-input-from: file do: b
}
diff --git a/prelude/pretty.atomo b/prelude/pretty.atomo
new file mode 100644
--- /dev/null
+++ b/prelude/pretty.atomo
@@ -0,0 +1,27 @@
+(b: Block) doc := Pretty clone join: b
+
+Pretty needs-parens?: Block := False
+Pretty needs-parens?: Boolean := False
+Pretty needs-parens?: Character := False
+Pretty needs-parens?: Continuation := False
+Pretty needs-parens?: Double := False
+Pretty needs-parens?: Expression := False
+Pretty needs-parens?: Haskell := False
+Pretty needs-parens?: Integer := False
+Pretty needs-parens?: List := False
+Pretty needs-parens?: Message := False
+Pretty needs-parens?: Method := False
+Pretty needs-parens?: Particle := False
+Pretty needs-parens?: Pattern := False
+Pretty needs-parens?: Process := False
+Pretty needs-parens?: Rational := False
+Pretty needs-parens?: Regexp := False
+Pretty needs-parens?: String := False
+Pretty needs-parens?: Tuple := False
+Pretty needs-parens?: _ := True
+
+x pretty-parens :=
+ { if: (needs-parens?: x)
+ then: { parens: x pretty }
+ else: { x pretty }
+ } doc
diff --git a/prelude/range.atomo b/prelude/range.atomo
new file mode 100644
--- /dev/null
+++ b/prelude/range.atomo
@@ -0,0 +1,56 @@
+class: Range: {
+ include: Enumerable
+
+ new.start: start end: end &exclusive?: False :=
+ { start = start
+ end = end
+ exclusive? = exclusive?
+ }
+
+ == (other: { me }) :=
+ equals?: other || [
+ start == other start
+ end == other end
+ exclusive? == other exclusive?
+ ] and
+
+ matches?: value :=
+ value >= start &&
+ if: exclusive?
+ then: { value < end }
+ else: { value <= end }
+
+ collect: action := step: action
+
+ step: action &size: 1 :=
+ { result = []
+ last = if: exclusive? then: { end pred } else: { end }
+ current = start
+ while: { current <= last } do: {
+ result << action call: current
+ current = current shift: size
+ }
+ result
+ } call
+
+ step &size: 1 :=
+ { result = []
+ last = if: exclusive? then: { end pred } else: { end }
+ current = start
+ while: { current <= last } do: {
+ result << current
+ current = current shift: size
+ }
+ result
+ } call
+
+ pretty :=
+ { if: exclusive?
+ then: { start pretty <+> text: "..." <+> end pretty }
+ else: { start pretty <+> text: ".." <+> end pretty }
+ } doc
+}
+
+x .. y := Range new.start: x end: y
+
+x ... y := Range new.start: x end: y &exclusive?: True
diff --git a/prelude/repl.atomo b/prelude/repl.atomo
--- a/prelude/repl.atomo
+++ b/prelude/repl.atomo
@@ -1,4 +1,8 @@
-{ evaluate-all: [] in: _ := error: @no-expressions
+{ *repl* = this
+
+ incomplete-input = ""
+
+ evaluate-all: [] in: _ := error: @no-expressions
evaluate-all: [e] in: t := t evaluate: e
evaluate-all: (e . es) in: t :=
{ t evaluate: e
@@ -6,11 +10,33 @@
} call
do-input: (s: String) in: env :=
- s parse-expressions match: {
- [] -> @ok
- es -> (evaluate-all: es in: env) show print
- }
+ { parsed =
+ { (incomplete-input .. s) parse-expressions
+ } with-restarts: {
+ incomplete ->
+ { *repl* incomplete-input = incomplete-input .. s .. "\n"
+ []
+ } call
+ } bind: {
+ @(parse-error: (@(unexpected: e) . _) at: _) ->
+ if: (e in?: ["", "ending"])
+ then: { restart: 'incomplete }
+ else: { *repl* incomplete-input = "" }
+ @(parse-error: _ at: _) ->
+ (*repl* incomplete-input = "")
+ }
+
+ parsed match: {
+ [] -> @ok
+
+ es ->
+ { *repl* incomplete-input = ""
+ (evaluate-all: es in: env) show print
+ } call
+ }
+ } call
+
get-value: t :=
(interaction: "enter value: ") parse-expressions match: {
[] -> get-value: t
@@ -28,7 +54,7 @@
{ basic-repl } bind: {
@prompt ->
- restart: 'use-prompt with: ["[!]> "]
+ restart: 'use-prompt with: "[!]> "
@(special: n) ->
when: (n all?: @digit?) do: {
@@ -76,9 +102,14 @@
{ env basic-repl } bind: {
@prompt ->
- restart: 'use-prompt with: ["[" .. frame show .. "]> "]
+ restart: 'use-prompt with: (
+ if: incomplete-input empty?
+ then: { "[" .. frame show .. "]> " }
+ else: { "." .. ($. repeat: frame show length) .. ".. " }
+ )
- @loop -> (super frame = frame + 1)
+ @loop ->
+ (super frame = frame + 1) when: incomplete-input empty?
@(special: "h") ->
":h\thelp" print
diff --git a/prelude/set.atomo b/prelude/set.atomo
new file mode 100644
--- /dev/null
+++ b/prelude/set.atomo
@@ -0,0 +1,24 @@
+target set!: (name: String) to: v :=
+ if: (target has-slot?: name)
+ then: {
+ target set-slot: name to: v
+ v
+ }
+ else: {
+ { done |
+ target delegates map: { d |
+ { d set!: name to: v
+ done yield: v
+ } handle: {
+ @(undefined: _) -> @ok
+ }
+ }
+
+ error: @(undefined: name)
+ } call/cc
+ }
+
+macro ((name: Dispatch) set!: v)
+ { msg = `Dispatch new: name particle to: ['this]
+ `(~(name target) set!: ~(msg name) to: ~v)
+ } call
diff --git a/prelude/string.atomo b/prelude/string.atomo
--- a/prelude/string.atomo
+++ b/prelude/string.atomo
@@ -31,3 +31,27 @@
}
} call
} call
+
+(s: String) plural :=
+ s case-of: {
+ r"o$"i ->
+ s .. "es"
+ r"[aeiou]$"i ->
+ s .. "s"
+ r"(?.+[aeiou])y$"i ->
+ s .. "s"
+ r"(lay-by|stand-by)$"i ->
+ s .. "s"
+ r"(?.+)y$"i ->
+ \root .. "ies"
+ r"(?.+)us$"i ->
+ \root .. "i"
+ r"(?.+)sis$"i ->
+ \root .. "es"
+ r"(?.+)(ex|ix)$"i ->
+ \root .. "ices"
+ r"(?.+)(ss|sh|ch|dge)$"i ->
+ s .. "es"
+ _ ->
+ s .. "s"
+ }
diff --git a/prelude/version.atomo b/prelude/version.atomo
--- a/prelude/version.atomo
+++ b/prelude/version.atomo
@@ -12,8 +12,8 @@
minor = rest
}
-(v: Version) show :=
- v major show .. " . " .. v minor show
+(v: Version) pretty :=
+ v major pretty <+> text: "." <+> v minor pretty
(v: Version) as: String :=
v major show .. "." .. v minor (as: String)
diff --git a/src/Atomo/Core.hs b/src/Atomo/Core.hs
--- a/src/Atomo/Core.hs
+++ b/src/Atomo/Core.hs
@@ -20,10 +20,10 @@
modify $ \e -> e { top = topObj }
-- Lobby is the very bottom scope object
- define (single "Lobby" (PMatch topObj)) (Primitive Nothing topObj)
+ define (single "Lobby" (PMatch topObj)) (EPrimitive Nothing topObj)
-- define Object as the root object
- define (single "Object" (PMatch topObj)) (Primitive Nothing object)
+ define (single "Object" (PMatch topObj)) (EPrimitive Nothing object)
-- create parser environment
parserEnv <- newObject [topObj] noMethods
@@ -41,7 +41,7 @@
number <- newObject [object] noMethods
-- define Object as the root object
- define (single "Number" (PMatch topObj)) (Primitive Nothing number)
+ define (single "Number" (PMatch topObj)) (EPrimitive Nothing number)
-- define primitive objects
forM_ primObjs $ \(n, f) -> do
@@ -50,13 +50,13 @@
then newObject [number] noMethods
else newObject [object] noMethods
- define (single n (PMatch topObj)) (Primitive Nothing o)
+ define (single n (PMatch topObj)) (EPrimitive Nothing o)
modify $ \e -> e { primitives = f (primitives e) o }
where
primObjs =
[ ("Block", \is r -> is { idBlock = r })
, ("Boolean", \is r -> is { idBoolean = r })
- , ("Char", \is r -> is { idChar = r })
+ , ("Character", \is r -> is { idCharacter = r })
, ("Continuation", \is r -> is { idContinuation = r })
, ("Double", \is r -> is { idDouble = r })
, ("Expression", \is r -> is { idExpression = r })
@@ -69,7 +69,9 @@
, ("Process", \is r -> is { idProcess = r })
, ("Pattern", \is r -> is { idPattern = r })
, ("Rational", \is r -> is { idRational = r })
+ , ("Regexp", \is r -> is { idRegexp = r })
, ("String", \is r -> is { idString = r })
+ , ("Tuple", \is r -> is { idTuple = r })
]
diff --git a/src/Atomo/Environment.hs b/src/Atomo/Environment.hs
--- a/src/Atomo/Environment.hs
+++ b/src/Atomo/Environment.hs
@@ -4,44 +4,48 @@
import Control.Monad.Cont
import Control.Monad.State
import Data.IORef
-import Data.List (nub)
import Atomo.Method
import Atomo.Pattern
+import Atomo.Pretty
import Atomo.Types
-- | Evaluate an expression, yielding a value.
eval :: Expr -> VM Value
-eval (Define { emPattern = p, eExpr = ev }) = do
+eval (EDefine { emPattern = p, eExpr = ev }) = do
define p ev
return (particle "ok")
-eval (Set { ePattern = PMessage p, eExpr = ev }) = do
+eval (ESet { ePattern = PMessage p, eExpr = ev }) = do
v <- eval ev
- define p (Primitive (eLocation ev) v)
+ define p (EPrimitive (eLocation ev) v)
return v
-eval (Set { ePattern = p, eExpr = ev }) = do
+eval (ESet { ePattern = p, eExpr = ev }) = do
v <- eval ev
set p v
-eval (Dispatch
- { eMessage = Single
- { mID = i
- , mName = n
- , mTarget = t
- }
- }) = do
+eval (EDispatch { eMessage = Single i n t [] }) = do
v <- eval t
- dispatch (Single i n v)
-eval (Dispatch
- { eMessage = Keyword
- { mID = i
- , mNames = ns
- , mTargets = ts
- }
- }) = do
+ dispatch (Single i n v [])
+eval (EDispatch { eMessage = Single i n t os }) = do
+ v <- eval t
+
+ nos <- forM os $ \(Option oi on oe) -> do
+ ov <- eval oe
+ return (Option oi on ov)
+
+ dispatch (Single i n v nos)
+eval (EDispatch { eMessage = Keyword i ns ts [] }) = do
vs <- mapM eval ts
- dispatch (Keyword i ns vs)
-eval (Operator { eNames = ns, eAssoc = a, ePrec = p }) = do
+ dispatch (Keyword i ns vs [])
+eval (EDispatch { eMessage = Keyword i ns ts os }) = do
+ vs <- mapM eval ts
+
+ nos <- forM os $ \(Option oi on e) -> do
+ ov <- eval e
+ return (Option oi on ov)
+
+ dispatch (Keyword i ns vs nos)
+eval (EOperator { eNames = ns, eAssoc = a, ePrec = p }) = do
forM_ ns $ \n -> modify $ \s ->
s
{ parserState =
@@ -52,21 +56,35 @@
}
return (particle "ok")
-eval (Primitive { eValue = v }) = return v
+eval (EPrimitive { eValue = v }) = return v
eval (EBlock { eArguments = as, eContents = es }) = do
t <- gets top
return (Block t as es)
eval (EList { eContents = es }) = do
vs <- mapM eval es
return (list vs)
+eval (ETuple { eContents = es }) = do
+ vs <- mapM eval es
+ return (tuple vs)
eval (EMacro {}) = return (particle "ok")
eval (EForMacro {}) = return (particle "ok")
-eval (EParticle { eParticle = PMSingle n }) =
- return (Particle $ PMSingle n)
-eval (EParticle { eParticle = PMKeyword ns mes }) = do
- mvs <- forM mes $
+eval (EParticle { eParticle = Single i n mt os }) = do
+ nos <- forM os $ \(Option oi on me) ->
+ liftM (Option oi on)
+ (maybe (return Nothing) (liftM Just . eval) me)
+
+ nmt <- maybe (return Nothing) (liftM Just . eval) mt
+
+ return (Particle $ Single i n nmt nos)
+eval (EParticle { eParticle = Keyword i ns mts os }) = do
+ nmts <- forM mts $
maybe (return Nothing) (liftM Just . eval)
- return (Particle $ PMKeyword ns mvs)
+
+ nos <- forM os $ \(Option oi on me) ->
+ liftM (Option oi on)
+ (maybe (return Nothing) (liftM Just . eval) me)
+
+ return (Particle $ Keyword i ns nmts nos)
eval (ETop {}) = gets top
eval (EVM { eAction = x }) = x
eval (EUnquote { eExpr = e }) = raise ["out-of-quote"] [Expression e]
@@ -79,20 +97,20 @@
r <- eval e
case r of
Expression e' -> return e'
- _ -> return (Primitive Nothing r)
+ _ -> return (EPrimitive Nothing r)
unquote n u@(EUnquote { eExpr = e }) = do
ne <- unquote (n - 1) e
return (u { eExpr = ne })
unquote n q@(EQuote { eExpr = e }) = do
ne <- unquote (n + 1) e
return q { eExpr = ne }
- unquote n d@(Define { eExpr = e }) = do
+ unquote n d@(EDefine { eExpr = e }) = do
ne <- unquote n e
return (d { eExpr = ne })
- unquote n s@(Set { eExpr = e }) = do
+ unquote n s@(ESet { eExpr = e }) = do
ne <- unquote n e
return (s { eExpr = ne })
- unquote n d@(Dispatch { eMessage = em }) =
+ unquote n d@(EDispatch { eMessage = em }) =
case em of
Keyword { mTargets = ts } -> do
nts <- mapM (unquote n) ts
@@ -107,18 +125,21 @@
unquote n l@(EList { eContents = es }) = do
nes <- mapM (unquote n) es
return l { eContents = nes }
+ unquote n t@(ETuple { eContents = es }) = do
+ nes <- mapM (unquote n) es
+ return t { eContents = nes }
unquote n m@(EMacro { eExpr = e }) = do
ne <- unquote n e
return m { eExpr = ne }
unquote n p@(EParticle { eParticle = ep }) =
case ep of
- PMKeyword ns mes -> do
+ Keyword { mNames = ns, mTargets = mes } -> do
nmes <- forM mes $ \me ->
case me of
Nothing -> return Nothing
Just e -> liftM Just (unquote n e)
- return p { eParticle = PMKeyword ns nmes }
+ return p { eParticle = keyword ns nmes }
_ -> return p
unquote n d@(ENewDynamic { eExpr = e }) = do
@@ -130,15 +151,22 @@
unquote n d@(ESetDynamic { eExpr = e }) = do
ne <- unquote n e
return d { eExpr = ne }
- unquote n p@(Primitive { eValue = Expression e }) = do
+ unquote n p@(EPrimitive { eValue = Expression e }) = do
ne <- unquote n e
return p { eValue = Expression ne }
- unquote _ p@(Primitive {}) = return p
+ unquote n m@(EMatch { eTarget = t, eBranches = bs }) = do
+ nt <- unquote n t
+ nbs <- forM bs $ \(p, e) -> do
+ ne <- unquote n e
+ return (p, ne)
+ return m { eTarget = nt, eBranches = nbs }
+ unquote _ p@(EPrimitive {}) = return p
unquote _ t@(ETop {}) = return t
unquote _ v@(EVM {}) = return v
- unquote _ o@(Operator {}) = return o
+ unquote _ o@(EOperator {}) = return o
unquote _ f@(EForMacro {}) = return f
unquote _ g@(EGetDynamic {}) = return g
+ unquote _ q@(EMacroQuote {}) = return q
eval (ENewDynamic { eBindings = bes, eExpr = e }) = do
bvs <- forM bes $ \(n, b) -> do
v <- eval b
@@ -165,7 +193,26 @@
eval (EGetDynamic { eName = n }) = do
mv <- gets (getDynamic n . dynamic)
maybe (raise ["unknown-dynamic"] [string n]) return mv
+eval (EMacroQuote { eName = n, eRaw = r, eFlags = fs }) = do
+ t <- gets (psEnvironment . parserState)
+ dispatch $
+ keyword'
+ ["quote", "as"]
+ [t, string r, particle n]
+ [option "flags" (list (map Character fs))]
+eval (EMatch { eTarget = t, eBranches = bs }) = do
+ v <- eval t
+ ids <- gets primitives
+ matchBranches ids bs v
+matchBranches :: IDs -> [(Pattern, Expr)] -> Value -> VM Value
+matchBranches _ [] v = raise ["no-match-for"] [v]
+matchBranches ids ((p, e):ps) v = do
+ p' <- matchable' p
+ if match ids Nothing p' v
+ then newScope $ set p' v >> eval e
+ else matchBranches ids ps v
+
-- | Evaluate multiple expressions, returning the last result.
evalAll :: [Expr] -> VM Value
evalAll [] = throwError NoExpressions
@@ -190,6 +237,7 @@
return res
+-- | Execute an action with the given dynamic bindings.
dynamicBind :: [(String, Value)] -> VM a -> VM a
dynamicBind bs x = do
modify $ \e -> e
@@ -237,26 +285,19 @@
is <- gets primitives
newp <- matchable p
m <- method newp e
-
- os <-
- case p of
- Keyword { mTargets = (PObject (ETop {}):_) } ->
- targets' is (head (mTargets newp))
-
- _ -> targets is newp
-
+ os <- targets is newp
forM_ os (flip defineOn m)
where
- method p' (Primitive _ v) = return (Slot p' v)
+ method p' (EPrimitive _ v) = return (Slot p' v)
method p' e' = gets top >>= \t -> return (Responder p' t e')
-- | Swap out a reference match with PThis, for inserting on an object.
setSelf :: Value -> Message Pattern -> Message Pattern
-setSelf v (Keyword i ns ps) =
- Keyword i ns (map (setSelf' v) ps)
-setSelf v (Single i n t) =
- Single i n (setSelf' v t)
+setSelf v (Keyword i ns ps os) =
+ Keyword i ns (map (setSelf' v) ps) os
+setSelf v (Single i n t os) =
+ Single i n (setSelf' v t) os
setSelf' :: Value -> Pattern -> Pattern
setSelf' v (PMatch x) | v == x = PThis
@@ -274,7 +315,7 @@
if match is Nothing p v
then do
forM_ (bindings' p v) $ \(p', v') ->
- define p' (Primitive Nothing v')
+ define p' (EPrimitive Nothing v')
return v
else throwError (Mismatch p v)
@@ -294,32 +335,34 @@
matchable' (PObject oe) = liftM PMatch (eval oe)
matchable' (PInstance p) = liftM PInstance (matchable' p)
matchable' (PStrict p) = liftM PStrict (matchable' p)
+matchable' (PVariable p) = liftM PVariable (matchable' p)
matchable' (PNamed n p') = liftM (PNamed n) (matchable' p')
matchable' (PMessage m) = liftM PMessage (matchable m)
matchable' p' = return p'
--- | Find the target objects for a pattern.
+-- | Find the target objects for a message pattern.
targets :: IDs -> Message Pattern -> VM [Value]
-targets is (Single _ _ p) = targets' is p
-targets is (Keyword _ _ ps) = do
- ts <- mapM (targets' is) ps
- return (nub (concat ts))
+targets is (Single { mTarget = p }) = targets' is p
+targets is (Keyword { mTargets = ps }) = targets' is (head ps)
+-- | Find the target objects for a pattern.
targets' :: IDs -> Pattern -> VM [Value]
targets' _ (PMatch v) = liftM (: []) (objectFor v)
targets' is (PNamed _ p) = targets' is p
targets' is PAny = return [idObject is]
targets' is (PList _) = return [idList is]
+targets' is (PTuple _) = return [idTuple is]
targets' is (PHeadTail h t) = do
ht <- targets' is h
tt <- targets' is t
- if idChar is `elem` ht || idString is `elem` tt
+ if idCharacter is `elem` ht || idString is `elem` tt
then return [idList is, idString is]
else return [idList is]
targets' is (PPMKeyword {}) = return [idParticle is]
targets' is (PExpr _) = return [idExpression is]
targets' is (PInstance p) = targets' is p
targets' is (PStrict p) = targets' is p
+targets' is (PVariable _) = return [idObject is]
targets' is (PMessage m) = targets is m
targets' _ p = error $ "no targets for " ++ show p
@@ -336,16 +379,16 @@
-- @\@did-not-understand:@ error is raised.
dispatch :: Message Value -> VM Value
dispatch !m = do
- find <- findFirstMethod m (vs m)
+ find <- findMethod (target m) m
case find of
Just method -> runMethod method m
Nothing ->
- case vs m of
- [v] -> sendDNU v
- _ -> sendDNUs (vs m) 0
+ case m of
+ Single { mTarget = t } -> sendDNU t
+ Keyword { mTargets = ts } -> sendDNUs ts 0
where
- vs (Single { mTarget = t }) = [t]
- vs (Keyword { mTargets = ts }) = ts
+ target (Single { mTarget = t }) = t
+ target (Keyword { mTargets = ts }) = head ts
sendDNU v = do
find <- findMethod v (dnuSingle v)
@@ -369,8 +412,8 @@
[v, Message m]
--- | Find a method on object `o' that responds to `m', searching its
--- delegates if necessary.
+-- | Find a method on an object that responds to a given message, searching
+-- its delegates if necessary.
findMethod :: Value -> Message Value -> VM (Maybe Method)
findMethod v m = do
is <- gets primitives
@@ -380,7 +423,7 @@
Nothing -> findFirstMethod m (oDelegates o)
mt -> return mt
--- | Find the first value that has a method defiend for `m'.
+-- | Find the first value that has a method defiend for a given message.
findFirstMethod :: Message Value -> [Value] -> VM (Maybe Method)
findFirstMethod _ [] = return Nothing
findFirstMethod m (v:vs) = do
@@ -389,7 +432,7 @@
Nothing -> findFirstMethod m vs
_ -> return r
--- | Find a relevant method for message `m' on object `o'.
+-- | Find a method on an object that responds to a given message.
relevant :: IDs -> Value -> (MethodMap, MethodMap) -> Message Value -> Maybe Method
relevant ids o ms m =
lookupMap (mID m) (methods m) >>= firstMatch ids (Just o) m
@@ -415,13 +458,34 @@
runMethod (Slot { mValue = v }) _ = return v
runMethod (Responder { mPattern = p, mContext = c, mExpr = e }) m = do
nt <- newObject [c] (bindings p m, emptyMap)
+
+ forM_ (mOptionals p) $ \(Option i n (PObject oe)) ->
+ case filter (\(Option x _ _) -> x == i) (mOptionals m) of
+ [] -> do
+ d <- withTop nt (eval oe)
+ define (Single i n (PMatch nt) [])
+ (EPrimitive Nothing d)
+ (Option oi on ov:_) ->
+ define (Single oi on (PMatch nt) [])
+ (EPrimitive Nothing ov)
+
withTop nt $ eval e
runMethod (Macro { mPattern = p, mExpr = e }) m = do
t <- gets (psEnvironment . parserState)
nt <- newObject [t] (bindings p m, emptyMap)
+
+ forM_ (mOptionals p) $ \(Option i n (PExpr d)) ->
+ case filter (\(Option x _ _) -> x == i) (mOptionals m) of
+ [] ->
+ define (Single i n (PMatch nt) [])
+ (EPrimitive Nothing (Expression d))
+ (Option oi on ov:_) ->
+ define (Single oi on (PMatch nt) [])
+ (EPrimitive Nothing ov)
+
withTop nt $ eval e
--- | Get the object reference for a value.
+-- | Get the object for a value.
objectFor :: Value -> VM Value
{-# INLINE objectFor #-}
objectFor !v = gets primitives >>= \is -> return $ objectFrom is v
@@ -438,6 +502,7 @@
-- | Convert an AtomoError into a value and raise it as an error.
throwError :: AtomoError -> VM a
+{-throwError e = error ("panic: " ++ show (pretty e))-}
throwError e = gets top >>= \t -> do
r <- dispatch (keyword ["responds-to?"] [t, particle "Error"])
@@ -445,7 +510,7 @@
then do
dispatch (msg t)
error ("panic: error returned normally for: " ++ show e)
- else error ("panic: " ++ show e)
+ else error ("panic: " ++ show (pretty e))
where
msg t = keyword ["error"] [t, asValue e]
diff --git a/src/Atomo/Format.hs b/src/Atomo/Format.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Format.hs
@@ -0,0 +1,338 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Atomo.Format where
+
+import Control.Monad.Identity
+import Control.Monad.RWS
+import Data.Char (intToDigit)
+import Numeric
+import qualified Data.Text as T
+
+import Atomo hiding (p, e)
+import Atomo.Format.Types
+
+
+i2d :: Int -> Char
+i2d x
+ | x >= 0 && x <= 36 = (['0'..'9'] ++ ['a'..'z']) !! x
+ | otherwise = error "radix must be between 0 and 36"
+
+format :: Formatter ()
+format = do
+ fs <- ask
+ case fs of
+ [] -> return ()
+ ((SBreak, ms) : _) | fSymbol ms '.' -> do
+ iter <- gets fsIterating
+ if null iter
+ then modify $ \s -> s { fsStop = True }
+ else local tail format
+ ((SBreak, _) : _) -> do
+ is <- inputs
+ if null is
+ then return ()
+ else local tail format
+ (f : _) -> do
+ process f
+ local tail format
+
+process :: Flagged -> Formatter ()
+process (SChunk s, _) = tell s
+process (SString, ms) = do
+ String s <- input >>= lift . findString
+ justifyL ms s >>= tell
+process (SDecimal, ms) = integer ms showInt
+process (SHex, ms) = integer ms showHex
+process (SOctal, ms) = integer ms showOct
+process (SBinary, ms) = integer ms (showIntAtBase 2 intToDigit)
+process (SRadix, ms) = do
+ n <- orIntegerInput (fPrecision ms)
+ integer ms (showIntAtBase (fromIntegral n) i2d)
+process (SFloat, ms) = float ms showFFloat
+process (SExponent, ms) = float ms showEFloat
+process (SGeneral, ms) = float ms showGFloat
+process (SCharacter, ms) = do
+ Character c <- input >>= lift . findCharacter
+ justifyL ms (T.singleton c) >>= tell
+process (SAsString, ms) = do
+ s <- lift (here "String")
+ i <- input
+ String x <- lift (dispatch (keyword ["as"] [i, s]) >>= findString)
+ justifyL ms x >>= tell
+process (SAny, ms) = do
+ i <- input
+ String x <- lift (dispatch (single "show" i) >>= findString)
+ justifyL ms x >>= tell
+process (SPluralize fs mp, ms) = do
+ w <- censor (const "") (liftM snd (listen (with fs format)))
+ Integer n <-
+ if fSymbol ms '>'
+ then liftM head inputs >>= lift . findInteger
+ else input >>= lift . findInteger
+
+ if n == 1
+ then tell w
+ else do
+
+ case mp of
+ Nothing -> do
+ String p <- lift (dispatch (single "plural" (String w)) >>= findString)
+ tell p
+ Just p ->
+ with p format
+process (SLowercase fs, _) =
+ censor T.toLower (with fs format)
+process (SCapitalize fs, ms) = do
+ mn <- fNumber ms
+ let fn = maybe (map cap) (\n ws -> map cap (take n ws) ++ drop n ws) mn
+ censor (T.unwords . fn . T.words) (with fs format)
+ where
+ cap t = T.toUpper (T.take 1 t) `T.append` (T.toLower (T.drop 1 t))
+process (SUppercase fs, _) =
+ censor T.toUpper (with fs format)
+process (SSkip, ms) = do
+ n <- liftM (maybe 1 id) (fNumber ms)
+ modify $ \fs -> fs
+ { fsPosition = fsPosition fs + (if back then -n else n)
+ }
+ where
+ back = fSymbol ms '<'
+process (SIndirection, ms) = do
+ f <- input
+ fs <- lift (dispatch (single "format" f) >>= fromHaskell)
+ if fSymbol ms '*'
+ then with fs format
+ else do
+
+ is <- input >>= liftM fromList . (lift . findList)
+ old <- get
+ put (startState is)
+ with fs format
+ put old
+process (SIterate fs, ms) = do
+ let rest = fSymbol ms '*'
+
+ is <-
+ if rest
+ then inputs
+ else do
+ i <- input >>= lift . findList
+ return (fromList i)
+
+ ois <- get
+
+ let sub = fSymbol ms '.'
+ alwaysRun = fSymbol ms '+'
+
+ n <- fNumber ms
+
+ if null is && alwaysRun && n /= Just 0
+ then with fs format
+ else do
+
+ case n of
+ Nothing | sub -> do
+ modify $ \s -> s { fsIterating = is }
+ forM_ is $ \i -> do
+ modify $ \s -> s
+ { fsInput = fromList i
+ , fsPosition = 0
+ , fsIterating = tail (fsIterating s)
+ }
+
+ with fs format
+ Nothing -> do
+ setInput is
+ iter
+ Just m -> do
+ setInput is
+ iterMax m
+
+ if rest
+ then modify $ \s -> s
+ { fsPosition = length (fsInput s)
+ }
+ else put ois
+ where
+ iter = do
+ is <- inputs
+ s <- gets fsStop
+ case is of
+ (_:_) | not s -> do
+ with fs format
+ iter
+ _ -> return ()
+
+ iterMax 0 = return ()
+ iterMax n = do
+ is <- inputs
+ s <- gets fsStop
+ case is of
+ (_:_) | not s -> do
+ with fs format
+ iterMax (n - 1)
+ _ -> return ()
+process (SBreak, _) = return ()
+process (SConditional fss md, ms) = do
+ case (fSymbol ms '?', fss) of
+ (True, (t:f:_)) -> do
+ Boolean b <- input >>= lift . findBoolean
+ with (if b then t else f) format
+ (True, (t:_)) -> do
+ Boolean b <- input >>= lift . findBoolean
+ if b
+ then with t format
+ else return ()
+ _ -> do
+ i <- fNumber ms >>= orIntegerInput
+ if i >= length fss
+ then maybe (return ()) (flip with format) md
+ else with (fss !! i) format
+process (SJustify fss, ms) = do
+ ts <- forM fss $ \fs -> censor (const "") $ do
+ (_, o) <- listen (with fs format)
+ return o
+
+ justify ms ts >>= tell
+
+input :: Formatter Value
+input = do
+ i <- inputs
+ case i of
+ [] -> lift (raise' "incomplete-input")
+ (x:_) -> do
+ modify $ \fs -> fs { fsPosition = succ (fsPosition fs) }
+ return x
+
+setInput :: [Value] -> Formatter ()
+setInput vs = modify (\s -> s { fsInput = vs, fsPosition = 0 })
+
+inputs :: Formatter [Value]
+inputs = do
+ i <- get
+ return (drop (fsPosition i) (fsInput i))
+
+orIntegerInput :: Maybe Int -> Formatter Int
+orIntegerInput =
+ maybe
+ (liftM (\(Integer i) -> fromIntegral i) $
+ input >>= lift . findInteger)
+ return
+
+integer :: [Flag] -> (Integer -> String -> String) -> Formatter ()
+integer ms f = do
+ Integer v <- input >>= lift . findInteger
+ justifyR ms (T.pack $ f v "") >>= tell
+
+float :: [Flag] -> (Maybe Int -> Double -> String -> String) -> Formatter ()
+float ms f = do
+ Double v <- input >>= lift . findDouble
+ justifyR ms (T.pack $ f prec v "") >>= tell
+ where
+ prec = fPrecision ms
+
+justifyL :: [Flag] -> T.Text -> Formatter T.Text
+justifyL fs s = do
+ n <- fNumber fs
+ return $
+ case n of
+ Nothing -> s
+ Just w | fSymbol fs '=' || fSymbol fs '<' && fSymbol fs '>' ->
+ T.center w pad s
+ Just w | fSymbol fs '>' ->
+ T.justifyRight w pad s
+ Just w ->
+ T.justifyLeft w pad s
+ where
+ pad | FZeroPad `elem` fs = '0'
+ | otherwise = ' '
+
+justifyR :: [Flag] -> T.Text -> Formatter T.Text
+justifyR fs s = do
+ n <- fNumber fs
+ return $
+ case n of
+ Nothing -> s
+ Just w | fSymbol fs '=' || fSymbol fs '<' && fSymbol fs '>' ->
+ T.center w pad s
+ Just w | fSymbol fs '<' ->
+ T.justifyLeft w pad s
+ Just w ->
+ T.justifyRight w pad s
+ where
+ pad | FZeroPad `elem` fs = '0'
+ | otherwise = ' '
+
+justify :: [Flag] -> [T.Text] -> Formatter T.Text
+justify fs [t] = justifyR fs t
+justify fs ts = do
+ n <- fNumber fs
+ return $
+ case n of
+ Nothing -> T.concat ts
+ Just w -> justifyTo fs w ts
+
+justifyTo :: [Flag] -> Int -> [T.Text] -> T.Text
+justifyTo fs to ts = start ts
+ where
+ need = to - sum (map T.length ts)
+ spacings
+ | fSymbol fs '<' && fSymbol fs '>' || fSymbol fs '=' =
+ length ts + 1
+ | fSymbol fs '<' = length ts
+ | fSymbol fs '>' = length ts
+ | otherwise = length ts - 1
+ naiveAvg = need `div` spacings
+
+ -- special case; e.g. 5 `div` 3 is 1, so we end up with 1|1|3;
+ -- try turning that into 1|2|2
+ --
+ -- to determine this, we see if the leftover space could be reduced
+ -- by adding 1 to the other spacings
+ avg | (need - naiveAvg * spacings) >= (spacings - 1) =
+ naiveAvg + 1
+ | otherwise = naiveAvg
+
+ start [] = T.empty
+ start (w:ws)
+ | fSymbol fs '<' || fSymbol fs '=' = T.concat
+ [ space naiveAvg
+ , w
+ , space avg
+ , spaced (need - naiveAvg - avg) ws
+ ]
+ | otherwise = T.concat
+ [ w
+ , space naiveAvg
+ , spaced (need - naiveAvg) ws
+ ]
+
+ spaced _ [] = T.empty
+ spaced n [w]
+ | fSymbol fs '>' || fSymbol fs '=' = w `T.append` space n
+ | otherwise = space n `T.append` w
+ spaced n (w:ws) = T.concat
+ [ w
+ , space avg
+ , spaced (n - avg) ws
+ ]
+
+ space = flip T.replicate (T.singleton ' ')
+
+fNumber :: [Flag] -> Formatter (Maybe Int)
+fNumber [] = return Nothing
+fNumber (FNumber (Just n):_) = return (Just n)
+fNumber (FNumber Nothing:_) = liftM (Just . length) inputs
+fNumber (_:fs) = fNumber fs
+
+fSymbol :: [Flag] -> Char -> Bool
+fSymbol [] _ = False
+fSymbol (FSymbol x:_) c | x == c = True
+fSymbol (_:fs) c = fSymbol fs c
+
+fPrecision :: [Flag] -> Maybe Int
+fPrecision [] = Nothing
+fPrecision (FPrecision n:_) = return n
+fPrecision (_:fs) = fPrecision fs
+
+with :: [Flagged] -> Formatter a -> Formatter a
+with fs = local (const fs)
diff --git a/src/Atomo/Format/Parser.hs b/src/Atomo/Format/Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Format/Parser.hs
@@ -0,0 +1,212 @@
+module Atomo.Format.Parser where
+
+import Control.Monad
+import Control.Monad.Identity
+import Text.Parsec
+import qualified Data.Text as T
+
+import Atomo.Format.Types
+import Atomo.Lexer.Base (decimal, charEscape)
+
+
+data FParserState =
+ FParserState
+ { fpsInsideOf :: [(SourcePos, Char)] -- delims we're inside of
+ , fpsWaitingFor :: [Char] -- balanced closing delim we're waiting for
+ }
+
+type Parser = ParsecT String FParserState Identity
+
+sChunk :: Parser Segment
+sChunk = liftM (SChunk . T.pack) (many1 cont)
+ where
+ match '{' = '}'
+ match '(' = ')'
+ match '[' = ']'
+ match x = error ("no matching delimiter for " ++ [x])
+
+ cont = do
+ i <- liftM fpsInsideOf getState
+ w <- liftM fpsWaitingFor getState
+ choice $
+ [ try $ do
+ char '\\'
+ oneOf "%{}()[]"
+ , try charEscape
+ , try $ do
+ char '%'
+ newline
+ cont
+ , if not (null w) && not (null i)
+ then try $ do
+ c <- char (head w)
+ if c == snd (head i) -- they opened another; close that one
+ then do
+ modifyState $ \ps -> ps { fpsInsideOf = tail i }
+ return c
+ else fail "end delim"
+ else fail "not inside anything"
+ , do
+ p <- getPosition
+ o <- oneOf "{(["
+ modifyState $ \ps -> ps { fpsInsideOf = (p, match o) : i }
+ return o
+ , noneOf ('%':take 1 w)
+ ]
+
+sString :: Parser Segment
+sString = char 's' >> return SString
+
+sInteger :: Parser Segment
+sInteger = char 'd' >> return SDecimal
+
+sHex :: Parser Segment
+sHex = char 'x' >> return SHex
+
+sOctal :: Parser Segment
+sOctal = char 'o' >> return SOctal
+
+sBinary :: Parser Segment
+sBinary = char 'b' >> return SBinary
+
+sRadix :: Parser Segment
+sRadix = char 'r' >> return SRadix
+
+sFloat :: Parser Segment
+sFloat = char 'f' >> return SFloat
+
+sExponent :: Parser Segment
+sExponent = char 'e' >> return SExponent
+
+sGeneral :: Parser Segment
+sGeneral = char 'g' >> return SGeneral
+
+sCharacter :: Parser Segment
+sCharacter = char 'c' >> return SCharacter
+
+sAsString :: Parser Segment
+sAsString = char 'a' >> return SAsString
+
+sAny :: Parser Segment
+sAny = char 'v' >> return SAny
+
+sPluralize :: Parser Segment
+sPluralize = do
+ char 'p'
+ s <- nested '(' ')'
+ mp <- optionMaybe (nested '(' ')')
+ return (SPluralize s mp)
+
+sLowercase :: Parser Segment
+sLowercase = do
+ char 'l'
+ fs <- nested '(' ')'
+ return (SLowercase fs)
+
+sCharacterOrCapitalize :: Parser Segment
+sCharacterOrCapitalize = do
+ char 'c'
+ cap <- option False (try (lookAhead (char '(' >> return True)))
+ if cap
+ then do
+ fs <- nested '(' ')'
+ return (SCapitalize fs)
+ else return SCharacter
+
+sUppercase :: Parser Segment
+sUppercase = do
+ char 'u'
+ fs <- nested '(' ')'
+ return (SUppercase fs)
+
+sSkip :: Parser Segment
+sSkip = char '_' >> return SSkip
+
+sIndirection :: Parser Segment
+sIndirection = char '%' >> return SIndirection
+
+sIterate :: Parser Segment
+sIterate = do
+ fs <- nested '{' '}'
+ return (SIterate fs)
+
+sBreak :: Parser Segment
+sBreak = char '^' >> return SBreak
+
+sConditional :: Parser Segment
+sConditional = do
+ fss <- many1 (nested '[' ']')
+ md <- optionMaybe (nested '(' ')')
+ return (SConditional fss md)
+
+sJustify :: Parser Segment
+sJustify = do
+ char 'j'
+ fss <- many1 (nested '(' ')')
+ return (SJustify fss)
+
+fChunk :: Parser Flagged
+fChunk = liftM (flip (,) []) sChunk
+
+fFlagged :: Parser Flagged
+fFlagged = do
+ char '%'
+ ms <- modifiers
+ s <- segment
+ return (s, ms)
+
+segment :: Parser Segment
+segment = choice
+ [ sString
+ , sInteger
+ , sHex
+ , sOctal
+ , sBinary
+ , sRadix
+ , sFloat
+ , sExponent
+ , sGeneral
+ , sCharacterOrCapitalize
+ , sAsString
+ , sAny
+ , sPluralize
+ , sLowercase
+ , sUppercase
+ , sSkip
+ , sIndirection
+ , sIterate
+ , sBreak
+ , sConditional
+ , sJustify
+ ]
+
+modifiers :: Parser [Flag]
+modifiers = do
+ many $ choice
+ [ char '#' >> return (FNumber Nothing)
+ , try $ do
+ char '0'
+ lookAhead ((char '.' >> decimal) <|> decimal)
+ return FZeroPad
+ , try $ do
+ char '.'
+ i <- decimal
+ return (FPrecision (fromIntegral i))
+ , do
+ i <- decimal
+ return (FNumber (Just $ fromIntegral i))
+ , liftM FSymbol (oneOf ".+*=<>,?")
+ ]
+
+parser :: Parser [Flagged]
+parser = many1 (choice [fFlagged, fChunk])
+
+-- grab text between characters, balanced
+nested :: Char -> Char -> Parser [Flagged]
+nested o c = do
+ char o
+ modifyState $ \ps -> ps { fpsWaitingFor = c : fpsWaitingFor ps }
+ fs <- option [] parser
+ char c
+ modifyState $ \ps -> ps { fpsWaitingFor = tail (fpsWaitingFor ps) }
+ return fs
diff --git a/src/Atomo/Format/Types.hs b/src/Atomo/Format/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Format/Types.hs
@@ -0,0 +1,165 @@
+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, TypeSynonymInstances #-}
+module Atomo.Format.Types where
+
+import Control.Monad.RWS
+import Data.Typeable
+import Text.PrettyPrint
+import qualified Data.Text as T
+
+import Atomo.Pretty
+import Atomo.Types
+
+
+-- | The core types of formats to use.
+data Segment
+ -- | Arbitrary text.
+ = SChunk T.Text
+
+ -- | %s
+ | SString
+
+ -- | %d
+ | SDecimal
+
+ -- | %x
+ | SHex
+
+ -- | %o
+ | SOctal
+
+ -- | %b
+ | SBinary
+
+ -- | %r
+ | SRadix
+
+ -- | %f
+ | SFloat
+
+ -- | %e
+ | SExponent
+
+ -- | %g
+ | SGeneral
+
+ -- | %c
+ | SCharacter
+
+ -- | %a
+ | SAsString
+
+ -- | %v
+ | SAny
+
+ -- | %p(...)
+ | SPluralize [Flagged] (Maybe [Flagged])
+
+ -- | %l(...)
+ | SLowercase [Flagged]
+
+ -- | %c(...)
+ | SCapitalize [Flagged]
+
+ -- | %u(...)
+ | SUppercase [Flagged]
+
+ -- | %_
+ | SSkip
+
+ -- | %%
+ | SIndirection
+
+ -- | %{...}
+ | SIterate [Flagged]
+
+ -- | %^
+ | SBreak
+
+ -- | %[...]+(...)? where + = one or more and ? = optional (the default)
+ | SConditional [[Flagged]] (Maybe [Flagged])
+
+ -- | %j(...)+ where + = one or more
+ | SJustify [[Flagged]]
+ deriving (Show, Typeable)
+
+-- Various modifiers, for our segments.
+data Flag
+ -- | FNumber
+ -- The Maybe is Nothing if they used #, in which case we use the number
+ -- of remaining values.
+ = FNumber (Maybe Int)
+
+ -- | FSome symbol presumeably known by the segment.
+ | FSymbol Char
+
+ -- | FUsed by %f and %d
+ | FZeroPad
+
+ -- | FUsed by %f
+ | FPrecision Int
+ deriving (Eq, Show, Typeable)
+
+data FormatState =
+ FormatState
+ { fsInput :: [Value]
+ , fsPosition :: Int
+ , fsStop :: Bool
+ , fsIterating :: [Value]
+ }
+
+type Flagged = (Segment, [Flag])
+
+type FormatterT = RWST Format T.Text FormatState
+
+type Formatter = FormatterT VM
+
+type Format = [Flagged]
+
+instance Pretty Format where
+ prettyFrom _ fs = hcat (map pretty fs)
+
+instance Pretty Flagged where
+ prettyFrom _ (SChunk s, _) = text (T.unpack (T.replace "\"" "\\\"" s))
+ prettyFrom _ (s, fs) = char '%' <> hcat (map pretty fs) <> pretty s
+
+instance Pretty Flag where
+ prettyFrom _ (FNumber Nothing) = char '#'
+ prettyFrom _ (FNumber (Just n)) = int n
+ prettyFrom _ (FSymbol c) = char c
+ prettyFrom _ FZeroPad = char '0'
+ prettyFrom _ (FPrecision n) = char '.' <> int n
+
+instance Pretty Segment where
+ prettyFrom _ (SChunk _) = error "pretty-printing a Chunk segment"
+ prettyFrom _ SString = char 's'
+ prettyFrom _ SDecimal = char 'd'
+ prettyFrom _ SHex = char 'x'
+ prettyFrom _ SOctal = char 'o'
+ prettyFrom _ SBinary = char 'b'
+ prettyFrom _ SRadix = char 'r'
+ prettyFrom _ SFloat = char 'f'
+ prettyFrom _ SExponent = char 'e'
+ prettyFrom _ SGeneral = char 'g'
+ prettyFrom _ SCharacter = char 'c'
+ prettyFrom _ SAsString = char 'a'
+ prettyFrom _ SAny = char 'v'
+ prettyFrom _ (SPluralize s Nothing) = char 'p' <> parens (pretty s)
+ prettyFrom _ (SPluralize s (Just p)) =
+ char 'p' <> parens (pretty s) <> parens (pretty p)
+ prettyFrom _ (SLowercase fs) = char 'l' <> parens (pretty fs)
+ prettyFrom _ (SCapitalize fs) = char 'c' <> parens (pretty fs)
+ prettyFrom _ (SUppercase fs) = char 'u' <> parens (pretty fs)
+ prettyFrom _ SSkip = char '_'
+ prettyFrom _ SIndirection = char '%'
+ prettyFrom _ (SIterate fs) = braces (pretty fs)
+ prettyFrom _ SBreak = char '^'
+ prettyFrom _ (SConditional bs Nothing) =
+ hcat (map (brackets . pretty) bs)
+ prettyFrom _ (SConditional bs (Just d)) =
+ hcat (map (brackets . pretty) bs) <> parens (pretty d)
+ prettyFrom _ (SJustify fs) =
+ char 'j' <> hcat (map (parens . pretty) fs)
+
+
+startState :: [Value] -> FormatState
+startState vs = FormatState vs 0 False []
diff --git a/src/Atomo/Helpers.hs b/src/Atomo/Helpers.hs
--- a/src/Atomo/Helpers.hs
+++ b/src/Atomo/Helpers.hs
@@ -3,6 +3,7 @@
import Control.Monad.State
import Data.Dynamic
+import Data.Maybe (isNothing)
import qualified Data.Text as T
import qualified Data.Vector as V
@@ -16,11 +17,11 @@
-- | Define a method as an action returning a value.
(=:) :: Message Pattern -> VM Value -> VM ()
-pat =: vm = define pat (EVM Nothing Nothing vm)
+pat =: vm = define pat (EVM Nothing vm)
-- | Set a slot to a given value.
(=::) :: Message Pattern -> Value -> VM ()
-pat =:: v = define pat (Primitive Nothing v)
+pat =:: v = define pat (EPrimitive Nothing v)
-- | Define a method that evaluates e.
(=:::) :: Message Pattern -> Expr -> VM ()
@@ -32,7 +33,7 @@
o <- eval e >>= dispatch . single "clone"
forM_ ss $ \(n, v) ->
- define (single n (PMatch o)) (Primitive Nothing v)
+ define (single n (PMatch o)) (EPrimitive Nothing v)
return o
@@ -69,11 +70,11 @@
| isBoolean v = return v
| otherwise = findValue "Boolean" isBoolean v
--- | `findValue' for `Char'
-findChar :: Value -> VM Value
-findChar v
- | isChar v = return v
- | otherwise = findValue "Char" isChar v
+-- | `findValue' for `Character'
+findCharacter :: Value -> VM Value
+findCharacter v
+ | isCharacter v = return v
+ | otherwise = findValue "Character" isCharacter v
-- | `findValue' for `Continuation'
findContinuation :: Value -> VM Value
@@ -153,12 +154,24 @@
| isObject v = return v
| otherwise = findValue "Object" isObject v
+-- | `findValue' for `Regexp'
+findRegexp :: Value -> VM Value
+findRegexp v
+ | isRegexp v = return v
+ | otherwise = findValue "Regexp" isRegexp v
+
-- | `findValue' for `String'
findString :: Value -> VM Value
findString v
| isString v = return v
| otherwise = findValue "String" isString v
+-- | `findValue' for `Tuple'
+findTuple :: Value -> VM Value
+findTuple v
+ | isTuple v = return v
+ | otherwise = findValue "Tuple" isTuple v
+
-- | Find a String given an expression to evaluate.
getString :: Expr -> VM String
getString e = eval e >>= liftM (fromText . fromString) . findString
@@ -311,8 +324,37 @@
-- | Fill in the empty values of a particle. The number of values missing
-- is expected to be equal to the number of values provided.
-completeKP :: [Maybe Value] -> [Value] -> [Value]
-completeKP [] _ = []
-completeKP (Nothing:mvs') (v:vs') = v : completeKP mvs' vs'
-completeKP (Just v:mvs') vs' = v : completeKP mvs' vs'
-completeKP mvs' vs' = error $ "impossible: completeKP on " ++ show (mvs', vs')
+fillParticle :: [Maybe Value] -> [Option (Maybe Value)] -> [Value] -> ([Value], [Option Value])
+fillParticle = fillParticle' ([], [])
+ where
+ fillParticle' acc [] [] _ = acc
+ fillParticle' (fvs, fos) [] (Option i n (Just v):mos) vs =
+ fillParticle' (fvs, fos ++ [Option i n v]) [] mos vs
+ fillParticle' (fvs, fos) [] (Option i n Nothing:mos) (v:vs) =
+ fillParticle' (fvs, fos ++ [Option i n v]) [] mos vs
+ fillParticle' (fvs, fos) (Just v:mvs) mos vs =
+ fillParticle' (fvs ++ [v], fos) mvs mos vs
+ fillParticle' (fvs, fos) (Nothing:mvs) mos (v:vs) =
+ fillParticle' (fvs ++ [v], fos) mvs mos vs
+ fillParticle' acc mvs mos vs =
+ error $ "impossible: fillParticle' on " ++ show (acc, mvs, mos, vs)
+
+completeParticle :: Particle Value -> [Value] -> VM (Message Value)
+completeParticle (Keyword i ns mts mos) vs
+ | length vs < totalBlanks mts mos =
+ throwError (ParticleArity (totalBlanks mts mos) (length vs))
+ | otherwise = return $ uncurry (Keyword i ns) (fillParticle mts mos vs)
+completeParticle (Single i n mt mos) vs
+ | length vs < totalBlanks [mt] mos =
+ throwError (ParticleArity (totalBlanks [mt] mos) (length vs))
+ | otherwise = return $ Single i n t os
+ where
+ ([t], os) = fillParticle [mt] mos vs
+
+totalBlanks :: [Maybe Value] -> [Option (Maybe Value)] -> Int
+totalBlanks mvs mos
+ = length (filter isNothing mvs)
+ + length (filter (\(Option _ _ mv) -> isNothing mv) mos)
+
+prettyVM :: Value -> VM String
+prettyVM = liftM (fromText . fromString) . dispatch . single "show"
diff --git a/src/Atomo/Kernel.hs b/src/Atomo/Kernel.hs
--- a/src/Atomo/Kernel.hs
+++ b/src/Atomo/Kernel.hs
@@ -19,7 +19,10 @@
import qualified Atomo.Kernel.Time as Time
import qualified Atomo.Kernel.Environment as Environment
import qualified Atomo.Kernel.Continuation as Continuation
-import qualified Atomo.Kernel.Char as Char
+import qualified Atomo.Kernel.Character as Character
+import qualified Atomo.Kernel.Regexp as Regexp
+import qualified Atomo.Kernel.Pretty as Pretty
+import qualified Atomo.Kernel.Format as Format
load :: VM ()
load = do
@@ -39,4 +42,7 @@
Time.load
Environment.load
Continuation.load
- Char.load
+ Character.load
+ Regexp.load
+ Pretty.load
+ Format.load
diff --git a/src/Atomo/Kernel/Block.hs b/src/Atomo/Kernel/Block.hs
--- a/src/Atomo/Kernel/Block.hs
+++ b/src/Atomo/Kernel/Block.hs
@@ -2,6 +2,8 @@
{-# OPTIONS -fno-warn-name-shadowing #-}
module Atomo.Kernel.Block (load) where
+import qualified Data.Vector as V
+
import Atomo
import Atomo.Method
import Atomo.Pattern (bindings')
@@ -24,12 +26,24 @@
callBlock b []
[$p|(b: Block) repeat|] =: do
- b@(Block c _ _) <- here "b" >>= findBlock
- withTop c (forever (callBlock b []))
+ Block c as es <- here "b" >>= findBlock
- [$p|(b: Block) call: (l: List)|] =: do
+ when (length as > 0) (throwError (BlockArity 0 (length as)))
+
+ withTop c (forever (evalAll es))
+
+ [$p|(b: Block) repeat: (n: Integer)|] =: do
+ Block c as cs <- here "b" >>= findBlock
+
+ when (length as > 0) (throwError (BlockArity 0 (length as)))
+
+ Integer n <- here "n" >>= findInteger
+ vs <- V.replicateM (fromIntegral n) (withTop c (evalAll cs))
+ return $ List vs
+
+ [$p|(b: Block) call: (... args)|] =: do
b <- here "b" >>= findBlock
- vs <- getList [$e|l|]
+ vs <- getList [$e|args|]
callBlock b vs
[$p|(b: Block) call-in: c|] =: do
@@ -54,10 +68,10 @@
b <- here "b" >>= findBlock
joinWith v b []
return v
- [$p|v do: (b: Block) with: (l: List)|] =: do
+ [$p|v do: (b: Block) with: (... args)|] =: do
v <- here "v"
b <- here "b" >>= findBlock
- as <- getList [$e|l|]
+ as <- getList [$e|args|]
joinWith v b as
return v
@@ -65,10 +79,10 @@
v <- here "v"
b <- here "b" >>= findBlock
joinWith v b []
- [$p|v join: (b: Block) with: (l: List)|] =: do
+ [$p|v join: (b: Block) with: (... args)|] =: do
v <- here "v"
b <- here "b" >>= findBlock
- as <- getList [$e|l|]
+ as <- getList [$e|args|]
joinWith v b as
@@ -79,11 +93,11 @@
| null as || null ps =
case t of
- o@(Object { oDelegates = ds }) ->
- withTop (o { oDelegates = ds ++ [s] }) (evalAll bes)
+ Object { oDelegates = ds } ->
+ withTop (t { oDelegates = s:ds }) (evalAll bes)
_ -> do
- blockScope <- newObject [t, s] noMethods
+ blockScope <- newObject [s, t] noMethods
withTop blockScope (evalAll bes)
| otherwise = do
@@ -94,11 +108,11 @@
)
case t of
- o@(Object { oDelegates = ds }) ->
- withTop (o { oDelegates = args : ds ++ [s] })
+ Object { oDelegates = ds } ->
+ withTop (t { oDelegates = args : s : ds })
(evalAll bes)
_ -> do
- blockScope <- newObject [args, t, s] noMethods
+ blockScope <- newObject [args, s, t] noMethods
withTop blockScope (evalAll bes)
joinWith _ v _ = error $ "impossible: joinWith on " ++ show v
diff --git a/src/Atomo/Kernel/Char.hs b/src/Atomo/Kernel/Char.hs
deleted file mode 100644
--- a/src/Atomo/Kernel/Char.hs
+++ /dev/null
@@ -1,79 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-module Atomo.Kernel.Char where
-
-import Data.Char
-
-import Atomo
-
-
-load :: VM ()
-load = do
- [$p|(c: Char) control?|] =: liftM Boolean (onChar isControl)
- [$p|(c: Char) space?|] =: liftM Boolean (onChar isSpace)
- [$p|(c: Char) lower?|] =: liftM Boolean (onChar isLower)
- [$p|(c: Char) upper?|] =: liftM Boolean (onChar isUpper)
- [$p|(c: Char) alpha?|] =: liftM Boolean (onChar isAlpha)
- [$p|(c: Char) alphanum?|] =: liftM Boolean (onChar isAlphaNum)
- [$p|(c: Char) print?|] =: liftM Boolean (onChar isPrint)
- [$p|(c: Char) digit?|] =: liftM Boolean (onChar isDigit)
- [$p|(c: Char) oct-digit?|] =: liftM Boolean (onChar isOctDigit)
- [$p|(c: Char) hex-digit?|] =: liftM Boolean (onChar isHexDigit)
- [$p|(c: Char) letter?|] =: liftM Boolean (onChar isLetter)
- [$p|(c: Char) mark?|] =: liftM Boolean (onChar isMark)
- [$p|(c: Char) number?|] =: liftM Boolean (onChar isNumber)
- [$p|(c: Char) punctuation?|] =: liftM Boolean (onChar isPunctuation)
- [$p|(c: Char) symbol?|] =: liftM Boolean (onChar isSymbol)
- [$p|(c: Char) separator?|] =: liftM Boolean (onChar isSeparator)
- [$p|(c: Char) ascii?|] =: liftM Boolean (onChar isAscii)
- [$p|(c: Char) latin1?|] =: liftM Boolean (onChar isLatin1)
- [$p|(c: Char) ascii-upper?|] =: liftM Boolean (onChar isAsciiLower)
- [$p|(c: Char) ascii-lower?|] =: liftM Boolean (onChar isAsciiUpper)
-
- [$p|(c: Char) uppercase|] =: liftM Char (onChar toUpper)
- [$p|(c: Char) lowercase|] =: liftM Char (onChar toLower)
- [$p|(c: Char) titlecase|] =: liftM Char (onChar toTitle)
-
- [$p|(c: Char) from-digit|] =: liftM (Integer . fromIntegral) (onChar digitToInt)
- [$p|(i: Integer) to-digit|] =: liftM Char (onInteger (intToDigit . fromIntegral))
-
- [$p|(c: Char) ord|] =: liftM (Integer . fromIntegral) (onChar ord)
- [$p|(i: Integer) chr|] =: liftM Char (onInteger (chr . fromIntegral))
-
- [$p|(c: Char) category|] =: liftM c (onChar generalCategory)
- where
- onChar :: (Char -> a) -> VM a
- onChar f = here "c" >>= liftM (f . fromChar) . findChar
-
- onInteger :: (Integer -> a) -> VM a
- onInteger f = here "i" >>= liftM (f . Atomo.fromInteger) . findInteger
-
- c UppercaseLetter = keyParticleN ["letter"] [particle "lowercase"]
- c LowercaseLetter = keyParticleN ["letter"] [particle "uppercase"]
- c TitlecaseLetter = keyParticleN ["letter"] [particle "titlecase"]
- c ModifierLetter = keyParticleN ["letter"] [particle "modified"]
- c OtherLetter = keyParticleN ["letter"] [particle "other"]
- c NonSpacingMark = keyParticleN ["mark"] [particle "non-spacing"]
- c SpacingCombiningMark = keyParticleN ["mark"] [particle "space-combining"]
- c EnclosingMark = keyParticleN ["mark"] [particle "enclosing"]
- c DecimalNumber = keyParticleN ["number"] [particle "decimal"]
- c LetterNumber = keyParticleN ["number"] [particle "letter"]
- c OtherNumber = keyParticleN ["number"] [particle "other"]
- c ConnectorPunctuation = keyParticleN ["punctuation"] [particle "connector"]
- c DashPunctuation = keyParticleN ["punctuation"] [particle "dash"]
- c OpenPunctuation = keyParticleN ["punctuation"] [particle "open"]
- c ClosePunctuation = keyParticleN ["punctuation"] [particle "close"]
- c InitialQuote = keyParticleN ["quote"] [particle "initial"]
- c FinalQuote = keyParticleN ["quote"] [particle "final"]
- c OtherPunctuation = keyParticleN ["punctuation"] [particle "other"]
- c MathSymbol = keyParticleN ["symbol"] [particle "math"]
- c CurrencySymbol = keyParticleN ["symbol"] [particle "currency"]
- c ModifierSymbol = keyParticleN ["symbol"] [particle "modifier"]
- c OtherSymbol = keyParticleN ["symbol"] [particle "other"]
- c Space = particle "space"
- c LineSeparator = keyParticleN ["separator"] [particle "line"]
- c ParagraphSeparator = keyParticleN ["separator"] [particle "paragraph"]
- c Control = particle "control"
- c Format = particle "format"
- c Surrogate = particle "surrogate"
- c PrivateUse = particle "private-use"
- c NotAssigned = particle "not-assigned"
diff --git a/src/Atomo/Kernel/Character.hs b/src/Atomo/Kernel/Character.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Character.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.Character where
+
+import Data.Char
+
+import Atomo
+
+
+load :: VM ()
+load = do
+ [$p|(c: Character) control?|] =: liftM Boolean (onCharacter isControl)
+ [$p|(c: Character) space?|] =: liftM Boolean (onCharacter isSpace)
+ [$p|(c: Character) lower?|] =: liftM Boolean (onCharacter isLower)
+ [$p|(c: Character) upper?|] =: liftM Boolean (onCharacter isUpper)
+ [$p|(c: Character) alpha?|] =: liftM Boolean (onCharacter isAlpha)
+ [$p|(c: Character) alphanum?|] =: liftM Boolean (onCharacter isAlphaNum)
+ [$p|(c: Character) print?|] =: liftM Boolean (onCharacter isPrint)
+ [$p|(c: Character) digit?|] =: liftM Boolean (onCharacter isDigit)
+ [$p|(c: Character) oct-digit?|] =: liftM Boolean (onCharacter isOctDigit)
+ [$p|(c: Character) hex-digit?|] =: liftM Boolean (onCharacter isHexDigit)
+ [$p|(c: Character) letter?|] =: liftM Boolean (onCharacter isLetter)
+ [$p|(c: Character) mark?|] =: liftM Boolean (onCharacter isMark)
+ [$p|(c: Character) number?|] =: liftM Boolean (onCharacter isNumber)
+ [$p|(c: Character) punctuation?|] =: liftM Boolean (onCharacter isPunctuation)
+ [$p|(c: Character) symbol?|] =: liftM Boolean (onCharacter isSymbol)
+ [$p|(c: Character) separator?|] =: liftM Boolean (onCharacter isSeparator)
+ [$p|(c: Character) ascii?|] =: liftM Boolean (onCharacter isAscii)
+ [$p|(c: Character) latin1?|] =: liftM Boolean (onCharacter isLatin1)
+ [$p|(c: Character) ascii-upper?|] =: liftM Boolean (onCharacter isAsciiLower)
+ [$p|(c: Character) ascii-lower?|] =: liftM Boolean (onCharacter isAsciiUpper)
+
+ [$p|(c: Character) uppercase|] =: liftM Character (onCharacter toUpper)
+ [$p|(c: Character) lowercase|] =: liftM Character (onCharacter toLower)
+ [$p|(c: Character) titlecase|] =: liftM Character (onCharacter toTitle)
+
+ [$p|(c: Character) from-digit|] =: liftM (Integer . fromIntegral) (onCharacter digitToInt)
+ [$p|(i: Integer) to-digit|] =: liftM Character (onInteger (intToDigit . fromIntegral))
+
+ [$p|(c: Character) ord|] =: liftM (Integer . fromIntegral) (onCharacter ord)
+ [$p|(i: Integer) chr|] =: liftM Character (onInteger (chr . fromIntegral))
+
+ [$p|(c: Character) category|] =: liftM c (onCharacter generalCategory)
+ where
+ onCharacter :: (Char -> a) -> VM a
+ onCharacter f = here "c" >>= liftM (f . fromCharacter) . findCharacter
+
+ onInteger :: (Integer -> a) -> VM a
+ onInteger f = here "i" >>= liftM (f . Atomo.fromInteger) . findInteger
+
+ c UppercaseLetter = keyParticleN ["letter"] [particle "uppercase"]
+ c LowercaseLetter = keyParticleN ["letter"] [particle "lowercase"]
+ c TitlecaseLetter = keyParticleN ["letter"] [particle "titlecase"]
+ c ModifierLetter = keyParticleN ["letter"] [particle "modified"]
+ c OtherLetter = keyParticleN ["letter"] [particle "other"]
+ c NonSpacingMark = keyParticleN ["mark"] [particle "non-spacing"]
+ c SpacingCombiningMark = keyParticleN ["mark"] [particle "space-combining"]
+ c EnclosingMark = keyParticleN ["mark"] [particle "enclosing"]
+ c DecimalNumber = keyParticleN ["number"] [particle "decimal"]
+ c LetterNumber = keyParticleN ["number"] [particle "letter"]
+ c OtherNumber = keyParticleN ["number"] [particle "other"]
+ c ConnectorPunctuation = keyParticleN ["punctuation"] [particle "connector"]
+ c DashPunctuation = keyParticleN ["punctuation"] [particle "dash"]
+ c OpenPunctuation = keyParticleN ["punctuation"] [particle "open"]
+ c ClosePunctuation = keyParticleN ["punctuation"] [particle "close"]
+ c InitialQuote = keyParticleN ["quote"] [particle "initial"]
+ c FinalQuote = keyParticleN ["quote"] [particle "final"]
+ c OtherPunctuation = keyParticleN ["punctuation"] [particle "other"]
+ c MathSymbol = keyParticleN ["symbol"] [particle "math"]
+ c CurrencySymbol = keyParticleN ["symbol"] [particle "currency"]
+ c ModifierSymbol = keyParticleN ["symbol"] [particle "modifier"]
+ c OtherSymbol = keyParticleN ["symbol"] [particle "other"]
+ c Space = particle "space"
+ c LineSeparator = keyParticleN ["separator"] [particle "line"]
+ c ParagraphSeparator = keyParticleN ["separator"] [particle "paragraph"]
+ c Control = particle "control"
+ c Format = particle "format"
+ c Surrogate = particle "surrogate"
+ c PrivateUse = particle "private-use"
+ c NotAssigned = particle "not-assigned"
diff --git a/src/Atomo/Kernel/Comparable.hs b/src/Atomo/Kernel/Comparable.hs
--- a/src/Atomo/Kernel/Comparable.hs
+++ b/src/Atomo/Kernel/Comparable.hs
@@ -22,29 +22,29 @@
[$p|(a: Object) == (b: Object)|] =::: [$e|a equals?: b|]
[$p|(a: Object) /= (b: Object)|] =::: [$e|(a == b) not|]
- [$p|(a: Char) < (b: Char)|] =: do
- Char a <- here "a" >>= findChar
- Char b <- here "b" >>= findChar
+ [$p|(a: Character) < (b: Character)|] =: do
+ Character a <- here "a" >>= findCharacter
+ Character b <- here "b" >>= findCharacter
return $ Boolean (a < b)
- [$p|(a: Char) > (b: Char)|] =: do
- Char a <- here "a" >>= findChar
- Char b <- here "b" >>= findChar
+ [$p|(a: Character) > (b: Character)|] =: do
+ Character a <- here "a" >>= findCharacter
+ Character b <- here "b" >>= findCharacter
return $ Boolean (a > b)
- [$p|(a: Char) <= (b: Char)|] =: do
- Char a <- here "a" >>= findChar
- Char b <- here "b" >>= findChar
+ [$p|(a: Character) <= (b: Character)|] =: do
+ Character a <- here "a" >>= findCharacter
+ Character b <- here "b" >>= findCharacter
return $ Boolean (a <= b)
- [$p|(a: Char) >= (b: Char)|] =: do
- Char a <- here "a" >>= findChar
- Char b <- here "b" >>= findChar
+ [$p|(a: Character) >= (b: Character)|] =: do
+ Character a <- here "a" >>= findCharacter
+ Character b <- here "b" >>= findCharacter
return $ Boolean (a >= b)
- [$p|(a: Char) == (b: Char)|] =: do
- Char a <- here "a" >>= findChar
- Char b <- here "b" >>= findChar
+ [$p|(a: Character) == (b: Character)|] =: do
+ Character a <- here "a" >>= findCharacter
+ Character b <- here "b" >>= findCharacter
return $ Boolean (a == b)
[$p|(a: Integer) < (b: Integer)|] =: primII (<)
@@ -117,13 +117,14 @@
Message b <- here "b" >>= findMessage
case (a, b) of
- (Single ai _ at, Single bi _ bt) -> do
+ (Single ai _ at aos, Single bi _ bt bos)
+ | ai == bi -> do
Boolean t <- dispatch (keyword ["=="] [at, bt]) >>= findBoolean
- return $ Boolean (ai == bi && t)
- (Keyword ai _ avs, Keyword bi _ bvs)
+ return $ Boolean (aos == bos && t) -- TODO: @== equality for options
+ (Keyword ai _ avs aos, Keyword bi _ bvs bos)
| ai == bi && length avs == length bvs -> do
eqs <- zipWithM (\x y -> dispatch (keyword ["=="] [x, y])) avs bvs
- return $ Boolean (all (== Boolean True) eqs)
+ return $ Boolean (aos == bos && all (== Boolean True) eqs)
_ -> return $ Boolean False
[$p|(a: Particle) == (b: Particle)|] =: do
@@ -131,10 +132,10 @@
Particle b <- here "b" >>= findParticle
case (a, b) of
- (PMSingle an, PMSingle bn) ->
- return $ Boolean (an == bn)
- (PMKeyword ans avs, PMKeyword bns bvs)
- | ans == bns && length avs == length bvs -> do
+ (Single { mID = ai }, Single { mID = bi }) ->
+ return $ Boolean (ai == bi)
+ (Keyword { mID = ai, mTargets = avs }, Keyword { mID = bi, mTargets = bvs })
+ | ai == bi && length avs == length bvs -> do
eqs <- zipWithM (\mx my ->
case (mx, my) of
(Nothing, Nothing) -> return (Boolean True)
diff --git a/src/Atomo/Kernel/Concurrency.hs b/src/Atomo/Kernel/Concurrency.hs
--- a/src/Atomo/Kernel/Concurrency.hs
+++ b/src/Atomo/Kernel/Concurrency.hs
@@ -30,9 +30,9 @@
then throwError (BlockArity (length as) 0)
else spawn (doBlock emptyMap s bes)
- [$p|(b: Block) spawn: (l: List)|] =: do
+ [$p|(b: Block) spawn: (... args)|] =: do
b@(Block _ as _) <- here "b" >>= findBlock
- vs <- getList [$e|l|]
+ vs <- getList [$e|args|]
if length as > length vs
then throwError (BlockArity (length as) (length vs))
diff --git a/src/Atomo/Kernel/Continuation.hs b/src/Atomo/Kernel/Continuation.hs
--- a/src/Atomo/Kernel/Continuation.hs
+++ b/src/Atomo/Kernel/Continuation.hs
@@ -21,18 +21,18 @@
liftIO (readIORef c) >>= ($ v)
-- this enables call/cc as well
- [$p|(c: Continuation) call: [v]|] =::: [$e|c yield: v|]
+ [$p|(c: Continuation) call: (... (v . _))|] =::: [$e|c yield: v|]
-- effectively just "jumping" to a continuation
[$p|(c: Continuation) yield|] =::: [$e|c yield: @ok|]
[$p|(c: Continuation) call|] =::: [$e|c yield: @ok|]
- [$p|(o: Object) call/cc|] =::: [$e|o call/cc: []|]
- [$p|(o: Object) call/cc: (as: List)|] =: callCC $ \c -> do
+ [$p|(o: Object) call/cc|] =::: [$e|o call/cc: ()|]
+ [$p|(o: Object) call/cc: (... args)|] =: callCC $ \c -> do
o <- here "o"
- as <- getList [$e|as|]
+ as <- getList [$e|args|]
cr <- mkContinuation c
- dispatch (keyword ["call"] [o, list (Continuation cr:as)])
+ dispatch (keyword ["call"] [o, tuple (Continuation cr:as)])
[$p|(v: Block) before: (b: Block) after: (a: Block)|] =: do
v <- here "v"
diff --git a/src/Atomo/Kernel/Expression.hs b/src/Atomo/Kernel/Expression.hs
--- a/src/Atomo/Kernel/Expression.hs
+++ b/src/Atomo/Kernel/Expression.hs
@@ -2,13 +2,13 @@
{-# OPTIONS -fno-warn-name-shadowing #-}
module Atomo.Kernel.Expression (load) where
-import Text.PrettyPrint (Doc)
+import Text.Parsec (sourceColumn, sourceLine, sourceName)
import Atomo
import Atomo.Parser (parseInput)
import Atomo.Parser.Expand
-import Atomo.Pattern (match)
import Atomo.Pretty (pretty)
+import Atomo.Valuable
load :: VM ()
@@ -25,40 +25,47 @@
es <- getList [$e|es|] >>= mapM findExpression
return (Expression (EList Nothing (map fromExpression es)))
+ [$p|`Tuple new: (es: List)|] =: do
+ es <- getList [$e|es|] >>= mapM findExpression
+ return (Expression (ETuple Nothing (map fromExpression es)))
+
[$p|`Match new: (branches: List) on: (value: Expression)|] =: do
- pats <- liftM (map fromExpression) $ getList [$e|branches map: @from|] >>= mapM findExpression
- exprs <- liftM (map fromExpression) $ getList [$e|branches map: @to|] >>= mapM findExpression
- Expression value <- here "value" >>= findExpression
+ bs <- getList [$e|branches|]
+ let pats = map (fromExpression . head . fromTuple) bs
+ exprs = map (fromExpression . (!! 1) . fromTuple) bs
+
ps <- mapM toRolePattern' pats
- ids <- gets primitives
- return . Expression . EVM Nothing (Just $ prettyMatch value (zip pats exprs)) $
- eval value >>= matchBranches ids (zip ps exprs)
+ Expression value <- here "value" >>= findExpression
+ return (Expression (EMatch Nothing value (zip ps exprs)))
[$p|`Set new: (pattern: Expression) to: (value: Expression)|] =: do
Expression pat <- here "pattern" >>= findExpression
Expression e <- here "value" >>= findExpression
p <- toPattern' pat
- return (Expression $ Set Nothing p e)
+ return (Expression $ ESet Nothing p e)
[$p|`Define new: (pattern: Expression) as: (expr: Expression)|] =: do
Expression pat <- here "pattern" >>= findExpression
Expression e <- here "expr" >>= findExpression
p <- toDefinePattern' pat
- return (Expression $ Define Nothing p e)
+ return (Expression $ EDefine Nothing p e)
- [$p|`Dispatch new: (name: Particle) to: (targets: List)|] =: do
+ [$p|`Dispatch new: (name: Particle) to: (targets: List) &optionals: []|] =: do
Particle name <- here "name" >>= findParticle
ts <- getList [$e|targets|] >>= mapM findExpression
+ os <- getList [$e|optionals|] >>= mapM fromValue
+ let opts = map (\(Particle (Single { mName = n }), Expression e) -> option n e) os
+
case name of
- PMSingle n ->
- return $ Expression (Dispatch Nothing (single n (fromExpression (head ts))))
+ Single { mName = n } ->
+ return $ Expression (EDispatch Nothing (single' n (fromExpression (head ts)) opts))
- PMKeyword ns _ ->
- return $ Expression (Dispatch Nothing (keyword ns (map fromExpression ts)))
+ Keyword { mNames = ns } ->
+ return $ Expression (EDispatch Nothing (keyword' ns (map fromExpression ts) opts))
[$p|`DefineDynamic new: (name: Expression) as: (root: Expression)|] =: do
n <- here "name" >>= findExpression >>= toName . fromExpression
@@ -95,71 +102,104 @@
Expression e <- here "e" >>= findExpression
liftM Expression $ macroExpand e
+ [$p|(e: Expression) pretty-expression|] =: do
+ Expression e <- here "e" >>= findExpression
+ toValue (pretty e)
+
+ [$p|(e: Expression) location|] =: do
+ Expression e <- here "e" >>= findExpression
+
+ case eLocation e of
+ Nothing -> return (particle "none")
+ Just s -> return $ keyParticleN ["name", "line", "column"]
+ [ string (sourceName s)
+ , Integer (fromIntegral (sourceLine s))
+ , Integer (fromIntegral (sourceColumn s))
+ ]
+
[$p|(e: Expression) type|] =: do
Expression e <- here "e" >>= findExpression
case e of
- Dispatch { eMessage = Keyword {} } ->
+ EDispatch { eMessage = Keyword {} } ->
return (keyParticleN ["dispatch"] [particle "keyword"])
- Dispatch { eMessage = Single {} } ->
+ EDispatch { eMessage = Single {} } ->
return (keyParticleN ["dispatch"] [particle "single"])
- Define {} -> return (particle "define")
- Set {} -> return (particle "set")
- Operator {} -> return (particle "operator")
- Primitive {} -> return (particle "primitive")
+ EDefine {} -> return (particle "define")
+ ESet {} -> return (particle "set")
+ EOperator {} -> return (particle "operator")
+ EPrimitive {} -> return (particle "primitive")
EBlock {} -> return (particle "block")
EVM {} -> return (particle "vm")
EList {} -> return (particle "list")
+ ETuple {} -> return (particle "tuple")
EMacro {} -> return (particle "macro")
EForMacro {} -> return (particle "for-macro")
ETop {} -> return (particle "top")
EQuote {} -> return (particle "quote")
EUnquote {} -> return (particle "unquote")
- EParticle { eParticle = PMKeyword _ _ } ->
+ EParticle { eParticle = Keyword {} } ->
return (keyParticleN ["particle"] [particle "keyword"])
- EParticle { eParticle = PMSingle _ } ->
+ EParticle { eParticle = Single {} } ->
return (keyParticleN ["particle"] [particle "single"])
ENewDynamic {} -> return (particle "new-dynamic")
ESetDynamic {} -> return (particle "set-dynamic")
EDefineDynamic {} -> return (particle "define-dynamic")
EGetDynamic {} -> return (particle "get-dynamic")
+ EMacroQuote {} -> return (particle "macro-quote")
+ EMatch {} -> return (particle "match")
[$p|(e: Expression) target|] =: do
Expression e <- here "e" >>= findExpression
case e of
- Dispatch { eMessage = Single { mTarget = t } } ->
+ EDispatch { eMessage = Single { mTarget = t } } ->
return (Expression t)
+ EMatch { eTarget = t } ->
+ return (Expression t)
_ -> raise ["no-target-for"] [Expression e]
[$p|(e: Expression) targets|] =: do
Expression e <- here "e" >>= findExpression
case e of
- Dispatch { eMessage = Keyword { mTargets = ts } } ->
+ EDispatch { eMessage = Keyword { mTargets = ts } } ->
return (list (map Expression ts))
- Dispatch { eMessage = Single { mTarget = t } } ->
+ EDispatch { eMessage = Single { mTarget = t } } ->
return $ list [Expression t]
_ -> raise ["no-targets-for"] [Expression e]
+ [$p|(e: Expression) optionals|] =: do
+ Expression e <- here "e" >>= findExpression
+
+ case e of
+ EDispatch { eMessage = m } ->
+ liftM list $
+ mapM (\(Option _ n v) -> toValue (particle n, Expression v))
+ (mOptionals m)
+ _ -> raise ["no-optionals-for"] [Expression e]
+
[$p|(e: Expression) name|] =: do
Expression e <- here "e" >>= findExpression
case e of
- EParticle _ (PMSingle n) -> return (string n)
- Dispatch { eMessage = Single { mName = n } } ->
+ EParticle _ (Single { mName = n }) ->
return (string n)
+ EDispatch { eMessage = Single { mName = n } } ->
+ return (string n)
+ EMacroQuote { eName = n } ->
+ return (string n)
_ -> raise ["no-name-for"] [Expression e]
[$p|(e: Expression) names|] =: do
Expression e <- here "e" >>= findExpression
case e of
- EParticle _ (PMKeyword ns _) ->
+ EParticle _ (Keyword { mNames = ns }) ->
return (list (map string ns))
- Dispatch { eMessage = Keyword { mNames = ns } } ->
+ EDispatch { eMessage = Keyword { mNames = ns } } ->
return (list (map string ns))
_ -> raise ["no-names-for"] [Expression e]
@@ -167,10 +207,10 @@
Expression e <- here "e" >>= findExpression
case e of
- Dispatch { eMessage = Keyword { mNames = ns } } ->
+ EDispatch { eMessage = Keyword { mNames = ns } } ->
return (keyParticle ns (replicate (fromIntegral $ length ns + 1) Nothing))
- Dispatch { eMessage = Single { mName = n } } ->
+ EDispatch { eMessage = Single { mName = n } } ->
return (particle n)
_ -> raise ["no-particle-for"] [Expression e]
@@ -179,7 +219,7 @@
Expression e <- here "e" >>= findExpression
case e of
- EParticle { eParticle = PMKeyword _ mes } ->
+ EParticle { eParticle = Keyword { mTargets = mes } } ->
return . list $
map
(maybe (particle "none") (keyParticleN ["ok"] . (:[]) . Expression))
@@ -194,8 +234,22 @@
return (list (map Expression es))
EList { eContents = es } ->
return (list (map Expression es))
+ ETuple { eContents = es } ->
+ return (list (map Expression es))
+ EMacroQuote { eRaw = r } ->
+ return (string r)
+ EMatch { eBranches = bs } ->
+ liftM list (mapM toValue bs)
_ -> raise ["no-contents-for"] [Expression e]
+ [$p|(e: Expression) flags|] =: do
+ Expression e <- here "e" >>= findExpression
+
+ case e of
+ EMacroQuote { eFlags = fs } ->
+ return (list (map Character fs))
+ _ -> raise ["no-flags-for"] [Expression e]
+
[$p|(e: Expression) arguments|] =: do
Expression e <- here "e" >>= findExpression
@@ -207,16 +261,16 @@
[$p|(e: Expression) pattern|] =: do
Expression e <- here "e" >>= findExpression
case e of
- Set { ePattern = p } -> return (Pattern p)
- Define { emPattern = p } -> return (Pattern (PMessage p))
+ ESet { ePattern = p } -> return (Pattern p)
+ EDefine { emPattern = p } -> return (Pattern (PMessage p))
EMacro { emPattern = p } -> return (Pattern (PMessage p))
_ -> raise ["no-pattern-for"] [Expression e]
[$p|(e: Expression) expression|] =: do
Expression e <- here "e" >>= findExpression
case e of
- Set { eExpr = e } -> return (Expression e)
- Define { eExpr = e } -> return (Expression e)
+ ESet { eExpr = e } -> return (Expression e)
+ EDefine { eExpr = e } -> return (Expression e)
EMacro { eExpr = e } -> return (Expression e)
EForMacro { eExpr = e } -> return (Expression e)
EQuote { eExpr = e } -> return (Expression e)
@@ -226,10 +280,10 @@
[$p|(e: Expression) associativity|] =: do
Expression e <- here "e" >>= findExpression
case e of
- Operator { eAssoc = ALeft } ->
+ EOperator { eAssoc = ALeft } ->
return (particle "left")
- Operator { eAssoc = ARight } ->
+ EOperator { eAssoc = ARight } ->
return (particle "right")
_ -> raise ["no-associativity-for"] [Expression e]
@@ -237,7 +291,7 @@
[$p|(e: Expression) precedence|] =: do
Expression e <- here "e" >>= findExpression
case e of
- Operator { ePrec = p } ->
+ EOperator { ePrec = p } ->
return (Integer p)
_ -> raise ["no-precedence-for"] [Expression e]
@@ -245,28 +299,11 @@
[$p|(e: Expression) operators|] =: do
Expression e <- here "e" >>= findExpression
case e of
- Operator { eNames = ns } ->
+ EOperator { eNames = ns } ->
return (list (map (\n -> keyParticle [n] [Nothing, Nothing]) ns))
_ -> raise ["no-operators-for"] [Expression e]
-
-matchBranches :: IDs -> [(Pattern, Expr)] -> Value -> VM Value
-matchBranches _ [] v = raise ["no-match-for"] [v]
-matchBranches ids ((p, e):ps) v = do
- p' <- matchable' p
- if match ids Nothing p' v
- then newScope $ set p' v >> eval e
- else matchBranches ids ps v
-
-prettyMatch :: Expr -> [(Expr, Expr)] -> Doc
-prettyMatch t bs =
- pretty . Dispatch Nothing $
- keyword ["match"] [t, EBlock Nothing [] branches]
- where
- branches = flip map bs $ \(p, e) ->
- Dispatch Nothing $ keyword ["->"] [p, e]
-
toName :: Expr -> VM String
-toName (Dispatch { eMessage = Single { mName = n } }) = return n
+toName (EDispatch { eMessage = Single { mName = n } }) = return n
toName x = raise ["unknown-dynamic-name"] [Expression x]
diff --git a/src/Atomo/Kernel/Format.hs b/src/Atomo/Kernel/Format.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Format.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.Format where
+
+import Control.Monad.RWS
+import Text.Parsec (runParser)
+import Text.PrettyPrint
+
+import Atomo
+import Atomo.Format
+import Atomo.Format.Parser
+import Atomo.Format.Types
+import Atomo.Pretty
+
+
+load :: VM ()
+load = do
+ ([$p|Formatter|] =::) =<< eval [$e|Object clone|]
+
+ [$p|Formatter new: (s: String)|] =: do
+ s <- getString [$e|s|]
+ case runParser parser (FParserState [] []) "" s of
+ Right fs ->
+ [$e|Formatter|] `newWith`
+ [ ("format", haskell fs)
+ ]
+ Left er ->
+ raise ["formatting-parse"] [string (show er)]
+
+ [$p|(f: Formatter) % (... inputs)|] =: do
+ fs <- eval [$e|f format|] >>= fromHaskell
+ is <- getList [$e|inputs|]
+ (_, f) <- evalRWST format fs (startState is)
+ return (String f)
+
+ [$p|(f: Formatter) pretty|] =: do
+ fs <- eval [$e|f format|] >>= fromHaskell
+ [$e|Pretty|] `newWith`
+ [ ("doc", haskell (char 'f' <> doubleQuotes (pretty (fs :: Format))))
+ ]
diff --git a/src/Atomo/Kernel/List.hs b/src/Atomo/Kernel/List.hs
--- a/src/Atomo/Kernel/List.hs
+++ b/src/Atomo/Kernel/List.hs
@@ -11,6 +11,8 @@
load = do
eval [$e|operator right .|]
+ [$p|List new: (... contents)|] =::: [$e|contents|]
+
[$p|(l: List) length|] =:
liftM (Integer . fromIntegral . V.length) (getVector [$e|l|])
@@ -80,12 +82,6 @@
Integer n <- here "n" >>= findInteger
return . List $ V.replicate (fromIntegral n) v
- [$p|(b: Block) repeat: (n: Integer)|] =: do
- b <- here "b" >>= findBlock
- Integer n <- here "n" >>= findInteger
- vs <- V.replicateM (fromIntegral n) (callBlock b [])
- return $ List vs
-
[$p|(a: List) .. (b: List)|] =: do
as <- getVector [$e|a|]
bs <- getVector [$e|b|]
@@ -99,27 +95,28 @@
b <- here "b"
nvs <- V.mapM (\v ->
- dispatch (keyword ["call"] [b, list [v]])) vs
+ dispatch (keyword ["call"] [b, v])) vs
return $ List nvs
- [$p|(x: List) zip: (y: List)|] =::: [$e|x zip: y with: @->|]
- [$p|(x: List) zip: (y: List) with: b|] =: do
+ [$p|(x: List) zip: (... ys) &zipper: @id|] =: do
xs <- getVector [$e|x|]
- ys <- getVector [$e|y|]
- b <- here "b"
+ yss <- getList [$e|ys|] >>= mapM (liftM (\(List v) -> v) . findList)
+ z <- here "zipper"
- nvs <- V.zipWithM (\x y ->
- dispatch (keyword ["call"] [b, list [x, y]])) xs ys
+ let zipped = zipN (xs:yss)
- return $ List nvs
+ if z == particle "id"
+ then return (list (map list zipped))
+ else liftM list $ forM zipped $ \vs ->
+ dispatch (keyword ["call"] [z, tuple vs])
[$p|(l: List) filter: b|] =: do
vs <- getVector [$e|l|]
b <- here "b"
nvs <- V.filterM (\v -> do
- Boolean t <- dispatch (keyword ["call"] [b, list [v]]) >>= findBoolean
+ Boolean t <- dispatch (keyword ["call"] [b, v]) >>= findBoolean
return t) vs
return $ List nvs
@@ -130,7 +127,7 @@
b <- here "b"
V.fold1M (\x acc ->
- dispatch (keyword ["call"] [b, list [x, acc]])) vs
+ dispatch (keyword ["call"] [b, tuple [x, acc]])) vs
[$p|(l: List) reduce: b with: v|] =: do
vs <- getVector [$e|l|]
@@ -138,7 +135,7 @@
v <- here "v"
V.foldM (\x acc ->
- dispatch (keyword ["call"] [b, list [x, acc]])) v vs
+ dispatch (keyword ["call"] [b, tuple [x, acc]])) v vs
[$p|[] reduce-right: b|] =::: [$e|error: @empty-list|]
[$p|(l: List) reduce-right: b|] =: do
@@ -146,7 +143,7 @@
b <- here "b"
foldr1MV (\x acc ->
- dispatch (keyword ["call"] [b, list [x, acc]])) vs
+ dispatch (keyword ["call"] [b, tuple [x, acc]])) vs
[$p|(l: List) reduce-right: b with: v|] =: do
vs <- getVector [$e|l|]
@@ -154,7 +151,7 @@
v <- here "v"
foldrMV (\x acc ->
- dispatch (keyword ["call"] [b, list [x, acc]])) v vs
+ dispatch (keyword ["call"] [b, tuple [x, acc]])) v vs
[$p|(l: List) concat|] =::: [$e|l reduce: @.. with: []|]
[$p|(l: List) sum|] =::: [$e|l reduce: @+ with: 0|]
@@ -167,7 +164,7 @@
b <- here "b"
nvs <- V.mapM (\v -> do
- Boolean t <- dispatch (keyword ["call"] [b, list [v]]) >>= findBoolean
+ Boolean t <- dispatch (keyword ["call"] [b, v]) >>= findBoolean
return t) vs
return $ Boolean (V.and nvs)
@@ -177,7 +174,7 @@
b <- here "b"
nvs <- V.mapM (\v -> do
- Boolean t <- dispatch (keyword ["call"] [b, list [v]]) >>= findBoolean
+ Boolean t <- dispatch (keyword ["call"] [b, v]) >>= findBoolean
return t) vs
return $ Boolean (V.or nvs)
@@ -191,7 +188,7 @@
let takeWhileM [] = return []
takeWhileM (x:xs) =
- ifVM (dispatch (keyword ["call"] [t, list [x]]))
+ ifVM (dispatch (keyword ["call"] [t, x]))
(liftM (x:) (takeWhileM xs))
(return [])
@@ -203,7 +200,7 @@
let dropWhileM [] = return []
dropWhileM (x:xs) =
- ifVM (dispatch (keyword ["call"] [t, list [x]]))
+ ifVM (dispatch (keyword ["call"] [t, x]))
(dropWhileM xs)
(return (x:xs))
@@ -214,35 +211,6 @@
-- TODO: find
- [$p|(x: Integer) .. (y: Integer)|] =: do
- Integer x <- here "x" >>= findInteger
- Integer y <- here "y" >>= findInteger
-
- if x < y
- then dispatch (keyword ["up-to"] [Integer x, Integer y])
- else dispatch (keyword ["down-to"] [Integer x, Integer y])
-
- [$p|(x: Integer) ... (y: Integer)|] =: do
- Integer x <- here "x" >>= findInteger
- Integer y <- here "y" >>= findInteger
-
- if x < y
- then dispatch (keyword ["up-to"] [Integer x, Integer (y - 1)])
- else dispatch (keyword ["down-to"] [Integer x, Integer (y + 1)])
-
- [$p|(x: Integer) to: (y: Integer) by: (d: Integer)|] =: do
- Integer x <- here "x" >>= findInteger
- Integer y <- here "y" >>= findInteger
- Integer d <- here "d" >>= findInteger
-
- return . List $ V.generate
- (fromIntegral $ abs ((y - x) `div` d) + 1)
- (Integer . (x +) . (* d) . fromIntegral)
-
- [$p|(x: Integer) up-to: (y: Integer)|] =::: [$e|x to: y by: 1|]
- [$p|(x: Integer) down-to: (y: Integer)|] =::: [$e|x to: y by: -1|]
-
- -- destructive update
[$p|(l: List) at: (n: Integer) put: v|] =: do
vs <- getVector [$e|l|]
@@ -262,13 +230,13 @@
v <- here "v"
return (List $ V.cons v vs)
- [$p|(l: List) << v|] =: do
+ [$p|(l: List) push: v|] =: do
vs <- getVector [$e|l|]
v <- here "v"
return . List $ V.snoc vs v
- [$p|v >> (l: List)|] =: do
+ [$p|(l: List) cons: v|] =: do
vs <- getVector [$e|l|]
v <- here "v"
@@ -286,16 +254,16 @@
return $ list (map list (splitWhen (== d) l))
- [$p|(l: List) sort|] =:
- getList [$e|l|] >>= liftM list . sortVM
+ [$p|(l: List) sort &comparison: @<=>|] =: do
+ cmp <- here "comparison"
+ getList [$e|l|] >>= liftM list . sortVM cmp
- [$p|(l: List) sort-by: cmp|] =: do
+ [$p|(l: List) sort-by: something &comparison: @<=>|] =: do
vs <- getList [$e|l|]
- cmp <- here "cmp"
+ something <- here "something"
+ cmp <- here "comparison"
- liftM list $ sortByVM (\a b -> do
- Boolean t <- dispatch (keyword ["call"] [cmp, list [a, b]]) >>= findBoolean
- return t) vs
+ liftM list $ sortByVM cmp something vs
foldr1MV :: (Value -> Value -> VM Value) -> V.Vector Value -> VM Value
@@ -307,25 +275,33 @@
rest <- foldrMV f acc (V.tail vs)
f (V.head vs) rest
-sortVM :: [Value] -> VM [Value]
-sortVM = sortByVM gt
+sortVM :: Value -> [Value] -> VM [Value]
+sortVM cmp = mergesort gt
where
gt a b = do
- Boolean t <- dispatch (keyword [">"] [a, b]) >>= findBoolean
+ Integer t <- dispatch (keyword ["call"] [cmp, tuple [a, b]])
+ >>= findInteger
return t
-sortByVM :: (Value -> Value -> VM Bool) -> [Value] -> VM [Value]
-sortByVM = mergesort
+sortByVM :: Value -> Value -> [Value] -> VM [Value]
+sortByVM cmp by = mergesort gt
+ where
+ gt a b = do
+ x <- dispatch (keyword ["call"] [by, a])
+ y <- dispatch (keyword ["call"] [by, b])
+ Integer t <- dispatch (keyword ["call"] [cmp, tuple [x, y]])
+ >>= findInteger
+ return t
-mergesort :: (Value -> Value -> VM Bool) -> [Value] -> VM [Value]
+mergesort :: (Value -> Value -> VM Integer) -> [Value] -> VM [Value]
mergesort cmp = mergesort' cmp . map (: [])
-mergesort' :: (Value -> Value -> VM Bool) -> [[Value]] -> VM [Value]
+mergesort' :: (Value -> Value -> VM Integer) -> [[Value]] -> VM [Value]
mergesort' _ [] = return []
mergesort' _ [xs] = return xs
mergesort' cmp xss = mergePairs cmp xss >>= mergesort' cmp
-mergePairs :: (Value -> Value -> VM Bool) -> [[Value]] -> VM [[Value]]
+mergePairs :: (Value -> Value -> VM Integer) -> [[Value]] -> VM [[Value]]
mergePairs _ [] = return []
mergePairs _ [xs] = return [xs]
mergePairs cmp (xs:ys:xss) = do
@@ -333,13 +309,13 @@
zs <- mergePairs cmp xss
return (z:zs)
-merge :: (Value -> Value -> VM Bool) -> [Value] -> [Value] -> VM [Value]
+merge :: (Value -> Value -> VM Integer) -> [Value] -> [Value] -> VM [Value]
merge _ [] ys = return ys
merge _ xs [] = return xs
merge cmp (x:xs) (y:ys) = do
o <- cmp x y
- if o
+ if o > 0
then do
rest <- merge cmp (x:xs) ys
return (y:rest)
@@ -363,3 +339,7 @@
| d `isPrefixOf` a = acc : splitOn' (drop (length d) a) []
| otherwise = splitOn' vs (acc ++ [v])
+zipN :: [VVector] -> [[Value]]
+zipN vs
+ | any V.null vs = []
+ | otherwise = (map V.head vs) : zipN (map V.tail vs)
diff --git a/src/Atomo/Kernel/Message.hs b/src/Atomo/Kernel/Message.hs
--- a/src/Atomo/Kernel/Message.hs
+++ b/src/Atomo/Kernel/Message.hs
@@ -2,6 +2,7 @@
module Atomo.Kernel.Message (load) where
import Atomo
+import Atomo.Valuable
load :: VM ()
@@ -28,3 +29,8 @@
[$p|(m: Message) targets|] =: do
Message (Keyword { mTargets = ts }) <- here "m" >>= findMessage
return $ list ts
+
+ [$p|(m: Message) optionals|] =: do
+ Message m <- here "m" >>= findMessage
+ liftM list $
+ mapM (\(Option _ n v) -> toValue (particle n, v)) (mOptionals m)
diff --git a/src/Atomo/Kernel/Nucleus.hs b/src/Atomo/Kernel/Nucleus.hs
--- a/src/Atomo/Kernel/Nucleus.hs
+++ b/src/Atomo/Kernel/Nucleus.hs
@@ -2,15 +2,18 @@
module Atomo.Kernel.Nucleus where
import Data.IORef
+import Data.Hashable (hash)
import Data.Maybe (isJust)
import Atomo
import Atomo.Load
import Atomo.Method
-import Atomo.Pretty
+import Atomo.Pattern
load :: VM ()
load = do
+ [$p|x id|] =::: [$e|x|]
+
[$p|(x: Object) clone|] =: do
x <- here "x"
newObject [x] noMethods
@@ -56,13 +59,27 @@
x <- here "x"
Particle p' <- here "p" >>= findParticle
- let completed =
- case p' of
- PMKeyword ns mvs -> keyword ns (completeKP mvs [x])
- PMSingle n -> single n x
+ case p' of
+ Keyword {} ->
+ liftM Boolean (particleMatch p' x)
- liftM (Boolean . isJust) $ findMethod x completed
+ Single { mName = n } ->
+ liftM (Boolean . isJust) . findMethod x $
+ single n x
+ [$p|x has-slot?: (name: String)|] =: do
+ x <- here "x" >>= objectFor
+ n <- getString [$e|name|]
+ (ss, _) <- liftIO (readIORef (oMethods x))
+ return (Boolean (memberMap (hash n) ss))
+
+ [$p|x set-slot: (name: String) to: v|] =: do
+ x <- here "x"
+ n <- getString [$e|name|]
+ v <- here "v"
+ define (single n (PMatch x)) (EPrimitive Nothing v)
+ return v
+
[$p|(o: Object) methods|] =: do
o <- here "o" >>= objectFor
(ss, ks) <- liftIO (readIORef (oMethods o))
@@ -83,8 +100,7 @@
[$p|(x: Object) as: String|] =::: [$e|x show|]
- [$p|(x: Object) show|] =:
- liftM (string . show . pretty) (here "x")
+ [$p|(x: Object) show|] =::: [$e|x pretty render|]
[$p|(t: Object) load: (fn: String)|] =: do
t <- here "t"
@@ -102,3 +118,19 @@
return (particle "ok")
+particleMatch :: Particle Value -> Value -> VM Bool
+particleMatch p' x = do
+ o <- objectFor x
+ mms <- liftIO (readIORef (oMethods o))
+ is <- gets primitives
+ return . maybe False (maybeMatch is p') $
+ lookupMap (mID p') (methods p' mms)
+ where
+ methods (Single {}) (s, _) = s
+ methods (Keyword {}) (_, k) = k
+
+ maybeMatch is (Single { mTarget = Just t }) ms =
+ any (flip (match is (Just x)) t . mTarget . mPattern) ms
+ maybeMatch is (Keyword { mTargets = ts }) ms =
+ any (all (\(Just v, pat) -> match is (Just x) pat v) . filter (isJust . fst) . zip ts . mTargets . mPattern) ms
+ maybeMatch _ (Single {}) _ = True
diff --git a/src/Atomo/Kernel/Particle.hs b/src/Atomo/Kernel/Particle.hs
--- a/src/Atomo/Kernel/Particle.hs
+++ b/src/Atomo/Kernel/Particle.hs
@@ -3,6 +3,7 @@
module Atomo.Kernel.Particle (load) where
import Atomo
+import Atomo.Valuable
load :: VM ()
@@ -12,48 +13,47 @@
return (particle n)
[$p|(p: Particle) new: (names: List)|] =: do
- ns <- liftM (map (fromText . fromString)) $ getList [$e|names|]
+ ns <- getList [$e|names|]
+ >>= mapM (liftM (fromText . fromString) . findString)
+
return (keyParticle ns (replicate (length ns + 1) Nothing))
- [$p|(p: Particle) call: (targets: List)|] =:::
+ [$p|(p: Particle) call|] =::: [$e|p call: ()|]
+ [$p|(p: Particle) call: targets|] =:::
[$e|(p complete: targets) dispatch|]
[$p|(p: Particle) name|] =: do
- Particle (PMSingle n) <- here "p" >>= findParticle
+ Particle (Single { mName = n }) <- here "p" >>= findParticle
return (string n)
[$p|(p: Particle) names|] =: do
- Particle (PMKeyword ns _) <- here "p" >>= findParticle
+ Particle (Keyword { mNames = ns }) <- here "p" >>= findParticle
return $ list (map string ns)
- [$p|(p: Particle) values|] =: do
- (Particle (PMKeyword _ mvs)) <- here "p" >>= findParticle
- return . list $
- map
- (maybe (particle "none") (keyParticleN ["ok"] . (:[])))
- mvs
+ [$p|(p: Particle) target|] =: do
+ (Particle (Single { mTarget = mt })) <- here "p" >>= findParticle
+ toValue mt
+ [$p|(p: Particle) targets|] =: do
+ (Particle (Keyword { mTargets = mts })) <- here "p" >>= findParticle
+ liftM list (mapM toValue mts)
+
+ [$p|(p: Particle) optionals|] =: do
+ Particle p <- here "p" >>= findParticle
+ liftM list $
+ mapM (\(Option _ n mv) -> toValue (particle n, mv)) (mOptionals p)
+
[$p|(p: Particle) type|] =: do
Particle p <- here "p" >>= findParticle
case p of
- PMKeyword {} -> return (particle "keyword")
- PMSingle {} -> return (particle "single")
+ Keyword {} -> return (particle "keyword")
+ Single {} -> return (particle "single")
- [$p|(p: Particle) complete: (targets: List)|] =: do
+ [$p|(p: Particle) complete|] =::: [$e|p complete: ()|]
+ [$p|(p: Particle) complete: (... targets)|] =: do
Particle p <- here "p" >>= findParticle
vs <- getList [$e|targets|]
-
- case p of
- PMKeyword ns mvs ->
- let blanks = length (filter (== Nothing) mvs)
- in
- if blanks > length vs
- then throwError (ParticleArity blanks (length vs))
- else return . Message . keyword ns $ completeKP mvs vs
- PMSingle n ->
- if null vs
- then throwError (ParticleArity 1 0)
- else return . Message . single n $ head vs
+ liftM Message (completeParticle p vs)
[$p|c define: (p: Particle) on: v with: (targets: List) as: e|] =: do
Particle p <- here "p" >>= findParticle
@@ -75,9 +75,9 @@
pat <-
matchable $
case p of
- PMKeyword ns _ ->
+ Keyword { mNames = ns } ->
keyword ns (main:others)
- PMSingle n ->
+ Single { mName = n } ->
single n main
let m =
@@ -104,14 +104,14 @@
expr =
case v of
Expression e -> e
- _ -> Primitive Nothing v
+ _ -> EPrimitive Nothing v
withTop c $ do
case p of
- PMKeyword ns _ ->
+ Keyword { mNames = ns } ->
define (keyword ns targets) expr
- PMSingle n ->
+ Single { mName = n } ->
define (single n (head targets)) expr
return (particle "ok")
diff --git a/src/Atomo/Kernel/Pattern.hs b/src/Atomo/Kernel/Pattern.hs
--- a/src/Atomo/Kernel/Pattern.hs
+++ b/src/Atomo/Kernel/Pattern.hs
@@ -11,17 +11,17 @@
([$p|Pattern Role|] =::) =<< eval [$e|Pattern clone|]
([$p|Pattern Define|] =::) =<< eval [$e|Pattern clone|]
- [$p|(e: Expression) as: Pattern|] =: do
+ [$p|(e: Expression) to: Pattern|] =: do
Expression e <- here "e" >>= findExpression
p <- toPattern' e
return (Pattern p)
- [$p|(e: Expression) as: Pattern Role|] =: do
+ [$p|(e: Expression) to: Pattern Role|] =: do
Expression e <- here "e" >>= findExpression
p <- toRolePattern' e
return (Pattern p)
- [$p|(e: Expression) as: Pattern Define|] =: do
+ [$p|(e: Expression) to: Pattern Define|] =: do
Expression e <- here "e" >>= findExpression
p <- toDefinePattern' e
return (Pattern (PMessage p))
@@ -55,7 +55,7 @@
PMessage (Keyword { mTargets = ts }) -> return $ list (map Pattern ts)
_ -> raise ["no-targets-for"] [Pattern p]
- [$p|(p: Pattern) matches?: v|] =: do
+ [$p|(p: Pattern) match: v|] =: do
Pattern p <- here "p" >>= findPattern
v <- here "v"
ids <- gets primitives
@@ -64,8 +64,8 @@
then do
bs <- eval [$e|Object clone|]
withTop bs (set p v)
- return (keyParticle ["yes"] [Nothing, Just bs])
- else return (particle "no")
+ return (keyParticleN ["ok"] [bs])
+ else return (particle "none")
[$p|top match: (p: Pattern) on: v|] =: do
p <- here "p" >>= findPattern >>= matchable' . fromPattern
@@ -73,5 +73,5 @@
t <- here "top"
case p of
- PMessage m -> define m (Primitive Nothing v) >> return v
+ PMessage m -> define m (EPrimitive Nothing v) >> return v
_ -> withTop t (set p v)
diff --git a/src/Atomo/Kernel/Ports.hs b/src/Atomo/Kernel/Ports.hs
--- a/src/Atomo/Kernel/Ports.hs
+++ b/src/Atomo/Kernel/Ports.hs
@@ -12,6 +12,7 @@
import Atomo
import Atomo.Parser
import Atomo.Pretty
+import Atomo.Valuable
load :: VM ()
@@ -31,25 +32,34 @@
hdl <- getHandle [$e|p handle|] >>= liftIO . hShow
return (string (""))
- [$p|Port new: (fn: String)|] =::: [$e|Port new: fn mode: @read-write|]
- [$p|Port new: (fn: String) mode: (m: Particle)|] =: do
+ [$p|Port new: (fn: String) &mode: @read-write|] =: do
fn <- getString [$e|fn|]
- Particle m <- here "m" >>= findParticle
+ Particle m <- here "mode" >>= findParticle
hdl <- case m of
- PMSingle "read" ->
+ Single { mName = "read" } -> do
+ checkExists fn
liftIO (openFile fn ReadMode)
- PMSingle "write" ->
+ Single { mName = "write" } ->
liftIO (openFile fn WriteMode)
- PMSingle "append" ->
+ Single { mName = "append" } ->
liftIO (openFile fn AppendMode)
- PMSingle "read-write" ->
+ Single { mName = "read-write" } ->
liftIO (openFile fn ReadWriteMode)
_ ->
error $ "unknown port mode: " ++ show (pretty m) ++ ", must be one of: @read, @write, @append, @read-write"
portObj hdl
+ [$p|(p: Port) buffering|] =:
+ getHandle [$e|p handle|] >>= liftIO . hGetBuffering >>= toValue
+
+ [$p|(p: Port) set-buffering: mode|] =: do
+ h <- getHandle [$e|p handle|]
+ m <- here "mode" >>= fromValue
+ liftIO (hSetBuffering h m)
+ return (particle "ok")
+
[$p|(p: Port) print: x|] =: do
x <- here "x"
port <- here "p"
@@ -84,9 +94,9 @@
segment <- liftIO (hGetSegment h)
parsed <- continuedParse segment ""
- let isPrimitive (Primitive {}) = True
- isPrimitive (EParticle { eParticle = PMSingle _ }) = True
- isPrimitive (EParticle { eParticle = PMKeyword _ ts }) =
+ let isPrimitive (EPrimitive {}) = True
+ isPrimitive (EParticle { eParticle = Single {} }) = True
+ isPrimitive (EParticle { eParticle = Keyword { mTargets = ts } }) =
all isPrimitive (catMaybes ts)
isPrimitive (EList { eContents = ts }) = all isPrimitive ts
isPrimitive _ = False
@@ -111,7 +121,7 @@
c <- liftIO (hGetChar h)
liftIO (hSetBuffering h b)
- return (Char c)
+ return (Character c)
[$p|(p: Port) contents|] =:
getHandle [$e|p handle|] >>= liftM String . liftIO . TIO.hGetContents
@@ -150,16 +160,12 @@
[$p|File open: (fn: String)|] =::: [$e|Port new: fn|]
[$p|File read: (fn: String)|] =:::
- [$e|Port (new: fn mode: @read) ensuring: @close do: @contents|]
+ [$e|Port (new: fn &mode: @read) ensuring: @close do: @contents|]
[$p|File delete: (fn: String)|] =: do
fn <- getString [$e|fn|]
- b <- liftIO (doesFileExist fn)
-
- if b
- then liftIO (removeFile fn)
- else raise ["file-not-found"] [string fn]
-
+ checkExists fn
+ liftIO (removeFile fn)
return (particle "ok")
[$p|File move: (from: String) to: (to: String)|] =:::
@@ -167,12 +173,14 @@
[$p|File rename: (from: String) to: (to: String)|] =: do
from <- getString [$e|from|]
to <- getString [$e|to|]
+ checkExists from
liftIO (renameFile from to)
return (particle "ok")
[$p|File copy: (from: String) to: (to: String)|] =: do
from <- getString [$e|from|]
to <- getString [$e|to|]
+ checkExists from
liftIO (copyFile from to)
return (particle "ok")
@@ -195,25 +203,30 @@
Nothing -> return (particle "none")
Just fn -> return (keyParticle ["ok"] [Nothing, Just (string fn)])
- [$p|File readable?: (fn: String)|] =:
- getString [$e|fn|]
- >>= liftM (Boolean . readable) . liftIO . getPermissions
+ [$p|File readable?: (fn: String)|] =: do
+ fn <- getString [$e|fn|]
+ checkExists fn
+ liftM (Boolean . readable) $ liftIO (getPermissions fn)
- [$p|File writable?: (fn: String)|] =:
- getString [$e|fn|]
- >>= liftM (Boolean . writable) . liftIO . getPermissions
+ [$p|File writable?: (fn: String)|] =: do
+ fn <- getString [$e|fn|]
+ checkExists fn
+ liftM (Boolean . writable) $ liftIO (getPermissions fn)
- [$p|File executable?: (fn: String)|] =:
- getString [$e|fn|]
- >>= liftM (Boolean . executable) . liftIO . getPermissions
+ [$p|File executable?: (fn: String)|] =: do
+ fn <- getString [$e|fn|]
+ checkExists fn
+ liftM (Boolean . executable) $ liftIO (getPermissions fn)
- [$p|File searchable?: (fn: String)|] =:
- getString [$e|fn|]
- >>= liftM (Boolean . searchable) . liftIO . getPermissions
+ [$p|File searchable?: (fn: String)|] =: do
+ fn <- getString [$e|fn|]
+ checkExists fn
+ liftM (Boolean . searchable) $ liftIO (getPermissions fn)
[$p|File set-readable: (fn: String) to: (b: Boolean)|] =: do
Boolean r <- here "b" >>= findBoolean
fn <- getString [$e|fn|]
+ checkExists fn
ps <- liftIO (getPermissions fn)
liftIO (setPermissions fn (ps { readable = r }))
return (particle "ok")
@@ -221,6 +234,7 @@
[$p|File set-writable: (fn: String) to: (b: Boolean)|] =: do
Boolean w <- here "b" >>= findBoolean
fn <- getString [$e|fn|]
+ checkExists fn
ps <- liftIO (getPermissions fn)
liftIO (setPermissions fn (ps { writable = w }))
return (particle "ok")
@@ -228,6 +242,7 @@
[$p|File set-executable: (fn: String) to: (b: Boolean)|] =: do
Boolean x <- here "b" >>= findBoolean
fn <- getString [$e|fn|]
+ checkExists fn
ps <- liftIO (getPermissions fn)
liftIO (setPermissions fn (ps { executable = x }))
return (particle "ok")
@@ -235,6 +250,7 @@
[$p|File set-searchable: (fn: String) to: (b: Boolean)|] =: do
Boolean s <- here "b" >>= findBoolean
fn <- getString [$e|fn|]
+ checkExists fn
ps <- liftIO (getPermissions fn)
liftIO (setPermissions fn (ps { searchable = s }))
return (particle "ok")
@@ -256,11 +272,13 @@
[$p|Directory remove: (path: String)|] =: do
path <- getString [$e|path|]
+ checkDirExists path
liftIO (removeDirectory path)
return (particle "ok")
[$p|Directory remove-recursive: (path: String)|] =: do
path <- getString [$e|path|]
+ checkDirExists path
liftIO (removeDirectoryRecursive path)
return (particle "ok")
@@ -269,18 +287,22 @@
[$p|Directory rename: (from: String) to: (to: String)|] =: do
from <- getString [$e|from|]
to <- getString [$e|to|]
+ checkDirExists from
liftIO (renameDirectory from to)
return (particle "ok")
- [$p|Directory contents: (path: String)|] =:
+ [$p|Directory contents: (path: String)|] =: do
+ path <- getString [$e|path|]
+ checkDirExists path
liftM (list . map string . filter (`notElem` [".", ".."]))
- (getString [$e|path|] >>= liftIO . getDirectoryContents)
+ (liftIO (getDirectoryContents path))
[$p|Directory current|] =:
liftM string $ liftIO getCurrentDirectory
- [$p|Directory current: (path: String)|] =: do
+ [$p|Directory set-current: (path: String)|] =: do
path <- getString [$e|path|]
+ checkDirExists path
liftIO (setCurrentDirectory path)
return (particle "ok")
@@ -325,6 +347,20 @@
Nothing -> raise' "interrupt"
where
+ checkExists fn = do
+ b <- liftIO (doesFileExist fn)
+
+ if b
+ then return ()
+ else raise ["file-not-found"] [string fn]
+
+ checkDirExists d = do
+ b <- liftIO (doesDirectoryExist d)
+
+ if b
+ then return ()
+ else raise ["directory-not-found"] [string d]
+
runInput h
= runInputT (defaultSettings { historyFile = Just h })
. withInterrupt
@@ -333,7 +369,7 @@
port <- eval [$e|Port clone|]
define (single "handle" (PMatch port))
- (Primitive Nothing $ haskell hdl)
+ (EPrimitive Nothing $ haskell hdl)
return port
diff --git a/src/Atomo/Kernel/Pretty.hs b/src/Atomo/Kernel/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Pretty.hs
@@ -0,0 +1,167 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.Pretty (load) where
+
+import Text.PrettyPrint
+
+import Atomo as A
+import Atomo.Pretty
+import Atomo.Valuable
+
+
+load :: VM ()
+load = do
+ ([$p|Pretty|] =::) =<< eval [$e|Object clone|]
+
+ [$p|(o: Object) pretty|] =:
+ here "o" >>= toValue . pretty
+
+ [$p|(p: -> Pretty) pretty|] =::: [$e|p|]
+
+ -- Converting values to documents
+ [$p|Pretty char: (c: Character)|] =:
+ here "c" >>= findCharacter >>= toValue . char . fromCharacter
+
+ [$p|Pretty text: (s: String)|] =:
+ getString [$e|s|] >>= toValue . text
+
+ [$p|Pretty zero-width-text: (s: String)|] =:
+ getString [$e|s|] >>= toValue . zeroWidthText
+
+ [$p|Pretty int: (i: Integer)|] =:
+ here "i" >>= findInteger >>= toValue . integer . A.fromInteger
+
+ [$p|Pretty integer: (i: Integer)|] =:
+ here "i" >>= findInteger >>= toValue . integer . A.fromInteger
+
+ [$p|Pretty float: (d: Double)|] =:
+ here "d" >>= findDouble >>= toValue . double . fromDouble
+
+ [$p|Pretty double: (d: Double)|] =:
+ here "d" >>= findDouble >>= toValue . double . fromDouble
+
+ [$p|Pretty rational: (r: Rational)|] =:
+ here "r" >>= findRational
+ >>= toValue . rational . (\(Rational r) -> r)
+
+ -- Simple derived documents
+ [$p|Pretty semi|] =: toValue semi
+ [$p|Pretty comma|] =: toValue comma
+ [$p|Pretty colon|] =: toValue colon
+ [$p|Pretty space|] =: toValue space
+ [$p|Pretty equals|] =: toValue equals
+ [$p|Pretty lparen|] =: toValue lparen
+ [$p|Pretty rparen|] =: toValue rparen
+ [$p|Pretty lbrack|] =: toValue lbrack
+ [$p|Pretty rbrack|] =: toValue rbrack
+ [$p|Pretty lbrace|] =: toValue lbrace
+ [$p|Pretty rbrace|] =: toValue rbrace
+
+ -- Wrapping documents in delimiters
+ [$p|Pretty parens: (p: Pretty)|] =:
+ here "p" >>= fromValue >>= toValue . parens
+
+ [$p|Pretty brackets: (p: Pretty)|] =:
+ here "p" >>= fromValue >>= toValue . brackets
+
+ [$p|Pretty braces: (p: Pretty)|] =:
+ here "p" >>= fromValue >>= toValue . braces
+
+ [$p|Pretty quotes: (p: Pretty)|] =:
+ here "p" >>= fromValue >>= toValue . quotes
+
+ [$p|Pretty double-quotes: (p: Pretty)|] =:
+ here "p" >>= fromValue >>= toValue . doubleQuotes
+
+ -- Combining documents
+ [$p|Pretty empty|] =: toValue empty
+
+ [$p|(a: Pretty) <> (b: Pretty)|] =: do
+ liftM2 (<>) (here "a" >>= fromValue) (here "b" >>= fromValue)
+ >>= toValue
+
+ [$p|(a: Pretty) <+> (b: Pretty)|] =: do
+ liftM2 (<+>) (here "a" >>= fromValue) (here "b" >>= fromValue)
+ >>= toValue
+
+ [$p|Pretty hcat: (ps: List)|] =: do
+ getList [$e|ps|] >>= mapM fromValue >>= toValue . hcat
+
+ [$p|Pretty hsep: (ps: List)|] =: do
+ getList [$e|ps|] >>= mapM fromValue >>= toValue . hsep
+
+ [$p|(a: Pretty) \\ (b: Pretty)|] =: do
+ liftM2 ($$) (here "a" >>= fromValue) (here "b" >>= fromValue)
+ >>= toValue
+
+ [$p|(a: Pretty) \+\ (b: Pretty)|] =: do
+ liftM2 ($+$) (here "a" >>= fromValue) (here "b" >>= fromValue)
+ >>= toValue
+
+ [$p|Pretty vcat: (ps: List)|] =: do
+ getList [$e|ps|] >>= mapM fromValue >>= toValue . vcat
+
+ [$p|Pretty sep: (ps: List)|] =: do
+ getList [$e|ps|] >>= mapM fromValue >>= toValue . sep
+
+ [$p|Pretty cat: (ps: List)|] =: do
+ getList [$e|ps|] >>= mapM fromValue >>= toValue . cat
+
+ [$p|Pretty fsep: (ps: List)|] =: do
+ getList [$e|ps|] >>= mapM fromValue >>= toValue . fsep
+
+ [$p|Pretty fcat: (ps: List)|] =: do
+ getList [$e|ps|] >>= mapM fromValue >>= toValue . fcat
+
+ [$p|(p: Pretty) nest: (i: Integer)|] =: do
+ d <- here "p" >>= fromValue
+ i <- here "i" >>= liftM (fromIntegral . A.fromInteger) . findInteger
+ toValue (nest i d)
+
+ [$p|(a: Pretty) hang: (b: Pretty) indented: (i: Integer)|] =: do
+ a <- here "a" >>= fromValue
+ b <- here "b" >>= fromValue
+ i <- here "i" >>= liftM (fromIntegral . A.fromInteger) . findInteger
+ toValue (hang a i b)
+
+ [$p|(delimiter: Pretty) punctuate: (ps: List)|] =: do
+ d <- here "delimiter" >>= fromValue
+ ps <- getList [$e|ps|] >>= mapM fromValue
+ liftM list (mapM toValue (punctuate d ps))
+
+ -- Predicates on documents
+ [$p|(p: Pretty) empty?|] =:
+ liftM (Boolean . isEmpty) (here "p" >>= fromValue)
+
+ -- Rendering documents
+ [$p|(p: -> Pretty) render &mode: @page &line-length: 100 &ribbons-per-line: 1.5|] =: do
+ d <- here "p" >>= fromValue
+ m <- here "mode" >>= findParticle
+ sl <- here "line-length" >>= liftM (fromIntegral . A.fromInteger) . findInteger
+ sr <- here "ribbons-per-line" >>= liftM (fromRational . toRational . fromDouble) . findDouble
+
+ sm <-
+ case m of
+ Particle (Single { mName = "page" }) ->
+ return PageMode
+
+ Particle (Single { mName = "zig-zag" }) ->
+ return ZigZagMode
+
+ Particle (Single { mName = "left" }) ->
+ return LeftMode
+
+ Particle (Single { mName = "one-line" }) ->
+ return OneLineMode
+
+ _ ->
+ raise ["unknown-render-mode", "must-be"]
+ [ m
+ , list
+ [ particle "page"
+ , particle "zig-zag"
+ , particle "left"
+ , particle "one-line"
+ ]
+ ]
+
+ return (string (renderStyle (Style sm sl sr) d))
diff --git a/src/Atomo/Kernel/Regexp.hs b/src/Atomo/Kernel/Regexp.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Regexp.hs
@@ -0,0 +1,179 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.Regexp where
+
+import Control.Arrow
+import Data.Char (isDigit)
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import Text.Regex.PCRE
+import qualified Data.Array as A
+import qualified Data.ByteString as BS
+import qualified Data.Text as T
+
+import Atomo
+
+byteString :: BS.ByteString -> Value
+byteString = String . decodeUtf8
+
+data MkRegex a = RegexOK a | Failed String
+
+instance Monad MkRegex where
+ return = RegexOK
+ fail = Failed
+
+ Failed x >>= _ = Failed x
+ RegexOK a >>= f = f a
+
+data REReplace
+ = REChunk T.Text
+ | REReference Int
+ | RENamed String
+
+load :: VM ()
+load = do
+ ([$p|RegexpBindings|] =::) =<< eval [$e|Object clone|]
+ ([$p|RegexpMatch|] =::) =<< eval [$e|Object clone|]
+
+ [$p|Regexp new: (s: String) &flags: ""|] =: do
+ s <- getString [$e|s|]
+ fs <- getString [$e|flags|]
+
+ case regex s fs of
+ RegexOK re ->
+ return (Regexp re s fs (namedCaptures s))
+ Failed x ->
+ raise ["regexp-failed"] [string x]
+
+ [$p|(r: Regexp) =~ (s: String)|] =::: [$e|r matches?: s|]
+ [$p|(s: String) =~ (r: Regexp)|] =::: [$e|r matches?: s|]
+
+ [$p|(r: Regexp) matches?: (s: String)|] =: do
+ Regexp { rCompiled = re } <- here "r" >>= findRegexp
+ t <- getText [$e|s|]
+ return (Boolean (match re (encodeUtf8 t)))
+
+ [$p|(r: Regexp) match: (s: String)|] =: do
+ Regexp { rCompiled = re, rNamed = ns } <- here "r" >>= findRegexp
+ t <- getText [$e|s|]
+ let mr = match re (encodeUtf8 t) :: MatchResult BS.ByteString
+ if BS.null (mrMatch mr)
+ then return (particle "none")
+ else do
+ bs <- mkBindings (mrMatch mr:mrSubList mr) ns
+
+ rm <- [$e|RegexpMatch|] `newWith`
+ [ ("before", byteString (mrBefore mr))
+ , ("match", byteString (mrMatch mr))
+ , ("after", byteString (mrAfter mr))
+ , ("captures", list (map byteString (mrSubList mr)))
+ , ("bindings", bs)
+ ]
+
+ return (keyParticleN ["ok"] [rm])
+
+ [$p|(s: String) replace: (r: Regexp) with: (callback: Block)|] =: do
+ Regexp { rCompiled = re, rNamed = ns } <- here "r" >>= findRegexp
+ callback <- here "callback"
+ t <- getText [$e|s|]
+ doReplace re t $ \cs -> do
+ bs <- mkBindings cs ns
+ dispatch (keyword ["join"] [bs, callback])
+ >>= liftM fromString . findString
+
+ [$p|(s: String) replace: (r: Regexp) with: (format: String)|] =: do
+ Regexp { rCompiled = re, rNamed = ns } <- here "r" >>= findRegexp
+ format <- getText [$e|format|]
+ t <- getText [$e|s|]
+ doReplace re t (reReplace (replacements format) ns)
+
+ [$p|(s: String) replace-all: (r: Regexp) with: (callback: Block)|] =: do
+ Regexp { rCompiled = re, rNamed = ns } <- here "r" >>= findRegexp
+ callback <- here "callback"
+ t <- getText [$e|s|]
+ doReplaceAll re t $ \cs -> do
+ bs <- mkBindings cs ns
+ dispatch (keyword ["join"] [bs, callback])
+ >>= liftM fromString . findString
+
+ [$p|(s: String) replace-all: (r: Regexp) with: (format: String)|] =: do
+ Regexp { rCompiled = re, rNamed = ns } <- here "r" >>= findRegexp
+ format <- getText [$e|format|]
+ t <- getText [$e|s|]
+ doReplaceAll re t (reReplace (replacements format) ns)
+
+doReplace :: Regex -> T.Text -> ([BS.ByteString] -> VM T.Text) -> VM Value
+doReplace re t f =
+ case ms of
+ [] -> return (String t)
+ ((s, (o, l)):cs) -> do
+ r <- f (s:map fst cs)
+ return . String . T.concat $
+ [ T.take o t
+ , r
+ , T.drop (o + l) t
+ ]
+ where
+ ms = getAllTextSubmatches (match re (encodeUtf8 t))
+
+doReplaceAll :: Regex -> T.Text -> ([BS.ByteString] -> VM T.Text) -> VM Value
+doReplaceAll re t f = do
+ rs <- forM (map (map fst) ms) f
+ return (String (fuse cs rs))
+ where
+ marr :: AllTextMatches (A.Array Int) (MatchText BS.ByteString)
+ marr = match re (encodeUtf8 t)
+
+ ms :: [[(BS.ByteString, (MatchOffset, MatchLength))]]
+ ms = map A.elems . A.elems $ getAllTextMatches marr
+
+ cs = chunks t (map (snd . head) ms)
+
+chunks :: T.Text -> [(MatchOffset, MatchLength)] -> [T.Text]
+chunks t [] = [t]
+chunks t ((o, l):xs) = c : chunks rest updated
+ where
+ c = T.take o t
+ rest = T.drop (o + l) t
+ updated = map (first (flip (-) (o + l))) xs
+
+fuse :: [T.Text] -> [T.Text] -> T.Text
+fuse (x:xs) (r:rs) = T.concat [x, r, fuse xs rs]
+fuse xs ys = T.concat (xs ++ ys)
+
+replacements :: T.Text -> [REReplace]
+replacements t
+ | T.null t = []
+ | T.head t == '$' && t `T.index` 1 == '(' =
+ RENamed name : replacements afterName
+ | T.head t == '$' =
+ REReference (read num) : replacements afterNum
+ | otherwise =
+ REChunk chunk : replacements rest
+ where
+ name = T.unpack (T.takeWhile (/= ')') (T.drop 2 t))
+ afterName = T.tail (T.dropWhile (/= ')') (T.drop 2 t))
+
+ num = T.unpack (T.takeWhile isDigit (T.tail t))
+ afterNum = T.dropWhile isDigit (T.tail t)
+
+ (chunk, rest) = T.span (/= '$') t
+
+reReplace :: [REReplace] -> [(String, Int)] -> [BS.ByteString] -> VM T.Text
+reReplace [] _ _ = return T.empty
+reReplace (REChunk c:rs) ns bs = liftM (c `T.append`) (reReplace rs ns bs)
+reReplace (REReference n:rs) ns bs =
+ liftM (decodeUtf8 (bs !! n) `T.append`) (reReplace rs ns bs)
+reReplace (RENamed n:rs) ns bs =
+ case lookup n ns of
+ Nothing -> raise ["unknown-regexp-reference"] [string n]
+ Just i -> do
+ rest <- reReplace rs ns bs
+ return (decodeUtf8 (bs !! i) `T.append` rest)
+
+mkBindings :: [BS.ByteString] -> [(String, Int)] -> VM Value
+mkBindings subs names =
+ [$e|RegexpBindings|] `newWith` concat
+ [ zipWith (\n m -> ("\\" ++ show n, byteString m))
+ [0 :: Int ..]
+ subs
+ , map (\(n, o) -> ("\\" ++ n, byteString (subs !! o))) names
+ ]
diff --git a/src/Atomo/Kernel/String.hs b/src/Atomo/Kernel/String.hs
--- a/src/Atomo/Kernel/String.hs
+++ b/src/Atomo/Kernel/String.hs
@@ -11,13 +11,13 @@
load :: VM ()
load = do
[$p|(s: String) as: List|] =:
- liftM (list . map Char) (getString [$e|s|])
+ liftM (list . map Character) (getString [$e|s|])
- [$p|(s: String) to: Char|] =: do
+ [$p|(s: String) to: Character|] =: do
s <- getString [$e|s|]
case s of
- "$'" -> return (Char '\'')
- '$':rest -> return (Char (read $ "'" ++ rest ++ "'"))
+ "$'" -> return (Character '\'')
+ '$':rest -> return (Character (read $ "'" ++ rest ++ "'"))
_ -> raise ["invalid-string"] [string s]
[$p|(s: String) to: Integer|] =: do
@@ -34,15 +34,15 @@
denom = read . tail $ dropWhile (/= '/') s
return (Rational (num % denom))
- [$p|(l: List) to-string|] =: do
+ [$p|(l: List) to: String|] =: do
vs <- getList [$e|l|]
- if all isChar vs
- then return $ string (map (\(Char c) -> c) vs)
+ if all isCharacter vs
+ then return $ string (map (\(Character c) -> c) vs)
else raise' "list-not-homogenous"
- [$p|(c: Char) singleton|] =: do
- Char c <- here "c" >>= findChar
+ [$p|(c: Character) singleton|] =: do
+ Character c <- here "c" >>= findCharacter
return (String (T.singleton c))
[$p|(s: String) length|] =:
@@ -57,15 +57,15 @@
if fromIntegral n >= T.length t
then raise ["out-of-bounds", "for-string"] [Integer n, String t]
- else return . Char $ t `T.index` fromIntegral n
+ else return . Character $ t `T.index` fromIntegral n
[$p|"" head|] =::: [$e|error: @empty-string|]
[$p|(s: String) head|] =:
- liftM (Char . T.head) (getText [$e|s|])
+ liftM (Character . T.head) (getText [$e|s|])
[$p|"" last|] =::: [$e|error: @empty-string|]
[$p|(s: String) last|] =:
- liftM (Char . T.last) (getText [$e|s|])
+ liftM (Character . T.last) (getText [$e|s|])
[$p|(s: String) from: (n: Integer) to: (m: Integer)|] =: do
Integer n <- here "n" >>= findInteger
@@ -103,7 +103,7 @@
let takeWhileM [] = return []
takeWhileM (x:xs) =
- ifVM (dispatch (keyword ["call"] [t, list [Char x]]))
+ ifVM (dispatch (keyword ["call"] [t, Character x]))
(liftM (x:) (takeWhileM xs))
(return [])
@@ -115,14 +115,14 @@
let dropWhileM [] = return []
dropWhileM (x:xs) =
- ifVM (dispatch (keyword ["call"] [t, list [Char x]]))
+ ifVM (dispatch (keyword ["call"] [t, Character x]))
(dropWhileM xs)
(return (x:xs))
liftM string $ dropWhileM s
- [$p|(c: Char) repeat: (n: Integer)|] =: do
- Char c <- here "c" >>= findChar
+ [$p|(c: Character) repeat: (n: Integer)|] =: do
+ Character c <- here "c" >>= findCharacter
Integer n <- here "n" >>= findInteger
return (string (replicate (fromIntegral n) c))
@@ -138,18 +138,22 @@
[$p|(s: String) reverse|] =:
liftM (String . T.reverse) (getText [$e|s|])
- [$p|(l: List) join|] =::: [$e|l reduce: @.. with: ""|]
+ [$p|(l: List) join|] =: do
+ ts <- getList [$e|l|]
+ >>= mapM (liftM fromString . findString)
+ return (String (T.concat ts))
+
[$p|(l: List) join: (d: String)|] =: do
ts <- getList [$e|l|]
- >>= mapM (liftM (\(String t) -> t) . findString)
+ >>= mapM (liftM fromString . findString)
d <- getText [$e|d|]
return (String (T.intercalate d ts))
- [$p|(s: String) intersperse: (c: Char)|] =: do
- Char c <- here "c" >>= findChar
+ [$p|(s: String) intersperse: (c: Character)|] =: do
+ Character c <- here "c" >>= findCharacter
t <- getText [$e|s|]
return (String (T.intersperse c t))
@@ -160,9 +164,9 @@
-- TODO: split-by
- [$p|(s: String) split-on: (d: Char)|] =: do
+ [$p|(s: String) split-on: (d: Character)|] =: do
s <- getText [$e|s|]
- Char d <- here "d" >>= findChar
+ Character d <- here "d" >>= findCharacter
return $ list (map String (T.split (== d) s))
[$p|(s: String) split-at: (n: Integer)|] =: do
@@ -209,36 +213,36 @@
return $ list (map String (T.words s))
[$p|(l: List) unlines|] =: do
- l <- getList [$e|l|]
- return $ String (T.unlines (map fromString l))
+ l <- getList [$e|l|] >>= mapM (liftM fromString . findString)
+ return $ String (T.unlines l)
[$p|(l: List) unwords|] =: do
- l <- getList [$e|l|]
- return $ String (T.unwords (map fromString l))
+ l <- getList [$e|l|] >>= mapM (liftM fromString . findString)
+ return $ String (T.unwords l)
[$p|(s: String) map: b|] =: do
s <- getString [$e|s|]
b <- here "b"
vs <- forM s $ \c ->
- dispatch (keyword ["call"] [b, list [Char c]])
+ dispatch (keyword ["call"] [b, Character c])
- if all isChar vs
- then return (string (map (\(Char c) -> c) vs))
+ if all isCharacter vs
+ then return (string (map (\(Character c) -> c) vs))
else return $ list vs
[$p|(s: String) each: (b: Block)|] =::: [$e|{ s map: b in-context; s } call|]
- [$p|(c: Char) . (s: String)|] =: do
- Char c <- here "c" >>= findChar
+ [$p|(c: Character) . (s: String)|] =: do
+ Character c <- here "c" >>= findCharacter
s <- getText [$e|s|]
return (String (T.cons c s))
- [$p|(c: Char) >> (s: String)|] =::: [$e|c . s|]
+ [$p|(c: Character) >> (s: String)|] =::: [$e|c . s|]
- [$p|(s: String) << (c: Char)|] =: do
+ [$p|(s: String) << (c: Character)|] =: do
s <- getText [$e|s|]
- Char c <- here "c" >>= findChar
+ Character c <- here "c" >>= findCharacter
return (String (T.snoc s c))
[$p|(haystack: String) replace: (needle: String) with: (new: String)|] =: do
@@ -256,24 +260,24 @@
[$p|(s: String) uppercase|] =:
liftM (String . T.toUpper) (getText [$e|s|])
- [$p|(s: String) left-justify: (length: Integer) with: (c: Char)|] =: do
+ [$p|(s: String) left-justify: (length: Integer) &padding: $ |] =: do
s <- getText [$e|s|]
Integer l <- here "length" >>= findInteger
- Char c <- here "c" >>= findChar
+ Character c <- here "c" >>= findCharacter
return (String (T.justifyLeft (fromIntegral l) c s))
- [$p|(s: String) right-justify: (length: Integer) with: (c: Char)|] =: do
+ [$p|(s: String) right-justify: (length: Integer) &padding: $ |] =: do
s <- getText [$e|s|]
Integer l <- here "length" >>= findInteger
- Char c <- here "c" >>= findChar
+ Character c <- here "c" >>= findCharacter
return (String (T.justifyRight (fromIntegral l) c s))
- [$p|(s: String) center: (length: Integer) with: (c: Char)|] =: do
+ [$p|(s: String) center: (length: Integer) &padding: $ |] =: do
s <- getText [$e|s|]
Integer l <- here "length" >>= findInteger
- Char c <- here "c" >>= findChar
+ Character c <- here "c" >>= findCharacter
return (String (T.center (fromIntegral l) c s))
@@ -286,27 +290,27 @@
[$p|(s: String) strip-end|] =:
liftM (String . T.stripEnd) (getText [$e|s|])
- [$p|(s: String) strip: (c: Char)|] =: do
- Char c <- here "c" >>= findChar
+ [$p|(s: String) strip: (c: Character)|] =: do
+ Character c <- here "c" >>= findCharacter
liftM (String . T.dropAround (== c)) (getText [$e|s|])
- [$p|(s: String) strip-start: (c: Char)|] =: do
- Char c <- here "c" >>= findChar
+ [$p|(s: String) strip-start: (c: Character)|] =: do
+ Character c <- here "c" >>= findCharacter
liftM (String . T.dropWhile (== c)) (getText [$e|s|])
- [$p|(s: String) strip-end: (c: Char)|] =: do
- Char c <- here "c" >>= findChar
+ [$p|(s: String) strip-end: (c: Character)|] =: do
+ Character c <- here "c" >>= findCharacter
liftM (String . T.dropWhileEnd (== c)) (getText [$e|s|])
[$p|(s: String) all?: b|] =::: [$e|(s as: List) all?: b|]
[$p|(s: String) any?: b|] =::: [$e|(s as: List) any?: b|]
- [$p|(s: String) contains?: (c: Char)|] =: do
+ [$p|(s: String) contains?: (c: Character)|] =: do
t <- getText [$e|s|]
- Char c <- here "c" >>= findChar
+ Character c <- here "c" >>= findCharacter
return (Boolean (T.any (== c) t))
- [$p|(c: Char) in?: (s: String)|] =::: [$e|s contains?: c|]
+ [$p|(c: Character) in?: (s: String)|] =::: [$e|s contains?: c|]
[$p|(s: String) reduce: b|] =::: [$e|(s as: List) reduce: b|]
[$p|(s: String) reduce: b with: v|] =::: [$e|(s as: List) reduce: b with: v|]
@@ -315,15 +319,15 @@
[$p|(s: String) reduce-right: b with: v|] =::: [$e|(s as: List) reduce-right: b with: v|]
[$p|(s: String) maximum|] =:
- liftM (Char . T.maximum) (getText [$e|s|])
+ liftM (Character . T.maximum) (getText [$e|s|])
[$p|(s: String) minimum|] =:
- liftM (Char . T.minimum) (getText [$e|s|])
+ liftM (Character . T.minimum) (getText [$e|s|])
[$p|(s: String) sort|] =:
liftM (string . sort) (getString [$e|s|])
- [$p|(s: String) sort-by: cmp|] =::: [$e|s (as: List) (sort-by: cmp) to-string|]
+ [$p|(s: String) sort-by: cmp|] =::: [$e|s (as: List) (sort-by: cmp) to: String|]
[$p|(a: String) is-prefix-of?: (b: String)|] =: do
a <- getText [$e|a|]
@@ -344,24 +348,19 @@
[$p|(a: String) ends-with?: (b: String)|] =::: [$e|b is-suffix-of?: a|]
[$p|(a: String) includes?: (b: String)|] =::: [$e|b is-infix-of?: a|]
- [$p|(s: String) filter: b|] =::: [$e|s (as: List) (filter: b) to-string|]
+ [$p|(s: String) filter: b|] =::: [$e|s (as: List) (filter: b) to: String|]
- [$p|(x: String) zip: (y: String)|] =::: [$e|x zip: y with: @->|]
- [$p|(x: String) zip: (y: String) with: z|] =: do
+ [$p|(x: String) zip: (y: String) &zipper: @->|] =: do
x <- getText [$e|x|]
y <- getText [$e|y|]
- z <- here "z"
+ z <- here "zipper"
vs <- forM (T.zip x y) $ \(a, b) ->
- dispatch (keyword ["call"] [z, list [Char a, Char b]])
+ dispatch (keyword ["call"] [z, tuple [Character a, Character b]])
return $ list vs
- [$p|(x: List) zip: (y: String)|] =::: [$e|x zip: (y as: List)|]
- [$p|(x: String) zip: (y: List)|] =::: [$e|(x as: List) zip: y|]
-
- [$p|(x: List) zip: (y: String) with: z|] =:::
- [$e|x zip: (y as: List) with: z|]
-
- [$p|(x: String) zip: (y: List) with: z|] =:::
- [$e|(x as: List) zip: y with: z|]
+ [$p|(x: List) zip: (y: String) &zipper: @->|] =:::
+ [$e|x zip: (y as: List) &zipper: zipper|]
+ [$p|(x: String) zip: (y: List) &zipper: @->|] =:::
+ [$e|(x as: List) zip: y &zipper: zipper|]
diff --git a/src/Atomo/Lexer.hs b/src/Atomo/Lexer.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Lexer.hs
@@ -0,0 +1,191 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+module Atomo.Lexer where
+
+import Control.Monad.State
+import Data.Char (isAlpha)
+import Text.Parsec
+
+import Atomo.Lexer.Base
+import Atomo.Lexer.Primitive
+
+
+lToken :: Lexer Token
+lToken = choice
+ [ lKeyword
+ , lReserved
+ , lOptional
+ , lOptionalFlag
+ , lOperator
+ , lParticle
+ , lPrimitive
+ , lMacroQuote
+ , lPunctuation
+ , lEnd
+ ]
+
+lReserved :: Lexer Token
+lReserved = try $ do
+ n <- anyIdent
+ if isReservedName n
+ then return (TokReserved n)
+ else fail "not reserved"
+
+lKeyword :: Lexer Token
+lKeyword = try $ do
+ n <- ident
+ char ':'
+ return (TokKeyword n)
+
+lOptional :: Lexer Token
+lOptional = try $ do
+ char '&'
+ n <- ident
+ char ':'
+ return (TokOptional n)
+
+lOptionalFlag :: Lexer Token
+lOptionalFlag = try $ do
+ char '&'
+ n <- ident
+ notFollowedBy (char ':')
+ return (TokOptionalFlag n)
+
+lParticle :: Lexer Token
+lParticle = try $ do
+ char '@'
+ ks <- choice
+ [ many1 . try $ do
+ n <- ident
+ char ':'
+ return n
+ , fmap (:[]) operator
+ ]
+ return (TokParticle ks)
+
+lOperator :: Lexer Token
+lOperator = try $ do
+ o <- operator
+ whiteSpace1 <|> eof <|> (lookAhead (lEnd <|> lPunctuation) >> return ())
+ return (TokOperator o)
+
+lPrimitive :: Lexer Token
+lPrimitive = liftM TokPrimitive $ choice
+ [ lvCharacter
+ , lvString
+ , try lvRational
+ , try lvDouble
+ , try lvInteger
+ , try lvBoolean
+ ]
+
+lPunctuation :: Lexer Token
+lPunctuation = choice
+ [ liftM TokPunctuation (oneOf "|`'~@")
+ , liftM TokOpen (oneOf "([{")
+ , liftM TokClose (oneOf ")]}")
+ ]
+
+lEnd :: Lexer Token
+lEnd = do
+ oneOf ",;"
+ return TokEnd
+
+-- | Parse an identifier, possibly followed by a macro-quote segment.
+lMacroQuote :: Lexer Token
+lMacroQuote = do
+ name <- ident
+ choice
+ [ do
+ str <- delimited "({[\"$|`'~@"
+ flags <- many (satisfy isAlpha)
+ return (TokMacroQuote name str flags)
+ , return (TokIdentifier name)
+ ]
+ where
+ delimited ds = do
+ o <- oneOf ds
+ cs <- many $ choice
+ [ try $ do
+ char '\\'
+ oneOf [o, close o]
+ , noneOf [o, close o]
+ ]
+ char (close o)
+ return cs
+
+ close '(' = ')'
+ close '{' = '}'
+ close '[' = ']'
+ close '<' = '>'
+ close x = x
+
+lIdentifier :: Lexer Token
+lIdentifier = liftM TokIdentifier ident
+
+lexer :: Lexer [TaggedToken]
+lexer = whiteSpace >> getPosition >>= subLexer
+
+subLexer :: SourcePos -> Lexer [TaggedToken]
+subLexer start = do
+ ios <- fmap lsInsideOf getState
+
+ liftM concat $ many $ do
+ i <- getPosition
+ os <- fmap lsInsideOf getState
+ if length os < length ios || sourceColumn i < sourceColumn start
+ then fail "finished sublexer"
+ else segment i
+
+-- A sequence of tokens with a given start indentation level.
+segment :: SourcePos -> Lexer [TaggedToken]
+segment i = do
+ t <- tagged lToken
+ whiteSpace
+ choice
+ [ eof >> return (if tToken t == TokEnd then [t] else [t, withTag t TokEnd])
+ , do
+ p <- getPosition
+ case tToken t of
+ TokOpen o -> do
+ modifyState $ \ls -> ls { lsInsideOf = (i, o) : lsInsideOf ls }
+ n <- subLexer i
+ p' <- getPosition
+ if chainContinue i p'
+ then choice
+ [ eof >> return (t : n)
+ , do
+ ts <- segment i
+ return (t : n ++ ts)
+ ]
+ else return (t:n)
+ TokClose c -> do
+ os <- fmap lsInsideOf getState
+ if not (null os) && matchWrap (snd $ head os) c
+ then modifyState $ \ls -> ls { lsInsideOf = tail os }
+ else fail $ "unmatched " ++ [c]
+
+ if chainContinue (fst (head os)) p || (not (chainContinue (fst (head os)) i) && chainContinue i p)
+ then return [t]
+ else return [t, withTag t TokEnd]
+ _ | chainContinue i p -> do
+ ts <- segment i
+ return (t:ts)
+ TokEnd -> return [t]
+ _ -> return [t, withTag t TokEnd]
+ ]
+ where
+ chainContinue o n = or
+ [ sourceLine o == sourceLine n
+ , sourceColumn o < sourceColumn n
+ ]
+
+matchWrap :: Char -> Char -> Bool
+matchWrap '(' ')' = True
+matchWrap '{' '}' = True
+matchWrap '[' ']' = True
+matchWrap _ _ = False
+
+fileLexer :: Lexer [TaggedToken]
+fileLexer = do
+ optional (string "#!" >> manyTill anyToken (eol <|> eof))
+ lexer
diff --git a/src/Atomo/Lexer/Base.hs b/src/Atomo/Lexer/Base.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Lexer/Base.hs
@@ -0,0 +1,368 @@
+module Atomo.Lexer.Base where
+
+import Control.Monad.Identity
+import Data.Char
+import Data.List (nub, sort)
+import Text.Parsec
+import qualified Text.Parsec.Token as P
+
+import Atomo.Types (Value)
+
+
+data LexerState =
+ LexerState
+ { lsInsideOf :: [(SourcePos, Char)]
+ }
+
+data Token
+ = TokKeyword String
+ | TokOptional String
+ | TokOptionalFlag String
+ | TokOperator String
+ | TokMacroQuote String String [Char]
+ | TokIdentifier String
+ | TokParticle [String]
+ | TokPrimitive Value
+ | TokPunctuation Char
+ | TokOpen Char
+ | TokClose Char
+ | TokReserved String
+ | TokEnd
+ deriving (Eq, Show)
+
+data TaggedToken =
+ TaggedToken
+ { tToken :: Token
+ , tLocation :: SourcePos
+ }
+ deriving (Eq, Show)
+
+type Lexer = ParsecT String LexerState Identity
+
+
+isOpLetter :: Char -> Bool
+isOpLetter c = c `elem` "!@#%&*-./\\?:" || (c `notElem` "`" && isSymbol c)
+
+isOperator :: String -> Bool
+isOperator "" = False
+isOperator cs = head cs `notElem` "@$~" && all isOpLetter cs
+
+def :: P.GenLanguageDef String u Identity
+def = P.LanguageDef
+ { P.commentStart = "{-"
+ , P.commentEnd = "-}"
+ , P.commentLine = "--"
+ , P.nestedComments = True
+ , P.identStart = satisfy (\c -> c == '_' || isLetter c || (c `notElem` "&@$~:" && isOpLetter c))
+ , P.identLetter = satisfy (\c -> c == '_' || isAlphaNum c || (c /= ':' && isOpLetter c))
+ , P.opStart = satisfy (\c -> c `notElem` "@$~" && isOpLetter c)
+ , P.opLetter = satisfy isOpLetter
+ , P.reservedOpNames = [",", "|"]
+ , P.reservedNames = ["operator", "macro", "for-macro", "this"]
+ , P.caseSensitive = True
+ }
+
+eol :: ParsecT String u Identity ()
+eol = newline >> return ()
+
+anyIdent :: ParsecT String u Identity String
+anyIdent = try $ do
+ c <- P.identStart def
+ cs <- many (P.identLetter def)
+ if isOperator (c:cs)
+ then unexpected "operator"
+ else do
+
+ return (c:cs)
+
+ident :: ParsecT String u Identity String
+ident = do
+ name <- anyIdent
+ if isReservedName name
+ then unexpected ("reserved word " ++ show name)
+ else return name
+
+lexeme :: ParsecT String u Identity a -> ParsecT String u Identity a
+lexeme l = do
+ r <- l
+ whiteSpace
+ return r
+
+symbol :: String -> ParsecT String u Identity String
+symbol = lexeme . string
+
+identifier :: ParsecT String u Identity String
+identifier = lexeme ident
+
+operator :: ParsecT String u Identity String
+operator = try $ do
+ c <- P.opStart def
+ cs <- many (P.opLetter def)
+ if (c:cs) `elem` P.reservedOpNames def
+ then unexpected ("reserved operator " ++ show (c:cs))
+ else return (c:cs)
+
+reserved :: String -> ParsecT String u Identity ()
+reserved n = try $ do
+ string n
+ notFollowedBy (P.identLetter def) "end of " ++ show n
+
+integer :: ParsecT String u Identity Integer
+integer = do
+ f <- sign
+ n <- natural
+ return (f n)
+
+float :: ParsecT String u Identity Double
+float = do
+ f <- sign
+ n <- floating
+ return (f n)
+
+natural :: ParsecT String u Identity Integer
+natural = zeroNumber <|> decimal
+
+stringLiteral :: ParsecT String u Identity String
+stringLiteral = do
+ str <-
+ between
+ (char '"')
+ (char '"' "end of string")
+ (many stringChar)
+
+ return (foldr (maybe id (:)) "" str)
+
+charLiteral :: ParsecT String u Identity Char
+charLiteral = do
+ char '$'
+ charEscape <|> charLetter
+ "literal character"
+
+tagged :: ParsecT String u Identity Token -> ParsecT String u Identity TaggedToken
+tagged p = do
+ pos <- getPosition
+ r <- p
+ return (TaggedToken r pos)
+
+withTag :: TaggedToken -> Token -> TaggedToken
+withTag tt t = tt { tToken = t }
+
+isReservedName :: String -> Bool
+isReservedName name = isReserved reservedNames name
+ where
+ reservedNames = sort (P.reservedNames def)
+
+isReserved :: [String] -> String -> Bool
+isReserved names name
+ = scan names
+ where
+ scan [] = False
+ scan (r:rs) =
+ case compare r name of
+ LT -> scan rs
+ EQ -> True
+ GT -> False
+
+
+-----------------------------------------------------------------------------
+-- Numeric ------------------------------------------------------------------
+-----------------------------------------------------------------------------
+
+decimal :: ParsecT String u Identity Integer
+decimal = number 10 digit
+
+number :: Integer -> ParsecT String u Identity Char -> ParsecT String u Identity Integer
+number base baseDigit = do
+ digits <- many1 baseDigit
+ let n = foldl (\x d -> base * x + toInteger (digitToInt d)) 0 digits
+ n `seq` (return n)
+
+zeroNumber :: ParsecT String u Identity Integer
+zeroNumber = do
+ char '0'
+ hexadecimal <|> octal <|> decimal <|> return 0
+ "zeroNumber"
+
+hexadecimal :: ParsecT String u Identity Integer
+hexadecimal = oneOf "xX" >> number 16 hexDigit
+
+octal :: ParsecT String u Identity Integer
+octal = oneOf "oO" >> number 8 octDigit
+
+floating :: ParsecT String u Identity Double
+floating = do
+ n <- decimal
+ fractExponent n
+
+fractExponent :: Integer -> ParsecT String u Identity Double
+fractExponent n = choice
+ [ do
+ fract <- fraction
+ expo <- option 1.0 exponent'
+ return ((fromInteger n + fract) * expo)
+ , do
+ expo <- exponent'
+ return (fromInteger n * expo)
+ ]
+
+fraction :: ParsecT String u Identity Double
+fraction = do
+ char '.'
+ digits <- many1 digit "fraction"
+ return (foldr op 0.0 digits)
+ "fraction"
+ where
+ op d f = (f + fromIntegral (digitToInt d)) / 10.0
+
+exponent' :: ParsecT String u Identity Double
+exponent' = do
+ oneOf "eE"
+ f <- sign
+ e <- decimal "exponent"
+ return (power (f e))
+ "exponent"
+ where
+ power e | e < 0 = 1.0 / power(-e)
+ | otherwise = fromInteger (10 ^ e)
+
+sign :: Num a => ParsecT String u Identity (a -> a)
+sign = choice
+ [ char '-' >> return negate
+ , char '+' >> return id
+ , return id
+ ]
+
+-----------------------------------------------------------------------------
+-- Whitespace & Comments ----------------------------------------------------
+-----------------------------------------------------------------------------
+
+whiteSpace :: ParsecT String u Identity ()
+whiteSpace = do
+ spacing
+ skipMany (try $ spacing >> newline)
+ spacing
+
+whiteSpace1 :: ParsecT String u Identity ()
+whiteSpace1 = (space <|> newline) >> whiteSpace
+
+simpleSpace :: ParsecT String u Identity ()
+simpleSpace = skipMany1 $ satisfy (`elem` " \t\f\v\xa0")
+
+spacing :: ParsecT String u Identity ()
+spacing = skipMany spacing1
+
+spacing1 :: ParsecT String u Identity ()
+spacing1 = choice
+ [ simpleSpace
+ , oneLineComment
+ , multiLineComment
+ ]
+ "whitespace or commend"
+
+oneLineComment :: ParsecT String u Identity ()
+oneLineComment = do
+ try (string (P.commentLine def))
+ skipMany (satisfy (/= '\n'))
+
+multiLineComment :: ParsecT String u Identity ()
+multiLineComment = do
+ try (string (P.commentStart def))
+ inComment
+
+inComment :: ParsecT String u Identity ()
+inComment = choice
+ [ try (string (P.commentEnd def)) >> return ()
+ , multiLineComment >> inComment
+ , skipMany1 (noneOf startEnd) >> inComment
+ , oneOf startEnd >> inComment
+ ]
+ "end of comment"
+ where
+ startEnd = nub (P.commentEnd def ++ P.commentStart def)
+
+
+-----------------------------------------------------------------------------
+-- Character Escaping -------------------------------------------------------
+-----------------------------------------------------------------------------
+
+charEscape :: ParsecT String u Identity Char
+charEscape = char '\\' >> escapeCode
+
+charLetter :: ParsecT String u Identity Char
+charLetter = satisfy (\c -> (c /= '\\') && (c > '\026'))
+
+stringChar :: ParsecT String u Identity (Maybe Char)
+stringChar = choice
+ [ fmap Just stringLetter
+ , stringEscape
+ ]
+ "string character"
+
+stringLetter :: ParsecT String u Identity Char
+stringLetter = satisfy (`notElem` "\"\\")
+
+stringEscape :: ParsecT String u Identity (Maybe Char)
+stringEscape = char '\\' >> choice
+ [ escapeGap >> return Nothing
+ , escapeEmpty >> return Nothing
+ , fmap Just escapeCode
+ ]
+
+escapeEmpty :: ParsecT String u Identity Char
+escapeEmpty = char '&'
+
+escapeGap :: ParsecT String u Identity Char
+escapeGap = do
+ many1 space
+ char '\\' "end of string gap"
+
+escMap :: [(Char, Char)]
+escMap = zip "abfnrtv\\\"" "\a\b\f\n\r\t\v\\\""
+
+asciiMap :: [(String, Char)]
+asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)
+
+ascii2codes :: [String]
+ascii2codes = [ "BS","HT","LF","VT","FF","CR","SO","SI","EM",
+ "FS","GS","RS","US","SP" ]
+
+ascii3codes :: [String]
+ascii3codes = [ "NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL",
+ "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB",
+ "CAN","SUB","ESC","DEL" ]
+
+ascii2 :: [Char]
+ascii2 = "\b\t\n\v\f\r\SO\SI\EM\FS\GS\RS\US "
+
+ascii3 :: [Char]
+ascii3 = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\a\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\SUB\ESC\DEL"
+
+escapeCode :: ParsecT String u Identity Char
+escapeCode = charEsc <|> charNum <|> charAscii <|> charControl
+ "escape code"
+
+charControl :: ParsecT String u Identity Char
+charControl = do
+ char '^'
+ code <- upper
+ return (toEnum (fromEnum code - fromEnum 'A'))
+
+charNum :: ParsecT String u Identity Char
+charNum = do
+ code <- choice
+ [ decimal
+ , char 'o' >> number 8 octDigit
+ , char 'x' >> number 16 hexDigit
+ ]
+
+ return (toEnum (fromInteger code))
+
+charEsc :: ParsecT String u Identity Char
+charEsc = choice (map parseEsc escMap)
+ where
+ parseEsc (c, code) = char c >> return code
+
+charAscii :: ParsecT String u Identity Char
+charAscii = choice (map parseAscii asciiMap)
+ where
+ parseAscii (asc, code) = try (string asc >> return code)
diff --git a/src/Atomo/Lexer/Primitive.hs b/src/Atomo/Lexer/Primitive.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Lexer/Primitive.hs
@@ -0,0 +1,52 @@
+module Atomo.Lexer.Primitive where
+
+import Control.Monad (liftM)
+import Data.Ratio
+import Text.Parsec
+
+import Atomo.Lexer.Base
+import Atomo.Types as T
+
+
+-- | Character literal.
+--
+-- Examples: @$a@, @$ @, @$\\EOT@, @$\\n@
+lvCharacter :: Lexer Value
+lvCharacter = liftM Character charLiteral
+
+-- | String literal.
+--
+-- Examples: @\"\"@, @\"foo\"@, @\"foo\\nbar\"@
+lvString :: Lexer Value
+lvString = liftM T.string stringLiteral
+
+-- | Double literal.
+--
+-- Examples: @1.0@, @4.6e10@, @-1.0@
+lvDouble :: Lexer Value
+lvDouble = liftM Double float
+
+-- | Integer literal.
+--
+-- Examples: @1@, @2@, @-1@, @-2@
+lvInteger :: Lexer Value
+lvInteger = liftM Integer integer
+
+-- | Boolean literal.
+--
+-- Examples: @True@, @False@
+lvBoolean :: Lexer Value
+lvBoolean = liftM Boolean $ true <|> false
+ where
+ true = reserved "True" >> return True
+ false = reserved "False" >> return False
+
+-- | Rational literal.
+--
+-- Examples: @1\/2@, @-1\/2@, @1\/-2@
+lvRational :: Lexer Value
+lvRational = do
+ n <- integer
+ char '/'
+ d <- integer
+ return (Rational (n % d))
diff --git a/src/Atomo/Method.hs b/src/Atomo/Method.hs
--- a/src/Atomo/Method.hs
+++ b/src/Atomo/Method.hs
@@ -5,6 +5,7 @@
, insertMethod
, insertMap
, lookupMap
+ , memberMap
, noMethods
, nullMap
, toMethods
@@ -92,13 +93,13 @@
exprPrecision 0 (EUnquote {}) (EUnquote {}) = EQ
exprPrecision 0 (EUnquote {}) _ = GT
exprPrecision 0 _ (EUnquote {}) = LT
-exprPrecision n (Define { eExpr = a }) (Define { eExpr = b }) =
+exprPrecision n (EDefine { eExpr = a }) (EDefine { eExpr = b }) =
exprPrecision n a b
-exprPrecision n (Set { eExpr = a }) (Set { eExpr = b }) =
+exprPrecision n (ESet { eExpr = a }) (ESet { eExpr = b }) =
exprPrecision n a b
-exprPrecision n (Dispatch { eMessage = am@(Keyword {}) }) (Dispatch { eMessage = bm@(Keyword {}) }) =
+exprPrecision n (EDispatch { eMessage = am@(Keyword {}) }) (EDispatch { eMessage = bm@(Keyword {}) }) =
comparePrecisionsWith (exprPrecision n) (mTargets am) (mTargets bm)
-exprPrecision n (Dispatch { eMessage = am@(Single {}) }) (Dispatch { eMessage = bm@(Single {}) }) =
+exprPrecision n (EDispatch { eMessage = am@(Single {}) }) (EDispatch { eMessage = bm@(Single {}) }) =
exprPrecision n (mTarget am) (mTarget bm)
exprPrecision n (EBlock { eContents = as }) (EBlock { eContents = bs }) =
comparePrecisionsWith (exprPrecision n) as bs
@@ -108,7 +109,7 @@
exprPrecision n a b
exprPrecision n (EParticle { eParticle = ap' }) (EParticle { eParticle = bp }) =
case (ap', bp) of
- (PMKeyword _ ames, PMKeyword _ bmes) ->
+ (Keyword { mTargets = ames }, Keyword { mTargets = bmes }) ->
comparePrecisionsWith (exprPrecision n) (firsts ames bmes) (seconds ames bmes)
_ -> EQ
where
@@ -133,7 +134,7 @@
insertMethod :: Method -> [Method] -> [Method]
insertMethod x [] = [x]
insertMethod x (y:ys)
- | mPattern x == mPattern y = x : ys
+ | mPattern x `samePattern` mPattern y = x : ys
| otherwise =
case comparePrecision (PMessage (mPattern x)) (PMessage (mPattern y)) of
-- stop at LT so it's after all of the definitons before this one
@@ -142,6 +143,16 @@
-- keep looking if we're EQ or GT
_ -> y : insertMethod x ys
+-- | Like ==, but ignore optionals.
+samePattern :: Message Pattern -> Message Pattern -> Bool
+samePattern (Single { mID = ai, mTarget = at })
+ (Single { mID = bi, mTarget = bt }) =
+ ai == bi && at == bt
+samePattern (Keyword { mID = ai, mTargets = ats })
+ (Keyword { mID = bi, mTargets = bts }) =
+ ai == bi && ats == bts
+samePattern _ _ = False
+
-- | Convert a list of slots to a MethodMap.
toMethods :: [(Message Pattern, Value)] -> MethodMap
toMethods = foldl (\ss (p, v) -> addMethod (Slot p v) ss) emptyMap
@@ -166,6 +177,11 @@
-- | All of the methods in a MethodMap.
elemsMap :: MethodMap -> [[Method]]
elemsMap = M.elems
+
+-- | Is a key set in a map?
+memberMap :: Int -> MethodMap -> Bool
+memberMap = M.member
+
-- | Insert a method into a MethodMap, replacing all other methods with the
-- same ID.
diff --git a/src/Atomo/Parser.hs b/src/Atomo/Parser.hs
--- a/src/Atomo/Parser.hs
+++ b/src/Atomo/Parser.hs
@@ -1,9 +1,13 @@
+{-# LANGUAGE FlexibleContexts #-}
module Atomo.Parser where
+import Control.Monad.Identity
import Control.Monad.State
import Text.Parsec
import Atomo.Environment
+import Atomo.Lexer
+import Atomo.Lexer.Base
import Atomo.Parser.Base
import Atomo.Parser.Expr
import Atomo.Parser.Expand
@@ -14,28 +18,31 @@
parseFile :: FilePath -> VM [Expr]
parseFile fn =
liftIO (readFile fn)
- >>= continue fileParser fn
+ >>= continue fileLexer parser fn
>>= nextPhase
-- | Parses an input string, performs macro expansion, and returns an AST.
parseInput :: String -> VM [Expr]
-parseInput s = continue parser "" s >>= nextPhase
+parseInput s = continue lexer parser "" s >>= nextPhase
-- | Given a Parser action, a source, and the input, perform that action
-- passing the parser state between VM and Parser.
-continue :: Parser a -> String -> String -> VM a
-continue p s i = do
+continue :: Stream x Identity t => Lexer x -> ParserOf x a -> String -> String -> VM a
+continue l p s i = do
ps <- gets parserState
- case runParser (p >>= \r -> getState >>= \ps' -> return (r, ps')) ps s i of
+ case runParser l (LexerState []) s i of
Left e -> throwError (ParseError e)
- Right (ok, ps') -> do
- modify $ \e -> e { parserState = ps' }
- return ok
+ Right ts ->
+ case runParser (p >>= \r -> getState >>= \ps' -> return (r, ps')) ps s ts of
+ Left e -> throwError (ParseError e)
+ Right (ok, ps') -> do
+ modify $ \e -> e { parserState = ps' }
+ return ok
-- | Parse input i from source s, maintaining parser state between parses.
continuedParse :: String -> String -> VM [Expr]
-continuedParse i s = continue parser s i
+continuedParse i s = continue lexer parser s i
-- | Run an arbitrary Parser action with the VM's parser state.
withParser :: Parser a -> VM a
-withParser x = continue x "" ""
+withParser x = continue lexer x "" ""
diff --git a/src/Atomo/Parser/Base.hs b/src/Atomo/Parser/Base.hs
--- a/src/Atomo/Parser/Base.hs
+++ b/src/Atomo/Parser/Base.hs
@@ -2,217 +2,182 @@
module Atomo.Parser.Base where
import Control.Monad.Identity
-import Data.Char
-import Data.List (nub, sort)
import Text.Parsec
-import qualified Text.Parsec.Token as P
-import Atomo.Types (Expr(..), ParserState(..))
+import Atomo.Lexer.Base (TaggedToken(..), Token(..))
+import Atomo.Types (Expr(..), ParserState(..), Value(..), Option(..))
+import Atomo.Pretty
+import qualified Atomo.Types as T
-type Parser = ParsecT String ParserState Identity
+-- | A headless dispatch segment.
+--
+-- Used for both single dispatch chains and particles.
+data Chained
+ = CSingle String [Option Expr]
+ | CKeyword [String] [Expr] [Option Expr]
+ deriving Show
+type ParserOf a = ParsecT a ParserState Identity
+type Parser = ParserOf [TaggedToken]
-isOpLetter :: Char -> Bool
-isOpLetter c = c `elem` "!@#%&*-./\\?:" || isSymbol c
-isOperator :: String -> Bool
-isOperator "" = False
-isOperator cs = head cs `notElem` "@$~" && all isOpLetter cs
-
-def :: P.GenLanguageDef String ParserState Identity
-def = P.LanguageDef
- { P.commentStart = "{-"
- , P.commentEnd = "-}"
- , P.commentLine = "--"
- , P.nestedComments = True
- , P.identStart = satisfy (\c -> c == '_' || isLetter c || (c `notElem` "@$~:" && isOpLetter c))
- , P.identLetter = satisfy (\c -> c == '_' || isAlphaNum c || (c /= ':' && isOpLetter c))
- , P.opStart = satisfy (\c -> c `notElem` "@$~" && isOpLetter c)
- , P.opLetter = satisfy isOpLetter
- , P.reservedOpNames = [",", "|"]
- , P.reservedNames = ["operator", "macro", "for-macro", "this", "True", "False"]
- , P.caseSensitive = True
- }
-
-tp :: P.GenTokenParser String ParserState Identity
-tp = makeTokenParser def
-
-eol :: Parser ()
-eol = newline >> return ()
-
-lexeme :: Parser a -> Parser a
-lexeme = P.lexeme tp
-
-anyIdent :: Parser String
-anyIdent = try $ do
- c <- P.identStart def
- cs <- many (P.identLetter def)
- if isOperator (c:cs)
- then unexpected "operator"
- else do
-
- ps <- getState
- if c == '#' && psInQuote ps
- then return ((c:cs) ++ ":" ++ show (psClock ps))
- else return (c:cs)
-
-anyIdentifier :: Parser String
-anyIdentifier = lexeme anyIdent
-
-identifier :: Parser String
-identifier = lexeme ident
-
-ident :: Parser String
-ident = do
- name <- anyIdent
- if isReservedName name
- then unexpected ("reserved word " ++ show name)
- else return name
-
-parens :: Parser a -> Parser a
-parens = P.parens tp
+showToken :: Token -> String
+showToken TokEnd = "ending"
+showToken t = show (pretty t)
-brackets :: Parser a -> Parser a
-brackets = P.brackets tp
+withToken :: (Token -> Maybe a) -> Parser a
+withToken f =
+ tokenPrim
+ (showToken . tToken)
+ (\_ t _ -> tLocation t)
+ (f . tToken)
-braces :: Parser a -> Parser a
-braces = P.braces tp
+someToken :: Parser Token
+someToken = withToken Just
-comma :: Parser String
-comma = P.comma tp
+endOfFile :: Parser ()
+endOfFile = try $ choice
+ [ do
+ t <- someToken
+ unexpected (showToken t)
+ , return ()
+ ]
-commaSep :: Parser a -> Parser [a]
-commaSep = P.commaSep tp
+keyword :: Parser String
+keyword = withToken $ \t ->
+ case t of
+ TokKeyword n -> Just n
+ _ -> Nothing
-commaSep1 :: Parser a -> Parser [a]
-commaSep1 = P.commaSep1 tp
+optionalKeyword :: Parser String
+optionalKeyword = withToken $ \t ->
+ case t of
+ TokOptional n -> Just n
+ _ -> Nothing
-dot :: Parser String
-dot = P.dot tp
+optionalFlag :: Parser String
+optionalFlag = withToken $ \t ->
+ case t of
+ TokOptionalFlag n -> Just n
+ _ -> Nothing
operator :: Parser String
-operator = try $ do
- c <- P.opStart def
- cs <- many (P.opLetter def)
- if (c:cs) `elem` P.reservedOpNames def
- then unexpected ("reserved operator " ++ show (c:cs))
- else return (c:cs)
-
-reserved :: String -> Parser ()
-reserved = P.reserved tp
-
-reservedOp :: String -> Parser ()
-reservedOp = P.reservedOp tp
+operator = withToken $ \t ->
+ case t of
+ TokOperator n -> Just n
+ _ -> Nothing
-integer :: Parser Integer
-integer = do
- f <- sign
- n <- natural
- return (f n)
- where
- sign = choice
- [ char '-' >> return negate
- , char '+' >> return id
- , return id
- ]
+identifier :: Parser String
+identifier = withToken $ \t ->
+ case t of
+ TokIdentifier n ->
+ Just n
+ _ -> Nothing
-float :: Parser Double
-float = do
- f <- sign
- n <- P.float tp
- return (f n)
+particle :: Parser Chained
+particle = withToken $ \t ->
+ case t of
+ TokParticle ns ->
+ Just (CKeyword ns (replicate (length ns) wildcard) [])
+ _ -> Nothing
where
- sign = choice
- [ char '-' >> return negate
- , char '+' >> return id
- , return id
- ]
-
-natural :: Parser Integer
-natural = P.natural tp
-
-symbol :: String -> Parser String
-symbol = P.symbol tp
-
-delimit :: String -> Parser String
-delimit n = whiteSpace >> symbol n
-
-stringLiteral :: Parser String
-stringLiteral = P.stringLiteral tp
+ wildcard = EDispatch Nothing (T.single "_" (ETop Nothing))
-charLiteral :: Parser Char
-charLiteral = P.charLiteral tp
+primitive :: Parser Value
+primitive = withToken $ \t ->
+ case t of
+ TokPrimitive v -> Just v
+ _ -> Nothing
-colon :: Parser ()
-colon = char ':' >> return ()
+macroQuote :: Parser (String, String, [Char])
+macroQuote = withToken $ \t ->
+ case t of
+ TokMacroQuote n r fs -> Just (n, r, fs)
+ _ -> Nothing
-wsBlock :: Parser a -> Parser [a]
-wsBlock = wsDelim ";"
+punctuation :: Char -> Parser ()
+punctuation p = withToken $ \t ->
+ case t of
+ TokPunctuation c | c == p -> Just ()
+ TokOpen c | c == p -> Just ()
+ TokClose c | c == p -> Just ()
+ _ -> Nothing
-wsDelim :: String -> Parser a -> Parser [a]
-wsDelim d = indentAware (\n o -> sourceColumn n == sourceColumn o) (delimit d >> return True) False
+reserved :: String -> Parser ()
+reserved r = withToken $ \t ->
+ case t of
+ TokReserved n | n == r -> Just ()
+ _ -> Nothing
-wsMany1 :: Parser a -> Parser [a]
-wsMany1 p = do
- ps <- indentAware chainContinue (return False) True p
- if null ps
- then fail "needed more than one"
- else return ps
+anyReserved :: Parser String
+anyReserved = withToken $ \t ->
+ case t of
+ TokReserved n -> Just n
+ _ -> Nothing
-wsMany :: Parser a -> Parser [a]
-wsMany = indentAware chainContinue (return False) True
+end :: Parser ()
+end = withToken $ \t ->
+ case t of
+ TokEnd -> Just ()
+ _ -> Nothing
-wsManyStart :: Show a => Parser a -> Parser a -> Parser [a]
-wsManyStart s p = do
- ps <- indentAwareStart chainContinue (return False) True s p
- if null ps
- then fail "needed more than one"
- else return ps
+symbol :: String -> Parser ()
+symbol s = withToken $ \t ->
+ case t of
+ TokIdentifier n | n == s -> Just ()
+ _ -> Nothing
-chainContinue :: SourcePos -> SourcePos -> Bool
-chainContinue n o = sourceLine o == sourceLine n || sourceColumn n > sourceColumn o
+integer :: Parser Integer
+integer = withToken $ \t ->
+ case t of
+ TokPrimitive (Integer i) -> Just i
+ _ -> Nothing
-indentAware :: (SourcePos -> SourcePos -> Bool) -> Parser Bool -> Bool -> Parser a -> Parser [a]
-indentAware cmp delim allowSeq p = indentAwareStart cmp delim allowSeq p p
+parens :: Parser a -> Parser a
+parens p = do
+ punctuation '('
+ r <- p
+ optional end
+ punctuation ')'
+ return r
-indentAwareStart :: (SourcePos -> SourcePos -> Bool) -> Parser Bool -> Bool -> Parser a -> Parser a -> Parser [a]
-indentAwareStart cmp delim allowSeq s p = do
- start <- getPosition
- wsmany start []
- where
- wsmany o es = choice
- [ do
- x <- if null es then s else try p
+brackets :: Parser a -> Parser a
+brackets p = do
+ punctuation '['
+ r <- p
+ punctuation ']'
+ return r
- new <- lookAhead (whiteSpace >> getPosition)
- sequential <- liftM (== new) $ lookAhead (spacing >> getPosition)
+braces :: Parser a -> Parser a
+braces p = do
+ punctuation '{'
+ r <- p
+ punctuation '}'
+ return r
- delimited <- option False $ try delim
+blockOf :: Parser a -> Parser [a]
+blockOf p = sepEndBy p end
- if delimited || cmp new o || (allowSeq && sequential)
- then whiteSpace >> wsmany o (es ++ [x])
- else return (es ++ [x])
- , return es
- ]
+blockOf1 :: Parser a -> Parser [a]
+blockOf1 p = sepEndBy1 p end
-keyword :: Parser a -> Parser (String, a)
-keyword p = do
- name <- keywordName
+keywordSegment :: Parser a -> Parser (String, a)
+keywordSegment p = do
+ name <- keyword
target <- p
return (name, target)
-keywordName :: Parser String
-keywordName = do
- n <- try (ident >>= \name -> char ':' >> return name) <|> operator
- whiteSpace1
- return n
+optionSegment :: Parser a -> Parser (String, a)
+optionSegment p = do
+ name <- optionalKeyword
+ target <- p
+ return (name, target)
-keywords :: Show a => ([String] -> [a] -> b) -> a -> Parser a -> Parser b
-keywords c d p = do
- r <- choice [try (lookAhead keywordName) >> return d, p]
- (ns, rs) <- liftM unzip $ wsMany1 (keyword p)
- return (c ns (r:rs))
+optionFlag :: Parser (String, Expr)
+optionFlag = do
+ name <- optionalFlag
+ return (name, EPrimitive Nothing (Boolean True))
tagged :: Parser Expr -> Parser Expr
tagged p = do
@@ -220,397 +185,8 @@
r <- p
return r { eLocation = Just pos }
-makeTokenParser :: P.GenLanguageDef String ParserState Identity -> P.GenTokenParser String ParserState Identity
-makeTokenParser languageDef
- = P.TokenParser{ P.identifier = identifier
- , P.reserved = reserved
- , P.operator = operator
- , P.reservedOp = reservedOp
-
- , P.charLiteral = charLiteral
- , P.stringLiteral = stringLiteral
- , P.natural = natural
- , P.integer = integer
- , P.float = float
- , P.naturalOrFloat = naturalOrFloat
- , P.decimal = decimal
- , P.hexadecimal = hexadecimal
- , P.octal = octal
-
- , P.symbol = symbol
- , P.lexeme = lexeme
- , P.whiteSpace = whiteSpace
-
- , P.parens = parens
- , P.braces = braces
- , P.angles = angles
- , P.brackets = brackets
- , P.squares = brackets
- , P.semi = semi
- , P.comma = comma
- , P.colon = colon
- , P.dot = dot
- , P.semiSep = semiSep
- , P.semiSep1 = semiSep1
- , P.commaSep = commaSep
- , P.commaSep1 = commaSep1
- }
- where
-
- -----------------------------------------------------------
- -- Bracketing
- -----------------------------------------------------------
- parens = between (open "(") (close ")")
- braces = between (open "{") (close "}")
- angles = between (open "<") (close ">")
- brackets = between (open "[") (close "]")
-
- semi = delimit ";"
- comma = delimit ","
- dot = delimit "."
- colon = delimit ":"
-
- commaSep p = sepBy p comma
- semiSep p = sepBy p semi
-
- commaSep1 p = sepBy1 p comma
- semiSep1 p = sepBy1 p semi
-
-
- -----------------------------------------------------------
- -- Chars & Strings
- -----------------------------------------------------------
- charLiteral = lexeme (char '$' >> characterChar)
- "character"
-
- characterChar = charLetter <|> charEscape
- "literal character"
-
- charEscape = do{ char '\\'; escapeCode }
- charLetter = satisfy (\c -> (c /= '\\') && (c > '\026'))
-
-
-
- stringLiteral = lexeme (
- do{ str <- between (char '"')
- (char '"' "end of string")
- (many stringChar)
- ; return (foldr (maybe id (:)) "" str)
- }
- "literal string")
-
- stringChar = do{ c <- stringLetter; return (Just c) }
- <|> stringEscape
- "string character"
-
- stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))
-
- stringEscape = do{ char '\\'
- ; do{ escapeGap ; return Nothing }
- <|> do{ escapeEmpty; return Nothing }
- <|> do{ esc <- escapeCode; return (Just esc) }
- }
-
- escapeEmpty = char '&'
- escapeGap = do{ many1 space
- ; char '\\' "end of string gap"
- }
-
-
-
- -- escape codes
- escapeCode = charEsc <|> charNum <|> charAscii <|> charControl
- "escape code"
-
- charControl = do{ char '^'
- ; code <- upper
- ; return (toEnum (fromEnum code - fromEnum 'A'))
- }
-
- charNum = do{ code <- decimal
- <|> do{ char 'o'; number 8 octDigit }
- <|> do{ char 'x'; number 16 hexDigit }
- ; return (toEnum (fromInteger code))
- }
-
- charEsc = choice (map parseEsc escMap)
- where
- parseEsc (c,code) = do{ char c; return code }
-
- charAscii = choice (map parseAscii asciiMap)
- where
- parseAscii (asc,code) = try (do{ string asc; return code })
-
-
- -- escape code tables
- escMap = zip "abfnrtv\\\"" "\a\b\f\n\r\t\v\\\""
- asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)
-
- ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM",
- "FS","GS","RS","US","SP"]
- ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL",
- "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB",
- "CAN","SUB","ESC","DEL"]
-
- ascii2 = "\b\t\n\v\f\r\SO\SI\EM\FS\GS\RS\US "
- ascii3 = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\a\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\SUB\ESC\DEL"
-
-
- -----------------------------------------------------------
- -- Numbers
- -----------------------------------------------------------
- naturalOrFloat = lexeme natFloat "number"
-
- float = lexeme floating "float"
- integer = lexeme int "integer"
- natural = lexeme nat "natural"
-
-
- -- floats
- floating = do{ n <- decimal
- ; fractExponent n
- }
-
-
- natFloat = do{ char '0'
- ; zeroNumFloat
- }
- <|> decimalFloat
-
- zeroNumFloat = do{ n <- hexadecimal <|> octal
- ; return (Left n)
- }
- <|> decimalFloat
- <|> fractFloat 0
- <|> return (Left 0)
-
- decimalFloat = do{ n <- decimal
- ; option (Left n)
- (fractFloat n)
- }
-
- fractFloat n = do{ f <- fractExponent n
- ; return (Right f)
- }
-
- fractExponent n = do{ fract <- fraction
- ; expo <- option 1.0 exponent'
- ; return ((fromInteger n + fract)*expo)
- }
- <|>
- do{ expo <- exponent'
- ; return (fromInteger n*expo)
- }
-
- fraction = do{ char '.'
- ; digits <- many1 digit "fraction"
- ; return (foldr op 0.0 digits)
- }
- "fraction"
- where
- op d f = (f + fromIntegral (digitToInt d))/10.0
-
- exponent' = do{ oneOf "eE"
- ; f <- sign
- ; e <- decimal "exponent"
- ; return (power (f e))
- }
- "exponent"
- where
- power e | e < 0 = 1.0/power(-e)
- | otherwise = fromInteger (10^e)
-
-
- -- integers and naturals
- int = do{ f <- sign
- ; n <- nat
- ; return (f n)
- }
-
- sign = (char '-' >> return negate)
- <|> (char '+' >> return id)
- <|> return id
-
- nat = zeroNumber <|> decimal
-
- zeroNumber = do{ char '0'
- ; hexadecimal <|> octal <|> decimal <|> return 0
- }
- "zeroNumber"
-
- decimal = number 10 digit
- hexadecimal = do{ oneOf "xX"; number 16 hexDigit }
- octal = do{ oneOf "oO"; number 8 octDigit }
-
- number base baseDigit
- = do{ digits <- many1 baseDigit
- ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits
- ; seq n (return n)
- }
-
- -----------------------------------------------------------
- -- Operators & reserved ops
- -----------------------------------------------------------
- reservedOp name =
- lexeme $ try $
- do{ string name
- ; notFollowedBy (P.opLetter languageDef) ("end of " ++ show name)
- }
-
- operator =
- lexeme $ try $
- do{ name <- oper
- ; if isReservedOp name
- then unexpected ("reserved operator " ++ show name)
- else return name
- }
-
- oper =
- try (do{ c <- (P.opStart languageDef)
- ; cs <- many (P.opLetter languageDef)
- ; return (c:cs)
- })
- "operator"
-
- isReservedOp =
- isReserved (sort (P.reservedOpNames languageDef))
-
-
- -----------------------------------------------------------
- -- Identifiers & Reserved words
- -----------------------------------------------------------
- reserved name =
- lexeme $ try $
- do{ caseString name
- ; notFollowedBy (P.identLetter languageDef) ("end of " ++ show name)
- }
-
- caseString name
- | P.caseSensitive languageDef = string name
- | otherwise = do{ walk name; return name }
- where
- walk [] = return ()
- walk (c:cs) = do{ caseChar c msg; walk cs }
-
- caseChar c | isAlpha c = char (toLower c) <|> char (toUpper c)
- | otherwise = char c
-
- msg = show name
-
-
- identifier =
- try $
- do{ name <- ident
- ; if isReservedName name
- then unexpected ("reserved word " ++ show name)
- else return name
- }
-
-
- ident = try (do
- c <- P.identStart def
- cs <- many (P.identLetter def)
- if isOperator (c:cs)
- then unexpected "operator"
- else return (c:cs))
- "identifier"
-
-
-
- -----------------------------------------------------------
- -- White space & symbols
- -----------------------------------------------------------
- delimit name
- = try $ do{ whiteSpace; symbol name }
-
- open = symbol
-
- close name
- = do{ whiteSpace; s <- string name; spacing; return s }
-
- symbol name
- = do{ s <- string name; whiteSpace; return s }
-
- lexeme p
- = do{ x <- p; spacing; return x }
-
- --whiteSpace
- whiteSpace = do
- spacing
- skipMany (try $ spacing >> newline)
- spacing
-
-isReservedName :: String -> Bool
-isReservedName name = isReserved reservedNames caseName
- where
- caseName
- | P.caseSensitive def = name
- | otherwise = map toLower name
-
- reservedNames
- | P.caseSensitive def = sortedNames
- | otherwise = map (map toLower) sortedNames
- where
- sortedNames = sort (P.reservedNames def)
-
-isReserved :: [String] -> String -> Bool
-isReserved names name
- = scan names
- where
- scan [] = False
- scan (r:rs) =
- case compare r name of
- LT -> scan rs
- EQ -> True
- GT -> False
-
-
-whiteSpace :: Parser ()
-whiteSpace = P.whiteSpace tp
-
-whiteSpace1 :: Parser ()
-whiteSpace1 = (space <|> newline) >> whiteSpace
-
-simpleSpace :: Parser ()
-simpleSpace = skipMany1 $ satisfy (`elem` " \t\f\v\xa0")
-
-spacing :: Parser ()
-spacing = skipMany spacing1
-
-spacing1 :: Parser ()
-spacing1 | noLine && noMulti = simpleSpace "whitespace"
- | noLine = simpleSpace <|> multiLineComment "whitespace or multiline comment"
- | noMulti = simpleSpace <|> oneLineComment "whitespace or line comment"
- | otherwise = simpleSpace <|> oneLineComment <|> multiLineComment "whitespace or commend"
- where
- noLine = null (P.commentLine def)
- noMulti = null (P.commentStart def)
-
-oneLineComment :: Parser ()
-oneLineComment = try (string (P.commentLine def)) >> skipMany (satisfy (/= '\n'))
-
-multiLineComment :: Parser ()
-multiLineComment = try (string (P.commentStart def)) >> inComment
-
-inComment :: Parser ()
-inComment | P.nestedComments def = inCommentMulti
- | otherwise = inCommentSingle
-
-inCommentMulti :: Parser ()
-inCommentMulti = (try (string (P.commentEnd def)) >> return ())
- <|> (multiLineComment >> inCommentMulti)
- <|> (skipMany1 (noneOf startEnd) >> inCommentMulti)
- <|> (oneOf startEnd >> inCommentMulti)
- "end of comment"
- where
- startEnd = nub (P.commentEnd def ++ P.commentStart def)
-
-inCommentSingle :: Parser ()
-inCommentSingle = (try (string (P.commentEnd def)) >> return ())
- <|> (skipMany1 (noneOf startEnd) >> inCommentSingle)
- <|> (oneOf startEnd >> inCommentSingle)
- "end of comment"
- where
- startEnd = nub (P.commentEnd def ++ P.commentStart def)
-
-
+followedBy :: Parser a -> Parser Bool
+followedBy p = choice
+ [ lookAhead (try p) >> return True
+ , return False
+ ]
diff --git a/src/Atomo/Parser/Expand.hs b/src/Atomo/Parser/Expand.hs
--- a/src/Atomo/Parser/Expand.hs
+++ b/src/Atomo/Parser/Expand.hs
@@ -9,6 +9,9 @@
import Atomo.Types
+gensym :: Char
+gensym = '!'
+
nextPhase :: [Expr] -> VM [Expr]
nextPhase es = do
mapM_ doPragmas es
@@ -16,35 +19,42 @@
doPragmas :: Expr -> VM ()
-doPragmas (Dispatch { eMessage = em }) =
+doPragmas (EDispatch { eMessage = em }) =
pragmas em
where
- pragmas (Single _ _ t) =
+ pragmas (Single { mTarget = t }) =
doPragmas t
- pragmas (Keyword _ _ ts) =
+ pragmas (Keyword { mTargets = ts }) =
mapM_ doPragmas ts
-doPragmas (Define { eExpr = e }) = do
+doPragmas (EDefine { eExpr = e }) = do
doPragmas e
-doPragmas (Set { eExpr = e }) = do
+doPragmas (ESet { eExpr = e }) = do
doPragmas e
doPragmas (EBlock { eContents = es }) = do
mapM_ doPragmas es
doPragmas (EList { eContents = es }) = do
mapM_ doPragmas es
-doPragmas (EMacro { emPattern = p, eExpr = e }) = do
- {-e' <- doPragmas e-}
- macroExpand e >>= addMacro p
+doPragmas (ETuple { eContents = es }) = do
+ mapM_ doPragmas es
+doPragmas (EMacro { emPattern = p, eExpr = e }) =
+ addMacro p e
doPragmas (EParticle { eParticle = ep }) =
case ep of
- PMKeyword _ mes ->
+ Keyword { mTargets = mes } ->
forM_ mes $ \me ->
case me of
Nothing -> return ()
Just e -> doPragmas e
+ Single { mTarget = Just e } ->
+ doPragmas e
+
_ -> return ()
-doPragmas (Operator {}) = return ()
-doPragmas (Primitive {}) = return ()
+doPragmas (EMatch { eTarget = e, eBranches = bs }) = do
+ doPragmas e
+ forM_ bs (doPragmas . snd)
+doPragmas (EOperator {}) = return ()
+doPragmas (EPrimitive {}) = return ()
doPragmas (EForMacro { eExpr = e }) = do
env <- gets (psEnvironment . parserState)
macroExpand e >>= withTop env . eval
@@ -62,6 +72,7 @@
mapM_ (\(_, b) -> doPragmas b) bs
doPragmas e
doPragmas (EGetDynamic {}) = return ()
+doPragmas (EMacroQuote {}) = return ()
-- | Defines a macro, given its pattern and expression.
@@ -99,35 +110,47 @@
-- Every other expression just recursively calls macroExpand on any
-- sub-expressions.
macroExpand :: Expr -> VM Expr
-macroExpand d@(Dispatch { eMessage = em }) = do
+macroExpand d@(EDispatch { eMessage = em }) = do
mm <- findMacro msg
case mm of
Just m -> do
modifyPS $ \ps -> ps { psClock = psClock ps + 1 }
- Expression ne <- runMethod m msg >>= findExpression
+ eb <- gensyms (mExpr m) >>= macroExpand
+ Expression ne <-
+ runMethod (m { mExpr = eb }) msg
+ >>= findExpression
- macroExpand ne
+ gensyms ne >>= macroExpand
Nothing -> do
nem <- expanded em
return d { eMessage = nem }
where
- expanded (Single i n t) = do
+ expanded s@(Single { mTarget = t }) = do
nt <- macroExpand t
- return (Single i n nt)
- expanded (Keyword i ns ts) = do
+ return s { mTarget = nt }
+ expanded k@(Keyword { mTargets = ts }) = do
nts <- mapM macroExpand ts
- return (Keyword i ns nts)
+ return k { mTargets = nts }
msg =
case em of
- Single i n t -> Single i n (Expression t)
- Keyword i ns ts -> Keyword i ns (map Expression ts)
-macroExpand d@(Define { eExpr = e }) = do
+ Single i n t os -> Single i n (Expression t) (map exprOpt os)
+ Keyword i ns ts os -> Keyword i ns (map Expression ts) (map exprOpt os)
+
+ exprOpt (Option i n e) = Option i n (Expression e)
+macroExpand e@(EMacroQuote { eName = n, eRaw = r, eFlags = fs }) = do
+ t <- gets (psEnvironment . parserState)
+ liftM (EPrimitive (eLocation e)) . dispatch $
+ keyword'
+ ["quote", "as"]
+ [t, string r, particle n]
+ [option "flags" (list (map Character fs))]
+macroExpand d@(EDefine { eExpr = e }) = do
e' <- macroExpand e
return d { eExpr = e' }
-macroExpand s@(Set { eExpr = e }) = do
+macroExpand s@(ESet { eExpr = e }) = do
e' <- macroExpand e
return s { eExpr = e' }
macroExpand b@(EBlock { eContents = es }) = do
@@ -136,19 +159,27 @@
macroExpand l@(EList { eContents = es }) = do
nes <- mapM macroExpand es
return l { eContents = nes }
-macroExpand m@(EMacro { eExpr = e }) = do -- TODO: is this sane?
- e' <- macroExpand e
- return m { eExpr = e' }
-macroExpand p@(EParticle { eParticle = ep }) =
+macroExpand t@(ETuple { eContents = es }) = do
+ nes <- mapM macroExpand es
+ return t { eContents = nes }
+macroExpand p@(EParticle { eParticle = ep }) = do
+ nos <- forM (mOptionals ep) $ \(Option i n me) -> do
+ ne <- maybe (return Nothing) (liftM Just . macroExpand) me
+ return (Option i n ne)
+
case ep of
- PMKeyword ns mes -> do
+ Keyword { mNames = ns, mTargets = mes } -> do
nmes <- forM mes $ \me ->
case me of
Nothing -> return Nothing
Just e -> liftM Just (macroExpand e)
- return p { eParticle = PMKeyword ns nmes }
+ return p { eParticle = keyword' ns nmes nos }
+ Single { mName = n, mTarget = Just e } -> do
+ ne <- macroExpand e
+ return p { eParticle = single' n (Just ne) nos }
+
_ -> return p
macroExpand s@(ESetDynamic { eExpr = e }) = do
e' <- macroExpand e
@@ -160,17 +191,131 @@
bs' <- mapM (\(p, b) -> macroExpand b >>= \nb -> return (p, nb)) bs
e' <- macroExpand e
return n { eBindings = bs', eExpr = e' }
+macroExpand m@(EMatch { eTarget = t, eBranches = bs }) = do
+ nt <- macroExpand t
+ nbs <- forM bs $ \(p, e) -> do
+ ne <- macroExpand e
+ return (p, ne)
+ return m { eTarget = nt, eBranches = nbs }
+macroExpand m@(EMacro {}) = return m
macroExpand e@(EGetDynamic {}) = return e
-macroExpand e@(Operator {}) = return e
-macroExpand e@(Primitive {}) = return e
+macroExpand e@(EOperator {}) = return e
+macroExpand e@(EPrimitive {}) = return e
macroExpand e@(EForMacro {}) = return e
macroExpand e@(ETop {}) = return e
macroExpand e@(EVM {}) = return e
--- TODO: follow through EQuote into EUnquote
-macroExpand e@(EQuote {}) = return e
+macroExpand e@(EQuote {}) = expandQuote e
macroExpand e@(EUnquote {}) = return e
+expandQuote :: Expr -> VM Expr
+expandQuote = throughQuotes 0 $ \n e ->
+ case n of
+ 0 -> macroExpand e
+ _ -> return e
+gensyms :: Expr -> VM Expr
+gensyms = throughQuotes 0 $ \_ e ->
+ case e of
+ EDispatch { eMessage = m@(Single { mName = x:xs }) }
+ | x == gensym -> do
+ c <- gets (psClock . parserState)
+ return e
+ { eMessage = single'
+ (xs ++ ":" ++ show c)
+ (mTarget m)
+ (mOptionals m)
+ }
+ _ -> return e
+
+throughQuotes :: Int -> (Int -> Expr -> VM Expr) -> Expr -> VM Expr
+throughQuotes 0 f u@(EUnquote { eExpr = e }) = do
+ ne <- f 0 e
+ return u { eExpr = ne }
+throughQuotes n f u@(EUnquote { eExpr = a }) = do
+ ne <- throughQuotes (n - 1) f a
+ f n u { eExpr = ne }
+-- don't expand through definitions, as gensyms in those
+-- are likely used elsewhere where they'll be expanded
+throughQuotes n f d@(EDefine {}) = f n d
+throughQuotes n f s@(ESet { ePattern = p, eExpr = e }) = do
+ np <- expandPattern p
+ ne <- throughQuotes n f e
+ f n s { ePattern = np, eExpr = ne }
+throughQuotes n f d@(EDispatch { eMessage = m@(Keyword {}) }) = do
+ nts <- mapM (throughQuotes n f) (mTargets m)
+ f n d { eMessage = m { mTargets = nts } }
+throughQuotes n f d@(EDispatch { eMessage = m@(Single {}) }) = do
+ nt <- throughQuotes n f (mTarget m)
+ f n d { eMessage = m { mTarget = nt } }
+throughQuotes n f b@(EBlock { eArguments = ps, eContents = es }) = do
+ nps <- mapM expandPattern ps
+ nes <- mapM (throughQuotes n f) es
+ f n b { eArguments = nps, eContents = nes }
+throughQuotes n f l@(EList { eContents = es }) = do
+ nes <- mapM (throughQuotes n f) es
+ f n l { eContents = nes }
+throughQuotes n f t@(ETuple { eContents = es }) = do
+ nes <- mapM (throughQuotes n f) es
+ f n t { eContents = nes }
+throughQuotes n f m@(EMacro { eExpr = e }) = do
+ ne <- throughQuotes n f e
+ f n m { eExpr = ne }
+throughQuotes n f p@(EParticle { eParticle = m@(Keyword { mTargets = mes }) }) = do
+ nmes <- forM mes $ maybe (return Nothing) (liftM Just . throughQuotes n f)
+ f n p { eParticle = m { mTargets = nmes } }
+throughQuotes n f p@(EParticle { eParticle = m@(Single { mTarget = me }) }) = do
+ nme <- maybe (return Nothing) (liftM Just . throughQuotes n f) me
+ f n p { eParticle = m { mTarget = nme } }
+throughQuotes n f s@(ESetDynamic { eExpr = e }) = do
+ e' <- throughQuotes n f e
+ f n s { eExpr = e' }
+throughQuotes n f d@(EDefineDynamic { eExpr = e }) = do
+ e' <- throughQuotes n f e
+ f n d { eExpr = e' }
+throughQuotes n f d@(ENewDynamic { eBindings = bs, eExpr = e }) = do
+ nbs <- mapM (\(p, b) -> f n b >>= \nb -> return (p, nb)) bs
+ ne <- throughQuotes n f e
+ f n d { eBindings = nbs, eExpr = ne }
+throughQuotes n f q@(EQuote { eExpr = e }) = do
+ ne <- throughQuotes (n + 1) f e
+ f (n + 1) q { eExpr = ne }
+throughQuotes n f m@(EMatch { eTarget = t, eBranches = bs }) = do
+ nt <- throughQuotes n f t
+ nbs <- mapM (\(p, b) -> f n b >>= \nb -> return (p, nb)) bs
+ f n m { eTarget = nt, eBranches = nbs }
+throughQuotes n f e = f n e
+
+expandPattern :: Pattern -> VM Pattern
+expandPattern (PNamed n p)
+ | head n == gensym = do
+ c <- gets (psClock . parserState)
+ np <- expandPattern p
+ return (PNamed (tail n ++ ":" ++ show c) np)
+ | otherwise = liftM (PNamed n) (expandPattern p)
+expandPattern (PHeadTail h t) =
+ liftM2 PHeadTail (expandPattern h) (expandPattern t)
+expandPattern (PList ps) =
+ liftM PList (mapM expandPattern ps)
+expandPattern (PTuple ps) =
+ liftM PTuple (mapM expandPattern ps)
+expandPattern (PMessage (m@(Single { mTarget = t }))) = do
+ nt <- expandPattern t
+ return $ PMessage m { mTarget = nt }
+expandPattern (PMessage (m@(Keyword { mTargets = ts }))) = do
+ nts <- mapM expandPattern ts
+ return $ PMessage m { mTargets = nts }
+expandPattern (PInstance p) =
+ liftM PInstance (expandPattern p)
+expandPattern (PStrict p) =
+ liftM PStrict (expandPattern p)
+expandPattern (PVariable p) =
+ liftM PVariable (expandPattern p)
+expandPattern (PExpr p) =
+ liftM PExpr (expandQuote p)
+expandPattern (PPMKeyword ns ps) =
+ liftM (PPMKeyword ns) (mapM expandPattern ps)
+expandPattern p = return p
+
-- | find a findMacro method for message `m' on object `o'
findMacro :: Message Value -> VM (Maybe Method)
findMacro m = do
@@ -182,7 +327,7 @@
methods (Keyword {}) = liftM (snd . psMacros) getPS
firstMatch _ _ [] = Nothing
- firstMatch ids' m' (mt:mts)
+ firstMatch ids' m' (mt:mts)
| match ids' Nothing (PMessage (mPattern mt)) (Message m') =
Just mt
| otherwise = firstMatch ids' m' mts
diff --git a/src/Atomo/Parser/Expr.hs b/src/Atomo/Parser/Expr.hs
--- a/src/Atomo/Parser/Expr.hs
+++ b/src/Atomo/Parser/Expr.hs
@@ -1,23 +1,15 @@
module Atomo.Parser.Expr where
-import Control.Arrow (first, second)
import Control.Monad.State
-import Data.Maybe (fromJust, isJust)
+import Data.Maybe (fromJust)
import Text.Parsec
import Atomo.Parser.Base
-import Atomo.Parser.Primitive
import Atomo.Pattern
-import Atomo.Types hiding (keyword, string)
+import Atomo.Types hiding (keyword, option, particle, string)
import qualified Atomo.Types as T
--- | The types of values in Dispatch syntax.
-data Dispatch
- = DParticle (Particle Expr)
- | DNormal Expr
- deriving Show
-
-- | The default precedence for an operator (5).
defaultPrec :: Integer
defaultPrec = 5
@@ -28,9 +20,7 @@
[ pOperator
, pMacro
, pForMacro
- , try pDispatch
- , pLiteral
- , parens pExpr
+ , pDispatch
]
"expression"
@@ -39,7 +29,9 @@
pLiteral = choice
[ pThis
, pBlock
+ , pMacroQuote
, pList
+ , pTuple
, pParticle
, pQuoted
, pQuasiQuoted
@@ -52,44 +44,48 @@
--
-- Examples: @1@, @2.0@, @3\/4@, @$d@, @\"foo\"@, @True@, @False@
pPrimitive :: Parser Expr
-pPrimitive = tagged $ liftM (Primitive Nothing) pPrim
+pPrimitive = tagged $ liftM (EPrimitive Nothing) primitive
-- | The @this@ keyword, i.e. the toplevel object literal.
pThis :: Parser Expr
-pThis = tagged $ reserved "this" >> return (ETop Nothing)
+pThis = tagged (reserved "this" >> return (ETop Nothing))
+ "this"
-- | An expression literal.
--
-- Example: @'1@, @'(2 + 2)@
pQuoted :: Parser Expr
-pQuoted = tagged $ do
- char '\''
+pQuoted = tagged (do
+ punctuation '\''
e <- pSpacedExpr
- return (Primitive Nothing (Expression e))
+ return (EPrimitive Nothing (Expression e)))
+ "quoted expression"
-- | An expression literal that may contain "unquotes" - expressions to splice
-- in to yield a different expression.
--
-- Examples: @`a@, @`(1 + ~(2 + 2))@
pQuasiQuoted :: Parser Expr
-pQuasiQuoted = tagged $ do
- char '`'
+pQuasiQuoted = tagged (do
+ punctuation '`'
modifyState $ \ps -> ps { psInQuote = True }
e <- pSpacedExpr
modifyState $ \ps -> ps { psInQuote = False }
- return (EQuote Nothing e)
+ return (EQuote Nothing e))
+ "quasiquoted expression"
-- | An unquote expression, used inside a quasiquote.
---
+--
-- Examples: @~1@, @~(2 + 2)@
pUnquoted :: Parser Expr
-pUnquoted = tagged $ do
- char '~'
+pUnquoted = tagged (do
+ punctuation '~'
iq <- fmap psInQuote getState
modifyState $ \ps -> ps { psInQuote = False }
e <- pSpacedExpr
modifyState $ \ps -> ps { psInQuote = iq }
- return (EUnquote Nothing e)
+ return (EUnquote Nothing e))
+ "unquoted expression"
-- | Any expression that fits into one lexical "space" - either a simple
-- literal value, a single dispatch to the toplevel object, or an expression in
@@ -98,24 +94,20 @@
-- Examples: @1@, @[1, 2]@, @a@, @(2 + 2)@
pSpacedExpr :: Parser Expr
pSpacedExpr = pLiteral <|> simpleDispatch <|> parens pExpr
- where
- simpleDispatch = tagged $ do
- name <- ident
- notFollowedBy (char ':')
- spacing
- return (Dispatch Nothing (single name (ETop Nothing)))
+-- | A single message sent to the toplevel object.
+simpleDispatch :: Parser Expr
+simpleDispatch = tagged $ do
+ name <- identifier
+ return (EDispatch Nothing (single name (ETop Nothing)))
+
-- | The for-macro "pragma."
--
-- Example: @for-macro 1 print@
pForMacro :: Parser Expr
pForMacro = tagged (do
reserved "for-macro"
-
- whiteSpace
-
e <- pExpr
-
return (EForMacro Nothing e))
"for-macro expression"
@@ -125,15 +117,8 @@
pMacro :: Parser Expr
pMacro = tagged (do
reserved "macro"
-
- whiteSpace
-
p <- parens (liftM (fromJust . toMacroPattern) pExpr)
-
- whiteSpace
-
e <- pExpr
-
return (EMacro Nothing p e))
"macro definition"
@@ -145,20 +130,18 @@
pOperator = tagged (do
reserved "operator"
- whiteSpace
-
info <- choice
[ do
a <- choice
[ symbol "right" >> return ARight
, symbol "left" >> return ALeft
]
- prec <- option defaultPrec (try integer)
+ prec <- option defaultPrec integer
return (a, prec)
, liftM ((,) ALeft) integer
]
- ops <- operator `sepBy1` spacing
+ ops <- many operator
forM_ ops $ \name ->
modifyState $ \ps -> ps
@@ -166,250 +149,268 @@
(name, info) : psOperators ps
}
- return (uncurry (Operator Nothing ops) info))
- "operator pragma"
+ return (uncurry (EOperator Nothing ops) info))
+ "operator declaration"
-- | A particle literal.
--
-- Examples: @\@foo@, @\@(bar: 2)@, @\@bar:@, @\@(foo: 2 bar: _)@
pParticle :: Parser Expr
pParticle = tagged (do
- char '@'
- c <- choice
- [ cKeyword True
- , binary
- , try (cSingle True)
- , symbols
+ msg <- choice
+ [ do
+ punctuation '@'
+ liftM toMsg (cSingle <|> try cKeyword) <|> filledHead
+ , liftM toMsg particle
]
- return (EParticle Nothing c))
- "particle"
- where
- binary = do
- op <- operator
- return $ PMKeyword [op] [Nothing, Nothing]
- symbols = do
- names <- many1 (anyIdent >>= \n -> char ':' >> return n)
- spacing
- return $ PMKeyword names (replicate (length names + 1) Nothing)
-
--- | Any dispatch, both single and keyword.
-pDispatch :: Parser Expr
-pDispatch = try pdKeys <|> pdChain
- "dispatch"
-
--- | A keyword dispatch.
---
--- Examples: @1 foo: 2@, @1 + 2@
-pdKeys :: Parser Expr
-pdKeys = do
- pos <- getPosition
- msg <- keywords T.keyword (ETop (Just pos)) (try pdChain <|> headless)
- ops <- liftM psOperators getState
- return $ Dispatch (Just pos) (toBinaryOps ops msg)
- "keyword dispatch"
+ return (EParticle Nothing msg))
+ "particle"
where
- headless = do
- p <- getPosition
- msg <- ckeywd p
- ops <- liftM psOperators getState
- return (Dispatch (Just p) (toBinaryOps ops msg))
-
- ckeywd pos = do
- ks <- wsMany1 $ keyword pdChain
- let (ns, es) = unzip ks
- return $ T.keyword ns (ETop (Just pos):es)
- "keyword segment"
-
--- | A chain of message sends, both single and chained keywords.
---
--- Example: @1 sqrt (* 2) floor@
-pdChain :: Parser Expr
-pdChain = do
- pos <- getPosition
-
- chain <- wsManyStart
- (liftM DNormal (try pLiteral <|> pThis <|> parens pExpr) <|> chained)
- chained
+ filledHead = do
+ p <- parens pDispatch
+ case p of
+ EDispatch { eMessage = Single i n t os } ->
+ return (Single i n (toRole t) (map toOpt os))
+ EDispatch { eMessage = Keyword i ns ts os } ->
+ return (Keyword i ns (map toRole ts) (map toOpt os))
+ _ -> fail "non-message in particle"
- return $ dispatches pos chain
- "single dispatch"
- where
- chained = liftM DParticle $ choice
- [ cKeyword False
- , cSingle False
- ]
+ toOpt (Option i n e) = Option i n (toRole e)
- -- start off by dispatching on either a primitive or Top
- dispatches :: SourcePos -> [Dispatch] -> Expr
- dispatches p (DNormal e:ps) =
- dispatches' p ps e
- dispatches p (DParticle (PMSingle n):ps) =
- dispatches' p ps (Dispatch (Just p) $ single n (ETop (Just p)))
- dispatches p (DParticle (PMKeyword ns (Nothing:es)):ps) =
- dispatches' p ps (Dispatch (Just p) $ T.keyword ns (ETop (Just p):map fromJust es))
- dispatches _ ds = error $ "impossible: dispatches on " ++ show ds
+ toMsg (CSingle n os) =
+ single' n Nothing (map toOpt os)
+ toMsg (CKeyword ns es os) =
+ keyword' ns (Nothing:map toRole es) (map toOpt os)
- -- roll a list of partial messages into a bunch of dispatches
- dispatches' :: SourcePos -> [Dispatch] -> Expr -> Expr
- dispatches' _ [] acc = acc
- dispatches' p (DParticle (PMKeyword ns (Nothing:es)):ps) acc =
- dispatches' p ps (Dispatch (Just p) $ T.keyword ns (acc : map fromJust es))
- dispatches' p (DParticle (PMSingle n):ps) acc =
- dispatches' p ps (Dispatch (Just p) $ single n acc)
- dispatches' _ x y = error $ "impossible: dispatches' on " ++ show (x, y)
+ toRole (EDispatch { eMessage = Single { mName = "_", mTarget = ETop {} } }) =
+ Nothing
+ toRole e = Just e
-- | A comma-separated list of zero or more expressions, surrounded by square
-- brackets.
--
-- Examples: @[]@, @[1, $a]@
pList :: Parser Expr
-pList = (tagged . liftM (EList Nothing) $ brackets (wsDelim "," pExpr))
+pList = tagged (liftM (EList Nothing) (brackets (blockOf pExpr)))
"list"
+-- | A comma-separated list of zero or two or more expressions, surrounded by
+-- parentheses.
+--
+-- Examples: @(1, $a)@
+pTuple :: Parser Expr
+pTuple = (tagged . liftM (ETuple Nothing) . try . parens $ choice
+ [ do
+ v <- pExpr
+ end
+ vs <- blockOf1 pExpr
+ return (v:vs)
+ , return []
+ ])
+ "tuple"
+
-- | A block of expressions, surrounded by braces and optionally having
-- arguments.
--
-- Examples: @{ }@, @{ a b | a + b }@, @{ a = 1; a + 1 }@
pBlock :: Parser Expr
-pBlock = tagged (braces $ do
- arguments <- option [] . try $ do
- ps <- many1 pSpacedExpr
- whiteSpace
- string "|"
- whiteSpace1
- return $ map (fromJust . toPattern) ps
-
- code <- wsBlock pExpr
+pBlock = tagged . braces $ do
+ as <- option [] (try $ manyTill pSpacedExpr (punctuation '|' >> optional end))
+ es <- blockOf pExpr
+ return (EBlock Nothing (map (fromJust . toPattern) as) es)
- return $ EBlock Nothing arguments code)
- "block"
+pMacroQuote :: Parser Expr
+pMacroQuote = tagged $ do
+ (name, raw, flags) <- macroQuote
+ return (EMacroQuote Nothing name raw flags)
--- | A general "single dispatch" form, without a target.
+-- | Parse an expression possibly up to an operator dispatch.
--
--- Used for both chaines and particles.
-cSingle :: Bool -> Parser (Particle Expr)
-cSingle p = do
- n <- if p then anyIdent else ident
- notFollowedBy colon
- spacing
- return (PMSingle n)
- "single segment"
+-- That is, this may be:
+-- - an operator dispatch
+-- - a keyword dispatch
+-- - a single dispatch
+-- - a literal or parenthesized expression
+pDispatch :: Parser Expr
+pDispatch = tagged (do
+ s <- do
+ h <- choice
+ [ try (lookAhead (keyword <|> operator)) >> return (ETop Nothing)
+ , pmSingle
+ ]
--- | A general "keyword dispatch" form, without a head.
+ case h of
+ EDispatch { eMessage = m@(Single { mOptionals = [] }) } -> do
+ os <- pdOptionals
+ return h { eMessage = m { mOptionals = os } }
+ _ -> return h
+
+ k <- followedBy keyword
+ if k
+ then keywordNext s
+ else do
+
+ o <- followedBy operator
+ if o
+ then operatorNext s
+ else return s)
+ "dispatch"
+
+-- | Optional keyword arguments.
+pdOptionals :: Parser [Option Expr]
+pdOptionals = do
+ os <- many (optionSegment prKeyword <|> optionFlag)
+ return (map (uncurry T.option) os)
+
+-- | Parse an expr up to a single dispatch.
--
--- Used for both chaines and particles.
-cKeyword :: Bool -> Parser (Particle Expr)
-cKeyword wc = do
- ks <- parens $ many1 keyword'
- let (ns, mvs) = second (Nothing:) $ unzip ks
- if any isOperator (tail ns)
- then toDispatch ns mvs
- else return $ PMKeyword ns mvs
- "keyword segment"
+-- That is, this may end up just being a literal or a parenthesized expression.
+pmSingle :: Parser Expr
+pmSingle = do
+ target <- pSpacedExpr
+
+ let restOf =
+ case target of
+ EDispatch {} -> many
+ _ -> many1
+
+ chain <- option [] (try $ restOf (cSingle <|> cKeyword))
+
+ if null chain
+ then return target
+ else return (dispatches target chain)
where
- keywordVal
- | wc = wildcard <|> value
- | otherwise = value
+ dispatches = foldl sendTo
- keywordDispatch
- | wc = wildcard <|> disp
- | otherwise = disp
+ sendTo t (CSingle n os) =
+ EDispatch Nothing (single' n t os)
+ sendTo t (CKeyword ns es os) =
+ EDispatch Nothing (keyword' ns (t:es) os)
- value = liftM Just pdChain
- disp = liftM Just pDispatch
+-- | Parse an expr up to a keyword dispatch.
+--
+-- That is, this may end up just being a single dispatch, or a literal, or
+-- a parenthesized expression, but it will not parse the rest of an operator
+-- dispatch.
+pmKeyword :: Parser Expr
+pmKeyword = do
+ t <- choice
+ [ try (lookAhead keyword) >> return (ETop Nothing)
+ , pmSingle
+ ]
- keyword' = do
- name <- try (do
- name <- ident
- char ':'
- return name) <|> operator
- whiteSpace1
- target <-
- if isOperator name
- then keywordDispatch
- else keywordVal
- return (name, target)
+ k <- followedBy keyword
+ if not k
+ then return t
+ else do
- wildcard = symbol "_" >> return Nothing
+ phKeyword t
- toDispatch [] mvs = error $ "impossible: toDispatch on [] and " ++ show mvs
- toDispatch (n:ns) mvs
- | all isJust opVals = do
- os <- getState
- pos <- getPosition
- let msg = toBinaryOps (psOperators os) $ T.keyword opers (map fromJust opVals)
- return . PMKeyword nonOpers $
- partVals ++ [Just $ Dispatch (Just pos) msg]
- | otherwise = fail "invalid particle; toplevel operator with wildcards as values"
- where
- (nonOpers, opers) = first (n:) $ break isOperator ns
- (partVals, opVals) = splitAt (length nonOpers) mvs
+-- | Headless operator dispatch
+phOperator :: Parser Expr
+phOperator = do
+ n <- operator
+ t <- prOperator
+ os <- pdOptionals
+ return (EDispatch Nothing (keyword' [n] [ETop Nothing, t] os))
--- | Work out precadence, associativity, etc. for a keyword dispatch.
+-- | Headless keyword dispatch
+phKeyword :: Expr -> Parser Expr
+phKeyword t = do
+ (ns, ts) <- liftM unzip $ many1 (keywordSegment prKeyword)
+ os <- pdOptionals
+ return $ EDispatch Nothing (keyword' ns (t:ts) os)
+
+-- | Keyword (non-first) roles
+prKeyword :: Parser Expr
+prKeyword = phOperator <|> phKeyword (ETop Nothing) <|> pmSingle
+ "keyword role"
+
+-- | Operator (non-first) roles
+prOperator :: Parser Expr
+prOperator = phOperator <|> phKeyword (ETop Nothing) <|> pmKeyword
+ "operand"
+
+-- | Parse the rest of a keyword dispatch, possibly followed by an operator
+-- dispatch, with a given first role.
+keywordNext :: Expr -> Parser Expr
+keywordNext t = do
+ keywd <- phKeyword t
+
+ o <- followedBy operator
+ if o
+ then operatorNext keywd
+ else return keywd
+
+-- | Parse the rest of an operator dispatch, with a given first role.
+operatorNext :: Expr -> Parser Expr
+operatorNext f = do
+ (ns, ts, os) <- liftM unzip3 . many1 $ do
+ n <- operator
+ t <- prOperator
+ os <- pdOptionals
+ return (n, t, os)
+
+ ops <- fmap psOperators getState
+ return (EDispatch Nothing (opChain ops ns (f:ts) os))
+
+-- | Chained single message
+cSingle :: Parser Chained
+cSingle = choice
+ [ liftM (flip CSingle []) (anyReserved <|> identifier)
+ , try . parens $ do
+ n <- anyReserved <|> identifier
+ os <- pdOptionals
+ return (CSingle n os)
+ ]
+
+-- | Chained keyword message
+cKeyword :: Parser Chained
+cKeyword = parens $ do
+ (ns, es) <- choice
+ [ liftM unzip $ many1 (keywordSegment prKeyword)
+ , do
+ o <- operator
+ e <- prOperator
+ return ([o], [e])
+ ]
+
+ os <- pdOptionals
+
+ return (CKeyword ns es os)
+
+-- | Work out precadence, associativity, etc. for binary dispatch.
+-- Takes the operator table, a list of operators, their operands, and their
+-- options, and creates a message dispatch with proper associativity/precedence
+-- worked out.
--
--- The input is a keyword EMessage with a mix of operators and identifiers as
--- its name, e.g. @keyword { emNames = ["+", "*", "remainder"] }@.
-toBinaryOps :: Operators -> Message Expr -> Message Expr
-toBinaryOps _ done@(Keyword _ [_] [_, _]) = done
-toBinaryOps ops (Keyword h (n:ns) (v:vs))
+-- Operators taking optional values are treated with highest precedence
+-- regardless of their settings in the operator table.
+--
+-- For example, @1 -> 2 &x: 3 * 5@ is @(1 -> 2 &x: 3) * 5@, rather than
+-- @1 -> (2 * 5) &x: 3@
+opChain :: Operators -> [String] -> [Expr] -> [[Option Expr]] -> Message Expr
+opChain _ [] [EDispatch { eMessage = done }] [] = done
+opChain _ [a] [w, x] [opts] = keyword' [a] [w, x] opts
+opChain os (a:b:cs) (w:x:y:zs) (aopts:bopts:opts)
| nextFirst =
- T.keyword [n]
- [ v
- , Dispatch (eLocation v)
- (toBinaryOps ops (T.keyword ns vs))
- ]
- | isOperator n =
- toBinaryOps ops . T.keyword ns $
- (Dispatch (eLocation v) (T.keyword [n] [v, head vs]):tail vs)
- | nonOperators == ns = Keyword h (n:ns) (v:vs)
- | null nonOperators && length vs > 2 =
- T.keyword [head ns]
- [ Dispatch (eLocation v) $
- T.keyword [n] [v, head vs]
- , Dispatch (eLocation v) $
- toBinaryOps ops (T.keyword (tail ns) (tail vs))
- ]
+ keyword' [a] [w, disp $ opChain os (b:cs) (x:y:zs) (bopts:opts)] aopts
| otherwise =
- toBinaryOps ops . T.keyword (drop numNonOps ns) $
- (Dispatch (eLocation v) $
- T.keyword (n : nonOperators)
- (v : take (numNonOps + 1) vs)) :
- drop (numNonOps + 1) vs
+ opChain os (b:cs) (disp (keyword' [a] [w, x] aopts):y:zs) (bopts:opts)
where
- numNonOps = length nonOperators
- nonOperators = takeWhile (not . isOperator) ns
- nextFirst =
- isOperator n && or
- [ null ns
- , prec next > prec n
- , assoc n == ARight && prec next == prec n
- ]
- where next = head ns
+ disp = EDispatch Nothing
- assoc n' =
- case lookup n' ops of
- Nothing -> ALeft
- Just (a, _) -> a
+ nextFirst =
+ null aopts && (prec b > prec a || (assoc a == ARight && prec b == prec a))
- prec n' =
- case lookup n' ops of
- Nothing -> defaultPrec
- Just (_, p) -> p
-toBinaryOps _ u = error $ "cannot toBinaryOps: " ++ show u
+ assoc o = maybe ALeft fst (lookup o os)
+ prec o = maybe defaultPrec snd (lookup o os)
+opChain _ ns ts oss = error $ "opChain: " ++ show (ns, ts, oss)
-- | Parse a block of expressions from a given input string.
parser :: Parser [Expr]
parser = do
- whiteSpace
- es <- wsBlock pExpr
- whiteSpace
- eof
+ es <- blockOf pExpr
+ endOfFile
return es
-
--- | Same as `parser', but ignores a shebang at the start of the source.
-fileParser :: Parser [Expr]
-fileParser = do
- optional (string "#!" >> manyTill anyToken (eol <|> eof))
- parser
-
diff --git a/src/Atomo/Parser/Primitive.hs b/src/Atomo/Parser/Primitive.hs
deleted file mode 100644
--- a/src/Atomo/Parser/Primitive.hs
+++ /dev/null
@@ -1,63 +0,0 @@
-module Atomo.Parser.Primitive where
-
-import Control.Monad (liftM)
-import Data.Ratio
-import Text.Parsec
-
-import Atomo.Parser.Base
-import Atomo.Types as T
-
-
--- | Parser for all primitive values.
-pPrim :: Parser Value
-pPrim = choice
- [ pvChar
- , pvString
- , try pvRational
- , try pvDouble
- , try pvInteger
- , try pvBoolean
- ]
-
--- | Character literal.
---
--- Examples: @$a@, @$ @, @$\\EOT@, @$\\n@
-pvChar :: Parser Value
-pvChar = liftM Char charLiteral
-
--- | String literal.
---
--- Examples: @\"\"@, @\"foo\"@, @\"foo\\nbar\"@
-pvString :: Parser Value
-pvString = liftM T.string stringLiteral
-
--- | Double literal.
---
--- Examples: @1.0@, @4.6e10@, @-1.0@
-pvDouble :: Parser Value
-pvDouble = liftM Double float
-
--- | Integer literal.
---
--- Examples: @1@, @2@, @-1@, @-2@
-pvInteger :: Parser Value
-pvInteger = liftM Integer integer
-
--- | Boolean literal.
---
--- Examples: @True@, @False@
-pvBoolean :: Parser Value
-pvBoolean = liftM Boolean $ true <|> false
- where
- true = reserved "True" >> return True
- false = reserved "False" >> return False
-
--- | Rational literal.
---
--- Examples: @1\/2@, @-1\/2@, @1\/-2@
-pvRational :: Parser Value
-pvRational = do
- n <- integer
- char '/'
- d <- integer
- return (Rational (n % d))
diff --git a/src/Atomo/Pattern.hs b/src/Atomo/Pattern.hs
--- a/src/Atomo/Pattern.hs
+++ b/src/Atomo/Pattern.hs
@@ -21,9 +21,6 @@
-- | Check if a value matches a given pattern.
---
--- Note that this is much faster when pure, so it uses unsafePerformIO
--- to check things like delegation matches.
match :: IDs -> Maybe Value -> Pattern -> Value -> Bool
{-# NOINLINE match #-}
match ids (Just r) PThis y@(Object { oDelegates = ds }) =
@@ -48,6 +45,8 @@
match ids r (PInstance p) v = match ids r p v
match _ _ (PStrict (PMatch x)) v = x == v
match ids r (PStrict p) v = match ids r p v
+match ids r (PVariable p) (Tuple t) = match ids r p (List t)
+match ids r (PVariable p) v = match ids r p (list [v])
match ids r (PNamed _ p) v = match ids r p v
match _ _ PAny _ = True
match ids r (PList ps) (List v) = matchAll ids r ps (V.toList v)
@@ -57,8 +56,9 @@
h = V.head vs
t = List (V.tail vs)
match ids r (PHeadTail hp tp) (String t) | not (T.null t) =
- match ids r hp (Char (T.head t)) && match ids r tp (String (T.tail t))
-match ids r (PPMKeyword ans aps) (Particle (PMKeyword bns mvs)) =
+ match ids r hp (Character (T.head t)) && match ids r tp (String (T.tail t))
+match ids r (PTuple ps) (Tuple v) = matchAll ids r ps (V.toList v)
+match ids r (PPMKeyword ans aps) (Particle (Keyword { mNames = bns, mTargets = mvs })) =
ans == bns && matchParticle ids r aps mvs
match ids r p (Object { oDelegates = ds }) =
any (match ids r p) ds
@@ -66,11 +66,12 @@
match _ _ _ _ = False
macroMatch :: Pattern -> Expr -> Bool
-macroMatch PEDispatch (Dispatch {}) = True
-macroMatch PEOperator (Operator {}) = True
-macroMatch PEPrimitive (Primitive {}) = True
+macroMatch PEDispatch (EDispatch {}) = True
+macroMatch PEOperator (EOperator {}) = True
+macroMatch PEPrimitive (EPrimitive {}) = True
macroMatch PEBlock (EBlock {}) = True
macroMatch PEList (EList {}) = True
+macroMatch PETuple (ETuple {}) = True
macroMatch PEMacro (EMacro {}) = True
macroMatch PEParticle (EParticle {}) = True
macroMatch PETop (ETop {}) = True
@@ -93,30 +94,32 @@
matchEParticle _ _ _ = False
matchExpr :: Int -> Expr -> Expr -> Bool
-matchExpr 0 (EUnquote { eExpr = Dispatch { eMessage = Single {} } }) _ = True
-matchExpr 0 (EUnquote { eExpr = Dispatch { eMessage = Keyword { mTargets = [ETop {}, pat] } } }) e
+matchExpr 0 (EUnquote { eExpr = EDispatch { eMessage = Single {} } }) _ = True
+matchExpr 0 (EUnquote { eExpr = EDispatch { eMessage = Keyword { mTargets = [ETop {}, pat] } } }) e
| isJust mp = macroMatch (fromJust mp) e --matchExpr 0 pat e
where
mp = toMacroRole pat
matchExpr n (EUnquote { eExpr = a }) (EUnquote { eExpr = b }) =
matchExpr (n - 1) a b
-matchExpr n (Define { emPattern = ap', eExpr = a }) (Define { emPattern = bp, eExpr = b }) =
+matchExpr n (EDefine { emPattern = ap', eExpr = a }) (EDefine { emPattern = bp, eExpr = b }) =
ap' == bp && matchExpr n a b
-matchExpr n (Set { ePattern = ap', eExpr = a }) (Set { ePattern = bp, eExpr = b }) =
+matchExpr n (ESet { ePattern = ap', eExpr = a }) (ESet { ePattern = bp, eExpr = b }) =
ap' == bp && matchExpr n a b
-matchExpr n (Dispatch { eMessage = am@(Keyword {}) }) (Dispatch { eMessage = bm@(Keyword {}) }) =
+matchExpr n (EDispatch { eMessage = am@(Keyword {}) }) (EDispatch { eMessage = bm@(Keyword {}) }) =
mID am == mID bm && length (mTargets am) == length (mTargets bm) && and (zipWith (matchExpr n) (mTargets am) (mTargets bm))
-matchExpr n (Dispatch { eMessage = am@(Single {}) }) (Dispatch { eMessage = bm@(Single {}) }) =
+matchExpr n (EDispatch { eMessage = am@(Single {}) }) (EDispatch { eMessage = bm@(Single {}) }) =
mID am == mID bm && matchExpr n (mTarget am) (mTarget bm)
matchExpr n (EBlock { eArguments = aps, eContents = as }) (EBlock { eArguments = bps, eContents = bs }) =
aps == bps && length as == length bs && and (zipWith (matchExpr n) as bs)
matchExpr n (EList { eContents = as }) (EList { eContents = bs }) =
length as == length bs && and (zipWith (matchExpr n) as bs)
+matchExpr n (ETuple { eContents = as }) (ETuple { eContents = bs }) =
+ length as == length bs && and (zipWith (matchExpr n) as bs)
matchExpr n (EMacro { emPattern = ap', eExpr = a }) (EMacro { emPattern = bp, eExpr = b }) =
ap' == bp && matchExpr n a b
matchExpr n (EParticle { eParticle = ap' }) (EParticle { eParticle = bp }) =
case (ap', bp) of
- (PMKeyword ans ames, PMKeyword bns bmes) ->
+ (Keyword { mNames = ans, mTargets = ames }, Keyword { mNames = bns, mTargets = bmes }) ->
ans == bns && matchEParticle n ames bmes
_ -> ap' == bp
matchExpr n (EQuote { eExpr = a }) (EQuote { eExpr = b }) =
@@ -142,7 +145,7 @@
-- | Given a pattern and avalue, return the bindings as a list of pairs.
bindings' :: Pattern -> Value -> [(Message Pattern, Value)]
bindings' (PNamed n p) v = (single n PThis, v) : bindings' p v
-bindings' (PPMKeyword _ ps) (Particle (PMKeyword _ mvs)) =
+bindings' (PPMKeyword _ ps) (Particle (Keyword { mTargets = mvs })) =
concatMap (\(p, Just v) -> bindings' p v)
$ filter (isJust . snd)
$ zip ps mvs
@@ -153,41 +156,46 @@
h = V.head vs
t = List (V.tail vs)
bindings' (PHeadTail hp tp) (String t) | not (T.null t) =
- bindings' hp (Char (T.head t)) ++ bindings' tp (String (T.tail t))
+ bindings' hp (Character (T.head t)) ++ bindings' tp (String (T.tail t))
+bindings' (PTuple ps) (Tuple vs) = concat (zipWith bindings' ps (V.toList vs))
bindings' (PExpr a) (Expression b) = exprBindings 0 a b
bindings' (PInstance p) (Object { oDelegates = ds }) =
concatMap (bindings' p) ds
bindings' (PInstance p) v = bindings' p v
bindings' (PStrict p) v = bindings' p v
+bindings' (PVariable p) (Tuple t) = bindings' p (List t)
+bindings' (PVariable p) v = bindings' p (list [v])
bindings' p (Object { oDelegates = ds }) =
concatMap (bindings' p) ds
bindings' _ _ = []
exprBindings :: Int -> Expr -> Expr -> [(Message Pattern, Value)]
-exprBindings 0 (EUnquote { eExpr = Dispatch { eMessage = Single { mName = n } } }) e =
+exprBindings 0 (EUnquote { eExpr = EDispatch { eMessage = Single { mName = n } } }) e =
[(single n PThis, Expression e)]
-exprBindings 0 (EUnquote { eExpr = Dispatch { eMessage = Keyword { mNames = [n] } } }) e =
+exprBindings 0 (EUnquote { eExpr = EDispatch { eMessage = Keyword { mNames = [n] } } }) e =
[(single n PThis, Expression e)]
exprBindings n (EUnquote { eExpr = a }) (EUnquote { eExpr = b }) =
exprBindings (n - 1) a b
-exprBindings n (Define { eExpr = a }) (Define { eExpr = b }) =
+exprBindings n (EDefine { eExpr = a }) (EDefine { eExpr = b }) =
exprBindings n a b
-exprBindings n (Set { eExpr = a }) (Set { eExpr = b }) =
+exprBindings n (ESet { eExpr = a }) (ESet { eExpr = b }) =
exprBindings n a b
-exprBindings n (Dispatch { eMessage = am@(Keyword {}) }) (Dispatch { eMessage = bm@(Keyword {}) }) =
+exprBindings n (EDispatch { eMessage = am@(Keyword {}) }) (EDispatch { eMessage = bm@(Keyword {}) }) =
concat $ zipWith (exprBindings n) (mTargets am) (mTargets bm)
-exprBindings n (Dispatch { eMessage = am@(Single {}) }) (Dispatch { eMessage = bm@(Single {}) }) =
+exprBindings n (EDispatch { eMessage = am@(Single {}) }) (EDispatch { eMessage = bm@(Single {}) }) =
exprBindings n (mTarget am) (mTarget bm)
exprBindings n (EBlock { eContents = as }) (EBlock { eContents = bs }) =
concat $ zipWith (exprBindings n) as bs
exprBindings n (EList { eContents = as }) (EList { eContents = bs }) =
concat $ zipWith (exprBindings n) as bs
+exprBindings n (ETuple { eContents = as }) (ETuple { eContents = bs }) =
+ concat $ zipWith (exprBindings n) as bs
exprBindings n (EMacro { eExpr = a }) (EMacro { eExpr = b }) =
exprBindings n a b
exprBindings n (EParticle { eParticle = ap' }) (EParticle { eParticle = bp }) =
case (ap', bp) of
- (PMKeyword _ ames, PMKeyword _ bmes) ->
+ (Keyword { mNames = _, mTargets = ames }, Keyword { mNames = _, mTargets = bmes }) ->
concatMap (\(Just a, Just b) -> exprBindings n a b)
$ filter (isJust . fst)
$ zip ames bmes
@@ -198,31 +206,36 @@
-- | Convert an expression to the pattern match it represents.
toPattern :: Expr -> Maybe Pattern
-toPattern (Dispatch { eMessage = Keyword { mNames = ["."], mTargets = [h, t] } }) = do
+toPattern (EDispatch { eMessage = Keyword { mNames = ["."], mTargets = [h, t] } }) = do
hp <- toPattern h
tp <- toPattern t
return (PHeadTail hp tp)
-toPattern (Dispatch { eMessage = Keyword { mNames = ["->"], mTargets = [ETop {}, o] } }) = do
+toPattern (EDispatch { eMessage = Keyword { mNames = ["->"], mTargets = [ETop {}, o] } }) = do
liftM PInstance (toPattern o)
-toPattern (Dispatch { eMessage = Keyword { mNames = ["=="], mTargets = [ETop {}, o] } }) = do
+toPattern (EDispatch { eMessage = Keyword { mNames = ["=="], mTargets = [ETop {}, o] } }) = do
liftM PStrict (toPattern o)
-toPattern (Dispatch { eMessage = Keyword { mNames = [n], mTargets = [ETop {}, x] } }) = do
+toPattern (EDispatch { eMessage = Keyword { mNames = ["..."], mTargets = [ETop {}, o] } }) = do
+ liftM PVariable (toPattern o)
+toPattern (EDispatch { eMessage = Keyword { mNames = [n], mTargets = [ETop {}, x] } }) = do
p <- toPattern x
return (PNamed n p)
-toPattern (Dispatch { eMessage = Keyword { mNames = ns, mTargets = ts } }) =
+toPattern (EDispatch { eMessage = Keyword { mNames = ns, mTargets = ts } }) =
return (pkeyword ns (map PObject ts))
-toPattern (Dispatch { eMessage = Single { mName = "_" } }) =
+toPattern (EDispatch { eMessage = Single { mName = "_" } }) =
return PAny
-toPattern (Dispatch { eMessage = Single { mName = n, mTarget = ETop {} } }) =
+toPattern (EDispatch { eMessage = Single { mName = n, mTarget = ETop {} } }) =
return (PNamed n PAny)
-toPattern (Dispatch { eMessage = Single { mTarget = d@(Dispatch {}), mName = n } }) =
+toPattern (EDispatch { eMessage = Single { mTarget = d@(EDispatch {}), mName = n } }) =
return (psingle n (PObject d))
toPattern (EList { eContents = es }) = do
ps <- mapM toPattern es
return (PList ps)
-toPattern (EParticle { eParticle = PMSingle n }) =
- return (PMatch (Particle (PMSingle n)))
-toPattern (EParticle { eParticle = PMKeyword ns mes }) = do
+toPattern (ETuple { eContents = es }) = do
+ ps <- mapM toPattern es
+ return (PTuple ps)
+toPattern (EParticle { eParticle = Single { mName = n } }) =
+ return (PMatch (particle n))
+toPattern (EParticle { eParticle = Keyword { mNames = ns, mTargets = mes } }) = do
ps <- forM mes $ \me ->
case me of
Nothing -> return PAny
@@ -230,64 +243,73 @@
return (PPMKeyword ns ps)
toPattern (EQuote { eExpr = e }) = return (PExpr e)
-toPattern (Primitive { eValue = v }) =
+toPattern (EPrimitive { eValue = v }) =
return (PMatch v)
toPattern (ETop {}) =
return (PObject (ETop Nothing))
toPattern b@(EBlock {}) =
- return (PObject (Dispatch Nothing (keyword ["call-in"] [b, ETop Nothing])))
+ return (PObject (EDispatch Nothing (keyword ["call-in"] [b, ETop Nothing])))
toPattern _ = Nothing
-- | Convert an expression into a definition's message pattern.
toDefinePattern :: Expr -> Maybe (Message Pattern)
-toDefinePattern (Dispatch { eMessage = Single { mName = n, mTarget = t } }) = do
+toDefinePattern (EDispatch { eMessage = Single { mName = n, mTarget = t, mOptionals = os } }) = do
p <- toRolePattern t
- return (single n p)
-toDefinePattern (Dispatch { eMessage = Keyword { mNames = ns, mTargets = ts } }) = do
+ return (single' n p (map (\(Option oi on oe) -> Option oi on (PObject oe)) os))
+toDefinePattern (EDispatch { eMessage = Keyword { mNames = ns, mTargets = ts, mOptionals = os } }) = do
ps <- mapM toRolePattern ts
- return (keyword ns ps)
+ return (keyword' ns ps (map (\(Option oi on oe) -> Option oi on (PObject oe)) os))
toDefinePattern _ = Nothing
-- | Convert an expression into a pattern-match for use as a message's role.
toRolePattern :: Expr -> Maybe Pattern
-toRolePattern (Dispatch { eMessage = Keyword { mNames = ["->"], mTargets = [ETop {}, o] } }) = do
+toRolePattern (EDispatch { eMessage = Keyword { mNames = ["->"], mTargets = [ETop {}, o] } }) = do
liftM PInstance (toRolePattern o)
-toRolePattern (Dispatch { eMessage = Keyword { mNames = ["=="], mTargets = [ETop {}, o] } }) = do
+toRolePattern (EDispatch { eMessage = Keyword { mNames = ["=="], mTargets = [ETop {}, o] } }) = do
liftM PStrict (toRolePattern o)
-toRolePattern (Dispatch { eMessage = Keyword { mNames = [n], mTargets = [ETop {}, x] } }) = do
+toRolePattern (EDispatch { eMessage = Keyword { mNames = ["..."], mTargets = [ETop {}, o] } }) = do
+ liftM PVariable (toPattern o)
+toRolePattern (EDispatch { eMessage = Keyword { mNames = [n], mTargets = [ETop {}, x] } }) = do
p <- toRolePattern x
return (PNamed n p)
-toRolePattern d@(Dispatch { eMessage = Single { mTarget = ETop {}, mName = n } })
+toRolePattern d@(EDispatch { eMessage = Single { mTarget = ETop {}, mName = n } })
| isUpper (head n) = return (PObject d)
| n == "_" = return PAny
| otherwise = return (PNamed n PAny)
-toRolePattern d@(Dispatch { eMessage = Single { mTarget = (Dispatch {}) } }) =
+toRolePattern d@(EDispatch { eMessage = Single { mTarget = (EDispatch {}) } }) =
return (PObject d)
toRolePattern p = toPattern p
-- | Convert an expression into a macro's message pattern.
toMacroPattern :: Expr -> Maybe (Message Pattern)
-toMacroPattern (Dispatch { eMessage = Single { mName = n, mTarget = t } }) = do
+toMacroPattern (EDispatch { eMessage = Single { mName = n, mTarget = t, mOptionals = os } }) = do
p <- toMacroRole t
- return (single n p)
-toMacroPattern (Dispatch { eMessage = Keyword { mNames = ns, mTargets = ts } }) = do
+ return (single' n p (map macroOptional os))
+toMacroPattern (EDispatch { eMessage = Keyword { mNames = ns, mTargets = ts, mOptionals = os } }) = do
ps <- mapM toMacroRole ts
- return (keyword ns ps)
+ return (keyword' ns ps (map macroOptional os))
toMacroPattern _ = Nothing
+macroOptional :: Option Expr -> Option Pattern
+macroOptional (Option i n e) = Option i n (PExpr e)
+
-- | Convert an expression into a pattern-match for use as a macro's role.
toMacroRole :: Expr -> Maybe Pattern
-toMacroRole (Dispatch _ (Single _ "Dispatch" _)) = Just PEDispatch
-toMacroRole (Dispatch _ (Single _ "Operator" _)) = Just PEOperator
-toMacroRole (Dispatch _ (Single _ "Primitive" _)) = Just PEPrimitive
-toMacroRole (Dispatch _ (Single _ "Block" _)) = Just PEBlock
-toMacroRole (Dispatch _ (Single _ "List" _)) = Just PEList
-toMacroRole (Dispatch _ (Single _ "Macro" _)) = Just PEMacro
-toMacroRole (Dispatch _ (Single _ "Particle" _)) = Just PEParticle
-toMacroRole (Dispatch _ (Single _ "Top" _)) = Just PETop
-toMacroRole (Dispatch _ (Single _ "Quote" _)) = Just PEQuote
-toMacroRole (Dispatch _ (Single _ "Unquote" _)) = Just PEUnquote
-toMacroRole (Dispatch { eMessage = Keyword { mNames = [n], mTargets = [ETop {}, x] } }) = do
+toMacroRole (EDispatch _ (Single { mName = "Dispatch" })) = Just PEDispatch
+toMacroRole (EDispatch _ (Single { mName = "Operator" })) = Just PEOperator
+toMacroRole (EDispatch _ (Single { mName = "Primitive" })) = Just PEPrimitive
+toMacroRole (EDispatch _ (Single { mName = "Block" })) = Just PEBlock
+toMacroRole (EDispatch _ (Single { mName = "List" })) = Just PEList
+toMacroRole (EDispatch _ (Single { mName = "Tuple" })) = Just PETuple
+toMacroRole (EDispatch _ (Single { mName = "Macro" })) = Just PEMacro
+toMacroRole (EDispatch _ (Single { mName = "ForMacro" })) = Just PEForMacro
+toMacroRole (EDispatch _ (Single { mName = "Particle" })) = Just PEParticle
+toMacroRole (EDispatch _ (Single { mName = "Top" })) = Just PETop
+toMacroRole (EDispatch _ (Single { mName = "Quote" })) = Just PEQuote
+toMacroRole (EDispatch _ (Single { mName = "Unquote" })) = Just PEUnquote
+toMacroRole (EDispatch _ (Single { mName = "MacroQuote" })) = Just PEMacroQuote
+toMacroRole (EDispatch _ (Single { mName = "Match" })) = Just PEMatch
+toMacroRole (EDispatch { eMessage = Keyword { mNames = [n], mTargets = [ETop {}, x] } }) = do
p <- toMacroRole x
return (PNamed n p)
toMacroRole (ETop {}) = Just PAny
diff --git a/src/Atomo/Pretty.hs b/src/Atomo/Pretty.hs
--- a/src/Atomo/Pretty.hs
+++ b/src/Atomo/Pretty.hs
@@ -1,17 +1,19 @@
-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
-module Atomo.Pretty (Pretty(pretty)) where
+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, StandaloneDeriving, TypeSynonymInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Atomo.Pretty (Pretty(..), Prettied) where
import Data.Char (isUpper)
import Data.IORef
import Data.Maybe (isNothing)
import Data.Ratio
+import Data.Typeable
import System.IO.Unsafe
import Text.PrettyPrint hiding (braces)
import qualified Data.Vector as V
import Atomo.Method
import Atomo.Types hiding (keyword)
-import Atomo.Parser.Base (isOperator)
+import Atomo.Lexer.Base (isOperator, Token(..), TaggedToken(..))
data Context
@@ -23,11 +25,15 @@
| CPattern
| CList
+type Prettied = Doc
+
+deriving instance Typeable Prettied
+
class Pretty a where
-- | Pretty-print a value into a Doc. Typically this should be parseable
-- back into the original value, or just a nice user-friendly output form.
- pretty :: a -> Doc
- prettyFrom :: Context -> a -> Doc
+ pretty :: a -> Prettied
+ prettyFrom :: Context -> a -> Prettied
pretty = prettyFrom CNone
@@ -40,7 +46,7 @@
where
exprs = sep . punctuate (text ";") $ map pretty es
prettyFrom _ (Boolean b) = text $ show b
- prettyFrom _ (Char c) = char '$' <> (text . tail . init $ show c)
+ prettyFrom _ (Character c) = char '$' <> (text . tail . init $ show c)
prettyFrom _ (Continuation _) = internal "continuation" empty
prettyFrom _ (Double d) = double d
prettyFrom _ (Expression e) = char '\'' <> parens (pretty e)
@@ -49,6 +55,9 @@
prettyFrom _ (List l) =
brackets . hsep . punctuate comma $ map (prettyFrom CList) vs
where vs = V.toList l
+ prettyFrom _ (Tuple l) =
+ parens . hsep . punctuate comma $ map (prettyFrom CList) vs
+ where vs = V.toList l
prettyFrom _ (Message m) = internal "message" $ pretty m
prettyFrom _ (Method (Slot p _)) = internal "slot" $ parens (pretty p)
prettyFrom _ (Method (Responder p _ _)) =
@@ -59,14 +68,13 @@
prettyFrom _ (Process _ tid) =
internal "process" $ text (words (show tid) !! 1)
prettyFrom CNone (Object { oDelegates = ds, oMethods = ms }) =
- vcat
- [ internal "object" $ parens (text "delegates to" <+> pretty ds)
- , nest 2 (pretty ms)
- ]
+ internal "object" (parens (text "delegates to" <+> pretty ds)) $$
+ nest 2 (pretty ms)
prettyFrom _ (Rational r) =
integer (numerator r) <> char '/' <> integer (denominator r)
prettyFrom _ (Object {}) = internal "object" empty
prettyFrom _ (String s) = text (show s)
+ prettyFrom _ (Regexp _ s o _) = text "r{" <> text (macroEscape s) <> char '}' <> text o
instance Pretty Methods where
prettyFrom _ ms = vcat
@@ -98,36 +106,40 @@
parens $ pretty h <+> text "." <+> pretty t
prettyFrom c (PMessage m) = prettyFrom c m
prettyFrom _ (PList ps) =
- brackets . sep $ punctuate comma (map pretty ps)
+ brackets . sep $ punctuate comma (map (prettyFrom CList) ps)
+ prettyFrom _ (PTuple ps) =
+ parens . sep $ punctuate comma (map (prettyFrom CList) ps)
prettyFrom _ (PMatch v) = prettyFrom CPattern v
prettyFrom _ (PNamed n PAny) = text n
prettyFrom _ (PNamed n p) = parens $ text n <> colon <+> pretty p
- prettyFrom _ (PObject e@(Dispatch { eMessage = msg }))
+ prettyFrom _ (PObject e@(EDispatch { eMessage = msg }))
| capitalized msg = pretty e
| isParticular msg = pretty block
where
capitalized (Single { mName = n, mTarget = ETop {} }) =
isUpper (head n)
- capitalized (Single { mTarget = Dispatch { eMessage = t@(Single {}) } }) =
+ capitalized (Single { mTarget = EDispatch { eMessage = t@(Single {}) } }) =
capitalized t
capitalized _ = False
- isParticular (Keyword { mNames = ["call"], mTargets = [EBlock {}, ETop {}] }) =
+ isParticular (Keyword { mNames = ["call-in"], mTargets = [EBlock {}, ETop {}] }) =
True
isParticular _ = False
- block = mTarget msg
+ block = head (mTargets msg)
prettyFrom _ (PObject e) = parens $ pretty e
prettyFrom _ (PInstance p) = parens $ text "->" <+> pretty p
prettyFrom _ (PStrict p) = parens $ text "==" <+> pretty p
+ prettyFrom _ (PVariable p) = parens $ text "..." <+> pretty p
prettyFrom _ (PPMKeyword ns ps)
| all isAny ps = char '@' <> text (concatMap keyword ns)
| isAny (head ps) =
- char '@' <> parens (headlessKeywords' (prettyFrom CKeyword) ns (tail ps))
- | otherwise = char '@' <> parens (keywords' (prettyFrom CKeyword) ns ps)
+ char '@' <> parens (headlessKeywords ns (tail ps))
+ | otherwise = char '@' <> parens (keywords ns ps)
where
isAny PAny = True
isAny _ = False
+ prettyFrom _ (PExpr e) = pretty (EQuote Nothing e)
prettyFrom _ PThis = text ""
prettyFrom _ PEDispatch = text "Dispatch"
@@ -135,39 +147,42 @@
prettyFrom _ PEPrimitive = text "Primitive"
prettyFrom _ PEBlock = text "Block"
prettyFrom _ PEList = text "List"
+ prettyFrom _ PETuple = text "Tuple"
prettyFrom _ PEMacro = text "Macro"
+ prettyFrom _ PEForMacro = text "ForMacro"
prettyFrom _ PEParticle = text "Particle"
prettyFrom _ PETop = text "Top"
prettyFrom _ PEQuote = text "Quote"
prettyFrom _ PEUnquote = text "Unquote"
-
- prettyFrom _ (PExpr e) = pretty (EQuote Nothing e)
+ prettyFrom _ PEMacroQuote = text "MacroQuote"
+ prettyFrom _ PEMatch = text "Match"
instance Pretty Expr where
- prettyFrom _ (Define _ p v) =
+ prettyFrom _ (EDefine _ p v) =
prettyFrom CDefine p <+> text ":=" <++> prettyFrom CDefine v
- prettyFrom _ (Set _ p v) =
+ prettyFrom _ (ESet _ p v) =
prettyFrom CDefine p <+> text "=" <++> prettyFrom CDefine v
- prettyFrom CKeyword (Dispatch _ m@(Keyword {})) = parens $ pretty m
- prettyFrom CSingle (Dispatch _ m@(Keyword {})) = parens $ pretty m
- prettyFrom c (Dispatch _ m) = prettyFrom c m
- prettyFrom _ (Operator _ ns a i) =
+ prettyFrom CKeyword (EDispatch _ m@(Keyword {})) = parens $ pretty m
+ prettyFrom CSingle (EDispatch _ m@(Keyword {})) = parens $ pretty m
+ prettyFrom c (EDispatch _ m) = prettyFrom c m
+ prettyFrom _ (EOperator _ ns a i) =
text "operator" <+> assoc a <+> integer i <+> sep (map text ns)
where
assoc ALeft = text "left"
assoc ARight = text "right"
- prettyFrom c (Primitive _ v) = prettyFrom c v
+ prettyFrom c (EPrimitive _ v) = prettyFrom c v
prettyFrom _ (EBlock _ ps es)
| null ps = braces exprs
| otherwise = braces $ sep (map pretty ps) <+> char '|' <+> exprs
where
exprs = sep . punctuate (text ";") $ map pretty es
prettyFrom CDefine (EVM {}) = text "..."
- prettyFrom _ (EVM { ePretty = Nothing }) = text ""
- prettyFrom _ (EVM { ePretty = Just d }) = d
+ prettyFrom _ (EVM {}) = text ""
prettyFrom _ (EList _ es) =
brackets . sep . punctuate comma $ map (prettyFrom CList) es
+ prettyFrom _ (ETuple _ es) =
+ parens . sep . punctuate comma $ map (prettyFrom CList) es
prettyFrom _ (EMacro _ p e) =
text "macro" <+> parens (pretty p) <++> pretty e
prettyFrom _ (EForMacro { eExpr = e }) = text "for-macro" <+> pretty e
@@ -183,55 +198,66 @@
internal "set-dynamic" $ text n <+> pretty e
prettyFrom _ (EGetDynamic { eName = n }) =
internal "get-dynamic" $ text n
+ prettyFrom _ (EMacroQuote _ n r f) =
+ text n <> char '{' <> text (macroEscape r) <> char '}' <> text f
+ prettyFrom _ (EMatch _ t bs) =
+ prettyFrom CKeyword t <+> text "match:" <+> branches
+ where
+ branches = braces . sep . punctuate (text ";") $
+ flip map bs $ \(p, e) ->
+ pretty p <+> text "->" <+> pretty e
+instance Pretty [Expr] where
+ prettyFrom _ es = sep . punctuate (text ";") $ map pretty es
+instance Pretty x => Pretty (Option x) where
+ prettyFrom _ (Option _ n x) = char '&' <> text n <> char ':' <+> pretty x
+
instance Pretty (Message Pattern) where
- prettyFrom _ (Single _ n (PObject ETop {})) = text n
- prettyFrom _ (Single _ n PThis) = text n
- prettyFrom _ (Single _ n p) = pretty p <+> text n
- prettyFrom _ (Keyword _ ns (PObject ETop {}:vs)) =
- headlessKeywords ns vs
- prettyFrom _ (Keyword _ ns (PThis:vs)) =
- headlessKeywords ns vs
- prettyFrom _ (Keyword _ ns vs) = keywords ns vs
+ prettyFrom _ (Single { mName = n, mTarget = PThis, mOptionals = os }) =
+ text n <+> sep (map pretty os)
+ prettyFrom _ (Single { mName = n, mTarget = (PObject ETop {}), mOptionals = os }) =
+ text n <+> sep (map pretty os)
+ prettyFrom _ (Single { mName = n, mTarget = p, mOptionals = os }) =
+ pretty p <+> text n <+> sep (map pretty os)
+ prettyFrom _ (Keyword { mNames = ns, mTargets = (PThis:vs), mOptionals = os }) =
+ headlessKeywords ns vs <+> sep (map pretty os)
+ prettyFrom _ (Keyword { mNames = ns, mTargets = (PObject ETop {}:vs), mOptionals = os }) =
+ headlessKeywords ns vs <+> sep (map pretty os)
+ prettyFrom _ (Keyword { mNames = ns, mTargets = vs, mOptionals = os }) =
+ keywords ns vs <+> sep (map pretty os)
instance Pretty (Message Value) where
- prettyFrom _ (Single _ n t) = prettyFrom CSingle t <+> text n
- prettyFrom _ (Keyword _ ns vs) = keywords ns vs
-
+ prettyFrom _ (Single { mName = n, mTarget = t, mOptionals = os }) =
+ prettyFrom CSingle t <+> text n <+> sep (map pretty os)
+ prettyFrom _ (Keyword { mNames = ns, mTargets = vs, mOptionals = os }) =
+ keywords ns vs <+> sep (map pretty os)
instance Pretty (Message Expr) where
- prettyFrom _ (Single _ n (ETop {})) = text n
- prettyFrom _ (Single _ n t) = prettyFrom CSingle t <+> text n
- prettyFrom _ (Keyword _ ns (ETop {}:es)) = headlessKeywords ns es
- prettyFrom _ (Keyword _ ns es) = keywords ns es
+ prettyFrom _ (Single { mName = n, mTarget = ETop {}, mOptionals = os }) =
+ text n <+> sep (map pretty os)
+ prettyFrom _ (Single { mName = n, mTarget = t, mOptionals = os }) =
+ prettyFrom CSingle t <+> text n <+> sep (map pretty os)
+ prettyFrom _ (Keyword { mNames = ns, mTargets = (ETop {}:es), mOptionals = os }) =
+ headlessKeywords ns es <+> sep (map pretty os)
+ prettyFrom _ (Keyword { mNames = ns, mTargets = es, mOptionals = os }) =
+ keywords ns es <+> sep (map pretty os)
-instance Pretty (Particle Value) where
- prettyFrom _ (PMSingle e) = text e
- prettyFrom _ (PMKeyword ns vs)
- | all isNothing vs = text . concat $ map keyword ns
+instance Pretty x => Pretty (Particle x) where
+ prettyFrom _ (Single { mName = n, mTarget = Nothing, mOptionals = [] }) = text n
+ prettyFrom _ (Single { mName = n, mTarget = Nothing, mOptionals = os }) =
+ parens (text n <+> sep (map pretty os))
+ prettyFrom _ (Single { mName = n, mTarget = Just t, mOptionals = os }) =
+ parens (pretty t <+> text n <+> sep (map pretty os))
+ prettyFrom _ (Keyword { mNames = ns, mTargets = vs, mOptionals = os })
+ | all isNothing vs && null os = text . concat $ map keyword ns
| isNothing (head vs) =
- parens $ headlessKeywords' prettyVal ns (tail vs)
- | otherwise = parens (keywords' prettyVal ns vs)
- where
- prettyVal me =
- case me of
- Nothing -> text "_"
- Just e -> prettyFrom CKeyword e
-
-instance Pretty (Particle Expr) where
- prettyFrom _ (PMSingle e) = text e
- prettyFrom _ (PMKeyword ns es)
- | all isNothing es = text . concat $ map keyword ns
- | isNothing (head es) =
- parens $ headlessKeywords' prettyVal ns (tail es)
- | otherwise = parens $ keywords' prettyVal ns es
- where
- prettyVal me =
- case me of
- Nothing -> text "_"
- Just e -> pretty e
+ parens $ headlessKeywords ns (tail vs) <+> sep (map pretty os)
+ | otherwise = parens $ keywords ns vs <+> sep (map pretty os)
+instance Pretty x => Pretty (Maybe x) where
+ prettyFrom _ Nothing = text "_"
+ prettyFrom c (Just v) = prettyFrom c v
instance Pretty Delegates where
prettyFrom _ [] = internal "bottom" empty
@@ -239,13 +265,68 @@
prettyFrom _ ds = text $ show (length ds) ++ " objects"
+instance Pretty Token where
+ prettyFrom _ (TokKeyword k) = text k <> char ':'
+ prettyFrom _ (TokOptional o) = char '&' <> text o <> char ':'
+ prettyFrom _ (TokOptionalFlag o) = char '&' <> text o
+ prettyFrom _ (TokOperator o) = text o
+ prettyFrom _ (TokMacroQuote n r f) =
+ text n <> char '{' <> text (macroEscape r) <> char '}' <> text f
+ prettyFrom _ (TokIdentifier i) = text i
+ prettyFrom _ (TokParticle ks) = char '@' <> hcat (map (text . keyword) ks)
+ prettyFrom _ (TokPrimitive p) = pretty p
+ prettyFrom _ (TokPunctuation c) = char c
+ prettyFrom _ (TokOpen c) = char c
+ prettyFrom _ (TokClose c) = char c
+ prettyFrom _ (TokReserved r) = text r
+ prettyFrom _ TokEnd = char ';'
+instance Pretty TaggedToken where
+ prettyFrom c tt = prettyFrom c (tToken tt)
+
+type Tokens = [TaggedToken]
+
+instance Pretty Tokens where
+ prettyFrom _ ts = hsep (map pretty ts)
+
+
+instance Pretty AtomoError where
+ prettyFrom _ (Error v) =
+ text "error:" <+> pretty v
+ prettyFrom _ (ParseError e) =
+ text "parse error:" <+> text (show e)
+ prettyFrom _ (DidNotUnderstand m) =
+ text "message not understood:" <+> pretty m
+ prettyFrom _ (Mismatch a b) =
+ text "mismatch:" $$ nest 2 (pretty a $$ pretty b)
+ prettyFrom _ (ImportError e) =
+ text "haskell interpreter:" <+> text (show e)
+ prettyFrom _ (FileNotFound fn) =
+ text "file not found:" <+> text fn
+ prettyFrom _ (ParticleArity e g) =
+ text ("particle needed " ++ show e ++ " values to complete, given " ++ show g)
+ prettyFrom _ (BlockArity e g) =
+ text ("block expected " ++ show e ++ " arguments, given " ++ show g)
+ prettyFrom _ NoExpressions =
+ text "no expressions to evaluate"
+ prettyFrom _ (ValueNotFound d v) =
+ text "could not find a" <+> text d <+> text "in" <+> pretty v
+ prettyFrom _ (DynamicNeeded t) =
+ text "expected dynamic value of type" <+> text t
+
+
internal :: String -> Doc -> Doc
internal n d = char '<' <> text n <+> d <> char '>'
braces :: Doc -> Doc
braces d = char '{' <+> d <+> char '}'
+macroEscape :: String -> String
+macroEscape "" = ""
+macroEscape ('{':cs) = "\\{" ++ macroEscape cs
+macroEscape ('}':cs) = "\\}" ++ macroEscape cs
+macroEscape (c:cs) = c : macroEscape cs
+
headlessKeywords' :: (a -> Doc) -> [String] -> [a] -> Doc
headlessKeywords' p (k:ks) (v:vs) =
text (keyword k) <+> p v <++> headlessKeywords'' p ks vs
@@ -277,11 +358,11 @@
| needsParens e = parens (prettyFrom c e)
| otherwise = prettyFrom c e
where
- needsParens (Define {}) = True
- needsParens (Set {}) = True
- needsParens (Dispatch { eMessage = Keyword {} }) = True
- needsParens (Dispatch { eMessage = Single { mTarget = ETop {} } }) = False
- needsParens (Dispatch { eMessage = Single {} }) = True
+ needsParens (EDefine {}) = True
+ needsParens (ESet {}) = True
+ needsParens (EDispatch { eMessage = Keyword {} }) = True
+ needsParens (EDispatch { eMessage = Single { mTarget = ETop {} } }) = False
+ needsParens (EDispatch { eMessage = Single {} }) = True
needsParens _ = False
diff --git a/src/Atomo/PrettyVM.hs b/src/Atomo/PrettyVM.hs
deleted file mode 100644
--- a/src/Atomo/PrettyVM.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Atomo.PrettyVM where
-
-import Control.Monad (liftM)
-import Atomo.Environment
-import Atomo.Types
-
-
--- | Pretty-print a value by sending @show@ to it.
-prettyVM :: Value -> VM String
-prettyVM = liftM (fromText . fromString) . dispatch . single "show"
diff --git a/src/Atomo/QuasiQuotes.hs b/src/Atomo/QuasiQuotes.hs
--- a/src/Atomo/QuasiQuotes.hs
+++ b/src/Atomo/QuasiQuotes.hs
@@ -17,8 +17,9 @@
import Atomo.Core
import Atomo.Helpers (fromHaskell')
+import Atomo.Lexer
import Atomo.Parser
-import Atomo.Parser.Base
+import Atomo.Parser.Base (Parser, blockOf, end)
import Atomo.Parser.Expr
import Atomo.Pattern (toDefinePattern)
import Atomo.Types
@@ -54,7 +55,7 @@
-- here be dragons
fromHaskell' $ unsafePerformIO (runWith go (qqEnv))
where
- go = liftM haskell $ continue pp "" s
+ go = liftM haskell $ continue lexer pp "" s
pp = do
pos <- getPosition
@@ -62,11 +63,9 @@
flip setSourceName file $
flip setSourceLine line $
setSourceColumn pos col
- whiteSpace
- e <- p
- whiteSpace
- eof
- return e
+ r <- p
+ end <|> eof
+ return r
quotePatternExp :: String -> TH.ExpQ
quotePatternExp = withLocation (parsing (liftM (fromJust . toDefinePattern) pExpr)) lift
@@ -75,4 +74,4 @@
quoteExprExp = withLocation (parsing pExpr) lift
quoteExprsExp :: String -> TH.ExpQ
-quoteExprsExp = withLocation (parsing (wsBlock pExpr)) (fmap ListE . mapM lift)
+quoteExprsExp = withLocation (parsing (blockOf pExpr)) (fmap ListE . mapM lift)
diff --git a/src/Atomo/Run.hs b/src/Atomo/Run.hs
--- a/src/Atomo/Run.hs
+++ b/src/Atomo/Run.hs
@@ -59,15 +59,17 @@
[ "core"
, "boolean"
+ , "comparable"
, "association"
, "string"
+ , "pretty"
, "condition"
, "errors"
, "exception"
+ , "set"
, "block"
- , "comparable"
, "continuation"
, "list"
, "numeric"
@@ -77,6 +79,11 @@
, "version"
, "eco"
+
+ , "class-objects"
+ , "enumerable"
+ , "ordered"
+ , "range"
, "repl"
]
diff --git a/src/Atomo/Types.hs b/src/Atomo/Types.hs
--- a/src/Atomo/Types.hs
+++ b/src/Atomo/Types.hs
@@ -5,18 +5,21 @@
import Control.Concurrent.Chan
import Control.Monad.Cont
import Control.Monad.State
+import Data.Bits
import Data.Dynamic
import Data.Hashable (hash)
+import Data.IORef
import Data.List (nub)
import Data.Maybe (listToMaybe)
-import Data.IORef
-import Text.Parsec (ParseError, SourcePos)
-import Text.PrettyPrint (Doc)
+import Text.Parsec (ParseError, SourcePos, sourceName, sourceLine, sourceColumn)
+import Text.Regex.PCRE
import qualified Data.IntMap as M
+import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Language.Haskell.Interpreter as H
import qualified Language.Haskell.TH.Syntax as S
+import qualified Text.Parsec.Error as PE
-- | The Atomo VM. A Continuation monad wrapping a State monad.
@@ -31,7 +34,7 @@
| Boolean { fromBoolean :: !Bool }
-- | A character value.
- | Char { fromChar :: {-# UNPACK #-} !Char }
+ | Character { fromCharacter :: {-# UNPACK #-} !Char }
-- | A continuation reference.
| Continuation { fromContinuation :: Continuation }
@@ -57,31 +60,43 @@
-- | A method value.
| Method { fromMethod :: Method }
+ -- | An object reference.
+ | Object
+ { oDelegates :: !Delegates
+ , oMethods :: !Methods
+ }
+
-- | A particle value.
| Particle { fromParticle :: Particle Value }
- -- | A process; a communications channel and the thread's ID.
- | Process Channel ThreadId
-
-- | A pattern value.
| Pattern { fromPattern :: Pattern }
+ -- | A process; a communications channel and the thread's ID.
+ | Process Channel ThreadId
+
-- | A rational value.
| Rational Rational
- -- | An object reference.
- | Object
- { oDelegates :: !Delegates
- , oMethods :: !Methods
+ -- | A compiled regular expression.
+ | Regexp
+ { rCompiled :: !Regex
+ , rString :: String
+ , rOptions :: String
+ , rNamed :: [(String, Int)]
}
-- | A string value; Data.Text.Text.
| String { fromString :: !T.Text }
- deriving (Show, Typeable)
--- | Methods, slot, and macro methods.
+ -- | An arbitrary grouping of Values.
+ | Tuple VVector
+ deriving Typeable
+
+-- | Methods: responders, slots, and macro.
data Method
- -- | Responds to a message by evaluating an expression in the given context.
+ -- | Responds to a message by evaluating an expression with the method's
+ -- context available.
= Responder
{ mPattern :: !(Message Pattern)
, mContext :: !Value
@@ -108,6 +123,7 @@
{ mID :: !Int
, mNames :: [String]
, mTargets :: [v]
+ , mOptionals :: ![Option v]
}
-- | A single message sent to one target.
@@ -115,17 +131,16 @@
{ mID :: !Int
, mName :: String
, mTarget :: v
+ , mOptionals :: ![Option v]
}
- deriving (Eq, Show, Typeable)
+ deriving (Show, Typeable)
--- | Partial messages.
-data Particle v
- -- | A single message with no target.
- = PMSingle String
+-- | A named optional value.
+data Option v = Option !Int String v
+ deriving (Show, Typeable)
- -- | A keyword message with many optional targets.
- | PMKeyword [String] [Maybe v]
- deriving (Eq, Show, Typeable)
+-- | Partial messages.
+type Particle v = Message (Maybe v)
-- | Shortcut error values.
data AtomoError
@@ -147,56 +162,120 @@
-- The Eq instance only checks equivalence. For example, named pattern matches
-- only match their patterns, not the names.
data Pattern
+ -- | Matches any value.
= PAny
+
+ -- | Matches a non-empty list, with the given patterns for its head and
+ -- tail.
| PHeadTail Pattern Pattern
+
+ -- | Matches a list of a given length, also pattern-matching its contents.
| PList [Pattern]
+
+ -- | Matches a tuple of a given length, also pattern-matching its contents.
+ | PTuple [Pattern]
+
+ -- | Matches a specific value. When matching objects, the delegates are
+ -- checked as well.
| PMatch Value
+
+ -- | Matches a message value.
| PMessage (Message Pattern)
+
+ -- | Matches an object delegating to something that matches a pattern.
| PInstance Pattern
+
+ -- | Matches a value strictly; delegates are not checked.
| PStrict Pattern
+
+ -- | Matches a value strictly; delegates are not checked.
+ | PVariable Pattern
+
+ -- | Gives a name to a pattern; this introduces a binding when
+ -- pattern-matching.
| PNamed String Pattern
+
+ -- | Match an object specified by an expression. When used in a method
+ -- definition, it's evaluated and turned into a @PMatch@.
| PObject Expr
+
+ -- | Structurally matches an expression. The @Expr@ here is an @EQuote@,
+ -- inside of which @EUnquote@s have @PNamed@ semantics.
+ | PExpr Expr
+
+ -- | Match a keyword particle. @PAny@ matches missing roles, but nothing
+ -- else does.
| PPMKeyword [String] [Pattern]
+
+ -- | Shortcut for the current object we're searching for a method on.
| PThis
- -- expression types, used in macros
+ -- | Matches any @Dispatch@ expression.
| PEDispatch
+
+ -- | Matches any @Operator@ expression.
| PEOperator
+
+ -- | Matches any @Primitive@ expression.
| PEPrimitive
+
+ -- | Matches any @EBlock@ expression.
| PEBlock
+
+ -- | Matches any @EList@ expression.
| PEList
+
+ -- | Matches any @ETuple@ expression.
+ | PETuple
+
+ -- | Matches any @EMacro@ expression.
| PEMacro
+
+ -- | Matches any @EForMacro@ expression.
+ | PEForMacro
+
+ -- | Matches any @EParticle@ expression.
| PEParticle
+
+ -- | Matches any @ETop@ expression.
| PETop
+
+ -- | Matches any @EQuote@ expression.
| PEQuote
+
+ -- | Matches any @EUnquote@ expression.
| PEUnquote
- | PExpr Expr
+ -- | Matches any @EMacroQuote@ expression.
+ | PEMacroQuote
+
+ -- | Matches any @EMatch@ expression.
+ | PEMatch
deriving (Show, Typeable)
-- | Expressions; the nodes in a syntax tree.
data Expr
- = Define
+ = EDefine
{ eLocation :: Maybe SourcePos
, emPattern :: Message Pattern
, eExpr :: Expr
}
- | Set
+ | ESet
{ eLocation :: Maybe SourcePos
, ePattern :: Pattern
, eExpr :: Expr
}
- | Dispatch
+ | EDispatch
{ eLocation :: Maybe SourcePos
, eMessage :: Message Expr
}
- | Operator
+ | EOperator
{ eLocation :: Maybe SourcePos
, eNames :: [String]
, eAssoc :: Assoc
, ePrec :: Integer
}
- | Primitive
+ | EPrimitive
{ eLocation :: Maybe SourcePos
, eValue :: !Value
}
@@ -209,6 +288,10 @@
{ eLocation :: Maybe SourcePos
, eContents :: [Expr]
}
+ | ETuple
+ { eLocation :: Maybe SourcePos
+ , eContents :: [Expr]
+ }
| EMacro
{ eLocation :: Maybe SourcePos
, emPattern :: Message Pattern
@@ -227,7 +310,6 @@
}
| EVM
{ eLocation :: Maybe SourcePos
- , ePretty :: Maybe Doc
, eAction :: VM Value
}
| EQuote
@@ -257,6 +339,17 @@
{ eLocation :: Maybe SourcePos
, eName :: String
}
+ | EMacroQuote
+ { eLocation :: Maybe SourcePos
+ , eName :: String
+ , eRaw :: String
+ , eFlags :: [Char]
+ }
+ | EMatch
+ { eLocation :: Maybe SourcePos
+ , eTarget :: Expr
+ , eBranches :: [(Pattern, Expr)]
+ }
deriving (Show, Typeable)
-- | Atomo's VM state.
@@ -306,7 +399,7 @@
{ idObject :: Value
, idBlock :: Value
, idBoolean :: Value
- , idChar :: Value
+ , idCharacter :: Value
, idContinuation :: Value
, idDouble :: Value
, idExpression :: Value
@@ -316,10 +409,12 @@
, idMessage :: Value
, idMethod :: Value
, idParticle :: Value
- , idProcess :: Value
, idPattern :: Value
+ , idProcess :: Value
, idRational :: Value
+ , idRegexp :: Value
, idString :: Value
+ , idTuple :: Value
}
deriving (Show, Typeable)
@@ -375,7 +470,7 @@
(==) (Block at aps aes) (Block bt bps bes) =
at == bt && aps == bps && aes == bes
(==) (Boolean a) (Boolean b) = a == b
- (==) (Char a) (Char b) = a == b
+ (==) (Character a) (Character b) = a == b
(==) (Continuation a) (Continuation b) = a == b
(==) (Double a) (Double b) = a == b
(==) (Expression a) (Expression b) = a == b
@@ -384,11 +479,15 @@
(==) (List a) (List b) = a == b
(==) (Message a) (Message b) = a == b
(==) (Method a) (Method b) = a == b
+ (==) (Object _ am) (Object _ bm) = am == bm
(==) (Particle a) (Particle b) = a == b
+ (==) (Pattern a) (Pattern b) = a == b
(==) (Process _ a) (Process _ b) = a == b
(==) (Rational a) (Rational b) = a == b
- (==) (Object _ am) (Object _ bm) = am == bm
+ (==) (Regexp _ a ao _) (Regexp _ b bo _) =
+ a == b && S.fromList ao == S.fromList bo
(==) (String a) (String b) = a == b
+ (==) (Tuple a) (Tuple b) = a == b
(==) _ _ = False
instance Eq Pattern where
@@ -397,43 +496,122 @@
(==) PAny PAny = True
(==) (PHeadTail ah at) (PHeadTail bh bt) =
ah == bh && at == bt
- (==) (PMessage a) (PMessage b) = a == b
(==) (PList aps) (PList bps) =
length aps == length bps && and (zipWith (==) aps bps)
+ (==) (PTuple aps) (PTuple bps) =
+ length aps == length bps && and (zipWith (==) aps bps)
(==) (PMatch a) (PMatch b) = a == b
+ (==) (PMessage a) (PMessage b) = a == b
+ (==) (PInstance a) (PInstance b) = a == b
+ (==) (PStrict a) (PStrict b) = a == b
+ (==) (PVariable a) (PVariable b) = a == b
(==) (PNamed _ a) (PNamed _ b) = a == b
(==) (PNamed _ a) b = a == b
(==) a (PNamed _ b) = a == b
+ (==) (PObject a) (PObject b) = a == b
+ -- TODO: ignore names in unquotes
+ (==) (PExpr a) (PExpr b) = a == b
(==) (PPMKeyword ans aps) (PPMKeyword bns bps) =
ans == bns && and (zipWith (==) aps bps)
(==) PThis PThis = True
+ (==) PEDispatch PEDispatch = True
+ (==) PEOperator PEOperator = True
+ (==) PEPrimitive PEPrimitive = True
+ (==) PEBlock PEBlock = True
+ (==) PEList PEList = True
+ (==) PETuple PETuple = True
+ (==) PEMacro PEMacro = True
+ (==) PEForMacro PEForMacro = True
+ (==) PEParticle PEParticle = True
+ (==) PETop PETop = True
+ (==) PEQuote PEQuote = True
+ (==) PEUnquote PEUnquote = True
+ (==) PEMacroQuote PEMacroQuote = True
+ (==) PEMatch PEMatch = True
(==) _ _ = False
-
instance Eq Expr where
- (==) (Define _ ap' ae) (Define _ bp be) = ap' == bp && ae == be
- (==) (Set _ ap' ae) (Set _ bp be) = ap' == bp && ae == be
- (==) (Dispatch _ am) (Dispatch _ bm) = am == bm
- (==) (Operator _ ans aa ap') (Operator _ bns ba bp) =
+ (==) (EDefine _ am ae) (EDefine _ bm be) = am == bm && ae == be
+ (==) (ESet _ am ae) (ESet _ bm be) = am == bm && ae == be
+ (==) (EDispatch _ am) (EDispatch _ bm) = am == bm
+ (==) (EOperator _ ans aa ap') (EOperator _ bns ba bp) =
ans == bns && aa == ba && ap' == bp
- (==) (Primitive _ a) (Primitive _ b) = a == b
+ (==) (EPrimitive _ a) (EPrimitive _ b) = a == b
(==) (EBlock _ aas aes) (EBlock _ bas bes) =
aas == bas && aes == bes
(==) (EList _ aes) (EList _ bes) = aes == bes
+ (==) (ETuple _ aes) (ETuple _ bes) = aes == bes
+ (==) (EMacro _ am ae) (EMacro _ bm be) = am == bm && ae == be
+ (==) (EForMacro _ ae) (EForMacro _ be) = ae == be
(==) (EParticle _ ap') (EParticle _ bp) = ap' == bp
(==) (ETop _) (ETop _) = True
(==) (EVM {}) (EVM {}) = False
+ (==) (EQuote _ ae) (EQuote _ be) = ae == be
+ (==) (EUnquote _ ae) (EUnquote _ be) = ae == be
+ (==) (ENewDynamic _ ab ae) (ENewDynamic _ bb be) =
+ ab == bb && ae == be
+ (==) (EDefineDynamic _ an ae) (EDefineDynamic _ bn be) =
+ an == bn && ae == be
+ (==) (ESetDynamic _ an ae) (ESetDynamic _ bn be) =
+ an == bn && ae == be
+ (==) (EGetDynamic _ an) (EGetDynamic _ bn) = an == bn
+ (==) (EMacroQuote _ an ac afs) (EMacroQuote _ bn bc bfs) =
+ an == bn && ac == bc && afs == bfs
+ (==) (EMatch _ at avs) (EMatch _ bt bvs) =
+ at == bt && avs == bvs
(==) _ _ = False
-
-instance Show Channel where
- show _ = "Channel"
+instance Eq a => Eq (Message a) where
+ (==) (Single ai _ at aos) (Single bi _ bt bos) =
+ ai == bi && at == bt && aos == bos
+ (==) (Keyword ai _ ats aos) (Keyword bi _ bts bos) =
+ ai == bi && ats == bts && aos == bos
+ (==) _ _ = False
-instance Show Methods where
- show _ = "Methods"
+instance Eq a => Eq (Option a) where
+ (==) (Option ai _ av) (Option bi _ bv) = ai == bi && av == bv
-instance Show Continuation where
- show _ = "Continuation"
+-- | A prettier Show instance. Note that some are not entirely accurate
+-- constructors, e.g. Process, Continuation, and Object.
+instance Show Value where
+ show (Block v as es) =
+ "Block (" ++ show v ++ ") " ++ show as ++ " " ++ show es
+ show (Boolean x) =
+ "Boolean " ++ show x
+ show (Character x) =
+ "Character " ++ show x
+ show (Continuation _) =
+ "Continuation"
+ show (Double x) =
+ "Double " ++ show x
+ show (Expression x) =
+ "Expression (" ++ show x ++ ")"
+ show (Haskell x) =
+ "Haskell " ++ show x
+ show (Integer x) =
+ "Integer " ++ show x
+ show (List x) =
+ "List (" ++ show x ++ ")"
+ show (Message x) =
+ "Message (" ++ show x ++ ")"
+ show (Method x) =
+ "Method (" ++ show x ++ ")"
+ show (Object ds _) =
+ "Object " ++ show ds
+ show (Particle x) =
+ "Particle (" ++ show x ++ ")"
+ show (Pattern x) =
+ "Pattern (" ++ show x ++ ")"
+ show (Process _ t) =
+ "Process (" ++ show t ++ ")"
+ show (Rational x) =
+ "Rational (" ++ show x ++ ")"
+ show (Regexp _ x o _) =
+ "Regexp " ++ show x ++ " " ++ show o
+ show (String x) =
+ "String " ++ show x
+ show (Tuple x) =
+ "Tuple (" ++ show x ++ ")"
instance Show (VM a) where
show _ = "VM"
@@ -443,14 +621,15 @@
instance S.Lift Expr where
- lift (Define _ p e) = [| Define Nothing p e |]
- lift (Set _ p e) = [| Set Nothing p e |]
- lift (Dispatch _ m) = [| Dispatch Nothing m |]
- lift (Operator _ ns a p) = [| Operator Nothing ns a p |]
- lift (Primitive _ v) = [| Primitive Nothing v |]
+ lift (EDefine _ p e) = [| EDefine Nothing p e |]
+ lift (ESet _ p e) = [| ESet Nothing p e |]
+ lift (EDispatch _ m) = [| EDispatch Nothing m |]
+ lift (EOperator _ ns a p) = [| EOperator Nothing ns a p |]
+ lift (EPrimitive _ v) = [| EPrimitive Nothing v |]
lift (EBlock _ as es) = [| EBlock Nothing as es |]
lift (EVM {}) = error "cannot lift EVM"
lift (EList _ es) = [| EList Nothing es |]
+ lift (ETuple _ es) = [| ETuple Nothing es |]
lift (ETop _) = [| ETop Nothing |]
lift (EParticle _ p) = [| EParticle Nothing p |]
lift (EMacro _ p e) = [| EMacro Nothing p e |]
@@ -461,23 +640,24 @@
lift (ESetDynamic _ n e) = [| ESetDynamic Nothing n e |]
lift (EDefineDynamic _ n e) = [| EDefineDynamic Nothing n e |]
lift (EGetDynamic _ n) = [| EGetDynamic Nothing n |]
+ lift (EMacroQuote _ n r fs) = [| EMacroQuote Nothing n r fs |]
+ lift (EMatch _ t bs) = [| EMatch Nothing t bs |]
instance S.Lift Assoc where
lift ALeft = [| ALeft |]
lift ARight = [| ARight |]
instance (S.Lift v) => S.Lift (Message v) where
- lift (Keyword i ns vs) = [| Keyword i ns vs |]
- lift (Single i n v) = [| Single i n v |]
+ lift (Keyword i ns vs os) = [| Keyword i ns vs os |]
+ lift (Single i n v os) = [| Single i n v os |]
-instance (S.Lift v) => S.Lift (Particle v) where
- lift (PMSingle n) = [| PMSingle n |]
- lift (PMKeyword ns vs) = [| PMKeyword ns vs |]
+instance (S.Lift v) => S.Lift (Option v) where
+ lift (Option i n v) = [| Option i n v |]
instance S.Lift Value where
lift (Block s as es) = [| Block s as es |]
lift (Boolean b) = [| Boolean b |]
- lift (Char c) = [| Char c |]
+ lift (Character c) = [| Character c |]
lift (Double d) = [| Double $(return $ S.LitE (S.RationalL (toRational d))) |]
lift (Expression e) = [| Expression e |]
lift (Integer i) = [| Integer i |]
@@ -492,6 +672,7 @@
lift (PHeadTail h t) = [| PHeadTail h t |]
lift (PMessage m) = [| PMessage m |]
lift (PList ps) = [| PList ps |]
+ lift (PTuple ps) = [| PTuple ps |]
lift (PMatch v) = [| PMatch v |]
lift (PNamed n p) = [| PNamed n p |]
lift (PObject e) = [| PObject e |]
@@ -502,14 +683,19 @@
lift PEPrimitive = [| PEPrimitive |]
lift PEBlock = [| PEBlock |]
lift PEList = [| PEList |]
+ lift PETuple = [| PETuple |]
lift PEMacro = [| PEMacro |]
+ lift PEForMacro = [| PEForMacro |]
lift PEParticle = [| PEParticle |]
lift PETop = [| PETop |]
lift PEQuote = [| PEQuote |]
lift PEUnquote = [| PEUnquote |]
+ lift PEMacroQuote = [| PEMacroQuote |]
+ lift PEMatch = [| PEMatch |]
lift (PExpr e) = [| PExpr e |]
lift (PInstance p) = [| PInstance p |]
lift (PStrict p) = [| PStrict p |]
+ lift (PVariable p) = [| PVariable p |]
-- | Initial "empty" parser state.
@@ -525,7 +711,7 @@
{ idObject = error "idObject not set"
, idBlock = error "idBlock not set"
, idBoolean = error "idBoolean not set"
- , idChar = error "idChar not set"
+ , idCharacter = error "idCharacter not set"
, idContinuation = error "idContinuation not set"
, idDouble = error "idDouble not set"
, idExpression = error "idExpression not set"
@@ -535,10 +721,12 @@
, idMessage = error "idMessage not set"
, idMethod = error "idMethod not set"
, idParticle = error "idParticle not set"
- , idProcess = error "idProcess not set"
, idPattern = error "idPattern not set"
+ , idProcess = error "idProcess not set"
, idRational = error "idRational not set"
+ , idRegexp = error "idRegexp not set"
, idString = error "idString not set"
+ , idTuple = error "idTuple not set"
}
, channel = error "channel not set"
, halt = error "halt not set"
@@ -596,18 +784,62 @@
-- | Create a single particle with a given name.
particle :: String -> Value
{-# INLINE particle #-}
-particle = Particle . PMSingle
+particle = Particle . flip single Nothing
-- | Create a keyword particle with a given name and optional values.
keyParticle :: [String] -> [Maybe Value] -> Value
{-# INLINE keyParticle #-}
-keyParticle ns vs = Particle $ PMKeyword ns vs
+keyParticle ns vs = Particle $ keyword ns vs
-- | Create a keyword particle with no first role and the given values.
keyParticleN :: [String] -> [Value] -> Value
{-# INLINE keyParticleN #-}
keyParticleN ns vs = keyParticle ns (Nothing:map Just vs)
+-- | Create a Regex value.
+regex :: Monad m => String -> String -> m Regex
+regex p fs = do
+ os <- opt fs
+ makeRegexOptsM os defaultExecOpt p
+ where
+ base
+ | 'U' `elem` fs = compBlank
+ | otherwise = compUTF8
+
+ opt [] = return base
+ opt (o:os) = liftM2 (.|.) (toOpt o) (opt os)
+
+ -- standard Perl
+ toOpt 'm' = return compMultiline
+ toOpt 's' = return compDotAll
+ toOpt 'i' = return compCaseless
+ toOpt 'x' = return compExtended
+
+ -- additional
+ toOpt 'a' = return compAnchored
+ toOpt 'G' = return compUngreedy
+ toOpt 'e' = return compDollarEndOnly
+ toOpt 'f' = return compFirstLine
+ toOpt 'C' = return compNoAutoCapture
+
+ toOpt c = fail $ "unknown regex flag " ++ show c
+
+-- | Scan a regular expression to determine the index for named captures.
+namedCaptures :: String -> [(String, Int)]
+namedCaptures = cap 1
+ where
+ cap _ "" = []
+ cap n ('\\':_:cs) = cap n cs
+ cap n ('[':cs) = cap n (dropWhile (/= ']') cs)
+ cap n ('(':'?':'<':'=':cs) = cap n cs
+ cap n ('(':'?':'<':'!':cs) = cap n cs
+ cap n ('(':'?':'<':cs) = (name, n) : cap (n + 1) rest
+ where
+ (name, _:rest) = span (/= '>') cs
+ cap n ('(':'?':cs) = cap n cs
+ cap n ('(':cs) = cap (n + 1) cs
+ cap n (_:cs) = cap n cs
+
-- | Convert a String into a Value.
string :: String -> Value
{-# INLINE string #-}
@@ -623,6 +855,11 @@
{-# INLINE list #-}
list = List . V.fromList
+-- | Convert a tuple of values into a tuple Value.
+tuple :: [Value] -> Value
+{-# INLINE tuple #-}
+tuple = Tuple . V.fromList
+
-- | Convert a Text string into a String.
fromText :: T.Text -> String
{-# INLINE fromText #-}
@@ -633,16 +870,36 @@
fromList (List vr) = V.toList vr
fromList v = error $ "no fromList for: " ++ show v
+-- | Convert a Tuple Value into a list of Values.
+fromTuple :: Value -> [Value]
+fromTuple (Tuple vr) = V.toList vr
+fromTuple v = error $ "no fromTuple for: " ++ show v
+
-- | Create a single message with a given name and target.
single :: String -> v -> Message v
{-# INLINE single #-}
-single n = Single (hash n) n
+single n v = Single (hash n) n v []
+-- | Create a single message with a given name and target.
+single' :: String -> v -> [Option v] -> Message v
+{-# INLINE single' #-}
+single' n v os = Single (hash n) n v os
+
-- | Create a keyword message with a given name and targets.
keyword :: [String] -> [v] -> Message v
{-# INLINE keyword #-}
-keyword ns = Keyword (hash ns) ns
+keyword ns vs = Keyword (hash ns) ns vs []
+-- | Create a keyword message with a given name and targets.
+keyword' :: [String] -> [v] -> [Option v] -> Message v
+{-# INLINE keyword' #-}
+keyword' ns vs os = Keyword (hash ns) ns vs os
+
+-- | Create an @Option@ with the given name and value.
+option :: String -> v -> Option v
+{-# INLINE option #-}
+option n v = Option (hash n) n v
+
-- | Create a single message pattern with a given name and target pattern.
psingle :: String -> Pattern -> Pattern
{-# INLINE psingle #-}
@@ -663,10 +920,10 @@
isBoolean (Boolean _) = True
isBoolean _ = False
--- | Is a value a `Char'?
-isChar :: Value -> Bool
-isChar (Char _) = True
-isChar _ = False
+-- | Is a value a `Character'?
+isCharacter :: Value -> Bool
+isCharacter (Character _) = True
+isCharacter _ = False
-- | Is a value a `Continuation'?
isContinuation :: Value -> Bool
@@ -708,6 +965,11 @@
isMethod (Method _) = True
isMethod _ = False
+-- | Is a value a `Object'?
+isObject :: Value -> Bool
+isObject (Object {}) = True
+isObject _ = False
+
-- | Is a value a `Particle'?
isParticle :: Value -> Bool
isParticle (Particle _) = True
@@ -728,21 +990,42 @@
isRational (Rational _) = True
isRational _ = False
--- | Is a value a `Object'?
-isObject :: Value -> Bool
-isObject (Object {}) = True
-isObject _ = False
+-- | Is a value a `Regexp'?
+isRegexp :: Value -> Bool
+isRegexp (Regexp {}) = True
+isRegexp _ = False
-- | Is a value a `String'?
isString :: Value -> Bool
isString (String _) = True
isString _ = False
+-- | Is a value a `Tuple'?
+isTuple :: Value -> Bool
+isTuple (Tuple _) = True
+isTuple _ = False
+
+
-- | Convert an AtomoError into the Value we want to error with.
asValue :: AtomoError -> Value
asValue (Error v) = v
asValue (ParseError pe) =
- keyParticleN ["parse-error"] [string (show pe)]
+ keyParticleN ["parse-error", "at"]
+ [ list (nub $ map msgValue (PE.errorMessages pe))
+ , spValue (PE.errorPos pe)
+ ]
+ where
+ msgValue (PE.SysUnExpect s) = keyParticleN ["unexpected"] [string s]
+ msgValue (PE.UnExpect s) = keyParticleN ["unexpected"] [string s]
+ msgValue (PE.Expect s) = keyParticleN ["expected"] [string s]
+ msgValue (PE.Message s) = string s
+
+ spValue s =
+ keyParticleN ["source", "line", "column"]
+ [ string (sourceName s)
+ , Integer (fromIntegral $ sourceLine s)
+ , Integer (fromIntegral $ sourceColumn s)
+ ]
asValue (DidNotUnderstand m) =
keyParticleN ["did-not-understand"] [Message m]
asValue (Mismatch pat v) =
@@ -779,7 +1062,7 @@
objectFrom _ o@(Object {}) = o
objectFrom ids (Block _ _ _) = idBlock ids
objectFrom ids (Boolean _) = idBoolean ids
-objectFrom ids (Char _) = idChar ids
+objectFrom ids (Character _) = idCharacter ids
objectFrom ids (Continuation _) = idContinuation ids
objectFrom ids (Double _) = idDouble ids
objectFrom ids (Expression _) = idExpression ids
@@ -789,7 +1072,9 @@
objectFrom ids (Message _) = idMessage ids
objectFrom ids (Method _) = idMethod ids
objectFrom ids (Particle _) = idParticle ids
-objectFrom ids (Process _ _) = idProcess ids
objectFrom ids (Pattern _) = idPattern ids
+objectFrom ids (Process _ _) = idProcess ids
objectFrom ids (Rational _) = idRational ids
+objectFrom ids (Regexp {}) = idRegexp ids
objectFrom ids (String _) = idString ids
+objectFrom ids (Tuple _) = idTuple ids
diff --git a/src/Atomo/Valuable.hs b/src/Atomo/Valuable.hs
--- a/src/Atomo/Valuable.hs
+++ b/src/Atomo/Valuable.hs
@@ -1,11 +1,15 @@
+{-# LANGUAGE QuasiQuotes, TypeSynonymInstances #-}
module Atomo.Valuable where
import Control.Monad (liftM)
-import Control.Monad.Trans (liftIO)
-import Data.IORef
+import System.IO
import qualified Data.Text as T
import qualified Data.Vector as V
+import Atomo.Environment
+import Atomo.Helpers
+import Atomo.Pretty (Prettied)
+import Atomo.QuasiQuotes
import Atomo.Types
@@ -21,33 +25,108 @@
fromValue = return
instance Valuable Char where
- toValue = return . Char
- fromValue (Char c) = return c
+ toValue = return . Character
+ fromValue (Character c) = return c
+ fromValue v = raise ["wrong-value", "needed"] [v, string "Character"]
instance Valuable Double where
toValue = return . Double
fromValue (Double d) = return d
+ fromValue v = raise ["wrong-value", "needed"] [v, string "Double"]
instance Valuable Float where
toValue = return . Double . fromRational . toRational
fromValue (Double d) = return (fromRational . toRational $ d)
+ fromValue v = raise ["wrong-value", "needed"] [v, string "Double"]
instance Valuable Integer where
toValue = return . Integer
fromValue (Integer i) = return i
+ fromValue v = raise ["wrong-value", "needed"] [v, string "Integer"]
instance Valuable Int where
toValue = return . Integer . fromIntegral
fromValue (Integer i) = return (fromIntegral i)
+ fromValue v = raise ["wrong-value", "needed"] [v, string "Integer"]
instance Valuable a => Valuable [a] where
toValue xs = liftM list (mapM toValue xs)
fromValue (List v) = mapM fromValue (V.toList v)
+ fromValue v = raise ["wrong-value", "needed"] [v, string "List"]
instance Valuable a => Valuable (V.Vector a) where
toValue xs = liftM List (V.mapM toValue xs)
fromValue (List v) = V.mapM fromValue v
+ fromValue v = raise ["wrong-value", "needed"] [v, string "List"]
instance Valuable T.Text where
toValue = return . String
fromValue (String s) = return s
+ fromValue v = raise ["wrong-value", "needed"] [v, string "String"]
+
+instance Valuable Pattern where
+ toValue = return . Pattern
+ fromValue (Pattern x) = return x
+ fromValue v = raise ["wrong-value", "needed"] [v, string "Pattern"]
+
+instance Valuable Expr where
+ toValue = return . Expression
+ fromValue (Expression x) = return x
+ fromValue v = raise ["wrong-value", "needed"] [v, string "Expression"]
+
+instance Valuable x => Valuable (Maybe x) where
+ toValue (Just x) = liftM (keyParticleN ["ok"] . (:[])) (toValue x)
+ toValue Nothing = return (particle "none")
+
+ fromValue (Particle (Single { mName = "none" })) = return Nothing
+ fromValue (Particle (Keyword { mNames = ["ok"], mTargets = [_, Just v]})) =
+ liftM Just (fromValue v)
+ fromValue v = raise ["wrong-value", "needed"]
+ [ v
+ , keyParticleN ["one-of"]
+ [ tuple
+ [ particle "none"
+ , keyParticle ["ok"] [Nothing, Nothing]
+ ]
+ ]
+ ]
+
+instance (Valuable x, Valuable y) => Valuable (x, y) where
+ toValue (x, y) = do
+ xv <- toValue x
+ yv <- toValue y
+ dispatch (keyword ["->"] [xv, yv])
+
+ fromValue v = do
+ x <- dispatch (single "from" v) >>= fromValue
+ y <- dispatch (single "to" v) >>= fromValue
+ return (x, y)
+
+instance Valuable BufferMode where
+ toValue (BlockBuffering Nothing) = return (particle "block")
+ toValue (BlockBuffering (Just i)) = return (keyParticleN ["block"] [Integer (fromIntegral i)])
+ toValue LineBuffering = return (particle "line")
+ toValue NoBuffering = return (particle "none")
+
+ fromValue (Particle (Single { mName = "block" })) = return (BlockBuffering Nothing)
+ fromValue (Particle (Keyword { mNames = ["block"], mTargets = [Nothing, Just (Integer i)] })) =
+ return (BlockBuffering (Just (fromIntegral i)))
+ fromValue (Particle (Single { mName = "line" })) = return LineBuffering
+ fromValue (Particle (Single { mName = "none" })) = return NoBuffering
+ fromValue v = raise ["wrong-value", "needed"]
+ [ v
+ , keyParticleN ["one-of"]
+ [ tuple
+ [ particle "block"
+ , keyParticle ["block"] [Nothing, Nothing]
+ , particle "line"
+ , particle "none"
+ ]
+ ]
+ ]
+
+instance Valuable Prettied where
+ toValue d =
+ [$e|Pretty|] `newWith` [("doc", haskell d)]
+
+ fromValue v = dispatch (single "doc" v) >>= fromHaskell
diff --git a/src/Main.hs b/src/Main.hs
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -8,7 +8,6 @@
import Atomo.Core
import Atomo.Load
import Atomo.Parser
-import Atomo.PrettyVM
import Atomo.Run
import qualified Atomo.Kernel as Kernel