get lensy and classy

app/Builtins.hs

@@ -2,24 +2,22 @@ module Builtins where
 
 import Code
   ( Builtin(..)
-  , Cho(..)
   , Code
   , Datum(..)
   , Dereferenced(..)
   , Instr(..)
-  , Interp(..)
   , InterpFn
   , InterpFn
   , derefHeap
   , heapStruct
   , newHeapVars
   )
+import CodeLens
 import qualified Compiler as Co
 import Control.Exception (IOException, catch)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Except (runExceptT)
-import Control.Monad.Trans.State.Lazy (get, gets, modify)
 import Data.Functor.Identity (runIdentity)
 import Data.List (intercalate)
 import qualified Data.Map as M
@@ -27,6 +25,7 @@ import Data.Maybe (fromJust)
 import Env (PrlgEnv(..), findAtom, findStruct, prlgError)
 import qualified IR
 import Interpreter (backtrack)
+import Lens.Family2.State
 import Load (processInput)
 import qualified Operators as O
 import System.Console.Haskeline (getInputChar, outputStr, outputStrLn)
@@ -51,17 +50,17 @@ showTerm itos heap = runIdentity . heapStruct atom struct hrec heap
 
 printLocals :: InterpFn
 printLocals = do
-  scope <- gets (gvar . cur)
+  scope <- use (cur . gvar)
-  heap <- gets (heap . cur)
+  heap <- use (cur . heap)
-  IR.StrTable _ _ itos <- gets strtable
+  IR.StrTable _ _ itos <- use strtable
   flip traverse (M.assocs scope) $ \(local, ref) ->
-    lift . outputStrLn $
+    lift . outputStrLn $ "_Local" ++ show local ++ " = " ++
-    "_Local" ++ show local ++ " = " ++ showTerm itos heap ref
+    showTerm itos heap ref
   continue
 
 promptRetry :: InterpFn
 promptRetry = do
-  last <- gets (null . cho)
+  last <- cho `uses` null
   if last
     then continue
     else promptRetry'
@@ -75,7 +74,7 @@ promptRetry' = do
 
 withArgs :: [Int] -> ([Int] -> InterpFn) -> InterpFn
 withArgs as f = do
-  scope <- gets (hvar . cur)
+  scope <- use (cur . hvar)
   if all (`M.member` scope) as
     then f $ map (scope M.!) as
     else prlgError "arguments not bound"
@@ -83,8 +82,8 @@ withArgs as f = do
 write' :: InterpFn -> InterpFn
 write' c =
   withArgs [0] $ \[arg] -> do
-    heap <- gets (heap . cur)
+    heap <- use (cur . heap)
-    IR.StrTable _ _ itos <- gets strtable
+    IR.StrTable _ _ itos <- use strtable
     lift . outputStr $ showTerm itos heap arg
     c --this now allows error fallthrough but we might like EitherT
 
@@ -101,19 +100,19 @@ writeln = write' nl
 assertFact :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn
 assertFact addClause =
   withArgs [0] $ \[arg] -> do
-    heap <- gets (heap . cur)
+    heap <- use (cur . heap)
     case Co.compileGoal . Co.squashVars <$>
          Co.heapStructPrlgInt Nothing heap arg of
       Just (U (Struct s):head) -> do
-        addClause (head ++ [NoGoal]) s
+        addClause (head ++ [Done]) s
         continue
       _ -> prlgError "assert fact failure"
 
 assertRule :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn
 assertRule addClause =
   withArgs [0, 1] $ \args -> do
-    scope <- gets (hvar . cur)
+    scope <- use (cur . hvar)
-    heap <- gets (heap . cur)
+    heap <- use (cur . heap)
     comma <- findAtom ","
     cut <- findAtom "!"
     case Co.squashVars . IR.CallI 0 <$>
@@ -128,7 +127,7 @@ assertRule addClause =
 retractall :: InterpFn
 retractall =
   withArgs [0] $ \[arg] -> do
