Unions

compiler/src/Compiler.hs

@@ -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
+    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." expected kind
-
-maxFieldNumber = 1023
+                         \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

@@ -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))]
@@ -64,7 +65,8 @@ 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 (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

@@ -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

@@ -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

@@ -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

@@ -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)