diff --git a/app/Frontend.hs b/app/Frontend.hs index cea9976..0211958 100644 --- a/app/Frontend.hs +++ b/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 -interpret = (>> return True) . lex - where - lex input = do - case MP.parse P.lexPrlg "-" input of - Left bundle -> lift . outputStr $ MP.errorBundlePretty bundle - Right toks -> parse toks - parse toks = do - case MP.parse P.parsePrlg "-" toks of - Left bundle -> lift . outputStr $ MP.errorBundlePretty bundle - Right asts -> traverse_ shunt asts - shunt ast = do - o <- gets ops - case P.shuntPrlg o ast of - Left err -> lift . outputStrLn $ "expression parsing: " ++ err - Right prlg -> intern prlg - intern prlgs = do - prlgi <- withStrTable $ \st -> IR.internPrlg st prlgs - underscore <- findAtom "_" - list <- findAtom "[]" - prlgv <- - withStrTable $ \st -> - ( st - , C.squashVars $ - C.variablizePrlg underscore st $ C.desugarPrlg list prlgi) - compile prlgv - compile prlgv = do - comma <- findAtom "," - cut <- findAtom "!" - let code = C.seqGoals $ C.compileGoals comma cut prlgv - execute code - execute code = do - res <- I.prove code - lift . outputStrLn $ - case res of - Left err -> err - Right res -> - if res - then "yes." - else "no proof." +left f = either (Left . f) Right + +tokenize = left MP.errorBundlePretty . MP.parse P.lexPrlg "" + +parse = left MP.errorBundlePretty . MP.parse P.parsePrlg "" + +shunt ops = + left (\err -> "operator resolution: " ++ err ++ "\n") . P.shuntPrlg ops + +makeAssertion x = IR.CallS "assert" [x] + +intern prlgs = do + prlgi <- withStrTable $ \st -> IR.internPrlg st prlgs + underscore <- findAtom "_" + list <- findAtom "[]" + withStrTable $ \st -> + ( st + , C.squashVars $ C.variablizePrlg underscore st $ C.desugarPrlg list prlgi) + +compile prlgv = do + comma <- findAtom "," + cut <- findAtom "!" + return $ C.seqGoals (C.compileGoals comma cut prlgv) + +-- the signature of this is too ugly to include here +handleError m = do + res <- runExceptT m + case res of + Left err -> lift $ outputStr err + _ -> pure () + +processInput astHook good bad input = + (True <$) . handleError $ do + asts <- except $ tokenize input >>= parse + ops <- lift $ gets ops + for asts $ \ast' -> do + ast <- except $ astHook <$> shunt ops ast' + code <- lift $ intern ast >>= compile + res <- lift (I.prove code) >>= except . left (++ "\n") + 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 = do - minput <- lift $ getInputLine "prlg? " --TODO switch with plain . +interpreterLoop :: Bool -> PrlgEnv () +interpreterLoop queryMode = do + 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 ()