106 lines
3 KiB
Haskell
106 lines
3 KiB
Haskell
module Builtins where
|
|
|
|
import Code
|
|
import Control.Monad.IO.Class
|
|
import Control.Monad.Trans.Class
|
|
import Control.Monad.Trans.State.Lazy
|
|
import Data.List (intercalate)
|
|
import qualified Data.Map as M
|
|
import Env hiding (PrlgEnv)
|
|
import qualified IR
|
|
import Interpreter (backtrack)
|
|
import qualified Operators as O
|
|
import System.Console.Haskeline
|
|
|
|
bi = Builtin
|
|
|
|
showTerm itos heap visited ref
|
|
| ref `elem` visited = "_Rec" ++ show ref
|
|
| HeapRef r <- heap M.! ref =
|
|
if r == ref
|
|
then "_X" ++ show ref
|
|
else showTerm itos heap (ref : visited) r
|
|
| Struct (IR.Id h arity) <- heap M.! ref =
|
|
itos M.! h ++
|
|
"(" ++
|
|
intercalate
|
|
","
|
|
[showTerm itos heap (ref : visited) (ref + i) | i <- [1 .. arity]] ++
|
|
")"
|
|
| Atom a <- heap M.! ref = itos M.! a
|
|
|
|
printLocals :: BuiltinFn
|
|
printLocals = do
|
|
scope <- gets (gvar . cur)
|
|
Heap _ heap <- gets (heap . cur)
|
|
IR.StrTable _ _ itos <- gets strtable
|
|
flip traverse (M.elems scope) $ \(ref, name) ->
|
|
lift . outputStrLn $ (itos M.! name) ++ " = " ++ showTerm itos heap [] ref
|
|
return Nothing
|
|
|
|
promptRetry :: BuiltinFn
|
|
promptRetry = do
|
|
x <- lift $ getInputChar "? "
|
|
case x of
|
|
Just ';' -> backtrack
|
|
_ -> return Nothing
|
|
|
|
write :: BuiltinFn
|
|
write = do
|
|
scope <- gets (hvar . cur)
|
|
Heap _ heap <- gets (heap . cur)
|
|
IR.StrTable _ _ itos <- gets strtable
|
|
lift . outputStr $ showTerm itos heap [] (fst $ scope M.! 0)
|
|
return Nothing
|
|
|
|
nl :: BuiltinFn
|
|
nl = do
|
|
lift $ outputStrLn ""
|
|
return Nothing
|
|
|
|
writeln :: BuiltinFn
|
|
writeln = write >> nl
|
|
|
|
addBuiltins :: PrlgEnv ()
|
|
addBuiltins = do
|
|
a1 <- findStruct "a" 1
|
|
a <- findAtom "a"
|
|
b <- findAtom "b"
|
|
c <- findAtom "c"
|
|
varX <- findAtom "X"
|
|
b0 <- findStruct "b" 0
|
|
any1 <- findStruct "any" 1
|
|
eq2 <- findStruct "=" 2
|
|
hello0 <- findStruct "hello" 0
|
|
fail0 <- findStruct "fail" 0
|
|
true0 <- findStruct "true" 0
|
|
printlocals0 <- findStruct "print_locals" 0
|
|
debugprint0 <- findStruct "interpreter_state" 0
|
|
promptretry0 <- findStruct "prompt_retry" 0
|
|
write1 <- findStruct "write" 1
|
|
writeln1 <- findStruct "writeln" 1
|
|
nl0 <- findStruct "nl" 0
|
|
modify $ \s ->
|
|
s
|
|
{ defs =
|
|
M.fromList
|
|
[ (eq2, [[U (LocalRef 0 varX), U (LocalRef 0 varX), NoGoal]])
|
|
, (any1, [[U VoidRef, NoGoal]])
|
|
, (fail0, [[Invoke $ bi backtrack]])
|
|
, (true0, [[Invoke $ bi (pure Nothing)]])
|
|
, ( debugprint0
|
|
, [[Invoke $ bi (get >>= liftIO . print >> pure Nothing)]])
|
|
, (printlocals0, [[Invoke $ bi printLocals]])
|
|
, (promptretry0, [[Invoke $ bi promptRetry]])
|
|
, (write1, [[U (LocalRef 0 varX), Invoke $ bi write]])
|
|
, (writeln1, [[U (LocalRef 0 varX), Invoke $ bi writeln]])
|
|
, (nl0, [[Invoke $ bi nl]])
|
|
, (a1, [[U (Atom a), NoGoal], [U (Atom b), NoGoal]])
|
|
, ( b0
|
|
, [ [Goal, U (Struct a1), U (Atom c), LastCall]
|
|
, [Goal, U (Struct a1), U (Atom b), LastCall]
|
|
])
|
|
]
|
|
, ops = [(O.xfy "," 1000), (O.xfx "=" 700)]
|
|
}
|