atomo 0.1 → 0.1.1
raw patch · 34 files changed
+928/−538 lines, 34 filesdep −mtldep −pretty-showbuild-type:Customsetup-changed
Dependencies removed: mtl, pretty-show
Files
- Setup.hs +28/−2
- atomo.cabal +27/−22
- src/Atomo/Debug.hs +1/−2
- src/Atomo/Environment.hs +58/−35
- src/Atomo/Haskell.hs +7/−8
- src/Atomo/Kernel.hs +55/−22
- src/Atomo/Kernel/Association.hs +18/−7
- src/Atomo/Kernel/Block.hs +14/−13
- src/Atomo/Kernel/Bool.hs +0/−64
- src/Atomo/Kernel/Boolean.hs +66/−0
- src/Atomo/Kernel/Comparable.hs +2/−2
- src/Atomo/Kernel/Concurrency.hs +1/−3
- src/Atomo/Kernel/Continuation.hs +10/−8
- src/Atomo/Kernel/Eco.hs +171/−150
- src/Atomo/Kernel/Exception.hs +21/−1
- src/Atomo/Kernel/List.hs +28/−28
- src/Atomo/Kernel/Message.hs +4/−0
- src/Atomo/Kernel/Method.hs +24/−0
- src/Atomo/Kernel/Numeric.hs +22/−8
- src/Atomo/Kernel/Parameter.hs +13/−13
- src/Atomo/Kernel/Particle.hs +19/−15
- src/Atomo/Kernel/Pattern.hs +30/−1
- src/Atomo/Kernel/Ports.hs +56/−30
- src/Atomo/Kernel/String.hs +8/−5
- src/Atomo/Kernel/Time.hs +5/−5
- src/Atomo/Method.hs +31/−32
- src/Atomo/Parser.hs +28/−10
- src/Atomo/Parser/Base.hs +2/−2
- src/Atomo/Parser/Pattern.hs +2/−2
- src/Atomo/Pretty.hs +18/−12
- src/Atomo/Types.hs +108/−33
- src/Atomo/Valuable.hs +49/−0
- src/Main.hs +2/−2
- src/rts.c +0/−1
Setup.hs view
@@ -1,3 +1,29 @@-import Distribution.Simple (defaultMain)+import Distribution.PackageDescription+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Setup -main = defaultMain+import System.Directory+import System.Exit+import System.FilePath++main = defaultMainWithHooks simpleUserHooks+ { postInst = installEco+ }++installEco :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO ()+installEco _ _ _ _ = do+ home <- getHomeDirectory++ mapM_ (createDirectoryIfMissing True . (ecosystem home </>))+ ["bin", "lib"]++ copyFile eco (toEco home)++ from <- getPermissions (toEco home)+ setPermissions (toEco home) (from { executable = True })+ where+ ecosystem h = h </> ".eco"++ eco = "bin" </> "eco"+ toEco h = ecosystem h </> eco
atomo.cabal view
@@ -1,5 +1,5 @@ name: atomo-version: 0.1+version: 0.1.1 synopsis: A highly dynamic, extremely simple, very fun programming language. description:@@ -18,22 +18,29 @@ Examples: <http://darcsden.com/alex/atomo/browse/examples> . IRC Channel: <irc://irc.freenode.net/atomo>-homepage: http://darcsden.com/alex/atomo+homepage: http://atomo-lang.org/ license: BSD3 license-file: LICENSE author: Alex Suraci maintainer: i.am@toogeneric.com category: Language-build-type: Simple+build-type: Custom+stability: Experimental -cabal-version: >= 1.4+cabal-version: >= 1.6 +source-repository head+ type: darcs+ location: http://darcsden.com/alex/atomo +source-repository this+ type: darcs+ location: http://darcsden.com/alex/atomo+ tag: 0.1.1+ library hs-source-dirs: src - extensions: PackageImports- build-depends: base >= 4 && < 5, containers,@@ -51,9 +58,19 @@ vector exposed-modules:- Atomo.Debug, Atomo.Environment, Atomo.Haskell,+ Atomo.Method,+ Atomo.Parser,+ Atomo.Parser.Base,+ Atomo.Parser.Pattern,+ Atomo.Parser.Primitive,+ Atomo.Pretty,+ Atomo.Types,+ Atomo.Valuable++ other-modules:+ Atomo.Debug, Atomo.Kernel, Atomo.Kernel.Numeric, Atomo.Kernel.List,@@ -62,25 +79,19 @@ Atomo.Kernel.Expression, Atomo.Kernel.Concurrency, Atomo.Kernel.Message,+ Atomo.Kernel.Method, Atomo.Kernel.Comparable, Atomo.Kernel.Particle, Atomo.Kernel.Pattern, Atomo.Kernel.Ports, Atomo.Kernel.Time,- Atomo.Kernel.Bool,+ Atomo.Kernel.Boolean, 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+ Atomo.Kernel.Continuation executable atomo@@ -91,10 +102,6 @@ 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,@@ -104,10 +111,8 @@ haskeline, hint, monads-fd,- mtl, parsec >= 3.0.0, pretty,- pretty-show, split, template-haskell, text,
src/Atomo/Debug.hs view
@@ -1,7 +1,6 @@ module Atomo.Debug where import Debug.Trace-import Text.Show.Pretty debugging :: Bool@@ -24,4 +23,4 @@ dout s v = trace (prettyShow s ++ ": " ++ prettyShow v) v prettyShow :: Show a => a -> String-prettyShow = ppShow+prettyShow = show
src/Atomo/Environment.hs view
@@ -1,9 +1,9 @@ {-# 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.Monad.Cont+import Control.Monad.Error+import Control.Monad.State import Control.Concurrent (forkIO) import Control.Concurrent.Chan import Data.IORef@@ -12,7 +12,6 @@ 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@@ -113,7 +112,7 @@ modify $ \e -> e { top = topObj } -- define Object as the root object- define (psingle "Object" PSelf) (Primitive Nothing object)+ define (psingle "Object" PThis) (Primitive Nothing object) modify $ \e -> e { primitives = (primitives e) { idObject = rORef object } }@@ -125,7 +124,7 @@ -- define primitive objects forM_ primObjs $ \(n, f) -> do o <- newObject $ \o -> o { oDelegates = [object] }- define (psingle n PSelf) (Primitive Nothing o)+ define (psingle n PThis) (Primitive Nothing o) modify $ \e -> e { primitives = f (primitives e) (rORef o) } Kernel.load@@ -136,9 +135,11 @@ , ("Continuation", \is r -> is { idContinuation = r }) , ("Double", \is r -> is { idDouble = r }) , ("Expression", \is r -> is { idExpression = r })+ , ("Haskell", \is r -> is { idHaskell = r }) , ("Integer", \is r -> is { idInteger = r }) , ("List", \is r -> is { idList = r }) , ("Message", \is r -> is { idMessage = r })+ , ("Method", \is r -> is { idMethod = r }) , ("Particle", \is r -> is { idParticle = r }) , ("Process", \is r -> is { idProcess = r }) , ("Pattern", \is r -> is { idPattern = r })@@ -213,11 +214,11 @@ newObject $ \o -> o { oMethods = ( toMethods- [ (psingle "sender" PSelf, callSender c)- , (psingle "message" PSelf, Message (callMessage c))- , (psingle "context" PSelf, callContext c)+ [ (psingle "sender" PThis, callSender c)+ , (psingle "message" PThis, Message (callMessage c))+ , (psingle "context" PThis, callContext c) ]- , M.empty+ , emptyMap ) } eval' (EList { eContents = es }) = do@@ -243,7 +244,7 @@ newObject f = fmap Reference . liftIO $ newIORef . f $ Object { oDelegates = []- , oMethods = (M.empty, M.empty)+ , oMethods = noMethods } -- | run x with t as its toplevel object@@ -270,7 +271,13 @@ define !p !e = do is <- gets primitives newp <- methodPattern p- os <- targets is newp++ os <-+ case p of+ PKeyword { ppTargets = (t:_) } | isTop t ->+ targets is (head (ppTargets newp))+ _ -> targets is newp+ m <- method newp e forM_ os $ \o -> do obj <- liftIO (readIORef o)@@ -283,9 +290,13 @@ liftIO . writeIORef o $ obj { oMethods = ms newp } where+ isTop PThis = True+ isTop (PObject ETop {}) = True+ isTop _ = False+ 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')+ return (\o -> Responder (setSelf o p') t e') methodPattern p'@(PSingle { ppTarget = t }) = do t' <- methodPattern t@@ -293,20 +304,17 @@ 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 PThis = fmap PMatch (gets top)+ methodPattern (PObject oe) = fmap PMatch (eval oe)+ methodPattern (PNamed n p') = fmap (PNamed n) (methodPattern p') methodPattern p' = return p' - -- | Swap out a reference match with PSelf, for inserting on the object+ -- | Swap out a reference match with PThis, 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+ | o == x = PThis setSelf o (PNamed n p') = PNamed n (setSelf o p') setSelf o (PSingle i n t) =@@ -322,7 +330,6 @@ 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@@ -331,6 +338,7 @@ if idChar is `elem` ht || idString is `elem` tt then return [idList is, idString is] else return [idList is]+targets is (PPMKeyword {}) = return [idParticle is] targets _ p = error $ "no targets for " ++ show p @@ -398,7 +406,7 @@ -- | 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+ lookupMap (mID m) (methods m) >>= firstMatch ids m where methods (Single {}) = fst (oMethods o) methods (Keyword {}) = snd (oMethods o)@@ -413,9 +421,9 @@ -- to check things like delegation matches. match :: IDs -> Pattern -> Value -> Bool {-# NOINLINE match #-}-match ids PSelf (Reference y) =+match ids PThis (Reference y) = refMatch ids (idMatch ids) y-match ids PSelf y =+match ids PThis y = match ids (PMatch (Reference (idMatch ids))) (Reference (orefFrom ids y)) match ids (PMatch (Reference x)) (Reference y) = refMatch ids x y@@ -444,7 +452,6 @@ 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@@ -474,17 +481,17 @@ -- 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+runMethod (Responder { mPattern = p, mContext = c, mExpr = e }) m = do nt <- newObject $ \o -> o- { oDelegates = [t]- , oMethods = (bindings p m, M.empty)+ { oDelegates = [c]+ , oMethods = (bindings p m, emptyMap) } modify $ \e' -> e' { call = Call { callSender = top e' , callMessage = m- , callContext = t+ , callContext = c } } @@ -510,7 +517,7 @@ -- | 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' (PNamed n p) v = (psingle n PThis, v) : bindings' p v bindings' (PPMKeyword _ ps) (Particle (PMKeyword _ mvs)) = concat $ map (\(p, Just v) -> bindings' p v) $ filter (isJust . snd)@@ -607,6 +614,10 @@ {-# INLINE findMessage #-} findMessage = findValue "Message" isMessage +findMethod' :: Value -> VM Value+{-# INLINE findMethod' #-}+findMethod' = findValue "Method" isMethod+ findParticle :: Value -> VM Value {-# INLINE findParticle #-} findParticle = findValue "Particle" isParticle@@ -651,6 +662,18 @@ bool True = here "True" bool False = here "False" +ifVM :: VM Value -> VM a -> VM a -> VM a+ifVM c a b = do+ true <- bool True+ r <- c++ if r == true+ then a+ else b++ifE :: Expr -> VM a -> VM a -> VM a+ifE = ifVM . eval+ referenceTo :: Value -> VM Value {-# INLINE referenceTo #-} referenceTo = fmap Reference . orefFor@@ -660,7 +683,7 @@ doBlock bms s es = do blockScope <- newObject $ \o -> o { oDelegates = [s]- , oMethods = (bms, M.empty)+ , oMethods = (bms, emptyMap) } withTop blockScope (evalAll es)@@ -681,14 +704,15 @@ orefFrom ids (Continuation _) = idContinuation ids orefFrom ids (Double _) = idDouble ids orefFrom ids (Expression _) = idExpression ids+orefFrom ids (Haskell _) = idHaskell ids orefFrom ids (Integer _) = idInteger ids orefFrom ids (List _) = idList ids orefFrom ids (Message _) = idMessage ids+orefFrom ids (Method _) = idMethod ids orefFrom ids (Particle _) = idParticle ids orefFrom ids (Process _ _) = idProcess ids orefFrom ids (Pattern _) = idPattern ids orefFrom ids (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@@ -732,8 +756,7 @@ _ -> do initialPath <- gets loadPath - source <- liftIO (readFile file)- ast <- continuedParse source file+ ast <- continuedParseFile file modify $ \s -> s { loadPath = [takeDirectory file]
src/Atomo/Haskell.hs view
@@ -14,10 +14,11 @@ 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 Control.Monad.Cont (MonadCont(..), ContT(..))+import Control.Monad.Error (MonadError(..), ErrorT(..))+import Control.Monad.Identity (runIdentity)+import Control.Monad.State (MonadState(..), gets, modify)+import Control.Monad.Trans import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Text.Parsec@@ -51,7 +52,7 @@ parsing :: Monad m => Parser a -> String -> (String, Int, Int) -> m a parsing p s (file, line, col) =- case runParser pp [] "<qq>" s of+ case runIdentity (runParserT pp [] "<qq>" s) of Left e -> fail (show e) Right e -> return e where@@ -167,10 +168,8 @@ 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)+patternToExp PThis = ConE (mkName "PThis")
src/Atomo/Kernel.hs view
@@ -4,7 +4,6 @@ import Data.IORef import Data.List ((\\)) import Data.Maybe (isJust)-import qualified Data.IntMap as M import Atomo.Debug import Atomo.Environment@@ -19,12 +18,13 @@ 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.Method as Method 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.Boolean as Boolean import qualified Atomo.Kernel.Association as Association import qualified Atomo.Kernel.Parameter as Parameter import qualified Atomo.Kernel.Exception as Exception@@ -73,6 +73,17 @@ findMethod x completed >>= bool . isJust + [$p|(o: Object) methods|] =: do+ o <- here "o" >>= objectFor+ let (ss, ks) = oMethods o+ singles <- mapM (list . map Method) (elemsMap ss) >>= list+ keywords <- mapM (list . map Method) (elemsMap ks) >>= list++ ([$p|ms|] =::) =<< eval [$e|Object clone|]+ [$p|ms singles|] =:: singles+ [$p|ms keywords|] =:: keywords+ here "ms"+ [$p|(s: String) as: String|] =::: [$e|s|] [$p|(x: Object) as: String|] =::: [$e|x show|]@@ -141,7 +152,7 @@ Association.load- Bool.load+ Boolean.load Parameter.load Numeric.load List.load@@ -150,6 +161,7 @@ Expression.load Concurrency.load Message.load+ Method.load Comparable.load Particle.load Pattern.load@@ -166,22 +178,23 @@ 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+ 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)- }- }+ match = (p as: Pattern) matches?: v+ if: (match == @no)+ then: {+ v match: (Block new: es tail in: b context)+ }+ else: {+ @(yes: bindings) = match+ bindings delegates-to: b context+ e evaluate-in: bindings+ }+ } |] joinWith :: Value -> Value -> [Value] -> VM Value@@ -199,11 +212,15 @@ res <- withTop blockScope (evalAll bes) new <- objectFor blockScope++ -- replace the old object with the new one liftIO $ writeIORef r new { oDelegates = oDelegates new \\ [s] , oMethods = oMethods new } + finalize (rORef blockScope) new+ return res _ -> do blockScope <- newObject $ \o -> o@@ -214,7 +231,7 @@ | otherwise = do -- a toplevel scope with transient definitions pseudoScope <- newObject $ \o -> o- { oMethods = (bs, M.empty)+ { oMethods = (bs, emptyMap) } case t of@@ -235,11 +252,14 @@ res <- withTop blockScope (evalAll bes) new <- objectFor blockScope+ liftIO (writeIORef r new { oDelegates = oDelegates new \\ [pseudoScope, doppelganger, s] , oMethods = merge ms (oMethods new) }) + finalize (rORef blockScope) new+ return res _ -> do blockScope <- newObject $ \o -> o@@ -248,11 +268,24 @@ withTop blockScope (evalAll bes) where- bs = addMethod (Slot (psingle "this" PSelf) t) $+ bs = addMethod (Slot (psingle "this" PThis) 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)+ ( foldl (flip addMethod) os (concat $ elemsMap ns)+ , foldl (flip addMethod) ok (concat $ elemsMap nk) )++ -- clear the toplevel object's methods and have it delegate to the updated+ -- object+ --+ -- this is important because method definitions have this as their context,+ -- so methods changed in the new object wouldn't otherwise be available to+ -- them+ finalize :: ORef -> Object -> VM ()+ finalize r c = liftIO $ writeIORef r c+ { oDelegates = t : oDelegates c+ , oMethods = noMethods+ }+ joinWith _ v _ = error $ "impossible: joinWith on " ++ show v
src/Atomo/Kernel/Association.hs view
@@ -11,17 +11,28 @@ Association = Object clone a -> b := Association clone do: { from = a; to = b }- (a: Association) show := a from show .. " -> " .. a to show + (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 }+ 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 }+ if: (k == a from)+ then: { @(ok: a) }+ else: { as find: k }++ (l: List) set: k to: v :=+ (l find: k) match: {+ @none -> l << (k -> v)+ @(ok: a) ->+ { a to = v+ l+ } call+ } |]
src/Atomo/Kernel/Block.hs view
@@ -2,8 +2,6 @@ {-# 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@@ -28,7 +26,7 @@ if length as > 0 then throwError (BlockArity (length as) 0)- else doBlock M.empty s es+ else doBlock emptyMap s es [$p|(b: Block) call: (l: List)|] =: do Block s ps es <- here "b" >>= findBlock@@ -55,27 +53,30 @@ prelude :: VM () prelude = mapM_ eval [$es|- (b: Block) repeat := { b in-context call; b repeat } call+ (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+ 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)+ Block new: (a contents .. b contents) in: dispatch sender (start: Integer) to: (end: Integer) by: (diff: Integer) do: b :=- (start to: end by: diff) each: b+ (start to: end by: diff) each: b (start: Integer) up-to: (end: Integer) do: b :=- start to: end by: 1 do: b+ start to: end by: 1 do: b (start: Integer) down-to: (end: Integer) do: b :=- start to: end by: -1 do: b+ start to: end by: -1 do: b (n: Integer) times: (b: Block) :=- 1 up-to: n do: b in-context+ 1 up-to: n do: b in-context |]
− src/Atomo/Kernel/Bool.hs
@@ -1,64 +0,0 @@-{-# 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/Boolean.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE QuasiQuotes #-}+module Atomo.Kernel.Boolean (load) where++import Atomo.Environment+import Atomo.Haskell+++load :: VM ()+load = mapM_ eval [$es|+ Boolean = Object clone+ True = Object clone+ False = Object clone++ True delegates-to: Boolean+ False delegates-to: Boolean++ True && True = True+ Boolean && Boolean = False++ False and: _ = False+ True and: (b: Block) := b call++ True || Boolean = True+ False || (b: Boolean) := b++ True or: _ = True+ False or: (b: Block) := b call++ True not := False+ False not := True++ if: True then: (a: Block) else: Block :=+ a call++ if: False then: Block else: (b: Block) :=+ b call++ when: False do: Block = @ok+ when: True do: (action: Block) :=+ { action in-context call+ @ok+ } call++ while: (test: Block) do: (action: Block) :=+ when: test call do:+ { action in-context call+ while: test do: action+ }++ True show := "True"+ False show := "False"++ otherwise := True++ condition: (b: Block) :=+ if: b contents empty?+ then: { raise: @no-true-branches }+ else: {+ es = b contents+ [c, e] = es head targets++ if: (c evaluate-in: b context)+ then: { e evaluate-in: b context }+ else: { condition: (Block new: es tail in: b context) }+ }+|]
src/Atomo/Kernel/Comparable.hs view
@@ -204,8 +204,8 @@ prelude :: VM () prelude = mapM_ eval [$es| x max: y :=- if: (x > y) then: { x } else: { y }+ if: (x > y) then: { x } else: { y } x min: y :=- if: (x < y) then: { x } else: { y }+ if: (x < y) then: { x } else: { y } |]
src/Atomo/Kernel/Concurrency.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} module Atomo.Kernel.Concurrency (load) where -import qualified Data.IntMap as M- import Atomo.Environment import Atomo.Haskell import Atomo.Method@@ -33,7 +31,7 @@ if length as > 0 then throwError (BlockArity (length as) 0)- else spawn (doBlock M.empty s bes)+ else spawn (doBlock emptyMap s bes) [$p|(b: Block) spawn: (l: List)|] =: do Block s as bes <- here "b" >>= findBlock
src/Atomo/Kernel/Continuation.hs view
@@ -55,10 +55,8 @@ new = cont clone do: { yield: v := {- dynamic-unwind call: [- winds- dynamic-winds _? length - winds length- ]+ dynamic-unwind: winds+ delta: (dynamic-winds _? length - winds length) cont yield: v } call@@ -80,12 +78,16 @@ } } call|] - ([$p|dynamic-unwind|] =::) =<< eval [$e|{ to d |+ [$p|(init: Block) wrap: cleanup do: action|] =::: [$e|+ { action call: [x] } before: { x = init call } in-context after: { cleanup call: [x] }+ |]++ [$p|dynamic-unwind: to delta: d|] =::: [$e|{ condition: { (dynamic-winds _? == to) -> @ok (d < 0) -> {- dynamic-unwind call: [to tail, d + 1]+ dynamic-unwind: to tail delta: (d + 1) to head from call dynamic-winds =! to @ok@@ -95,7 +97,7 @@ post = dynamic-winds _? head to dynamic-winds =! dynamic-winds _? tail post call- dynamic-unwind call: [to, d - 1]+ dynamic-unwind: to delta: (d - 1) } call }- }|]+ } call|]
src/Atomo/Kernel/Eco.hs view
@@ -10,192 +10,207 @@ loadEco :: VM () loadEco = mapM_ eval [$es|- Eco = Object clone do: {- -- all packages OK for loading- -- name -> [package]- packages = []+ Eco =+ Object clone do:+ { -- all packages OK for loading+ -- name -> [package]+ packages = [] - -- versions loaded by @use:- -- name -> package- loaded = []- }+ -- versions loaded by @use:+ -- name -> package+ loaded = []+ } - Eco Package = Object clone do: {- version = 0 . 1- dependencies = []- include = []- executables = []- }+ Eco Package =+ Object clone do:+ { version = 0 . 1+ dependencies = []+ include = []+ executables = []+ } (e: Eco) initialize :=- e initialize: (Eco Package load-from: "package.eco")+ 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 .. ")")+ (e: Eco) initialize: pkg :=+ { pkg dependencies each: { c |+ e packages (find: c from) match: {+ @none -> raise: @(package-unavailable: c from needed: c to) - -- filter out versions not satisfying our dependency- @(ok: d) -> {- safe = d to (filter: { p | p version join: c to })+ -- 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+ safe match: {+ [] ->+ raise: @(no-versions-of: d satisfy: c to for: pkg name) - -- initialize the first safe version of the package- (p . _) -> {- -- remove unsafe versions from the ecosystem- d to = safe- e initialize: p- } call- }- } call- }+ -- 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+ } call - (e: Eco) load := {- eco = Directory home </> ".eco" </> "lib"+ (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")- }+ when: Directory (exists?: eco) do: {+ e packages =+ Directory (contents: eco) map:+ { c |+ versions = Directory (contents: (eco </> c))+ pkgs = versions map:+ { v |+ Eco Package load-from:+ (eco </> c </> v </> "package.eco")+ } - c -> pkgs (sort-by: { a b | a version < b version })+ c -> pkgs (sort-by: { a b | a version < b version })+ } }- } call + @ok+ } call+ Eco path-to: (c: Eco Package) :=- Eco path-to: c name version: c version+ Eco path-to: c name version: c version Eco path-to: (name: String) :=- Directory home </> ".eco" </> "lib" </> name+ Directory home </> ".eco" </> "lib" </> name - Eco path-to: (name: String) version: (v: Version) :=- (Eco path-to: name) </> (v as: String)+ Eco path-to: pkg version: (v: Version) :=+ (Eco path-to: pkg) </> (v as: String) Eco executable: (name: String) :=- Directory home </> ".eco" </> "bin" </> name+ Directory home </> ".eco" </> "bin" </> name - Eco install: (path: String) := {- pkg = Eco Package load-from: (path </> "package.eco")+ Eco which-main: (path: String) :=+ if: File (exists?: (path </> "main.hs"))+ then: { "main.hs" }+ else: { "main.atomo" }++ Eco install: (path: String) :=+ { pkg = Eco Package load-from: (path </> "package.eco") target = Eco path-to: pkg - contents = "main.atomo" . ("package.eco" . pkg include)+ contents = (Eco which-main: path) . ("package.eco" . pkg include) Directory create-tree-if-missing: target - contents each: { c |+ contents each:+ { c | if: Directory (exists?: (path </> c))- then: { Directory copy: (path </> c) to: (target </> c) }- else: { File copy: (path </> c) to: (target </> 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)+ pkg executables each:+ { e |+ exe =+ [ "#!/usr/bin/env atomo"+ "load: " .. (path </> e to) show+ ] unlines++ with-output-to: (Eco executable: e from) do: { exe print }+ File set-executable: (Eco executable: e from) to: True- }- } call+ } - Eco uninstall: (name: String) version: (version: Version) := {- path = Eco path-to: name version: version+ @ok+ } call++ Eco uninstall: (name: String) version: (version: Version) :=+ { path = Eco path-to: name version: version pkg = Eco Package load-from: (path </> "package.eco") Directory remove-recursive: path- pkg executables each: { e |+ pkg executables each:+ { e | File remove: (Eco executable: e from)- }- } call+ }+ + @ok+ } call Eco uninstall: (name: String) :=- Directory (contents: (Eco path-to: name)) each: { v |+ { 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+ } call + Eco Package load-from: (file: String) :=+ Eco Package clone do: { load: file }+ (p: Eco Package) name: (n: String) :=- p name = n+ p name = n (p: Eco Package) description: (d: String) :=- p description = d+ p description = d (p: Eco Package) version: (v: Version) :=- p version = v+ p version = v (p: Eco Package) author: (a: String) :=- p author = a+ p author = a (p: Eco Package) include: (l: List) :=- p include = l+ 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 dependencies = ds map:+ { d |+ if: (d is-a?: Association)+ then: { d }+ else: { d -> { True } } } (p: Eco Package) executables: (es: List) :=- p executables = es+ p executables = es - Eco Package load-from: (file: String) :=- Eco Package clone do: { load: file }+ context use: (name: String) :=+ context use: name version: { True } + context use: (name: String) version: (v: Version) :=+ context use: name version: { == v }++ context use: (name: String) version: (check: Block) :=+ Eco loaded (lookup: name) match: {+ @none ->+ (Eco packages (lookup: name) match: {+ @none -> raise: @(package-unavailable: name)+ @(ok: []) -> raise: @(no-package-versions: name)+ @(ok: pkgs) ->+ { satisfactory = pkgs filter: { p | p version join: check }++ when: satisfactory empty? do: {+ raise: @(no-versions-of: (name -> versions) satisfy: check)+ }++ Eco loaded << (name -> satisfactory head)++ path = Eco path-to: satisfactory head+ context load: (path </> (Eco which-main: path))++ @ok+ } call+ })++ @(ok: p) ->+ when: (p version join: check) not+ do: { raise: @(incompatible-version-loaded: name needed: check) }+ }+ Eco load |] @@ -204,64 +219,70 @@ Version = Object clone (major: Integer) . (minor: Integer) :=- Version clone do: {- major = major- minor = minor+ Version clone do:+ { major = major+ minor = minor } (major: Integer) . (rest: Version) :=- Version clone do: {- major = major- minor = rest+ Version clone do:+ { major = major+ minor = rest } (v: Version) show :=- v major show .. " . " .. v minor show+ v major show .. " . " .. v minor show (v: Version) as: String :=- v major show .. "." .. v minor (as: String)+ v major show .. "." .. v minor (as: String) (s: String) as: Version :=- s (split-on: '.') (map: @(as: Integer)) reduce-right: @.+ 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 major == b major) and: { a minor == b minor } + (n: Integer) == (v: Version) :=+ (n == v major) && (v minor == 0)++ (v: Version) == (n: Integer) :=+ (n == v major) && (v minor == 0)+ (a: Version) > (b: Version) :=- (a major > b major) or: { a minor > b minor }+ (a major > b major) or: { a minor > b minor } (n: Integer) > (v: Version) :=- (n > v major) or: { v major == n && v minor /= 0 }+ (n > v major) or: { v major == n && (v minor /= 0) } (v: Version) > (n: Integer) :=- (v major > n) or: { v major == n && v minor /= 0 }+ (v major > n) or: { v major == n && (v minor /= 0) } (a: Version) < (b: Version) :=- (a major < b major) or: { a minor < b minor }+ (a major < b major) or: { a minor < b minor } (n: Integer) < (v: Version) :=- (n < v major) or: { v major == n && v minor /= 0 }+ (n < v major) or: { v major == n && (v minor /= 0) } (v: Version) < (n: Integer) :=- (v major < n) or: { v major == n && v minor /= 0 }+ (v major < n) or: { v major == n && (v minor /= 0) } (a: Version) >= (b: Version) :=- (a major >= b major) or: { a minor >= b minor }+ (a major >= b major) or: { a minor >= b minor } (n: Integer) >= (v: Version) :=- n >= v major+ n >= v major (v: Version) >= (n: Integer) :=- v major >= n+ v major >= n (a: Version) <= (b: Version) :=- (a major <= b major) or: { a minor <= b minor }+ (a major <= b major) or: { a minor <= b minor } (n: Integer) <= (v: Version) :=- n <= v major+ n <= v major (v: Version) <= (n: Integer) :=- v major <= n+ v major <= n |]
src/Atomo/Kernel/Exception.hs view
@@ -19,7 +19,10 @@ dispatch (keyword ["call"] [recover, args]) [$p|(action: Block) catch: (recover: Block) ensuring: (cleanup: Block)|] =:- catchError (eval [$e|action call|]) $ \err -> do+ catchError+ (do r <- eval [$e|action call|]+ eval [$e|cleanup call|]+ return r) $ \err -> do recover <- here "recover" args <- list [asValue err] @@ -27,6 +30,21 @@ eval [$e|cleanup call|] return res + [$p|(action: Block) handle: (branches: Block)|] =::: [$e|+ action catch: { e |+ { e match: branches } catch: { e* |+ e* match: {+ @(no-matches-for: _) -> raise: e+ _ -> raise: e*+ }+ }+ }+ |]++ [$p|(a: Block) handle: (b: Block) ensuring: (c: Block)|] =::: [$e|+ { a handle: b } ensuring: c+ |]+ [$p|(action: Block) ensuring: (cleanup: Block)|] =: catchError (do r <- eval [$e|action call|]@@ -64,3 +82,5 @@ asValue NoExpressions = particle "no-expressions" asValue (ValueNotFound d v) = keyParticleN ["could-not-found", "in"] [string d, v]+asValue (DynamicNeeded t) =+ keyParticleN ["dynamic-needed"] [string t]
src/Atomo/Kernel/List.hs view
@@ -37,36 +37,39 @@ ] else return (vs `V.unsafeIndex` fromIntegral n) - [$p|[] head|] =: raise' "empty-list"+ [$p|[] head|] =::: [$e|raise: @empty-list|] [$p|(l: List) head|] =: getVector [$e|l|] >>= return . V.unsafeHead - [$p|[] last|] =: raise' "empty-list"+ [$p|[] last|] =::: [$e|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+ [$p|(l: List) from: (s: Integer) to: (e: Integer)|] =:::+ [$e|l from: s take: (e - s)|]++ [$p|(l: List) from: (s: Integer) take: (n: Integer)|] =: do vs <- getVector [$e|l|] Integer start <- here "s" >>= findInteger- Integer end <- here "e" >>= findInteger+ Integer num <- here "n" >>= findInteger - if start < 0 || end < 0 || (start + end) > fromIntegral (V.length vs)+ if start < 0 || num < 0 || (start + num) > fromIntegral (V.length vs) then here "l" >>= \l -> raise- ["invalid-range", "for-list"]- [ keyParticleN ["from", "to"] [Integer start, Integer end]+ ["invalid-slice", "for-list"]+ [ keyParticleN ["from", "take"] [Integer start, Integer num] , l ]- else list' (V.unsafeSlice+ else list' $ V.unsafeSlice (fromIntegral start)- (fromIntegral end)- vs)+ (fromIntegral num)+ vs - [$p|[] init|] =: raise' "empty-list"+ [$p|[] init|] =::: [$e|raise: @empty-list|] [$p|(l: List) init|] =: getVector [$e|l|] >>= list' . V.unsafeInit - [$p|[] tail|] =: raise' "empty-list"+ [$p|[] tail|] =::: [$e|raise: @empty-list|] [$p|(l: List) tail|] =: getVector [$e|l|] >>= list' . V.unsafeTail @@ -134,7 +137,7 @@ list' nvs - [$p|[] reduce: b|] =: raise' "empty-list"+ [$p|[] reduce: b|] =::: [$e|raise: @empty-list|] [$p|(l: List) reduce: b|] =: do vs <- getVector [$e|l|] b <- here "b"@@ -152,7 +155,7 @@ as <- list [x, acc] dispatch (keyword ["call"] [b, as])) v vs - [$p|[] reduce-right: b|] =: raise' "empty-list"+ [$p|[] reduce-right: b|] =::: [$e|raise: @empty-list|] [$p|(l: List) reduce-right: b|] =: do vs <- getVector [$e|l|] b <- here "b"@@ -271,10 +274,7 @@ 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+ [$p|(l: List) << v|] =: do List l <- here "l" >>= findList vs <- getVector [$e|l|] v <- here "v"@@ -283,7 +283,7 @@ return (List l) - [$p|(l: List) left-push: v|] =: do+ [$p|v >> (l: List)|] =: do List l <- here "l" >>= findList vs <- getVector [$e|l|] v <- here "v"@@ -292,14 +292,14 @@ return (List l) - [$p|[] pop!|] =: raise' "empty-list"+ [$p|[] pop!|] =::: [$e|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)+ return (V.head vs) [$p|(l: List) split: (d: List)|] =: do l <- getList [$e|l|]@@ -331,21 +331,21 @@ prelude :: VM () prelude = mapM_ eval [$es|- (l: List) each: (b: Block) := {- l map: b in-context+ (l: List) each: (b: Block) :=+ { l map: b in-context l- } call+ } call [] includes?: List := False (x: List) includes?: (y: List) :=- if: (x (take: y length) == y)- then: { True }- else: { x tail includes?: y }+ 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)+ x .. d .. (xs join: d) |] foldr1MV :: (Value -> Value -> VM Value) -> V.Vector Value -> VM Value
src/Atomo/Kernel/Message.hs view
@@ -13,6 +13,10 @@ Single {} -> return (particle "single") Keyword {} -> return (particle "keyword") + [$p|(m: Message) send|] =: do+ Message m <- here "m" >>= findMessage+ dispatch m+ [$p|(m: Message) particle|] =: do Message m <- here "m" >>= findMessage case m of
+ src/Atomo/Kernel/Method.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE QuasiQuotes #-}+module Atomo.Kernel.Method where++import Atomo.Environment+import Atomo.Haskell+++load :: VM ()+load = do+ [$p|(m: Method) value|] =: do+ Method m <- here "m" >>= findMethod'+ return (mValue m)++ [$p|(m: Method) pattern|] =: do+ Method m <- here "m" >>= findMethod'+ return (Pattern (mPattern m))++ [$p|(m: Method) expression|] =: do+ Method m <- here "m" >>= findMethod'+ return (Expression (mExpr m))++ [$p|(m: Method) context|] =: do+ Method m <- here "m" >>= findMethod'+ return (mContext m)
src/Atomo/Kernel/Numeric.hs view
@@ -18,14 +18,28 @@ 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|(i: Integer) sqrt|] =: do+ Integer i <- here "i" >>= findInteger+ return (Double (sqrt (fromIntegral i))) - [$p|(a: Double) sqrt|] =: do- Double a <- here "a" >>= findDouble- return (Double (sqrt a))+ [$p|(d: Double) sqrt|] =: do+ Double d <- here "d" >>= findDouble+ return (Double (sqrt d)) + [$p|(d: Double) ceiling|] =: do+ Double d <- here "d" >>= findDouble+ return (Integer (ceiling d))++ [$p|(d: Double) round|] =: do+ Double d <- here "d" >>= findDouble+ return (Integer (round d))++ [$p|(d: Double) floor|] =: do+ Double d <- here "d" >>= findDouble+ return (Integer (floor d))++ [$p|(d: Double) as: Integer|] =::: [$e|d floor|]+ [$p|(a: Integer) + (b: Integer)|] =: primII (+) [$p|(a: Integer) + (b: Double)|] =: primID (+) [$p|(a: Double) + (b: Integer)|] =: primDI (+)@@ -80,8 +94,8 @@ (n: Integer) odd? := n even? not (x: Integer) divides?: (y: Integer) :=- (y % x) == 0+ (y % x) == 0 (x: Integer) divisible-by?: (y: Integer) :=- y divides?: x+ y divides?: x |]
src/Atomo/Kernel/Parameter.hs view
@@ -10,33 +10,33 @@ operator right 0 =! Parameter = Object clone- Parameter new: v := Parameter clone do: {- set-default: v- }+ Parameter new: v := Parameter clone do:+ { set-default: v+ } (p: Parameter) _? := p value: self (p: Parameter) =! v :=- (p) value: (self) = v+ (p) value: (self) = v (p: Parameter) set-default: v :=- (p) value: _ = v+ (p) value: _ = v - with: (p: Parameter) as: new do: (action: Block) := {- old = p _?+ with: (p: Parameter) as: new do: (action: Block) :=+ { old = p _? action before: { p =! new } after: { p =! old }- } call+ } call - with-default: (p: Parameter) as: new do: (action: Block) := {- old = p _?+ with-default: (p: Parameter) as: new do: (action: Block) :=+ { old = p _? action before: { p set-default: new } after: { p set-default: old }- } call+ } 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: 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 }+ with-default: b from as: b to do: { with: bs do: action } |]
src/Atomo/Kernel/Particle.hs view
@@ -47,21 +47,8 @@ } |] - [$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) call: (targets: List)|] =:::+ [$e|(p complete: targets) send|] [$p|(p: Particle) name|] =: do Particle (PMSingle n) <- here "p" >>= findParticle@@ -83,3 +70,20 @@ case p of PMKeyword {} -> return (particle "keyword") PMSingle {} -> return (particle "single")++ [$p|(p: Particle) complete: (targets: List)|] =: do+ Particle p <- here "p" >>= findParticle+ vs <- getList [$e|targets|]++ case p of+ PMKeyword ns mvs -> do+ let blanks = length (filter (== Nothing) mvs)++ if blanks > length vs+ then throwError (ParticleArity blanks (length vs))+ else return . Message . keyword ns $ completeKP mvs vs+ PMSingle n -> do+ if length vs == 0+ then throwError (ParticleArity 1 0)+ else return . Message . single n $ head vs+
src/Atomo/Kernel/Pattern.hs view
@@ -14,6 +14,35 @@ p <- toPattern e return (Pattern p) + [$p|(p: Pattern) name|] =: do+ Pattern p <- here "p" >>= findPattern++ case p of+ PNamed n _ -> return (string n)+ PSingle { ppName = n } -> return (string n)+ _ -> raise ["no-name-for"] [Pattern p]++ [$p|(p: Pattern) names|] =: do+ Pattern p <- here "p" >>= findPattern++ case p of+ PKeyword { ppNames = ns } -> list (map string ns)+ _ -> raise ["no-names-for"] [Pattern p]++ [$p|(p: Pattern) target|] =: do+ Pattern p <- here "p" >>= findPattern++ case p of+ PSingle { ppTarget = t } -> return (Pattern t)+ _ -> raise ["no-target-for"] [Pattern p]++ [$p|(p: Pattern) targets|] =: do+ Pattern p <- here "p" >>= findPattern++ case p of+ PKeyword { ppTargets = ts } -> list (map Pattern ts)+ _ -> raise ["no-targets-for"] [Pattern p]+ [$p|(p: Pattern) matches?: v|] =: do Pattern p <- here "p" >>= findPattern v <- here "v"@@ -46,7 +75,7 @@ ps <- mapM toPattern es return (PList ps) toPattern (EParticle { eParticle = EPMSingle n }) =- return (PPMSingle n)+ return (PMatch (Particle (PMSingle n))) toPattern (EParticle { eParticle = EPMKeyword ns mes }) = do ps <- forM mes $ \me -> case me of
src/Atomo/Kernel/Ports.hs view
@@ -2,7 +2,6 @@ module Atomo.Kernel.Ports (load) where import Data.Char (isSpace)-import Data.Dynamic import Data.Maybe (catMaybes) import System.Directory import System.FilePath ((</>), (<.>))@@ -93,9 +92,23 @@ [$p|read-line|] =::: [$e|current-input-port _? read-line|] [$p|(p: Port) read-line|] =: do- getHandle [$e|p handle|] >>= liftIO . TIO.hGetLine- >>= return . String+ h <- getHandle [$e|p handle|]+ done <- liftIO (hIsEOF h) + if done+ then raise' "end-of-input"+ else fmap String $ liftIO (TIO.hGetLine h)++ [$p|read-char|] =::: [$e|current-input-port _? read-char|]+ [$p|(p: Port) read-char|] =: do+ h <- getHandle [$e|p handle|]+ b <- liftIO (hGetBuffering h)+ liftIO (hSetBuffering h NoBuffering)+ c <- liftIO (hGetChar h)+ liftIO (hSetBuffering h b)++ return (Char c)+ [$p|contents|] =::: [$e|current-input-port _? contents|] [$p|(p: Port) contents|] =: getHandle [$e|p handle|] >>= liftIO . TIO.hGetContents@@ -204,7 +217,7 @@ >>= fmap searchable . liftIO . getPermissions >>= bool - [$p|File set-readable: (fn: String) to: (b: Bool)|] =: do+ [$p|File set-readable: (fn: String) to: (b: Boolean)|] =: do t <- bool True b <- here "b" fn <- getString [$e|fn|]@@ -212,7 +225,7 @@ liftIO (setPermissions fn (ps { readable = b == t })) return (particle "ok") - [$p|File set-writable: (fn: String) to: (b: Bool)|] =: do+ [$p|File set-writable: (fn: String) to: (b: Boolean)|] =: do t <- bool True b <- here "b" fn <- getString [$e|fn|]@@ -220,7 +233,7 @@ liftIO (setPermissions fn (ps { writable = b == t })) return (particle "ok") - [$p|File set-executable: (fn: String) to: (b: Bool)|] =: do+ [$p|File set-executable: (fn: String) to: (b: Boolean)|] =: do t <- bool True b <- here "b" fn <- getString [$e|fn|]@@ -228,7 +241,7 @@ liftIO (setPermissions fn (ps { executable = b == t })) return (particle "ok") - [$p|File set-searchable: (fn: String) to: (b: Bool)|] =: do+ [$p|File set-searchable: (fn: String) to: (b: Boolean)|] =: do t <- bool True b <- here "b" fn <- getString [$e|fn|]@@ -330,15 +343,13 @@ portObj hdl = newScope $ do port <- eval [$e|Port clone|] [$p|p|] =:: port- [$p|p handle|] =:: Haskell (toDyn hdl)+ [$p|p handle|] =:: haskell hdl here "p" - getHandle ex = do- Haskell hdl <- eval ex- return (fromDyn hdl (error "handle invalid"))+ getHandle ex = eval ex >>= fromHaskell "Handle" hGetSegment :: Handle -> IO String- hGetSegment h = dropSpaces >> hGetSegment'+ hGetSegment h = dropSpaces >> hGetSegment' Nothing where dropSpaces = do c <- hLookAhead h@@ -346,7 +357,7 @@ then hGetChar h >> dropSpaces else return () - hGetSegment' = do+ hGetSegment' stop = do end <- hIsEOF h if end@@ -356,16 +367,27 @@ 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]+ '"' -> wrapped '"'+ '\'' -> wrapped '\''+ '(' -> nested '(' ')'+ '{' -> nested '{' '}'+ '[' -> nested '[' ']'+ s | (stop == Nothing && isSpace s) || (Just s == stop) ->+ return [c] _ -> do- cs <- hGetSegment'+ cs <- hGetSegment' stop return (c:cs)+ where+ wrapped d = do+ w <- fmap (d:) $ hGetUntil h d+ rest <- hGetSegment' stop+ return (w ++ rest) + nested c end = do+ sub <- fmap (c:) $ hGetSegment' (Just end)+ rest <- hGetSegment' stop+ return (sub ++ rest)+ hGetUntil :: Handle -> Char -> IO String hGetUntil h x = do c <- hGetChar h@@ -380,16 +402,18 @@ 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+ { Port (new: fn mode: @write) } wrap: @close do:+ { file |+ with-output-to: file do: b } with-output-to: (p: Port) do: b :=- with: current-output-port as: p do: b+ with: 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+ { Port (new: fn mode: @read) } wrap: @close do:+ { file |+ with-input-from: file do: b } with-input-from: (p: Port) do: (b: Block) :=@@ -397,18 +421,20 @@ with-all-output-to: (fn: String) do: b :=- Port (new: fn) ensuring: @close do: { file |- with-all-output-to: file do: b+ { Port (new: fn mode: @write) } wrap: @close do:+ { file |+ with-all-output-to: file do: b } with-all-output-to: (p: Port) do: b := with-default: current-output-port as: p do: b with-all-input-from: (fn: String) do: (b: Block) :=- Port (new: fn) ensuring: @close do: { file |- with-all-input-from: file do: b+ { Port (new: fn mode: @read) } wrap: @close do:+ { file |+ with-all-input-from: file do: b } with-all-input-from: (p: Port) do: (b: Block) :=- with-default: current-input-port as: p do: b+ with-default: current-input-port as: p do: b |]
src/Atomo/Kernel/String.hs view
@@ -33,23 +33,26 @@ [$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"+ if fromIntegral n >= T.length t+ then raise ["out-of-bounds", "for-string"] [Integer n, String t]+ else return . Char $ t `T.index` fromIntegral n++ [$p|"" head|] =::: [$e|raise: @empty-string|] [$p|(s: String) head|] =: getText [$e|s|] >>= return . Char . T.head - [$p|"" last|] =: raise' "empty-string"+ [$p|"" last|] =::: [$e|raise: @empty-string|] [$p|(s: String) last|] =: getText [$e|s|] >>= return . Char . T.last -- TODO: @from:to: - [$p|"" init|] =: raise' "empty-string"+ [$p|"" init|] =::: [$e|raise: @empty-string|] [$p|(s: String) init|] =: getText [$e|s|] >>= return . String . T.init - [$p|"" tail|] =: raise' "empty-string"+ [$p|"" tail|] =::: [$e|raise: @empty-string|] [$p|(s: String) tail|] =: getText [$e|s|] >>= return . String . T.tail
src/Atomo/Kernel/Time.hs view
@@ -37,17 +37,17 @@ prelude :: VM () prelude = mapM_ eval [$es| Timer do: (b: Block) every: (n: Number) :=- { { Timer sleep: n; b spawn } repeat } spawn+ { { Timer sleep: n; b spawn } repeat } spawn Timer do: (b: Block) after: (n: Number) :=- { Timer sleep: n; b call } spawn+ { Timer sleep: n; b call } spawn - (b: Block) time := {- before = Timer now+ (b: Block) time :=+ { before = Timer now b call after = Timer now after - before- } call+ } call -- units! (n: Number) us := n
src/Atomo/Method.hs view
@@ -1,4 +1,13 @@-module Atomo.Method (addMethod, insertMethod, toMethods) where+module Atomo.Method+ ( addMethod+ , elemsMap+ , emptyMap+ , insertMethod+ , lookupMap+ , noMethods+ , nullMap+ , toMethods+ ) where import Data.IORef import Data.List (elemIndices)@@ -17,7 +26,7 @@ comparePrecision (PNamed _ a) b = comparePrecision a b comparePrecision a (PNamed _ b) = comparePrecision a b comparePrecision PAny PAny = EQ-comparePrecision PSelf PSelf = EQ+comparePrecision PThis PThis = EQ comparePrecision (PMatch (Reference a)) (PMatch (Reference b)) | unsafeDelegatesTo (Reference a) (Reference b) = LT | unsafeDelegatesTo (Reference a) (Reference b) = GT@@ -25,7 +34,6 @@ 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) =@@ -37,20 +45,18 @@ comparePrecision (PObject _) (PObject _) = EQ comparePrecision PAny _ = GT comparePrecision _ PAny = LT-comparePrecision PSelf (PMatch (Reference _)) = LT-comparePrecision (PMatch (Reference _)) PSelf = GT+comparePrecision PThis (PMatch (Reference _)) = LT+comparePrecision (PMatch (Reference _)) PThis = 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 PThis _ = LT+comparePrecision _ PThis = GT comparePrecision (PObject _) _ = LT comparePrecision _ (PObject _) = GT comparePrecision _ _ = GT@@ -94,32 +100,25 @@ LT -> x : ys -- replace equivalent patterns- _ | equivalent (mPattern x) (mPattern y) -> insertMethod x ys'+ _ | 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+toMethods bs = foldl (\ss (p, v) -> addMethod (Slot p v) ss) emptyMap 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+noMethods :: (MethodMap, MethodMap)+noMethods = (M.empty, M.empty)++emptyMap :: MethodMap+emptyMap = M.empty++lookupMap :: Int -> MethodMap -> Maybe [Method]+lookupMap = M.lookup++nullMap :: MethodMap -> Bool+nullMap = M.null++elemsMap :: MethodMap -> [[Method]]+elemsMap = M.elems
src/Atomo/Parser.hs view
@@ -1,7 +1,8 @@ module Atomo.Parser where -import "monads-fd" Control.Monad.Error-import "monads-fd" Control.Monad.State+import Control.Monad.Error+import Control.Monad.Identity+import Control.Monad.State import Data.Maybe (fromJust) import Text.Parsec @@ -21,7 +22,14 @@ defaultPrec = 5 pExpr :: Parser Expr-pExpr = try pOperator <|> try pDefine <|> try pSet <|> try pDispatch <|> pLiteral <|> parens pExpr+pExpr = choice+ [ try pOperator+ , try pDefine+ , try pSet+ , try pDispatch+ , pLiteral+ , parens pExpr+ ] <?> "expression" pLiteral :: Parser Expr@@ -68,7 +76,7 @@ return $ EPMKeyword [op] [Nothing, Nothing] symbols = do- names <- many1 (anyIdentifier >>= \n -> char ':' >> return n)+ names <- many1 (anyIdent >>= \n -> char ':' >> return n) spacing return $ EPMKeyword names (replicate (length names + 1) Nothing) @@ -252,7 +260,13 @@ 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)+ nextFirst =+ isOperator n && or+ [ null ns+ , prec next > prec n+ , assoc n == ARight && prec next == prec n+ ]+ where next = head ns assoc n' = case lookup n' ops of@@ -266,7 +280,8 @@ toBinaryOps _ u = error $ "cannot toBinaryOps: " ++ show u isOperator :: String -> Bool-isOperator = all (`elem` opLetters)+isOperator "" = error "isOperator: empty string"+isOperator (c:_) = c `elem` opLetters parser :: Parser [Expr] parser = do@@ -284,20 +299,23 @@ return (s, r) parseFile :: String -> IO (Either ParseError [Expr])-parseFile fn = fmap (runParser parser [] fn) (readFile fn)+parseFile fn = fmap (runIdentity . runParserT parser [] fn) (readFile fn) parseInput :: String -> Either ParseError [Expr]-parseInput = runParser parser [] "<input>"+parseInput = runIdentity . runParserT parser [] "<input>" parse :: Parser a -> String -> Either ParseError a-parse p = runParser p [] "<parse>"+parse p = runIdentity . runParserT 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+ case runIdentity (runParserT cparser ps s i) of Left e -> throwError (ParseError e) Right (ps', es) -> do modify $ \e -> e { parserState = ps' } return es++continuedParseFile :: FilePath -> VM [Expr]+continuedParseFile fn = liftIO (readFile fn) >>= flip continuedParse fn
src/Atomo/Parser/Base.hs view
@@ -2,7 +2,7 @@ {-# OPTIONS -fno-warn-name-shadowing #-} module Atomo.Parser.Base where -import "mtl" Control.Monad.Identity+import Control.Monad.Identity import Data.Char import Data.List (nub, sort, (\\)) import Text.Parsec@@ -11,7 +11,7 @@ import Atomo.Types (Expr(..), Operators) -type Parser = Parsec String Operators+type Parser = ParsecT String Operators Identity opLetters :: [Char]
src/Atomo/Parser/Pattern.hs view
@@ -170,7 +170,7 @@ char '@' try keywordParticle <|> singleParticle where- singleParticle = fmap PPMSingle anyIdentifier+ singleParticle = fmap (PMatch . Particle . PMSingle) anyIdentifier keywordParticle = choice [ parens $ do@@ -182,7 +182,7 @@ spacing return $ PPMKeyword [o] [PAny, PAny] , do- names <- many1 (anyIdentifier >>= \n -> char ':' >> return n)+ names <- many1 (anyIdent >>= \n -> char ':' >> return n) spacing return $ PPMKeyword names (replicate (length names + 1) PAny) ]
src/Atomo/Pretty.hs view
@@ -2,13 +2,14 @@ module Atomo.Pretty (Pretty(..), prettyStack) where import Data.IORef+import Data.List (nub) 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.Method import Atomo.Types hiding (keyword) import Atomo.Parser.Base (opLetters) @@ -45,6 +46,8 @@ brackets . hsep . punctuate comma $ map (prettyFrom CList) vs where vs = V.toList (unsafePerformIO (readIORef l)) prettyFrom _ (Message m) = internal "message" $ pretty m+ prettyFrom _ (Method (Slot p _)) = internal "slot" $ parens (pretty p)+ prettyFrom _ (Method (Responder p _ _)) = internal "responder" $ parens (pretty p) prettyFrom _ (Particle p) = char '@' <> pretty p prettyFrom _ (Pattern p) = internal "pattern" $ pretty p prettyFrom _ (Process _ tid) =@@ -57,23 +60,23 @@ 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 ->+ , if not (nullMap ss)+ then nest 2 $ vcat (flip map (elemsMap ss) $ (\ms -> vcat (map prettyMethod ms))) <>- if not (M.null ks)+ if not (nullMap ks) then char '\n' else empty else empty - , if not (M.null ks)- then nest 2 . vcat $ flip map (M.elems ks) $ \ms ->+ , if not (nullMap ks)+ then nest 2 . vcat $ flip map (elemsMap 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 }) =+ prettyMethod (Responder { mPattern = p, mExpr = e }) = prettyFrom CDefine p <+> text ":=" <++> prettyFrom CDefine e instance Pretty Message where@@ -99,8 +102,10 @@ prettyFrom _ PAny = text "_" prettyFrom _ (PHeadTail h t) = parens $ pretty h <+> text "." <+> pretty t- prettyFrom _ (PKeyword _ ns (PSelf:vs)) =+ prettyFrom _ (PKeyword _ ns (PObject ETop {}:vs)) = headlessKeywords ns vs+ prettyFrom _ (PKeyword _ ns (PThis:vs)) =+ headlessKeywords ns vs prettyFrom _ (PKeyword _ ns vs) = keywords ns vs prettyFrom _ (PList ps) = brackets . sep $ punctuate comma (map pretty ps)@@ -108,7 +113,6 @@ 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) =@@ -117,10 +121,10 @@ 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 PThis) = text n prettyFrom _ (PSingle _ n p) = pretty p <+> text n+ prettyFrom _ PThis = text "<this>" instance Pretty Expr where@@ -181,7 +185,7 @@ 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))+ text "import error:" $$ nest 2 (vcat (map (\e -> text e <> char '\n') (nub (map H.errMsg ges)))) prettyFrom _ (ImportError (H.NotAllowed s)) = text "import error:" <+> text s prettyFrom _ (ImportError (H.GhcException s)) =@@ -207,6 +211,8 @@ prettyFrom _ NoExpressions = text "no expressions to evaluate" prettyFrom _ (ValueNotFound d v) = text ("could not find a " ++ d ++ " in") <+> pretty v+ prettyFrom _ (DynamicNeeded t) =+ text "dynamic value not of type" <+> text t instance Pretty Delegates where
src/Atomo/Types.hs view
@@ -3,10 +3,10 @@ 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 Control.Monad.Trans+import Control.Monad.Cont+import Control.Monad.Error+import Control.Monad.State import Data.Dynamic import Data.Hashable (hash) import Data.IORef@@ -29,6 +29,7 @@ | Integer !Integer | List VVector | Message Message+ | Method Method | Particle Particle | Process Channel ThreadId | Pattern Pattern@@ -46,16 +47,16 @@ deriving Show data Method- = Method+ = Responder { mPattern :: !Pattern- , mTop :: !Value+ , mContext :: !Value , mExpr :: !Expr } | Slot { mPattern :: !Pattern , mValue :: !Value }- deriving Show+ deriving (Eq, Show) data Message = Keyword@@ -68,12 +69,12 @@ , mName :: String , mTarget :: Value }- deriving Show+ deriving (Eq, Show) data Particle = PMSingle String | PMKeyword [String] [Maybe Value]- deriving Show+ deriving (Eq, Show) data AtomoError = Error Value@@ -86,6 +87,7 @@ | BlockArity Int Int | NoExpressions | ValueNotFound String Value+ | DynamicNeeded String deriving Show -- pattern-matches@@ -101,14 +103,13 @@ | PMatch Value | PNamed String Pattern | PObject Expr- | PPMSingle String | PPMKeyword [String] [Pattern]- | PSelf | PSingle { ppID :: !Int , ppName :: String , ppTarget :: Pattern }+ | PThis deriving Show -- expressions@@ -173,12 +174,12 @@ , emName :: String , emTarget :: Expr }- deriving Show+ deriving (Eq, Show) data EParticle = EPMSingle String | EPMKeyword [String] [Maybe Expr]- deriving Show+ deriving (Eq, Show) -- the evaluation environment data Env =@@ -194,9 +195,6 @@ , parserState :: Operators } --- simple mapping from operator name -> associativity and predence-type Operators = [(String, (Assoc, Integer))]- -- operator associativity data Assoc = ALeft | ARight deriving (Eq, Show)@@ -219,9 +217,11 @@ , idContinuation :: ORef , idDouble :: ORef , idExpression :: ORef+ , idHaskell :: ORef , idInteger :: ORef , idList :: ORef , idMessage :: ORef+ , idMethod :: ORef , idParticle :: ORef , idProcess :: ORef , idPattern :: ORef@@ -229,32 +229,79 @@ } +-- helper synonyms+type Operators = [(String, (Assoc, Integer))] -- name -> assoc, precedence+type Delegates = [Value]+type Channel = Chan Value+type MethodMap = M.IntMap [Method]+type ORef = IORef Object+type VVector = IORef (V.Vector Value)+type Continuation = IORef (Value -> VM Value) + -- 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+ (==) (Block at aps aes) (Block bt bps bes) =+ at == bt && aps == bps && aes == bes+ (==) (Char a) (Char b) = a == b+ (==) (Continuation a) (Continuation b) = a == b+ (==) (Double a) (Double b) = a == b+ (==) (Expression a) (Expression b) = a == b+ (==) (Haskell _) (Haskell _) = False+ (==) (Integer a) (Integer b) = a == b+ (==) (List a) (List b) = a == b+ (==) (Message a) (Message b) = a == b+ (==) (Method a) (Method b) = a == b+ (==) (Particle a) (Particle b) = a == b+ (==) (Process _ a) (Process _ b) = a == b+ (==) (Reference a) (Reference b) = a == b+ (==) (String a) (String b) = a == b+ (==) _ _ = False +instance Eq Pattern where+ -- check if two patterns are "equivalent", ignoring names for patterns+ -- and other things that mean the same thing+ (==) PAny PAny = True+ (==) (PHeadTail ah at) (PHeadTail bh bt) =+ (==) ah bh && (==) at bt+ (==) (PKeyword _ ans aps) (PKeyword _ bns bps) =+ ans == bns && and (zipWith (==) aps bps)+ (==) (PList aps) (PList bps) =+ length aps == length bps && and (zipWith (==) aps bps)+ (==) (PMatch a) (PMatch b) = a == b+ (==) (PNamed _ a) (PNamed _ b) = (==) a b+ (==) (PNamed _ a) b = (==) a b+ (==) a (PNamed _ b) = (==) a b+ (==) (PPMKeyword ans aps) (PPMKeyword bns bps) =+ ans == bns && and (zipWith (==) aps bps)+ (==) (PSingle ai _ at) (PSingle bi _ bt) =+ ai == bi && (==) at bt+ (==) PThis PThis = True+ (==) _ _ = False+++instance Eq Expr where+ (==) (Define _ ap ae) (Define _ bp be) = ap == bp && ae == be+ (==) (Set _ ap ae) (Set _ bp be) = ap == bp && ae == be+ (==) (Dispatch _ am) (Dispatch _ bm) = am == bm+ (==) (Operator _ ans aa ap) (Operator _ bns ba bp) =+ ans == bns && aa == ba && ap == bp+ (==) (Primitive _ a) (Primitive _ b) = a == b+ (==) (EBlock _ aas aes) (EBlock _ bas bes) =+ aas == bas && aes == bes+ (==) (EDispatchObject _) (EDispatchObject _) = True+ (==) (EList _ aes) (EList _ bes) = aes == bes+ (==) (EParticle _ ap) (EParticle _ bp) = ap == bp+ (==) (ETop _) (ETop _) = True+ (==) (EVM _ _) (EVM _ _) = False+ (==) _ _ = 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" @@ -273,6 +320,7 @@ instance Typeable (VM a) where typeOf _ = mkTyConApp (mkTyCon "VM") [typeOf ()] + startEnv :: Env startEnv = Env { top = error "top object not set"@@ -285,9 +333,11 @@ , idContinuation = error "idContinuation not set" , idDouble = error "idDouble not set" , idExpression = error "idExpression not set"+ , idHaskell = error "idHaskell not set" , idInteger = error "idInteger not set" , idList = error "idList not set" , idMessage = error "idMessage not set"+ , idMethod = error "idMethod not set" , idParticle = error "idParticle not set" , idProcess = error "idProcess not set" , idPattern = error "idPattern not set"@@ -331,6 +381,24 @@ {-# INLINE string #-} string = String . T.pack +haskell :: Typeable a => a -> Value+{-# INLINE haskell #-}+haskell = Haskell . toDyn++fromHaskell :: Typeable a => String -> Value -> VM a+fromHaskell t (Haskell d) =+ case fromDynamic d of+ Just a -> return a+ Nothing -> throwError (DynamicNeeded t)+fromHaskell t _ = throwError (DynamicNeeded t)++fromHaskell' :: Typeable a => String -> Value -> a+fromHaskell' t (Haskell d) =+ case fromDynamic d of+ Just a -> a+ Nothing -> error ("needed Haskell value of type " ++ t)+fromHaskell' t _ = error ("needed haskell value of type " ++ t)+ list :: MonadIO m => [Value] -> m Value list = list' . V.fromList @@ -369,6 +437,8 @@ {-# INLINE ekeyword #-} ekeyword ns = EKeyword (hash ns) ns +-- | Fill in the empty values of a particle. The number of values missing+-- is expected to be equal to the number of values provided. completeKP :: [Maybe Value] -> [Value] -> [Value] completeKP [] [] = [] completeKP (Nothing:mvs') (v:vs') = v : completeKP mvs' vs'@@ -419,6 +489,11 @@ isMessage :: Value -> Bool isMessage (Message _) = True isMessage _ = False++-- | Is a value a Method?+isMethod :: Value -> Bool+isMethod (Method _) = True+isMethod _ = False -- | Is a value a Particle? isParticle :: Value -> Bool
+ src/Atomo/Valuable.hs view
@@ -0,0 +1,49 @@+module Atomo.Valuable where++import Control.Monad.Trans (liftIO)+import Data.IORef+import qualified Data.Text as T+import qualified Data.Vector as V++import Atomo.Types+++class Valuable a where+ toValue :: a -> VM Value+ fromValue :: Value -> VM a++instance Valuable Value where+ toValue = return+ fromValue = return++instance Valuable Char where+ toValue = return . Char+ fromValue (Char c) = return c++instance Valuable Double where+ toValue = return . Double+ fromValue (Double d) = return d++instance Valuable Float where+ toValue = return . Double . fromRational . toRational+ fromValue (Double d) = return (fromRational . toRational $ d)++instance Valuable Integer where+ toValue = return . Integer+ fromValue (Integer i) = return i++instance Valuable Int where+ toValue = return . Integer . fromIntegral+ fromValue (Integer i) = return (fromIntegral i)++instance Valuable a => Valuable [a] where+ toValue xs = mapM toValue xs >>= list+ fromValue (List v) = liftIO (readIORef v) >>= mapM fromValue . V.toList++instance Valuable a => Valuable (V.Vector a) where+ toValue xs = V.mapM toValue xs >>= list'+ fromValue (List v) = liftIO (readIORef v) >>= V.mapM fromValue++instance Valuable T.Text where+ toValue = return . String+ fromValue (String s) = return s
src/Main.hs view
@@ -1,7 +1,7 @@ module Main where -import "monads-fd" Control.Monad.Cont-import "monads-fd" Control.Monad.Error+import Control.Monad.Cont+import Control.Monad.Error import Data.Char (isSpace) import Prelude hiding (catch) import System.Console.Haskeline
− src/rts.c
@@ -1,1 +0,0 @@-char *ghc_rts_opts = "-N";