load.hs finally loaded

1 files changed, 69 insertions, 0 deletions

diff --git a/app/Load.hs b/app/Load.hs
new file mode 100644
index 0000000..b1ad0a5
--- /dev/null
+++ b/app/Load.hs
@@ -0,0 +1,69 @@
+module Load where
+
+import Code (Code, Interp(..))
+import qualified Compiler as C
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Except (except)
+import Control.Monad.Trans.State.Lazy (gets, modify)
+import qualified Data.Map as M
+import Env (PrlgEnv, findAtom, findStruct, withStrTable)
+import qualified IR
+import qualified Parser as P
+import qualified Text.Megaparsec as MP
+
+left :: (a -> b) -> Either a c -> Either b c
+left f = either (Left . f) Right
+
+tokenize :: String -> String -> Either String [P.Lexeme]
+tokenize fn = left MP.errorBundlePretty . MP.parse P.lexPrlg fn
+
+parse :: String -> [P.Lexeme] -> Either String [P.PAST]
+parse fn = left MP.errorBundlePretty . MP.parse P.parsePrlg fn
+
+shunt past = do
+  ops <- lift $ gets ops
+  except . left (\err -> "operator resolution: " ++ err ++ "\n") $
+    P.shuntPrlg ops past
+
+intern :: IR.PrlgStr -> PrlgEnv IR.PrlgInt
+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 :: IR.PrlgInt -> PrlgEnv Code
+compile prlgv = do
+  comma <- findAtom ","
+  cut <- findAtom "!"
+  return $ C.seqGoals (C.compileGoals comma cut prlgv)
+
+expansion ::
+     (Int -> IR.PrlgInt -> IR.PrlgInt)
+  -> String
+  -> String
+  -> IR.PrlgInt
+  -> PrlgEnv IR.PrlgInt
+expansion noexpand expander output x = do
+  es <- findStruct expander 2
+  o <- findAtom output
+  comma <- findAtom ","
+  expand <- gets (M.member es . defs)
+  pure $
+    if expand
+      then IR.CallI
+             comma
+             [ IR.CallI (IR.str es) [x, IR.VarI (-1) 0]
+             , IR.CallI o [IR.VarI (-1) 0]
+             ]
+      else noexpand o x
+
+queryExpansion = expansion (\_ -> id) "query_expansion" "call"
+
+loadExpansion = expansion (\o x -> IR.CallI o [x]) "load_expansion" "assert"
+
+processInput fn queryMode input = do
+  asts <- except $ tokenize fn input >>= parse fn
+  lift . modify $ \s -> s {cmdq = [(queryMode, ast) | ast <- asts]}