From bc52411ae2ed26cab1d5086ae6df68f23ebbd052 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom.smeding@gmail.com>
Date: Wed, 10 Jun 2020 19:59:03 +0200
Subject: Initial state I found the code in

---
 parser/CC/Parser.hs | 114 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 114 insertions(+)
 create mode 100644 parser/CC/Parser.hs

(limited to 'parser/CC')

diff --git a/parser/CC/Parser.hs b/parser/CC/Parser.hs
new file mode 100644
index 0000000..0088956
--- /dev/null
+++ b/parser/CC/Parser.hs
@@ -0,0 +1,114 @@
+module CC.Parser(runPass, parseProgram) where
+
+import Control.Monad
+import Text.Parsec hiding (State, SourcePos, getPosition, token)
+import qualified Text.Parsec
+
+import CC.Source
+
+
+type Parser a = Parsec String State a
+type State = Int  -- base indentation level; hanging lines should be > this
+
+runPass :: Context -> RawString -> Either ParseError Program
+runPass (Context path) (RawString src) = parseProgram path src
+
+parseProgram :: FilePath -> String -> Either ParseError Program
+parseProgram fname src = runParser pProgram 0 fname src
+
+pProgram :: Parser Program
+pProgram = do
+    prog <- Program <$> many pDecl
+    emptyLines
+    eof
+    return prog
+
+pDecl :: Parser Decl
+pDecl = Def <$> pDef
+
+pDef :: Parser Def
+pDef = do
+    func <- try $ do
+        emptyLines
+        putState 0
+        name <- pName0 <?> "declaration head name"
+        return name
+    mtyp <- optionMaybe $ do
+        symbol "::"
+        typ <- pType
+        whitespace >> void newline
+        emptyLines
+        func' <- fst <$> pName0
+        guard (fst func == func')
+        return typ
+    args <- many pName
+    symbol "="
+    expr <- pExpr
+    return (Function mtyp func args expr)
+
+pType :: Parser Type
+pType = chainr1 pTypeAtom (symbol "->" >> return TFun)
+
+pTypeAtom :: Parser Type
+pTypeAtom = (wordToken "Int" >> return TInt) <|> between (token "(") (token ")") pType
+
+pExpr :: Parser Expr
+pExpr = lab "expression" $ do
+    atoms <- many1 pExprAtom
+    return (foldl1 (\a b -> Call (mergeRange (range a) (range b)) a b) atoms)
+
+pExprAtom :: Parser Expr
+pExprAtom =
+    choice [ uncurry (flip Int) <$> pInt
+           , uncurry (flip Var) <$> pName
+           , between (token "(") (token ")") pExpr ]
+
+pInt :: Parser (Int, SourceRange)
+pInt = try (whitespace >> pInt0)
+  where
+    pInt0 = do
+        p1 <- getPosition
+        num <- read <$> many1 digit
+        p2 <- getPosition
+        return (num, SourceRange p1 p2)
+
+pName0 :: Parser (Name, SourceRange)
+pName0 = do
+    p1 <- getPosition
+    c <- pWordFirstChar
+    cs <- many pWordMidChar
+    p2 <- getPosition
+    notFollowedBy pWordMidChar
+    return (c : cs, SourceRange p1 p2)
+
+pWordFirstChar :: Parser Char
+pWordFirstChar = letter <|> oneOf "_$#!"
+
+pWordMidChar :: Parser Char
+pWordMidChar = alphaNum <|> oneOf "_$#!"
+
+pName :: Parser (Name, SourceRange)
+pName = try (whitespace >> pName0)
+
+symbol :: String -> Parser ()
+symbol s = token s >> (eof <|> void space <|> void (oneOf "(){}[]"))
+
+wordToken :: String -> Parser ()
+wordToken s = token s >> notFollowedBy pWordMidChar
+
+token :: String -> Parser ()
+token s = try (whitespace >> void (string s))
+
+emptyLines :: Parser ()
+emptyLines = (try (whitespace >> newline) >> emptyLines) <|> try (whitespace >> eof) <|> return ()
+
+whitespace :: Parser ()
+whitespace = void (many (char ' '))
+
+lab :: String -> Parser a -> Parser a
+lab = flip label
+
+getPosition :: Parser SourcePos
+getPosition = do
+    pos <- Text.Parsec.getPosition
+    return (SourcePos (sourceLine pos) (sourceColumn pos))
-- 
cgit v1.2.3-70-g09d2