some small stuff

1 files changed, 73 insertions, 0 deletions

diff --git a/app/Parser.hs b/app/Parser.hs
new file mode 100644
index 0000000..d43dce2
--- /dev/null
+++ b/app/Parser.hs
@@ -0,0 +1,73 @@
+module Parser where
+
+import Control.Applicative (liftA2)
+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)
+
+specialOp = (`elem` ",;|")
+
+specialChar = (`elem` "()[]")
+
+specialName = (`elem` "_")
+
+specialUnused = (`elem` "\'%")
+
+type Lexer = Parsec Void String
+
+data Lexeme
+  = Blank String
+  | Tok String
+  | QTok String String -- unquoted quoted
+  | Cmt String
+  deriving (Show)
+
+blank :: Lexer Lexeme
+blank = Blank <$> some (satisfy isSpace)
+
+tok :: Lexer Lexeme
+tok =
+  Tok <$>
+  choice
+    [ pure <$> satisfy specialOp
+    , pure <$> satisfy specialChar
+    , some $
+      satisfy $ \x ->
+        all
+          ($ x)
+          [ not . specialOp
+          , not . specialChar
+          , not . specialUnused
+          , not . specialName
+          , liftA2 (||) isSymbol isPunctuation
+          ]
+    , (:) <$> satisfy (\x -> any ($ x) [specialName, isAlpha]) <*>
+      many (satisfy $ \x -> any ($ x) [specialName, isAlphaNum, isMark])
+    ]
+
+qtok :: Lexer Lexeme
+qtok = do
+  x <- string "'"
+  y <- many $ satisfy (/= '\'')
+  z <- string "'"
+  return $ QTok y (x ++ y ++ z)
+
+cmt :: Lexer Lexeme
+cmt =
+  Cmt . 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