Extract common parsing code

code/cs325-langs/src/CommonParsing.hs

@@ -0,0 +1,66 @@
+module CommonParsing where
+import Data.Char
+import Data.Functor
+import Text.Parsec
+import Text.Parsec.Char
+import Text.Parsec.Combinator
+
+type Parser a b = Parsec String a b
+
+kw :: String -> Parser a ()
+kw s = string s $> ()
+
+kwIf :: Parser a ()
+kwIf = kw "if"
+
+kwThen :: Parser a ()
+kwThen = kw "then"
+
+kwElse :: Parser a ()
+kwElse = kw "else"
+
+kwState :: Parser a ()
+kwState = kw "state"
+
+kwEffect :: Parser a ()
+kwEffect = kw "effect"
+
+kwCombine :: Parser a ()
+kwCombine = kw "combine"
+
+kwRand :: Parser a ()
+kwRand = kw "rand"
+
+op :: String -> op -> Parser a op
+op s o = string s $> o
+
+int :: Parser a Int
+int = read <$> (many1 digit <* spaces)
+
+var :: [String] -> Parser a String
+var reserved =
+    do
+        c <- satisfy $ \c -> isLetter c || c == '_'
+        cs <- many (satisfy isLetter <|> digit) <* spaces
+        let name = c:cs
+        if name `elem` reserved
+        then fail "Can't use reserved keyword as identifier"
+        else return name
+
+surround :: Char -> Char -> Parser a b -> Parser a b
+surround c1 c2 pe =
+    do
+        char c1 >> spaces
+        e <- pe
+        spaces >> char c2 >> spaces
+        return e
+
+level :: (o -> e -> e -> e) -> Parser a o -> Parser a e -> Parser a e
+level c po pe =
+    do
+        e <- pe <* spaces
+        ops <- many $ try $ (flip . c <$> (po <* spaces) <*> pe) <* spaces
+        return $ foldl (flip ($)) e ops
+
+precedence :: (o -> e -> e -> e) -> Parser a e -> [ Parser a o ] -> Parser a e
+precedence = foldl . flip . level

code/cs325-langs/src/LanguageOne.hs

@@ -1,5 +1,6 @@
 module LanguageOne where
 import qualified PythonAst as Py
+import qualified CommonParsing as P
 import Data.Bifunctor
 import Data.Char
 import Data.Functor
@@ -54,31 +55,8 @@ data Prog = Prog [Function]
 {- Parser -}
 type Parser = Parsec String (Maybe Int)
 
-parseInt :: Parser Int
-parseInt = read <$> (many1 digit <* spaces)
-
 parseVar :: Parser String
-parseVar =
-    do
-        c <- satisfy (\c -> (isLetter c && isLower c) || c == '_')
-        cs <- many (satisfy isLetter <|> digit)
-        spaces
-        let var = c:cs
-        if var `elem` ["if", "then", "else", "rand"]
-        then fail "reserved"
-        else return var
-
-parseKwIf :: Parser ()
-parseKwIf = string "if" $> ()
-
-parseKwThen :: Parser ()
-parseKwThen = string "then" $> ()
-
-parseKwElse :: Parser ()
-parseKwElse = string "else" $> ()
-
-parseKwRand :: Parser Expr
-parseKwRand = string "rand" $> Random
+parseVar = P.var ["if", "then", "else", "var"]
 
 parseThis :: Parser Expr
 parseThis =
@@ -127,11 +105,11 @@ parseSelector =
 parseIfElse :: Parser Expr
 parseIfElse =
     do
-        parseKwIf >> spaces
+        P.kwIf >> spaces
         ec <- parseExpr
-        spaces >> parseKwThen >> spaces
+        spaces >> P.kwThen >> spaces
         et <- parseExpr
-        spaces >> parseKwElse >> spaces
+        spaces >> P.kwElse >> spaces
         ee <- parseExpr
         spaces
         return $ IfElse ec et ee
@@ -162,7 +140,7 @@ parseParenthesized =
 
 parseBasicExpr :: Parser Expr
 parseBasicExpr = choice
