exa/prlg
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

get lensy and classy

Browse source
This commit is contained in:
Mirek Kratochvil 2023-02-25 22:35:59 +01:00
parent 3eb6125609
commit 81df52f656
9 changed files with 212 additions and 202 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

141
app/Builtins.hs
View file

@ -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

74
app/Code.hs
View file

@ -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)

10
app/CodeLens.hs Normal file
View file

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

7
app/Compiler.hs
View file

@ -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

10
app/Env.hs
View file

@ -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

44
app/Frontend.hs
View file

@ -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 "<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
, 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 = []
})

107
app/Interpreter.hs
View file

@ -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)
-}

17
app/Load.hs
View file

@ -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]

4
prlg.cabal
View file

@ -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