Revive evaluation code.

Main.hs

@@ -1,23 +1,19 @@
 -- {-# LANGUAGE DeriveDataTypeable #-}
 -- {-# LANGUAGE DeriveGeneric #-}
--- {-# LANGUAGE RecursiveDo #-}
 -- {-# LANGUAGE TemplateHaskell #-}
 -- {-# LANGUAGE ViewPatterns #-}
 
 module Main where
 
 -- import Control.Applicative
 -- import Control.Monad
--- import Control.Monad.Error.Class
 -- import Control.Monad.Error.Lens
--- import Control.Monad.IO.Class
 -- import Control.Monad.Trans.Either
 -- import Control.Monad.Trans.RWS
 import Data.Binary.Get
 -- import Data.Bits
 import qualified Data.ByteString.Lazy as BSL
 -- import Data.Foldable (toList)
--- import Data.IORef
 -- import Data.List
 -- import Data.List.NonEmpty (NonEmpty(..))
 -- import qualified Data.List.NonEmpty as NE
@@ -34,6 +30,7 @@ import System.Environment
 
 import Masque.AST
 import Masque.Equality
+import Masque.Eval
 import Masque.Monte
 import Masque.Objects
 import Masque.Vats
@@ -49,9 +46,6 @@ import Masque.Vats
 -- -- | Lenses on other data types
 -- -- These are destined for various upstreams at some point.
 -- 
--- first :: Lens' (NonEmpty a) a
--- first = lens (\(a :| _) -> a) (\(_ :| as) -> (:| as))
--- 
 -- final :: Lens' (NonEmpty a) a
 -- final = lens g s
 --     where
@@ -253,15 +247,6 @@ import Masque.Vats
 -- 
 -- -- | Evaluation helpers
 -- 
--- scoped :: Monte a -> Monte a
--- scoped action =
---     bracketEitherT push pop (const action)
---     where
---     push = envStack %= (Env M.empty NE.<|)
---     -- Only works as long as the environment stack isn't overpopped during the
---     -- scoped action. Shouldn't happen.
---     pop _ = envStack %= (\(_ :| (a:as)) -> a :| as)
--- 
 -- stashingScope :: NonEmpty Env -> Monte a -> Monte a
 -- stashingScope es action = bracketEitherT open (envStack .=) (const action)
 --     where
@@ -270,16 +255,6 @@ import Masque.Vats
 --         envStack .= es
 --         return stashed
 -- 
--- varBinding :: String -> Obj -> Monte ()
--- varBinding name obj = do
---     slotRef <- liftIO $ newIORef obj
---     -- XXX use an actual guard next time!
---     guardRef <- liftIO $ newIORef NullObj
---     envStack . first . unEnv . at name ?= VarBind slotRef guardRef
--- 
--- defBinding :: String -> Obj -> Monte ()
--- defBinding name obj = envStack . first . unEnv . at name ?= DefBind obj
--- 
 -- newEjector :: Monte Obj
 -- newEjector = do
 --     u <- liftIO newUnique
@@ -319,119 +294,6 @@ import Masque.Vats
 --     maybe (left Unsettled) resolve mobj
 -- resolve obj = return obj
 -- 
--- -- | Unification and evaluation
--- 
--- unifyEject :: Obj -> Obj -> Pattern -> Monte ()
--- unifyEject _  _ (BindPattern _) = undefined
--- unifyEject obj _ (Final n Null) = defBinding n obj
--- unifyEject obj ej (Final n g) = do
---     g' <- eval g
---     obj' <- call g' "coerce" [obj, ej]
---     defBinding n obj'
--- unifyEject _ _ (Ignore Null) = return ()
--- unifyEject obj ej (Ignore g) = do
---     g' <- eval g
---     void $ call g' "coerce" [obj, ej]
--- unifyEject (ConstListObj os) ej (ListPattern ps)
---     | Seq.length os == length ps = forM_ (zip os' ps) $ \(o, p) -> unifyEject o ej p
---     where os' = toList os
--- unifyEject _ ej (ListPattern _) = fire ej NullObj
--- -- XXX need to generate slots here
--- unifyEject obj _ (Var n _) = varBinding n obj
--- unifyEject obj ej (Via expr p) = do
---     examiner <- eval expr
---     examined <- call examiner "run" [obj, ej]
---     unifyEject examined ej p
--- 
--- unify :: Obj -> Pattern -> Monte Bool
--- unify _  (BindPattern _) = undefined
--- unify obj (Final n Null) = defBinding n obj >> return True
--- unify obj (Final n g) = do
---     g' <- eval g
---     obj' <- call g' "coerce" [obj, NullObj]
---     defBinding n obj'
---     return True
--- unify _ (Ignore Null) = return True
--- unify obj (Ignore g) = do
---     g' <- eval g
---     void $ call g' "coerce" [obj, NullObj]
---     return True
--- unify (ConstListObj os) (ListPattern ps)
---     | Seq.length os == length ps = do
---         unified <- forM (zip os' ps) $ uncurry unify
---         return $ and unified
---     where os' = toList os
--- unify _ (ListPattern _) = return False
--- unify obj (Var n _) = varBinding n obj >> return True
--- unify obj (Via expr p) = do
---     examiner <- eval expr
---     examined <- call examiner "run" [obj, NullObj]
---     unify examined p
--- 
--- eval :: Node -> Monte Obj
--- eval Null = return NullObj
--- eval (CharNode c) = return $ CharObj c
--- eval (DoubleNode d) = return $ DoubleObj d
--- eval (IntNode i) = return $ IntObj i
--- eval (StrNode s) = return $ StrObj s
--- eval (Tuple t) = do
---     objs <- mapM eval t
---     return . ConstListObj $ Seq.fromList objs
--- eval (Assign name node) = do
---     obj <- eval node
---     binding <- getBinding name
---     case binding of
---         DefBind _ -> left $ BadWrite name
---         -- XXX invoke guard here
---         VarBind slotRef _ -> do
---             liftIO $ writeIORef slotRef obj
---             return obj
--- eval (BindingNode _) = return BindingObj
--- eval (Call o v as) = do
---     o' <- eval o
---     StrObj v' <- eval v
---     ConstListObj as' <- eval as
---     call o' v' $ toList as'
--- eval (Def p ej expr) = do
---     rvalue <- eval expr
---     ej' <- eval ej
---     unifyEject rvalue ej' p
---     return rvalue
--- eval (Escape p n _ _) = scoped $ do
---     ej@(EjectorObj u) <- newEjector
---     success <- unify ej p
---     if success then catchEjector u $ eval n else left Unknown
--- eval (Finally node atLast) = bracketEitherT before after return
---     where
---     before = scoped $ eval node
---     after obj = scoped $ eval atLast >> return obj
--- eval (If i t f) = do
---     test <- eval i
---     BoolObj b <- resolve test
---     scoped $ eval $ if b then t else f
--- eval (Hide n) = scoped $ eval n
--- eval (Noun name) = getName name
--- eval (Object _ p _ (Script _ methods matchers)) = mdo
---     u <- liftIO newUnique
---     let rv = UserObj u objName env methodMap matcherList
---     success <- unify rv p
---     env <- uses envStack $ \es -> Env (M.unions (map _unEnv (NE.toList es)))
---     if success then return rv else left Unknown
---     where
---     methodMap = M.fromListWith (++) methodList
---     methodList = [(verb, [(ListPattern p', n)]) | Method _ (StrNode verb) p' _ n <- methods ]
---     matcherList = [(p', n) | Matcher p' n <- matchers ]
---     objName = case p of
---         Final name _ -> name
---         _            -> "_"
--- eval (Sequence ns) = do
---     os <- mapM eval ns
---     return $ if null os then NullObj else last os
--- eval (Try n p h) = scoped $ catchError (eval n) $ \_ -> do
---     success <- unify NullObj p
---     if success then eval h else left Unknown
--- eval n = error $ "Couldn't evaluate node: " ++ show n
--- 
 -- -- | Scope creation
 -- 
 -- coreScope :: M.Map String Obj

Masque/Ejectors.hs

@@ -0,0 +1,22 @@
+module Masque.Ejectors where
+
+import Control.Monad.Error.Class
+import Control.Monad.Trans.Either
+import Data.Unique
+
+import Masque.Monte
+import Masque.Objects
+
+-- | Run an action, catching a single specified ejector. If caught, the
+--   ejector's payload will be run through the given handler action.
+catchEjector :: Unique -> Monte Obj -> (Obj -> Monte Obj) -> Monte Obj
+catchEjector u action handler = catchError action $ \err ->
+    case err of
+        Ejecting u' obj | u == u' -> handler obj
+        _                         -> left err
+
+-- | Like Monte m`throw.eject(ej, problem)`.
+throwEject :: Obj -> Obj -> Monte ()
+throwEject ej problem = left $ case ej of
+    EjectorObj u -> Ejecting u problem
+    _            -> Exception problem

Masque/Equality.hs

@@ -25,7 +25,7 @@ sameEver left right = case (left, right) of
         bools <- zipWithM zippingTuples xs ys
         return $ and bools
     -- Should consider auditors, not just object identity.
-    (UserObj x _ _ _ _ _, UserObj y _ _ _ _ _) -> return $ x == y
+    (UserObj x _ _ _ _, UserObj y _ _ _ _) -> return $ x == y
     (_, _) -> return False
     where
     zippingTuples (k, v) (k', v') = do