git.barrelfish.org Git - barrelfish/blob - 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