/src/Hummus/Runtime.hs

 1module Hummus.Runtime where
 2
 3import Control.Monad
 4import Control.Monad.CC.Dynvar
 5import Control.Monad.Trans
 6import Data.Maybe (catMaybes, isJust)
 7import qualified Data.HashTable.IO as H
 8
 9import Hummus.Types
10
11
12evaluate :: Value ans -> Value ans -> VM ans (Value ans)
13evaluate env (Pair a b) = do
14  x <- evaluate env a
15  if isCombiner x
16    then apply env x b
17    else error ("not a combiner: " ++ show x)
18evaluate env (Symbol s) = do
19  mv <- fetch env s
20  case mv of
21    Just v -> return v
22    Nothing -> error ("undefined: " ++ s)
23evaluate env o@(Operative { oStaticEnvironment = Nothing }) =
24  return o { oStaticEnvironment = Just env }
25evaluate _ x = return x
26
27evaluateSequence :: Value ans -> [Value ans] -> VM ans (Value ans)
28evaluateSequence _ [] = return Inert
29evaluateSequence e [s] = evaluate e s
30evaluateSequence e (s:ss) = evaluate e s >> evaluateSequence e ss
31
32evaluateAll :: Value ans -> Value ans -> VM ans (Value ans)
33evaluateAll env (Pair a b) = do
34  ea <- evaluate env a
35  eb <- evaluateAll env b
36  return (Pair ea eb)
37evaluateAll _ x = return x
38
39apply :: Value ans -> Value ans -> Value ans -> VM ans (Value ans)
40apply env (CoreOperative f) as = f as env
41apply env (Operative fs ef b se) as = do
42  newEnv <- newEnvironment (catMaybes [se])
43
44  define newEnv fs as
45  define newEnv ef env
46
47  evaluate newEnv b
48apply env (Applicative x) vs = do
49  as <- evaluateAll env vs
50  apply env x as
51apply _ (Dynvar d x) _ = liftM (maybe x id) (mdref d)
52apply _ v _ = error ("cannot apply: " ++ show v)
53
54define :: Value ans -> Value ans -> Value ans -> VM ans ()
55define env@(Environment ht _) p v =
56  case p of
57    Ignore -> return ()
58
59    Symbol n -> liftIO (H.insert ht n v)
60
61    Null ->
62      case v of
63        Null -> return ()
64        _ -> error ("mismatch: " ++ show (p, v))
65
66    Pair pa pb ->
67      case v of
68        Pair va vb -> do
69          define env pa va
70          define env pb vb
71
72        _ -> error ("mismatch: " ++ show (p, v))
73
74    _ -> error ("unknown pattern: " ++ show p)
75define _ _ _ = error "invalid definition target"
76
77binds :: Value ans -> String -> VM ans Bool
78binds e n = liftM isJust (fetch e n)
79
80fetch :: Value ans -> String -> VM ans (Maybe (Value ans))
81fetch (Environment ht ps) n = do
82  l <- liftIO (H.lookup ht n)
83  case l of
84    Just v -> return (Just v)
85    Nothing -> do
86      up <- mapM (flip fetch n) ps
87      case catMaybes up of
88        (x:_) -> return (Just x)
89        [] -> return Nothing
90fetch v n = error ("cannot fetch " ++ show n ++ " from " ++ show v)