consultation mode

app/Frontend.hs

@@ -5,9 +5,10 @@ import Code (Interp(..))
 import qualified Compiler as C
 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)
-import Data.Foldable (traverse_)
 import qualified Data.Map as M
+import Data.Traversable (for)
 import Env (PrlgEnv, findAtom, withStrTable)
 import qualified IR
 import qualified Interpreter as I
@@ -28,61 +29,78 @@ ppr x =
       }
     x
 
-interpret :: String -> PrlgEnv Bool
+left f = either (Left . f) Right
-interpret = (>> return True) . lex
+
-  where
+tokenize = left MP.errorBundlePretty . MP.parse P.lexPrlg "<stdin>"
-    lex input = do
+
-      case MP.parse P.lexPrlg "-" input of
+parse = left MP.errorBundlePretty . MP.parse P.parsePrlg "<stdin>"
-        Left bundle -> lift . outputStr $ MP.errorBundlePretty bundle
+
-        Right toks -> parse toks
+shunt ops =
-    parse toks = do
+  left (\err -> "operator resolution: " ++ err ++ "\n") . P.shuntPrlg ops
-      case MP.parse P.parsePrlg "-" toks of
+
-        Left bundle -> lift . outputStr $ MP.errorBundlePretty bundle
+makeAssertion x = IR.CallS "assert" [x]
-        Right asts -> traverse_ shunt asts
+
-    shunt ast = do
+intern prlgs = do
-      o <- gets ops
+  prlgi <- withStrTable $ \st -> IR.internPrlg st prlgs
-      case P.shuntPrlg o ast of
+  underscore <- findAtom "_"
-        Left err -> lift . outputStrLn $ "expression parsing: " ++ err
+  list <- findAtom "[]"
-        Right prlg -> intern prlg
+  withStrTable $ \st ->
-    intern prlgs = do
+    ( st
-      prlgi <- withStrTable $ \st -> IR.internPrlg st prlgs
+    , C.squashVars $ C.variablizePrlg underscore st $ C.desugarPrlg list prlgi)
-      underscore <- findAtom "_"
+
-      list <- findAtom "[]"
+compile prlgv = do
-      prlgv <-
+  comma <- findAtom ","
-        withStrTable $ \st ->
+  cut <- findAtom "!"
-          ( st
+  return $ C.seqGoals (C.compileGoals comma cut prlgv)
-          , C.squashVars $
+
-            C.variablizePrlg underscore st $ C.desugarPrlg list prlgi)
+-- the signature of this is too ugly to include here
-      compile prlgv
+handleError m = do
-    compile prlgv = do
+  res <- runExceptT m
-      comma <- findAtom ","
+  case res of
-      cut <- findAtom "!"
+    Left err -> lift $ outputStr err
-      let code = C.seqGoals $ C.compileGoals comma cut prlgv
+    _ -> pure ()
-      execute code
+
-    execute code = do
+processInput astHook good bad input =
-      res <- I.prove code
+  (True <$) . handleError $ do
-      lift . outputStrLn $
+    asts <- except $ tokenize input >>= parse
-        case res of
+    ops <- lift $ gets ops
-          Left err -> err
+    for asts $ \ast' -> do
-          Right res ->
+      ast <- except $ astHook <$> shunt ops ast'
-            if res
+      code <- lift $ intern ast >>= compile
-              then "yes."
+      res <- lift (I.prove code) >>= except . left (++ "\n")
-              else "no proof."
+      lift . lift . outputStrLn $
+        if res
+          then good
+          else bad
+
+query = processInput id "yes." "no proof."
+
+assert = processInput makeAssertion "ok." "rejected."
 
 interpreterStart :: PrlgEnv ()
 interpreterStart = do
   addPrelude
-  interpreterLoop
+  interpreterLoop True
 
-interpreterLoop :: PrlgEnv ()
+interpreterLoop :: Bool -> PrlgEnv ()
-interpreterLoop = do
+interpreterLoop queryMode = do
-  minput <- lift $ getInputLine "prlg? " --TODO switch with plain .
+  minput <-
+    lift $
+    getInputLine
+      (if queryMode
+         then "prlg? "
+         else "prlg |- ")
   case minput of
     Nothing -> return ()
+    Just "." -> interpreterLoop (not queryMode)
     Just input -> do
-      continue <- interpret input
+      continue <-
+        (if queryMode
+           then query
+           else assert)
+          input
       if continue
-        then interpreterLoop
+        then interpreterLoop queryMode
         else return ()
 
 interpreter :: InputT IO ()