diff --git a/app/Builtins.hs b/app/Builtins.hs index 2dd1e61..8ad94ef 100644 --- a/app/Builtins.hs +++ b/app/Builtins.hs @@ -4,6 +4,7 @@ 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 @@ -13,10 +14,20 @@ import System.Console.Haskeline bi = Builtin -hello :: BuiltinFn -hello = do - liftIO $ putStrLn "hllo prlg" - return Nothing +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 @@ -24,7 +35,7 @@ printLocals = do Heap _ heap <- gets (heap . cur) IR.StrTable _ _ itos <- gets strtable flip traverse (M.elems scope) $ \(ref, name) -> - lift . outputStrLn $ (itos M.! name) ++ " = " ++ show (heap M.! ref) + lift . outputStrLn $ (itos M.! name) ++ " = " ++ showTerm itos heap [] ref return Nothing promptRetry :: BuiltinFn @@ -34,6 +45,22 @@ promptRetry = do 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 @@ -50,24 +77,29 @@ addBuiltins = do 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]]) - , (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] - ]) , (any1, [[U VoidRef, NoGoal]]) - , (hello0, [[Invoke $ bi hello]]) , (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)] } diff --git a/app/Frontend.hs b/app/Frontend.hs index eac4e89..38ad353 100644 --- a/app/Frontend.hs +++ b/app/Frontend.hs @@ -73,7 +73,7 @@ interpreterStart = do interpreterLoop :: PrlgEnv () interpreterLoop = do - minput <- lift $ getInputLine "prlg> " + minput <- lift $ getInputLine "π> " case minput of Nothing -> return () Just input -> do