1{-
2  SockeyeParser.hs: Parser for Sockeye
3
4  Part of Sockeye
5
6  Copyright (c) 2018, 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, Universitaetstrasse 6, CH-8092 Zurich,
13  Attn: Systems Group.
14-}
15
16module SockeyeParser
17( parseSockeye ) where
18
19import System.FilePath
20
21import Text.Parsec
22import Text.Parsec.Expr
23import qualified Text.Parsec.Token as P
24import Text.Parsec.Language (emptyDef)
25
26import SockeyeASTMeta
27import qualified SockeyeParserAST as AST
28
29{- Parser main function -}
30parseSockeye :: String -> String -> Either ParseError AST.SockeyeFile
31parseSockeye = parse sockeyeFile
32
33data TopLevel
34    = ModuleDecl AST.Module
35    | TypeDecl AST.NamedType
36
37data ModuleBody
38    = ConstDecl AST.NamedConstant
39    | InstDecl AST.InstanceDeclaration
40    | NodeDecl AST.NodeDeclaration
41    | Def AST.Definition
42
43{- Sockeye parsing -}
44sockeyeFile = do
45    whiteSpace
46    pos <- getPositionMeta
47    imports <- many sockeyeImport
48    (modules, types) <- do
49        stmts <- many $ choice [moduleDecl, typeDecl]
50        return $ foldr splitDecl ([], []) stmts
51    eof
52    return AST.SockeyeFile
53        { AST.sockeyeFileMeta = pos
54        , AST.imports         = imports
55        , AST.modules         = modules
56        , AST.types           = types
57        }
58    where
59        moduleDecl = fmap ModuleDecl sockeyeModule
60        typeDecl = fmap TypeDecl namedType
61        splitDecl (ModuleDecl m) (ms, ts) = (m:ms, ts)
62        splitDecl (TypeDecl t)   (ms, ts) = (ms, t:ts)
63
64sockeyeImport = do
65    pos <- getPositionMeta
66    reserved "import"
67    path <- many1 (alphaNum <|> char '_' <|> char '-' <|> char '/') <* whiteSpace
68    explImports <- optionMaybe (parens $ commaSep1 importAlias)
69    return AST.Import
70        { AST.importMeta  = pos
71        , AST.importFile  = path <.> "soc"
72        , AST.explImports = explImports
73        }
74    <?> "import"
75
76importAlias = do
77    pos <- getPositionMeta
78    origName <- identString <?> "module or type to import"
79    alias <- option origName importAlias
80    return AST.ImportAlias
81        { AST.importAliasMeta = pos
82        , AST.originalName    = origName
83        , AST.importAlias     = alias
84        }
85    where
86        importAlias = do
87            reserved "as"
88            identString <?> "import alias"
89
90sockeyeModule = do
91    pos <- getPositionMeta
92    extern <- option False moduleExtern
93    reserved "module"
94    name <- moduleName
95    params <- option [] (parens $ commaSep moduleParam)
96    (consts, insts, nodes, defs) <- braces moduleBody
97    return AST.Module
98        { AST.moduleMeta  = pos
99        , AST.moduleExtern = extern
100        , AST.moduleName  = name
101        , AST.parameters  = params
102        , AST.constants   = consts
103        , AST.instDecls   = insts
104        , AST.nodeDecls   = nodes
105        , AST.definitions = defs
106        }
107    <?> "module specification"
108
109moduleExtern = do
110    reserved "extern"
111    return True
112
113moduleParam = do
114    pos <- getPositionMeta
115    range <- parens naturalSet <?> "parameter range"
116    paramName <- parameterName
117    return AST.ModuleParameter
118        { AST.paramMeta  = pos
119        , AST.paramName  = paramName
120        , AST.paramRange = range
121        }
122
123moduleBody = do
124    body <- many $ choice [constDecl, instDecl, nodeDecl, def]
125    return $ foldr splitBody ([], [], [], []) body
126    where
127        constDecl = fmap ConstDecl namedConstant
128        instDecl = fmap InstDecl instanceDeclaration
129        nodeDecl = fmap NodeDecl nodeDeclaration
130        def = fmap Def definition
131        splitBody (ConstDecl c) (cs, is, ns, ds) = (c:cs, is, ns, ds)
132        splitBody (InstDecl i)  (cs, is, ns, ds) = (cs, i:is, ns, ds)
133        splitBody (NodeDecl n)  (cs, is, ns, ds) = (cs, is, n:ns, ds)
134        splitBody (Def d)       (cs, is, ns, ds) = (cs, is, ns, d:ds)
135
136instanceDeclaration = do
137    pos <- getPositionMeta
138    reserved "instance"
139    name <- identifierName
140    size <- optionMaybe arraySize
141    reserved "of"
142    modName <- moduleName
143    return AST.InstanceDeclaration
144        { AST.instDeclMeta = pos
145        , AST.instName     = name
146        , AST.instModName  = modName
147        , AST.instArrSize  = size
148        }
149    <?> "instance declaration"
150
151nodeDeclaration = do
152    pos <- getPositionMeta
153    kind <- nodeKind
154    t <- nodeType
155    name <- identifierName
156    size <- optionMaybe arraySize
157    return AST.NodeDeclaration
158        { AST.nodeDeclMeta = pos
159        , AST.nodeKind     = kind
160        , AST.nodeType     = t
161        , AST.nodeName     = name
162        , AST.nodeArrSize  = size
163        }
164    <?> "node declaration"
165
166nodeKind = option AST.InternalNode $ choice [input, output]
167    where
168        input = do
169            reserved "input"
170            return AST.InputPort
171        output = do
172            reserved "output"
173            return AST.OutputPort
174
175nodeType = do
176    pos <- getPositionMeta
177    originDomain <- domain
178    originType <- edgeType
179    (targetDomain, targetType) <- option (originDomain, Nothing) $ do
180        reserved "to"
181        d <- domain
182        t <- optionMaybe edgeType
183        return (d, t)
184    return AST.NodeType
185        { AST.nodeTypeMeta = pos
186        , AST.originDomain = originDomain
187        , AST.originType   = originType
188        , AST.targetDomain = targetDomain
189        , AST.targetType   = targetType
190        }
191
192
193domain = choice [memory, intr, power, clock] <?> "node domain"
194    where
195        memory = do
196            reserved "memory"
197            return AST.Memory
198        intr = do
199            reserved "intr"
200            return AST.Interrupt
201        power = do
202            reserved "power"
203            return AST.Power
204        clock = do
205            reserved "clock"
206            return AST.Clock
207
208edgeType = choice [literal, named]
209    where
210        literal = do
211            pos <- getPositionMeta
212            addrType <- addressType
213            return $ AST.TypeLiteral pos addrType
214        named = do
215            pos <- getPositionMeta
216            name <- parens typeName
217            return $ AST.TypeName pos name
218            <?> "(<type name>)"
219
220definition = choice [forall, def]
221    where
222        def = do
223            receiver <- unqualifiedRef
224            choice
225                [ accepts receiver
226                , maps receiver
227                , converts receiver
228                , overlays receiver
229                , blockoverlays receiver
230                , instantiates receiver
231                , binds receiver
232                ]
233
234accepts node = do
235    pos <- getPositionMeta
236    reserved "accepts"
237    blocks <- brackets $ semiSep addressBlock
238    return $ AST.Accepts pos node blocks
239
240maps node = do
241    pos <- getPositionMeta
242    reserved "maps"
243    maps <- brackets $ semiSep mapSpec
244    return $ AST.Maps pos node maps
245
246mapSpec = do
247    pos <- getPositionMeta
248    addr <- addressBlock
249    reserved "to"
250    targets <- commaSep1 mapTarget
251    return $ AST.MapSpec pos addr targets
252    where
253        mapTarget = do
254            pos <- getPositionMeta
255            node <- nodeReference
256            reserved "at"
257            addr <- addressBlock
258            return $ AST.MapTarget pos node addr
259
260converts node = do
261    pos <- getPositionMeta
262    reserved "converts"
263    converts <- brackets $ semiSep convertSpec
264    return $ AST.Converts pos node converts
265
266convertSpec = mapSpec
267
268blockoverlays node = do
269    pos <- getPositionMeta
270    reserved "blockoverlays"
271    overlay <- nodeReference
272    reserved "bits"
273    blocksizes <- parens $ commaSep1 natural
274    return $ AST.BlockOverlays pos node overlay blocksizes
275
276overlays node = do
277    pos <- getPositionMeta
278    reserved "overlays"
279    overlay <- nodeReference
280    return $ AST.Overlays pos node overlay
281
282instantiates inst = do
283    pos <- getPositionMeta
284    reserved "instantiates"
285    modName <- moduleName
286    args <- option [] (parens $ commaSep naturalExpr)
287    return AST.Instantiates
288        { AST.defMeta    = pos
289        , AST.inst       = inst
290        , AST.instModule = modName
291        , AST.arguments  = args
292        }
293
294binds inst = do
295    pos <- getPositionMeta
296    reserved "binds"
297    bindings <- brackets $ semiSep portBinding
298    return $ AST.Binds pos inst bindings
299    where
300        portBinding = do
301            pos <- getPositionMeta
302            port <- unqualifiedRef
303            reserved "to"
304            node <- nodeReference
305            return $ AST.PortBinding pos port node
306
307forall = do
308    pos <- getPositionMeta
309    reserved "forall"
310    var <- variableName
311    reserved "in"
312    range <- parens naturalSet
313    body <- braces $ many definition
314    return AST.Forall
315        { AST.defMeta        = pos
316        , AST.boundVarName   = var
317        , AST.varRange       = range
318        , AST.quantifierBody = body
319        }
320
321unqualifiedRef = do
322    pos <- getPositionMeta
323    name <- identifierName
324    index <- optionMaybe arrayIndex
325    return AST.UnqualifiedRef
326        { AST.refMeta  = pos
327        , AST.refName  = name
328        , AST.refIndex = index
329        }
330
331nodeReference = do
332    pos <- getPositionMeta
333    ref1 <- unqualifiedRef
334    ref2 <- optionMaybe $ (reservedOp "." >> unqualifiedRef)
335    return $ maybe (AST.InternalNodeRef pos ref1) (AST.InputPortRef pos ref1) ref2
336
337namedType = do
338    pos <- getPositionMeta
339    reserved "type"
340    name <- typeName
341    addrType <- addressType
342    return $ AST.NamedType pos name addrType
343    <?> "named type"
344
345namedConstant = do
346    pos <- getPositionMeta
347    reserved "const"
348    name <- constName
349    value <- natural
350    return $ AST.NamedConstant pos name value
351    <?> "named constant"
352
353addressType = do
354    pos <- getPositionMeta
355    addrType <- parens $ semiSep1 naturalSet
356    return $ AST.AddressType pos addrType
357    <?> "address type literal"
358
359address = do
360    pos <- getPositionMeta
361    addr <- parens $ semiSep1 wildcardSet
362    return $ AST.Address pos addr
363    <?> "address tuple"
364
365addressBlock = do
366    pos <- getPositionMeta
367    addr <- address
368    props <- option AST.True propertyExpr
369    return $ AST.AddressBlock pos addr props
370
371arraySize = do
372    pos <- getPositionMeta
373    size <- brackets $ semiSep1 naturalSet
374    return $ AST.ArraySize pos size
375    <?> "array size"
376
377arrayIndex = do
378    pos <- getPositionMeta
379    index <- brackets $ semiSep1 wildcardSet
380    return $ AST.ArrayIndex pos index
381    <?> "array index"
382
383naturalSet = do
384    pos <- getPositionMeta
385    ranges <- commaSep1 naturalRange
386    return $ AST.NaturalSet pos ranges
387    <?> "set of naturals"
388
389wildcardSet = choice [wildcard, explicit]
390    where
391        explicit = do
392            pos <- getPositionMeta
393            set <- naturalSet
394            return $ AST.ExplicitSet pos set
395        wildcard = do
396            pos <- getPositionMeta
397            reservedOp "*"
398            return $ AST.Wildcard pos
399
400naturalRange = do
401    pos <- getPositionMeta
402    base <- naturalExpr
403    choice [bits pos base, limit pos base, singleton pos base]
404    <?> "range of naturals"
405    where
406        bits pos base = do
407            reserved "bits"
408            bits <- naturalExpr
409            return $ AST.BitsRange pos base bits
410        limit pos base = do
411            reserved "to"
412            limit <- naturalExpr
413            return $ AST.LimitRange pos base limit
414        singleton pos base = return $ AST.SingletonRange pos base
415
416naturalExpr = buildExpressionParser opTable term <?> "arithmetic expression"
417    where
418        term = parens naturalExpr <|> var <|> lit
419        opTable =
420            [ [ Postfix slice ]
421            , [ Infix mult AssocLeft ]
422            , [ Infix add AssocLeft, Infix sub AssocLeft ]
423            , [ Infix concat AssocLeft ]
424            ]
425        var = do
426            pos <- getPositionMeta
427            name <- variableName
428            return $ AST.Variable pos name
429        lit = do
430            pos <- getPositionMeta
431            value <- natural
432            return $ AST.Literal pos value
433        slice = do
434            pos <- getPositionMeta
435            range <- brackets naturalRange
436            return $ flip (AST.Slice pos) range
437        mult = do
438            pos <- getPositionMeta
439            reservedOp "*"
440            return $ AST.Multiplication pos
441        add = do
442            pos <- getPositionMeta
443            reservedOp "+"
444            return $ AST.Addition pos
445        sub = do
446            pos <- getPositionMeta
447            reservedOp "-"
448            return $ AST.Subtraction pos
449        concat = do
450            pos <- getPositionMeta
451            reservedOp "++"
452            return $ AST.Concat pos
453
454propertyExpr = buildExpressionParser opTable term <?> "property expression"
455    where
456        term = parens propertyExpr <|> prop
457        opTable =
458            [ [ Prefix not ]
459            , [ Infix and AssocLeft, Infix or AssocLeft ]
460            ]
461        prop = do
462            pos <- getPositionMeta
463            name <- propertyName
464            return $ AST.Property pos name
465        not = do
466            pos <- getPositionMeta
467            reservedOp "!"
468            return $ AST.Not pos
469        and = do
470            pos <- getPositionMeta
471            reservedOp "&&"
472            return $ AST.And pos
473        or = do
474            pos <- getPositionMeta
475            reservedOp "||"
476            return $ AST.Or pos
477
478{- Helper functions -}
479lexer = P.makeTokenParser (
480    emptyDef {
481        {- List of reserved names -}
482        P.reservedNames =
483            [ "import", "as"
484            , "extern"
485            , "module"
486            , "input", "output"
487            , "type", "const"
488            , "memory", "intr", "power", "clock", "instance"
489            , "of"
490            , "forall", "in"
491            , "accepts", "maps", "converts", "overlays", "blockoverlays"
492            , "instantiates", "binds"
493            , "to", "at"
494            , "bits"
495            ],
496
497        {- List of operators -}
498        P.reservedOpNames =
499            [ "+", "-", "*", "/", "++"
500            , "!", "&&", "||"
501            , "."
502            ],
503
504        {- Valid identifiers -}
505        P.identStart = letter,
506        P.identLetter = alphaNum <|> char '_',
507
508        {- comment start and end -}
509        P.commentStart = "/*",
510        P.commentEnd = "*/",
511        P.commentLine = "//",
512        P.nestedComments = False,
513
514        {- Sockeye is case sensitive -}
515        P.caseSensitive = True
516    })
517
518whiteSpace    = P.whiteSpace lexer
519reserved      = P.reserved lexer
520reservedOp    = P.reservedOp lexer
521parens        = P.parens lexer
522brackets      = P.brackets lexer
523braces        = P.braces lexer
524commaSep      = P.commaSep lexer
525commaSep1     = P.commaSep1 lexer
526semiSep       = P.semiSep lexer
527semiSep1      = P.semiSep1 lexer
528identString   = P.identifier lexer
529natural       = P.natural lexer
530
531typeName       = identString <?> "type name"
532constName      = identString <?> "constant name"
533moduleName     = identString <?> "module name"
534parameterName  = identString <?> "parameter name"
535variableName   = identString <?> "variable name"
536propertyName   = identString <?> "property name"
537identifierName = identString <?> "identifier"
538
539getPositionMeta = fmap ParserMeta getPosition
540