-    heap <- gets (heap . cur)
+    heap <- use (cur . heap)
     case derefHeap heap arg of
       BoundRef _ (Atom a) ->
         dropProcedure (IR.Id {IR.arity = 0, IR.str = a}) >> continue
@@ -138,21 +137,15 @@ retractall =
 exec' :: (Code -> Code) -> InterpFn
 exec' fgol =
   withArgs [0] $ \[arg] -> do
-    heap <- gets (heap . cur)
+    heap <- use (cur . heap)
     case Co.squashVars <$> Co.heapStructPrlgInt Nothing heap arg of
       Just gs -> do
-        cur <- gets cur
         comma <- findAtom ","
         cut <- findAtom "!"
-        modify $ \s ->
+        zoom cur $ do
-          s
+          hvar .= M.empty
-            { cur =
+          hed .= Co.seqGoals (Co.compileGoals comma cut gs)
-                cur
+          gol %= fgol
-                  { hvar = M.empty
-                  , hed = Co.seqGoals (Co.compileGoals comma cut gs)
-                  , gol = fgol (gol cur)
-                  }
-            }
         continue
       _ -> prlgError "bad goal"
 
@@ -160,13 +153,13 @@ call :: InterpFn
 call = exec' id
 
 exec :: InterpFn
-exec = exec' (const [LastCall])
+exec = exec' (const [Done])
 
 {- struct assembly/disassembly -}
 struct :: InterpFn
 struct = do
-  heap <- gets (heap . cur)
+  heap <- use (cur . heap)
-  scope <- gets (hvar . cur)
+  scope <- use (cur . hvar)
   case derefHeap heap <$> scope M.!? 0 of
     Just (BoundRef addr (Struct IR.Id {IR.arity = arity, IR.str = str})) ->
       structUnify arity str
@@ -192,8 +185,8 @@ heapListLength listAtom heap ref = go 0 ref ref (id, fromJust . step)
 
 structAssemble :: InterpFn
 structAssemble = do
-  heap <- gets (heap . cur)
+  heap <- use (cur . heap)
-  scope <- gets (hvar . cur)
+  scope <- use (cur . hvar)
   case derefHeap heap <$> scope M.!? 1 of
     Just (BoundRef addr (Atom str)) -> do
       listAtom <- findAtom "[]"
@@ -203,9 +196,8 @@ structAssemble = do
     _ -> prlgError "struct id unknown"
 
 structUnify arity str = do