-    [ IntLiteral <$> parseInt
+    [ IntLiteral <$> P.int
     , parseThis
     , parseList
     , parseSplit
@@ -170,7 +148,7 @@ parseBasicExpr = choice
     , parseParameter
     , parseParenthesized
     , Var <$> try parseVar
-    , parseKwRand
+    , P.kwRand $> Random
     , parseIfElse
     ] 
 
@@ -203,33 +181,16 @@ parsePostfixedExpr =
         ps <- many parsePostfix
         return $ foldl (flip ($)) eb ps
 
-parseOp :: String -> Op -> Parser Op
-parseOp s o = try (string s) >> return o
-
-parseLevel :: Parser Expr -> Parser Op -> Parser Expr
-parseLevel pe po =
-    do
-        start <- pe
-        spaces
-        ops <- many $ try $ do
-            op <- po
-            spaces
-            val <- pe
-            spaces
-            return (op, val)
-        spaces
-        return $ foldl (\l (o, r) -> BinOp o l r) start ops
-
 parseExpr :: Parser Expr
-parseExpr = foldl parseLevel parsePostfixedExpr
-    [ parseOp "*" Multiply, parseOp "/" Divide
-    , parseOp "+" Add, parseOp "-" Subtract
-    , parseOp "<<" Insert
-    , parseOp "++" Concat
-    , parseOp "<=" LessThanEq <|> parseOp ">=" GreaterThanEq <|>
-        parseOp "<" LessThan <|> parseOp ">" GreaterThan <|>
-        parseOp "==" Equal <|> parseOp "!=" NotEqual
-    , parseOp "&&" And <|> parseOp "||" Or
+parseExpr = P.precedence BinOp parsePostfixedExpr
+    [ P.op "*" Multiply, P.op "/" Divide
+    , P.op "+" Add, P.op "-" Subtract
+    , P.op "<<" Insert
+    , P.op "++" Concat
+    , try (P.op "<=" LessThanEq) <|> try (P.op ">=" GreaterThanEq) <|>
+        P.op "<" LessThan <|> P.op ">" GreaterThan <|>
+        P.op "==" Equal <|> P.op "!=" NotEqual
+    , P.op "&&" And <|> P.op "||" Or
     ]
 
 parseFunction :: Parser Function

code/cs325-langs/src/LanguageTwo.hs

@@ -1,5 +1,6 @@
 module LanguageTwo where
 import qualified PythonAst as Py
+import qualified CommonParsing as P
 import Data.Char
 import Data.Functor
 import Text.Parsec
@@ -33,95 +34,50 @@ data Prog = Prog Expr [Stmt] [Stmt]
 {- Parser -}
 type Parser = Parsec String ()
 
-parseKw :: String -> Parser ()
-parseKw s = string s $> ()
-
-parseKwIf :: Parser ()
-parseKwIf = parseKw "if"
-
-parseKwElse :: Parser ()
-parseKwElse = parseKw "else"
-
-parseKwState :: Parser ()
-parseKwState = parseKw "state"
-
-parseKwEffect :: Parser ()
-parseKwEffect = parseKw "effect"
-
-parseKwCombine :: Parser ()
-parseKwCombine = parseKw "combine"
-
-parseOp :: String -> Op -> Parser Op
-parseOp s o = string s $> o
-
-parseInt :: Parser Int
-parseInt = read <$> (many1 digit <* spaces)
-
 parseVar :: Parser String
-parseVar =
-    do
-        c <- satisfy $ \c -> isLetter c || c == '_'
-        cs <- many (satisfy isLetter <|> digit) <* spaces
-        let name = c:cs
-        if name `elem` ["if", "else", "state", "effect", "combine"]
-        then fail "Can't use reserved keyword as identifier"
-        else return name
-
-parseSurrounded :: Char -> Char -> Parser a -> Parser a
-parseSurrounded c1 c2 pe =
-    do
-        char c1 >> spaces
-        e <- pe
-        spaces >> char c2 >> spaces
-        return e
+parseVar = P.var [ "if", "else", "state", "effect", "combine" ]
 
 parseLength :: Parser Expr
-parseLength = Length <$> parseSurrounded '|' '|' parseExpr
+parseLength = Length <$> P.surround '|' '|' parseExpr
 
 parseParenthesized :: Parser Expr
-parseParenthesized = parseSurrounded '(' ')' parseExpr
+parseParenthesized = P.surround '(' ')' parseExpr
 
 parseBasic :: Parser Expr
 parseBasic = choice
-    [ IntLiteral <$> parseInt
+    [ IntLiteral <$> P.int
     , Var <$> parseVar
     , parseLength
     , parseParenthesized
     ]
 
-parseLevel :: Parser Op -> Parser Expr -> Parser Expr
-parseLevel po pe =
-    do
-        e <- pe <* spaces
-        ops <- many ((flip . BinOp <$> (po <* spaces) <*> pe) <* spaces)
-        return $ foldl (flip ($)) e ops
 
 parseExpr :: Parser Expr
-parseExpr = foldl (flip parseLevel) parseBasic
-    [ parseOp "*" Multiply <|> parseOp "/" Divide
-    , parseOp "+" Add <|> parseOp "-" Subtract
-    , parseOp "==" Equal <|> parseOp "!=" NotEqual
-    , parseOp "&&" And
-    , try $ parseOp "||" Or
+parseExpr = P.precedence BinOp parseBasic
+    [ P.op "*" Multiply <|> P.op "/" Divide
+    , P.op "+" Add <|> P.op "-" Subtract
+    , P.op "==" Equal <|> P.op "!=" NotEqual
+    , P.op "&&" And
+    , try $ P.op "||" Or
     ]
 
 parseIf :: Parser Stmt
 parseIf = do
-    parseKwIf >> spaces
+    P.kwIf >> spaces
     c <- parseParenthesized
     t <- parseStmt <* spaces
-    e <- (Just <$> (parseKwElse >> spaces *> parseStmt)) <|> return Nothing
+    e <- (Just <$> (P.kwElse >> spaces *> parseStmt)) <|> return Nothing
     return $ IfElse c t e
 
 parseBlockStmts :: Parser [Stmt]
-parseBlockStmts = parseSurrounded '{' '}' (many parseStmt)
+parseBlockStmts = P.surround '{' '}' (many parseStmt)
 
 parseBlock :: Parser Stmt
 parseBlock = Block <$> parseBlockStmts
 
 parseAssign :: Parser Stmt
 parseAssign = Assign <$>
-    (parseVar <* spaces <* char '=' <* spaces) <*>
+    (parseVar <* char '=' <* spaces) <*>
     parseExpr <* (char ';' >> spaces)
 
 parseStmt :: Parser Stmt
@@ -133,9 +89,9 @@ parseStmt = choice
 
 parseProgram :: Parser Prog
 parseProgram = do
-    state <- parseKwState >> spaces *> parseExpr <* char ';' <* spaces
-    effect <- parseKwEffect >> spaces *> parseBlockStmts <* spaces
-    combined <- parseKwCombine >> spaces *> parseBlockStmts <* spaces
+    state <- P.kwState >> spaces *> parseExpr <* char ';' <* spaces
+    effect <- P.kwEffect >> spaces *> parseBlockStmts <* spaces
+    combined <- P.kwCombine >> spaces *> parseBlockStmts <* spaces
     return $ Prog state effect combined
 
 parse :: String -> String -> Either ParseError Prog