op cleaner

1 files changed, 25 insertions, 12 deletions

diff --git a/app/Builtins.hs b/app/Builtins.hs
index fc0a1cb..834adf4 100644
--- a/app/Builtins.hs
+++ b/app/Builtins.hs
@@ -266,18 +266,30 @@ same_term = do
 
 {- 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}
-        continue
-    _ -> prlgError "bad op spec"
+op =
+  withArgs [0, 1, 2] $ \args -> do
+    heap <- gets (heap . cur)
+    IR.StrTable _ _ itos <- gets strtable
+    case map (derefHeap heap) args of
+      [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}
+          continue
+      _ -> prlgError "bad op spec"
+
+deop :: InterpFn
+deop =
+  withArgs [0] $ \[arg] -> do
+    heap <- gets (heap . cur)
+    IR.StrTable _ _ itos <- gets strtable
+    case derefHeap heap arg of
+      BoundRef _ (Atom opatom)
+        | Just op <- itos M.!? opatom -> do
+          modify $ \s -> s {ops = filter ((/= op) . fst) (ops s)}
+          continue
+      _ -> prlgError "bad op spec"
 
 stashOps :: InterpFn
 stashOps = do
@@ -379,6 +391,7 @@ addPrelude = do
   addBi (load True) "source" 1
   {- operators -}
   addBi op "op" 3
+  addBi deop "deop" 1
   addBi stashOps "stash_operators" 0
   addBi popOps "pop_operators" 0
   {- query tools -}