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

macros macro

Browse source 
macron edition
This commit is contained in:
Mirek Kratochvil 2023-01-14 23:10:52 +01:00
parent dab150976d
commit ab86f0f21f
2 changed files with 40 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
app/Builtins.hs
View file

@ -133,8 +133,8 @@ retractall =
BoundRef _ (Struct id) -> dropProcedure id >> continue BoundRef _ (Struct id) -> dropProcedure id >> continue
_ -> prlgError "retractall needs a struct" _ -> prlgError "retractall needs a struct"
call :: InterpFn call' :: InterpFn
call = call' =
withArgs [0] $ \[arg] -> do withArgs [0] $ \[arg] -> do
heap@(Heap _ hmap) <- gets (heap . cur) heap@(Heap _ hmap) <- gets (heap . cur)
let exec base struct arity = do let exec base struct arity = do
@ -156,8 +156,8 @@ call =
exec addr (Struct IR.Id {IR.arity = 0, IR.str = a}) 0 exec addr (Struct IR.Id {IR.arity = 0, IR.str = a}) 0
_ -> prlgError "not callable" _ -> prlgError "not callable"
exec :: InterpFn exec' :: (Code -> Code) -> InterpFn
exec = exec' fgol =
withArgs [0] $ \[arg] -> do withArgs [0] $ \[arg] -> do
heap <- gets (heap . cur) heap <- gets (heap . cur)
case Co.squashVars <$> Co.heapStructPrlgInt Nothing heap arg of case Co.squashVars <$> Co.heapStructPrlgInt Nothing heap arg of
@ -171,11 +171,17 @@ exec =
cur cur
{ hvar = M.empty { hvar = M.empty
, hed = Co.seqGoals (Co.compileGoals comma cut gs) , hed = Co.seqGoals (Co.compileGoals comma cut gs)
, gol = [LastCall] , gol = fgol (gol cur)
} }
} }
continue continue
_ -> prlgError "goal exec failure" _ -> prlgError "bad goal"
call :: InterpFn
call = exec' id
exec :: InterpFn
exec = exec' (const [LastCall])
{- struct assembly/disassembly -} {- struct assembly/disassembly -}
struct :: InterpFn struct :: InterpFn

36
app/Frontend.hs
View file

@ -9,7 +9,7 @@ import Control.Monad.Trans.Except (except, runExceptT)
import Control.Monad.Trans.State.Lazy (evalStateT, gets) import Control.Monad.Trans.State.Lazy (evalStateT, gets)
import qualified Data.Map as M import qualified Data.Map as M
import Data.Traversable (for) import Data.Traversable (for)
import Env (PrlgEnv, findAtom, withStrTable) import Env (PrlgEnv, findAtom, findStruct, withStrTable)
import qualified IR import qualified IR
import qualified Interpreter as I import qualified Interpreter as I
import qualified Parser as P import qualified Parser as P
@ -38,8 +38,6 @@ parse = left MP.errorBundlePretty . MP.parse P.parsePrlg "<stdin>"
shunt ops = shunt ops =
left (\err -> "operator resolution: " ++ err ++ "\n") . P.shuntPrlg ops left (\err -> "operator resolution: " ++ err ++ "\n") . P.shuntPrlg ops
makeAssertion x = IR.CallS "assert" [x]
intern prlgs = do intern prlgs = do
prlgi <- withStrTable $ \st -> IR.internPrlg st prlgs prlgi <- withStrTable $ \st -> IR.internPrlg st prlgs
underscore <- findAtom "_" underscore <- findAtom "_"
@ -60,22 +58,44 @@ handleError m = do
Left err -> lift $ outputStr err Left err -> lift $ outputStr err
_ -> pure () _ -> pure ()
processInput astHook good bad input = processInput precompileHook good bad input =
(True <$) . handleError $ do (True <$) . handleError $ do
asts <- except $ tokenize input >>= parse asts <- except $ tokenize input >>= parse
ops <- lift $ gets ops ops <- lift $ gets ops
for asts $ \ast' -> do for asts $ \ast' -> do
ast <- except $ astHook <$> shunt ops ast' ast <- except $ shunt ops ast'
code <- lift $ intern ast >>= compile code <- lift $ intern ast >>= precompileHook >>= compile
res <- lift (I.prove code) >>= except . left (++ "\n") res <- lift (I.prove code) >>= except . left (++ "\n")
lift . lift . outputStrLn $ lift . lift . outputStrLn $
if res if res
then good then good
else bad else bad
query = processInput id "yes." "no proof." expansion noexpand expander output x = do
es <- findStruct expander 2
o <- findAtom output
comma <- findAtom ","
expand <- gets (M.member es . defs)
pure $
if expand
then IR.CallI
comma
[ IR.CallI (IR.str es) [x, IR.VarI (-1) 0]
, IR.CallI o [IR.VarI (-1) 0]
]
else noexpand o x
assert = processInput makeAssertion "ok." "rejected." query =
processInput
(expansion (\_ -> id) "query_expansion" "call")
"yes."
"no proof."
assert =
processInput
(expansion (\o x -> IR.CallI o [x]) "load_expansion" "assert")
"ok."
"rejected."
interpreterStart :: PrlgEnv () interpreterStart :: PrlgEnv ()
interpreterStart = do interpreterStart = do