-  cur <- gets cur
+  h <- use (cur . heap)
-  let h = heap cur
+  scope <- use (cur . hvar)
-      scope = hvar cur
   listAtom <- findAtom "[]"
   let hcode = map U $ maybe VoidRef HeapRef . (scope M.!?) <$> [0 .. 2]
       (h', pvars) = newHeapVars arity h
@@ -217,15 +209,17 @@ structUnify arity str = do
           pvars ++
         [Atom listAtom]
       gcode = map U $ structData ++ [Atom str] ++ paramsData
-  modify $ \s ->
+  zoom cur $ do
-    s {cur = cur {heap = h', gol = gcode ++ gol cur, hed = hcode ++ hed cur}}
+    heap .= h'
+    gol %= (gcode ++)
+    hed %= (hcode ++)
   continue
 
 {- terms -}
 var :: InterpFn
 var = do
-  heap <- gets (heap . cur)
+  heap <- use (cur . heap)
-  scope <- gets (hvar . cur)
+  scope <- use (cur . hvar)
   case derefHeap heap <$> scope M.!? 0 of
     Nothing -> continue
     Just (FreeRef _) -> continue
@@ -233,8 +227,8 @@ var = do
 
 sameTerm :: InterpFn
 sameTerm = do
-  heap <- gets (heap . cur)
+  heap <- use (cur . heap)
-  scope <- gets (hvar . cur)
+  scope <- use (cur . hvar)
   case map (fmap (derefHeap heap) . (scope M.!?)) [0, 1] of
     [Just a, Just b]
       | a == b -> continue
@@ -243,8 +237,8 @@ sameTerm = do
 currentPredicate :: InterpFn
 currentPredicate =
   withArgs [0] $ \[arg] -> do
-    heap <- gets (heap . cur)
+    heap <- use (cur . heap)
-    ds <- gets defs
+    ds <- use defs
     case derefHeap heap arg of
       BoundRef _ (Struct s) ->
         if s `M.member` ds
@@ -256,76 +250,73 @@ currentPredicate =
 op :: InterpFn
 op =
   withArgs [0, 1, 2] $ \args -> do
-    heap <- gets (heap . cur)
+    heap <- use (cur . heap)
-    IR.StrTable _ _ itos <- gets strtable
+    IR.StrTable _ _ itos <- use 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}
+          ops %= (op :)
           continue
       _ -> prlgError "bad op spec"
 
 deop :: InterpFn
 deop =
   withArgs [0] $ \[arg] -> do
-    heap <- gets (heap . cur)
+    heap <- use (cur . heap)
-    IR.StrTable _ _ itos <- gets strtable
+    IR.StrTable _ _ itos <- use strtable
     case derefHeap heap arg of
       BoundRef _ (Atom opatom)
         | Just op <- itos M.!? opatom -> do
-          modify $ \s -> s {ops = filter ((/= op) . fst) (ops s)}
+          ops %= filter ((/= op) . fst)
           continue
       _ -> prlgError "bad op spec"
 
 stashOps :: InterpFn
 stashOps = do
-  currentOps <- gets ops
+  currentOps <- use ops
-  modify $ \s -> s {opstash = currentOps : opstash s}
+  opstash %= (currentOps :)
   continue
 
 popOps :: InterpFn
 popOps = do
-  currentOps <- gets opstash
+  currentOps <- use opstash
   case currentOps of
     [] -> prlgError "no ops stashed"
     (ops':opss) -> do
-      modify $ \s -> s {ops = ops', opstash = opss}
+      ops .= ops'
+      opstash .= opss
       continue
 
 {- expansion environment -}
 stashExpansions :: InterpFn
 stashExpansions = do
-  ds <- gets defs
+  ds <- use defs
   les <- findStruct "load_expansion" 2
   qes <- findStruct "query_expansion" 2
   let [le, qe] = map (ds M.!?) [les, qes]
-  modify $ \s -> s {macrostash = (le, qe) : macrostash s}
+  macrostash %= ((le, qe) :)
   continue
 
 popExpansions :: InterpFn
 popExpansions = do
-  currentMacros <- gets macrostash
+  currentMacros <- use macrostash
   les <- findStruct "load_expansion" 2
   qes <- findStruct "query_expansion" 2
   case currentMacros of
     [] -> prlgError "no expansions stashed"
     ((le, qe):stash') -> do
-      modify $ \s ->
+      defs %= M.alter (const le) les . M.alter (const qe) qes
-        s
+      macrostash .= stash'
-          { defs = M.alter (const le) les $ M.alter (const qe) qes $ defs s
-          , macrostash = stash'
-          }
       continue
 
 {- adding the builtins -}
 addOp :: (String, O.Op) -> PrlgEnv ()
-addOp op = modify $ \s -> s {ops = op : ops s}
+addOp op = ops %= (op :)
 
 modDef :: ([Code] -> Maybe [Code]) -> IR.Id -> PrlgEnv ()
-modDef fn struct =
+modDef fn struct = defs %= M.alter (maybe (fn []) fn) struct
-  modify $ \s -> s {defs = M.alter (maybe (fn []) fn) struct $ defs s}
 
 addClauseA :: Code -> IR.Id -> PrlgEnv ()
 addClauseA code = modDef $ Just . (code :)
@@ -350,8 +341,8 @@ addBi b n a =
 load :: Bool -> InterpFn
 load queryMode =
   withArgs [0] $ \[arg] -> do
-    heap <- gets (heap . cur)
+    heap <- use (cur . heap)
-    IR.StrTable _ _ itos <- gets strtable --TODO the argument here should preferably be a string, right?
+    IR.StrTable _ _ itos <- use strtable --TODO the argument here should preferably be a string, right?
     case derefHeap heap arg of
       BoundRef _ (Atom a) -> do
         let fn = itos M.! a
@@ -373,7 +364,7 @@ addPrelude = do
   addBi (pure Nothing) "true" 0
   addBi backtrack "fail" 0
   addOp $ O.xfx "=" 700
-  addProc [[U (LocalRef 0), U (LocalRef 0), NoGoal]] "=" 2
+  addProc [[U (LocalRef 0), U (LocalRef 0), Done]] "=" 2
   {- clauses -}
   addOp $ O.xfy "," 1000
   addOp $ O.xfx ":-" 1200
@@ -417,19 +408,17 @@ addPrelude = do
         addProc
           [ [ U (LocalRef 0)
             , U (LocalRef 1)
-            , Goal -- current_predicate(expand_something(_,_)),
+            , U (Struct cp) -- current_predicate(expand_something(_,_)),
-            , U (Struct cp)
             , U (Struct s)
             , U VoidRef
             , U VoidRef
-            , Call -- no cut!
+            , U (Struct s) -- expand_something(Arg1, Arg2).
-            , Goal -- expand_something(Arg1, Arg2).
-            , U (Struct s)
             , U (LocalRef 0)
             , U (LocalRef 1)
-            , LastCall
+            , Cut -- TODO  check that the cut works here; this was the whole reason why we migrated off vienna
+            , Done
             ]
-          , [U (LocalRef 0), U (LocalRef 0), NoGoal]
+          , [U (LocalRef 0), U (LocalRef 0), Done]
           ]
           ("expand_" ++ q)
           2
@@ -444,4 +433,4 @@ addPrelude = do
   addBi writeln "writeln" 1
   addBi nl "nl" 0
   {- debug -}
-  addBi (get >>= liftIO . print >> pure Nothing) "interpreter_trace" 0
+  addBi (use id >>= liftIO . print >> pure Nothing) "interpreter_trace" 0

app/Code.hs

@@ -19,13 +19,11 @@ data Datum
   deriving (Show, Eq, Ord)
 
 data Instr
-  = U Datum -- something unifiable
+  = U Datum -- unify/resolve something
-  | NoGoal -- trivial goal (directly after head)
+  | Invoke Builtin -- give control to a builtin (invoked from head)
-  | Invoke Builtin -- also directly after head
+  | Done -- all done, can return
-  | Goal -- a new goal (set head)
+  | Cut -- remove choicepoints of the current goal
-  | Call -- all seems okay, call the head's hoal
+  | Choices [[Code]] -- split off several possibilities (push choicepoints)
-  | LastCall -- tail call the head's goal
-  | Cut -- remove all alternative clauses of the current goal
   deriving (Show)
 
 type Code = [Instr]
@@ -45,30 +43,32 @@ emptyScope = M.empty
 
 data Cho =
   Cho
-    { hed :: Code -- head pointer
+    { _hed :: Code -- head pointer
-    , hvar :: Scope -- variables unified in head (so far)
+    , _hvar :: Scope -- variables unified in head (so far)
-    , gol :: Code -- goal pointer
+    , _gol :: Code -- goal pointer
-    , gvar :: Scope -- variables unified in the goal
+    , _gvar :: Scope -- variables unified in the goal
-    , heap :: Heap -- a snapshot of the heap (there's no trail; we rely on CoW copies in other choicepoints)
+    , _unis :: Int -- items left to unify
-    , stk :: [(Code, Scope, [Cho])] -- remaining goals together with their vars and cuts
+    , _retcut :: Bool -- cut after this goal succeeds
-    , cut :: [Cho] -- snapshot of choicepoints before entering
+    , _heap :: Heap -- a snapshot of the heap (there's no trail; we rely on CoW copies in other choicepoints)
+    , _stk :: [(Code, Scope, [Cho], Bool)] -- remaining goals together with their vars, cuts, and ret-cut flag
+    , _cut :: [Cho] -- snapshot of choicepoints before entering
     }
   deriving (Show)
 
 data Interp =
   Interp
-    { defs :: Defs -- global definitions for lookup
+    { _defs :: Defs -- global definitions for lookup
-    , cur :: Cho -- the choice that is being evaluated right now
+    , _cur :: Cho -- the choice that is being evaluated right now
-    , cho :: [Cho] -- remaining choice points
+    , _cho :: [Cho] -- remaining choice points
-    , ops :: Ops -- currently defined operators
+    , _ops :: Ops -- currently defined operators
-    , opstash :: [Ops] -- saved operators
+    , _opstash :: [Ops] -- saved operators
-    , macrostash :: [(Maybe [Code], Maybe [Code])] -- saved expansion defs (load, query)
+    , _macrostash :: [(Maybe [Code], Maybe [Code])] -- saved expansion defs (load, query)
-    , strtable :: StrTable -- string table
+    , _strtable :: StrTable -- string table
-    , cmdq :: [(Bool, PAST)] -- isQuery, lexemes
+    , _cmdq :: [(Bool, PAST)] -- isQuery, lexemes
     }
   deriving (Show)
 
-type PrlgEnv a = StateT Interp (InputT IO) a
+type PrlgEnv = StateT Interp (InputT IO)
 
 type InterpFn = PrlgEnv (Maybe (Either String Bool))
 
@@ -114,34 +114,6 @@ withNewHeapStruct addr s@(Struct Id {arity = arity}) heap cont =
       m'' = M.insert addr (HeapRef $ head addrs) . M.insert (head addrs) s $ m'
    in cont (map HeapRef $ tail addrs) (Heap nxt' m'')
 
--- TODO are we actually going to use this?
-codeStruct ::
-     Monad m
-  => (Datum -> m a)
-  -> (Datum -> [a] -> m a)
-  -> (Datum -> m (Either Int a))
-  -> (Datum -> Int -> m a)
-  -> m a
-  -> Heap
-  -> Code
-  -> m (Code, a)
-codeStruct atom struct local rec end heap = go
-  where
-    go [] = ([], ) <$> end
-    go (U lr@(LocalRef _):cs) = do
-      x <- local lr
-      case x of
-        Left ref -> (cs, ) <$> heapStruct atom struct rec heap ref
-        Right a -> pure (cs, a)
-    go (U s@(Struct (IR.Id _ arity)):cs) = eat arity cs >>= traverse (struct s)
-    go (U x:cs) = (cs, ) <$> atom x
-    go cs = (cs, ) <$> end
-    eat n cs
-      | n <= 0 = pure (cs, [])
-      | otherwise = do
-        (rest, a) <- go cs
-        fmap (a :) <$> eat (n - 1) rest
-
 heapStruct ::
      Monad m
   => (Datum -> m a)

app/CodeLens.hs

@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module CodeLens where
+
+import Code
+import Lens.Family2.TH
+
+$(makeLenses ''Cho)
+
+$(makeLenses ''Interp)

app/Compiler.hs

@@ -74,12 +74,7 @@ compileArg (VarI x _) = [U (LocalRef x)]
 compileArg (VoidI) = [U VoidRef]
 
 seqGoals :: [Code] -> Code
-seqGoals [] = [NoGoal]
+seqGoals = (++ [Done]) . concat
-seqGoals [[Cut]] = [Cut, NoGoal]
-seqGoals [x] = [Goal] ++ x ++ [LastCall]
-seqGoals [x, [Cut]] = [Goal] ++ x ++ [LastCall, Cut]
-seqGoals ([Cut]:xs) = [Cut] ++ seqGoals xs
-seqGoals (x:xs) = [Goal] ++ x ++ [Call] ++ seqGoals xs
 
 heapStructPrlgInt :: Monad m => m PrlgInt -> Heap -> Int -> m PrlgInt
 heapStructPrlgInt heaperr heap ref = heapStruct atom struct hrec heap ref

app/Env.hs

@@ -1,14 +1,14 @@
 module Env where
 
-import Code (Interp(..), InterpFn, PrlgEnv)
+import Code (InterpFn, PrlgEnv)
-import Control.Monad.Trans.State.Lazy (gets, modify)
+import CodeLens
 import qualified IR
+import Lens.Family2.State
 
 withStrTable :: (IR.StrTable -> (IR.StrTable, a)) -> Env.PrlgEnv a
 withStrTable f = do
-  st <- gets strtable
+  (st', x) <- strtable `uses` f
-  let (st', x) = f st
+  strtable .= st'
-  modify (\s -> s {strtable = st'})
   return x
 
 findStruct :: String -> Int -> Env.PrlgEnv IR.Id

app/Frontend.hs

@@ -2,15 +2,16 @@ module Frontend where
 
 import Builtins
 import Code (Interp(..))
+import CodeLens
 import Control.Monad (when)
-import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Except (except, runExceptT)
-import Control.Monad.Trans.State.Lazy (evalStateT, gets, modify)
+import Control.Monad.Trans.State.Lazy (evalStateT)
 import qualified Data.Map as M
 import Env (PrlgEnv)
 import qualified IR
 import qualified Interpreter as I
+import Lens.Family2.State
 import Load
   ( compile
   , intern
@@ -20,19 +21,6 @@ import Load
   , shunt
   )
 import System.Console.Haskeline
-import qualified Text.Pretty.Simple as Ppr
-
-ppr :: Show a => a -> PrlgEnv ()
-ppr x =
-  liftIO $
-  Ppr.pPrintOpt
-    Ppr.CheckColorTty
-    Ppr.defaultOutputOptionsDarkBg
-      { Ppr.outputOptionsCompactParens = True
-      , Ppr.outputOptionsIndentAmount = 2
-      , Ppr.outputOptionsPageWidth = 80
-      }
-    x
 
 -- the signature of this is too ugly to include here
 handleError m = do
@@ -40,8 +28,8 @@ handleError m = do
   case res of
     Left err -> do
       lift $ outputStrLn err
-      modify $ \s -> s {cmdq = []}
+      cmdq .= []
-    _ -> pure ()
+    _ -> (pure () :: PrlgEnv ()) --prevents ambiguity
 
 processCmd precompileHook ast' = do
   ast <- shunt ast'
@@ -55,7 +43,7 @@ interpreterStart = do
 
 interpreterLoop :: Bool -> PrlgEnv ()
 interpreterLoop queryMode = do
-  q <- gets cmdq
+  q <- use cmdq
   case q of
     [] -> do
       minput <-
@@ -71,7 +59,7 @@ interpreterLoop queryMode = do
           handleError $ processInput "<user input>" queryMode input
           interpreterLoop queryMode
     ((mode, ast):asts) -> do
-      modify $ \s -> s {cmdq = asts}
+      cmdq .= asts
       handleError $ do
         resOK <-
           processCmd
@@ -79,7 +67,7 @@ interpreterLoop queryMode = do
                then queryExpansion
                else loadExpansion)
             ast
-        finished <- lift $ gets (null . cmdq)
+        finished <- lift $ cmdq `uses` null
         when finished . lift . lift . outputStrLn $
           case (resOK, queryMode) of
             (True, True) -> "yes."
@@ -93,12 +81,12 @@ interpreter =
   evalStateT
     interpreterStart
     (Interp
-       { defs = M.empty
+       { _defs = M.empty
-       , cur = error "no cur"
+       , _cur = error "no cur"
-       , cho = []
+       , _cho = []
-       , ops = []
+       , _ops = []
-       , opstash = []
+       , _opstash = []
-       , macrostash = []
+       , _macrostash = []
-       , strtable = IR.emptystrtable
+       , _strtable = IR.emptystrtable
-       , cmdq = []
+       , _cmdq = []
        })

app/Interpreter.hs

@@ -1,4 +1,4 @@
-{- VAM 2P, done the lazy way -}
+{- pražský přehledný stroj -}
 module Interpreter where
 
 import Code
@@ -8,7 +8,6 @@ import Code
   , Datum(..)
   , Dereferenced(..)
   , Instr(..)
-  , Interp(..)
   , InterpFn
   , derefHeap
   , emptyHeap
@@ -17,29 +16,27 @@ import Code
   , withNewHeapStruct
   , writeHeap
   )
-import qualified Control.Monad.Trans.State.Lazy as St
+import CodeLens
-import Env (PrlgEnv)
-
---import Data.Function
 import qualified Data.Map as M
+import Env (PrlgEnv)
 import IR (Id(..), StrTable(..))
+import Lens.Family2.State
 
 prove :: Code -> PrlgEnv (Either String Bool)
 prove g = do
-  St.modify $ \i ->
+  cur .=
-    i
+    Cho
-      { cur =
+      { _hed = g
-          Cho
+      , _hvar = emptyScope
-            { hed = g
+      , _gol = [Done]
-            , hvar = emptyScope
+      , _gvar = emptyScope
-            , gol = [LastCall]
+      , _unis = 0
-            , gvar = emptyScope
+      , _retcut = True
-            , heap = emptyHeap
+      , _heap = emptyHeap
-            , stk = []
+      , _stk = []
-            , cut = []
+      , _cut = []
-            }
-      , cho = []
       }
+  cho .= []
   loop
   where
     loop = do
@@ -48,20 +45,75 @@ prove g = do
         Nothing -> loop -- not finished yet
         Just x -> return x
 
-{- Simple "fail" backtracking -}
+{- toplevel decision -}
+proveStep :: InterpFn
+proveStep = do
+  u <- use (cur . unis)
+  h <- use (cur . hed)
+  case (u, h) of
+    (0, []) -> goalStep
+    (0, _) -> headStep h
+    (_, _)
+      | u > 0 -> unifyStep h
+    _ -> err "invalid state"
+
+err :: String -> InterpFn
+err = return . Just . Left
+
+{- toplevel choices -}
+goalStep :: InterpFn
+goalStep = do
+  g <- use (cur . gol)
+  case g of
+    U (Struct _):gs -> undefined -- TODO these things NEED lens-family.
+    [Done] -> undefined
+    [Cut, Done] -> undefined
+    Cut:gs -> undefined
+    [Choices cs, Done] -> undefined
+    [Choices cs, Cut, Done] -> undefined
+    Choices cs:gs -> undefined
+    _ -> err "invalid goal code"
+
+headStep :: [Instr] -> InterpFn
+headStep h = do
+  g <- use (cur . gol)
+  case (h, g) of
+    ([Done], _) -> undefined
+    ([Cut, Done], _) -> undefined
+    (_, [Done]) -> undefined
+    (_, [Cut, Done]) -> undefined
+    (_, _) -> undefined
+
+unifyStep h = do
+  g <- use (cur . gol)
+  case (h, g) of
+    (U hd:_, U gd:_) -> undefined hd gd
+    (_, _) -> err "invalid unification code"
+
+{- helpers -}
 backtrack :: InterpFn
 backtrack = do
-  chos <- St.gets cho
+  chos <- use cho
-  case chos
+  case chos of
-    {- if available, restore the easiest choicepoint -}
+    (c:cs)
-        of
+      {- if available, restore the easiest choicepoint -}
-    (c:cs) -> do
+     -> do
-      St.modify $ \i -> i {cur = c, cho = cs}
+      cur .= c
+      cho .= cs
       pure Nothing
     {- if there's no other choice, answer no -}
     _ -> pure . Just $ Right False
 
-proveStep :: InterpFn
+retCut :: InterpFn
+retCut = undefined
+
+cutHead :: InterpFn
+cutHead = undefined
+
+cutGoal :: InterpFn
+cutGoal = undefined
+{- original, TODO remove -}
+{-proveStep :: InterpFn
 proveStep = St.get >>= go
   where
     finish = pure . Just
@@ -325,3 +377,4 @@ proveStep = St.get >>= go
       "code broken: impossible instruction combo hed=" ++
       show (hed . cur $ i) ++
       " gol=" ++ show (gol . cur $ i) ++ " stk=" ++ show (stk . cur $ i)
+-}

app/Load.hs

@@ -1,13 +1,14 @@
 module Load where
 
-import Code (Code, Interp(..))
+import Code (Code, PrlgEnv)
+import CodeLens
 import qualified Compiler as C
 import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Except (except)
+import Control.Monad.Trans.Except (ExceptT, except)
-import Control.Monad.Trans.State.Lazy (gets, modify)
 import qualified Data.Map as M
-import Env (PrlgEnv, findAtom, findStruct, withStrTable)
+import Env (findAtom, findStruct, withStrTable)
 import qualified IR
+import Lens.Family2.State
 import qualified Parser as P
 import qualified Text.Megaparsec as MP
 
@@ -20,8 +21,9 @@ tokenize fn = left MP.errorBundlePretty . MP.parse P.lexPrlg fn
 parse :: String -> [P.Lexeme] -> Either String [P.PAST]
 parse fn = left MP.errorBundlePretty . MP.parse P.parsePrlg fn
 
+shunt :: P.PAST -> ExceptT String PrlgEnv IR.PrlgStr
 shunt past = do
-  ops <- lift $ gets ops
+  ops <- lift $ use ops
   except . left (\err -> "operator resolution: " ++ err ++ "\n") $
     P.shuntPrlg ops past
 
@@ -50,7 +52,7 @@ expansion noexpand expander output x = do
   es <- findStruct expander 2
   o <- findAtom output
   comma <- findAtom ","
-  expand <- gets (M.member es . defs)
+  expand <- defs `uses` M.member es
   pure $
     if expand
       then IR.CallI
@@ -64,6 +66,7 @@ queryExpansion = expansion (\_ -> id) "expand_query" "call"
 
 loadExpansion = expansion (\o x -> IR.CallI o [x]) "expand_load" "assert"
 
+processInput :: String -> Bool -> String -> ExceptT String PrlgEnv ()
 processInput fn queryMode input = do
   asts <- except $ tokenize fn input >>= parse fn
-  lift . modify $ \s -> s {cmdq = [(queryMode, ast) | ast <- asts]}
+  lift $ cmdq .= [(queryMode, ast) | ast <- asts]

prlg.cabal

@@ -25,11 +25,11 @@ executable prlg
     main-is:          Main.hs
 
     -- Modules included in this executable, other than Main.
-    other-modules:    Interpreter, Compiler, Parser, Frontend, IR, Operators, Code, Builtins, Env, Load
+    other-modules:    Interpreter, Compiler, Parser, Frontend, IR, Operators, Code, Builtins, Env, Load, CodeLens
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
-    build-depends:    base >=4.14, containers, megaparsec, haskeline, pretty-simple, split, transformers
+    build-depends:    base >=4.14, containers, megaparsec, haskeline, split, transformers, lens-family, lens-family-th
     hs-source-dirs:   app
     default-language: Haskell2010
     ghc-options:      -Wunused-imports