1 files changed, 93 insertions, 0 deletions
diff --git a/Parser.hs b/Parser.hs
new file mode 100644
index 0000000..93d457c
--- /dev/null
+++ b/Parser.hs
@@ -0,0 +1,93 @@
+module Parser(parseProgram, parseExpression) where
+
+import Control.Monad
+import Control.Monad.Trans
+import Data.Char
+import Text.Parsec
+import Text.Parsec.Pos
+
+import AST
+
+
+type Parser = ParsecT String () IO
+
+
+parseProgram :: String -> IO (Either ParseError Program)
+parseProgram = runParserT pProgram () ""
+
+pProgram :: Parser Program
+pProgram = between pWhiteComment eof (liftM Program (many pValue))
+
+
+parseExpression :: String -> IO (Either ParseError Value)
+parseExpression = runParserT pExpression () ""
+
+pExpression :: Parser Value
+pExpression = between pWhiteComment eof pValue
+
+
+pValue :: Parser Value
+pValue = pPPC <|> pVEllipsis <|> pVList <|> pVNum <|> pVString <|> pVName <|> pVQuoted  <?> "value"
+
+pVList :: Parser Value
+pVList = flip label "list" $ do
+    symbol "("
+    exs <- many pValue
+    symbol ")"
+    return $ VList exs
+
+pVNum :: Parser Value
+pVNum = liftM (VNum . read) (many1 digit) <* pWhiteComment  <?> "number"
+
+pVString :: Parser Value
+pVString = fmap VString pString
+
+pVName :: Parser Value
+pVName = flip label "name" $ do
+    first <- satisfy isFirstNameChar
+    rest <- many (satisfy isNameChar)
+    pWhiteComment
+    return $ VName $ first : rest
+  where
+    isNameChar c = ((c >= '*' && c <= 'z') || c `elem` "!$%&|~") && c /= ';'
+    isFirstNameChar c = isNameChar c && not (isDigit c)
+
+pVQuoted :: Parser Value
+pVQuoted = char '\'' >> liftM VQuoted pValue  <?> "quoted value"
+
+pVEllipsis :: Parser Value
+pVEllipsis = symbol "..." >> return VEllipsis  <?> "ellipsis"
+
+pPPC :: Parser Value
+pPPC = flip label "preprocessor command" $ do
+    symbol "#include"
+    fname <- pString
+    src <- liftIO $ readFile fname
+    stateBackup <- getParserState
+    void $ setParserState (State ("(do " ++ src ++ ")") (initialPos fname) ())
+    result <- pValue <* eof
+    void $ setParserState stateBackup
+    return result
+
+
+symbol :: String -> Parser ()
+symbol s = try (string s) >> pWhiteComment
+
+pString :: Parser String
+pString = flip label "string" $ do
+    void $ char '"'
+    s <- manyTill anyChar (symbol "\"")
+    return s
+
+pWhiteComment :: Parser ()
+pWhiteComment = do
+    pWhitespace
+    void $ many $ pComment >> pWhitespace
+  where
+    pWhitespace :: Parser ()
+    pWhitespace = void (many space)  <?> "whitespace"
+
+    pComment :: Parser ()
+    pComment = flip label "comment" $ do
+        void $ char ';'
+        void (manyTill anyChar (void endOfLine <|> eof))