<commit_before>module L2.Parser where

import Control.Monad (liftM)
import Text.ParserCombinators.Parsec hiding (State)
import Text.Parsec.Prim (parserFail)

import L2.Grammar


{- Skip 1 or more spaces -}
spaces1 :: Parser ()
spaces1 = skipMany1 space

{- Liveness parser -}
parseLiveness :: Parser [L2Instruction]
parseLiveness = do
    whitespaceOrComment
    m <- parseMain
    return m

{- Spill parsers -}
parseSpill :: Parser L2Spill
parseSpill = do
    whitespaceOrComment
    body <- parseMain
    whitespaceOrComment
    var <- parseVar
    whitespaceOrComment
    offset <- parseNumber
    whitespaceOrComment
    spillPrefix <- parseVar
    return $ L2Spill body var offset spillPrefix


{- Regular L2 parsers -}
readProg :: String -> L2Program
readProg input = case parse parseProg "lisp" input of
    Left err -> L2Program [] []
    Right prog -> prog

readInstrList :: String -> [L2Instruction]
readInstrList input = case parse parseMain "lisp" input of
    Left err -> error $ show err
    Right m -> m

readInstruction :: String -> L2Instruction
readInstruction input = case parse parseInstruction "lisp" input of
    Left err -> error $ show err
    Right instr -> instr

parseProg :: Parser L2Program
parseProg = do
    whitespaceOrComment
    char '('
    whitespaceOrComment
    main <- parseMain
    whitespaceOrComment
    funs <- parseFunctions
    whitespaceOrComment
    char ')'
    return $ L2Program main funs


parseMain :: Parser [L2Instruction]
parseMain = do
    char '('
    whitespaceOrComment
    ls <- parseInstructions
    whitespaceOrComment
    char ')'
    return ls

parseFunctions :: Parser [L2Function]
parseFunctions = do
    fs <- sepBy parseFunction whitespaceOrComment
    return fs

parseFunction :: Parser L2Function
parseFunction = do
    char '('
    name <- parseLabel
    whitespaceOrComment
    ls <- parseInstructions
    whitespaceOrComment
    char ')'
    return $ L2Function name ls

parseInstructions :: Parser [L2Instruction]
parseInstructions = do
    ls <- sepEndBy parseInstruction whitespaceOrComment
    return ls

whitespaceOrComment :: Parser ()
whitespaceOrComment = do
    spaces
    c <- lookAhead anyChar
    case c of
        ';' -> skipComment
        '\n' -> char '\n' >> whitespaceOrComment
        otherwise -> return ()

skipComment :: Parser ()
skipComment = do
    char ';'
    skipMany (noneOf "\n")
    char '\n'
    whitespaceOrComment

parseInstruction :: Parser L2Instruction
parseInstruction = (liftM L2ILab parseLabel) <|> do
    char '('
    whitespaceOrComment
    instr <- (try parseCall)
         <|> (try parseCjump)
         <|> (try parseTailCall)
         <|> (try parseReturn)
         <|> (try parseGoto)
         <|> parseUpdate
         <|> parseRegOp
    whitespaceOrComment
    char ')'
    return instr


parseCall :: Parser L2Instruction
parseCall = do
    string "call"
    whitespaceOrComment
    (liftM L2Call parseU)

parseCjump :: Parser L2Instruction
parseCjump = do
    string "cjump"
    whitespaceOrComment
    t1 <- parseT
    whitespaceOrComment
    cmp <- parseCMP
    whitespaceOrComment
    t2 <- parseT
    whitespaceOrComment
    l1 <- parseLabel
    whitespaceOrComment
    l2 <- parseLabel
    return $ L2Cjump t1 cmp t2 l1 l2

parseTailCall :: Parser L2Instruction
parseTailCall = do
    string "tail-call"
    whitespaceOrComment
    (liftM L2TailCall parseU)

parseReturn :: Parser L2Instruction
parseReturn = do
    string "return"
    return L2Return

parseGoto :: Parser L2Instruction
parseGoto = do
    string "goto"
    whitespaceOrComment
    (liftM L2Goto parseLabel)

parseUpdate :: Parser L2Instruction
parseUpdate = do
    string "(mem"
    whitespaceOrComment
    x <- parseX
    whitespaceOrComment
    n <- parseNumber
    char ')'
    whitespaceOrComment
    string "<-"
    whitespaceOrComment
    s <- parseS
    return $ L2Update x n s

parseRegOp :: Parser L2Instruction
parseRegOp = do
    x <- parseX
    whitespaceOrComment
    op <- many1 (noneOf " ;)(")
    whitespaceOrComment
    case op of
        "<-" -> parseArrow x
        "+=" -> parseArith x L2Add
        "-=" -> parseArith x L2Sub
        "*=" -> parseArith x L2Mult
        "&=" -> parseArith x L2And
        "<<=" -> parseShift x L2ShiftLeft
        ">>=" -> parseShift x L2ShiftRight

parseArrow :: L2X -> Parser L2Instruction
parseArrow x = parseArrowParen x
           <|> try (parseSaveCmp x)
           <|> parseAssign x
<commit_msg>Less permissive reg op parse<commit_after>module L2.Parser where

import Control.Monad (liftM)
import Text.ParserCombinators.Parsec hiding (State)
import Text.Parsec.Prim (parserFail)

