6d8a5f9bffbe9274c61510085b5f1b9cffa8a644
[barrelfish] / tools / flounder / Parser.hs
1 {- 
2  
3    Parser.hs: Parser for the Flounder interface definition language
4                       
5    Part of Flounder: a strawman device definition DSL for Barrelfish
6    
7   Copyright (c) 2009, ETH Zurich.
8
9   All rights reserved.
10   
11   This file is distributed under the terms in the attached LICENSE file.
12   If you do not find this file, copies can be found by writing to:
13   ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group.
14 -}
15   
16 module Parser where
17
18 import Syntax
19
20 import Prelude 
21 import Text.ParserCombinators.Parsec as Parsec
22 import Text.ParserCombinators.Parsec.Expr
23 import Text.ParserCombinators.Parsec.Pos
24 import qualified Text.ParserCombinators.Parsec.Token as P
25 import Text.ParserCombinators.Parsec.Language( javaStyle )
26 import Data.Char
27 import Numeric
28 import Data.List
29 import Text.Printf
30
31 parse_intf predefDecls filename = parseFromFile (intffile predefDecls) filename
32 parse_include predefDecls filename = parseFromFile (includefile predefDecls) filename
33
34 lexer = P.makeTokenParser (javaStyle
35                            { P.reservedNames = [ "interface", 
36                                                  "message",
37                                                  "rpc",
38                                                  "in",
39                                                  "out"
40                                                ]
41                            , P.reservedOpNames = ["*","/","+","-"]
42                            , P.commentStart = "/*"
43                            , P.commentEnd = "*/"
44                            })
45
46 whiteSpace = P.whiteSpace lexer 
47 reserved   = P.reserved lexer
48 identifier = P.identifier lexer
49 stringLit  = P.stringLiteral lexer
50 comma      = P.comma lexer
51 commaSep   = P.commaSep lexer
52 commaSep1  = P.commaSep1 lexer
53 parens     = P.parens lexer
54 braces     = P.braces lexer
55 squares    = P.squares lexer
56 semiSep    = P.semiSep lexer
57 symbol     = P.symbol lexer
58 natural    = P.natural lexer
59
60 builtinTypes = map show [UInt8 ..] ++ ["int"] -- int is legacy -AB
61
62 -- identifyBuiltin :: [(String, Declaration)] -> String -> TypeRef
63 identifyBuiltin typeDcls typeName = 
64     do {
65       if typeName `elem` builtinTypes then
66           return $ Builtin $ (read typeName::TypeBuiltin)
67       else 
68           case typeName `lookup` typeDcls of
69             Just (Typedef (TAliasT new orig)) -> return $ TypeAlias new orig
70             Just _ -> return $ TypeVar typeName 
71             Nothing -> 
72                 do {
73                 ; pos <- getPosition
74                 -- This is ugly, I agree:
75                 ; return $ error ("Use of undeclared type '" ++ typeName ++ "' in "
76                                   ++ show (sourceName pos) ++ " at l. "
77                                   ++ show (sourceLine pos) ++ " col. "
78                                   ++ show (sourceColumn pos))
79                 }
80     }
81
82 intffile predefDecls = do { whiteSpace
83              ; i <- iface predefDecls
84              ; return i
85               }
86
87 includefile predefDecls = do { whiteSpace
88              ; typeDecls <- typeDeclaration predefDecls
89              ; return typeDecls
90               }
91
92 iface predefDecls = do { reserved "interface"
93            ; name <- identifier 
94            ; descr <- option name stringLit
95            ; decls <- braces $ do {
96                                ; typeDecls <- typeDeclaration predefDecls
97                                ; msgDecls <- many1 $ mesg typeDecls
98                                ; return ((map snd typeDecls) ++ msgDecls)
99                                }
100            ; symbol ";" <?> " ';' missing from end of " ++ name ++ " interface specification"
101            ;  return (Interface name (Just descr) decls)
102            }
103
104
105 typeDeclaration typeDcls = do {
106                            ; decl <- try (do {
107                                            ; x <- transparentAlias 
108                                            ; return $ Just x
109                                            })
110                                      <|> try (do {
111                                                ; x <- typedefinition typeDcls
112                                                ; return $ Just x
113                                                })
114                                     <|> return Nothing
115                            ; case decl of 
116                                Nothing -> return typeDcls
117                                Just x -> typeDeclaration (x : typeDcls)
118                            }       
119
120 mesg typeDcls = do { bckArgs <- many backendParams
121                    ; def <- msg typeDcls bckArgs <|> rpc typeDcls bckArgs
122                    ; return $ Messagedef def
123                    }
124
125 msg typeDcls bckArgs = do { t <- msgtype
126                           ; i <- identifier
127                           ; a <- parens $ commaSep (marg typeDcls)
128                           ; symbol ";"
129                           ; return $ Message t i a bckArgs
130                           }
131
132 rpc typeDcls bckArgs= do { _ <- rpctype
133                          ; i <- identifier
134                          ; a <- parens $ commaSep (rpcArg typeDcls)
135                          ; symbol ";"
136                          ; return $ RPC i a bckArgs
137                          }
138
139 rpctype = do { reserved "rpc"
140              ; return () }
141
142 rpcArg typeDcls = do { reserved "in"
143                        ; Arg b n <- marg typeDcls
144                        ; return $ RPCArgIn b n
145                        }
146                        <|> do { reserved "out"
147                        ; Arg b n <- marg typeDcls
148                        ; return $ RPCArgOut b n
149                        }
150
151 backendParams = do { char '@'
152                    ; i <- identifier
153                    ; p <- parens $ commaSep backendParam
154                    ; return (i, p)
155                    }
156
157 backendParam = do { name <- identifier
158                   ; symbol "="
159                   ;     do { num <- natural ; return $ (name, BackendInt num) }
160                     <|> do { arg <- identifier ; return $ (name, BackendMsgArg arg) }
161                   }
162
163 msgtype = do { reserved "message"; return MMessage }
164           <|> do  { reserved "call"; return MCall }
165           <|> do  { reserved "response"; return MResponse }
166
167 marg typeDcls = try (marg_array typeDcls)
168                <|> (marg_simple typeDcls)
169
170 marg_simple typeDcls = do { t <- identifier
171                           ; n <- identifier
172                           ; b <- identifyBuiltin typeDcls t
173                           ; return (Arg b (Name n))
174                           }
175
176 marg_array typeDcls  = do { t <- identifier
177                           ; n <- identifier
178                           ; symbol "["
179                           ; l <- identifier
180                           ; symbol "]"
181                           ; bType <- identifyBuiltin typeDcls t
182                           ; return (Arg bType (DynamicArray n l))
183                           }
184
185 transparentAlias = do { whiteSpace 
186                       ; reserved "alias"
187                       ; newType <- identifier
188                       ; originType <- identifier
189                       ; symbol ";"
190                       ; return (newType, Typedef $ TAliasT newType 
191                                                            (read originType::TypeBuiltin))
192                       }
193
194 typedefinition typeDcls = do { whiteSpace
195                              ; reserved "typedef"
196                              ; (name, typeDef) <- typedef_body typeDcls
197                              ; symbol ";"
198                              ; return (name, Typedef typeDef)
199                              }
200
201 typedef_body typeDcls = try (struct_typedef typeDcls)
202                         <|> try (array_typedef typeDcls)
203                         <|> try enum_typedef
204                         <|> (alias_typedef typeDcls)
205  
206 struct_typedef typeDcls = do { reserved "struct"
207                              ; f <- braces $ many1 (struct_field typeDcls)
208                              ; i <- identifier
209                              ; return (i, (TStruct i f))
210                              }
211
212 struct_field typeDcls = do { t <- identifier
213                            ; i <- identifier 
214                            ; symbol ";"
215                            ; b <- identifyBuiltin typeDcls t
216                            ; return (TStructField b i)
217                            }
218
219 array_typedef typeDcls = do { t <- identifier
220                             ; i <- identifier
221                             ; symbol "["
222                             ; sz <- integer
223                             ; symbol "]"
224                             ; b <- identifyBuiltin typeDcls t
225                             ; return (i, (TArray b i sz))
226                             }
227
228 enum_typedef = do { reserved "enum"
229                   ; v <- braces $ commaSep1 identifier
230                   ; i <- identifier
231                   ; return (i, (TEnum i v))
232                   }
233
234 alias_typedef typeDcls = do { t <- identifier
235                             ; i <- identifier
236                             ; b <- identifyBuiltin typeDcls t
237                             ; return (i, (TAlias i b))
238                             }
239
240 integer = P.integer lexer