ops op

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'

app/Code.hs

@@ -60,6 +60,7 @@ data Interp =
     , cur :: Cho -- the choice that is being evaluated right now
     , cho :: [Cho] -- remaining choice points
     , ops :: Ops -- currently defined operators
+    , opstash :: [Ops] -- saved operators
     , strtable :: StrTable -- string table
     }
   deriving (Show)

app/Frontend.hs

@@ -92,6 +92,7 @@ interpreter =
     (Interp
        { defs = M.empty
        , ops = []
+       , opstash = []
        , strtable = IR.emptystrtable
        , cur = error "no cur"
        , cho = []

app/Operators.hs

@@ -26,6 +26,17 @@ numArgs (Op _ f) = go f
 
 type Ops = [(String, Op)]
 
+argKind :: Char -> Maybe ArgKind
+argKind 'x' = Just X
+argKind 'y' = Just Y
+argKind _ = Nothing
+
+fixity :: String -> Maybe Fixity
+fixity [l, 'f', r] = Infix <$> argKind l <*> argKind r
+fixity ['f', x] = Prefix <$> argKind x
+fixity [x, 'f'] = Suffix <$> argKind x
+fixity _ = Nothing
+
 xfx, xfy, yfx, fx, fy, xf, yf :: String -> Int -> (String, Op)
 xfx o p = (o, Op p (Infix X X))
 

prlg.cabal

@@ -29,7 +29,7 @@ executable prlg
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
-    build-depends:    base >=4.16, containers, megaparsec, haskeline, pretty-simple, split, transformers
+    build-depends:    base >=4.14, containers, megaparsec, haskeline, pretty-simple, split, transformers
     hs-source-dirs:   app
     default-language: Haskell2010
     ghc-options:      -Wunused-imports