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