From d0dd067977e9e6db748dfc894ebde13d3c58e525 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Grave Date: Sat, 16 Feb 2019 20:22:29 +0000 Subject: Change to Parsec and add Lexer --- src/VeriFuzz/Parser.hs | 173 +++++++++++++++++++++++++++++++------------------ 1 file changed, 110 insertions(+), 63 deletions(-) (limited to 'src/VeriFuzz/Parser.hs') diff --git a/src/VeriFuzz/Parser.hs b/src/VeriFuzz/Parser.hs index 3991a1f..ef91265 100644 --- a/src/VeriFuzz/Parser.hs +++ b/src/VeriFuzz/Parser.hs @@ -20,42 +20,39 @@ module VeriFuzz.Parser , parseExpr ) where -import Control.Applicative ((<|>)) -import Data.Attoparsec.Expr -import Data.Attoparsec.Text as A -import Data.Char (isLetter) -import Data.Functor (($>)) -import Data.Text (Text) +import Data.Functor (($>)) +import Data.Functor.Identity (Identity) +import qualified Data.Text as T +import Text.Parsec +import Text.Parsec.Expr import VeriFuzz.AST +import VeriFuzz.Internal +import VeriFuzz.Lexer + +type Parser = Parsec String () + +type ParseOperator = Operator String () Identity sBinOp :: BinaryOperator -> Expr -> Expr -> Expr sBinOp = sOp BinOp where sOp f b a = f a b -parseExpr :: Parser Expr -parseExpr = buildExpressionParser parseTable parseTerm +parseExpr' :: Parser Expr +parseExpr' = buildExpressionParser parseTable parseTerm "expr" parseParens :: Parser a -> Parser a parseParens a = do - val <- "(" *> skipSpace *> a - _ <- skipSpace *> ")" + val <- string "(" *> spaces *> a + _ <- spaces *> string ")" 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 = ptxt >>= constP pa - ignoreWS :: Parser a -> Parser a ignoreWS a = do - skipSpace + spaces t <- a - skipSpace + spaces return t matchHex :: Char -> Bool @@ -67,44 +64,61 @@ matchHex c = c == 'h' || c == 'H' matchDec :: Char -> Bool matchDec c = c == 'd' || c == 'D' ---matchOct :: Char -> Bool ---matchOct c = c == 'o' || c == 'O' +matchOct :: Char -> Bool +matchOct c = c == 'o' || c == 'O' -- | Parse a Number depending on if it is in a hex or decimal form. Octal and -- binary are not supported yet. parseNum :: Parser Expr parseNum = ignoreWS $ do - size <- decimal - _ <- "'" + size <- fromIntegral <$> decimal + _ <- string "'" matchNum size where matchNum size = (satisfy matchHex >> Number size <$> hexadecimal) <|> (satisfy matchDec >> Number size <$> decimal) + <|> (satisfy matchOct >> Number size <$> octal) + +parseVar :: Parser Expr +parseVar = Id <$> ident + +parseFunction :: Parser Function +parseFunction = string "unsigned" $> UnSignedFunc + <|> string "signed" $> SignedFunc + +parseFun :: Parser Expr +parseFun = do + f <- spaces *> reservedOp "$" *> parseFunction + expr <- string "(" *> spaces *> parseExpr + _ <- spaces *> string ")" *> spaces + return $ Func f expr parseTerm :: Parser Expr -parseTerm = (Concat <$> aroundList "{" "}" parseExpr) - <|> parseCond - <|> parseParens parseExpr +parseTerm = parseParens parseExpr + <|> (Concat <$> aroundList (string "{") (string "}") parseExpr) + <|> parseFun <|> parseNum + <|> parseVar "simple expr" -takeUntil :: Char -> Parser Text -takeUntil c = do - t <- takeWhile1 (/=c) - _ <- char c - return t - -- | Parses the ternary conditional operator. It will behave in a right -- associative way. -parseCond :: Parser Expr -parseCond = do - x <- parseOf (takeUntil '?') parseExpr - y <- parseOf (takeUntil ':') parseExpr - Cond x y <$> parseExpr +parseCond :: Expr -> Parser Expr +parseCond e = do + _ <- reservedOp "?" + expr <- parseExpr + _ <- reservedOp ":" + Cond e expr <$> parseExpr + +parseExpr :: Parser Expr +parseExpr = do + e <- parseExpr' + y <- option e $ parseCond e + return y -- | Table of binary and unary operators that encode the right precedence for -- each. -parseTable :: [[Operator Text Expr]] +parseTable :: [[ParseOperator Expr]] parseTable = [ [ prefix "!" (UnOp UnLNot), prefix "~" (UnOp UnNot) ] , [ prefix "&" (UnOp UnAnd), prefix "|" (UnOp UnOr), prefix "~&" (UnOp UnNand) @@ -133,48 +147,81 @@ parseTable = , [ 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) +binary :: String -> (a -> a -> a) -> Assoc -> ParseOperator a +binary name fun = Infix ((reservedOp name "binary") >> return fun) -commaSep :: Parser a -> Parser [a] -commaSep f = sepBy f (skipSpace *> char ',' *> skipSpace) +prefix :: String -> (a -> a) -> ParseOperator a +prefix name fun = Prefix ((reservedOp name "prefix") >> return fun) aroundList :: Parser a -> Parser b -> Parser c -> Parser [c] aroundList a b c = do - l <- a *> skipSpace *> commaSep c + l <- a *> spaces *> commaSep c _ <- b return l parseContAssign :: Parser ContAssign parseContAssign = do - var <- Identifier <$> (skipSpace *> "assign" *> skipSpace *> takeWhile1 isLetter) - expr <- skipSpace *> "=" *> skipSpace *> parseExpr - _ <- skipSpace *> ";" + var <- (spaces *> reserved "assign" *> spaces *> ident) + expr <- spaces *> reservedOp "=" *> spaces *> parseExpr + _ <- spaces *> string ";" return $ ContAssign var expr -parseModItem :: Parser [ModItem] -parseModItem = fmap ModCA <$> many1 parseContAssign +-- | Parse a range and return the total size. As it is inclusive, 1 has to be +-- added to the difference. +parseRange :: Parser Int +parseRange = do + rangeH <- string "[" *> spaces *> decimal + rangeL <- spaces *> string ":" *> spaces *> decimal + spaces *> string "]" *> spaces + return . fromIntegral $ rangeH - rangeL + 1 + +ident :: Parser Identifier +ident = Identifier . T.pack <$> identifier + +parseNetDecl :: Maybe PortDir -> Parser ModItem +parseNetDecl pd = do + t <- option Wire type_ + sign <- option False (reserved "signed" *> spaces $> True) + range <- option 1 parseRange + name <- ident + _ <- spaces *> string ";" + return . Decl pd . Port t sign range $ name + where + type_ = reserved "wire" *> spaces $> Wire + <|> reserved "reg" *> spaces $> Reg + +parsePortDir :: Parser PortDir +parsePortDir = + reserved "output" *> spaces $> PortOut + <|> reserved "input" *> spaces $> PortIn + <|> reserved "inout" *> spaces $> PortInOut + +parseDecl :: Parser ModItem +parseDecl = + (Just <$> parsePortDir >>= parseNetDecl) + <|> parseNetDecl Nothing + +parseModItem :: Parser ModItem +parseModItem = + (ModCA <$> parseContAssign) + <|> parseDecl parseModList :: Parser [Identifier] -parseModList = list <|> skipSpace $> [] +parseModList = list <|> spaces $> [] where - list = fmap Identifier - <$> aroundList "(" ")" (takeWhile1 isLetter) + list = aroundList (string "(") (string ")") ident parseModDecl :: Parser ModDecl parseModDecl = do - name <- Identifier <$> ("module" *> skipSpace *> takeWhile1 isLetter) - modL <- fmap (Port Wire 1) <$> (skipSpace *> parseModList) - _ <- skipSpace *> ";" - modItem <- parseModItem <|> skipSpace $> [] - _ <- skipSpace *> "endmodule" - return $ ModDecl name [Port Wire 1 "y"] modL modItem + name <- (reserved "module" *> ident) + modL <- fmap defaultPort <$> parseModList + _ <- string ";" + modItem <- option [] . try $ many1 parseModItem + _ <- reserved "endmodule" + return $ ModDecl name [defaultPort "y"] modL modItem parseDescription :: Parser Description -parseDescription = Description <$> (skipSpace *> parseModDecl) +parseDescription = Description <$> parseModDecl parseVerilogSrc :: Parser VerilogSrc -parseVerilogSrc = VerilogSrc <$> many1 parseDescription +parseVerilogSrc = VerilogSrc <$> many parseDescription -- cgit