diff --git a/atomo.cabal b/atomo.cabal
--- a/atomo.cabal
+++ b/atomo.cabal
@@ -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):
+ Documentation:
.
- Examples:
+ Examples:
.
IRC Channel:
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,
diff --git a/prelude/association.atomo b/prelude/association.atomo
--- a/prelude/association.atomo
+++ b/prelude/association.atomo
@@ -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) }
diff --git a/prelude/block.atomo b/prelude/block.atomo
--- a/prelude/block.atomo
+++ b/prelude/block.atomo
@@ -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
}
diff --git a/prelude/boolean.atomo b/prelude/boolean.atomo
--- a/prelude/boolean.atomo
+++ b/prelude/boolean.atomo
@@ -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 })
diff --git a/prelude/condition.atomo b/prelude/condition.atomo
--- a/prelude/condition.atomo
+++ b/prelude/condition.atomo
@@ -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 := ""
- 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
diff --git a/prelude/core.atomo b/prelude/core.atomo
--- a/prelude/core.atomo
+++ b/prelude/core.atomo
@@ -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
diff --git a/prelude/eco.atomo b/prelude/eco.atomo
--- a/prelude/eco.atomo
+++ b/prelude/eco.atomo
@@ -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) :=
diff --git a/prelude/exception.atomo b/prelude/exception.atomo
--- a/prelude/exception.atomo
+++ b/prelude/exception.atomo
@@ -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) :=
diff --git a/prelude/list.atomo b/prelude/list.atomo
--- a/prelude/list.atomo
+++ b/prelude/list.atomo
@@ -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
diff --git a/prelude/numeric.atomo b/prelude/numeric.atomo
--- a/prelude/numeric.atomo
+++ b/prelude/numeric.atomo
@@ -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
diff --git a/prelude/parameter.atomo b/prelude/parameter.atomo
--- a/prelude/parameter.atomo
+++ b/prelude/parameter.atomo
@@ -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)
diff --git a/prelude/particle.atomo b/prelude/particle.atomo
--- a/prelude/particle.atomo
+++ b/prelude/particle.atomo
@@ -1,4 +1,4 @@
-(p: Particle) show :=
+(p: -> Particle) show :=
p type match: {
@keyword ->
{ operator?: str := str all?: @(in?: "~!@#$%^&*-_=+./\\|<>?:")
diff --git a/prelude/repl.atomo b/prelude/repl.atomo
--- a/prelude/repl.atomo
+++ b/prelude/repl.atomo
@@ -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))
diff --git a/src/Atomo.hs b/src/Atomo.hs
--- a/src/Atomo.hs
+++ b/src/Atomo.hs
@@ -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
diff --git a/src/Atomo/Core.hs b/src/Atomo/Core.hs
--- a/src/Atomo/Core.hs
+++ b/src/Atomo/Core.hs
@@ -7,6 +7,7 @@
import Atomo.Environment
+-- | Defines all primitive objects, including the Lobby.
initCore :: VM ()
initCore = do
-- the very root object
diff --git a/src/Atomo/Environment.hs b/src/Atomo/Environment.hs
--- a/src/Atomo/Environment.hs
+++ b/src/Atomo/Environment.hs
@@ -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]
diff --git a/src/Atomo/Helpers.hs b/src/Atomo/Helpers.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Helpers.hs
@@ -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')
diff --git a/src/Atomo/Kernel.hs b/src/Atomo/Kernel.hs
--- a/src/Atomo/Kernel.hs
+++ b/src/Atomo/Kernel.hs
@@ -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")
diff --git a/src/Atomo/Kernel/Block.hs b/src/Atomo/Kernel/Block.hs
--- a/src/Atomo/Kernel/Block.hs
+++ b/src/Atomo/Kernel/Block.hs
@@ -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
diff --git a/src/Atomo/Kernel/Comparable.hs b/src/Atomo/Kernel/Comparable.hs
--- a/src/Atomo/Kernel/Comparable.hs
+++ b/src/Atomo/Kernel/Comparable.hs
@@ -9,7 +9,7 @@
load :: VM ()
load = do
mapM_ eval
- [ [$e|operator 4 ==, /=, <, <=, >=, >|]
+ [ [$e|operator 4 == /= < <= >= >|]
, [$e|operator right 3 &&|]
, [$e|operator right 2 |||]
]
diff --git a/src/Atomo/Kernel/Expression.hs b/src/Atomo/Kernel/Expression.hs
--- a/src/Atomo/Kernel/Expression.hs
+++ b/src/Atomo/Kernel/Expression.hs
@@ -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
diff --git a/src/Atomo/Kernel/List.hs b/src/Atomo/Kernel/List.hs
--- a/src/Atomo/Kernel/List.hs
+++ b/src/Atomo/Kernel/List.hs
@@ -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])
diff --git a/src/Atomo/Kernel/Numeric.hs b/src/Atomo/Kernel/Numeric.hs
--- a/src/Atomo/Kernel/Numeric.hs
+++ b/src/Atomo/Kernel/Numeric.hs
@@ -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|] =::)
diff --git a/src/Atomo/Kernel/Pattern.hs b/src/Atomo/Kernel/Pattern.hs
--- a/src/Atomo/Kernel/Pattern.hs
+++ b/src/Atomo/Kernel/Pattern.hs
@@ -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)
diff --git a/src/Atomo/Kernel/Ports.hs b/src/Atomo/Kernel/Ports.hs
--- a/src/Atomo/Kernel/Ports.hs
+++ b/src/Atomo/Kernel/Ports.hs
@@ -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"
diff --git a/src/Atomo/Kernel/String.hs b/src/Atomo/Kernel/String.hs
--- a/src/Atomo/Kernel/String.hs
+++ b/src/Atomo/Kernel/String.hs
@@ -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|] =:
diff --git a/src/Atomo/Load.hs b/src/Atomo/Load.hs
--- a/src/Atomo/Load.hs
+++ b/src/Atomo/Load.hs
@@ -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
diff --git a/src/Atomo/Method.hs b/src/Atomo/Method.hs
--- a/src/Atomo/Method.hs
+++ b/src/Atomo/Method.hs
@@ -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
diff --git a/src/Atomo/Parser.hs b/src/Atomo/Parser.hs
--- a/src/Atomo/Parser.hs
+++ b/src/Atomo/Parser.hs
@@ -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) ""
+-- | 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 "" ""
-
-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
diff --git a/src/Atomo/Parser/Base.hs b/src/Atomo/Parser/Base.hs
--- a/src/Atomo/Parser/Base.hs
+++ b/src/Atomo/Parser/Base.hs
@@ -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
diff --git a/src/Atomo/Parser/Pattern.hs b/src/Atomo/Parser/Pattern.hs
deleted file mode 100644
--- a/src/Atomo/Parser/Pattern.hs
+++ /dev/null
@@ -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)
- ]
diff --git a/src/Atomo/Parser/Pattern.hs-boot b/src/Atomo/Parser/Pattern.hs-boot
deleted file mode 100644
--- a/src/Atomo/Parser/Pattern.hs-boot
+++ /dev/null
@@ -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
diff --git a/src/Atomo/Parser/Primitive.hs b/src/Atomo/Parser/Primitive.hs
--- a/src/Atomo/Parser/Primitive.hs
+++ b/src/Atomo/Parser/Primitive.hs
@@ -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
diff --git a/src/Atomo/Pattern.hs b/src/Atomo/Pattern.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Pattern.hs
@@ -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
diff --git a/src/Atomo/Pretty.hs b/src/Atomo/Pretty.hs
--- a/src/Atomo/Pretty.hs
+++ b/src/Atomo/Pretty.hs
@@ -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 ""
- 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 ""
- 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 <++>, <+++>
diff --git a/src/Atomo/PrettyVM.hs b/src/Atomo/PrettyVM.hs
--- a/src/Atomo/PrettyVM.hs
+++ b/src/Atomo/PrettyVM.hs
@@ -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"
-
diff --git a/src/Atomo/QuasiQuotes.hs b/src/Atomo/QuasiQuotes.hs
--- a/src/Atomo/QuasiQuotes.hs
+++ b/src/Atomo/QuasiQuotes.hs
@@ -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 "" s
- get >>= liftIO . writeIORef qqEnv
- return r
+ go = liftM haskell $ continue pp "" 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)
diff --git a/src/Atomo/Run.hs b/src/Atomo/Run.hs
--- a/src/Atomo/Run.hs
+++ b/src/Atomo/Run.hs
@@ -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 ->
diff --git a/src/Atomo/Spawn.hs b/src/Atomo/Spawn.hs
--- a/src/Atomo/Spawn.hs
+++ b/src/Atomo/Spawn.hs
@@ -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"))
diff --git a/src/Atomo/Types.hs b/src/Atomo/Types.hs
--- a/src/Atomo/Types.hs
+++ b/src/Atomo/Types.hs
@@ -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
diff --git a/src/Atomo/VMT.hs b/src/Atomo/VMT.hs
--- a/src/Atomo/VMT.hs
+++ b/src/Atomo/VMT.hs
@@ -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)
diff --git a/src/Atomo/Valuable.hs b/src/Atomo/Valuable.hs
--- a/src/Atomo/Valuable.hs
+++ b/src/Atomo/Valuable.hs
@@ -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
diff --git a/src/Main.hs b/src/Main.hs
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -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 ""
+ ast <- parseInput expr
r <- evalAll ast
d <- prettyVM r
liftIO (putStrLn d)
return (particle "ok")
("-s":expr:_) -> exec $ do
- ast <- continuedParse expr ""
+ 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