Sockeye: Clean up ASTs
[barrelfish] / tools / sockeye / SockeyeParser.hs
1 {-
2   SockeyeParser.hs: Parser for Sockeye
3
4   Part of Sockeye
5
6   Copyright (c) 2017, ETH Zurich.
7
8   All rights reserved.
9
10   This file is distributed under the terms in the attached LICENSE file.
11   If you do not find this file, copies can be found by writing to:
12   ETH Zurich D-INFK, CAB F.78, Universitaetstr. 6, CH-8092 Zurich,
13   Attn: Systems Group.
14 -}
15
16 module SockeyeParser
17 ( parseSockeye ) where
18
19 import Text.Parsec
20 import qualified Text.Parsec.Token as P
21 import Text.Parsec.Language (javaStyle)
22
23 import qualified SockeyeASTParser as AST
24
25 {- Parser main function -}
26 parseSockeye :: String -> String -> Either ParseError AST.SockeyeSpec
27 parseSockeye = parse sockeyeFile
28
29 {- Sockeye parsing -}
30 sockeyeFile = do
31     whiteSpace
32     spec <- sockeyeSpec
33     eof
34     return spec
35
36 sockeyeSpec = do
37     imports <- many imports
38     modules <- many sockeyeModule
39     net <- many netSpecs
40     return AST.SockeyeSpec
41         { AST.imports = imports
42         , AST.modules = modules
43         , AST.net     = concat net
44         }
45
46 imports = do
47     reserved "import"
48     path <- try importPath <?> "import path"
49     return $ AST.Import path
50
51
52 sockeyeModule = do
53     reserved "module"
54     name <- moduleName
55     params <- option [] $ parens (commaSep moduleParam)
56     body <- braces moduleBody
57     return AST.Module
58         { AST.name       = name
59         , AST.parameters = params
60         , AST.moduleBody = body
61         }
62
63 moduleParam = do
64     paramType <- choice [intType, addrType] <?> "parameter type"
65     paramName <- parameterName
66     return AST.ModuleParam
67         { AST.paramName = paramName
68         , AST.paramType = paramType 
69         }
70     where
71         intType = do
72             symbol "nat"
73             return AST.NaturalParam
74         addrType = do
75             symbol "addr" 
76             return AST.AddressParam
77
78 moduleBody = do
79     ports <- many ports
80     net <- many netSpecs
81     return AST.ModuleBody
82         { AST.ports     = concat ports
83         , AST.moduleNet = concat net
84         }
85
86 ports = choice [inputPorts, outputPorts]
87     where
88         inputPorts = do
89             reserved "input"
90             commaSep1 inDef
91         inDef = do
92             (forFn, portId) <- identifierFor
93             symbol "/"
94             portWidth <- decimal <?> "number of bits"
95             let port = AST.InputPort portId portWidth
96             case forFn of
97                 Nothing -> return port
98                 Just f  -> return $ AST.MultiPort (f port)
99         outputPorts = do
100             reserved "output"
101             commaSep1 outDef
102         outDef = do
103             (forFn, portId) <- identifierFor
104             symbol "/"
105             portWidth <- decimal <?> "number of bits"
106             let port = AST.OutputPort portId portWidth
107             case forFn of
108                 Nothing -> return port
109                 Just f  -> return $ AST.MultiPort (f port)
110
111 netSpecs = choice [ inst <?> "module instantiation"
112                  , decl <?> "node declaration"
113                  ]
114     where
115         inst = do
116             moduleInst <- moduleInst
117             return $ [AST.ModuleInstSpec moduleInst]
118         decl = do
119             nodeDecls <- nodeDecls
120             return $ [AST.NodeDeclSpec decl | decl <- nodeDecls]
121
122 moduleInst = do
123     (name, args) <- try $ do
124         name <- moduleName
125         args <- option [] $ parens (commaSep moduleArg)
126         symbol "as"
127         return (name, args)
128     (forFn, namespace) <- identifierFor
129     portMappings <- option [] $ symbol "with" *> many1 portMapping
130     return $ let
131         moduleInst = AST.ModuleInst
132             { AST.moduleName = name
133             , AST.namespace  = namespace
134             , AST.arguments  = args 
135             , AST.portMappings = portMappings
136             }
137         in case forFn of
138             Nothing -> moduleInst
139             Just f  -> AST.MultiModuleInst $ f moduleInst
140
141 moduleArg = choice [addressArg, numberArg, paramArg]
142     where
143         addressArg = do
144             addr <- addressLiteral
145             return $ AST.AddressArg addr
146         numberArg = do
147             num <- numberLiteral
148             return $ AST.NaturalArg num
149         paramArg = do
150             name <- parameterName
151             return $ AST.ParamArg name
152
153 portMapping = choice [inputMapping, outputMapping]
154     where
155         inputMapping = do
156             (forFn, mappedId) <- try $ identifierFor <* symbol ">"
157             portId <- identifier
158             return $ let
159                 portMap = AST.InputPortMap
160                     { AST.mappedId   = mappedId
161                     , AST.mappedPort = portId
162                     }
163                 in case forFn of
164                     Nothing -> portMap
165                     Just f  -> AST.MultiPortMap $ f portMap
166         outputMapping = do
167             (forFn, mappedId) <- try $ identifierFor <* symbol "<"
168             portId <- identifier
169             return $ let
170                 portMap = AST.OutputPortMap
171                     { AST.mappedId   = mappedId
172                     , AST.mappedPort = portId
173                     }
174                 in case forFn of
175                     Nothing -> portMap
176                     Just f  -> AST.MultiPortMap $ f portMap
177
178 nodeDecls = do
179     nodeIds <- choice [try single, try multiple]
180     nodeSpec <- nodeSpec
181     return $ map (toNodeDecl nodeSpec) nodeIds
182     where
183         single = do
184             nodeId <- identifier
185             reserved "is"
186             return [(Nothing, nodeId)]
187         multiple = do
188             nodeIds <- commaSep1 identifierFor
189             reserved "are"
190             return nodeIds
191         toNodeDecl nodeSpec (forFn, ident) = let
192             nodeDecl = AST.NodeDecl
193                 { AST.nodeId = ident
194                 , AST.nodeSpec = nodeSpec
195                 }
196             in case forFn of
197                 Nothing -> nodeDecl
198                 Just f  -> AST.MultiNodeDecl $ f nodeDecl
199
200 identifier = do
201     (_, ident) <- identifierHelper False
202     return ident
203
204 nodeSpec = do
205     nodeType <- option AST.Other $ try nodeType
206     accept <- option [] accept 
207     translate <- option [] tranlsate
208     reserve <- option [] reserve
209     overlay <- optionMaybe overlay
210     return AST.NodeSpec 
211         { AST.nodeType  = nodeType
212         , AST.accept    = accept
213         , AST.translate = translate
214         , AST.reserved  = reserve
215         , AST.overlay   = overlay
216         }
217     where
218         accept = do
219             try $ reserved "accept"
220             brackets $ many blockSpec
221         tranlsate = do
222             try $ reserved "map"
223             specs <- brackets $ many mapSpecs
224             return $ concat specs
225         reserve = do
226             try $ reserved "reserved"
227             brackets $ many blockSpec
228
229 nodeType = choice [memory, device]
230     where memory = do
231             symbol "memory"
232             return AST.Memory
233           device = do
234             symbol "device"
235             return AST.Device
236
237 blockSpec = choice [range, length, singleton]
238     where
239         singleton = do
240             address <- address
241             return $ AST.SingletonBlock address
242         range = do
243             base <- try $ address <* symbol "-"
244             limit <- address
245             return $ AST.RangeBlock base limit
246         length = do
247             base <- try $ address <* symbol "/"
248             bits <- decimal <?> "number of bits"
249             return $ AST.LengthBlock base bits
250
251 address = choice [address, param]
252     where
253         address = do
254             addr <- addressLiteral
255             return $ AST.LiteralAddress addr
256         param = do
257             name <- parameterName
258             return $ AST.ParamAddress name
259
260 mapSpecs = do
261     block <- blockSpec
262     reserved "to"
263     dests <- commaSep1 $ mapDest
264     return $ map (toMapSpec block) dests
265     where
266         mapDest = do
267             destNode <- identifier
268             destBase <- optionMaybe $ reserved "at" *> address
269             return (destNode, destBase)
270         toMapSpec block (destNode, destBase) = AST.MapSpec
271             { AST.block    = block
272             , AST.destNode = destNode
273             , AST.destBase = destBase
274             }
275
276 overlay = do
277     reserved "over"
278     over <- identifier
279     symbol "/"
280     width <- decimal <?> "number of bits"
281     return AST.OverlaySpec
282         { AST.over  = over
283         , AST.width = width
284         }
285
286 identifierFor = identifierHelper True
287
288 forVarRange optVarName
289     | optVarName = do 
290         var <- option "#" (try $ variableName <* reserved "in")
291         range var
292     | otherwise = do
293         var <- variableName
294         reserved "in"
295         range var
296     where
297         range var = brackets (do
298             start <- index
299             symbol ".."
300             end <- index
301             return AST.ForVarRange
302                 { AST.var   = var
303                 , AST.start = start
304                 , AST.end   = end
305                 }
306             )
307             <?> "range ([a..b])"
308         index = choice [numberIndex, paramIndex]
309         numberIndex = do
310             num <- numberLiteral
311             return $ AST.LiteralLimit num
312         paramIndex = do
313             name <- parameterName
314             return $ AST.ParamLimit name
315
316 {- Helper functions -}
317 lexer = P.makeTokenParser (
318     javaStyle  {
319         {- list of reserved Names -}
320         P.reservedNames = keywords,
321
322         {- valid identifiers -}
323         P.identStart = letter,
324         P.identLetter = identLetter,
325
326         {- comment start and end -}
327         P.commentStart = "/*",
328         P.commentEnd = "*/",
329         P.commentLine = "//",
330         P.nestedComments = False
331     })
332
333 whiteSpace    = P.whiteSpace lexer
334 reserved      = P.reserved lexer
335 parens        = P.parens lexer
336 brackets      = P.brackets lexer
337 braces        = P.braces lexer
338 symbol        = P.symbol lexer
339 commaSep      = P.commaSep lexer
340 commaSep1     = P.commaSep1 lexer
341 identString   = P.identifier lexer
342 hexadecimal   = symbol "0" *> P.hexadecimal lexer <* whiteSpace
343 decimal       = P.decimal lexer <* whiteSpace
344
345 keywords = ["import", "module",
346             "input", "output",
347             "in",
348             "as", "with",
349             "is", "are",
350             "accept", "map",
351             "reserved", "over",
352             "to", "at"]   
353
354 identStart     = letter
355 identLetter    = alphaNum <|> char '_' <|> char '-'
356
357 importPath     = many (identLetter <|> char '/') <* whiteSpace
358 moduleName     = identString <?> "module name"
359 parameterName  = identString <?> "parameter name"
360 variableName   = identString <?> "variable name"
361 identifierName = try ident <?> "identifier"
362     where
363         ident = do
364             start <- identStart
365             rest <- many identLetter
366             let ident = start:rest
367             if ident `elem` keywords
368                 then unexpected $ "reserved word \"" ++ ident ++ "\""
369                 else return ident
370
371 numberLiteral  = try decimal <?> "number literal"
372 addressLiteral = try hexadecimal <?> "address literal (hex)"
373
374 identifierHelper inlineFor = do
375     (varRanges, Just ident) <- choice [template identifierName, simple identifierName] <* whiteSpace
376     let
377         forFn = case varRanges of
378          [] -> Nothing
379          _  -> Just $ \body -> AST.For
380                 { AST.varRanges = varRanges
381                 , AST.body      = body
382                 }
383     return (forFn, ident)
384     where
385         simple ident = do
386             name <- ident
387             return $ ([], Just $ AST.SimpleIdent name)
388         template ident = do
389             prefix <- try $ ident <* symbol "{"
390             (ranges, varName, suffix) <- if inlineFor 
391                 then choice [forTemplate, varTemplate]
392                 else varTemplate
393             let
394                 ident = Just AST.TemplateIdent
395                     { AST.prefix = prefix
396                     , AST.varName = varName
397                     , AST.suffix = suffix
398                     }
399             return (ranges, ident)
400         varTemplate = do
401             varName <- variableName
402             char '}'
403             (ranges, suffix) <- templateSuffix
404             return (ranges, varName, suffix)
405         forTemplate = do
406             optVarRange <- forVarRange True
407             char '}'
408             (subRanges, suffix) <- templateSuffix
409             return $ let
410                 varName = mapOptVarName subRanges (AST.var optVarRange)
411                 varRange = optVarRange { AST.var = varName }
412                 ranges = varRange:subRanges
413                 in (ranges, varName, suffix)
414         templateSuffix = option ([], Nothing) $ choice
415             [ template $ many identLetter
416             , simple $ many1 identLetter
417             ]
418         mapOptVarName prev "#" = "#" ++ (show $ (length prev) + 1)
419         mapOptVarName _ name = name