packages feed

atomo (empty) → 0.1

raw patch · 37 files changed

+5998/−0 lines, 37 filesdep +basedep +containersdep +directorysetup-changed

Dependencies added: base, containers, directory, filepath, hashable, haskeline, hint, monads-fd, mtl, parsec, pretty, pretty-show, split, template-haskell, text, time, vector

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple (defaultMain)++main = defaultMain
+ atomo.cabal view
@@ -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): <http://atomo-lang.org/docs/>+    .+    Examples: <http://darcsden.com/alex/atomo/browse/examples>+    .+    IRC Channel: <irc://irc.freenode.net/atomo>+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
+ src/Atomo/Debug.hs view
@@ -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
+ src/Atomo/Environment.hs view
@@ -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
+ src/Atomo/Haskell.hs view
@@ -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 [] "<qq>" s of+        Left e -> fail (show e)+        Right e -> return e+  where+    pp = do+        pos <- getPosition+        setPosition $+            (flip setSourceName) file $+            (flip setSourceLine) line $+            (flip setSourceColumn) col $+            pos+        whiteSpace+        e <- p+        whiteSpace+        eof+        return e++parsePattern :: Monad m => String -> (String, Int, Int) -> m Pattern+parsePattern = parsing ppDefine++quotePatternExp :: String -> TH.ExpQ+quotePatternExp = withLocation parsePattern patternToExp++parseExpr :: Monad m => String -> (String, Int, Int) -> m Expr+parseExpr = parsing pExpr++quoteExprExp :: String -> TH.ExpQ+quoteExprExp = withLocation parseExpr exprToExp++parseExprs :: Monad m => String -> (String, Int, Int) -> m [Expr]+parseExprs = parsing (wsBlock pExpr)++quoteExprsExp :: String -> TH.ExpQ+quoteExprsExp = withLocation parseExprs (ListE . map exprToExp)++exprToExp :: Expr -> Exp+exprToExp (Define l p e) = AppE (AppE (expr "Define" l) (patternToExp p)) (exprToExp e)+exprToExp (Set l p e) = AppE (AppE (expr "Set" l) (patternToExp p)) (exprToExp e)+exprToExp (Dispatch l m) = AppE (expr "Dispatch" l) (emessageToExp m)+exprToExp (Operator l ns a p) = AppE (AppE (AppE (expr "Operator" l) (ListE (map (LitE . StringL) ns))) (assocToExp a)) (LitE (IntegerL p))+exprToExp (Primitive l v) = AppE (expr "Primitive" l) (valueToExp v)+exprToExp (EBlock l as es) =+    AppE (AppE (expr "EBlock" l) (ListE (map patternToExp as))) (ListE (map exprToExp es))+exprToExp (EDispatchObject l) =+    expr "EDispatchObject" l+exprToExp (EVM _ _) = error "cannot exprToExp EVM"+exprToExp (EList l es) =+    AppE (expr "EList" l) (ListE (map exprToExp es))+exprToExp (ETop l) =+    expr "ETop" l+exprToExp (EParticle l p) =+    AppE (expr "EParticle" l) (eparticleToExp p)++assocToExp :: Assoc -> Exp+assocToExp ALeft = ConE (mkName "ALeft")+assocToExp ARight = ConE (mkName "ARight")++messageToExp :: Message -> Exp+messageToExp (Keyword i ns vs) =+    AppE (AppE (AppE (ConE (mkName "Keyword")) (LitE (IntegerL (fromIntegral i)))) (ListE (map (LitE . StringL) ns))) (ListE (map valueToExp vs))+messageToExp (Single i n v) =+    AppE (AppE (AppE (ConE (mkName "Single")) (LitE (IntegerL (fromIntegral i)))) (LitE (StringL n))) (valueToExp v)++particleToExp :: Particle -> Exp+particleToExp (PMSingle n) =+    AppE (ConE (mkName "PMSingle")) (LitE (StringL n))+particleToExp (PMKeyword ns vs) =+    AppE (AppE (ConE (mkName "PMKeyword")) (ListE (map (LitE . StringL) ns))) (ListE (map maybeValue vs))+  where+    maybeValue Nothing = ConE (mkName "Nothing")+    maybeValue (Just v) = AppE (ConE (mkName "Just")) (valueToExp v)++emessageToExp :: EMessage -> Exp+emessageToExp (EKeyword i ns es) =+    AppE (AppE (AppE (ConE (mkName "EKeyword")) (LitE (IntegerL (fromIntegral i)))) (ListE (map (LitE . StringL) ns))) (ListE (map exprToExp es))+emessageToExp (ESingle i n e) =+    AppE (AppE (AppE (ConE (mkName "ESingle")) (LitE (IntegerL (fromIntegral i)))) (LitE (StringL n))) (exprToExp e)++eparticleToExp :: EParticle -> Exp+eparticleToExp (EPMSingle n) =+    AppE (ConE (mkName "EPMSingle")) (LitE (StringL n))+eparticleToExp (EPMKeyword ns es) =+    AppE (AppE (ConE (mkName "EPMKeyword")) (ListE (map (LitE . StringL) ns))) (ListE (map maybeExpr es))+  where+    maybeExpr Nothing = ConE (mkName "Nothing")+    maybeExpr (Just e) = AppE (ConE (mkName "Just")) (exprToExp e)++expr :: String -> Maybe SourcePos -> Exp+expr n _ = AppE (ConE (mkName n)) (ConE (mkName "Nothing"))++valueToExp :: Value -> Exp+valueToExp (Block s as es) =+    AppE (AppE (AppE (ConE (mkName "Block")) (valueToExp s)) (ListE (map patternToExp as))) (ListE (map exprToExp es))+valueToExp (Char c) = AppE (ConE (mkName "Char")) (LitE (CharL c))+valueToExp (Double d) = AppE (ConE (mkName "Double")) (LitE (RationalL (toRational d)))+valueToExp (Expression e) = AppE (ConE (mkName "Expression")) (exprToExp e)+valueToExp (Integer i) = AppE (ConE (mkName "Integer")) (LitE (IntegerL i))+valueToExp (Message m) = AppE (ConE (mkName "Message")) (messageToExp m)+valueToExp (Particle p) = AppE (ConE (mkName "Particle")) (particleToExp p)+valueToExp (Pattern p) = AppE (ConE (mkName "Pattern")) (patternToExp p)+valueToExp (String s) = AppE (VarE (mkName "string")) (LitE (StringL (T.unpack s)))+valueToExp v = error $ "no valueToExp for: " ++ show v++patternToExp :: Pattern -> Exp+patternToExp PAny = ConE (mkName "PAny")+patternToExp (PHeadTail h t) = AppE (AppE (ConE (mkName "PHeadTail")) (patternToExp h)) (patternToExp t)+patternToExp (PKeyword i ns ts) =+    AppE (AppE (AppE (ConE (mkName "PKeyword")) (LitE (IntegerL (fromIntegral i)))) (ListE (map (LitE . StringL) ns))) (ListE (map patternToExp ts))+patternToExp (PList ps) =+    AppE (ConE (mkName "PList")) (ListE (map patternToExp ps))+patternToExp (PMatch v) =+    AppE (ConE (mkName "PMatch")) (valueToExp v)+patternToExp (PNamed n p) =+    AppE (AppE (ConE (mkName "PNamed")) (LitE (StringL n))) (patternToExp p)+patternToExp (PObject e) =+    AppE (ConE (mkName "PObject")) (exprToExp e)+patternToExp (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)
+ src/Atomo/Kernel.hs view
@@ -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
+ src/Atomo/Kernel.hs-boot view
@@ -0,0 +1,5 @@+module Atomo.Kernel (load) where++import Atomo.Types (VM)++load :: VM ()
+ src/Atomo/Kernel/Association.hs view
@@ -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 }+|]
+ src/Atomo/Kernel/Block.hs view
@@ -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+|]
+ src/Atomo/Kernel/Bool.hs view
@@ -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) }+            }+|]
+ src/Atomo/Kernel/Comparable.hs view
@@ -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 }+|]
+ src/Atomo/Kernel/Concurrency.hs view
@@ -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")
+ src/Atomo/Kernel/Continuation.hs view
@@ -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 "<continuation>"++    [$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+        }+    }|]
+ src/Atomo/Kernel/Eco.hs view
@@ -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+|]
+ src/Atomo/Kernel/Environment.hs view
@@ -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
+ src/Atomo/Kernel/Exception.hs view
@@ -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]
+ src/Atomo/Kernel/Expression.hs view
@@ -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]
+ src/Atomo/Kernel/List.hs view
@@ -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)+
+ src/Atomo/Kernel/Message.hs view
@@ -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
+ src/Atomo/Kernel/Numeric.hs view
@@ -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+|]
+ src/Atomo/Kernel/Parameter.hs view
@@ -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 }+|]
+ src/Atomo/Kernel/Particle.hs view
@@ -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")
+ src/Atomo/Kernel/Pattern.hs view
@@ -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]
+ src/Atomo/Kernel/Ports.hs view
@@ -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 "<read>"++        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+|]
+ src/Atomo/Kernel/String.hs view
@@ -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
+ src/Atomo/Kernel/Time.hs view
@@ -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+|]
+ src/Atomo/Method.hs view
@@ -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
+ src/Atomo/Parser.hs view
@@ -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 [] "<input>"++parse :: Parser a -> String -> Either ParseError a+parse p = runParser p [] "<parse>"++-- | 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
+ src/Atomo/Parser/Base.hs view
@@ -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)++
+ src/Atomo/Parser/Pattern.hs view
@@ -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) +        ]
+ src/Atomo/Parser/Pattern.hs-boot view
@@ -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
+ src/Atomo/Parser/Primitive.hs view
@@ -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
+ src/Atomo/Pretty.hs view
@@ -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 "<self>"+    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 "<vm>"+    prettyFrom _ (EList _ es) =+        brackets . sep . punctuate comma $ map (prettyFrom CList) es+    prettyFrom c (EParticle _ p) = char '@' <> prettyFrom c p+    prettyFrom _ (ETop {}) = text "<top>"+++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
+ src/Atomo/Types.hs view
@@ -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
+ src/Main.hs view
@@ -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 "<input>"+            r <- evalAll ast+            p <- prettyVM r+            liftIO (print p)+            return (particle "ok")++        ("-s":expr:_) -> exec $ do+            ast <- continuedParse expr "<input>"+            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) "<input>"+                >>= 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
+ src/rts.c view
@@ -0,0 +1,1 @@+char *ghc_rts_opts = "-N";