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
16module Parser where
17
18import Syntax
19
20import Prelude
21import Text.ParserCombinators.Parsec as Parsec
22import Text.ParserCombinators.Parsec.Expr
23import Text.ParserCombinators.Parsec.Pos
24import qualified Text.ParserCombinators.Parsec.Token as P
25import Text.ParserCombinators.Parsec.Language( javaStyle )
26import Data.Char
27import Numeric
28import Data.List
29import Text.Printf
30
31parse_intf predefDecls filename = parseFromFile (intffile predefDecls) filename
32parse_include predefDecls filename = parseFromFile (includefile predefDecls) filename
33
34lexer = 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
46whiteSpace = P.whiteSpace lexer
47reserved   = P.reserved lexer
48identifier = P.identifier lexer
49stringLit  = P.stringLiteral lexer
50comma      = P.comma lexer
51commaSep   = P.commaSep lexer
52commaSep1  = P.commaSep1 lexer
53parens     = P.parens lexer
54braces     = P.braces lexer
55squares    = P.squares lexer
56semiSep    = P.semiSep lexer
57symbol     = P.symbol lexer
58natural    = P.natural lexer
59
60builtinTypes = map show [UInt8 ..] ++ ["errval"] ++ ["int"] -- int is legacy -AB
61
62-- identifyBuiltin :: [(String, Declaration)] -> String -> TypeRef
63identifyBuiltin 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
82intffile predefDecls = do { whiteSpace
83             ; i <- iface predefDecls
84             ; return i
85              }
86
87includefile predefDecls = do { whiteSpace
88             ; typeDecls <- typeDeclaration predefDecls
89             ; return typeDecls
90              }
91
92iface 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
105typeDeclaration 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
120mesg typeDcls = do { bckArgs <- many backendParams
121                   ; def <- msg typeDcls bckArgs <|> rpc typeDcls bckArgs
122                   ; return $ Messagedef def
123                   }
124
125msg 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
132rpc typeDcls bckArgs= do { _ <- rpctype
133                         ; i <- identifier
134                         ; a <- parens $ commaSep (rpcArg typeDcls)
135                         ; symbol ";"
136                         ; return $ RPC i a bckArgs
137                         }
138
139rpctype = do { reserved "rpc"
140             ; return () }
141
142rpcArg 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
151backendParams = do { char '@'
152                   ; i <- identifier
153                   ; p <- parens $ commaSep backendParam
154                   ; return (i, p)
155                   }
156
157backendParam = do { name <- identifier
158                  ; symbol "="
159                  ;     do { num <- natural ; return $ (name, BackendInt num) }
160                    <|> do { arg <- identifier ; return $ (name, BackendMsgArg arg) }
161                  }
162
163msgtype = do { reserved "message"; return MMessage }
164
165marg typeDcls = try (marg_array typeDcls)
166               <|> (marg_string typeDcls)
167               <|> (marg_simple typeDcls)
168
169
170marg_string typeDcls = do {  symbol "String"
171                           ; n <- identifier
172                           ; symbol "["
173                           ; s <- natural
174                           ; symbol "]"
175                           ; bType <- identifyBuiltin typeDcls "String"
176                           ; return (Arg bType (StringArray n s))
177                           }
178
179
180marg_simple typeDcls = do { t <- identifier
181                          ; n <- identifier
182                          ; b <- identifyBuiltin typeDcls t
183                          ; return (Arg b (Name n))
184                          }
185
186marg_array typeDcls  = do { t <- identifier
187                          ; n <- identifier
188                          ; symbol "["
189                          ; l <- identifier
190                          ; comma
191                          ; s <- natural
192                          ; symbol "]"
193                          ; bType <- identifyBuiltin typeDcls t
194                          ; return (Arg bType (DynamicArray n l s))
195                          }
196
197transparentAlias = do { whiteSpace
198                      ; reserved "alias"
199                      ; newType <- identifier
200                      ; originType <- identifier
201                      ; symbol ";"
202                      ; return (newType, Typedef $ TAliasT newType
203                                                           (read originType::TypeBuiltin))
204                      }
205
206typedefinition typeDcls = do { whiteSpace
207                             ; reserved "typedef"
208                             ; (name, typeDef) <- typedef_body typeDcls
209                             ; symbol ";"
210                             ; return (name, Typedef typeDef)
211                             }
212
213typedef_body typeDcls = try (struct_typedef typeDcls)
214                        <|> try (array_typedef typeDcls)
215                        <|> try enum_typedef
216                        <|> (alias_typedef typeDcls)
217
218struct_typedef typeDcls = do { reserved "struct"
219                             ; f <- braces $ many1 (struct_field typeDcls)
220                             ; i <- identifier
221                             ; return (i, (TStruct i f))
222                             }
223
224struct_field typeDcls = do { t <- identifier
225                           ; i <- identifier
226                           ; symbol ";"
227                           ; b <- identifyBuiltin typeDcls t
228                           ; return (TStructField b i)
229                           }
230
231array_typedef typeDcls = do { t <- identifier
232                            ; i <- identifier
233                            ; symbol "["
234                            ; sz <- integer
235                            ; symbol "]"
236                            ; b <- identifyBuiltin typeDcls t
237                            ; return (i, (TArray b i sz))
238                            }
239
240enum_typedef = do { reserved "enum"
241                  ; v <- braces $ commaSep1 identifier
242                  ; i <- identifier
243                  ; return (i, (TEnum i v))
244                  }
245
246alias_typedef typeDcls = do { t <- identifier
247                            ; i <- identifier
248                            ; b <- identifyBuiltin typeDcls t
249                            ; return (i, (TAlias i b))
250                            }
251
252integer = P.integer lexer
253