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
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
|
{-|
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
( -- * Parsers
parseVerilogSrc
, parseDescription
, parseModDecl
, parseContAssign
, 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 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 = ptxt >>= constP pa
ignoreWS :: Parser a -> Parser a
ignoreWS a = do
skipSpace
t <- a
skipSpace
return t
matchHex :: Char -> Bool
matchHex c = c == 'h' || c == 'H'
--matchBin :: Char -> Bool
--matchBin c = c == 'b' || c == 'B'
matchDec :: Char -> Bool
matchDec c = c == 'd' || c == 'D'
--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
_ <- "'"
matchNum size
where
matchNum size = (satisfy matchHex >> Number size <$> hexadecimal)
<|> (satisfy matchDec >> Number size <$> decimal)
parseTerm :: Parser Expr
parseTerm = (Concat <$> aroundList "{" "}" parseExpr)
<|> parseCond
<|> parseParens parseExpr
<|> parseNum
<?> "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
-- | Table of binary and unary operators that encode the right precedence for
-- each.
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)
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
|
