1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
{-|
Module : VeriFuzz.Parser
Description : Minimal Verilog parser to reconstruct the AST.
Copyright : (c) 2019, Yann Herklotz Grave
License : GPL-3
Maintainer : ymherklotz [at] gmail [dot] com
Stability : experimental
Portability : POSIX
Minimal Verilog parser to reconstruct the AST. This parser does not support the
whole Verilog syntax, as the AST does not support it either.
-}
module VeriFuzz.Parser 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 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)
aroundList :: Parser a -> Parser b -> Parser c -> Parser [c]
aroundList a b c = do
l <- a *> skipSpace *> commaSep c
_ <- b
return l
parseContAssign :: Parser ContAssign
parseContAssign = do
var <- Identifier <$> (skipSpace *> "assign" *> skipSpace *> takeWhile1 isLetter)
expr <- skipSpace *> "=" *> skipSpace *> parseExpr
_ <- skipSpace *> ";"
return $ ContAssign var expr
parseModItem :: Parser [ModItem]
parseModItem = fmap ModCA <$> many1 parseContAssign
parseModList :: Parser [Identifier]
parseModList = list <|> skipSpace $> []
where
list = fmap Identifier
<$> aroundList "(" ")" (takeWhile1 isLetter)
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
parseDescription :: Parser Description
parseDescription = Description <$> (skipSpace *> parseModDecl)
parseVerilogSrc :: Parser VerilogSrc
parseVerilogSrc = VerilogSrc <$> many1 parseDescription
|
