atomo 0.2.2.1 → 0.3
raw patch · 47 files changed
+1378/−1216 lines, 47 filesdep −monads-fddep ~text
Dependencies removed: monads-fd
Dependency ranges changed: text
Files
- atomo.cabal +5/−9
- prelude/association.atomo +0/−2
- prelude/block.atomo +8/−6
- prelude/boolean.atomo +24/−6
- prelude/condition.atomo +5/−5
- prelude/continuation.atomo +4/−58
- prelude/core.atomo +24/−34
- prelude/eco.atomo +8/−5
- prelude/errors.atomo +50/−0
- prelude/exception.atomo +2/−2
- prelude/numeric.atomo +5/−0
- prelude/parameter.atomo +0/−55
- prelude/ports.atomo +5/−22
- prelude/repl.atomo +1/−1
- prelude/string.atomo +18/−12
- prelude/version.atomo +5/−2
- src/Atomo.hs +3/−3
- src/Atomo/Core.hs +26/−9
- src/Atomo/Environment.hs +158/−143
- src/Atomo/Helpers.hs +68/−63
- src/Atomo/Kernel.hs +3/−225
- src/Atomo/Kernel/Block.hs +60/−0
- src/Atomo/Kernel/Continuation.hs +60/−4
- src/Atomo/Kernel/Expression.hs +79/−20
- src/Atomo/Kernel/List.hs +6/−7
- src/Atomo/Kernel/Method.hs +1/−1
- src/Atomo/Kernel/Nucleus.hs +104/−0
- src/Atomo/Kernel/Numeric.hs +0/−5
- src/Atomo/Kernel/Particle.hs +14/−6
- src/Atomo/Kernel/Pattern.hs +9/−13
- src/Atomo/Kernel/Ports.hs +11/−6
- src/Atomo/Kernel/String.hs +14/−15
- src/Atomo/Load.hs +1/−1
- src/Atomo/Method.hs +65/−30
- src/Atomo/Parser.hs +5/−5
- src/Atomo/Parser/Base.hs +6/−6
- src/Atomo/Parser/Expand.hs +126/−29
- src/Atomo/Parser/Expr.hs +55/−68
- src/Atomo/Pattern.hs +102/−100
- src/Atomo/Pretty.hs +69/−56
- src/Atomo/QuasiQuotes.hs +2/−2
- src/Atomo/Run.hs +2/−2
- src/Atomo/Spawn.hs +1/−1
- src/Atomo/Types.hs +153/−141
- src/Atomo/VMT.hs +9/−34
- src/Atomo/Valuable.hs +1/−1
- src/Main.hs +1/−1
atomo.cabal view
@@ -1,5 +1,5 @@ name: atomo-version: 0.2.2.1+version: 0.3 synopsis: A highly dynamic, extremely simple, very fun programming language. description:@@ -26,6 +26,7 @@ category: Language build-type: Custom stability: Experimental+tested-with: GHC >= 6 && < 7 cabal-version: >= 1.6 @@ -47,17 +48,14 @@ filepath, hashable, hint,- monads-fd, mtl, parsec >= 3.0.0, pretty, template-haskell,- text,+ text >= 0.11.0.0, time, vector - extensions: PackageImports- exposed-modules: Atomo, Atomo.Core,@@ -83,6 +81,7 @@ other-modules: Atomo.Debug, Atomo.Kernel,+ Atomo.Kernel.Nucleus, Atomo.Kernel.Numeric, Atomo.Kernel.List, Atomo.Kernel.String,@@ -110,8 +109,6 @@ ghc-options: -Wall -threaded -fno-warn-unused-do-bind -funfolding-use-threshold=9999 - extensions: PackageImports- build-depends: base >= 4 && < 5, containers,@@ -120,11 +117,10 @@ hashable, haskeline, hint,- monads-fd, mtl, parsec >= 3.0.0, pretty, template-haskell,- text,+ text >= 0.11.0.0, time, vector
prelude/association.atomo view
@@ -1,5 +1,3 @@-operator right 1 ->- Association = Object clone a -> b := Association clone do: { from = a; to = b }
prelude/block.atomo view
@@ -4,11 +4,6 @@ context Block: (es: List) arguments: (as: List) := Block new: es arguments: as in: context -(b: Block) repeat :=- { b in-context call- b repeat- } call- (b: Block) in-context := b clone do: { call := b call-in: b context@@ -16,7 +11,14 @@ } (start: Integer) to: (end: Integer) by: (diff: Integer) do: b :=- (start to: end by: diff) each: b+ { cc |+ n = start++ while: { (n - diff - end) abs >= diff abs } do: {+ b call: [n]+ n = n + diff+ }+ } call/cc (start: Integer) up-to: (end: Integer) do: b := start to: end by: 1 do: b
prelude/boolean.atomo view
@@ -18,7 +18,7 @@ if: False then: Block else: (b: Block) := b call -unless: True do: Block = @ok+unless: True do: Block := @ok unless: False do: (action: Block) := { action in-context call @ok@@ -26,7 +26,7 @@ macro (e unless: b) `(unless: ~b do: { ~e }) -when: False do: Block = @ok+when: False do: Block := @ok when: True do: (action: Block) := { action in-context call @ok@@ -35,10 +35,28 @@ macro (e when: b) `(when: ~b do: { ~e }) while: (test: Block) do: (action: Block) :=- when: test call do:- { action in-context call- while: test do: action- }+ { cc a |+ { (cc yield: @ok) unless: test call+ a call+ } repeat+ } call/cc: [action in-context]++(action: Block) while: (test: Block) :=+ { action in-context call+ while: test do: action+ } call++until: (test: Block) do: (action: Block) :=+ { cc a |+ { (cc yield: @ok) when: test call+ a call+ } repeat+ } 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"
prelude/condition.atomo view
@@ -1,4 +1,4 @@-for-macro Restart = Object clone+for-macro super Restart = Object clone { define: *handlers* as: [] define: *restarts* as: []@@ -30,10 +30,10 @@ (w: Simple-Warning) describe-error := w value describe-error Simple-Error new: v :=- Simple-Error clone do: { delegates-to: v; value = v }+ Simple-Error clone (delegating-to: v) do: { value = v } Simple-Warning new: v :=- Simple-Warning clone do: { delegates-to: v; value = 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 .. ">"@@ -70,7 +70,7 @@ } } call - (r: Restart) show := "<restart " .. r action show .. ">"+ (r: -> Restart) show := "<restart " .. r action show .. ">" macro (action with-restarts: (restarts: Block)) { rs = restarts contents map:@@ -149,6 +149,6 @@ `({ h a | with-handler: h do: a- } call: [{ #c | #c match: ~handler }, ~a])+ } call: [{ #c | super = super; #c match: ~handler }, ~a]) } call } call
prelude/continuation.atomo view
@@ -1,58 +1,4 @@-{ define: *dynamic-winds* as: []-- (o: Object) call/cc := o call/cc: []- (o: Object) call/cc: as :=- { cc |- winds = *dynamic-winds* _?-- new = cc clone do:- { yield: v :=- { dynamic-unwind: winds- delta: (*dynamic-winds* _? length - winds length)-- cc yield: v- } call- }-- o call: (new . as)- } raw-call/cc-- (v: Block) before: (b: Block) := v before: b after: { @ok }- (v: Block) after: (a: Block) := v before: { @ok } after: a-- (v: Block) before: (b: Block) after: (a: Block) :=- { b call-- *dynamic-winds* =! ((b -> a) . *dynamic-winds* _?)-- res = v call-- a call-- *dynamic-winds* =! *dynamic-winds* _? tail-- res- } call-- (init: Block) wrap: cleanup do: action :=- { action call: [x] } before: { x = init call } in-context after: { cleanup call: [x] }-- dynamic-unwind: to delta: d :=- condition: {- (*dynamic-winds* _? == to) -> @ok-- (d < 0) ->- { dynamic-unwind: to tail delta: (d + 1)- to head from call- *dynamic-winds* =! to- @ok- } call-- otherwise ->- { post = *dynamic-winds* _? head to- *dynamic-winds* =! *dynamic-winds* _? tail- post call- dynamic-unwind: to delta: (d - 1)- } call- }-} call+(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] }
prelude/core.atomo view
@@ -1,7 +1,8 @@-macro (x match: (ts: Block))- `Match new: (ts contents map: { `(~p -> ~e) | p -> e expand }) on: x+operator right 0 = := =!+operator right 1 -> -operator right 0 = :=+macro (x match: (ts: Block))+ `Match new: (ts contents map: { `(~p -> ~e) | p -> e expand }) on: x expand macro (p = e) `Set new: p to: e@@ -9,40 +10,29 @@ macro (p := e) `Define new: p as: e -@(parse-error: d) describe-error :=- "parse error:\n" .. (d indent: 2)--@(did-not-understand: m) describe-error :=- "message not understood: " .. m show--@(pattern: p did-not-match: v) describe-error :=- v show .. " did not match pattern: " .. p show--@(unknown-hint-error: d) describe-error :=- "unknown hint error:\n" .. (d indent: 2)--@(wont-compile: es) describe-error :=- "Haskell source won't compile:\n" .. es (map: @(indent: 2)) (join: "\n\n")--@(not-allowed: e) describe-error :=- "not allowed: " .. e--@(ghc-exception: e) describe-error :=- "GHC exception: " .. e+macro (define: (name: Dispatch) as: root)+ `({ ~name := ~name _?+ ~(`DefineDynamic new: name as: root)+ } call-in: this) -@(file-not-found: f) describe-error :=- "file not found: " .. f+macro (x _?)+ `GetDynamic new: x -@(particle-needed: n given: g) describe-error :=- "particle needed " .. n show .. " values to complete, given " .. g show+macro (x =! y)+ `SetDynamic new: x to: y -@(block-expected: e given: g) describe-error :=- "block expected " .. e show .. " arguments, given " .. g show+macro (with: x as: y do: b)+ `NewDynamic new: [x -> y] do: `(~b call) -@no-expressions describe-error := "no expressions to evaluate"+macro (with: (bs: List) do: action)+ `NewDynamic new: (bs contents map: { `(~a -> ~b) | a -> b }) do: `(~action call) -@(could-not-find: t in: v) describe-error :=- "could not find a " .. t .. " in: " .. v show+macro (modify: param as: change do: action)+ `(with: ~param as: (~change call: [~param _?]) do: ~action) -@(dynamic-needed: t) describe-error :=- "expecting Haskell value of type " .. t+macro (target slurp: filename)+ { src = File read: (super evaluate: filename)+ exprs = src parse-expressions+ blk = `Block new: exprs+ `(~blk call-in: ~target)+ } call
prelude/eco.atomo view
@@ -62,7 +62,7 @@ pkgs = versions map: { v | Eco Package load-from:- (eco </> c </> v </> "package.eco")+ (eco </> c </> v </> "package.eco") } c -> pkgs (sort-by: { a b | a version < b version })@@ -108,7 +108,7 @@ { e | exe = [ "#!/usr/bin/env atomo"- "load: " .. (path </> e to) show+ "require: " .. (".." </> "lib" </> pkg name </> pkg version (as: String) </> e to) show ] unlines with-output-to: (Eco executable: e from) do: { exe print }@@ -135,7 +135,7 @@ Eco uninstall: (name: String) := { Directory (contents: (Eco path-to: name)) each: { v |- Eco uninstall: name version: (v as: Version)+ Eco uninstall: name version: (v to: Version) } @ok@@ -164,7 +164,7 @@ { d | if: (d is-a?: Association) then: { d }- else: { d -> { True } }+ else: { d -> { any } } } (p: Eco Package) executables: (es: List) :=@@ -197,7 +197,7 @@ } context use: (name: String) :=- context use: name version: { True }+ context use: name version: { any } context use: (name: String) version: (v: Version) := context use: name version: (evaluate: `({ == ~v }))@@ -226,6 +226,9 @@ @(package-unavailable: name) describe-error := "package unavailable: " .. name++@(package-unavailable: name needed: constraint) describe-error :=+ "package unavailable: " .. name .. " (needed " .. constraint show .. ")" @(no-versions-of: pkg satisfy: check for: needer) describe-error := "no versions of '" .. pkg .. "' satisfy version constraint " .. check show .. " needed by " .. needer
+ prelude/errors.atomo view
@@ -0,0 +1,50 @@+@(did-not-understand: m) describe-error :=+ m type match: {+ @single ->+ [ "message " .. m particle show .. " not understood by:"+ m target show indent: 2+ ] join: "\n"++ @keyword ->+ [ "message " .. m particle show .. " not understood by targets:"+ m targets (map: @show) unlines indent: 2+ ] join: "\n"+ }++@(parse-error: d) describe-error :=+ "parse error:\n" .. (d indent: 2)++@(pattern: p did-not-match: v) describe-error :=+ v show .. " did not match pattern: " .. p show++@(unknown-hint-error: d) describe-error :=+ "unknown hint error:\n" .. (d indent: 2)++@(wont-compile: es) describe-error :=+ "Haskell source won't compile:\n" .. es (map: @(indent: 2)) (join: "\n\n")++@(not-allowed: e) describe-error :=+ "not allowed: " .. e++@(ghc-exception: e) describe-error :=+ "GHC exception: " .. e++@(file-not-found: f) describe-error :=+ "file not found: " .. f++@(particle-needed: n given: g) describe-error :=+ "particle needed " .. n show .. " values to complete, given " .. g show++@(block-expected: e given: g) describe-error :=+ "block expected " .. e show .. " arguments, given " .. g show++@no-expressions describe-error := "no expressions to evaluate"++@(could-not-find: t in: v) describe-error :=+ "could not find a " .. t .. " in: " .. v show++@(dynamic-needed: e got: g) describe-error :=+ "expected Haskell value of type:\n" .. (e indent: 2) .. "\nbut got value of type:\n" .. (g indent: 2)++@(dynamic-needed: e given: v) describe-error :=+ "expected Haskell value of type:\n" .. (e indent: 2) .. "\nbut given value:\n" .. (v show indent: 2)
prelude/exception.atomo view
@@ -1,9 +1,9 @@ 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))
prelude/numeric.atomo view
@@ -11,3 +11,8 @@ (x: Integer) divisible-by?: (y: Integer) := y divides?: x++(n: Number) abs :=+ if: (n < 0)+ then: { - n }+ else: { n }
− prelude/parameter.atomo
@@ -1,55 +0,0 @@-operator right 0 =!--Parameter = Object clone-Parameter new: v := Parameter clone do:- { default = v- }--(p: Parameter) value: _ := p default--macro (define: (x: Dispatch) as: root)- `(~x = Parameter new: ~root)--(p: Parameter) show :=- "<" .. p _? show .. ">"--(p: Parameter) _? := p value: self--((p: Parameter) =! v) :=- p value: self = v--(p: Parameter) set-default: v :=- p default = v--with: (p: Parameter) as: new do: (action: Block) :=- { old = p _?- action before: { p =! new } after: { p =! old }- } call--with-default: (p: Parameter) as: new do: (action: Block) :=- { old-default = p default- old = p _?- action before: { p set-default: new; p =! new } after: {- p set-default: old-default- p =! old- }- } call--macro (with: (bs: List) do: action)- bs contents- (reduce-right:- { `(~a -> ~b) x |- `{ with: ~a as: ~b do: ~x }- } with: action)- contents head--macro (with-defaults: (bs: List) do: action)- bs contents- (reduce-right:- { `(~a -> ~b) x |- `{ with-default: ~a as: ~b do: ~x }- } with: action)- contents head--macro (modify: param as: change do: action)- `(with: ~param as: (~change call: [~param _?]) do: ~action)
prelude/ports.atomo view
@@ -1,7 +1,9 @@-*history-file* = Parameter new: (Directory home </> ".atomo_history")-*output-port* = Parameter new: Port standard-output-*input-port* = Parameter new: Port standard-input+define: *history-file* as: (Directory home </> ".atomo_history")+define: *output-port* as: Port standard-output+define: *input-port* as: Port standard-input +current-history-file := *history-file* _?+ (x: Object) print := *output-port* _? print: x (x: Object) display := *output-port* _? display: x @@ -62,25 +64,6 @@ with-input-from: (p: Port) do: (b: Block) := with: *input-port* as: p do: b---with-all-output-to: (fn: String) do: b :=- { Port (new: fn mode: @write) } wrap: @close do:- { file |- with-all-output-to: file do: b- }--with-all-output-to: (p: Port) do: b :=- with-default: *output-port* as: p do: b--with-all-input-from: (fn: String) do: (b: Block) :=- { Port (new: fn mode: @read) } wrap: @close do:- { file |- with-all-input-from: file do: b- }--with-all-input-from: (p: Port) do: (b: Block) :=- with-default: *input-port* as: p do: b Directory copy: (from: String) to: (to: String) :=
prelude/repl.atomo view
@@ -32,7 +32,7 @@ @(special: n) -> when: (n all?: @digit?) do: {- r = Restart get: (n as: Integer)+ r = Restart get: (n to: Integer) r jump: (get-n-values: r action arguments length) } }
prelude/string.atomo view
@@ -5,23 +5,29 @@ (s: String) word-wrap: (length: Integer) := s lines- (map: { l | (l take-while: @space?) .. (wrap-line: l to: length) })+ (map: { l |+ if: (l all?: @space?)+ then: { l }+ else: { (l take-while: @space?) .. (wrap-line: l to: length acc: "") }+ }) unlines - wrap-line: l to: length :=+ wrap-line: "" to: _ acc: acc := acc+ wrap-line: l to: length acc: acc := { words = l words - line-length = 0+ condition: {+ acc empty? ->+ wrap-line: words tail unwords to: length acc: words head - ok-words =- words take-while:- { w |- line-length = line-length + 1 + w length- line-length < length- } in-context+ acc length > length ->+ acc .. "\n" .. (wrap-line: l to: length acc: "") - [ ok-words unwords- words (drop: ok-words length) unwords word-wrap: length- ] unlines strip-end+ acc length + 1 + words head length > length ->+ acc .. "\n" .. (wrap-line: words tail unwords to: length acc: words head)++ otherwise ->+ wrap-line: words tail unwords to: length acc: (acc .. " " .. words head)+ } } call } call
prelude/version.atomo view
@@ -18,10 +18,13 @@ (v: Version) as: String := v major show .. "." .. v minor (as: String) -(s: String) as: Version :=- s (split-on: $.) (map: @(as: Integer)) reduce-right: @.+(s: String) to: Version :=+ s (split-on: $.) (map: @(to: Integer)) reduce-right: @. (n: Integer) as: Version := n . 0++-- used for checking version satisfying constraint { any }+Version any = True (a: Version) == (b: Version) := a major == b major && a minor == b minor
src/Atomo.hs view
@@ -13,9 +13,9 @@ import Control.Concurrent import Control.Monad-import "monads-fd" Control.Monad.Cont (MonadCont(..), ContT(..))-import "monads-fd" Control.Monad.State (MonadState(..), StateT(..), evalStateT, gets, modify)-import "monads-fd" Control.Monad.Trans+import Control.Monad.Cont (MonadCont(..), ContT(..))+import Control.Monad.State (MonadState(..), StateT(..), evalStateT, gets, modify)+import Control.Monad.Trans import Atomo.Environment import Atomo.Helpers
src/Atomo/Core.hs view
@@ -1,9 +1,10 @@ module Atomo.Core where import Control.Concurrent-import "monads-fd" Control.Monad.State+import Control.Monad.State import Atomo.Types+import Atomo.Method import Atomo.Environment @@ -11,30 +12,46 @@ initCore :: VM () initCore = do -- the very root object- object <- newObject id+ object <- newObject [] noMethods -- top scope is a proto delegating to the root object- topObj <- newObject $ \o -> o { oDelegates = [object] }+ topObj <- newObject [object] noMethods+ modify $ \e -> e { top = topObj } -- Lobby is the very bottom scope object- define (psingle "Lobby" PThis) (Primitive Nothing topObj)+ define (single "Lobby" (PMatch topObj)) (Primitive Nothing topObj) -- define Object as the root object- define (psingle "Object" PThis) (Primitive Nothing object)+ define (single "Object" (PMatch topObj)) (Primitive Nothing object)++ -- create parser environment+ parserEnv <- newObject [topObj] noMethods+ modify $ \e -> e- { primitives = (primitives e) { idObject = rORef object }+ { primitives = (primitives e) { idObject = object }+ , parserState = (parserState e) { psEnvironment = parserEnv } } -- this thread's channel chan <- liftIO newChan modify $ \e -> e { channel = chan } + -- Numeric object; Integer and Double+ number <- newObject [object] noMethods++ -- define Object as the root object+ define (single "Number" (PMatch topObj)) (Primitive Nothing number)+ -- define primitive objects forM_ primObjs $ \(n, f) -> do- o <- newObject $ \o -> o { oDelegates = [object] }- define (psingle n PThis) (Primitive Nothing o)- modify $ \e -> e { primitives = f (primitives e) (rORef o) }+ o <-+ if n `elem` ["Integer", "Double"]+ then newObject [number] noMethods+ else newObject [object] noMethods++ define (single n (PMatch topObj)) (Primitive Nothing o)+ modify $ \e -> e { primitives = f (primitives e) o } where primObjs = [ ("Block", \is r -> is { idBlock = r })
src/Atomo/Environment.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE BangPatterns #-} module Atomo.Environment where -import "monads-fd" Control.Monad.Cont-import "monads-fd" Control.Monad.State+import Control.Monad.Cont+import Control.Monad.State import Data.IORef import Data.List (nub) @@ -13,14 +13,10 @@ -- | Evaluate an expression, yielding a value. eval :: Expr -> VM Value-eval (Define { ePattern = p, eExpr = ev }) = do+eval (Define { emPattern = p, eExpr = ev }) = do define p ev return (particle "ok")-eval (Set { ePattern = p@(PSingle {}), eExpr = ev }) = do- v <- eval ev- define p (Primitive (eLocation ev) v)- return v-eval (Set { ePattern = p@(PKeyword {}), eExpr = ev }) = do+eval (Set { ePattern = PMessage p, eExpr = ev }) = do v <- eval ev define p (Primitive (eLocation ev) v) return v@@ -28,19 +24,19 @@ v <- eval ev set p v eval (Dispatch- { eMessage = ESingle- { emID = i- , emName = n- , emTarget = t+ { eMessage = Single+ { mID = i+ , mName = n+ , mTarget = t } }) = do v <- eval t dispatch (Single i n v) eval (Dispatch- { eMessage = EKeyword- { emID = i- , emNames = ns- , emTargets = ts+ { eMessage = Keyword+ { mID = i+ , mNames = ns+ , mTargets = ts } }) = do vs <- mapM eval ts@@ -63,27 +59,11 @@ eval (EList { eContents = es }) = do vs <- mapM eval es return (list vs)-eval (EMacro { ePattern = p, eExpr = e }) = do- ps <- gets parserState- modify $ \s -> s- { parserState = ps- { psMacros =- case p of- PSingle {} ->- (addMethod (Macro p e) (fst (psMacros ps)), snd (psMacros ps))-- PKeyword {} ->- (fst (psMacros ps), addMethod (Macro p e) (snd (psMacros ps)))-- _ -> error $ "impossible: eval EMacro: p is " ++ show p- }- }-- return (particle "ok")+eval (EMacro {}) = return (particle "ok") eval (EForMacro {}) = return (particle "ok")-eval (EParticle { eParticle = EPMSingle n }) =+eval (EParticle { eParticle = PMSingle n }) = return (Particle $ PMSingle n)-eval (EParticle { eParticle = EPMKeyword ns mes }) = do+eval (EParticle { eParticle = PMKeyword ns mes }) = do mvs <- forM mes $ maybe (return Nothing) (liftM Just . eval) return (Particle $ PMKeyword ns mvs)@@ -103,6 +83,9 @@ 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 ne <- unquote n e return (d { eExpr = ne })@@ -111,13 +94,13 @@ return (s { eExpr = ne }) unquote n d@(Dispatch { eMessage = em }) = case em of- EKeyword { emTargets = ts } -> do+ Keyword { mTargets = ts } -> do nts <- mapM (unquote n) ts- return d { eMessage = em { emTargets = nts } }+ return d { eMessage = em { mTargets = nts } } - ESingle { emTarget = t } -> do+ Single { mTarget = t } -> do nt <- unquote n t- return d { eMessage = em { emTarget = nt } }+ return d { eMessage = em { mTarget = nt } } unquote n b@(EBlock { eContents = es }) = do nes <- mapM (unquote n) es return b { eContents = nes }@@ -129,18 +112,24 @@ return m { eExpr = ne } unquote n p@(EParticle { eParticle = ep }) = case ep of- EPMKeyword ns mes -> do+ PMKeyword ns mes -> do nmes <- forM mes $ \me -> case me of Nothing -> return Nothing Just e -> liftM Just (unquote n e) - return p { eParticle = EPMKeyword ns nmes }+ return p { eParticle = PMKeyword ns nmes } _ -> return p- unquote n q@(EQuote { eExpr = e }) = do- ne <- unquote (n + 1) e- return q { eExpr = ne }+ unquote n d@(ENewDynamic { eExpr = e }) = do+ ne <- unquote n e+ return d { eExpr = ne }+ unquote n d@(EDefineDynamic { eExpr = e }) = do+ ne <- unquote n e+ return d { eExpr = ne }+ unquote n d@(ESetDynamic { eExpr = e }) = do+ ne <- unquote n e+ return d { eExpr = ne } unquote n p@(Primitive { eValue = Expression e }) = do ne <- unquote n e return p { eValue = Expression ne }@@ -149,7 +138,34 @@ unquote _ v@(EVM {}) = return v unquote _ o@(Operator {}) = return o unquote _ f@(EForMacro {}) = return f+ unquote _ g@(EGetDynamic {}) = return g+eval (ENewDynamic { eBindings = bes, eExpr = e }) = do+ bvs <- forM bes $ \(n, b) -> do+ v <- eval b+ return (n, v) + dynamicBind bvs (eval e)+eval (EDefineDynamic { eName = n, eExpr = e }) = do+ v <- eval e++ modify $ \env -> env+ { dynamic = newDynamic n v (dynamic env)+ }++ return v+eval (ESetDynamic { eName = n, eExpr = e }) = do+ v <- eval e+ d <- gets dynamic++ if isBound n d+ then modify $ \env -> env { dynamic = setDynamic n v d }+ else raise ["unbound-dynamic"] [string n]++ return v+eval (EGetDynamic { eName = n }) = do+ mv <- gets (getDynamic n . dynamic)+ maybe (raise ["unknown-dynamic"] [string n]) return mv+ -- | Evaluate multiple expressions, returning the last result. evalAll :: [Expr] -> VM Value evalAll [] = throwError NoExpressions@@ -157,16 +173,14 @@ evalAll (e:es) = eval e >> evalAll es -- | Create a new empty object, passing a function to initialize it.-newObject :: (Object -> Object) -> VM Value-newObject f = liftM Reference . liftIO $- newIORef . f $ Object- { oDelegates = []- , oMethods = noMethods- }+newObject :: Delegates -> (MethodMap, MethodMap) -> VM Value+newObject ds mm = do+ ms <- liftIO (newIORef mm)+ return (Object ds ms) -- | Run x with t as its toplevel object. withTop :: Value -> VM a -> VM a-withTop t x = do+withTop !t x = do o <- gets top modify (\e -> e { top = t }) @@ -176,14 +190,25 @@ return res +dynamicBind :: [(String, Value)] -> VM a -> VM a+dynamicBind bs x = do+ modify $ \e -> e+ { dynamic = foldl (\m (n, v) -> bindDynamic n v m) (dynamic e) bs+ }++ res <- x++ modify $ \e -> e+ { dynamic = foldl (\m (n, _) -> unbindDynamic n m) (dynamic e) bs+ }++ return res+ -- | Execute an action with a new toplevel delegating to the old one. newScope :: VM a -> VM a newScope x = do t <- gets top- nt <- newObject $ \o -> o- { oDelegates = [t]- }-+ nt <- newObject [t] noMethods withTop nt x @@ -193,22 +218,21 @@ -- | Insert a method on a single value. defineOn :: Value -> Method -> VM ()-defineOn v m' = do- o <- orefFor v- obj <- liftIO (readIORef o)+defineOn v m' = liftIO $ do+ (oss, oks) <- readIORef (oMethods v) - let (oss, oks) = oMethods obj- ms (PSingle {}) = (addMethod m oss, oks)- ms (PKeyword {}) = (oss, addMethod m oks)- ms x = error $ "impossible: defining with pattern " ++ show x+ writeIORef (oMethods v) $+ case mPattern m of+ Single {} ->+ (addMethod m oss, oks) - liftIO . writeIORef o $- obj { oMethods = ms (mPattern m) }+ Keyword {} ->+ (oss, addMethod m oks) where m = m' { mPattern = setSelf v (mPattern m') } -- | Define a method on all roles involved in its pattern.-define :: Pattern -> Expr -> VM ()+define :: Message Pattern -> Expr -> VM () define !p !e = do is <- gets primitives newp <- matchable p@@ -216,35 +240,32 @@ os <- case p of- PKeyword { ppTargets = (t:_) } | isTop t ->- targets is (head (ppTargets newp))+ Keyword { mTargets = (PObject (ETop {}):_) } ->+ targets' is (head (mTargets newp)) _ -> targets is newp - forM_ os $ \o ->- defineOn (Reference o) m+ forM_ os (flip defineOn m) where- isTop PThis = True- isTop (PObject ETop {}) = True- isTop _ = False- method p' (Primitive _ 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 -> Pattern -> Pattern-setSelf v (PKeyword i ns ps) =- PKeyword i ns (map (setSelf v) ps)-setSelf v (PMatch x) | v == x = PThis-setSelf v (PNamed n p') =- PNamed n (setSelf v p')-setSelf v (PSingle i n t) =- PSingle i n (setSelf v t)-setSelf v (PInstance p) = PInstance (setSelf v p)-setSelf v (PStrict p) = PStrict (setSelf v p)-setSelf _ p' = p'+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' :: Value -> Pattern -> Pattern+setSelf' v (PMatch x) | v == x = PThis+setSelf' v (PMessage m) = PMessage $ setSelf v m+setSelf' v (PNamed n p') =+ PNamed n (setSelf' v p')+setSelf' v (PInstance p) = PInstance (setSelf' v p)+setSelf' v (PStrict p) = PStrict (setSelf' v p)+setSelf' _ p' = p' -- | Pattern-match a value, inserting bindings into the current toplevel. set :: Pattern -> Value -> VM Value@@ -260,42 +281,47 @@ -- | Turn any PObject patterns into PMatches.-matchable :: Pattern -> VM Pattern-matchable p'@(PSingle { ppTarget = t }) = do- t' <- matchable t- return p' { ppTarget = t' }-matchable p'@(PKeyword { ppTargets = ts }) = do- ts' <- mapM matchable ts- return p' { ppTargets = ts' }-matchable PThis = liftM PMatch (gets top)-matchable (PObject oe) = liftM PMatch (eval oe)-matchable (PInstance p) = liftM PInstance (matchable p)-matchable (PStrict p) = liftM PStrict (matchable p)-matchable (PNamed n p') = liftM (PNamed n) (matchable p')-matchable p' = return p'+matchable :: Message Pattern -> VM (Message Pattern)+matchable p'@(Single { mTarget = t }) = do+ t' <- matchable' t+ return p' { mTarget = t' }+matchable p'@(Keyword { mTargets = ts }) = do+ ts' <- mapM matchable' ts+ return p' { mTargets = ts' } +matchable' :: Pattern -> VM Pattern+matchable' PThis = liftM PMatch (gets top)+matchable' (PObject oe) = liftM PMatch (eval oe)+matchable' (PInstance p) = liftM PInstance (matchable' p)+matchable' (PStrict p) = liftM PStrict (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.-targets :: IDs -> Pattern -> VM [ORef]-targets _ (PMatch v) = liftM (: []) (orefFor v)-targets is (PSingle _ _ p) = targets is p-targets is (PKeyword _ _ ps) = do- ts <- mapM (targets is) ps+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 (PNamed _ p) = targets is p-targets is PAny = return [idObject is]-targets is (PList _) = return [idList is]-targets is (PHeadTail h t) = do- ht <- targets is h- tt <- targets is t++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 (PHeadTail h t) = do+ ht <- targets' is h+ tt <- targets' is t if idChar 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 _ p = error $ "no targets for " ++ show p+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 (PMessage m) = targets is m+targets' _ p = error $ "no targets for " ++ show p @@ -308,7 +334,7 @@ -- If the message is not understood, @\@did-not-understand:(at:)@ is sent to all -- roles until one responds to it. If none of them handle it, a -- @\@did-not-understand:@ error is raised.-dispatch :: Message -> VM Value+dispatch :: Message Value -> VM Value dispatch !m = do find <- findFirstMethod m (vs m) case find of@@ -345,17 +371,17 @@ -- | Find a method on object `o' that responds to `m', searching its -- delegates if necessary.-findMethod :: Value -> Message -> VM (Maybe Method)+findMethod :: Value -> Message Value -> VM (Maybe Method) findMethod v m = do is <- gets primitives- r <- orefFor v- o <- liftIO (readIORef r)- case relevant is r o m of+ o <- objectFor v+ ms <- liftIO (readIORef (oMethods o))+ case relevant is o ms m of Nothing -> findFirstMethod m (oDelegates o) mt -> return mt -- | Find the first value that has a method defiend for `m'.-findFirstMethod :: Message -> [Value] -> VM (Maybe Method)+findFirstMethod :: Message Value -> [Value] -> VM (Maybe Method) findFirstMethod _ [] = return Nothing findFirstMethod m (v:vs) = do r <- findMethod v m@@ -364,16 +390,16 @@ _ -> return r -- | Find a relevant method for message `m' on object `o'.-relevant :: IDs -> ORef -> Object -> Message -> Maybe Method-relevant ids r o m =- lookupMap (mID m) (methods m) >>= firstMatch ids (Just r) m+relevant :: IDs -> Value -> (MethodMap, MethodMap) -> Message Value -> Maybe Method+relevant ids o ms m =+ lookupMap (mID m) (methods m) >>= firstMatch ids (Just o) m where- methods (Single {}) = fst (oMethods o)- methods (Keyword {}) = snd (oMethods o)+ methods (Single {}) = fst ms+ methods (Keyword {}) = snd ms firstMatch _ _ _ [] = Nothing firstMatch ids' r' m' (mt:mts)- | match ids' r' (mPattern mt) (Message m') = Just mt+ | match ids' r' (PMessage (mPattern mt)) (Message m') = Just mt | otherwise = firstMatch ids' r' m' mts -- | Evaluate a method.@@ -385,31 +411,20 @@ -- -- Macro methods: evaluates its expression in a scope with the pattern's -- bindings.-runMethod :: Method -> Message -> VM Value+runMethod :: Method -> Message Value -> VM Value runMethod (Slot { mValue = v }) _ = return v runMethod (Responder { mPattern = p, mContext = c, mExpr = e }) m = do- nt <- newObject $ \o -> o- { oDelegates = [c]- , oMethods =- ( bindings p m- , emptyMap- )- }-+ nt <- newObject [c] (bindings p m, emptyMap) withTop nt $ eval e runMethod (Macro { mPattern = p, mExpr = e }) m = do- t <- gets top- nt <- newObject $ \o -> o- { oDelegates = [t]- , oMethods = (bindings p m, emptyMap)- }-+ t <- gets (psEnvironment . parserState)+ nt <- newObject [t] (bindings p m, emptyMap) withTop nt $ eval e -- | Get the object reference for a value.-orefFor :: Value -> VM ORef-{-# INLINE orefFor #-}-orefFor !v = gets primitives >>= \is -> return $ orefFrom is v+objectFor :: Value -> VM Value+{-# INLINE objectFor #-}+objectFor !v = gets primitives >>= \is -> return $ objectFrom is v -- | Raise a keyword particle as an error. raise :: [String] -> [Value] -> VM a
src/Atomo/Helpers.hs view
@@ -1,8 +1,8 @@+{-# LANGUAGE ScopedTypeVariables #-} module Atomo.Helpers where -import "monads-fd" Control.Monad.State+import Control.Monad.State import Data.Dynamic-import Data.IORef import qualified Data.Text as T import qualified Data.Vector as V @@ -15,39 +15,47 @@ infixr 0 =:, =:: -- | Define a method as an action returning a value.-(=:) :: Pattern -> VM Value -> VM ()+(=:) :: Message Pattern -> VM Value -> VM () pat =: vm = define pat (EVM Nothing Nothing vm) -- | Set a slot to a given value.-(=::) :: Pattern -> Value -> VM ()+(=::) :: Message Pattern -> Value -> VM () pat =:: v = define pat (Primitive Nothing v) -- | Define a method that evaluates e.-(=:::) :: Pattern -> Expr -> VM ()+(=:::) :: Message Pattern -> Expr -> VM () pat =::: e = define pat e +-- | Create an object with some slots.+newWith :: Expr -> [(String, Value)] -> VM Value+newWith e ss = do+ o <- eval e >>= dispatch . single "clone"++ forM_ ss $ \(n, v) ->+ define (single n (PMatch o)) (Primitive Nothing v)++ return o+ -- | Find a value, searching through an object's delegates, and throwing -- @\@could-not-find:in:@ if it is not found. findValue :: String -> (Value -> Bool) -> Value -> VM Value findValue _ t v | t v = return v-findValue d t v = findValue' t v >>= maybe die return+findValue d t v = maybe die return (findValue' t v) where die = throwError (ValueNotFound d v) -- | Same as `findValue', but returning Nothing instead of failing-findValue' :: (Value -> Bool) -> Value -> VM (Maybe Value)-findValue' t v | t v = return (Just v)-findValue' t (Reference r) = do- o <- liftIO (readIORef r)- findDels (oDelegates o)+findValue' :: (Value -> Bool) -> Value -> Maybe Value+findValue' t v | t v = Just v+findValue' t (Object { oDelegates = ds' }) =+ findFirst ds' where- findDels [] = return Nothing- findDels (d:ds) = do- f <- findValue' t d- case f of- Nothing -> findDels ds- Just v -> return (Just v)-findValue' _ _ = return Nothing+ findFirst [] = Nothing+ findFirst (d:ds) =+ case findValue' t d of+ Nothing -> findFirst ds+ Just v -> Just v+findValue' _ _ = Nothing -- | `findValue' for `Block' findBlock :: Value -> VM Value@@ -139,11 +147,11 @@ | isRational v = return v | otherwise = findValue "Rational" isRational v --- | `findValue' for `Reference'-findReference :: Value -> VM Value-findReference v- | isReference v = return v- | otherwise = findValue "Reference" isReference v+-- | `findValue' for `Object'+findObject :: Value -> VM Value+findObject v+ | isObject v = return v+ | otherwise = findValue "Object" isObject v -- | `findValue' for `String' findString :: Value -> VM Value@@ -189,11 +197,6 @@ ifE :: Expr -> VM a -> VM a -> VM a ifE = ifVM . eval --- | Get a value's object.-referenceTo :: Value -> VM Value-{-# INLINE referenceTo #-}-referenceTo = liftM Reference . orefFor- -- | Call a block with the given arguments. Creates a scope, checks that its -- argument patterns match, and executes it with the bindings. callBlock :: Value -> [Value] -> VM Value@@ -214,38 +217,22 @@ doBlock :: MethodMap -> Value -> [Expr] -> VM Value {-# INLINE doBlock #-} doBlock bms s es = do- blockScope <- newObject $ \o -> o- { oDelegates = [s]- , oMethods = (bms, emptyMap)- }-+ blockScope <- newObject [s] (bms, emptyMap) withTop blockScope (evalAll es) --- | Get the object backing a value.-objectFor :: Value -> VM Object-{-# INLINE objectFor #-}-objectFor v = orefFor v >>= liftIO . readIORef- -- | Does one value delegate to another?-delegatesTo :: Value -> Value -> VM Bool-delegatesTo f t = do- o <- objectFor f- delegatesTo' (oDelegates o)- where- delegatesTo' [] = return False- delegatesTo' (d:ds)- | t `elem` (d:ds) = return True- | otherwise = do- o <- objectFor d- delegatesTo' (oDelegates o ++ ds)+delegatesTo :: Value -> Value -> Bool+delegatesTo (Object { oDelegates = ds }) t =+ t `elem` ds || any (`delegatesTo` t) ds+delegatesTo _ _ = False -- | Is one value an instance of, equal to, or a delegation to another? -- -- For example, 1 is-a?: Integer, but 1 does not delegates-to?: Integer isA :: Value -> Value -> VM Bool isA x y = do- xr <- orefFor x- yr <- orefFor y+ xr <- objectFor x+ yr <- objectFor y if xr == yr then return True@@ -264,28 +251,46 @@ -- a string. -- -- If conversion fails, raises @\@dynamic-needed:@ with the given string.-fromHaskell :: Typeable a => String -> Value -> VM a-fromHaskell t (Haskell d) =+fromHaskell :: forall a. Typeable a => Value -> VM a+fromHaskell (Haskell d) = case fromDynamic d of Just a -> return a- Nothing -> raise ["dynamic-needed"] [string t]-fromHaskell t _ = raise ["dynamic-needed"] [string t]+ Nothing ->+ raise ["dynamic-needed", "got"]+ [ string (show (typeOf (undefined :: a)))+ , string (show (dynTypeRep d))+ ]+fromHaskell u =+ raise ["dynamic-needed", "given"]+ [string (show (typeOf (undefined :: a))), u] -- | Convert an Atomo Haskell dynamic value into its value, erroring on -- failure.-fromHaskell' :: Typeable a => String -> Value -> a-fromHaskell' t (Haskell d) =+fromHaskell' :: forall a. Typeable a => Value -> a+fromHaskell' (Haskell d) = case fromDynamic d of Just a -> a- Nothing -> error ("needed Haskell value of type " ++ t)-fromHaskell' t _ = error ("needed haskell value of type " ++ t)+ Nothing ->+ error $ unwords+ [ "needed Haskell value of type"+ , show (typeOf (undefined :: a))+ , "but got"+ , show (dynTypeRep d)+ ]+fromHaskell' v =+ error $ unwords+ [ "needed Haskell value of type"+ , show (typeOf (undefined :: a))+ , "but given value"+ , show v+ ] -- | `toPattern', raising @\@unknown-pattern:@ if conversion fails. toPattern' :: Expr -> VM Pattern toPattern' = tryPattern toPattern -- | `toDefinePattern', raising @\@unknown-pattern:@ if conversion fails.-toDefinePattern' :: Expr -> VM Pattern+toDefinePattern' :: Expr -> VM (Message Pattern) toDefinePattern' = tryPattern toDefinePattern -- | `toRolePattern', raising @\@unknown-pattern:@ if conversion fails.@@ -293,13 +298,13 @@ toRolePattern' = tryPattern toRolePattern -- | `toMacroPattern', raising @\@unknown-pattern:@ if conversion fails.-toMacroPattern' :: Expr -> VM Pattern+toMacroPattern' :: Expr -> VM (Message Pattern) toMacroPattern' = tryPattern toMacroPattern -- | Try a given pattern conversion, raising @\@unknown-pattern:@ if conversion -- fails.-tryPattern :: (Expr -> Maybe Pattern) -> Expr -> VM Pattern-tryPattern c e = +tryPattern :: (Expr -> Maybe p) -> Expr -> VM p+tryPattern c e = case c e of Nothing -> raise ["unknown-pattern"] [Expression e] Just p -> return p
src/Atomo/Kernel.hs view
@@ -1,16 +1,9 @@ {-# LANGUAGE QuasiQuotes #-} module Atomo.Kernel (load) where -import Data.IORef-import Data.List ((\\))-import Data.Maybe (isJust)--import Atomo-import Atomo.Load-import Atomo.Method-import Atomo.Pattern (bindings')-import Atomo.Pretty+import Atomo.Types +import qualified Atomo.Kernel.Nucleus as Nucleus import qualified Atomo.Kernel.Numeric as Numeric import qualified Atomo.Kernel.List as List import qualified Atomo.Kernel.String as String@@ -30,129 +23,7 @@ load :: VM () load = do- [$p|(x: Object) clone|] =: do- x <- here "x"- newObject $ \o -> o- { oDelegates = [x]- }-- [$p|(x: Object) copy|] =: do- x <- here "x" >>= objectFor- liftM Reference (liftIO $ newIORef x)-- [$p|(x: Object) copy: (diff: Block)|] =:::- [$e|x copy do: diff|]-- [$p|(x: Object) delegates-to: (y: Object)|] =: do- f <- here "x" >>= orefFor- t <- here "y"-- from <- liftIO (readIORef f)- liftIO $ writeIORef f (from { oDelegates = oDelegates from ++ [t] })-- return (particle "ok")-- [$p|(x: Object) delegates-to?: (y: Object)|] =: do- x <- here "x"- y <- here "y"- liftM Boolean (delegatesTo x y)-- [$p|(x: Object) delegates|] =: do- o <- here "x" >>= objectFor- return $ list (oDelegates o)-- [$p|(x: Object) with-delegates: (ds: List)|] =: do- ds <- getList [$e|ds|]- x <- here "x" >>= objectFor- newObject $ \o -> o- { oMethods = oMethods x- , oDelegates = ds- }-- [$p|(x: Object) super|] =::: [$e|x delegates head|]-- [$p|(x: Object) is-a?: (y: Object)|] =: do- x <- here "x"- y <- here "y"- liftM Boolean (isA x y)-- [$p|(x: Object) responds-to?: (p: Particle)|] =: do- 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-- liftM (Boolean . isJust) $ findMethod x completed-- [$p|(o: Object) methods|] =: do- o <- here "o" >>= objectFor- let (ss, ks) = oMethods o-- ([$p|ms|] =::) =<< eval [$e|Object clone|]- [$p|(ms) singles|] =:: list (map (list . map Method) (elemsMap ss))- [$p|(ms) keywords|] =:: list (map (list . map Method) (elemsMap ks))- here "ms"-- [$p|(x: Object) dump|] =: do- o <- here "x"- liftIO (print o)- return o-- [$p|(x: Object) describe-error|] =::: [$e|x as: String|]-- [$p|(s: String) as: String|] =::: [$e|s|]-- [$p|(x: Object) as: String|] =::: [$e|x show|]-- [$p|(x: Object) show|] =:- liftM (string . show . pretty) (here "x")-- [$p|(t: Object) load: (fn: String)|] =: do- t <- here "t"- fn <- getString [$e|fn|]-- modify $ \s -> s { top = t }-- loadFile fn-- return (particle "ok")-- [$p|(t: Object) require: (fn: String)|] =: do- t <- here "t"- fn <- getString [$e|fn|]-- modify $ \s -> s { top = t }-- requireFile fn-- return (particle "ok")-- [$p|v do: (b: Block)|] =: do- v <- here "v"- b <- here "b" >>= findBlock- joinWith v b []- return v- [$p|v do: (b: Block) with: (l: List)|] =: do- v <- here "v"- b <- here "b" >>= findBlock- as <- getList [$e|l|]- joinWith v b as- return v-- [$p|v join: (b: Block)|] =: do- v <- here "v"- b <- here "b" >>= findBlock- joinWith v b []- [$p|v join: (b: Block) with: (l: List)|] =: do- v <- here "v"- b <- here "b" >>= findBlock- as <- getList [$e|l|]- joinWith v b as--+ Nucleus.load Numeric.load List.load String.load@@ -169,96 +40,3 @@ Environment.load Continuation.load Char.load---joinWith :: Value -> Value -> [Value] -> VM Value-joinWith t (Block s ps bes) as- | length ps > length as =- throwError (BlockArity (length ps) (length as))- | null as || null ps =- case t of- Reference r -> do- Object ds ms <- objectFor t- blockScope <- newObject $ \o -> o- { oDelegates = ds ++ [s]- , oMethods = ms- }-- res <- withTop blockScope (evalAll bes)- new <- objectFor blockScope-- -- replace the old object with the new one- liftIO $ writeIORef r new- { oDelegates = oDelegates new \\ [s]- , oMethods = oMethods new- }-- finalize (rORef blockScope) new-- return res- _ -> do- blockScope <- newObject $ \o -> o- { oDelegates = [t, s]- }-- withTop blockScope (evalAll bes)- | otherwise = do- -- a toplevel scope with transient definitions- pseudoScope <- newObject $ \o -> o- { oMethods = (bs, emptyMap)- }-- case t of- Reference r -> do- Object ds ms <- objectFor t- -- the original prototype, but without its delegations- -- this is to prevent dispatch loops- doppelganger <- newObject $ \o -> o- { oMethods = ms- }-- -- the main scope, methods are taken from here and merged with- -- the originals. delegates to the pseudoscope and doppelganger- -- so it has their methods in scope, but definitions go here- blockScope <- newObject $ \o -> o- { oDelegates = pseudoScope : doppelganger : ds ++ [s]- }-- res <- withTop blockScope (evalAll bes)- new <- objectFor blockScope-- liftIO (writeIORef r new- { oDelegates = oDelegates new \\ [pseudoScope, doppelganger, s]- , oMethods = merge ms (oMethods new)- })-- finalize (rORef blockScope) new-- return res- _ -> do- blockScope <- newObject $ \o -> o- { oDelegates = [pseudoScope, t, s]- }-- withTop blockScope (evalAll bes)- where- bs = toMethods . concat $ zipWith bindings' ps as-- merge (os, ok) (ns, nk) =- ( foldl (flip addMethod) os (concat $ elemsMap ns)- , foldl (flip addMethod) ok (concat $ elemsMap nk)- )-- -- clear the toplevel object's methods and have it delegate to the updated- -- object- --- -- this is important because method definitions have this as their context,- -- so methods changed in the new object wouldn't otherwise be available to- -- them- finalize :: ORef -> Object -> VM ()- finalize r c = liftIO $ writeIORef r c- { oDelegates = t : oDelegates c- , oMethods = noMethods- }--joinWith _ v _ = error $ "impossible: joinWith on " ++ show v
src/Atomo/Kernel/Block.hs view
@@ -3,6 +3,8 @@ module Atomo.Kernel.Block (load) where import Atomo+import Atomo.Method+import Atomo.Pattern (bindings') load :: VM ()@@ -21,6 +23,10 @@ b <- here "b" >>= findBlock callBlock b [] + [$p|(b: Block) repeat|] =: do+ b@(Block c _ _) <- here "b" >>= findBlock+ withTop c (forever (callBlock b []))+ [$p|(b: Block) call: (l: List)|] =: do b <- here "b" >>= findBlock vs <- getList [$e|l|]@@ -42,3 +48,57 @@ [$p|(b: Block) contents|] =: do Block _ _ es <- here "b" >>= findBlock return $ list (map Expression es)++ [$p|v do: (b: Block)|] =: do+ v <- here "v"+ b <- here "b" >>= findBlock+ joinWith v b []+ return v+ [$p|v do: (b: Block) with: (l: List)|] =: do+ v <- here "v"+ b <- here "b" >>= findBlock+ as <- getList [$e|l|]+ joinWith v b as+ return v++ [$p|v join: (b: Block)|] =: do+ v <- here "v"+ b <- here "b" >>= findBlock+ joinWith v b []+ [$p|v join: (b: Block) with: (l: List)|] =: do+ v <- here "v"+ b <- here "b" >>= findBlock+ as <- getList [$e|l|]+ joinWith v b as+++joinWith :: Value -> Value -> [Value] -> VM Value+joinWith t (Block s ps bes) as+ | length ps > length as =+ throwError (BlockArity (length ps) (length as))++ | null as || null ps =+ case t of+ o@(Object { oDelegates = ds }) ->+ withTop (o { oDelegates = ds ++ [s] }) (evalAll bes)++ _ -> do+ blockScope <- newObject [t, s] noMethods+ withTop blockScope (evalAll bes)++ | otherwise = do+ -- argument bindings+ args <- newObject []+ ( toMethods . concat $ zipWith bindings' ps as+ , emptyMap+ )++ case t of+ o@(Object { oDelegates = ds }) ->+ withTop (o { oDelegates = args : ds ++ [s] })+ (evalAll bes)++ _ -> do+ blockScope <- newObject [args, t, s] noMethods+ withTop blockScope (evalAll bes)+joinWith _ v _ = error $ "impossible: joinWith on " ++ show v
src/Atomo/Kernel/Continuation.hs view
@@ -27,8 +27,64 @@ [$p|(c: Continuation) yield|] =::: [$e|c yield: @ok|] [$p|(c: Continuation) call|] =::: [$e|c yield: @ok|] - -- internal call/cc, quite unsafe (no unwinding)- [$p|(o: Object) raw-call/cc|] =: callCC $ \c -> do+ [$p|(o: Object) call/cc|] =::: [$e|o call/cc: []|]+ [$p|(o: Object) call/cc: (as: List)|] =: callCC $ \c -> do o <- here "o"- cr <- liftIO (newIORef c)- dispatch (keyword ["call"] [o, list [Continuation cr]])+ as <- getList [$e|as|]+ cr <- mkContinuation c+ dispatch (keyword ["call"] [o, list (Continuation cr:as)])++ [$p|(v: Block) before: (b: Block) after: (a: Block)|] =: do+ v <- here "v"+ b <- here "b"+ a <- here "a"++ dispatch (single "call" b)++ modify $ \env -> env { unwinds = (b, a) : unwinds env }++ res <- dispatch (single "call" v)++ dispatch (single "call" a)++ modify $ \env -> env { unwinds = tail (unwinds env) }++ return res++mkContinuation :: (Value -> VM Value) -> VM Continuation+mkContinuation c = do+ env <- get+ liftIO . newIORef $ \v -> do+ ws <- gets unwinds+ unwind (unwinds env) (length ws - length (unwinds env))++ modify $ \env' -> env'+ { top = top env+ , dynamic = dynamic env+ }++ put env+ c v++unwind :: [(Value, Value)] -> Int -> VM Value+unwind to d = do+ ws <- gets unwinds+ if ws == to+ then return (particle "ok")+ else do++ if d < 0+ then do+ unwind us (d + 1)+ dispatch (single "call" pre)+ modify $ \env -> env { unwinds = to }+ return (particle "ok")+ else do++ let post = snd (head ws)+ modify $ \env -> env { unwinds = tail (unwinds env) }+ dispatch (single "call" post)+ unwind to (d - 1)+ where+ (u:us) = to+ pre = fst u
src/Atomo/Kernel/Expression.hs view
@@ -5,7 +5,7 @@ import Text.PrettyPrint (Doc) import Atomo-import Atomo.Parser (parseInput, withParser)+import Atomo.Parser (parseInput) import Atomo.Parser.Expand import Atomo.Pattern (match) import Atomo.Pretty (pretty)@@ -16,9 +16,11 @@ [$p|`Block new: (es: List)|] =::: [$e|`Block new: es arguments: []|] [$p|`Block new: (es: List) arguments: (as: List)|] =: do es <- getList [$e|es|] >>= mapM findExpression- as <- getList [$e|as|] >>= mapM findExpression- return (Expression (EBlock Nothing (map fromPattern as) (map fromExpression es)))+ as <- getList [$e|as|] >>=+ mapM (\e -> findExpression e >>= toPattern' . fromExpression) + return (Expression (EBlock Nothing as (map fromExpression es)))+ [$p|`List new: (es: List)|] =: do es <- getList [$e|es|] >>= mapM findExpression return (Expression (EList Nothing (map fromExpression es)))@@ -47,6 +49,40 @@ p <- toDefinePattern' pat return (Expression $ Define Nothing p e) + [$p|`Dispatch new: (name: Particle) to: (targets: List)|] =: do+ Particle name <- here "name" >>= findParticle+ ts <- getList [$e|targets|] >>= mapM findExpression++ case name of+ PMSingle n ->+ return $ Expression (Dispatch Nothing (single n (fromExpression (head ts))))++ PMKeyword ns _ ->+ return $ Expression (Dispatch Nothing (keyword ns (map fromExpression ts)))++ [$p|`DefineDynamic new: (name: Expression) as: (root: Expression)|] =: do+ n <- here "name" >>= findExpression >>= toName . fromExpression+ Expression r <- here "root" >>= findExpression+ return . Expression $ EDefineDynamic Nothing n r++ [$p|`SetDynamic new: (name: Expression) to: (root: Expression)|] =: do+ n <- here "name" >>= findExpression >>= toName . fromExpression+ Expression r <- here "root" >>= findExpression+ return . Expression $ ESetDynamic Nothing n r++ [$p|`GetDynamic new: (name: Expression)|] =: do+ n <- here "name" >>= findExpression >>= toName . fromExpression+ return . Expression $ EGetDynamic Nothing n++ [$p|`NewDynamic new: (bindings: List) do: (expr: Expression)|] =: do+ ns <- getList [$e|bindings map: @from|]+ >>= mapM findExpression+ >>= mapM (toName . fromExpression)+ exprs <- liftM (map fromExpression) $ getList [$e|bindings map: @to|] >>= mapM findExpression++ Expression e <- here "expr" >>= findExpression+ return . Expression $ ENewDynamic Nothing (zip ns exprs) e+ [$p|(s: String) parse-expressions|] =: getString [$e|s|] >>= liftM (list . map Expression) . parseInput @@ -57,14 +93,14 @@ [$p|(e: Expression) expand|] =: do Expression e <- here "e" >>= findExpression- liftM Expression $ withParser (macroExpand e)+ liftM Expression $ macroExpand e [$p|(e: Expression) type|] =: do Expression e <- here "e" >>= findExpression case e of- Dispatch { eMessage = EKeyword {} } ->+ Dispatch { eMessage = Keyword {} } -> return (keyParticleN ["dispatch"] [particle "keyword"])- Dispatch { eMessage = ESingle {} } ->+ Dispatch { eMessage = Single {} } -> return (keyParticleN ["dispatch"] [particle "single"]) Define {} -> return (particle "define")@@ -80,16 +116,21 @@ EQuote {} -> return (particle "quote") EUnquote {} -> return (particle "unquote") - EParticle { eParticle = EPMKeyword _ _ } ->+ EParticle { eParticle = PMKeyword _ _ } -> return (keyParticleN ["particle"] [particle "keyword"])- EParticle { eParticle = EPMSingle _ } ->+ EParticle { eParticle = PMSingle _ } -> 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")+ [$p|(e: Expression) target|] =: do Expression e <- here "e" >>= findExpression case e of- Dispatch { eMessage = ESingle { emTarget = t } } ->+ Dispatch { eMessage = Single { mTarget = t } } -> return (Expression t) _ -> raise ["no-target-for"] [Expression e] @@ -97,16 +138,18 @@ Expression e <- here "e" >>= findExpression case e of- Dispatch { eMessage = EKeyword { emTargets = ts } } ->+ Dispatch { eMessage = Keyword { mTargets = ts } } -> return (list (map Expression ts))+ Dispatch { eMessage = Single { mTarget = t } } ->+ return $ list [Expression t] _ -> raise ["no-targets-for"] [Expression e] [$p|(e: Expression) name|] =: do Expression e <- here "e" >>= findExpression case e of- EParticle _ (EPMSingle n) -> return (string n)- Dispatch { eMessage = ESingle { emName = n } } ->+ EParticle _ (PMSingle n) -> return (string n)+ Dispatch { eMessage = Single { mName = n } } -> return (string n) _ -> raise ["no-name-for"] [Expression e] @@ -114,17 +157,29 @@ Expression e <- here "e" >>= findExpression case e of- EParticle _ (EPMKeyword ns _) ->+ EParticle _ (PMKeyword ns _) -> return (list (map string ns))- Dispatch { eMessage = EKeyword { emNames = ns } } ->+ Dispatch { eMessage = Keyword { mNames = ns } } -> return (list (map string ns)) _ -> raise ["no-names-for"] [Expression e] + [$p|(e: Expression) particle|] =: do+ Expression e <- here "e" >>= findExpression++ case e of+ Dispatch { eMessage = Keyword { mNames = ns } } ->+ return (keyParticle ns (replicate (fromIntegral $ length ns + 1) Nothing))++ Dispatch { eMessage = Single { mName = n } } ->+ return (particle n)++ _ -> raise ["no-particle-for"] [Expression e]+ [$p|(e: Expression) values|] =: do Expression e <- here "e" >>= findExpression case e of- EParticle { eParticle = EPMKeyword _ mes } ->+ EParticle { eParticle = PMKeyword _ mes } -> return . list $ map (maybe (particle "none") (keyParticleN ["ok"] . (:[]) . Expression))@@ -153,8 +208,8 @@ Expression e <- here "e" >>= findExpression case e of Set { ePattern = p } -> return (Pattern p)- Define { ePattern = p } -> return (Pattern p)- EMacro { ePattern = p } -> return (Pattern p)+ Define { emPattern = p } -> return (Pattern (PMessage p))+ EMacro { emPattern = p } -> return (Pattern (PMessage p)) _ -> raise ["no-pattern-for"] [Expression e] [$p|(e: Expression) expression|] =: do@@ -199,7 +254,7 @@ matchBranches :: IDs -> [(Pattern, Expr)] -> Value -> VM Value matchBranches _ [] v = raise ["no-match-for"] [v] matchBranches ids ((p, e):ps) v = do- p' <- matchable p+ p' <- matchable' p if match ids Nothing p' v then newScope $ set p' v >> eval e else matchBranches ids ps v@@ -207,7 +262,11 @@ prettyMatch :: Expr -> [(Expr, Expr)] -> Doc prettyMatch t bs = pretty . Dispatch Nothing $- ekeyword ["match"] [t, EBlock Nothing [] branches]+ keyword ["match"] [t, EBlock Nothing [] branches] where branches = flip map bs $ \(p, e) ->- Dispatch Nothing $ ekeyword ["->"] [p, e]+ Dispatch Nothing $ keyword ["->"] [p, e]++toName :: Expr -> VM String+toName (Dispatch { eMessage = Single { mName = n } }) = return n+toName x = raise ["unknown-dynamic-name"] [Expression x]
src/Atomo/Kernel/List.hs view
@@ -80,11 +80,10 @@ Integer n <- here "n" >>= findInteger return . List $ V.replicate (fromIntegral n) v - [$p|b repeat: (n: Integer)|] =: do- b <- here "b"+ [$p|(b: Block) repeat: (n: Integer)|] =: do+ b <- here "b" >>= findBlock Integer n <- here "n" >>= findInteger- vs <- V.replicateM (fromIntegral n) $- dispatch (single "call" b)+ vs <- V.replicateM (fromIntegral n) (callBlock b []) return $ List vs [$p|(a: List) .. (b: List)|] =: do@@ -360,7 +359,7 @@ splitOn d vs' = splitOn' vs' [] where splitOn' [] acc = [acc]- splitOn' vs acc- | d `isPrefixOf` vs = acc : splitOn' (drop (length d) vs) []- | otherwise = splitOn' (tail vs) (acc ++ [head vs])+ splitOn' a@(v:vs) acc+ | d `isPrefixOf` a = acc : splitOn' (drop (length d) a) []+ | otherwise = splitOn' vs (acc ++ [v])
src/Atomo/Kernel/Method.hs view
@@ -12,7 +12,7 @@ [$p|(m: Method) pattern|] =: do Method m <- here "m" >>= findMethod'- return (Pattern (mPattern m))+ return (Pattern (PMessage (mPattern m))) [$p|(m: Method) expression|] =: do Method m <- here "m" >>= findMethod'
+ src/Atomo/Kernel/Nucleus.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE QuasiQuotes #-}+module Atomo.Kernel.Nucleus where++import Data.IORef+import Data.Maybe (isJust)++import Atomo+import Atomo.Load+import Atomo.Method+import Atomo.Pretty++load :: VM ()+load = do+ [$p|(x: Object) clone|] =: do+ x <- here "x"+ newObject [x] noMethods++ [$p|(x: Object) copy|] =: do+ x <- here "x" >>= objectFor+ ms <- liftIO (readIORef (oMethods x))+ liftM (Object (oDelegates x)) (liftIO (newIORef ms))++ [$p|(x: Object) copy: (diff: Block)|] =:::+ [$e|x copy do: diff|]++ [$p|(x: Object) delegating-to: (y: Object)|] =: do+ f <- here "x" >>= objectFor+ t <- here "y"++ return f+ { oDelegates = oDelegates f ++ [t]+ }++ [$p|(x: Object) delegates-to?: (y: Object)|] =: do+ x <- here "x"+ y <- here "y"+ return (Boolean (delegatesTo x y))++ [$p|(x: Object) delegates|] =: do+ o <- here "x" >>= objectFor+ return $ list (oDelegates o)++ [$p|(x: Object) with-delegates: (ds: List)|] =: do+ ds <- getList [$e|ds|]+ x <- here "x" >>= objectFor+ return x { oDelegates = ds }++ [$p|(x: Object) super|] =::: [$e|x delegates head|]++ [$p|(x: Object) is-a?: (y: Object)|] =: do+ x <- here "x"+ y <- here "y"+ liftM Boolean (isA x y)++ [$p|(x: Object) responds-to?: (p: Particle)|] =: do+ 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++ liftM (Boolean . isJust) $ findMethod x completed++ [$p|(o: Object) methods|] =: do+ o <- here "o" >>= objectFor+ (ss, ks) <- liftIO (readIORef (oMethods o))++ [$e|Object|] `newWith`+ [ ("singles", list (map (list . map Method) (elemsMap ss)))+ , ("keywords", list (map (list . map Method) (elemsMap ks)))+ ]++ [$p|(x: Object) dump|] =: do+ o <- here "x"+ liftIO (print o)+ return o++ [$p|(x: Object) describe-error|] =::: [$e|x as: String|]++ [$p|(s: String) as: String|] =::: [$e|s|]++ [$p|(x: Object) as: String|] =::: [$e|x show|]++ [$p|(x: Object) show|] =:+ liftM (string . show . pretty) (here "x")++ [$p|(t: Object) load: (fn: String)|] =: do+ t <- here "t"+ fn <- getString [$e|fn|]++ withTop t (loadFile fn)++ return (particle "ok")++ [$p|(t: Object) require: (fn: String)|] =: do+ t <- here "t"+ fn <- getString [$e|fn|]++ withTop t (requireFile fn)++ return (particle "ok")+
src/Atomo/Kernel/Numeric.hs view
@@ -14,11 +14,6 @@ , [$e|operator 6 + -|] ] - eval [$e|Object clone|] >>= ([$p|Number|] =::)-- eval [$e|Integer delegates-to: Number|]- eval [$e|Double delegates-to: Number|]- [$p|(i: Integer) sqrt|] =: do Integer i <- here "i" >>= findInteger return (Double (sqrt (fromIntegral i)))
src/Atomo/Kernel/Particle.hs view
@@ -7,6 +7,14 @@ load :: VM () load = do+ [$p|(p: Particle) new: (name: String)|] =: do+ n <- getString [$e|name|]+ return (particle n)++ [$p|(p: Particle) new: (names: List)|] =: do+ ns <- liftM (map (fromText . fromString)) $ getList [$e|names|]+ return (keyParticle ns (replicate (length ns + 1) Nothing))+ [$p|(p: Particle) call: (targets: List)|] =::: [$e|(p complete: targets) dispatch|] @@ -62,15 +70,15 @@ main = toPattern v ids <- gets primitives- obj <- targets ids main+ obj <- targets' ids main pat <- matchable $ case p of PMKeyword ns _ ->- pkeyword ns (main:others)+ keyword ns (main:others) PMSingle n ->- psingle n main+ single n main let m = case e of@@ -78,7 +86,7 @@ _ -> Slot pat v forM_ obj $ \o ->- defineOn (Reference o) m+ defineOn o m return (particle "ok") @@ -101,9 +109,9 @@ withTop c $ do case p of PMKeyword ns _ ->- define (pkeyword ns targets) expr+ define (keyword ns targets) expr PMSingle n ->- define (psingle n (head targets)) expr+ define (single n (head targets)) expr return (particle "ok")
src/Atomo/Kernel/Pattern.hs view
@@ -24,35 +24,35 @@ [$p|(e: Expression) as: Pattern Define|] =: do Expression e <- here "e" >>= findExpression p <- toDefinePattern' e- return (Pattern p)+ return (Pattern (PMessage p)) [$p|(p: Pattern) name|] =: do Pattern p <- here "p" >>= findPattern case p of PNamed n _ -> return (string n)- PSingle { ppName = n } -> return (string n)+ PMessage (Single { mName = n }) -> return (string n) _ -> raise ["no-name-for"] [Pattern p] [$p|(p: Pattern) names|] =: do Pattern p <- here "p" >>= findPattern case p of- PKeyword { ppNames = ns } -> return $ list (map string ns)+ PMessage (Keyword { mNames = ns }) -> return $ list (map string ns) _ -> raise ["no-names-for"] [Pattern p] [$p|(p: Pattern) target|] =: do Pattern p <- here "p" >>= findPattern case p of- PSingle { ppTarget = t } -> return (Pattern t)+ PMessage (Single { mTarget = t }) -> return (Pattern t) _ -> raise ["no-target-for"] [Pattern p] [$p|(p: Pattern) targets|] =: do Pattern p <- here "p" >>= findPattern case p of- PKeyword { ppTargets = ts } -> return $ list (map Pattern ts)+ PMessage (Keyword { mTargets = ts }) -> return $ list (map Pattern ts) _ -> raise ["no-targets-for"] [Pattern p] [$p|(p: Pattern) matches?: v|] =: do@@ -68,14 +68,10 @@ else return (particle "no") [$p|top match: (p: Pattern) on: v|] =: do- p <- here "p" >>= findPattern >>= matchable . fromPattern+ p <- here "p" >>= findPattern >>= matchable' . fromPattern v <- here "v" t <- here "top" - let isMethod (PSingle {}) = True- isMethod (PKeyword {}) = True- isMethod _ = False-- if isMethod p- then define p (Primitive Nothing v) >> return v- else withTop t (set p v)+ case p of+ PMessage m -> define m (Primitive Nothing v) >> return v+ _ -> withTop t (set p v)
src/Atomo/Kernel/Ports.hs view
@@ -85,8 +85,8 @@ parsed <- continuedParse segment "<read>" let isPrimitive (Primitive {}) = True- isPrimitive (EParticle { eParticle = EPMSingle _ }) = True- isPrimitive (EParticle { eParticle = EPMKeyword _ ts }) =+ isPrimitive (EParticle { eParticle = PMSingle _ }) = True+ isPrimitive (EParticle { eParticle = PMKeyword _ ts }) = all isPrimitive (catMaybes ts) isPrimitive (EList { eContents = ts }) = all isPrimitive ts isPrimitive _ = False@@ -154,7 +154,12 @@ [$p|File delete: (fn: String)|] =: do fn <- getString [$e|fn|]- liftIO (removeFile fn)+ b <- liftIO (doesFileExist fn)++ if b+ then liftIO (removeFile fn)+ else raise ["file-not-found"] [string fn]+ return (particle "ok") [$p|File move: (from: String) to: (to: String)|] =:::@@ -308,7 +313,7 @@ [$p|interaction: (prompt: String)|] =: do prompt <- getString [$e|prompt|]- history <- getString [$e|*history-file* _?|]+ history <- getString [$e|current-history-file|] line <- liftIO $ Haskeline.catch (liftM Just $ runInput history (getInputLine prompt))@@ -327,12 +332,12 @@ portObj hdl = newScope $ do port <- eval [$e|Port clone|] - define (psingle "handle" (PMatch port))+ define (single "handle" (PMatch port)) (Primitive Nothing $ haskell hdl) return port - getHandle ex = eval ex >>= fromHaskell "Handle"+ getHandle ex = eval ex >>= fromHaskell hGetSegment :: Handle -> IO String hGetSegment h = dropSpaces >> hGetSegment' Nothing
src/Atomo/Kernel/String.hs view
@@ -13,23 +13,22 @@ [$p|(s: String) as: List|] =: liftM (list . map Char) (getString [$e|s|]) - -- TODO: rename these to @read: or @to:- [$p|(s: String) as: Char|] =: do+ [$p|(s: String) to: Char|] =: do s <- getString [$e|s|] case s of "$'" -> return (Char '\'') '$':rest -> return (Char (read $ "'" ++ rest ++ "'"))- _ -> raise ["invalid-string"] [String $ T.pack s]- - [$p|(s: String) as: Integer|] =: do+ _ -> raise ["invalid-string"] [string s]++ [$p|(s: String) to: Integer|] =: do s <- getString [$e|s|] return (Integer (read s))- - [$p|(s: String) as: Double|] =: do++ [$p|(s: String) to: Double|] =: do s <- getString [$e|s|] return (Double (read s))- - [$p|(s: String) as: Rational|] =: do++ [$p|(s: String) to: Rational|] =: do s <- getString [$e|s|] let num = read $ takeWhile (/= '/') s denom = read . tail $ dropWhile (/= '/') s@@ -157,14 +156,14 @@ [$p|(s: String) split: (d: String)|] =: do s <- getText [$e|s|] d <- getText [$e|d|]- return $ list (map String (T.split d s))+ return $ list (map String (T.splitOn d s)) -- TODO: split-by [$p|(s: String) split-on: (d: Char)|] =: do s <- getText [$e|s|] Char d <- here "d" >>= findChar- return $ list (map String (T.splitBy (== d) s))+ return $ list (map String (T.split (== d) s)) [$p|(s: String) split-at: (n: Integer)|] =: do Integer n <- here "n" >>= findInteger@@ -172,16 +171,16 @@ let (a, b) = T.splitAt (fromIntegral n) s return $ list [String a, String b] - [$p|(s: String) break-on: (d: Integer)|] =: do+ [$p|(s: String) break-on: (d: String)|] =: do s <- getText [$e|s|] d <- getText [$e|d|]- let (a, b) = T.break d s+ let (a, b) = T.breakOn d s return $ list [String a, String b] - [$p|(s: String) break-end: (d: Integer)|] =: do+ [$p|(s: String) break-end: (d: String)|] =: do s <- getText [$e|s|] d <- getText [$e|d|]- let (a, b) = T.breakEnd d s+ let (a, b) = T.breakOnEnd d s return $ list [String a, String b] [$p|(s: String) group|] =: do
src/Atomo/Load.hs view
@@ -1,6 +1,6 @@ module Atomo.Load where -import "monads-fd" Control.Monad.State+import Control.Monad.State import System.Directory import System.FilePath import qualified Language.Haskell.Interpreter as H
src/Atomo/Method.hs view
@@ -10,17 +10,16 @@ , toMethods ) where -import Data.IORef import Data.List (elemIndices)-import System.IO.Unsafe+import Data.Maybe (isJust) import qualified Data.IntMap as M import Atomo.Types -- referring to the left side:--- LT = higher-precision--- GT = lower-precision+-- LT = is higher-precision+-- GT = is lower-precision comparePrecision :: Pattern -> Pattern -> Ordering comparePrecision (PNamed _ a) (PNamed _ b) = comparePrecision a b@@ -28,9 +27,9 @@ comparePrecision a (PNamed _ b) = comparePrecision a b comparePrecision PAny PAny = EQ comparePrecision PThis PThis = EQ-comparePrecision (PMatch (Reference a)) (PMatch (Reference b))- | unsafeDelegatesTo (Reference a) (Reference b) = LT- | unsafeDelegatesTo (Reference a) (Reference b) = GT+comparePrecision (PMatch a@(Object {})) (PMatch b@(Object {}))+ | delegatesTo a b = LT+ | delegatesTo a b = GT | otherwise = EQ comparePrecision (PMatch _) (PMatch _) = EQ comparePrecision (PList as) (PList bs) =@@ -39,17 +38,20 @@ comparePrecisions as bs comparePrecision (PHeadTail ah at) (PHeadTail bh bt) = comparePrecisions [ah, at] [bh, bt]-comparePrecision (PSingle { ppTarget = at }) (PSingle { ppTarget = bt }) =+comparePrecision (PMessage (Single { mTarget = at })) (PMessage (Single { mTarget = bt })) = comparePrecision at bt-comparePrecision (PKeyword { ppTargets = as }) (PKeyword { ppTargets = bs }) =+comparePrecision (PMessage (Keyword { mTargets = as })) (PMessage (Keyword { mTargets = bs })) = compareHeads as bs comparePrecision (PObject _) (PObject _) = EQ comparePrecision PAny _ = GT comparePrecision _ PAny = LT-comparePrecision PThis (PMatch (Reference _)) = LT-comparePrecision (PMatch (Reference _)) PThis = GT+comparePrecision PThis (PMatch (Object {})) = LT+comparePrecision (PMatch (Object {})) PThis = GT comparePrecision (PMatch _) _ = LT comparePrecision _ (PMatch _) = GT+comparePrecision (PExpr a) (PExpr b) = exprPrecision 0 a b+comparePrecision (PExpr _) _ = LT+comparePrecision _ (PExpr _) = GT comparePrecision (PList _) _ = LT comparePrecision _ (PList _) = GT comparePrecision (PPMKeyword _ _) _ = LT@@ -71,44 +73,77 @@ compareHeads a b = error $ "impossible: compareHeads on " ++ show (a, b) comparePrecisions :: [Pattern] -> [Pattern] -> Ordering-comparePrecisions as bs =+comparePrecisions = comparePrecisionsWith comparePrecision++comparePrecisionsWith :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering+comparePrecisionsWith cmp as bs = compare gt lt where- compared = zipWith comparePrecision as bs+ compared = zipWith cmp as bs gt = length $ elemIndices GT compared lt = length $ elemIndices LT compared -unsafeDelegatesTo :: Value -> Value -> Bool-unsafeDelegatesTo (Reference f) t =- t `elem` ds || any (`unsafeDelegatesTo` t) ds+delegatesTo :: Value -> Value -> Bool+delegatesTo (Object { oDelegates = ds }) t =+ t `elem` ds || any (`delegatesTo` t) ds+delegatesTo _ _ = False++exprPrecision :: Int -> Expr -> Expr -> Ordering+exprPrecision 0 (EUnquote {}) (EUnquote {}) = EQ+exprPrecision 0 (EUnquote {}) _ = GT+exprPrecision 0 _ (EUnquote {}) = LT+exprPrecision n (Define { eExpr = a }) (Define { eExpr = b }) =+ exprPrecision n a b+exprPrecision n (Set { eExpr = a }) (Set { eExpr = b }) =+ exprPrecision n a b+exprPrecision n (Dispatch { eMessage = am@(Keyword {}) }) (Dispatch { eMessage = bm@(Keyword {}) }) =+ comparePrecisionsWith (exprPrecision n) (mTargets am) (mTargets bm)+exprPrecision n (Dispatch { eMessage = am@(Single {}) }) (Dispatch { eMessage = bm@(Single {}) }) =+ exprPrecision n (mTarget am) (mTarget bm)+exprPrecision n (EBlock { eContents = as }) (EBlock { eContents = bs }) =+ comparePrecisionsWith (exprPrecision n) as bs+exprPrecision n (EList { eContents = as }) (EList { eContents = bs }) =+ comparePrecisionsWith (exprPrecision n) as bs+exprPrecision n (EMacro { eExpr = a }) (EMacro { eExpr = b }) =+ exprPrecision n a b+exprPrecision n (EParticle { eParticle = ap' }) (EParticle { eParticle = bp }) =+ case (ap', bp) of+ (PMKeyword _ ames, PMKeyword _ bmes) ->+ comparePrecisionsWith (exprPrecision n) (firsts ames bmes) (seconds ames bmes)+ _ -> EQ where- ds = oDelegates (unsafePerformIO (readIORef f))-unsafeDelegatesTo _ _ = False+ pairs ames bmes = map (\(Just a, Just b) -> (a, b)) $ filter (\(a, b) -> isJust a && isJust b) $ zip ames bmes + firsts ames = fst . unzip . pairs ames+ seconds ames = fst . unzip . pairs ames+exprPrecision n (EQuote { eExpr = a }) (EQuote { eExpr = b }) =+ exprPrecision (n + 1) a b+exprPrecision _ _ _ = EQ++ -- | Insert a method into a MethodMap based on its pattern's ID and precision. addMethod :: Method -> MethodMap -> MethodMap addMethod m mm = M.insertWith (\[m'] ms -> insertMethod m' ms) key [m] mm where- key = ppID (mPattern m)+ key = mID $ mPattern m -- | Insert a method into a list of existing methods most precise goes first, -- equivalent patterns are replaced. insertMethod :: Method -> [Method] -> [Method] insertMethod x [] = [x]-insertMethod x ys@(y:ys') =- case comparePrecision (mPattern x) (mPattern y) of- -- stop at LT so it's after all of the definitons before this one- LT -> x : ys-- -- replace equivalent patterns- _ | mPattern x == mPattern y -> insertMethod x ys'+insertMethod x (y:ys)+ | mPattern x == 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+ LT -> x : y : ys - -- keep looking if we're EQ or GT- _ -> y : insertMethod x ys'+ -- keep looking if we're EQ or GT+ _ -> y : insertMethod x ys -- | Convert a list of slots to a MethodMap.-toMethods :: [(Pattern, Value)] -> MethodMap+toMethods :: [(Message Pattern, Value)] -> MethodMap toMethods = foldl (\ss (p, v) -> addMethod (Slot p v) ss) emptyMap -- | A pair of two empty MethodMaps; one for single methods and one for keyword@@ -137,4 +172,4 @@ insertMap :: Method -> MethodMap -> MethodMap insertMap m mm = M.insert key [m] mm where- key = ppID (mPattern m)+ key = mID $ mPattern m
src/Atomo/Parser.hs view
@@ -1,6 +1,6 @@ module Atomo.Parser where -import "monads-fd" Control.Monad.State+import Control.Monad.State import Text.Parsec import Atomo.Environment@@ -14,19 +14,19 @@ parseFile :: FilePath -> VM [Expr] parseFile fn = liftIO (readFile fn)- >>= continue (fileParser >>= mapM macroExpand) fn+ >>= continue fileParser fn+ >>= nextPhase -- | Parses an input string, performs macro expansion, and returns an AST. parseInput :: String -> VM [Expr]-parseInput = continue (parser >>= mapM macroExpand) "<input>"+parseInput s = continue 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 ps <- gets parserState- r <- runParserT (p >>= \r -> getState >>= \ps' -> return (r, ps')) ps s i- case r of+ case runParser (p >>= \r -> getState >>= \ps' -> return (r, ps')) ps s i of Left e -> throwError (ParseError e) Right (ok, ps') -> do modify $ \e -> e { parserState = ps' }
src/Atomo/Parser/Base.hs view
@@ -1,16 +1,16 @@ {-# OPTIONS -fno-warn-name-shadowing #-} module Atomo.Parser.Base where -import Control.Monad (liftM)+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(..), VM)+import Atomo.Types (Expr(..), ParserState(..)) -type Parser = ParsecT String ParserState VM+type Parser = ParsecT String ParserState Identity isOpLetter :: Char -> Bool@@ -20,7 +20,7 @@ isOperator "" = False isOperator cs = head cs `notElem` "@$~" && all isOpLetter cs -def :: P.GenLanguageDef String ParserState VM+def :: P.GenLanguageDef String ParserState Identity def = P.LanguageDef { P.commentStart = "{-" , P.commentEnd = "-}"@@ -35,7 +35,7 @@ , P.caseSensitive = True } -tp :: P.GenTokenParser String ParserState VM+tp :: P.GenTokenParser String ParserState Identity tp = makeTokenParser def eol :: Parser ()@@ -220,7 +220,7 @@ r <- p return r { eLocation = Just pos } -makeTokenParser :: P.GenLanguageDef String ParserState VM -> P.GenTokenParser String ParserState VM+makeTokenParser :: P.GenLanguageDef String ParserState Identity -> P.GenTokenParser String ParserState Identity makeTokenParser languageDef = P.TokenParser{ P.identifier = identifier , P.reserved = reserved
src/Atomo/Parser/Expand.hs view
@@ -1,17 +1,96 @@-module Atomo.Parser.Expand (macroExpand) where+module Atomo.Parser.Expand (doPragmas, macroExpand, nextPhase) where -import "monads-fd" Control.Monad.State-import Text.Parsec-import qualified "mtl" Control.Monad.Trans as MTL+import Control.Monad.State import Atomo.Environment import Atomo.Helpers-import Atomo.Method (lookupMap)-import Atomo.Parser.Base+import Atomo.Method (addMethod, lookupMap) import Atomo.Pattern (match) import Atomo.Types +nextPhase :: [Expr] -> VM [Expr]+nextPhase es = do+ mapM_ doPragmas es+ mapM macroExpand es+++doPragmas :: Expr -> VM ()+doPragmas (Dispatch { eMessage = em }) =+ pragmas em+ where+ pragmas (Single _ _ t) =+ doPragmas t+ pragmas (Keyword _ _ ts) =+ mapM_ doPragmas ts+doPragmas (Define { eExpr = e }) = do+ doPragmas e+doPragmas (Set { 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 (EParticle { eParticle = ep }) =+ case ep of+ PMKeyword _ mes ->+ forM_ mes $ \me ->+ case me of+ Nothing -> return ()+ Just e -> doPragmas e++ _ -> return ()+doPragmas (Operator {}) = return ()+doPragmas (Primitive {}) = return ()+doPragmas (EForMacro { eExpr = e }) = do+ env <- gets (psEnvironment . parserState)+ macroExpand e >>= withTop env . eval+ return ()+doPragmas (ETop {}) = return ()+doPragmas (EVM {}) = return ()+-- TODO: follow through EQuote into EUnquote+doPragmas (EQuote {}) = return ()+doPragmas (EUnquote {}) = return ()+doPragmas (ESetDynamic { eExpr = e }) =+ doPragmas e+doPragmas (EDefineDynamic { eExpr = e }) =+ doPragmas e+doPragmas (ENewDynamic { eBindings = bs, eExpr = e }) = do+ mapM_ (\(_, b) -> doPragmas b) bs+ doPragmas e+doPragmas (EGetDynamic {}) = return ()+++-- | Defines a macro, given its pattern and expression.+addMacro :: Message Pattern -> Expr -> VM ()+addMacro p e =+ modify $ \env -> env+ { parserState = (parserState env)+ { psMacros = withMacro (psMacros (parserState env))+ }+ }+ where+ withMacro ms =+ case p of+ Single {} ->+ (addMethod (Macro p e) (fst ms), snd ms)++ Keyword {} ->+ (fst ms, addMethod (Macro p e) (snd ms))+++modifyPS :: (ParserState -> ParserState) -> VM ()+modifyPS f =+ modify $ \e -> e+ { parserState = f (parserState e)+ }++getPS :: VM ParserState+getPS = gets parserState+ -- | Go through an expression recursively expanding macros. A dispatch -- expression is checked to see if a macro was defined for it; if a macro is -- found, its targets are sent to the macro method (unexpanded), and the@@ -19,33 +98,32 @@ -- -- Every other expression just recursively calls macroExpand on any -- sub-expressions.-macroExpand :: Expr -> Parser Expr+macroExpand :: Expr -> VM Expr macroExpand d@(Dispatch { eMessage = em }) = do mm <- findMacro msg case mm of Just m -> do- modifyState $ \ps -> ps { psClock = psClock ps + 1 }+ modifyPS $ \ps -> ps { psClock = psClock ps + 1 } - Expression e <-- MTL.lift (runMethod m msg >>= findExpression)+ Expression ne <- runMethod m msg >>= findExpression - macroExpand e+ macroExpand ne Nothing -> do nem <- expanded em return d { eMessage = nem } where- expanded (ESingle i n t) = do+ expanded (Single i n t) = do nt <- macroExpand t- return (ESingle i n nt)- expanded (EKeyword i ns ts) = do+ return (Single i n nt)+ expanded (Keyword i ns ts) = do nts <- mapM macroExpand ts- return (EKeyword i ns nts)+ return (Keyword i ns nts) msg = case em of- ESingle i n t -> Single i n (Expression t)- EKeyword i ns ts -> Keyword i ns (map Expression ts)+ 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 e' <- macroExpand e return d { eExpr = e' }@@ -63,29 +141,48 @@ return m { eExpr = e' } macroExpand p@(EParticle { eParticle = ep }) = case ep of- EPMKeyword ns mes -> do+ PMKeyword ns mes -> do nmes <- forM mes $ \me -> case me of Nothing -> return Nothing Just e -> liftM Just (macroExpand e) - return p { eParticle = EPMKeyword ns nmes }+ return p { eParticle = PMKeyword ns nmes } _ -> return p--- TODO: EUnquote?-macroExpand e = return e+macroExpand s@(ESetDynamic { eExpr = e }) = do+ e' <- macroExpand e+ return s { eExpr = e' }+macroExpand d@(EDefineDynamic { eExpr = e }) = do+ e' <- macroExpand e+ return d { eExpr = e' }+macroExpand n@(ENewDynamic { eBindings = bs, eExpr = e }) = do+ bs' <- mapM (\(p, b) -> macroExpand b >>= \nb -> return (p, nb)) bs+ e' <- macroExpand e+ return n { eBindings = bs', eExpr = e' }+macroExpand e@(EGetDynamic {}) = return e+macroExpand e@(Operator {}) = return e+macroExpand e@(Primitive {}) = 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@(EUnquote {}) = return e + -- | find a findMacro method for message `m' on object `o'-findMacro :: Message -> Parser (Maybe Method)+findMacro :: Message Value -> VM (Maybe Method) findMacro m = do- ids <- MTL.lift (gets primitives)+ ids <- gets primitives ms <- methods m- maybe (return Nothing) (firstMatch ids m) (lookupMap (mID m) ms)+ return $ maybe Nothing (firstMatch ids m) (lookupMap (mID m) ms) where- methods (Single {}) = liftM (fst . psMacros) getState- methods (Keyword {}) = liftM (snd . psMacros) getState+ methods (Single {}) = liftM (fst . psMacros) getPS+ methods (Keyword {}) = liftM (snd . psMacros) getPS - firstMatch _ _ [] = return Nothing- firstMatch ids' m' (mt:mts)- | match ids' Nothing (mPattern mt) (Message m') = return (Just mt)+ firstMatch _ _ [] = Nothing+ 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,20 @@ module Atomo.Parser.Expr where import Control.Arrow (first, second)-import "monads-fd" Control.Monad.State+import Control.Monad.State import Data.Maybe (fromJust, isJust) import Text.Parsec-import qualified "mtl" Control.Monad.Trans as MTL -import Atomo.Environment-import Atomo.Helpers (toPattern', toMacroPattern')-import Atomo.Method (addMethod) import Atomo.Parser.Base-import Atomo.Parser.Expand import Atomo.Parser.Primitive+import Atomo.Pattern import Atomo.Types hiding (keyword, string)+import qualified Atomo.Types as T -- | The types of values in Dispatch syntax. data Dispatch- = DParticle EParticle+ = DParticle (Particle Expr) | DNormal Expr deriving Show @@ -106,7 +103,7 @@ name <- ident notFollowedBy (char ':') spacing- return (Dispatch Nothing (esingle name (ETop Nothing)))+ return (Dispatch Nothing (single name (ETop Nothing))) -- | The for-macro "pragma." --@@ -114,9 +111,11 @@ pForMacro :: Parser Expr pForMacro = tagged (do reserved "for-macro"++ whiteSpace+ e <- pExpr- -- TODO: evaluate this with a specific toplevel, probably Lobby- macroExpand e >>= MTL.lift . eval+ return (EForMacro Nothing e)) <?> "for-macro expression" @@ -126,10 +125,15 @@ pMacro :: Parser Expr pMacro = tagged (do reserved "macro"- p <- parens (pExpr >>= MTL.lift . toMacroPattern')+ whiteSpace++ p <- parens (liftM (fromJust . toMacroPattern) pExpr)++ whiteSpace+ e <- pExpr- macroExpand e >>= addMacro p+ return (EMacro Nothing p e)) <?> "macro definition" @@ -141,6 +145,8 @@ pOperator = tagged (do reserved "operator" + whiteSpace+ info <- choice [ do a <- choice@@ -155,7 +161,10 @@ ops <- operator `sepBy1` spacing forM_ ops $ \name ->- modifyState (\ps -> ps { psOperators = (name, info) : psOperators ps })+ modifyState $ \ps -> ps+ { psOperators =+ (name, info) : psOperators ps+ } return (uncurry (Operator Nothing ops) info)) <?> "operator pragma"@@ -177,12 +186,12 @@ where binary = do op <- operator- return $ EPMKeyword [op] [Nothing, Nothing]+ return $ PMKeyword [op] [Nothing, Nothing] symbols = do names <- many1 (anyIdent >>= \n -> char ':' >> return n) spacing- return $ EPMKeyword names (replicate (length names + 1) Nothing)+ return $ PMKeyword names (replicate (length names + 1) Nothing) -- | Any dispatch, both single and keyword. pDispatch :: Parser Expr@@ -195,7 +204,7 @@ pdKeys :: Parser Expr pdKeys = do pos <- getPosition- msg <- keywords ekeyword (ETop (Just pos)) (try pdChain <|> headless)+ msg <- keywords T.keyword (ETop (Just pos)) (try pdChain <|> headless) ops <- liftM psOperators getState return $ Dispatch (Just pos) (toBinaryOps ops msg) <?> "keyword dispatch"@@ -209,7 +218,7 @@ ckeywd pos = do ks <- wsMany1 $ keyword pdChain let (ns, es) = unzip ks- return $ ekeyword ns (ETop (Just pos):es)+ return $ T.keyword ns (ETop (Just pos):es) <?> "keyword segment" -- | A chain of message sends, both single and chained keywords.@@ -235,19 +244,19 @@ dispatches :: SourcePos -> [Dispatch] -> Expr dispatches p (DNormal e:ps) = dispatches' p ps e- dispatches p (DParticle (EPMSingle n):ps) =- dispatches' p ps (Dispatch (Just p) $ esingle n (ETop (Just p)))- dispatches p (DParticle (EPMKeyword ns (Nothing:es)):ps) =- dispatches' p ps (Dispatch (Just p) $ ekeyword ns (ETop (Just p):map fromJust es))+ 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 -- roll a list of partial messages into a bunch of dispatches dispatches' :: SourcePos -> [Dispatch] -> Expr -> Expr dispatches' _ [] acc = acc- dispatches' p (DParticle (EPMKeyword ns (Nothing:es)):ps) acc =- dispatches' p ps (Dispatch (Just p) $ ekeyword ns (acc : map fromJust es))- dispatches' p (DParticle (EPMSingle n):ps) acc =- dispatches' p ps (Dispatch (Just p) $ esingle n 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) -- | A comma-separated list of zero or more expressions, surrounded by square@@ -269,7 +278,7 @@ whiteSpace string "|" whiteSpace1- mapM (MTL.lift . toPattern') ps+ return $ map (fromJust . toPattern) ps code <- wsBlock pExpr @@ -279,24 +288,24 @@ -- | A general "single dispatch" form, without a target. -- -- Used for both chaines and particles.-cSingle :: Bool -> Parser EParticle+cSingle :: Bool -> Parser (Particle Expr) cSingle p = do n <- if p then anyIdent else ident notFollowedBy colon spacing- return (EPMSingle n)+ return (PMSingle n) <?> "single segment" -- | A general "keyword dispatch" form, without a head. -- -- Used for both chaines and particles.-cKeyword :: Bool -> Parser EParticle+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 $ EPMKeyword ns mvs+ else return $ PMKeyword ns mvs <?> "keyword segment" where keywordVal@@ -329,8 +338,8 @@ | all isJust opVals = do os <- getState pos <- getPosition- let msg = toBinaryOps (psOperators os) $ ekeyword opers (map fromJust opVals)- return . EPMKeyword nonOpers $+ 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@@ -340,31 +349,31 @@ -- | Work out precadence, associativity, etc. for a keyword dispatch. -- -- The input is a keyword EMessage with a mix of operators and identifiers as--- its name, e.g. @EKeyword { emNames = ["+", "*", "remainder"] }@.-toBinaryOps :: Operators -> EMessage -> EMessage-toBinaryOps _ done@(EKeyword _ [_] [_, _]) = done-toBinaryOps ops (EKeyword h (n:ns) (v:vs))+-- 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)) | nextFirst =- ekeyword [n]+ T.keyword [n] [ v , Dispatch (eLocation v)- (toBinaryOps ops (ekeyword ns vs))+ (toBinaryOps ops (T.keyword ns vs)) ] | isOperator n =- toBinaryOps ops . ekeyword ns $- (Dispatch (eLocation v) (ekeyword [n] [v, head vs]):tail vs)- | nonOperators == ns = EKeyword h (n:ns) (v:vs)+ 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 =- ekeyword [head ns]+ T.keyword [head ns] [ Dispatch (eLocation v) $- ekeyword [n] [v, head vs]+ T.keyword [n] [v, head vs] , Dispatch (eLocation v) $- toBinaryOps ops (ekeyword (tail ns) (tail vs))+ toBinaryOps ops (T.keyword (tail ns) (tail vs)) ] | otherwise =- toBinaryOps ops . ekeyword (drop numNonOps ns) $+ toBinaryOps ops . T.keyword (drop numNonOps ns) $ (Dispatch (eLocation v) $- ekeyword (n : nonOperators)+ T.keyword (n : nonOperators) (v : take (numNonOps + 1) vs)) : drop (numNonOps + 1) vs where@@ -388,28 +397,6 @@ Nothing -> defaultPrec Just (_, p) -> p toBinaryOps _ u = error $ "cannot toBinaryOps: " ++ show u---- | Defines a macro, given its pattern and expression.-addMacro :: Pattern -> Expr -> Parser ()-addMacro p e =- case p of- PSingle {} ->- modifyState $ \ps -> ps- { psMacros =- ( addMethod (Macro p e) (fst (psMacros ps))- , snd (psMacros ps)- )- }-- PKeyword {} ->- modifyState $ \ps -> ps- { psMacros =- ( fst (psMacros ps)- , addMethod (Macro p e) (snd (psMacros ps))- )- }-- _ -> error $ "impossible: addMacro: p is " ++ show p -- | Parse a block of expressions from a given input string. parser :: Parser [Expr]
src/Atomo/Pattern.hs view
@@ -12,9 +12,7 @@ import Control.Monad (forM, liftM) import Data.Char (isUpper)-import Data.IORef (readIORef)-import Data.Maybe (isJust)-import System.IO.Unsafe+import Data.Maybe (fromJust, isJust) import qualified Data.Text as T import qualified Data.Vector as V @@ -26,26 +24,27 @@ -- -- Note that this is much faster when pure, so it uses unsafePerformIO -- to check things like delegation matches.-match :: IDs -> Maybe ORef -> Pattern -> Value -> Bool+match :: IDs -> Maybe Value -> Pattern -> Value -> Bool {-# NOINLINE match #-}-match ids (Just r) PThis (Reference y) =- refMatch ids (Just r) r y+match ids (Just r) PThis y@(Object { oDelegates = ds }) =+ r == y || any (match ids (Just r) (PMatch r)) ds match ids (Just r) PThis y =- match ids (Just r) (PMatch (Reference r)) (Reference (orefFrom ids y))+ match ids (Just r) (PMatch r) (objectFrom ids y) match _ _ (PMatch x) y | x == y = True-match ids r (PMatch x) (Reference y) =- delegatesMatch ids r (PMatch x) y-match ids r (PMatch (Reference x)) y =- match ids r (PMatch (Reference x)) (Reference (orefFrom ids y))+match ids r x@(PMatch _) (Object { oDelegates = ds }) =+ any (match ids r x) ds+match ids r x@(PMatch (Object {})) y =+ match ids r x (objectFrom ids y) match ids r- (PSingle { ppTarget = p })- (Message (Single { mTarget = t })) =+ (PMessage (Single { mTarget = p }))+ ( Message (Single { mTarget = t })) = match ids r p t match ids r- (PKeyword { ppTargets = ps })- (Message (Keyword { mTargets = ts })) =+ (PMessage (Keyword { mTargets = ps }))+ ( Message (Keyword { mTargets = ts })) = matchAll ids r ps ts-match ids r (PInstance p) (Reference o) = delegatesMatch ids r p o+match ids r (PInstance p) (Object { oDelegates = ds }) =+ any (match ids r p) ds 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@@ -61,31 +60,27 @@ 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)) = ans == bns && matchParticle ids r aps mvs-match _ _ PEDispatch (Expression (Dispatch {})) = True-match _ _ PEOperator (Expression (Operator {})) = True-match _ _ PEPrimitive (Expression (Primitive {})) = True-match _ _ PEBlock (Expression (EBlock {})) = True-match _ _ PEList (Expression (EList {})) = True-match _ _ PEMacro (Expression (EMacro {})) = True-match _ _ PEParticle (Expression (EParticle {})) = True-match _ _ PETop (Expression (ETop {})) = True-match _ _ PEQuote (Expression (EQuote {})) = True-match _ _ PEUnquote (Expression (EUnquote {})) = True-match _ _ (PExpr a) (Expression b) = matchExpr 0 a b-match ids r p (Reference y) = delegatesMatch ids r p y+match ids r p (Object { oDelegates = ds }) =+ any (match ids r p) ds+match _ _ p (Expression e) = macroMatch p e match _ _ _ _ = False --- | Check if two references are equal or if one delegates to another.-refMatch :: IDs -> Maybe ORef -> ORef -> ORef -> Bool-refMatch ids r x y = x == y || delegatesMatch ids r (PMatch (Reference x)) y---- | Check if an object's delegates match a pattern.-delegatesMatch :: IDs -> Maybe ORef -> Pattern -> ORef -> Bool-delegatesMatch ids mr p x =- any (match ids mr p) (oDelegates (unsafePerformIO (readIORef x)))+macroMatch :: Pattern -> Expr -> Bool+macroMatch PEDispatch (Dispatch {}) = True+macroMatch PEOperator (Operator {}) = True+macroMatch PEPrimitive (Primitive {}) = True+macroMatch PEBlock (EBlock {}) = True+macroMatch PEList (EList {}) = True+macroMatch PEMacro (EMacro {}) = True+macroMatch PEParticle (EParticle {}) = True+macroMatch PETop (ETop {}) = True+macroMatch PEQuote (EQuote {}) = True+macroMatch PEUnquote (EUnquote {}) = True+macroMatch (PExpr a) b = matchExpr 0 a b+macroMatch _ _ = False -- | Match multiple patterns with multiple values.-matchAll :: IDs -> Maybe ORef -> [Pattern] -> [Value] -> Bool+matchAll :: IDs -> Maybe Value -> [Pattern] -> [Value] -> Bool matchAll _ _ [] [] = True matchAll ids mr (p:ps) (v:vs) = match ids mr p v && matchAll ids mr ps vs matchAll _ _ _ _ = False@@ -98,33 +93,37 @@ matchEParticle _ _ _ = False matchExpr :: Int -> Expr -> Expr -> Bool-matchExpr 0 (EUnquote {}) _ = True+matchExpr 0 (EUnquote { eExpr = Dispatch { eMessage = Single {} } }) _ = True+matchExpr 0 (EUnquote { eExpr = Dispatch { 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 { ePattern = ap', eExpr = a }) (Define { ePattern = bp, eExpr = b }) =+matchExpr n (Define { emPattern = ap', eExpr = a }) (Define { emPattern = bp, eExpr = b }) = ap' == bp && matchExpr n a b matchExpr n (Set { ePattern = ap', eExpr = a }) (Set { ePattern = bp, eExpr = b }) = ap' == bp && matchExpr n a b-matchExpr n (Dispatch { eMessage = am@(EKeyword {}) }) (Dispatch { eMessage = bm@(EKeyword {}) }) =- emID am == emID bm && length (emTargets am) == length (emTargets bm) && and (zipWith (matchExpr n) (emTargets am) (emTargets bm))-matchExpr n (Dispatch { eMessage = am@(ESingle {}) }) (Dispatch { eMessage = bm@(ESingle {}) }) =- emID am == emID bm && matchExpr n (emTarget am) (emTarget bm)+matchExpr n (Dispatch { eMessage = am@(Keyword {}) }) (Dispatch { 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 {}) }) =+ 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 (EMacro { ePattern = ap', eExpr = a }) (EMacro { ePattern = bp, eExpr = b }) =+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- (EPMKeyword ans ames, EPMKeyword bns bmes) ->+ (PMKeyword ans ames, PMKeyword bns bmes) -> ans == bns && matchEParticle n ames bmes _ -> ap' == bp matchExpr n (EQuote { eExpr = a }) (EQuote { eExpr = b }) = matchExpr (n + 1) a b matchExpr _ a b = a == b -matchParticle :: IDs -> Maybe ORef -> [Pattern] -> [Maybe Value] -> Bool+matchParticle :: IDs -> Maybe Value -> [Pattern] -> [Maybe Value] -> Bool matchParticle _ _ [] [] = True matchParticle ids mr (PAny:ps) (Nothing:mvs) = matchParticle ids mr ps mvs matchParticle ids mr (PNamed _ p:ps) mvs = matchParticle ids mr (p:ps) mvs@@ -133,16 +132,16 @@ matchParticle _ _ _ _ = False -- | Given a pattern and a message, return the bindings from the pattern.-bindings :: Pattern -> Message -> MethodMap-bindings (PSingle { ppTarget = p }) (Single { mTarget = t }) =+bindings :: Message Pattern -> Message Value -> MethodMap+bindings (Single { mTarget = p }) (Single { mTarget = t }) = toMethods (bindings' p t)-bindings (PKeyword { ppTargets = ps }) (Keyword { mTargets = ts }) =+bindings (Keyword { mTargets = ps }) (Keyword { mTargets = ts }) = toMethods $ concat (zipWith bindings' ps ts) bindings p m = error $ "impossible: bindings on " ++ show (p, m) -- | Given a pattern and avalue, return the bindings as a list of pairs.-bindings' :: Pattern -> Value -> [(Pattern, Value)]-bindings' (PNamed n p) v = (psingle n PThis, v) : bindings' p v+bindings' :: Pattern -> Value -> [(Message Pattern, Value)]+bindings' (PNamed n p) v = (single n PThis, v) : bindings' p v bindings' (PPMKeyword _ ps) (Particle (PMKeyword _ mvs)) = concatMap (\(p, Just v) -> bindings' p v) $ filter (isJust . snd)@@ -156,28 +155,30 @@ bindings' (PHeadTail hp tp) (String t) | not (T.null t) = bindings' hp (Char (T.head t)) ++ bindings' tp (String (T.tail t)) bindings' (PExpr a) (Expression b) = exprBindings 0 a b-bindings' (PInstance p) (Reference r) =- concatMap (bindings' p) $ oDelegates (unsafePerformIO (readIORef r))+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' p (Reference r) =- concatMap (bindings' p) $ oDelegates (unsafePerformIO (readIORef r))+bindings' p (Object { oDelegates = ds }) =+ concatMap (bindings' p) ds bindings' _ _ = [] -exprBindings :: Int -> Expr -> Expr -> [(Pattern, Value)]-exprBindings 0 (EUnquote { eExpr = Dispatch { eMessage = ESingle { emName = n } } }) e =- [(psingle n PThis, Expression e)]+exprBindings :: Int -> Expr -> Expr -> [(Message Pattern, Value)]+exprBindings 0 (EUnquote { eExpr = Dispatch { eMessage = Single { mName = n } } }) e =+ [(single n PThis, Expression e)]+exprBindings 0 (EUnquote { eExpr = Dispatch { 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 a b exprBindings n (Set { eExpr = a }) (Set { eExpr = b }) = exprBindings n a b-exprBindings n (Dispatch { eMessage = am@(EKeyword {}) }) (Dispatch { eMessage = bm@(EKeyword {}) }) =- concat $ zipWith (exprBindings n) (emTargets am) (emTargets bm)-exprBindings n (Dispatch { eMessage = am@(ESingle {}) }) (Dispatch { eMessage = bm@(ESingle {}) }) =- exprBindings n (emTarget am) (emTarget bm)+exprBindings n (Dispatch { eMessage = am@(Keyword {}) }) (Dispatch { eMessage = bm@(Keyword {}) }) =+ concat $ zipWith (exprBindings n) (mTargets am) (mTargets bm)+exprBindings n (Dispatch { eMessage = am@(Single {}) }) (Dispatch { 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 }) =@@ -186,7 +187,7 @@ exprBindings n a b exprBindings n (EParticle { eParticle = ap' }) (EParticle { eParticle = bp }) = case (ap', bp) of- (EPMKeyword _ ames, EPMKeyword _ bmes) ->+ (PMKeyword _ ames, PMKeyword _ bmes) -> concatMap (\(Just a, Just b) -> exprBindings n a b) $ filter (isJust . fst) $ zip ames bmes@@ -197,31 +198,31 @@ -- | Convert an expression to the pattern match it represents. toPattern :: Expr -> Maybe Pattern-toPattern (Dispatch { eMessage = EKeyword { emNames = ["."], emTargets = [h, t] } }) = do+toPattern (Dispatch { eMessage = Keyword { mNames = ["."], mTargets = [h, t] } }) = do hp <- toPattern h tp <- toPattern t return (PHeadTail hp tp)-toPattern (Dispatch { eMessage = EKeyword { emNames = ["->"], emTargets = [ETop {}, o] } }) = do+toPattern (Dispatch { eMessage = Keyword { mNames = ["->"], mTargets = [ETop {}, o] } }) = do liftM PInstance (toPattern o)-toPattern (Dispatch { eMessage = EKeyword { emNames = ["=="], emTargets = [ETop {}, o] } }) = do+toPattern (Dispatch { eMessage = Keyword { mNames = ["=="], mTargets = [ETop {}, o] } }) = do liftM PStrict (toPattern o)-toPattern (Dispatch { eMessage = EKeyword { emNames = [n], emTargets = [ETop {}, x] } }) = do+toPattern (Dispatch { eMessage = Keyword { mNames = [n], mTargets = [ETop {}, x] } }) = do p <- toPattern x return (PNamed n p)-toPattern (Dispatch { eMessage = EKeyword { emNames = ns, emTargets = ts } }) =+toPattern (Dispatch { eMessage = Keyword { mNames = ns, mTargets = ts } }) = return (pkeyword ns (map PObject ts))-toPattern (Dispatch { eMessage = ESingle { emName = "_" } }) =+toPattern (Dispatch { eMessage = Single { mName = "_" } }) = return PAny-toPattern (Dispatch { eMessage = ESingle { emName = n, emTarget = ETop {} } }) =+toPattern (Dispatch { eMessage = Single { mName = n, mTarget = ETop {} } }) = return (PNamed n PAny)-toPattern (Dispatch { eMessage = ESingle { emTarget = d@(Dispatch {}), emName = n } }) =+toPattern (Dispatch { eMessage = Single { mTarget = d@(Dispatch {}), mName = n } }) = return (psingle n (PObject d)) toPattern (EList { eContents = es }) = do ps <- mapM toPattern es return (PList ps)-toPattern (EParticle { eParticle = EPMSingle n }) =+toPattern (EParticle { eParticle = PMSingle n }) = return (PMatch (Particle (PMSingle n)))-toPattern (EParticle { eParticle = EPMKeyword ns mes }) = do+toPattern (EParticle { eParticle = PMKeyword ns mes }) = do ps <- forM mes $ \me -> case me of Nothing -> return PAny@@ -234,58 +235,59 @@ toPattern (ETop {}) = return (PObject (ETop Nothing)) toPattern b@(EBlock {}) =- return (PObject (Dispatch Nothing (esingle "call" b)))+ return (PObject (Dispatch Nothing (keyword ["call-in"] [b, ETop Nothing]))) toPattern _ = Nothing -- | Convert an expression into a definition's message pattern.-toDefinePattern :: Expr -> Maybe Pattern-toDefinePattern (Dispatch { eMessage = ESingle { emName = n, emTarget = t } }) = do+toDefinePattern :: Expr -> Maybe (Message Pattern)+toDefinePattern (Dispatch { eMessage = Single { mName = n, mTarget = t } }) = do p <- toRolePattern t- return (psingle n p)-toDefinePattern (Dispatch { eMessage = EKeyword { emNames = ns, emTargets = ts } }) = do+ return (single n p)+toDefinePattern (Dispatch { eMessage = Keyword { mNames = ns, mTargets = ts } }) = do ps <- mapM toRolePattern ts- return (pkeyword ns ps)+ return (keyword ns ps) toDefinePattern _ = Nothing -- | Convert an expression into a pattern-match for use as a message's role. toRolePattern :: Expr -> Maybe Pattern-toRolePattern (Dispatch { eMessage = EKeyword { emNames = ["->"], emTargets = [ETop {}, o] } }) = do+toRolePattern (Dispatch { eMessage = Keyword { mNames = ["->"], mTargets = [ETop {}, o] } }) = do liftM PInstance (toRolePattern o)-toRolePattern (Dispatch { eMessage = EKeyword { emNames = ["=="], emTargets = [ETop {}, o] } }) = do+toRolePattern (Dispatch { eMessage = Keyword { mNames = ["=="], mTargets = [ETop {}, o] } }) = do liftM PStrict (toRolePattern o)-toRolePattern (Dispatch { eMessage = EKeyword { emNames = [n], emTargets = [ETop {}, x] } }) = do+toRolePattern (Dispatch { eMessage = Keyword { mNames = [n], mTargets = [ETop {}, x] } }) = do p <- toRolePattern x return (PNamed n p)-toRolePattern d@(Dispatch { eMessage = ESingle { emTarget = ETop {}, emName = n } })+toRolePattern d@(Dispatch { eMessage = Single { mTarget = ETop {}, mName = n } }) | isUpper (head n) = return (PObject d)+ | n == "_" = return PAny | otherwise = return (PNamed n PAny)-toRolePattern d@(Dispatch { eMessage = ESingle { emTarget = (Dispatch {}) } }) =+toRolePattern d@(Dispatch { eMessage = Single { mTarget = (Dispatch {}) } }) = return (PObject d) toRolePattern p = toPattern p -- | Convert an expression into a macro's message pattern.-toMacroPattern :: Expr -> Maybe Pattern-toMacroPattern (Dispatch { eMessage = ESingle { emName = n, emTarget = t } }) = do+toMacroPattern :: Expr -> Maybe (Message Pattern)+toMacroPattern (Dispatch { eMessage = Single { mName = n, mTarget = t } }) = do p <- toMacroRole t- return (psingle n p)-toMacroPattern (Dispatch { eMessage = EKeyword { emNames = ns, emTargets = ts } }) = do+ return (single n p)+toMacroPattern (Dispatch { eMessage = Keyword { mNames = ns, mTargets = ts } }) = do ps <- mapM toMacroRole ts- return (pkeyword ns ps)+ return (keyword ns ps) toMacroPattern _ = Nothing -- | Convert an expression into a pattern-match for use as a macro's role. toMacroRole :: Expr -> Maybe Pattern-toMacroRole (Dispatch _ (ESingle _ "Dispatch" _)) = Just PEDispatch-toMacroRole (Dispatch _ (ESingle _ "Operator" _)) = Just PEOperator-toMacroRole (Dispatch _ (ESingle _ "Primitive" _)) = Just PEPrimitive-toMacroRole (Dispatch _ (ESingle _ "Block" _)) = Just PEBlock-toMacroRole (Dispatch _ (ESingle _ "List" _)) = Just PEList-toMacroRole (Dispatch _ (ESingle _ "Macro" _)) = Just PEMacro-toMacroRole (Dispatch _ (ESingle _ "Particle" _)) = Just PEParticle-toMacroRole (Dispatch _ (ESingle _ "Top" _)) = Just PETop-toMacroRole (Dispatch _ (ESingle _ "Quote" _)) = Just PEQuote-toMacroRole (Dispatch _ (ESingle _ "Unquote" _)) = Just PEUnquote-toMacroRole (Dispatch { eMessage = EKeyword { emNames = [n], emTargets = [ETop {}, x] } }) = do+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 p <- toMacroRole x return (PNamed n p) toMacroRole (ETop {}) = Just PAny
src/Atomo/Pretty.hs view
@@ -1,12 +1,12 @@-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} module Atomo.Pretty (Pretty(pretty)) where import Data.Char (isUpper) import Data.IORef import Data.Maybe (isNothing) import Data.Ratio-import Text.PrettyPrint hiding (braces) import System.IO.Unsafe+import Text.PrettyPrint hiding (braces) import qualified Data.Vector as V import Atomo.Method@@ -58,29 +58,33 @@ prettyFrom _ (Pattern p) = internal "pattern" $ pretty p prettyFrom _ (Process _ tid) = internal "process" $ text (words (show tid) !! 1)- prettyFrom CNone (Reference r) = pretty (unsafePerformIO (readIORef r))+ prettyFrom CNone (Object { oDelegates = ds, oMethods = ms }) =+ vcat+ [ internal "object" $ parens (text "delegates to" <+> pretty ds)+ , nest 2 (pretty ms)+ ] prettyFrom _ (Rational r) = integer (numerator r) <> char '/' <> integer (denominator r)- prettyFrom _ (Reference _) = internal "object" empty+ prettyFrom _ (Object {}) = internal "object" empty prettyFrom _ (String s) = text (show s) -instance Pretty Object where- prettyFrom _ (Object ds (ss, ks)) = vcat- [ internal "object" $ parens (text "delegates to" <+> pretty ds)-- , if not (nullMap ss)- then nest 2 $ vcat (map (vcat . map prettyMethod) (elemsMap ss)) <>+instance Pretty Methods where+ prettyFrom _ ms = vcat+ [ if not (nullMap ss)+ then vcat (map (vcat . map prettyMethod) (elemsMap ss)) <> if not (nullMap ks) then char '\n' else empty else empty , if not (nullMap ks)- then nest 2 . vcat $ flip map (elemsMap ks) $ \ms ->- vcat (map prettyMethod ms) <> char '\n'+ then vcat $ flip map (elemsMap ks) $ \ps ->+ vcat (map prettyMethod ps) <> char '\n' else empty ] where+ (ss, ks) = unsafePerformIO (readIORef ms)+ prettyMethod (Slot { mPattern = p, mValue = v }) = prettyFrom CDefine p <+> text ":=" <++> prettyFrom CDefine v prettyMethod (Responder { mPattern = p, mExpr = e }) =@@ -88,34 +92,11 @@ prettyMethod (Macro { mPattern = p, mExpr = e }) = text "macro" <+> parens (pretty p) <++> prettyFrom CDefine e -instance Pretty Message where- prettyFrom _ (Single _ n t) = prettyFrom CSingle t <+> text n- prettyFrom _ (Keyword _ ns vs) = keywords ns vs---instance Pretty Particle where- prettyFrom _ (PMSingle e) = text e- prettyFrom _ (PMKeyword ns vs)- | all isNothing vs = text . concat $ map keyword ns- | isNothing (head vs) =- parens $ headlessKeywords' prettyVal ns (tail vs)- | otherwise = parens (keywords' prettyVal ns vs)- where- prettyVal me =- case me of- Nothing -> text "_"- Just e -> prettyFrom CKeyword e-- instance Pretty Pattern where prettyFrom _ PAny = text "_" prettyFrom _ (PHeadTail h t) = parens $ pretty h <+> text "." <+> pretty t- prettyFrom _ (PKeyword _ ns (PObject ETop {}:vs)) =- headlessKeywords ns vs- prettyFrom _ (PKeyword _ ns (PThis:vs)) =- headlessKeywords ns vs- prettyFrom _ (PKeyword _ ns vs) = keywords ns vs+ prettyFrom c (PMessage m) = prettyFrom c m prettyFrom _ (PList ps) = brackets . sep $ punctuate comma (map pretty ps) prettyFrom _ (PMatch v) = prettyFrom CPattern v@@ -125,17 +106,17 @@ | capitalized msg = pretty e | isParticular msg = pretty block where- capitalized (ESingle { emName = n, emTarget = ETop {} }) =+ capitalized (Single { mName = n, mTarget = ETop {} }) = isUpper (head n)- capitalized (ESingle { emTarget = Dispatch { eMessage = t@(ESingle {}) } }) =+ capitalized (Single { mTarget = Dispatch { eMessage = t@(Single {}) } }) = capitalized t capitalized _ = False - isParticular (ESingle { emName = "call", emTarget = EBlock {} }) =+ isParticular (Keyword { mNames = ["call"], mTargets = [EBlock {}, ETop {}] }) = True isParticular _ = False - block = emTarget msg+ block = mTarget msg prettyFrom _ (PObject e) = parens $ pretty e prettyFrom _ (PInstance p) = parens $ text "->" <+> pretty p prettyFrom _ (PStrict p) = parens $ text "==" <+> pretty p@@ -147,9 +128,6 @@ where isAny PAny = True isAny _ = False- prettyFrom _ (PSingle _ n (PObject ETop {})) = text n- prettyFrom _ (PSingle _ n PThis) = text n- prettyFrom _ (PSingle _ n p) = pretty p <+> text n prettyFrom _ PThis = text "<this>" prettyFrom _ PEDispatch = text "Dispatch"@@ -171,8 +149,8 @@ prettyFrom CDefine p <+> text ":=" <++> prettyFrom CDefine v prettyFrom _ (Set _ p v) = prettyFrom CDefine p <+> text "=" <++> prettyFrom CDefine v- prettyFrom CKeyword (Dispatch _ m@(EKeyword {})) = parens $ pretty m- prettyFrom CSingle (Dispatch _ m@(EKeyword {})) = parens $ pretty m+ 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) = text "operator" <+> assoc a <+> integer i <+> sep (map text ns)@@ -197,18 +175,53 @@ prettyFrom _ (ETop {}) = text "this" prettyFrom c (EQuote _ e) = char '`' <> prettySpacedExpr c e prettyFrom c (EUnquote _ e) = char '~' <> prettySpacedExpr c e+ prettyFrom _ (ENewDynamic {}) =+ internal "new-dynamic" empty+ prettyFrom _ (EDefineDynamic { eName = n, eExpr = e }) =+ internal "define-dynamic" $ text n <+> pretty e+ prettyFrom _ (ESetDynamic { eName = n, eExpr = e }) =+ internal "set-dynamic" $ text n <+> pretty e+ prettyFrom _ (EGetDynamic { eName = n }) =+ internal "get-dynamic" $ text n -instance Pretty EMessage where- prettyFrom _ (ESingle _ n (ETop {})) = text n- prettyFrom _ (ESingle _ n t) = prettyFrom CSingle t <+> text n- prettyFrom _ (EKeyword _ ns (ETop {}:es)) = headlessKeywords ns es- prettyFrom _ (EKeyword _ ns es) = keywords ns es+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 +instance Pretty (Message Value) where+ prettyFrom _ (Single _ n t) = prettyFrom CSingle t <+> text n+ prettyFrom _ (Keyword _ ns vs) = keywords ns vs -instance Pretty EParticle where- prettyFrom _ (EPMSingle e) = text e- prettyFrom _ (EPMKeyword ns es)++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++instance Pretty (Particle Value) where+ prettyFrom _ (PMSingle e) = text e+ prettyFrom _ (PMKeyword ns vs)+ | all isNothing vs = text . concat $ map keyword ns+ | isNothing (head vs) =+ parens $ headlessKeywords' prettyVal ns (tail vs)+ | otherwise = parens (keywords' prettyVal ns vs)+ where+ 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)@@ -266,9 +279,9 @@ where needsParens (Define {}) = True needsParens (Set {}) = True- needsParens (Dispatch { eMessage = EKeyword {} }) = True- needsParens (Dispatch { eMessage = ESingle { emTarget = ETop {} } }) = False- needsParens (Dispatch { eMessage = ESingle {} }) = True+ needsParens (Dispatch { eMessage = Keyword {} }) = True+ needsParens (Dispatch { eMessage = Single { mTarget = ETop {} } }) = False+ needsParens (Dispatch { eMessage = Single {} }) = True needsParens _ = False
src/Atomo/QuasiQuotes.hs view
@@ -6,7 +6,7 @@ , es ) where -import "monads-fd" Control.Monad.State hiding (lift)+import Control.Monad.State hiding (lift) import Data.Maybe (fromJust) import Data.Typeable import Language.Haskell.TH.Quote@@ -52,7 +52,7 @@ parsing :: Typeable a => Parser a -> String -> (String, Int, Int) -> a parsing p s (file, line, col) = -- here be dragons- fromHaskell' "a" $ unsafePerformIO (runWith go (qqEnv))+ fromHaskell' $ unsafePerformIO (runWith go (qqEnv)) where go = liftM haskell $ continue pp "<qq>" s
src/Atomo/Run.hs view
@@ -1,7 +1,7 @@ module Atomo.Run where import Control.Concurrent-import "monads-fd" Control.Monad.State+import Control.Monad.State import Atomo.Core import Atomo.Environment@@ -60,10 +60,10 @@ , "boolean" , "association"- , "parameter" , "string" , "condition"+ , "errors" , "exception" , "block"
src/Atomo/Spawn.hs view
@@ -1,7 +1,7 @@ module Atomo.Spawn where import Control.Concurrent-import "monads-fd" Control.Monad.State+import Control.Monad.State import Atomo.Types
src/Atomo/Types.hs view
@@ -3,11 +3,12 @@ import Control.Concurrent (ThreadId) import Control.Concurrent.Chan-import "monads-fd" Control.Monad.Cont-import "monads-fd" Control.Monad.State+import Control.Monad.Cont+import Control.Monad.State import Data.Dynamic import Data.Hashable (hash) import Data.List (nub)+import Data.Maybe (listToMaybe) import Data.IORef import Text.Parsec (ParseError, SourcePos) import Text.PrettyPrint (Doc)@@ -27,7 +28,7 @@ = Block !Value [Pattern] [Expr] -- | A boolean value.- | Boolean { fromBoolean :: {-# UNPACK #-} !Bool }+ | Boolean { fromBoolean :: !Bool } -- | A character value. | Char { fromChar :: {-# UNPACK #-} !Char }@@ -51,13 +52,13 @@ | List VVector -- | A message value.- | Message { fromMessage :: Message }+ | Message { fromMessage :: Message Value } -- | A method value. | Method { fromMethod :: Method } -- | A particle value.- | Particle { fromParticle :: Particle }+ | Particle { fromParticle :: Particle Value } -- | A process; a communications channel and the thread's ID. | Process Channel ThreadId@@ -69,78 +70,68 @@ | Rational Rational -- | An object reference.- | Reference- { rORef :: {-# UNPACK #-} !ORef+ | Object+ { oDelegates :: !Delegates+ , oMethods :: !Methods } -- | A string value; Data.Text.Text. | String { fromString :: !T.Text } deriving (Show, Typeable) --- | A pure object.-data Object =- Object- { -- | The object's delegates list.- oDelegates :: !Delegates-- -- | A pair of (single, keyword) methods.- , oMethods :: !(MethodMap, MethodMap)- }- deriving (Show, Typeable)- -- | Methods, slot, and macro methods. data Method -- | Responds to a message by evaluating an expression in the given context. = Responder- { mPattern :: !Pattern+ { mPattern :: !(Message Pattern) , mContext :: !Value , mExpr :: !Expr } -- | Responds to a macro message by evaluating an expression. | Macro- { mPattern :: !Pattern+ { mPattern :: !(Message Pattern) , mExpr :: !Expr } -- | Responds to a message by returning a value. | Slot- { mPattern :: !Pattern+ { mPattern :: !(Message Pattern) , mValue :: !Value } deriving (Eq, Show, Typeable) -- | Messages sent to objects.-data Message+data Message v -- | A keyword-delimited message with multiple targets. = Keyword { mID :: !Int , mNames :: [String]- , mTargets :: [Value]+ , mTargets :: [v] } -- | A single message sent to one target. | Single { mID :: !Int , mName :: String- , mTarget :: Value+ , mTarget :: v } deriving (Eq, Show, Typeable) -- | Partial messages.-data Particle+data Particle v -- | A single message with no target. = PMSingle String -- | A keyword message with many optional targets.- | PMKeyword [String] [Maybe Value]+ | PMKeyword [String] [Maybe v] deriving (Eq, Show, Typeable) -- | Shortcut error values. data AtomoError = Error Value | ParseError ParseError- | DidNotUnderstand Message+ | DidNotUnderstand (Message Value) | Mismatch Pattern Value | ImportError H.InterpreterError | FileNotFound String@@ -152,26 +143,20 @@ deriving (Show, Typeable) -- | Pattern-matching.+--+-- The Eq instance only checks equivalence. For example, named pattern matches+-- only match their patterns, not the names. data Pattern = PAny | PHeadTail Pattern Pattern- | PKeyword- { ppID :: !Int- , ppNames :: [String]- , ppTargets :: [Pattern]- } | PList [Pattern] | PMatch Value+ | PMessage (Message Pattern) | PInstance Pattern | PStrict Pattern | PNamed String Pattern | PObject Expr | PPMKeyword [String] [Pattern]- | PSingle- { ppID :: !Int- , ppName :: String- , ppTarget :: Pattern- } | PThis -- expression types, used in macros@@ -193,7 +178,7 @@ data Expr = Define { eLocation :: Maybe SourcePos- , ePattern :: Pattern+ , emPattern :: Message Pattern , eExpr :: Expr } | Set@@ -203,7 +188,7 @@ } | Dispatch { eLocation :: Maybe SourcePos- , eMessage :: EMessage+ , eMessage :: Message Expr } | Operator { eLocation :: Maybe SourcePos@@ -226,7 +211,7 @@ } | EMacro { eLocation :: Maybe SourcePos- , ePattern :: Pattern+ , emPattern :: Message Pattern , eExpr :: Expr } | EForMacro@@ -235,7 +220,7 @@ } | EParticle { eLocation :: Maybe SourcePos- , eParticle :: EParticle+ , eParticle :: Particle Expr } | ETop { eLocation :: Maybe SourcePos@@ -253,27 +238,26 @@ { eLocation :: Maybe SourcePos , eExpr :: Expr }- deriving (Show, Typeable)---- | An unevaluated message dispatch.-data EMessage- = EKeyword- { emID :: !Int- , emNames :: [String]- , emTargets :: [Expr]+ | ENewDynamic+ { eLocation :: Maybe SourcePos+ , eBindings :: [(String, Expr)]+ , eExpr :: Expr }- | ESingle- { emID :: !Int- , emName :: String- , emTarget :: Expr+ | EDefineDynamic+ { eLocation :: Maybe SourcePos+ , eName :: String+ , eExpr :: Expr }- deriving (Eq, Show, Typeable)---- | An unevaluated particle.-data EParticle- = EPMSingle String- | EPMKeyword [String] [Maybe Expr]- deriving (Eq, Show, Typeable)+ | ESetDynamic+ { eLocation :: Maybe SourcePos+ , eName :: String+ , eExpr :: Expr+ }+ | EGetDynamic+ { eLocation :: Maybe SourcePos+ , eName :: String+ }+ deriving (Show, Typeable) -- | Atomo's VM state. data Env =@@ -303,6 +287,12 @@ -- | The parser's state, passed around when a parser action needs to -- be run. , parserState :: ParserState++ -- | The current dynamic environment.+ , dynamic :: DynamicMap++ -- | Unwind actions for call/cc etc.+ , unwinds :: [(Value, Value)] } deriving Typeable @@ -313,23 +303,23 @@ -- | A giant record of the objects for each primitive value. data IDs = IDs- { idObject :: ORef- , idBlock :: ORef- , idBoolean :: ORef- , idChar :: ORef- , idContinuation :: ORef- , idDouble :: ORef- , idExpression :: ORef- , idHaskell :: ORef- , idInteger :: ORef- , idList :: ORef- , idMessage :: ORef- , idMethod :: ORef- , idParticle :: ORef- , idProcess :: ORef- , idPattern :: ORef- , idRational :: ORef- , idString :: ORef+ { idObject :: Value+ , idBlock :: Value+ , idBoolean :: Value+ , idChar :: Value+ , idContinuation :: Value+ , idDouble :: Value+ , idExpression :: Value+ , idHaskell :: Value+ , idInteger :: Value+ , idList :: Value+ , idMessage :: Value+ , idMethod :: Value+ , idParticle :: Value+ , idProcess :: Value+ , idPattern :: Value+ , idRational :: Value+ , idString :: Value } deriving (Show, Typeable) @@ -347,6 +337,9 @@ -- | The number of macros we've expanded. , psClock :: Integer++ -- | Environment that for-macro and macro methods are evaluated in.+ , psEnvironment :: Value } deriving (Show, Typeable) @@ -356,6 +349,9 @@ -- | The list of values an object delegates to. type Delegates = [Value] +-- | An object's methods.+type Methods = IORef (MethodMap, MethodMap)+ -- | A channel for sending values through to processes. type Channel = Chan Value @@ -363,7 +359,7 @@ type MethodMap = M.IntMap [Method] -- | A reference to an object.-type ORef = IORef Object+{-type ORef = IORef Object-} -- | A vector containing values. type VVector = V.Vector Value@@ -371,7 +367,10 @@ -- | A reference to a continuation function. type Continuation = IORef (Value -> VM Value) +-- | A dynamic environment+type DynamicMap = M.IntMap [Value] + instance Eq Value where (==) (Block at aps aes) (Block bt bps bes) = at == bt && aps == bps && aes == bes@@ -388,29 +387,25 @@ (==) (Particle a) (Particle b) = a == b (==) (Process _ a) (Process _ b) = a == b (==) (Rational a) (Rational b) = a == b- (==) (Reference a) (Reference b) = a == b+ (==) (Object _ am) (Object _ bm) = am == bm (==) (String a) (String b) = a == b (==) _ _ = False - instance Eq Pattern where -- check if two patterns are "equivalent", ignoring names for patterns -- and other things that mean the same thing (==) PAny PAny = True (==) (PHeadTail ah at) (PHeadTail bh bt) =- (==) ah bh && (==) at bt- (==) (PKeyword _ ans aps) (PKeyword _ bns bps) =- ans == bns && and (zipWith (==) aps bps)+ ah == bh && at == bt+ (==) (PMessage a) (PMessage b) = a == b (==) (PList aps) (PList bps) = length aps == length bps && and (zipWith (==) aps bps) (==) (PMatch a) (PMatch b) = a == b- (==) (PNamed _ a) (PNamed _ b) = (==) a b- (==) (PNamed _ a) b = (==) a b- (==) a (PNamed _ b) = (==) a b+ (==) (PNamed _ a) (PNamed _ b) = a == b+ (==) (PNamed _ a) b = a == b+ (==) a (PNamed _ b) = a == b (==) (PPMKeyword ans aps) (PPMKeyword bns bps) = ans == bns && and (zipWith (==) aps bps)- (==) (PSingle ai _ at) (PSingle bi _ bt) =- ai == bi && (==) at bt (==) PThis PThis = True (==) _ _ = False @@ -434,8 +429,8 @@ instance Show Channel where show _ = "Channel" -instance Show ORef where- show _ = "ORef"+instance Show Methods where+ show _ = "Methods" instance Show Continuation where show _ = "Continuation"@@ -462,27 +457,23 @@ lift (EForMacro _ e) = [| EForMacro Nothing e |] lift (EQuote _ e) = [| EQuote Nothing e |] lift (EUnquote _ e) = [| EUnquote Nothing e |]+ lift (ENewDynamic _ bs e) = [| ENewDynamic Nothing bs e |]+ lift (ESetDynamic _ n e) = [| ESetDynamic Nothing n e |]+ lift (EDefineDynamic _ n e) = [| EDefineDynamic Nothing n e |]+ lift (EGetDynamic _ n) = [| EGetDynamic Nothing n |] instance S.Lift Assoc where lift ALeft = [| ALeft |] lift ARight = [| ARight |] -instance S.Lift Message where+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 |] -instance S.Lift Particle where+instance (S.Lift v) => S.Lift (Particle v) where lift (PMSingle n) = [| PMSingle n |] lift (PMKeyword ns vs) = [| PMKeyword ns vs |] -instance S.Lift EMessage where- lift (EKeyword i ns es) = [| EKeyword i ns es |]- lift (ESingle i n e) = [| ESingle i n e |]--instance S.Lift EParticle where- lift (EPMSingle n) = [| EPMSingle n |]- lift (EPMKeyword ns es) = [| EPMKeyword ns es |]- instance S.Lift Value where lift (Block s as es) = [| Block s as es |] lift (Boolean b) = [| Boolean b |]@@ -499,13 +490,12 @@ instance S.Lift Pattern where lift PAny = [| PAny |] lift (PHeadTail h t) = [| PHeadTail h t |]- lift (PKeyword i ns ts) = [| PKeyword i ns ts |]+ lift (PMessage m) = [| PMessage m |] lift (PList ps) = [| PList ps |] lift (PMatch v) = [| PMatch v |] lift (PNamed n p) = [| PNamed n p |] lift (PObject e) = [| PObject e |] lift (PPMKeyword ns ts) = [| PPMKeyword ns ts |]- lift (PSingle i n t) = [| PSingle i n t |] lift PThis = [| PThis |] lift PEDispatch = [| PEDispatch |] lift PEOperator = [| PEOperator |]@@ -524,7 +514,7 @@ -- | Initial "empty" parser state. startParserState :: ParserState-startParserState = ParserState [] (M.empty, M.empty) False 0+startParserState = ParserState [] (M.empty, M.empty) False 0 (error "no parser environment") -- | Initial "empty" environment state. startEnv :: Env@@ -556,6 +546,8 @@ , loaded = [] , stack = [] , parserState = startParserState+ , dynamic = M.empty+ , unwinds = [] } -- | Evaluate x with e as the environment.@@ -568,6 +560,36 @@ -----------------------------------------------------------------------------+-- Dynamic environment ------------------------------------------------------+-----------------------------------------------------------------------------++newDynamic :: String -> Value -> DynamicMap -> DynamicMap+newDynamic n v m =+ M.insert (hash n) [v] m++bindDynamic :: String -> Value -> DynamicMap -> DynamicMap+bindDynamic n v m =+ M.adjust (v:) (hash n) m++unbindDynamic :: String -> DynamicMap -> DynamicMap+unbindDynamic n m =+ M.adjust tail (hash n) m++setDynamic :: String -> Value -> DynamicMap -> DynamicMap+setDynamic n v m =+ M.adjust ((v:) . tail) (hash n) m++getDynamic :: String -> DynamicMap -> Maybe Value+getDynamic n m = M.lookup (hash n) m >>= listToMaybe++isBound :: String -> DynamicMap -> Bool+isBound n m =+ case M.lookup (hash n) m of+ Just x -> length x > 1+ Nothing -> False+++----------------------------------------------------------------------------- -- Helpers ------------------------------------------------------------------ ----------------------------------------------------------------------------- @@ -612,34 +634,24 @@ fromList v = error $ "no fromList for: " ++ show v -- | Create a single message with a given name and target.-single :: String -> Value -> Message+single :: String -> v -> Message v {-# INLINE single #-} single n = Single (hash n) n -- | Create a keyword message with a given name and targets.-keyword :: [String] -> [Value] -> Message+keyword :: [String] -> [v] -> Message v {-# INLINE keyword #-} keyword ns = Keyword (hash ns) ns -- | Create a single message pattern with a given name and target pattern. psingle :: String -> Pattern -> Pattern {-# INLINE psingle #-}-psingle n = PSingle (hash n) n+psingle n = PMessage . single n -- | Create a keyword message pattern with a given name and target patterns. pkeyword :: [String] -> [Pattern] -> Pattern {-# INLINE pkeyword #-}-pkeyword ns = PKeyword (hash ns) ns---- | Create a single message expression with a given name and target expression.-esingle :: String -> Expr -> EMessage-{-# INLINE esingle #-}-esingle n = ESingle (hash n) n---- | Create a keyword message expression with a given name and target expressions.-ekeyword :: [String] -> [Expr] -> EMessage-{-# INLINE ekeyword #-}-ekeyword ns = EKeyword (hash ns) ns+pkeyword ns = PMessage . keyword ns -- | Is a value a `Block'? isBlock :: Value -> Bool@@ -716,10 +728,10 @@ isRational (Rational _) = True isRational _ = False --- | Is a value a `Reference'?-isReference :: Value -> Bool-isReference (Reference _) = True-isReference _ = False+-- | Is a value a `Object'?+isObject :: Value -> Bool+isObject (Object {}) = True+isObject _ = False -- | Is a value a `String'? isString :: Value -> Bool@@ -761,23 +773,23 @@ asValue (DynamicNeeded t) = keyParticleN ["dynamic-needed"] [string t] --- | Given a record of primitive IDs, get the object reference backing a value.-orefFrom :: IDs -> Value -> ORef-{-# INLINE orefFrom #-}-orefFrom _ (Reference r) = r-orefFrom ids (Block _ _ _) = idBlock ids-orefFrom ids (Boolean _) = idBoolean ids-orefFrom ids (Char _) = idChar ids-orefFrom ids (Continuation _) = idContinuation ids-orefFrom ids (Double _) = idDouble ids-orefFrom ids (Expression _) = idExpression ids-orefFrom ids (Haskell _) = idHaskell ids-orefFrom ids (Integer _) = idInteger ids-orefFrom ids (List _) = idList ids-orefFrom ids (Message _) = idMessage ids-orefFrom ids (Method _) = idMethod ids-orefFrom ids (Particle _) = idParticle ids-orefFrom ids (Process _ _) = idProcess ids-orefFrom ids (Pattern _) = idPattern ids-orefFrom ids (Rational _) = idRational ids-orefFrom ids (String _) = idString ids+-- | Given a record of primitive IDs, get the object backing a value.+objectFrom :: IDs -> Value -> Value+{-# INLINE objectFrom #-}+objectFrom _ o@(Object {}) = o+objectFrom ids (Block _ _ _) = idBlock ids+objectFrom ids (Boolean _) = idBoolean ids+objectFrom ids (Char _) = idChar ids+objectFrom ids (Continuation _) = idContinuation ids+objectFrom ids (Double _) = idDouble ids+objectFrom ids (Expression _) = idExpression ids+objectFrom ids (Haskell _) = idHaskell ids+objectFrom ids (Integer _) = idInteger ids+objectFrom ids (List _) = idList ids+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 (Rational _) = idRational ids+objectFrom ids (String _) = idString ids
src/Atomo/VMT.hs view
@@ -1,56 +1,31 @@ module Atomo.VMT where -import "monads-fd" Control.Monad.Cont-import "monads-fd" Control.Monad.State-import "monads-fd" Control.Monad.Trans+import Control.Monad.Cont+import Control.Monad.State+import Control.Monad.Trans import Atomo.Types -- | A monad transformer for Atomo's VM which just passes around the VM -- environment.-newtype VMT m a =- VMT- { runVMT :: Env -> m (a, Env)- }--instance Monad m => Monad (VMT m) where- x >>= f = VMT $ \e -> do- (v, e') <- runVMT x e- runVMT (f v) e'-- return x = VMT $ \e -> return (x, e)--instance MonadTrans VMT where- lift m = VMT $ \e -> do- a <- m- return (a, e)--instance MonadIO m => MonadIO (VMT m) where- liftIO f = VMT $ \e -> do- x <- liftIO f- return (x, e)--instance MonadCont m => MonadCont (VMT m) where- callCC f = VMT $ \e ->- callCC $ \c -> runVMT (f (\a -> VMT (\e' -> c (a, e')))) e-+type VMT = StateT Env -- | Execute a VM action inside a VMT monad. vm :: MonadIO m => VM Value -> VMT m Value-vm x = VMT (liftIO . runStateT (runContT x return))+vm x = StateT (liftIO . runStateT (runContT x return)) -- | Like `vm', but ignores the result. vm_ :: MonadIO m => VM a -> VMT m () vm_ x = vm (x >> return (particle "ok")) >> return () --- | Grab the underlying VM envionment.+-- | Grab the underlying VM environment. getEnv :: Monad m => VMT m Env-getEnv = VMT $ \e -> return (e, e)+getEnv = StateT $ \e -> return (e, e) -- | Replace the underlying VM environment. putEnv :: Monad m => Env -> VMT m ()-putEnv e = VMT $ \_ -> return ((), e)+putEnv e = StateT $ \_ -> return ((), e) -- | Execute a VMT monad with an initial environment, returning its result. execVM :: Monad m => VMT m a -> Env -> m a-execVM x e = liftM fst (runVMT x e)+execVM x e = liftM fst (runStateT x e)
src/Atomo/Valuable.hs view
@@ -1,7 +1,7 @@ module Atomo.Valuable where import Control.Monad (liftM)-import "monads-fd" Control.Monad.Trans (liftIO)+import Control.Monad.Trans (liftIO) import Data.IORef import qualified Data.Text as T import qualified Data.Vector as V
src/Main.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} module Main where -import "monads-fd" Control.Monad.Cont+import Control.Monad.Cont import System.Environment (getArgs) import Atomo