Commits

Alex Suraci committed b6f1e20

fleshed out Atomy.Runtime.eval, added Atomy.Dynamic

Comments (0)

Files changed (2)

src/Atomy/Dynamic.hs

+module Atomy.Dynamic where
+
+import Data.Hashable (hash)
+import qualified Data.IntMap as M
+
+import Atomy.Types
+
+
+newDynamic :: String -> Value -> DynamicMap -> DynamicMap
+newDynamic n v m =
+    M.insert (hash n) [v] m
+
+bindDynamic :: String -> Value -> DynamicMap -> DynamicMap
+bindDynamic n v m =
+    M.adjust (v:) (hash n) m
+
+unbindDynamic :: String -> DynamicMap -> DynamicMap
+unbindDynamic n m =
+    M.adjust tail (hash n) m
+
+setDynamic :: String -> Value -> DynamicMap -> DynamicMap
+setDynamic n v m =
+    M.adjust ((v:) . tail) (hash n) m
+
+getDynamic :: String -> DynamicMap -> Maybe Value
+getDynamic n m = fmap head (M.lookup (hash n) m)
+
+isBound :: String -> DynamicMap -> Bool
+isBound n m =
+    case M.lookup (hash n) m of
+        Just x -> length x > 1
+        Nothing -> False

src/Atomy/Runtime.hs

 import Control.Monad.State
 import qualified Data.Map as M
 
+import Atomy.Dynamic
 import Atomy.Method
 import Atomy.Pattern
 import Atomy.Types
 
     return res
 
+dynamicBind :: [(String, Value)] -> VM a -> VM a
+dynamicBind bs x = do
+    modify $ \e -> e
+        { dynamic = foldl (\m (n, v) -> bindDynamic n v m) (dynamic e) bs
+        }
+
+    res <- x
+
+    modify $ \e -> e
+        { dynamic = foldl (\m (n, _) -> unbindDynamic n m) (dynamic e) bs
+        }
+
+    return res
 -- | Evaluate an expression, yielding a value.
 eval :: Expr -> VM Value
 eval (Define { emPattern = p, eExpr = ev }) = do
 eval (Primitive { eValue = v }) = return v
 eval (ETop {}) = gets top
 eval (EVM { eAction = x }) = x
-eval e = error $ "no eval for " ++ show e
+eval (Operator {}) = return (particle "ok")
+eval (EBlock { eArguments = as, eContents = es }) = do
+    Trait t <- gets top
+    return (Block t as es)
+eval (EList { eContents = es }) = do
+    vs <- mapM eval es
+    return (list vs)
+eval (EParticle { eParticle = Single i n Nothing }) =
+    return (Particle $ Single i n Nothing)
+eval (EParticle { eParticle = Keyword i ns mes }) = do
+    mvs <- forM mes $
+        maybe (return Nothing) (liftM Just . eval)
+    return (Particle $ Keyword i ns mvs)
+eval (EMacro {}) = return (particle "ok")
+eval (EForMacro {}) = return (particle "ok")
+eval (EUnquote { eExpr = e }) = raise ["out-of-quote"] [Expression e]
+eval (EQuote { eExpr = qe }) = do
+    unquoted <- unquote 0 qe
+    return (Expression unquoted)
+  where
+    unquote :: Int -> Expr -> VM Expr
+    unquote 0 (EUnquote { eExpr = e }) = do
+        r <- eval e
+        case r of
+            Expression e' -> return e'
+            _ -> return (Primitive Nothing r)
+    unquote n u@(EUnquote { eExpr = e }) = do
+        ne <- unquote (n - 1) e
+        return (u { eExpr = ne })
+    unquote n q@(EQuote { eExpr = e }) = do
+        ne <- unquote (n + 1) e
+        return q { eExpr = ne }
+    unquote n d@(Define { eExpr = e }) = do
+        ne <- unquote n e
+        return (d { eExpr = ne })
+    unquote n s@(Set { eExpr = e }) = do
+        ne <- unquote n e
+        return (s { eExpr = ne })
+    unquote n d@(Dispatch { eMessage = em }) =
+        case em of
+            Keyword { mTargets = ts } -> do
+                nts <- mapM (unquote n) ts
+                return d { eMessage = em { mTargets = nts } }
+
+            Single { mTarget = t } -> do
+                nt <- unquote n t
+                return d { eMessage = em { mTarget = nt } }
+    unquote n b@(EBlock { eContents = es }) = do
+        nes <- mapM (unquote n) es
+        return b { eContents = nes }
+    unquote n l@(EList { eContents = es }) = do
+        nes <- mapM (unquote n) es
+        return l { eContents = nes }
+    unquote n m@(EMacro { eExpr = e }) = do
+        ne <- unquote n e
+        return m { eExpr = ne }
+    unquote n p@(EParticle { eParticle = ep }) =
+        case ep of
+            Keyword i ns mes -> do
+                nmes <- forM mes $ \me ->
+                    case me of
+                        Nothing -> return Nothing
+                        Just e -> liftM Just (unquote n e)
+
+                return p { eParticle = Keyword i ns nmes }
+
+            _ -> return p
+    unquote n d@(ENewDynamic { eExpr = e }) = do
+        ne <- unquote n e
+        return d { eExpr = ne }
+    unquote n d@(EDefineDynamic { eExpr = e }) = do
+        ne <- unquote n e
+        return d { eExpr = ne }
+    unquote n d@(ESetDynamic { eExpr = e }) = do
+        ne <- unquote n e
+        return d { eExpr = ne }
+    unquote n p@(Primitive { eValue = Expression e }) = do
+        ne <- unquote n e
+        return p { eValue = Expression ne }
+    unquote _ p@(Primitive {}) = return p
+    unquote _ t@(ETop {}) = return t
+    unquote _ v@(EVM {}) = return v
+    unquote _ o@(Operator {}) = return o
+    unquote _ f@(EForMacro {}) = return f
+    unquote _ g@(EGetDynamic {}) = return g
+eval (ENewDynamic { eBindings = bes, eExpr = e }) = do
+    bvs <- forM bes $ \(n, b) -> do
+        v <- eval b
+        return (n, v)
+
+    dynamicBind bvs (eval e)
+eval (EDefineDynamic { eName = n, eExpr = e }) = do
+    v <- eval e
+
+    modify $ \env -> env
+        { dynamic = newDynamic n v (dynamic env)
+        }
+
+    return v
+eval (ESetDynamic { eName = n, eExpr = e }) = do
+    v <- eval e
+    d <- gets dynamic
+
+    if isBound n d
+        then modify $ \env -> env { dynamic = setDynamic n v d }
+        else raise ["unbound-dynamic"] [string n]
+
+    return v
+eval (EGetDynamic { eName = n }) = do
+    mv <- gets (getDynamic n . dynamic)
+    maybe (raise ["unknown-dynamic"] [string n]) return mv
+
+-- | Evaluate multiple expressions, returning the last result.
+evalAll :: [Expr] -> VM Value
+evalAll [] = throwError NoExpressions
+evalAll [e] = eval e
+evalAll (e:es) = eval e >> evalAll es
 
 -- | Pattern-match a value, inserting bindings into the current toplevel.
 set :: Pattern -> Value -> VM Value