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 diff --git a/app/Code.hs b/app/Code.hs index 9e1f453..4473287 100644 --- a/app/Code.hs +++ b/app/Code.hs @@ -19,13 +19,11 @@ data Datum deriving (Show, Eq, Ord) data Instr - = U Datum -- something unifiable - | NoGoal -- trivial goal (directly after head) - | Invoke Builtin -- also directly after head - | Goal -- a new goal (set head) - | Call -- all seems okay, call the head's hoal - | LastCall -- tail call the head's goal - | Cut -- remove all alternative clauses of the current goal + = U Datum -- unify/resolve something + | Invoke Builtin -- give control to a builtin (invoked from head) + | Done -- all done, can return + | Cut -- remove choicepoints of the current goal + | Choices [[Code]] -- split off several possibilities (push choicepoints) deriving (Show) type Code = [Instr] @@ -45,30 +43,32 @@ emptyScope = M.empty data Cho = Cho - { hed :: Code -- head pointer - , hvar :: Scope -- variables unified in head (so far) - , gol :: Code -- goal pointer - , 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) - , stk :: [(Code, Scope, [Cho])] -- remaining goals together with their vars and cuts - , cut :: [Cho] -- snapshot of choicepoints before entering + { _hed :: Code -- head pointer + , _hvar :: Scope -- variables unified in head (so far) + , _gol :: Code -- goal pointer + , _gvar :: Scope -- variables unified in the goal + , _unis :: Int -- items left to unify + , _retcut :: Bool -- cut after this goal succeeds + , _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 - , cur :: Cho -- the choice that is being evaluated right now - , cho :: [Cho] -- remaining choice points - , ops :: Ops -- currently defined operators - , opstash :: [Ops] -- saved operators - , macrostash :: [(Maybe [Code], Maybe [Code])] -- saved expansion defs (load, query) - , strtable :: StrTable -- string table - , cmdq :: [(Bool, PAST)] -- isQuery, lexemes + { _defs :: Defs -- global definitions for lookup + , _cur :: Cho -- the choice that is being evaluated right now + , _cho :: [Cho] -- remaining choice points + , _ops :: Ops -- currently defined operators + , _opstash :: [Ops] -- saved operators + , _macrostash :: [(Maybe [Code], Maybe [Code])] -- saved expansion defs (load, query) + , _strtable :: StrTable -- string table + , _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) diff --git a/app/CodeLens.hs b/app/CodeLens.hs new file mode 100644 index 0000000..9c1f1d6 --- /dev/null +++ b/app/CodeLens.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} + +module CodeLens where + +import Code +import Lens.Family2.TH + +$(makeLenses ''Cho) + +$(makeLenses ''Interp) diff --git a/app/Compiler.hs b/app/Compiler.hs index 849afdb..749ecdb 100644 --- a/app/Compiler.hs +++ b/app/Compiler.hs @@ -74,12 +74,7 @@ compileArg (VarI x _) = [U (LocalRef x)] compileArg (VoidI) = [U VoidRef] seqGoals :: [Code] -> Code -seqGoals [] = [NoGoal] -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 +seqGoals = (++ [Done]) . concat heapStructPrlgInt :: Monad m => m PrlgInt -> Heap -> Int -> m PrlgInt heapStructPrlgInt heaperr heap ref = heapStruct atom struct hrec heap ref diff --git a/app/Env.hs b/app/Env.hs index 82bf9d0..592d608 100644 --- a/app/Env.hs +++ b/app/Env.hs @@ -1,14 +1,14 @@ module Env where -import Code (Interp(..), InterpFn, PrlgEnv) -import Control.Monad.Trans.State.Lazy (gets, modify) +import Code (InterpFn, PrlgEnv) +import CodeLens import qualified IR +import Lens.Family2.State withStrTable :: (IR.StrTable -> (IR.StrTable, a)) -> Env.PrlgEnv a withStrTable f = do - st <- gets strtable - let (st', x) = f st - modify (\s -> s {strtable = st'}) + (st', x) <- strtable `uses` f + strtable .= st' return x findStruct :: String -> Int -> Env.PrlgEnv IR.Id diff --git a/app/Frontend.hs b/app/Frontend.hs index 990e79d..77706d8 100644 --- a/app/Frontend.hs +++ b/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 = []} - _ -> pure () + cmdq .= [] + _ -> (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 "" 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 - , cur = error "no cur" - , cho = [] - , ops = [] - , opstash = [] - , macrostash = [] - , strtable = IR.emptystrtable - , cmdq = [] + { _defs = M.empty + , _cur = error "no cur" + , _cho = [] + , _ops = [] + , _opstash = [] + , _macrostash = [] + , _strtable = IR.emptystrtable + , _cmdq = [] }) diff --git a/app/Interpreter.hs b/app/Interpreter.hs index b215049..43ea1d5 100644 --- a/app/Interpreter.hs +++ b/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 Env (PrlgEnv) - ---import Data.Function +import CodeLens 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 -> - i - { cur = - Cho - { hed = g - , hvar = emptyScope - , gol = [LastCall] - , gvar = emptyScope - , heap = emptyHeap - , stk = [] - , cut = [] - } - , cho = [] + cur .= + Cho + { _hed = g + , _hvar = emptyScope + , _gol = [Done] + , _gvar = emptyScope + , _unis = 0 + , _retcut = True + , _heap = emptyHeap + , _stk = [] + , _cut = [] } + 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 - case chos - {- if available, restore the easiest choicepoint -} - of - (c:cs) -> do - St.modify $ \i -> i {cur = c, cho = cs} + chos <- use cho + case chos of + (c:cs) + {- if available, restore the easiest choicepoint -} + -> do + 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) +-} diff --git a/app/Load.hs b/app/Load.hs index 23b92fe..85a6d03 100644 --- a/app/Load.hs +++ b/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.State.Lazy (gets, modify) +import Control.Monad.Trans.Except (ExceptT, except) 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] diff --git a/prlg.cabal b/prlg.cabal index 797a155..929d3ee 100644 --- a/prlg.cabal +++ b/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