From 14b77cd058ad3780d73df8bb41be946599150d18 Mon Sep 17 00:00:00 2001
From: Mirek Kratochvil <exa.exa@gmail.com>
Date: Mon, 24 Oct 2022 23:43:35 +0200
Subject: [PATCH] this.

---
 app/Main.hs   | 59 ++++++++++++++++++++++++++++-----------------------
 app/Parser.hs | 54 ++++++++++++++++++++++++++++++++++++++++++++--
 2 files changed, 84 insertions(+), 29 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 5b9ed07..88b1782 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,7 +1,12 @@
 module Main where
 
+import qualified Compiler as C
+import Control.Monad.IO.Class
 import qualified Data.Map as M
-import Interpreter
+import qualified Interpreter as I
+import qualified Parser as P
+import System.Console.Haskeline
+import qualified Text.Megaparsec as MP
 import Text.Pretty.Simple
 
 ppr :: Show a => a -> IO ()
@@ -14,30 +19,30 @@ ppr =
       , outputOptionsPageWidth = 80
       }
 
-main :: IO ()
-main = do
-  let (res, interp) =
-        prove [Goal, U (Struct $ Id 1 2), U (Atom 1), U (Atom 2), LastCall] $
-        M.fromList
-          [ ( Id 1 2
-            , [ [U (Atom 333), U (Atom 444), NoGoal]
-              , [ U (Atom 1)
-                , U (Atom 2)
-                , Goal
-                , U (Struct $ Id 2 0)
-                , Call
-                , Goal
-                , U (Struct $ Id 1 2)
-                , U (Atom 333)
-                , U (Atom 444)
-                , LastCall
-                ]
-              ])
-          , (Id 2 0, [[NoGoal]])
-          ]
-  ppr interp
-  ppr res
+interpret :: String -> InputT IO ()
+interpret = liftIO . lex
+  where
+    lex input =
+      case MP.parse P.lexPrlg "-" input of
+        Left bundle -> putStr (MP.errorBundlePretty bundle)
+        Right toks -> parse toks
+    parse toks =
+      case MP.parse P.parsePrlg "-" toks of
+        Left bundle -> putStr (MP.errorBundlePretty bundle)
+        Right ast -> prologize ast
+    prologize ast = ppr $ map (P.ast2prlg P.defaultOps) ast
 
-{-
-ppr $ let { Right l = parse lexPrlg "stdin" "c(cc(X)) :- a, b. " ; Right p = parse parsePrlg "stdin" l; clause:_ = map (ast2prlg defaultOps) p; ((StrTable _ strfwd strback),codei) = strtablizePrlg emptystrtable clause } in compileRule (Id (strfwd M.! ":-") 2) (Id (strfwd M.! ",") 2) codei
- -}
+main :: IO ()
+main =
+  runInputT defaultSettings $ do
+    outputStrLn "PRLG."
+    loop
+  where
+    loop :: InputT IO ()
+    loop = do
+      minput <- getInputLine "|= "
+      case minput of
+        Nothing -> return ()
+        Just input -> do
+          interpret input
+          loop
diff --git a/app/Parser.hs b/app/Parser.hs
index 8e6a258..dcdc347 100644
--- a/app/Parser.hs
+++ b/app/Parser.hs
@@ -1,14 +1,19 @@
+{-# LANGUAGE FlexibleInstances #-}
+
 module Parser where
 
 import Control.Applicative (liftA2)
 import Control.Monad (void)
 import Data.Char
+import Data.List (intercalate)
+import Data.List.NonEmpty (NonEmpty(..))
 import Data.List.Split (splitOn)
 import Data.Void
 import Text.Megaparsec
 import Text.Megaparsec.Char
 
 import Compiler (PrlgStr(..))
+import Debug.Trace
 
 singleToks = ",;|()[]"
 
@@ -63,6 +68,51 @@ lexeme = choice [blank, tok, qtok, cmt]
 lexPrlg :: Lexer [Lexeme]
 lexPrlg = many lexeme <* (many blank >> eof)
 
+showTok (Blank x) = x
+showTok (Tok x) = x
+showTok (QTok _ x) = x
+
+instance VisualStream [Lexeme] where
+  showTokens _ (a :| b) = concatMap showTok (a : b)
+  tokensLength _ (a :| b) = sum $ map (length . showTok) (a : b)
+
+instance TraversableStream [Lexeme] where
+  reachOffset o pst = go
+    where
+      handleEmpty "" = "<empty line>"
+      handleEmpty x = x
+      go
+        | o <= pstateOffset pst =
+          ( Just . handleEmpty $ pstateLinePrefix pst ++
+            takeWhile (/= '\n') (concatMap showTok $ pstateInput pst)
+          , pst)
+        | o > pstateOffset pst =
+          let (tok:rest) = pstateInput pst
+              stok = showTok tok
+              lines = splitOn "\n" stok
+              nls = length lines - 1
+              sp = pstateSourcePos pst
+           in reachOffset
+                o
+                pst
+                  { pstateInput = rest
+                  , pstateOffset = pstateOffset pst + 1
+                  , pstateLinePrefix =
+                      if nls > 0
+                        then last lines
+                        else pstateLinePrefix pst ++ last lines
+                  , pstateSourcePos =
+                      sp
+                        { sourceLine = mkPos $ unPos (sourceLine sp) + nls
+                        , sourceColumn =
+                            mkPos $
+                            (if nls > 0
+                               then 1
+                               else unPos (sourceColumn sp)) +
+                            length (last lines)
+                        }
+                  }
+
 data AST
   = Call String [[AST]]
   | Seq [AST]
@@ -196,7 +246,7 @@ shunt optable = start
       | Just _ <- getPrefix x
       , Just (ops', vs') <- pushPrefix ops vs x = wo ops' vs' xs
       | isOperand x = ho ops (rec l : vs) xs
-      | otherwise = error $ "want valid operand " ++ show (ops,vs,l,xs)
+      | otherwise = error $ "want valid operand"
     {- incoming non-literal (i.e., surely operand), push it and switch to "have operand" -}
     wo ops vs (x:xs) = ho ops (rec x : vs) xs
     {- end of stream, but the operand is missing -}
@@ -236,8 +286,8 @@ shunt optable = start
     {- actual pushery -}
     canPush [] op = Just True
     canPush ((_, Op p f):ops) (Op np nf) = go p f np nf
-      where
         {- helper -}
+      where
         prioLtOp X = (<)
         prioLtOp Y = (<=)
         {- pushing a prefix -}