ops op

1 files changed, 34 insertions, 0 deletions

diff --git a/app/Builtins.hs b/app/Builtins.hs
index 22e1c30..898d664 100644
--- a/app/Builtins.hs
+++ b/app/Builtins.hs
@@ -211,6 +211,36 @@ structUnify arity str = do
     s {cur = cur {heap = h', gol = gcode ++ gol cur, hed = hcode ++ hed cur}}
   return Nothing
 
+{- operator management -}
+op :: InterpFn
+op = do
+  heap <- gets (heap . cur)
+  scope <- gets (hvar . cur)
+  IR.StrTable _ _ itos <- gets strtable
+  case sequence $ map (fmap (derefHeap heap) . (scope M.!?)) [0 .. 2] of
+    Just [BoundRef _ (Number prio), BoundRef _ (Atom fixityAtom), BoundRef _ (Atom opatom)]
+      | Just op <-
+         (,) <$> itos M.!? opatom <*>
+         (O.Op prio <$> ((itos M.!? fixityAtom) >>= O.fixity)) -> do
+        modify $ \s -> s {ops = op : ops s}
+        return Nothing
+    _ -> prlgError "bad op spec"
+
+stashOps :: InterpFn
+stashOps = do
+  currentOps <- gets ops
+  modify $ \s -> s {opstash = currentOps : opstash s}
+  return Nothing
+
+popOps :: InterpFn
+popOps = do
+  currentOps <- gets opstash
+  case currentOps of
+    [] -> prlgError "no op stash to pop"
+    (ops':opss) -> do
+      modify $ \s -> s {ops = ops', opstash = opss}
+      return Nothing
+
 {- adding the builtins -}
 addOp op = modify $ \s -> s {ops = op : ops s}
 
@@ -263,6 +293,10 @@ addPrelude = do
   addBi "retractall" 1 retractall
   addBi "call" 1 call
   addBi "struct" 3 struct
+  {- operators -}
+  addBi "op" 3 op
+  addBi "stash_operators" 0 stashOps
+  addBi "pop_operators" 0 popOps
   {- query tools -}
   addBi "print_locals" 0 printLocals
   addBi "prompt_retry" 0 promptRetry'