From 60f5eb274cb3dc8d8a28942ada97763bcc0c8f9f Mon Sep 17 00:00:00 2001
From: Mirek Kratochvil <exa.exa@gmail.com>
Date: Mon, 17 Oct 2022 22:01:56 +0200
Subject: [PATCH] actually parse

---
 app/Parser.hs | 91 ++++++++++++++++++++++++++++++++++++++++++++-------
 1 file changed, 80 insertions(+), 11 deletions(-)

diff --git a/app/Parser.hs b/app/Parser.hs
index d43dce2..2e7020c 100644
--- a/app/Parser.hs
+++ b/app/Parser.hs
@@ -1,17 +1,13 @@
 module Parser where
 
 import Control.Applicative (liftA2)
+import Control.Monad (void)
 import Data.Char
 import Data.Void
 import Text.Megaparsec
 import Text.Megaparsec.Char
 
-data AST
-  = Call String [AST]
-  | Seq [AST]
-  | List [AST] (Maybe AST)
-  | Literal String
-  deriving (Show)
+import Compiler (PrlgStr (..))
 
 specialOp = (`elem` ",;|")
 
@@ -27,8 +23,7 @@ data Lexeme
   = Blank String
   | Tok String
   | QTok String String -- unquoted quoted
-  | Cmt String
-  deriving (Show)
+  deriving (Show, Eq, Ord)
 
 blank :: Lexer Lexeme
 blank = Blank <$> some (satisfy isSpace)
@@ -51,6 +46,7 @@ tok =
           ]
     , (:) <$> satisfy (\x -> any ($ x) [specialName, isAlpha]) <*>
       many (satisfy $ \x -> any ($ x) [specialName, isAlphaNum, isMark])
+    , some (satisfy isNumber)
     ]
 
 qtok :: Lexer Lexeme
@@ -62,12 +58,85 @@ qtok = do
 
 cmt :: Lexer Lexeme
 cmt =
-  Cmt . concat <$>
+  Blank . concat <$>
   sequence
     [string "%", many $ satisfy (/= '\n'), choice [string "\n", "" <$ eof]]
 
 lexeme :: Lexer Lexeme
 lexeme = choice [blank, tok, qtok, cmt]
 
-lex :: Lexer [Lexeme]
-lex = many lexeme <* eof
+lexPrlg :: Lexer [Lexeme]
+lexPrlg = many lexeme <* (many blank >> eof)
+
+data AST
+  = Call String [AST]
+  | Seq [AST]
+  | List [AST] (Maybe [AST])
+  | Literal String
+  deriving (Show)
+
+type Parser = Parsec Void [Lexeme]
+
+isBlank (Blank _) = True
+isBlank _ = False
+
+ws = many $ satisfy isBlank
+
+free = (ws >>)
+
+isNormalTokStr = (`notElem` [".", "[", "]", "(", "|", ")"])
+
+isNormalTok (Tok x) = isNormalTokStr x
+isNormalTok (QTok x _) = isNormalTokStr x
+isNormalTok _ = False
+
+unTok (Tok t) = t
+unTok (QTok t _) = t
+
+literal :: Parser AST
+literal = Literal . unTok <$> (satisfy isNormalTok <* notFollowedBy lParen)
+
+call = do
+  fn <- unTok <$> satisfy isNormalTok
+  Seq inner <- parens -- not free!
+  return $ Call fn inner
+
+parens = Seq <$> (lParen *> some seqItem <* free rParen)
+
+list = do
+  lBracket
+  choice
+    [ List [] Nothing <$ free rBracket
+    , do items <- some seqItem
+         choice
+           [ List items Nothing <$ free rBracket
+           , List items . Just <$>
+             (free listTail *> some seqItem <* free rBracket)
+           ]
+    ]
+
+seqItem = free $ choice [try call, literal, parens, list]
+
+simpleTok :: String -> Parser ()
+simpleTok s = void $ single (Tok s)
+
+comma = simpleTok "."
+
+lParen = simpleTok "("
+
+rParen = simpleTok ")"
+
+lBracket = simpleTok "["
+
+listTail = simpleTok "|"
+
+rBracket = simpleTok "]"
+
+clause :: Parser AST
+clause = Seq <$> some seqItem <* free comma
+
+parsePrlg :: Parser [AST]
+parsePrlg = many clause <* free eof
+
+operatorize :: [AST] -> [PrlgStr]
+operatorize = undefined