very assertive
This commit is contained in:
parent
be9beabac0
commit
3aa85f6a93
163
app/Builtins.hs
163
app/Builtins.hs
|
|
@ -3,6 +3,7 @@ module Builtins where
|
|||
import Code
|
||||
( Builtin(..)
|
||||
, Cho(..)
|
||||
, Code
|
||||
, Datum(..)
|
||||
, Dereferenced(..)
|
||||
, Heap(..)
|
||||
|
|
@ -30,6 +31,8 @@ import System.Console.Haskeline (getInputChar, outputStr, outputStrLn)
|
|||
|
||||
bi = Builtin
|
||||
|
||||
continue = pure Nothing
|
||||
|
||||
showTerm itos heap = runIdentity . heapStruct atom struct hrec heap
|
||||
where
|
||||
atom (Atom a) = pure $ "'" ++ itos M.! a ++ "'"
|
||||
|
|
@ -52,13 +55,13 @@ printLocals = do
|
|||
flip traverse (M.assocs scope) $ \(local, ref) ->
|
||||
lift . outputStrLn $
|
||||
"_Local" ++ show local ++ " = " ++ showTerm itos heap ref
|
||||
return Nothing
|
||||
continue
|
||||
|
||||
promptRetry :: InterpFn
|
||||
promptRetry = do
|
||||
last <- gets (null . cho)
|
||||
if last
|
||||
then return Nothing
|
||||
then continue
|
||||
else promptRetry'
|
||||
|
||||
promptRetry' :: InterpFn
|
||||
|
|
@ -66,7 +69,7 @@ promptRetry' = do
|
|||
x <- lift $ getInputChar "? "
|
||||
case x of
|
||||
Just ';' -> backtrack
|
||||
_ -> return Nothing
|
||||
_ -> continue
|
||||
|
||||
withArgs :: [Int] -> ([Int] -> InterpFn) -> InterpFn
|
||||
withArgs as f = do
|
||||
|
|
@ -83,29 +86,29 @@ write' c =
|
|||
lift . outputStr $ showTerm itos heap arg
|
||||
c --this now allows error fallthrough but we might like EitherT
|
||||
|
||||
write = write' $ return Nothing
|
||||
write = write' continue
|
||||
|
||||
nl :: InterpFn
|
||||
nl = do
|
||||
lift $ outputStrLn ""
|
||||
return Nothing
|
||||
continue
|
||||
|
||||
writeln :: InterpFn
|
||||
writeln = write' nl
|
||||
|
||||
assertFact :: InterpFn
|
||||
assertFact =
|
||||
assertFact :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn
|
||||
assertFact addClause =
|
||||
withArgs [0] $ \[arg] -> do
|
||||
heap <- gets (heap . cur)
|
||||
case Co.compileGoal . Co.squashVars <$>
|
||||
Co.heapStructPrlgInt Nothing heap arg of
|
||||
Just (U (Struct s):head) -> do
|
||||
addClause s $ head ++ [NoGoal]
|
||||
return Nothing
|
||||
addClause (head ++ [NoGoal]) s
|
||||
continue
|
||||
_ -> prlgError "assert fact failure"
|
||||
|
||||
assertClause :: InterpFn
|
||||
assertClause =
|
||||
assertRule :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn
|
||||
assertRule addClause =
|
||||
withArgs [0, 1] $ \args -> do
|
||||
scope <- gets (hvar . cur)
|
||||
heap <- gets (heap . cur)
|
||||
|
|
@ -116,8 +119,8 @@ assertClause =
|
|||
Just (IR.CallI 0 [hs, gs]) ->
|
||||
let (U (Struct s):cs) =
|
||||
Co.compileGoal hs ++ Co.seqGoals (Co.compileGoals comma cut gs)
|
||||
in do addClause s cs
|
||||
return Nothing
|
||||
in do addClause cs s
|
||||
continue
|
||||
_ -> prlgError "assert clause failure"
|
||||
|
||||
retractall :: InterpFn
|
||||
|
|
@ -125,8 +128,9 @@ retractall =
|
|||
withArgs [0] $ \[arg] -> do
|
||||
heap <- gets (heap . cur)
|
||||
case derefHeap heap arg of
|
||||
BoundRef _ (Atom a) -> dropProcedure (IR.Id {IR.arity = 0, IR.str = a})
|
||||
BoundRef _ (Struct id) -> dropProcedure id
|
||||
BoundRef _ (Atom a) ->
|
||||
dropProcedure (IR.Id {IR.arity = 0, IR.str = a}) >> continue
|
||||
BoundRef _ (Struct id) -> dropProcedure id >> continue
|
||||
_ -> prlgError "retractall needs a struct"
|
||||
|
||||
call :: InterpFn
|
||||
|
|
@ -144,7 +148,7 @@ call =
|
|||
[U $ hmap M.! (base + i) | i <- [1 .. arity]] ++ gol cur
|
||||
}
|
||||
}
|
||||
return Nothing
|
||||
continue
|
||||
case derefHeap heap arg of
|
||||
BoundRef addr struct@(Struct IR.Id {IR.arity = arity}) ->
|
||||
exec addr struct arity
|
||||
|
|
@ -152,7 +156,28 @@ call =
|
|||
exec addr (Struct IR.Id {IR.arity = 0, IR.str = a}) 0
|
||||
_ -> prlgError "not callable"
|
||||
|
||||
{- struct building -}
|
||||
exec :: InterpFn
|
||||
exec =
|
||||
withArgs [0] $ \[arg] -> do
|
||||
heap <- gets (heap . cur)
|
||||
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 = [LastCall]
|
||||
}
|
||||
}
|
||||
continue
|
||||
_ -> prlgError "goal exec failure"
|
||||
|
||||
{- struct assembly/disassembly -}
|
||||
struct :: InterpFn
|
||||
struct = do
|
||||
heap <- gets (heap . cur)
|
||||
|
|
@ -209,7 +234,7 @@ structUnify arity str = do
|
|||
gcode = map U $ structData ++ [Atom str] ++ paramsData
|
||||
modify $ \s ->
|
||||
s {cur = cur {heap = h', gol = gcode ++ gol cur, hed = hcode ++ hed cur}}
|
||||
return Nothing
|
||||
continue
|
||||
|
||||
{- operator management -}
|
||||
op :: InterpFn
|
||||
|
|
@ -223,14 +248,14 @@ op = do
|
|||
(,) <$> itos M.!? opatom <*>
|
||||
(O.Op prio <$> ((itos M.!? fixityAtom) >>= O.fixity)) -> do
|
||||
modify $ \s -> s {ops = op : ops s}
|
||||
return Nothing
|
||||
continue
|
||||
_ -> prlgError "bad op spec"
|
||||
|
||||
stashOps :: InterpFn
|
||||
stashOps = do
|
||||
currentOps <- gets ops
|
||||
modify $ \s -> s {opstash = currentOps : opstash s}
|
||||
return Nothing
|
||||
continue
|
||||
|
||||
popOps :: InterpFn
|
||||
popOps = do
|
||||
|
|
@ -239,71 +264,77 @@ popOps = do
|
|||
[] -> prlgError "no op stash to pop"
|
||||
(ops':opss) -> do
|
||||
modify $ \s -> s {ops = ops', opstash = opss}
|
||||
return Nothing
|
||||
continue
|
||||
|
||||
{- adding the builtins -}
|
||||
addOp :: (String, O.Op) -> PrlgEnv ()
|
||||
addOp op = modify $ \s -> s {ops = op : ops s}
|
||||
|
||||
addClause struct code =
|
||||
modify $ \s ->
|
||||
s {defs = M.alter (Just . maybe [code] (\hs -> code : hs)) struct $ defs s}
|
||||
modDef :: ([Code] -> Maybe [Code]) -> IR.Id -> PrlgEnv ()
|
||||
modDef fn struct =
|
||||
modify $ \s -> s {defs = M.alter (maybe (fn []) fn) struct $ defs s}
|
||||
|
||||
addProcedure struct heads =
|
||||
modify $ \s -> s {defs = M.insert struct heads $ defs s}
|
||||
addClauseZ :: Code -> IR.Id -> PrlgEnv ()
|
||||
addClauseZ code = modDef $ Just . ([code] ++)
|
||||
|
||||
dropProcedure struct = do
|
||||
d <- gets defs
|
||||
if struct `M.member` d
|
||||
then do
|
||||
modify $ \s -> s {defs = M.delete struct d}
|
||||
return Nothing
|
||||
else prlgError "no such definition" -- this should backtrack?
|
||||
addClauseA :: Code -> IR.Id -> PrlgEnv ()
|
||||
addClauseA code = modDef $ Just . (code :)
|
||||
|
||||
addProc n a c = do
|
||||
sym <- findStruct n a
|
||||
addProcedure sym c
|
||||
addProcedure :: [Code] -> IR.Id -> PrlgEnv ()
|
||||
addProcedure heads = modDef $ Just . const heads
|
||||
|
||||
addBi n i b =
|
||||
addProc n i [[U (LocalRef $ r - 1) | r <- [1 .. i]] ++ [Invoke $ bi b]]
|
||||
dropProcedure :: IR.Id -> PrlgEnv ()
|
||||
dropProcedure = modDef $ const Nothing
|
||||
|
||||
addProc :: [Code] -> String -> Int -> PrlgEnv ()
|
||||
addProc c n a = findStruct n a >>= addProcedure c
|
||||
|
||||
addBi :: InterpFn -> String -> Int -> PrlgEnv ()
|
||||
addBi b n a =
|
||||
addProc [[U (LocalRef $ r - 1) | r <- [1 .. a]] ++ [Invoke $ bi b]] n a
|
||||
|
||||
{- actual prlgude -}
|
||||
addPrelude :: PrlgEnv ()
|
||||
addPrelude = do
|
||||
pure undefined
|
||||
{- primitives -}
|
||||
addBi "true" 0 (pure Nothing)
|
||||
addBi "fail" 0 backtrack
|
||||
addBi (pure Nothing) "true" 0
|
||||
addBi backtrack "fail" 0
|
||||
addOp $ O.xfx "=" 700
|
||||
addProc "=" 2 [[U (LocalRef 0), U (LocalRef 0), NoGoal]]
|
||||
addProc [[U (LocalRef 0), U (LocalRef 0), NoGoal]] "=" 2
|
||||
{- clauses -}
|
||||
addOp $ O.xfy "," 1000
|
||||
addOp $ O.xfx ":-" 1200
|
||||
addOp $ O.fx ":-" 1200
|
||||
horn1 <- findStruct ":-" 1
|
||||
horn2 <- findStruct ":-" 2
|
||||
--addOp $ O.fx ":-" 1200
|
||||
addProc
|
||||
"assert"
|
||||
1
|
||||
[ [ U (Struct horn2)
|
||||
, U (LocalRef 0)
|
||||
, U (LocalRef 1)
|
||||
, Cut
|
||||
, Invoke (bi assertClause)
|
||||
]
|
||||
, [U (LocalRef 0), Invoke (bi assertFact)]
|
||||
]
|
||||
addBi "retractall" 1 retractall
|
||||
addBi "call" 1 call
|
||||
addBi "struct" 3 struct
|
||||
let assertCode ac =
|
||||
[ [ U (Struct horn2)
|
||||
, U (LocalRef 0)
|
||||
, U (LocalRef 1)
|
||||
, Cut
|
||||
, Invoke . bi $ assertRule ac
|
||||
]
|
||||
, [U (Struct horn1), U (LocalRef 0), Cut, Invoke $ bi exec]
|
||||
, [U (LocalRef 0), Invoke . bi $ assertFact ac]
|
||||
]
|
||||
in do addProc (assertCode addClauseA) "asserta" 1
|
||||
addProc (assertCode addClauseZ) "assertz" 1
|
||||
addProc (assertCode addClauseZ) "assert" 1
|
||||
addBi retractall "retractall" 1
|
||||
addBi call "call" 1
|
||||
addBi struct "struct" 3
|
||||
{- operators -}
|
||||
addBi "op" 3 op
|
||||
addBi "stash_operators" 0 stashOps
|
||||
addBi "pop_operators" 0 popOps
|
||||
addBi op "op" 3
|
||||
addBi stashOps "stash_operators" 0
|
||||
addBi popOps "pop_operators" 0
|
||||
{- query tools -}
|
||||
addBi "print_locals" 0 printLocals
|
||||
addBi "prompt_retry" 0 promptRetry'
|
||||
addBi "query" 0 (printLocals >> promptRetry)
|
||||
addBi printLocals "print_locals" 0
|
||||
addBi promptRetry' "prompt_retry" 0
|
||||
addBi (printLocals >> promptRetry) "query" 0
|
||||
{- IO -}
|
||||
addBi "write" 1 write
|
||||
addBi "writeln" 1 writeln
|
||||
addBi "nl" 0 nl
|
||||
addBi write "write" 1
|
||||
addBi writeln "writeln" 1
|
||||
addBi nl "nl" 0
|
||||
{- debug -}
|
||||
addBi "interpreter_trace" 0 (get >>= liftIO . print >> pure Nothing)
|
||||
addBi (get >>= liftIO . print >> pure Nothing) "interpreter_trace" 0
|
||||
|
|
|
|||
|
|
@ -85,6 +85,7 @@ heapStructPrlgInt :: Monad m => m PrlgInt -> Heap -> Int -> m PrlgInt
|
|||
heapStructPrlgInt heaperr heap ref = heapStruct atom struct hrec heap ref
|
||||
where
|
||||
atom (Atom s) = pure $ AtomI s
|
||||
atom (Number n) = pure $ NumI n
|
||||
atom VoidRef = pure $ VoidI
|
||||
struct (Struct s) args = pure $ CallI (str s) args
|
||||
hrec (HeapRef r) ref
|
||||
|
|
|
|||
Loading…
Reference in a new issue