atomo 0.1.1 → 0.2
raw patch · 58 files changed
+2292/−1759 lines, 58 filesdep +mtl
Dependencies added: mtl
Files
- atomo.cabal +22/−8
- bin/eco +33/−0
- prelude/association.atomo +25/−0
- prelude/block.atomo +25/−0
- prelude/boolean.atomo +47/−0
- prelude/comparable.atomo +5/−0
- prelude/continuation.atomo +54/−0
- prelude/core.atomo +14/−0
- prelude/eco.atomo +219/−0
- prelude/list.atomo +15/−0
- prelude/numeric.atomo +8/−0
- prelude/parameter.atomo +38/−0
- prelude/particle.atomo +40/−0
- prelude/ports.atomo +50/−0
- prelude/time.atomo +42/−0
- prelude/version.atomo +69/−0
- src/Atomo.hs +23/−0
- src/Atomo/Core.hs +58/−0
- src/Atomo/Environment.hs +221/−309
- src/Atomo/Haskell.hs +0/−175
- src/Atomo/Kernel.hs +23/−52
- src/Atomo/Kernel.hs-boot +0/−5
- src/Atomo/Kernel/Association.hs +0/−38
- src/Atomo/Kernel/Block.hs +8/−49
- src/Atomo/Kernel/Boolean.hs +0/−66
- src/Atomo/Kernel/Comparable.hs +108/−129
- src/Atomo/Kernel/Concurrency.hs +4/−5
- src/Atomo/Kernel/Continuation.hs +6/−75
- src/Atomo/Kernel/Eco.hs +0/−288
- src/Atomo/Kernel/Environment.hs +5/−6
- src/Atomo/Kernel/Exception.hs +7/−7
- src/Atomo/Kernel/Expression.hs +16/−11
- src/Atomo/Kernel/List.hs +54/−114
- src/Atomo/Kernel/Message.hs +2/−3
- src/Atomo/Kernel/Method.hs +1/−2
- src/Atomo/Kernel/Numeric.hs +102/−23
- src/Atomo/Kernel/Parameter.hs +0/−42
- src/Atomo/Kernel/Particle.hs +31/−43
- src/Atomo/Kernel/Pattern.hs +9/−4
- src/Atomo/Kernel/Ports.hs +33/−104
- src/Atomo/Kernel/String.hs +25/−28
- src/Atomo/Kernel/Time.hs +2/−51
- src/Atomo/Load.hs +82/−0
- src/Atomo/Method.hs +6/−0
- src/Atomo/Parser.hs +159/−35
- src/Atomo/Parser/Base.hs +7/−8
- src/Atomo/Parser/Pattern.hs +46/−1
- src/Atomo/Parser/Pattern.hs-boot +2/−1
- src/Atomo/Parser/Primitive.hs +16/−0
- src/Atomo/Pretty.hs +23/−2
- src/Atomo/PrettyVM.hs +40/−0
- src/Atomo/QuasiQuotes.hs +187/−0
- src/Atomo/Run.hs +82/−0
- src/Atomo/Spawn.hs +24/−0
- src/Atomo/Types.hs +109/−62
- src/Atomo/VMT.hs +51/−0
- src/Atomo/Valuable.hs +5/−5
- src/Main.hs +9/−8
atomo.cabal view
@@ -1,5 +1,5 @@ name: atomo-version: 0.1.1+version: 0.2 synopsis: A highly dynamic, extremely simple, very fun programming language. description:@@ -29,6 +29,10 @@ cabal-version: >= 1.6 +extra-source-files: bin/eco++data-files: prelude/*.atomo+ source-repository head type: darcs location: http://darcsden.com/alex/atomo@@ -49,6 +53,7 @@ hashable, hint, monads-fd,+ mtl, parsec >= 3.0.0, pretty, split,@@ -57,17 +62,26 @@ time, vector + extensions: PackageImports+ exposed-modules:+ Atomo,+ Atomo.Core, Atomo.Environment,- Atomo.Haskell,+ Atomo.Load, Atomo.Method, Atomo.Parser, Atomo.Parser.Base, Atomo.Parser.Pattern, Atomo.Parser.Primitive, Atomo.Pretty,+ Atomo.PrettyVM,+ Atomo.QuasiQuotes,+ Atomo.Run,+ Atomo.Spawn, Atomo.Types,- Atomo.Valuable+ Atomo.Valuable,+ Atomo.VMT other-modules: Atomo.Debug,@@ -85,13 +99,10 @@ Atomo.Kernel.Pattern, Atomo.Kernel.Ports, Atomo.Kernel.Time,- Atomo.Kernel.Boolean,- Atomo.Kernel.Association,- Atomo.Kernel.Parameter, Atomo.Kernel.Exception, Atomo.Kernel.Environment,- Atomo.Kernel.Eco,- Atomo.Kernel.Continuation+ Atomo.Kernel.Continuation,+ Paths_atomo executable atomo@@ -102,6 +113,8 @@ ghc-options: -Wall -threaded -fno-warn-unused-do-bind -funfolding-use-threshold=9999 + extensions: PackageImports+ build-depends: base >= 4 && < 5, containers,@@ -111,6 +124,7 @@ haskeline, hint, monads-fd,+ mtl, parsec >= 3.0.0, pretty, split,
+ bin/eco view
@@ -0,0 +1,33 @@+#!/usr/bin/env atomo++Environment arguments tail match: {+ ("install" . path . _) ->+ Eco install: path++ ("install" . _) ->+ Eco install: "."++ ("uninstall" . name . version . _) ->+ Eco uninstall: name version: (version as: Version)++ ("uninstall" . name . _) ->+ Eco uninstall: name++ ("list" . _) ->+ Eco packages each: { p |+ pkgs = p to+ p from print+ ("\tdescription: " .. pkgs head description) print+ ("\tlatest version: " .. pkgs head version (as: String)) print+ ("\tavailable versions: " .. pkgs (map: { p | p version as: String }) (join: ", ")) print+ "" print+ }++ _ -> {+ "usage:" print+ "\tinstall PATH:\tinstall package at PATH to ~/.eco" print+ "\tinstall:\tinstall package at cwd to ~/.eco" print+ "\tuninstall NAME VERSION:\tuninstall package NAME version VERSION" print+ "\tuninstall NAME:\tuninstall package all versions of package NAME" print+ } call+}
+ prelude/association.atomo view
@@ -0,0 +1,25 @@+operator right 1 ->++Association = Object clone+a -> b := Association clone do: { from = a; to = b }++(a: Association) show :=+ a from show .. " -> " .. a to show++[] lookup: _ = @none+(a . as) lookup: k :=+ if: (k == a from)+ then: { @(ok: a to) }+ else: { as lookup: k }++[] find: _ = @none+(a . as) find: k :=+ if: (k == a from)+ then: { @(ok: a) }+ else: { as find: k }++[] set: k to: v := [k -> v]+(a . as) set: k to: v :=+ if: (k == a from)+ then: { (k -> v) . as }+ else: { a . (as set: k to: v) }
+ prelude/block.atomo view
@@ -0,0 +1,25 @@+(b: Block) repeat :=+ { b in-context call+ b repeat+ } call++(b: Block) in-context :=+ b clone do:+ { call := b context join: b+ call: vs := b context join: b with: vs+ }++(a: Block) .. (b: Block) :=+ Block new: (a contents .. b contents) in: sender++(start: Integer) to: (end: Integer) by: (diff: Integer) do: b :=+ (start to: end by: diff) each: b++(start: Integer) up-to: (end: Integer) do: b :=+ start to: end by: 1 do: b++(start: Integer) down-to: (end: Integer) do: b :=+ start to: end by: -1 do: b++(n: Integer) times: (b: Block) :=+ 1 up-to: n do: b in-context
+ prelude/boolean.atomo view
@@ -0,0 +1,47 @@+False and: _ = False+True and: (b: Block) := b call++True or: _ = True+False or: (b: Block) := b call++macro a && b := `(~a and: { ~b })+macro a || b := `(~a or: { ~b })++True not := False+False not := True++if: True then: (a: Block) else: Block :=+ a call++if: False then: Block else: (b: Block) :=+ b call++when: False do: Block = @ok+when: True do: (action: Block) :=+ { action in-context call+ @ok+ } call++while: (test: Block) do: (action: Block) :=+ when: test call do:+ { action in-context call+ while: test do: action+ }++True show := "True"+False show := "False"++otherwise := True++macro condition: (bs: Block) :=+ { ps = bs contents map:+ { pair |+ [c, e] = pair targets+ c -> e+ }++ ps reduce-right:+ { pair x |+ `(if: ~(pair from) then: { ~(pair to) } else: { ~x })+ } with: `(raise: @no-true-branches)+ } call
+ prelude/comparable.atomo view
@@ -0,0 +1,5 @@+x max: y :=+ if: (x > y) then: { x } else: { y }++x min: y :=+ if: (x < y) then: { x } else: { y }
+ prelude/continuation.atomo view
@@ -0,0 +1,54 @@+{ dynamic-winds = Parameter new: []++ (o: Object) call/cc :=+ { 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]+ } 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 _?)++ { v call } ensuring:+ { dynamic-winds =! dynamic-winds _? tail+ a call+ }+ } 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
+ prelude/core.atomo view
@@ -0,0 +1,14 @@+macro x match: (ts: Block) :=+ { obj = Object clone++ (obj) match-on: x := raise: @(no-matches-for: x)++ ts contents each:+ { pair |+ [p, e] = pair targets+ @match-on: define-on: [obj, p as: Pattern] as:+ `({ delegates-to: sender; ~e } call) in: Lobby+ }++ `(~obj match-on: ~x)+ } call
+ prelude/eco.atomo view
@@ -0,0 +1,219 @@+Eco =+ Object clone do:+ { -- all packages OK for loading+ -- name -> [package]+ packages = []++ -- versions loaded by @use:+ -- name -> package+ loaded = []+ }++Eco Package = Object clone++Eco Package new :=+ Eco Package clone do:+ { version = 0 . 1+ dependencies = []+ include = []+ executables = []+ contexts = []+ environment = Lobby+ }++(e: Eco) initialize :=+ e initialize: (Eco Package load-from: "package.eco")++(e: Eco) initialize: pkg :=+ { pkg dependencies each: { c |+ e packages (find: c from) match: {+ @none -> raise: @(package-unavailable: c from needed: c to)++ -- filter out versions not satisfying our dependency+ @(ok: d) ->+ { safe = d to (filter: { p | p version join: c to })++ safe match: {+ [] ->+ raise: @(no-versions-of: d satisfy: c to for: pkg name)++ -- initialize the first safe version of the package+ (p . _) ->+ { -- remove unsafe versions from the ecosystem+ d to = safe+ e initialize: p+ } call+ }+ } call+ }+ }++ @ok+ } call++(e: Eco) load :=+ { eco = Directory home </> ".eco" </> "lib"++ when: Directory (exists?: eco) do: {+ e packages =+ Directory (contents: eco) map:+ { c |+ versions = Directory (contents: (eco </> c))+ pkgs = versions map:+ { v |+ Eco Package load-from:+ (eco </> c </> v </> "package.eco")+ }++ c -> pkgs (sort-by: { a b | a version < b version })+ }+ }++ @ok+ } call++Eco path-to: (c: Eco Package) :=+ Eco path-to: c name version: c version++Eco path-to: (name: String) :=+ Directory home </> ".eco" </> "lib" </> name++Eco path-to: pkg version: (v: Version) :=+ (Eco path-to: pkg) </> (v as: String)++Eco executable: (name: String) :=+ Directory home </> ".eco" </> "bin" </> name++Eco which-main: (path: String) :=+ if: File (exists?: (path </> "main.hs"))+ then: { "main.hs" }+ else: { "main.atomo" }++Eco install: (path: String) :=+ { pkg = Eco Package load-from: (path </> "package.eco")+ target = Eco path-to: pkg++ contents = (Eco which-main: path) . ("package.eco" . pkg include)++ Directory create-tree-if-missing: target++ contents each:+ { c |+ if: Directory (exists?: (path </> c))+ then: { Directory copy: (path </> c) to: (target </> c) }+ else: { File copy: (path </> c) to: (target </> c) }+ }++ pkg executables each:+ { e |+ exe =+ [ "#!/usr/bin/env atomo"+ "load: " .. (path </> e to) show+ ] unlines++ with-output-to: (Eco executable: e from) do: { exe print }++ File set-executable: (Eco executable: e from) to: True+ }++ @ok+ } call++Eco uninstall: (name: String) version: (version: Version) :=+ { path = Eco path-to: name version: version+ pkg = Eco Package load-from: (path </> "package.eco")++ Directory remove-recursive: path+ pkg executables each:+ { e |+ File remove: (Eco executable: e from)+ }+ + @ok+ } call++Eco uninstall: (name: String) :=+ { Directory (contents: (Eco path-to: name)) each:+ { v |+ Eco uninstall: name version: (v as: Version)+ }++ @ok+ } call++Eco Package load-from: (file: String) :=+ Eco Package new do: { load: file }++(p: Eco Package) name: (n: String) :=+ p name = n++(p: Eco Package) description: (d: String) :=+ p description = d++(p: Eco Package) version: (v: Version) :=+ p version = v++(p: Eco Package) author: (a: String) :=+ p author = a++(p: Eco Package) include: (l: List) :=+ p include = l++(p: Eco Package) depends-on: (ds: List) :=+ p dependencies = ds map:+ { d |+ if: (d is-a?: Association)+ then: { d }+ else: { d -> { True } }+ }++(p: Eco Package) executables: (es: List) :=+ p executables = es++Eco load: name version: check in: env :=+ Eco packages (lookup: name) match: {+ @none -> raise: @(package-unavailable: name)+ @(ok: []) -> raise: @(no-package-versions: name)+ @(ok: pkgs) ->+ { pkg =+ pkgs (filter: { p | p version join: check }) match: {+ [] -> raise: @(no-versions-of: name satisfy: check)+ (p . _) -> p+ }++ path = Eco path-to: pkg++ pkg contexts = pkg contexts << env super++ env load: (path </> (Eco which-main: path))++ pkg environment = env++ when: name (in?: Eco loaded (map: @from)) not do:+ { Eco loaded = Eco loaded << (name -> pkg) }++ env+ } call+ }++context use: (name: String) :=+ context use: name version: { True }++context use: (name: String) version: (v: Version) :=+ context use: name version: { == v }++context use: (name: String) version: (check: Block) :=+ Eco loaded (lookup: name) match: {+ @none -> (Eco load: name version: check in: context clone)++ @(ok: p) ->+ condition: {+ p version (join: check) not ->+ raise: @(incompatible-version-loaded: name needed: check)++ (context in?: p contexts) -> p environment++ otherwise ->+ (Eco load: name version: check in: context clone)+ }+ }
+ prelude/list.atomo view
@@ -0,0 +1,15 @@+(l: List) each: (b: Block) :=+ { l map: b in-context+ l+ } call++[] includes?: List := False+(x: List) includes?: (y: List) :=+ if: (x (take: y length) == y)+ then: { True }+ else: { x tail includes?: y }++[] join: List := []+[x] join: List := x+(x . xs) join: (d: List) :=+ x .. d .. (xs join: d)
+ prelude/numeric.atomo view
@@ -0,0 +1,8 @@+(n: Integer) even? := 2 divides?: n+(n: Integer) odd? := n even? not++(x: Integer) divides?: (y: Integer) :=+ (y % x) == 0++(x: Integer) divisible-by?: (y: Integer) :=+ y divides?: x
+ prelude/parameter.atomo view
@@ -0,0 +1,38 @@+operator right 0 =!++Parameter = Object clone+Parameter new: v := Parameter clone do:+ { set-default: v+ }++context define: (name: Particle) as: root :=+ name define-on: [context] as: (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) value: _ = 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 = p _?+ action before: { p set-default: new } after: { p set-default: old }+ } call++with: [] do: (action: Block) := action call+with: (b . bs) do: (action: Block) :=+ with: b from as: b to do: { with: bs do: action }++with-defaults: [] do: (action: Block) := action call+with-defaults: (b . bs) do: (action: Block) :=+ with-default: b from as: b to do: { with: bs do: action }
+ prelude/particle.atomo view
@@ -0,0 +1,40 @@+(p: Particle) show :=+ p type match: {+ @keyword ->+ { operator?: str := str all?: @(in?: "~!@#$%^&*-_=+./\\|<>?:")++ keywordfy: str :=+ if: (operator?: str)+ then: { str }+ else: { str .. ":" }+ + vs := p values map:+ { v |+ v match:+ { @none -> "_"+ @(ok: v) -> v show+ }+ }++ initial :=+ vs head match: {+ "_" -> ""+ v -> v .. " "+ }++ rest :=+ (p names zip: vs tail)+ (map:+ { pair |+ keywordfy: pair from .. " " .. pair to+ })+ (join: " ")++ if: p values (all?: @(== @none))+ then: { "@" .. p names (map: { n | keywordfy: n }) join }+ else: { "@(" .. initial .. rest .. ")" }+ } call++ @single ->+ ("@" .. p name)+ }
+ prelude/ports.atomo view
@@ -0,0 +1,50 @@+current-output-port = Parameter new: Port standard-output+current-input-port = Parameter new: Port standard-input++(x: Object) print := current-output-port _? print: x+(x: Object) display := current-output-port _? display: x++read := current-input-port _? read+read-line := current-input-port _? read-line+read-char := current-input-port _? read-char++contents := current-input-port _? contents+ready? := current-input-port _? ready?+eof? := current-input-port _? eof?++with-output-to: (fn: String) do: b :=+ { Port (new: fn mode: @write) } wrap: @close do:+ { file |+ with-output-to: file do: b+ }++with-output-to: (p: Port) do: b :=+ with: current-output-port as: p do: b++with-input-from: (fn: String) do: (b: Block) :=+ { Port (new: fn mode: @read) } wrap: @close do:+ { file |+ with-input-from: file do: b+ }++with-input-from: (p: Port) do: (b: Block) :=+ with: current-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: current-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: current-input-port as: p do: b
+ prelude/time.atomo view
@@ -0,0 +1,42 @@+Timer do: (b: Block) every: (n: Number) :=+ { { Timer sleep: n; b spawn } repeat } spawn++Timer do: (b: Block) after: (n: Number) :=+ { Timer sleep: n; b call } spawn++(b: Block) time :=+ { before = Timer now+ b call+ after = Timer now+ after - before+ } call++-- units!+(n: Number) us := n+(n: Number) microseconds := n us+(n: Number) microsecond := n us++(n: Number) ms := n * 1000+(n: Number) milliseconds := n ms+(n: Number) millisecond := n ms++(n: Number) seconds := n * 1000000+(n: Number) second := n seconds++(n: Number) minutes := (n * 60) seconds+(n: Number) minute := n minutes++(n: Number) hours := (n * 60) minutes+(n: Number) hour := n hours++(n: Number) days := (n * 24) hours+(n: Number) day := n days++(n: Number) weeks := (n * 7) days+(n: Number) week := n weeks++(n: Number) months := (n * 30) days+(n: Number) month := n months++(n: Number) years := (n * 365) days+(n: Number) year := n years
+ prelude/version.atomo view
@@ -0,0 +1,69 @@+Version = Object clone++(major: Integer) . (minor: Integer) :=+ Version clone do:+ { major = major+ minor = minor+ }++(major: Integer) . (rest: Version) :=+ Version clone do:+ { major = major+ minor = rest+ }++(v: Version) show :=+ v major show .. " . " .. v minor show++(v: Version) as: String :=+ v major show .. "." .. v minor (as: String)++(s: String) as: Version :=+ s (split-on: '.') (map: @(as: Integer)) reduce-right: @.++(n: Integer) as: Version := n . 0++(a: Version) == (b: Version) :=+ a major == b major && a minor == b minor++(n: Integer) == (v: Version) :=+ (n == v major) && (v minor == 0)++(v: Version) == (n: Integer) :=+ (n == v major) && (v minor == 0)++(a: Version) > (b: Version) :=+ a major > b major || a minor > b minor++(n: Integer) > (v: Version) :=+ n > v major || v major == n && v minor /= 0++(v: Version) > (n: Integer) :=+ v major > n || v major == n && v minor /= 0++(a: Version) < (b: Version) :=+ a major < b major || a minor < b minor++(n: Integer) < (v: Version) :=+ n < v major || v major == n && v minor /= 0++(v: Version) < (n: Integer) :=+ v major < n || v major == n && v minor /= 0++(a: Version) >= (b: Version) :=+ a major >= b major || a minor >= b minor++(n: Integer) >= (v: Version) :=+ n >= v major++(v: Version) >= (n: Integer) :=+ v major >= n++(a: Version) <= (b: Version) :=+ a major <= b major || a minor <= b minor++(n: Integer) <= (v: Version) :=+ n <= v major++(v: Version) <= (n: Integer) :=+ v major <= n
+ src/Atomo.hs view
@@ -0,0 +1,23 @@+module Atomo+ ( module Atomo.Environment+ , module Atomo.QuasiQuotes+ , module Atomo.Types++ , module Control.Concurrent+ , module Control.Monad+ , module Control.Monad.Cont+ , module Control.Monad.Error+ , module Control.Monad.State+ , module Control.Monad.Trans+ ) where++import Control.Concurrent+import Control.Monad+import "monads-fd" Control.Monad.Cont (MonadCont(..), ContT(..))+import "monads-fd" Control.Monad.Error (MonadError(..), ErrorT(..))+import "monads-fd" Control.Monad.State (MonadState(..), StateT(..), evalStateT, gets, modify)+import "monads-fd" Control.Monad.Trans++import Atomo.Environment+import Atomo.QuasiQuotes+import Atomo.Types
+ src/Atomo/Core.hs view
@@ -0,0 +1,58 @@+module Atomo.Core where++import Control.Concurrent+import "monads-fd" Control.Monad.State++import Atomo.Types+import Atomo.Environment+++initCore :: VM ()+initCore = do+ -- the very root object+ object <- newObject id++ -- top scope is a proto delegating to the root object+ topObj <- newObject $ \o -> o { oDelegates = [object] }+ modify $ \e -> e { top = topObj }++ -- Lobby is the very bottom scope object+ define (psingle "Lobby" PThis) (Primitive Nothing topObj)++ -- define Object as the root object+ define (psingle "Object" PThis) (Primitive Nothing object)+ modify $ \e -> e+ { primitives = (primitives e) { idObject = rORef object }+ }++ -- this thread's channel+ chan <- liftIO newChan+ modify $ \e -> e { channel = chan }++ -- 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) }+ where+ primObjs =+ [ ("Block", \is r -> is { idBlock = r })+ , ("Boolean", \is r -> is { idBoolean = r })+ , ("Char", \is r -> is { idChar = r })+ , ("Continuation", \is r -> is { idContinuation = r })+ , ("Double", \is r -> is { idDouble = r })+ , ("Expression", \is r -> is { idExpression = r })+ , ("Haskell", \is r -> is { idHaskell = r })+ , ("Integer", \is r -> is { idInteger = r })+ , ("List", \is r -> is { idList = r })+ , ("Message", \is r -> is { idMessage = r })+ , ("Method", \is r -> is { idMethod = r })+ , ("Particle", \is r -> is { idParticle = r })+ , ("Process", \is r -> is { idProcess = r })+ , ("Pattern", \is r -> is { idPattern = r })+ , ("Rational", \is r -> is { idRational = r })+ , ("String", \is r -> is { idString = r })+ ]+++
src/Atomo/Environment.hs view
@@ -1,157 +1,20 @@ {-# LANGUAGE BangPatterns #-} module Atomo.Environment where -import Control.Monad.Cont-import Control.Monad.Error-import Control.Monad.State-import Control.Concurrent (forkIO)-import Control.Concurrent.Chan+import "monads-fd" Control.Monad.Cont+import "monads-fd" Control.Monad.Error+import "monads-fd" Control.Monad.State import Data.IORef import Data.List (nub) import Data.Maybe (isJust)-import System.Directory-import System.FilePath import System.IO.Unsafe import qualified Data.Text as T import qualified Data.Vector as V-import qualified Language.Haskell.Interpreter as H-import qualified Text.PrettyPrint as P import Atomo.Method-import Atomo.Parser-import Atomo.Pretty import Atomo.Types-import {-# SOURCE #-} qualified Atomo.Kernel as Kernel --------------------------------------------------------------------------------- Execution -------------------------------------------------------------------------------------------------------------------------------------------------- | execute an action in a new thread, initializing the environment and--- printing a traceback on error-exec :: VM Value -> IO ()-exec x = execWith (initEnv >> x) startEnv---- | execute an action in a new thread, printing a traceback on error-execWith :: VM Value -> Env -> IO ()-execWith x e = do- haltChan <- newChan-- forkIO $ do- runWith (go x >> gets halt >>= liftIO >> return (particle "ok")) e- { halt = writeChan haltChan ()- }-- return ()-- readChan haltChan---- | execute x, printing an error if there is one-go :: VM Value -> VM Value-go x = catchError x (\e -> printError e >> return (particle "ok"))---- | execute x, initializing the environment with initEnv-run :: VM Value -> IO (Either AtomoError Value)-run x = runWith (initEnv >> x) startEnv---- | evaluate x with e as the environment-runWith :: VM Value -> Env -> IO (Either AtomoError Value)-runWith x e = evalStateT (runContT (runErrorT x) return) e---- | print an error, including the previous 10 expressions evaluated--- with the most recent on the bottom-printError :: AtomoError -> VM ()-printError err = do- t <- traceback-- if not (null t)- then do- liftIO (putStrLn "traceback:")-- forM_ t $ \e -> liftIO $- print (prettyStack e)-- liftIO (putStrLn "")- else return ()-- prettyError err >>= liftIO . print-- modify $ \s -> s { stack = [] }- where- traceback = fmap (reverse . take 10 . reverse) (gets stack)--prettyError :: AtomoError -> VM P.Doc-prettyError (Error v) = fmap (P.text "error:" P.<+>) (prettyVM v)-prettyError e = return (pretty e)---- | pretty-print by sending \@show to the object-prettyVM :: Value -> VM P.Doc-prettyVM = fmap (P.text . fromString) . dispatch . (single "show")---- | spawn a process to execute x. returns the Process.-spawn :: VM Value -> VM Value-spawn x = do- e <- get- chan <- liftIO newChan- tid <- liftIO . forkIO $ do- runWith (go x >> return (particle "ok")) (e { channel = chan })- return ()-- return (Process chan tid)---- | set up the primitive objects, etc.-initEnv :: VM ()-{-# INLINE initEnv #-}-initEnv = do- -- the very root object- object <- newObject id-- -- top scope is a proto delegating to the root object- topObj <- newObject $ \o -> o { oDelegates = [object] }- modify $ \e -> e { top = topObj }-- -- define Object as the root object- define (psingle "Object" PThis) (Primitive Nothing object)- modify $ \e -> e- { primitives = (primitives e) { idObject = rORef object }- }-- -- this thread's channel- chan <- liftIO newChan- modify $ \e -> e { channel = chan }-- -- 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) }-- Kernel.load- where- primObjs =- [ ("Block", \is r -> is { idBlock = r })- , ("Char", \is r -> is { idChar = r })- , ("Continuation", \is r -> is { idContinuation = r })- , ("Double", \is r -> is { idDouble = r })- , ("Expression", \is r -> is { idExpression = r })- , ("Haskell", \is r -> is { idHaskell = r })- , ("Integer", \is r -> is { idInteger = r })- , ("List", \is r -> is { idList = r })- , ("Message", \is r -> is { idMessage = r })- , ("Method", \is r -> is { idMethod = r })- , ("Particle", \is r -> is { idParticle = r })- , ("Process", \is r -> is { idProcess = r })- , ("Pattern", \is r -> is { idPattern = r })- , ("String", \is r -> is { idString = r })- ]------------------------------------------------------------------------------------ General ------------------------------------------------------------------------------------------------------------------------------------------------- -- | evaluation eval :: Expr -> VM Value eval e = eval' e `catchError` pushStack@@ -173,15 +36,7 @@ return v eval' (Set { ePattern = p, eExpr = ev }) = do v <- eval ev-- is <- gets primitives- if match is p v- then do- forM_ (bindings' p v) $ \(p', v') -> do- define p' (Primitive (eLocation ev) v')-- return v- else throwError (Mismatch p v)+ set p v eval' (Dispatch { eMessage = ESingle { emID = i@@ -202,37 +57,104 @@ dispatch (Keyword i ns vs) eval' (Operator { eNames = ns, eAssoc = a, ePrec = p }) = do forM_ ns $ \n -> modify $ \s ->- s { parserState = (n, (a, p)) : parserState s }+ s+ { parserState =+ (parserState s)+ { psOperators =+ (n, (a, p)) : psOperators (parserState s)+ }+ } return (particle "ok") eval' (Primitive { eValue = v }) = return v eval' (EBlock { eArguments = as, eContents = es }) = do t <- gets top return (Block t as es)- eval' (EDispatchObject {}) = do- c <- gets call- newObject $ \o -> o- { oMethods =- ( toMethods- [ (psingle "sender" PThis, callSender c)- , (psingle "message" PThis, Message (callMessage c))- , (psingle "context" PThis, callContext c)- ]- , emptyMap- )- } eval' (EList { eContents = es }) = do vs <- mapM eval es- list vs+ 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' (EParticle { eParticle = EPMSingle n }) = return (Particle $ PMSingle n) eval' (EParticle { eParticle = EPMKeyword ns mes }) = do mvs <- forM mes $- maybe (return Nothing) (fmap Just . eval)+ maybe (return Nothing) (liftM Just . eval) return (Particle $ PMKeyword ns mvs) eval' (ETop {}) = gets top eval' (EVM { eAction = x }) = x+ eval' (EUnquote { eExpr = e' }) = raise ["out-of-quote"] [Expression e']+ eval' (EQuote { eExpr = qe }) = do+ unquoted <- unquote 0 qe+ return (Expression unquoted)+ where+ unquote :: Int -> Expr -> VM Expr+ unquote 0 (EUnquote { eExpr = e' }) = do+ r <- eval e'+ case r of+ Expression e'' -> return e''+ _ -> return (Primitive Nothing r)+ unquote n u@(EUnquote { eExpr = e' }) = do+ ne <- unquote (n - 1) e'+ return (u { eExpr = ne })+ unquote n d@(Define { eExpr = e' }) = do+ ne <- unquote n e'+ return (d { eExpr = ne })+ unquote n s@(Set { eExpr = e' }) = do+ ne <- unquote n e'+ return (s { eExpr = ne })+ unquote n d@(Dispatch { eMessage = em }) =+ case em of+ EKeyword { emTargets = ts } -> do+ nts <- mapM (unquote n) ts+ return d { eMessage = em { emTargets = nts } } + ESingle { emTarget = t } -> do+ nt <- unquote n t+ return d { eMessage = em { emTarget = nt } }+ unquote n b@(EBlock { eContents = es }) = do+ nes <- mapM (unquote n) es+ return b { eContents = nes }+ unquote n l@(EList { eContents = es }) = do+ nes <- mapM (unquote n) es+ return l { eContents = nes }+ unquote n m@(EMacro { eExpr = e' }) = do+ ne <- unquote n e'+ return m { eExpr = ne }+ unquote n p@(EParticle { eParticle = ep }) =+ case ep of+ EPMKeyword ns mes -> do+ nmes <- forM mes $ \me ->+ case me of+ Nothing -> return Nothing+ Just e' -> liftM Just (unquote n e')++ return p { eParticle = EPMKeyword ns nmes }++ _ -> return p+ unquote n q@(EQuote { eExpr = e' }) = do+ ne <- unquote (n + 1) e'+ return q { eExpr = ne }+ unquote _ p@(Primitive {}) = return p+ unquote _ t@(ETop {}) = return t+ unquote _ v@(EVM {}) = return v+ unquote _ o@(Operator {}) = return o+ -- | evaluating multiple expressions, returning the last result evalAll :: [Expr] -> VM Value evalAll [] = throwError NoExpressions@@ -241,7 +163,7 @@ -- | object creation newObject :: (Object -> Object) -> VM Value-newObject f = fmap Reference . liftIO $+newObject f = liftM Reference . liftIO $ newIORef . f $ Object { oDelegates = [] , oMethods = noMethods@@ -304,9 +226,9 @@ methodPattern p'@(PKeyword { ppTargets = ts }) = do ts' <- mapM methodPattern ts return p' { ppTargets = ts' }- methodPattern PThis = fmap PMatch (gets top)- methodPattern (PObject oe) = fmap PMatch (eval oe)- methodPattern (PNamed n p') = fmap (PNamed n) (methodPattern p')+ methodPattern PThis = liftM PMatch (gets top)+ methodPattern (PObject oe) = liftM PMatch (eval oe)+ methodPattern (PNamed n p') = liftM (PNamed n) (methodPattern p') methodPattern p' = return p' -- | Swap out a reference match with PThis, for inserting on the object@@ -322,6 +244,17 @@ setSelf _ p' = p' +set :: Pattern -> Value -> VM Value+set p v = do+ is <- gets primitives+ if match is p v+ then do+ forM_ (bindings' p v) $ \(p', v') -> do+ define p' (Primitive Nothing v')++ return v+ else throwError (Mismatch p v)+ -- | find the target objects for a pattern targets :: IDs -> Pattern -> VM [ORef] targets _ (PMatch v) = orefFor v >>= return . (: [])@@ -394,14 +327,16 @@ o <- liftIO (readIORef r) case relevant (is { idMatch = r }) o m of Nothing -> findFirstMethod m (oDelegates o)- Just mt -> return (Just mt)+ mt -> return mt -- | find the first value that has a method defiend for `m' findFirstMethod :: Message -> [Value] -> VM (Maybe Method) findFirstMethod _ [] = return Nothing findFirstMethod m (v:vs) = do- findMethod v m- >>= maybe (findFirstMethod m vs) (return . Just)+ r <- findMethod v m+ case r of+ Nothing -> findFirstMethod m vs+ _ -> return r -- | find a relevant method for message `m' on object `o' relevant :: IDs -> Object -> Message -> Maybe Method@@ -425,8 +360,8 @@ refMatch ids (idMatch ids) y match ids PThis y = match ids (PMatch (Reference (idMatch ids))) (Reference (orefFrom ids y))-match ids (PMatch (Reference x)) (Reference y) =- refMatch ids x y+match ids (PMatch x) (Reference y) =+ refMatch ids (orefFrom ids x) y match ids (PMatch (Reference x)) y = match ids (PMatch (Reference x)) (Reference (orefFrom ids y)) match _ (PMatch x) y =@@ -441,19 +376,28 @@ matchAll ids ps ts match ids (PNamed _ p) v = match ids p v match _ PAny _ = True-match ids (PList ps) (List v) = matchAll ids ps vs- where- vs = V.toList $ unsafePerformIO (readIORef v)-match ids (PHeadTail hp tp) (List v) =+match ids (PList ps) (List v) = matchAll ids ps (V.toList v)+match ids (PHeadTail hp tp) (List vs) = V.length vs > 0 && match ids hp h && match ids tp t where- vs = unsafePerformIO (readIORef v) h = V.head vs- t = List (unsafePerformIO (newIORef (V.tail vs)))+ t = List (V.tail vs) match ids (PHeadTail hp tp) (String t) | not (T.null t) = match ids hp (Char (T.head t)) && match ids tp (String (T.tail t)) match ids (PPMKeyword ans aps) (Particle (PMKeyword bns mvs)) = ans == bns && matchParticle ids aps mvs+match _ PEDefine (Expression (Define {})) = True+match _ PESet (Expression (Set {})) = True+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 _ _ _ = False refMatch :: IDs -> ORef -> ORef -> Bool@@ -482,17 +426,22 @@ runMethod :: Method -> Message -> VM Value runMethod (Slot { mValue = v }) _ = return v runMethod (Responder { mPattern = p, mContext = c, mExpr = e }) m = do+ t <- gets top+ nt <- newObject $ \o -> o { oDelegates = [c]- , oMethods = (bindings p m, emptyMap)+ , oMethods =+ ( insertMap (Slot (psingle "sender" PThis) t) $ bindings p m+ , emptyMap+ ) } - modify $ \e' -> e'- { call = Call- { callSender = top e'- , callMessage = m- , callContext = c- }+ 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) } withTop nt $ eval e@@ -522,15 +471,12 @@ $ map (\(p, Just v) -> bindings' p v) $ filter (isJust . snd) $ zip ps mvs-bindings' (PList ps) (List v) = concat (zipWith bindings' ps vs)- where- vs = V.toList $ unsafePerformIO (readIORef v)-bindings' (PHeadTail hp tp) (List v) =+bindings' (PList ps) (List vs) = concat (zipWith bindings' ps (V.toList vs))+bindings' (PHeadTail hp tp) (List vs) = bindings' hp h ++ bindings' tp t where- vs = unsafePerformIO (readIORef v) h = V.head vs- t = List (unsafePerformIO (newIORef (V.tail vs)))+ t = List (V.tail vs) bindings' (PHeadTail hp tp) (String t) | not (T.null t) = bindings' hp (Char (T.head t)) ++ bindings' tp (String (T.tail t)) bindings' _ _ = []@@ -579,105 +525,137 @@ findValue' _ _ = return Nothing findBlock :: Value -> VM Value-{-# INLINE findBlock #-}-findBlock = findValue "Block" isBlock+findBlock v+ | isBlock v = return v+ | otherwise = findValue "Block" isBlock v +findBoolean :: Value -> VM Value+findBoolean v+ | isBoolean v = return v+ | otherwise = findValue "Boolean" isBoolean v+ findChar :: Value -> VM Value-{-# INLINE findChar #-}-findChar = findValue "Char" isChar+findChar v+ | isChar v = return v+ | otherwise = findValue "Char" isChar v findContinuation :: Value -> VM Value-{-# INLINE findContinuation #-}-findContinuation = findValue "Continuation" isContinuation+findContinuation v+ | isContinuation v = return v+ | otherwise = findValue "Continuation" isContinuation v findDouble :: Value -> VM Value-{-# INLINE findDouble #-}-findDouble = findValue "Double" isDouble+findDouble v+ | isDouble v = return v+ | otherwise = findValue "Double" isDouble v findExpression :: Value -> VM Value-{-# INLINE findExpression #-}-findExpression = findValue "Expression" isExpression+findExpression v+ | isExpression v = return v+ | otherwise = findValue "Expression" isExpression v findHaskell :: Value -> VM Value-{-# INLINE findHaskell #-}-findHaskell = findValue "Haskell" isHaskell+findHaskell v+ | isHaskell v = return v+ | otherwise = findValue "Haskell" isHaskell v findInteger :: Value -> VM Value-{-# INLINE findInteger #-}-findInteger = findValue "Integer" isInteger+findInteger v+ | isInteger v = return v+ | otherwise = findValue "Integer" isInteger v findList :: Value -> VM Value-{-# INLINE findList #-}-findList = findValue "List" isList+findList v+ | isList v = return v+ | otherwise = findValue "List" isList v findMessage :: Value -> VM Value-{-# INLINE findMessage #-}-findMessage = findValue "Message" isMessage+findMessage v+ | isMessage v = return v+ | otherwise = findValue "Message" isMessage v findMethod' :: Value -> VM Value-{-# INLINE findMethod' #-}-findMethod' = findValue "Method" isMethod+findMethod' v+ | isMethod v = return v+ | otherwise = findValue "Method" isMethod v findParticle :: Value -> VM Value-{-# INLINE findParticle #-}-findParticle = findValue "Particle" isParticle+findParticle v+ | isParticle v = return v+ | otherwise = findValue "Particle" isParticle v findProcess :: Value -> VM Value-{-# INLINE findProcess #-}-findProcess = findValue "Process" isProcess+findProcess v+ | isProcess v = return v+ | otherwise = findValue "Process" isProcess v findPattern :: Value -> VM Value-{-# INLINE findPattern #-}-findPattern = findValue "Pattern" isPattern+findPattern v+ | isPattern v = return v+ | otherwise = findValue "Pattern" isPattern v +findRational :: Value -> VM Value+findRational v+ | isRational v = return v+ | otherwise = findValue "Rational" isRational v+ findReference :: Value -> VM Value-{-# INLINE findReference #-}-findReference = findValue "Reference" isReference+findReference v+ | isReference v = return v+ | otherwise = findValue "Reference" isReference v findString :: Value -> VM Value-{-# INLINE findString #-}-findString = findValue "String" isString+findString v+ | isString v = return v+ | otherwise = findValue "String" isString v getString :: Expr -> VM String-getString e = eval e >>= fmap fromString . findString+getString e = eval e >>= liftM (fromText . fromString) . findString getText :: Expr -> VM T.Text getText e = eval e >>= findString >>= \(String t) -> return t getList :: Expr -> VM [Value]-getList = fmap V.toList . getVector+getList = liftM V.toList . getVector getVector :: Expr -> VM (V.Vector Value) getVector e = eval e >>= findList- >>= \(List v) -> liftIO . readIORef $ v+ >>= \(List v) -> return v here :: String -> VM Value-here n =- gets top- >>= dispatch . (single n)--bool :: Bool -> VM Value-{-# INLINE bool #-}-bool True = here "True"-bool False = here "False"+here n = gets top >>= dispatch . (single n) ifVM :: VM Value -> VM a -> VM a -> VM a ifVM c a b = do- true <- bool True r <- c+ if r == Boolean True then a else b - if r == true- then a- else b+ifVM' :: VM Bool -> VM a -> VM a -> VM a+ifVM' c a b = do+ r <- c+ if r then a else b ifE :: Expr -> VM a -> VM a -> VM a ifE = ifVM . eval referenceTo :: Value -> VM Value {-# INLINE referenceTo #-}-referenceTo = fmap Reference . orefFor+referenceTo = liftM Reference . orefFor +callBlock :: Value -> [Value] -> VM Value+callBlock (Block s ps es) vs = do+ is <- gets primitives+ checkArgs is ps vs+ doBlock (toMethods . concat $ zipWith bindings' ps vs) s es+ where+ checkArgs _ [] _ = return ()+ checkArgs _ _ [] = throwError (BlockArity (length ps) (length vs))+ checkArgs is (p:ps') (v:vs')+ | match is p v = checkArgs is ps' vs'+ | otherwise = throwError (Mismatch p v)+callBlock x _ = raise ["not-a-block"] [x]+ doBlock :: MethodMap -> Value -> [Expr] -> VM Value {-# INLINE doBlock #-} doBlock bms s es = do@@ -694,12 +672,13 @@ orefFor :: Value -> VM ORef {-# INLINE orefFor #-}-orefFor v = gets primitives >>= \is -> return $ orefFrom is v+orefFor !v = gets primitives >>= \is -> return $ orefFrom is v 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@@ -712,77 +691,9 @@ 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 --- load a file, remembering it to prevent repeated loading--- searches with cwd as lowest priority-requireFile :: FilePath -> VM Value-requireFile fn = do- initialPath <- gets loadPath- file <- findFile (initialPath ++ [""]) fn-- alreadyLoaded <- gets ((file `elem`) . loaded)- if alreadyLoaded- then return (particle "already-loaded")- else do-- modify $ \s -> s { loaded = file : loaded s }-- doLoad file---- load a file--- searches with cwd as highest priority-loadFile :: FilePath -> VM Value-loadFile fn = do- initialPath <- gets loadPath- findFile ("":initialPath) fn >>= doLoad---- execute a file-doLoad :: FilePath -> VM Value-doLoad file =- case takeExtension file of- ".hs" -> do- int <- liftIO . H.runInterpreter $ do- H.loadModules [file]- H.setTopLevelModules ["Main"]- H.interpret "load" (H.as :: VM ())-- load <- either (throwError . ImportError) return int-- load-- return (particle "ok")-- _ -> do- initialPath <- gets loadPath-- ast <- continuedParseFile file-- modify $ \s -> s- { loadPath = [takeDirectory file]- }-- r <- evalAll ast-- modify $ \s -> s- { loadPath = initialPath- }-- return r---- | given a list of paths to search, find the file to load--- attempts to find the filename with .atomo and .hs extensions-findFile :: [FilePath] -> FilePath -> VM FilePath-findFile [] fn = throwError (FileNotFound fn)-findFile (p:ps) fn = do- check <- filterM (liftIO . doesFileExist . ((p </> fn) <.>)) exts-- case check of- [] -> findFile ps fn- (ext:_) -> liftIO (canonicalizePath $ p </> fn <.> ext)- where- exts = ["", "atomo", "hs"]- -- | does one value delegate to another? delegatesTo :: Value -> Value -> VM Bool delegatesTo f t = do@@ -806,7 +717,7 @@ if xr == yr then return True else do- ds <- fmap oDelegates (objectFor x)+ ds <- liftM oDelegates (objectFor x) isA' ds where isA' [] = return False@@ -815,3 +726,4 @@ if di then return True else isA' ds+
− src/Atomo/Haskell.hs
@@ -1,175 +0,0 @@-{-# OPTIONS -fno-warn-name-shadowing #-}-module Atomo.Haskell- ( module Control.Concurrent- , module Control.Monad- , module Control.Monad.Cont- , module Control.Monad.Error- , module Control.Monad.State- , module Control.Monad.Trans- , module Atomo.Types- , p- , e- , es- ) where--import Control.Concurrent-import Control.Monad-import Control.Monad.Cont (MonadCont(..), ContT(..))-import Control.Monad.Error (MonadError(..), ErrorT(..))-import Control.Monad.Identity (runIdentity)-import Control.Monad.State (MonadState(..), gets, modify)-import Control.Monad.Trans-import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax-import Text.Parsec-import qualified Language.Haskell.TH as TH-import qualified Data.Text as T--import Atomo.Parser-import Atomo.Parser.Pattern-import Atomo.Parser.Base-import Atomo.Types---p :: QuasiQuoter-p = QuasiQuoter quotePatternExp undefined--e :: QuasiQuoter-e = QuasiQuoter quoteExprExp undefined--es :: QuasiQuoter-es = QuasiQuoter quoteExprsExp undefined--withLocation :: (String -> (String, Int, Int) -> Q a) -> (a -> Exp) -> String -> TH.ExpQ-withLocation p c s = do- l <- TH.location- r <- p s- ( TH.loc_filename l- , fst $ TH.loc_start l- , snd $ TH.loc_start l- )- return (c r)--parsing :: Monad m => Parser a -> String -> (String, Int, Int) -> m a-parsing p s (file, line, col) =- case runIdentity (runParserT pp [] "<qq>" s) of- Left e -> fail (show e)- Right e -> return e- where- pp = do- pos <- getPosition- setPosition $- (flip setSourceName) file $- (flip setSourceLine) line $- (flip setSourceColumn) col $- pos- whiteSpace- e <- p- whiteSpace- eof- return e--parsePattern :: Monad m => String -> (String, Int, Int) -> m Pattern-parsePattern = parsing ppDefine--quotePatternExp :: String -> TH.ExpQ-quotePatternExp = withLocation parsePattern patternToExp--parseExpr :: Monad m => String -> (String, Int, Int) -> m Expr-parseExpr = parsing pExpr--quoteExprExp :: String -> TH.ExpQ-quoteExprExp = withLocation parseExpr exprToExp--parseExprs :: Monad m => String -> (String, Int, Int) -> m [Expr]-parseExprs = parsing (wsBlock pExpr)--quoteExprsExp :: String -> TH.ExpQ-quoteExprsExp = withLocation parseExprs (ListE . map exprToExp)--exprToExp :: Expr -> Exp-exprToExp (Define l p e) = AppE (AppE (expr "Define" l) (patternToExp p)) (exprToExp e)-exprToExp (Set l p e) = AppE (AppE (expr "Set" l) (patternToExp p)) (exprToExp e)-exprToExp (Dispatch l m) = AppE (expr "Dispatch" l) (emessageToExp m)-exprToExp (Operator l ns a p) = AppE (AppE (AppE (expr "Operator" l) (ListE (map (LitE . StringL) ns))) (assocToExp a)) (LitE (IntegerL p))-exprToExp (Primitive l v) = AppE (expr "Primitive" l) (valueToExp v)-exprToExp (EBlock l as es) =- AppE (AppE (expr "EBlock" l) (ListE (map patternToExp as))) (ListE (map exprToExp es))-exprToExp (EDispatchObject l) =- expr "EDispatchObject" l-exprToExp (EVM _ _) = error "cannot exprToExp EVM"-exprToExp (EList l es) =- AppE (expr "EList" l) (ListE (map exprToExp es))-exprToExp (ETop l) =- expr "ETop" l-exprToExp (EParticle l p) =- AppE (expr "EParticle" l) (eparticleToExp p)--assocToExp :: Assoc -> Exp-assocToExp ALeft = ConE (mkName "ALeft")-assocToExp ARight = ConE (mkName "ARight")--messageToExp :: Message -> Exp-messageToExp (Keyword i ns vs) =- AppE (AppE (AppE (ConE (mkName "Keyword")) (LitE (IntegerL (fromIntegral i)))) (ListE (map (LitE . StringL) ns))) (ListE (map valueToExp vs))-messageToExp (Single i n v) =- AppE (AppE (AppE (ConE (mkName "Single")) (LitE (IntegerL (fromIntegral i)))) (LitE (StringL n))) (valueToExp v)--particleToExp :: Particle -> Exp-particleToExp (PMSingle n) =- AppE (ConE (mkName "PMSingle")) (LitE (StringL n))-particleToExp (PMKeyword ns vs) =- AppE (AppE (ConE (mkName "PMKeyword")) (ListE (map (LitE . StringL) ns))) (ListE (map maybeValue vs))- where- maybeValue Nothing = ConE (mkName "Nothing")- maybeValue (Just v) = AppE (ConE (mkName "Just")) (valueToExp v)--emessageToExp :: EMessage -> Exp-emessageToExp (EKeyword i ns es) =- AppE (AppE (AppE (ConE (mkName "EKeyword")) (LitE (IntegerL (fromIntegral i)))) (ListE (map (LitE . StringL) ns))) (ListE (map exprToExp es))-emessageToExp (ESingle i n e) =- AppE (AppE (AppE (ConE (mkName "ESingle")) (LitE (IntegerL (fromIntegral i)))) (LitE (StringL n))) (exprToExp e)--eparticleToExp :: EParticle -> Exp-eparticleToExp (EPMSingle n) =- AppE (ConE (mkName "EPMSingle")) (LitE (StringL n))-eparticleToExp (EPMKeyword ns es) =- AppE (AppE (ConE (mkName "EPMKeyword")) (ListE (map (LitE . StringL) ns))) (ListE (map maybeExpr es))- where- maybeExpr Nothing = ConE (mkName "Nothing")- maybeExpr (Just e) = AppE (ConE (mkName "Just")) (exprToExp e)--expr :: String -> Maybe SourcePos -> Exp-expr n _ = AppE (ConE (mkName n)) (ConE (mkName "Nothing"))--valueToExp :: Value -> Exp-valueToExp (Block s as es) =- AppE (AppE (AppE (ConE (mkName "Block")) (valueToExp s)) (ListE (map patternToExp as))) (ListE (map exprToExp es))-valueToExp (Char c) = AppE (ConE (mkName "Char")) (LitE (CharL c))-valueToExp (Double d) = AppE (ConE (mkName "Double")) (LitE (RationalL (toRational d)))-valueToExp (Expression e) = AppE (ConE (mkName "Expression")) (exprToExp e)-valueToExp (Integer i) = AppE (ConE (mkName "Integer")) (LitE (IntegerL i))-valueToExp (Message m) = AppE (ConE (mkName "Message")) (messageToExp m)-valueToExp (Particle p) = AppE (ConE (mkName "Particle")) (particleToExp p)-valueToExp (Pattern p) = AppE (ConE (mkName "Pattern")) (patternToExp p)-valueToExp (String s) = AppE (VarE (mkName "string")) (LitE (StringL (T.unpack s)))-valueToExp v = error $ "no valueToExp for: " ++ show v--patternToExp :: Pattern -> Exp-patternToExp PAny = ConE (mkName "PAny")-patternToExp (PHeadTail h t) = AppE (AppE (ConE (mkName "PHeadTail")) (patternToExp h)) (patternToExp t)-patternToExp (PKeyword i ns ts) =- AppE (AppE (AppE (ConE (mkName "PKeyword")) (LitE (IntegerL (fromIntegral i)))) (ListE (map (LitE . StringL) ns))) (ListE (map patternToExp ts))-patternToExp (PList ps) =- AppE (ConE (mkName "PList")) (ListE (map patternToExp ps))-patternToExp (PMatch v) =- AppE (ConE (mkName "PMatch")) (valueToExp v)-patternToExp (PNamed n p) =- AppE (AppE (ConE (mkName "PNamed")) (LitE (StringL n))) (patternToExp p)-patternToExp (PObject e) =- AppE (ConE (mkName "PObject")) (exprToExp e)-patternToExp (PPMKeyword ns ts) =- AppE (AppE (ConE (mkName "PPMKeyword")) (ListE (map (LitE . StringL) ns))) (ListE (map patternToExp ts))-patternToExp (PSingle i n t) =- AppE (AppE (AppE (ConE (mkName "PSingle")) (LitE (IntegerL (fromIntegral i)))) (LitE (StringL n))) (patternToExp t)-patternToExp PThis = ConE (mkName "PThis")
src/Atomo/Kernel.hs view
@@ -5,9 +5,8 @@ import Data.List ((\\)) import Data.Maybe (isJust) -import Atomo.Debug-import Atomo.Environment-import Atomo.Haskell+import Atomo+import Atomo.Load import Atomo.Method import Atomo.Pretty @@ -24,17 +23,13 @@ import qualified Atomo.Kernel.Pattern as Pattern import qualified Atomo.Kernel.Ports as Ports import qualified Atomo.Kernel.Time as Time-import qualified Atomo.Kernel.Boolean as Boolean-import qualified Atomo.Kernel.Association as Association-import qualified Atomo.Kernel.Parameter as Parameter import qualified Atomo.Kernel.Exception as Exception import qualified Atomo.Kernel.Environment as Environment-import qualified Atomo.Kernel.Eco as Eco import qualified Atomo.Kernel.Continuation as Continuation load :: VM () load = do- [$p|this|] =::: [$e|dispatch sender|]+ [$p|this|] =::: [$e|sender|] [$p|(x: Object) clone|] =: do x <- here "x"@@ -42,6 +37,13 @@ { 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"@@ -54,12 +56,18 @@ [$p|(x: Object) delegates-to?: (y: Object)|] =: do x <- here "x" y <- here "y"- delegatesTo x y >>= bool+ fmap Boolean (delegatesTo x y) + [$p|(x: Object) delegates|] =: do+ o <- here "x" >>= objectFor+ return $ list (oDelegates o)++ [$p|(x: Object) super|] =::: [$e|x delegates head|]+ [$p|(x: Object) is-a?: (y: Object)|] =: do x <- here "x" y <- here "y"- isA x y >>= bool+ fmap Boolean (isA x y) [$p|(x: Object) responds-to?: (p: Particle)|] =: do x <- here "x"@@ -70,18 +78,15 @@ PMKeyword ns mvs -> keyword ns (completeKP mvs [x]) PMSingle n -> single n x - findMethod x completed- >>= bool . isJust+ fmap (Boolean . isJust) $ findMethod x completed [$p|(o: Object) methods|] =: do o <- here "o" >>= objectFor let (ss, ks) = oMethods o- singles <- mapM (list . map Method) (elemsMap ss) >>= list- keywords <- mapM (list . map Method) (elemsMap ks) >>= list ([$p|ms|] =::) =<< eval [$e|Object clone|]- [$p|ms singles|] =:: singles- [$p|ms keywords|] =:: keywords+ [$p|ms singles|] =:: list (map (list . map Method) (elemsMap ss))+ [$p|ms keywords|] =:: list (map (list . map Method) (elemsMap ks)) here "ms" [$p|(s: String) as: String|] =::: [$e|s|]@@ -101,12 +106,7 @@ return (Char (read s)) [$p|(x: Object) show|] =:- fmap (string . show . pretty) (here "x")-- [$p|(x: Object) dump|] =: do- x <- here "x"- liftIO (putStrLn (prettyShow x))- return x+ liftM (string . show . pretty) (here "x") [$p|(t: Object) load: (fn: String)|] =: do t <- here "t"@@ -151,9 +151,6 @@ joinWith v b as - Association.load- Boolean.load- Parameter.load Numeric.load List.load String.load@@ -169,34 +166,9 @@ Time.load Exception.load Environment.load- Eco.load Continuation.load - prelude --prelude :: VM ()-prelude = mapM_ eval [$es|- v match: (b: Block) :=- if: b contents empty?- then: { raise: @(no-matches-for: v) }- else: {- es = b contents- [p, e] = es head targets-- match = (p as: Pattern) matches?: v- if: (match == @no)- then: {- v match: (Block new: es tail in: b context)- }- else: {- @(yes: bindings) = match- bindings delegates-to: b context- e evaluate-in: bindings- }- }-|]- joinWith :: Value -> Value -> [Value] -> VM Value joinWith t (Block s ps bes) as | length ps > length as =@@ -268,8 +240,7 @@ withTop blockScope (evalAll bes) where- bs = addMethod (Slot (psingle "this" PThis) t) $- toMethods . concat $ zipWith bindings' ps as+ bs = toMethods . concat $ zipWith bindings' ps as merge (os, ok) (ns, nk) = ( foldl (flip addMethod) os (concat $ elemsMap ns)
− src/Atomo/Kernel.hs-boot
@@ -1,5 +0,0 @@-module Atomo.Kernel (load) where--import Atomo.Types (VM)--load :: VM ()
− src/Atomo/Kernel/Association.hs
@@ -1,38 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-module Atomo.Kernel.Association (load) where--import Atomo.Environment-import Atomo.Haskell---load :: VM ()-load = mapM_ eval [$es|- operator right 1 ->-- Association = Object clone- a -> b := Association clone do: { from = a; to = b }-- (a: Association) show :=- a from show .. " -> " .. a to show-- [] lookup: _ = @none- (a . as) lookup: k :=- if: (k == a from)- then: { @(ok: a to) }- else: { as lookup: k }-- [] find: _ = @none- (a . as) find: k :=- if: (k == a from)- then: { @(ok: a) }- else: { as find: k }-- (l: List) set: k to: v :=- (l find: k) match: {- @none -> l << (k -> v)- @(ok: a) ->- { a to = v- l- } call- }-|]
src/Atomo/Kernel/Block.hs view
@@ -2,15 +2,13 @@ {-# OPTIONS -fno-warn-name-shadowing #-} module Atomo.Kernel.Block (load) where -import Atomo.Environment-import Atomo.Haskell-import Atomo.Method+import Atomo load :: VM () load = do [$p|Block new: (l: List)|] =:::- [$e|Block new: l in: dispatch sender|]+ [$e|Block new: l in: sender|] [$p|Block new: (l: List) in: t|] =: do t <- here "t"@@ -22,19 +20,13 @@ return (Block t [] (map toExpr es)) [$p|(b: Block) call|] =: do- Block s as es <- here "b" >>= findBlock-- if length as > 0- then throwError (BlockArity (length as) 0)- else doBlock emptyMap s es+ b <- here "b" >>= findBlock+ callBlock b [] [$p|(b: Block) call: (l: List)|] =: do- Block s ps es <- here "b" >>= findBlock+ b <- here "b" >>= findBlock vs <- getList [$e|l|]-- if length ps > length vs- then throwError (BlockArity (length ps) (length vs))- else doBlock (toMethods . concat $ zipWith bindings' ps vs) s es+ callBlock b vs [$p|(b: Block) context|] =: do Block s _ _ <- here "b" >>= findBlock@@ -42,41 +34,8 @@ [$p|(b: Block) arguments|] =: do Block _ as _ <- here "b" >>= findBlock- list (map Pattern as)+ return $ list (map Pattern as) [$p|(b: Block) contents|] =: do Block _ _ es <- here "b" >>= findBlock- list (map Expression es)-- prelude---prelude :: VM ()-prelude = mapM_ eval [$es|- (b: Block) repeat :=- { b in-context call- b repeat- } call-- (b: Block) in-context :=- Object clone do:- { delegates-to: b- call := b context join: b- call: vs := b context join: b with: vs- }-- (a: Block) .. (b: Block) :=- Block new: (a contents .. b contents) in: dispatch sender-- (start: Integer) to: (end: Integer) by: (diff: Integer) do: b :=- (start to: end by: diff) each: b-- (start: Integer) up-to: (end: Integer) do: b :=- start to: end by: 1 do: b-- (start: Integer) down-to: (end: Integer) do: b :=- start to: end by: -1 do: b-- (n: Integer) times: (b: Block) :=- 1 up-to: n do: b in-context-|]+ return $ list (map Expression es)
− src/Atomo/Kernel/Boolean.hs
@@ -1,66 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-module Atomo.Kernel.Boolean (load) where--import Atomo.Environment-import Atomo.Haskell---load :: VM ()-load = mapM_ eval [$es|- Boolean = Object clone- True = Object clone- False = Object clone-- True delegates-to: Boolean- False delegates-to: Boolean-- True && True = True- Boolean && Boolean = False-- False and: _ = False- True and: (b: Block) := b call-- True || Boolean = True- False || (b: Boolean) := b-- True or: _ = True- False or: (b: Block) := b call-- True not := False- False not := True-- if: True then: (a: Block) else: Block :=- a call-- if: False then: Block else: (b: Block) :=- b call-- when: False do: Block = @ok- when: True do: (action: Block) :=- { action in-context call- @ok- } call-- while: (test: Block) do: (action: Block) :=- when: test call do:- { action in-context call- while: test do: action- }-- True show := "True"- False show := "False"-- otherwise := True-- condition: (b: Block) :=- if: b contents empty?- then: { raise: @no-true-branches }- else: {- es = b contents- [c, e] = es head targets-- if: (c evaluate-in: b context)- then: { e evaluate-in: b context }- else: { condition: (Block new: es tail in: b context) }- }-|]
src/Atomo/Kernel/Comparable.hs view
@@ -3,8 +3,7 @@ import qualified Data.Vector as V -import Atomo.Environment-import Atomo.Haskell+import Atomo load :: VM ()@@ -15,139 +14,89 @@ , [$e|operator right 2 |||] ] - [$p|a equals: b|] =: do+ [$p|a equals?: b|] =: do a <- here "a" b <- here "b"- bool (a == b)+ return $ Boolean (a == b) - [$p|(a: Object) == (b: Object)|] =::: [$e|a equals: b|]+ [$p|(a: Object) == (b: Object)|] =::: [$e|a equals?: b|] [$p|(a: Object) /= (b: Object)|] =::: [$e|(a == b) not|] [$p|(a: Char) < (b: Char)|] =: do Char a <- here "a" >>= findChar Char b <- here "b" >>= findChar- bool (a < b)-- [$p|(a: Integer) < (b: Integer)|] =: do- Integer a <- here "a" >>= findInteger- Integer b <- here "b" >>= findInteger- bool (a < b)-- [$p|(a: Integer) < (b: Double)|] =: do- Integer a <- here "a" >>= findInteger- Double b <- here "b" >>= findDouble- bool (fromIntegral a < b)-- [$p|(a: Double) < (b: Integer)|] =: do- Double a <- here "a" >>= findDouble- Integer b <- here "b" >>= findInteger- bool (a < fromIntegral b)-- [$p|(a: Double) < (b: Double)|] =: do- Double a <- here "a" >>= findDouble- Double b <- here "b" >>= findDouble- bool (a < b)+ return $ Boolean (a < b) [$p|(a: Char) > (b: Char)|] =: do Char a <- here "a" >>= findChar Char b <- here "b" >>= findChar- bool (a > b)-- [$p|(a: Integer) > (b: Integer)|] =: do- Integer a <- here "a" >>= findInteger- Integer b <- here "b" >>= findInteger- bool (a > b)-- [$p|(a: Integer) > (b: Double)|] =: do- Integer a <- here "a" >>= findInteger- Double b <- here "b" >>= findDouble- bool (fromIntegral a > b)-- [$p|(a: Double) > (b: Integer)|] =: do- Double a <- here "a" >>= findDouble- Integer b <- here "b" >>= findInteger- bool (a > fromIntegral b)-- [$p|(a: Double) > (b: Double)|] =: do- Double a <- here "a" >>= findDouble- Double b <- here "b" >>= findDouble- bool (a > b)+ return $ Boolean (a > b) [$p|(a: Char) <= (b: Char)|] =: do Char a <- here "a" >>= findChar Char b <- here "b" >>= findChar- bool (a <= b)-- [$p|(a: Integer) <= (b: Integer)|] =: do- Integer a <- here "a" >>= findInteger- Integer b <- here "b" >>= findInteger- bool (a <= b)-- [$p|(a: Integer) <= (b: Double)|] =: do- Integer a <- here "a" >>= findInteger- Double b <- here "b" >>= findDouble- bool (fromIntegral a <= b)-- [$p|(a: Double) <= (b: Integer)|] =: do- Double a <- here "a" >>= findDouble- Integer b <- here "b" >>= findInteger- bool (a <= fromIntegral b)-- [$p|(a: Double) <= (b: Double)|] =: do- Double a <- here "a" >>= findDouble- Double b <- here "b" >>= findDouble- bool (a <= b)+ return $ Boolean (a <= b) [$p|(a: Char) >= (b: Char)|] =: do Char a <- here "a" >>= findChar Char b <- here "b" >>= findChar- bool (a >= b)-- [$p|(a: Integer) >= (b: Integer)|] =: do- Integer a <- here "a" >>= findInteger- Integer b <- here "b" >>= findInteger- bool (a >= b)-- [$p|(a: Integer) >= (b: Double)|] =: do- Integer a <- here "a" >>= findInteger- Double b <- here "b" >>= findDouble- bool (fromIntegral a >= b)-- [$p|(a: Double) >= (b: Integer)|] =: do- Double a <- here "a" >>= findDouble- Integer b <- here "b" >>= findInteger- bool (a >= fromIntegral b)-- [$p|(a: Double) >= (b: Double)|] =: do- Double a <- here "a" >>= findDouble- Double b <- here "b" >>= findDouble- bool (a >= b)+ return $ Boolean (a >= b) [$p|(a: Char) == (b: Char)|] =: do Char a <- here "a" >>= findChar Char b <- here "b" >>= findChar- bool (a == b)+ return $ Boolean (a == b) - [$p|(a: Integer) == (b: Integer)|] =: do- Integer a <- here "a" >>= findInteger- Integer b <- here "b" >>= findInteger- bool (a == b)+ [$p|(a: Integer) < (b: Integer)|] =: primII (<)+ [$p|(a: Double) < (b: Double)|] =: primDD (<)+ [$p|(a: Rational) < (b: Rational)|] =: primRR (<)+ [$p|(a: Integer) < (b: Double)|] =: primID (<)+ [$p|(a: Integer) < (b: Rational)|] =: primIR (<)+ [$p|(a: Double) < (b: Integer)|] =: primDI (<)+ [$p|(a: Double) < (b: Rational)|] =: primDR (<)+ [$p|(a: Rational) < (b: Integer)|] =: primRI (<)+ [$p|(a: Rational) < (b: Double)|] =: primRD (<) - [$p|(a: Integer) == (b: Double)|] =: do- Integer a <- here "a" >>= findInteger- Double b <- here "b" >>= findDouble- bool (fromIntegral a == b)+ [$p|(a: Integer) > (b: Integer)|] =: primII (>)+ [$p|(a: Double) > (b: Double)|] =: primDD (>)+ [$p|(a: Rational) > (b: Rational)|] =: primRR (>)+ [$p|(a: Integer) > (b: Double)|] =: primID (>)+ [$p|(a: Integer) > (b: Rational)|] =: primIR (>)+ [$p|(a: Double) > (b: Integer)|] =: primDI (>)+ [$p|(a: Double) > (b: Rational)|] =: primDR (>)+ [$p|(a: Rational) > (b: Integer)|] =: primRI (>)+ [$p|(a: Rational) > (b: Double)|] =: primRD (>) - [$p|(a: Double) == (b: Integer)|] =: do- Double a <- here "a" >>= findDouble- Integer b <- here "b" >>= findInteger- bool (a == fromIntegral b)+ [$p|(a: Integer) <= (b: Integer)|] =: primII (<=)+ [$p|(a: Double) <= (b: Double)|] =: primDD (<=)+ [$p|(a: Rational) <= (b: Rational)|] =: primRR (<=)+ [$p|(a: Integer) <= (b: Double)|] =: primID (<=)+ [$p|(a: Integer) <= (b: Rational)|] =: primIR (<=)+ [$p|(a: Double) <= (b: Integer)|] =: primDI (<=)+ [$p|(a: Double) <= (b: Rational)|] =: primDR (<=)+ [$p|(a: Rational) <= (b: Integer)|] =: primRI (<=)+ [$p|(a: Rational) <= (b: Double)|] =: primRD (<=) - [$p|(a: Double) == (b: Double)|] =: do- Double a <- here "a" >>= findDouble- Double b <- here "b" >>= findDouble- bool (a == b)+ [$p|(a: Integer) >= (b: Integer)|] =: primII (>=)+ [$p|(a: Double) >= (b: Double)|] =: primDD (>=)+ [$p|(a: Rational) >= (b: Rational)|] =: primRR (>=)+ [$p|(a: Integer) >= (b: Double)|] =: primID (>=)+ [$p|(a: Integer) >= (b: Rational)|] =: primIR (>=)+ [$p|(a: Double) >= (b: Integer)|] =: primDI (>=)+ [$p|(a: Double) >= (b: Rational)|] =: primDR (>=)+ [$p|(a: Rational) >= (b: Integer)|] =: primRI (>=)+ [$p|(a: Rational) >= (b: Double)|] =: primRD (>=) + [$p|(a: Integer) == (b: Integer)|] =: primII (==)+ [$p|(a: Double) == (b: Double)|] =: primDD (==)+ [$p|(a: Rational) == (b: Rational)|] =: primRR (==)+ [$p|(a: Integer) == (b: Double)|] =: primID (==)+ [$p|(a: Integer) == (b: Rational)|] =: primIR (==)+ [$p|(a: Double) == (b: Integer)|] =: primDI (==)+ [$p|(a: Double) == (b: Rational)|] =: primDR (==)+ [$p|(a: Rational) == (b: Integer)|] =: primRI (==)+ [$p|(a: Rational) == (b: Double)|] =: primRD (==)+ [$p|(a: List) == (b: List)|] =: do as <- getVector [$e|a|] bs <- getVector [$e|b|]@@ -155,57 +104,87 @@ if V.length as == V.length bs then do eqs <- V.zipWithM (\a b -> dispatch (keyword ["=="] [a, b])) as bs- true <- bool True- bool (V.all (== true) eqs)- else bool False+ return $ Boolean (V.all (== Boolean True) eqs)+ else return $ Boolean False [$p|(a: Process) == (b: Process)|] =: do Process _ a <- here "a" >>= findProcess Process _ b <- here "b" >>= findProcess- bool (a == b)+ return $ Boolean (a == b) [$p|(a: Message) == (b: Message)|] =: do Message a <- here "a" >>= findMessage Message b <- here "b" >>= findMessage - true <- bool True case (a, b) of (Single ai _ at, Single bi _ bt) -> do- t <- dispatch (keyword ["=="] [at, bt])- bool (ai == bi && t == true)+ Boolean t <- dispatch (keyword ["=="] [at, bt]) >>= findBoolean+ return $ Boolean (ai == bi && t) (Keyword ai _ avs, Keyword bi _ bvs) | ai == bi && length avs == length bvs -> do eqs <- zipWithM (\x y -> dispatch (keyword ["=="] [x, y])) avs bvs- bool (all (== true) eqs)- _ -> bool False+ return $ Boolean (all (== Boolean True) eqs)+ _ -> return $ Boolean False [$p|(a: Particle) == (b: Particle)|] =: do Particle a <- here "a" >>= findParticle Particle b <- here "b" >>= findParticle - true <- bool True case (a, b) of (PMSingle an, PMSingle bn) ->- bool (an == bn)+ return $ Boolean (an == bn) (PMKeyword ans avs, PMKeyword bns bvs) | ans == bns && length avs == length bvs -> do eqs <- zipWithM (\mx my -> case (mx, my) of- (Nothing, Nothing) -> return true+ (Nothing, Nothing) -> return (Boolean True) (Just x, Just y) -> dispatch (keyword ["=="] [x, y])- _ -> bool False) avs bvs- bool (all (== true) eqs)- _ -> bool False+ _ -> return $ Boolean False) avs bvs+ return $ Boolean (all (== Boolean True) eqs)+ _ -> return $ Boolean False+ where+ primII f = do+ Integer a <- here "a" >>= findInteger+ Integer b <- here "b" >>= findInteger+ return (Boolean $ f a b) - prelude+ primDD f = do+ Double a <- here "a" >>= findDouble+ Double b <- here "b" >>= findDouble+ return (Boolean $ f a b) + primRR f = do+ Rational a <- here "a" >>= findRational+ Rational b <- here "b" >>= findRational+ return (Boolean $ f a b) -prelude :: VM ()-prelude = mapM_ eval [$es|- x max: y :=- if: (x > y) then: { x } else: { y }+ primID f = do+ Integer a <- here "a" >>= findInteger+ Double b <- here "b" >>= findDouble+ return (Boolean $ f (fromIntegral a) b) - x min: y :=- if: (x < y) then: { x } else: { y }-|]+ primIR f = do+ Integer a <- here "a" >>= findInteger+ Rational b <- here "b" >>= findRational+ return (Boolean $ f (toRational a) b)++ primDI f = do+ Double a <- here "a" >>= findDouble+ Integer b <- here "b" >>= findInteger+ return (Boolean $ f a (fromIntegral b))++ primDR f = do+ Double a <- here "a" >>= findDouble+ Rational b <- here "b" >>= findRational+ return (Boolean $ f (toRational a) b)++ primRD f = do+ Rational a <- here "a" >>= findRational+ Double b <- here "b" >>= findDouble+ return (Boolean $ f a (toRational b))++ primRI f = do+ Rational a <- here "a" >>= findRational+ Integer b <- here "b" >>= findInteger+ return (Boolean $ f a (toRational b))
src/Atomo/Kernel/Concurrency.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE QuasiQuotes #-} module Atomo.Kernel.Concurrency (load) where -import Atomo.Environment-import Atomo.Haskell+import Atomo import Atomo.Method+import Atomo.Spawn load :: VM ()@@ -34,13 +34,12 @@ else spawn (doBlock emptyMap s bes) [$p|(b: Block) spawn: (l: List)|] =: do- Block s as bes <- here "b" >>= findBlock+ b@(Block _ as _) <- here "b" >>= findBlock vs <- getList [$e|l|] if length as > length vs then throwError (BlockArity (length as) (length vs))- else spawn $- doBlock (toMethods . concat $ zipWith bindings' as vs) s bes+ else spawn (callBlock b vs) [$p|(p: Process) stop|] =: do Process _ tid <- here "p" >>= findProcess
src/Atomo/Kernel/Continuation.hs view
@@ -3,8 +3,7 @@ import Data.IORef -import Atomo.Environment-import Atomo.Haskell+import Atomo load :: VM ()@@ -28,76 +27,8 @@ [$p|(c: Continuation) yield|] =::: [$e|c yield: @ok|] [$p|(c: Continuation) call|] =::: [$e|c yield: @ok|] - -- an object providing lower-level call/cc functionality- -- only used in call/cc's definition- callccObj <- newScope $ do- ([$p|o|] =::) =<< eval [$e|Object clone|]- [$p|(o) pass-to: b|] =: callCC $ \c -> do- b <- here "b"- cr <- liftIO (newIORef c)- as <- list [Continuation cr]- dispatch (keyword ["call"] [b, as])- eval [$e|o|]-- -- define call/cc and dynamic-wind in a new scope for hiding- -- helper methods (internal-call/cc, dynamic-winds, dynamic-unwind)- newScope (dynamicWind callccObj >> return (particle "ok"))-- return ()--dynamicWind :: Value -> VM ()-dynamicWind callccObj = do- [$p|internal-call/cc|] =:: callccObj- ([$p|dynamic-winds|] =::) =<< eval [$e|Parameter new: []|]-- [$p|(o: Object) call/cc|] =::: [$e|internal-call/cc pass-to: { cont |- winds = dynamic-winds _? copy-- new = cont clone do: {- yield: v := {- dynamic-unwind: winds- delta: (dynamic-winds _? length - winds length)-- cont yield: v- } call- }-- o call: [new]- }|]-- [$p|(v: Block) before: (b: Block)|] =::: [$e|v before: b after: { @ok }|]- [$p|(v: Block) after: (a: Block)|] =::: [$e|v before: { @ok } after: a|]- [$p|(v: Block) before: (b: Block) after: (a: Block)|] =::: [$e|{- b call-- dynamic-winds =! ((b -> a) . dynamic-winds _?)-- { v call } ensuring: {- dynamic-winds =! dynamic-winds _? tail- a call- }- } call|]-- [$p|(init: Block) wrap: cleanup do: action|] =::: [$e|- { action call: [x] } before: { x = init call } in-context after: { cleanup call: [x] }- |]-- [$p|dynamic-unwind: to delta: d|] =::: [$e|{- 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|]+ -- internal call/cc, quite unsafe (no unwinding)+ [$p|(o: Object) raw-call/cc|] =: callCC $ \c -> do+ o <- here "o"+ cr <- liftIO (newIORef c)+ dispatch (keyword ["call"] [o, list [Continuation cr]])
− src/Atomo/Kernel/Eco.hs
@@ -1,288 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-module Atomo.Kernel.Eco where--import Atomo.Environment-import Atomo.Haskell---load :: VM ()-load = loadVersions >> loadEco--loadEco :: VM ()-loadEco = mapM_ eval [$es|- Eco =- Object clone do:- { -- all packages OK for loading- -- name -> [package]- packages = []-- -- versions loaded by @use:- -- name -> package- loaded = []- }-- Eco Package =- Object clone do:- { version = 0 . 1- dependencies = []- include = []- executables = []- }-- (e: Eco) initialize :=- e initialize: (Eco Package load-from: "package.eco")-- (e: Eco) initialize: pkg :=- { pkg dependencies each: { c |- e packages (find: c from) match: {- @none -> raise: @(package-unavailable: c from needed: c to)-- -- filter out versions not satisfying our dependency- @(ok: d) ->- { safe = d to (filter: { p | p version join: c to })-- safe match: {- [] ->- raise: @(no-versions-of: d satisfy: c to for: pkg name)-- -- initialize the first safe version of the package- (p . _) ->- { -- remove unsafe versions from the ecosystem- d to = safe- e initialize: p- } call- }- } call- }- }-- @ok- } call-- (e: Eco) load :=- { eco = Directory home </> ".eco" </> "lib"-- when: Directory (exists?: eco) do: {- e packages =- Directory (contents: eco) map:- { c |- versions = Directory (contents: (eco </> c))- pkgs = versions map:- { v |- Eco Package load-from:- (eco </> c </> v </> "package.eco")- }-- c -> pkgs (sort-by: { a b | a version < b version })- }- }-- @ok- } call-- Eco path-to: (c: Eco Package) :=- Eco path-to: c name version: c version-- Eco path-to: (name: String) :=- Directory home </> ".eco" </> "lib" </> name-- Eco path-to: pkg version: (v: Version) :=- (Eco path-to: pkg) </> (v as: String)-- Eco executable: (name: String) :=- Directory home </> ".eco" </> "bin" </> name-- Eco which-main: (path: String) :=- if: File (exists?: (path </> "main.hs"))- then: { "main.hs" }- else: { "main.atomo" }-- Eco install: (path: String) :=- { pkg = Eco Package load-from: (path </> "package.eco")- target = Eco path-to: pkg-- contents = (Eco which-main: path) . ("package.eco" . pkg include)-- Directory create-tree-if-missing: target-- contents each:- { c |- if: Directory (exists?: (path </> c))- then: { Directory copy: (path </> c) to: (target </> c) }- else: { File copy: (path </> c) to: (target </> c) }- }-- pkg executables each:- { e |- exe =- [ "#!/usr/bin/env atomo"- "load: " .. (path </> e to) show- ] unlines-- with-output-to: (Eco executable: e from) do: { exe print }-- File set-executable: (Eco executable: e from) to: True- }-- @ok- } call-- Eco uninstall: (name: String) version: (version: Version) :=- { path = Eco path-to: name version: version- pkg = Eco Package load-from: (path </> "package.eco")-- Directory remove-recursive: path- pkg executables each:- { e |- File remove: (Eco executable: e from)- }- - @ok- } call-- Eco uninstall: (name: String) :=- { Directory (contents: (Eco path-to: name)) each:- { v |- Eco uninstall: name version: (v as: Version)- }-- @ok- } call-- Eco Package load-from: (file: String) :=- Eco Package clone do: { load: file }-- (p: Eco Package) name: (n: String) :=- p name = n-- (p: Eco Package) description: (d: String) :=- p description = d-- (p: Eco Package) version: (v: Version) :=- p version = v-- (p: Eco Package) author: (a: String) :=- p author = a-- (p: Eco Package) include: (l: List) :=- p include = l-- (p: Eco Package) depends-on: (ds: List) :=- p dependencies = ds map:- { d |- if: (d is-a?: Association)- then: { d }- else: { d -> { True } }- }-- (p: Eco Package) executables: (es: List) :=- p executables = es-- context use: (name: String) :=- context use: name version: { True }-- context use: (name: String) version: (v: Version) :=- context use: name version: { == v }-- context use: (name: String) version: (check: Block) :=- Eco loaded (lookup: name) match: {- @none ->- (Eco packages (lookup: name) match: {- @none -> raise: @(package-unavailable: name)- @(ok: []) -> raise: @(no-package-versions: name)- @(ok: pkgs) ->- { satisfactory = pkgs filter: { p | p version join: check }-- when: satisfactory empty? do: {- raise: @(no-versions-of: (name -> versions) satisfy: check)- }-- Eco loaded << (name -> satisfactory head)-- path = Eco path-to: satisfactory head- context load: (path </> (Eco which-main: path))-- @ok- } call- })-- @(ok: p) ->- when: (p version join: check) not- do: { raise: @(incompatible-version-loaded: name needed: check) }- }-- Eco load-|]--loadVersions :: VM ()-loadVersions = mapM_ eval [$es|- Version = Object clone-- (major: Integer) . (minor: Integer) :=- Version clone do:- { major = major- minor = minor- }-- (major: Integer) . (rest: Version) :=- Version clone do:- { major = major- minor = rest- }-- (v: Version) show :=- v major show .. " . " .. v minor show-- (v: Version) as: String :=- v major show .. "." .. v minor (as: String)-- (s: String) as: Version :=- s (split-on: '.') (map: @(as: Integer)) reduce-right: @.-- (n: Integer) as: Version := n . 0-- (a: Version) == (b: Version) :=- (a major == b major) and: { a minor == b minor }-- (n: Integer) == (v: Version) :=- (n == v major) && (v minor == 0)-- (v: Version) == (n: Integer) :=- (n == v major) && (v minor == 0)-- (a: Version) > (b: Version) :=- (a major > b major) or: { a minor > b minor }-- (n: Integer) > (v: Version) :=- (n > v major) or: { v major == n && (v minor /= 0) }-- (v: Version) > (n: Integer) :=- (v major > n) or: { v major == n && (v minor /= 0) }-- (a: Version) < (b: Version) :=- (a major < b major) or: { a minor < b minor }-- (n: Integer) < (v: Version) :=- (n < v major) or: { v major == n && (v minor /= 0) }-- (v: Version) < (n: Integer) :=- (v major < n) or: { v major == n && (v minor /= 0) }-- (a: Version) >= (b: Version) :=- (a major >= b major) or: { a minor >= b minor }-- (n: Integer) >= (v: Version) :=- n >= v major-- (v: Version) >= (n: Integer) :=- v major >= n-- (a: Version) <= (b: Version) :=- (a major <= b major) or: { a minor <= b minor }-- (n: Integer) <= (v: Version) :=- n <= v major-- (v: Version) <= (n: Integer) :=- v major <= n-|]
src/Atomo/Kernel/Environment.hs view
@@ -3,8 +3,7 @@ import System.Environment -import Atomo.Environment-import Atomo.Haskell+import Atomo load :: VM ()@@ -12,14 +11,14 @@ ([$p|Environment|] =::) =<< eval [$e|Object clone|] [$p|Environment arguments|] =:- liftIO getArgs >>= list . map string+ liftIO getArgs >>= return . list . map string [$p|Environment program-name|] =:- fmap string $ liftIO getProgName+ liftM string $ liftIO getProgName [$p|Environment get: (name: String)|] =: getString [$e|name|]- >>= fmap string . (liftIO . getEnv)+ >>= liftM string . (liftIO . getEnv) [$p|Environment all|] =: do env <- liftIO getEnvironment@@ -27,4 +26,4 @@ assocs <- forM env $ \(k, v) -> dispatch (keyword ["->"] [string k, string v]) - list assocs+ return $ list assocs
src/Atomo/Kernel/Exception.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} module Atomo.Kernel.Exception (load) where -import Atomo.Environment-import Atomo.Haskell+import Atomo load :: VM ()@@ -13,20 +12,21 @@ [$p|(action: Block) catch: (recover: Block)|] =: catchError (eval [$e|action call|]) $ \err -> do- recover <- here "recover"- args <- list [asValue err]+ modify $ \s -> s { stack = [] } - dispatch (keyword ["call"] [recover, args])+ recover <- here "recover"+ dispatch (keyword ["call"] [recover, list [asValue err]]) [$p|(action: Block) catch: (recover: Block) ensuring: (cleanup: Block)|] =: catchError (do r <- eval [$e|action call|] eval [$e|cleanup call|] return r) $ \err -> do+ modify $ \s -> s { stack = [] }+ recover <- here "recover"- args <- list [asValue err] - res <- dispatch (keyword ["call"] [recover, args])+ res <- dispatch (keyword ["call"] [recover, list [asValue err]]) eval [$e|cleanup call|] return res
src/Atomo/Kernel/Expression.hs view
@@ -2,21 +2,24 @@ {-# OPTIONS -fno-warn-name-shadowing #-} module Atomo.Kernel.Expression (load) where -import Atomo.Environment-import Atomo.Haskell+import Atomo+import Atomo.Parser (macroExpand, withParser) load :: VM () load = do- [$p|(e: Expression) evaluate|] =: do- Expression e <- here "e" >>= findExpression- eval e+ [$p|(e: Expression) evaluate|] =:::+ [$e|e evaluate-in: sender|] [$p|(e: Expression) evaluate-in: t|] =: do Expression e <- here "e" >>= findExpression t <- here "t" withTop t (eval e) + [$p|(e: Expression) expand|] =: do+ Expression e <- here "e" >>= findExpression+ liftM Expression $ withParser (macroExpand e)+ [$p|(e: Expression) type|] =: do Expression e <- here "e" >>= findExpression case e of@@ -26,10 +29,12 @@ Operator {} -> return (particle "operator") Primitive {} -> return (particle "primitive") EBlock {} -> return (particle "block")- EDispatchObject {} -> return (particle "call") EVM {} -> return (particle "vm") EList {} -> return (particle "list")+ EMacro {} -> return (particle "macro") ETop {} -> return (particle "top")+ EQuote {} -> return (particle "quote")+ EUnquote {} -> return (particle "unquote") EParticle {} -> return (particle "particle") [$p|(e: Expression) dispatch-type|] =: do@@ -58,7 +63,7 @@ [$p|(e: Expression) targets|] =: do Expression (Dispatch _ (EKeyword { emTargets = vs })) <- here "e" >>= findExpression- list (map Expression vs)+ return $ list (map Expression vs) [$p|(e: Expression) name|] =: do Expression (EParticle _ (EPMSingle n)) <- here "e" >>= findExpression@@ -66,18 +71,18 @@ [$p|(e: Expression) names|] =: do Expression (EParticle _ (EPMKeyword ns _)) <- here "e" >>= findExpression- list (map string ns)+ return $ list (map string ns) [$p|(e: Expression) values|] =: do Expression (EParticle _ (EPMKeyword _ mes)) <- here "e" >>= findExpression- list $+ return . list $ map (maybe (particle "none") (keyParticle ["ok"] . ([Nothing] ++) . (:[]). Just . Expression)) mes [$p|(e: Expression) contents|] =: do- Expression (EList _ es) <- here "e" >>= findExpression- list (map Expression es)+ Expression e <- here "e" >>= findExpression+ return $ list (map Expression (eContents e)) [$p|(e: Expression) pattern|] =: do Expression e <- here "e" >>= findExpression
src/Atomo/Kernel/List.hs view
@@ -1,12 +1,10 @@ {-# LANGUAGE QuasiQuotes #-} module Atomo.Kernel.List (load) where -import Data.IORef import Data.List.Split import qualified Data.Vector as V -import Atomo.Environment-import Atomo.Haskell+import Atomo load :: VM ()@@ -16,14 +14,11 @@ [$p|(l: List) show|] =::: [$e|"[" .. l (map: @show) (join: ", ") .. "]"|] - [$p|(l: List) copy|] =:- getVector [$e|l|] >>= list'- [$p|(l: List) length|] =: getVector [$e|l|] >>= return . Integer . fromIntegral . V.length [$p|(l: List) empty?|] =:- getVector [$e|l|] >>= bool . V.null+ liftM (Boolean . V.null) $ getVector [$e|l|] [$p|(l: List) at: (n: Integer)|] =: do Integer n <- here "n" >>= findInteger@@ -60,58 +55,57 @@ [ keyParticleN ["from", "take"] [Integer start, Integer num] , l ]- else list' $ V.unsafeSlice+ else return . List $ V.unsafeSlice (fromIntegral start) (fromIntegral num) vs [$p|[] init|] =::: [$e|raise: @empty-list|] [$p|(l: List) init|] =:- getVector [$e|l|] >>= list' . V.unsafeInit+ getVector [$e|l|] >>= return . List . V.unsafeInit [$p|[] tail|] =::: [$e|raise: @empty-list|] [$p|(l: List) tail|] =:- getVector [$e|l|] >>= list' . V.unsafeTail+ getVector [$e|l|] >>= return . List . V.unsafeTail [$p|(l: List) take: (n: Integer)|] =: do vs <- getVector [$e|l|] Integer n <- here "n" >>= findInteger- list' (V.take (fromIntegral n) vs)+ return . List $ V.take (fromIntegral n) vs [$p|(l: List) drop: (n: Integer)|] =: do vs <- getVector [$e|l|] Integer n <- here "n" >>= findInteger- list' (V.drop (fromIntegral n) vs)+ return . List $ V.drop (fromIntegral n) vs [$p|v replicate: (n: Integer)|] =: do v <- here "v" Integer n <- here "n" >>= findInteger- list' (V.replicate (fromIntegral n) v)+ return . List $ V.replicate (fromIntegral n) v [$p|b repeat: (n: Integer)|] =: do b <- here "b" Integer n <- here "n" >>= findInteger vs <- V.replicateM (fromIntegral n) $ dispatch (single "call" b)- list' vs+ return $ List vs [$p|(a: List) .. (b: List)|] =: do as <- getVector [$e|a|] bs <- getVector [$e|b|]- list' (as V.++ bs)+ return . List $ as V.++ bs [$p|(l: List) reverse|] =: do- getVector [$e|l|] >>= list' . V.reverse+ getVector [$e|l|] >>= return . List . V.reverse [$p|(l: List) map: b|] =: do vs <- getVector [$e|l|] b <- here "b" - nvs <- V.mapM (\v -> do- as <- list' (V.singleton v)- dispatch (keyword ["call"] [b, as])) vs+ nvs <- V.mapM (\v ->+ dispatch (keyword ["call"] [b, list [v]])) vs - list' nvs+ return $ List nvs [$p|(x: List) zip: (y: List)|] =::: [$e|x zip: y with: @->|] [$p|(x: List) zip: (y: List) with: b|] =: do@@ -119,59 +113,52 @@ ys <- getVector [$e|y|] b <- here "b" - nvs <- V.zipWithM (\x y -> do- as <- list [x, y]- dispatch (keyword ["call"] [b, as])) xs ys+ nvs <- V.zipWithM (\x y ->+ dispatch (keyword ["call"] [b, list [x, y]])) xs ys - list' nvs+ return $ List nvs [$p|(l: List) filter: b|] =: do vs <- getVector [$e|l|] b <- here "b" - t <- bool True nvs <- V.filterM (\v -> do- as <- list [v]- check <- dispatch (keyword ["call"] [b, as])- return (check == t)) vs+ Boolean t <- dispatch (keyword ["call"] [b, list [v]]) >>= findBoolean+ return t) vs - list' nvs+ return $ List nvs [$p|[] reduce: b|] =::: [$e|raise: @empty-list|] [$p|(l: List) reduce: b|] =: do vs <- getVector [$e|l|] b <- here "b" - V.fold1M (\x acc -> do- as <- list [x, acc]- dispatch (keyword ["call"] [b, as])) vs+ V.fold1M (\x acc ->+ dispatch (keyword ["call"] [b, list [x, acc]])) vs [$p|(l: List) reduce: b with: v|] =: do vs <- getVector [$e|l|] b <- here "b" v <- here "v" - V.foldM (\x acc -> do- as <- list [x, acc]- dispatch (keyword ["call"] [b, as])) v vs+ V.foldM (\x acc ->+ dispatch (keyword ["call"] [b, list [x, acc]])) v vs [$p|[] reduce-right: b|] =::: [$e|raise: @empty-list|] [$p|(l: List) reduce-right: b|] =: do vs <- getVector [$e|l|] b <- here "b" - foldr1MV (\x acc -> do- as <- list [x, acc]- dispatch (keyword ["call"] [b, as])) vs+ foldr1MV (\x acc ->+ dispatch (keyword ["call"] [b, list [x, acc]])) vs [$p|(l: List) reduce-right: b with: v|] =: do vs <- getVector [$e|l|] b <- here "b" v <- here "v" - foldrMV (\x acc -> do- as <- list [x, acc]- dispatch (keyword ["call"] [b, as])) v vs+ foldrMV (\x acc ->+ dispatch (keyword ["call"] [b, list [x, acc]])) v vs [$p|(l: List) concat|] =::: [$e|l reduce: @.. with: []|] [$p|(l: List) sum|] =::: [$e|l reduce: @+ with: 0|]@@ -183,35 +170,24 @@ vs <- getVector [$e|l|] b <- here "b" - t <- bool True nvs <- V.mapM (\v -> do- as <- list' (V.singleton v)- check <- dispatch (keyword ["call"] [b, as])- return (check == t)) vs+ Boolean t <- dispatch (keyword ["call"] [b, list [v]]) >>= findBoolean+ return t) vs - bool (V.and nvs)+ return $ Boolean (V.and nvs) [$p|(l: List) any?: b|] =: do vs <- getVector [$e|l|] b <- here "b" - t <- bool True nvs <- V.mapM (\v -> do- as <- list' (V.singleton v)- check <- dispatch (keyword ["call"] [b, as])- return (check == t)) vs-- bool (V.or nvs)+ Boolean t <- dispatch (keyword ["call"] [b, list [v]]) >>= findBoolean+ return t) vs - [$p|(l: List) and|] =: do- vs <- getVector [$e|l|]- t <- bool True- bool (V.all (== t) vs)+ return $ Boolean (V.or nvs) - [$p|(l: List) or|] =: do- vs <- getVector [$e|l|]- t <- bool True- bool (V.any (== t) vs)+ [$p|(l: List) and|] =::: [$e|l all?: @(== True)|]+ [$p|(l: List) or|] =::: [$e|l any?: @(== True)|] -- TODO: take-while, drop-while @@ -241,7 +217,7 @@ Integer y <- here "y" >>= findInteger Integer d <- here "d" >>= findInteger - list' $ V.generate+ return . List $ V.generate (fromIntegral $ abs ((y - x) `div` d) + 1) (Integer . (x +) . (* d) . fromIntegral) @@ -250,7 +226,6 @@ -- destructive update [$p|(l: List) at: (n: Integer) put: v|] =: do- List l <- here "l" >>= findList vs <- getVector [$e|l|] Integer n <- here "n" >>= findInteger@@ -264,90 +239,56 @@ ] else do - liftIO . writeIORef l $ vs V.// [(fromIntegral n, v)]-- return (List l)+ return (List $ vs V.// [(fromIntegral n, v)]) [$p|v . (l: List)|] =: do vs <- getVector [$e|l|] v <- here "v"- l <- liftIO . newIORef $ V.cons v vs- return (List l)+ return (List $ V.cons v vs) [$p|(l: List) << v|] =: do- List l <- here "l" >>= findList vs <- getVector [$e|l|] v <- here "v" - liftIO . writeIORef l $ V.snoc vs v-- return (List l)+ return . List $ V.snoc vs v [$p|v >> (l: List)|] =: do- List l <- here "l" >>= findList vs <- getVector [$e|l|] v <- here "v" - liftIO . writeIORef l $ V.cons v vs-- return (List l)-- [$p|[] pop!|] =::: [$e|raise: @empty-list|]- [$p|(l: List) pop!|] =: do- List l <- here "l" >>= findList- vs <- getVector [$e|l|]+ return . List $ V.cons v vs - liftIO . writeIORef l $ V.tail vs+ {-[$p|[] pop!|] =::: [$e|raise: @empty-list|]-}+ {-[$p|(l: List) pop!|] =: do-}+ {-List l <- here "l" >>= findList-}+ {-vs <- getVector [$e|l|]-} - return (V.head vs)+ {-return . List l $ V.tail vs-} [$p|(l: List) split: (d: List)|] =: do l <- getList [$e|l|] d <- getList [$e|d|] - mapM list (splitOn d l) >>= list+ return $ list (map list (splitOn d l)) [$p|(l: List) split-on: d|] =: do l <- getList [$e|l|] d <- here "d" - mapM list (splitWhen (== d) l) >>= list+ return $ list (map list (splitWhen (== d) l)) [$p|(l: List) sort|] =:- getList [$e|l|] >>= sortVM >>= list+ getList [$e|l|] >>= liftM list . sortVM [$p|(l: List) sort-by: cmp|] =: do- t <- bool True vs <- getList [$e|l|] cmp <- here "cmp" - sortByVM (\a b -> do- as <- list [a, b]- r <- dispatch (keyword ["call"] [cmp, as])- return (r == t)) vs >>= list-- prelude+ liftM list $ sortByVM (\a b -> do+ Boolean t <- dispatch (keyword ["call"] [cmp, list [a, b]]) >>= findBoolean+ return t) vs -prelude :: VM ()-prelude = mapM_ eval [$es|- (l: List) each: (b: Block) :=- { l map: b in-context- l- } call-- [] includes?: List := False- (x: List) includes?: (y: List) :=- if: (x (take: y length) == y)- then: { True }- else: { x tail includes?: y }-- [] join: List := []- [x] join: List := x- (x . xs) join: (d: List) :=- x .. d .. (xs join: d)-|]- foldr1MV :: (Value -> Value -> VM Value) -> V.Vector Value -> VM Value foldr1MV f vs = foldrMV f (V.last vs) (V.init vs) @@ -361,9 +302,8 @@ sortVM = sortByVM gt where gt a b = do- t <- bool True- r <- dispatch (keyword [">"] [a, b])- return (r == t)+ Boolean t <- dispatch (keyword [">"] [a, b]) >>= findBoolean+ return t sortByVM :: (Value -> Value -> VM Bool) -> [Value] -> VM [Value] sortByVM = mergesort
src/Atomo/Kernel/Message.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} module Atomo.Kernel.Message (load) where -import Atomo.Environment-import Atomo.Haskell+import Atomo load :: VM ()@@ -29,4 +28,4 @@ [$p|(m: Message) targets|] =: do Message (Keyword { mTargets = ts }) <- here "m" >>= findMessage- list ts+ return $ list ts
src/Atomo/Kernel/Method.hs view
@@ -1,8 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} module Atomo.Kernel.Method where -import Atomo.Environment-import Atomo.Haskell+import Atomo load :: VM ()
src/Atomo/Kernel/Numeric.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE QuasiQuotes #-} module Atomo.Kernel.Numeric (load) where -import Atomo.Environment-import Atomo.Haskell+import Data.Ratio +import Atomo + load :: VM () load = do mapM_ eval $@@ -38,64 +39,142 @@ Double d <- here "d" >>= findDouble return (Integer (floor d)) + [$p|(i: Integer) reciprocal|] =: do+ Integer i <- here "i" >>= findInteger+ return (Double (recip (fromIntegral i)))++ [$p|(d: Double) reciprocal|] =: do+ Double d <- here "d" >>= findDouble+ return (Double (recip d))++ [$p|(r: Rational) reciprocal|] =: do+ Rational r <- here "r" >>= findRational+ return (Rational (recip r))++ [$p|(r: Rational) numerator|] =: do+ Rational r <- here "r" >>= findRational+ return (Integer (numerator r))++ [$p|(r: Rational) denominator|] =: do+ Rational r <- here "r" >>= findRational+ return (Integer (denominator r))+ [$p|(d: Double) as: Integer|] =::: [$e|d floor|]+ [$p|(d: Double) as: Rational|] =::: [$e|d rationalize|]+ [$p|(i: Integer) as: Double|] =: do+ Integer i <- here "i" >>= findInteger+ return (Double (fromIntegral i))+ [$p|(i: Integer) as: Rational|] =: do+ Integer i <- here "i" >>= findInteger+ return (Rational (i % 1))+ [$p|(r: Rational) as: Double|] =::: [$e|r approximate|]+ [$p|(r: Rational) as: Integer|] =::: [$e|r approximate floor|] + [$p|(i: Integer) rationalize|] =::: [$e|(i as: Double) rationalize|]+ [$p|(d: Double) rationalize|] =::: [$e|d rationalize: 0.001|]+ [$p|(d: Double) rationalize: (e: Double)|] =: do+ Double d <- here "d" >>= findDouble+ Double e' <- here "e" >>= findDouble+ return (Rational (approxRational d e'))++ [$p|(r: Rational) approximate|] =: do+ Rational r <- here "r" >>= findRational+ return (Double (fromRational r))+ [$p|(a: Integer) + (b: Integer)|] =: primII (+)+ [$p|(a: Rational) + (b: Rational)|] =: primRR (+)+ [$p|(a: Double) + (b: Double)|] =: primDD (+) [$p|(a: Integer) + (b: Double)|] =: primID (+)+ [$p|(a: Integer) + (b: Rational)|] =: primIR (+) [$p|(a: Double) + (b: Integer)|] =: primDI (+)- [$p|(a: Double) + (b: Double)|] =: primDD (+)+ [$p|(a: Double) + (b: Rational)|] =: primDR (+)+ [$p|(a: Rational) + (b: Integer)|] =: primRI (+)+ [$p|(a: Rational) + (b: Double)|] =: primRD (+)+ [$p|(a: Integer) - (b: Integer)|] =: primII (-)+ [$p|(a: Rational) - (b: Rational)|] =: primRR (-)+ [$p|(a: Double) - (b: Double)|] =: primDD (-) [$p|(a: Integer) - (b: Double)|] =: primID (-)+ [$p|(a: Integer) - (b: Rational)|] =: primIR (-) [$p|(a: Double) - (b: Integer)|] =: primDI (-)- [$p|(a: Double) - (b: Double)|] =: primDD (-)+ [$p|(a: Double) - (b: Rational)|] =: primDR (-)+ [$p|(a: Rational) - (b: Integer)|] =: primRI (-)+ [$p|(a: Rational) - (b: Double)|] =: primRD (-)+ [$p|(a: Integer) * (b: Integer)|] =: primII (*)+ [$p|(a: Rational) * (b: Rational)|] =: primRR (*)+ [$p|(a: Double) * (b: Double)|] =: primDD (*) [$p|(a: Integer) * (b: Double)|] =: primID (*)+ [$p|(a: Integer) * (b: Rational)|] =: primIR (*) [$p|(a: Double) * (b: Integer)|] =: primDI (*)- [$p|(a: Double) * (b: Double)|] =: primDD (*)+ [$p|(a: Double) * (b: Rational)|] =: primDR (*)+ [$p|(a: Rational) * (b: Integer)|] =: primRI (*)+ [$p|(a: Rational) * (b: Double)|] =: primRD (*)+ [$p|(a: Integer) / (b: Integer)|] =: primII div+ [$p|(a: Rational) / (b: Rational)|] =: primRR (/)+ [$p|(a: Double) / (b: Double)|] =: primDD (/) [$p|(a: Integer) / (b: Double)|] =: primID (/)+ [$p|(a: Integer) / (b: Rational)|] =: primIR (/) [$p|(a: Double) / (b: Integer)|] =: primDI (/)- [$p|(a: Double) / (b: Double)|] =: primDD (/)+ [$p|(a: Double) / (b: Rational)|] =: primDR (/)+ [$p|(a: Rational) / (b: Integer)|] =: primRI (/)+ [$p|(a: Rational) / (b: Double)|] =: primRD (/)+ [$p|(a: Integer) ^ (b: Integer)|] =: primII (^)+ [$p|(a: Double) ^ (b: Double)|] =: primDD (**) [$p|(a: Integer) ^ (b: Double)|] =: primID (**) [$p|(a: Double) ^ (b: Integer)|] =: primDI (**)- [$p|(a: Double) ^ (b: Double)|] =: primDD (**)+ [$p|(a: Rational) ^ (b: Integer)|] =: do+ Rational a <- here "a" >>= findRational+ Integer b <- here "b" >>= findInteger+ return (Rational (a ^ b)) [$p|(a: Integer) % (b: Integer)|] =: primII mod [$p|(a: Integer) quotient: (b: Integer)|] =: primII quot [$p|(a: Integer) remainder: (b: Integer)|] =: primII rem-- prelude where primII f = do Integer a <- here "a" >>= findInteger Integer b <- here "b" >>= findInteger return (Integer (f a b)) + primDD f = do+ Double a <- here "a" >>= findDouble+ Double b <- here "b" >>= findDouble+ return (Double (f a b))++ primRR f = do+ Rational a <- here "a" >>= findRational+ Rational b <- here "b" >>= findRational+ return (Rational (f a b))+ primID f = do Integer a <- here "a" >>= findInteger Double b <- here "b" >>= findDouble return (Double (f (fromIntegral a) b)) + primIR f = do+ Integer a <- here "a" >>= findInteger+ Rational b <- here "b" >>= findRational+ return (Rational (f (toRational a) b))+ primDI f = do Double a <- here "a" >>= findDouble Integer b <- here "b" >>= findInteger return (Double (f a (fromIntegral b))) - primDD f = do+ primDR f = do Double a <- here "a" >>= findDouble- Double b <- here "b" >>= findDouble- return (Double (f a b))---prelude :: VM ()-prelude = mapM_ eval [$es|- (n: Integer) even? := 2 divides?: n- (n: Integer) odd? := n even? not+ Rational b <- here "b" >>= findRational+ return (Rational (f (toRational a) b)) - (x: Integer) divides?: (y: Integer) :=- (y % x) == 0+ primRD f = do+ Rational a <- here "a" >>= findRational+ Double b <- here "b" >>= findDouble+ return (Rational (f a (toRational b))) - (x: Integer) divisible-by?: (y: Integer) :=- y divides?: x-|]+ primRI f = do+ Rational a <- here "a" >>= findRational+ Integer b <- here "b" >>= findInteger+ return (Rational (f a (toRational b)))
− src/Atomo/Kernel/Parameter.hs
@@ -1,42 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-module Atomo.Kernel.Parameter (load) where--import Atomo.Environment-import Atomo.Haskell---load :: VM ()-load = mapM_ eval [$es|- operator right 0 =!-- Parameter = Object clone- Parameter new: v := Parameter clone do:- { set-default: v- }-- (p: Parameter) _? := p value: self-- (p: Parameter) =! v :=- (p) value: (self) = v-- (p: Parameter) set-default: v :=- (p) value: _ = 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 = p _?- action before: { p set-default: new } after: { p set-default: old }- } call-- with: [] do: (action: Block) := action call- with: (b . bs) do: (action: Block) :=- with: b from as: b to do: { with: bs do: action }-- with-defaults: [] do: (action: Block) := action call- with-defaults: (b . bs) do: (action: Block) :=- with-default: b from as: b to do: { with: bs do: action }-|]
src/Atomo/Kernel/Particle.hs view
@@ -2,51 +2,11 @@ {-# OPTIONS -fno-warn-name-shadowing #-} module Atomo.Kernel.Particle (load) where -import Atomo.Environment-import Atomo.Haskell+import Atomo load :: VM () load = do- [$p|(p: Particle) show|] =::: [$e|- p type match: {- @keyword -> {- operator? = @(all?: @(in?: "~!@#$%^&*-_=+./\\\|<>?:"))-- keywordfy = { str |- if: (operator? call: [str])- then: { str }- else: { str .. ":" }- }- - vs := p values map: { v |- v match: {- @none -> "_"- @(ok: v) -> v show- }- }-- initial := vs head match: {- "_" -> ""- v -> v .. " "- }-- rest := (p names zip: vs tail) (map: { pair |- keywordfy call: [pair from] .. " " .. pair to- }) (join: " ")-- if: p values (all?: @(== @none))- then: { "@" .. p names (map: { n | keywordfy call: [n] }) join }- else: {- "@(" .. initial .. rest .. ")"- }- } call-- @single ->- ("@" .. p name)- }- |]- [$p|(p: Particle) call: (targets: List)|] =::: [$e|(p complete: targets) send|] @@ -56,11 +16,11 @@ [$p|(p: Particle) names|] =: do Particle (PMKeyword ns _) <- here "p" >>= findParticle- list (map string ns)+ return $ list (map string ns) [$p|(p: Particle) values|] =: do (Particle (PMKeyword _ mvs)) <- here "p" >>= findParticle- list $+ return . list $ map (maybe (particle "none") (keyParticleN ["ok"] . (:[]))) mvs@@ -87,3 +47,31 @@ then throwError (ParticleArity 1 0) else return . Message . single n $ head vs + [$p|(p: Particle) define-on: (targets: List) as: v|] =:::+ [$e|p define-on: targets as: v in: sender|]++ [$p|(p: Particle) define-on: (targets: List) as: v in: c|] =: do+ Particle p <- here "p" >>= findParticle+ vs <- getList [$e|targets|]+ v <- here "v"+ c <- here "c"++ let targets =+ map (\v ->+ case v of+ Pattern p -> p+ _ -> PMatch v) vs+ expr =+ case v of+ Expression e -> e+ _ -> Primitive Nothing v++ withTop c $ do+ case p of+ PMKeyword ns _ ->+ define (pkeyword ns targets) expr++ PMSingle n ->+ define (psingle n (head targets)) expr++ return (particle "ok")
src/Atomo/Kernel/Pattern.hs view
@@ -2,8 +2,7 @@ {-# OPTIONS -fno-warn-name-shadowing #-} module Atomo.Kernel.Pattern (load) where -import Atomo.Environment-import Atomo.Haskell+import Atomo import Atomo.Method @@ -26,7 +25,7 @@ Pattern p <- here "p" >>= findPattern case p of- PKeyword { ppNames = ns } -> list (map string ns)+ PKeyword { ppNames = ns } -> return $ list (map string ns) _ -> raise ["no-names-for"] [Pattern p] [$p|(p: Pattern) target|] =: do@@ -40,7 +39,7 @@ Pattern p <- here "p" >>= findPattern case p of- PKeyword { ppTargets = ts } -> list (map Pattern ts)+ PKeyword { ppTargets = ts } -> return $ list (map Pattern ts) _ -> raise ["no-targets-for"] [Pattern p] [$p|(p: Pattern) matches?: v|] =: do@@ -58,6 +57,12 @@ return (keyParticle ["yes"] [Nothing, Just o]) else return (particle "no")++ [$p|(p: Pattern) set-to: v|] =: do+ Pattern p <- here "p" >>= findPattern+ v <- here "v"+ s <- eval [$e|sender|]+ withTop s (set p v) where -- convert an expression to the pattern match it represents toPattern (Dispatch { eMessage = EKeyword { emNames = ["."], emTargets = [h, t] } }) = do
src/Atomo/Kernel/Ports.hs view
@@ -8,8 +8,7 @@ import System.IO import qualified Data.Text.IO as TIO -import Atomo.Environment-import Atomo.Haskell+import Atomo import Atomo.Parser import Atomo.Pretty @@ -27,9 +26,6 @@ [$p|Port standard-output|] =:: soutp [$p|Port standard-error|] =:: serrp - ([$p|current-output-port|] =::) =<< eval [$e|Parameter new: Port standard-output|]- ([$p|current-input-port|] =::) =<< eval [$e|Parameter new: Port standard-input|]- [$p|Port new: (fn: String)|] =::: [$e|Port new: fn mode: @read-write|] [$p|Port new: (fn: String) mode: (m: Particle)|] =: do fn <- getString [$e|fn|]@@ -49,7 +45,6 @@ portObj hdl - [$p|(x: Object) print|] =::: [$e|current-output-port _? print: x|] [$p|(p: Port) print: x|] =: do x <- here "x" hdl <- getHandle [$e|p handle|]@@ -60,7 +55,6 @@ liftIO (hFlush hdl) return x - [$p|(x: Object) display|] =::: [$e|current-output-port _? display: x|] [$p|(p: Port) display: x|] =: do x <- here "x" hdl <- getHandle [$e|p handle|]@@ -71,7 +65,6 @@ liftIO (hFlush hdl) return x - [$p|read|] =::: [$e|current-input-port _? read|] [$p|(p: Port) read|] =: do h <- getHandle [$e|p handle|] @@ -90,16 +83,14 @@ is | all isPrimitive is -> evalAll is (i:_) -> return (Expression i) - [$p|read-line|] =::: [$e|current-input-port _? read-line|] [$p|(p: Port) read-line|] =: do h <- getHandle [$e|p handle|] done <- liftIO (hIsEOF h) if done then raise' "end-of-input"- else fmap String $ liftIO (TIO.hGetLine h)+ else liftM String $ liftIO (TIO.hGetLine h) - [$p|read-char|] =::: [$e|current-input-port _? read-char|] [$p|(p: Port) read-char|] =: do h <- getHandle [$e|p handle|] b <- liftIO (hGetBuffering h)@@ -109,7 +100,6 @@ return (Char c) - [$p|contents|] =::: [$e|current-input-port _? contents|] [$p|(p: Port) contents|] =: getHandle [$e|p handle|] >>= liftIO . TIO.hGetContents >>= return . String@@ -123,34 +113,25 @@ >> return (particle "ok") [$p|(p: Port) open?|] =:- getHandle [$e|p handle|] >>= liftIO . hIsOpen- >>= bool+ getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hIsOpen [$p|(p: Port) closed?|] =:- getHandle [$e|p handle|] >>= liftIO . hIsClosed- >>= bool+ getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hIsClosed [$p|(p: Port) readable?|] =:- getHandle [$e|p handle|] >>= liftIO . hIsReadable- >>= bool+ getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hIsReadable [$p|(p: Port) writable?|] =:- getHandle [$e|p handle|] >>= liftIO . hIsWritable- >>= bool+ getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hIsWritable [$p|(p: Port) seekable?|] =:- getHandle [$e|p handle|] >>= liftIO . hIsSeekable- >>= bool+ getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hIsSeekable - [$p|ready?|] =::: [$e|current-input-port _? ready?|] [$p|(p: Port) ready?|] =:- getHandle [$e|p handle|] >>= liftIO . hReady- >>= bool+ getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hReady - [$p|eof?|] =::: [$e|current-input-port _? eof?|] [$p|(p: Port) eof?|] =:- getHandle [$e|p handle|] >>= liftIO . hIsEOF- >>= bool+ getHandle [$e|p handle|] >>= liftM Boolean . liftIO . hIsEOF [$p|File new: (fn: String)|] =::: [$e|Port new: fn|]@@ -180,15 +161,15 @@ [$p|File canonicalize-path: (fn: String)|] =: do fn <- getString [$e|fn|]- fmap string $ liftIO (canonicalizePath fn)+ liftM string $ liftIO (canonicalizePath fn) [$p|File make-relative: (fn: String)|] =: do fn <- getString [$e|fn|]- fmap string $ liftIO (makeRelativeToCurrentDirectory fn)+ liftM string $ liftIO (makeRelativeToCurrentDirectory fn) [$p|File exists?: (fn: String)|] =: do fn <- getString [$e|fn|]- liftIO (doesFileExist fn) >>= bool+ fmap Boolean $ liftIO (doesFileExist fn) [$p|File find-executable: (name: String)|] =: do name <- getString [$e|name|]@@ -199,54 +180,46 @@ [$p|File readable?: (fn: String)|] =: getString [$e|fn|]- >>= fmap readable . liftIO . getPermissions- >>= bool+ >>= liftM (Boolean . readable) . liftIO . getPermissions [$p|File writable?: (fn: String)|] =: getString [$e|fn|]- >>= fmap writable . liftIO . getPermissions- >>= bool+ >>= liftM (Boolean . writable) . liftIO . getPermissions [$p|File executable?: (fn: String)|] =: getString [$e|fn|]- >>= fmap executable . liftIO . getPermissions- >>= bool+ >>= liftM (Boolean . executable) . liftIO . getPermissions [$p|File searchable?: (fn: String)|] =: getString [$e|fn|]- >>= fmap searchable . liftIO . getPermissions- >>= bool+ >>= liftM (Boolean . searchable) . liftIO . getPermissions [$p|File set-readable: (fn: String) to: (b: Boolean)|] =: do- t <- bool True- b <- here "b"+ Boolean r <- here "b" >>= findBoolean fn <- getString [$e|fn|] ps <- liftIO (getPermissions fn)- liftIO (setPermissions fn (ps { readable = b == t }))+ liftIO (setPermissions fn (ps { readable = r })) return (particle "ok") [$p|File set-writable: (fn: String) to: (b: Boolean)|] =: do- t <- bool True- b <- here "b"+ Boolean w <- here "b" >>= findBoolean fn <- getString [$e|fn|] ps <- liftIO (getPermissions fn)- liftIO (setPermissions fn (ps { writable = b == t }))+ liftIO (setPermissions fn (ps { writable = w })) return (particle "ok") [$p|File set-executable: (fn: String) to: (b: Boolean)|] =: do- t <- bool True- b <- here "b"+ Boolean x <- here "b" >>= findBoolean fn <- getString [$e|fn|] ps <- liftIO (getPermissions fn)- liftIO (setPermissions fn (ps { executable = b == t }))+ liftIO (setPermissions fn (ps { executable = x })) return (particle "ok") [$p|File set-searchable: (fn: String) to: (b: Boolean)|] =: do- t <- bool True- b <- here "b"+ Boolean s <- here "b" >>= findBoolean fn <- getString [$e|fn|] ps <- liftIO (getPermissions fn)- liftIO (setPermissions fn (ps { searchable = b == t }))+ liftIO (setPermissions fn (ps { searchable = s })) return (particle "ok") [$p|Directory create: (path: String)|] =: do@@ -300,11 +273,10 @@ [$p|Directory contents: (path: String)|] =: getString [$e|path|] >>= liftIO . getDirectoryContents- >>= return . filter (not . (`elem` [".", ".."]))- >>= list . map string+ >>= return . list . map string . filter (not . (`elem` [".", ".."])) [$p|Directory current|] =:- fmap string $ liftIO getCurrentDirectory+ liftM string $ liftIO getCurrentDirectory [$p|Directory current: (path: String)|] =: do path <- getString [$e|path|]@@ -312,21 +284,21 @@ return (particle "ok") [$p|Directory home|] =:- fmap string $ liftIO getHomeDirectory+ liftM string $ liftIO getHomeDirectory [$p|Directory user-data-for: (app: String)|] =: do app <- getString [$e|app|]- fmap string $ liftIO (getAppUserDataDirectory app)+ liftM string $ liftIO (getAppUserDataDirectory app) [$p|Directory user-documents|] =:- fmap string $ liftIO getUserDocumentsDirectory+ liftM string $ liftIO getUserDocumentsDirectory [$p|Directory temporary|] =:- fmap string $ liftIO getTemporaryDirectory+ liftM string $ liftIO getTemporaryDirectory [$p|Directory exists?: (path: String)|] =: do path <- getString [$e|path|]- liftIO (doesDirectoryExist path) >>= bool+ liftM Boolean $ liftIO (doesDirectoryExist path) [$p|(a: String) </> (b: String)|] =: do a <- getString [$e|a|]@@ -337,8 +309,6 @@ a <- getString [$e|a|] b <- getString [$e|b|] return (string (a <.> b))-- prelude where portObj hdl = newScope $ do port <- eval [$e|Port clone|]@@ -379,12 +349,12 @@ return (c:cs) where wrapped d = do- w <- fmap (d:) $ hGetUntil h d+ w <- liftM (d:) $ hGetUntil h d rest <- hGetSegment' stop return (w ++ rest) nested c end = do- sub <- fmap (c:) $ hGetSegment' (Just end)+ sub <- liftM (c:) $ hGetSegment' (Just end) rest <- hGetSegment' stop return (sub ++ rest) @@ -397,44 +367,3 @@ else do cs <- hGetUntil h x return (c:cs)---prelude :: VM ()-prelude = mapM_ eval [$es|- with-output-to: (fn: String) do: b :=- { Port (new: fn mode: @write) } wrap: @close do:- { file |- with-output-to: file do: b- }-- with-output-to: (p: Port) do: b :=- with: current-output-port as: p do: b-- with-input-from: (fn: String) do: (b: Block) :=- { Port (new: fn mode: @read) } wrap: @close do:- { file |- with-input-from: file do: b- }-- with-input-from: (p: Port) do: (b: Block) :=- with: current-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: current-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: current-input-port as: p do: b-|]
src/Atomo/Kernel/String.hs view
@@ -4,14 +4,13 @@ import Data.List (sort) import qualified Data.Text as T -import Atomo.Environment-import Atomo.Haskell+import Atomo load :: VM () load = do [$p|(s: String) as: List|] =:- getString [$e|s|] >>= list . map Char+ getString [$e|s|] >>= return . list . map Char [$p|(l: List) to-string|] =: do vs <- getList [$e|l|]@@ -28,7 +27,7 @@ getText [$e|s|] >>= return . Integer . fromIntegral . T.length [$p|(s: String) empty?|] =:- getText [$e|s|] >>= bool . T.null+ liftM (Boolean . T.null) $ getText [$e|s|] [$p|(s: String) at: (n: Integer)|] =: do Integer n <- here "n" >>= findInteger@@ -90,7 +89,7 @@ [$p|(l: List) join: (d: String)|] =: do ts <- getList [$e|l|]- >>= mapM (fmap (\(String t) -> t) . findString)+ >>= mapM (liftM (\(String t) -> t) . findString) d <- getText [$e|d|] @@ -104,57 +103,57 @@ [$p|(s: String) split: (d: String)|] =: do s <- getText [$e|s|] d <- getText [$e|d|]- list (map String (T.split d s))+ return $ list (map String (T.split d s)) -- TODO: split-by [$p|(s: String) split-on: (d: Char)|] =: do s <- getText [$e|s|] Char d <- here "d" >>= findChar- list (map String (T.splitBy (== d) s))+ return $ list (map String (T.splitBy (== d) s)) [$p|(s: String) split-at: (n: Integer)|] =: do Integer n <- here "n" >>= findInteger s <- getText [$e|s|] let (a, b) = T.splitAt (fromIntegral n) s- list [String a, String b]+ return $ list [String a, String b] [$p|(s: String) break-on: (d: Integer)|] =: do s <- getText [$e|s|] d <- getText [$e|d|] let (a, b) = T.break d s- list [String a, String b]+ return $ list [String a, String b] [$p|(s: String) break-end: (d: Integer)|] =: do s <- getText [$e|s|] d <- getText [$e|d|] let (a, b) = T.breakEnd d s- list [String a, String b]+ return $ list [String a, String b] [$p|(s: String) group|] =: do s <- getText [$e|s|]- list (map String (T.group s))+ return $ list (map String (T.group s)) [$p|(s: String) inits|] =: do s <- getText [$e|s|]- list (map String (T.inits s))+ return $ list (map String (T.inits s)) [$p|(s: String) tails|] =: do s <- getText [$e|s|]- list (map String (T.tails s))+ return $ list (map String (T.tails s)) [$p|(s: String) chunks-of: (n: Integer)|] =: do Integer n <- here "n" >>= findInteger s <- getText [$e|s|]- list (map String (T.chunksOf (fromIntegral n) s))+ return $ list (map String (T.chunksOf (fromIntegral n) s)) [$p|(s: String) lines|] =: do s <- getText [$e|s|]- list (map String (T.lines s))+ return $ list (map String (T.lines s)) [$p|(s: String) words|] =: do s <- getText [$e|s|]- list (map String (T.words s))+ return $ list (map String (T.words s)) [$p|(l: List) unlines|] =::: [$e|l (map: @(<< '\n')) join|] [$p|(l: List) unwords|] =::: [$e|l join: " "|]@@ -163,13 +162,12 @@ s <- getString [$e|s|] b <- here "b" - vs <- forM s $ \c -> do- as <- list [Char c]- dispatch (keyword ["call"] [b, as])+ vs <- forM s $ \c ->+ dispatch (keyword ["call"] [b, list [Char c]]) if all isChar vs then return (string (map (\(Char c) -> c) vs))- else list vs+ else return $ list vs [$p|(s: String) each: (b: Block)|] =::: [$e|{ s map: b in-context; s } call|] @@ -246,7 +244,7 @@ [$p|(s: String) contains?: (c: Char)|] =: do t <- getText [$e|s|] Char c <- here "c" >>= findChar- bool (T.any (== c) t)+ return (Boolean (T.any (== c) t)) [$p|(c: Char) in?: (s: String)|] =::: [$e|s contains?: c|] @@ -270,17 +268,17 @@ [$p|(a: String) is-prefix-of?: (b: String)|] =: do a <- getText [$e|a|] b <- getText [$e|b|]- bool (T.isPrefixOf a b)+ return $ Boolean (T.isPrefixOf a b) [$p|(a: String) is-suffix-of?: (b: String)|] =: do a <- getText [$e|a|] b <- getText [$e|b|]- bool (T.isSuffixOf a b)+ return $ Boolean (T.isSuffixOf a b) [$p|(a: String) is-infix-of?: (b: String)|] =: do a <- getText [$e|a|] b <- getText [$e|b|]- bool (T.isInfixOf a b)+ return $ Boolean (T.isInfixOf a b) [$p|(a: String) starts-with?: (b: String)|] =::: [$e|b is-prefix-of?: a|] [$p|(a: String) ends-with?: (b: String)|] =::: [$e|b is-suffix-of?: a|]@@ -294,8 +292,7 @@ y <- getText [$e|y|] z <- here "z" - vs <- forM (T.zip x y) $ \(a, b) -> do- as <- list [Char a, Char b]- dispatch (keyword ["call"] [z, as])+ vs <- forM (T.zip x y) $ \(a, b) ->+ dispatch (keyword ["call"] [z, list [Char a, Char b]]) - list vs+ return $ list vs
src/Atomo/Kernel/Time.hs view
@@ -3,8 +3,7 @@ import Data.Time.Clock.POSIX (getPOSIXTime) -import Atomo.Environment-import Atomo.Haskell+import Atomo load :: VM ()@@ -12,7 +11,7 @@ ([$p|Timer|] =::) =<< eval [$e|Object clone|] [$p|Timer now|] =:- fmap (Double . fromRational . toRational) (liftIO getPOSIXTime)+ liftM (Double . fromRational . toRational) (liftIO getPOSIXTime) [$p|Timer sleep: (n: Integer)|] =: do Integer n <- here "n" >>= findInteger@@ -24,58 +23,10 @@ liftIO (threadDelay (floor d)) return (particle "ok") - prelude - sleepFor :: Integer -> IO () sleepFor n | n > fromIntegral limit = threadDelay limit >> sleepFor (n - fromIntegral limit) | otherwise = threadDelay (fromIntegral n) where limit = maxBound :: Int--prelude :: VM ()-prelude = mapM_ eval [$es|- Timer do: (b: Block) every: (n: Number) :=- { { Timer sleep: n; b spawn } repeat } spawn-- Timer do: (b: Block) after: (n: Number) :=- { Timer sleep: n; b call } spawn-- (b: Block) time :=- { before = Timer now- b call- after = Timer now- after - before- } call-- -- units!- (n: Number) us := n- (n: Number) microseconds := n us- (n: Number) microsecond := n us-- (n: Number) ms := n * 1000- (n: Number) milliseconds := n ms- (n: Number) millisecond := n ms-- (n: Number) seconds := n * 1000000- (n: Number) second := n seconds-- (n: Number) minutes := (n * 60) seconds- (n: Number) minute := n minutes-- (n: Number) hours := (n * 60) minutes- (n: Number) hour := n hours-- (n: Number) days := (n * 24) hours- (n: Number) day := n days-- (n: Number) weeks := (n * 7) days- (n: Number) week := n weeks-- (n: Number) months := (n * 30) days- (n: Number) month := n months-- (n: Number) years := (n * 365) days- (n: Number) year := n years-|]
+ src/Atomo/Load.hs view
@@ -0,0 +1,82 @@+module Atomo.Load where++import "monads-fd" Control.Monad.Error+import "monads-fd" Control.Monad.State+import System.Directory+import System.FilePath+import qualified Language.Haskell.Interpreter as H++import Atomo.Environment+import Atomo.Parser+import Atomo.Types+++-- load a file, remembering it to prevent repeated loading+-- searches with cwd as lowest priority+requireFile :: FilePath -> VM Value+requireFile fn = do+ initialPath <- gets loadPath+ file <- findFile (initialPath ++ [""]) fn++ alreadyLoaded <- gets ((file `elem`) . loaded)+ if alreadyLoaded+ then return (particle "already-loaded")+ else do++ modify $ \s -> s { loaded = file : loaded s }++ doLoad file++-- load a file+-- searches with cwd as highest priority+loadFile :: FilePath -> VM Value+loadFile fn = do+ initialPath <- gets loadPath+ findFile ("":initialPath) fn >>= doLoad++-- execute a file+doLoad :: FilePath -> VM Value+doLoad file =+ case takeExtension file of+ ".hs" -> do+ int <- liftIO . H.runInterpreter $ do+ H.loadModules [file]+ H.setTopLevelModules ["Main"]+ H.interpret "load" (H.as :: VM ())++ load <- either (throwError . ImportError) return int++ load++ return (particle "ok")++ _ -> do+ initialPath <- gets loadPath++ ast <- parseFile file++ modify $ \s -> s+ { loadPath = [takeDirectory file]+ }++ r <- evalAll ast++ modify $ \s -> s+ { loadPath = initialPath+ }++ return r++-- | given a list of paths to search, find the file to load+-- attempts to find the filename with .atomo and .hs extensions+findFile :: [FilePath] -> FilePath -> VM FilePath+findFile [] fn = throwError (FileNotFound fn)+findFile (p:ps) fn = do+ check <- filterM (liftIO . doesFileExist . ((p </> fn) <.>)) exts++ case check of+ [] -> findFile ps fn+ (ext:_) -> liftIO (canonicalizePath $ p </> fn <.> ext)+ where+ exts = ["", "atomo", "hs"]+
src/Atomo/Method.hs view
@@ -3,6 +3,7 @@ , elemsMap , emptyMap , insertMethod+ , insertMap , lookupMap , noMethods , nullMap@@ -122,3 +123,8 @@ elemsMap :: MethodMap -> [[Method]] elemsMap = M.elems++insertMap :: Method -> MethodMap -> MethodMap+insertMap m mm = M.insert key [m] mm+ where+ key = ppID (mPattern m)
src/Atomo/Parser.hs view
@@ -1,12 +1,15 @@ module Atomo.Parser where -import Control.Monad.Error-import Control.Monad.Identity-import Control.Monad.State-import Data.Maybe (fromJust)+import Control.Arrow (first, second)+import "monads-fd" Control.Monad.Error+import "monads-fd" Control.Monad.State+import Data.Maybe (fromJust, isJust) import Text.Parsec+import qualified "mtl" Control.Monad.Trans as MTL import Atomo.Debug+import Atomo.Environment+import Atomo.Method import Atomo.Parser.Base import {-# SOURCE #-} Atomo.Parser.Pattern import Atomo.Parser.Primitive@@ -24,6 +27,7 @@ pExpr :: Parser Expr pExpr = choice [ try pOperator+ , try pMacro , try pDefine , try pSet , try pDispatch@@ -33,9 +37,55 @@ <?> "expression" pLiteral :: Parser Expr-pLiteral = try pBlock <|> try pList <|> try pParticle <|> pPrimitive+pLiteral = try pBlock <|> try pList <|> try pParticle <|> try pQuoted <|> try pUnquoted <|> pPrimitive <?> "literal" +pQuoted :: Parser Expr+pQuoted = tagged $ do+ char '`'+ e <- pSpacedExpr+ return (EQuote Nothing e)++pUnquoted :: Parser Expr+pUnquoted = tagged $ do+ char '~'+ e <- pSpacedExpr+ return (EUnquote Nothing e)++pSpacedExpr :: Parser Expr+pSpacedExpr = try pLiteral <|> simpleDispatch <|> parens pExpr+ where+ simpleDispatch = tagged $ do+ name <- ident+ notFollowedBy (char ':')+ return (Dispatch Nothing (esingle name (ETop Nothing)))++pMacro :: Parser Expr+pMacro = tagged (do+ reserved "macro"+ p <- ppMacro+ reserved ":="+ whiteSpace+ e <- pExpr+ addMacro p e+ return (EMacro Nothing p e))+ <?> "macro definition"++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+ pOperator :: Parser Expr pOperator = tagged (do reserved "operator"@@ -54,7 +104,7 @@ ops <- commaSep1 operator forM_ ops $ \name ->- modifyState ((name, info) :)+ modifyState (\ps -> ps { psOperators = (name, info) : psOperators ps }) return (Operator Nothing ops (fst info) (snd info))) <?> "operator pragma"@@ -111,14 +161,14 @@ pdKeys = do pos <- getPosition msg <- keywords ekeyword (ETop (Just pos)) (try pdCascade <|> headless)- ops <- getState+ ops <- fmap psOperators getState return $ Dispatch (Just pos) (toBinaryOps ops msg) <?> "keyword dispatch" where headless = do p <- getPosition msg <- ckeywd p- ops <- getState+ ops <- fmap psOperators getState return (Dispatch (Just p) (toBinaryOps ops msg)) ckeywd pos = do@@ -132,7 +182,7 @@ pos <- getPosition chain <- wsManyStart- (fmap DNormal (try pLiteral <|> pCall <|> parens pExpr) <|> cascaded)+ (fmap DNormal (try pLiteral <|> parens pExpr) <|> cascaded) cascaded return $ dispatches pos chain@@ -170,8 +220,9 @@ pBlock = tagged (braces $ do arguments <- option [] . try $ do ps <- many1 pPattern- delimit "|" whiteSpace+ string "|"+ whiteSpace1 return ps code <- wsBlock pExpr@@ -179,10 +230,6 @@ return $ EBlock Nothing arguments code) <?> "block" -pCall :: Parser Expr-pCall = tagged (reserved "dispatch" >> return (EDispatchObject Nothing))- <?> "dispatch object"- cSingle :: Bool -> Parser EParticle cSingle p = do n <- if p then anyIdent else ident@@ -194,8 +241,10 @@ cKeyword :: Bool -> Parser EParticle cKeyword wc = do ks <- parens $ many1 keyword'- let (ns, vs) = unzip ks- return $ EPMKeyword ns (Nothing:vs)+ let (ns, mvs) = second (Nothing:) $ unzip ks+ if any isOperator (tail ns)+ then toDispatch ns mvs+ else return $ EPMKeyword ns mvs <?> "keyword segment" where keywordVal@@ -203,11 +252,11 @@ | otherwise = value keywordDispatch- | wc = wildcard <|> dispatch- | otherwise = dispatch+ | wc = wildcard <|> disp+ | otherwise = disp value = fmap Just pdCascade- dispatch = fmap Just pDispatch+ disp = fmap Just pDispatch keyword' = do name <- try (do@@ -223,6 +272,19 @@ wildcard = symbol "_" >> return Nothing + toDispatch [] mvs = error $ "impossible: toDispatch on [] and " ++ show mvs+ toDispatch (n:ns) mvs+ | all isJust opVals = do+ os <- getState+ pos <- getPosition+ let msg = toBinaryOps (psOperators os) $ ekeyword opers (map fromJust opVals)+ return . EPMKeyword nonOpers $+ partVals ++ [Just $ Dispatch (Just pos) msg]+ | otherwise = fail "invalid particle; toplevel operator with wildcards as values"+ where+ (nonOpers, opers) = first (n:) $ span (not . isOperator) ns+ (partVals, opVals) = splitAt (length nonOpers) mvs+ -- work out precadence, associativity, etc. from a stream of operators -- the input is a keyword EMessage with a mix of operators and identifiers -- as its name, e.g. EKeyword { emNames = ["+", "*", "remainder"] }@@ -292,30 +354,92 @@ eof return es -cparser :: Parser (Operators, [Expr])+cparser :: Parser (ParserState, [Expr]) cparser = do r <- parser s <- getState return (s, r) -parseFile :: String -> IO (Either ParseError [Expr])-parseFile fn = fmap (runIdentity . runParserT parser [] fn) (readFile fn)--parseInput :: String -> Either ParseError [Expr]-parseInput = runIdentity . runParserT parser [] "<input>"+parseFile :: String -> VM [Expr]+parseFile fn = liftIO (readFile fn) >>= continue (parser >>= mapM macroExpand) fn -parse :: Parser a -> String -> Either ParseError a-parse p = runIdentity . runParserT p [] "<parse>"+parseInput :: String -> VM [Expr]+parseInput s = continue (parser >>= mapM macroExpand) "<input>" s --- | parse input i from source s, maintaining parser state between parses-continuedParse :: String -> String -> VM [Expr]-continuedParse i s = do+continue :: Parser a -> String -> String -> VM a+continue p s i = do ps <- gets parserState- case runIdentity (runParserT cparser ps s i) of+ r <- runParserT (p >>= \r -> getState >>= \ps' -> return (r, ps')) ps s i+ case r of Left e -> throwError (ParseError e)- Right (ps', es) -> do+ Right (ok, ps') -> do modify $ \e -> e { parserState = ps' }- return es+ return ok -continuedParseFile :: FilePath -> VM [Expr]-continuedParseFile fn = liftIO (readFile fn) >>= flip continuedParse fn+-- | parse input i from source s, maintaining parser state between parses+continuedParse :: String -> String -> VM [Expr]+continuedParse i s = continue parser s i++withParser :: Parser a -> VM a+withParser x = continue x "<internal>" ""++macroExpand :: Expr -> Parser Expr+macroExpand d@(Define { eExpr = e }) = do+ e' <- macroExpand e+ return d { eExpr = e' }+macroExpand s@(Set { eExpr = e }) = do+ e' <- macroExpand e+ return s { eExpr = e' }+macroExpand d@(Dispatch { eMessage = em }) = do+ (msg, nem) <- expandMsg em++ mm <- findMacro msg+ case mm of+ Just m -> do+ Expression e <- MTL.lift $ runMethod m msg+ macroExpand e++ _ -> return d { eMessage = nem }+ where+ expandMsg (ESingle i n t) = do+ nt <- macroExpand t+ return (Single i n (Expression nt), ESingle i n nt)+ expandMsg (EKeyword i ns ts) = do+ nts <- mapM macroExpand ts+ return (Keyword i ns (map Expression nts), EKeyword i ns nts)+macroExpand b@(EBlock { eContents = es }) = do+ nes <- mapM macroExpand es+ return b { eContents = nes }+macroExpand l@(EList { eContents = es }) = do+ nes <- mapM macroExpand es+ return l { eContents = nes }+macroExpand m@(EMacro { eExpr = e }) = do -- TODO: is this sane?+ e' <- macroExpand e+ return m { eExpr = e' }+macroExpand p@(EParticle { eParticle = ep }) =+ case ep of+ EPMKeyword 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+macroExpand e = return e++-- | find a findMacro method for message `m' on object `o'+findMacro :: Message -> Parser (Maybe Method)+findMacro m = do+ ids <- MTL.lift (gets primitives)+ ms <- methods m+ maybe (return Nothing) (firstMatch ids m) (lookupMap (mID m) ms)+ where+ methods (Single {}) = fmap (fst . psMacros) getState+ methods (Keyword {}) = fmap (snd . psMacros) getState++ firstMatch _ _ [] = return Nothing+ firstMatch ids' m' (mt:mts)+ | match ids' (mPattern mt) (Message m') = return (Just mt)+ | otherwise = firstMatch ids' m' mts
src/Atomo/Parser/Base.hs view
@@ -2,22 +2,21 @@ {-# OPTIONS -fno-warn-name-shadowing #-} module Atomo.Parser.Base where -import Control.Monad.Identity import Data.Char import Data.List (nub, sort, (\\)) import Text.Parsec import qualified Text.Parsec.Token as P -import Atomo.Types (Expr(..), Operators)+import Atomo.Types (Expr(..), ParserState, VM) -type Parser = ParsecT String Operators Identity+type Parser = ParsecT String ParserState VM opLetters :: [Char] opLetters = "~!@#$%^&*-_=+./\\|<>?" -def :: P.GenLanguageDef String Operators Identity+def :: P.GenLanguageDef String ParserState VM def = P.LanguageDef { P.commentStart = "{-" , P.commentEnd = "-}"@@ -25,14 +24,14 @@ , P.nestedComments = True , P.identStart = letter <|> oneOf "_" , P.identLetter = alphaNum <|> P.opLetter def- , P.opStart = oneOf (opLetters \\ "@")+ , P.opStart = oneOf (opLetters \\ "@_~") , P.opLetter = letter <|> oneOf opLetters , P.reservedOpNames = ["=", ":=", ",", "|", "_"]- , P.reservedNames = ["dispatch", "operator"]+ , P.reservedNames = ["operator", "macro", "True", "False"] , P.caseSensitive = True } -tp :: P.GenTokenParser String Operators Identity+tp :: P.GenTokenParser String ParserState VM tp = makeTokenParser def lexeme :: Parser a -> Parser a@@ -229,7 +228,7 @@ r <- p return r { eLocation = Just pos } -makeTokenParser :: P.GenLanguageDef String Operators Identity -> P.GenTokenParser String Operators Identity+makeTokenParser :: P.GenLanguageDef String ParserState VM -> P.GenTokenParser String ParserState VM makeTokenParser languageDef = P.TokenParser{ P.identifier = identifier , P.reserved = reserved
src/Atomo/Parser/Pattern.hs view
@@ -36,6 +36,51 @@ ppSet :: Parser Pattern ppSet = try ppDefine <|> pPattern +ppMacro :: Parser Pattern+ppMacro = try ppMacroKeywords <|> ppMacroSingle++ppMacroSingle :: Parser Pattern+ppMacroSingle = do+ (t, v) <- choice+ [ try $ do+ t <- ppMacroRole+ v <- identifier+ return (t, v)++ , do+ v <- identifier+ return (PAny, v)+ ]++ return $ psingle v t++ppMacroKeywords :: Parser Pattern+ppMacroKeywords = keywords pkeyword PAny ppMacroRole++ppMacroRole :: Parser Pattern+ppMacroRole = choice+ [ symbol "Define" >> return PEDefine+ , symbol "Set" >> return PESet+ , symbol "Dispatch" >> return PEDispatch+ , symbol "Operator" >> return PEOperator+ , symbol "Primitive" >> return PEPrimitive+ , symbol "Block" >> return PEBlock+ , symbol "List" >> return PEList+ , symbol "Macro" >> return PEMacro+ , symbol "Particle" >> return PEParticle+ , symbol "Top" >> return PETop+ , symbol "Quote" >> return PEQuote+ , symbol "Unquote" >> return PEUnquote+ , ppAny+ , ppNamedMacro+ ]+ where+ ppNamedMacro = parens $ do+ n <- identifier+ delimit ":"+ p <- ppMacroRole+ return $ PNamed n p+ ppDefine :: Parser Pattern ppDefine = try ppKeywords <|> ppSingle @@ -130,7 +175,7 @@ return (PNamed name PAny) ppWildcard :: Parser Pattern-ppWildcard = symbol "_" >> return PAny+ppWildcard = char '_' >> notFollowedBy identifier >> spacing >> return PAny ppMatch :: Parser Pattern ppMatch = do
src/Atomo/Parser/Pattern.hs-boot view
@@ -1,8 +1,9 @@-module Atomo.Parser.Pattern (pPattern, ppDefine, ppSet) where+module Atomo.Parser.Pattern (pPattern, ppDefine, ppMacro, ppSet) where import Atomo.Parser.Base (Parser) import Atomo.Types pPattern :: Parser Pattern ppDefine :: Parser Pattern+ppMacro :: Parser Pattern ppSet :: Parser Pattern
src/Atomo/Parser/Primitive.hs view
@@ -1,5 +1,6 @@ module Atomo.Parser.Primitive where +import Data.Ratio import Text.Parsec import Atomo.Parser.Base@@ -13,8 +14,10 @@ pPrim = choice [ pvChar , pvString+ , try pvRational , try pvDouble , try pvInteger+ , try pvBoolean ] pvChar :: Parser Value@@ -28,3 +31,16 @@ pvInteger :: Parser Value pvInteger = integer >>= return . Integer++pvBoolean :: Parser Value+pvBoolean = fmap Boolean $ true <|> false+ where+ true = reserved "True" >> return True+ false = reserved "False" >> return False++pvRational :: Parser Value+pvRational = do+ n <- integer+ char '/'+ d <- integer+ return (Rational (n % d))
src/Atomo/Pretty.hs view
@@ -4,6 +4,7 @@ import Data.IORef import Data.List (nub) import Data.Maybe (isJust)+import Data.Ratio import Text.PrettyPrint hiding (braces) import System.IO.Unsafe import qualified Data.Vector as V@@ -36,6 +37,7 @@ | otherwise = braces $ sep (map (prettyFrom CArgs) ps) <+> char '|' <+> exprs where exprs = sep . punctuate (text ";") $ map pretty es+ prettyFrom _ (Boolean b) = text $ show b prettyFrom _ (Char c) = text $ show c prettyFrom _ (Continuation _) = internal "continuation" empty prettyFrom _ (Double d) = double d@@ -44,15 +46,17 @@ prettyFrom _ (Integer i) = integer i prettyFrom _ (List l) = brackets . hsep . punctuate comma $ map (prettyFrom CList) vs- where vs = V.toList (unsafePerformIO (readIORef l))+ where vs = V.toList l prettyFrom _ (Message m) = internal "message" $ pretty m prettyFrom _ (Method (Slot p _)) = internal "slot" $ parens (pretty p) prettyFrom _ (Method (Responder p _ _)) = internal "responder" $ parens (pretty p)+ prettyFrom _ (Method (Macro p _)) = internal "macro" $ parens (pretty p) prettyFrom _ (Particle p) = char '@' <> pretty p 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 _ (Rational r) = integer (numerator r) <> char '/' <> integer (denominator r) prettyFrom _ (Reference _) = internal "object" empty prettyFrom _ (String s) = text (show s) @@ -78,6 +82,8 @@ prettyFrom CDefine p <+> text ":=" <++> prettyFrom CDefine v prettyMethod (Responder { mPattern = p, mExpr = e }) = prettyFrom CDefine p <+> text ":=" <++> prettyFrom CDefine e+ prettyMethod (Macro { mPattern = p, mExpr = e }) =+ text "macro" <+> prettyFrom CDefine p <+> text ":=" <++> prettyFrom CDefine e instance Pretty Message where prettyFrom _ (Single _ n t) = prettyFrom CSingle t <+> text n@@ -126,7 +132,20 @@ prettyFrom _ (PSingle _ n p) = pretty p <+> text n prettyFrom _ PThis = text "<this>" + prettyFrom _ PEDefine = text "Define"+ prettyFrom _ PESet = text "Set"+ prettyFrom _ PEDispatch = text "Dispatch"+ prettyFrom _ PEOperator = text "Operator"+ prettyFrom _ PEPrimitive = text "Primitive"+ prettyFrom _ PEBlock = text "Block"+ prettyFrom _ PEList = text "List"+ prettyFrom _ PEMacro = text "Macro"+ prettyFrom _ PEParticle = text "Particle"+ prettyFrom _ PETop = text "Top"+ prettyFrom _ PEQuote = text "Quote"+ prettyFrom _ PEUnquote = text "Unquote" + instance Pretty Expr where prettyFrom _ (Define _ p v) = prettyFrom CDefine p <+> text ":=" <++> prettyFrom CDefine v prettyFrom _ (Set _ p v) = prettyFrom CDefine p <+> text "=" <++> prettyFrom CDefine v@@ -144,13 +163,15 @@ | otherwise = braces $ sep (map pretty ps) <+> char '|' <+> exprs where exprs = sep . punctuate (text ";") $ map pretty es- prettyFrom _ (EDispatchObject {}) = text "dispatch" prettyFrom CDefine (EVM {}) = text "..." prettyFrom _ (EVM {}) = text "<vm>" prettyFrom _ (EList _ es) = brackets . sep . punctuate comma $ map (prettyFrom CList) es+ prettyFrom _ (EMacro _ p v) = text "macro" <+> prettyFrom CDefine p <+> text ":=" <++> prettyFrom CDefine v prettyFrom c (EParticle _ p) = char '@' <> prettyFrom c p prettyFrom _ (ETop {}) = text "<top>"+ prettyFrom _ (EQuote _ e) = char '`' <> parens (pretty e)+ prettyFrom _ (EUnquote _ e) = char '~' <> parens (pretty e) instance Pretty EMessage where
+ src/Atomo/PrettyVM.hs view
@@ -0,0 +1,40 @@+module Atomo.PrettyVM where++import "monads-fd" Control.Monad.State+import qualified Text.PrettyPrint as P++import Atomo.Environment+import Atomo.Pretty+import Atomo.Types+++-- | print an error, including the previous 10 expressions evaluated+-- with the most recent on the bottom+printError :: AtomoError -> VM ()+printError err = do+ t <- traceback++ if not (null t)+ then do+ liftIO (putStrLn "traceback:")++ forM_ t $ \e -> liftIO $+ print (prettyStack e)++ liftIO (putStrLn "")+ else return ()++ prettyError err >>= liftIO . print++ modify $ \s -> s { stack = [] }+ where+ traceback = liftM (reverse . take 10 . reverse) (gets stack)++prettyError :: AtomoError -> VM P.Doc+prettyError (Error v) = liftM (P.text "error:" P.<+>) (prettyVM v)+prettyError e = return (pretty e)++-- | pretty-print by sending \@show to the object+prettyVM :: Value -> VM P.Doc+prettyVM = liftM (P.text . fromText . fromString) . dispatch . (single "show")+
+ src/Atomo/QuasiQuotes.hs view
@@ -0,0 +1,187 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+module Atomo.QuasiQuotes+ ( p+ , e+ , es+ ) where++import "monads-fd" Control.Monad.State+import Data.IORef+import Data.Typeable+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import System.IO.Unsafe+import Text.Parsec+import qualified Data.Text as T+import qualified Language.Haskell.TH as TH++import Atomo.Core+import Atomo.Parser+import Atomo.Parser.Pattern+import Atomo.Parser.Base+import Atomo.Pretty+import Atomo.Types++qqEnv :: IORef Env+qqEnv = unsafePerformIO $ do+ (_, e) <- runVM (initCore >> return (particle "ok")) startEnv+ newIORef e++p :: QuasiQuoter+p = QuasiQuoter quotePatternExp undefined++e :: QuasiQuoter+e = QuasiQuoter quoteExprExp undefined++es :: QuasiQuoter+es = QuasiQuoter quoteExprsExp undefined++withLocation :: (String -> (String, Int, Int) -> Q a) -> (a -> Exp) -> String -> TH.ExpQ+withLocation p c s = do+ l <- TH.location+ r <- p s+ ( TH.loc_filename l+ , fst $ TH.loc_start l+ , snd $ TH.loc_start l+ )+ return (c r)++parsing :: (Monad m, Typeable a) => Parser a -> String -> (String, Int, Int) -> m a+parsing p s (file, line, col) =+ -- OH GOD!+ -- OH GOD! NO!+ -- WHYYYYYYYYYYYYYYYYYYYYYY+ case unsafePerformIO (runWith go (unsafePerformIO (readIORef qqEnv))) of+ Left e -> fail (show $ pretty e)+ Right x -> return (fromHaskell' "a" x)+ where+ go = do+ r <- fmap haskell $ continue pp "<qq>" s+ get >>= liftIO . writeIORef qqEnv+ return r++ pp = do+ pos <- getPosition+ setPosition $+ (flip setSourceName) file $+ (flip setSourceLine) line $+ (flip setSourceColumn) col $+ pos+ whiteSpace+ e <- p+ whiteSpace+ eof+ return e++quotePatternExp :: String -> TH.ExpQ+quotePatternExp = withLocation (parsing ppDefine) patternToExp++quoteExprExp :: String -> TH.ExpQ+quoteExprExp = withLocation (parsing pExpr) exprToExp++quoteExprsExp :: String -> TH.ExpQ+quoteExprsExp = withLocation (parsing (wsBlock pExpr)) (ListE . map exprToExp)++exprToExp :: Expr -> Exp+exprToExp (Define l p e) = AppE (AppE (expr "Define" l) (patternToExp p)) (exprToExp e)+exprToExp (Set l p e) = AppE (AppE (expr "Set" l) (patternToExp p)) (exprToExp e)+exprToExp (Dispatch l m) = AppE (expr "Dispatch" l) (emessageToExp m)+exprToExp (Operator l ns a p) = AppE (AppE (AppE (expr "Operator" l) (ListE (map (LitE . StringL) ns))) (assocToExp a)) (LitE (IntegerL p))+exprToExp (Primitive l v) = AppE (expr "Primitive" l) (valueToExp v)+exprToExp (EBlock l as es) =+ AppE (AppE (expr "EBlock" l) (ListE (map patternToExp as))) (ListE (map exprToExp es))+exprToExp (EVM _ _) = error "cannot exprToExp EVM"+exprToExp (EList l es) =+ AppE (expr "EList" l) (ListE (map exprToExp es))+exprToExp (ETop l) =+ expr "ETop" l+exprToExp (EParticle l p) =+ AppE (expr "EParticle" l) (eparticleToExp p)+exprToExp (EMacro l p e) =+ AppE (AppE (expr "EMacro" l) (patternToExp p)) (exprToExp e)+exprToExp (EQuote l e) =+ AppE (expr "EQuote" l) (exprToExp e)+exprToExp (EUnquote l e) =+ AppE (expr "EUnquote" l) (exprToExp e)++assocToExp :: Assoc -> Exp+assocToExp ALeft = ConE (mkName "ALeft")+assocToExp ARight = ConE (mkName "ARight")++messageToExp :: Message -> Exp+messageToExp (Keyword i ns vs) =+ AppE (AppE (AppE (ConE (mkName "Keyword")) (LitE (IntegerL (fromIntegral i)))) (ListE (map (LitE . StringL) ns))) (ListE (map valueToExp vs))+messageToExp (Single i n v) =+ AppE (AppE (AppE (ConE (mkName "Single")) (LitE (IntegerL (fromIntegral i)))) (LitE (StringL n))) (valueToExp v)++particleToExp :: Particle -> Exp+particleToExp (PMSingle n) =+ AppE (ConE (mkName "PMSingle")) (LitE (StringL n))+particleToExp (PMKeyword ns vs) =+ AppE (AppE (ConE (mkName "PMKeyword")) (ListE (map (LitE . StringL) ns))) (ListE (map maybeValue vs))+ where+ maybeValue Nothing = ConE (mkName "Nothing")+ maybeValue (Just v) = AppE (ConE (mkName "Just")) (valueToExp v)++emessageToExp :: EMessage -> Exp+emessageToExp (EKeyword i ns es) =+ AppE (AppE (AppE (ConE (mkName "EKeyword")) (LitE (IntegerL (fromIntegral i)))) (ListE (map (LitE . StringL) ns))) (ListE (map exprToExp es))+emessageToExp (ESingle i n e) =+ AppE (AppE (AppE (ConE (mkName "ESingle")) (LitE (IntegerL (fromIntegral i)))) (LitE (StringL n))) (exprToExp e)++eparticleToExp :: EParticle -> Exp+eparticleToExp (EPMSingle n) =+ AppE (ConE (mkName "EPMSingle")) (LitE (StringL n))+eparticleToExp (EPMKeyword ns es) =+ AppE (AppE (ConE (mkName "EPMKeyword")) (ListE (map (LitE . StringL) ns))) (ListE (map maybeExpr es))+ where+ maybeExpr Nothing = ConE (mkName "Nothing")+ maybeExpr (Just e) = AppE (ConE (mkName "Just")) (exprToExp e)++expr :: String -> Maybe SourcePos -> Exp+expr n _ = AppE (ConE (mkName n)) (ConE (mkName "Nothing"))++valueToExp :: Value -> Exp+valueToExp (Block s as es) =+ AppE (AppE (AppE (ConE (mkName "Block")) (valueToExp s)) (ListE (map patternToExp as))) (ListE (map exprToExp es))+valueToExp (Boolean b) = AppE (ConE (mkName "Boolean")) (ConE (mkName (show b)))+valueToExp (Char c) = AppE (ConE (mkName "Char")) (LitE (CharL c))+valueToExp (Double d) = AppE (ConE (mkName "Double")) (LitE (RationalL (toRational d)))+valueToExp (Expression e) = AppE (ConE (mkName "Expression")) (exprToExp e)+valueToExp (Integer i) = AppE (ConE (mkName "Integer")) (LitE (IntegerL i))+valueToExp (Message m) = AppE (ConE (mkName "Message")) (messageToExp m)+valueToExp (Particle p) = AppE (ConE (mkName "Particle")) (particleToExp p)+valueToExp (Pattern p) = AppE (ConE (mkName "Pattern")) (patternToExp p)+valueToExp (String s) = AppE (VarE (mkName "string")) (LitE (StringL (T.unpack s)))+valueToExp v = error $ "no valueToExp for: " ++ show v++patternToExp :: Pattern -> Exp+patternToExp PAny = ConE (mkName "PAny")+patternToExp (PHeadTail h t) = AppE (AppE (ConE (mkName "PHeadTail")) (patternToExp h)) (patternToExp t)+patternToExp (PKeyword i ns ts) =+ AppE (AppE (AppE (ConE (mkName "PKeyword")) (LitE (IntegerL (fromIntegral i)))) (ListE (map (LitE . StringL) ns))) (ListE (map patternToExp ts))+patternToExp (PList ps) =+ AppE (ConE (mkName "PList")) (ListE (map patternToExp ps))+patternToExp (PMatch v) =+ AppE (ConE (mkName "PMatch")) (valueToExp v)+patternToExp (PNamed n p) =+ AppE (AppE (ConE (mkName "PNamed")) (LitE (StringL n))) (patternToExp p)+patternToExp (PObject e) =+ AppE (ConE (mkName "PObject")) (exprToExp e)+patternToExp (PPMKeyword ns ts) =+ AppE (AppE (ConE (mkName "PPMKeyword")) (ListE (map (LitE . StringL) ns))) (ListE (map patternToExp ts))+patternToExp (PSingle i n t) =+ AppE (AppE (AppE (ConE (mkName "PSingle")) (LitE (IntegerL (fromIntegral i)))) (LitE (StringL n))) (patternToExp t)+patternToExp PThis = ConE (mkName "PThis")+patternToExp PEDefine = ConE (mkName "PEDefine")+patternToExp PESet = ConE (mkName "PESet")+patternToExp PEDispatch = ConE (mkName "PEDispatch")+patternToExp PEOperator = ConE (mkName "PEOperator")+patternToExp PEPrimitive = ConE (mkName "PEPrimitive")+patternToExp PEBlock = ConE (mkName "PEBlock")+patternToExp PEList = ConE (mkName "PEList")+patternToExp PEMacro = ConE (mkName "PEMacro")+patternToExp PEParticle = ConE (mkName "PEParticle")+patternToExp PETop = ConE (mkName "PETop")+patternToExp PEQuote = ConE (mkName "PEQuote")+patternToExp PEUnquote = ConE (mkName "PEUnquote")
+ src/Atomo/Run.hs view
@@ -0,0 +1,82 @@+module Atomo.Run where++import Control.Concurrent+import "monads-fd" Control.Monad.Error+import "monads-fd" Control.Monad.State++import Atomo.Core+import Atomo.Environment+import Atomo.Load+import Atomo.Spawn (go)+import Atomo.Types+import qualified Atomo.Kernel as Kernel++import Paths_atomo+++-----------------------------------------------------------------------------+-- Execution ----------------------------------------------------------------+-----------------------------------------------------------------------------++-- | execute an action in a new thread, initializing the environment and+-- printing a traceback on error+exec :: VM Value -> IO ()+exec x = execWith (initEnv >> x) startEnv++-- | execute an action in a new thread, printing a traceback on error+execWith :: VM Value -> Env -> IO ()+execWith x e = do+ haltChan <- newChan++ forkIO $ do+ r <- runWith (go x >> gets halt >>= liftIO >> return (particle "ok")) e+ { halt = writeChan haltChan ()+ }++ either+ (putStrLn . ("WARNING: exited abnormally with: " ++) . show)+ (\_ -> return ())+ r++ writeChan haltChan ()++ readChan haltChan++-- | execute x, initializing the environment with initEnv+run :: VM Value -> IO (Either AtomoError Value)+run x = runWith (initEnv >> x) startEnv++-- | set up the primitive objects, etc.+initEnv :: VM ()+{-# INLINE initEnv #-}+initEnv = initCore >> Kernel.load >> loadPrelude++loadPrelude :: VM ()+loadPrelude = do+ forM_ preludes $ \p ->+ liftIO (getDataFileName ("prelude/" ++ p))+ >>= loadFile++ here "Eco" >>= dispatch . single "load"++ return ()+ where+ preludes =+ [ "core"++ , "association"+ , "parameter"++ , "block"+ , "boolean"+ , "comparable"+ , "continuation"+ , "list"+ , "numeric"+ , "particle"+ , "ports"+ , "time"++ , "version"+ , "eco"+ ]
+ src/Atomo/Spawn.hs view
@@ -0,0 +1,24 @@+module Atomo.Spawn where++import Control.Concurrent+import "monads-fd" Control.Monad.State+import "monads-fd" Control.Monad.Error++import Atomo.PrettyVM+import Atomo.Types+++-- | spawn a process to execute x. returns the Process.+spawn :: VM Value -> VM Value+spawn x = do+ e <- get+ chan <- liftIO newChan+ tid <- liftIO . forkIO $ do+ runWith (go x >> return (particle "ok")) (e { channel = chan })+ return ()++ return (Process chan tid)++-- | execute x, printing an error if there is one+go :: VM Value -> VM Value+go x = catchError x (\e -> printError e >> return (particle "ok"))
src/Atomo/Types.hs view
@@ -1,12 +1,11 @@-{-# LANGUAGE BangPatterns, TypeSynonymInstances #-}+{-# LANGUAGE BangPatterns, DeriveDataTypeable, TypeSynonymInstances #-} module Atomo.Types where import Control.Concurrent (ThreadId) import Control.Concurrent.Chan-import Control.Monad.Trans-import Control.Monad.Cont-import Control.Monad.Error-import Control.Monad.State+import "monads-fd" Control.Monad.Cont+import "monads-fd" Control.Monad.Error+import "monads-fd" Control.Monad.State import Data.Dynamic import Data.Hashable (hash) import Data.IORef@@ -21,30 +20,32 @@ data Value = Block !Value [Pattern] [Expr]- | Char {-# UNPACK #-} !Char- | Continuation Continuation- | Double {-# UNPACK #-} !Double- | Expression Expr+ | Boolean { fromBoolean :: {-# UNPACK #-} !Bool }+ | Char { fromChar :: {-# UNPACK #-} !Char }+ | Continuation { fromContinuation :: Continuation }+ | Double { fromDouble :: {-# UNPACK #-} !Double }+ | Expression { fromExpression :: Expr } | Haskell Dynamic- | Integer !Integer+ | Integer { fromInteger :: !Integer } | List VVector- | Message Message- | Method Method- | Particle Particle+ | Message { fromMessage :: Message }+ | Method { fromMethod :: Method }+ | Particle { fromParticle :: Particle } | Process Channel ThreadId- | Pattern Pattern+ | Pattern { fromPattern :: Pattern }+ | Rational Rational | Reference { rORef :: {-# UNPACK #-} !ORef }- | String !T.Text- deriving Show+ | String { fromString :: !T.Text }+ deriving (Show, Typeable) data Object = Object { oDelegates :: !Delegates , oMethods :: !(MethodMap, MethodMap) -- singles, keywords }- deriving Show+ deriving (Show, Typeable) data Method = Responder@@ -52,11 +53,15 @@ , mContext :: !Value , mExpr :: !Expr }+ | Macro+ { mPattern :: !Pattern+ , mExpr :: !Expr+ } | Slot { mPattern :: !Pattern , mValue :: !Value }- deriving (Eq, Show)+ deriving (Eq, Show, Typeable) data Message = Keyword@@ -69,12 +74,12 @@ , mName :: String , mTarget :: Value }- deriving (Eq, Show)+ deriving (Eq, Show, Typeable) data Particle = PMSingle String | PMKeyword [String] [Maybe Value]- deriving (Eq, Show)+ deriving (Eq, Show, Typeable) data AtomoError = Error Value@@ -88,7 +93,7 @@ | NoExpressions | ValueNotFound String Value | DynamicNeeded String- deriving Show+ deriving (Show, Typeable) -- pattern-matches data Pattern@@ -110,8 +115,22 @@ , ppTarget :: Pattern } | PThis- deriving Show + -- expression types, used in macros+ | PEDefine+ | PESet+ | PEDispatch+ | PEOperator+ | PEPrimitive+ | PEBlock+ | PEList+ | PEMacro+ | PEParticle+ | PETop+ | PEQuote+ | PEUnquote+ deriving (Show, Typeable)+ -- expressions data Expr = Define@@ -143,13 +162,15 @@ , eArguments :: [Pattern] , eContents :: [Expr] }- | EDispatchObject- { eLocation :: Maybe SourcePos- } | EList { eLocation :: Maybe SourcePos , eContents :: [Expr] }+ | EMacro+ { eLocation :: Maybe SourcePos+ , ePattern :: Pattern+ , eExpr :: Expr+ } | EParticle { eLocation :: Maybe SourcePos , eParticle :: EParticle@@ -161,7 +182,15 @@ { eLocation :: Maybe SourcePos , eAction :: VM Value }- deriving Show+ | EQuote+ { eLocation :: Maybe SourcePos+ , eExpr :: Expr+ }+ | EUnquote+ { eLocation :: Maybe SourcePos+ , eExpr :: Expr+ }+ deriving (Show, Typeable) data EMessage = EKeyword@@ -174,12 +203,12 @@ , emName :: String , emTarget :: Expr }- deriving (Eq, Show)+ deriving (Eq, Show, Typeable) data EParticle = EPMSingle String | EPMKeyword [String] [Maybe Expr]- deriving (Eq, Show)+ deriving (Eq, Show, Typeable) -- the evaluation environment data Env =@@ -191,21 +220,13 @@ , loadPath :: [FilePath] , loaded :: [FilePath] , stack :: [Expr]- , call :: Call- , parserState :: Operators+ , parserState :: ParserState }+ deriving Typeable -- operator associativity data Assoc = ALeft | ARight- deriving (Eq, Show)---- meta information for the dispatch-data Call =- Call- { callSender :: Value- , callMessage :: Message- , callContext :: Value- }+ deriving (Eq, Show, Typeable) -- a giant record of the objects for each primitive value data IDs =@@ -213,6 +234,7 @@ { idMatch :: ORef -- used in dispatch to refer to the object currently being searched , idObject :: ORef -- root object , idBlock :: ORef+ , idBoolean :: ORef , idChar :: ORef , idContinuation :: ORef , idDouble :: ORef@@ -225,17 +247,29 @@ , idParticle :: ORef , idProcess :: ORef , idPattern :: ORef+ , idRational :: ORef , idString :: ORef }+ deriving (Show, Typeable) +data ParserState =+ ParserState+ { psOperators :: Operators+ , psMacros :: (MethodMap, MethodMap)+ }+ deriving (Show, Typeable)++startParserState :: ParserState+startParserState = ParserState [] (M.empty, M.empty)+ -- helper synonyms type Operators = [(String, (Assoc, Integer))] -- name -> assoc, precedence type Delegates = [Value] type Channel = Chan Value type MethodMap = M.IntMap [Method] type ORef = IORef Object-type VVector = IORef (V.Vector Value)+type VVector = V.Vector Value type Continuation = IORef (Value -> VM Value) @@ -243,6 +277,7 @@ instance Eq Value where (==) (Block at aps aes) (Block bt bps bes) = at == bt && aps == bps && aes == bes+ (==) (Boolean a) (Boolean b) = a == b (==) (Char a) (Char b) = a == b (==) (Continuation a) (Continuation b) = a == b (==) (Double a) (Double b) = a == b@@ -254,6 +289,7 @@ (==) (Method a) (Method b) = a == b (==) (Particle a) (Particle b) = a == b (==) (Process _ a) (Process _ b) = a == b+ (==) (Rational a) (Rational b) = a == b (==) (Reference a) (Reference b) = a == b (==) (String a) (String b) = a == b (==) _ _ = False@@ -282,17 +318,16 @@ instance Eq Expr where- (==) (Define _ ap ae) (Define _ bp be) = ap == bp && ae == be- (==) (Set _ ap ae) (Set _ bp be) = ap == bp && ae == be+ (==) (Define _ ap' ae) (Define _ bp be) = ap' == bp && ae == be+ (==) (Set _ ap' ae) (Set _ bp be) = ap' == bp && ae == be (==) (Dispatch _ am) (Dispatch _ bm) = am == bm- (==) (Operator _ ans aa ap) (Operator _ bns ba bp) =- ans == bns && aa == ba && ap == bp+ (==) (Operator _ ans aa ap') (Operator _ bns ba bp) =+ ans == bns && aa == ba && ap' == bp (==) (Primitive _ a) (Primitive _ b) = a == b (==) (EBlock _ aas aes) (EBlock _ bas bes) = aas == bas && aes == bes- (==) (EDispatchObject _) (EDispatchObject _) = True (==) (EList _ aes) (EList _ bes) = aes == bes- (==) (EParticle _ ap) (EParticle _ bp) = ap == bp+ (==) (EParticle _ ap') (EParticle _ bp) = ap' == bp (==) (ETop _) (ETop _) = True (==) (EVM _ _) (EVM _ _) = False (==) _ _ = False@@ -308,9 +343,6 @@ instance Show ORef where show _ = "ORef" -instance Show VVector where- show _ = "VVector"- instance Show Continuation where show _ = "Continuation" @@ -329,6 +361,7 @@ { idMatch = error "idMatch not set" , idObject = error "idObject not set" , idBlock = error "idBlock not set"+ , idBoolean = error "idBoolean not set" , idChar = error "idChar not set" , idContinuation = error "idContinuation not set" , idDouble = error "idDouble not set"@@ -341,6 +374,7 @@ , idParticle = error "idParticle not set" , idProcess = error "idProcess not set" , idPattern = error "idPattern not set"+ , idRational = error "idRational not set" , idString = error "idString not set" } , channel = error "channel not set"@@ -348,11 +382,18 @@ , loadPath = [] , loaded = [] , stack = []- , call = error "call not set"- , parserState = []+ , parserState = startParserState } +-- | evaluate x with e as the environment+runWith :: VM Value -> Env -> IO (Either AtomoError Value)+runWith x e = evalStateT (runContT (runErrorT x) return) e +-- | evaluate x with e as the environment+runVM :: VM Value -> Env -> IO (Either AtomoError Value, Env)+runVM x e = runStateT (runContT (runErrorT x) return) e++ ----------------------------------------------------------------------------- -- Helpers ------------------------------------------------------------------ -----------------------------------------------------------------------------@@ -399,19 +440,15 @@ Nothing -> error ("needed Haskell value of type " ++ t) fromHaskell' t _ = error ("needed haskell value of type " ++ t) -list :: MonadIO m => [Value] -> m Value-list = list' . V.fromList--list' :: MonadIO m => V.Vector Value -> m Value-list' = liftM List . liftIO . newIORef+list :: [Value] -> Value+list = List . V.fromList -fromString :: Value -> String-fromString (String s) = T.unpack s-fromString v = error $ "no fromString for: " ++ show v+fromText :: T.Text -> String+fromText = T.unpack -toList :: MonadIO m => Value -> m [Value]-toList (List vr) = liftM V.toList (liftIO (readIORef vr))-toList v = error $ "no toList for: " ++ show v+fromList :: Value -> [Value]+fromList (List vr) = V.toList vr+fromList v = error $ "no fromList for: " ++ show v single :: String -> Value -> Message {-# INLINE single #-}@@ -450,6 +487,11 @@ isBlock (Block _ _ _) = True isBlock _ = False +-- | Is a value a Boolean?+isBoolean :: Value -> Bool+isBoolean (Boolean _) = True+isBoolean _ = False+ -- | Is a value a Char? isChar :: Value -> Bool isChar (Char _) = True@@ -509,6 +551,11 @@ isProcess :: Value -> Bool isProcess (Process _ _) = True isProcess _ = False++-- | Is a value a Rational?+isRational :: Value -> Bool+isRational (Rational _) = True+isRational _ = False -- | Is a value a Reference? isReference :: Value -> Bool
+ src/Atomo/VMT.hs view
@@ -0,0 +1,51 @@+module Atomo.VMT where++import "monads-fd" Control.Monad.Cont+import "monads-fd" Control.Monad.Error+import "monads-fd" Control.Monad.State+import "monads-fd" Control.Monad.Trans++import Atomo.Types++newtype VMT m a =+ VMT+ { runVMT :: Env -> m (Either AtomoError a, Env)+ }++instance Monad m => Monad (VMT m) where+ x >>= f = VMT $ \e -> do+ (ev, e') <- runVMT x e+ case ev of+ Right v -> runVMT (f v) e'+ Left err -> return (Left err, e')++ return x = VMT $ \e -> return (Right x, e)++instance MonadTrans VMT where+ lift m = VMT $ \e -> do+ a <- m+ return (Right a, e)++instance MonadIO m => MonadIO (VMT m) where+ liftIO f = VMT $ \e -> do+ x <- liftIO f+ return (Right x, e)++instance MonadCont m => MonadCont (VMT m) where+ callCC f = VMT $ \e ->+ callCC $ \c -> runVMT (f (\a -> VMT (\e' -> c (Right a, e')))) e++vm :: MonadIO m => VM Value -> VMT m Value+vm x = VMT (liftIO . runStateT (runContT (runErrorT x) return))++vm_ :: MonadIO m => VM a -> VMT m ()+vm_ x = vm (x >> return (particle "ok")) >> return ()++getEnv :: Monad m => VMT m Env+getEnv = VMT $ \e -> return (Right e, e)++putEnv :: Monad m => Env -> VMT m ()+putEnv e = VMT $ \_ -> return (Right (), e)++execVM :: Monad m => (VMT m a) -> Env -> (AtomoError -> m a) -> m a+execVM x e h = runVMT x e >>= either h return . fst
src/Atomo/Valuable.hs view
@@ -1,6 +1,6 @@ module Atomo.Valuable where -import Control.Monad.Trans (liftIO)+import "monads-fd" Control.Monad.Trans (liftIO) import Data.IORef import qualified Data.Text as T import qualified Data.Vector as V@@ -37,12 +37,12 @@ fromValue (Integer i) = return (fromIntegral i) instance Valuable a => Valuable [a] where- toValue xs = mapM toValue xs >>= list- fromValue (List v) = liftIO (readIORef v) >>= mapM fromValue . V.toList+ toValue xs = mapM toValue xs >>= return . list+ fromValue (List v) = mapM fromValue (V.toList v) instance Valuable a => Valuable (V.Vector a) where- toValue xs = V.mapM toValue xs >>= list'- fromValue (List v) = liftIO (readIORef v) >>= V.mapM fromValue+ toValue xs = V.mapM toValue xs >>= return . List+ fromValue (List v) = V.mapM fromValue v instance Valuable T.Text where toValue = return . String
src/Main.hs view
@@ -1,7 +1,7 @@ module Main where -import Control.Monad.Cont-import Control.Monad.Error+import "monads-fd" Control.Monad.Cont+import "monads-fd" Control.Monad.Error import Data.Char (isSpace) import Prelude hiding (catch) import System.Console.Haskeline@@ -10,7 +10,10 @@ import System.FilePath import Atomo.Environment+import Atomo.Load import Atomo.Parser+import Atomo.PrettyVM+import Atomo.Run import Atomo.Types @@ -78,23 +81,21 @@ Nothing -> askQuit (repl' input r) where- evaluate expr =- continuedParse (input ++ expr) "<input>"- >>= evalAll+ evaluate expr = parseInput (input ++ expr) >>= evalAll prompt | quiet = "" | null input = "> " | otherwise = ". " - askQuit continue = do+ askQuit c = do r <- liftIO . runInputT defaultSettings $ getInputChar "really quit? (y/n) " case r of Just 'y' -> return (particle "ok")- Just 'n' -> continue- _ -> askQuit continue+ Just 'n' -> c+ _ -> askQuit c bracesBalanced s = hangingBraces s == 0 where