Environment.hs

{-# 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