diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c)2010, Alex Suraci
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Alex Suraci nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple (defaultMain)
+
+main = defaultMain
diff --git a/atomo.cabal b/atomo.cabal
new file mode 100644
--- /dev/null
+++ b/atomo.cabal
@@ -0,0 +1,115 @@
+name: atomo
+version: 0.1
+synopsis: A highly dynamic, extremely simple, very fun programming
+ language.
+description:
+ A super simple, object-oriented language centered around prototyping and
+ multiple dispatch. Supports usage of Haskell code/libraries via a thin
+ layer, using hint and Data.Dynamic. Experimental, but quickly evolving and
+ very fun.
+ .
+ Influences: Scheme, Slate, Io, Erlang, Haskell, Ruby.
+ .
+ Neat stuff: first-class continuations, very metaprogramming and DSL
+ -friendly, message-passing concurrency, pattern-matching.
+ .
+ Documentation (WIP):
+ .
+ Examples:
+ .
+ IRC Channel:
+homepage: http://darcsden.com/alex/atomo
+license: BSD3
+license-file: LICENSE
+author: Alex Suraci
+maintainer: i.am@toogeneric.com
+category: Language
+build-type: Simple
+
+cabal-version: >= 1.4
+
+
+library
+ hs-source-dirs: src
+
+ extensions: PackageImports
+
+ build-depends:
+ base >= 4 && < 5,
+ containers,
+ directory,
+ filepath,
+ hashable,
+ hint,
+ monads-fd,
+ parsec >= 3.0.0,
+ pretty,
+ split,
+ template-haskell,
+ text,
+ time,
+ vector
+
+ exposed-modules:
+ Atomo.Debug,
+ Atomo.Environment,
+ Atomo.Haskell,
+ Atomo.Kernel,
+ Atomo.Kernel.Numeric,
+ Atomo.Kernel.List,
+ Atomo.Kernel.String,
+ Atomo.Kernel.Block,
+ Atomo.Kernel.Expression,
+ Atomo.Kernel.Concurrency,
+ Atomo.Kernel.Message,
+ Atomo.Kernel.Comparable,
+ Atomo.Kernel.Particle,
+ Atomo.Kernel.Pattern,
+ Atomo.Kernel.Ports,
+ Atomo.Kernel.Time,
+ Atomo.Kernel.Bool,
+ Atomo.Kernel.Association,
+ Atomo.Kernel.Parameter,
+ Atomo.Kernel.Exception,
+ Atomo.Kernel.Environment,
+ Atomo.Kernel.Eco,
+ Atomo.Kernel.Continuation,
+ Atomo.Method,
+ Atomo.Parser,
+ Atomo.Parser.Base,
+ Atomo.Parser.Pattern,
+ Atomo.Parser.Primitive,
+ Atomo.Pretty,
+ Atomo.Types
+
+
+executable atomo
+ hs-source-dirs: src
+ main-is: Main.hs
+
+ ghc-prof-options: -prof -auto-all -caf-all
+ ghc-options: -Wall -threaded -fno-warn-unused-do-bind
+ -funfolding-use-threshold=9999
+
+ extensions: PackageImports
+
+ c-sources: src/rts.c
+
+ build-depends:
+ base >= 4 && < 5,
+ containers,
+ directory,
+ filepath,
+ hashable,
+ haskeline,
+ hint,
+ monads-fd,
+ mtl,
+ parsec >= 3.0.0,
+ pretty,
+ pretty-show,
+ split,
+ template-haskell,
+ text,
+ time,
+ vector
diff --git a/src/Atomo/Debug.hs b/src/Atomo/Debug.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Debug.hs
@@ -0,0 +1,27 @@
+module Atomo.Debug where
+
+import Debug.Trace
+import Text.Show.Pretty
+
+
+debugging :: Bool
+debugging = False
+
+debug :: (Show a, Show b) => b -> a -> a
+debug s v
+ | debugging = dout s v
+ | otherwise = v
+
+dump :: (Monad m, Show a) => a -> m ()
+dump x
+ | debugging = out x
+ | otherwise = return ()
+
+out :: (Monad m, Show a) => a -> m ()
+out x = trace (prettyShow x) (return ())
+
+dout :: (Show a, Show b) => b -> a -> a
+dout s v = trace (prettyShow s ++ ": " ++ prettyShow v) v
+
+prettyShow :: Show a => a -> String
+prettyShow = ppShow
diff --git a/src/Atomo/Environment.hs b/src/Atomo/Environment.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Environment.hs
@@ -0,0 +1,794 @@
+{-# LANGUAGE BangPatterns #-}
+module Atomo.Environment where
+
+import "monads-fd" Control.Monad.Cont
+import "monads-fd" Control.Monad.Error
+import "monads-fd" Control.Monad.State
+import Control.Concurrent (forkIO)
+import Control.Concurrent.Chan
+import Data.IORef
+import Data.List (nub)
+import Data.Maybe (isJust)
+import System.Directory
+import System.FilePath
+import System.IO.Unsafe
+import qualified Data.IntMap as M
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import qualified Language.Haskell.Interpreter as H
+import qualified Text.PrettyPrint as P
+
+import Atomo.Method
+import Atomo.Parser
+import Atomo.Pretty
+import Atomo.Types
+import {-# SOURCE #-} qualified Atomo.Kernel as Kernel
+
+
+-----------------------------------------------------------------------------
+-- Execution ----------------------------------------------------------------
+-----------------------------------------------------------------------------
+
+-- | execute an action in a new thread, initializing the environment and
+-- printing a traceback on error
+exec :: VM Value -> IO ()
+exec x = execWith (initEnv >> x) startEnv
+
+-- | execute an action in a new thread, printing a traceback on error
+execWith :: VM Value -> Env -> IO ()
+execWith x e = do
+ haltChan <- newChan
+
+ forkIO $ do
+ runWith (go x >> gets halt >>= liftIO >> return (particle "ok")) e
+ { halt = writeChan haltChan ()
+ }
+
+ return ()
+
+ readChan haltChan
+
+-- | execute x, printing an error if there is one
+go :: VM Value -> VM Value
+go x = catchError x (\e -> printError e >> return (particle "ok"))
+
+-- | execute x, initializing the environment with initEnv
+run :: VM Value -> IO (Either AtomoError Value)
+run x = runWith (initEnv >> x) startEnv
+
+-- | evaluate x with e as the environment
+runWith :: VM Value -> Env -> IO (Either AtomoError Value)
+runWith x e = evalStateT (runContT (runErrorT x) return) e
+
+-- | print an error, including the previous 10 expressions evaluated
+-- with the most recent on the bottom
+printError :: AtomoError -> VM ()
+printError err = do
+ t <- traceback
+
+ if not (null t)
+ then do
+ liftIO (putStrLn "traceback:")
+
+ forM_ t $ \e -> liftIO $
+ print (prettyStack e)
+
+ liftIO (putStrLn "")
+ else return ()
+
+ prettyError err >>= liftIO . print
+
+ modify $ \s -> s { stack = [] }
+ where
+ traceback = fmap (reverse . take 10 . reverse) (gets stack)
+
+prettyError :: AtomoError -> VM P.Doc
+prettyError (Error v) = fmap (P.text "error:" P.<+>) (prettyVM v)
+prettyError e = return (pretty e)
+
+-- | pretty-print by sending \@show to the object
+prettyVM :: Value -> VM P.Doc
+prettyVM = fmap (P.text . fromString) . dispatch . (single "show")
+
+-- | spawn a process to execute x. returns the Process.
+spawn :: VM Value -> VM Value
+spawn x = do
+ e <- get
+ chan <- liftIO newChan
+ tid <- liftIO . forkIO $ do
+ runWith (go x >> return (particle "ok")) (e { channel = chan })
+ return ()
+
+ return (Process chan tid)
+
+-- | set up the primitive objects, etc.
+initEnv :: VM ()
+{-# INLINE initEnv #-}
+initEnv = do
+ -- the very root object
+ object <- newObject id
+
+ -- top scope is a proto delegating to the root object
+ topObj <- newObject $ \o -> o { oDelegates = [object] }
+ modify $ \e -> e { top = topObj }
+
+ -- define Object as the root object
+ define (psingle "Object" PSelf) (Primitive Nothing object)
+ modify $ \e -> e
+ { primitives = (primitives e) { idObject = rORef object }
+ }
+
+ -- this thread's channel
+ chan <- liftIO newChan
+ modify $ \e -> e { channel = chan }
+
+ -- define primitive objects
+ forM_ primObjs $ \(n, f) -> do
+ o <- newObject $ \o -> o { oDelegates = [object] }
+ define (psingle n PSelf) (Primitive Nothing o)
+ modify $ \e -> e { primitives = f (primitives e) (rORef o) }
+
+ Kernel.load
+ where
+ primObjs =
+ [ ("Block", \is r -> is { idBlock = r })
+ , ("Char", \is r -> is { idChar = r })
+ , ("Continuation", \is r -> is { idContinuation = r })
+ , ("Double", \is r -> is { idDouble = r })
+ , ("Expression", \is r -> is { idExpression = r })
+ , ("Integer", \is r -> is { idInteger = r })
+ , ("List", \is r -> is { idList = r })
+ , ("Message", \is r -> is { idMessage = r })
+ , ("Particle", \is r -> is { idParticle = r })
+ , ("Process", \is r -> is { idProcess = r })
+ , ("Pattern", \is r -> is { idPattern = r })
+ , ("String", \is r -> is { idString = r })
+ ]
+
+
+
+-----------------------------------------------------------------------------
+-- General ------------------------------------------------------------------
+-----------------------------------------------------------------------------
+
+-- | evaluation
+eval :: Expr -> VM Value
+eval e = eval' e `catchError` pushStack
+ where
+ pushStack err = do
+ modify $ \s -> s { stack = e : stack s }
+ throwError err
+
+ eval' (Define { ePattern = p, eExpr = ev }) = do
+ define p ev
+ return (particle "ok")
+ eval' (Set { ePattern = p@(PSingle {}), eExpr = ev }) = do
+ v <- eval ev
+ define p (Primitive (eLocation ev) v)
+ return v
+ eval' (Set { ePattern = p@(PKeyword {}), eExpr = ev }) = do
+ v <- eval ev
+ define p (Primitive (eLocation ev) v)
+ return v
+ eval' (Set { ePattern = p, eExpr = ev }) = do
+ v <- eval ev
+
+ is <- gets primitives
+ if match is p v
+ then do
+ forM_ (bindings' p v) $ \(p', v') -> do
+ define p' (Primitive (eLocation ev) v')
+
+ return v
+ else throwError (Mismatch p v)
+ eval' (Dispatch
+ { eMessage = ESingle
+ { emID = i
+ , emName = n
+ , emTarget = t
+ }
+ }) = do
+ v <- eval t
+ dispatch (Single i n v)
+ eval' (Dispatch
+ { eMessage = EKeyword
+ { emID = i
+ , emNames = ns
+ , emTargets = ts
+ }
+ }) = do
+ vs <- mapM eval ts
+ dispatch (Keyword i ns vs)
+ eval' (Operator { eNames = ns, eAssoc = a, ePrec = p }) = do
+ forM_ ns $ \n -> modify $ \s ->
+ s { parserState = (n, (a, p)) : parserState s }
+
+ return (particle "ok")
+ eval' (Primitive { eValue = v }) = return v
+ eval' (EBlock { eArguments = as, eContents = es }) = do
+ t <- gets top
+ return (Block t as es)
+ eval' (EDispatchObject {}) = do
+ c <- gets call
+ newObject $ \o -> o
+ { oMethods =
+ ( toMethods
+ [ (psingle "sender" PSelf, callSender c)
+ , (psingle "message" PSelf, Message (callMessage c))
+ , (psingle "context" PSelf, callContext c)
+ ]
+ , M.empty
+ )
+ }
+ eval' (EList { eContents = es }) = do
+ vs <- mapM eval es
+ list vs
+ eval' (EParticle { eParticle = EPMSingle n }) =
+ return (Particle $ PMSingle n)
+ eval' (EParticle { eParticle = EPMKeyword ns mes }) = do
+ mvs <- forM mes $
+ maybe (return Nothing) (fmap Just . eval)
+ return (Particle $ PMKeyword ns mvs)
+ eval' (ETop {}) = gets top
+ eval' (EVM { eAction = x }) = x
+
+-- | evaluating 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
+newObject :: (Object -> Object) -> VM Value
+newObject f = fmap Reference . liftIO $
+ newIORef . f $ Object
+ { oDelegates = []
+ , oMethods = (M.empty, M.empty)
+ }
+
+-- | run x with t as its toplevel object
+withTop :: Value -> VM Value -> VM Value
+withTop t x = do
+ o <- gets top
+ modify (\e -> e { top = t })
+
+ res <- catchError x $ \err -> do
+ modify (\e -> e { top = o })
+ throwError err
+
+ modify (\e -> e { top = o })
+
+ return res
+
+
+-----------------------------------------------------------------------------
+-- Define -------------------------------------------------------------------
+-----------------------------------------------------------------------------
+
+-- | define a pattern to evaluate an expression
+define :: Pattern -> Expr -> VM ()
+define !p !e = do
+ is <- gets primitives
+ newp <- methodPattern p
+ os <- targets is newp
+ m <- method newp e
+ forM_ os $ \o -> do
+ obj <- liftIO (readIORef o)
+
+ let (oss, oks) = oMethods obj
+ ms (PSingle {}) = (addMethod (m o) oss, oks)
+ ms (PKeyword {}) = (oss, addMethod (m o) oks)
+ ms x = error $ "impossible: defining with pattern " ++ show x
+
+ liftIO . writeIORef o $
+ obj { oMethods = ms newp }
+ where
+ method p' (Primitive _ v) = return (\o -> Slot (setSelf o p') v)
+ method p' e' = gets top >>= \t ->
+ return (\o -> Method (setSelf o p') t e')
+
+ methodPattern p'@(PSingle { ppTarget = t }) = do
+ t' <- methodPattern t
+ return p' { ppTarget = t' }
+ methodPattern p'@(PKeyword { ppTargets = ts }) = do
+ ts' <- mapM methodPattern ts
+ return p' { ppTargets = ts' }
+ methodPattern (PObject oe) = do
+ v <- eval oe
+ return (PMatch v)
+ methodPattern (PNamed n p') = do
+ p'' <- methodPattern p'
+ return (PNamed n p'')
+ methodPattern p' = return p'
+
+ -- | Swap out a reference match with PSelf, for inserting on the object
+ setSelf :: ORef -> Pattern -> Pattern
+ setSelf o (PKeyword i ns ps) =
+ PKeyword i ns (map (setSelf o) ps)
+ setSelf o (PMatch (Reference x))
+ | o == x = PSelf
+ setSelf o (PNamed n p') =
+ PNamed n (setSelf o p')
+ setSelf o (PSingle i n t) =
+ PSingle i n (setSelf o t)
+ setSelf _ p' = p'
+
+
+-- | find the target objects for a pattern
+targets :: IDs -> Pattern -> VM [ORef]
+targets _ (PMatch v) = orefFor v >>= return . (: [])
+targets is (PSingle _ _ p) = targets is p
+targets is (PKeyword _ _ ps) = do
+ ts <- mapM (targets is) ps
+ return (nub (concat ts))
+targets is (PNamed _ p) = targets is p
+targets _ PSelf = gets top >>= orefFor >>= return . (: [])
+targets is PAny = return [idObject is]
+targets is (PList _) = return [idList is]
+targets is (PHeadTail h t) = do
+ ht <- targets is h
+ tt <- targets is t
+ if idChar is `elem` ht || idString is `elem` tt
+ then return [idList is, idString is]
+ else return [idList is]
+targets _ p = error $ "no targets for " ++ show p
+
+
+
+-----------------------------------------------------------------------------
+-- Dispatch -----------------------------------------------------------------
+-----------------------------------------------------------------------------
+
+-- | dispatch a message and return a value
+dispatch :: Message -> VM Value
+dispatch !m = do
+ find <- findFirstMethod m vs
+ case find of
+ Just method -> runMethod method m
+ Nothing ->
+ case vs of
+ [v] -> sendDNU v
+ _ -> sendDNUs vs 0
+ where
+ vs =
+ case m of
+ Single { mTarget = t } -> [t]
+ Keyword { mTargets = ts } -> ts
+
+ sendDNU v = do
+ find <- findMethod v (dnuSingle v)
+ case find of
+ Nothing -> throwError $ DidNotUnderstand m
+ Just method -> runMethod method (dnuSingle v)
+
+ sendDNUs [] _ = throwError $ DidNotUnderstand m
+ sendDNUs (v:vs') n = do
+ find <- findMethod v (dnu v n)
+ case find of
+ Nothing -> sendDNUs vs' (n + 1)
+ Just method -> runMethod method (dnu v n)
+
+ dnu v n = keyword
+ ["did-not-understand", "at"]
+ [v, Message m, Integer n]
+
+ dnuSingle v = keyword
+ ["did-not-understand"]
+ [v, Message m]
+
+
+-- | 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
+ Nothing -> findFirstMethod m (oDelegates o)
+ Just mt -> return (Just mt)
+
+-- | find the first value that has a method defiend for `m'
+findFirstMethod :: Message -> [Value] -> VM (Maybe Method)
+findFirstMethod _ [] = return Nothing
+findFirstMethod m (v:vs) = do
+ findMethod v m
+ >>= maybe (findFirstMethod m vs) (return . Just)
+
+-- | find a relevant method for message `m' on object `o'
+relevant :: IDs -> Object -> Message -> Maybe Method
+relevant ids o m =
+ M.lookup (mID m) (methods m) >>= firstMatch ids 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 PSelf (Reference y) =
+ refMatch ids (idMatch ids) y
+match ids PSelf y =
+ match ids (PMatch (Reference (idMatch ids))) (Reference (orefFrom ids y))
+match ids (PMatch (Reference x)) (Reference y) =
+ refMatch ids x y
+match ids (PMatch (Reference x)) y =
+ match ids (PMatch (Reference x)) (Reference (orefFrom ids y))
+match _ (PMatch x) y =
+ x == 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 vs
+ where
+ vs = V.toList $ unsafePerformIO (readIORef v)
+match ids (PHeadTail hp tp) (List v) =
+ V.length vs > 0 && match ids hp h && match ids tp t
+ where
+ vs = unsafePerformIO (readIORef v)
+ h = V.head vs
+ t = List (unsafePerformIO (newIORef (V.tail vs)))
+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 _ (PPMSingle a) (Particle (PMSingle b)) = a == b
+match ids (PPMKeyword ans aps) (Particle (PMKeyword bns mvs)) =
+ ans == bns && matchParticle ids aps mvs
+match _ _ _ = False
+
+refMatch :: IDs -> ORef -> ORef -> Bool
+refMatch ids x y = x == y || delegatesMatch
+ where
+ delegatesMatch = any
+ (match ids (PMatch (Reference x)))
+ (oDelegates (unsafePerformIO (readIORef y)))
+
+-- | 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
+
+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
+
+-- | evaluate a method in a scope with the pattern's bindings, delegating to
+-- the method's context and setting the "dispatch" object
+runMethod :: Method -> Message -> VM Value
+runMethod (Slot { mValue = v }) _ = return v
+runMethod (Method { mPattern = p, mTop = t, mExpr = e }) m = do
+ nt <- newObject $ \o -> o
+ { oDelegates = [t]
+ , oMethods = (bindings p m, M.empty)
+ }
+
+ modify $ \e' -> e'
+ { call = Call
+ { callSender = top e'
+ , callMessage = m
+ , callContext = t
+ }
+ }
+
+ 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 PSelf, v) : bindings' p v
+bindings' (PPMKeyword _ ps) (Particle (PMKeyword _ mvs)) = concat
+ $ map (\(p, Just v) -> bindings' p v)
+ $ filter (isJust . snd)
+ $ zip ps mvs
+bindings' (PList ps) (List v) = concat (zipWith bindings' ps vs)
+ where
+ vs = V.toList $ unsafePerformIO (readIORef v)
+bindings' (PHeadTail hp tp) (List v) =
+ bindings' hp h ++ bindings' tp t
+ where
+ vs = unsafePerformIO (readIORef v)
+ h = V.head vs
+ t = List (unsafePerformIO (newIORef (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' _ _ = []
+
+
+
+-----------------------------------------------------------------------------
+-- Helpers ------------------------------------------------------------------
+-----------------------------------------------------------------------------
+
+infixr 0 =:, =::
+
+-- | define a method as an action returning a value
+(=:) :: Pattern -> VM Value -> VM ()
+pat =: vm = define pat (EVM 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
+{-# INLINE findBlock #-}
+findBlock = findValue "Block" isBlock
+
+findChar :: Value -> VM Value
+{-# INLINE findChar #-}
+findChar = findValue "Char" isChar
+
+findContinuation :: Value -> VM Value
+{-# INLINE findContinuation #-}
+findContinuation = findValue "Continuation" isContinuation
+
+findDouble :: Value -> VM Value
+{-# INLINE findDouble #-}
+findDouble = findValue "Double" isDouble
+
+findExpression :: Value -> VM Value
+{-# INLINE findExpression #-}
+findExpression = findValue "Expression" isExpression
+
+findHaskell :: Value -> VM Value
+{-# INLINE findHaskell #-}
+findHaskell = findValue "Haskell" isHaskell
+
+findInteger :: Value -> VM Value
+{-# INLINE findInteger #-}
+findInteger = findValue "Integer" isInteger
+
+findList :: Value -> VM Value
+{-# INLINE findList #-}
+findList = findValue "List" isList
+
+findMessage :: Value -> VM Value
+{-# INLINE findMessage #-}
+findMessage = findValue "Message" isMessage
+
+findParticle :: Value -> VM Value
+{-# INLINE findParticle #-}
+findParticle = findValue "Particle" isParticle
+
+findProcess :: Value -> VM Value
+{-# INLINE findProcess #-}
+findProcess = findValue "Process" isProcess
+
+findPattern :: Value -> VM Value
+{-# INLINE findPattern #-}
+findPattern = findValue "Pattern" isPattern
+
+findReference :: Value -> VM Value
+{-# INLINE findReference #-}
+findReference = findValue "Reference" isReference
+
+findString :: Value -> VM Value
+{-# INLINE findString #-}
+findString = findValue "String" isString
+
+getString :: Expr -> VM String
+getString e = eval e >>= fmap fromString . findString
+
+getText :: Expr -> VM T.Text
+getText e = eval e >>= findString >>= \(String t) -> return t
+
+getList :: Expr -> VM [Value]
+getList = fmap V.toList . getVector
+
+getVector :: Expr -> VM (V.Vector Value)
+getVector e = eval e
+ >>= findList
+ >>= \(List v) -> liftIO . readIORef $ v
+
+here :: String -> VM Value
+here n =
+ gets top
+ >>= dispatch . (single n)
+
+bool :: Bool -> VM Value
+{-# INLINE bool #-}
+bool True = here "True"
+bool False = here "False"
+
+referenceTo :: Value -> VM Value
+{-# INLINE referenceTo #-}
+referenceTo = fmap Reference . orefFor
+
+doBlock :: MethodMap -> Value -> [Expr] -> VM Value
+{-# INLINE doBlock #-}
+doBlock bms s es = do
+ blockScope <- newObject $ \o -> o
+ { oDelegates = [s]
+ , oMethods = (bms, M.empty)
+ }
+
+ withTop blockScope (evalAll es)
+
+objectFor :: Value -> VM Object
+{-# INLINE objectFor #-}
+objectFor v = orefFor v >>= liftIO . readIORef
+
+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 (Char _) = idChar ids
+orefFrom ids (Continuation _) = idContinuation ids
+orefFrom ids (Double _) = idDouble ids
+orefFrom ids (Expression _) = idExpression ids
+orefFrom ids (Integer _) = idInteger ids
+orefFrom ids (List _) = idList ids
+orefFrom ids (Message _) = idMessage ids
+orefFrom ids (Particle _) = idParticle ids
+orefFrom ids (Process _ _) = idProcess ids
+orefFrom ids (Pattern _) = idPattern ids
+orefFrom ids (String _) = idString ids
+orefFrom _ v = error $ "no orefFrom for: " ++ show v
+
+-- load a file, remembering it to prevent repeated loading
+-- searches with cwd as lowest priority
+requireFile :: FilePath -> VM Value
+requireFile fn = do
+ initialPath <- gets loadPath
+ file <- findFile (initialPath ++ [""]) fn
+
+ alreadyLoaded <- gets ((file `elem`) . loaded)
+ if alreadyLoaded
+ then return (particle "already-loaded")
+ else do
+
+ modify $ \s -> s { loaded = file : loaded s }
+
+ doLoad file
+
+-- load a file
+-- searches with cwd as highest priority
+loadFile :: FilePath -> VM Value
+loadFile fn = do
+ initialPath <- gets loadPath
+ findFile ("":initialPath) fn >>= doLoad
+
+-- execute a file
+doLoad :: FilePath -> VM Value
+doLoad file =
+ case takeExtension file of
+ ".hs" -> do
+ int <- liftIO . H.runInterpreter $ do
+ H.loadModules [file]
+ H.setTopLevelModules ["Main"]
+ H.interpret "load" (H.as :: VM ())
+
+ load <- either (throwError . ImportError) return int
+
+ load
+
+ return (particle "ok")
+
+ _ -> do
+ initialPath <- gets loadPath
+
+ source <- liftIO (readFile file)
+ ast <- continuedParse source file
+
+ modify $ \s -> s
+ { loadPath = [takeDirectory file]
+ }
+
+ r <- evalAll ast
+
+ modify $ \s -> s
+ { loadPath = initialPath
+ }
+
+ return r
+
+-- | given a list of paths to search, find the file to load
+-- attempts to find the filename with .atomo and .hs extensions
+findFile :: [FilePath] -> FilePath -> VM FilePath
+findFile [] fn = throwError (FileNotFound fn)
+findFile (p:ps) fn = do
+ check <- filterM (liftIO . doesFileExist . ((p fn) <.>)) exts
+
+ case check of
+ [] -> findFile ps fn
+ (ext:_) -> liftIO (canonicalizePath $ p fn <.> ext)
+ where
+ exts = ["", "atomo", "hs"]
+
+-- | does one value delegate to another?
+delegatesTo :: Value -> Value -> VM Bool
+delegatesTo f t = do
+ 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 <- fmap 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
diff --git a/src/Atomo/Haskell.hs b/src/Atomo/Haskell.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Haskell.hs
@@ -0,0 +1,176 @@
+{-# OPTIONS -fno-warn-name-shadowing #-}
+module Atomo.Haskell
+ ( module Control.Concurrent
+ , module Control.Monad
+ , module Control.Monad.Cont
+ , module Control.Monad.Error
+ , module Control.Monad.State
+ , module Control.Monad.Trans
+ , module Atomo.Types
+ , p
+ , e
+ , es
+ ) where
+
+import Control.Concurrent
+import Control.Monad
+import "monads-fd" Control.Monad.Cont (MonadCont(..), ContT(..))
+import "monads-fd" Control.Monad.Error (MonadError(..), ErrorT(..))
+import "monads-fd" Control.Monad.State (MonadState(..), gets, modify)
+import "monads-fd" Control.Monad.Trans
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH.Syntax
+import Text.Parsec
+import qualified Language.Haskell.TH as TH
+import qualified Data.Text as T
+
+import Atomo.Parser
+import Atomo.Parser.Pattern
+import Atomo.Parser.Base
+import Atomo.Types
+
+
+p :: QuasiQuoter
+p = QuasiQuoter quotePatternExp undefined
+
+e :: QuasiQuoter
+e = QuasiQuoter quoteExprExp undefined
+
+es :: QuasiQuoter
+es = QuasiQuoter quoteExprsExp undefined
+
+withLocation :: (String -> (String, Int, Int) -> Q a) -> (a -> Exp) -> String -> TH.ExpQ
+withLocation p c s = do
+ l <- TH.location
+ r <- p s
+ ( TH.loc_filename l
+ , fst $ TH.loc_start l
+ , snd $ TH.loc_start l
+ )
+ return (c r)
+
+parsing :: Monad m => Parser a -> String -> (String, Int, Int) -> m a
+parsing p s (file, line, col) =
+ case runParser pp [] "" s of
+ Left e -> fail (show e)
+ Right e -> return e
+ where
+ pp = do
+ pos <- getPosition
+ setPosition $
+ (flip setSourceName) file $
+ (flip setSourceLine) line $
+ (flip setSourceColumn) col $
+ pos
+ whiteSpace
+ e <- p
+ whiteSpace
+ eof
+ return e
+
+parsePattern :: Monad m => String -> (String, Int, Int) -> m Pattern
+parsePattern = parsing ppDefine
+
+quotePatternExp :: String -> TH.ExpQ
+quotePatternExp = withLocation parsePattern patternToExp
+
+parseExpr :: Monad m => String -> (String, Int, Int) -> m Expr
+parseExpr = parsing pExpr
+
+quoteExprExp :: String -> TH.ExpQ
+quoteExprExp = withLocation parseExpr exprToExp
+
+parseExprs :: Monad m => String -> (String, Int, Int) -> m [Expr]
+parseExprs = parsing (wsBlock pExpr)
+
+quoteExprsExp :: String -> TH.ExpQ
+quoteExprsExp = withLocation parseExprs (ListE . map exprToExp)
+
+exprToExp :: Expr -> Exp
+exprToExp (Define l p e) = AppE (AppE (expr "Define" l) (patternToExp p)) (exprToExp e)
+exprToExp (Set l p e) = AppE (AppE (expr "Set" l) (patternToExp p)) (exprToExp e)
+exprToExp (Dispatch l m) = AppE (expr "Dispatch" l) (emessageToExp m)
+exprToExp (Operator l ns a p) = AppE (AppE (AppE (expr "Operator" l) (ListE (map (LitE . StringL) ns))) (assocToExp a)) (LitE (IntegerL p))
+exprToExp (Primitive l v) = AppE (expr "Primitive" l) (valueToExp v)
+exprToExp (EBlock l as es) =
+ AppE (AppE (expr "EBlock" l) (ListE (map patternToExp as))) (ListE (map exprToExp es))
+exprToExp (EDispatchObject l) =
+ expr "EDispatchObject" l
+exprToExp (EVM _ _) = error "cannot exprToExp EVM"
+exprToExp (EList l es) =
+ AppE (expr "EList" l) (ListE (map exprToExp es))
+exprToExp (ETop l) =
+ expr "ETop" l
+exprToExp (EParticle l p) =
+ AppE (expr "EParticle" l) (eparticleToExp p)
+
+assocToExp :: Assoc -> Exp
+assocToExp ALeft = ConE (mkName "ALeft")
+assocToExp ARight = ConE (mkName "ARight")
+
+messageToExp :: Message -> Exp
+messageToExp (Keyword i ns vs) =
+ AppE (AppE (AppE (ConE (mkName "Keyword")) (LitE (IntegerL (fromIntegral i)))) (ListE (map (LitE . StringL) ns))) (ListE (map valueToExp vs))
+messageToExp (Single i n v) =
+ AppE (AppE (AppE (ConE (mkName "Single")) (LitE (IntegerL (fromIntegral i)))) (LitE (StringL n))) (valueToExp v)
+
+particleToExp :: Particle -> Exp
+particleToExp (PMSingle n) =
+ AppE (ConE (mkName "PMSingle")) (LitE (StringL n))
+particleToExp (PMKeyword ns vs) =
+ AppE (AppE (ConE (mkName "PMKeyword")) (ListE (map (LitE . StringL) ns))) (ListE (map maybeValue vs))
+ where
+ maybeValue Nothing = ConE (mkName "Nothing")
+ maybeValue (Just v) = AppE (ConE (mkName "Just")) (valueToExp v)
+
+emessageToExp :: EMessage -> Exp
+emessageToExp (EKeyword i ns es) =
+ AppE (AppE (AppE (ConE (mkName "EKeyword")) (LitE (IntegerL (fromIntegral i)))) (ListE (map (LitE . StringL) ns))) (ListE (map exprToExp es))
+emessageToExp (ESingle i n e) =
+ AppE (AppE (AppE (ConE (mkName "ESingle")) (LitE (IntegerL (fromIntegral i)))) (LitE (StringL n))) (exprToExp e)
+
+eparticleToExp :: EParticle -> Exp
+eparticleToExp (EPMSingle n) =
+ AppE (ConE (mkName "EPMSingle")) (LitE (StringL n))
+eparticleToExp (EPMKeyword ns es) =
+ AppE (AppE (ConE (mkName "EPMKeyword")) (ListE (map (LitE . StringL) ns))) (ListE (map maybeExpr es))
+ where
+ maybeExpr Nothing = ConE (mkName "Nothing")
+ maybeExpr (Just e) = AppE (ConE (mkName "Just")) (exprToExp e)
+
+expr :: String -> Maybe SourcePos -> Exp
+expr n _ = AppE (ConE (mkName n)) (ConE (mkName "Nothing"))
+
+valueToExp :: Value -> Exp
+valueToExp (Block s as es) =
+ AppE (AppE (AppE (ConE (mkName "Block")) (valueToExp s)) (ListE (map patternToExp as))) (ListE (map exprToExp es))
+valueToExp (Char c) = AppE (ConE (mkName "Char")) (LitE (CharL c))
+valueToExp (Double d) = AppE (ConE (mkName "Double")) (LitE (RationalL (toRational d)))
+valueToExp (Expression e) = AppE (ConE (mkName "Expression")) (exprToExp e)
+valueToExp (Integer i) = AppE (ConE (mkName "Integer")) (LitE (IntegerL i))
+valueToExp (Message m) = AppE (ConE (mkName "Message")) (messageToExp m)
+valueToExp (Particle p) = AppE (ConE (mkName "Particle")) (particleToExp p)
+valueToExp (Pattern p) = AppE (ConE (mkName "Pattern")) (patternToExp p)
+valueToExp (String s) = AppE (VarE (mkName "string")) (LitE (StringL (T.unpack s)))
+valueToExp v = error $ "no valueToExp for: " ++ show v
+
+patternToExp :: Pattern -> Exp
+patternToExp PAny = ConE (mkName "PAny")
+patternToExp (PHeadTail h t) = AppE (AppE (ConE (mkName "PHeadTail")) (patternToExp h)) (patternToExp t)
+patternToExp (PKeyword i ns ts) =
+ AppE (AppE (AppE (ConE (mkName "PKeyword")) (LitE (IntegerL (fromIntegral i)))) (ListE (map (LitE . StringL) ns))) (ListE (map patternToExp ts))
+patternToExp (PList ps) =
+ AppE (ConE (mkName "PList")) (ListE (map patternToExp ps))
+patternToExp (PMatch v) =
+ AppE (ConE (mkName "PMatch")) (valueToExp v)
+patternToExp (PNamed n p) =
+ AppE (AppE (ConE (mkName "PNamed")) (LitE (StringL n))) (patternToExp p)
+patternToExp (PObject e) =
+ AppE (ConE (mkName "PObject")) (exprToExp e)
+patternToExp (PPMSingle n) =
+ AppE (ConE (mkName "PPMSingle")) (LitE (StringL n))
+patternToExp (PPMKeyword ns ts) =
+ AppE (AppE (ConE (mkName "PPMKeyword")) (ListE (map (LitE . StringL) ns))) (ListE (map patternToExp ts))
+patternToExp PSelf = ConE (mkName "PSelf")
+patternToExp (PSingle i n t) =
+ AppE (AppE (AppE (ConE (mkName "PSingle")) (LitE (IntegerL (fromIntegral i)))) (LitE (StringL n))) (patternToExp t)
diff --git a/src/Atomo/Kernel.hs b/src/Atomo/Kernel.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel.hs
@@ -0,0 +1,258 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel (load) where
+
+import Data.IORef
+import Data.List ((\\))
+import Data.Maybe (isJust)
+import qualified Data.IntMap as M
+
+import Atomo.Debug
+import Atomo.Environment
+import Atomo.Haskell
+import Atomo.Method
+import Atomo.Pretty
+
+import qualified Atomo.Kernel.Numeric as Numeric
+import qualified Atomo.Kernel.List as List
+import qualified Atomo.Kernel.String as String
+import qualified Atomo.Kernel.Block as Block
+import qualified Atomo.Kernel.Expression as Expression
+import qualified Atomo.Kernel.Concurrency as Concurrency
+import qualified Atomo.Kernel.Message as Message
+import qualified Atomo.Kernel.Comparable as Comparable
+import qualified Atomo.Kernel.Particle as Particle
+import qualified Atomo.Kernel.Pattern as Pattern
+import qualified Atomo.Kernel.Ports as Ports
+import qualified Atomo.Kernel.Time as Time
+import qualified Atomo.Kernel.Bool as Bool
+import qualified Atomo.Kernel.Association as Association
+import qualified Atomo.Kernel.Parameter as Parameter
+import qualified Atomo.Kernel.Exception as Exception
+import qualified Atomo.Kernel.Environment as Environment
+import qualified Atomo.Kernel.Eco as Eco
+import qualified Atomo.Kernel.Continuation as Continuation
+
+load :: VM ()
+load = do
+ [$p|this|] =::: [$e|dispatch sender|]
+
+ [$p|(x: Object) clone|] =: do
+ x <- here "x"
+ newObject $ \o -> o
+ { oDelegates = [x]
+ }
+
+ [$p|(x: Object) delegates-to: (y: Object)|] =: do
+ f <- here "x" >>= orefFor
+ t <- here "y"
+
+ from <- liftIO (readIORef f)
+ liftIO $ writeIORef f (from { oDelegates = oDelegates from ++ [t] })
+
+ return (particle "ok")
+
+ [$p|(x: Object) delegates-to?: (y: Object)|] =: do
+ x <- here "x"
+ y <- here "y"
+ delegatesTo x y >>= bool
+
+ [$p|(x: Object) is-a?: (y: Object)|] =: do
+ x <- here "x"
+ y <- here "y"
+ isA x y >>= bool
+
+ [$p|(x: Object) responds-to?: (p: Particle)|] =: do
+ x <- here "x"
+ Particle p' <- here "p" >>= findParticle
+
+ let completed =
+ case p' of
+ PMKeyword ns mvs -> keyword ns (completeKP mvs [x])
+ PMSingle n -> single n x
+
+ findMethod x completed
+ >>= bool . isJust
+
+ [$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|] =:
+ fmap (string . show . pretty) (here "x")
+
+ [$p|(x: Object) dump|] =: do
+ x <- here "x"
+ liftIO (putStrLn (prettyShow x))
+ return x
+
+ [$p|(t: Object) load: (fn: String)|] =: do
+ t <- here "t"
+ fn <- getString [$e|fn|]
+
+ modify $ \s -> s { top = t }
+
+ loadFile fn
+
+ return (particle "ok")
+
+ [$p|(t: Object) require: (fn: String)|] =: do
+ t <- here "t"
+ fn <- getString [$e|fn|]
+
+ modify $ \s -> s { top = t }
+
+ requireFile fn
+
+ return (particle "ok")
+
+ [$p|v do: (b: Block)|] =: do
+ v <- here "v"
+ b <- here "b" >>= findBlock
+ joinWith v b []
+ return v
+ [$p|v do: (b: Block) with: (l: List)|] =: do
+ v <- here "v"
+ b <- here "b" >>= findBlock
+ as <- getList [$e|l|]
+ joinWith v b as
+ return v
+
+ [$p|v join: (b: Block)|] =: do
+ v <- here "v"
+ b <- here "b" >>= findBlock
+ joinWith v b []
+ [$p|v join: (b: Block) with: (l: List)|] =: do
+ v <- here "v"
+ b <- here "b" >>= findBlock
+ as <- getList [$e|l|]
+ joinWith v b as
+
+
+ Association.load
+ Bool.load
+ Parameter.load
+ Numeric.load
+ List.load
+ String.load
+ Block.load
+ Expression.load
+ Concurrency.load
+ Message.load
+ Comparable.load
+ Particle.load
+ Pattern.load
+ Ports.load
+ Time.load
+ Exception.load
+ Environment.load
+ Eco.load
+ Continuation.load
+
+ prelude
+
+
+prelude :: VM ()
+prelude = mapM_ eval [$es|
+ v match: (b: Block) :=
+ if: b contents empty?
+ then: { raise: @(no-matches-for: v) }
+ else: {
+ es = b contents
+ [p, e] = es head targets
+
+ match = (p as: Pattern) matches?: v
+ if: (match == @no)
+ then: {
+ v match: (Block new: es tail in: b context)
+ }
+ else: {
+ @(yes: obj) = match
+ obj join: (Block new: [e] in: b context)
+ }
+ }
+|]
+
+joinWith :: Value -> Value -> [Value] -> VM Value
+joinWith t (Block s ps bes) as
+ | length ps > length as =
+ throwError (BlockArity (length ps) (length as))
+ | null as || null ps = do
+ case t of
+ Reference r -> do
+ Object ds ms <- objectFor t
+ blockScope <- newObject $ \o -> o
+ { oDelegates = ds ++ [s]
+ , oMethods = ms
+ }
+
+ res <- withTop blockScope (evalAll bes)
+ new <- objectFor blockScope
+ liftIO $ writeIORef r new
+ { oDelegates = oDelegates new \\ [s]
+ , oMethods = oMethods new
+ }
+
+ return res
+ _ -> do
+ blockScope <- newObject $ \o -> o
+ { oDelegates = [t, s]
+ }
+
+ withTop blockScope (evalAll bes)
+ | otherwise = do
+ -- a toplevel scope with transient definitions
+ pseudoScope <- newObject $ \o -> o
+ { oMethods = (bs, M.empty)
+ }
+
+ case t of
+ Reference r -> do
+ Object ds ms <- objectFor t
+ -- the original prototype, but without its delegations
+ -- this is to prevent dispatch loops
+ doppelganger <- newObject $ \o -> o
+ { oMethods = ms
+ }
+
+ -- the main scope, methods are taken from here and merged with
+ -- the originals. delegates to the pseudoscope and doppelganger
+ -- so it has their methods in scope, but definitions go here
+ blockScope <- newObject $ \o -> o
+ { oDelegates = pseudoScope : doppelganger : ds ++ [s]
+ }
+
+ res <- withTop blockScope (evalAll bes)
+ new <- objectFor blockScope
+ liftIO (writeIORef r new
+ { oDelegates = oDelegates new \\ [pseudoScope, doppelganger, s]
+ , oMethods = merge ms (oMethods new)
+ })
+
+ return res
+ _ -> do
+ blockScope <- newObject $ \o -> o
+ { oDelegates = [pseudoScope, t, s]
+ }
+
+ withTop blockScope (evalAll bes)
+ where
+ bs = addMethod (Slot (psingle "this" PSelf) t) $
+ toMethods . concat $ zipWith bindings' ps as
+
+ merge (os, ok) (ns, nk) =
+ ( foldl (flip addMethod) os (concat $ M.elems ns)
+ , foldl (flip addMethod) ok (concat $ M.elems nk)
+ )
+joinWith _ v _ = error $ "impossible: joinWith on " ++ show v
diff --git a/src/Atomo/Kernel.hs-boot b/src/Atomo/Kernel.hs-boot
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel.hs-boot
@@ -0,0 +1,5 @@
+module Atomo.Kernel (load) where
+
+import Atomo.Types (VM)
+
+load :: VM ()
diff --git a/src/Atomo/Kernel/Association.hs b/src/Atomo/Kernel/Association.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Association.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.Association (load) where
+
+import Atomo.Environment
+import Atomo.Haskell
+
+
+load :: VM ()
+load = mapM_ eval [$es|
+ operator right 1 ->
+
+ Association = Object clone
+ a -> b := Association clone do: { from = a; to = b }
+ (a: Association) show := a from show .. " -> " .. a to show
+
+ [] lookup: _ = @none
+ (a . as) lookup: k :=
+ if: (k == a from)
+ then: { @(ok: a to) }
+ else: { as lookup: k }
+
+ [] find: _ = @none
+ (a . as) find: k :=
+ if: (k == a from)
+ then: { @(ok: a) }
+ else: { as find: k }
+|]
diff --git a/src/Atomo/Kernel/Block.hs b/src/Atomo/Kernel/Block.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Block.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# OPTIONS -fno-warn-name-shadowing #-}
+module Atomo.Kernel.Block (load) where
+
+import qualified Data.IntMap as M
+
+import Atomo.Environment
+import Atomo.Haskell
+import Atomo.Method
+
+
+load :: VM ()
+load = do
+ [$p|Block new: (l: List)|] =:::
+ [$e|Block new: l in: dispatch sender|]
+
+ [$p|Block new: (l: List) in: t|] =: do
+ t <- here "t"
+ es <- getList [$e|l|]
+
+ let toExpr (Expression e') = e'
+ toExpr v = Primitive Nothing v
+
+ return (Block t [] (map toExpr es))
+
+ [$p|(b: Block) call|] =: do
+ Block s as es <- here "b" >>= findBlock
+
+ if length as > 0
+ then throwError (BlockArity (length as) 0)
+ else doBlock M.empty s es
+
+ [$p|(b: Block) call: (l: List)|] =: do
+ Block s ps es <- here "b" >>= findBlock
+ vs <- getList [$e|l|]
+
+ if length ps > length vs
+ then throwError (BlockArity (length ps) (length vs))
+ else doBlock (toMethods . concat $ zipWith bindings' ps vs) s es
+
+ [$p|(b: Block) context|] =: do
+ Block s _ _ <- here "b" >>= findBlock
+ return s
+
+ [$p|(b: Block) arguments|] =: do
+ Block _ as _ <- here "b" >>= findBlock
+ list (map Pattern as)
+
+ [$p|(b: Block) contents|] =: do
+ Block _ _ es <- here "b" >>= findBlock
+ list (map Expression es)
+
+ prelude
+
+
+prelude :: VM ()
+prelude = mapM_ eval [$es|
+ (b: Block) repeat := { b in-context call; b repeat } call
+
+ (b: Block) in-context :=
+ Object clone do: {
+ delegates-to: b
+ call := b context join: b
+ call: vs := b context join: b with: vs
+ }
+
+ (a: Block) .. (b: Block) :=
+ Block new: (a contents .. b contents)
+
+ (start: Integer) to: (end: Integer) by: (diff: Integer) do: b :=
+ (start to: end by: diff) each: b
+
+ (start: Integer) up-to: (end: Integer) do: b :=
+ start to: end by: 1 do: b
+
+ (start: Integer) down-to: (end: Integer) do: b :=
+ start to: end by: -1 do: b
+
+ (n: Integer) times: (b: Block) :=
+ 1 up-to: n do: b in-context
+|]
diff --git a/src/Atomo/Kernel/Bool.hs b/src/Atomo/Kernel/Bool.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Bool.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.Bool (load) where
+
+import Atomo.Environment
+import Atomo.Haskell
+
+
+load :: VM ()
+load = mapM_ eval [$es|
+ Bool = Object clone
+ True = Object clone
+ False = Object clone
+
+ True delegates-to: Bool
+ False delegates-to: Bool
+
+ True && True = True
+ Bool && Bool = False
+
+ False and: _ = False
+ True and: (b: Block) := b call
+
+ True || Bool = True
+ False || (b: Bool) := b
+
+ True or: _ = True
+ False or: (b: Block) := b call
+
+ True not := False
+ False not := True
+
+ if: True then: (a: Block) else: Block :=
+ a call
+
+ if: False then: Block else: (b: Block) :=
+ b call
+
+ when: (b: Bool) do: (action: Block) :=
+ if: b then: action in-context else: { @ok }
+
+ while: (test: Block) do: (action: Block) :=
+ when: test call
+ do: {
+ action context do: action
+ while: test do: action
+ }
+
+ True show := "True"
+ False show := "False"
+
+ otherwise := True
+
+ condition: (b: Block) :=
+ if: b contents empty?
+ then: { raise: "condition: no branches are true" }
+ else: {
+ es = b contents
+ [c, e] = es head targets
+
+ if: (c evaluate-in: b context)
+ then: { e evaluate-in: b context }
+ else: { condition: (Block new: es tail in: b context) }
+ }
+|]
diff --git a/src/Atomo/Kernel/Comparable.hs b/src/Atomo/Kernel/Comparable.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Comparable.hs
@@ -0,0 +1,211 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.Comparable (load) where
+
+import qualified Data.Vector as V
+
+import Atomo.Environment
+import Atomo.Haskell
+
+
+load :: VM ()
+load = do
+ mapM_ eval $
+ [ [$e|operator 4 ==, /=, <, <=, >=, >|]
+ , [$e|operator right 3 &&|]
+ , [$e|operator right 2 |||]
+ ]
+
+ [$p|a equals: b|] =: do
+ a <- here "a"
+ b <- here "b"
+ bool (a == b)
+
+ [$p|(a: Object) == (b: Object)|] =::: [$e|a equals: b|]
+ [$p|(a: Object) /= (b: Object)|] =::: [$e|(a == b) not|]
+
+ [$p|(a: Char) < (b: Char)|] =: do
+ Char a <- here "a" >>= findChar
+ Char b <- here "b" >>= findChar
+ bool (a < b)
+
+ [$p|(a: Integer) < (b: Integer)|] =: do
+ Integer a <- here "a" >>= findInteger
+ Integer b <- here "b" >>= findInteger
+ bool (a < b)
+
+ [$p|(a: Integer) < (b: Double)|] =: do
+ Integer a <- here "a" >>= findInteger
+ Double b <- here "b" >>= findDouble
+ bool (fromIntegral a < b)
+
+ [$p|(a: Double) < (b: Integer)|] =: do
+ Double a <- here "a" >>= findDouble
+ Integer b <- here "b" >>= findInteger
+ bool (a < fromIntegral b)
+
+ [$p|(a: Double) < (b: Double)|] =: do
+ Double a <- here "a" >>= findDouble
+ Double b <- here "b" >>= findDouble
+ bool (a < b)
+
+ [$p|(a: Char) > (b: Char)|] =: do
+ Char a <- here "a" >>= findChar
+ Char b <- here "b" >>= findChar
+ bool (a > b)
+
+ [$p|(a: Integer) > (b: Integer)|] =: do
+ Integer a <- here "a" >>= findInteger
+ Integer b <- here "b" >>= findInteger
+ bool (a > b)
+
+ [$p|(a: Integer) > (b: Double)|] =: do
+ Integer a <- here "a" >>= findInteger
+ Double b <- here "b" >>= findDouble
+ bool (fromIntegral a > b)
+
+ [$p|(a: Double) > (b: Integer)|] =: do
+ Double a <- here "a" >>= findDouble
+ Integer b <- here "b" >>= findInteger
+ bool (a > fromIntegral b)
+
+ [$p|(a: Double) > (b: Double)|] =: do
+ Double a <- here "a" >>= findDouble
+ Double b <- here "b" >>= findDouble
+ bool (a > b)
+
+ [$p|(a: Char) <= (b: Char)|] =: do
+ Char a <- here "a" >>= findChar
+ Char b <- here "b" >>= findChar
+ bool (a <= b)
+
+ [$p|(a: Integer) <= (b: Integer)|] =: do
+ Integer a <- here "a" >>= findInteger
+ Integer b <- here "b" >>= findInteger
+ bool (a <= b)
+
+ [$p|(a: Integer) <= (b: Double)|] =: do
+ Integer a <- here "a" >>= findInteger
+ Double b <- here "b" >>= findDouble
+ bool (fromIntegral a <= b)
+
+ [$p|(a: Double) <= (b: Integer)|] =: do
+ Double a <- here "a" >>= findDouble
+ Integer b <- here "b" >>= findInteger
+ bool (a <= fromIntegral b)
+
+ [$p|(a: Double) <= (b: Double)|] =: do
+ Double a <- here "a" >>= findDouble
+ Double b <- here "b" >>= findDouble
+ bool (a <= b)
+
+ [$p|(a: Char) >= (b: Char)|] =: do
+ Char a <- here "a" >>= findChar
+ Char b <- here "b" >>= findChar
+ bool (a >= b)
+
+ [$p|(a: Integer) >= (b: Integer)|] =: do
+ Integer a <- here "a" >>= findInteger
+ Integer b <- here "b" >>= findInteger
+ bool (a >= b)
+
+ [$p|(a: Integer) >= (b: Double)|] =: do
+ Integer a <- here "a" >>= findInteger
+ Double b <- here "b" >>= findDouble
+ bool (fromIntegral a >= b)
+
+ [$p|(a: Double) >= (b: Integer)|] =: do
+ Double a <- here "a" >>= findDouble
+ Integer b <- here "b" >>= findInteger
+ bool (a >= fromIntegral b)
+
+ [$p|(a: Double) >= (b: Double)|] =: do
+ Double a <- here "a" >>= findDouble
+ Double b <- here "b" >>= findDouble
+ bool (a >= b)
+
+ [$p|(a: Char) == (b: Char)|] =: do
+ Char a <- here "a" >>= findChar
+ Char b <- here "b" >>= findChar
+ bool (a == b)
+
+ [$p|(a: Integer) == (b: Integer)|] =: do
+ Integer a <- here "a" >>= findInteger
+ Integer b <- here "b" >>= findInteger
+ bool (a == b)
+
+ [$p|(a: Integer) == (b: Double)|] =: do
+ Integer a <- here "a" >>= findInteger
+ Double b <- here "b" >>= findDouble
+ bool (fromIntegral a == b)
+
+ [$p|(a: Double) == (b: Integer)|] =: do
+ Double a <- here "a" >>= findDouble
+ Integer b <- here "b" >>= findInteger
+ bool (a == fromIntegral b)
+
+ [$p|(a: Double) == (b: Double)|] =: do
+ Double a <- here "a" >>= findDouble
+ Double b <- here "b" >>= findDouble
+ bool (a == b)
+
+ [$p|(a: List) == (b: List)|] =: do
+ as <- getVector [$e|a|]
+ bs <- getVector [$e|b|]
+
+ if V.length as == V.length bs
+ then do
+ eqs <- V.zipWithM (\a b -> dispatch (keyword ["=="] [a, b])) as bs
+ true <- bool True
+ bool (V.all (== true) eqs)
+ else bool False
+
+ [$p|(a: Process) == (b: Process)|] =: do
+ Process _ a <- here "a" >>= findProcess
+ Process _ b <- here "b" >>= findProcess
+ bool (a == b)
+
+ [$p|(a: Message) == (b: Message)|] =: do
+ Message a <- here "a" >>= findMessage
+ Message b <- here "b" >>= findMessage
+
+ true <- bool True
+ case (a, b) of
+ (Single ai _ at, Single bi _ bt) -> do
+ t <- dispatch (keyword ["=="] [at, bt])
+ bool (ai == bi && t == true)
+ (Keyword ai _ avs, Keyword bi _ bvs)
+ | ai == bi && length avs == length bvs -> do
+ eqs <- zipWithM (\x y -> dispatch (keyword ["=="] [x, y])) avs bvs
+ bool (all (== true) eqs)
+ _ -> bool False
+
+ [$p|(a: Particle) == (b: Particle)|] =: do
+ Particle a <- here "a" >>= findParticle
+ Particle b <- here "b" >>= findParticle
+
+ true <- bool True
+ case (a, b) of
+ (PMSingle an, PMSingle bn) ->
+ bool (an == bn)
+ (PMKeyword ans avs, PMKeyword bns bvs)
+ | ans == bns && length avs == length bvs -> do
+ eqs <- zipWithM (\mx my ->
+ case (mx, my) of
+ (Nothing, Nothing) -> return true
+ (Just x, Just y) ->
+ dispatch (keyword ["=="] [x, y])
+ _ -> bool False) avs bvs
+ bool (all (== true) eqs)
+ _ -> bool False
+
+ prelude
+
+
+prelude :: VM ()
+prelude = mapM_ eval [$es|
+ x max: y :=
+ if: (x > y) then: { x } else: { y }
+
+ x min: y :=
+ if: (x < y) then: { x } else: { y }
+|]
diff --git a/src/Atomo/Kernel/Concurrency.hs b/src/Atomo/Kernel/Concurrency.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Concurrency.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.Concurrency (load) where
+
+import qualified Data.IntMap as M
+
+import Atomo.Environment
+import Atomo.Haskell
+import Atomo.Method
+
+
+load :: VM ()
+load = do
+ [$p|self|] =: do
+ chan <- gets channel
+ tid <- liftIO myThreadId
+ return (Process chan tid)
+
+ [$p|receive|] =: do
+ chan <- gets channel
+ v <- liftIO (readChan chan)
+ return v
+
+ [$p|halt|] =: gets halt >>= liftIO >> return (particle "ok")
+
+ [$p|(p: Process) ! v|] =: do
+ Process chan _ <- here "p" >>= findProcess
+ v <- here "v"
+ liftIO (writeChan chan v)
+ here "p"
+
+ [$p|(b: Block) spawn|] =: do
+ Block s as bes <- here "b" >>= findBlock
+
+ if length as > 0
+ then throwError (BlockArity (length as) 0)
+ else spawn (doBlock M.empty s bes)
+
+ [$p|(b: Block) spawn: (l: List)|] =: do
+ Block s as bes <- here "b" >>= findBlock
+ vs <- getList [$e|l|]
+
+ if length as > length vs
+ then throwError (BlockArity (length as) (length vs))
+ else spawn $
+ doBlock (toMethods . concat $ zipWith bindings' as vs) s bes
+
+ [$p|(p: Process) stop|] =: do
+ Process _ tid <- here "p" >>= findProcess
+ liftIO (killThread tid)
+ return (particle "ok")
diff --git a/src/Atomo/Kernel/Continuation.hs b/src/Atomo/Kernel/Continuation.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Continuation.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.Continuation where
+
+import Data.IORef
+
+import Atomo.Environment
+import Atomo.Haskell
+
+
+load :: VM ()
+load = do
+ [$p|current-continuation|] =:::
+ [$e|{ cc | cc } call/cc|]
+
+ -- call/cc actually makes an object delegating to Continuation
+ -- so just add the show definiton here
+ [$p|Continuation show|] =:: string ""
+
+ [$p|(c: Continuation) yield: v|] =: do
+ Continuation c <- here "c" >>= findContinuation
+ v <- here "v"
+ liftIO (readIORef c) >>= ($ v)
+
+ -- this enables call/cc as well
+ [$p|(c: Continuation) call: [v]|] =::: [$e|c yield: v|]
+
+ -- effectively just "jumping" to a continuation
+ [$p|(c: Continuation) yield|] =::: [$e|c yield: @ok|]
+ [$p|(c: Continuation) call|] =::: [$e|c yield: @ok|]
+
+ -- an object providing lower-level call/cc functionality
+ -- only used in call/cc's definition
+ callccObj <- newScope $ do
+ ([$p|o|] =::) =<< eval [$e|Object clone|]
+ [$p|(o) pass-to: b|] =: callCC $ \c -> do
+ b <- here "b"
+ cr <- liftIO (newIORef c)
+ as <- list [Continuation cr]
+ dispatch (keyword ["call"] [b, as])
+ eval [$e|o|]
+
+ -- define call/cc and dynamic-wind in a new scope for hiding
+ -- helper methods (internal-call/cc, dynamic-winds, dynamic-unwind)
+ newScope (dynamicWind callccObj >> return (particle "ok"))
+
+ return ()
+
+dynamicWind :: Value -> VM ()
+dynamicWind callccObj = do
+ [$p|internal-call/cc|] =:: callccObj
+ ([$p|dynamic-winds|] =::) =<< eval [$e|Parameter new: []|]
+
+ [$p|(o: Object) call/cc|] =::: [$e|internal-call/cc pass-to: { cont |
+ winds = dynamic-winds _? copy
+
+ new = cont clone do: {
+ yield: v := {
+ dynamic-unwind call: [
+ winds
+ dynamic-winds _? length - winds length
+ ]
+
+ cont yield: v
+ } call
+ }
+
+ o call: [new]
+ }|]
+
+ [$p|(v: Block) before: (b: Block)|] =::: [$e|v before: b after: { @ok }|]
+ [$p|(v: Block) after: (a: Block)|] =::: [$e|v before: { @ok } after: a|]
+ [$p|(v: Block) before: (b: Block) after: (a: Block)|] =::: [$e|{
+ b call
+
+ dynamic-winds =! ((b -> a) . dynamic-winds _?)
+
+ { v call } ensuring: {
+ dynamic-winds =! dynamic-winds _? tail
+ a call
+ }
+ } call|]
+
+ ([$p|dynamic-unwind|] =::) =<< eval [$e|{ to d |
+ condition: {
+ (dynamic-winds _? == to) -> @ok
+
+ (d < 0) -> {
+ dynamic-unwind call: [to tail, d + 1]
+ to head from call
+ dynamic-winds =! to
+ @ok
+ } call
+
+ otherwise -> {
+ post = dynamic-winds _? head to
+ dynamic-winds =! dynamic-winds _? tail
+ post call
+ dynamic-unwind call: [to, d - 1]
+ } call
+ }
+ }|]
diff --git a/src/Atomo/Kernel/Eco.hs b/src/Atomo/Kernel/Eco.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Eco.hs
@@ -0,0 +1,267 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.Eco where
+
+import Atomo.Environment
+import Atomo.Haskell
+
+
+load :: VM ()
+load = loadVersions >> loadEco
+
+loadEco :: VM ()
+loadEco = mapM_ eval [$es|
+ Eco = Object clone do: {
+ -- all packages OK for loading
+ -- name -> [package]
+ packages = []
+
+ -- versions loaded by @use:
+ -- name -> package
+ loaded = []
+ }
+
+ Eco Package = Object clone do: {
+ version = 0 . 1
+ dependencies = []
+ include = []
+ executables = []
+ }
+
+ (e: Eco) initialize :=
+ e initialize: (Eco Package load-from: "package.eco")
+
+ (e: Eco) initialize: pkg := {
+ pkg dependencies each: { c |
+ e packages (find: c from) match: {
+ @none -> raise: ("required package not found: " .. c from .. " (satisfying " .. c to show .. ")")
+
+ -- filter out versions not satisfying our dependency
+ @(ok: d) -> {
+ safe = d to (filter: { p | p version join: c to })
+
+ safe match: {
+ [] ->
+ raise:
+ [
+ "no versions of package "
+ d from
+ " (" .. d to (map: { p | p version as: String }) (join: ", ") .. ")"
+ " satisfy constraint "
+ c to show
+ " for package " .. pkg name show
+ ] concat
+
+ -- initialize the first safe version of the package
+ (p . _) -> {
+ -- remove unsafe versions from the ecosystem
+ d to = safe
+ e initialize: p
+ } call
+ }
+ } call
+ }
+ }
+
+ @ok
+ } call
+
+ (e: Eco) load := {
+ eco = Directory home ".eco" "lib"
+
+ e packages = Directory (contents: eco) map: { c |
+ versions = Directory (contents: (eco c))
+ pkgs = versions map: { v |
+ Eco Package load-from:
+ (eco c v "package.eco")
+ }
+
+ c -> pkgs (sort-by: { a b | a version < b version })
+ }
+ } call
+
+ Eco path-to: (c: Eco Package) :=
+ Eco path-to: c name version: c version
+
+ Eco path-to: (name: String) :=
+ Directory home ".eco" "lib" name
+
+ Eco path-to: (name: String) version: (v: Version) :=
+ (Eco path-to: name) (v as: String)
+
+ Eco executable: (name: String) :=
+ Directory home ".eco" "bin" name
+
+ Eco install: (path: String) := {
+ pkg = Eco Package load-from: (path "package.eco")
+ target = Eco path-to: pkg
+
+ contents = "main.atomo" . ("package.eco" . pkg include)
+
+ Directory create-tree-if-missing: target
+
+ contents each: { c |
+ if: Directory (exists?: (path c))
+ then: { Directory copy: (path c) to: (target c) }
+ else: { File copy: (path c) to: (target c) }
+ }
+
+ pkg executables each: { e |
+ File copy: (path e to) to: (Eco executable: e from)
+ File set-executable: (Eco executable: e from) to: True
+ }
+ } call
+
+ Eco uninstall: (name: String) version: (version: Version) := {
+ path = Eco path-to: name version: version
+ pkg = Eco Package load-from: (path "package.eco")
+
+ Directory remove-recursive: path
+ pkg executables each: { e |
+ File remove: (Eco executable: e from)
+ }
+ } call
+
+ Eco uninstall: (name: String) :=
+ Directory (contents: (Eco path-to: name)) each: { v |
+ Eco uninstall: name version: (v as: Version)
+ }
+
+ context use: (name: String) :=
+ context use: name version: { True }
+
+ context use: (name: String) version: (v: Version) :=
+ context use: name version: { == v }
+
+ context use: (name: String) version: (check: Block) := {
+ Eco loaded (lookup: name) match: {
+ @none -> {
+ Eco packages (lookup: name) match: {
+ @none -> raise: ("package not found: " .. name)
+ @(ok: []) -> raise: ("no versions for package: " .. name)
+ @(ok: pkgs) -> {
+ satisfactory = pkgs filter: { p | p version join: check }
+
+ when: satisfactory empty?
+ do: {
+ raise:
+ [
+ "no versions of package "
+ name
+ " (" .. versions (map: @(as: String)) (join: ", ") .. ")"
+ " satisfy constraint "
+ check show
+ ] concat
+ }
+
+ Eco loaded << (name -> satisfactory head)
+
+ context load: ((Eco path-to: satisfactory head) "main.atomo")
+ } call
+ }
+ } call
+
+ @(ok: p) ->
+ when: (p version join: check) not
+ do: { raise: ("package " .. name .. " already loaded, but version (" .. (v as: String) .. ") does not satisfy constraint " .. check show) }
+ }
+
+ @ok
+ } call
+
+ (p: Eco Package) name: (n: String) :=
+ p name = n
+
+ (p: Eco Package) description: (d: String) :=
+ p description = d
+
+ (p: Eco Package) version: (v: Version) :=
+ p version = v
+
+ (p: Eco Package) author: (a: String) :=
+ p author = a
+
+ (p: Eco Package) include: (l: List) :=
+ p include = l
+
+ (p: Eco Package) depends-on: (ds: List) :=
+ p dependencies = ds map: { d |
+ if: (d is-a?: Association)
+ then: { d }
+ else: { d -> { True } }
+ }
+
+ (p: Eco Package) executables: (es: List) :=
+ p executables = es
+
+ Eco Package load-from: (file: String) :=
+ Eco Package clone do: { load: file }
+
+ Eco load
+|]
+
+loadVersions :: VM ()
+loadVersions = mapM_ eval [$es|
+ Version = Object clone
+
+ (major: Integer) . (minor: Integer) :=
+ Version clone do: {
+ major = major
+ minor = minor
+ }
+
+ (major: Integer) . (rest: Version) :=
+ Version clone do: {
+ major = major
+ minor = rest
+ }
+
+ (v: Version) show :=
+ v major show .. " . " .. v minor show
+
+ (v: Version) as: String :=
+ v major show .. "." .. v minor (as: String)
+
+ (s: String) as: Version :=
+ s (split-on: '.') (map: @(as: Integer)) reduce-right: @.
+
+ (n: Integer) as: Version := n . 0
+
+ (a: Version) == (b: Version) :=
+ (a major == b major) and: { a minor == b minor }
+
+ (a: Version) > (b: Version) :=
+ (a major > b major) or: { a minor > b minor }
+
+ (n: Integer) > (v: Version) :=
+ (n > v major) or: { v major == n && v minor /= 0 }
+
+ (v: Version) > (n: Integer) :=
+ (v major > n) or: { v major == n && v minor /= 0 }
+
+ (a: Version) < (b: Version) :=
+ (a major < b major) or: { a minor < b minor }
+
+ (n: Integer) < (v: Version) :=
+ (n < v major) or: { v major == n && v minor /= 0 }
+
+ (v: Version) < (n: Integer) :=
+ (v major < n) or: { v major == n && v minor /= 0 }
+
+ (a: Version) >= (b: Version) :=
+ (a major >= b major) or: { a minor >= b minor }
+
+ (n: Integer) >= (v: Version) :=
+ n >= v major
+
+ (v: Version) >= (n: Integer) :=
+ v major >= n
+
+ (a: Version) <= (b: Version) :=
+ (a major <= b major) or: { a minor <= b minor }
+
+ (n: Integer) <= (v: Version) :=
+ n <= v major
+
+ (v: Version) <= (n: Integer) :=
+ v major <= n
+|]
diff --git a/src/Atomo/Kernel/Environment.hs b/src/Atomo/Kernel/Environment.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Environment.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.Environment where
+
+import System.Environment
+
+import Atomo.Environment
+import Atomo.Haskell
+
+
+load :: VM ()
+load = do
+ ([$p|Environment|] =::) =<< eval [$e|Object clone|]
+
+ [$p|Environment arguments|] =:
+ liftIO getArgs >>= list . map string
+
+ [$p|Environment program-name|] =:
+ fmap string $ liftIO getProgName
+
+ [$p|Environment get: (name: String)|] =:
+ getString [$e|name|]
+ >>= fmap string . (liftIO . getEnv)
+
+ [$p|Environment all|] =: do
+ env <- liftIO getEnvironment
+
+ assocs <- forM env $ \(k, v) ->
+ dispatch (keyword ["->"] [string k, string v])
+
+ list assocs
diff --git a/src/Atomo/Kernel/Exception.hs b/src/Atomo/Kernel/Exception.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Exception.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.Exception (load) where
+
+import Atomo.Environment
+import Atomo.Haskell
+
+
+load :: VM ()
+load = do
+ [$p|raise: v|] =: do
+ v <- here "v"
+ throwError (Error v)
+
+ [$p|(action: Block) catch: (recover: Block)|] =:
+ catchError (eval [$e|action call|]) $ \err -> do
+ recover <- here "recover"
+ args <- list [asValue err]
+
+ dispatch (keyword ["call"] [recover, args])
+
+ [$p|(action: Block) catch: (recover: Block) ensuring: (cleanup: Block)|] =:
+ catchError (eval [$e|action call|]) $ \err -> do
+ recover <- here "recover"
+ args <- list [asValue err]
+
+ res <- dispatch (keyword ["call"] [recover, args])
+ eval [$e|cleanup call|]
+ return res
+
+ [$p|(action: Block) ensuring: (cleanup: Block)|] =:
+ catchError
+ (do r <- eval [$e|action call|]
+ eval [$e|cleanup call|]
+ return r)
+ (\err -> eval [$e|cleanup call|] >> throwError err)
+
+ [$p|v ensuring: p do: b|] =:::
+ [$e|{ b call: [v] } ensuring: { p call: [v] }|]
+
+
+
+asValue :: AtomoError -> Value
+asValue (Error v) = v
+asValue (ParseError pe) =
+ keyParticleN ["parse-error"] [string (show pe)]
+asValue (DidNotUnderstand m) =
+ keyParticleN ["did-not-understand"] [Message m]
+asValue (Mismatch pat v) =
+ keyParticleN
+ ["pattern", "did-not-match"]
+ [Pattern pat, v]
+asValue (ImportError ie) =
+ keyParticleN ["import-error"] [string (show ie)]
+asValue (FileNotFound fn) =
+ keyParticleN ["file-not-found"] [string fn]
+asValue (ParticleArity e' g) =
+ keyParticleN
+ ["particle-needed", "given"]
+ [Integer (fromIntegral e'), Integer (fromIntegral g)]
+asValue (BlockArity e' g) =
+ keyParticleN
+ ["block-expected", "given"]
+ [Integer (fromIntegral e'), Integer (fromIntegral g)]
+asValue NoExpressions = particle "no-expressions"
+asValue (ValueNotFound d v) =
+ keyParticleN ["could-not-found", "in"] [string d, v]
diff --git a/src/Atomo/Kernel/Expression.hs b/src/Atomo/Kernel/Expression.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Expression.hs
@@ -0,0 +1,94 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# OPTIONS -fno-warn-name-shadowing #-}
+module Atomo.Kernel.Expression (load) where
+
+import Atomo.Environment
+import Atomo.Haskell
+
+
+load :: VM ()
+load = do
+ [$p|(e: Expression) evaluate|] =: do
+ Expression e <- here "e" >>= findExpression
+ eval e
+
+ [$p|(e: Expression) evaluate-in: t|] =: do
+ Expression e <- here "e" >>= findExpression
+ t <- here "t"
+ withTop t (eval e)
+
+ [$p|(e: Expression) type|] =: do
+ Expression e <- here "e" >>= findExpression
+ case e of
+ Dispatch {} -> return (particle "dispatch")
+ Define {} -> return (particle "define")
+ Set {} -> return (particle "set")
+ Operator {} -> return (particle "operator")
+ Primitive {} -> return (particle "primitive")
+ EBlock {} -> return (particle "block")
+ EDispatchObject {} -> return (particle "call")
+ EVM {} -> return (particle "vm")
+ EList {} -> return (particle "list")
+ ETop {} -> return (particle "top")
+ EParticle {} -> return (particle "particle")
+
+ [$p|(e: Expression) dispatch-type|] =: do
+ Expression (Dispatch _ d) <- here "e" >>= findExpression
+ case d of
+ ESingle {} -> return (particle "single")
+ EKeyword {} -> return (particle "keyword")
+
+ [$p|(e: Expression) particle-type|] =: do
+ Expression (EParticle _ p) <- here "e" >>= findExpression
+ case p of
+ EPMKeyword {} -> return (particle "keyword")
+ EPMSingle {} -> return (particle "single")
+
+ [$p|(e: Expression) target|] =: do
+ Expression (Dispatch _ (ESingle { emTarget = t })) <- here "e" >>= findExpression
+ return (Expression t)
+
+ [$p|(e: Expression) particle|] =: do
+ Expression (Dispatch _ em) <- here "e" >>= findExpression
+
+ case em of
+ EKeyword { emNames = ns } ->
+ return (keyParticle ns (replicate (length ns + 1) Nothing))
+ ESingle { emName = n } -> return (particle n)
+
+ [$p|(e: Expression) targets|] =: do
+ Expression (Dispatch _ (EKeyword { emTargets = vs })) <- here "e" >>= findExpression
+ list (map Expression vs)
+
+ [$p|(e: Expression) name|] =: do
+ Expression (EParticle _ (EPMSingle n)) <- here "e" >>= findExpression
+ return (string n)
+
+ [$p|(e: Expression) names|] =: do
+ Expression (EParticle _ (EPMKeyword ns _)) <- here "e" >>= findExpression
+ list (map string ns)
+
+ [$p|(e: Expression) values|] =: do
+ Expression (EParticle _ (EPMKeyword _ mes)) <- here "e" >>= findExpression
+ list $
+ map
+ (maybe (particle "none") (keyParticle ["ok"] . ([Nothing] ++) . (:[]). Just . Expression))
+ mes
+
+ [$p|(e: Expression) contents|] =: do
+ Expression (EList _ es) <- here "e" >>= findExpression
+ list (map Expression es)
+
+ [$p|(e: Expression) pattern|] =: do
+ Expression e <- here "e" >>= findExpression
+ case e of
+ Set { ePattern = p } -> return (Pattern p)
+ Define { ePattern = p } -> return (Pattern p)
+ _ -> raise ["no-pattern-for"] [Expression e]
+
+ [$p|(e: Expression) expression|] =: do
+ Expression e <- here "e" >>= findExpression
+ case e of
+ Set { eExpr = e } -> return (Expression e)
+ Define { eExpr = e } -> return (Expression e)
+ _ -> raise ["no-expression-for"] [Expression e]
diff --git a/src/Atomo/Kernel/List.hs b/src/Atomo/Kernel/List.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/List.hs
@@ -0,0 +1,400 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.List (load) where
+
+import Data.IORef
+import Data.List.Split
+import qualified Data.Vector as V
+
+import Atomo.Environment
+import Atomo.Haskell
+
+
+load :: VM ()
+load = do
+ eval [$e|operator right .|]
+
+ [$p|(l: List) show|] =:::
+ [$e|"[" .. l (map: @show) (join: ", ") .. "]"|]
+
+ [$p|(l: List) copy|] =:
+ getVector [$e|l|] >>= list'
+
+ [$p|(l: List) length|] =:
+ getVector [$e|l|] >>= return . Integer . fromIntegral . V.length
+
+ [$p|(l: List) empty?|] =:
+ getVector [$e|l|] >>= bool . V.null
+
+ [$p|(l: List) at: (n: Integer)|] =: do
+ Integer n <- here "n" >>= findInteger
+ vs <- getVector [$e|l|]
+
+ if fromIntegral n >= V.length vs
+ then here "l" >>= \l -> raise
+ ["out-of-bounds", "for-list"]
+ [ Integer n
+ , l
+ ]
+ else return (vs `V.unsafeIndex` fromIntegral n)
+
+ [$p|[] head|] =: raise' "empty-list"
+ [$p|(l: List) head|] =:
+ getVector [$e|l|] >>= return . V.unsafeHead
+
+ [$p|[] last|] =: raise' "empty-list"
+ [$p|(l: List) last|] =:
+ getVector [$e|l|] >>= return . V.unsafeLast
+
+ -- TODO: handle negative ranges
+ [$p|(l: List) from: (s: Integer) to: (e: Integer)|] =: do
+ vs <- getVector [$e|l|]
+ Integer start <- here "s" >>= findInteger
+ Integer end <- here "e" >>= findInteger
+
+ if start < 0 || end < 0 || (start + end) > fromIntegral (V.length vs)
+ then here "l" >>= \l -> raise
+ ["invalid-range", "for-list"]
+ [ keyParticleN ["from", "to"] [Integer start, Integer end]
+ , l
+ ]
+ else list' (V.unsafeSlice
+ (fromIntegral start)
+ (fromIntegral end)
+ vs)
+
+ [$p|[] init|] =: raise' "empty-list"
+ [$p|(l: List) init|] =:
+ getVector [$e|l|] >>= list' . V.unsafeInit
+
+ [$p|[] tail|] =: raise' "empty-list"
+ [$p|(l: List) tail|] =:
+ getVector [$e|l|] >>= list' . V.unsafeTail
+
+ [$p|(l: List) take: (n: Integer)|] =: do
+ vs <- getVector [$e|l|]
+ Integer n <- here "n" >>= findInteger
+ list' (V.take (fromIntegral n) vs)
+
+ [$p|(l: List) drop: (n: Integer)|] =: do
+ vs <- getVector [$e|l|]
+ Integer n <- here "n" >>= findInteger
+ list' (V.drop (fromIntegral n) vs)
+
+ [$p|v replicate: (n: Integer)|] =: do
+ v <- here "v"
+ Integer n <- here "n" >>= findInteger
+ list' (V.replicate (fromIntegral n) v)
+
+ [$p|b repeat: (n: Integer)|] =: do
+ b <- here "b"
+ Integer n <- here "n" >>= findInteger
+ vs <- V.replicateM (fromIntegral n) $
+ dispatch (single "call" b)
+ list' vs
+
+ [$p|(a: List) .. (b: List)|] =: do
+ as <- getVector [$e|a|]
+ bs <- getVector [$e|b|]
+ list' (as V.++ bs)
+
+ [$p|(l: List) reverse|] =: do
+ getVector [$e|l|] >>= list' . V.reverse
+
+ [$p|(l: List) map: b|] =: do
+ vs <- getVector [$e|l|]
+ b <- here "b"
+
+ nvs <- V.mapM (\v -> do
+ as <- list' (V.singleton v)
+ dispatch (keyword ["call"] [b, as])) vs
+
+ list' nvs
+
+ [$p|(x: List) zip: (y: List)|] =::: [$e|x zip: y with: @->|]
+ [$p|(x: List) zip: (y: List) with: b|] =: do
+ xs <- getVector [$e|x|]
+ ys <- getVector [$e|y|]
+ b <- here "b"
+
+ nvs <- V.zipWithM (\x y -> do
+ as <- list [x, y]
+ dispatch (keyword ["call"] [b, as])) xs ys
+
+ list' nvs
+
+ [$p|(l: List) filter: b|] =: do
+ vs <- getVector [$e|l|]
+ b <- here "b"
+
+ t <- bool True
+ nvs <- V.filterM (\v -> do
+ as <- list [v]
+ check <- dispatch (keyword ["call"] [b, as])
+ return (check == t)) vs
+
+ list' nvs
+
+ [$p|[] reduce: b|] =: raise' "empty-list"
+ [$p|(l: List) reduce: b|] =: do
+ vs <- getVector [$e|l|]
+ b <- here "b"
+
+ V.fold1M (\x acc -> do
+ as <- list [x, acc]
+ dispatch (keyword ["call"] [b, as])) vs
+
+ [$p|(l: List) reduce: b with: v|] =: do
+ vs <- getVector [$e|l|]
+ b <- here "b"
+ v <- here "v"
+
+ V.foldM (\x acc -> do
+ as <- list [x, acc]
+ dispatch (keyword ["call"] [b, as])) v vs
+
+ [$p|[] reduce-right: b|] =: raise' "empty-list"
+ [$p|(l: List) reduce-right: b|] =: do
+ vs <- getVector [$e|l|]
+ b <- here "b"
+
+ foldr1MV (\x acc -> do
+ as <- list [x, acc]
+ dispatch (keyword ["call"] [b, as])) vs
+
+ [$p|(l: List) reduce-right: b with: v|] =: do
+ vs <- getVector [$e|l|]
+ b <- here "b"
+ v <- here "v"
+
+ foldrMV (\x acc -> do
+ as <- list [x, acc]
+ dispatch (keyword ["call"] [b, as])) v vs
+
+ [$p|(l: List) concat|] =::: [$e|l reduce: @.. with: []|]
+ [$p|(l: List) sum|] =::: [$e|l reduce: @+ with: 0|]
+ [$p|(l: List) product|] =::: [$e|l reduce: @* with: 1|]
+ [$p|(l: List) maximum|] =::: [$e|l reduce: @max:|]
+ [$p|(l: List) minimum|] =::: [$e|l reduce: @min:|]
+
+ [$p|(l: List) all?: b|] =: do
+ vs <- getVector [$e|l|]
+ b <- here "b"
+
+ t <- bool True
+ nvs <- V.mapM (\v -> do
+ as <- list' (V.singleton v)
+ check <- dispatch (keyword ["call"] [b, as])
+ return (check == t)) vs
+
+ bool (V.and nvs)
+
+ [$p|(l: List) any?: b|] =: do
+ vs <- getVector [$e|l|]
+ b <- here "b"
+
+ t <- bool True
+ nvs <- V.mapM (\v -> do
+ as <- list' (V.singleton v)
+ check <- dispatch (keyword ["call"] [b, as])
+ return (check == t)) vs
+
+ bool (V.or nvs)
+
+ [$p|(l: List) and|] =: do
+ vs <- getVector [$e|l|]
+ t <- bool True
+ bool (V.all (== t) vs)
+
+ [$p|(l: List) or|] =: do
+ vs <- getVector [$e|l|]
+ t <- bool True
+ bool (V.any (== t) vs)
+
+ -- TODO: take-while, drop-while
+
+ [$p|v in?: (l: List)|] =::: [$e|l contains?: v|]
+ [$p|(l: List) contains?: v|] =::: [$e|l any?: @(== v)|]
+
+ -- TODO: find
+
+ [$p|(x: Integer) .. (y: Integer)|] =: do
+ Integer x <- here "x" >>= findInteger
+ Integer y <- here "y" >>= findInteger
+
+ if x < y
+ then dispatch (keyword ["up-to"] [Integer x, Integer y])
+ else dispatch (keyword ["down-to"] [Integer x, Integer y])
+
+ [$p|(x: Integer) ... (y: Integer)|] =: do
+ Integer x <- here "x" >>= findInteger
+ Integer y <- here "y" >>= findInteger
+
+ if x < y
+ then dispatch (keyword ["up-to"] [Integer x, Integer (y - 1)])
+ else dispatch (keyword ["down-to"] [Integer x, Integer (y + 1)])
+
+ [$p|(x: Integer) to: (y: Integer) by: (d: Integer)|] =: do
+ Integer x <- here "x" >>= findInteger
+ Integer y <- here "y" >>= findInteger
+ Integer d <- here "d" >>= findInteger
+
+ list' $ V.generate
+ (fromIntegral $ abs ((y - x) `div` d) + 1)
+ (Integer . (x +) . (* d) . fromIntegral)
+
+ [$p|(x: Integer) up-to: (y: Integer)|] =::: [$e|x to: y by: 1|]
+ [$p|(x: Integer) down-to: (y: Integer)|] =::: [$e|x to: y by: -1|]
+
+ -- destructive update
+ [$p|(l: List) at: (n: Integer) put: v|] =: do
+ List l <- here "l" >>= findList
+ vs <- getVector [$e|l|]
+
+ Integer n <- here "n" >>= findInteger
+ v <- here "v"
+
+ if fromIntegral n >= V.length vs
+ then here "l" >>= \l' -> raise
+ ["out-of-bounds", "for-list"]
+ [ Integer n
+ , l'
+ ]
+ else do
+
+ liftIO . writeIORef l $ vs V.// [(fromIntegral n, v)]
+
+ return (List l)
+
+ [$p|v . (l: List)|] =: do
+ vs <- getVector [$e|l|]
+ v <- here "v"
+ l <- liftIO . newIORef $ V.cons v vs
+ return (List l)
+
+ [$p|(l: List) << v|] =::: [$e|l push: v|]
+ [$p|v >> (l: List)|] =::: [$e|l left-push: v|]
+
+ [$p|(l: List) push: v|] =: do
+ List l <- here "l" >>= findList
+ vs <- getVector [$e|l|]
+ v <- here "v"
+
+ liftIO . writeIORef l $ V.snoc vs v
+
+ return (List l)
+
+ [$p|(l: List) left-push: v|] =: do
+ List l <- here "l" >>= findList
+ vs <- getVector [$e|l|]
+ v <- here "v"
+
+ liftIO . writeIORef l $ V.cons v vs
+
+ return (List l)
+
+ [$p|[] pop!|] =: raise' "empty-list"
+ [$p|(l: List) pop!|] =: do
+ List l <- here "l" >>= findList
+ vs <- getVector [$e|l|]
+
+ liftIO . writeIORef l $ V.tail vs
+
+ return (List l)
+
+ [$p|(l: List) split: (d: List)|] =: do
+ l <- getList [$e|l|]
+ d <- getList [$e|d|]
+
+ mapM list (splitOn d l) >>= list
+
+ [$p|(l: List) split-on: d|] =: do
+ l <- getList [$e|l|]
+ d <- here "d"
+
+ mapM list (splitWhen (== d) l) >>= list
+
+ [$p|(l: List) sort|] =:
+ getList [$e|l|] >>= sortVM >>= list
+
+ [$p|(l: List) sort-by: cmp|] =: do
+ t <- bool True
+ vs <- getList [$e|l|]
+ cmp <- here "cmp"
+
+ sortByVM (\a b -> do
+ as <- list [a, b]
+ r <- dispatch (keyword ["call"] [cmp, as])
+ return (r == t)) vs >>= list
+
+ prelude
+
+
+prelude :: VM ()
+prelude = mapM_ eval [$es|
+ (l: List) each: (b: Block) := {
+ l map: b in-context
+ l
+ } call
+
+ [] includes?: List := False
+ (x: List) includes?: (y: List) :=
+ if: (x (take: y length) == y)
+ then: { True }
+ else: { x tail includes?: y }
+
+ [] join: List := []
+ [x] join: List := x
+ (x . xs) join: (d: List) :=
+ x .. d .. (xs join: d)
+|]
+
+foldr1MV :: (Value -> Value -> VM Value) -> V.Vector Value -> VM Value
+foldr1MV f vs = foldrMV f (V.last vs) (V.init vs)
+
+foldrMV :: (Value -> Value -> VM Value) -> Value -> V.Vector Value -> VM Value
+foldrMV _ acc vs | V.null vs = return acc
+foldrMV f acc vs = do
+ rest <- foldrMV f acc (V.tail vs)
+ f (V.head vs) rest
+
+sortVM :: [Value] -> VM [Value]
+sortVM = sortByVM gt
+ where
+ gt a b = do
+ t <- bool True
+ r <- dispatch (keyword [">"] [a, b])
+ return (r == t)
+
+sortByVM :: (Value -> Value -> VM Bool) -> [Value] -> VM [Value]
+sortByVM = mergesort
+
+mergesort :: (Value -> Value -> VM Bool) -> [Value] -> VM [Value]
+mergesort cmp = mergesort' cmp . map (\x -> [x])
+
+mergesort' :: (Value -> Value -> VM Bool) -> [[Value]] -> VM [Value]
+mergesort' _ [] = return []
+mergesort' _ [xs] = return xs
+mergesort' cmp xss = merge_pairs cmp xss >>= mergesort' cmp
+
+merge_pairs :: (Value -> Value -> VM Bool) -> [[Value]] -> VM [[Value]]
+merge_pairs _ [] = return []
+merge_pairs _ [xs] = return [xs]
+merge_pairs cmp (xs:ys:xss) = do
+ z <- merge cmp xs ys
+ zs <- merge_pairs cmp xss
+ return (z:zs)
+
+merge :: (Value -> Value -> VM Bool) -> [Value] -> [Value] -> VM [Value]
+merge _ [] ys = return ys
+merge _ xs [] = return xs
+merge cmp (x:xs) (y:ys) = do
+ o <- cmp x y
+
+ if o
+ then do
+ rest <- merge cmp (x:xs) ys
+ return (y:rest)
+ else do
+ rest <- merge cmp xs (y:ys)
+ return (x:rest)
+
diff --git a/src/Atomo/Kernel/Message.hs b/src/Atomo/Kernel/Message.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Message.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.Message (load) where
+
+import Atomo.Environment
+import Atomo.Haskell
+
+
+load :: VM ()
+load = do
+ [$p|(m: Message) type|] =: do
+ Message m <- here "m" >>= findMessage
+ case m of
+ Single {} -> return (particle "single")
+ Keyword {} -> return (particle "keyword")
+
+ [$p|(m: Message) particle|] =: do
+ Message m <- here "m" >>= findMessage
+ case m of
+ Single { mName = n } -> return (particle n)
+ Keyword { mNames = ns } -> return (keyParticle ns (replicate (length ns + 1) Nothing))
+
+ [$p|(m: Message) target|] =: do
+ Message (Single { mTarget = t }) <- here "m" >>= findMessage
+ return t
+
+ [$p|(m: Message) targets|] =: do
+ Message (Keyword { mTargets = ts }) <- here "m" >>= findMessage
+ list ts
diff --git a/src/Atomo/Kernel/Numeric.hs b/src/Atomo/Kernel/Numeric.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Numeric.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.Numeric (load) where
+
+import Atomo.Environment
+import Atomo.Haskell
+
+
+load :: VM ()
+load = do
+ mapM_ eval $
+ [ [$e|operator right 8 ^|]
+ , [$e|operator 7 %, *, /|]
+ , [$e|operator 6 +, -|]
+ ]
+
+ eval [$e|Object clone|] >>= ([$p|Number|] =::)
+
+ eval [$e|Integer delegates-to: Number|]
+ eval [$e|Double delegates-to: Number|]
+
+ [$p|(a: Integer) sqrt|] =: do
+ Integer a <- here "a" >>= findInteger
+ return (Double (sqrt (fromIntegral a)))
+
+ [$p|(a: Double) sqrt|] =: do
+ Double a <- here "a" >>= findDouble
+ return (Double (sqrt a))
+
+ [$p|(a: Integer) + (b: Integer)|] =: primII (+)
+ [$p|(a: Integer) + (b: Double)|] =: primID (+)
+ [$p|(a: Double) + (b: Integer)|] =: primDI (+)
+ [$p|(a: Double) + (b: Double)|] =: primDD (+)
+ [$p|(a: Integer) - (b: Integer)|] =: primII (-)
+ [$p|(a: Integer) - (b: Double)|] =: primID (-)
+ [$p|(a: Double) - (b: Integer)|] =: primDI (-)
+ [$p|(a: Double) - (b: Double)|] =: primDD (-)
+ [$p|(a: Integer) * (b: Integer)|] =: primII (*)
+ [$p|(a: Integer) * (b: Double)|] =: primID (*)
+ [$p|(a: Double) * (b: Integer)|] =: primDI (*)
+ [$p|(a: Double) * (b: Double)|] =: primDD (*)
+ [$p|(a: Integer) / (b: Integer)|] =: primII div
+ [$p|(a: Integer) / (b: Double)|] =: primID (/)
+ [$p|(a: Double) / (b: Integer)|] =: primDI (/)
+ [$p|(a: Double) / (b: Double)|] =: primDD (/)
+ [$p|(a: Integer) ^ (b: Integer)|] =: primII (^)
+ [$p|(a: Integer) ^ (b: Double)|] =: primID (**)
+ [$p|(a: Double) ^ (b: Integer)|] =: primDI (**)
+ [$p|(a: Double) ^ (b: Double)|] =: primDD (**)
+
+ [$p|(a: Integer) % (b: Integer)|] =: primII mod
+ [$p|(a: Integer) quotient: (b: Integer)|] =: primII quot
+ [$p|(a: Integer) remainder: (b: Integer)|] =: primII rem
+
+ prelude
+ where
+ primII f = do
+ Integer a <- here "a" >>= findInteger
+ Integer b <- here "b" >>= findInteger
+ return (Integer (f a b))
+
+ primID f = do
+ Integer a <- here "a" >>= findInteger
+ Double b <- here "b" >>= findDouble
+ return (Double (f (fromIntegral a) b))
+
+ primDI f = do
+ Double a <- here "a" >>= findDouble
+ Integer b <- here "b" >>= findInteger
+ return (Double (f a (fromIntegral b)))
+
+ primDD f = do
+ Double a <- here "a" >>= findDouble
+ Double b <- here "b" >>= findDouble
+ return (Double (f a b))
+
+
+prelude :: VM ()
+prelude = mapM_ eval [$es|
+ (n: Integer) even? := 2 divides?: n
+ (n: Integer) odd? := n even? not
+
+ (x: Integer) divides?: (y: Integer) :=
+ (y % x) == 0
+
+ (x: Integer) divisible-by?: (y: Integer) :=
+ y divides?: x
+|]
diff --git a/src/Atomo/Kernel/Parameter.hs b/src/Atomo/Kernel/Parameter.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Parameter.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.Parameter (load) where
+
+import Atomo.Environment
+import Atomo.Haskell
+
+
+load :: VM ()
+load = mapM_ eval [$es|
+ operator right 0 =!
+
+ Parameter = Object clone
+ Parameter new: v := Parameter clone do: {
+ set-default: v
+ }
+
+ (p: Parameter) _? := p value: self
+
+ (p: Parameter) =! v :=
+ (p) value: (self) = v
+
+ (p: Parameter) set-default: v :=
+ (p) value: _ = v
+
+ with: (p: Parameter) as: new do: (action: Block) := {
+ old = p _?
+ action before: { p =! new } after: { p =! old }
+ } call
+
+ with-default: (p: Parameter) as: new do: (action: Block) := {
+ old = p _?
+ action before: { p set-default: new } after: { p set-default: old }
+ } call
+
+ with: [] do: (action: Block) := action call
+ with: (b . bs) do: (action: Block) :=
+ with: b from as: b to do: { with: bs do: action }
+
+ with-defaults: [] do: (action: Block) := action call
+ with-defaults: (b . bs) do: (action: Block) :=
+ with-default: b from as: b to do: { with: bs do: action }
+|]
diff --git a/src/Atomo/Kernel/Particle.hs b/src/Atomo/Kernel/Particle.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Particle.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# OPTIONS -fno-warn-name-shadowing #-}
+module Atomo.Kernel.Particle (load) where
+
+import Atomo.Environment
+import Atomo.Haskell
+
+
+load :: VM ()
+load = do
+ [$p|(p: Particle) show|] =::: [$e|
+ p type match: {
+ @keyword -> {
+ operator? = @(all?: @(in?: "~!@#$%^&*-_=+./\\\|<>?:"))
+
+ keywordfy = { str |
+ if: (operator? call: [str])
+ then: { str }
+ else: { str .. ":" }
+ }
+
+ vs := p values map: { v |
+ v match: {
+ @none -> "_"
+ @(ok: v) -> v show
+ }
+ }
+
+ initial := vs head match: {
+ "_" -> ""
+ v -> v .. " "
+ }
+
+ rest := (p names zip: vs tail) (map: { pair |
+ keywordfy call: [pair from] .. " " .. pair to
+ }) (join: " ")
+
+ if: p values (all?: @(== @none))
+ then: { "@" .. p names (map: { n | keywordfy call: [n] }) join }
+ else: {
+ "@(" .. initial .. rest .. ")"
+ }
+ } call
+
+ @single ->
+ ("@" .. p name)
+ }
+ |]
+
+ [$p|(p: Particle) call: (l: List)|] =: do
+ Particle p <- here "p" >>= findParticle
+ vs <- getList [$e|l|]
+
+ case p of
+ PMKeyword ns mvs -> do
+ let blanks = length (filter (== Nothing) mvs)
+
+ if blanks > length vs
+ then throwError (ParticleArity blanks (length vs))
+ else dispatch (keyword ns $ completeKP mvs vs)
+ PMSingle n -> do
+ if length vs == 0
+ then throwError (ParticleArity 1 0)
+ else dispatch (single n (head vs))
+
+ [$p|(p: Particle) name|] =: do
+ Particle (PMSingle n) <- here "p" >>= findParticle
+ return (string n)
+
+ [$p|(p: Particle) names|] =: do
+ Particle (PMKeyword ns _) <- here "p" >>= findParticle
+ list (map string ns)
+
+ [$p|(p: Particle) values|] =: do
+ (Particle (PMKeyword _ mvs)) <- here "p" >>= findParticle
+ list $
+ map
+ (maybe (particle "none") (keyParticleN ["ok"] . (:[])))
+ mvs
+
+ [$p|(p: Particle) type|] =: do
+ Particle p <- here "p" >>= findParticle
+ case p of
+ PMKeyword {} -> return (particle "keyword")
+ PMSingle {} -> return (particle "single")
diff --git a/src/Atomo/Kernel/Pattern.hs b/src/Atomo/Kernel/Pattern.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Pattern.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# OPTIONS -fno-warn-name-shadowing #-}
+module Atomo.Kernel.Pattern (load) where
+
+import Atomo.Environment
+import Atomo.Haskell
+import Atomo.Method
+
+
+load :: VM ()
+load = do
+ [$p|(e: Expression) as: Pattern|] =: do
+ Expression e <- here "e" >>= findExpression
+ p <- toPattern e
+ return (Pattern p)
+
+ [$p|(p: Pattern) matches?: v|] =: do
+ Pattern p <- here "p" >>= findPattern
+ v <- here "v"
+ ids <- gets primitives
+
+ if match ids p v
+ then do
+ obj <- eval [$e|Object clone|]
+ o <- newObject $ \o -> o
+ { oDelegates = [obj]
+ , oMethods = (toMethods (bindings' p v), snd (oMethods o))
+ }
+
+ return (keyParticle ["yes"] [Nothing, Just o])
+ else return (particle "no")
+ where
+ -- convert an expression to the pattern match it represents
+ 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 = ESingle { emName = "_" } }) =
+ return PAny
+ toPattern (Dispatch { eMessage = ESingle { emName = n } }) =
+ return (PNamed n PAny)
+ toPattern (EList { eContents = es }) = do
+ ps <- mapM toPattern es
+ return (PList ps)
+ toPattern (EParticle { eParticle = EPMSingle n }) =
+ return (PPMSingle 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 (Primitive { eValue = v }) =
+ return (PMatch v)
+ toPattern e = raise ["unknown-pattern"] [Expression e]
diff --git a/src/Atomo/Kernel/Ports.hs b/src/Atomo/Kernel/Ports.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Ports.hs
@@ -0,0 +1,414 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.Ports (load) where
+
+import Data.Char (isSpace)
+import Data.Dynamic
+import Data.Maybe (catMaybes)
+import System.Directory
+import System.FilePath ((), (<.>))
+import System.IO
+import qualified Data.Text.IO as TIO
+
+import Atomo.Environment
+import Atomo.Haskell
+import Atomo.Parser
+import Atomo.Pretty
+
+
+load :: VM ()
+load = do
+ ([$p|Port|] =::) =<< eval [$e|Object clone|]
+ ([$p|File|] =::) =<< eval [$e|Object clone|]
+ ([$p|Directory|] =::) =<< eval [$e|Object clone|]
+
+ sinp <- portObj stdin
+ soutp <- portObj stdout
+ serrp <- portObj stderr
+ [$p|Port standard-input|] =:: sinp
+ [$p|Port standard-output|] =:: soutp
+ [$p|Port standard-error|] =:: serrp
+
+ ([$p|current-output-port|] =::) =<< eval [$e|Parameter new: Port standard-output|]
+ ([$p|current-input-port|] =::) =<< eval [$e|Parameter new: Port standard-input|]
+
+ [$p|Port new: (fn: String)|] =::: [$e|Port new: fn mode: @read-write|]
+ [$p|Port new: (fn: String) mode: (m: Particle)|] =: do
+ fn <- getString [$e|fn|]
+ Particle m <- here "m" >>= findParticle
+
+ hdl <- case m of
+ PMSingle "read" ->
+ liftIO (openFile fn ReadMode)
+ PMSingle "write" ->
+ liftIO (openFile fn WriteMode)
+ PMSingle "append" ->
+ liftIO (openFile fn AppendMode)
+ PMSingle "read-write" ->
+ liftIO (openFile fn ReadWriteMode)
+ _ ->
+ error $ "unknown port mode: " ++ show (pretty m) ++ ", must be one of: @read, @write, @append, @read-write"
+
+ portObj hdl
+
+ [$p|(x: Object) print|] =::: [$e|current-output-port _? print: x|]
+ [$p|(p: Port) print: x|] =: do
+ x <- here "x"
+ hdl <- getHandle [$e|p handle|]
+
+ String s <- eval [$e|x as: String|] >>= findString
+
+ liftIO (TIO.hPutStrLn hdl s)
+ liftIO (hFlush hdl)
+ return x
+
+ [$p|(x: Object) display|] =::: [$e|current-output-port _? display: x|]
+ [$p|(p: Port) display: x|] =: do
+ x <- here "x"
+ hdl <- getHandle [$e|p handle|]
+
+ String s <- eval [$e|x as: String|] >>= findString
+
+ liftIO (TIO.hPutStr hdl s)
+ liftIO (hFlush hdl)
+ return x
+
+ [$p|read|] =::: [$e|current-input-port _? read|]
+ [$p|(p: Port) read|] =: do
+ h <- getHandle [$e|p handle|]
+
+ segment <- liftIO (hGetSegment h)
+ parsed <- continuedParse segment ""
+
+ let isPrimitive (Primitive {}) = True
+ isPrimitive (EParticle { eParticle = EPMSingle _ }) = True
+ isPrimitive (EParticle { eParticle = EPMKeyword _ ts }) =
+ all isPrimitive (catMaybes ts)
+ isPrimitive (EList { eContents = ts }) = all isPrimitive ts
+ isPrimitive _ = False
+
+ case parsed of
+ [] -> raise' "no-expressions-parsed"
+ is | all isPrimitive is -> evalAll is
+ (i:_) -> return (Expression i)
+
+ [$p|read-line|] =::: [$e|current-input-port _? read-line|]
+ [$p|(p: Port) read-line|] =: do
+ getHandle [$e|p handle|] >>= liftIO . TIO.hGetLine
+ >>= return . String
+
+ [$p|contents|] =::: [$e|current-input-port _? contents|]
+ [$p|(p: Port) contents|] =:
+ getHandle [$e|p handle|] >>= liftIO . TIO.hGetContents
+ >>= return . String
+
+ [$p|(p: Port) flush|] =:
+ getHandle [$e|p handle|] >>= liftIO . hFlush
+ >> return (particle "ok")
+
+ [$p|(p: Port) close|] =:
+ getHandle [$e|p handle|] >>= liftIO . hClose
+ >> return (particle "ok")
+
+ [$p|(p: Port) open?|] =:
+ getHandle [$e|p handle|] >>= liftIO . hIsOpen
+ >>= bool
+
+ [$p|(p: Port) closed?|] =:
+ getHandle [$e|p handle|] >>= liftIO . hIsClosed
+ >>= bool
+
+ [$p|(p: Port) readable?|] =:
+ getHandle [$e|p handle|] >>= liftIO . hIsReadable
+ >>= bool
+
+ [$p|(p: Port) writable?|] =:
+ getHandle [$e|p handle|] >>= liftIO . hIsWritable
+ >>= bool
+
+ [$p|(p: Port) seekable?|] =:
+ getHandle [$e|p handle|] >>= liftIO . hIsSeekable
+ >>= bool
+
+ [$p|ready?|] =::: [$e|current-input-port _? ready?|]
+ [$p|(p: Port) ready?|] =:
+ getHandle [$e|p handle|] >>= liftIO . hReady
+ >>= bool
+
+ [$p|eof?|] =::: [$e|current-input-port _? eof?|]
+ [$p|(p: Port) eof?|] =:
+ getHandle [$e|p handle|] >>= liftIO . hIsEOF
+ >>= bool
+
+
+ [$p|File new: (fn: String)|] =::: [$e|Port new: fn|]
+ [$p|File open: (fn: String)|] =::: [$e|Port new: fn|]
+
+ [$p|File read: (fn: String)|] =:::
+ [$e|Port (new: fn mode: @read) ensuring: @close do: @contents|]
+
+ [$p|File delete: (fn: String)|] =: do
+ fn <- getString [$e|fn|]
+ liftIO (removeFile fn)
+ return (particle "ok")
+
+ [$p|File move: (from: String) to: (to: String)|] =:::
+ [$e|File rename: from to: to|]
+ [$p|File rename: (from: String) to: (to: String)|] =: do
+ from <- getString [$e|from|]
+ to <- getString [$e|to|]
+ liftIO (renameFile from to)
+ return (particle "ok")
+
+ [$p|File copy: (from: String) to: (to: String)|] =: do
+ from <- getString [$e|from|]
+ to <- getString [$e|to|]
+ liftIO (copyFile from to)
+ return (particle "ok")
+
+ [$p|File canonicalize-path: (fn: String)|] =: do
+ fn <- getString [$e|fn|]
+ fmap string $ liftIO (canonicalizePath fn)
+
+ [$p|File make-relative: (fn: String)|] =: do
+ fn <- getString [$e|fn|]
+ fmap string $ liftIO (makeRelativeToCurrentDirectory fn)
+
+ [$p|File exists?: (fn: String)|] =: do
+ fn <- getString [$e|fn|]
+ liftIO (doesFileExist fn) >>= bool
+
+ [$p|File find-executable: (name: String)|] =: do
+ name <- getString [$e|name|]
+ find <- liftIO (findExecutable name)
+ case find of
+ Nothing -> return (particle "none")
+ Just fn -> return (keyParticle ["ok"] [Nothing, Just (string fn)])
+
+ [$p|File readable?: (fn: String)|] =:
+ getString [$e|fn|]
+ >>= fmap readable . liftIO . getPermissions
+ >>= bool
+
+ [$p|File writable?: (fn: String)|] =:
+ getString [$e|fn|]
+ >>= fmap writable . liftIO . getPermissions
+ >>= bool
+
+ [$p|File executable?: (fn: String)|] =:
+ getString [$e|fn|]
+ >>= fmap executable . liftIO . getPermissions
+ >>= bool
+
+ [$p|File searchable?: (fn: String)|] =:
+ getString [$e|fn|]
+ >>= fmap searchable . liftIO . getPermissions
+ >>= bool
+
+ [$p|File set-readable: (fn: String) to: (b: Bool)|] =: do
+ t <- bool True
+ b <- here "b"
+ fn <- getString [$e|fn|]
+ ps <- liftIO (getPermissions fn)
+ liftIO (setPermissions fn (ps { readable = b == t }))
+ return (particle "ok")
+
+ [$p|File set-writable: (fn: String) to: (b: Bool)|] =: do
+ t <- bool True
+ b <- here "b"
+ fn <- getString [$e|fn|]
+ ps <- liftIO (getPermissions fn)
+ liftIO (setPermissions fn (ps { writable = b == t }))
+ return (particle "ok")
+
+ [$p|File set-executable: (fn: String) to: (b: Bool)|] =: do
+ t <- bool True
+ b <- here "b"
+ fn <- getString [$e|fn|]
+ ps <- liftIO (getPermissions fn)
+ liftIO (setPermissions fn (ps { executable = b == t }))
+ return (particle "ok")
+
+ [$p|File set-searchable: (fn: String) to: (b: Bool)|] =: do
+ t <- bool True
+ b <- here "b"
+ fn <- getString [$e|fn|]
+ ps <- liftIO (getPermissions fn)
+ liftIO (setPermissions fn (ps { searchable = b == t }))
+ return (particle "ok")
+
+ [$p|Directory create: (path: String)|] =: do
+ path <- getString [$e|path|]
+ liftIO (createDirectory path)
+ return (particle "ok")
+
+ [$p|Directory create-if-missing: (path: String)|] =: do
+ path <- getString [$e|path|]
+ liftIO (createDirectoryIfMissing False path)
+ return (particle "ok")
+
+ [$p|Directory create-tree-if-missing: (path: String)|] =: do
+ path <- getString [$e|path|]
+ liftIO (createDirectoryIfMissing True path)
+ return (particle "ok")
+
+ [$p|Directory remove: (path: String)|] =: do
+ path <- getString [$e|path|]
+ liftIO (removeDirectory path)
+ return (particle "ok")
+
+ [$p|Directory remove-recursive: (path: String)|] =: do
+ path <- getString [$e|path|]
+ liftIO (removeDirectoryRecursive path)
+ return (particle "ok")
+
+ [$p|Directory move: (from: String) to: (to: String)|] =:::
+ [$e|Directory rename: from to: to|]
+ [$p|Directory rename: (from: String) to: (to: String)|] =: do
+ from <- getString [$e|from|]
+ to <- getString [$e|to|]
+ liftIO (renameDirectory from to)
+ return (particle "ok")
+
+ [$p|Directory copy: (from: String) to: (to: String)|] =::: [$e|{
+ Directory create-tree-if-missing: to
+
+ Directory (contents: from) map: { c |
+ f = from / c
+ t = to / c
+
+ if: Directory (exists?: f)
+ then: { Directory copy: f to: t }
+ else: { File copy: f to: t }
+ }
+
+ @ok
+ } call|]
+
+ [$p|Directory contents: (path: String)|] =:
+ getString [$e|path|]
+ >>= liftIO . getDirectoryContents
+ >>= return . filter (not . (`elem` [".", ".."]))
+ >>= list . map string
+
+ [$p|Directory current|] =:
+ fmap string $ liftIO getCurrentDirectory
+
+ [$p|Directory current: (path: String)|] =: do
+ path <- getString [$e|path|]
+ liftIO (setCurrentDirectory path)
+ return (particle "ok")
+
+ [$p|Directory home|] =:
+ fmap string $ liftIO getHomeDirectory
+
+ [$p|Directory user-data-for: (app: String)|] =: do
+ app <- getString [$e|app|]
+ fmap string $ liftIO (getAppUserDataDirectory app)
+
+ [$p|Directory user-documents|] =:
+ fmap string $ liftIO getUserDocumentsDirectory
+
+ [$p|Directory temporary|] =:
+ fmap string $ liftIO getTemporaryDirectory
+
+ [$p|Directory exists?: (path: String)|] =: do
+ path <- getString [$e|path|]
+ liftIO (doesDirectoryExist path) >>= bool
+
+ [$p|(a: String) (b: String)|] =: do
+ a <- getString [$e|a|]
+ b <- getString [$e|b|]
+ return (string (a b))
+
+ [$p|(a: String) <.> (b: String)|] =: do
+ a <- getString [$e|a|]
+ b <- getString [$e|b|]
+ return (string (a <.> b))
+
+ prelude
+ where
+ portObj hdl = newScope $ do
+ port <- eval [$e|Port clone|]
+ [$p|p|] =:: port
+ [$p|p handle|] =:: Haskell (toDyn hdl)
+ here "p"
+
+ getHandle ex = do
+ Haskell hdl <- eval ex
+ return (fromDyn hdl (error "handle invalid"))
+
+ hGetSegment :: Handle -> IO String
+ hGetSegment h = dropSpaces >> hGetSegment'
+ where
+ dropSpaces = do
+ c <- hLookAhead h
+ if isSpace c
+ then hGetChar h >> dropSpaces
+ else return ()
+
+ hGetSegment' = do
+ end <- hIsEOF h
+
+ if end
+ then return ""
+ else do
+
+ c <- hGetChar h
+
+ case c of
+ '"' -> hGetUntil h '"' >>= return . (c:)
+ '\'' -> hGetUntil h '\'' >>= return . (c:)
+ '(' -> hGetUntil h ')' >>= return . (c:)
+ '{' -> hGetUntil h '}' >>= return . (c:)
+ '[' -> hGetUntil h ']' >>= return . (c:)
+ s | isSpace s -> return [c]
+ _ -> do
+ cs <- hGetSegment'
+ return (c:cs)
+
+ hGetUntil :: Handle -> Char -> IO String
+ hGetUntil h x = do
+ c <- hGetChar h
+
+ if c == x
+ then return [c]
+ else do
+ cs <- hGetUntil h x
+ return (c:cs)
+
+
+prelude :: VM ()
+prelude = mapM_ eval [$es|
+ with-output-to: (fn: String) do: b :=
+ Port (new: fn) ensuring: @close do: { file |
+ with-output-to: file do: b
+ }
+
+ with-output-to: (p: Port) do: b :=
+ with: current-output-port as: p do: b
+
+ with-input-from: (fn: String) do: (b: Block) :=
+ Port (new: fn) ensuring: @close do: { file |
+ with-input-from: file do: b
+ }
+
+ with-input-from: (p: Port) do: (b: Block) :=
+ with: current-input-port as: p do: b
+
+
+ with-all-output-to: (fn: String) do: b :=
+ Port (new: fn) ensuring: @close do: { file |
+ with-all-output-to: file do: b
+ }
+
+ with-all-output-to: (p: Port) do: b :=
+ with-default: current-output-port as: p do: b
+
+ with-all-input-from: (fn: String) do: (b: Block) :=
+ Port (new: fn) ensuring: @close do: { file |
+ with-all-input-from: file do: b
+ }
+
+ with-all-input-from: (p: Port) do: (b: Block) :=
+ with-default: current-input-port as: p do: b
+|]
diff --git a/src/Atomo/Kernel/String.hs b/src/Atomo/Kernel/String.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/String.hs
@@ -0,0 +1,298 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.String where
+
+import Data.List (sort)
+import qualified Data.Text as T
+
+import Atomo.Environment
+import Atomo.Haskell
+
+
+load :: VM ()
+load = do
+ [$p|(s: String) as: List|] =:
+ getString [$e|s|] >>= list . map Char
+
+ [$p|(l: List) to-string|] =: do
+ vs <- getList [$e|l|]
+
+ if all isChar vs
+ then return $ string (map (\(Char c) -> c) vs)
+ else raise' "list-not-homogenous"
+
+ [$p|(c: Char) singleton|] =: do
+ Char c <- here "c" >>= findChar
+ return (String (T.singleton c))
+
+ [$p|(s: String) length|] =:
+ getText [$e|s|] >>= return . Integer . fromIntegral . T.length
+
+ [$p|(s: String) empty?|] =:
+ getText [$e|s|] >>= bool . T.null
+
+ [$p|(s: String) at: (n: Integer)|] =: do
+ Integer n <- here "n" >>= findInteger
+ t <- getText [$e|s|]
+ return . Char $ t `T.index` fromIntegral n
+
+ [$p|"" head|] =: raise' "empty-string"
+ [$p|(s: String) head|] =:
+ getText [$e|s|] >>= return . Char . T.head
+
+ [$p|"" last|] =: raise' "empty-string"
+ [$p|(s: String) last|] =:
+ getText [$e|s|] >>= return . Char . T.last
+
+ -- TODO: @from:to:
+
+ [$p|"" init|] =: raise' "empty-string"
+ [$p|(s: String) init|] =:
+ getText [$e|s|] >>= return . String . T.init
+
+ [$p|"" tail|] =: raise' "empty-string"
+ [$p|(s: String) tail|] =:
+ getText [$e|s|] >>= return . String . T.tail
+
+ [$p|(s: String) take: (n: Integer)|] =: do
+ Integer n <- here "n" >>= findInteger
+ getText [$e|s|] >>=
+ return . String . T.take (fromIntegral n)
+
+ [$p|(s: String) drop: (n: Integer)|] =: do
+ Integer n <- here "n" >>= findInteger
+ getText [$e|s|] >>=
+ return . String . T.drop (fromIntegral n)
+
+ -- TODO: take-while:, drop-while:
+
+ [$p|(c: Char) repeat: (n: Integer)|] =: do
+ Char c <- here "c" >>= findChar
+ Integer n <- here "n" >>= findInteger
+ return (string (replicate (fromIntegral n) c))
+
+ [$p|(s: String) repeat: (n: Integer)|] =: do
+ Integer n <- here "n" >>= findInteger
+ getText [$e|s|] >>=
+ return . String . T.replicate (fromIntegral n)
+
+ [$p|(a: String) .. (b: String)|] =: do
+ a <- getText [$e|a|]
+ b <- getText [$e|b|]
+ return (String (a `T.append` b))
+
+ [$p|(s: String) reverse|] =:
+ getText [$e|s|] >>= return . String . T.reverse
+
+ [$p|(l: List) join|] =::: [$e|l reduce: @.. with: ""|]
+
+ [$p|(l: List) join: (d: String)|] =: do
+ ts <- getList [$e|l|]
+ >>= mapM (fmap (\(String t) -> t) . findString)
+
+ d <- getText [$e|d|]
+
+ return (String (T.intercalate d ts))
+
+ [$p|(s: String) intersperse: (c: Char)|] =: do
+ Char c <- here "c" >>= findChar
+ t <- getText [$e|s|]
+ return (String (T.intersperse c t))
+
+ [$p|(s: String) split: (d: String)|] =: do
+ s <- getText [$e|s|]
+ d <- getText [$e|d|]
+ list (map String (T.split d s))
+
+ -- TODO: split-by
+
+ [$p|(s: String) split-on: (d: Char)|] =: do
+ s <- getText [$e|s|]
+ Char d <- here "d" >>= findChar
+ list (map String (T.splitBy (== d) s))
+
+ [$p|(s: String) split-at: (n: Integer)|] =: do
+ Integer n <- here "n" >>= findInteger
+ s <- getText [$e|s|]
+ let (a, b) = T.splitAt (fromIntegral n) s
+ list [String a, String b]
+
+ [$p|(s: String) break-on: (d: Integer)|] =: do
+ s <- getText [$e|s|]
+ d <- getText [$e|d|]
+ let (a, b) = T.break d s
+ list [String a, String b]
+
+ [$p|(s: String) break-end: (d: Integer)|] =: do
+ s <- getText [$e|s|]
+ d <- getText [$e|d|]
+ let (a, b) = T.breakEnd d s
+ list [String a, String b]
+
+ [$p|(s: String) group|] =: do
+ s <- getText [$e|s|]
+ list (map String (T.group s))
+
+ [$p|(s: String) inits|] =: do
+ s <- getText [$e|s|]
+ list (map String (T.inits s))
+
+ [$p|(s: String) tails|] =: do
+ s <- getText [$e|s|]
+ list (map String (T.tails s))
+
+ [$p|(s: String) chunks-of: (n: Integer)|] =: do
+ Integer n <- here "n" >>= findInteger
+ s <- getText [$e|s|]
+ list (map String (T.chunksOf (fromIntegral n) s))
+
+ [$p|(s: String) lines|] =: do
+ s <- getText [$e|s|]
+ list (map String (T.lines s))
+
+ [$p|(s: String) words|] =: do
+ s <- getText [$e|s|]
+ list (map String (T.words s))
+
+ [$p|(l: List) unlines|] =::: [$e|l (map: @(<< '\n')) join|]
+ [$p|(l: List) unwords|] =::: [$e|l join: " "|]
+
+ [$p|(s: String) map: b|] =: do
+ s <- getString [$e|s|]
+ b <- here "b"
+
+ vs <- forM s $ \c -> do
+ as <- list [Char c]
+ dispatch (keyword ["call"] [b, as])
+
+ if all isChar vs
+ then return (string (map (\(Char c) -> c) vs))
+ else list vs
+
+ [$p|(s: String) each: (b: Block)|] =::: [$e|{ s map: b in-context; s } call|]
+
+ [$p|(c: Char) . (s: String)|] =: do
+ Char c <- here "c" >>= findChar
+ s <- getText [$e|s|]
+ return (String (T.cons c s))
+
+ [$p|(s: String) << (c: Char)|] =: do
+ s <- getText [$e|s|]
+ Char c <- here "c" >>= findChar
+ return (String (T.snoc s c))
+
+ [$p|(haystack: String) replace: (needle: String) with: (new: String)|] =: do
+ h <- getText [$e|haystack|]
+ n <- getText [$e|needle|]
+ s <- getText [$e|new|]
+ return (String (T.replace n s h))
+
+ [$p|(s: String) case-fold|] =: do
+ getText [$e|s|] >>= return . String . T.toCaseFold
+
+ [$p|(s: String) lowercase|] =: do
+ getText [$e|s|] >>= return . String . T.toLower
+
+ [$p|(s: String) uppercase|] =: do
+ getText [$e|s|] >>= return . String . T.toUpper
+
+ [$p|(s: String) left-justify: (length: Integer) with: (c: Char)|] =: do
+ s <- getText [$e|s|]
+ Integer l <- here "length" >>= findInteger
+ Char c <- here "c" >>= findChar
+
+ return (String (T.justifyLeft (fromIntegral l) c s))
+
+ [$p|(s: String) right-justify: (length: Integer) with: (c: Char)|] =: do
+ s <- getText [$e|s|]
+ Integer l <- here "length" >>= findInteger
+ Char c <- here "c" >>= findChar
+
+ return (String (T.justifyRight (fromIntegral l) c s))
+
+ [$p|(s: String) center: (length: Integer) with: (c: Char)|] =: do
+ s <- getText [$e|s|]
+ Integer l <- here "length" >>= findInteger
+ Char c <- here "c" >>= findChar
+
+ return (String (T.center (fromIntegral l) c s))
+
+ [$p|(s: String) strip|] =: do
+ getText [$e|s|] >>= return . String . T.strip
+
+ [$p|(s: String) strip-start|] =: do
+ getText [$e|s|] >>= return . String . T.stripStart
+
+ [$p|(s: String) strip-end|] =: do
+ getText [$e|s|] >>= return . String . T.stripEnd
+
+ [$p|(s: String) strip: (c: Char)|] =: do
+ Char c <- here "c" >>= findChar
+ getText [$e|s|] >>= return . String . T.dropAround (== c)
+
+ [$p|(s: String) strip-start: (c: Char)|] =: do
+ Char c <- here "c" >>= findChar
+ getText [$e|s|] >>= return . String . T.dropWhile (== c)
+
+ [$p|(s: String) strip-end: (c: Char)|] =: do
+ Char c <- here "c" >>= findChar
+ getText [$e|s|] >>= return . String . T.dropWhileEnd (== c)
+
+ [$p|(s: String) all?: b|] =::: [$e|(s as: List) all?: b|]
+ [$p|(s: String) any?: b|] =::: [$e|(s as: List) any?: b|]
+
+ [$p|(s: String) contains?: (c: Char)|] =: do
+ t <- getText [$e|s|]
+ Char c <- here "c" >>= findChar
+ bool (T.any (== c) t)
+
+ [$p|(c: Char) in?: (s: String)|] =::: [$e|s contains?: c|]
+
+ [$p|(s: String) reduce: b|] =::: [$e|(s as: List) reduce: b|]
+ [$p|(s: String) reduce: b with: v|] =::: [$e|(s as: List) reduce: b with: v|]
+
+ [$p|(s: String) reduce-right: b|] =::: [$e|(s as: List) reduce-right: b|]
+ [$p|(s: String) reduce-right: b with: v|] =::: [$e|(s as: List) reduce-right: b with: v|]
+
+ [$p|(s: String) maximum|] =: do
+ getText [$e|s|] >>= return . Char . T.maximum
+
+ [$p|(s: String) minimum|] =: do
+ getText [$e|s|] >>= return . Char . T.minimum
+
+ [$p|(s: String) sort|] =:
+ getString [$e|s|] >>= return . string . sort
+
+ [$p|(s: String) sort-by: cmp|] =::: [$e|s (as: List) (sort-by: cmp) to-string|]
+
+ [$p|(a: String) is-prefix-of?: (b: String)|] =: do
+ a <- getText [$e|a|]
+ b <- getText [$e|b|]
+ bool (T.isPrefixOf a b)
+
+ [$p|(a: String) is-suffix-of?: (b: String)|] =: do
+ a <- getText [$e|a|]
+ b <- getText [$e|b|]
+ bool (T.isSuffixOf a b)
+
+ [$p|(a: String) is-infix-of?: (b: String)|] =: do
+ a <- getText [$e|a|]
+ b <- getText [$e|b|]
+ bool (T.isInfixOf a b)
+
+ [$p|(a: String) starts-with?: (b: String)|] =::: [$e|b is-prefix-of?: a|]
+ [$p|(a: String) ends-with?: (b: String)|] =::: [$e|b is-suffix-of?: a|]
+ [$p|(a: String) includes?: (b: String)|] =::: [$e|b is-infix-of?: a|]
+
+ [$p|(s: String) filter: b|] =::: [$e|s (as: List) (filter: b) to-string|]
+
+ [$p|(x: String) zip: (y: String)|] =::: [$e|x zip: y with: @->|]
+ [$p|(x: String) zip: (y: String) with: z|] =: do
+ x <- getText [$e|x|]
+ y <- getText [$e|y|]
+ z <- here "z"
+
+ vs <- forM (T.zip x y) $ \(a, b) -> do
+ as <- list [Char a, Char b]
+ dispatch (keyword ["call"] [z, as])
+
+ list vs
diff --git a/src/Atomo/Kernel/Time.hs b/src/Atomo/Kernel/Time.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Kernel/Time.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Atomo.Kernel.Time (load) where
+
+import Data.Time.Clock.POSIX (getPOSIXTime)
+
+import Atomo.Environment
+import Atomo.Haskell
+
+
+load :: VM ()
+load = do
+ ([$p|Timer|] =::) =<< eval [$e|Object clone|]
+
+ [$p|Timer now|] =:
+ fmap (Double . fromRational . toRational) (liftIO getPOSIXTime)
+
+ [$p|Timer sleep: (n: Integer)|] =: do
+ Integer n <- here "n" >>= findInteger
+ liftIO (sleepFor n)
+ return (particle "ok")
+
+ [$p|Timer sleep: (d: Double)|] =: do
+ Double d <- here "d" >>= findDouble
+ liftIO (threadDelay (floor d))
+ return (particle "ok")
+
+ prelude
+
+
+sleepFor :: Integer -> IO ()
+sleepFor n
+ | n > fromIntegral limit = threadDelay limit >> sleepFor (n - fromIntegral limit)
+ | otherwise = threadDelay (fromIntegral n)
+ where
+ limit = maxBound :: Int
+
+prelude :: VM ()
+prelude = mapM_ eval [$es|
+ Timer do: (b: Block) every: (n: Number) :=
+ { { Timer sleep: n; b spawn } repeat } spawn
+
+ Timer do: (b: Block) after: (n: Number) :=
+ { Timer sleep: n; b call } spawn
+
+ (b: Block) time := {
+ before = Timer now
+ b call
+ after = Timer now
+ after - before
+ } call
+
+ -- units!
+ (n: Number) us := n
+ (n: Number) microseconds := n us
+ (n: Number) microsecond := n us
+
+ (n: Number) ms := n * 1000
+ (n: Number) milliseconds := n ms
+ (n: Number) millisecond := n ms
+
+ (n: Number) seconds := n * 1000000
+ (n: Number) second := n seconds
+
+ (n: Number) minutes := (n * 60) seconds
+ (n: Number) minute := n minutes
+
+ (n: Number) hours := (n * 60) minutes
+ (n: Number) hour := n hours
+
+ (n: Number) days := (n * 24) hours
+ (n: Number) day := n days
+
+ (n: Number) weeks := (n * 7) days
+ (n: Number) week := n weeks
+
+ (n: Number) months := (n * 30) days
+ (n: Number) month := n months
+
+ (n: Number) years := (n * 365) days
+ (n: Number) year := n years
+|]
diff --git a/src/Atomo/Method.hs b/src/Atomo/Method.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Method.hs
@@ -0,0 +1,125 @@
+module Atomo.Method (addMethod, insertMethod, toMethods) where
+
+import Data.IORef
+import Data.List (elemIndices)
+import System.IO.Unsafe
+import qualified Data.IntMap as M
+
+import Atomo.Types
+
+
+-- referring to the left side:
+-- LT = higher-precision
+-- GT = lower-precision
+comparePrecision :: Pattern -> Pattern -> Ordering
+comparePrecision (PNamed _ a) (PNamed _ b) =
+ comparePrecision a b
+comparePrecision (PNamed _ a) b = comparePrecision a b
+comparePrecision a (PNamed _ b) = comparePrecision a b
+comparePrecision PAny PAny = EQ
+comparePrecision PSelf PSelf = EQ
+comparePrecision (PMatch (Reference a)) (PMatch (Reference b))
+ | unsafeDelegatesTo (Reference a) (Reference b) = LT
+ | unsafeDelegatesTo (Reference a) (Reference b) = GT
+ | otherwise = EQ
+comparePrecision (PMatch _) (PMatch _) = EQ
+comparePrecision (PList as) (PList bs) =
+ comparePrecisions as bs
+comparePrecision (PPMSingle _) (PPMSingle _) = EQ
+comparePrecision (PPMKeyword _ as) (PPMKeyword _ bs) =
+ comparePrecisions as bs
+comparePrecision (PHeadTail ah at) (PHeadTail bh bt) =
+ comparePrecisions [ah, at] [bh, bt]
+comparePrecision (PSingle { ppTarget = at }) (PSingle { ppTarget = bt }) =
+ comparePrecision at bt
+comparePrecision (PKeyword { ppTargets = as }) (PKeyword { ppTargets = bs }) =
+ compareHeads as bs
+comparePrecision (PObject _) (PObject _) = EQ
+comparePrecision PAny _ = GT
+comparePrecision _ PAny = LT
+comparePrecision PSelf (PMatch (Reference _)) = LT
+comparePrecision (PMatch (Reference _)) PSelf = GT
+comparePrecision (PMatch _) _ = LT
+comparePrecision _ (PMatch _) = GT
+comparePrecision (PList _) _ = LT
+comparePrecision _ (PList _) = GT
+comparePrecision (PPMSingle _) _ = LT
+comparePrecision _ (PPMSingle _) = GT
+comparePrecision (PPMKeyword _ _) _ = LT
+comparePrecision _ (PPMKeyword _ _) = GT
+comparePrecision (PHeadTail _ _) _ = LT
+comparePrecision _ (PHeadTail _ _) = GT
+comparePrecision PSelf _ = LT
+comparePrecision _ PSelf = GT
+comparePrecision (PObject _) _ = LT
+comparePrecision _ (PObject _) = GT
+comparePrecision _ _ = GT
+
+compareHeads :: [Pattern] -> [Pattern] -> Ordering
+compareHeads [a] [b] = comparePrecision a b
+compareHeads (a:as) (b:bs) =
+ case comparePrecision a b of
+ EQ -> compareHeads as bs
+ x -> x
+compareHeads a b = error $ "impossible: compareHeads on " ++ show (a, b)
+
+comparePrecisions :: [Pattern] -> [Pattern] -> Ordering
+comparePrecisions as bs =
+ compare gt lt
+ where
+ compared = zipWith comparePrecision as bs
+ gt = length $ elemIndices GT compared
+ lt = length $ elemIndices LT compared
+
+unsafeDelegatesTo :: Value -> Value -> Bool
+unsafeDelegatesTo (Reference f) t =
+ t `elem` ds || any (flip unsafeDelegatesTo t) ds
+ where
+ ds = oDelegates (unsafePerformIO (readIORef f))
+unsafeDelegatesTo _ _ = False
+
+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
+insertMethod :: Method -> [Method] -> [Method]
+insertMethod x [] = [x]
+insertMethod x ys@(y:ys') =
+ case comparePrecision (mPattern x) (mPattern y) of
+ -- stop at LT so it's after all of the definitons before this one
+ LT -> x : ys
+
+ -- replace equivalent patterns
+ _ | equivalent (mPattern x) (mPattern y) -> insertMethod x ys'
+
+ -- keep looking if we're EQ or GT
+ _ -> y : insertMethod x ys'
+
+toMethods :: [(Pattern, Value)] -> MethodMap
+toMethods bs = foldl (\ss (p, v) -> addMethod (Slot p v) ss) M.empty bs
+
+-- check if two patterns are "equivalent", ignoring names for patterns
+-- and other things that mean the same thing
+equivalent :: Pattern -> Pattern -> Bool
+equivalent PAny PAny = True
+equivalent (PHeadTail ah at) (PHeadTail bh bt) =
+ equivalent ah bh && equivalent at bt
+equivalent (PKeyword _ ans aps) (PKeyword _ bns bps) =
+ ans == bns && and (zipWith equivalent aps bps)
+equivalent (PList aps) (PList bps) =
+ length aps == length bps && and (zipWith equivalent aps bps)
+equivalent (PMatch a) (PMatch b) = a == b
+equivalent (PNamed _ a) (PNamed _ b) = equivalent a b
+equivalent (PNamed _ a) b = equivalent a b
+equivalent a (PNamed _ b) = equivalent a b
+equivalent (PPMSingle a) (PPMSingle b) = a == b
+equivalent (PPMKeyword ans aps) (PPMKeyword bns bps) =
+ ans == bns && and (zipWith equivalent aps bps)
+equivalent PSelf PSelf = True
+equivalent (PSingle ai _ at) (PSingle bi _ bt) =
+ ai == bi && equivalent at bt
+equivalent _ _ = False
diff --git a/src/Atomo/Parser.hs b/src/Atomo/Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Parser.hs
@@ -0,0 +1,303 @@
+module Atomo.Parser where
+
+import "monads-fd" Control.Monad.Error
+import "monads-fd" Control.Monad.State
+import Data.Maybe (fromJust)
+import Text.Parsec
+
+import Atomo.Debug
+import Atomo.Parser.Base
+import {-# SOURCE #-} Atomo.Parser.Pattern
+import Atomo.Parser.Primitive
+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 = try pOperator <|> try pDefine <|> try pSet <|> try pDispatch <|> pLiteral <|> parens pExpr
+ "expression"
+
+pLiteral :: Parser Expr
+pLiteral = try pBlock <|> try pList <|> try pParticle <|> pPrimitive
+ "literal"
+
+pOperator :: Parser Expr
+pOperator = tagged (do
+ reserved "operator"
+
+ info <- choice
+ [ try $ do
+ a <- choice
+ [ symbol "right" >> return ARight
+ , symbol "left" >> return ALeft
+ ]
+ prec <- option defaultPrec (try integer)
+ return (a, prec)
+ , fmap ((,) ALeft) integer
+ ]
+
+ ops <- commaSep1 operator
+
+ forM_ ops $ \name ->
+ modifyState ((name, info) :)
+
+ return (Operator Nothing ops (fst info) (snd info)))
+ "operator pragma"
+
+pParticle :: Parser Expr
+pParticle = tagged (do
+ char '@'
+ c <- choice
+ [ try (cSingle True)
+ , try (cKeyword True)
+ , try binary
+ , try symbols
+ ]
+ return (EParticle Nothing c))
+ "particle"
+ where
+ binary = do
+ op <- operator
+ return $ EPMKeyword [op] [Nothing, Nothing]
+
+ symbols = do
+ names <- many1 (anyIdentifier >>= \n -> char ':' >> return n)
+ spacing
+ return $ EPMKeyword names (replicate (length names + 1) Nothing)
+
+pDefine :: Parser Expr
+pDefine = tagged (do
+ pattern <- ppDefine
+ dump ("pDefine: define pattern", pattern)
+ reservedOp ":="
+ whiteSpace
+ expr <- pExpr
+ return $ Define Nothing pattern expr)
+ "definition"
+
+pSet :: Parser Expr
+pSet = tagged (do
+ pattern <- ppSet
+ dump ("pSet: set pattern", pattern)
+ reservedOp "="
+ whiteSpace
+ expr <- pExpr
+ return $ Set Nothing pattern expr)
+ "set"
+
+pDispatch :: Parser Expr
+pDispatch = choice
+ [ try pdKeys
+ , pdCascade
+ ]
+ "dispatch"
+
+pdKeys :: Parser Expr
+pdKeys = do
+ pos <- getPosition
+ msg <- keywords ekeyword (ETop (Just pos)) (try pdCascade <|> headless)
+ ops <- getState
+ return $ Dispatch (Just pos) (toBinaryOps ops msg)
+ "keyword dispatch"
+ where
+ headless = do
+ p <- getPosition
+ msg <- ckeywd p
+ ops <- 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
+ (fmap DNormal (try pLiteral <|> pCall <|> parens pExpr) <|> cascaded)
+ cascaded
+
+ return $ dispatches pos chain
+ "single dispatch"
+ where
+ cascaded = fmap DParticle $ choice
+ [ try (cSingle False)
+ , try (cKeyword 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 . fmap (EList Nothing) $ brackets (wsDelim "," pExpr))
+ "list"
+
+pBlock :: Parser Expr
+pBlock = tagged (braces $ do
+ arguments <- option [] . try $ do
+ ps <- many1 pPattern
+ delimit "|"
+ whiteSpace
+ return ps
+
+ code <- wsBlock pExpr
+
+ return $ EBlock Nothing arguments code)
+ "block"
+
+pCall :: Parser Expr
+pCall = tagged (reserved "dispatch" >> return (EDispatchObject Nothing))
+ "dispatch object"
+
+cSingle :: Bool -> Parser EParticle
+cSingle p = do
+ n <- if p then anyIdent else ident
+ notFollowedBy colon
+ spacing
+ return (EPMSingle n)
+ "single segment"
+
+cKeyword :: Bool -> Parser EParticle
+cKeyword wc = do
+ ks <- parens $ many1 keyword'
+ let (ns, vs) = unzip ks
+ return $ EPMKeyword ns (Nothing:vs)
+ "keyword segment"
+ where
+ keywordVal
+ | wc = wildcard <|> value
+ | otherwise = value
+
+ keywordDispatch
+ | wc = wildcard <|> dispatch
+ | otherwise = dispatch
+
+ value = fmap Just pdCascade
+ dispatch = fmap 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
+
+-- 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 && (null ns || (assoc n == ARight && prec (head ns) >= prec n) || prec (head ns) > prec n)
+
+ 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
+
+isOperator :: String -> Bool
+isOperator = all (`elem` opLetters)
+
+parser :: Parser [Expr]
+parser = do
+ optional (string "#!" >> manyTill anyToken newline)
+ whiteSpace
+ es <- wsBlock pExpr
+ whiteSpace
+ eof
+ return es
+
+cparser :: Parser (Operators, [Expr])
+cparser = do
+ r <- parser
+ s <- getState
+ return (s, r)
+
+parseFile :: String -> IO (Either ParseError [Expr])
+parseFile fn = fmap (runParser parser [] fn) (readFile fn)
+
+parseInput :: String -> Either ParseError [Expr]
+parseInput = runParser parser [] ""
+
+parse :: Parser a -> String -> Either ParseError a
+parse p = runParser p [] ""
+
+-- | parse input i from source s, maintaining parser state between parses
+continuedParse :: String -> String -> VM [Expr]
+continuedParse i s = do
+ ps <- gets parserState
+ case runParser cparser ps s i of
+ Left e -> throwError (ParseError e)
+ Right (ps', es) -> do
+ modify $ \e -> e { parserState = ps' }
+ return es
diff --git a/src/Atomo/Parser/Base.hs b/src/Atomo/Parser/Base.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Parser/Base.hs
@@ -0,0 +1,626 @@
+{-# LANGUAGE OverloadedStrings, RankNTypes #-}
+{-# OPTIONS -fno-warn-name-shadowing #-}
+module Atomo.Parser.Base where
+
+import "mtl" Control.Monad.Identity
+import Data.Char
+import Data.List (nub, sort, (\\))
+import Text.Parsec
+import qualified Text.Parsec.Token as P
+
+import Atomo.Types (Expr(..), Operators)
+
+
+type Parser = Parsec String Operators
+
+
+opLetters :: [Char]
+opLetters = "~!@#$%^&*-_=+./\\|<>?"
+
+def :: P.GenLanguageDef String Operators Identity
+def = P.LanguageDef
+ { P.commentStart = "{-"
+ , P.commentEnd = "-}"
+ , P.commentLine = "--"
+ , P.nestedComments = True
+ , P.identStart = letter <|> oneOf "_"
+ , P.identLetter = alphaNum <|> P.opLetter def
+ , P.opStart = oneOf (opLetters \\ "@")
+ , P.opLetter = letter <|> oneOf opLetters
+ , P.reservedOpNames = ["=", ":=", ",", "|", "_"]
+ , P.reservedNames = ["dispatch", "operator"]
+ , P.caseSensitive = True
+ }
+
+tp :: P.GenTokenParser String Operators Identity
+tp = makeTokenParser def
+
+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 = do
+ c <- P.identStart def
+ cs <- many (P.identLetter def)
+ return (c:cs)
+
+anyIdentifier :: Parser String
+anyIdentifier = lexeme anyIdent
+
+parens :: Parser a -> Parser a
+parens = P.parens tp
+
+brackets :: Parser a -> Parser a
+brackets = P.brackets tp
+
+braces :: Parser a -> Parser a
+braces = P.braces tp
+
+comma :: Parser String
+comma = P.comma tp
+
+commaSep :: Parser a -> Parser [a]
+commaSep = P.commaSep tp
+
+commaSep1 :: Parser a -> Parser [a]
+commaSep1 = P.commaSep1 tp
+
+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 = do
+ c <- P.opStart def
+ cs <- many (P.opLetter def)
+ if (c:cs) `elem` P.reservedOpNames def
+ then unexpected ("reserved operator " ++ show (c:cs))
+ else return (c:cs)
+
+reserved :: String -> Parser ()
+reserved = P.reserved tp
+
+reservedOp :: String -> Parser ()
+reservedOp = P.reservedOp tp
+
+integer :: Parser Integer
+integer = do
+ f <- sign
+ n <- natural
+ return (f n)
+ where
+ sign = choice
+ [ char '-' >> return negate
+ , char '+' >> return id
+ , return id
+ ]
+
+float :: Parser Double
+float = do
+ f <- sign
+ n <- P.float tp
+ return (f n)
+ where
+ sign = choice
+ [ char '-' >> return negate
+ , char '+' >> return id
+ , return id
+ ]
+
+natural :: Parser Integer
+natural = P.natural tp
+
+symbol :: String -> Parser String
+symbol = P.symbol tp
+
+delimit :: String -> Parser String
+delimit n = whiteSpace >> symbol n
+
+stringLiteral :: Parser String
+stringLiteral = P.stringLiteral tp
+
+charLiteral :: Parser Char
+charLiteral = P.charLiteral tp
+
+colon :: Parser ()
+colon = char ':' >> return ()
+
+wsBlock :: Parser a -> Parser [a]
+wsBlock = wsDelim ";"
+
+wsDelim :: String -> Parser a -> Parser [a]
+wsDelim d = indentAware (\n o -> sourceColumn n == sourceColumn o) (delimit d >> return True) False
+
+wsMany1 :: Parser a -> Parser [a]
+wsMany1 p = do
+ ps <- indentAware chainContinue (return False) True p
+ if null ps
+ then fail "needed more than one"
+ else return ps
+
+wsMany :: Parser a -> Parser [a]
+wsMany = indentAware chainContinue (return False) True
+
+wsManyStart :: Show a => Parser a -> Parser a -> Parser [a]
+wsManyStart s p = do
+ ps <- indentAwareStart chainContinue (return False) True s p
+ if null ps
+ then fail "needed more than one"
+ else return ps
+
+chainContinue :: SourcePos -> SourcePos -> Bool
+chainContinue n o = sourceLine o == sourceLine n || sourceColumn n > sourceColumn o
+
+indentAware :: (SourcePos -> SourcePos -> Bool) -> Parser Bool -> Bool -> Parser a -> Parser [a]
+indentAware cmp delim allowSeq p = indentAwareStart cmp delim allowSeq p p
+
+indentAwareStart :: (SourcePos -> SourcePos -> Bool) -> Parser Bool -> Bool -> Parser a -> Parser a -> Parser [a]
+indentAwareStart cmp delim allowSeq s p = do
+ start <- getPosition
+ wsmany start []
+ where
+ wsmany o es = choice
+ [ try $ do
+ x <- if null es then s else p
+
+ new <- lookAhead (whiteSpace >> getPosition)
+ sequential <- fmap (== new) $ lookAhead (spacing >> getPosition)
+
+ delimited <- option False $ try delim
+
+ if delimited || cmp new o || (allowSeq && sequential)
+ then whiteSpace >> wsmany o (es ++ [x])
+ else return (es ++ [x])
+ , return es
+ ]
+
+keyword :: Parser a -> Parser (String, a)
+keyword p = try $ do
+ name <- try (do
+ name <- ident
+ char ':'
+ return name) <|> operator
+ whiteSpace1
+ target <- p
+ return (name, target)
+
+keywords :: Show a => ([String] -> [a] -> b) -> a -> Parser a -> Parser b
+keywords c d p = do
+ (first, ks) <- choice
+ [ try $ do
+ f <- p
+ fs <- wsMany1 (keyword p)
+ return (f, fs)
+ , do
+ fs <- wsMany1 (keyword p)
+ return (d, fs)
+ ]
+
+ let (ns, ps) = unzip ks
+
+ return $ c ns (first:ps)
+
+tagged :: Parser Expr -> Parser Expr
+tagged p = do
+ pos <- getPosition
+ r <- p
+ return r { eLocation = Just pos }
+
+makeTokenParser :: P.GenLanguageDef String Operators Identity -> P.GenTokenParser String Operators Identity
+makeTokenParser languageDef
+ = P.TokenParser{ P.identifier = identifier
+ , P.reserved = reserved
+ , P.operator = operator
+ , P.reservedOp = reservedOp
+
+ , P.charLiteral = charLiteral
+ , P.stringLiteral = stringLiteral
+ , P.natural = natural
+ , P.integer = integer
+ , P.float = float
+ , P.naturalOrFloat = naturalOrFloat
+ , P.decimal = decimal
+ , P.hexadecimal = hexadecimal
+ , P.octal = octal
+
+ , P.symbol = symbol
+ , P.lexeme = lexeme
+ , P.whiteSpace = whiteSpace
+
+ , P.parens = parens
+ , P.braces = braces
+ , P.angles = angles
+ , P.brackets = brackets
+ , P.squares = brackets
+ , P.semi = semi
+ , P.comma = comma
+ , P.colon = colon
+ , P.dot = dot
+ , P.semiSep = semiSep
+ , P.semiSep1 = semiSep1
+ , P.commaSep = commaSep
+ , P.commaSep1 = commaSep1
+ }
+ where
+
+ -----------------------------------------------------------
+ -- Bracketing
+ -----------------------------------------------------------
+ parens p = between (open "(") (close ")") p
+ braces p = between (open "{") (close "}") p
+ angles p = between (open "<") (close ">") p
+ brackets p = between (open "[") (close "]") p
+
+ semi = delimit ";"
+ comma = delimit ","
+ dot = delimit "."
+ colon = delimit ":"
+
+ commaSep p = sepBy p comma
+ semiSep p = sepBy p semi
+
+ commaSep1 p = sepBy1 p comma
+ semiSep1 p = sepBy1 p semi
+
+
+ -----------------------------------------------------------
+ -- Chars & Strings
+ -----------------------------------------------------------
+ charLiteral = lexeme (between (char '\'')
+ (char '\'' "end of character")
+ characterChar )
+ "character"
+
+ characterChar = charLetter <|> charEscape
+ "literal character"
+
+ charEscape = do{ char '\\'; escapeCode }
+ charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))
+
+
+
+ stringLiteral = lexeme (
+ do{ str <- between (char '"')
+ (char '"' "end of string")
+ (many stringChar)
+ ; return (foldr (maybe id (:)) "" str)
+ }
+ "literal string")
+
+ stringChar = do{ c <- stringLetter; return (Just c) }
+ <|> stringEscape
+ "string character"
+
+ stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))
+
+ stringEscape = do{ char '\\'
+ ; do{ escapeGap ; return Nothing }
+ <|> do{ escapeEmpty; return Nothing }
+ <|> do{ esc <- escapeCode; return (Just esc) }
+ }
+
+ escapeEmpty = char '&'
+ escapeGap = do{ many1 space
+ ; char '\\' "end of string gap"
+ }
+
+
+
+ -- escape codes
+ escapeCode = charEsc <|> charNum <|> charAscii <|> charControl
+ "escape code"
+
+ charControl = do{ char '^'
+ ; code <- upper
+ ; return (toEnum (fromEnum code - fromEnum 'A'))
+ }
+
+ charNum = do{ code <- decimal
+ <|> do{ char 'o'; number 8 octDigit }
+ <|> do{ char 'x'; number 16 hexDigit }
+ ; return (toEnum (fromInteger code))
+ }
+
+ charEsc = choice (map parseEsc escMap)
+ where
+ parseEsc (c,code) = do{ char c; return code }
+
+ charAscii = choice (map parseAscii asciiMap)
+ where
+ parseAscii (asc,code) = try (do{ string asc; return code })
+
+
+ -- escape code tables
+ escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'")
+ asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)
+
+ ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM",
+ "FS","GS","RS","US","SP"]
+ ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL",
+ "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB",
+ "CAN","SUB","ESC","DEL"]
+
+ ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI',
+ '\EM','\FS','\GS','\RS','\US','\SP']
+ ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK',
+ '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK',
+ '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL']
+
+
+ -----------------------------------------------------------
+ -- Numbers
+ -----------------------------------------------------------
+ naturalOrFloat = lexeme (natFloat) "number"
+
+ float = lexeme floating "float"
+ integer = lexeme int "integer"
+ natural = lexeme nat "natural"
+
+
+ -- floats
+ floating = do{ n <- decimal
+ ; fractExponent n
+ }
+
+
+ natFloat = do{ char '0'
+ ; zeroNumFloat
+ }
+ <|> decimalFloat
+
+ zeroNumFloat = do{ n <- hexadecimal <|> octal
+ ; return (Left n)
+ }
+ <|> decimalFloat
+ <|> fractFloat 0
+ <|> return (Left 0)
+
+ decimalFloat = do{ n <- decimal
+ ; option (Left n)
+ (fractFloat n)
+ }
+
+ fractFloat n = do{ f <- fractExponent n
+ ; return (Right f)
+ }
+
+ fractExponent n = do{ fract <- fraction
+ ; expo <- option 1.0 exponent'
+ ; return ((fromInteger n + fract)*expo)
+ }
+ <|>
+ do{ expo <- exponent'
+ ; return ((fromInteger n)*expo)
+ }
+
+ fraction = do{ char '.'
+ ; digits <- many1 digit "fraction"
+ ; return (foldr op 0.0 digits)
+ }
+ "fraction"
+ where
+ op d f = (f + fromIntegral (digitToInt d))/10.0
+
+ exponent' = do{ oneOf "eE"
+ ; f <- sign
+ ; e <- decimal "exponent"
+ ; return (power (f e))
+ }
+ "exponent"
+ where
+ power e | e < 0 = 1.0/power(-e)
+ | otherwise = fromInteger (10^e)
+
+
+ -- integers and naturals
+ int = do{ f <- sign
+ ; n <- nat
+ ; return (f n)
+ }
+
+ sign = (char '-' >> return negate)
+ <|> (char '+' >> return id)
+ <|> return id
+
+ nat = zeroNumber <|> decimal
+
+ zeroNumber = do{ char '0'
+ ; hexadecimal <|> octal <|> decimal <|> return 0
+ }
+ ""
+
+ decimal = number 10 digit
+ hexadecimal = do{ oneOf "xX"; number 16 hexDigit }
+ octal = do{ oneOf "oO"; number 8 octDigit }
+
+ number base baseDigit
+ = do{ digits <- many1 baseDigit
+ ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits
+ ; seq n (return n)
+ }
+
+ -----------------------------------------------------------
+ -- Operators & reserved ops
+ -----------------------------------------------------------
+ reservedOp name =
+ lexeme $ try $
+ do{ string name
+ ; notFollowedBy (P.opLetter languageDef) ("end of " ++ show name)
+ }
+
+ operator =
+ lexeme $ try $
+ do{ name <- oper
+ ; if (isReservedOp name)
+ then unexpected ("reserved operator " ++ show name)
+ else return name
+ }
+
+ oper =
+ do{ c <- (P.opStart languageDef)
+ ; cs <- many (P.opLetter languageDef)
+ ; return (c:cs)
+ }
+ "operator"
+
+ isReservedOp name =
+ isReserved (sort (P.reservedOpNames languageDef)) name
+
+
+ -----------------------------------------------------------
+ -- Identifiers & Reserved words
+ -----------------------------------------------------------
+ reserved name =
+ lexeme $ try $
+ do{ caseString name
+ ; notFollowedBy (P.identLetter languageDef) ("end of " ++ show name)
+ }
+
+ caseString name
+ | P.caseSensitive languageDef = string name
+ | otherwise = do{ walk name; return name }
+ where
+ walk [] = return ()
+ walk (c:cs) = do{ caseChar c msg; walk cs }
+
+ caseChar c | isAlpha c = char (toLower c) <|> char (toUpper c)
+ | otherwise = char c
+
+ msg = show name
+
+
+ identifier =
+ try $
+ do{ name <- ident
+ ; if (isReservedName name)
+ then unexpected ("reserved word " ++ show name)
+ else return name
+ }
+
+
+ ident
+ = do{ c <- P.identStart languageDef
+ ; cs <- many (P.identLetter languageDef)
+ ; 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
+ -----------------------------------------------------------
+ delimit name
+ = try $ do{ whiteSpace; symbol name }
+
+ open = symbol
+
+ close name
+ = do{ whiteSpace; s <- string name; spacing; return s }
+
+ symbol name
+ = do{ s <- string name; whiteSpace; return s }
+
+ lexeme p
+ = do{ x <- p; spacing; return x }
+
+ --whiteSpace
+ whiteSpace = do
+ spacing
+ skipMany (try $ spacing >> newline)
+ spacing
+
+whiteSpace :: Parser ()
+whiteSpace = P.whiteSpace tp
+
+whiteSpace1 :: Parser ()
+whiteSpace1 = (space <|> newline) >> whiteSpace
+
+simpleSpace :: Parser ()
+simpleSpace = skipMany1 $ satisfy (`elem` " \t\f\v\xa0")
+
+spacing :: Parser ()
+spacing = skipMany spacing1
+
+spacing1 :: Parser ()
+spacing1 | noLine && noMulti = simpleSpace ""
+ | noLine = simpleSpace <|> multiLineComment ""
+ | noMulti = simpleSpace <|> oneLineComment ""
+ | otherwise = simpleSpace <|> oneLineComment <|> multiLineComment ""
+ where
+ noLine = null (P.commentLine def)
+ noMulti = null (P.commentStart def)
+
+oneLineComment :: Parser ()
+oneLineComment = try (string (P.commentLine def)) >> skipMany (satisfy (/= '\n'))
+
+multiLineComment :: Parser ()
+multiLineComment = try (string (P.commentStart def)) >> inComment
+
+inComment :: Parser ()
+inComment | P.nestedComments def = inCommentMulti
+ | otherwise = inCommentSingle
+
+inCommentMulti :: Parser ()
+inCommentMulti = (try (string (P.commentEnd def)) >> return ())
+ <|> (multiLineComment >> inCommentMulti)
+ <|> (skipMany1 (noneOf startEnd) >> inCommentMulti)
+ <|> (oneOf startEnd >> inCommentMulti)
+ "end of comment"
+ where
+ startEnd = nub (P.commentEnd def ++ P.commentStart def)
+
+inCommentSingle :: Parser ()
+inCommentSingle = (try (string (P.commentEnd def)) >> return ())
+ <|> (skipMany1 (noneOf startEnd) >> inCommentSingle)
+ <|> (oneOf startEnd >> inCommentSingle)
+ "end of comment"
+ where
+ startEnd = nub (P.commentEnd def ++ P.commentStart def)
+
+
diff --git a/src/Atomo/Parser/Pattern.hs b/src/Atomo/Parser/Pattern.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Parser/Pattern.hs
@@ -0,0 +1,188 @@
+module Atomo.Parser.Pattern where
+
+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
+ , ppAny
+ , parens pPattern
+ ]
+
+pObjectPattern :: Parser Pattern
+pObjectPattern = choice
+ [ try ppNamedSensitive
+ , try ppHeadTail
+ , try ppObject
+ , try ppMatch
+ , ppList
+ , ppString
+ , ppParticle
+ , ppAnySensitive
+ , parens pObjectPattern
+ ]
+
+ppSet :: Parser Pattern
+ppSet = try ppDefine <|> pPattern
+
+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
+ , 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 = symbol "_" >> 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 = fmap PPMSingle 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 (anyIdentifier >>= \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
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Parser/Pattern.hs-boot
@@ -0,0 +1,8 @@
+module Atomo.Parser.Pattern (pPattern, ppDefine, ppSet) where
+
+import Atomo.Parser.Base (Parser)
+import Atomo.Types
+
+pPattern :: Parser Pattern
+ppDefine :: Parser Pattern
+ppSet :: Parser Pattern
diff --git a/src/Atomo/Parser/Primitive.hs b/src/Atomo/Parser/Primitive.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Parser/Primitive.hs
@@ -0,0 +1,30 @@
+module Atomo.Parser.Primitive where
+
+import Text.Parsec
+
+import Atomo.Parser.Base
+import Atomo.Types as T
+
+
+pPrimitive :: Parser Expr
+pPrimitive = tagged $ fmap (Primitive Nothing) pPrim
+
+pPrim :: Parser Value
+pPrim = choice
+ [ pvChar
+ , pvString
+ , try pvDouble
+ , try pvInteger
+ ]
+
+pvChar :: Parser Value
+pvChar = charLiteral >>= return . Char
+
+pvString :: Parser Value
+pvString = stringLiteral >>= return . T.string
+
+pvDouble :: Parser Value
+pvDouble = float >>= return . Double
+
+pvInteger :: Parser Value
+pvInteger = integer >>= return . Integer
diff --git a/src/Atomo/Pretty.hs b/src/Atomo/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Pretty.hs
@@ -0,0 +1,270 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+module Atomo.Pretty (Pretty(..), prettyStack) where
+
+import Data.IORef
+import Data.Maybe (isJust)
+import Text.PrettyPrint hiding (braces)
+import System.IO.Unsafe
+import qualified Data.IntMap as M
+import qualified Data.Vector as V
+import qualified Language.Haskell.Interpreter as H
+
+import Atomo.Types hiding (keyword)
+import Atomo.Parser.Base (opLetters)
+
+
+data Context
+ = CNone
+ | CDefine
+ | CKeyword
+ | CSingle
+ | CArgs
+ | CPattern
+ | CList
+
+class Pretty a where
+ pretty :: a -> Doc
+ prettyFrom :: Context -> a -> Doc
+
+ pretty = prettyFrom CNone
+
+
+instance Pretty Value where
+ prettyFrom _ (Block _ ps es)
+ | null ps = braces exprs
+ | otherwise = braces $ sep (map (prettyFrom CArgs) ps) <+> char '|' <+> exprs
+ where
+ exprs = sep . punctuate (text ";") $ map pretty es
+ prettyFrom _ (Char c) = text $ show c
+ prettyFrom _ (Continuation _) = internal "continuation" empty
+ prettyFrom _ (Double d) = double d
+ prettyFrom _ (Expression e) = internal "expression" $ pretty e
+ prettyFrom _ (Haskell v) = internal "haskell" $ text (show v)
+ prettyFrom _ (Integer i) = integer i
+ prettyFrom _ (List l) =
+ brackets . hsep . punctuate comma $ map (prettyFrom CList) vs
+ where vs = V.toList (unsafePerformIO (readIORef l))
+ prettyFrom _ (Message m) = internal "message" $ pretty m
+ 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 _ (Reference _) = internal "object" empty
+ prettyFrom _ (String s) = text (show s)
+
+instance Pretty Object where
+ prettyFrom _ (Object ds (ss, ks)) = vcat
+ [ internal "object" $ parens (text "delegates to" <+> pretty ds)
+
+ , if not (M.null ss)
+ then nest 2 $ vcat (flip map (M.elems ss) $ (\ms ->
+ vcat (map prettyMethod ms))) <>
+ if not (M.null ks)
+ then char '\n'
+ else empty
+ else empty
+
+ , if not (M.null ks)
+ then nest 2 . vcat $ flip map (M.elems ks) $ \ms ->
+ vcat (map prettyMethod ms) <> char '\n'
+ else empty
+ ]
+ where
+ prettyMethod (Slot { mPattern = p, mValue = v }) =
+ prettyFrom CDefine p <+> text ":=" <++> prettyFrom CDefine v
+ prettyMethod (Method { mPattern = p, mExpr = e }) =
+ prettyFrom CDefine p <+> text ":=" <++> prettyFrom CDefine e
+
+instance Pretty Message where
+ prettyFrom _ (Single _ n t) = prettyFrom CSingle t <+> text n
+ prettyFrom _ (Keyword _ ns vs) = keywords ns vs
+
+
+instance Pretty Particle where
+ prettyFrom _ (PMSingle e) = text e
+ prettyFrom _ (PMKeyword ns vs)
+ | all (not . isJust) vs = text . concat $ map keyword ns
+ | not (isJust (head vs)) =
+ parens $ headlessKeywords' prettyVal ns (tail vs)
+ | otherwise = parens (keywords' prettyVal ns vs)
+ where
+ prettyVal me =
+ case me of
+ Nothing -> text "_"
+ Just e -> prettyFrom CKeyword e
+
+
+instance Pretty Pattern where
+ prettyFrom _ PAny = text "_"
+ prettyFrom _ (PHeadTail h t) =
+ parens $ pretty h <+> text "." <+> pretty t
+ prettyFrom _ (PKeyword _ ns (PSelf:vs)) =
+ headlessKeywords ns vs
+ prettyFrom _ (PKeyword _ ns vs) = keywords ns vs
+ prettyFrom _ (PList ps) =
+ brackets . sep $ punctuate comma (map pretty ps)
+ prettyFrom _ (PMatch v) = prettyFrom CPattern v
+ prettyFrom _ (PNamed n PAny) = text n
+ prettyFrom _ (PNamed n p) = parens $ text n <> colon <+> pretty p
+ prettyFrom _ (PObject e) = pretty e
+ prettyFrom _ (PPMSingle n) = char '@' <> text n
+ prettyFrom _ (PPMKeyword ns ps)
+ | all isAny ps = char '@' <> text (concat $ map keyword ns)
+ | isAny (head ps) =
+ char '@' <> parens (headlessKeywords' (prettyFrom CKeyword) ns (tail ps))
+ | otherwise = char '@' <> parens (keywords' (prettyFrom CKeyword) ns ps)
+ where
+ isAny PAny = True
+ isAny _ = False
+ prettyFrom _ PSelf = text ""
+ prettyFrom _ (PSingle _ n (PObject ETop {})) = text n
+ prettyFrom _ (PSingle _ n PSelf) = text n
+ prettyFrom _ (PSingle _ n p) = pretty p <+> text n
+
+
+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 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))
+ where
+ assoc ALeft = text "left"
+ assoc ARight = text "right"
+ prettyFrom c (Primitive _ v) = prettyFrom c v
+ prettyFrom _ (EBlock _ ps es)
+ | null ps = braces exprs
+ | otherwise = braces $ sep (map pretty ps) <+> char '|' <+> exprs
+ where
+ exprs = sep . punctuate (text ";") $ map pretty es
+ prettyFrom _ (EDispatchObject {}) = text "dispatch"
+ prettyFrom CDefine (EVM {}) = text "..."
+ prettyFrom _ (EVM {}) = text ""
+ prettyFrom _ (EList _ es) =
+ brackets . sep . punctuate comma $ map (prettyFrom CList) es
+ prettyFrom c (EParticle _ p) = char '@' <> prettyFrom c p
+ prettyFrom _ (ETop {}) = text ""
+
+
+instance Pretty EMessage where
+ prettyFrom _ (ESingle _ n (ETop {})) = text n
+ prettyFrom _ (ESingle _ n t) = prettyFrom CSingle t <+> text n
+ prettyFrom _ (EKeyword _ ns (ETop {}:es)) = headlessKeywords ns es
+ prettyFrom _ (EKeyword _ ns es) = keywords ns es
+
+
+instance Pretty EParticle where
+ prettyFrom _ (EPMSingle e) = text e
+ prettyFrom _ (EPMKeyword ns es)
+ | all (not . isJust) es = text . concat $ map keyword ns
+ | not (isJust (head es)) =
+ parens $ headlessKeywords' prettyVal ns (tail es)
+ | otherwise = parens $ keywords' prettyVal ns es
+ where
+ prettyVal me =
+ case me of
+ Nothing -> text "_"
+ Just e -> pretty e
+
+
+instance Pretty AtomoError where
+ prettyFrom _ (Error v) = text "error:" <+> pretty v
+ prettyFrom _ (DidNotUnderstand m) =
+ text "message not understood:" $$ nest 2 (pretty m)
+ prettyFrom _ (ParseError e) =
+ text "parse error:" $$ nest 2 (text (show e))
+ prettyFrom _ (Mismatch p v) =
+ text "pattern" <+> char '<' <> pretty p <> char '>' <+> text "did not match value:" <+> pretty v
+ prettyFrom _ (ImportError (H.UnknownError s)) =
+ text "import error:" <+> text s
+ prettyFrom _ (ImportError (H.WontCompile ges)) =
+ text "import error:" <+> sep (map text (map H.errMsg ges))
+ prettyFrom _ (ImportError (H.NotAllowed s)) =
+ text "import error:" <+> text s
+ prettyFrom _ (ImportError (H.GhcException s)) =
+ text "import error:" <+> text s
+ prettyFrom _ (FileNotFound fn) =
+ text "file not found:" <+> text fn
+ prettyFrom _ (ParticleArity e g) =
+ text . unwords $
+ [ "particle needs"
+ , show e
+ , "values to complete,"
+ , show g
+ , "given"
+ ]
+ prettyFrom _ (BlockArity e g) =
+ text . unwords $
+ [ "block expects"
+ , show e
+ , "arguments,"
+ , show g
+ , "given"
+ ]
+ prettyFrom _ NoExpressions = text "no expressions to evaluate"
+ prettyFrom _ (ValueNotFound d v) =
+ text ("could not find a " ++ d ++ " in") <+> pretty v
+
+
+instance Pretty Delegates where
+ prettyFrom _ [] = internal "bottom" empty
+ prettyFrom _ [_] = text "1 object"
+ prettyFrom _ ds = text $ show (length ds) ++ " objects"
+
+
+
+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 '>'
+
+braces :: Doc -> Doc
+braces d = char '{' <+> d <+> char '}'
+
+headlessKeywords' :: (a -> Doc) -> [String] -> [a] -> Doc
+headlessKeywords' p (k:ks) (v:vs) =
+ text (keyword k) <+> p v <++> headlessKeywords'' p ks vs
+headlessKeywords' _ _ _ = empty
+
+headlessKeywords'' :: (a -> Doc) -> [String] -> [a] -> Doc
+headlessKeywords'' p (k:ks) (v:vs) =
+ text (keyword k) <+> p v <+++> headlessKeywords'' p ks vs
+headlessKeywords'' _ _ _ = empty
+
+keywords' :: (a -> Doc) -> [String] -> [a] -> Doc
+keywords' p ks (v:vs) =
+ p v <+> headlessKeywords' p ks vs
+keywords' _ _ _ = empty
+
+headlessKeywords :: Pretty a => [String] -> [a] -> Doc
+headlessKeywords = headlessKeywords' (prettyFrom CKeyword)
+
+keywords :: Pretty a => [String] -> [a] -> Doc
+keywords = keywords' (prettyFrom CKeyword)
+
+keyword :: String -> String
+keyword k
+ | all (`elem` opLetters) k = k
+ | otherwise = k ++ ":"
+
+infixr 4 <++>, <+++>
+
+-- similar to <+>, but the second half will be nested to prevent long lines
+(<++>) :: Doc -> Doc -> Doc
+(<++>) a b
+ | length (show a ++ show b) > 80 = a $$ nest 2 b
+ | otherwise = a <+> b
+
+-- similar to <++>, but without nesting
+(<+++>) :: Doc -> Doc -> Doc
+(<+++>) a b
+ | length (show a ++ show b) > 80 = a $$ b
+ | otherwise = a <+> b
diff --git a/src/Atomo/Types.hs b/src/Atomo/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Atomo/Types.hs
@@ -0,0 +1,446 @@
+{-# LANGUAGE BangPatterns, TypeSynonymInstances #-}
+module Atomo.Types where
+
+import Control.Concurrent (ThreadId)
+import Control.Concurrent.Chan
+import "monads-fd" Control.Monad.Trans
+import "monads-fd" Control.Monad.Cont
+import "monads-fd" Control.Monad.Error
+import "monads-fd" Control.Monad.State
+import Data.Dynamic
+import Data.Hashable (hash)
+import Data.IORef
+import Data.Typeable
+import Text.Parsec (ParseError, SourcePos)
+import qualified Data.IntMap as M
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import qualified Language.Haskell.Interpreter as H
+
+type VM = ErrorT AtomoError (ContT (Either AtomoError Value) (StateT Env IO))
+
+data Value
+ = Block !Value [Pattern] [Expr]
+ | Char {-# UNPACK #-} !Char
+ | Continuation Continuation
+ | Double {-# UNPACK #-} !Double
+ | Expression Expr
+ | Haskell Dynamic
+ | Integer !Integer
+ | List VVector
+ | Message Message
+ | Particle Particle
+ | Process Channel ThreadId
+ | Pattern Pattern
+ | Reference
+ { rORef :: {-# UNPACK #-} !ORef
+ }
+ | String !T.Text
+ deriving Show
+
+data Object =
+ Object
+ { oDelegates :: !Delegates
+ , oMethods :: !(MethodMap, MethodMap) -- singles, keywords
+ }
+ deriving Show
+
+data Method
+ = Method
+ { mPattern :: !Pattern
+ , mTop :: !Value
+ , mExpr :: !Expr
+ }
+ | Slot
+ { mPattern :: !Pattern
+ , mValue :: !Value
+ }
+ deriving Show
+
+data Message
+ = Keyword
+ { mID :: !Int
+ , mNames :: [String]
+ , mTargets :: [Value]
+ }
+ | Single
+ { mID :: !Int
+ , mName :: String
+ , mTarget :: Value
+ }
+ deriving Show
+
+data Particle
+ = PMSingle String
+ | PMKeyword [String] [Maybe Value]
+ deriving Show
+
+data AtomoError
+ = Error Value
+ | ParseError ParseError
+ | DidNotUnderstand Message
+ | Mismatch Pattern Value
+ | ImportError H.InterpreterError
+ | FileNotFound String
+ | ParticleArity Int Int
+ | BlockArity Int Int
+ | NoExpressions
+ | ValueNotFound String Value
+ deriving Show
+
+-- pattern-matches
+data Pattern
+ = PAny
+ | PHeadTail Pattern Pattern
+ | PKeyword
+ { ppID :: !Int
+ , ppNames :: [String]
+ , ppTargets :: [Pattern]
+ }
+ | PList [Pattern]
+ | PMatch Value
+ | PNamed String Pattern
+ | PObject Expr
+ | PPMSingle String
+ | PPMKeyword [String] [Pattern]
+ | PSelf
+ | PSingle
+ { ppID :: !Int
+ , ppName :: String
+ , ppTarget :: Pattern
+ }
+ deriving Show
+
+-- expressions
+data Expr
+ = Define
+ { eLocation :: Maybe SourcePos
+ , ePattern :: Pattern
+ , eExpr :: Expr
+ }
+ | Set
+ { eLocation :: Maybe SourcePos
+ , ePattern :: Pattern
+ , eExpr :: Expr
+ }
+ | Dispatch
+ { eLocation :: Maybe SourcePos
+ , eMessage :: EMessage
+ }
+ | Operator
+ { eLocation :: Maybe SourcePos
+ , eNames :: [String]
+ , eAssoc :: Assoc
+ , ePrec :: Integer
+ }
+ | Primitive
+ { eLocation :: Maybe SourcePos
+ , eValue :: !Value
+ }
+ | EBlock
+ { eLocation :: Maybe SourcePos
+ , eArguments :: [Pattern]
+ , eContents :: [Expr]
+ }
+ | EDispatchObject
+ { eLocation :: Maybe SourcePos
+ }
+ | EList
+ { eLocation :: Maybe SourcePos
+ , eContents :: [Expr]
+ }
+ | EParticle
+ { eLocation :: Maybe SourcePos
+ , eParticle :: EParticle
+ }
+ | ETop
+ { eLocation :: Maybe SourcePos
+ }
+ | EVM
+ { eLocation :: Maybe SourcePos
+ , eAction :: VM Value
+ }
+ deriving Show
+
+data EMessage
+ = EKeyword
+ { emID :: !Int
+ , emNames :: [String]
+ , emTargets :: [Expr]
+ }
+ | ESingle
+ { emID :: !Int
+ , emName :: String
+ , emTarget :: Expr
+ }
+ deriving Show
+
+data EParticle
+ = EPMSingle String
+ | EPMKeyword [String] [Maybe Expr]
+ deriving Show
+
+-- the evaluation environment
+data Env =
+ Env
+ { top :: Value
+ , primitives :: IDs
+ , channel :: Channel
+ , halt :: IO ()
+ , loadPath :: [FilePath]
+ , loaded :: [FilePath]
+ , stack :: [Expr]
+ , call :: Call
+ , parserState :: Operators
+ }
+
+-- simple mapping from operator name -> associativity and predence
+type Operators = [(String, (Assoc, Integer))]
+
+-- operator associativity
+data Assoc = ALeft | ARight
+ deriving (Eq, Show)
+
+-- meta information for the dispatch
+data Call =
+ Call
+ { callSender :: Value
+ , callMessage :: Message
+ , callContext :: 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
+ , idBlock :: ORef
+ , idChar :: ORef
+ , idContinuation :: ORef
+ , idDouble :: ORef
+ , idExpression :: ORef
+ , idInteger :: ORef
+ , idList :: ORef
+ , idMessage :: ORef
+ , idParticle :: ORef
+ , idProcess :: ORef
+ , idPattern :: ORef
+ , idString :: ORef
+ }
+
+
+
+-- a basic Eq instance
+instance Eq Value where
+ Char a == Char b = a == b
+ Continuation a == Continuation b = a == b
+ Double a == Double b = a == b
+ Integer a == Integer b = a == b
+ List a == List b = a == b
+ Process _ a == Process _ b = a == b
+ Reference a == Reference b = a == b
+ String a == String b = a == b
+ _ == _ = False
+
+
+instance Error AtomoError where
+ strMsg = Error . string
+
+
+-- helper synonyms
+type Delegates = [Value]
+type Channel = Chan Value
+type MethodMap = M.IntMap [Method]
+type ORef = IORef Object
+type VVector = IORef (V.Vector Value)
+type Continuation = IORef (Value -> VM Value)
+
+instance Show Channel where
+ show _ = "Channel"
+
+instance Show ORef where
+ show _ = "ORef"
+
+instance Show VVector where
+ show _ = "VVector"
+
+instance Show Continuation where
+ show _ = "Continuation"
+
+instance Show (VM a) where
+ show _ = "VM"
+
+instance Typeable (VM a) where
+ typeOf _ = mkTyConApp (mkTyCon "VM") [typeOf ()]
+
+startEnv :: Env
+startEnv = Env
+ { top = error "top object not set"
+ , primitives =
+ IDs
+ { idMatch = error "idMatch not set"
+ , idObject = error "idObject not set"
+ , idBlock = error "idBlock not set"
+ , idChar = error "idChar not set"
+ , idContinuation = error "idContinuation not set"
+ , idDouble = error "idDouble not set"
+ , idExpression = error "idExpression not set"
+ , idInteger = error "idInteger not set"
+ , idList = error "idList not set"
+ , idMessage = error "idMessage not set"
+ , idParticle = error "idParticle not set"
+ , idProcess = error "idProcess not set"
+ , idPattern = error "idPattern not set"
+ , idString = error "idString not set"
+ }
+ , channel = error "channel not set"
+ , halt = error "halt not set"
+ , loadPath = []
+ , loaded = []
+ , stack = []
+ , call = error "call not set"
+ , parserState = []
+ }
+
+
+-----------------------------------------------------------------------------
+-- Helpers ------------------------------------------------------------------
+-----------------------------------------------------------------------------
+
+particle :: String -> Value
+{-# INLINE particle #-}
+particle = Particle . PMSingle
+
+keyParticle :: [String] -> [Maybe Value] -> Value
+{-# INLINE keyParticle #-}
+keyParticle ns vs = Particle $ PMKeyword ns vs
+
+keyParticleN :: [String] -> [Value] -> Value
+{-# INLINE keyParticleN #-}
+keyParticleN ns vs = keyParticle ns (Nothing:map Just vs)
+
+raise :: [String] -> [Value] -> VM a
+{-# INLINE raise #-}
+raise ns vs = throwError . Error $ keyParticleN ns vs
+
+raise' :: String -> VM a
+{-# INLINE raise' #-}
+raise' = throwError . Error . particle
+
+string :: String -> Value
+{-# INLINE string #-}
+string = String . T.pack
+
+list :: MonadIO m => [Value] -> m Value
+list = list' . V.fromList
+
+list' :: MonadIO m => V.Vector Value -> m Value
+list' = liftM List . liftIO . newIORef
+
+fromString :: Value -> String
+fromString (String s) = T.unpack s
+fromString v = error $ "no fromString for: " ++ show v
+
+toList :: MonadIO m => Value -> m [Value]
+toList (List vr) = liftM V.toList (liftIO (readIORef vr))
+toList v = error $ "no toList for: " ++ show v
+
+single :: String -> Value -> Message
+{-# INLINE single #-}
+single n = Single (hash n) n
+
+keyword :: [String] -> [Value] -> Message
+{-# INLINE keyword #-}
+keyword ns = Keyword (hash ns) ns
+
+psingle :: String -> Pattern -> Pattern
+{-# INLINE psingle #-}
+psingle n = PSingle (hash n) n
+
+pkeyword :: [String] -> [Pattern] -> Pattern
+{-# INLINE pkeyword #-}
+pkeyword ns = PKeyword (hash ns) ns
+
+esingle :: String -> Expr -> EMessage
+{-# INLINE esingle #-}
+esingle n = ESingle (hash n) n
+
+ekeyword :: [String] -> [Expr] -> EMessage
+{-# INLINE ekeyword #-}
+ekeyword ns = EKeyword (hash ns) ns
+
+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?
+isBlock :: Value -> Bool
+isBlock (Block _ _ _) = True
+isBlock _ = False
+
+-- | Is a value a Char?
+isChar :: Value -> Bool
+isChar (Char _) = True
+isChar _ = False
+
+-- | Is a value a Continuation?
+isContinuation :: Value -> Bool
+isContinuation (Continuation _) = True
+isContinuation _ = False
+
+-- | Is a value a Double?
+isDouble :: Value -> Bool
+isDouble (Double _) = True
+isDouble _ = False
+
+-- | Is a value an Expression?
+isExpression :: Value -> Bool
+isExpression (Expression _) = True
+isExpression _ = False
+
+-- | Is a value a Haskell value?
+isHaskell :: Value -> Bool
+isHaskell (Haskell _) = True
+isHaskell _ = False
+
+-- | Is a value an Integer?
+isInteger :: Value -> Bool
+isInteger (Integer _) = True
+isInteger _ = False
+
+-- | Is a value a List?
+isList :: Value -> Bool
+isList (List _) = True
+isList _ = False
+
+-- | Is a value a Message?
+isMessage :: Value -> Bool
+isMessage (Message _) = True
+isMessage _ = False
+
+-- | Is a value a Particle?
+isParticle :: Value -> Bool
+isParticle (Particle _) = True
+isParticle _ = False
+
+-- | Is a value a Pattern?
+isPattern :: Value -> Bool
+isPattern (Pattern _) = True
+isPattern _ = False
+
+-- | Is a value a Process?
+isProcess :: Value -> Bool
+isProcess (Process _ _) = True
+isProcess _ = False
+
+-- | Is a value a Reference?
+isReference :: Value -> Bool
+isReference (Reference _) = True
+isReference _ = False
+
+-- | Is a value a String?
+isString :: Value -> Bool
+isString (String _) = True
+isString _ = False
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,108 @@
+module Main where
+
+import "monads-fd" Control.Monad.Cont
+import "monads-fd" Control.Monad.Error
+import Data.Char (isSpace)
+import Prelude hiding (catch)
+import System.Console.Haskeline
+import System.Directory (getHomeDirectory)
+import System.Environment (getArgs)
+import System.FilePath
+
+import Atomo.Environment
+import Atomo.Parser
+import Atomo.Types
+
+
+main :: IO ()
+main = do
+ args <- getArgs
+
+ case args of
+ r | null r || r == ["-d"] ->
+ exec (repl (r == ["-d"]))
+
+ ("-e":expr:_) -> exec $ do
+ ast <- continuedParse expr ""
+ r <- evalAll ast
+ p <- prettyVM r
+ liftIO (print p)
+ return (particle "ok")
+
+ ("-s":expr:_) -> exec $ do
+ ast <- continuedParse expr ""
+ evalAll ast
+ repl False
+
+ ("-l":fn:_) -> exec $ do
+ loadFile fn
+ repl False
+
+ (fn:_) | not (head fn == '-') ->
+ exec (loadFile fn)
+
+ _ -> putStrLn . unlines $
+ [ "usage:"
+ , "\tatomo\t\tstart the REPL"
+ , "\tatomo -d\tstart the REPL in quiet mode"
+ , "\tatomo -e EXPR\tevaluate EXPR and output the result"
+ , "\tatomo -s EXPR\tevaluate EXPR and start the REPL"
+ , "\tatomo -l FILE\tload FILENAME and start the REPL"
+ , "\tatomo FILE\texecute FILE"
+ ]
+
+repl :: Bool -> VM Value
+repl quiet = do
+ home <- liftIO getHomeDirectory
+ repl' "" $ runInput home . withInterrupt
+ where
+ escape Interrupt = return Nothing
+
+ runInput home = runInputT defaultSettings
+ { historyFile = Just (home ".atomo_history")
+ }
+
+ repl' input r = do
+ me <- liftIO (catch (r $ getInputLine prompt) escape)
+
+ case me of
+ Just blank | null (dropWhile isSpace blank) -> repl' input r
+ Just part | not (bracesBalanced $ input ++ part) ->
+ repl' (input ++ part) r
+ Just expr -> do
+ catchError
+ (evaluate expr >>= prettyVM >>= liftIO . print)
+ printError
+
+ repl' "" r
+
+ Nothing -> askQuit (repl' input r)
+ where
+ evaluate expr =
+ continuedParse (input ++ expr) ""
+ >>= evalAll
+
+ prompt
+ | quiet = ""
+ | null input = "> "
+ | otherwise = ". "
+
+ askQuit continue = do
+ r <- liftIO . runInputT defaultSettings $
+ getInputChar "really quit? (y/n) "
+
+ case r of
+ Just 'y' -> return (particle "ok")
+ Just 'n' -> continue
+ _ -> askQuit continue
+
+ bracesBalanced s = hangingBraces s == 0
+ where
+ hangingBraces :: String -> Int
+ hangingBraces [] = 0
+ hangingBraces (b:ss)
+ | b == '"' = hangingBraces (tail $ dropWhile (/= '"') ss)
+ | b == '\'' = hangingBraces (tail $ dropWhile (/= '\'') ss)
+ | b `elem` "([{" = 1 + hangingBraces ss
+ | b `elem` ")]}" = hangingBraces ss - 1
+ | otherwise = hangingBraces ss
diff --git a/src/rts.c b/src/rts.c
new file mode 100644
--- /dev/null
+++ b/src/rts.c
@@ -0,0 +1,1 @@
+char *ghc_rts_opts = "-N";