From 7453b4e8ed3a23f16822b32a100bd36e813910d4 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Grave Date: Fri, 15 Feb 2019 19:40:03 +0000 Subject: Add expression parsing --- src/VeriFuzz/Parser.hs | 171 +++++++++++++++++++++++++++---------------------- 1 file changed, 96 insertions(+), 75 deletions(-) (limited to 'src') diff --git a/src/VeriFuzz/Parser.hs b/src/VeriFuzz/Parser.hs index 4b2d076..28a475d 100644 --- a/src/VeriFuzz/Parser.hs +++ b/src/VeriFuzz/Parser.hs @@ -14,13 +14,104 @@ whole Verilog syntax, as the AST does not support it either. module VeriFuzz.Parser where import Control.Applicative ((<|>)) -import Data.Attoparsec.Text +import Data.Attoparsec.Expr +import Data.Attoparsec.Text as A +import Data.Char (isLetter) import Data.Functor (($>)) import Data.Text (Text) import qualified Data.Text as T import VeriFuzz.AST import VeriFuzz.CodeGen +sBinOp :: BinaryOperator -> Expr -> Expr -> Expr +sBinOp = sOp BinOp + where + sOp f b a = f a b + +parseExpr :: Parser Expr +parseExpr = buildExpressionParser parseTable parseTerm + "expr" + +parseParens :: Parser a -> Parser a +parseParens a = do + val <- "(" *> skipSpace *> a + _ <- skipSpace *> ")" + return val + +constP :: Parser a -> Text -> Parser a +constP p t = case parseOnly p t of + Left _ -> fail "constP" + Right a -> return a + +parseOf :: Parser Text -> Parser a -> Parser a +parseOf ptxt pa = bothParse + where + bothParse = ptxt >>= constP pa + +ignoreWS :: Parser a -> Parser a +ignoreWS a = do + skipSpace + t <- a + skipSpace + return t + +parseTerm :: Parser Expr +parseTerm = (Concat <$> aroundList "{" "}" parseExpr) + <|> parseCond + <|> parseParens parseExpr + <|> ignoreWS (Number 32 <$> decimal) + "simple expr" + +takeUntil :: Char -> Parser Text +takeUntil c = do + t <- takeWhile1 (/=c) + _ <- char c + return t + +parseCond :: Parser Expr +parseCond = do + x <- parseOf (takeUntil '?') parseExpr + y <- parseOf (takeUntil ':') parseExpr + Cond x y <$> parseExpr + +parseTable :: [[Operator Text Expr]] +parseTable = + [ [ prefix "!" (UnOp UnLNot), prefix "~" (UnOp UnNot) ] + , [ prefix "&" (UnOp UnAnd), prefix "|" (UnOp UnOr), prefix "~&" (UnOp UnNand) + , prefix "~|" (UnOp UnNor), prefix "^" (UnOp UnXor), prefix "~^" (UnOp UnNxor) + , prefix "^~" (UnOp UnNxorInv) + ] + , [ prefix "+" (UnOp UnPlus), prefix "-" (UnOp UnMinus) ] + , [ binary "**" (sBinOp BinPower) AssocRight ] + , [ binary "*" (sBinOp BinTimes) AssocLeft, binary "/" (sBinOp BinDiv) AssocLeft + , binary "%" (sBinOp BinMod) AssocLeft + ] + , [ binary "+" (sBinOp BinPlus) AssocLeft, binary "-" (sBinOp BinPlus) AssocLeft ] + , [ binary "<<" (sBinOp BinLSL) AssocLeft, binary ">>" (sBinOp BinLSR) AssocLeft ] + , [ binary "<<<" (sBinOp BinASL) AssocLeft, binary ">>>" (sBinOp BinASR) AssocLeft ] + , [ binary "<" (sBinOp BinLT) AssocNone, binary ">" (sBinOp BinGT) AssocNone + , binary "<=" (sBinOp BinLEq) AssocNone, binary ">=" (sBinOp BinLEq) AssocNone + ] + , [ binary "==" (sBinOp BinEq) AssocNone, binary "!=" (sBinOp BinNEq) AssocNone ] + , [ binary "===" (sBinOp BinEq) AssocNone, binary "!==" (sBinOp BinNEq) AssocNone ] + , [ binary "&" (sBinOp BinAnd) AssocLeft ] + , [ binary "^" (sBinOp BinXor) AssocLeft, binary "^~" (sBinOp BinXNor) AssocLeft + , binary "~^" (sBinOp BinXNorInv) AssocLeft + ] + , [ binary "|" (sBinOp BinOr) AssocLeft ] + , [ binary "&&" (sBinOp BinLAnd) AssocLeft ] + , [ binary "|" (sBinOp BinLOr) AssocLeft ] + ] + +binary :: Text -> (a -> a -> a) -> Assoc -> Operator Text a +binary name fun = Infix ((string name "binary") >> return fun) + +prefix :: Text -> (a -> a) -> Operator Text a +prefix name fun = Prefix ((string name "prefix") >> return fun) + +postfix :: Text -> (a -> a) -> Operator Text a +postfix name fun = Postfix ((string name "postfix") >> return fun) + commaSep :: Parser a -> Parser [a] commaSep f = sepBy f (skipSpace *> char ',' *> skipSpace) @@ -30,79 +121,9 @@ aroundList a b c = do _ <- b return l -parseBinOp :: Parser BinaryOperator -parseBinOp = - "+" $> BinPlus - <|> "-" $> BinMinus - <|> "*" $> BinTimes - <|> "/" $> BinDiv - <|> "%" $> BinMod - <|> "==" $> BinEq - <|> "!=" $> BinNEq - <|> "===" $> BinCEq - <|> "!==" $> BinCNEq - <|> "&&" $> BinLAnd - <|> "||" $> BinLOr - <|> "<" $> BinLT - <|> "<=" $> BinLEq - <|> ">" $> BinGT - <|> ">=" $> BinGEq - <|> "&" $> BinAnd - <|> "|" $> BinOr - <|> "^" $> BinXor - <|> "^~" $> BinXNor - <|> "~^" $> BinXNorInv - <|> "**" $> BinPower - <|> "<<" $> BinLSL - <|> ">>" $> BinLSR - <|> "<<<" $> BinASL - <|> ">>>" $> BinASR - -parseUnOp :: Parser UnaryOperator -parseUnOp = - "+" $> UnPlus - <|> "-" $> UnMinus - <|> "!" $> UnLNot - <|> "~" $> UnNot - <|> "&" $> UnAnd - <|> "~&" $> UnNand - <|> "|" $> UnOr - <|> "~|" $> UnNor - <|> "^" $> UnXor - <|> "~^" $> UnNxor - <|> "^~" $> UnNxorInv - -parseExpr :: Parser Expr -parseExpr = cond <|> binop <|> unop <|> conc <|> brack <|> var <|> num - where - var = Id . Identifier . T.pack <$> many1 letter - num = Number 32 <$> decimal - binop = do - lhs <- var <|> num - bo <- skipSpace *> parseBinOp - skipSpace - BinOp lhs bo <$> parseExpr - brack = do - expr <- "(" *> skipSpace *> parseExpr - skipSpace *> ")" *> skipSpace - return expr - cond = do - expr1 <- parseExpr - skipSpace *> "?" *> skipSpace - expr2 <- parseExpr - skipSpace *> ":" *> skipSpace - expr3 <- parseExpr - skipSpace - return $ Cond expr1 expr2 expr3 - conc = Concat <$> aroundList "{" "}" parseExpr - unop = do - uo <- parseUnOp - skipSpace - UnOp uo <$> parseExpr - parseContAssign :: Parser ContAssign parseContAssign = do - var <- Identifier . T.pack <$> (skipSpace *> "assign" *> skipSpace *> many1 letter) + var <- Identifier <$> (skipSpace *> "assign" *> skipSpace *> takeWhile1 isLetter) expr <- skipSpace *> "=" *> skipSpace *> parseExpr _ <- skipSpace *> ";" return $ ContAssign var expr @@ -113,12 +134,12 @@ parseModItem = fmap ModCA <$> many1 parseContAssign parseModList :: Parser [Identifier] parseModList = list <|> skipSpace $> [] where - list = fmap (Identifier . T.pack) - <$> aroundList "(" ")" (many1 letter) + list = fmap Identifier + <$> aroundList "(" ")" (takeWhile1 isLetter) parseModDecl :: Parser ModDecl parseModDecl = do - name <- Identifier . T.pack <$> ("module" *> skipSpace *> many1 letter) + name <- Identifier <$> ("module" *> skipSpace *> takeWhile1 isLetter) modL <- fmap (Port Wire 1) <$> (skipSpace *> parseModList) _ <- skipSpace *> ";" modItem <- parseModItem <|> skipSpace $> [] -- cgit