this.

1 files changed, 52 insertions, 2 deletions

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 -}