diff options
Diffstat (limited to 'app/Builtins.hs')
| -rw-r--r-- | app/Builtins.hs | 141 |
1 files changed, 65 insertions, 76 deletions
diff --git a/app/Builtins.hs b/app/Builtins.hs index 2de3f89..a12da07 100644 --- a/app/Builtins.hs +++ b/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) - heap <- gets (heap . cur) - IR.StrTable _ _ itos <- gets strtable + scope <- use (cur . gvar) + heap <- use (cur . heap) + IR.StrTable _ _ itos <- use strtable flip traverse (M.assocs scope) $ \(local, ref) -> - lift . outputStrLn $ - "_Local" ++ show local ++ " = " ++ showTerm itos heap ref + lift . outputStrLn $ "_Local" ++ show local ++ " = " ++ + 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) - IR.StrTable _ _ itos <- gets strtable + heap <- use (cur . heap) + 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) - heap <- gets (heap . cur) + scope <- use (cur . hvar) + 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 -> - s - { cur = - cur - { hvar = M.empty - , hed = Co.seqGoals (Co.compileGoals comma cut gs) - , gol = fgol (gol cur) - } - } + zoom cur $ do + hvar .= M.empty + hed .= Co.seqGoals (Co.compileGoals comma cut gs) + gol %= fgol 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) - scope <- gets (hvar . cur) + heap <- use (cur . heap) + 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) - scope <- gets (hvar . cur) + heap <- use (cur . heap) + 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 - let h = heap cur - scope = hvar cur + h <- use (cur . heap) + scope <- use (cur . hvar) 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 -> - s {cur = cur {heap = h', gol = gcode ++ gol cur, hed = hcode ++ hed cur}} + zoom cur $ do + heap .= h' + gol %= (gcode ++) + hed %= (hcode ++) continue {- terms -} var :: InterpFn var = do - heap <- gets (heap . cur) - scope <- gets (hvar . cur) + heap <- use (cur . heap) + 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) - scope <- gets (hvar . cur) + heap <- use (cur . heap) + 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) - ds <- gets defs + heap <- use (cur . heap) + 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) - IR.StrTable _ _ itos <- gets strtable + heap <- use (cur . heap) + 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) - IR.StrTable _ _ itos <- gets strtable + heap <- use (cur . heap) + 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 - modify $ \s -> s {opstash = currentOps : opstash s} + currentOps <- use ops + 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 -> - s - { defs = M.alter (const le) les $ M.alter (const qe) qes $ defs s - , macrostash = stash' - } + defs %= M.alter (const le) les . M.alter (const qe) qes + 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 = - modify $ \s -> s {defs = M.alter (maybe (fn []) fn) struct $ defs s} +modDef fn struct = defs %= M.alter (maybe (fn []) fn) struct 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) - IR.StrTable _ _ itos <- gets strtable --TODO the argument here should preferably be a string, right? + heap <- use (cur . heap) + 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) + , U (Struct cp) -- current_predicate(expand_something(_,_)), , U (Struct s) , U VoidRef , U VoidRef - , Call -- no cut! - , Goal -- expand_something(Arg1, Arg2). - , U (Struct s) + , U (Struct s) -- expand_something(Arg1, Arg2). , 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 |