packages feed

atomo 0.2.1 → 0.2.2

raw patch · 43 files changed

+1352/−1586 lines, 43 filesdep −split

Dependencies removed: split

Files

atomo.cabal view
@@ -1,5 +1,5 @@ name:                atomo-version:             0.2.1+version:             0.2.2 synopsis:            A highly dynamic, extremely simple, very fun programming                      language. description:@@ -13,9 +13,9 @@     Neat stuff: first-class continuations, very metaprogramming and DSL     -friendly, message-passing concurrency, pattern-matching.     .-    Documentation (WIP): <http://atomo-lang.org/docs/>+    Documentation: <http://atomo-lang.org/docs/>     .-    Examples: <http://darcsden.com/alex/atomo/browse/examples>+    Examples: <http://bitbucket.org/alex/atomo/src/tip/examples/>     .     IRC Channel: <irc://irc.freenode.net/atomo> homepage:            http://atomo-lang.org/@@ -34,13 +34,8 @@ data-files:         prelude/*.atomo  source-repository   head-    type:           darcs-    location:       http://darcsden.com/alex/atomo--source-repository   this-    type:           darcs-    location:       http://darcsden.com/alex/atomo-    tag:            0.1.1+    type:           hg+    location:       http://bitbucket.org/alex/atomo  library   hs-source-dirs:    src@@ -56,7 +51,6 @@     mtl,     parsec >= 3.0.0,     pretty,-    split,     template-haskell,     text,     time,@@ -68,12 +62,13 @@     Atomo,     Atomo.Core,     Atomo.Environment,+    Atomo.Helpers,     Atomo.Load,     Atomo.Method,     Atomo.Parser,     Atomo.Parser.Base,-    Atomo.Parser.Pattern,     Atomo.Parser.Primitive,+    Atomo.Pattern,     Atomo.Pretty,     Atomo.PrettyVM,     Atomo.QuasiQuotes,@@ -127,7 +122,6 @@     mtl,     parsec >= 3.0.0,     pretty,-    split,     template-haskell,     text,     time,
prelude/association.atomo view
@@ -6,13 +6,13 @@ (a: Association) show :=     a from show .. " -> " .. a to show -[] lookup: _ = @none+[] lookup: _ := @none (a . as) lookup: k :=   if: (k == a from)     then: { @(ok: a to) }     else: { as lookup: k } -[] find: _ = @none+[] find: _ := @none (a . as) find: k :=   if: (k == a from)     then: { @(ok: a) }
prelude/block.atomo view
@@ -11,7 +11,7 @@  (b: Block) in-context :=   b clone do:-    { call := b context join: b+    { call := b call-in: b context       call: vs := b context join: b with: vs     }
prelude/boolean.atomo view
@@ -1,13 +1,13 @@ @no-true-branches describe-error := "no tests in condition: block were true" -False and: _ = False+False and: _ := False True and: (b: Block) := b call -True or: _ = True+True or: _ := True False or: (b: Block) := b call -macro a && b := `(~a and: { ~b })-macro a || b := `(~a or: { ~b })+macro (a && b) `(~a and: { ~b })+macro (a || b) `(~a or: { ~b })  True not := False False not := True@@ -24,7 +24,7 @@     @ok   } call -macro e unless: b := `(unless: ~b do: { ~e })+macro (e unless: b) `(unless: ~b do: { ~e })  when: False do: Block = @ok when: True do: (action: Block) :=@@ -32,7 +32,7 @@     @ok   } call -macro e when: b := `(when: ~b do: { ~e })+macro (e when: b) `(when: ~b do: { ~e })  while: (test: Block) do: (action: Block) :=   when: test call do:@@ -45,7 +45,7 @@  otherwise := True -macro condition: (bs: Block) :=+macro (condition: (bs: Block))   bs contents reduce-right:     { `(~test -> ~branch) x |       `(if: ~test then: { ~branch } else: { ~x })
prelude/condition.atomo view
@@ -1,3 +1,5 @@+for-macro Restart = Object clone+ { define: *handlers* as: []   define: *restarts* as: [] @@ -24,9 +26,6 @@     Simple-Warning = Warning clone   } -  for-macro Handler = Object clone do: { handle: _ := @ok }-  for-macro Restart = Object clone-   (e: Simple-Error) describe-error := e value describe-error   (w: Simple-Warning) describe-error := w value describe-error @@ -73,7 +72,7 @@    (r: Restart) show := "<restart " .. r action show .. ">" -  macro action with-restarts: (restarts: Block) :=+  macro (action with-restarts: (restarts: Block))     { rs = restarts contents map:         { `(~n -> ~e) |           e type match: {@@ -95,7 +94,7 @@     modify: *restarts* as: { rs | restarts .. rs } do: action    (super) signal: v :=-    { *handlers* _? map: @(handle: v)+    { *handlers* _? map: { h | h (call: [v]) (call: [v]) }       @ok     } call @@ -135,43 +134,21 @@   (super) find-restart: name :=     *restarts* _? lookup: name -  (super) with-handler: (h: Handler) do: (action: Block) :=+  (super) with-handler: (h: Block) do: (action: Block) :=     modify: *handlers* as: { hs | h . hs } do: action -  macro a bind: (bs: Block) :=-    { h = Handler clone--      (h) in: c :=-        { h context = c-          h-        } call--      -- yield a hygienic expr to define on the handler-      expr-for: e :=-        condition: {-          e type == @block && e arguments empty? not ->-            ``(~'~e call: [~s]) -- wow--          e type == @block ->-            `'(~e call)--          otherwise -> `'~e+  macro (a bind: (bs: Block))+    { branches = bs contents map:+        { `(~p -> ~e) |+          if: (e type == @block)+            then: { `(~p -> ~e) }+            else: { `(~p -> { ~e }) }         } -      signals = bs contents map:-        { `(~pat -> ~expr) |-          Lobby-            define: @handle:-              on: `(h: ~h) (as: Pattern)-              with: [`(s: ~pat) as: Pattern]-              as: `(-                { match: ~(pat as: Pattern) on: s-                  (with-delegates: [h context])-                    evaluate: ~(expr-for: expr)-                } call-              )-        }+      handler = `Block new: (branches .. ['(_ -> { @ok })]) -      `(with-handler: (~h in: this) do: ~a)+      `({ h a |+          with-handler: h do: a+        } call: [{ #c | #c match: ~handler }, ~a])     } call } call
prelude/core.atomo view
@@ -1,3 +1,14 @@+macro (x match: (ts: Block))+  `Match new: (ts contents map: { `(~p -> ~e) | p -> e expand }) on: x++operator right 0 = :=++macro (p = e)+  `Set new: p to: e++macro (p := e)+  `Define new: p as: e+ @(parse-error: d) describe-error :=   "parse error:\n" .. (d indent: 2) @@ -35,7 +46,3 @@  @(dynamic-needed: t) describe-error :=   "expecting Haskell value of type " .. t---macro x match: (ts: Block) :=-  `Match new: (ts contents map: { `(~p -> ~e) | p -> e }) on: x
prelude/eco.atomo view
@@ -202,10 +202,10 @@ context use: (name: String) version: (v: Version) :=   context use: name version: (evaluate: `({ == ~v })) -macro context use: name version: (v: Primitive) :=+macro (context use: name version: (v: Primitive))   `(~context use: ~name version: { == ~v }) -macro context use: name version: (v: `(~_ . ~_)) :=+macro (context use: name version: (v: `(~_ . ~_)))   `(~context use: ~name version: { == ~v })  context use: (name: String) version: (check: Block) :=
prelude/exception.atomo view
@@ -1,4 +1,4 @@-macro action handle: (branches: Block) :=+macro (action handle: (branches: Block))   { handlers = branches contents map:       { `(~c -> ~e) | `(~c -> escape-handle yield: ~e)       }@@ -6,7 +6,7 @@     `({ escape-handle | ~action bind: ~(`Block new: handlers) } call/cc)   } call -macro a handle: (b: Block) ensuring: (c: Block) :=+macro (a handle: (b: Block) ensuring: (c: Block))   `({ ~a handle: ~b } ensuring: ~c)  (action: Block) catch: (recover: Block) :=@@ -16,7 +16,7 @@     }   } call/cc -macro a catch: (b: Block) ensuring: (c: Block) :=+macro (a catch: (b: Block) ensuring: (c: Block))   `({ ~a catch: ~b } ensuring: ~c)  (action: Block) ensuring: (cleanup: Block) :=
prelude/list.atomo view
@@ -1,5 +1,8 @@ @empty-list describe-error := "list is empty" +(l: -> List) show :=+  "[" .. l (map: @show) (join: ", ") .. "]"+ (l: List) each: (b: Block) :=   { l map: b in-context     l
prelude/numeric.atomo view
@@ -1,5 +1,5 @@-macro x += y := `(match: ~(x as: Pattern) on: (~x + ~y))-macro x -= y := `(match: ~(x as: Pattern) on: (~x - ~y))+macro (x += y) `(~x = ~x + ~y)+macro (x -= y) `(~x = ~x - ~y)  - (n: Number) := -1 * n
prelude/parameter.atomo view
@@ -7,19 +7,19 @@  (p: Parameter) value: _ := p default -macro define: (x: Dispatch) as: root :=-  `(match: ~(x as: Pattern) on: (Parameter new: ~root))+macro (define: (x: Dispatch) as: root)+  `(~x = Parameter new: ~root)  (p: Parameter) show :=   "<" .. p _? show .. ">"  (p: Parameter) _? := p value: self -(p: Parameter) =! v :=-  (p) value: (self) = v+((p: Parameter) =! v) :=+  p value: self = v  (p: Parameter) set-default: v :=-  (p) default = v+  p default = v  with: (p: Parameter) as: new do: (action: Block) :=   { old = p _?@@ -35,7 +35,7 @@     }   } call -macro with: (bs: List) do: action :=+macro (with: (bs: List) do: action)   bs contents     (reduce-right:       { `(~a -> ~b) x |@@ -43,7 +43,7 @@       } with: action)     contents head -macro with-defaults: (bs: List) do: action :=+macro (with-defaults: (bs: List) do: action)   bs contents     (reduce-right:       { `(~a -> ~b) x |@@ -51,5 +51,5 @@       } with: action)     contents head -macro modify: param as: change do: action :=+macro (modify: param as: change do: action)   `(with: ~param as: (~change call: [~param _?]) do: ~action)
prelude/particle.atomo view
@@ -1,4 +1,4 @@-(p: Particle) show :=+(p: -> Particle) show :=   p type match: {     @keyword ->       { operator?: str := str all?: @(in?: "~!@#$%^&*-_=+./\\|<>?:")
prelude/repl.atomo view
@@ -17,7 +17,7 @@       es -> evaluate-all: es in: t     } -  get-n-values: 0 = []+  get-n-values: 0 := []   get-n-values: n :=     (get-value: Lobby) . (get-n-values: (n - 1))
src/Atomo.hs view
@@ -1,5 +1,6 @@ module Atomo     ( module Atomo.Environment+    , module Atomo.Helpers     , module Atomo.QuasiQuotes     , module Atomo.Types @@ -17,5 +18,6 @@ import "monads-fd" Control.Monad.Trans  import Atomo.Environment+import Atomo.Helpers import Atomo.QuasiQuotes import Atomo.Types
src/Atomo/Core.hs view
@@ -7,6 +7,7 @@ import Atomo.Environment  +-- | Defines all primitive objects, including the Lobby. initCore :: VM () initCore = do     -- the very root object
src/Atomo/Environment.hs view
@@ -3,20 +3,15 @@  import "monads-fd" Control.Monad.Cont import "monads-fd" Control.Monad.State-import Data.Char (isUpper)-import Data.Dynamic import Data.IORef import Data.List (nub)-import Data.Maybe (isJust)-import System.IO.Unsafe-import qualified Data.Text as T-import qualified Data.Vector as V  import Atomo.Method+import Atomo.Pattern import Atomo.Types  --- | evaluation+-- | Evaluate an expression, yielding a value. eval :: Expr -> VM Value eval (Define { ePattern = p, eExpr = ev }) = do     define p ev@@ -85,6 +80,7 @@         }      return (particle "ok")+eval (EForMacro {}) = return (particle "ok") eval (EParticle { eParticle = EPMSingle n }) =     return (Particle $ PMSingle n) eval (EParticle { eParticle = EPMKeyword ns mes }) = do@@ -152,14 +148,15 @@     unquote _ t@(ETop {}) = return t     unquote _ v@(EVM {}) = return v     unquote _ o@(Operator {}) = return o+    unquote _ f@(EForMacro {}) = return f --- | evaluating multiple expressions, returning the last result+-- | Evaluate multiple expressions, returning the last result. evalAll :: [Expr] -> VM Value evalAll [] = throwError NoExpressions evalAll [e] = eval e evalAll (e:es) = eval e >> evalAll es --- | object creation+-- | Create a new empty object, passing a function to initialize it. newObject :: (Object -> Object) -> VM Value newObject f = liftM Reference . liftIO $     newIORef . f $ Object@@ -167,8 +164,8 @@         , oMethods = noMethods         } --- | run x with t as its toplevel object-withTop :: Value -> VM Value -> VM Value+-- | Run x with t as its toplevel object.+withTop :: Value -> VM a -> VM a withTop t x = do     o <- gets top     modify (\e -> e { top = t })@@ -179,11 +176,22 @@      return res +-- | Execute an action with a new toplevel delegating to the old one.+newScope :: VM a -> VM a+newScope x = do+    t <- gets top+    nt <- newObject $ \o -> o+        { oDelegates = [t]+        } +    withTop nt x++ ----------------------------------------------------------------------------- -- Define ------------------------------------------------------------------- ----------------------------------------------------------------------------- +-- | Insert a method on a single value. defineOn :: Value -> Method -> VM () defineOn v m' = do     o <- orefFor v@@ -199,7 +207,7 @@   where     m = m' { mPattern = setSelf v (mPattern m') } --- | define a pattern to evaluate an expression+-- | Define a method on all roles involved in its pattern. define :: Pattern -> Expr -> VM () define !p !e = do     is <- gets primitives@@ -224,7 +232,7 @@     method p' e' = gets top >>= \t -> return (Responder p' t e')  --- | Swap out a reference match with PThis, for inserting on the object+-- | Swap out a reference match with PThis, for inserting on an object. setSelf :: Value -> Pattern -> Pattern setSelf v (PKeyword i ns ps) =     PKeyword i ns (map (setSelf v) ps)@@ -233,13 +241,16 @@     PNamed n (setSelf v p') setSelf v (PSingle i n t) =     PSingle i n (setSelf v t)+setSelf v (PInstance p) = PInstance (setSelf v p)+setSelf v (PStrict p) = PStrict (setSelf v p) setSelf _ p' = p'  +-- | Pattern-match a value, inserting bindings into the current toplevel. set :: Pattern -> Value -> VM Value set p v = do     is <- gets primitives-    if match is p v+    if match is Nothing p v         then do             forM_ (bindings' p v) $ \(p', v') ->                 define p' (Primitive Nothing v')@@ -248,7 +259,7 @@         else throwError (Mismatch p v)  --- | turn any PObject patterns into PMatches+-- | Turn any PObject patterns into PMatches. matchable :: Pattern -> VM Pattern matchable p'@(PSingle { ppTarget = t }) = do     t' <- matchable t@@ -258,11 +269,13 @@     return p' { ppTargets = ts' } matchable PThis = liftM PMatch (gets top) matchable (PObject oe) = liftM PMatch (eval oe)+matchable (PInstance p) = liftM PInstance (matchable p)+matchable (PStrict p) = liftM PStrict (matchable p) matchable (PNamed n p') = liftM (PNamed n) (matchable p') matchable p' = return p'  --- | find the target objects for a pattern+-- | Find the target objects for a pattern. targets :: IDs -> Pattern -> VM [ORef] targets _ (PMatch v) = liftM (: []) (orefFor v) targets is (PSingle _ _ p) = targets is p@@ -280,6 +293,8 @@         else return [idList is] targets is (PPMKeyword {}) = return [idParticle is] targets is (PExpr _) = return [idExpression is]+targets is (PInstance p) = targets is p+targets is (PStrict p) = targets is p targets _ p = error $ "no targets for " ++ show p  @@ -288,7 +303,11 @@ -- Dispatch ----------------------------------------------------------------- ----------------------------------------------------------------------------- --- | dispatch a message and return a value+-- | Dispatch a message to all roles and return a value.+--+-- If the message is not understood, @\@did-not-understand:(at:)@ is sent to all+-- roles until one responds to it. If none of them handle it, a+-- @\@did-not-understand:@ error is raised. dispatch :: Message -> VM Value dispatch !m = do     find <- findFirstMethod m (vs m)@@ -324,18 +343,18 @@         [v, Message m]  --- | find a method on object `o' that responds to `m', searching its--- delegates if necessary+-- | Find a method on object `o' that responds to `m', searching its+-- delegates if necessary. findMethod :: Value -> Message -> VM (Maybe Method) findMethod v m = do     is <- gets primitives     r <- orefFor v     o <- liftIO (readIORef r)-    case relevant (is { idMatch = r }) o m of+    case relevant is r o m of         Nothing -> findFirstMethod m (oDelegates o)         mt -> return mt --- | find the first value that has a method defiend for `m'+-- | Find the first value that has a method defiend for `m'. findFirstMethod :: Message -> [Value] -> VM (Maybe Method) findFirstMethod _ [] = return Nothing findFirstMethod m (v:vs) = do@@ -344,126 +363,28 @@         Nothing -> findFirstMethod m vs         _ -> return r --- | find a relevant method for message `m' on object `o'-relevant :: IDs -> Object -> Message -> Maybe Method-relevant ids o m =-    lookupMap (mID m) (methods m) >>= firstMatch ids m+-- | Find a relevant method for message `m' on object `o'.+relevant :: IDs -> ORef -> Object -> Message -> Maybe Method+relevant ids r o m =+    lookupMap (mID m) (methods m) >>= firstMatch ids (Just r) m   where     methods (Single {}) = fst (oMethods o)     methods (Keyword {}) = snd (oMethods o) -    firstMatch _ _ [] = Nothing-    firstMatch ids' m' (mt:mts)-        | match ids' (mPattern mt) (Message m') = Just mt-        | otherwise = firstMatch ids' m' mts---- | check if a value matches a given pattern--- note that this is much faster when pure, so it uses unsafePerformIO--- to check things like delegation matches.-match :: IDs -> Pattern -> Value -> Bool-{-# NOINLINE match #-}-match ids PThis (Reference y) =-    refMatch ids (idMatch ids) y-match ids PThis y =-    match ids (PMatch (Reference (idMatch ids))) (Reference (orefFrom ids y))-match _ (PMatch x) y | x == y = True-match ids (PMatch x) (Reference y) =-    delegatesMatch ids (PMatch x) y-match ids (PMatch (Reference x)) y =-    match ids (PMatch (Reference x)) (Reference (orefFrom ids y))-match ids-    (PSingle { ppTarget = p })-    (Message (Single { mTarget = t })) =-    match ids p t-match ids-    (PKeyword { ppTargets = ps })-    (Message (Keyword { mTargets = ts })) =-    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 (V.toList v)-match ids (PHeadTail hp tp) (List vs) =-    V.length vs > 0 && match ids hp h && match ids tp t-  where-    h = V.head 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 _ (PExpr a) (Expression b) = matchExpr 0 a b-match ids p (Reference y) = delegatesMatch ids p y-match _ _ _ = False--refMatch :: IDs -> ORef -> ORef -> Bool-refMatch ids x y = x == y || delegatesMatch ids (PMatch (Reference x)) y--delegatesMatch :: IDs -> Pattern -> ORef -> Bool-delegatesMatch ids p x =-    any (match ids p) (oDelegates (unsafePerformIO (readIORef x)))---- | match multiple patterns with multiple values-matchAll :: IDs -> [Pattern] -> [Value] -> Bool-matchAll _ [] [] = True-matchAll ids (p:ps) (v:vs) = match ids p v && matchAll ids ps vs-matchAll _ _ _ = False--matchEParticle :: Int -> [Maybe Expr] -> [Maybe Expr] -> Bool-matchEParticle _ [] [] = True-matchEParticle n (Just a:as) (Just b:bs) =-    matchExpr n a b && matchEParticle n as bs-matchEParticle n (Nothing:as) (Nothing:bs) = matchEParticle n as bs-matchEParticle _ _ _ = False--matchExpr :: Int -> Expr -> Expr -> Bool-matchExpr 0 (EUnquote {}) _ = True-matchExpr n (EUnquote { eExpr = a }) (EUnquote { eExpr = b }) =-    matchExpr (n - 1) a b-matchExpr n (Define { ePattern = ap', eExpr = a }) (Define { ePattern = bp, eExpr = b }) =-    ap' == bp && matchExpr n a b-matchExpr n (Set { ePattern = ap', eExpr = a }) (Set { ePattern = bp, eExpr = b }) =-    ap' == bp && matchExpr n a b-matchExpr n (Dispatch { eMessage = am@(EKeyword {}) }) (Dispatch { eMessage = bm@(EKeyword {}) }) =-    emID am == emID bm && length (emTargets am) == length (emTargets bm) && and (zipWith (matchExpr n) (emTargets am) (emTargets bm))-matchExpr n (Dispatch { eMessage = am@(ESingle {}) }) (Dispatch { eMessage = bm@(ESingle {}) }) =-    emID am == emID bm && matchExpr n (emTarget am) (emTarget bm)-matchExpr n (EBlock { eArguments = aps, eContents = as }) (EBlock { eArguments = bps, eContents = bs }) =-    aps == bps && length as == length bs && and (zipWith (matchExpr n) as bs)-matchExpr n (EList { eContents = as }) (EList { eContents = bs }) =-    length as == length bs && and (zipWith (matchExpr n) as bs)-matchExpr n (EMacro { ePattern = ap', eExpr = a }) (EMacro { ePattern = bp, eExpr = b }) =-    ap' == bp && matchExpr n a b-matchExpr n (EParticle { eParticle = ap' }) (EParticle { eParticle = bp }) =-    case (ap', bp) of-        (EPMKeyword ans ames, EPMKeyword bns bmes) ->-            ans == bns && matchEParticle n ames bmes-        _ -> ap' == bp-matchExpr n (EQuote { eExpr = a }) (EQuote { eExpr = b }) =-    matchExpr (n + 1) a b-matchExpr _ a b = a == b--matchParticle :: IDs -> [Pattern] -> [Maybe Value] -> Bool-matchParticle _ [] [] = True-matchParticle ids (PAny:ps) (Nothing:mvs) = matchParticle ids ps mvs-matchParticle ids (PNamed _ p:ps) mvs = matchParticle ids (p:ps) mvs-matchParticle ids (p:ps) (Just v:mvs) =-    match ids p v && matchParticle ids ps mvs-matchParticle _ _ _ = False+    firstMatch _ _ _ [] = Nothing+    firstMatch ids' r' m' (mt:mts)+        | match ids' r' (mPattern mt) (Message m') = Just mt+        | otherwise = firstMatch ids' r' m' mts --- | evaluate a method in a scope with the pattern's bindings, delegating to--- the method's context and setting the "dispatch" object+-- | Evaluate a method.+--+-- Responder methods: evaluates its expression in a scope with the pattern's+-- bindings, delegating to the method's context.+--+-- Slot methods: simply returns the value.+--+-- Macro methods: evaluates its expression in a scope with the pattern's+-- bindings. runMethod :: Method -> Message -> VM Value runMethod (Slot { mValue = v }) _ = return v runMethod (Responder { mPattern = p, mContext = c, mExpr = e }) m = do@@ -485,375 +406,31 @@      withTop nt $ eval e --- | evaluate an action in a new scope-newScope :: VM Value -> VM Value-newScope x = do-    t <- gets top-    nt <- newObject $ \o -> o-        { oDelegates = [t]-        }--    withTop nt x---- | given a pattern and a message, return the bindings from the pattern-bindings :: Pattern -> Message -> MethodMap-bindings (PSingle { ppTarget = p }) (Single { mTarget = t }) =-    toMethods (bindings' p t)-bindings (PKeyword { ppTargets = ps }) (Keyword { mTargets = ts }) =-    toMethods $ concat (zipWith bindings' ps ts)-bindings p m = error $ "impossible: bindings on " ++ show (p, m)---- | given a pattern and avalue, return the bindings as a list of pairs-bindings' :: Pattern -> Value -> [(Pattern, Value)]-bindings' (PNamed n p) v = (psingle n PThis, v) : bindings' p v-bindings' (PPMKeyword _ ps) (Particle (PMKeyword _ mvs)) =-    concatMap (\(p, Just v) -> bindings' p v)-    $ filter (isJust . snd)-    $ zip ps mvs-bindings' (PList ps) (List vs) = concat (zipWith bindings' ps (V.toList vs))-bindings' (PHeadTail hp tp) (List vs) =-    bindings' hp h ++ bindings' tp t-  where-    h = V.head vs-    t = List (V.tail vs)-bindings' (PHeadTail hp tp) (String t) | not (T.null t) =-    bindings' hp (Char (T.head t)) ++ bindings' tp (String (T.tail t))-bindings' (PExpr a) (Expression b) = exprBindings 0 a b-bindings' p (Reference r) =-    concatMap (bindings' p) $ oDelegates (unsafePerformIO (readIORef r))-bindings' _ _ = []---exprBindings :: Int -> Expr -> Expr -> [(Pattern, Value)]-exprBindings 0 (EUnquote { eExpr = Dispatch { eMessage = ESingle { emName = n } } }) e =-    [(psingle n PThis, Expression e)]-exprBindings n (EUnquote { eExpr = a }) (EUnquote { eExpr = b }) =-    exprBindings (n - 1) a b-exprBindings n (Define { eExpr = a }) (Define { eExpr = b }) =-    exprBindings n a b-exprBindings n (Set { eExpr = a }) (Set { eExpr = b }) =-    exprBindings n a b-exprBindings n (Dispatch { eMessage = am@(EKeyword {}) }) (Dispatch { eMessage = bm@(EKeyword {}) }) =-    concat $ zipWith (exprBindings n) (emTargets am) (emTargets bm)-exprBindings n (Dispatch { eMessage = am@(ESingle {}) }) (Dispatch { eMessage = bm@(ESingle {}) }) =-    exprBindings n (emTarget am) (emTarget bm)-exprBindings n (EBlock { eContents = as }) (EBlock { eContents = bs }) =-    concat $ zipWith (exprBindings n) as bs-exprBindings n (EList { eContents = as }) (EList { eContents = bs }) =-    concat $ zipWith (exprBindings n) as bs-exprBindings n (EMacro { eExpr = a }) (EMacro { eExpr = b }) =-    exprBindings n a b-exprBindings n (EParticle { eParticle = ap' }) (EParticle { eParticle = bp }) =-    case (ap', bp) of-        (EPMKeyword _ ames, EPMKeyword _ bmes) ->-            concatMap (\(Just a, Just b) -> exprBindings n a b)-            $ filter (isJust . fst)-            $ zip ames bmes-        _ -> []-exprBindings n (EQuote { eExpr = a }) (EQuote { eExpr = b }) =-    exprBindings (n + 1) a b-exprBindings _ _ _ = []----------------------------------------------------------------------------------- Helpers --------------------------------------------------------------------------------------------------------------------------------------------------infixr 0 =:, =::---- | define a method as an action returning a value-(=:) :: Pattern -> VM Value -> VM ()-pat =: vm = define pat (EVM Nothing Nothing vm)---- | define a slot to a given value-(=::) :: Pattern -> Value -> VM ()-pat =:: v = define pat (Primitive Nothing v)---- | define a method that evaluates e-(=:::) :: Pattern -> Expr -> VM ()-pat =::: e = define pat e---- | find a value from an object, searching its delegates, throwing--- a descriptive error if it is not found-findValue :: String -> (Value -> Bool) -> Value -> VM Value-findValue _ t v | t v = return v-findValue d t v = findValue' t v >>= maybe die return-  where-    die = throwError (ValueNotFound d v)---- | findValue, but returning Nothing instead of failing-findValue' :: (Value -> Bool) -> Value -> VM (Maybe Value)-findValue' t v | t v = return (Just v)-findValue' t (Reference r) = do-    o <- liftIO (readIORef r)-    findDels (oDelegates o)-  where-    findDels [] = return Nothing-    findDels (d:ds) = do-        f <- findValue' t d-        case f of-            Nothing -> findDels ds-            Just v -> return (Just v)-findValue' _ _ = return Nothing--findBlock :: Value -> VM Value-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-findChar v-    | isChar v = return v-    | otherwise = findValue "Char" isChar v--findContinuation :: Value -> VM Value-findContinuation v-    | isContinuation v = return v-    | otherwise = findValue "Continuation" isContinuation v--findDouble :: Value -> VM Value-findDouble v-    | isDouble v = return v-    | otherwise = findValue "Double" isDouble v--findExpression :: Value -> VM Value-findExpression v-    | isExpression v = return v-    | otherwise = findValue "Expression" isExpression v--findHaskell :: Value -> VM Value-findHaskell v-    | isHaskell v = return v-    | otherwise = findValue "Haskell" isHaskell v--findInteger :: Value -> VM Value-findInteger v-    | isInteger v = return v-    | otherwise = findValue "Integer" isInteger v--findList :: Value -> VM Value-findList v-    | isList v = return v-    | otherwise = findValue "List" isList v--findMessage :: Value -> VM Value-findMessage v-    | isMessage v = return v-    | otherwise = findValue "Message" isMessage v--findMethod' :: Value -> VM Value-findMethod' v-    | isMethod v = return v-    | otherwise = findValue "Method" isMethod v--findParticle :: Value -> VM Value-findParticle v-    | isParticle v = return v-    | otherwise = findValue "Particle" isParticle v--findProcess :: Value -> VM Value-findProcess v-    | isProcess v = return v-    | otherwise = findValue "Process" isProcess v--findPattern :: Value -> VM Value-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-findReference v-    | isReference v = return v-    | otherwise = findValue "Reference" isReference v--findString :: Value -> VM Value-findString v-    | isString v = return v-    | otherwise = findValue "String" isString v--getString :: Expr -> VM String-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 = liftM V.toList . getVector--getVector :: Expr -> VM (V.Vector Value)-getVector e = eval e-    >>= findList-    >>= \(List v) -> return v--here :: String -> VM Value-here n = gets top >>= dispatch . single n--ifVM :: VM Value -> VM a -> VM a -> VM a-ifVM c a b = do-    r <- c-    if r == Boolean 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 = 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 (particle "ok")-    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-    blockScope <- newObject $ \o -> o-        { oDelegates = [s]-        , oMethods = (bms, emptyMap)-        }--    withTop blockScope (evalAll es)--objectFor :: Value -> VM Object-{-# INLINE objectFor #-}-objectFor v = orefFor v >>= liftIO . readIORef-+-- | Get the object reference for a value. orefFor :: Value -> VM ORef {-# INLINE orefFor #-} 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-orefFrom ids (Expression _) = idExpression ids-orefFrom ids (Haskell _) = idHaskell ids-orefFrom ids (Integer _) = idInteger ids-orefFrom ids (List _) = idList ids-orefFrom ids (Message _) = idMessage ids-orefFrom ids (Method _) = idMethod ids-orefFrom ids (Particle _) = idParticle ids-orefFrom ids (Process _ _) = idProcess ids-orefFrom ids (Pattern _) = idPattern ids-orefFrom ids (Rational _) = idRational ids-orefFrom ids (String _) = idString ids---- | does one value delegate to another?-delegatesTo :: Value -> Value -> VM Bool-delegatesTo f t = do-    o <- objectFor f-    delegatesTo' (oDelegates o)-  where-    delegatesTo' [] = return False-    delegatesTo' (d:ds)-        | t `elem` (d:ds) = return True-        | otherwise = do-            o <- objectFor d-            delegatesTo' (oDelegates o ++ ds)---- | is one value an instance of, equal to, or a delegation to another?--- for example, 1 is-a?: Integer, but 1 does not delegates-to?: Integer-isA :: Value -> Value -> VM Bool-isA x y = do-    xr <- orefFor x-    yr <- orefFor y--    if xr == yr-        then return True-        else do-            ds <- liftM oDelegates (objectFor x)-            isA' ds-  where-    isA' [] = return False-    isA' (d:ds) = do-        di <- isA d y-        if di-            then return True-            else isA' ds-+-- | Raise a keyword particle as an error. raise :: [String] -> [Value] -> VM a {-# INLINE raise #-} raise ns vs = throwError . Error $ keyParticleN ns vs +-- | Raise a single particle as an error. raise' :: String -> VM a {-# INLINE raise' #-} raise' = throwError . Error . particle -fromHaskell :: Typeable a => String -> Value -> VM a-fromHaskell t (Haskell d) =-    case fromDynamic d of-        Just a -> return a-        Nothing -> raise ["dynamic-needed"] [string t]-fromHaskell t _ = raise ["dynamic-needed"] [string t]-+-- | Convert an AtomoError into a value and raise it as an error. throwError :: AtomoError -> VM a-throwError e = gets top >>= \t ->-    ifVM (dispatch (keyword ["responds-to?"] [t, particle "Error"]))-        (dispatch (msg t) >> error ("panic: error returned normally for: " ++ show e))-        (error ("panic: " ++ show e))+throwError e = gets top >>= \t -> do+    r <- dispatch (keyword ["responds-to?"] [t, particle "Error"])++    if r == Boolean True+        then do+            dispatch (msg t)+            error ("panic: error returned normally for: " ++ show e)+        else error ("panic: " ++ show e)   where     msg t = keyword ["error"] [t, asValue e] --- convert an expression to the pattern match it represents-toPattern :: Expr -> VM Pattern-toPattern (Dispatch { eMessage = EKeyword { emNames = ["."], emTargets = [h, t] } }) = do-    hp <- toPattern h-    tp <- toPattern t-    return (PHeadTail hp tp)-toPattern (Dispatch { eMessage = EKeyword { emNames = [n], emTargets = [ETop {}, x] } }) = do-    p <- toPattern x-    return (PNamed n p)-toPattern (Dispatch { eMessage = EKeyword { emNames = ns, emTargets = ts } }) = do-    ps <- mapM toPattern ts-    return (pkeyword ns ps)-toPattern (Dispatch { eMessage = ESingle { emName = "_" } }) =-    return PAny-toPattern d@(Dispatch { eMessage = ESingle { emTarget = ETop {}, emName = n } })-    | isUpper (head n) = return (PObject d)-    | otherwise = return (PNamed n PAny)-toPattern (Dispatch { eMessage = ESingle { emTarget = d@(Dispatch {}), emName = n } }) =-    return (psingle n (PObject d))-toPattern (EList { eContents = es }) = do-    ps <- mapM toPattern es-    return (PList ps)-toPattern (EParticle { eParticle = EPMSingle n }) =-    return (PMatch (Particle (PMSingle n)))-toPattern (EParticle { eParticle = EPMKeyword ns mes }) = do-    ps <- forM mes $ \me ->-        case me of-            Nothing -> return PAny-            Just e -> toPattern e--    return (PPMKeyword ns ps)-toPattern (EQuote { eExpr = e }) = return (PExpr e)-toPattern (Primitive { eValue = v }) =-    return (PMatch v)-toPattern e = raise ["unknown-pattern"] [Expression e]
+ src/Atomo/Helpers.hs view
@@ -0,0 +1,313 @@+module Atomo.Helpers where++import "monads-fd" Control.Monad.State+import Data.Dynamic+import Data.IORef+import qualified Data.Text as T+import qualified Data.Vector as V++import Atomo.Environment+import Atomo.Method+import Atomo.Pattern+import Atomo.Types+++infixr 0 =:, =::++-- | Define a method as an action returning a value.+(=:) :: Pattern -> VM Value -> VM ()+pat =: vm = define pat (EVM Nothing Nothing vm)++-- | Set a slot to a given value.+(=::) :: Pattern -> Value -> VM ()+pat =:: v = define pat (Primitive Nothing v)++-- | Define a method that evaluates e.+(=:::) :: Pattern -> Expr -> VM ()+pat =::: e = define pat e++-- | Find a value, searching through an object's delegates, and throwing+-- @\@could-not-find:in:@ if it is not found.+findValue :: String -> (Value -> Bool) -> Value -> VM Value+findValue _ t v | t v = return v+findValue d t v = findValue' t v >>= maybe die return+  where+    die = throwError (ValueNotFound d v)++-- | Same as `findValue', but returning Nothing instead of failing+findValue' :: (Value -> Bool) -> Value -> VM (Maybe Value)+findValue' t v | t v = return (Just v)+findValue' t (Reference r) = do+    o <- liftIO (readIORef r)+    findDels (oDelegates o)+  where+    findDels [] = return Nothing+    findDels (d:ds) = do+        f <- findValue' t d+        case f of+            Nothing -> findDels ds+            Just v -> return (Just v)+findValue' _ _ = return Nothing++-- | `findValue' for `Block'+findBlock :: Value -> VM Value+findBlock v+    | isBlock v = return v+    | otherwise = findValue "Block" isBlock v++-- | `findValue' for `Boolean'+findBoolean :: Value -> VM Value+findBoolean v+    | isBoolean v = return v+    | otherwise = findValue "Boolean" isBoolean v++-- | `findValue' for `Char'+findChar :: Value -> VM Value+findChar v+    | isChar v = return v+    | otherwise = findValue "Char" isChar v++-- | `findValue' for `Continuation'+findContinuation :: Value -> VM Value+findContinuation v+    | isContinuation v = return v+    | otherwise = findValue "Continuation" isContinuation v++-- | `findValue' for `Double'+findDouble :: Value -> VM Value+findDouble v+    | isDouble v = return v+    | otherwise = findValue "Double" isDouble v++-- | `findValue' for `Expression'+findExpression :: Value -> VM Value+findExpression v+    | isExpression v = return v+    | otherwise = findValue "Expression" isExpression v++-- | `findValue' for `Haskell'+findHaskell :: Value -> VM Value+findHaskell v+    | isHaskell v = return v+    | otherwise = findValue "Haskell" isHaskell v++-- | `findValue' for `Integer'+findInteger :: Value -> VM Value+findInteger v+    | isInteger v = return v+    | otherwise = findValue "Integer" isInteger v++-- | `findValue' for `List'+findList :: Value -> VM Value+findList v+    | isList v = return v+    | otherwise = findValue "List" isList v++-- | `findValue' for `Message'+findMessage :: Value -> VM Value+findMessage v+    | isMessage v = return v+    | otherwise = findValue "Message" isMessage v++-- | `findValue' for `Method''+findMethod' :: Value -> VM Value+findMethod' v+    | isMethod v = return v+    | otherwise = findValue "Method" isMethod v++-- | `findValue' for `Particle'+findParticle :: Value -> VM Value+findParticle v+    | isParticle v = return v+    | otherwise = findValue "Particle" isParticle v++-- | `findValue' for `Process'+findProcess :: Value -> VM Value+findProcess v+    | isProcess v = return v+    | otherwise = findValue "Process" isProcess v++-- | `findValue' for `Pattern'+findPattern :: Value -> VM Value+findPattern v+    | isPattern v = return v+    | otherwise = findValue "Pattern" isPattern v++-- | `findValue' for `Rational'+findRational :: Value -> VM Value+findRational v+    | isRational v = return v+    | otherwise = findValue "Rational" isRational v++-- | `findValue' for `Reference'+findReference :: Value -> VM Value+findReference v+    | isReference v = return v+    | otherwise = findValue "Reference" isReference v++-- | `findValue' for `String'+findString :: Value -> VM Value+findString v+    | isString v = return v+    | otherwise = findValue "String" isString v++-- | Find a String given an expression to evaluate.+getString :: Expr -> VM String+getString e = eval e >>= liftM (fromText . fromString) . findString++-- | Find a Data.Text.Text given an expression to evaluate.+getText :: Expr -> VM T.Text+getText e = eval e >>= findString >>= \(String t) -> return t++-- | Find a list of values, given an expression to evaluate.+getList :: Expr -> VM [Value]+getList = liftM V.toList . getVector++-- | Find a VVector, given an expression to evaluate.+getVector :: Expr -> VM VVector+getVector e = eval e+    >>= findList+    >>= \(List v) -> return v++-- | Dispatch a single message to the current toplevel.+here :: String -> VM Value+here n = gets top >>= dispatch . single n++-- | if-then-else based on a VM action yielding a Boolean Value.+ifVM :: VM Value -> VM a -> VM a -> VM a+ifVM c a b = do+    r <- c+    if r == Boolean True then a else b++-- | if-then-else based on a VM action yielding a Bool.+ifVM' :: VM Bool -> VM a -> VM a -> VM a+ifVM' c a b = do+    r <- c+    if r then a else b++-- | if-then-else based on an expression to evaluate.+ifE :: Expr -> VM a -> VM a -> VM a+ifE = ifVM . eval++-- | Get a value's object.+referenceTo :: Value -> VM Value+{-# INLINE referenceTo #-}+referenceTo = liftM Reference . orefFor++-- | Call a block with the given arguments. Creates a scope, checks that its+-- argument patterns match, and executes it with the bindings.+callBlock :: Value -> [Value] -> VM Value+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 (particle "ok")+    checkArgs _ _ [] = throwError (BlockArity (length ps) (length vs))+    checkArgs is (p:ps') (v:vs')+        | match is Nothing p v = checkArgs is ps' vs'+        | otherwise = throwError (Mismatch p v)+callBlock x _ = raise ["not-a-block"] [x]++-- | Evaluate multiple expressions given a context and bindings for the+-- toplevel object.+doBlock :: MethodMap -> Value -> [Expr] -> VM Value+{-# INLINE doBlock #-}+doBlock bms s es = do+    blockScope <- newObject $ \o -> o+        { oDelegates = [s]+        , oMethods = (bms, emptyMap)+        }++    withTop blockScope (evalAll es)++-- | Get the object backing a value.+objectFor :: Value -> VM Object+{-# INLINE objectFor #-}+objectFor v = orefFor v >>= liftIO . readIORef++-- | Does one value delegate to another?+delegatesTo :: Value -> Value -> VM Bool+delegatesTo f t = do+    o <- objectFor f+    delegatesTo' (oDelegates o)+  where+    delegatesTo' [] = return False+    delegatesTo' (d:ds)+        | t `elem` (d:ds) = return True+        | otherwise = do+            o <- objectFor d+            delegatesTo' (oDelegates o ++ ds)++-- | Is one value an instance of, equal to, or a delegation to another?+--+-- For example, 1 is-a?: Integer, but 1 does not delegates-to?: Integer+isA :: Value -> Value -> VM Bool+isA x y = do+    xr <- orefFor x+    yr <- orefFor y++    if xr == yr+        then return True+        else do+            ds <- liftM oDelegates (objectFor x)+            isA' ds+  where+    isA' [] = return False+    isA' (d:ds) = do+        di <- isA d y+        if di+            then return True+            else isA' ds++-- | Attempt conversion from a Haskell Value, given the type we expect as+-- a string.+--+-- If conversion fails, raises @\@dynamic-needed:@ with the given string.+fromHaskell :: Typeable a => String -> Value -> VM a+fromHaskell t (Haskell d) =+    case fromDynamic d of+        Just a -> return a+        Nothing -> raise ["dynamic-needed"] [string t]+fromHaskell t _ = raise ["dynamic-needed"] [string t]++-- | Convert an Atomo Haskell dynamic value into its value, erroring on+-- failure.+fromHaskell' :: Typeable a => String -> Value -> a+fromHaskell' t (Haskell d) =+    case fromDynamic d of+        Just a -> a+        Nothing -> error ("needed Haskell value of type " ++ t)+fromHaskell' t _ = error ("needed haskell value of type " ++ t)++-- | `toPattern', raising @\@unknown-pattern:@ if conversion fails.+toPattern' :: Expr -> VM Pattern+toPattern' = tryPattern toPattern++-- | `toDefinePattern', raising @\@unknown-pattern:@ if conversion fails.+toDefinePattern' :: Expr -> VM Pattern+toDefinePattern' = tryPattern toDefinePattern++-- | `toRolePattern', raising @\@unknown-pattern:@ if conversion fails.+toRolePattern' :: Expr -> VM Pattern+toRolePattern' = tryPattern toRolePattern++-- | `toMacroPattern', raising @\@unknown-pattern:@ if conversion fails.+toMacroPattern' :: Expr -> VM Pattern+toMacroPattern' = tryPattern toMacroPattern++-- | Try a given pattern conversion, raising @\@unknown-pattern:@ if conversion+-- fails.+tryPattern :: (Expr -> Maybe Pattern) -> Expr -> VM Pattern+tryPattern c e = +    case c e of+        Nothing -> raise ["unknown-pattern"] [Expression e]+        Just p -> return p++-- | Fill in the empty values of a particle. The number of values missing+-- is expected to be equal to the number of values provided.+completeKP :: [Maybe Value] -> [Value] -> [Value]+completeKP [] _ = []+completeKP (Nothing:mvs') (v:vs') = v : completeKP mvs' vs'+completeKP (Just v:mvs') vs' = v : completeKP mvs' vs'+completeKP mvs' vs' = error $ "impossible: completeKP on " ++ show (mvs', vs')
src/Atomo/Kernel.hs view
@@ -8,6 +8,7 @@ import Atomo import Atomo.Load import Atomo.Method+import Atomo.Pattern (bindings') import Atomo.Pretty  import qualified Atomo.Kernel.Numeric as Numeric@@ -91,8 +92,8 @@         let (ss, ks) = oMethods o          ([$p|ms|] =::) =<< eval [$e|Object clone|]-        [$p|ms singles|] =:: list (map (list . map Method) (elemsMap ss))-        [$p|ms keywords|] =:: list (map (list . map Method) (elemsMap ks))+        [$p|(ms) singles|] =:: list (map (list . map Method) (elemsMap ss))+        [$p|(ms) keywords|] =:: list (map (list . map Method) (elemsMap ks))         here "ms"      [$p|(x: Object) dump|] =: do@@ -105,18 +106,6 @@     [$p|(s: String) as: String|] =::: [$e|s|]      [$p|(x: Object) as: String|] =::: [$e|x show|]--    [$p|(s: String) as: Integer|] =: do-        s <- getString [$e|s|]-        return (Integer (read s))--    [$p|(s: String) as: Double|] =: do-        s <- getString [$e|s|]-        return (Double (read s))--    [$p|(s: String) as: Char|] =: do-        s <- getString [$e|s|]-        return (Char (read s))      [$p|(x: Object) show|] =:         liftM (string . show . pretty) (here "x")
src/Atomo/Kernel/Block.hs view
@@ -26,6 +26,11 @@         vs <- getList [$e|l|]         callBlock b vs +    [$p|(b: Block) call-in: c|] =: do+        Block _ _ es <- here "b" >>= findBlock+        c <- here "c"+        withTop c (evalAll es)+     [$p|(b: Block) context|] =: do         Block s _ _ <- here "b" >>= findBlock         return s
src/Atomo/Kernel/Comparable.hs view
@@ -9,7 +9,7 @@ load :: VM () load = do     mapM_ eval-        [ [$e|operator 4 ==, /=, <, <=, >=, >|]+        [ [$e|operator 4 == /= < <= >= >|]         , [$e|operator right 3 &&|]         , [$e|operator right 2 |||]         ]
src/Atomo/Kernel/Expression.hs view
@@ -5,32 +5,48 @@ import Text.PrettyPrint (Doc)  import Atomo+import Atomo.Parser (parseInput, withParser)+import Atomo.Parser.Expand+import Atomo.Pattern (match) import Atomo.Pretty (pretty)-import Atomo.Parser (macroExpand, parseInput, withParser)   load :: VM () load = do     [$p|`Block new: (es: List)|] =::: [$e|`Block new: es arguments: []|]     [$p|`Block new: (es: List) arguments: (as: List)|] =: do-        es <- getList [$e|es|]-        as <- getList [$e|as|]+        es <- getList [$e|es|] >>= mapM findExpression+        as <- getList [$e|as|] >>= mapM findExpression         return (Expression (EBlock Nothing (map fromPattern as) (map fromExpression es)))      [$p|`List new: (es: List)|] =: do-        es <- getList [$e|es|]+        es <- getList [$e|es|] >>= mapM findExpression         return (Expression (EList Nothing (map fromExpression es)))      [$p|`Match new: (branches: List) on: (value: Expression)|] =: do-        pats <- liftM (map fromExpression) $ getList [$e|branches map: @from|]-        exprs <- liftM (map fromExpression) $ getList [$e|branches map: @to|]+        pats <- liftM (map fromExpression) $ getList [$e|branches map: @from|] >>= mapM findExpression+        exprs <- liftM (map fromExpression) $ getList [$e|branches map: @to|] >>= mapM findExpression         Expression value <- here "value" >>= findExpression -        ps <- mapM toPattern pats+        ps <- mapM toRolePattern' pats         ids <- gets primitives         return . Expression . EVM Nothing (Just $ prettyMatch value (zip pats exprs)) $             eval value >>= matchBranches ids (zip ps exprs) +    [$p|`Set new: (pattern: Expression) to: (value: Expression)|] =: do+        Expression pat <- here "pattern" >>= findExpression+        Expression e <- here "value" >>= findExpression++        p <- toPattern' pat+        return (Expression $ Set Nothing p e)++    [$p|`Define new: (pattern: Expression) as: (expr: Expression)|] =: do+        Expression pat <- here "pattern" >>= findExpression+        Expression e <- here "expr" >>= findExpression++        p <- toDefinePattern' pat+        return (Expression $ Define Nothing p e)+     [$p|(s: String) parse-expressions|] =:         getString [$e|s|] >>= liftM (list . map Expression) . parseInput @@ -59,6 +75,7 @@             EVM {} -> return (particle "vm")             EList {} -> return (particle "list")             EMacro {} -> return (particle "macro")+            EForMacro {} -> return (particle "for-macro")             ETop {} -> return (particle "top")             EQuote {} -> return (particle "quote")             EUnquote {} -> return (particle "unquote")@@ -137,6 +154,7 @@         case e of             Set { ePattern = p } -> return (Pattern p)             Define { ePattern = p } -> return (Pattern p)+            EMacro { ePattern = p } -> return (Pattern p)             _ -> raise ["no-pattern-for"] [Expression e]      [$p|(e: Expression) expression|] =: do@@ -144,14 +162,45 @@         case e of             Set { eExpr = e } -> return (Expression e)             Define { eExpr = e } -> return (Expression e)+            EMacro { eExpr = e } -> return (Expression e)+            EForMacro { eExpr = e } -> return (Expression e)+            EQuote { eExpr = e } -> return (Expression e)+            EUnquote { eExpr = e } -> return (Expression e)             _ -> raise ["no-expression-for"] [Expression e] +    [$p|(e: Expression) associativity|] =: do+        Expression e <- here "e" >>= findExpression+        case e of+            Operator { eAssoc = ALeft } ->+                return (particle "left") +            Operator { eAssoc = ARight } ->+                return (particle "right")++            _ -> raise ["no-associativity-for"] [Expression e]++    [$p|(e: Expression) precedence|] =: do+        Expression e <- here "e" >>= findExpression+        case e of+            Operator { ePrec = p } ->+                return (Integer p)++            _ -> raise ["no-precedence-for"] [Expression e]++    [$p|(e: Expression) operators|] =: do+        Expression e <- here "e" >>= findExpression+        case e of+            Operator { eNames = ns } ->+                return (list (map (\n -> keyParticle [n] [Nothing, Nothing]) ns))++            _ -> raise ["no-operators-for"] [Expression e]++ matchBranches :: IDs -> [(Pattern, Expr)] -> Value -> VM Value matchBranches _ [] v = raise ["no-match-for"] [v] matchBranches ids ((p, e):ps) v = do     p' <- matchable p-    if match ids p' v+    if match ids Nothing p' v         then newScope $ set p' v >> eval e         else matchBranches ids ps v
src/Atomo/Kernel/List.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} module Atomo.Kernel.List (load) where -import Data.List.Split+import Data.List (isPrefixOf) import qualified Data.Vector as V  import Atomo@@ -11,9 +11,6 @@ load = do     eval [$e|operator right .|] -    [$p|(l: List) show|] =:::-        [$e|"[" .. l (map: @show) (join: ", ") .. "]"|]-     [$p|(l: List) length|] =:         liftM (Integer . fromIntegral . V.length) (getVector [$e|l|]) @@ -350,4 +347,20 @@         else do             rest <- merge cmp xs (y:ys)             return (x:rest)++splitWhen :: (a -> Bool) -> [a] -> [[a]]+splitWhen f vs' = splitWhen' vs' []+  where+    splitWhen' [] acc = [acc]+    splitWhen' (v:vs) acc+        | f v = acc : splitWhen' vs []+        | otherwise = splitWhen' vs (acc ++ [v])++splitOn :: Eq a => [a] -> [a] -> [[a]]+splitOn d vs' = splitOn' vs' []+  where+    splitOn' [] acc = [acc]+    splitOn' vs acc+        | d `isPrefixOf` vs = acc : splitOn' (drop (length d) vs) []+        | otherwise = splitOn' (tail vs) (acc ++ [head vs])
src/Atomo/Kernel/Numeric.hs view
@@ -10,8 +10,8 @@ load = do     mapM_ eval         [ [$e|operator right 8 ^|]-        , [$e|operator 7 %, *, /|]-        , [$e|operator 6 +, -|]+        , [$e|operator 7 % * /|]+        , [$e|operator 6 + -|]         ]      eval [$e|Object clone|] >>= ([$p|Number|] =::)
src/Atomo/Kernel/Pattern.hs view
@@ -3,15 +3,29 @@ module Atomo.Kernel.Pattern (load) where  import Atomo+import Atomo.Pattern (match)   load :: VM () load = do+    ([$p|Pattern Role|] =::) =<< eval [$e|Pattern clone|]+    ([$p|Pattern Define|] =::) =<< eval [$e|Pattern clone|]+     [$p|(e: Expression) as: Pattern|] =: do         Expression e <- here "e" >>= findExpression-        p <- toPattern e+        p <- toPattern' e         return (Pattern p) +    [$p|(e: Expression) as: Pattern Role|] =: do+        Expression e <- here "e" >>= findExpression+        p <- toRolePattern' e+        return (Pattern p)++    [$p|(e: Expression) as: Pattern Define|] =: do+        Expression e <- here "e" >>= findExpression+        p <- toDefinePattern' e+        return (Pattern p)+     [$p|(p: Pattern) name|] =: do         Pattern p <- here "p" >>= findPattern @@ -46,7 +60,7 @@         v <- here "v"         ids <- gets primitives -        if match ids p v+        if match ids Nothing p v             then do                 bs <- eval [$e|Object clone|]                 withTop bs (set p v)
src/Atomo/Kernel/Ports.hs view
@@ -326,9 +326,11 @@      portObj hdl = newScope $ do         port <- eval [$e|Port clone|]-        [$p|p|] =:: port-        [$p|p handle|] =:: haskell hdl-        here "p"++        define (psingle "handle" (PMatch port))+            (Primitive Nothing $ haskell hdl)++        return port      getHandle ex = eval ex >>= fromHaskell "Handle"
src/Atomo/Kernel/String.hs view
@@ -2,6 +2,7 @@ module Atomo.Kernel.String where  import Data.List (sort)+import Data.Ratio ((%)) import qualified Data.Text as T  import Atomo@@ -12,6 +13,28 @@     [$p|(s: String) as: List|] =:         liftM (list . map Char) (getString [$e|s|]) +    -- TODO: rename these to @read: or @to:+    [$p|(s: String) as: Char|] =: do+        s <- getString [$e|s|]+        case s of+            "$'" -> return (Char '\'')+            '$':rest -> return (Char (read $ "'" ++ rest ++ "'"))+            _ -> raise ["invalid-string"] [String $ T.pack s]+    +    [$p|(s: String) as: Integer|] =: do+        s <- getString [$e|s|]+        return (Integer (read s))+        +    [$p|(s: String) as: Double|] =: do+        s <- getString [$e|s|]+        return (Double (read s))+    +    [$p|(s: String) as: Rational|] =: do+        s <- getString [$e|s|]+        let num = read $ takeWhile (/= '/') s+            denom = read . tail $ dropWhile (/= '/') s+        return (Rational (num % denom))+     [$p|(l: List) to-string|] =: do         vs <- getList [$e|l|] @@ -45,7 +68,19 @@     [$p|(s: String) last|] =:         liftM (Char . T.last) (getText [$e|s|]) -    -- TODO: @from:to:+    [$p|(s: String) from: (n: Integer) to: (m: Integer)|] =: do+            Integer n <- here "n" >>= findInteger+            Integer m <- here "m" >>= findInteger+            t <- getText [$e|s|]++            let start = fromIntegral n+                count = (fromIntegral m) - start++            if count > T.length t || start < 0 || count < 0+                then raise+                    ["invalid-slice", "for-string"]+                    [keyParticleN ["from", "to"] [Integer n, Integer m], String t]+                else return (String . T.take count . T.drop start $ t)      [$p|"" init|] =::: [$e|error: @empty-string|]     [$p|(s: String) init|] =:
src/Atomo/Load.hs view
@@ -10,8 +10,8 @@ import Atomo.Types  --- load a file, remembering it to prevent repeated loading--- searches with cwd as lowest priority+-- | Load a file, remembering its absolute path to prevent repeated loading.+-- Searches with cwd as lowest priority requireFile :: FilePath -> VM Value requireFile fn = do     initialPath <- gets loadPath@@ -26,14 +26,14 @@      doLoad file --- load a file--- searches with cwd as highest priority+-- | 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+-- | Execute a file; for .hs filenames, interprets its `load' function and+-- calls it. for anything else, it interprets it as Atomo source. doLoad :: FilePath -> VM Value doLoad file =     case takeExtension file of@@ -64,8 +64,10 @@              return r --- | given a list of paths to search, find the file to load--- attempts to find the filename with .atomo and .hs extensions+-- | Given a list of paths to search, find the file to load. Attempts to find+-- the filename with .atomo and .hs extensions.+--+-- If no file is found, throws a FileNotFound error. findFile :: [FilePath] -> FilePath -> VM FilePath findFile [] fn = throwError (FileNotFound fn) findFile (p:ps) fn = do
src/Atomo/Method.hs view
@@ -85,14 +85,15 @@     ds = oDelegates (unsafePerformIO (readIORef f)) unsafeDelegatesTo _ _ = False +-- | Insert a method into a MethodMap based on its pattern's ID and precision. addMethod :: Method -> MethodMap -> MethodMap addMethod m mm =     M.insertWith (\[m'] ms -> insertMethod m' ms) key [m] mm   where     key = ppID (mPattern m) --- insert a method into a list of existing methods--- most precise goes first, equivalent patterns are replaced+-- | Insert a method into a list of existing methods most precise goes first,+-- equivalent patterns are replaced. insertMethod :: Method -> [Method] -> [Method] insertMethod x [] = [x] insertMethod x ys@(y:ys') =@@ -106,24 +107,33 @@         -- keep looking if we're EQ or GT         _ -> y : insertMethod x ys' +-- | Convert a list of slots to a MethodMap. toMethods :: [(Pattern, Value)] -> MethodMap toMethods = foldl (\ss (p, v) -> addMethod (Slot p v) ss) emptyMap +-- | A pair of two empty MethodMaps; one for single methods and one for keyword+-- methods. noMethods :: (MethodMap, MethodMap) noMethods = (M.empty, M.empty) +-- | An empty MethodMap. emptyMap :: MethodMap emptyMap = M.empty +-- | Find methods in a MethodMap by the pattern ID. lookupMap :: Int -> MethodMap -> Maybe [Method] lookupMap = M.lookup +-- | Is a MethodMap empty?. nullMap :: MethodMap -> Bool nullMap = M.null +-- | All of the methods in a MethodMap. elemsMap :: MethodMap -> [[Method]] elemsMap = M.elems +-- | Insert a method into a MethodMap, replacing all other methods with the+-- same ID. insertMap :: Method -> MethodMap -> MethodMap insertMap m mm = M.insert key [m] mm   where
src/Atomo/Parser.hs view
@@ -1,391 +1,27 @@ module Atomo.Parser where -import Control.Arrow (first, second) import "monads-fd" Control.Monad.State-import Data.Maybe (fromJust, isJust) import Text.Parsec-import qualified "mtl" Control.Monad.Trans as MTL  import Atomo.Environment-import Atomo.Method import Atomo.Parser.Base-import {-# SOURCE #-} Atomo.Parser.Pattern-import Atomo.Parser.Primitive+import Atomo.Parser.Expr+import Atomo.Parser.Expand import Atomo.Types hiding (keyword, string) --- the types of values in Dispatch syntax-data Dispatch-    = DParticle EParticle-    | DNormal Expr-    deriving Show -defaultPrec :: Integer-defaultPrec = 5--pExpr :: Parser Expr-pExpr = choice-    [ pOperator-    , pMacro-    , pForMacro-    , try pDispatch-    , pDefine-    , pSet-    , pLiteral-    , parens pExpr-    ]-    <?> "expression"--pLiteral :: Parser Expr-pLiteral = pThis <|> pBlock <|> pList <|> pParticle <|> pQuoted <|> pQuasiQuoted <|> pUnquoted <|> pPrimitive-    <?> "literal"--pThis :: Parser Expr-pThis = tagged $ reserved "this" >> return (ETop Nothing)--pQuoted :: Parser Expr-pQuoted = tagged $ do-    char '\''-    e <- pSpacedExpr-    return (Primitive Nothing (Expression e))--pQuasiQuoted :: Parser Expr-pQuasiQuoted = tagged $ do-    char '`'-    e <- pSpacedExpr-    return (EQuote Nothing e)--pUnquoted :: Parser Expr-pUnquoted = tagged $ do-    char '~'-    e <- pSpacedExpr-    return (EUnquote Nothing e)--pSpacedExpr :: Parser Expr-pSpacedExpr = pLiteral <|> simpleDispatch <|> parens pExpr-  where-    simpleDispatch = tagged $ do-        name <- ident-        notFollowedBy (char ':')-        spacing-        return (Dispatch Nothing (esingle name (ETop Nothing)))--pForMacro :: Parser Expr-pForMacro = tagged (do-    reserved "for-macro"-    e <- pExpr-    MTL.lift (eval e)-    return (Primitive Nothing (Expression e))) --e)-    <?> "for-macro expression"--pMacro :: Parser Expr-pMacro = tagged (do-    reserved "macro"-    p <- ppMacro-    reserved ":="-    whiteSpace-    e <- pExpr-    macroExpand e >>= addMacro p-    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"--    info <- choice-        [ do-            a <- choice-                [ symbol "right" >> return ARight-                , symbol "left" >> return ALeft-                ]-            prec <- option defaultPrec (try integer)-            return (a, prec)-        , liftM ((,) ALeft) integer-        ]--    ops <- commaSep1 operator--    forM_ ops $ \name ->-        modifyState (\ps -> ps { psOperators = (name, info) : psOperators ps })--    return (uncurry (Operator Nothing ops) info))-    <?> "operator pragma"--pParticle :: Parser Expr-pParticle = tagged (do-    char '@'-    c <- choice-        [ cKeyword True-        , binary-        , try (cSingle True)-        , symbols-        ]-    return (EParticle Nothing c))-    <?> "particle"-  where-    binary = do-        op <- operator-        return $ EPMKeyword [op] [Nothing, Nothing]--    symbols = do-        names <- many1 (anyIdent >>= \n -> char ':' >> return n)-        spacing-        return $ EPMKeyword names (replicate (length names + 1) Nothing)--pDefine :: Parser Expr-pDefine = tagged (do-    pattern <- try $ do-        p <- ppDefine-        reservedOp ":="-        return p--    whiteSpace-    expr <- pExpr--    return $ Define Nothing pattern expr)-    <?> "definition"--pSet :: Parser Expr-pSet = tagged (do-    pattern <- try $ do-        p <- ppSet-        reservedOp "="-        return p--    whiteSpace-    expr <- pExpr--    return $ Set Nothing pattern expr)-    <?> "set"--pDispatch :: Parser Expr-pDispatch = do-    d <- choice-        [ try pdKeys-        , pdCascade-        ]-    notFollowedBy (reserved ":=" <|> reserved "=")-    return d-    <?> "dispatch"--pdKeys :: Parser Expr-pdKeys = do-    pos <- getPosition-    msg <- keywords ekeyword (ETop (Just pos)) (try pdCascade <|> headless)-    ops <- liftM psOperators getState-    return $ Dispatch (Just pos) (toBinaryOps ops msg)-    <?> "keyword dispatch"-  where-    headless = do-        p <- getPosition-        msg <- ckeywd p-        ops <- liftM psOperators getState-        return (Dispatch (Just p) (toBinaryOps ops msg))--    ckeywd pos = do-        ks <- wsMany1 $ keyword pdCascade-        let (ns, es) = unzip ks-        return $ ekeyword ns (ETop (Just pos):es)-        <?> "keyword segment"--pdCascade :: Parser Expr-pdCascade = do-    pos <- getPosition--    chain <- wsManyStart-        (liftM DNormal (try pLiteral <|> pThis <|> parens pExpr) <|> cascaded)-        cascaded--    return $ dispatches pos chain-    <?> "single dispatch"-  where-    cascaded = liftM DParticle $ choice-        [ cKeyword False-        , cSingle False-        ]--    -- start off by dispatching on either a primitive or Top-    dispatches :: SourcePos -> [Dispatch] -> Expr-    dispatches p (DNormal e:ps) =-        dispatches' p ps e-    dispatches p (DParticle (EPMSingle n):ps) =-        dispatches' p ps (Dispatch (Just p) $ esingle n (ETop (Just p)))-    dispatches p (DParticle (EPMKeyword ns (Nothing:es)):ps) =-        dispatches' p ps (Dispatch (Just p) $ ekeyword ns (ETop (Just p):map fromJust es))-    dispatches _ ds = error $ "impossible: dispatches on " ++ show ds--    -- roll a list of partial messages into a bunch of dispatches-    dispatches' :: SourcePos -> [Dispatch] -> Expr -> Expr-    dispatches' _ [] acc = acc-    dispatches' p (DParticle (EPMKeyword ns (Nothing:es)):ps) acc =-        dispatches' p ps (Dispatch (Just p) $ ekeyword ns (acc : map fromJust es))-    dispatches' p (DParticle (EPMSingle n):ps) acc =-        dispatches' p ps (Dispatch (Just p) $ esingle n acc)-    dispatches' _ x y = error $ "impossible: dispatches' on " ++ show (x, y)--pList :: Parser Expr-pList = (tagged . liftM (EList Nothing) $ brackets (wsDelim "," pExpr))-    <?> "list"--pBlock :: Parser Expr-pBlock = tagged (braces $ do-    arguments <- option [] . try $ do-        ps <- many1 pPattern-        whiteSpace-        string "|"-        whiteSpace1-        return ps--    code <- wsBlock pExpr--    return $ EBlock Nothing arguments code)-    <?> "block"--cSingle :: Bool -> Parser EParticle-cSingle p = do-    n <- if p then anyIdent else ident-    notFollowedBy colon-    spacing-    return (EPMSingle n)-    <?> "single segment"--cKeyword :: Bool -> Parser EParticle-cKeyword wc = do-    ks <- parens $ many1 keyword'-    let (ns, mvs) = second (Nothing:) $ unzip ks-    if any isOperator (tail ns)-        then toDispatch ns mvs-        else return $ EPMKeyword ns mvs-    <?> "keyword segment"-  where-    keywordVal-        | wc = wildcard <|> value-        | otherwise = value--    keywordDispatch-        | wc = wildcard <|> disp-        | otherwise = disp--    value = liftM Just pdCascade-    disp = liftM Just pDispatch--    keyword' = do-        name <- try (do-            name <- ident-            char ':'-            return name) <|> operator-        whiteSpace1-        target <--            if isOperator name-                then keywordDispatch-                else keywordVal-        return (name, target)--    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:) $ break 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"] }-toBinaryOps :: Operators -> EMessage -> EMessage-toBinaryOps _ done@(EKeyword _ [_] [_, _]) = done-toBinaryOps ops (EKeyword h (n:ns) (v:vs))-    | nextFirst =-         ekeyword [n]-            [ v-            , Dispatch (eLocation v)-                (toBinaryOps ops (ekeyword ns vs))-            ]-    | isOperator n =-        toBinaryOps ops . ekeyword ns $-            (Dispatch (eLocation v) (ekeyword [n] [v, head vs]):tail vs)-    | nonOperators == ns = EKeyword h (n:ns) (v:vs)-    | null nonOperators && length vs > 2 =-        ekeyword [head ns]-            [ Dispatch (eLocation v) $-                ekeyword [n] [v, head vs]-            , Dispatch (eLocation v) $-                toBinaryOps ops (ekeyword (tail ns) (tail vs))-            ]-    | otherwise =-        ekeyword-            (n : nonOperators)-            (concat-                [ [v]-                , take numNonOps vs-                , [ Dispatch (eLocation v) $ toBinaryOps ops-                        (ekeyword-                            (drop numNonOps ns)-                            (drop numNonOps vs)) ]-                ])-  where-    numNonOps = length nonOperators-    nonOperators = takeWhile (not . isOperator) ns-    nextFirst =-        isOperator n && or-            [ null ns-            , prec next > prec n-            , assoc n == ARight && prec next == prec n-            ]-      where next = head ns--    assoc n' =-        case lookup n' ops of-            Nothing -> ALeft-            Just (a, _) -> a--    prec n' =-        case lookup n' ops of-            Nothing -> defaultPrec-            Just (_, p) -> p-toBinaryOps _ u = error $ "cannot toBinaryOps: " ++ show u--parser :: Parser [Expr]-parser = do-    whiteSpace-    es <- wsBlock pExpr-    whiteSpace-    eof-    return es--fileParser :: Parser [Expr]-fileParser = do-    optional (string "#!" >> manyTill anyToken (eol <|> eof))-    parser--parseFile :: String -> VM [Expr]-parseFile fn = liftIO (readFile fn) >>= continue (fileParser >>= mapM macroExpand) fn+-- | Parses an input file, performs macro expansion, and returns an AST.+parseFile :: FilePath -> VM [Expr]+parseFile fn =+    liftIO (readFile fn)+        >>= continue (fileParser >>= mapM macroExpand) fn +-- | Parses an input string, performs macro expansion, and returns an AST. parseInput :: String -> VM [Expr] parseInput = continue (parser >>= mapM macroExpand) "<input>" +-- | Given a Parser action, a source, and the input, perform that action+-- passing the parser state between VM and Parser. continue :: Parser a -> String -> String -> VM a continue p s i = do     ps <- gets parserState@@ -396,70 +32,10 @@             modify $ \e -> e { parserState = ps' }             return ok --- | parse input i from source s, maintaining parser state between parses+-- | Parse input i from source s, maintaining parser state between parses. continuedParse :: String -> String -> VM [Expr] continuedParse i s = continue parser s i +-- | Run an arbitrary Parser action with the VM's parser state. 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 {}) = liftM (fst . psMacros) getState-    methods (Keyword {}) = liftM (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
@@ -7,14 +7,14 @@ import Text.Parsec import qualified Text.Parsec.Token as P -import Atomo.Types (Expr(..), ParserState, VM)+import Atomo.Types (Expr(..), ParserState(..), VM)   type Parser = ParsecT String ParserState VM   isOpLetter :: Char -> Bool-isOpLetter c = c `elem` "!@#%&*-./\\?" || isSymbol c+isOpLetter c = c `elem` "!@#%&*-./\\?:" || isSymbol c  isOperator :: String -> Bool isOperator "" = False@@ -26,11 +26,11 @@     , P.commentEnd = "-}"     , P.commentLine = "--"     , P.nestedComments = True-    , P.identStart = letter <|> P.opStart def <|> oneOf "_"-    , P.identLetter = alphaNum <|> P.opLetter def+    , P.identStart = satisfy (\c -> c == '_' || isLetter c || (c `notElem` "@$~:" && isOpLetter c))+    , P.identLetter = satisfy (\c -> c == '_' || isAlphaNum c || (c /= ':' && isOpLetter c))     , P.opStart = satisfy (\c -> c `notElem` "@$~" && isOpLetter c)     , P.opLetter = satisfy isOpLetter-    , P.reservedOpNames = ["=", ":=", ",", "|"]+    , P.reservedOpNames = [",", "|"]     , P.reservedNames = ["operator", "macro", "for-macro", "this", "True", "False"]     , P.caseSensitive = True     }@@ -44,35 +44,32 @@ lexeme :: Parser a -> Parser a lexeme = P.lexeme tp -capIdent :: Parser String-capIdent = do-    c <- satisfy isUpper-    cs <- many (P.identLetter def)-    return (c:cs)--lowIdent :: Parser String-lowIdent = do-    c <- satisfy isLower-    cs <- many (P.identLetter def)-    return (c:cs)--capIdentifier :: Parser String-capIdentifier = lexeme capIdent--lowIdentifier :: Parser String-lowIdentifier = lexeme lowIdent- anyIdent :: Parser String anyIdent = try $ do     c <- P.identStart def     cs <- many (P.identLetter def)     if isOperator (c:cs)         then unexpected "operator"+        else do++    ps <- getState+    if c == '#' && psInQuote ps+        then return ((c:cs) ++ ":" ++ show (psClock ps))         else return (c:cs)  anyIdentifier :: Parser String anyIdentifier = lexeme anyIdent +identifier :: Parser String+identifier = lexeme ident++ident :: Parser String+ident = do+    name <- anyIdent+    if isReservedName name+        then unexpected ("reserved word " ++ show name)+        else return name+ parens :: Parser a -> Parser a parens = P.parens tp @@ -94,12 +91,6 @@ dot :: Parser String dot = P.dot tp -identifier :: Parser String-identifier = lexeme $ P.identifier tp--ident :: Parser String-ident = P.identifier tp- operator :: Parser String operator = try $ do     c <- P.opStart def@@ -213,7 +204,7 @@  keywordName :: Parser String keywordName = do-    n <- operator <|> (ident >>= \name -> char ':' >> return name)+    n <- try (ident >>= \name -> char ':' >> return name) <|> operator     whiteSpace1     return n @@ -352,7 +343,7 @@       -- escape code tables-    escMap          = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'"+    escMap          = zip "abfnrtv\\\"" "\a\b\f\n\r\t\v\\\""     asciiMap        = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)      ascii2codes     = ["BS","HT","LF","VT","FF","CR","SO","SI","EM",@@ -524,30 +515,8 @@             else return (c:cs))         <?> "identifier" -    isReservedName name-        = isReserved theReservedNames caseName-        where-          caseName      | P.caseSensitive languageDef  = name-                        | otherwise               = map toLower name  -    isReserved names name-        = scan names-        where-          scan []       = False-          scan (r:rs)   = case compare r name of-                            LT  -> scan rs-                            EQ  -> True-                            GT  -> False--    theReservedNames-        | P.caseSensitive languageDef  = sortedNames-        | otherwise               = map (map toLower) sortedNames-        where-          sortedNames   = sort (P.reservedNames languageDef)---     -----------------------------------------------------------     -- White space & symbols     -----------------------------------------------------------@@ -570,6 +539,31 @@         spacing         skipMany (try $ spacing >> newline)         spacing++isReservedName :: String -> Bool+isReservedName name = isReserved reservedNames caseName+  where+    caseName+        | P.caseSensitive def  = name+        | otherwise = map toLower name++    reservedNames+        | P.caseSensitive def = sortedNames+        | otherwise = map (map toLower) sortedNames+      where+        sortedNames = sort (P.reservedNames def)++isReserved :: [String] -> String -> Bool+isReserved names name+    = scan names+    where+        scan [] = False+        scan (r:rs) =+            case compare r name of+                LT  -> scan rs+                EQ  -> True+                GT  -> False+  whiteSpace :: Parser () whiteSpace = P.whiteSpace tp
− src/Atomo/Parser/Pattern.hs 
@@ -1,243 +0,0 @@-module Atomo.Parser.Pattern where--import Control.Monad (liftM)-import Text.Parsec--import Atomo.Debug-import Atomo.Parser-import Atomo.Parser.Base-import Atomo.Parser.Primitive-import Atomo.Types hiding (keyword)--pPattern :: Parser Pattern-pPattern = choice-    [ try ppNamed-    , try ppHeadTail-    , try ppMatch-    , ppList-    , ppString-    , ppParticle-    , ppExpr-    , ppAny-    , parens pPattern-    ]--pObjectPattern :: Parser Pattern-pObjectPattern = choice-    [ try ppNamedSensitive-    , try ppHeadTail-    , try ppObject-    , try ppMatch-    , ppList-    , ppString-    , ppParticle-    , ppExpr-    , ppAnySensitive-    , parens pObjectPattern-    ]--ppSet :: Parser Pattern-ppSet = try ppDefine <|> pPattern--ppMacro :: Parser Pattern-ppMacro = try ppMacroKeywords <|> ppMacroSingle--ppExpr :: Parser Pattern-ppExpr = do-    q <- pQuasiQuoted-    return (PExpr (eExpr q))--ppMacroSingle :: Parser Pattern-ppMacroSingle = do-    (t, v) <- choice-        [ 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-    [ ppExpr-    , try $ symbol "Define" >> return PEDefine-    , try $ symbol "Set" >> return PESet-    , try $ symbol "Dispatch" >> return PEDispatch-    , try $ symbol "Operator" >> return PEOperator-    , try $ symbol "Primitive" >> return PEPrimitive-    , try $ symbol "Block" >> return PEBlock-    , try $ symbol "List" >> return PEList-    , try $ symbol "Macro" >> return PEMacro-    , try $ symbol "Particle" >> return PEParticle-    , try $ symbol "Top" >> return PETop-    , try $ symbol "Quote" >> return PEQuote-    , try $ symbol "Unquote" >> return PEUnquote-    , ppAny-    , ppNamedMacro-    ]-  where-    ppNamedMacro = parens $ do-        n <- identifier-        delimit ":"-        p <- ppMacroRole-        return $ PNamed n p--ppDefine :: Parser Pattern-ppDefine = try ppKeywords <|> ppSingle--ppSingle :: Parser Pattern-ppSingle = do-    (t, v) <- choice-        [ try $ do-            t <- pNonExpr-            dump ("got pNonExpr", t)-            v <- identifier-            return (t, v)-        , try $ do-            ds <- pdCascade-            dump ("got pdCascade", ds)-            p <- cInit ds-            v <- cLast ds-            return (PObject p, v)-        , do-            v <- identifier-            return (PObject (ETop Nothing), v)-        ]--    dump ("single", t, v)--    return $ psingle v t-  where-    cLast (Dispatch _ (ESingle _ n _)) = return n-    cLast _ = fail "last target of dispatch chain is not a single messsage"--    cInit (Dispatch _ (ESingle _ _ x)) = return x-    cInit _ = fail "last target of dispatch chain is not a single messsage"--    -- patterns that would otherwise be mistaken for expressions-    -- if the pdCascade pattern were to grab them-    pNonExpr = choice-        [ try ppNamedSensitive-        , try ppHeadTail-        , try ppMatch-        , ppList-        , ppString-        , ppParticle-        , ppExpr-        , ppWildcard-        , parens pNonExpr-        ]---ppKeywords :: Parser Pattern-ppKeywords = keywords pkeyword (PObject (ETop Nothing)) pObjectPattern--ppNamed :: Parser Pattern-ppNamed = parens $ do-    name <- identifier-    delimit ":"-    p <- pPattern-    return $ PNamed name p--ppNamedSensitive :: Parser Pattern-ppNamedSensitive = parens $ do-    name <- lowIdentifier-    dump ("got ppNamedSensitive", name)-    delimit ":"-    p <- pObjectPattern-    dump ("finished ppNamedSensitive", name, p)-    return $ PNamed name p--ppObject :: Parser Pattern-ppObject = choice-    [ try $ parens ppHeadTail-    , do-        p <- name <|> parens pExpr-        return $ PObject p-    ]-  where-    name = do-        lookAhead capIdentifier-        pdCascade--ppAny :: Parser Pattern-ppAny = ppWildcard-    <|> ppNamedAny-  where-    ppNamedAny = do-        name <- identifier-        return (PNamed name PAny)--ppAnySensitive :: Parser Pattern-ppAnySensitive = ppWildcard-    <|> ppNamedAny-  where-    ppNamedAny = do-        name <- lowIdentifier-        return (PNamed name PAny)--ppWildcard :: Parser Pattern-ppWildcard = char '_' >> notFollowedBy identifier >> spacing >> return PAny--ppMatch :: Parser Pattern-ppMatch = do-    v <- pPrim-    return $ PMatch v--ppHeadTail :: Parser Pattern-ppHeadTail = parens subHT-  where-    subHT = do-        h <- pHead-        dot-        t <- try subHT <|> pPattern-        return $ PHeadTail h t-    pHead = choice-        [ try ppNamed-        , try ppMatch-        , ppList-        , ppString-        , ppParticle-        , ppAny-        , parens pHead-        ]--ppList :: Parser Pattern-ppList = brackets $ do-    ps <- commaSep pPattern-    return $ PList ps--ppString :: Parser Pattern-ppString = do-    cs <- stringLiteral-    return $ PList (map (PMatch . Char) cs)--ppParticle :: Parser Pattern-ppParticle = do-    char '@'-    try keywordParticle <|> singleParticle-  where-    singleParticle = liftM (PMatch . Particle . PMSingle) anyIdentifier--    keywordParticle = choice-        [ parens $ do-            ks <- many1 (keyword pPattern)-            let (ns, ps) = unzip ks-            return $ PPMKeyword ns (PAny:ps)-        , do-            o <- operator-            spacing-            return $ PPMKeyword [o] [PAny, PAny]-        , do-            names <- many1 (anyIdent >>= \n -> char ':' >> return n)-            spacing-            return $ PPMKeyword names (replicate (length names + 1) PAny) -        ]
− src/Atomo/Parser/Pattern.hs-boot 
@@ -1,9 +0,0 @@-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
@@ -8,9 +8,7 @@ import Atomo.Types as T  -pPrimitive :: Parser Expr-pPrimitive = tagged $ liftM (Primitive Nothing) pPrim-+-- | Parser for all primitive values. pPrim :: Parser Value pPrim = choice     [ pvChar@@ -21,24 +19,42 @@     , try pvBoolean     ] +-- | Character literal.+--+-- Examples: @$a@, @$ @, @$\\EOT@, @$\\n@ pvChar :: Parser Value pvChar = liftM Char charLiteral +-- | String literal.+--+-- Examples: @\"\"@, @\"foo\"@, @\"foo\\nbar\"@ pvString :: Parser Value pvString = liftM T.string stringLiteral +-- | Double literal.+--+-- Examples: @1.0@, @4.6e10@, @-1.0@ pvDouble :: Parser Value pvDouble = liftM Double float +-- | Integer literal.+--+-- Examples: @1@, @2@, @-1@, @-2@ pvInteger :: Parser Value pvInteger = liftM Integer integer +-- | Boolean literal.+--+-- Examples: @True@, @False@ pvBoolean :: Parser Value pvBoolean = liftM Boolean $ true <|> false   where     true = reserved "True" >> return True     false = reserved "False" >> return False +-- | Rational literal.+--+-- Examples: @1\/2@, @-1\/2@, @1\/-2@ pvRational :: Parser Value pvRational = do     n <- integer
+ src/Atomo/Pattern.hs view
@@ -0,0 +1,292 @@+module Atomo.Pattern+    ( bindings+    , bindings'+    , match+    , matchAll+    , toPattern+    , toDefinePattern+    , toRolePattern+    , toMacroPattern+    , toMacroRole+    ) where++import Control.Monad (forM, liftM)+import Data.Char (isUpper)+import Data.IORef (readIORef)+import Data.Maybe (isJust)+import System.IO.Unsafe+import qualified Data.Text as T+import qualified Data.Vector as V++import Atomo.Method+import Atomo.Types+++-- | Check if a value matches a given pattern.+--+-- Note that this is much faster when pure, so it uses unsafePerformIO+-- to check things like delegation matches.+match :: IDs -> Maybe ORef -> Pattern -> Value -> Bool+{-# NOINLINE match #-}+match ids (Just r) PThis (Reference y) =+    refMatch ids (Just r) r y+match ids (Just r) PThis y =+    match ids (Just r) (PMatch (Reference r)) (Reference (orefFrom ids y))+match _ _ (PMatch x) y | x == y = True+match ids r (PMatch x) (Reference y) =+    delegatesMatch ids r (PMatch x) y+match ids r (PMatch (Reference x)) y =+    match ids r (PMatch (Reference x)) (Reference (orefFrom ids y))+match ids r+    (PSingle { ppTarget = p })+    (Message (Single { mTarget = t })) =+    match ids r p t+match ids r+    (PKeyword { ppTargets = ps })+    (Message (Keyword { mTargets = ts })) =+    matchAll ids r ps ts+match ids r (PInstance p) (Reference o) = delegatesMatch ids r p o+match ids r (PInstance p) v = match ids r p v+match _ _ (PStrict (PMatch x)) v = x == v+match ids r (PStrict p) v = match ids r p v+match ids r (PNamed _ p) v = match ids r p v+match _ _ PAny _ = True+match ids r (PList ps) (List v) = matchAll ids r ps (V.toList v)+match ids r (PHeadTail hp tp) (List vs) =+    V.length vs > 0 && match ids r hp h && match ids r tp t+  where+    h = V.head vs+    t = List (V.tail vs)+match ids r (PHeadTail hp tp) (String t) | not (T.null t) =+    match ids r hp (Char (T.head t)) && match ids r tp (String (T.tail t))+match ids r (PPMKeyword ans aps) (Particle (PMKeyword bns mvs)) =+    ans == bns && matchParticle ids r aps mvs+match _ _ PEDispatch (Expression (Dispatch {})) = True+match _ _ PEOperator (Expression (Operator {})) = True+match _ _ PEPrimitive (Expression (Primitive {})) = True+match _ _ PEBlock (Expression (EBlock {})) = True+match _ _ PEList (Expression (EList {})) = True+match _ _ PEMacro (Expression (EMacro {})) = True+match _ _ PEParticle (Expression (EParticle {})) = True+match _ _ PETop (Expression (ETop {})) = True+match _ _ PEQuote (Expression (EQuote {})) = True+match _ _ PEUnquote (Expression (EUnquote {})) = True+match _ _ (PExpr a) (Expression b) = matchExpr 0 a b+match ids r p (Reference y) = delegatesMatch ids r p y+match _ _ _ _ = False++-- | Check if two references are equal or if one delegates to another.+refMatch :: IDs -> Maybe ORef -> ORef -> ORef -> Bool+refMatch ids r x y = x == y || delegatesMatch ids r (PMatch (Reference x)) y++-- | Check if an object's delegates match a pattern.+delegatesMatch :: IDs -> Maybe ORef -> Pattern -> ORef -> Bool+delegatesMatch ids mr p x =+    any (match ids mr p) (oDelegates (unsafePerformIO (readIORef x)))++-- | Match multiple patterns with multiple values.+matchAll :: IDs -> Maybe ORef -> [Pattern] -> [Value] -> Bool+matchAll _ _ [] [] = True+matchAll ids mr (p:ps) (v:vs) = match ids mr p v && matchAll ids mr ps vs+matchAll _ _ _ _ = False++matchEParticle :: Int -> [Maybe Expr] -> [Maybe Expr] -> Bool+matchEParticle _ [] [] = True+matchEParticle n (Just a:as) (Just b:bs) =+    matchExpr n a b && matchEParticle n as bs+matchEParticle n (Nothing:as) (Nothing:bs) = matchEParticle n as bs+matchEParticle _ _ _ = False++matchExpr :: Int -> Expr -> Expr -> Bool+matchExpr 0 (EUnquote {}) _ = True+matchExpr n (EUnquote { eExpr = a }) (EUnquote { eExpr = b }) =+    matchExpr (n - 1) a b+matchExpr n (Define { ePattern = ap', eExpr = a }) (Define { ePattern = bp, eExpr = b }) =+    ap' == bp && matchExpr n a b+matchExpr n (Set { ePattern = ap', eExpr = a }) (Set { ePattern = bp, eExpr = b }) =+    ap' == bp && matchExpr n a b+matchExpr n (Dispatch { eMessage = am@(EKeyword {}) }) (Dispatch { eMessage = bm@(EKeyword {}) }) =+    emID am == emID bm && length (emTargets am) == length (emTargets bm) && and (zipWith (matchExpr n) (emTargets am) (emTargets bm))+matchExpr n (Dispatch { eMessage = am@(ESingle {}) }) (Dispatch { eMessage = bm@(ESingle {}) }) =+    emID am == emID bm && matchExpr n (emTarget am) (emTarget bm)+matchExpr n (EBlock { eArguments = aps, eContents = as }) (EBlock { eArguments = bps, eContents = bs }) =+    aps == bps && length as == length bs && and (zipWith (matchExpr n) as bs)+matchExpr n (EList { eContents = as }) (EList { eContents = bs }) =+    length as == length bs && and (zipWith (matchExpr n) as bs)+matchExpr n (EMacro { ePattern = ap', eExpr = a }) (EMacro { ePattern = bp, eExpr = b }) =+    ap' == bp && matchExpr n a b+matchExpr n (EParticle { eParticle = ap' }) (EParticle { eParticle = bp }) =+    case (ap', bp) of+        (EPMKeyword ans ames, EPMKeyword bns bmes) ->+            ans == bns && matchEParticle n ames bmes+        _ -> ap' == bp+matchExpr n (EQuote { eExpr = a }) (EQuote { eExpr = b }) =+    matchExpr (n + 1) a b+matchExpr _ a b = a == b++matchParticle :: IDs -> Maybe ORef -> [Pattern] -> [Maybe Value] -> Bool+matchParticle _ _ [] [] = True+matchParticle ids mr (PAny:ps) (Nothing:mvs) = matchParticle ids mr ps mvs+matchParticle ids mr (PNamed _ p:ps) mvs = matchParticle ids mr (p:ps) mvs+matchParticle ids mr (p:ps) (Just v:mvs) =+    match ids mr p v && matchParticle ids mr ps mvs+matchParticle _ _ _ _ = False++-- | Given a pattern and a message, return the bindings from the pattern.+bindings :: Pattern -> Message -> MethodMap+bindings (PSingle { ppTarget = p }) (Single { mTarget = t }) =+    toMethods (bindings' p t)+bindings (PKeyword { ppTargets = ps }) (Keyword { mTargets = ts }) =+    toMethods $ concat (zipWith bindings' ps ts)+bindings p m = error $ "impossible: bindings on " ++ show (p, m)++-- | Given a pattern and avalue, return the bindings as a list of pairs.+bindings' :: Pattern -> Value -> [(Pattern, Value)]+bindings' (PNamed n p) v = (psingle n PThis, v) : bindings' p v+bindings' (PPMKeyword _ ps) (Particle (PMKeyword _ mvs)) =+    concatMap (\(p, Just v) -> bindings' p v)+    $ filter (isJust . snd)+    $ zip ps mvs+bindings' (PList ps) (List vs) = concat (zipWith bindings' ps (V.toList vs))+bindings' (PHeadTail hp tp) (List vs) =+    bindings' hp h ++ bindings' tp t+  where+    h = V.head vs+    t = List (V.tail vs)+bindings' (PHeadTail hp tp) (String t) | not (T.null t) =+    bindings' hp (Char (T.head t)) ++ bindings' tp (String (T.tail t))+bindings' (PExpr a) (Expression b) = exprBindings 0 a b+bindings' (PInstance p) (Reference r) =+    concatMap (bindings' p) $ oDelegates (unsafePerformIO (readIORef r))+bindings' (PInstance p) v = bindings' p v+bindings' (PStrict p) v = bindings' p v+bindings' p (Reference r) =+    concatMap (bindings' p) $ oDelegates (unsafePerformIO (readIORef r))+bindings' _ _ = []+++exprBindings :: Int -> Expr -> Expr -> [(Pattern, Value)]+exprBindings 0 (EUnquote { eExpr = Dispatch { eMessage = ESingle { emName = n } } }) e =+    [(psingle n PThis, Expression e)]+exprBindings n (EUnquote { eExpr = a }) (EUnquote { eExpr = b }) =+    exprBindings (n - 1) a b+exprBindings n (Define { eExpr = a }) (Define { eExpr = b }) =+    exprBindings n a b+exprBindings n (Set { eExpr = a }) (Set { eExpr = b }) =+    exprBindings n a b+exprBindings n (Dispatch { eMessage = am@(EKeyword {}) }) (Dispatch { eMessage = bm@(EKeyword {}) }) =+    concat $ zipWith (exprBindings n) (emTargets am) (emTargets bm)+exprBindings n (Dispatch { eMessage = am@(ESingle {}) }) (Dispatch { eMessage = bm@(ESingle {}) }) =+    exprBindings n (emTarget am) (emTarget bm)+exprBindings n (EBlock { eContents = as }) (EBlock { eContents = bs }) =+    concat $ zipWith (exprBindings n) as bs+exprBindings n (EList { eContents = as }) (EList { eContents = bs }) =+    concat $ zipWith (exprBindings n) as bs+exprBindings n (EMacro { eExpr = a }) (EMacro { eExpr = b }) =+    exprBindings n a b+exprBindings n (EParticle { eParticle = ap' }) (EParticle { eParticle = bp }) =+    case (ap', bp) of+        (EPMKeyword _ ames, EPMKeyword _ bmes) ->+            concatMap (\(Just a, Just b) -> exprBindings n a b)+            $ filter (isJust . fst)+            $ zip ames bmes+        _ -> []+exprBindings n (EQuote { eExpr = a }) (EQuote { eExpr = b }) =+    exprBindings (n + 1) a b+exprBindings _ _ _ = []++-- | Convert an expression to the pattern match it represents.+toPattern :: Expr -> Maybe Pattern+toPattern (Dispatch { eMessage = EKeyword { emNames = ["."], emTargets = [h, t] } }) = do+    hp <- toPattern h+    tp <- toPattern t+    return (PHeadTail hp tp)+toPattern (Dispatch { eMessage = EKeyword { emNames = ["->"], emTargets = [ETop {}, o] } }) = do+    liftM PInstance (toPattern o)+toPattern (Dispatch { eMessage = EKeyword { emNames = ["=="], emTargets = [ETop {}, o] } }) = do+    liftM PStrict (toPattern o)+toPattern (Dispatch { eMessage = EKeyword { emNames = [n], emTargets = [ETop {}, x] } }) = do+    p <- toPattern x+    return (PNamed n p)+toPattern (Dispatch { eMessage = EKeyword { emNames = ns, emTargets = ts } }) =+    return (pkeyword ns (map PObject ts))+toPattern (Dispatch { eMessage = ESingle { emName = "_" } }) =+    return PAny+toPattern (Dispatch { eMessage = ESingle { emName = n, emTarget = ETop {} } }) =+    return (PNamed n PAny)+toPattern (Dispatch { eMessage = ESingle { emTarget = d@(Dispatch {}), emName = n } }) =+    return (psingle n (PObject d))+toPattern (EList { eContents = es }) = do+    ps <- mapM toPattern es+    return (PList ps)+toPattern (EParticle { eParticle = EPMSingle n }) =+    return (PMatch (Particle (PMSingle n)))+toPattern (EParticle { eParticle = EPMKeyword ns mes }) = do+    ps <- forM mes $ \me ->+        case me of+            Nothing -> return PAny+            Just e -> toPattern e++    return (PPMKeyword ns ps)+toPattern (EQuote { eExpr = e }) = return (PExpr e)+toPattern (Primitive { eValue = v }) =+    return (PMatch v)+toPattern (ETop {}) =+    return (PObject (ETop Nothing))+toPattern b@(EBlock {}) =+    return (PObject (Dispatch Nothing (esingle "call" b)))+toPattern _ = Nothing++-- | Convert an expression into a definition's message pattern.+toDefinePattern :: Expr -> Maybe Pattern+toDefinePattern (Dispatch { eMessage = ESingle { emName = n, emTarget = t } }) = do+    p <- toRolePattern t+    return (psingle n p)+toDefinePattern (Dispatch { eMessage = EKeyword { emNames = ns, emTargets = ts } }) = do+    ps <- mapM toRolePattern ts+    return (pkeyword ns ps)+toDefinePattern _ = Nothing++-- | Convert an expression into a pattern-match for use as a message's role.+toRolePattern :: Expr -> Maybe Pattern+toRolePattern (Dispatch { eMessage = EKeyword { emNames = ["->"], emTargets = [ETop {}, o] } }) = do+    liftM PInstance (toRolePattern o)+toRolePattern (Dispatch { eMessage = EKeyword { emNames = ["=="], emTargets = [ETop {}, o] } }) = do+    liftM PStrict (toRolePattern o)+toRolePattern (Dispatch { eMessage = EKeyword { emNames = [n], emTargets = [ETop {}, x] } }) = do+    p <- toRolePattern x+    return (PNamed n p)+toRolePattern d@(Dispatch { eMessage = ESingle { emTarget = ETop {}, emName = n } })+    | isUpper (head n) = return (PObject d)+    | otherwise = return (PNamed n PAny)+toRolePattern d@(Dispatch { eMessage = ESingle { emTarget = (Dispatch {}) } }) =+    return (PObject d)+toRolePattern p = toPattern p++-- | Convert an expression into a macro's message pattern.+toMacroPattern :: Expr -> Maybe Pattern+toMacroPattern (Dispatch { eMessage = ESingle { emName = n, emTarget = t } }) = do+    p <- toMacroRole t+    return (psingle n p)+toMacroPattern (Dispatch { eMessage = EKeyword { emNames = ns, emTargets = ts } }) = do+    ps <- mapM toMacroRole ts+    return (pkeyword ns ps)+toMacroPattern _ = Nothing++-- | Convert an expression into a pattern-match for use as a macro's role.+toMacroRole :: Expr -> Maybe Pattern+toMacroRole (Dispatch _ (ESingle _ "Dispatch" _)) = Just PEDispatch+toMacroRole (Dispatch _ (ESingle _ "Operator" _)) = Just PEOperator+toMacroRole (Dispatch _ (ESingle _ "Primitive" _)) = Just PEPrimitive+toMacroRole (Dispatch _ (ESingle _ "Block" _)) = Just PEBlock+toMacroRole (Dispatch _ (ESingle _ "List" _)) = Just PEList+toMacroRole (Dispatch _ (ESingle _ "Macro" _)) = Just PEMacro+toMacroRole (Dispatch _ (ESingle _ "Particle" _)) = Just PEParticle+toMacroRole (Dispatch _ (ESingle _ "Top" _)) = Just PETop+toMacroRole (Dispatch _ (ESingle _ "Quote" _)) = Just PEQuote+toMacroRole (Dispatch _ (ESingle _ "Unquote" _)) = Just PEUnquote+toMacroRole (Dispatch { eMessage = EKeyword { emNames = [n], emTargets = [ETop {}, x] } }) = do+    p <- toMacroRole x+    return (PNamed n p)+toMacroRole (ETop {}) = Just PAny+toMacroRole p = toPattern p
src/Atomo/Pretty.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE TypeSynonymInstances #-}-module Atomo.Pretty (Pretty(..), prettyStack) where+module Atomo.Pretty (Pretty(pretty)) where +import Data.Char (isUpper) import Data.IORef import Data.Maybe (isNothing) import Data.Ratio@@ -23,6 +24,8 @@     | CList  class Pretty a where+    -- | Pretty-print a value into a Doc. Typically this should be parseable+    -- back into the original value, or just a nice user-friendly output form.     pretty :: a -> Doc     prettyFrom :: Context -> a -> Doc @@ -32,7 +35,8 @@ instance Pretty Value where     prettyFrom _ (Block _ ps es)         | null ps = braces exprs-        | otherwise = braces $ sep (map (prettyFrom CArgs) ps) <+> char '|' <+> exprs+        | otherwise = braces $+            sep (map (prettyFrom CArgs) ps) <+> char '|' <+> exprs       where         exprs = sep . punctuate (text ";") $ map pretty es     prettyFrom _ (Boolean b) = text $ show b@@ -47,14 +51,16 @@       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 (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 _ (Rational r) =+        integer (numerator r) <> char '/' <> integer (denominator r)     prettyFrom _ (Reference _) = internal "object" empty     prettyFrom _ (String s) = text (show s) @@ -80,7 +86,7 @@         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+            text "macro" <+> parens (pretty p) <++> prettyFrom CDefine e  instance Pretty Message where     prettyFrom _ (Single _ n t) = prettyFrom CSingle t <+> text n@@ -115,7 +121,24 @@     prettyFrom _ (PMatch v) = prettyFrom CPattern v     prettyFrom _ (PNamed n PAny) = text n     prettyFrom _ (PNamed n p) = parens $ text n <> colon <+> pretty p-    prettyFrom _ (PObject e) = pretty e+    prettyFrom _ (PObject e@(Dispatch { eMessage = msg }))+        | capitalized msg = pretty e+        | isParticular msg = pretty block+      where+        capitalized (ESingle { emName = n, emTarget = ETop {} }) =+            isUpper (head n)+        capitalized (ESingle { emTarget = Dispatch { eMessage = t@(ESingle {}) } }) =+            capitalized t+        capitalized _ = False++        isParticular (ESingle { emName = "call", emTarget = EBlock {} }) =+            True+        isParticular _ = False++        block = emTarget msg+    prettyFrom _ (PObject e) = parens $ pretty e+    prettyFrom _ (PInstance p) = parens $ text "->" <+> pretty p+    prettyFrom _ (PStrict p) = parens $ text "==" <+> pretty p     prettyFrom _ (PPMKeyword ns ps)         | all isAny ps = char '@' <> text (concatMap keyword ns)         | isAny (head ps) =@@ -129,8 +152,6 @@     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"@@ -146,13 +167,15 @@   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+    prettyFrom _ (Define _ p v) =+        prettyFrom CDefine p <+> text ":=" <++> prettyFrom CDefine v+    prettyFrom _ (Set _ p v)    =+        prettyFrom CDefine p <+> text "=" <++> prettyFrom CDefine v     prettyFrom CKeyword (Dispatch _ m@(EKeyword {})) = parens $ pretty m     prettyFrom CSingle (Dispatch _ m@(EKeyword {})) = parens $ pretty m     prettyFrom c (Dispatch _ m) = prettyFrom c m     prettyFrom _ (Operator _ ns a i) =-        text "operator" <+> assoc a <+> integer i <+> sep (punctuate comma (map text ns))+        text "operator" <+> assoc a <+> integer i <+> sep (map text ns)       where         assoc ALeft = text "left"         assoc ARight = text "right"@@ -167,11 +190,13 @@     prettyFrom _ (EVM { ePretty = Just d }) = d     prettyFrom _ (EList _ es) =         brackets . sep . punctuate comma $ map (prettyFrom CList) es-    prettyFrom _ (EMacro _ p v) = text "macro" <+> prettyFrom CDefine p <+> text ":=" <++> prettyFrom CDefine v+    prettyFrom _ (EMacro _ p e) =+        text "macro" <+> parens (pretty p) <++> pretty e+    prettyFrom _ (EForMacro { eExpr = e }) = text "for-macro" <+> pretty e     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)+    prettyFrom _ (ETop {}) = text "this"+    prettyFrom c (EQuote _ e) = char '`' <> prettySpacedExpr c e+    prettyFrom c (EUnquote _ e) = char '~' <> prettySpacedExpr c e   instance Pretty EMessage where@@ -202,13 +227,6 @@   -prettyStack :: Expr -> Doc-prettyStack (EVM {}) = text "... internal ..."-prettyStack e =-    case eLocation e of-        Nothing -> text "(...)" $$ nest 2 (pretty e)-        Just s -> text (show s) $$ nest 2 (pretty e)- internal :: String -> Doc -> Doc internal n d = char '<' <> text n <+> d <> char '>' @@ -240,6 +258,19 @@ keyword k     | isOperator k = k     | otherwise    = k ++ ":"++prettySpacedExpr :: Context -> Expr -> Doc+prettySpacedExpr c e+    | needsParens e = parens (prettyFrom c e)+    | otherwise = prettyFrom c e+  where+    needsParens (Define {}) = True+    needsParens (Set {}) = True+    needsParens (Dispatch { eMessage = EKeyword {} }) = True+    needsParens (Dispatch { eMessage = ESingle { emTarget = ETop {} } }) = False+    needsParens (Dispatch { eMessage = ESingle {} }) = True+    needsParens _ = False+  infixr 4 <++>, <+++>
src/Atomo/PrettyVM.hs view
@@ -5,7 +5,6 @@ import Atomo.Types  --- | pretty-print by sending \@show to the object+-- | Pretty-print a value by sending @show@ to it. prettyVM :: Value -> VM String prettyVM = liftM (fromText . fromString) . dispatch . single "show"-
src/Atomo/QuasiQuotes.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS -fno-warn-name-shadowing #-} module Atomo.QuasiQuotes     ( p@@ -5,58 +6,55 @@     , es     ) where -import "monads-fd" Control.Monad.State-import Data.IORef+import "monads-fd" Control.Monad.State hiding (lift)+import Data.Maybe (fromJust) 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.Helpers (fromHaskell') import Atomo.Parser-import Atomo.Parser.Pattern import Atomo.Parser.Base+import Atomo.Parser.Expr+import Atomo.Pattern (toDefinePattern) import Atomo.Types -qqEnv :: IORef Env-qqEnv = unsafePerformIO $ do-    (_, e) <- runVM (initCore >> return (particle "ok")) startEnv-    newIORef e +qqEnv :: Env+qqEnv = snd $ unsafePerformIO $+    runVM (initCore >> return (particle "ok")) startEnv++-- | Pattern quasi-quoter. p :: QuasiQuoter p = QuasiQuoter quotePatternExp undefined +-- | Single expression quasi-quoter. e :: QuasiQuoter e = QuasiQuoter quoteExprExp undefined +-- | Quasi-quoter for multiple expressions (a block of code). es :: QuasiQuoter es = QuasiQuoter quoteExprsExp undefined -withLocation :: (String -> (String, Int, Int) -> Q a) -> (a -> Exp) -> String -> TH.ExpQ+withLocation :: (String -> (String, Int, Int) -> a) -> (a -> Q Exp) -> String -> TH.ExpQ withLocation p c s = do     l <- TH.location-    r <- p s+    c $ 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 :: Typeable a => Parser a -> String -> (String, Int, Int) -> a parsing p s (file, line, col) =-    -- OH GOD!-    -- OH GOD! NO!-    -- WHYYYYYYYYYYYYYYYYYYYYYY-    case unsafePerformIO (runWith go (unsafePerformIO (readIORef qqEnv))) of-        x -> return (fromHaskell' "a" x)+    -- here be dragons+    fromHaskell' "a" $ unsafePerformIO (runWith go (qqEnv))   where-    go = do-        r <- liftM haskell $ continue pp "<qq>" s-        get >>= liftIO . writeIORef qqEnv-        return r+    go = liftM haskell $ continue pp "<qq>" s      pp = do         pos <- getPosition@@ -71,115 +69,10 @@         return e  quotePatternExp :: String -> TH.ExpQ-quotePatternExp = withLocation (parsing ppDefine) patternToExp+quotePatternExp = withLocation (parsing (liftM (fromJust . toDefinePattern) pExpr)) lift  quoteExprExp :: String -> TH.ExpQ-quoteExprExp = withLocation (parsing pExpr) exprToExp+quoteExprExp = withLocation (parsing pExpr) lift  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")-patternToExp (PExpr e) = AppE (ConE (mkName "PExpr")) (exprToExp e)+quoteExprsExp = withLocation (parsing (wsBlock pExpr)) (fmap ListE . mapM lift)
src/Atomo/Run.hs view
@@ -5,8 +5,8 @@  import Atomo.Core import Atomo.Environment+import Atomo.Helpers (here) import Atomo.Load-import Atomo.Spawn (go) import Atomo.Types import qualified Atomo.Kernel as Kernel @@ -17,18 +17,17 @@ -- Execution ---------------------------------------------------------------- ----------------------------------------------------------------------------- --- | execute an action in a new thread, initializing the environment and--- printing a traceback on error+-- | Execute an action in a new thread, initializing the environment first. exec :: VM Value -> IO () exec x = execWith (initEnv >> x) startEnv --- | execute an action in a new thread, printing a traceback on error+-- | Execute an action in a new thread. execWith :: VM Value -> Env -> IO () execWith x e = do     haltChan <- newChan      forkIO $ do-        runWith (go x >> gets halt >>= liftIO >> return (particle "ok")) e+        runWith (x >> gets halt >>= liftIO >> return (particle "ok")) e             { halt = writeChan haltChan () >> myThreadId >>= killThread             } @@ -36,15 +35,16 @@      readChan haltChan --- | execute x, initializing the environment with initEnv+-- | Execute x, initializing the environment first. run :: VM Value -> IO Value run x = runWith (initEnv >> x) startEnv --- | set up the primitive objects, etc.+-- | Set up the primitive objects, and load up the kernel and prelude. initEnv :: VM () {-# INLINE initEnv #-} initEnv = initCore >> Kernel.load >> loadPrelude +-- | Load all of the prelude and load the ecosystem. loadPrelude :: VM () loadPrelude = do     forM_ preludes $ \p ->
src/Atomo/Spawn.hs view
@@ -6,17 +6,13 @@ import Atomo.Types  --- | spawn a process to execute x. returns the Process.+-- | Spawn a process to execute x. Returns the Process value. 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 })+        runWith (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 = x --catchError x (\e -> printError e >> return (particle "ok"))
src/Atomo/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances #-}+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeSynonymInstances #-} module Atomo.Types where  import Control.Concurrent (ThreadId)@@ -8,7 +8,6 @@ import Data.Dynamic import Data.Hashable (hash) import Data.List (nub)-import Data.Maybe (fromMaybe) import Data.IORef import Text.Parsec (ParseError, SourcePos) import Text.PrettyPrint (Doc)@@ -16,60 +15,111 @@ import qualified Data.Text as T import qualified Data.Vector as V import qualified Language.Haskell.Interpreter as H+import qualified Language.Haskell.TH.Syntax as S ++-- | The Atomo VM. A Continuation monad wrapping a State monad. type VM = ContT Value (StateT Env IO) +-- | All values usable in Atomo. data Value+    -- | A block of expressions, bound to a context and with optional arguments.     = Block !Value [Pattern] [Expr]++    -- | A boolean value.     | Boolean { fromBoolean :: {-# UNPACK #-} !Bool }++    -- | A character value.     | Char { fromChar :: {-# UNPACK #-} !Char }++    -- | A continuation reference.     | Continuation { fromContinuation :: Continuation }++    -- | A double value.     | Double { fromDouble :: {-# UNPACK #-} !Double }++    -- | An expression value.     | Expression { fromExpression :: Expr }++    -- | A dynamically-typed Haskell value.     | Haskell Dynamic++    -- | An Integer value.     | Integer { fromInteger :: !Integer }++    -- | A vector of Values.     | List VVector++    -- | A message value.     | Message { fromMessage :: Message }++    -- | A method value.     | Method { fromMethod :: Method }++    -- | A particle value.     | Particle { fromParticle :: Particle }++    -- | A process; a communications channel and the thread's ID.     | Process Channel ThreadId++    -- | A pattern value.     | Pattern { fromPattern :: Pattern }++    -- | A rational value.     | Rational Rational++    -- | An object reference.     | Reference         { rORef :: {-# UNPACK #-} !ORef         }++    -- | A string value; Data.Text.Text.     | String { fromString :: !T.Text }     deriving (Show, Typeable) +-- | A pure object. data Object =     Object-        { oDelegates :: !Delegates-        , oMethods :: !(MethodMap, MethodMap) -- singles, keywords+        { -- | The object's delegates list.+          oDelegates :: !Delegates++          -- | A pair of (single, keyword) methods.+        , oMethods :: !(MethodMap, MethodMap)         }     deriving (Show, Typeable) +-- | Methods, slot, and macro methods. data Method+    -- | Responds to a message by evaluating an expression in the given context.     = Responder         { mPattern :: !Pattern         , mContext :: !Value         , mExpr :: !Expr         }++    -- | Responds to a macro message by evaluating an expression.     | Macro         { mPattern :: !Pattern         , mExpr :: !Expr         }++    -- | Responds to a message by returning a value.     | Slot         { mPattern :: !Pattern         , mValue :: !Value         }     deriving (Eq, Show, Typeable) +-- | Messages sent to objects. data Message+    -- | A keyword-delimited message with multiple targets.     = Keyword         { mID :: !Int         , mNames :: [String]         , mTargets :: [Value]         }++    -- | A single message sent to one target.     | Single         { mID :: !Int         , mName :: String@@ -77,11 +127,16 @@         }     deriving (Eq, Show, Typeable) +-- | Partial messages. data Particle+    -- | A single message with no target.     = PMSingle String++    -- | A keyword message with many optional targets.     | PMKeyword [String] [Maybe Value]     deriving (Eq, Show, Typeable) +-- | Shortcut error values. data AtomoError     = Error Value     | ParseError ParseError@@ -96,7 +151,7 @@     | DynamicNeeded String     deriving (Show, Typeable) --- pattern-matches+-- | Pattern-matching. data Pattern     = PAny     | PHeadTail Pattern Pattern@@ -107,6 +162,8 @@         }     | PList [Pattern]     | PMatch Value+    | PInstance Pattern+    | PStrict Pattern     | PNamed String Pattern     | PObject Expr     | PPMKeyword [String] [Pattern]@@ -118,8 +175,6 @@     | PThis      -- expression types, used in macros-    | PEDefine-    | PESet     | PEDispatch     | PEOperator     | PEPrimitive@@ -134,7 +189,7 @@     | PExpr Expr     deriving (Show, Typeable) --- expressions+-- | Expressions; the nodes in a syntax tree. data Expr     = Define         { eLocation :: Maybe SourcePos@@ -174,6 +229,10 @@         , ePattern :: Pattern         , eExpr :: Expr         }+    | EForMacro+        { eLocation :: Maybe SourcePos+        , eExpr :: Expr+        }     | EParticle         { eLocation :: Maybe SourcePos         , eParticle :: EParticle@@ -196,6 +255,7 @@         }     deriving (Show, Typeable) +-- | An unevaluated message dispatch. data EMessage     = EKeyword         { emID :: !Int@@ -209,34 +269,51 @@         }     deriving (Eq, Show, Typeable) +-- | An unevaluated particle. data EParticle     = EPMSingle String     | EPMKeyword [String] [Maybe Expr]     deriving (Eq, Show, Typeable) --- the evaluation environment+-- | Atomo's VM state. data Env =     Env-        { top :: Value+        { -- | The current toplevel object.+          top :: Value++          -- | A record of objects representing the primitive values.         , primitives :: IDs++          -- | This process's communications channel.         , channel :: Channel++          -- | Function to call which will shut down the entire VM when called+          -- from any thread.         , halt :: IO ()++          -- | Paths to search for files.         , loadPath :: [FilePath]++          -- | Files aready loaded.         , loaded :: [FilePath]++          -- | The last N expressions evaluated up to the current error.         , stack :: [Expr]++          -- | The parser's state, passed around when a parser action needs to+          -- be run.         , parserState :: ParserState         }     deriving Typeable --- operator associativity+-- | Operator associativity. data Assoc = ALeft | ARight     deriving (Eq, Show, Typeable) --- a giant record of the objects for each primitive value+-- | A giant record of the objects for each primitive value. data IDs =     IDs-        { idMatch :: ORef -- used in dispatch to refer to the object currently being searched-        , idObject :: ORef -- root object+        { idObject :: ORef         , idBlock :: ORef         , idBoolean :: ORef         , idChar :: ORef@@ -256,28 +333,45 @@         }     deriving (Show, Typeable) -+-- | State underlying the parser, and saved in the VM. data ParserState =     ParserState-        { psOperators :: Operators+        { -- | Operator precedence and associativity.+          psOperators :: Operators++          -- | All defined macros; (single macros, keyword macros).         , psMacros :: (MethodMap, MethodMap)++          -- | Are we parsing in a quasiquote?+        , psInQuote :: Bool++          -- | The number of macros we've expanded.+        , psClock :: Integer         }     deriving (Show, Typeable) -startParserState :: ParserState-startParserState = ParserState [] (M.empty, M.empty)+-- | A map of operators to their associativity and precedence.+type Operators = [(String, (Assoc, Integer))] --- helper synonyms-type Operators = [(String, (Assoc, Integer))] -- name -> assoc, precedence+-- | The list of values an object delegates to. type Delegates = [Value]++-- | A channel for sending values through to processes. type Channel = Chan Value++-- | A selector-indexed and precision-sorted map of methods. type MethodMap = M.IntMap [Method]++-- | A reference to an object. type ORef = IORef Object++-- | A vector containing values. type VVector = V.Vector Value++-- | A reference to a continuation function. type Continuation = IORef (Value -> VM Value)  --- a basic Eq instance instance Eq Value where     (==) (Block at aps aes) (Block bt bps bes) =         at == bt && aps == bps && aes == bes@@ -353,13 +447,92 @@     typeOf _ = mkTyConApp (mkTyCon "VM") [typeOf ()]  +instance S.Lift Expr where+    lift (Define _ p e) = [| Define Nothing p e |]+    lift (Set _ p e) = [| Set Nothing p e |]+    lift (Dispatch _ m) = [| Dispatch Nothing m |]+    lift (Operator _ ns a p) = [| Operator Nothing ns a p |]+    lift (Primitive _ v) = [| Primitive Nothing v |]+    lift (EBlock _ as es) = [| EBlock Nothing as es |]+    lift (EVM {}) = error "cannot lift EVM"+    lift (EList _ es) = [| EList Nothing es |]+    lift (ETop _) = [| ETop Nothing |]+    lift (EParticle _ p) = [| EParticle Nothing p |]+    lift (EMacro _ p e) = [| EMacro Nothing p e |]+    lift (EForMacro _ e) = [| EForMacro Nothing e |]+    lift (EQuote _ e) = [| EQuote Nothing e |]+    lift (EUnquote _ e) = [| EUnquote Nothing e |]++instance S.Lift Assoc where+    lift ALeft = [| ALeft |]+    lift ARight = [| ARight |]++instance S.Lift Message where+    lift (Keyword i ns vs) = [| Keyword i ns vs |]+    lift (Single i n v) = [| Single i n v |]++instance S.Lift Particle where+    lift (PMSingle n) = [| PMSingle n |]+    lift (PMKeyword ns vs) = [| PMKeyword ns vs |]++instance S.Lift EMessage where+    lift (EKeyword i ns es) = [| EKeyword i ns es |]+    lift (ESingle i n e) = [| ESingle i n e |]++instance S.Lift EParticle where+    lift (EPMSingle n) = [| EPMSingle n |]+    lift (EPMKeyword ns es) = [| EPMKeyword ns es |]++instance S.Lift Value where+    lift (Block s as es) = [| Block s as es |]+    lift (Boolean b) = [| Boolean b |]+    lift (Char c) = [| Char c |]+    lift (Double d) = [| Double $(return $ S.LitE (S.RationalL (toRational d))) |]+    lift (Expression e) = [| Expression e |]+    lift (Integer i) = [| Integer i |]+    lift (Message m) = [| Message m |]+    lift (Particle p) = [| Particle p |]+    lift (Pattern p) = [| Pattern p |]+    lift (String s) = [| String (T.pack $(return $ S.LitE (S.StringL (T.unpack s)))) |]+    lift v = error $ "no lift for: " ++ show v++instance S.Lift Pattern where+    lift PAny = [| PAny |]+    lift (PHeadTail h t) = [| PHeadTail h t |]+    lift (PKeyword i ns ts) = [| PKeyword i ns ts |]+    lift (PList ps) = [| PList ps |]+    lift (PMatch v) = [| PMatch v |]+    lift (PNamed n p) = [| PNamed n p |]+    lift (PObject e) = [| PObject e |]+    lift (PPMKeyword ns ts) = [| PPMKeyword ns ts |]+    lift (PSingle i n t) = [| PSingle i n t |]+    lift PThis = [| PThis |]+    lift PEDispatch = [| PEDispatch |]+    lift PEOperator = [| PEOperator |]+    lift PEPrimitive = [| PEPrimitive |]+    lift PEBlock = [| PEBlock |]+    lift PEList = [| PEList |]+    lift PEMacro = [| PEMacro |]+    lift PEParticle = [| PEParticle |]+    lift PETop = [| PETop |]+    lift PEQuote = [| PEQuote |]+    lift PEUnquote = [| PEUnquote |]+    lift (PExpr e) = [| PExpr e |]+    lift (PInstance p) = [| PInstance p |]+    lift (PStrict p) = [| PStrict p |]+++-- | Initial "empty" parser state.+startParserState :: ParserState+startParserState = ParserState [] (M.empty, M.empty) False 0++-- | Initial "empty" environment state. startEnv :: Env startEnv = Env     { top = error "top object not set"     , primitives =         IDs-            { idMatch = error "idMatch not set"-            , idObject = error "idObject not set"+            { idObject = error "idObject not set"             , idBlock = error "idBlock not set"             , idBoolean = error "idBoolean not set"             , idChar = error "idChar not set"@@ -385,11 +558,11 @@     , parserState = startParserState     } --- | evaluate x with e as the environment+-- | Evaluate x with e as the environment. runWith :: VM Value -> Env -> IO Value runWith x = evalStateT (runContT x return) --- | evaluate x with e as the environment+-- | Evaluate x with e as the environment. runVM :: VM Value -> Env -> IO (Value, Env) runVM x = runStateT (runContT x return) @@ -398,153 +571,162 @@ -- Helpers ------------------------------------------------------------------ ----------------------------------------------------------------------------- +-- | Create a single particle with a given name. particle :: String -> Value {-# INLINE particle #-} particle = Particle . PMSingle +-- | Create a keyword particle with a given name and optional values. keyParticle :: [String] -> [Maybe Value] -> Value {-# INLINE keyParticle #-} keyParticle ns vs = Particle $ PMKeyword ns vs +-- | Create a keyword particle with no first role and the given values. keyParticleN :: [String] -> [Value] -> Value {-# INLINE keyParticleN #-} keyParticleN ns vs = keyParticle ns (Nothing:map Just vs) +-- | Convert a String into a Value. string :: String -> Value {-# INLINE string #-} string = String . T.pack +-- | Convert a Typeable value into a Haskell Value. haskell :: Typeable a => a -> Value {-# INLINE haskell #-} haskell = Haskell . toDyn +-- | Convert a list of values into a List Value. list :: [Value] -> Value+{-# INLINE list #-} list = List . V.fromList +-- | Convert a Text string into a String. fromText :: T.Text -> String+{-# INLINE fromText #-} fromText = T.unpack +-- | Convert a List Value into a list of Values. fromList :: Value -> [Value] fromList (List vr) = V.toList vr fromList v = error $ "no fromList for: " ++ show v +-- | Create a single message with a given name and target. single :: String -> Value -> Message {-# INLINE single #-} single n = Single (hash n) n +-- | Create a keyword message with a given name and targets. keyword :: [String] -> [Value] -> Message {-# INLINE keyword #-} keyword ns = Keyword (hash ns) ns +-- | Create a single message pattern with a given name and target pattern. psingle :: String -> Pattern -> Pattern {-# INLINE psingle #-} psingle n = PSingle (hash n) n +-- | Create a keyword message pattern with a given name and target patterns. pkeyword :: [String] -> [Pattern] -> Pattern {-# INLINE pkeyword #-} pkeyword ns = PKeyword (hash ns) ns +-- | Create a single message expression with a given name and target expression. esingle :: String -> Expr -> EMessage {-# INLINE esingle #-} esingle n = ESingle (hash n) n +-- | Create a keyword message expression with a given name and target expressions. ekeyword :: [String] -> [Expr] -> EMessage {-# INLINE ekeyword #-} ekeyword ns = EKeyword (hash ns) ns --- | Fill in the empty values of a particle. The number of values missing--- is expected to be equal to the number of values provided.-completeKP :: [Maybe Value] -> [Value] -> [Value]-completeKP [] [] = []-completeKP (Nothing:mvs') (v:vs') = v : completeKP mvs' vs'-completeKP (Just v:mvs') vs' = v : completeKP mvs' vs'-completeKP mvs' vs' = error $ "impossible: completeKP on " ++ show (mvs', vs')---- | Is a value a Block?+-- | Is a value a `Block'? isBlock :: Value -> Bool isBlock (Block _ _ _) = True isBlock _ = False --- | Is a value a Boolean?+-- | Is a value a `Boolean'? isBoolean :: Value -> Bool isBoolean (Boolean _) = True isBoolean _ = False --- | Is a value a Char?+-- | Is a value a `Char'? isChar :: Value -> Bool isChar (Char _) = True isChar _ = False --- | Is a value a Continuation?+-- | Is a value a `Continuation'? isContinuation :: Value -> Bool isContinuation (Continuation _) = True isContinuation _ = False --- | Is a value a Double?+-- | Is a value a `Double'? isDouble :: Value -> Bool isDouble (Double _) = True isDouble _ = False --- | Is a value an Expression?+-- | Is a value an `Expression'? isExpression :: Value -> Bool isExpression (Expression _) = True isExpression _ = False --- | Is a value a Haskell value?+-- | Is a value a `Haskell'? isHaskell :: Value -> Bool isHaskell (Haskell _) = True isHaskell _ = False --- | Is a value an Integer?+-- | Is a value an `Integer'? isInteger :: Value -> Bool isInteger (Integer _) = True isInteger _ = False --- | Is a value a List?+-- | Is a value a `List'? isList :: Value -> Bool isList (List _) = True isList _ = False --- | Is a value a Message?+-- | Is a value a `Message'? isMessage :: Value -> Bool isMessage (Message _) = True isMessage _ = False --- | Is a value a Method?+-- | Is a value a `Method'? isMethod :: Value -> Bool isMethod (Method _) = True isMethod _ = False --- | Is a value a Particle?+-- | Is a value a `Particle'? isParticle :: Value -> Bool isParticle (Particle _) = True isParticle _ = False --- | Is a value a Pattern?+-- | Is a value a `Pattern'? isPattern :: Value -> Bool isPattern (Pattern _) = True isPattern _ = False --- | Is a value a Process?+-- | Is a value a `Process'? isProcess :: Value -> Bool isProcess (Process _ _) = True isProcess _ = False --- | Is a value a Rational?+-- | Is a value a `Rational'? isRational :: Value -> Bool isRational (Rational _) = True isRational _ = False --- | Is a value a Reference?+-- | Is a value a `Reference'? isReference :: Value -> Bool isReference (Reference _) = True isReference _ = False --- | Is a value a String?+-- | Is a value a `String'? isString :: Value -> Bool isString (String _) = True isString _ = False +-- | Convert an AtomoError into the Value we want to error with. asValue :: AtomoError -> Value asValue (Error v) = v asValue (ParseError pe) =@@ -575,12 +757,27 @@         [Integer (fromIntegral e'), Integer (fromIntegral g)] asValue NoExpressions = particle "no-expressions" asValue (ValueNotFound d v) =-    keyParticleN ["could-not-found", "in"] [string d, v]+    keyParticleN ["could-not-find", "in"] [string d, v] asValue (DynamicNeeded t) =     keyParticleN ["dynamic-needed"] [string t] -fromHaskell' :: Typeable a => String -> Value -> a-fromHaskell' t (Haskell d) =-    fromMaybe (error ("needed Haskell value of type " ++ t))-        (fromDynamic d)-fromHaskell' t _ = error ("needed haskell value of type " ++ t)+-- | Given a record of primitive IDs, get the object reference backing a value.+orefFrom :: IDs -> Value -> ORef+{-# INLINE orefFrom #-}+orefFrom _ (Reference r) = r+orefFrom ids (Block _ _ _) = idBlock ids+orefFrom ids (Boolean _) = idBoolean ids+orefFrom ids (Char _) = idChar ids+orefFrom ids (Continuation _) = idContinuation ids+orefFrom ids (Double _) = idDouble ids+orefFrom ids (Expression _) = idExpression ids+orefFrom ids (Haskell _) = idHaskell ids+orefFrom ids (Integer _) = idInteger ids+orefFrom ids (List _) = idList ids+orefFrom ids (Message _) = idMessage ids+orefFrom ids (Method _) = idMethod ids+orefFrom ids (Particle _) = idParticle ids+orefFrom ids (Process _ _) = idProcess ids+orefFrom ids (Pattern _) = idPattern ids+orefFrom ids (Rational _) = idRational ids+orefFrom ids (String _) = idString ids
src/Atomo/VMT.hs view
@@ -6,6 +6,8 @@  import Atomo.Types +-- | A monad transformer for Atomo's VM which just passes around the VM+-- environment. newtype VMT m a =     VMT         { runVMT :: Env -> m (a, Env)@@ -32,17 +34,23 @@     callCC f = VMT $ \e ->         callCC $ \c -> runVMT (f (\a -> VMT (\e' -> c (a, e')))) e ++-- | Execute a VM action inside a VMT monad. vm :: MonadIO m => VM Value -> VMT m Value vm x = VMT (liftIO . runStateT (runContT x return)) +-- | Like `vm', but ignores the result. vm_ :: MonadIO m => VM a -> VMT m () vm_ x = vm (x >> return (particle "ok")) >> return () +-- | Grab the underlying VM envionment. getEnv :: Monad m => VMT m Env getEnv = VMT $ \e -> return (e, e) +-- | Replace the underlying VM environment. putEnv :: Monad m => Env -> VMT m () putEnv e = VMT $ \_ -> return ((), e) +-- | Execute a VMT monad with an initial environment, returning its result. execVM :: Monad m => VMT m a -> Env -> m a execVM x e = liftM fst (runVMT x e)
src/Atomo/Valuable.hs view
@@ -10,7 +10,10 @@   class Valuable a where+    -- | Convert to an Atomo value.     toValue :: a -> VM Value++    -- | Convert from an Atomo value.     fromValue :: Value -> VM a  instance Valuable Value where
src/Main.hs view
@@ -5,10 +5,12 @@ import System.Environment (getArgs)  import Atomo+import Atomo.Core import Atomo.Load import Atomo.Parser import Atomo.PrettyVM import Atomo.Run+import qualified Atomo.Kernel as Kernel   main :: IO ()@@ -18,15 +20,18 @@     case args of         [] -> exec repl +        ["-x"] -> noPrelude primRepl+        ("-x":fn:_) -> noPrelude (parseFile fn >>= liftIO . mapM_ print >> liftIO (putStrLn "result:") >> loadFile fn)+         ("-e":expr:_) -> exec $ do-            ast <- continuedParse expr "<input>"+            ast <- parseInput expr             r <- evalAll ast             d <- prettyVM r             liftIO (putStrLn d)             return (particle "ok")          ("-s":expr:_) -> exec $ do-            ast <- continuedParse expr "<input>"+            ast <- parseInput expr             evalAll ast             repl @@ -46,5 +51,20 @@             , "\tatomo FILE\texecute FILE"             ] +noPrelude :: VM Value -> IO ()+noPrelude x = do+    runWith (initCore >> Kernel.load >> x) startEnv+    return ()+ repl :: VM Value repl = eval [$e|Lobby clone repl|]++primRepl :: VM Value+primRepl = do+    liftIO (putStrLn "next:")+    expr <- liftIO getLine+    ast <- parseInput expr+    r <- evalAll ast+    d <- prettyVM r+    liftIO (putStrLn d)+    primRepl