Skip to content

C
capnproto
Commit 897276d9 authored by Kenton Varda's avatar Kenton Varda
Browse files
Options

Unions

parent 4b4c3970
Hide whitespace changes
Inline Side-by-side
Showing with 153 additions and 58 deletions
compiler/src/Compiler.hs
View file @ 897276d9
......@@ -251,19 +251,19 @@ compileType scope (TypeExpression n (param:moreParams)) = do
------------------------------------------------------------------------------------------
requireSequentialNumbering :: String -> [Located Integer] -> Status ()
requireSequentialNumbering kind items = Active () (loop 0 sortedItems) where
requireSequentialNumbering kind items = Active () (loop undefined (-1) sortedItems) where
sortedItems = List.sort items
loop _ [] = []
loop expected (Located pos num:rest) = result where
rest' = loop (num + 1) rest
result = if num == expected
then rest'
else err:rest' where
err = newErrorMessage (Message message) pos
message = printf "Skipped number %d. %s must be numbered sequentially starting \
\from zero." expected kind
maxFieldNumber = 1023
loop _ _ [] = []
loop _ prev (Located pos num:rest) | num == prev + 1 = loop pos num rest
loop prevPos prev (Located pos num:rest) | num == prev = err1:err2:loop pos num rest where
err1 = newErrorMessage (Message message) prevPos
err2 = newErrorMessage (Message message) pos
message = printf "Duplicate number %d. %s must be numbered uniquely within their scope."
num kind
loop _ prev (Located pos num:rest) = err:loop pos num rest where
err = newErrorMessage (Message message) pos
message = printf "Skipped number %d. %s must be numbered sequentially starting \
\from zero." (prev + 1) kind
requireFieldNumbersInRange fieldNums =
Active () [ fieldNumError num pos | Located pos num <- fieldNums, num > maxFieldNumber ] where
......@@ -287,13 +287,20 @@ requireNoDuplicateNames decls = Active () (loop (List.sort locatedNames)) where
dupError val = newErrorMessage (Message message) where
message = printf "Duplicate declaration \"%s\"." val
fieldInUnion name f = case fieldUnion f of
Nothing -> False
Just x -> (unionName x) == name
------------------------------------------------------------------------------------------
-- For CompiledMemberStatus, the second parameter contains members that should be inserted into the
-- parent's map, e.g. fields defined in a union which should be considered members of the parent
-- struct as well. Usually (except in the case of unions) this map is empty.
data CompiledStatementStatus = CompiledMemberStatus String (Status Desc)
| CompiledOptionStatus (Status OptionAssignmentDesc)
toCompiledStatement :: CompiledStatementStatus -> Maybe CompiledStatement
toCompiledStatement (CompiledMemberStatus name (Active desc _)) = Just (CompiledMember desc)
toCompiledStatement (CompiledMemberStatus _ (Active desc _)) = Just (CompiledMember desc)
toCompiledStatement (CompiledOptionStatus (Active desc _)) = Just (CompiledOption desc)
toCompiledStatement _ = Nothing
......@@ -346,22 +353,25 @@ compileDecl scope (EnumDecl (Located _ name) decls) =
, enumStatements = statements
})))
compileDecl scope (EnumValueDecl (Located _ name) (Located _ number) decls) =
compileDecl (DescEnum parent) (EnumValueDecl (Located _ name) (Located _ number) decls) =
CompiledMemberStatus name (feedback (\desc -> do
(_, _, options, statements) <- compileChildDecls desc decls
return (DescEnumValue EnumValueDesc
{ enumValueName = name
, enumValueParent = scope
, enumValueParent = parent
, enumValueNumber = number
, enumValueOptions = options
, enumValueStatements = statements
})))
compileDecl _ (EnumValueDecl (Located pos name) _ _) =
CompiledMemberStatus name (makeError pos "Enum values can only appear inside enums.")
compileDecl scope (StructDecl (Located _ name) decls) =
CompiledMemberStatus name (feedback (\desc -> do
(members, memberMap, options, statements) <- compileChildDecls desc decls
requireNoDuplicateNames decls
fieldNums <- return [ num | FieldDecl _ num _ _ _ <- decls ]
fieldNums <- return ([ num | FieldDecl _ num _ _ _ _ <- decls ] ++
[ num | UnionDecl _ num _ <- decls ])
requireSequentialNumbering "Fields" fieldNums
requireFieldNumbersInRange fieldNums
return (DescStruct StructDesc
......@@ -378,8 +388,31 @@ compileDecl scope (StructDecl (Located _ name) decls) =
, structStatements = statements
})))
compileDecl scope (FieldDecl (Located _ name) (Located _ number) typeExp defaultValue decls) =
compileDecl (DescStruct parent) (UnionDecl (Located _ name) (Located _ number) decls) =
CompiledMemberStatus name (feedback (\desc -> do
(_, _, options, statements) <- compileChildDecls desc decls
return (DescUnion UnionDesc
{ unionName = name
, unionParent = parent
, unionNumber = number
, unionFields = [f | f <- structFields parent, fieldInUnion name f]
, unionOptions = options
, unionStatements = statements
})))
compileDecl _ (UnionDecl (Located pos name) _ _) =
CompiledMemberStatus name (makeError pos "Unions can only appear inside structs.")
compileDecl scope@(DescStruct parent)
(FieldDecl (Located _ name) (Located _ number) union typeExp defaultValue decls) =
CompiledMemberStatus name (feedback (\desc -> do
unionDesc <- case union of
Nothing -> return Nothing
Just (Located p n) -> do
udesc <- maybeError (descMember n scope) p
(printf "No union '%s' defined in '%s'." n (structName parent))
case udesc of
DescUnion d -> return (Just d)
_ -> makeError p (printf "'%s' is not a union." n)
typeDesc <- compileType scope typeExp
defaultDesc <- case defaultValue of
Just (Located pos value) -> fmap Just (compileValue pos typeDesc value)
......@@ -387,13 +420,16 @@ compileDecl scope (FieldDecl (Located _ name) (Located _ number) typeExp default
(_, _, options, statements) <- compileChildDecls desc decls
return (DescField FieldDesc
{ fieldName = name
, fieldParent = scope
, fieldParent = parent
, fieldNumber = number
, fieldUnion = unionDesc
, fieldType = typeDesc
, fieldDefaultValue = defaultDesc
, fieldOptions = options
, fieldStatements = statements
})))
compileDecl _ (FieldDecl (Located pos name) _ _ _ _ _) =
CompiledMemberStatus name (makeError pos "Fields can only appear inside structs.")
compileDecl scope (InterfaceDecl (Located _ name) decls) =
CompiledMemberStatus name (feedback (\desc -> do
......@@ -414,20 +450,23 @@ compileDecl scope (InterfaceDecl (Located _ name) decls) =
, interfaceStatements = statements
})))
compileDecl scope (MethodDecl (Located _ name) (Located _ number) params returnType decls) =
compileDecl scope@(DescInterface parent)
(MethodDecl (Located _ name) (Located _ number) params returnType decls) =
CompiledMemberStatus name (feedback (\desc -> do
paramDescs <- doAll (map (compileParam scope) params)
returnTypeDesc <- compileType scope returnType
(_, _, options, statements) <- compileChildDecls desc decls
return (DescMethod MethodDesc
{ methodName = name
, methodParent = scope
, methodParent = parent
, methodNumber = number
, methodParams = paramDescs
, methodReturnType = returnTypeDesc
, methodOptions = options
, methodStatements = statements
})))
compileDecl _ (MethodDecl (Located pos name) _ _ _ _) =
CompiledMemberStatus name (makeError pos "Methods can only appear inside interfaces.")
compileDecl scope (OptionDecl name (Located valuePos value)) =
CompiledOptionStatus (do
......
compiler/src/Grammar.hs
View file @ 897276d9
......@@ -49,8 +49,9 @@ data Declaration = AliasDecl (Located String) DeclName
| EnumDecl (Located String) [Declaration]
| EnumValueDecl (Located String) (Located Integer) [Declaration]
| StructDecl (Located String) [Declaration]
| FieldDecl (Located String) (Located Integer)
| FieldDecl (Located String) (Located Integer) (Maybe (Located String))
TypeExpression (Maybe (Located FieldValue)) [Declaration]
| UnionDecl (Located String) (Located Integer) [Declaration]
| InterfaceDecl (Located String) [Declaration]
| MethodDecl (Located String) (Located Integer)
[(String, TypeExpression, Maybe (Located FieldValue))]
......@@ -59,12 +60,13 @@ data Declaration = AliasDecl (Located String) DeclName
deriving (Show)
declarationName :: Declaration -> Maybe (Located String)
declarationName (AliasDecl n _) = Just n
declarationName (ConstantDecl n _ _) = Just n
declarationName (EnumDecl n _) = Just n
declarationName (EnumValueDecl n _ _) = Just n
declarationName (StructDecl n _) = Just n
declarationName (FieldDecl n _ _ _ _) = Just n
declarationName (InterfaceDecl n _) = Just n
declarationName (MethodDecl n _ _ _ _) = Just n
declarationName (OptionDecl _ _) = Nothing
declarationName (AliasDecl n _) = Just n
declarationName (ConstantDecl n _ _) = Just n
declarationName (EnumDecl n _) = Just n
declarationName (EnumValueDecl n _ _) = Just n
declarationName (StructDecl n _) = Just n
declarationName (FieldDecl n _ _ _ _ _) = Just n
declarationName (UnionDecl n _ _) = Just n
declarationName (InterfaceDecl n _) = Just n
declarationName (MethodDecl n _ _ _ _) = Just n
declarationName (OptionDecl _ _) = Nothing
compiler/src/Lexer.hs
View file @ 897276d9
......@@ -31,11 +31,17 @@ import Text.Parsec.Language (emptyDef)
import Token
keywords =
[ (ImportKeyword, "import")
[ (InKeyword, "in")
, (OfKeyword, "of")
, (AsKeyword, "as")
, (WithKeyword, "with")
, (FromKeyword, "from")
, (ImportKeyword, "import")
, (UsingKeyword, "using")
, (ConstKeyword, "const")
, (EnumKeyword, "enum")
, (StructKeyword, "struct")
, (UnionKeyword, "union")
, (InterfaceKeyword, "interface")
, (OptionKeyword, "option")
]
......
compiler/src/Parser.hs
View file @ 897276d9
......@@ -43,13 +43,19 @@ tokenErrorString Colon = "\":\""
tokenErrorString Period = "\".\""
tokenErrorString EqualsSign = "\"=\""
tokenErrorString MinusSign = "\"-\""
tokenErrorString ImportKeyword = "\"import\""
tokenErrorString UsingKeyword = "\"using\""
tokenErrorString ConstKeyword = "\"const\""
tokenErrorString EnumKeyword = "\"enum\""
tokenErrorString StructKeyword = "\"struct\""
tokenErrorString InterfaceKeyword = "\"interface\""
tokenErrorString OptionKeyword = "\"option\""
tokenErrorString InKeyword = "keyword \"in\""
tokenErrorString OfKeyword = "keyword \"of\""
tokenErrorString AsKeyword = "keyword \"as\""
tokenErrorString WithKeyword = "keyword \"with\""
tokenErrorString FromKeyword = "keyword \"from\""
tokenErrorString ImportKeyword = "keyword \"import\""
tokenErrorString UsingKeyword = "keyword \"using\""
tokenErrorString ConstKeyword = "keyword \"const\""
tokenErrorString EnumKeyword = "keyword \"enum\""
tokenErrorString StructKeyword = "keyword \"struct\""
tokenErrorString UnionKeyword = "keyword \"union\""
tokenErrorString InterfaceKeyword = "keyword \"interface\""
tokenErrorString OptionKeyword = "keyword \"option\""
type TokenParser = Parsec [Located Token] [ParseError]
......@@ -78,11 +84,13 @@ colon = tokenParser (matchSimpleToken Colon) <?> "\":\""
period = tokenParser (matchSimpleToken Period) <?> "\".\""
equalsSign = tokenParser (matchSimpleToken EqualsSign) <?> "\"=\""
minusSign = tokenParser (matchSimpleToken MinusSign) <?> "\"=\""
inKeyword = tokenParser (matchSimpleToken InKeyword) <?> "\"in\""
importKeyword = tokenParser (matchSimpleToken ImportKeyword) <?> "\"import\""
usingKeyword = tokenParser (matchSimpleToken UsingKeyword) <?> "\"using\""
constKeyword = tokenParser (matchSimpleToken ConstKeyword) <?> "\"const\""
enumKeyword = tokenParser (matchSimpleToken EnumKeyword) <?> "\"enum\""
structKeyword = tokenParser (matchSimpleToken StructKeyword) <?> "\"struct\""
unionKeyword = tokenParser (matchSimpleToken UnionKeyword) <?> "\"union\""
interfaceKeyword = tokenParser (matchSimpleToken InterfaceKeyword) <?> "\"interface\""
optionKeyword = tokenParser (matchSimpleToken OptionKeyword) <?> "\"option\""
......@@ -110,6 +118,13 @@ typeExpression = do
suffixes <- option [] (parenthesizedList typeExpression)
return (TypeExpression name suffixes)
nameWithOrdinal :: TokenParser (Located String, Located Integer)
nameWithOrdinal = do
name <- located identifier
atSign
ordinal <- located literalInt
return (name, ordinal)
topLine :: Maybe [Located Statement] -> TokenParser Declaration
topLine Nothing = optionDecl <|> aliasDecl <|> constantDecl
topLine (Just statements) = typeDecl statements
......@@ -162,18 +177,27 @@ structDecl statements = do
return (StructDecl name children)
structLine :: Maybe [Located Statement] -> TokenParser Declaration
structLine Nothing = optionDecl <|> constantDecl <|> fieldDecl []
structLine (Just statements) = typeDecl statements <|> fieldDecl statements
structLine Nothing = optionDecl <|> constantDecl <|> unionDecl [] <|> fieldDecl []
structLine (Just statements) = typeDecl statements <|> unionDecl statements <|> fieldDecl statements
unionDecl statements = do
unionKeyword
(name, ordinal) <- nameWithOrdinal
children <- parseBlock unionLine statements
return (UnionDecl name ordinal children)
unionLine :: Maybe [Located Statement] -> TokenParser Declaration
unionLine Nothing = optionDecl <|> fieldDecl []
unionLine (Just statements) = fieldDecl statements
fieldDecl statements = do
name <- located identifier
atSign
ordinal <- located literalInt
(name, ordinal) <- nameWithOrdinal
union <- optionMaybe (inKeyword >> located identifier)
colon
t <- typeExpression
value <- optionMaybe (equalsSign >> located fieldValue)
children <- parseBlock fieldLine statements
return (FieldDecl name ordinal t value children)
return (FieldDecl name ordinal union t value children)
negativeFieldValue = liftM (IntegerFieldValue . negate) literalInt
<|> liftM (FloatFieldValue . negate) literalFloat
......@@ -208,9 +232,7 @@ interfaceLine Nothing = optionDecl <|> constantDecl <|> methodDecl []
interfaceLine (Just statements) = typeDecl statements <|> methodDecl statements
methodDecl statements = do
name <- located identifier
atSign
ordinal <- located literalInt
(name, ordinal) <- nameWithOrdinal
params <- parenthesizedList paramDecl
colon
t <- typeExpression
......
compiler/src/Semantics.hs
View file @ 897276d9
......@@ -33,6 +33,8 @@ import Text.Printf(printf)
import Control.Monad(join)
import Util(delimit)
maxFieldNumber = 255
type ByteString = [Word8]
data Desc = DescFile FileDesc
......@@ -41,6 +43,7 @@ data Desc = DescFile FileDesc
| DescEnum EnumDesc
| DescEnumValue EnumValueDesc
| DescStruct StructDesc
| DescUnion UnionDesc
| DescField FieldDesc
| DescInterface InterfaceDesc
| DescMethod MethodDesc
......@@ -54,6 +57,7 @@ descName (DescConstant d) = constantName d
descName (DescEnum d) = enumName d
descName (DescEnumValue d) = enumValueName d
descName (DescStruct d) = structName d
descName (DescUnion d) = unionName d
descName (DescField d) = fieldName d
descName (DescInterface d) = interfaceName d
descName (DescMethod d) = methodName d
......@@ -65,11 +69,12 @@ descParent (DescFile _) = error "File descriptor has no parent."
descParent (DescAlias d) = aliasParent d
descParent (DescConstant d) = constantParent d
descParent (DescEnum d) = enumParent d
descParent (DescEnumValue d) = enumValueParent d
descParent (DescEnumValue d) = DescEnum (enumValueParent d)
descParent (DescStruct d) = structParent d
descParent (DescField d) = fieldParent d
descParent (DescUnion d) = DescStruct (unionParent d)
descParent (DescField d) = DescStruct (fieldParent d)
descParent (DescInterface d) = interfaceParent d
descParent (DescMethod d) = methodParent d
descParent (DescMethod d) = DescInterface (methodParent d)
descParent (DescOption d) = optionParent d
descParent (DescBuiltinType _) = error "Builtin type has no parent."
descParent DescBuiltinList = error "Builtin type has no parent."
......@@ -200,7 +205,7 @@ data EnumDesc = EnumDesc
data EnumValueDesc = EnumValueDesc
{ enumValueName :: String
, enumValueParent :: Desc
, enumValueParent :: EnumDesc
, enumValueNumber :: Integer
, enumValueOptions :: OptionMap
, enumValueStatements :: [CompiledStatement]
......@@ -220,10 +225,20 @@ data StructDesc = StructDesc
, structStatements :: [CompiledStatement]
}
data UnionDesc = UnionDesc
{ unionName :: String
, unionParent :: StructDesc
, unionNumber :: Integer
, unionFields :: [FieldDesc]
, unionOptions :: OptionMap
, unionStatements :: [CompiledStatement]
}
data FieldDesc = FieldDesc
{ fieldName :: String
, fieldParent :: Desc
, fieldParent :: StructDesc
, fieldNumber :: Integer
, fieldUnion :: Maybe UnionDesc
, fieldType :: TypeDesc
, fieldDefaultValue :: Maybe ValueDesc
, fieldOptions :: OptionMap
......@@ -246,7 +261,7 @@ data InterfaceDesc = InterfaceDesc
data MethodDesc = MethodDesc
{ methodName :: String
, methodParent :: Desc
, methodParent :: InterfaceDesc
, methodNumber :: Integer
, methodParams :: [(String, TypeDesc, Maybe ValueDesc)]
, methodReturnType :: TypeDesc
......@@ -291,22 +306,27 @@ descToCode indent (DescEnumValue desc) = printf "%s%s = %d%s" indent
descToCode indent (DescStruct desc) = printf "%sstruct %s%s" indent
(structName desc)
(blockCode indent (structStatements desc))
descToCode indent (DescField desc) = printf "%s%s@%d: %s%s%s" indent
descToCode indent (DescField desc) = printf "%s%s@%d%s: %s%s%s" indent
(fieldName desc) (fieldNumber desc)
(typeName (fieldParent desc) (fieldType desc))
(case fieldUnion desc of { Nothing -> ""; Just u -> " in " ++ unionName u})
(typeName (DescStruct (fieldParent desc)) (fieldType desc))
(case fieldDefaultValue desc of { Nothing -> ""; Just v -> " = " ++ valueString v; })
(maybeBlockCode indent $ fieldStatements desc)
descToCode indent (DescUnion desc) = printf "%sunion %s@%d%s" indent
(unionName desc) (unionNumber desc)
(maybeBlockCode indent $ unionStatements desc)
descToCode indent (DescInterface desc) = printf "%sinterface %s%s" indent
(interfaceName desc)
(blockCode indent (interfaceStatements desc))
descToCode indent (DescMethod desc) = printf "%s%s@%d(%s): %s%s" indent
(methodName desc) (methodNumber desc)
(delimit ", " (map paramToCode (methodParams desc)))
(typeName (methodParent desc) (methodReturnType desc))
(typeName scope (methodReturnType desc))
(maybeBlockCode indent $ methodStatements desc) where
paramToCode (name, t, Nothing) = printf "%s: %s" name (typeName (methodParent desc) t)
scope = DescInterface (methodParent desc)
paramToCode (name, t, Nothing) = printf "%s: %s" name (typeName scope t)
paramToCode (name, t, Just v) = printf "%s: %s = %s"
name (typeName (methodParent desc) t) (valueString v)
name (typeName scope t) (valueString v)
descToCode _ (DescOption _) = error "options not implemented"
descToCode _ (DescBuiltinType _) = error "Can't print code for builtin type."
descToCode _ DescBuiltinList = error "Can't print code for builtin type."
......
compiler/src/Token.hs
View file @ 897276d9
......@@ -48,11 +48,17 @@ data Token = Identifier String
| Period
| EqualsSign
| MinusSign
| InKeyword
| OfKeyword
| AsKeyword
| WithKeyword
| FromKeyword
| ImportKeyword
| UsingKeyword
| ConstKeyword
| EnumKeyword
| StructKeyword
| UnionKeyword
| InterfaceKeyword
| OptionKeyword
deriving (Show, Eq)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment