atomo 0.2 → 0.2.1
raw patch · 47 files changed
+1582/−950 lines, 47 files
Files
- atomo.cabal +2/−2
- prelude/block.atomo +6/−3
- prelude/boolean.atomo +16/−11
- prelude/condition.atomo +177/−0
- prelude/continuation.atomo +18/−14
- prelude/core.atomo +38/−11
- prelude/eco.atomo +28/−7
- prelude/exception.atomo +26/−0
- prelude/list.atomo +2/−0
- prelude/numeric.atomo +5/−0
- prelude/parameter.atomo +29/−12
- prelude/ports.atomo +64/−14
- prelude/repl.atomo +101/−0
- prelude/string.atomo +27/−0
- prelude/version.atomo +1/−1
- src/Atomo.hs +0/−2
- src/Atomo/Environment.hs +324/−194
- src/Atomo/Kernel.hs +21/−8
- src/Atomo/Kernel/Block.hs +6/−8
- src/Atomo/Kernel/Char.hs +79/−0
- src/Atomo/Kernel/Comparable.hs +1/−1
- src/Atomo/Kernel/Concurrency.hs +2/−5
- src/Atomo/Kernel/Environment.hs +2/−2
- src/Atomo/Kernel/Exception.hs +0/−86
- src/Atomo/Kernel/Expression.hs +104/−39
- src/Atomo/Kernel/List.hs +45/−32
- src/Atomo/Kernel/Message.hs +2/−3
- src/Atomo/Kernel/Numeric.hs +1/−1
- src/Atomo/Kernel/Particle.hs +43/−11
- src/Atomo/Kernel/Pattern.hs +13/−39
- src/Atomo/Kernel/Ports.hs +36/−24
- src/Atomo/Kernel/String.hs +78/−43
- src/Atomo/Load.hs +1/−4
- src/Atomo/Method.hs +2/−2
- src/Atomo/Parser.hs +70/−50
- src/Atomo/Parser/Base.hs +67/−70
- src/Atomo/Parser/Pattern.hs +23/−13
- src/Atomo/Parser/Primitive.hs +7/−6
- src/Atomo/Pretty.hs +16/−57
- src/Atomo/PrettyVM.hs +3/−32
- src/Atomo/QuasiQuotes.hs +7/−9
- src/Atomo/Run.hs +10/−10
- src/Atomo/Spawn.hs +1/−3
- src/Atomo/Types.hs +53/−35
- src/Atomo/VMT.hs +12/−15
- src/Atomo/Valuable.hs +3/−2
- src/Main.hs +10/−69
atomo.cabal view
@@ -1,5 +1,5 @@ name: atomo-version: 0.2+version: 0.2.1 synopsis: A highly dynamic, extremely simple, very fun programming language. description:@@ -99,9 +99,9 @@ Atomo.Kernel.Pattern, Atomo.Kernel.Ports, Atomo.Kernel.Time,- Atomo.Kernel.Exception, Atomo.Kernel.Environment, Atomo.Kernel.Continuation,+ Atomo.Kernel.Char, Paths_atomo
prelude/block.atomo view
@@ -1,3 +1,9 @@+context Block: (es: List) :=+ Block new: es arguments: [] in: context++context Block: (es: List) arguments: (as: List) :=+ Block new: es arguments: as in: context+ (b: Block) repeat := { b in-context call b repeat@@ -8,9 +14,6 @@ { call := b context join: b call: vs := b context join: b with: vs }--(a: Block) .. (b: Block) :=- Block new: (a contents .. b contents) in: sender (start: Integer) to: (end: Integer) by: (diff: Integer) do: b := (start to: end by: diff) each: b
prelude/boolean.atomo view
@@ -1,3 +1,5 @@+@no-true-branches describe-error := "no tests in condition: block were true"+ False and: _ = False True and: (b: Block) := b call @@ -16,12 +18,22 @@ if: False then: Block else: (b: Block) := b call +unless: True do: Block = @ok+unless: False do: (action: Block) :=+ { action in-context call+ @ok+ } call++macro e unless: b := `(unless: ~b do: { ~e })+ when: False do: Block = @ok when: True do: (action: Block) := { action in-context call @ok } call +macro e when: b := `(when: ~b do: { ~e })+ while: (test: Block) do: (action: Block) := when: test call do: { action in-context call@@ -34,14 +46,7 @@ otherwise := True macro condition: (bs: Block) :=- { ps = bs contents map:- { pair |- [c, e] = pair targets- c -> e- }-- ps reduce-right:- { pair x |- `(if: ~(pair from) then: { ~(pair to) } else: { ~x })- } with: `(raise: @no-true-branches)- } call+ bs contents reduce-right:+ { `(~test -> ~branch) x |+ `(if: ~test then: { ~branch } else: { ~x })+ } with: `(error: @no-true-branches)
+ prelude/condition.atomo view
@@ -0,0 +1,177 @@+{ define: *handlers* as: []+ define: *restarts* as: []++ super do: {+ Default-Debugger = Object clone do:+ { run: e :=+ { Restart show-options-for: e++ "!> " display++ Restart (get: read) jump: []+ } call+ }++ define: *debugger* as: Default-Debugger+ define: *error-output* as: Port standard-error++ Condition = Object clone++ Error = Condition clone+ Simple-Error = Error clone++ Warning = Condition clone+ Simple-Warning = Warning clone+ }++ for-macro Handler = Object clone do: { handle: _ := @ok }+ for-macro Restart = Object clone++ (e: Simple-Error) describe-error := e value describe-error+ (w: Simple-Warning) describe-error := w value describe-error++ Simple-Error new: v :=+ Simple-Error clone do: { delegates-to: v; value = v }++ Simple-Warning new: v :=+ Simple-Warning clone do: { delegates-to: v; value = v }++ (e: Simple-Error) show := "<error " .. e value show .. ">"+ (e: Simple-Warning) show := "<warning " .. e value show .. ">"++ Restart show-options-for: e :=+ { $- (repeat: 78) print+ e describe-error+ (word-wrap: 74)+ lines+ (map: { l | "*** " .. l })+ unlines+ print++ halt when: *restarts* _? empty?++ "restarts:" print++ *restarts* _? (zip: (0 .. *restarts* _? length)) map:+ { choice |+ [index, name] = [choice to, choice from from]+ (" :" .. index show .. " -> " .. name name) print+ }+ } call++ Restart get: (n: Integer) :=+ *restarts* _? (at: n) to++ Restart new: (a: Block) in: (c: Continuation) :=+ { res = *restarts* _?+ Restart clone do:+ { jump: as := with: *restarts* as: res do: { c yield: (a call: as) }+ action = a+ context = c+ }+ } call++ (r: Restart) show := "<restart " .. r action show .. ">"++ macro action with-restarts: (restarts: Block) :=+ { rs = restarts contents map:+ { `(~n -> ~e) |+ e type match: {+ @block -> `('~n -> ~e)+ _ -> `('~n -> { ~e })+ }+ }++ `(+ { cc action pairs |+ restarts = pairs map:+ { a | a from -> (~Restart new: a to in: cc) }+ action with-restarts: restarts+ } call/cc: [~action, ~(`List new: rs)]+ )+ } call++ (action: Block) with-restarts: (restarts: List) :=+ modify: *restarts* as: { rs | restarts .. rs } do: action++ (super) signal: v :=+ { *handlers* _? map: @(handle: v)+ @ok+ } call++ (super) error: v := error: (Simple-Error new: v)+ (super) error: (e: Error) :=+ { signal: e++ with-output-to: *error-output* _? do: {+ *debugger* _? run: e+ }+ } call++ (super) warning: v := warning: (Simple-Warning new: v)+ (super) warning: (w: Warning) :=+ { signal: w++ with-output-to: *error-output* _? do: {+ ("WARNING: " .. w describe-error) print+ }++ @ok+ } with-restarts: {+ muffle-warning -> @ok+ }++ (super) restart: name := restart: name with: []++ (super) restart: name with: (params: List) :=+ *restarts* _? (lookup: name) match: {+ @(ok: r) ->+ r jump: params++ @none ->+ error: @(unknown-restart: name)+ }++ (super) find-restart: name :=+ *restarts* _? lookup: name++ (super) with-handler: (h: Handler) do: (action: Block) :=+ modify: *handlers* as: { hs | h . hs } do: action++ macro a bind: (bs: Block) :=+ { h = Handler clone++ (h) in: c :=+ { h context = c+ h+ } call++ -- yield a hygienic expr to define on the handler+ expr-for: e :=+ condition: {+ e type == @block && e arguments empty? not ->+ ``(~'~e call: [~s]) -- wow++ e type == @block ->+ `'(~e call)++ otherwise -> `'~e+ }++ signals = bs contents map:+ { `(~pat -> ~expr) |+ Lobby+ define: @handle:+ on: `(h: ~h) (as: Pattern)+ with: [`(s: ~pat) as: Pattern]+ as: `(+ { match: ~(pat as: Pattern) on: s+ (with-delegates: [h context])+ evaluate: ~(expr-for: expr)+ } call+ )+ }++ `(with-handler: (~h in: this) do: ~a)+ } call+} call
prelude/continuation.atomo view
@@ -1,19 +1,20 @@-{ dynamic-winds = Parameter new: []+{ define: *dynamic-winds* as: [] - (o: Object) call/cc :=+ (o: Object) call/cc := o call/cc: []+ (o: Object) call/cc: as := { cc |- winds = dynamic-winds _?+ winds = *dynamic-winds* _? new = cc clone do: { yield: v := { dynamic-unwind: winds- delta: (dynamic-winds _? length - winds length)+ delta: (*dynamic-winds* _? length - winds length) cc yield: v } call } - o call: [new]+ o call: (new . as) } raw-call/cc (v: Block) before: (b: Block) := v before: b after: { @ok }@@ -22,12 +23,15 @@ (v: Block) before: (b: Block) after: (a: Block) := { b call - dynamic-winds =! ((b -> a) . dynamic-winds _?)+ *dynamic-winds* =! ((b -> a) . *dynamic-winds* _?) - { v call } ensuring:- { dynamic-winds =! dynamic-winds _? tail- a call- }+ res = v call++ a call++ *dynamic-winds* =! *dynamic-winds* _? tail++ res } call (init: Block) wrap: cleanup do: action :=@@ -35,18 +39,18 @@ dynamic-unwind: to delta: d := condition: {- (dynamic-winds _? == to) -> @ok+ (*dynamic-winds* _? == to) -> @ok (d < 0) -> { dynamic-unwind: to tail delta: (d + 1) to head from call- dynamic-winds =! to+ *dynamic-winds* =! to @ok } call otherwise ->- { post = dynamic-winds _? head to- dynamic-winds =! dynamic-winds _? tail+ { post = *dynamic-winds* _? head to+ *dynamic-winds* =! *dynamic-winds* _? tail post call dynamic-unwind: to delta: (d - 1) } call
prelude/core.atomo view
@@ -1,14 +1,41 @@-macro x match: (ts: Block) :=- { obj = Object clone+@(parse-error: d) describe-error :=+ "parse error:\n" .. (d indent: 2) - (obj) match-on: x := raise: @(no-matches-for: x)+@(did-not-understand: m) describe-error :=+ "message not understood: " .. m show - ts contents each:- { pair |- [p, e] = pair targets- @match-on: define-on: [obj, p as: Pattern] as:- `({ delegates-to: sender; ~e } call) in: Lobby- }+@(pattern: p did-not-match: v) describe-error :=+ v show .. " did not match pattern: " .. p show - `(~obj match-on: ~x)- } call+@(unknown-hint-error: d) describe-error :=+ "unknown hint error:\n" .. (d indent: 2)++@(wont-compile: es) describe-error :=+ "Haskell source won't compile:\n" .. es (map: @(indent: 2)) (join: "\n\n")++@(not-allowed: e) describe-error :=+ "not allowed: " .. e++@(ghc-exception: e) describe-error :=+ "GHC exception: " .. e++@(file-not-found: f) describe-error :=+ "file not found: " .. f++@(particle-needed: n given: g) describe-error :=+ "particle needed " .. n show .. " values to complete, given " .. g show++@(block-expected: e given: g) describe-error :=+ "block expected " .. e show .. " arguments, given " .. g show++@no-expressions describe-error := "no expressions to evaluate"++@(could-not-find: t in: v) describe-error :=+ "could not find a " .. t .. " in: " .. v show++@(dynamic-needed: t) describe-error :=+ "expecting Haskell value of type " .. t+++macro x match: (ts: Block) :=+ `Match new: (ts contents map: { `(~p -> ~e) | p -> e }) on: x
prelude/eco.atomo view
@@ -27,7 +27,7 @@ (e: Eco) initialize: pkg := { pkg dependencies each: { c | e packages (find: c from) match: {- @none -> raise: @(package-unavailable: c from needed: c to)+ @none -> error: @(package-unavailable: c from needed: c to) -- filter out versions not satisfying our dependency @(ok: d) ->@@ -35,7 +35,7 @@ safe match: { [] ->- raise: @(no-versions-of: d satisfy: c to for: pkg name)+ error: @(no-versions-of: d satisfy: c to for: pkg name) -- initialize the first safe version of the package (p . _) ->@@ -172,12 +172,12 @@ Eco load: name version: check in: env := Eco packages (lookup: name) match: {- @none -> raise: @(package-unavailable: name)- @(ok: []) -> raise: @(no-package-versions: name)+ @none -> error: @(package-unavailable: name)+ @(ok: []) -> error: @(no-package-versions: name) @(ok: pkgs) -> { pkg = pkgs (filter: { p | p version join: check }) match: {- [] -> raise: @(no-versions-of: name satisfy: check)+ [] -> error: @(no-versions-of: name satisfy: check) (p . _) -> p } @@ -200,8 +200,14 @@ context use: name version: { True } context use: (name: String) version: (v: Version) :=- context use: name version: { == v }+ context use: name version: (evaluate: `({ == ~v })) +macro context use: name version: (v: Primitive) :=+ `(~context use: ~name version: { == ~v })++macro context use: name version: (v: `(~_ . ~_)) :=+ `(~context use: ~name version: { == ~v })+ context use: (name: String) version: (check: Block) := Eco loaded (lookup: name) match: { @none -> (Eco load: name version: check in: context clone)@@ -209,7 +215,7 @@ @(ok: p) -> condition: { p version (join: check) not ->- raise: @(incompatible-version-loaded: name needed: check)+ error: @(incompatible-version-loaded: name needed: check) (context in?: p contexts) -> p environment @@ -217,3 +223,18 @@ (Eco load: name version: check in: context clone) } }++@(package-unavailable: name) describe-error :=+ "package unavailable: " .. name++@(no-versions-of: pkg satisfy: check for: needer) describe-error :=+ "no versions of '" .. pkg .. "' satisfy version constraint " .. check show .. " needed by " .. needer++@(no-package-versions: pkg) describe-error :=+ "weird: package '" .. pkg .. "' has no versions"++@(no-versions-of: pkg satisfy: check) describe-error :=+ "no versions of '" .. pkg .. "' satisfy version constraint " .. check show++@(incompatible-version-loaded: pkg needed: check) describe-error :=+ "package '" .. pkg .. "' with version constraint " .. check show .. " required, but an incompatible version has already been loaded"
+ prelude/exception.atomo view
@@ -0,0 +1,26 @@+macro action handle: (branches: Block) :=+ { handlers = branches contents map:+ { `(~c -> ~e) | `(~c -> escape-handle yield: ~e)+ }++ `({ 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) :=+ { cc |+ action bind: {+ Error -> { e | cc yield: (recover call: [e]) }+ }+ } call/cc++macro a catch: (b: Block) ensuring: (c: Block) :=+ `({ ~a catch: ~b } ensuring: ~c)++(action: Block) ensuring: (cleanup: Block) :=+ action after: cleanup++v ensuring: p do: b :=+ { b call: [v] } ensuring: { p call: [v] }
prelude/list.atomo view
@@ -1,3 +1,5 @@+@empty-list describe-error := "list is empty"+ (l: List) each: (b: Block) := { l map: b in-context l
prelude/numeric.atomo view
@@ -1,3 +1,8 @@+macro x += y := `(match: ~(x as: Pattern) on: (~x + ~y))+macro x -= y := `(match: ~(x as: Pattern) on: (~x - ~y))++- (n: Number) := -1 * n+ (n: Integer) even? := 2 divides?: n (n: Integer) odd? := n even? not
prelude/parameter.atomo view
@@ -2,12 +2,14 @@ Parameter = Object clone Parameter new: v := Parameter clone do:- { set-default: v+ { default = v } -context define: (name: Particle) as: root :=- name define-on: [context] as: (Parameter new: root)+(p: Parameter) value: _ := p default +macro define: (x: Dispatch) as: root :=+ `(match: ~(x as: Pattern) on: (Parameter new: ~root))+ (p: Parameter) show := "<" .. p _? show .. ">" @@ -17,7 +19,7 @@ (p) value: (self) = v (p: Parameter) set-default: v :=- (p) value: _ = v+ (p) default = v with: (p: Parameter) as: new do: (action: Block) := { old = p _?@@ -25,14 +27,29 @@ } call with-default: (p: Parameter) as: new do: (action: Block) :=- { old = p _?- action before: { p set-default: new } after: { p set-default: old }+ { old-default = p default+ old = p _?+ action before: { p set-default: new; p =! new } after: {+ p set-default: old-default+ p =! old+ } } call -with: [] do: (action: Block) := action call-with: (b . bs) do: (action: Block) :=- with: b from as: b to do: { with: bs do: action }+macro with: (bs: List) do: action :=+ bs contents+ (reduce-right:+ { `(~a -> ~b) x |+ `{ with: ~a as: ~b do: ~x }+ } with: action)+ contents head -with-defaults: [] do: (action: Block) := action call-with-defaults: (b . bs) do: (action: Block) :=- with-default: b from as: b to do: { with: bs do: action }+macro with-defaults: (bs: List) do: action :=+ bs contents+ (reduce-right:+ { `(~a -> ~b) x |+ `{ with-default: ~a as: ~b do: ~x }+ } with: action)+ contents head++macro modify: param as: change do: action :=+ `(with: ~param as: (~change call: [~param _?]) do: ~action)
prelude/ports.atomo view
@@ -1,17 +1,50 @@-current-output-port = Parameter new: Port standard-output-current-input-port = Parameter new: Port standard-input+*history-file* = Parameter new: (Directory home </> ".atomo_history")+*output-port* = Parameter new: Port standard-output+*input-port* = Parameter new: Port standard-input -(x: Object) print := current-output-port _? print: x-(x: Object) display := current-output-port _? display: x+(x: Object) print := *output-port* _? print: x+(x: Object) display := *output-port* _? display: x -read := current-input-port _? read-read-line := current-input-port _? read-line-read-char := current-input-port _? read-char+read := *input-port* _? read+read-line := *input-port* _? read-line+read-char := *input-port* _? read-char -contents := current-input-port _? contents-ready? := current-input-port _? ready?-eof? := current-input-port _? eof?+contents := *input-port* _? contents+ready? := *input-port* _? ready?+eof? := *input-port* _? eof? ++String-Port = Port clone++String-Port show := "<port {string}>"++String-Port new := String-Port new: ""+String-Port new: (c: String) :=+ String-Port clone do: { contents = c }++(b: String-Port) print: x :=+ { b display: ((x as: String) .. "\n")+ x+ } call++(b: String-Port) display: x :=+ { b contents = b contents .. (x as: String)+ x+ } call++(b: String-Port) read-line :=+ { b contents take-while: @(/= $\n) } after: {+ b contents = b contents (drop-while: @(/= $\n)) tail+ }++(b: String-Port) read-char :=+ { b contents head } after: { b contents = b contents tail }++(b: String-Port) eof? := b contents empty?++(b: String-Port) ready? := b contents empty? not++ with-output-to: (fn: String) do: b := { Port (new: fn mode: @write) } wrap: @close do: { file |@@ -19,7 +52,7 @@ } with-output-to: (p: Port) do: b :=- with: current-output-port as: p do: b+ with: *output-port* as: p do: b with-input-from: (fn: String) do: (b: Block) := { Port (new: fn mode: @read) } wrap: @close do:@@ -28,7 +61,7 @@ } with-input-from: (p: Port) do: (b: Block) :=- with: current-input-port as: p do: b+ with: *input-port* as: p do: b with-all-output-to: (fn: String) do: b :=@@ -38,7 +71,7 @@ } with-all-output-to: (p: Port) do: b :=- with-default: current-output-port as: p do: b+ with-default: *output-port* as: p do: b with-all-input-from: (fn: String) do: (b: Block) := { Port (new: fn mode: @read) } wrap: @close do:@@ -47,4 +80,21 @@ } with-all-input-from: (p: Port) do: (b: Block) :=- with-default: current-input-port as: p do: b+ with-default: *input-port* as: p do: b+++Directory copy: (from: String) to: (to: String) :=+ { Directory create-tree-if-missing: to++ Directory (contents: from) map:+ { c |+ f = from </> c+ t = to </> c++ if: Directory (exists?: f)+ then: { Directory copy: f to: t }+ else: { File copy: f to: t }+ }++ @ok+ } call
+ prelude/repl.atomo view
@@ -0,0 +1,101 @@+{ evaluate-all: [] in: _ := error: @no-expressions+ evaluate-all: [e] in: t := t evaluate: e+ evaluate-all: (e . es) in: t :=+ { t evaluate: e+ evaluate-all: es in: t+ } call++ do-input: (s: String) in: env :=+ s parse-expressions match: {+ [] -> @ok+ es -> (evaluate-all: es in: env) show print+ }++ get-value: t :=+ (interaction: "enter value: ") parse-expressions match: {+ [] -> get-value: t+ es -> evaluate-all: es in: t+ }++ get-n-values: 0 = []+ get-n-values: n :=+ (get-value: Lobby) . (get-n-values: (n - 1))++ repl-debugger =+ Object clone do:+ { run: e :=+ { Restart show-options-for: e++ { basic-repl } bind: {+ @prompt ->+ restart: 'use-prompt with: ["[!]> "]++ @(special: n) ->+ when: (n all?: @digit?) do: {+ r = Restart get: (n as: Integer)+ r jump: (get-n-values: r action arguments length)+ }+ }+ } call+ }++ (env: Object) basic-repl :=+ { prompt =+ { signal: @prompt; "> " } with-restarts: {+ use-prompt -> { p | p }+ }++ in =+ { interaction: prompt } handle: {+ @end-of-input -> { signal: @quit; "" } call+ @interrupt -> { signal: @quit; "" } call+ }++ in match: {+ $: . name ->+ signal: @(special: name)++ source ->+ { try :=+ { do-input: source in: env } with-restarts: {+ retry -> try+ abort -> @ok+ }++ try+ } call+ }++ signal: @loop+ } repeat++ (env: Object) repl :=+ { stop |+ with: *debugger* as: repl-debugger do: {+ frame = 0++ { env basic-repl } bind: {+ @prompt ->+ restart: 'use-prompt with: ["[" .. frame show .. "]> "]++ @loop -> (super frame = frame + 1)++ @(special: "h") ->+ ":h\thelp" print++ @quit ->+ { ask :=+ { "really quit? (y/n) " display+ { read-char } (after: { "" print }) match: {+ $y -> stop yield+ $n -> @ok+ _ -> ask+ }+ } call++ ask+ } call+ }+ }+ } call/cc+} call
+ prelude/string.atomo view
@@ -0,0 +1,27 @@+{ @empty-string describe-error := "string is empty"++ (s: String) indent: (n: Integer) :=+ s lines (map: { l | $ (repeat: n) .. l }) (join: "\n")++ (s: String) word-wrap: (length: Integer) :=+ s lines+ (map: { l | (l take-while: @space?) .. (wrap-line: l to: length) })+ unlines++ wrap-line: l to: length :=+ { words = l words++ line-length = 0++ ok-words =+ words take-while:+ { w |+ line-length = line-length + 1 + w length+ line-length < length+ } in-context++ [ ok-words unwords+ words (drop: ok-words length) unwords word-wrap: length+ ] unlines strip-end+ } call+} call
prelude/version.atomo view
@@ -19,7 +19,7 @@ v major show .. "." .. v minor (as: String) (s: String) as: Version :=- s (split-on: '.') (map: @(as: Integer)) reduce-right: @.+ s (split-on: $.) (map: @(as: Integer)) reduce-right: @. (n: Integer) as: Version := n . 0
src/Atomo.hs view
@@ -6,7 +6,6 @@ , module Control.Concurrent , module Control.Monad , module Control.Monad.Cont- , module Control.Monad.Error , module Control.Monad.State , module Control.Monad.Trans ) where@@ -14,7 +13,6 @@ import Control.Concurrent import Control.Monad import "monads-fd" Control.Monad.Cont (MonadCont(..), ContT(..))-import "monads-fd" Control.Monad.Error (MonadError(..), ErrorT(..)) import "monads-fd" Control.Monad.State (MonadState(..), StateT(..), evalStateT, gets, modify) import "monads-fd" Control.Monad.Trans
src/Atomo/Environment.hs view
@@ -2,8 +2,9 @@ module Atomo.Environment where import "monads-fd" Control.Monad.Cont-import "monads-fd" Control.Monad.Error import "monads-fd" Control.Monad.State+import Data.Char (isUpper)+import Data.Dynamic import Data.IORef import Data.List (nub) import Data.Maybe (isJust)@@ -17,143 +18,140 @@ -- | evaluation eval :: Expr -> VM Value-eval e = eval' e `catchError` pushStack- where- pushStack err = do- modify $ \s -> s { stack = e : stack s }- throwError err-- eval' (Define { ePattern = p, eExpr = ev }) = do- define p ev- return (particle "ok")- eval' (Set { ePattern = p@(PSingle {}), eExpr = ev }) = do- v <- eval ev- define p (Primitive (eLocation ev) v)- return v- eval' (Set { ePattern = p@(PKeyword {}), eExpr = ev }) = do- v <- eval ev- define p (Primitive (eLocation ev) v)- return v- eval' (Set { ePattern = p, eExpr = ev }) = do- v <- eval ev- set p v- eval' (Dispatch- { eMessage = ESingle- { emID = i- , emName = n- , emTarget = t- }- }) = do- v <- eval t- dispatch (Single i n v)- eval' (Dispatch- { eMessage = EKeyword- { emID = i- , emNames = ns- , emTargets = ts- }- }) = do- vs <- mapM eval ts- dispatch (Keyword i ns vs)- eval' (Operator { eNames = ns, eAssoc = a, ePrec = p }) = do- forM_ ns $ \n -> modify $ \s ->- s- { parserState =- (parserState s)- { psOperators =- (n, (a, p)) : psOperators (parserState s)- }- }+eval (Define { ePattern = p, eExpr = ev }) = do+ define p ev+ return (particle "ok")+eval (Set { ePattern = p@(PSingle {}), eExpr = ev }) = do+ v <- eval ev+ define p (Primitive (eLocation ev) v)+ return v+eval (Set { ePattern = p@(PKeyword {}), eExpr = ev }) = do+ v <- eval ev+ define p (Primitive (eLocation ev) v)+ return v+eval (Set { ePattern = p, eExpr = ev }) = do+ v <- eval ev+ set p v+eval (Dispatch+ { eMessage = ESingle+ { emID = i+ , emName = n+ , emTarget = t+ }+ }) = do+ v <- eval t+ dispatch (Single i n v)+eval (Dispatch+ { eMessage = EKeyword+ { emID = i+ , emNames = ns+ , emTargets = ts+ }+ }) = do+ vs <- mapM eval ts+ dispatch (Keyword i ns vs)+eval (Operator { eNames = ns, eAssoc = a, ePrec = p }) = do+ forM_ ns $ \n -> modify $ \s ->+ s+ { parserState =+ (parserState s)+ { psOperators =+ (n, (a, p)) : psOperators (parserState s)+ }+ } - return (particle "ok")- eval' (Primitive { 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' (EMacro { ePattern = p, eExpr = e' }) = do- ps <- gets parserState- modify $ \s -> s- { parserState = ps- { psMacros =- case p of- PSingle {} ->- (addMethod (Macro p e') (fst (psMacros ps)), snd (psMacros ps))+ return (particle "ok")+eval (Primitive { 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 (EMacro { ePattern = p, eExpr = e }) = do+ ps <- gets parserState+ modify $ \s -> s+ { parserState = ps+ { psMacros =+ case p of+ PSingle {} ->+ (addMethod (Macro p e) (fst (psMacros ps)), snd (psMacros ps)) - PKeyword {} ->- (fst (psMacros ps), addMethod (Macro p e') (snd (psMacros ps)))+ PKeyword {} ->+ (fst (psMacros ps), addMethod (Macro p e) (snd (psMacros ps))) - _ -> error $ "impossible: eval EMacro: p is " ++ show p- }+ _ -> error $ "impossible: eval EMacro: p is " ++ show p }+ } - return (particle "ok")- eval' (EParticle { eParticle = EPMSingle n }) =- return (Particle $ PMSingle n)- eval' (EParticle { eParticle = EPMKeyword ns mes }) = do- mvs <- forM mes $- maybe (return Nothing) (liftM Just . eval)- return (Particle $ PMKeyword ns mvs)- eval' (ETop {}) = gets top- eval' (EVM { eAction = x }) = x- eval' (EUnquote { eExpr = e' }) = raise ["out-of-quote"] [Expression e']- eval' (EQuote { eExpr = qe }) = do- unquoted <- unquote 0 qe- return (Expression unquoted)- where- unquote :: Int -> Expr -> VM Expr- unquote 0 (EUnquote { eExpr = e' }) = do- r <- eval e'- case r of- Expression e'' -> return e''- _ -> return (Primitive Nothing r)- unquote n u@(EUnquote { eExpr = e' }) = do- ne <- unquote (n - 1) e'- return (u { eExpr = ne })- unquote n d@(Define { eExpr = e' }) = do- ne <- unquote n e'- return (d { eExpr = ne })- unquote n s@(Set { eExpr = e' }) = do- ne <- unquote n e'- return (s { eExpr = ne })- unquote n d@(Dispatch { eMessage = em }) =- case em of- EKeyword { emTargets = ts } -> do- nts <- mapM (unquote n) ts- return d { eMessage = em { emTargets = nts } }+ return (particle "ok")+eval (EParticle { eParticle = EPMSingle n }) =+ return (Particle $ PMSingle n)+eval (EParticle { eParticle = EPMKeyword ns mes }) = do+ mvs <- forM mes $+ maybe (return Nothing) (liftM Just . eval)+ return (Particle $ PMKeyword ns mvs)+eval (ETop {}) = gets top+eval (EVM { eAction = x }) = x+eval (EUnquote { eExpr = e }) = raise ["out-of-quote"] [Expression e]+eval (EQuote { eExpr = qe }) = do+ unquoted <- unquote 0 qe+ return (Expression unquoted)+ where+ unquote :: Int -> Expr -> VM Expr+ unquote 0 (EUnquote { eExpr = e }) = do+ r <- eval e+ case r of+ Expression e' -> return e'+ _ -> return (Primitive Nothing r)+ unquote n u@(EUnquote { eExpr = e }) = do+ ne <- unquote (n - 1) e+ return (u { eExpr = ne })+ unquote n d@(Define { eExpr = e }) = do+ ne <- unquote n e+ return (d { eExpr = ne })+ unquote n s@(Set { eExpr = e }) = do+ ne <- unquote n e+ return (s { eExpr = ne })+ unquote n d@(Dispatch { eMessage = em }) =+ case em of+ EKeyword { emTargets = ts } -> do+ nts <- mapM (unquote n) ts+ return d { eMessage = em { emTargets = nts } } - ESingle { emTarget = t } -> do- nt <- unquote n t- return d { eMessage = em { emTarget = nt } }- unquote n b@(EBlock { eContents = es }) = do- nes <- mapM (unquote n) es- return b { eContents = nes }- unquote n l@(EList { eContents = es }) = do- nes <- mapM (unquote n) es- return l { 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- EPMKeyword ns mes -> do- nmes <- forM mes $ \me ->- case me of- Nothing -> return Nothing- Just e' -> liftM Just (unquote n e')+ ESingle { emTarget = t } -> do+ nt <- unquote n t+ return d { eMessage = em { emTarget = nt } }+ unquote n b@(EBlock { eContents = es }) = do+ nes <- mapM (unquote n) es+ return b { eContents = nes }+ unquote n l@(EList { eContents = es }) = do+ nes <- mapM (unquote n) es+ return l { 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+ EPMKeyword ns mes -> do+ nmes <- forM mes $ \me ->+ case me of+ Nothing -> return Nothing+ Just e -> liftM Just (unquote n e) - return p { eParticle = EPMKeyword ns nmes }+ return p { eParticle = EPMKeyword ns nmes } - _ -> return p- unquote n q@(EQuote { eExpr = e' }) = do- ne <- unquote (n + 1) e'- return q { eExpr = ne }- unquote _ p@(Primitive {}) = return p- unquote _ t@(ETop {}) = return t- unquote _ v@(EVM {}) = return v- unquote _ o@(Operator {}) = return o+ _ -> return p+ unquote n q@(EQuote { eExpr = e }) = do+ ne <- unquote (n + 1) e+ return q { eExpr = ne }+ unquote n p@(Primitive { eValue = Expression e }) = do+ ne <- unquote n e+ return p { eValue = Expression ne }+ unquote _ p@(Primitive {}) = return p+ unquote _ t@(ETop {}) = return t+ unquote _ v@(EVM {}) = return v+ unquote _ o@(Operator {}) = return o -- | evaluating multiple expressions, returning the last result evalAll :: [Expr] -> VM Value@@ -175,9 +173,7 @@ o <- gets top modify (\e -> e { top = t }) - res <- catchError x $ \err -> do- modify (\e -> e { top = o })- throwError err+ res <- x modify (\e -> e { top = o }) @@ -188,60 +184,56 @@ -- Define ------------------------------------------------------------------- ----------------------------------------------------------------------------- +defineOn :: Value -> Method -> VM ()+defineOn v m' = do+ o <- orefFor v+ obj <- liftIO (readIORef o)++ let (oss, oks) = oMethods obj+ ms (PSingle {}) = (addMethod m oss, oks)+ ms (PKeyword {}) = (oss, addMethod m oks)+ ms x = error $ "impossible: defining with pattern " ++ show x++ liftIO . writeIORef o $+ obj { oMethods = ms (mPattern m) }+ where+ m = m' { mPattern = setSelf v (mPattern m') }+ -- | define a pattern to evaluate an expression define :: Pattern -> Expr -> VM () define !p !e = do is <- gets primitives- newp <- methodPattern p+ newp <- matchable p+ m <- method newp e os <- case p of PKeyword { ppTargets = (t:_) } | isTop t -> targets is (head (ppTargets newp))- _ -> targets is newp - m <- method newp e- forM_ os $ \o -> do- obj <- liftIO (readIORef o)-- let (oss, oks) = oMethods obj- ms (PSingle {}) = (addMethod (m o) oss, oks)- ms (PKeyword {}) = (oss, addMethod (m o) oks)- ms x = error $ "impossible: defining with pattern " ++ show x+ _ -> targets is newp - liftIO . writeIORef o $- obj { oMethods = ms newp }+ forM_ os $ \o ->+ defineOn (Reference o) m where isTop PThis = True isTop (PObject ETop {}) = True isTop _ = False - method p' (Primitive _ v) = return (\o -> Slot (setSelf o p') v)- method p' e' = gets top >>= \t ->- return (\o -> Responder (setSelf o p') t e')+ method p' (Primitive _ v) = return (Slot p' v)+ method p' e' = gets top >>= \t -> return (Responder p' t e') - methodPattern p'@(PSingle { ppTarget = t }) = do- t' <- methodPattern t- return p' { ppTarget = t' }- methodPattern p'@(PKeyword { ppTargets = ts }) = do- ts' <- mapM methodPattern ts- return p' { ppTargets = ts' }- methodPattern PThis = liftM PMatch (gets top)- methodPattern (PObject oe) = liftM PMatch (eval oe)- methodPattern (PNamed n p') = liftM (PNamed n) (methodPattern p')- methodPattern p' = return p' - -- | Swap out a reference match with PThis, for inserting on the object- setSelf :: ORef -> Pattern -> Pattern- setSelf o (PKeyword i ns ps) =- PKeyword i ns (map (setSelf o) ps)- setSelf o (PMatch (Reference x))- | o == x = PThis- setSelf o (PNamed n p') =- PNamed n (setSelf o p')- setSelf o (PSingle i n t) =- PSingle i n (setSelf o t)- setSelf _ p' = p'+-- | Swap out a reference match with PThis, for inserting on the object+setSelf :: Value -> Pattern -> Pattern+setSelf v (PKeyword i ns ps) =+ PKeyword i ns (map (setSelf v) ps)+setSelf v (PMatch x) | v == x = PThis+setSelf v (PNamed n p') =+ PNamed n (setSelf v p')+setSelf v (PSingle i n t) =+ PSingle i n (setSelf v t)+setSelf _ p' = p' set :: Pattern -> Value -> VM Value@@ -249,15 +241,30 @@ is <- gets primitives if match is p v then do- forM_ (bindings' p v) $ \(p', v') -> do+ forM_ (bindings' p v) $ \(p', v') -> define p' (Primitive Nothing v') return v else throwError (Mismatch p v) ++-- | turn any PObject patterns into PMatches+matchable :: Pattern -> VM Pattern+matchable p'@(PSingle { ppTarget = t }) = do+ t' <- matchable t+ return p' { ppTarget = t' }+matchable p'@(PKeyword { ppTargets = ts }) = do+ ts' <- mapM matchable ts+ return p' { ppTargets = ts' }+matchable PThis = liftM PMatch (gets top)+matchable (PObject oe) = liftM PMatch (eval oe)+matchable (PNamed n p') = liftM (PNamed n) (matchable p')+matchable p' = return p'++ -- | find the target objects for a pattern targets :: IDs -> Pattern -> VM [ORef]-targets _ (PMatch v) = orefFor v >>= return . (: [])+targets _ (PMatch v) = liftM (: []) (orefFor v) targets is (PSingle _ _ p) = targets is p targets is (PKeyword _ _ ps) = do ts <- mapM (targets is) ps@@ -272,6 +279,7 @@ then return [idList is, idString is] else return [idList is] targets is (PPMKeyword {}) = return [idParticle is]+targets is (PExpr _) = return [idExpression is] targets _ p = error $ "no targets for " ++ show p @@ -283,18 +291,16 @@ -- | dispatch a message and return a value dispatch :: Message -> VM Value dispatch !m = do- find <- findFirstMethod m vs+ find <- findFirstMethod m (vs m) case find of Just method -> runMethod method m Nothing ->- case vs of+ case vs m of [v] -> sendDNU v- _ -> sendDNUs vs 0+ _ -> sendDNUs (vs m) 0 where- vs =- case m of- Single { mTarget = t } -> [t]- Keyword { mTargets = ts } -> ts+ vs (Single { mTarget = t }) = [t]+ vs (Keyword { mTargets = ts }) = ts sendDNU v = do find <- findMethod v (dnuSingle v)@@ -360,12 +366,11 @@ refMatch ids (idMatch ids) y match ids PThis y = match ids (PMatch (Reference (idMatch ids))) (Reference (orefFrom ids y))+match _ (PMatch x) y | x == y = True match ids (PMatch x) (Reference y) =- refMatch ids (orefFrom ids x) y+ delegatesMatch ids (PMatch x) y match ids (PMatch (Reference x)) y = match ids (PMatch (Reference x)) (Reference (orefFrom ids y))-match _ (PMatch x) y =- x == y match ids (PSingle { ppTarget = p }) (Message (Single { mTarget = t })) =@@ -398,21 +403,57 @@ match _ PETop (Expression (ETop {})) = True match _ PEQuote (Expression (EQuote {})) = True match _ PEUnquote (Expression (EUnquote {})) = True+match _ (PExpr a) (Expression b) = matchExpr 0 a b+match ids p (Reference y) = delegatesMatch ids p y match _ _ _ = False refMatch :: IDs -> ORef -> ORef -> Bool-refMatch ids x y = x == y || delegatesMatch- where- delegatesMatch = any- (match ids (PMatch (Reference x)))- (oDelegates (unsafePerformIO (readIORef y)))+refMatch ids x y = x == y || delegatesMatch ids (PMatch (Reference x)) y +delegatesMatch :: IDs -> Pattern -> ORef -> Bool+delegatesMatch ids p x =+ any (match ids p) (oDelegates (unsafePerformIO (readIORef x)))+ -- | match multiple patterns with multiple values matchAll :: IDs -> [Pattern] -> [Value] -> Bool matchAll _ [] [] = True matchAll ids (p:ps) (v:vs) = match ids p v && matchAll ids ps vs matchAll _ _ _ = False +matchEParticle :: Int -> [Maybe Expr] -> [Maybe Expr] -> Bool+matchEParticle _ [] [] = True+matchEParticle n (Just a:as) (Just b:bs) =+ matchExpr n a b && matchEParticle n as bs+matchEParticle n (Nothing:as) (Nothing:bs) = matchEParticle n as bs+matchEParticle _ _ _ = False++matchExpr :: Int -> Expr -> Expr -> Bool+matchExpr 0 (EUnquote {}) _ = True+matchExpr n (EUnquote { eExpr = a }) (EUnquote { eExpr = b }) =+ matchExpr (n - 1) a b+matchExpr n (Define { ePattern = ap', eExpr = a }) (Define { ePattern = bp, eExpr = b }) =+ ap' == bp && matchExpr n a b+matchExpr n (Set { ePattern = ap', eExpr = a }) (Set { ePattern = bp, eExpr = b }) =+ ap' == bp && matchExpr n a b+matchExpr n (Dispatch { eMessage = am@(EKeyword {}) }) (Dispatch { eMessage = bm@(EKeyword {}) }) =+ emID am == emID bm && length (emTargets am) == length (emTargets bm) && and (zipWith (matchExpr n) (emTargets am) (emTargets bm))+matchExpr n (Dispatch { eMessage = am@(ESingle {}) }) (Dispatch { eMessage = bm@(ESingle {}) }) =+ emID am == emID bm && matchExpr n (emTarget am) (emTarget 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 (EMacro { ePattern = ap', eExpr = a }) (EMacro { ePattern = bp, eExpr = b }) =+ ap' == bp && matchExpr n a b+matchExpr n (EParticle { eParticle = ap' }) (EParticle { eParticle = bp }) =+ case (ap', bp) of+ (EPMKeyword ans ames, EPMKeyword bns bmes) ->+ ans == bns && matchEParticle n ames bmes+ _ -> ap' == bp+matchExpr n (EQuote { eExpr = a }) (EQuote { eExpr = b }) =+ matchExpr (n + 1) a b+matchExpr _ a b = a == b+ matchParticle :: IDs -> [Pattern] -> [Maybe Value] -> Bool matchParticle _ [] [] = True matchParticle ids (PAny:ps) (Nothing:mvs) = matchParticle ids ps mvs@@ -426,12 +467,10 @@ runMethod :: Method -> Message -> VM Value runMethod (Slot { mValue = v }) _ = return v runMethod (Responder { mPattern = p, mContext = c, mExpr = e }) m = do- t <- gets top- nt <- newObject $ \o -> o { oDelegates = [c] , oMethods =- ( insertMap (Slot (psingle "sender" PThis) t) $ bindings p m+ ( bindings p m , emptyMap ) }@@ -467,8 +506,8 @@ -- | given a pattern and avalue, return the bindings as a list of pairs bindings' :: Pattern -> Value -> [(Pattern, Value)] bindings' (PNamed n p) v = (psingle n PThis, v) : bindings' p v-bindings' (PPMKeyword _ ps) (Particle (PMKeyword _ mvs)) = concat- $ map (\(p, Just v) -> bindings' p v)+bindings' (PPMKeyword _ ps) (Particle (PMKeyword _ mvs)) =+ concatMap (\(p, Just v) -> bindings' p v) $ filter (isJust . snd) $ zip ps mvs bindings' (PList ps) (List vs) = concat (zipWith bindings' ps (V.toList vs))@@ -479,10 +518,43 @@ 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' (PExpr a) (Expression b) = exprBindings 0 a b+bindings' p (Reference r) =+ concatMap (bindings' p) $ oDelegates (unsafePerformIO (readIORef r)) bindings' _ _ = [] +exprBindings :: Int -> Expr -> Expr -> [(Pattern, Value)]+exprBindings 0 (EUnquote { eExpr = Dispatch { eMessage = ESingle { emName = n } } }) e =+ [(psingle 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 a b+exprBindings n (Set { eExpr = a }) (Set { eExpr = b }) =+ exprBindings n a b+exprBindings n (Dispatch { eMessage = am@(EKeyword {}) }) (Dispatch { eMessage = bm@(EKeyword {}) }) =+ concat $ zipWith (exprBindings n) (emTargets am) (emTargets bm)+exprBindings n (Dispatch { eMessage = am@(ESingle {}) }) (Dispatch { eMessage = bm@(ESingle {}) }) =+ exprBindings n (emTarget am) (emTarget 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 (EMacro { eExpr = a }) (EMacro { eExpr = b }) =+ exprBindings n a b+exprBindings n (EParticle { eParticle = ap' }) (EParticle { eParticle = bp }) =+ case (ap', bp) of+ (EPMKeyword _ ames, EPMKeyword _ bmes) ->+ concatMap (\(Just a, Just b) -> exprBindings n a b)+ $ filter (isJust . fst)+ $ zip ames bmes+ _ -> []+exprBindings n (EQuote { eExpr = a }) (EQuote { eExpr = b }) =+ exprBindings (n + 1) a b+exprBindings _ _ _ = [] + ----------------------------------------------------------------------------- -- Helpers ------------------------------------------------------------------ -----------------------------------------------------------------------------@@ -491,7 +563,7 @@ -- | define a method as an action returning a value (=:) :: Pattern -> VM Value -> VM ()-pat =: vm = define pat (EVM Nothing vm)+pat =: vm = define pat (EVM Nothing Nothing vm) -- | define a slot to a given value (=::) :: Pattern -> Value -> VM ()@@ -624,7 +696,7 @@ >>= \(List v) -> return v here :: String -> VM Value-here n = gets top >>= dispatch . (single n)+here n = gets top >>= dispatch . single n ifVM :: VM Value -> VM a -> VM a -> VM a ifVM c a b = do@@ -649,7 +721,7 @@ checkArgs is ps vs doBlock (toMethods . concat $ zipWith bindings' ps vs) s es where- checkArgs _ [] _ = return ()+ checkArgs _ [] _ = return (particle "ok") checkArgs _ _ [] = throwError (BlockArity (length ps) (length vs)) checkArgs is (p:ps') (v:vs') | match is p v = checkArgs is ps' vs'@@ -727,3 +799,61 @@ then return True else isA' ds +raise :: [String] -> [Value] -> VM a+{-# INLINE raise #-}+raise ns vs = throwError . Error $ keyParticleN ns vs++raise' :: String -> VM a+{-# INLINE raise' #-}+raise' = throwError . Error . particle++fromHaskell :: Typeable a => String -> Value -> VM a+fromHaskell t (Haskell d) =+ case fromDynamic d of+ Just a -> return a+ Nothing -> raise ["dynamic-needed"] [string t]+fromHaskell t _ = raise ["dynamic-needed"] [string t]++throwError :: AtomoError -> VM a+throwError e = gets top >>= \t ->+ ifVM (dispatch (keyword ["responds-to?"] [t, particle "Error"]))+ (dispatch (msg t) >> error ("panic: error returned normally for: " ++ show e))+ (error ("panic: " ++ show e))+ where+ msg t = keyword ["error"] [t, asValue e]++-- convert an expression to the pattern match it represents+toPattern :: Expr -> VM Pattern+toPattern (Dispatch { eMessage = EKeyword { emNames = ["."], emTargets = [h, t] } }) = do+ hp <- toPattern h+ tp <- toPattern t+ return (PHeadTail hp tp)+toPattern (Dispatch { eMessage = EKeyword { emNames = [n], emTargets = [ETop {}, x] } }) = do+ p <- toPattern x+ return (PNamed n p)+toPattern (Dispatch { eMessage = EKeyword { emNames = ns, emTargets = ts } }) = do+ ps <- mapM toPattern ts+ return (pkeyword ns ps)+toPattern (Dispatch { eMessage = ESingle { emName = "_" } }) =+ return PAny+toPattern d@(Dispatch { eMessage = ESingle { emTarget = ETop {}, emName = n } })+ | isUpper (head n) = return (PObject d)+ | otherwise = return (PNamed n PAny)+toPattern (Dispatch { eMessage = ESingle { emTarget = d@(Dispatch {}), emName = n } }) =+ return (psingle n (PObject d))+toPattern (EList { eContents = es }) = do+ ps <- mapM toPattern es+ return (PList ps)+toPattern (EParticle { eParticle = EPMSingle n }) =+ return (PMatch (Particle (PMSingle n)))+toPattern (EParticle { eParticle = EPMKeyword ns mes }) = do+ ps <- forM mes $ \me ->+ case me of+ Nothing -> return PAny+ Just e -> toPattern e++ return (PPMKeyword ns ps)+toPattern (EQuote { eExpr = e }) = return (PExpr e)+toPattern (Primitive { eValue = v }) =+ return (PMatch v)+toPattern e = raise ["unknown-pattern"] [Expression e]
src/Atomo/Kernel.hs view
@@ -23,14 +23,12 @@ import qualified Atomo.Kernel.Pattern as Pattern import qualified Atomo.Kernel.Ports as Ports import qualified Atomo.Kernel.Time as Time-import qualified Atomo.Kernel.Exception as Exception import qualified Atomo.Kernel.Environment as Environment import qualified Atomo.Kernel.Continuation as Continuation+import qualified Atomo.Kernel.Char as Char load :: VM () load = do- [$p|this|] =::: [$e|sender|]- [$p|(x: Object) clone|] =: do x <- here "x" newObject $ \o -> o@@ -56,18 +54,26 @@ [$p|(x: Object) delegates-to?: (y: Object)|] =: do x <- here "x" y <- here "y"- fmap Boolean (delegatesTo x y)+ liftM Boolean (delegatesTo x y) [$p|(x: Object) delegates|] =: do o <- here "x" >>= objectFor return $ list (oDelegates o) + [$p|(x: Object) with-delegates: (ds: List)|] =: do+ ds <- getList [$e|ds|]+ x <- here "x" >>= objectFor+ newObject $ \o -> o+ { oMethods = oMethods x+ , oDelegates = ds+ }+ [$p|(x: Object) super|] =::: [$e|x delegates head|] [$p|(x: Object) is-a?: (y: Object)|] =: do x <- here "x" y <- here "y"- fmap Boolean (isA x y)+ liftM Boolean (isA x y) [$p|(x: Object) responds-to?: (p: Particle)|] =: do x <- here "x"@@ -78,7 +84,7 @@ PMKeyword ns mvs -> keyword ns (completeKP mvs [x]) PMSingle n -> single n x - fmap (Boolean . isJust) $ findMethod x completed+ liftM (Boolean . isJust) $ findMethod x completed [$p|(o: Object) methods|] =: do o <- here "o" >>= objectFor@@ -89,6 +95,13 @@ [$p|ms keywords|] =:: list (map (list . map Method) (elemsMap ks)) here "ms" + [$p|(x: Object) dump|] =: do+ o <- here "x"+ liftIO (print o)+ return o++ [$p|(x: Object) describe-error|] =::: [$e|x as: String|]+ [$p|(s: String) as: String|] =::: [$e|s|] [$p|(x: Object) as: String|] =::: [$e|x show|]@@ -164,16 +177,16 @@ Pattern.load Ports.load Time.load- Exception.load Environment.load Continuation.load+ Char.load joinWith :: Value -> Value -> [Value] -> VM Value joinWith t (Block s ps bes) as | length ps > length as = throwError (BlockArity (length ps) (length as))- | null as || null ps = do+ | null as || null ps = case t of Reference r -> do Object ds ms <- objectFor t
src/Atomo/Kernel/Block.hs view
@@ -7,17 +7,15 @@ load :: VM () load = do- [$p|Block new: (l: List)|] =:::- [$e|Block new: l in: sender|]+ [$p|Block new: (es: List) in: t|] =:::+ [$e|Block new: es arguments: [] in: t|] - [$p|Block new: (l: List) in: t|] =: do+ [$p|Block new: (es: List) arguments: (as: List) in: t|] =: do t <- here "t"- es <- getList [$e|l|]-- let toExpr (Expression e') = e'- toExpr v = Primitive Nothing v+ es <- getList [$e|es|]+ as <- getList [$e|as|] - return (Block t [] (map toExpr es))+ return (Block t (map fromPattern as) (map fromExpression es)) [$p|(b: Block) call|] =: do b <- here "b" >>= findBlock
+ src/Atomo/Kernel/Char.hs view
@@ -0,0 +1,79 @@+{-# 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"
src/Atomo/Kernel/Comparable.hs view
@@ -8,7 +8,7 @@ load :: VM () load = do- mapM_ eval $+ mapM_ eval [ [$e|operator 4 ==, /=, <, <=, >=, >|] , [$e|operator right 3 &&|] , [$e|operator right 2 |||]
src/Atomo/Kernel/Concurrency.hs view
@@ -13,14 +13,11 @@ tid <- liftIO myThreadId return (Process chan tid) - [$p|receive|] =: do- chan <- gets channel- v <- liftIO (readChan chan)- return v+ [$p|receive|] =: gets channel >>= liftIO . readChan [$p|halt|] =: gets halt >>= liftIO >> return (particle "ok") - [$p|(p: Process) ! v|] =: do+ [$p|(p: Process) <- v|] =: do Process chan _ <- here "p" >>= findProcess v <- here "v" liftIO (writeChan chan v)
src/Atomo/Kernel/Environment.hs view
@@ -11,14 +11,14 @@ ([$p|Environment|] =::) =<< eval [$e|Object clone|] [$p|Environment arguments|] =:- liftIO getArgs >>= return . list . map string+ liftM (list . map string) (liftIO getArgs) [$p|Environment program-name|] =: liftM string $ liftIO getProgName [$p|Environment get: (name: String)|] =: getString [$e|name|]- >>= liftM string . (liftIO . getEnv)+ >>= liftM string . liftIO . getEnv [$p|Environment all|] =: do env <- liftIO getEnvironment
− src/Atomo/Kernel/Exception.hs
@@ -1,86 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-module Atomo.Kernel.Exception (load) where--import Atomo---load :: VM ()-load = do- [$p|raise: v|] =: do- v <- here "v"- throwError (Error v)-- [$p|(action: Block) catch: (recover: Block)|] =:- catchError (eval [$e|action call|]) $ \err -> do- modify $ \s -> s { stack = [] }-- recover <- here "recover"- dispatch (keyword ["call"] [recover, list [asValue err]])-- [$p|(action: Block) catch: (recover: Block) ensuring: (cleanup: Block)|] =:- catchError- (do r <- eval [$e|action call|]- eval [$e|cleanup call|]- return r) $ \err -> do- modify $ \s -> s { stack = [] }-- recover <- here "recover"-- res <- dispatch (keyword ["call"] [recover, list [asValue err]])- eval [$e|cleanup call|]- return res-- [$p|(action: Block) handle: (branches: Block)|] =::: [$e|- action catch: { e |- { e match: branches } catch: { e* |- e* match: {- @(no-matches-for: _) -> raise: e- _ -> raise: e*- }- }- }- |]-- [$p|(a: Block) handle: (b: Block) ensuring: (c: Block)|] =::: [$e|- { a handle: b } ensuring: c- |]-- [$p|(action: Block) ensuring: (cleanup: Block)|] =:- catchError- (do r <- eval [$e|action call|]- eval [$e|cleanup call|]- return r)- (\err -> eval [$e|cleanup call|] >> throwError err)-- [$p|v ensuring: p do: b|] =:::- [$e|{ b call: [v] } ensuring: { p call: [v] }|]----asValue :: AtomoError -> Value-asValue (Error v) = v-asValue (ParseError pe) =- keyParticleN ["parse-error"] [string (show pe)]-asValue (DidNotUnderstand m) =- keyParticleN ["did-not-understand"] [Message m]-asValue (Mismatch pat v) =- keyParticleN- ["pattern", "did-not-match"]- [Pattern pat, v]-asValue (ImportError ie) =- keyParticleN ["import-error"] [string (show ie)]-asValue (FileNotFound fn) =- keyParticleN ["file-not-found"] [string fn]-asValue (ParticleArity e' g) =- keyParticleN- ["particle-needed", "given"]- [Integer (fromIntegral e'), Integer (fromIntegral g)]-asValue (BlockArity e' g) =- keyParticleN- ["block-expected", "given"]- [Integer (fromIntegral e'), Integer (fromIntegral g)]-asValue NoExpressions = particle "no-expressions"-asValue (ValueNotFound d v) =- keyParticleN ["could-not-found", "in"] [string d, v]-asValue (DynamicNeeded t) =- keyParticleN ["dynamic-needed"] [string t]
src/Atomo/Kernel/Expression.hs view
@@ -2,18 +2,41 @@ {-# OPTIONS -fno-warn-name-shadowing #-} module Atomo.Kernel.Expression (load) where +import Text.PrettyPrint (Doc)+ import Atomo-import Atomo.Parser (macroExpand, withParser)+import Atomo.Pretty (pretty)+import Atomo.Parser (macroExpand, parseInput, withParser) load :: VM () load = do- [$p|(e: Expression) evaluate|] =:::- [$e|e evaluate-in: sender|]+ [$p|`Block new: (es: List)|] =::: [$e|`Block new: es arguments: []|]+ [$p|`Block new: (es: List) arguments: (as: List)|] =: do+ es <- getList [$e|es|]+ as <- getList [$e|as|]+ return (Expression (EBlock Nothing (map fromPattern as) (map fromExpression es))) - [$p|(e: Expression) evaluate-in: t|] =: do+ [$p|`List new: (es: List)|] =: do+ es <- getList [$e|es|]+ return (Expression (EList Nothing (map fromExpression es)))++ [$p|`Match new: (branches: List) on: (value: Expression)|] =: do+ pats <- liftM (map fromExpression) $ getList [$e|branches map: @from|]+ exprs <- liftM (map fromExpression) $ getList [$e|branches map: @to|]+ Expression value <- here "value" >>= findExpression++ ps <- mapM toPattern pats+ ids <- gets primitives+ return . Expression . EVM Nothing (Just $ prettyMatch value (zip pats exprs)) $+ eval value >>= matchBranches ids (zip ps exprs)++ [$p|(s: String) parse-expressions|] =:+ getString [$e|s|] >>= liftM (list . map Expression) . parseInput++ [$p|top evaluate: (e: Expression)|] =: do+ t <- here "top" Expression e <- here "e" >>= findExpression- t <- here "t" withTop t (eval e) [$p|(e: Expression) expand|] =: do@@ -23,7 +46,11 @@ [$p|(e: Expression) type|] =: do Expression e <- here "e" >>= findExpression case e of- Dispatch {} -> return (particle "dispatch")+ Dispatch { eMessage = EKeyword {} } ->+ return (keyParticleN ["dispatch"] [particle "keyword"])+ Dispatch { eMessage = ESingle {} } ->+ return (keyParticleN ["dispatch"] [particle "single"])+ Define {} -> return (particle "define") Set {} -> return (particle "set") Operator {} -> return (particle "operator")@@ -35,55 +62,76 @@ ETop {} -> return (particle "top") EQuote {} -> return (particle "quote") EUnquote {} -> return (particle "unquote")- EParticle {} -> return (particle "particle") - [$p|(e: Expression) dispatch-type|] =: do- Expression (Dispatch _ d) <- here "e" >>= findExpression- case d of- ESingle {} -> return (particle "single")- EKeyword {} -> return (particle "keyword")-- [$p|(e: Expression) particle-type|] =: do- Expression (EParticle _ p) <- here "e" >>= findExpression- case p of- EPMKeyword {} -> return (particle "keyword")- EPMSingle {} -> return (particle "single")+ EParticle { eParticle = EPMKeyword _ _ } ->+ return (keyParticleN ["particle"] [particle "keyword"])+ EParticle { eParticle = EPMSingle _ } ->+ return (keyParticleN ["particle"] [particle "single"]) [$p|(e: Expression) target|] =: do- Expression (Dispatch _ (ESingle { emTarget = t })) <- here "e" >>= findExpression- return (Expression t)-- [$p|(e: Expression) particle|] =: do- Expression (Dispatch _ em) <- here "e" >>= findExpression+ Expression e <- here "e" >>= findExpression - case em of- EKeyword { emNames = ns } ->- return (keyParticle ns (replicate (length ns + 1) Nothing))- ESingle { emName = n } -> return (particle n)+ case e of+ Dispatch { eMessage = ESingle { emTarget = t } } ->+ return (Expression t)+ _ -> raise ["no-target-for"] [Expression e] [$p|(e: Expression) targets|] =: do- Expression (Dispatch _ (EKeyword { emTargets = vs })) <- here "e" >>= findExpression- return $ list (map Expression vs)+ Expression e <- here "e" >>= findExpression + case e of+ Dispatch { eMessage = EKeyword { emTargets = ts } } ->+ return (list (map Expression ts))+ _ -> raise ["no-targets-for"] [Expression e]+ [$p|(e: Expression) name|] =: do- Expression (EParticle _ (EPMSingle n)) <- here "e" >>= findExpression- return (string n)+ Expression e <- here "e" >>= findExpression + case e of+ EParticle _ (EPMSingle n) -> return (string n)+ Dispatch { eMessage = ESingle { emName = n } } ->+ return (string n)+ _ -> raise ["no-name-for"] [Expression e]+ [$p|(e: Expression) names|] =: do- Expression (EParticle _ (EPMKeyword ns _)) <- here "e" >>= findExpression- return $ list (map string ns)+ Expression e <- here "e" >>= findExpression + case e of+ EParticle _ (EPMKeyword ns _) ->+ return (list (map string ns))+ Dispatch { eMessage = EKeyword { emNames = ns } } ->+ return (list (map string ns))+ _ -> raise ["no-names-for"] [Expression e]+ [$p|(e: Expression) values|] =: do- Expression (EParticle _ (EPMKeyword _ mes)) <- here "e" >>= findExpression- return . list $- map- (maybe (particle "none") (keyParticle ["ok"] . ([Nothing] ++) . (:[]). Just . Expression))- mes+ Expression e <- here "e" >>= findExpression + case e of+ EParticle { eParticle = EPMKeyword _ mes } ->+ return . list $+ map+ (maybe (particle "none") (keyParticleN ["ok"] . (:[]) . Expression))+ mes+ _ -> raise ["no-values-for"] [Expression e]+ [$p|(e: Expression) contents|] =: do Expression e <- here "e" >>= findExpression- return $ list (map Expression (eContents e)) + case e of+ EBlock { eContents = es } ->+ return (list (map Expression es))+ EList { eContents = es } ->+ return (list (map Expression es))+ _ -> raise ["no-contents-for"] [Expression e]++ [$p|(e: Expression) arguments|] =: do+ Expression e <- here "e" >>= findExpression++ case e of+ EBlock { eArguments = as } ->+ return (list (map Pattern as))+ _ -> raise ["no-arguments-for"] [Expression e]+ [$p|(e: Expression) pattern|] =: do Expression e <- here "e" >>= findExpression case e of@@ -97,3 +145,20 @@ Set { eExpr = e } -> return (Expression e) Define { eExpr = e } -> return (Expression e) _ -> raise ["no-expression-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 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 $+ ekeyword ["match"] [t, EBlock Nothing [] branches]+ where+ branches = flip map bs $ \(p, e) ->+ Dispatch Nothing $ ekeyword ["->"] [p, e]
src/Atomo/Kernel/List.hs view
@@ -15,10 +15,10 @@ [$e|"[" .. l (map: @show) (join: ", ") .. "]"|] [$p|(l: List) length|] =:- getVector [$e|l|] >>= return . Integer . fromIntegral . V.length+ liftM (Integer . fromIntegral . V.length) (getVector [$e|l|]) [$p|(l: List) empty?|] =:- liftM (Boolean . V.null) $ getVector [$e|l|]+ liftM (Boolean . V.null) (getVector [$e|l|]) [$p|(l: List) at: (n: Integer)|] =: do Integer n <- here "n" >>= findInteger@@ -32,13 +32,13 @@ ] else return (vs `V.unsafeIndex` fromIntegral n) - [$p|[] head|] =::: [$e|raise: @empty-list|]+ [$p|[] head|] =::: [$e|error: @empty-list|] [$p|(l: List) head|] =:- getVector [$e|l|] >>= return . V.unsafeHead+ liftM V.unsafeHead (getVector [$e|l|]) - [$p|[] last|] =::: [$e|raise: @empty-list|]+ [$p|[] last|] =::: [$e|error: @empty-list|] [$p|(l: List) last|] =:- getVector [$e|l|] >>= return . V.unsafeLast+ liftM V.unsafeLast (getVector [$e|l|]) -- TODO: handle negative ranges [$p|(l: List) from: (s: Integer) to: (e: Integer)|] =:::@@ -60,13 +60,13 @@ (fromIntegral num) vs - [$p|[] init|] =::: [$e|raise: @empty-list|]+ [$p|[] init|] =::: [$e|error: @empty-list|] [$p|(l: List) init|] =:- getVector [$e|l|] >>= return . List . V.unsafeInit+ liftM (List . V.unsafeInit) (getVector [$e|l|]) - [$p|[] tail|] =::: [$e|raise: @empty-list|]+ [$p|[] tail|] =::: [$e|error: @empty-list|] [$p|(l: List) tail|] =:- getVector [$e|l|] >>= return . List . V.unsafeTail+ liftM (List . V.unsafeTail) (getVector [$e|l|]) [$p|(l: List) take: (n: Integer)|] =: do vs <- getVector [$e|l|]@@ -95,8 +95,8 @@ bs <- getVector [$e|b|] return . List $ as V.++ bs - [$p|(l: List) reverse|] =: do- getVector [$e|l|] >>= return . List . V.reverse+ [$p|(l: List) reverse|] =:+ liftM (List . V.reverse) (getVector [$e|l|]) [$p|(l: List) map: b|] =: do vs <- getVector [$e|l|]@@ -128,7 +128,7 @@ return $ List nvs - [$p|[] reduce: b|] =::: [$e|raise: @empty-list|]+ [$p|[] reduce: b|] =::: [$e|error: @empty-list|] [$p|(l: List) reduce: b|] =: do vs <- getVector [$e|l|] b <- here "b"@@ -144,7 +144,7 @@ V.foldM (\x acc -> dispatch (keyword ["call"] [b, list [x, acc]])) v vs - [$p|[] reduce-right: b|] =::: [$e|raise: @empty-list|]+ [$p|[] reduce-right: b|] =::: [$e|error: @empty-list|] [$p|(l: List) reduce-right: b|] =: do vs <- getVector [$e|l|] b <- here "b"@@ -189,8 +189,30 @@ [$p|(l: List) and|] =::: [$e|l all?: @(== True)|] [$p|(l: List) or|] =::: [$e|l any?: @(== True)|] - -- TODO: take-while, drop-while+ [$p|(l: List) take-while: test|] =: do+ t <- here "test"+ l <- getList [$e|l|] + let takeWhileM [] = return []+ takeWhileM (x:xs) =+ ifVM (dispatch (keyword ["call"] [t, list [x]]))+ (liftM (x:) (takeWhileM xs))+ (return [])++ liftM list $ takeWhileM l++ [$p|(l: List) drop-while: test|] =: do+ t <- here "test"+ l <- getList [$e|l|]++ let dropWhileM [] = return []+ dropWhileM (x:xs) =+ ifVM (dispatch (keyword ["call"] [t, list [x]]))+ (dropWhileM xs)+ (return (x:xs))++ liftM list $ dropWhileM l+ [$p|v in?: (l: List)|] =::: [$e|l contains?: v|] [$p|(l: List) contains?: v|] =::: [$e|l any?: @(== v)|] @@ -237,9 +259,7 @@ [ Integer n , l' ]- else do-- return (List $ vs V.// [(fromIntegral n, v)])+ else return (List $ vs V.// [(fromIntegral n, v)]) [$p|v . (l: List)|] =: do vs <- getVector [$e|l|]@@ -258,13 +278,6 @@ return . List $ V.cons v vs - {-[$p|[] pop!|] =::: [$e|raise: @empty-list|]-}- {-[$p|(l: List) pop!|] =: do-}- {-List l <- here "l" >>= findList-}- {-vs <- getVector [$e|l|]-}-- {-return . List l $ V.tail vs-}- [$p|(l: List) split: (d: List)|] =: do l <- getList [$e|l|] d <- getList [$e|d|]@@ -309,19 +322,19 @@ sortByVM = mergesort mergesort :: (Value -> Value -> VM Bool) -> [Value] -> VM [Value]-mergesort cmp = mergesort' cmp . map (\x -> [x])+mergesort cmp = mergesort' cmp . map (: []) mergesort' :: (Value -> Value -> VM Bool) -> [[Value]] -> VM [Value] mergesort' _ [] = return [] mergesort' _ [xs] = return xs-mergesort' cmp xss = merge_pairs cmp xss >>= mergesort' cmp+mergesort' cmp xss = mergePairs cmp xss >>= mergesort' cmp -merge_pairs :: (Value -> Value -> VM Bool) -> [[Value]] -> VM [[Value]]-merge_pairs _ [] = return []-merge_pairs _ [xs] = return [xs]-merge_pairs cmp (xs:ys:xss) = do+mergePairs :: (Value -> Value -> VM Bool) -> [[Value]] -> VM [[Value]]+mergePairs _ [] = return []+mergePairs _ [xs] = return [xs]+mergePairs cmp (xs:ys:xss) = do z <- merge cmp xs ys- zs <- merge_pairs cmp xss+ zs <- mergePairs cmp xss return (z:zs) merge :: (Value -> Value -> VM Bool) -> [Value] -> [Value] -> VM [Value]
src/Atomo/Kernel/Message.hs view
@@ -12,9 +12,8 @@ Single {} -> return (particle "single") Keyword {} -> return (particle "keyword") - [$p|(m: Message) send|] =: do- Message m <- here "m" >>= findMessage- dispatch m+ [$p|(m: Message) dispatch|] =:+ here "m" >>= findMessage >>= dispatch . fromMessage [$p|(m: Message) particle|] =: do Message m <- here "m" >>= findMessage
src/Atomo/Kernel/Numeric.hs view
@@ -8,7 +8,7 @@ load :: VM () load = do- mapM_ eval $+ mapM_ eval [ [$e|operator right 8 ^|] , [$e|operator 7 %, *, /|] , [$e|operator 6 +, -|]
src/Atomo/Kernel/Particle.hs view
@@ -8,7 +8,7 @@ load :: VM () load = do [$p|(p: Particle) call: (targets: List)|] =:::- [$e|(p complete: targets) send|]+ [$e|(p complete: targets) dispatch|] [$p|(p: Particle) name|] =: do Particle (PMSingle n) <- here "p" >>= findParticle@@ -36,21 +36,53 @@ vs <- getList [$e|targets|] case p of- PMKeyword ns mvs -> do+ PMKeyword ns mvs -> let blanks = length (filter (== Nothing) mvs)-- if blanks > length vs- then throwError (ParticleArity blanks (length vs))- else return . Message . keyword ns $ completeKP mvs vs- PMSingle n -> do- if length vs == 0+ 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 - [$p|(p: Particle) define-on: (targets: List) as: v|] =:::- [$e|p define-on: targets as: v in: sender|]+ [$p|c define: (p: Particle) on: v with: (targets: List) as: e|] =: do+ Particle p <- here "p" >>= findParticle+ v <- here "v"+ ts <- getList [$e|targets|]+ e <- here "e"+ c <- here "c" - [$p|(p: Particle) define-on: (targets: List) as: v in: c|] =: do+ let toPattern (Pattern p) = p+ toPattern v = PMatch v+ + others = map toPattern ts+ + main = toPattern v++ ids <- gets primitives+ obj <- targets ids main++ pat <-+ matchable $+ case p of+ PMKeyword ns _ ->+ pkeyword ns (main:others)+ PMSingle n ->+ psingle n main++ let m =+ case e of+ Expression e' -> Responder pat c e'+ _ -> Slot pat v++ forM_ obj $ \o ->+ defineOn (Reference o) m+ + return (particle "ok")++ [$p|c define: (p: Particle) on: (targets: List) as: v|] =: do Particle p <- here "p" >>= findParticle vs <- getList [$e|targets|] v <- here "v"
src/Atomo/Kernel/Pattern.hs view
@@ -3,7 +3,6 @@ module Atomo.Kernel.Pattern (load) where import Atomo-import Atomo.Method load :: VM ()@@ -49,45 +48,20 @@ if match ids p v then do- obj <- eval [$e|Object clone|]- o <- newObject $ \o -> o- { oDelegates = [obj]- , oMethods = (toMethods (bindings' p v), snd (oMethods o))- }-- return (keyParticle ["yes"] [Nothing, Just o])+ bs <- eval [$e|Object clone|]+ withTop bs (set p v)+ return (keyParticle ["yes"] [Nothing, Just bs]) else return (particle "no") - [$p|(p: Pattern) set-to: v|] =: do- Pattern p <- here "p" >>= findPattern+ [$p|top match: (p: Pattern) on: v|] =: do+ p <- here "p" >>= findPattern >>= matchable . fromPattern v <- here "v"- s <- eval [$e|sender|]- withTop s (set p v)- where- -- convert an expression to the pattern match it represents- toPattern (Dispatch { eMessage = EKeyword { emNames = ["."], emTargets = [h, t] } }) = do- hp <- toPattern h- tp <- toPattern t- return (PHeadTail hp tp)- toPattern (Dispatch { eMessage = EKeyword { emNames = [n], emTargets = [ETop {}, x] } }) = do- p <- toPattern x- return (PNamed n p)- toPattern (Dispatch { eMessage = ESingle { emName = "_" } }) =- return PAny- toPattern (Dispatch { eMessage = ESingle { emName = n } }) =- return (PNamed n PAny)- toPattern (EList { eContents = es }) = do- ps <- mapM toPattern es- return (PList ps)- toPattern (EParticle { eParticle = EPMSingle n }) =- return (PMatch (Particle (PMSingle n)))- toPattern (EParticle { eParticle = EPMKeyword ns mes }) = do- ps <- forM mes $ \me ->- case me of- Nothing -> return PAny- Just e -> toPattern e+ t <- here "top" - return (PPMKeyword ns ps)- toPattern (Primitive { eValue = v }) =- return (PMatch v)- toPattern e = raise ["unknown-pattern"] [Expression e]+ let isMethod (PSingle {}) = True+ isMethod (PKeyword {}) = True+ isMethod _ = False++ if isMethod p+ then define p (Primitive Nothing v) >> return v+ else withTop t (set p v)
src/Atomo/Kernel/Ports.hs view
@@ -3,6 +3,7 @@ import Data.Char (isSpace) import Data.Maybe (catMaybes)+import System.Console.Haskeline as Haskeline import System.Directory import System.FilePath ((</>), (<.>)) import System.IO@@ -26,6 +27,10 @@ [$p|Port standard-output|] =:: soutp [$p|Port standard-error|] =:: serrp + [$p|(p: Port) show|] =: do+ hdl <- getHandle [$e|p handle|] >>= liftIO . hShow+ return (string ("<port " ++ hdl ++ ">"))+ [$p|Port new: (fn: String)|] =::: [$e|Port new: fn mode: @read-write|] [$p|Port new: (fn: String) mode: (m: Particle)|] =: do fn <- getString [$e|fn|]@@ -47,8 +52,12 @@ [$p|(p: Port) print: x|] =: do x <- here "x"+ port <- here "p" hdl <- getHandle [$e|p handle|] + c <- liftIO (hIsClosed hdl)+ when c (raise ["port-closed", "for"] [port, x])+ String s <- eval [$e|x as: String|] >>= findString liftIO (TIO.hPutStrLn hdl s)@@ -57,8 +66,12 @@ [$p|(p: Port) display: x|] =: do x <- here "x"+ port <- here "p" hdl <- getHandle [$e|p handle|] + c <- liftIO (hIsClosed hdl)+ when c (raise ["port-closed", "for"] [port, x])+ String s <- eval [$e|x as: String|] >>= findString liftIO (TIO.hPutStr hdl s)@@ -101,8 +114,7 @@ return (Char c) [$p|(p: Port) contents|] =:- getHandle [$e|p handle|] >>= liftIO . TIO.hGetContents- >>= return . String+ getHandle [$e|p handle|] >>= liftM String . liftIO . TIO.hGetContents [$p|(p: Port) flush|] =: getHandle [$e|p handle|] >>= liftIO . hFlush@@ -169,7 +181,7 @@ [$p|File exists?: (fn: String)|] =: do fn <- getString [$e|fn|]- fmap Boolean $ liftIO (doesFileExist fn)+ liftM Boolean $ liftIO (doesFileExist fn) [$p|File find-executable: (name: String)|] =: do name <- getString [$e|name|]@@ -255,25 +267,9 @@ liftIO (renameDirectory from to) return (particle "ok") - [$p|Directory copy: (from: String) to: (to: String)|] =::: [$e|{- Directory create-tree-if-missing: to-- Directory (contents: from) map: { c |- f = from / c- t = to / c-- if: Directory (exists?: f)- then: { Directory copy: f to: t }- else: { File copy: f to: t }- }-- @ok- } call|]- [$p|Directory contents: (path: String)|] =:- getString [$e|path|]- >>= liftIO . getDirectoryContents- >>= return . list . map string . filter (not . (`elem` [".", ".."]))+ liftM (list . map string . filter (`notElem` [".", ".."]))+ (getString [$e|path|] >>= liftIO . getDirectoryContents) [$p|Directory current|] =: liftM string $ liftIO getCurrentDirectory@@ -309,7 +305,25 @@ a <- getString [$e|a|] b <- getString [$e|b|] return (string (a <.> b))++ [$p|interaction: (prompt: String)|] =: do+ prompt <- getString [$e|prompt|]+ history <- getString [$e|*history-file* _?|]+ line <-+ liftIO $ Haskeline.catch+ (liftM Just $ runInput history (getInputLine prompt))+ (\Interrupt -> return Nothing)++ case line of+ Just (Just i) -> return (string i)+ Just Nothing -> raise' "end-of-input"+ Nothing -> raise' "interrupt"+ where+ runInput h+ = runInputT (defaultSettings { historyFile = Just h })+ . withInterrupt+ portObj hdl = newScope $ do port <- eval [$e|Port clone|] [$p|p|] =:: port@@ -323,9 +337,7 @@ where dropSpaces = do c <- hLookAhead h- if isSpace c- then hGetChar h >> dropSpaces- else return ()+ when (isSpace c) (hGetChar h >> dropSpaces) hGetSegment' stop = do end <- hIsEOF h
src/Atomo/Kernel/String.hs view
@@ -10,7 +10,7 @@ load :: VM () load = do [$p|(s: String) as: List|] =:- getString [$e|s|] >>= return . list . map Char+ liftM (list . map Char) (getString [$e|s|]) [$p|(l: List) to-string|] =: do vs <- getList [$e|l|]@@ -24,7 +24,7 @@ return (String (T.singleton c)) [$p|(s: String) length|] =:- getText [$e|s|] >>= return . Integer . fromIntegral . T.length+ liftM (Integer . fromIntegral . T.length) (getText [$e|s|]) [$p|(s: String) empty?|] =: liftM (Boolean . T.null) $ getText [$e|s|]@@ -37,36 +37,56 @@ then raise ["out-of-bounds", "for-string"] [Integer n, String t] else return . Char $ t `T.index` fromIntegral n - [$p|"" head|] =::: [$e|raise: @empty-string|]+ [$p|"" head|] =::: [$e|error: @empty-string|] [$p|(s: String) head|] =:- getText [$e|s|] >>= return . Char . T.head+ liftM (Char . T.head) (getText [$e|s|]) - [$p|"" last|] =::: [$e|raise: @empty-string|]+ [$p|"" last|] =::: [$e|error: @empty-string|] [$p|(s: String) last|] =:- getText [$e|s|] >>= return . Char . T.last+ liftM (Char . T.last) (getText [$e|s|]) -- TODO: @from:to: - [$p|"" init|] =::: [$e|raise: @empty-string|]+ [$p|"" init|] =::: [$e|error: @empty-string|] [$p|(s: String) init|] =:- getText [$e|s|] >>= return . String . T.init+ liftM (String . T.init) (getText [$e|s|]) - [$p|"" tail|] =::: [$e|raise: @empty-string|]+ [$p|"" tail|] =::: [$e|error: @empty-string|] [$p|(s: String) tail|] =:- getText [$e|s|] >>= return . String . T.tail+ liftM (String . T.tail) (getText [$e|s|]) [$p|(s: String) take: (n: Integer)|] =: do Integer n <- here "n" >>= findInteger- getText [$e|s|] >>=- return . String . T.take (fromIntegral n)+ liftM (String . T.take (fromIntegral n)) (getText [$e|s|]) [$p|(s: String) drop: (n: Integer)|] =: do Integer n <- here "n" >>= findInteger- getText [$e|s|] >>=- return . String . T.drop (fromIntegral n)+ liftM (String . T.drop (fromIntegral n)) (getText [$e|s|]) - -- TODO: take-while:, drop-while:+ [$p|(s: String) take-while: test|] =: do+ t <- here "test"+ s <- getString [$e|s|] + let takeWhileM [] = return []+ takeWhileM (x:xs) =+ ifVM (dispatch (keyword ["call"] [t, list [Char x]]))+ (liftM (x:) (takeWhileM xs))+ (return [])++ liftM string $ takeWhileM s++ [$p|(s: String) drop-while: test|] =: do+ t <- here "test"+ s <- getString [$e|s|]++ let dropWhileM [] = return []+ dropWhileM (x:xs) =+ ifVM (dispatch (keyword ["call"] [t, list [Char x]]))+ (dropWhileM xs)+ (return (x:xs))++ liftM string $ dropWhileM s+ [$p|(c: Char) repeat: (n: Integer)|] =: do Char c <- here "c" >>= findChar Integer n <- here "n" >>= findInteger@@ -74,8 +94,7 @@ [$p|(s: String) repeat: (n: Integer)|] =: do Integer n <- here "n" >>= findInteger- getText [$e|s|] >>=- return . String . T.replicate (fromIntegral n)+ liftM (String . T.replicate (fromIntegral n)) (getText [$e|s|]) [$p|(a: String) .. (b: String)|] =: do a <- getText [$e|a|]@@ -83,7 +102,7 @@ return (String (a `T.append` b)) [$p|(s: String) reverse|] =:- getText [$e|s|] >>= return . String . T.reverse+ liftM (String . T.reverse) (getText [$e|s|]) [$p|(l: List) join|] =::: [$e|l reduce: @.. with: ""|] @@ -155,9 +174,14 @@ s <- getText [$e|s|] return $ list (map String (T.words s)) - [$p|(l: List) unlines|] =::: [$e|l (map: @(<< '\n')) join|]- [$p|(l: List) unwords|] =::: [$e|l join: " "|]+ [$p|(l: List) unlines|] =: do+ l <- getList [$e|l|]+ return $ String (T.unlines (map fromString l)) + [$p|(l: List) unwords|] =: do+ l <- getList [$e|l|]+ return $ String (T.unwords (map fromString l))+ [$p|(s: String) map: b|] =: do s <- getString [$e|s|] b <- here "b"@@ -176,6 +200,8 @@ s <- getText [$e|s|] return (String (T.cons c s)) + [$p|(c: Char) >> (s: String)|] =::: [$e|c . s|]+ [$p|(s: String) << (c: Char)|] =: do s <- getText [$e|s|] Char c <- here "c" >>= findChar@@ -187,14 +213,14 @@ s <- getText [$e|new|] return (String (T.replace n s h)) - [$p|(s: String) case-fold|] =: do- getText [$e|s|] >>= return . String . T.toCaseFold+ [$p|(s: String) case-fold|] =:+ liftM (String . T.toCaseFold) (getText [$e|s|]) - [$p|(s: String) lowercase|] =: do- getText [$e|s|] >>= return . String . T.toLower+ [$p|(s: String) lowercase|] =:+ liftM (String . T.toLower) (getText [$e|s|]) - [$p|(s: String) uppercase|] =: do- getText [$e|s|] >>= return . String . T.toUpper+ [$p|(s: String) uppercase|] =:+ liftM (String . T.toUpper) (getText [$e|s|]) [$p|(s: String) left-justify: (length: Integer) with: (c: Char)|] =: do s <- getText [$e|s|]@@ -217,26 +243,26 @@ return (String (T.center (fromIntegral l) c s)) - [$p|(s: String) strip|] =: do- getText [$e|s|] >>= return . String . T.strip+ [$p|(s: String) strip|] =:+ liftM (String . T.strip) (getText [$e|s|]) - [$p|(s: String) strip-start|] =: do- getText [$e|s|] >>= return . String . T.stripStart+ [$p|(s: String) strip-start|] =:+ liftM (String . T.stripStart) (getText [$e|s|]) - [$p|(s: String) strip-end|] =: do- getText [$e|s|] >>= return . String . T.stripEnd+ [$p|(s: String) strip-end|] =:+ liftM (String . T.stripEnd) (getText [$e|s|]) [$p|(s: String) strip: (c: Char)|] =: do Char c <- here "c" >>= findChar- getText [$e|s|] >>= return . String . T.dropAround (== c)+ liftM (String . T.dropAround (== c)) (getText [$e|s|]) [$p|(s: String) strip-start: (c: Char)|] =: do Char c <- here "c" >>= findChar- getText [$e|s|] >>= return . String . T.dropWhile (== c)+ liftM (String . T.dropWhile (== c)) (getText [$e|s|]) [$p|(s: String) strip-end: (c: Char)|] =: do Char c <- here "c" >>= findChar- getText [$e|s|] >>= return . String . T.dropWhileEnd (== c)+ 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|]@@ -254,31 +280,31 @@ [$p|(s: String) reduce-right: b|] =::: [$e|(s as: List) reduce-right: b|] [$p|(s: String) reduce-right: b with: v|] =::: [$e|(s as: List) reduce-right: b with: v|] - [$p|(s: String) maximum|] =: do- getText [$e|s|] >>= return . Char . T.maximum+ [$p|(s: String) maximum|] =:+ liftM (Char . T.maximum) (getText [$e|s|]) - [$p|(s: String) minimum|] =: do- getText [$e|s|] >>= return . Char . T.minimum+ [$p|(s: String) minimum|] =:+ liftM (Char . T.minimum) (getText [$e|s|]) [$p|(s: String) sort|] =:- getString [$e|s|] >>= return . string . sort+ liftM (string . sort) (getString [$e|s|]) [$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|] b <- getText [$e|b|]- return $ Boolean (T.isPrefixOf a b)+ return $ Boolean (a `T.isPrefixOf` b) [$p|(a: String) is-suffix-of?: (b: String)|] =: do a <- getText [$e|a|] b <- getText [$e|b|]- return $ Boolean (T.isSuffixOf a b)+ return $ Boolean (a `T.isSuffixOf` b) [$p|(a: String) is-infix-of?: (b: String)|] =: do a <- getText [$e|a|] b <- getText [$e|b|]- return $ Boolean (T.isInfixOf a b)+ return $ Boolean (a `T.isInfixOf` b) [$p|(a: String) starts-with?: (b: String)|] =::: [$e|b is-prefix-of?: a|] [$p|(a: String) ends-with?: (b: String)|] =::: [$e|b is-suffix-of?: a|]@@ -296,3 +322,12 @@ dispatch (keyword ["call"] [z, list [Char a, Char 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|]
src/Atomo/Load.hs view
@@ -1,6 +1,5 @@ module Atomo.Load where -import "monads-fd" Control.Monad.Error import "monads-fd" Control.Monad.State import System.Directory import System.FilePath@@ -44,9 +43,7 @@ H.setTopLevelModules ["Main"] H.interpret "load" (H.as :: VM ()) - load <- either (throwError . ImportError) return int-- load+ join (either (throwError . ImportError) return int) return (particle "ok")
src/Atomo/Method.hs view
@@ -80,7 +80,7 @@ unsafeDelegatesTo :: Value -> Value -> Bool unsafeDelegatesTo (Reference f) t =- t `elem` ds || any (flip unsafeDelegatesTo t) ds+ t `elem` ds || any (`unsafeDelegatesTo` t) ds where ds = oDelegates (unsafePerformIO (readIORef f)) unsafeDelegatesTo _ _ = False@@ -107,7 +107,7 @@ _ -> y : insertMethod x ys' toMethods :: [(Pattern, Value)] -> MethodMap-toMethods bs = foldl (\ss (p, v) -> addMethod (Slot p v) ss) emptyMap bs+toMethods = foldl (\ss (p, v) -> addMethod (Slot p v) ss) emptyMap noMethods :: (MethodMap, MethodMap) noMethods = (M.empty, M.empty)
src/Atomo/Parser.hs view
@@ -1,13 +1,11 @@ module Atomo.Parser where import Control.Arrow (first, second)-import "monads-fd" Control.Monad.Error import "monads-fd" Control.Monad.State import Data.Maybe (fromJust, isJust) import Text.Parsec import qualified "mtl" Control.Monad.Trans as MTL -import Atomo.Debug import Atomo.Environment import Atomo.Method import Atomo.Parser.Base@@ -26,22 +24,32 @@ pExpr :: Parser Expr pExpr = choice- [ try pOperator- , try pMacro- , try pDefine- , try pSet+ [ pOperator+ , pMacro+ , pForMacro , try pDispatch+ , pDefine+ , pSet , pLiteral , parens pExpr ] <?> "expression" pLiteral :: Parser Expr-pLiteral = try pBlock <|> try pList <|> try pParticle <|> try pQuoted <|> try pUnquoted <|> pPrimitive+pLiteral = pThis <|> pBlock <|> pList <|> pParticle <|> pQuoted <|> pQuasiQuoted <|> pUnquoted <|> pPrimitive <?> "literal" +pThis :: Parser Expr+pThis = tagged $ reserved "this" >> return (ETop Nothing)+ pQuoted :: Parser Expr pQuoted = tagged $ do+ char '\''+ e <- pSpacedExpr+ return (Primitive Nothing (Expression e))++pQuasiQuoted :: Parser Expr+pQuasiQuoted = tagged $ do char '`' e <- pSpacedExpr return (EQuote Nothing e)@@ -53,13 +61,22 @@ return (EUnquote Nothing e) pSpacedExpr :: Parser Expr-pSpacedExpr = try pLiteral <|> simpleDispatch <|> parens pExpr+pSpacedExpr = pLiteral <|> simpleDispatch <|> parens pExpr where simpleDispatch = tagged $ do name <- ident notFollowedBy (char ':')+ spacing return (Dispatch Nothing (esingle name (ETop Nothing))) +pForMacro :: Parser Expr+pForMacro = tagged (do+ reserved "for-macro"+ e <- pExpr+ MTL.lift (eval e)+ return (Primitive Nothing (Expression e))) --e)+ <?> "for-macro expression"+ pMacro :: Parser Expr pMacro = tagged (do reserved "macro"@@ -67,7 +84,7 @@ reserved ":=" whiteSpace e <- pExpr- addMacro p e+ macroExpand e >>= addMacro p return (EMacro Nothing p e)) <?> "macro definition" @@ -91,14 +108,14 @@ reserved "operator" info <- choice- [ try $ do+ [ do a <- choice [ symbol "right" >> return ARight , symbol "left" >> return ALeft ] prec <- option defaultPrec (try integer) return (a, prec)- , fmap ((,) ALeft) integer+ , liftM ((,) ALeft) integer ] ops <- commaSep1 operator@@ -106,17 +123,17 @@ forM_ ops $ \name -> modifyState (\ps -> ps { psOperators = (name, info) : psOperators ps }) - return (Operator Nothing ops (fst info) (snd info)))+ return (uncurry (Operator Nothing ops) info)) <?> "operator pragma" pParticle :: Parser Expr pParticle = tagged (do char '@' c <- choice- [ try (cSingle True)- , try (cKeyword True)- , try binary- , try symbols+ [ cKeyword True+ , binary+ , try (cSingle True)+ , symbols ] return (EParticle Nothing c)) <?> "particle"@@ -132,43 +149,52 @@ pDefine :: Parser Expr pDefine = tagged (do- pattern <- ppDefine- dump ("pDefine: define pattern", pattern)- reservedOp ":="+ pattern <- try $ do+ p <- ppDefine+ reservedOp ":="+ return p+ whiteSpace expr <- pExpr+ return $ Define Nothing pattern expr) <?> "definition" pSet :: Parser Expr pSet = tagged (do- pattern <- ppSet- dump ("pSet: set pattern", pattern)- reservedOp "="+ pattern <- try $ do+ p <- ppSet+ reservedOp "="+ return p+ whiteSpace expr <- pExpr+ return $ Set Nothing pattern expr) <?> "set" pDispatch :: Parser Expr-pDispatch = choice- [ try pdKeys- , pdCascade- ]+pDispatch = do+ d <- choice+ [ try pdKeys+ , pdCascade+ ]+ notFollowedBy (reserved ":=" <|> reserved "=")+ return d <?> "dispatch" pdKeys :: Parser Expr pdKeys = do pos <- getPosition msg <- keywords ekeyword (ETop (Just pos)) (try pdCascade <|> headless)- ops <- fmap psOperators getState+ ops <- liftM psOperators getState return $ Dispatch (Just pos) (toBinaryOps ops msg) <?> "keyword dispatch" where headless = do p <- getPosition msg <- ckeywd p- ops <- fmap psOperators getState+ ops <- liftM psOperators getState return (Dispatch (Just p) (toBinaryOps ops msg)) ckeywd pos = do@@ -182,15 +208,15 @@ pos <- getPosition chain <- wsManyStart- (fmap DNormal (try pLiteral <|> parens pExpr) <|> cascaded)+ (liftM DNormal (try pLiteral <|> pThis <|> parens pExpr) <|> cascaded) cascaded return $ dispatches pos chain <?> "single dispatch" where- cascaded = fmap DParticle $ choice- [ try (cSingle False)- , try (cKeyword False)+ cascaded = liftM DParticle $ choice+ [ cKeyword False+ , cSingle False ] -- start off by dispatching on either a primitive or Top@@ -213,7 +239,7 @@ dispatches' _ x y = error $ "impossible: dispatches' on " ++ show (x, y) pList :: Parser Expr-pList = (tagged . fmap (EList Nothing) $ brackets (wsDelim "," pExpr))+pList = (tagged . liftM (EList Nothing) $ brackets (wsDelim "," pExpr)) <?> "list" pBlock :: Parser Expr@@ -255,8 +281,8 @@ | wc = wildcard <|> disp | otherwise = disp - value = fmap Just pdCascade- disp = fmap Just pDispatch+ value = liftM Just pdCascade+ disp = liftM Just pDispatch keyword' = do name <- try (do@@ -282,7 +308,7 @@ partVals ++ [Just $ Dispatch (Just pos) msg] | otherwise = fail "invalid particle; toplevel operator with wildcards as values" where- (nonOpers, opers) = first (n:) $ span (not . isOperator) ns+ (nonOpers, opers) = first (n:) $ break isOperator ns (partVals, opVals) = splitAt (length nonOpers) mvs -- work out precadence, associativity, etc. from a stream of operators@@ -341,30 +367,24 @@ Just (_, p) -> p toBinaryOps _ u = error $ "cannot toBinaryOps: " ++ show u -isOperator :: String -> Bool-isOperator "" = error "isOperator: empty string"-isOperator (c:_) = c `elem` opLetters- parser :: Parser [Expr] parser = do- optional (string "#!" >> manyTill anyToken newline) whiteSpace es <- wsBlock pExpr whiteSpace eof return es -cparser :: Parser (ParserState, [Expr])-cparser = do- r <- parser- s <- getState- return (s, r)+fileParser :: Parser [Expr]+fileParser = do+ optional (string "#!" >> manyTill anyToken (eol <|> eof))+ parser parseFile :: String -> VM [Expr]-parseFile fn = liftIO (readFile fn) >>= continue (parser >>= mapM macroExpand) fn+parseFile fn = liftIO (readFile fn) >>= continue (fileParser >>= mapM macroExpand) fn parseInput :: String -> VM [Expr]-parseInput s = continue (parser >>= mapM macroExpand) "<input>" s+parseInput = continue (parser >>= mapM macroExpand) "<input>" continue :: Parser a -> String -> String -> VM a continue p s i = do@@ -436,8 +456,8 @@ ms <- methods m maybe (return Nothing) (firstMatch ids m) (lookupMap (mID m) ms) where- methods (Single {}) = fmap (fst . psMacros) getState- methods (Keyword {}) = fmap (snd . psMacros) getState+ methods (Single {}) = liftM (fst . psMacros) getState+ methods (Keyword {}) = liftM (snd . psMacros) getState firstMatch _ _ [] = return Nothing firstMatch ids' m' (mt:mts)
src/Atomo/Parser/Base.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE OverloadedStrings, RankNTypes #-} {-# OPTIONS -fno-warn-name-shadowing #-} module Atomo.Parser.Base where +import Control.Monad (liftM) import Data.Char-import Data.List (nub, sort, (\\))+import Data.List (nub, sort) import Text.Parsec import qualified Text.Parsec.Token as P @@ -13,27 +13,34 @@ type Parser = ParsecT String ParserState VM -opLetters :: [Char]-opLetters = "~!@#$%^&*-_=+./\\|<>?"+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 VM def = P.LanguageDef { P.commentStart = "{-" , P.commentEnd = "-}" , P.commentLine = "--" , P.nestedComments = True- , P.identStart = letter <|> oneOf "_"+ , P.identStart = letter <|> P.opStart def <|> oneOf "_" , P.identLetter = alphaNum <|> P.opLetter def- , P.opStart = oneOf (opLetters \\ "@_~")- , P.opLetter = letter <|> oneOf opLetters- , P.reservedOpNames = ["=", ":=", ",", "|", "_"]- , P.reservedNames = ["operator", "macro", "True", "False"]+ , 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 VM tp = makeTokenParser def +eol :: Parser ()+eol = newline >> return ()+ lexeme :: Parser a -> Parser a lexeme = P.lexeme tp @@ -56,10 +63,12 @@ lowIdentifier = lexeme lowIdent anyIdent :: Parser String-anyIdent = do+anyIdent = try $ do c <- P.identStart def cs <- many (P.identLetter def)- return (c:cs)+ if isOperator (c:cs)+ then unexpected "operator"+ else return (c:cs) anyIdentifier :: Parser String anyIdentifier = lexeme anyIdent@@ -92,7 +101,7 @@ ident = P.identifier tp operator :: Parser String-operator = do+operator = try $ do c <- P.opStart def cs <- many (P.opLetter def) if (c:cs) `elem` P.reservedOpNames def@@ -182,11 +191,11 @@ wsmany start [] where wsmany o es = choice- [ try $ do- x <- if null es then s else p+ [ do+ x <- if null es then s else try p new <- lookAhead (whiteSpace >> getPosition)- sequential <- fmap (== new) $ lookAhead (spacing >> getPosition)+ sequential <- liftM (== new) $ lookAhead (spacing >> getPosition) delimited <- option False $ try delim @@ -197,30 +206,22 @@ ] keyword :: Parser a -> Parser (String, a)-keyword p = try $ do- name <- try (do- name <- ident- char ':'- return name) <|> operator- whiteSpace1+keyword p = do+ name <- keywordName target <- p return (name, target) +keywordName :: Parser String+keywordName = do+ n <- operator <|> (ident >>= \name -> char ':' >> return name)+ whiteSpace1+ return n+ keywords :: Show a => ([String] -> [a] -> b) -> a -> Parser a -> Parser b keywords c d p = do- (first, ks) <- choice- [ try $ do- f <- p- fs <- wsMany1 (keyword p)- return (f, fs)- , do- fs <- wsMany1 (keyword p)- return (d, fs)- ]-- let (ns, ps) = unzip ks-- return $ c ns (first:ps)+ r <- choice [try (lookAhead keywordName) >> return d, p]+ (ns, rs) <- liftM unzip $ wsMany1 (keyword p)+ return (c ns (r:rs)) tagged :: Parser Expr -> Parser Expr tagged p = do@@ -268,10 +269,10 @@ ----------------------------------------------------------- -- Bracketing ------------------------------------------------------------ parens p = between (open "(") (close ")") p- braces p = between (open "{") (close "}") p- angles p = between (open "<") (close ">") p- brackets p = between (open "[") (close "]") p+ parens = between (open "(") (close ")")+ braces = between (open "{") (close "}")+ angles = between (open "<") (close ">")+ brackets = between (open "[") (close "]") semi = delimit ";" comma = delimit ","@@ -288,16 +289,14 @@ ----------------------------------------------------------- -- Chars & Strings ------------------------------------------------------------ charLiteral = lexeme (between (char '\'')- (char '\'' <?> "end of character")- characterChar )+ charLiteral = lexeme (char '$' >> characterChar) <?> "character" characterChar = charLetter <|> charEscape <?> "literal character" charEscape = do{ char '\\'; escapeCode }- charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))+ charLetter = satisfy (\c -> (c /= '\\') && (c > '\026')) @@ -353,7 +352,7 @@ -- escape code tables- escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'")+ 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",@@ -362,21 +361,18 @@ "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB", "CAN","SUB","ESC","DEL"] - ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI',- '\EM','\FS','\GS','\RS','\US','\SP']- ascii3 = ['\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"+ naturalOrFloat = lexeme natFloat <?> "number" - float = lexeme floating <?> "float"- integer = lexeme int <?> "integer"- natural = lexeme nat <?> "natural"+ float = lexeme floating <?> "float"+ integer = lexeme int <?> "integer"+ natural = lexeme nat <?> "natural" -- floats@@ -412,7 +408,7 @@ } <|> do{ expo <- exponent'- ; return ((fromInteger n)*expo)+ ; return (fromInteger n*expo) } fraction = do{ char '.'@@ -449,7 +445,7 @@ zeroNumber = do{ char '0' ; hexadecimal <|> octal <|> decimal <|> return 0 }- <?> ""+ <?> "zeroNumber" decimal = number 10 digit hexadecimal = do{ oneOf "xX"; number 16 hexDigit }@@ -473,20 +469,20 @@ operator = lexeme $ try $ do{ name <- oper- ; if (isReservedOp name)+ ; if isReservedOp name then unexpected ("reserved operator " ++ show name) else return name } oper =- do{ c <- (P.opStart languageDef)+ try (do{ c <- (P.opStart languageDef) ; cs <- many (P.opLetter languageDef) ; return (c:cs)- }+ }) <?> "operator" - isReservedOp name =- isReserved (sort (P.reservedOpNames languageDef)) name+ isReservedOp =+ isReserved (sort (P.reservedOpNames languageDef)) -----------------------------------------------------------@@ -514,17 +510,18 @@ identifier = try $ do{ name <- ident- ; if (isReservedName name)+ ; if isReservedName name then unexpected ("reserved word " ++ show name) else return name } - ident- = do{ c <- P.identStart languageDef- ; cs <- many (P.identLetter languageDef)- ; return (c:cs)- }+ ident = try (do+ c <- P.identStart def+ cs <- many (P.identLetter def)+ if isOperator (c:cs)+ then unexpected "operator"+ else return (c:cs)) <?> "identifier" isReservedName name@@ -538,7 +535,7 @@ = scan names where scan [] = False- scan (r:rs) = case (compare r name) of+ scan (r:rs) = case compare r name of LT -> scan rs EQ -> True GT -> False@@ -587,10 +584,10 @@ spacing = skipMany spacing1 spacing1 :: Parser ()-spacing1 | noLine && noMulti = simpleSpace <?> ""- | noLine = simpleSpace <|> multiLineComment <?> ""- | noMulti = simpleSpace <|> oneLineComment <?> ""- | otherwise = simpleSpace <|> oneLineComment <|> multiLineComment <?> ""+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)
src/Atomo/Parser/Pattern.hs view
@@ -1,5 +1,6 @@ module Atomo.Parser.Pattern where +import Control.Monad (liftM) import Text.Parsec import Atomo.Debug@@ -16,6 +17,7 @@ , ppList , ppString , ppParticle+ , ppExpr , ppAny , parens pPattern ]@@ -29,6 +31,7 @@ , ppList , ppString , ppParticle+ , ppExpr , ppAnySensitive , parens pObjectPattern ]@@ -39,6 +42,11 @@ ppMacro :: Parser Pattern ppMacro = try ppMacroKeywords <|> ppMacroSingle +ppExpr :: Parser Pattern+ppExpr = do+ q <- pQuasiQuoted+ return (PExpr (eExpr q))+ ppMacroSingle :: Parser Pattern ppMacroSingle = do (t, v) <- choice@@ -59,18 +67,19 @@ ppMacroRole :: Parser Pattern ppMacroRole = choice- [ symbol "Define" >> return PEDefine- , symbol "Set" >> return PESet- , symbol "Dispatch" >> return PEDispatch- , symbol "Operator" >> return PEOperator- , symbol "Primitive" >> return PEPrimitive- , symbol "Block" >> return PEBlock- , symbol "List" >> return PEList- , symbol "Macro" >> return PEMacro- , symbol "Particle" >> return PEParticle- , symbol "Top" >> return PETop- , symbol "Quote" >> return PEQuote- , symbol "Unquote" >> return PEUnquote+ [ ppExpr+ , try $ symbol "Define" >> return PEDefine+ , try $ symbol "Set" >> return PESet+ , try $ symbol "Dispatch" >> return PEDispatch+ , try $ symbol "Operator" >> return PEOperator+ , try $ symbol "Primitive" >> return PEPrimitive+ , try $ symbol "Block" >> return PEBlock+ , try $ symbol "List" >> return PEList+ , try $ symbol "Macro" >> return PEMacro+ , try $ symbol "Particle" >> return PEParticle+ , try $ symbol "Top" >> return PETop+ , try $ symbol "Quote" >> return PEQuote+ , try $ symbol "Unquote" >> return PEUnquote , ppAny , ppNamedMacro ]@@ -122,6 +131,7 @@ , ppList , ppString , ppParticle+ , ppExpr , ppWildcard , parens pNonExpr ]@@ -215,7 +225,7 @@ char '@' try keywordParticle <|> singleParticle where- singleParticle = fmap (PMatch . Particle . PMSingle) anyIdentifier+ singleParticle = liftM (PMatch . Particle . PMSingle) anyIdentifier keywordParticle = choice [ parens $ do
src/Atomo/Parser/Primitive.hs view
@@ -1,5 +1,6 @@ module Atomo.Parser.Primitive where +import Control.Monad (liftM) import Data.Ratio import Text.Parsec @@ -8,7 +9,7 @@ pPrimitive :: Parser Expr-pPrimitive = tagged $ fmap (Primitive Nothing) pPrim+pPrimitive = tagged $ liftM (Primitive Nothing) pPrim pPrim :: Parser Value pPrim = choice@@ -21,19 +22,19 @@ ] pvChar :: Parser Value-pvChar = charLiteral >>= return . Char+pvChar = liftM Char charLiteral pvString :: Parser Value-pvString = stringLiteral >>= return . T.string+pvString = liftM T.string stringLiteral pvDouble :: Parser Value-pvDouble = float >>= return . Double+pvDouble = liftM Double float pvInteger :: Parser Value-pvInteger = integer >>= return . Integer+pvInteger = liftM Integer integer pvBoolean :: Parser Value-pvBoolean = fmap Boolean $ true <|> false+pvBoolean = liftM Boolean $ true <|> false where true = reserved "True" >> return True false = reserved "False" >> return False
src/Atomo/Pretty.hs view
@@ -2,17 +2,15 @@ module Atomo.Pretty (Pretty(..), prettyStack) where import Data.IORef-import Data.List (nub)-import Data.Maybe (isJust)+import Data.Maybe (isNothing) import Data.Ratio import Text.PrettyPrint hiding (braces) import System.IO.Unsafe import qualified Data.Vector as V-import qualified Language.Haskell.Interpreter as H import Atomo.Method import Atomo.Types hiding (keyword)-import Atomo.Parser.Base (opLetters)+import Atomo.Parser.Base (isOperator) data Context@@ -38,10 +36,10 @@ where exprs = sep . punctuate (text ";") $ map pretty es prettyFrom _ (Boolean b) = text $ show b- prettyFrom _ (Char c) = text $ show c+ prettyFrom _ (Char c) = char '$' <> (text . tail . init $ show c) prettyFrom _ (Continuation _) = internal "continuation" empty prettyFrom _ (Double d) = double d- prettyFrom _ (Expression e) = internal "expression" $ pretty e+ prettyFrom _ (Expression e) = char '\'' <> parens (pretty e) prettyFrom _ (Haskell v) = internal "haskell" $ text (show v) prettyFrom _ (Integer i) = integer i prettyFrom _ (List l) =@@ -65,8 +63,7 @@ [ internal "object" $ parens (text "delegates to" <+> pretty ds) , if not (nullMap ss)- then nest 2 $ vcat (flip map (elemsMap ss) $ (\ms ->- vcat (map prettyMethod ms))) <>+ then nest 2 $ vcat (map (vcat . map prettyMethod) (elemsMap ss)) <> if not (nullMap ks) then char '\n' else empty@@ -93,8 +90,8 @@ instance Pretty Particle where prettyFrom _ (PMSingle e) = text e prettyFrom _ (PMKeyword ns vs)- | all (not . isJust) vs = text . concat $ map keyword ns- | not (isJust (head vs)) =+ | all isNothing vs = text . concat $ map keyword ns+ | isNothing (head vs) = parens $ headlessKeywords' prettyVal ns (tail vs) | otherwise = parens (keywords' prettyVal ns vs) where@@ -120,7 +117,7 @@ prettyFrom _ (PNamed n p) = parens $ text n <> colon <+> pretty p prettyFrom _ (PObject e) = pretty e prettyFrom _ (PPMKeyword ns ps)- | all isAny ps = char '@' <> text (concat $ map keyword ns)+ | 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)@@ -145,7 +142,9 @@ prettyFrom _ PEQuote = text "Quote" prettyFrom _ PEUnquote = text "Unquote" + prettyFrom _ (PExpr e) = pretty (EQuote Nothing e) + instance Pretty Expr where prettyFrom _ (Define _ p v) = prettyFrom CDefine p <+> text ":=" <++> prettyFrom CDefine v prettyFrom _ (Set _ p v) = prettyFrom CDefine p <+> text "=" <++> prettyFrom CDefine v@@ -164,7 +163,8 @@ where exprs = sep . punctuate (text ";") $ map pretty es prettyFrom CDefine (EVM {}) = text "..."- prettyFrom _ (EVM {}) = text "<vm>"+ prettyFrom _ (EVM { ePretty = Nothing }) = text "<vm>"+ prettyFrom _ (EVM { ePretty = Just d }) = d prettyFrom _ (EList _ es) = brackets . sep . punctuate comma $ map (prettyFrom CList) es prettyFrom _ (EMacro _ p v) = text "macro" <+> prettyFrom CDefine p <+> text ":=" <++> prettyFrom CDefine v@@ -184,8 +184,8 @@ instance Pretty EParticle where prettyFrom _ (EPMSingle e) = text e prettyFrom _ (EPMKeyword ns es)- | all (not . isJust) es = text . concat $ map keyword ns- | not (isJust (head 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@@ -195,47 +195,6 @@ Just e -> pretty e -instance Pretty AtomoError where- prettyFrom _ (Error v) = text "error:" <+> pretty v- prettyFrom _ (DidNotUnderstand m) =- text "message not understood:" $$ nest 2 (pretty m)- prettyFrom _ (ParseError e) =- text "parse error:" $$ nest 2 (text (show e))- prettyFrom _ (Mismatch p v) =- text "pattern" <+> char '<' <> pretty p <> char '>' <+> text "did not match value:" <+> pretty v- prettyFrom _ (ImportError (H.UnknownError s)) =- text "import error:" <+> text s- prettyFrom _ (ImportError (H.WontCompile ges)) =- text "import error:" $$ nest 2 (vcat (map (\e -> text e <> char '\n') (nub (map H.errMsg ges))))- prettyFrom _ (ImportError (H.NotAllowed s)) =- text "import error:" <+> text s- prettyFrom _ (ImportError (H.GhcException s)) =- text "import error:" <+> text s- prettyFrom _ (FileNotFound fn) =- text "file not found:" <+> text fn- prettyFrom _ (ParticleArity e g) =- text . unwords $- [ "particle needs"- , show e- , "values to complete,"- , show g- , "given"- ]- prettyFrom _ (BlockArity e g) =- text . unwords $- [ "block expects"- , show e- , "arguments,"- , show g- , "given"- ]- prettyFrom _ NoExpressions = text "no expressions to evaluate"- prettyFrom _ (ValueNotFound d v) =- text ("could not find a " ++ d ++ " in") <+> pretty v- prettyFrom _ (DynamicNeeded t) =- text "dynamic value not of type" <+> text t-- instance Pretty Delegates where prettyFrom _ [] = internal "bottom" empty prettyFrom _ [_] = text "1 object"@@ -279,8 +238,8 @@ keyword :: String -> String keyword k- | all (`elem` opLetters) k = k- | otherwise = k ++ ":"+ | isOperator k = k+ | otherwise = k ++ ":" infixr 4 <++>, <+++>
src/Atomo/PrettyVM.hs view
@@ -1,40 +1,11 @@ module Atomo.PrettyVM where -import "monads-fd" Control.Monad.State-import qualified Text.PrettyPrint as P-+import Control.Monad (liftM) import Atomo.Environment-import Atomo.Pretty import Atomo.Types --- | print an error, including the previous 10 expressions evaluated--- with the most recent on the bottom-printError :: AtomoError -> VM ()-printError err = do- t <- traceback-- if not (null t)- then do- liftIO (putStrLn "traceback:")-- forM_ t $ \e -> liftIO $- print (prettyStack e)-- liftIO (putStrLn "")- else return ()-- prettyError err >>= liftIO . print-- modify $ \s -> s { stack = [] }- where- traceback = liftM (reverse . take 10 . reverse) (gets stack)--prettyError :: AtomoError -> VM P.Doc-prettyError (Error v) = liftM (P.text "error:" P.<+>) (prettyVM v)-prettyError e = return (pretty e)- -- | pretty-print by sending \@show to the object-prettyVM :: Value -> VM P.Doc-prettyVM = liftM (P.text . fromText . fromString) . dispatch . (single "show")+prettyVM :: Value -> VM String+prettyVM = liftM (fromText . fromString) . dispatch . single "show"
src/Atomo/QuasiQuotes.hs view
@@ -19,7 +19,6 @@ import Atomo.Parser import Atomo.Parser.Pattern import Atomo.Parser.Base-import Atomo.Pretty import Atomo.Types qqEnv :: IORef Env@@ -52,21 +51,19 @@ -- OH GOD! NO! -- WHYYYYYYYYYYYYYYYYYYYYYY case unsafePerformIO (runWith go (unsafePerformIO (readIORef qqEnv))) of- Left e -> fail (show $ pretty e)- Right x -> return (fromHaskell' "a" x)+ x -> return (fromHaskell' "a" x) where go = do- r <- fmap haskell $ continue pp "<qq>" s+ r <- liftM haskell $ continue pp "<qq>" s get >>= liftIO . writeIORef qqEnv return r pp = do pos <- getPosition setPosition $- (flip setSourceName) file $- (flip setSourceLine) line $- (flip setSourceColumn) col $- pos+ flip setSourceName file $+ flip setSourceLine line $+ setSourceColumn pos col whiteSpace e <- p whiteSpace@@ -90,7 +87,7 @@ exprToExp (Primitive l v) = AppE (expr "Primitive" l) (valueToExp v) exprToExp (EBlock l as es) = AppE (AppE (expr "EBlock" l) (ListE (map patternToExp as))) (ListE (map exprToExp es))-exprToExp (EVM _ _) = error "cannot exprToExp EVM"+exprToExp (EVM {}) = error "cannot exprToExp EVM" exprToExp (EList l es) = AppE (expr "EList" l) (ListE (map exprToExp es)) exprToExp (ETop l) =@@ -185,3 +182,4 @@ patternToExp PETop = ConE (mkName "PETop") patternToExp PEQuote = ConE (mkName "PEQuote") patternToExp PEUnquote = ConE (mkName "PEUnquote")+patternToExp (PExpr e) = AppE (ConE (mkName "PExpr")) (exprToExp e)
src/Atomo/Run.hs view
@@ -1,7 +1,6 @@ module Atomo.Run where import Control.Concurrent-import "monads-fd" Control.Monad.Error import "monads-fd" Control.Monad.State import Atomo.Core@@ -29,21 +28,16 @@ haltChan <- newChan forkIO $ do- r <- runWith (go x >> gets halt >>= liftIO >> return (particle "ok")) e- { halt = writeChan haltChan ()+ runWith (go x >> gets halt >>= liftIO >> return (particle "ok")) e+ { halt = writeChan haltChan () >> myThreadId >>= killThread } - either- (putStrLn . ("WARNING: exited abnormally with: " ++) . show)- (\_ -> return ())- r- writeChan haltChan () readChan haltChan -- | execute x, initializing the environment with initEnv-run :: VM Value -> IO (Either AtomoError Value)+run :: VM Value -> IO Value run x = runWith (initEnv >> x) startEnv -- | set up the primitive objects, etc.@@ -64,11 +58,15 @@ preludes = [ "core" + , "boolean" , "association" , "parameter"+ , "string" + , "condition"+ , "exception"+ , "block"- , "boolean" , "comparable" , "continuation" , "list"@@ -79,4 +77,6 @@ , "version" , "eco"++ , "repl" ]
src/Atomo/Spawn.hs view
@@ -2,9 +2,7 @@ import Control.Concurrent import "monads-fd" Control.Monad.State-import "monads-fd" Control.Monad.Error -import Atomo.PrettyVM import Atomo.Types @@ -21,4 +19,4 @@ -- | execute x, printing an error if there is one go :: VM Value -> VM Value-go x = catchError x (\e -> printError e >> return (particle "ok"))+go x = x --catchError x (\e -> printError e >> return (particle "ok"))
src/Atomo/Types.hs view
@@ -1,22 +1,23 @@-{-# LANGUAGE BangPatterns, DeriveDataTypeable, TypeSynonymInstances #-}+{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances #-} module Atomo.Types where import Control.Concurrent (ThreadId) import Control.Concurrent.Chan import "monads-fd" Control.Monad.Cont-import "monads-fd" Control.Monad.Error import "monads-fd" Control.Monad.State import Data.Dynamic import Data.Hashable (hash)+import Data.List (nub)+import Data.Maybe (fromMaybe) import Data.IORef-import Data.Typeable import Text.Parsec (ParseError, SourcePos)+import Text.PrettyPrint (Doc) import qualified Data.IntMap as M import qualified Data.Text as T import qualified Data.Vector as V import qualified Language.Haskell.Interpreter as H -type VM = ErrorT AtomoError (ContT (Either AtomoError Value) (StateT Env IO))+type VM = ContT Value (StateT Env IO) data Value = Block !Value [Pattern] [Expr]@@ -129,6 +130,8 @@ | PETop | PEQuote | PEUnquote++ | PExpr Expr deriving (Show, Typeable) -- expressions@@ -180,6 +183,7 @@ } | EVM { eLocation :: Maybe SourcePos+ , ePretty :: Maybe Doc , eAction :: VM Value } | EQuote@@ -329,14 +333,10 @@ (==) (EList _ aes) (EList _ bes) = aes == bes (==) (EParticle _ ap') (EParticle _ bp) = ap' == bp (==) (ETop _) (ETop _) = True- (==) (EVM _ _) (EVM _ _) = False+ (==) (EVM {}) (EVM {}) = False (==) _ _ = False -instance Error AtomoError where- strMsg = Error . string-- instance Show Channel where show _ = "Channel" @@ -386,12 +386,12 @@ } -- | evaluate x with e as the environment-runWith :: VM Value -> Env -> IO (Either AtomoError Value)-runWith x e = evalStateT (runContT (runErrorT x) return) e+runWith :: VM Value -> Env -> IO Value+runWith x = evalStateT (runContT x return) -- | evaluate x with e as the environment-runVM :: VM Value -> Env -> IO (Either AtomoError Value, Env)-runVM x e = runStateT (runContT (runErrorT x) return) e+runVM :: VM Value -> Env -> IO (Value, Env)+runVM x = runStateT (runContT x return) -----------------------------------------------------------------------------@@ -410,14 +410,6 @@ {-# INLINE keyParticleN #-} keyParticleN ns vs = keyParticle ns (Nothing:map Just vs) -raise :: [String] -> [Value] -> VM a-{-# INLINE raise #-}-raise ns vs = throwError . Error $ keyParticleN ns vs--raise' :: String -> VM a-{-# INLINE raise' #-}-raise' = throwError . Error . particle- string :: String -> Value {-# INLINE string #-} string = String . T.pack@@ -426,20 +418,6 @@ {-# INLINE haskell #-} haskell = Haskell . toDyn -fromHaskell :: Typeable a => String -> Value -> VM a-fromHaskell t (Haskell d) =- case fromDynamic d of- Just a -> return a- Nothing -> throwError (DynamicNeeded t)-fromHaskell t _ = throwError (DynamicNeeded t)--fromHaskell' :: Typeable a => String -> Value -> a-fromHaskell' t (Haskell d) =- case fromDynamic d of- Just a -> a- Nothing -> error ("needed Haskell value of type " ++ t)-fromHaskell' t _ = error ("needed haskell value of type " ++ t)- list :: [Value] -> Value list = List . V.fromList @@ -566,3 +544,43 @@ isString :: Value -> Bool isString (String _) = True isString _ = False++asValue :: AtomoError -> Value+asValue (Error v) = v+asValue (ParseError pe) =+ keyParticleN ["parse-error"] [string (show pe)]+asValue (DidNotUnderstand m) =+ keyParticleN ["did-not-understand"] [Message m]+asValue (Mismatch pat v) =+ keyParticleN+ ["pattern", "did-not-match"]+ [Pattern pat, v]+asValue (ImportError (H.UnknownError s)) =+ keyParticleN ["unknown-hint-error"] [string s]+asValue (ImportError (H.WontCompile ges)) =+ keyParticleN ["wont-compile"] [list (nub $ map (string . H.errMsg) ges)]+asValue (ImportError (H.NotAllowed s)) =+ keyParticleN ["not-allowed"] [string s]+asValue (ImportError (H.GhcException s)) =+ keyParticleN ["ghc-exception"] [string s]+asValue (FileNotFound fn) =+ keyParticleN ["file-not-found"] [string fn]+asValue (ParticleArity e' g) =+ keyParticleN+ ["particle-needed", "given"]+ [Integer (fromIntegral e'), Integer (fromIntegral g)]+asValue (BlockArity e' g) =+ keyParticleN+ ["block-expected", "given"]+ [Integer (fromIntegral e'), Integer (fromIntegral g)]+asValue NoExpressions = particle "no-expressions"+asValue (ValueNotFound d v) =+ keyParticleN ["could-not-found", "in"] [string d, v]+asValue (DynamicNeeded t) =+ keyParticleN ["dynamic-needed"] [string t]++fromHaskell' :: Typeable a => String -> Value -> a+fromHaskell' t (Haskell d) =+ fromMaybe (error ("needed Haskell value of type " ++ t))+ (fromDynamic d)+fromHaskell' t _ = error ("needed haskell value of type " ++ t)
src/Atomo/VMT.hs view
@@ -1,7 +1,6 @@ module Atomo.VMT where import "monads-fd" Control.Monad.Cont-import "monads-fd" Control.Monad.Error import "monads-fd" Control.Monad.State import "monads-fd" Control.Monad.Trans @@ -9,43 +8,41 @@ newtype VMT m a = VMT- { runVMT :: Env -> m (Either AtomoError a, Env)+ { runVMT :: Env -> m (a, Env) } instance Monad m => Monad (VMT m) where x >>= f = VMT $ \e -> do- (ev, e') <- runVMT x e- case ev of- Right v -> runVMT (f v) e'- Left err -> return (Left err, e')+ (v, e') <- runVMT x e+ runVMT (f v) e' - return x = VMT $ \e -> return (Right x, e)+ return x = VMT $ \e -> return (x, e) instance MonadTrans VMT where lift m = VMT $ \e -> do a <- m- return (Right a, e)+ return (a, e) instance MonadIO m => MonadIO (VMT m) where liftIO f = VMT $ \e -> do x <- liftIO f- return (Right x, e)+ return (x, e) instance MonadCont m => MonadCont (VMT m) where callCC f = VMT $ \e ->- callCC $ \c -> runVMT (f (\a -> VMT (\e' -> c (Right a, e')))) e+ callCC $ \c -> runVMT (f (\a -> VMT (\e' -> c (a, e')))) e vm :: MonadIO m => VM Value -> VMT m Value-vm x = VMT (liftIO . runStateT (runContT (runErrorT x) return))+vm x = VMT (liftIO . runStateT (runContT x return)) vm_ :: MonadIO m => VM a -> VMT m () vm_ x = vm (x >> return (particle "ok")) >> return () getEnv :: Monad m => VMT m Env-getEnv = VMT $ \e -> return (Right e, e)+getEnv = VMT $ \e -> return (e, e) putEnv :: Monad m => Env -> VMT m ()-putEnv e = VMT $ \_ -> return (Right (), e)+putEnv e = VMT $ \_ -> return ((), e) -execVM :: Monad m => (VMT m a) -> Env -> (AtomoError -> m a) -> m a-execVM x e h = runVMT x e >>= either h return . fst+execVM :: Monad m => VMT m a -> Env -> m a+execVM x e = liftM fst (runVMT x e)
src/Atomo/Valuable.hs view
@@ -1,5 +1,6 @@ module Atomo.Valuable where +import Control.Monad (liftM) import "monads-fd" Control.Monad.Trans (liftIO) import Data.IORef import qualified Data.Text as T@@ -37,11 +38,11 @@ fromValue (Integer i) = return (fromIntegral i) instance Valuable a => Valuable [a] where- toValue xs = mapM toValue xs >>= return . list+ toValue xs = liftM list (mapM toValue xs) fromValue (List v) = mapM fromValue (V.toList v) instance Valuable a => Valuable (V.Vector a) where- toValue xs = V.mapM toValue xs >>= return . List+ toValue xs = liftM List (V.mapM toValue xs) fromValue (List v) = V.mapM fromValue v instance Valuable T.Text where
src/Main.hs view
@@ -1,20 +1,14 @@+{-# LANGUAGE QuasiQuotes #-} module Main where import "monads-fd" Control.Monad.Cont-import "monads-fd" Control.Monad.Error-import Data.Char (isSpace)-import Prelude hiding (catch)-import System.Console.Haskeline-import System.Directory (getHomeDirectory) import System.Environment (getArgs)-import System.FilePath -import Atomo.Environment+import Atomo import Atomo.Load import Atomo.Parser import Atomo.PrettyVM import Atomo.Run-import Atomo.Types main :: IO ()@@ -22,88 +16,35 @@ args <- getArgs case args of- r | null r || r == ["-d"] ->- exec (repl (r == ["-d"]))+ [] -> exec repl ("-e":expr:_) -> exec $ do ast <- continuedParse expr "<input>" r <- evalAll ast- p <- prettyVM r- liftIO (print p)+ d <- prettyVM r+ liftIO (putStrLn d) return (particle "ok") ("-s":expr:_) -> exec $ do ast <- continuedParse expr "<input>" evalAll ast- repl False+ repl ("-l":fn:_) -> exec $ do loadFile fn- repl False+ repl - (fn:_) | not (head fn == '-') ->+ (fn:_) | head fn /= '-' -> exec (loadFile fn) _ -> putStrLn . unlines $ [ "usage:" , "\tatomo\t\tstart the REPL"- , "\tatomo -d\tstart the REPL in quiet mode" , "\tatomo -e EXPR\tevaluate EXPR and output the result" , "\tatomo -s EXPR\tevaluate EXPR and start the REPL" , "\tatomo -l FILE\tload FILENAME and start the REPL" , "\tatomo FILE\texecute FILE" ] -repl :: Bool -> VM Value-repl quiet = do- home <- liftIO getHomeDirectory- repl' "" $ runInput home . withInterrupt- where- escape Interrupt = return Nothing-- runInput home = runInputT defaultSettings- { historyFile = Just (home </> ".atomo_history")- }-- repl' input r = do- me <- liftIO (catch (r $ getInputLine prompt) escape)-- case me of- Just blank | null (dropWhile isSpace blank) -> repl' input r- Just part | not (bracesBalanced $ input ++ part) ->- repl' (input ++ part) r- Just expr -> do- catchError- (evaluate expr >>= prettyVM >>= liftIO . print)- printError-- repl' "" r-- Nothing -> askQuit (repl' input r)- where- evaluate expr = parseInput (input ++ expr) >>= evalAll-- prompt- | quiet = ""- | null input = "> "- | otherwise = ". "-- askQuit c = do- r <- liftIO . runInputT defaultSettings $- getInputChar "really quit? (y/n) "-- case r of- Just 'y' -> return (particle "ok")- Just 'n' -> c- _ -> askQuit c-- bracesBalanced s = hangingBraces s == 0- where- hangingBraces :: String -> Int- hangingBraces [] = 0- hangingBraces (b:ss)- | b == '"' = hangingBraces (tail $ dropWhile (/= '"') ss)- | b == '\'' = hangingBraces (tail $ dropWhile (/= '\'') ss)- | b `elem` "([{" = 1 + hangingBraces ss- | b `elem` ")]}" = hangingBraces ss - 1- | otherwise = hangingBraces ss+repl :: VM Value+repl = eval [$e|Lobby clone repl|]