import L2.Grammar


{- Skip 1 or more spaces -}
spaces1 :: Parser ()
spaces1 = skipMany1 space

{- Liveness parser -}
parseLiveness :: Parser [L2Instruction]
parseLiveness = do
    whitespaceOrComment
    m <- parseMain
    return m

{- Spill parsers -}
parseSpill :: Parser L2Spill
parseSpill = do
    whitespaceOrComment
    body <- parseMain
    whitespaceOrComment
    var <- parseVar
    whitespaceOrComment
    offset <- parseNumber
    whitespaceOrComment
    spillPrefix <- parseVar
    return $ L2Spill body var offset spillPrefix


{- Regular L2 parsers -}
readProg :: String -> L2Program
readProg input = case parse parseProg "lisp" input of
    Left err -> L2Program [] []
    Right prog -> prog

readInstrList :: String -> [L2Instruction]
readInstrList input = case parse parseMain "lisp" input of
    Left err -> error $ show err
    Right m -> m

readInstruction :: String -> L2Instruction
readInstruction input = case parse parseInstruction "lisp" input of
    Left err -> error $ show err
    Right instr -> instr

parseProg :: Parser L2Program
parseProg = do
    whitespaceOrComment
    char '('
    whitespaceOrComment
    main <- parseMain
    whitespaceOrComment
    funs <- parseFunctions
    whitespaceOrComment
    char ')'
    return $ L2Program main funs


parseMain :: Parser [L2Instruction]
parseMain = do
    char '('
    whitespaceOrComment
    ls <- parseInstructions
    whitespaceOrComment
    char ')'
    return ls

parseFunctions :: Parser [L2Function]
parseFunctions = do
    fs <- sepBy parseFunction whitespaceOrComment
    return fs

parseFunction :: Parser L2Function
parseFunction = do
    char '('
    name <- parseLabel
    whitespaceOrComment
    ls <- parseInstructions
    whitespaceOrComment
    char ')'
    return $ L2Function name ls

parseInstructions :: Parser [L2Instruction]
parseInstructions = do
    ls <- sepEndBy parseInstruction whitespaceOrComment
    return ls

whitespaceOrComment :: Parser ()
whitespaceOrComment = do
    spaces
    c <- lookAhead anyChar
    case c of
        ';' -> skipComment
        '\n' -> char '\n' >> whitespaceOrComment
        otherwise -> return ()

skipComment :: Parser ()
skipComment = do
    char ';'
    skipMany (noneOf "\n")
    char '\n'
    whitespaceOrComment

parseInstruction :: Parser L2Instruction
parseInstruction = (liftM L2ILab parseLabel) <|> do
    char '('
    whitespaceOrComment
    instr <- (try parseCall)
         <|> (try parseCjump)
         <|> (try parseTailCall)
         <|> (try parseReturn)
         <|> (try parseGoto)
         <|> parseUpdate
         <|> parseRegOp
    whitespaceOrComment
    char ')'
    return instr


parseCall :: Parser L2Instruction
parseCall = do
    string "call"
    whitespaceOrComment
    (liftM L2Call parseU)

parseCjump :: Parser L2Instruction
parseCjump = do
    string "cjump"
    whitespaceOrComment
    t1 <- parseT
    whitespaceOrComment
    cmp <- parseCMP
    whitespaceOrComment
    t2 <- parseT
    whitespaceOrComment
    l1 <- parseLabel
    whitespaceOrComment
    l2 <- parseLabel
    return $ L2Cjump t1 cmp t2 l1 l2

parseTailCall :: Parser L2Instruction
parseTailCall = do
    string "tail-call"
    whitespaceOrComment
    (liftM L2TailCall parseU)

parseReturn :: Parser L2Instruction
parseReturn = do
    string "return"
    return L2Return

parseGoto :: Parser L2Instruction
parseGoto = do
    string "goto"
    whitespaceOrComment
    (liftM L2Goto parseLabel)

parseUpdate :: Parser L2Instruction
parseUpdate = do
    string "(mem"
    whitespaceOrComment
    x <- parseX
    whitespaceOrComment
    n <- parseNumber
    char ')'
    whitespaceOrComment
    string "<-"
    whitespaceOrComment
    s <- parseS
    return $ L2Update x n s


regOpChars = oneOf "<>=-+*&"

parseRegOp :: Parser L2Instruction
parseRegOp = do
    x <- parseX
    whitespaceOrComment
    op <- many1 regOpChars
    whitespaceOrComment
    case op of
        "<-" -> parseArrow x
        "+=" -> parseArith x L2Add
        "-=" -> parseArith x L2Sub
        "*=" -> parseArith x L2Mult
        "&=" -> parseArith x L2And
        "<<=" -> parseShift x L2ShiftLeft
        ">>=" -> parseShift x L2ShiftRight

parseArrow :: L2X -> Parser L2Instruction
parseArrow x = parseArrowParen x
           <|> try (parseSaveCmp x)
           <|> parseAssign x

{'fraction_non_alphanumeric': 0.0835663944512809, 'fraction_numerical': 0.011858149681172391, 'mean_word_length': 2.8205128205128207, 'pattern_counts': {'":': 0, '<': 78, '<?xml version=': 0, '>': 70, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1019828', 'n_tokens_mistral': 2852, 'n_tokens_neox': 2824, 'n_words': 786}