op cleaner

2 files changed, 26 insertions, 13 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 -}
diff --git a/app/Interpreter.hs b/app/Interpreter.hs
index f36ef0b..b215049 100644
--- a/app/Interpreter.hs
+++ b/app/Interpreter.hs
@@ -77,7 +77,7 @@ proveStep = St.get >>= go
         _ -> do
           StrTable _ _ itos <- St.gets strtable
           ifail $
-            "no definition: " ++ (itos M.! str fn) ++ "/" ++ show (arity fn)
+            "no definition: '" ++ (itos M.! str fn) ++ "'/" ++ show (arity fn)
     {- Unification -}
     go i@Interp {cur = cur@Cho {hed = U h:hs, gol = U g:gs, heap = heap}} =
       unify h g