T185: sockeye: update parser to do correct type rewiring
[barrelfish] / tools / sockeye / SockeyeParser.hs
1 {- 
2  
3    Parser.hs: Parser for the Sockeye schema definition language
4                       
5    Part of Sockeye: a strawman device definition DSL for Barrelfish
6    
7   Copyright (c) 2015, 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 SockeyeParser where
17
18 import SockeyeSyntax
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 name filename = parseFromFile (intffile predefDecls name) filename
32 parse_include predefDecls filename = parseFromFile (includefile predefDecls) filename
33
34 lexer = P.makeTokenParser (javaStyle
35                            { P.reservedNames = [ "fact",
36                                                  "query",
37                                                  "key",
38                                                  "unique"
39                                                ]
40                            , P.reservedOpNames = ["*","/","+","-"]
41                            , P.commentStart = "/*"
42                            , P.commentEnd = "*/"
43                            })
44
45 whiteSpace = P.whiteSpace lexer 
46 reserved   = P.reserved lexer
47 identifier = P.identifier lexer
48 stringLit  = P.stringLiteral lexer
49 comma      = P.comma lexer
50 commaSep   = P.commaSep lexer
51 commaSep1  = P.commaSep1 lexer
52 parens     = P.parens lexer
53 braces     = P.braces lexer
54 squares    = P.squares lexer
55 semiSep    = P.semiSep lexer
56 symbol     = P.symbol lexer
57 natural    = P.natural lexer
58
59 builtinTypes = map show [UInt8 ..] ++ ["int"] -- int is legacy -AB
60
61 -- identifyBuiltin :: [(String, Declaration)] -> String -> TypeRef
62 identifyBuiltin typeDcls typeName = 
63     do {
64       if typeName `elem` builtinTypes then
65           return $ Builtin $ (read typeName::TypeBuiltin)
66       else 
67           case typeName `lookup` typeDcls of
68             Just (Typedef (TAliasT new orig)) -> return $ TypeAlias new orig
69             Just (Typedef (TAlias new orig)) -> return $ orig
70 --            Just x -> trace (show x) return $ TypeVar typeName
71             Nothing -> return $ UnknownType typeName
72 -- This needs to go to SockeyeTools:
73 --                do {
74 --                ; pos <- getPosition
75 --                -- This is ugly, I agree:
76 --                ; return $ error ("Use of undeclared type '" ++ typeName ++ "' in "
77 --                                  ++ show (sourceName pos) ++ " at l. "
78 --                                  ++ show (sourceLine pos) ++ " col. "
79 --                                  ++ show (sourceColumn pos))
80 --                }
81     }
82
83 intffile predefDecls name = do { whiteSpace
84              ; i <- pSchema predefDecls name
85              ; return i
86               }
87
88 includefile predefDecls = do { whiteSpace
89              ; typeDecls <- typeDeclaration predefDecls
90              ; return typeDecls
91               }
92
93 pSchema predefDecls _ = do { reserved "schema"
94            ; name <- identifier 
95            ; descr <- option name stringLit
96            ; decls <- braces $ do {
97                                ; typeDecls <- typeDeclaration predefDecls
98                                ; factDecls <- many1 $ pFact typeDecls
99                                ; queryDecls <- many $ pQuery typeDecls
100                                ; return ((map snd typeDecls) ++ factDecls ++ queryDecls)
101                                }
102            ; symbol ";" <?> " ';' missing from end of " ++ name ++ " interface specification"
103            ;  return (Schema name descr decls)
104            }
105
106
107 typeDeclaration typeDcls = do {
108                            ; decl <- try (do {
109                                            ; x <- transparentAlias 
110                                            ; return $ Just x
111                                            })
112                                      <|> try (do {
113                                                ; x <- typedefinition typeDcls
114                                                ; return $ Just x
115                                                })
116                                     <|> return Nothing
117                            ; case decl of 
118                                Nothing -> return typeDcls
119                                Just x -> typeDeclaration (x : typeDcls)
120                            }
121
122 pFact typeDcls = do { def <- pFct typeDcls
123                     ; return $ Factdef def
124                     }
125
126 pQuery typeDcls = do {def <- pQry typeDcls
127                    ; return $ Querydef def
128                    }
129
130 pQry typeDcls = do { reserved "query"
131                    ; i <- identifier
132                    ; d <- option i stringLit
133                    ; attrib <- braces $ commaSep (queryParams typeDcls)
134                    ; symbol ";"
135                    ; return $ Query i d attrib
136                    }
137
138
139 pFct typeDcls = do { reserved "fact"
140                    ; i <- identifier
141                    ; d <- option i stringLit
142                    ; attrib <- braces $ do { attrDecls <- many $ factAttribs typeDcls
143                                            ; return attrDecls
144                                            }
145                    ; symbol ";"
146                    ; return $ Fact i d attrib
147                    }
148
149
150 factAttribs typeDecls = do { b <-factAttribType typeDecls
151                            ; i <- identifier
152                            ; d <- option i stringLit
153                            ; symbol ";"
154                            ; return (FAttrib b (Name i) d)
155                            }
156  
157 --- XXX: verify that the fact is already defined
158 factAttribTypeRef typeDecls = do {
159                                  t <- identifier 
160                                --  ; b <- identifyBuiltin typeDecls t
161                                  ; return $ FactType t
162                               --   ; return b
163                                  }
164
165 factAttribTypeBultIn typeDecls = do { t <- identifier 
166                                     ; b <- identifyBuiltin typeDecls t
167                                     ; return b
168                                     }
169
170
171 factAttribType typeDcls = try (factAttribTypeBultIn typeDcls)
172                         <|> (factAttribTypeRef typeDcls)
173
174
175
176
177 queryParams typeDecls = do { i <- identifier
178                            ; symbol "="
179                            ; v <- identifier
180                            ; symbol ";"
181                            ; return $ QParam (Name i) i 
182                            }
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 enum_typedef
202                         <|> (alias_typedef typeDcls)
203  
204
205 enum_typedef = do { reserved "enum"
206                   ; v <- braces $ commaSep1 identifier
207                   ; i <- identifier
208                   ; return (i, (TEnum i v))
209                   }
210
211 alias_typedef typeDcls = do { t <- identifier
212                             ; i <- identifier
213                             ; b <- identifyBuiltin typeDcls t
214                             ; return (i, (TAlias i b))
215                             }
216
217 integer = P.integer lexer