Implement annotations.

compiler/src/Compiler.hs

@@ -27,6 +27,7 @@ import Grammar
 import Semantics
 import Token(Located(Located))
 import Parser(parseFile)
+import Control.Monad(unless)
 import qualified Data.Map as Map
 import Data.Map((!))
 import qualified Data.Set as Set
@@ -153,7 +154,27 @@ lookupDesc scope name = lookupDesc (descParent scope) name
 builtinTypeMap :: Map.Map String Desc
 builtinTypeMap = Map.fromList
     ([(builtinTypeName t, DescBuiltinType t) | t <- builtinTypes] ++
-     [("List", DescBuiltinList)])
+     [("List", DescBuiltinList), ("id", DescAnnotation builtinId)])
+
+builtinId = AnnotationDesc
+    { annotationName = "id"
+    , annotationParent = DescFile FileDesc
+        { fileName = "capnproto-builtins.capnp"
+        , fileImports = []
+        , fileAliases = []
+        , fileConstants = []
+        , fileEnums = []
+        , fileStructs = []
+        , fileInterfaces = []
+        , fileAnnotations = Map.empty
+        , fileMemberMap = Map.fromList [("id", Just $ DescAnnotation builtinId)]
+        , fileImportMap = Map.empty
+        , fileStatements = [DescAnnotation builtinId]
+        }
+    , annotationType = BuiltinType BuiltinText
+    , annotationAnnotations = Map.fromList [(idId, (builtinId, TextDesc idId))]
+    , annotationTargets = Set.fromList [minBound::AnnotationTarget .. maxBound::AnnotationTarget]
+    }
 
 ------------------------------------------------------------------------------------------
 
@@ -283,6 +304,31 @@ compileType scope (TypeExpression n (param:moreParams)) = do
                 else makeError (declNamePos n) "'List' requires exactly one type parameter."
         _ -> makeError (declNamePos n) "Only the type 'List' can have type parameters."
 
+compileAnnotation :: Desc -> AnnotationTarget -> Annotation -> Status (AnnotationDesc, ValueDesc)
+compileAnnotation scope kind (Annotation name (Located pos value)) = do
+    nameDesc <- lookupDesc scope name
+    annDesc <- case nameDesc of
+        DescAnnotation a -> return a
+        _ -> makeError (declNamePos name)
+           $ printf "'%s' is not an annotation." (declNameString name)
+    unless (Set.member kind (annotationTargets annDesc))
+        (makeError (declNamePos name)
+        $ printf "'%s' cannot be used on %s." (declNameString name) (show kind))
+    compiledValue <- compileValue pos (annotationType annDesc) value
+    return (annDesc, compiledValue)
+
+compileAnnotationMap :: Desc -> AnnotationTarget -> [Annotation] -> Status AnnotationMap
+compileAnnotationMap scope kind annotations = do
+    compiled <- doAll $ map (compileAnnotation scope kind) annotations
+
+    -- Makes a map entry for the annotation keyed by ID.  Throws out annotations with no ID.
+    let makeMapEntry ann@(desc, _) =
+            case Map.lookup idId $ annotationAnnotations desc of
+                Just (_, TextDesc globalId) -> Just (globalId, ann)
+                _ -> Nothing
+
+    return $ Map.fromList $ mapMaybe makeMapEntry compiled
+
 ------------------------------------------------------------------------------------------
 
 findDupesBy :: Ord a => (b -> a) -> [b] -> [[b]]
@@ -345,8 +391,8 @@ requireNoMoreThanOneFieldNumberLessThan name pos num fields = Active () errors w
 
 extractFieldNumbers :: [Declaration] -> [Located Integer]
 extractFieldNumbers decls = concat
-    ([ num | FieldDecl _ num _ _ <- decls ]
-    :[ num:extractFieldNumbers uDecls | UnionDecl _ num uDecls <- decls ])
+    ([ num | FieldDecl _ num _ _ _ <- decls ]
+    :[ num:extractFieldNumbers uDecls | UnionDecl _ num _ uDecls <- decls ])
 
 ------------------------------------------------------------------------------------------
 
@@ -486,34 +532,22 @@ packFields fields unions = (finalState, finalUnionState, Map.fromList packedItem
 
 ------------------------------------------------------------------------------------------
 
--- 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 _ (Active desc _)) = Just (CompiledMember desc)
-toCompiledStatement (CompiledOptionStatus (Active desc _)) = Just (CompiledOption desc)
-toCompiledStatement _ = Nothing
+data CompiledStatementStatus = CompiledStatementStatus String (Status Desc)
 
-compiledErrors (CompiledMemberStatus _ status) = statusErrors status
-compiledErrors (CompiledOptionStatus status) = statusErrors status
+compiledErrors (CompiledStatementStatus _ status) = statusErrors status
 
 compileChildDecls :: Desc -> [Declaration]
-                  -> Status ([Desc], MemberMap, OptionMap, [CompiledStatement])
-compileChildDecls desc decls = Active (members, memberMap, options, statements) errors where
+                  -> Status ([Desc], MemberMap)
+compileChildDecls desc decls = Active (members, memberMap) errors where
     compiledDecls = map (compileDecl desc) decls
     memberMap = Map.fromList memberPairs
     members = [member | (_, Just member) <- memberPairs]
-    memberPairs = [(name, statusToMaybe status) | CompiledMemberStatus name status <- compiledDecls]
-    options = Map.fromList [(optionName (optionAssignmentOption o), o)
-                           | CompiledOptionStatus (Active o _) <- compiledDecls]
+    memberPairs = [(name, statusToMaybe status)
+                  | CompiledStatementStatus name status <- compiledDecls]
     errors = concatMap compiledErrors compiledDecls
-    statements = mapMaybe toCompiledStatement compiledDecls
 
 compileDecl scope (AliasDecl (Located _ name) target) =
-    CompiledMemberStatus name (do
+    CompiledStatementStatus name (do
         targetDesc <- lookupDesc scope target
         return (DescAlias AliasDesc
             { aliasName = name
@@ -521,53 +555,57 @@ compileDecl scope (AliasDecl (Located _ name) target) =
             , aliasTarget = targetDesc
             }))
 
-compileDecl scope (ConstantDecl (Located _ name) t (Located valuePos value)) =
-    CompiledMemberStatus name (do
+compileDecl scope (ConstantDecl (Located _ name) t annotations (Located valuePos value)) =
+    CompiledStatementStatus name (do
         typeDesc <- compileType scope t
         valueDesc <- compileValue valuePos typeDesc value
+        compiledAnnotations <- compileAnnotationMap scope ConstantAnnotation annotations
         return (DescConstant ConstantDesc
             { constantName = name
             , constantParent = scope
             , constantType = typeDesc
             , constantValue = valueDesc
+            , constantAnnotations = compiledAnnotations
             }))
 
-compileDecl scope (EnumDecl (Located _ name) decls) =
-    CompiledMemberStatus name (feedback (\desc -> do
-        (members, memberMap, options, statements) <- compileChildDecls desc decls
+compileDecl scope (EnumDecl (Located _ name) annotations decls) =
+    CompiledStatementStatus name (feedback (\desc -> do
+        (members, memberMap) <- compileChildDecls desc decls
         requireNoDuplicateNames decls
         let numbers = [ num | EnumValueDecl _ num _ <- decls ]
         requireSequentialNumbering "Enum values" numbers
         requireOrdinalsInRange numbers
+        compiledAnnotations <- compileAnnotationMap scope EnumAnnotation annotations
         return (DescEnum EnumDesc
             { enumName = name
             , enumParent = scope
             , enumValues = [d | DescEnumValue d <- members]
-            , enumOptions = options
+            , enumAnnotations = compiledAnnotations
             , enumMemberMap = memberMap
-            , enumStatements = statements
+            , enumStatements = members
             })))
 
-compileDecl (DescEnum parent) (EnumValueDecl (Located _ name) (Located _ number) decls) =
-    CompiledMemberStatus name (feedback (\desc -> do
-        (_, _, options, statements) <- compileChildDecls desc decls
+compileDecl scope@(DescEnum parent)
+            (EnumValueDecl (Located _ name) (Located _ number) annotations) =
+    CompiledStatementStatus name (do
+        compiledAnnotations <- compileAnnotationMap scope EnumValueAnnotation annotations
         return (DescEnumValue EnumValueDesc
             { enumValueName = name
             , enumValueParent = parent
             , enumValueNumber = number
-            , enumValueOptions = options
-            , enumValueStatements = statements
-            })))
+            , enumValueAnnotations = compiledAnnotations
+            }))
 compileDecl _ (EnumValueDecl (Located pos name) _ _) =
-    CompiledMemberStatus name (makeError pos "Enum values can only appear inside enums.")
+    CompiledStatementStatus 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
+compileDecl scope (StructDecl (Located _ name) annotations decls) =
+    CompiledStatementStatus name (feedback (\desc -> do
+        (members, memberMap) <- compileChildDecls desc decls
         requireNoDuplicateNames decls
         let fieldNums = extractFieldNumbers decls
         requireSequentialNumbering "Fields" fieldNums
         requireOrdinalsInRange fieldNums
+        compiledAnnotations <- compileAnnotationMap scope StructAnnotation annotations
         return (let
             fields = [d | DescField d <- members]
             unions = [d | DescUnion d <- members]
@@ -583,19 +621,21 @@ compileDecl scope (StructDecl (Located _ name) decls) =
             , structNestedEnums      = [d | DescEnum      d <- members]
             , structNestedStructs    = [d | DescStruct    d <- members]
             , structNestedInterfaces = [d | DescInterface d <- members]
-            , structOptions = options
+            , structAnnotations = compiledAnnotations
             , structMemberMap = memberMap
-            , structStatements = statements
+            , structStatements = members
             , structFieldPackingMap = fieldPackingMap
             })))
 
-compileDecl (DescStruct parent) (UnionDecl (Located _ name) (Located numPos number) decls) =
-    CompiledMemberStatus name (feedback (\desc -> do
-        (members, memberMap, options, statements) <- compileChildDecls desc decls
+compileDecl scope@(DescStruct parent)
+            (UnionDecl (Located _ name) (Located numPos number) annotations decls) =
+    CompiledStatementStatus name (feedback (\desc -> do
+        (members, memberMap) <- compileChildDecls desc decls
         let fields = [f | DescField f <- members]
             orderedFieldNumbers = List.sort $ map fieldNumber fields
             discriminantMap = Map.fromList $ zip orderedFieldNumbers [0..]
         requireNoMoreThanOneFieldNumberLessThan name numPos number fields
+        compiledAnnotations <- compileAnnotationMap scope UnionAnnotation annotations
         return (let
             (tagOffset, tagPacking) = structFieldPackingMap parent ! number
             in DescUnion UnionDesc
@@ -605,17 +645,17 @@ compileDecl (DescStruct parent) (UnionDecl (Located _ name) (Located numPos numb
             , unionTagOffset = tagOffset
             , unionTagPacking = tagPacking
             , unionFields = fields
-            , unionOptions = options
+            , unionAnnotations = compiledAnnotations
             , unionMemberMap = memberMap
-            , unionStatements = statements
+            , unionStatements = members
             , unionFieldDiscriminantMap = discriminantMap
             })))
-compileDecl _ (UnionDecl (Located pos name) _ _) =
-    CompiledMemberStatus name (makeError pos "Unions can only appear inside structs.")
+compileDecl _ (UnionDecl (Located pos name) _ _ _) =
+    CompiledStatementStatus name (makeError pos "Unions can only appear inside structs.")
 
 compileDecl scope
-            (FieldDecl (Located pos name) (Located _ number) typeExp defaultValue) =
-    CompiledMemberStatus name (do
+            (FieldDecl (Located pos name) (Located _ number) typeExp annotations defaultValue) =
+    CompiledStatementStatus name (do
         parent <- case scope of
             DescStruct s -> return s
             DescUnion u -> return (unionParent u)
@@ -627,6 +667,7 @@ compileDecl scope
         defaultDesc <- case defaultValue of
             Just (Located defaultPos value) -> fmap Just (compileValue defaultPos typeDesc value)
             Nothing -> return Nothing
+        compiledAnnotations <- compileAnnotationMap scope FieldAnnotation annotations
         return (let
             (offset, packing) = structFieldPackingMap parent ! number
             in DescField FieldDesc
@@ -638,16 +679,17 @@ compileDecl scope
             , fieldUnion = unionDesc
             , fieldType = typeDesc
             , fieldDefaultValue = defaultDesc
-            , fieldOptions = Map.empty  -- TODO
+            , fieldAnnotations = compiledAnnotations
             }))
 
-compileDecl scope (InterfaceDecl (Located _ name) decls) =
-    CompiledMemberStatus name (feedback (\desc -> do
-        (members, memberMap, options, statements) <- compileChildDecls desc decls
+compileDecl scope (InterfaceDecl (Located _ name) annotations decls) =
+    CompiledStatementStatus name (feedback (\desc -> do
+        (members, memberMap) <- compileChildDecls desc decls
         requireNoDuplicateNames decls
         let numbers = [ num | MethodDecl _ num _ _ _ <- decls ]
         requireSequentialNumbering "Methods" numbers
         requireOrdinalsInRange numbers
+        compiledAnnotations <- compileAnnotationMap scope InterfaceAnnotation annotations
         return (DescInterface InterfaceDesc
             { interfaceName = name
             , interfaceParent = scope
@@ -657,53 +699,62 @@ compileDecl scope (InterfaceDecl (Located _ name) decls) =
             , interfaceNestedEnums      = [d | DescEnum      d <- members]
             , interfaceNestedStructs    = [d | DescStruct    d <- members]
             , interfaceNestedInterfaces = [d | DescInterface d <- members]
-            , interfaceOptions = options
+            , interfaceAnnotations = compiledAnnotations
             , interfaceMemberMap = memberMap
-            , interfaceStatements = statements
+            , interfaceStatements = members
             })))
 
 compileDecl scope@(DescInterface parent)
-            (MethodDecl (Located _ name) (Located _ number) params returnType decls) =
-    CompiledMemberStatus name (feedback (\desc -> do
-        paramDescs <- doAll (map (compileParam scope) params)
+            (MethodDecl (Located _ name) (Located _ number) params returnType annotations) =
+    CompiledStatementStatus name (feedback (\desc -> do
+        paramDescs <- doAll (map (compileParam desc) (zip [0..] params))
         returnTypeDesc <- compileType scope returnType
-        (_, _, options, statements) <- compileChildDecls desc decls
+        compiledAnnotations <- compileAnnotationMap scope MethodAnnotation annotations
         return (DescMethod MethodDesc
             { methodName = name
             , methodParent = parent
             , methodNumber = number
             , methodParams = paramDescs
             , methodReturnType = returnTypeDesc
-            , methodOptions = options
-            , methodStatements = statements
+            , methodAnnotations = compiledAnnotations
             })))
 compileDecl _ (MethodDecl (Located pos name) _ _ _ _) =
-    CompiledMemberStatus name (makeError pos "Methods can only appear inside interfaces.")
-
-compileDecl scope (OptionDecl name (Located valuePos value)) =
-    CompiledOptionStatus (do
-        uncheckedOptionDesc <- lookupDesc scope name
-        optionDesc <- case uncheckedOptionDesc of
-            (DescOption d) -> return d
-            _ -> makeError (declNamePos name) (printf "'%s' is not an option." (declNameString name))
-        valueDesc <- compileValue valuePos (optionType optionDesc) value
-        return OptionAssignmentDesc
-            { optionAssignmentParent = scope
-            , optionAssignmentOption = optionDesc
-            , optionAssignmentValue = valueDesc
-            })
+    CompiledStatementStatus name (makeError pos "Methods can only appear inside interfaces.")
+
+compileDecl scope (AnnotationDecl (Located _ name) typeExp annotations targets) =
+    CompiledStatementStatus name (do
+        typeDesc <- compileType scope typeExp
+        compiledAnnotations <- compileAnnotationMap scope AnnotationAnnotation annotations
+        return (DescAnnotation AnnotationDesc
+            { annotationName = name
+            , annotationParent = scope
+            , annotationType = typeDesc
+            , annotationAnnotations = compiledAnnotations
+            , annotationTargets = Set.fromList targets
+            }))
 
-compileParam scope (name, typeExp, defaultValue) = do
+compileParam scope@(DescMethod parent)
+             (ordinal, ParamDecl name typeExp annotations defaultValue) = do
     typeDesc <- compileType scope typeExp
     defaultDesc <- case defaultValue of
         Just (Located pos value) -> fmap Just (compileValue pos typeDesc value)
         Nothing -> return Nothing
-    return (name, typeDesc, defaultDesc)
-
-compileFile name decls importMap =
+    compiledAnnotations <- compileAnnotationMap scope ParamAnnotation annotations
+    return ParamDesc
+        { paramName = name
+        , paramParent = parent
+        , paramNumber = ordinal
+        , paramType = typeDesc
+        , paramDefaultValue = defaultDesc
+        , paramAnnotations = compiledAnnotations
+        }
+compileParam _ _ = error "scope of parameter was not a method"
+
+compileFile name decls annotations importMap =
     feedback (\desc -> do
-        (members, memberMap, options, statements) <- compileChildDecls (DescFile desc) decls
+        (members, memberMap) <- compileChildDecls (DescFile desc) decls
         requireNoDuplicateNames decls
+        compiledAnnotations <- compileAnnotationMap (DescFile desc) FileAnnotation annotations
         return FileDesc
             { fileName = name
             , fileImports = Map.elems importMap
@@ -712,10 +763,10 @@ compileFile name decls importMap =
             , fileEnums      = [d | DescEnum      d <- members]
             , fileStructs    = [d | DescStruct    d <- members]
             , fileInterfaces = [d | DescInterface d <- members]
-            , fileOptions = options
+            , fileAnnotations = compiledAnnotations
             , fileMemberMap = memberMap
             , fileImportMap = importMap
-            , fileStatements = statements
+            , fileStatements = members
             })
 
 dedup :: Ord a => [a] -> [a]
@@ -729,7 +780,7 @@ emptyFileDesc filename = FileDesc
     , fileEnums = []
     , fileStructs = []
     , fileInterfaces = []
-    , fileOptions = Map.empty
+    , fileAnnotations = Map.empty
     , fileMemberMap = Map.empty
     , fileImportMap = Map.empty
     , fileStatements = []
@@ -741,7 +792,7 @@ parseAndCompileFile :: Monad m
                     -> (String -> m (Either FileDesc String))  -- Callback to import other files.
                     -> m (Status FileDesc)                     -- Compiled file and/or errors.
 parseAndCompileFile filename text importCallback = do
-    let (decls, parseErrors) = parseFile filename text
+    let (decls, annotations, parseErrors) = parseFile filename text
         importNames = dedup $ concatMap declImports decls
         doImport (Located pos name) = do
             result <- importCallback name
@@ -773,4 +824,4 @@ parseAndCompileFile filename text importCallback = do
         imports <- doAll importStatuses
 
         -- Compile the file!
-        compileFile filename decls $ Map.fromList imports)
+        compileFile filename decls annotations $ Map.fromList imports)

compiler/src/Grammar.hs

@@ -45,6 +45,10 @@ typeImports :: TypeExpression -> [Located String]
 typeImports (TypeExpression name params) =
     maybeToList (declNameImport name) ++ concatMap typeImports params
 
+data Annotation = Annotation DeclName (Located FieldValue) deriving(Show)
+
+annotationImports (Annotation name _) = maybeToList $ declNameImport name
+
 data FieldValue = VoidFieldValue
                 | BoolFieldValue Bool
                 | IntegerFieldValue Integer
@@ -56,43 +60,75 @@ data FieldValue = VoidFieldValue
                 | UnionFieldValue String FieldValue
                 deriving (Show)
 
+data ParamDecl = ParamDecl String TypeExpression [Annotation] (Maybe (Located FieldValue))
+               deriving (Show)
+
+paramImports (ParamDecl _ t ann _) = typeImports t ++ concatMap annotationImports ann
+
+data AnnotationTarget = FileAnnotation
+                      | ConstantAnnotation
+                      | EnumAnnotation
+                      | EnumValueAnnotation
+                      | StructAnnotation
+                      | FieldAnnotation
+                      | UnionAnnotation
+                      | InterfaceAnnotation
+                      | MethodAnnotation
+                      | ParamAnnotation
+                      | AnnotationAnnotation
+                      deriving(Eq, Ord, Bounded, Enum)
+
+instance Show AnnotationTarget where
+    show FileAnnotation = "file"
+    show ConstantAnnotation = "const"
+    show EnumAnnotation = "enum"
+    show EnumValueAnnotation = "enumerant"
+    show StructAnnotation = "struct"
+    show FieldAnnotation = "field"
+    show UnionAnnotation = "union"
+    show InterfaceAnnotation = "interface"
+    show MethodAnnotation = "method"
+    show ParamAnnotation = "param"
+    show AnnotationAnnotation = "annotation"
+
 data Declaration = AliasDecl (Located String) DeclName
-                 | ConstantDecl (Located String) TypeExpression (Located FieldValue)
-                 | EnumDecl (Located String) [Declaration]
-                 | EnumValueDecl (Located String) (Located Integer) [Declaration]
-                 | StructDecl (Located String) [Declaration]
+                 | ConstantDecl (Located String) TypeExpression [Annotation] (Located FieldValue)
+                 | EnumDecl (Located String) [Annotation] [Declaration]
+                 | EnumValueDecl (Located String) (Located Integer) [Annotation]
+                 | StructDecl (Located String) [Annotation] [Declaration]
                  | FieldDecl (Located String) (Located Integer)
-                             TypeExpression (Maybe (Located FieldValue))
-                 | UnionDecl (Located String) (Located Integer) [Declaration]
-                 | InterfaceDecl (Located String) [Declaration]
-                 | MethodDecl (Located String) (Located Integer)
-                              [(String, TypeExpression, Maybe (Located FieldValue))]
-                              TypeExpression [Declaration]
-                 | OptionDecl DeclName (Located FieldValue)
+                             TypeExpression [Annotation] (Maybe (Located FieldValue))
+                 | UnionDecl (Located String) (Located Integer) [Annotation] [Declaration]
+                 | InterfaceDecl (Located String) [Annotation] [Declaration]
+                 | MethodDecl (Located String) (Located Integer) [ParamDecl]
+                              TypeExpression [Annotation]
+                 | AnnotationDecl (Located String) TypeExpression [Annotation] [AnnotationTarget]
                  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 (UnionDecl 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 (AnnotationDecl n _ _ _) = Just n
 
 declImports :: Declaration -> [Located String]
-declImports (AliasDecl _ name) = maybeToList $ declNameImport name
-declImports (ConstantDecl _ t _) = typeImports t
-declImports (EnumDecl _ decls) = concatMap declImports decls
-declImports (EnumValueDecl _ _ decls) = concatMap declImports decls
-declImports (StructDecl _ decls) = concatMap declImports decls
-declImports (FieldDecl _ _ t _) = typeImports t
-declImports (UnionDecl _ _ decls) = concatMap declImports decls
-declImports (InterfaceDecl _ decls) = concatMap declImports decls
-declImports (MethodDecl _ _ params t decls) =
-    concat [paramsImports, typeImports t, concatMap declImports decls] where
-        paramsImports = concat [typeImports pt | (_, pt, _) <- params]
-declImports (OptionDecl name _) = maybeToList $ declNameImport name
+declImports (AliasDecl _ name) = maybeToList (declNameImport name)
+declImports (ConstantDecl _ t ann _) = typeImports t ++ concatMap annotationImports ann
+declImports (EnumDecl _ ann decls) = concatMap annotationImports ann ++ concatMap declImports decls
+declImports (EnumValueDecl _ _ ann) = concatMap annotationImports ann
+declImports (StructDecl _ ann decls) = concatMap annotationImports ann ++
+                                       concatMap declImports decls
+declImports (FieldDecl _ _ t ann _) = typeImports t ++ concatMap annotationImports ann
+declImports (UnionDecl _ _ ann decls) = concatMap annotationImports ann ++
+                                        concatMap declImports decls
+declImports (InterfaceDecl _ ann decls) = concatMap annotationImports ann ++
+                                          concatMap declImports decls
+declImports (MethodDecl _ _ params t ann) =
+    concat [concatMap paramImports params, typeImports t, concatMap annotationImports ann]
+declImports (AnnotationDecl _ t ann _) = typeImports t ++ concatMap annotationImports ann

compiler/src/Lexer.hs

@@ -48,7 +48,7 @@ keywords =
     , (StructKeyword, "struct")
     , (UnionKeyword, "union")
     , (InterfaceKeyword, "interface")
-    , (OptionKeyword, "option")
+    , (AnnotationKeyword, "annotation")
     ]
 
 languageDef :: T.LanguageDef st
@@ -114,15 +114,17 @@ tokenSequence = do
 token :: Parser Token
 token = keyword
     <|> identifier
-    <|> liftM ParenthesizedList  (parens (sepBy tokenSequence (symbol ",")))
-    <|> liftM BracketedList      (brackets (sepBy tokenSequence (symbol ",")))
-    <|> liftM toLiteral          naturalOrFloat
-    <|> liftM LiteralString      stringLiteral
-    <|> liftM (const AtSign)     (symbol "@")
-    <|> liftM (const Colon)      (symbol ":")
-    <|> liftM (const Period)     (symbol ".")
-    <|> liftM (const EqualsSign) (symbol "=")
-    <|> liftM (const MinusSign)  (symbol "-")
+    <|> liftM ParenthesizedList   (parens (sepBy tokenSequence (symbol ",")))
+    <|> liftM BracketedList       (brackets (sepBy tokenSequence (symbol ",")))
+    <|> liftM toLiteral           naturalOrFloat
+    <|> liftM LiteralString       stringLiteral
+    <|> liftM (const AtSign)      (symbol "@")
+    <|> liftM (const Colon)       (symbol ":")
+    <|> liftM (const DollarSign)  (symbol "$")
+    <|> liftM (const Period)      (symbol ".")
+    <|> liftM (const EqualsSign)  (symbol "=")
+    <|> liftM (const MinusSign)   (symbol "-")
+    <|> liftM (const Asterisk)    (symbol "*")
     <|> liftM (const ExclamationPoint) (symbol "!")
     <?> "token"
 

compiler/src/Parser.hs

@@ -42,9 +42,11 @@ tokenErrorString (LiteralFloat f) = "float literal " ++ show f
 tokenErrorString (LiteralString s) = "string literal " ++  show s
 tokenErrorString AtSign = "\"@\""
 tokenErrorString Colon = "\":\""
+tokenErrorString DollarSign = "\"$\""
 tokenErrorString Period = "\".\""
 tokenErrorString EqualsSign = "\"=\""
 tokenErrorString MinusSign = "\"-\""
+tokenErrorString Asterisk = "\"*\""
 tokenErrorString ExclamationPoint = "\"!\""
 tokenErrorString VoidKeyword = "keyword \"void\""
 tokenErrorString TrueKeyword = "keyword \"true\""
@@ -62,7 +64,7 @@ tokenErrorString EnumKeyword = "keyword \"enum\""
 tokenErrorString StructKeyword = "keyword \"struct\""
 tokenErrorString UnionKeyword = "keyword \"union\""
 tokenErrorString InterfaceKeyword = "keyword \"interface\""
-tokenErrorString OptionKeyword = "keyword \"option\""
+tokenErrorString AnnotationKeyword = "keyword \"annotation\""
 
 type TokenParser = Parsec [Located Token] [ParseError]
 
@@ -105,9 +107,11 @@ literalVoid = tokenParser (matchSimpleToken VoidKeyword) <?> "\"void\""
 
 atSign = tokenParser (matchSimpleToken AtSign) <?> "\"@\""
 colon = tokenParser (matchSimpleToken Colon) <?> "\":\""
+dollarSign = tokenParser (matchSimpleToken DollarSign) <?> "\"$\""
 period = tokenParser (matchSimpleToken Period) <?> "\".\""
 equalsSign = tokenParser (matchSimpleToken EqualsSign) <?> "\"=\""
-minusSign = tokenParser (matchSimpleToken MinusSign) <?> "\"=\""
+minusSign = tokenParser (matchSimpleToken MinusSign) <?> "\"-\""
+asterisk = tokenParser (matchSimpleToken Asterisk) <?> "\"*\""
 importKeyword = tokenParser (matchSimpleToken ImportKeyword) <?> "\"import\""
 usingKeyword = tokenParser (matchSimpleToken UsingKeyword) <?> "\"using\""
 constKeyword = tokenParser (matchSimpleToken ConstKeyword) <?> "\"const\""
@@ -115,7 +119,8 @@ 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\""
+annotationKeyword = tokenParser (matchSimpleToken AnnotationKeyword) <?> "\"annotation\""
+onKeyword = tokenParser (matchSimpleToken OnKeyword) <?> "\"on\""
 
 parenthesizedList parser = do
     items <- tokenParser (matchUnary ParenthesizedList)
@@ -153,9 +158,19 @@ nameWithOrdinal = do
     ordinal <- located literalInt
     return (name, ordinal)
 
-topLine :: Maybe [Located Statement] -> TokenParser Declaration
-topLine Nothing = optionDecl <|> aliasDecl <|> constantDecl
-topLine (Just statements) = typeDecl statements
+annotation :: TokenParser Annotation
+annotation = do
+    dollarSign
+    name <- declName
+    value <- located (try (parenthesized fieldValue)
+                  <|> liftM RecordFieldValue (parenthesizedList fieldAssignment)
+                  <|> return VoidFieldValue)
+    return (Annotation name value)
+
+topLine :: Maybe [Located Statement] -> TokenParser (Either Declaration Annotation)
+topLine Nothing = liftM Left (aliasDecl <|> constantDecl <|> annotationDecl)
+              <|> liftM Right annotation
+topLine (Just statements) = liftM Left $ typeDecl statements
 
 aliasDecl = do
     usingKeyword
@@ -169,9 +184,10 @@ constantDecl = do
     name <- located varIdentifier
     colon
     typeName <- typeExpression
+    annotations <- many annotation
     equalsSign
     value <- located fieldValue
-    return (ConstantDecl name typeName value)
+    return (ConstantDecl name typeName annotations value)
 
 typeDecl statements = enumDecl statements
                   <|> structDecl statements
@@ -180,48 +196,48 @@ typeDecl statements = enumDecl statements
 enumDecl statements = do
     enumKeyword
     name <- located typeIdentifier
+    annotations <- many annotation
     children <- parseBlock enumLine statements
-    return (EnumDecl name children)
+    return (EnumDecl name annotations children)
 
 enumLine :: Maybe [Located Statement] -> TokenParser Declaration
-enumLine Nothing = optionDecl <|> enumValueDecl []
-enumLine (Just statements) = enumValueDecl statements
+enumLine Nothing = enumValueDecl
+enumLine (Just _) = fail "Blocks not allowed here."
 
-enumValueDecl statements = do
+enumValueDecl = do
     (name, value) <- nameWithOrdinal
-    children <- parseBlock enumValueLine statements
-    return (EnumValueDecl name value children)
-
-enumValueLine :: Maybe [Located Statement] -> TokenParser Declaration
-enumValueLine Nothing = optionDecl
-enumValueLine (Just _) = fail "Blocks not allowed here."
+    annotations <- many annotation
+    return (EnumValueDecl name value annotations)
 
 structDecl statements = do
     structKeyword
     name <- located typeIdentifier
+    annotations <- many annotation
     children <- parseBlock structLine statements
-    return (StructDecl name children)
+    return (StructDecl name annotations children)
 
 structLine :: Maybe [Located Statement] -> TokenParser Declaration
-structLine Nothing = optionDecl <|> constantDecl <|> fieldDecl
+structLine Nothing = constantDecl <|> fieldDecl <|> annotationDecl
 structLine (Just statements) = typeDecl statements <|> unionDecl statements <|> unionDecl statements
 
 unionDecl statements = do
     (name, ordinal) <- nameWithOrdinal
     unionKeyword
+    annotations <- many annotation
     children <- parseBlock unionLine statements
-    return (UnionDecl name ordinal children)
+    return (UnionDecl name ordinal annotations children)
 
 unionLine :: Maybe [Located Statement] -> TokenParser Declaration
-unionLine Nothing = optionDecl <|> fieldDecl
+unionLine Nothing = fieldDecl
 unionLine (Just _) = fail "Blocks not allowed here."
 
 fieldDecl = do
     (name, ordinal) <- nameWithOrdinal
     colon
     t <- typeExpression
+    annotations <- many annotation
     value <- optionMaybe (equalsSign >> located fieldValue)
-    return (FieldDecl name ordinal t value)
+    return (FieldDecl name ordinal t annotations value)
 
 negativeFieldValue = liftM (IntegerFieldValue . negate) literalInt
                  <|> liftM (FloatFieldValue . negate) literalFloat
@@ -252,38 +268,61 @@ fieldAssignment = do
 interfaceDecl statements = do
     interfaceKeyword
     name <- located typeIdentifier
+    annotations <- many annotation
     children <- parseBlock interfaceLine statements
-    return (InterfaceDecl name children)
+    return (InterfaceDecl name annotations children)
 
 interfaceLine :: Maybe [Located Statement] -> TokenParser Declaration
-interfaceLine Nothing = optionDecl <|> constantDecl <|> methodDecl []
-interfaceLine (Just statements) = typeDecl statements <|> methodDecl statements
+interfaceLine Nothing = constantDecl <|> methodDecl <|> annotationDecl
+interfaceLine (Just statements) = typeDecl statements
 
-methodDecl statements = do
+methodDecl = do
     (name, ordinal) <- nameWithOrdinal
     params <- parenthesizedList paramDecl
     colon
     t <- typeExpression
-    children <- parseBlock methodLine statements
-    return (MethodDecl name ordinal params t children)
+    annotations <- many annotation
+    return (MethodDecl name ordinal params t annotations)
 
 paramDecl = do
     name <- varIdentifier
     colon
     t <- typeExpression
+    annotations <- many annotation
     value <- optionMaybe (equalsSign >> located fieldValue)
-    return (name, t, value)
+    return (ParamDecl name t annotations value)
 
-methodLine :: Maybe [Located Statement] -> TokenParser Declaration
-methodLine Nothing = optionDecl
-methodLine (Just _) = fail "Blocks not allowed here."
-
-optionDecl = do
-    optionKeyword
-    name <- declName
-    equalsSign
-    value <- located fieldValue
-    return (OptionDecl name value)
+annotationDecl = do
+    annotationKeyword
+    name <- located varIdentifier
+    colon
+    t <- typeExpression
+    annotations <- many annotation
+    onKeyword
+    targets <- try (parenthesized asterisk >> return allAnnotationTargets)
+           <|> parenthesizedList annotationTarget
+    return (AnnotationDecl name t annotations targets)
+allAnnotationTargets = [minBound::AnnotationTarget .. maxBound::AnnotationTarget]
+
+annotationTarget = (constKeyword >> return ConstantAnnotation)
+               <|> (enumKeyword >> return EnumAnnotation)
+               <|> (structKeyword >> return StructAnnotation)
+               <|> (unionKeyword >> return UnionAnnotation)
+               <|> (interfaceKeyword >> return InterfaceAnnotation)
+               <|> (annotationKeyword >> return AnnotationAnnotation)
+               <|> (do
+                   name <- varIdentifier
+                   case name of
+                       "file" -> return FileAnnotation
+                       "enumerant" -> return EnumValueAnnotation
+                       "field" -> return FieldAnnotation
+                       "method" -> return MethodAnnotation
+                       "parameter" -> return ParamAnnotation
+                       _ -> fail "" <?> annotationTargetList)
+               <?> annotationTargetList
+
+annotationTargetList = "const, enum, enumerant, struct, field, union, interface, method, \
+                       \parameter, or annotation"
 
 extractErrors :: Either ParseError (a, [ParseError]) -> [ParseError]
 extractErrors (Left err) = [err]
@@ -322,21 +361,23 @@ parseCollectingErrors parser tokenSequence = runParser parser' [] "" tokens wher
         errors <- getState
         return (result, errors)
 
-parseStatement :: (Maybe [Located Statement] -> TokenParser Declaration)
+parseStatement :: (Maybe [Located Statement] -> TokenParser a)
                -> Located Statement
-               -> Either ParseError (Declaration, [ParseError])
+               -> Either ParseError (a, [ParseError])
 parseStatement parser (Located _ (Line tokens)) =
     parseCollectingErrors (parser Nothing) tokens
 parseStatement parser (Located _ (Block tokens statements)) =
     parseCollectingErrors (parser (Just statements)) tokens
 
-parseFileTokens :: [Located Statement] -> ([Declaration], [ParseError])
-parseFileTokens statements = (decls, errors) where
+parseFileTokens :: [Located Statement] -> ([Declaration], [Annotation], [ParseError])
+parseFileTokens statements = (decls, annotations, errors) where
+    results :: [Either ParseError (Either Declaration Annotation, [ParseError])]
     results = map (parseStatement topLine) statements
     errors = concatMap extractErrors results
-    decls = [ result | Right (result, _) <- results ]
+    decls = [ decl | Right (Left decl, _) <- results ]
+    annotations = [ ann | Right (Right ann, _) <- results ]
 
-parseFile :: String -> String -> ([Declaration], [ParseError])
+parseFile :: String -> String -> ([Declaration], [Annotation], [ParseError])
 parseFile filename text = case parse lexer filename text of
-    Left e -> ([], [e])
+    Left e -> ([], [], [e])
     Right statements -> parseFileTokens statements

compiler/src/Semantics.hs

@@ -24,6 +24,7 @@
 module Semantics where
 
 import qualified Data.Map as Map
+import qualified Data.Set as Set
 import qualified Data.List as List
 import qualified Data.Maybe as Maybe
 import Data.Int (Int8, Int16, Int32, Int64)
@@ -32,11 +33,14 @@ import Data.Char (chr)
 import Text.Printf(printf)
 import Control.Monad(join)
 import Util(delimit)
+import Grammar(AnnotationTarget(..))
 
 -- Field counts are 16-bit, therefore there cannot be more than 65535 fields, therefore the max
 -- ordinal is 65534.
 maxOrdinal = 65534 :: Integer
 
+idId = "com.capnproto.compiler.builtin.id"
+
 type ByteString = [Word8]
 
 data Desc = DescFile FileDesc
@@ -49,7 +53,8 @@ data Desc = DescFile FileDesc
           | DescField FieldDesc
           | DescInterface InterfaceDesc
           | DescMethod MethodDesc
-          | DescOption OptionDesc
+          | DescParam ParamDesc
+          | DescAnnotation AnnotationDesc
           | DescBuiltinType BuiltinType
           | DescBuiltinList
 
@@ -63,7 +68,8 @@ descName (DescUnion     d) = unionName d
 descName (DescField     d) = fieldName d
 descName (DescInterface d) = interfaceName d
 descName (DescMethod    d) = methodName d
-descName (DescOption    d) = optionName d
+descName (DescParam     d) = paramName d
+descName (DescAnnotation d) = annotationName d
 descName (DescBuiltinType d) = builtinTypeName d
 descName DescBuiltinList = "List"
 
@@ -77,7 +83,8 @@ descParent (DescUnion     d) = DescStruct (unionParent d)
 descParent (DescField     d) = DescStruct (fieldParent d)
 descParent (DescInterface d) = interfaceParent d
 descParent (DescMethod    d) = DescInterface (methodParent d)
-descParent (DescOption    d) = optionParent d
+descParent (DescParam     d) = DescMethod (paramParent d)
+descParent (DescAnnotation d) = annotationParent d
 descParent (DescBuiltinType _) = error "Builtin type has no parent."
 descParent DescBuiltinList = error "Builtin type has no parent."
 
@@ -263,10 +270,10 @@ data FileDesc = FileDesc
     , fileEnums :: [EnumDesc]
     , fileStructs :: [StructDesc]
     , fileInterfaces :: [InterfaceDesc]
-    , fileOptions :: OptionMap
+    , fileAnnotations :: AnnotationMap
     , fileMemberMap :: MemberMap
     , fileImportMap :: Map.Map String FileDesc
-    , fileStatements :: [CompiledStatement]
+    , fileStatements :: [Desc]
     }
 
 data AliasDesc = AliasDesc
@@ -279,6 +286,7 @@ data ConstantDesc = ConstantDesc
     { constantName :: String
     , constantParent :: Desc
     , constantType :: TypeDesc
+    , constantAnnotations :: AnnotationMap
     , constantValue :: ValueDesc
     }
 
@@ -286,17 +294,16 @@ data EnumDesc = EnumDesc
     { enumName :: String
     , enumParent :: Desc
     , enumValues :: [EnumValueDesc]
-    , enumOptions :: OptionMap
+    , enumAnnotations :: AnnotationMap
     , enumMemberMap :: MemberMap
-    , enumStatements :: [CompiledStatement]
+    , enumStatements :: [Desc]
     }
 
 data EnumValueDesc = EnumValueDesc
     { enumValueName :: String
     , enumValueParent :: EnumDesc
     , enumValueNumber :: Integer
-    , enumValueOptions :: OptionMap
-    , enumValueStatements :: [CompiledStatement]
+    , enumValueAnnotations :: AnnotationMap
     }
 
 data StructDesc = StructDesc
@@ -310,9 +317,9 @@ data StructDesc = StructDesc
     , structNestedEnums :: [EnumDesc]
     , structNestedStructs :: [StructDesc]
     , structNestedInterfaces :: [InterfaceDesc]
-    , structOptions :: OptionMap
+    , structAnnotations :: AnnotationMap
     , structMemberMap :: MemberMap
-    , structStatements :: [CompiledStatement]
+    , structStatements :: [Desc]
 
     -- Don't use this directly, use the members of FieldDesc and UnionDesc.
     -- This field is exposed here only because I was too lazy to create a way to pass it on
@@ -327,9 +334,9 @@ data UnionDesc = UnionDesc
     , unionTagOffset :: Integer
     , unionTagPacking :: PackingState
     , unionFields :: [FieldDesc]
-    , unionOptions :: OptionMap
+    , unionAnnotations :: AnnotationMap
     , unionMemberMap :: MemberMap
-    , unionStatements :: [CompiledStatement]
+    , unionStatements :: [Desc]
 
     -- Maps field numbers to discriminants for all fields in the union.
     , unionFieldDiscriminantMap :: Map.Map Integer Integer
@@ -344,7 +351,7 @@ data FieldDesc = FieldDesc
     , fieldUnion :: Maybe (UnionDesc, Integer)  -- Integer is value of union discriminant.
     , fieldType :: TypeDesc
     , fieldDefaultValue :: Maybe ValueDesc
-    , fieldOptions :: OptionMap
+    , fieldAnnotations :: AnnotationMap
     }
 
 data InterfaceDesc = InterfaceDesc
@@ -356,66 +363,70 @@ data InterfaceDesc = InterfaceDesc
     , interfaceNestedEnums :: [EnumDesc]
     , interfaceNestedStructs :: [StructDesc]
     , interfaceNestedInterfaces :: [InterfaceDesc]
-    , interfaceOptions :: OptionMap
+    , interfaceAnnotations :: AnnotationMap
     , interfaceMemberMap :: MemberMap
-    , interfaceStatements :: [CompiledStatement]
+    , interfaceStatements :: [Desc]
     }
 
 data MethodDesc = MethodDesc
     { methodName :: String
     , methodParent :: InterfaceDesc
     , methodNumber :: Integer
-    , methodParams :: [(String, TypeDesc, Maybe ValueDesc)]
+    , methodParams :: [ParamDesc]
     , methodReturnType :: TypeDesc
-    , methodOptions :: OptionMap
-    , methodStatements :: [CompiledStatement]
+    , methodAnnotations :: AnnotationMap
     }
 
-type OptionMap = Map.Map String OptionAssignmentDesc
-
-data OptionAssignmentDesc = OptionAssignmentDesc
-    { optionAssignmentParent :: Desc
-    , optionAssignmentOption :: OptionDesc
-    , optionAssignmentValue :: ValueDesc
+data ParamDesc = ParamDesc
+    { paramName :: String
+    , paramParent :: MethodDesc
+    , paramNumber :: Integer
+    , paramType :: TypeDesc
+    , paramDefaultValue :: Maybe ValueDesc
+    , paramAnnotations :: AnnotationMap
     }
 
-data OptionDesc = OptionDesc
-    { optionName :: String
-    , optionParent :: Desc
-    , optionId :: String
-    , optionType :: TypeDesc
-    , optionDefaultValue :: Maybe ValueDesc
+data AnnotationDesc = AnnotationDesc
+    { annotationName :: String
+    , annotationParent :: Desc
+    , annotationType :: TypeDesc
+    , annotationAnnotations :: AnnotationMap
+    , annotationTargets :: Set.Set AnnotationTarget
     }
 
-data CompiledStatement = CompiledMember Desc
-                       | CompiledOption OptionAssignmentDesc
+type AnnotationMap = Map.Map String (AnnotationDesc, ValueDesc)
 
--- TODO:  Print options as well as members.  Will be ugly-ish.
 descToCode :: String -> Desc -> String
-descToCode indent (DescFile desc) = printf "# %s\n%s"
+descToCode indent self@(DescFile desc) = printf "# %s\n%s%s"
     (fileName desc)
-    (concatMap (statementToCode indent) (fileStatements desc))
+    (concatMap ((++ ";\n") . annotationCode (descParent self)) $ Map.toList $ fileAnnotations desc)
+    (concatMap (descToCode indent) (fileStatements desc))
 descToCode indent (DescAlias desc) = printf "%susing %s = %s;\n" indent
     (aliasName desc)
     (descQualifiedName (aliasParent desc) (aliasTarget desc))
-descToCode indent (DescConstant desc) = printf "%sconst %s: %s = %s;\n" indent
+descToCode indent self@(DescConstant desc) = printf "%sconst %s: %s%s = %s;\n" indent
     (constantName desc)
-    (typeName (constantParent desc) (constantType desc))
+    (typeName (descParent self) (constantType desc))
+    (annotationsCode (descParent self) $ constantAnnotations desc)
     (valueString (constantValue desc))
-descToCode indent (DescEnum desc) = printf "%senum %s {\n%s%s}\n" indent
+descToCode indent self@(DescEnum desc) = printf "%senum %s%s {\n%s%s}\n" indent
     (enumName desc)
+    (annotationsCode (descParent self) $ enumAnnotations desc)
     (blockCode indent (enumStatements desc))
     indent
-descToCode indent (DescEnumValue desc) = printf "%s%s @%d%s" indent
-    (enumValueName desc) (enumValueNumber desc) (maybeBlockCode indent $ enumValueStatements desc)
-descToCode indent (DescStruct desc) = printf "%sstruct %s {\n%s%s}\n" indent
+descToCode indent self@(DescEnumValue desc) = printf "%s%s @%d%s;\n" indent
+    (enumValueName desc) (enumValueNumber desc)
+    (annotationsCode (descParent self) $ enumValueAnnotations desc)
+descToCode indent self@(DescStruct desc) = printf "%sstruct %s%s {\n%s%s}\n" indent
     (structName desc)
+    (annotationsCode (descParent self) $ structAnnotations desc)
     (blockCode indent (structStatements desc))
     indent
-descToCode indent (DescField desc) = printf "%s%s@%d%s: %s%s;  # %s\n" indent
+descToCode indent self@(DescField desc) = printf "%s%s@%d%s: %s%s%s;  # %s\n" indent
     (fieldName desc) (fieldNumber desc)
     (case fieldUnion desc of { Nothing -> ""; Just (u, _) -> " in " ++ unionName u})
-    (typeName (DescStruct (fieldParent desc)) (fieldType desc))
+    (typeName (descParent self) (fieldType desc))
+    (annotationsCode (descParent self) $ fieldAnnotations desc)
     (case fieldDefaultValue desc of { Nothing -> ""; Just v -> " = " ++ valueString v; })
     (case fieldSize $ fieldType desc of
         SizeReference -> printf "ref[%d]" $ fieldOffset desc
@@ -424,41 +435,53 @@ descToCode indent (DescField desc) = printf "%s%s@%d%s: %s%s;  # %s\n" indent
             bits = sizeInBits s
             offset = fieldOffset desc
             in printf "bits[%d, %d)" (offset * bits) ((offset + 1) * bits))
-descToCode indent (DescUnion desc) = printf "%sunion %s@%d {  # [%d, %d)\n%s%s}\n" indent
+descToCode indent self@(DescUnion desc) = printf "%sunion %s@%d%s {  # [%d, %d)\n%s%s}\n" indent
     (unionName desc) (unionNumber desc)
+    (annotationsCode (descParent self) $ unionAnnotations desc)
     (unionTagOffset desc * 16) (unionTagOffset desc * 16 + 16)
     (blockCode indent $ unionStatements desc)
     indent
-descToCode indent (DescInterface desc) = printf "%sinterface %s {\n%s%s}\n" indent
+descToCode indent self@(DescInterface desc) = printf "%sinterface %s%s {\n%s%s}\n" indent
     (interfaceName desc)
+    (annotationsCode (descParent self) $ interfaceAnnotations desc)
     (blockCode indent (interfaceStatements desc))
     indent
-descToCode indent (DescMethod desc) = printf "%s%s@%d(%s): %s%s" indent
+descToCode indent self@(DescMethod desc) = printf "%s%s@%d(%s): %s%s" indent
     (methodName desc) (methodNumber desc)
-    (delimit ", " (map paramToCode (methodParams desc)))
-    (typeName scope (methodReturnType desc))
-    (maybeBlockCode indent $ methodStatements desc) where
-        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 scope t) (valueString v)
-descToCode _ (DescOption _) = error "options not implemented"
+    (delimit ", " (map (descToCode indent . DescParam) (methodParams desc)))
+    (typeName (descParent self) (methodReturnType desc))
+    (annotationsCode (descParent self) $ methodAnnotations desc)
+descToCode _ self@(DescParam desc) = printf "%s: %s%s%s"
+    (paramName desc)
+    (typeName (descParent self) (paramType desc))
+    (annotationsCode (descParent self) $ paramAnnotations desc)
+    (case paramDefaultValue desc of
+        Just v -> printf " = %s" $ valueString v
+        Nothing -> "")
+descToCode indent self@(DescAnnotation desc) = printf "%sannotation %s: %s%s on(%s);\n" indent
+    (annotationName desc)
+    (typeName (descParent self) (annotationType desc))
+    (annotationsCode (descParent self) $ annotationAnnotations desc)
+    (delimit ", " $ map show $ Set.toList $ annotationTargets desc)
 descToCode _ (DescBuiltinType _) = error "Can't print code for builtin type."
 descToCode _ DescBuiltinList = error "Can't print code for builtin type."
 
-statementToCode :: String -> CompiledStatement -> String
-statementToCode indent (CompiledMember desc) = descToCode indent desc
-statementToCode indent (CompiledOption desc) = printf "%s%s.%s = %s;\n" indent
-    (descQualifiedName (optionAssignmentParent desc) $ optionParent $ optionAssignmentOption desc)
-    (optionName $ optionAssignmentOption desc)
-    (valueString (optionAssignmentValue desc))
-
-maybeBlockCode :: String -> [CompiledStatement] -> String
+maybeBlockCode :: String -> [Desc] -> String
 maybeBlockCode _ [] = ";\n"
 maybeBlockCode indent statements = printf " {\n%s%s}\n" (blockCode indent statements) indent
 
-blockCode :: String -> [CompiledStatement] -> String
-blockCode indent = concatMap (statementToCode ("  " ++ indent))
+blockCode :: String -> [Desc] -> String
+blockCode indent = concatMap (descToCode ("  " ++ indent))
+
+annotationCode :: Desc -> (String, (AnnotationDesc, ValueDesc)) -> String
+annotationCode scope (_, (desc, VoidDesc)) =
+    printf "$%s" (descQualifiedName scope (DescAnnotation desc))
+annotationCode _ (annId, (desc, val)) | annId == idId =
+    printf "$id(%s)" (valueString val)
+annotationCode scope (_, (desc, val)) =
+    printf "$%s(%s)" (descQualifiedName scope (DescAnnotation desc)) (valueString val)
+
+annotationsCode scope = concatMap ((' ':) . annotationCode scope) . Map.toList
 
 instance Show FileDesc where { show desc = descToCode "" (DescFile desc) }
 instance Show AliasDesc where { show desc = descToCode "" (DescAlias desc) }
@@ -469,3 +492,5 @@ instance Show StructDesc where { show desc = descToCode "" (DescStruct desc) }
 instance Show FieldDesc where { show desc = descToCode "" (DescField desc) }
 instance Show InterfaceDesc where { show desc = descToCode "" (DescInterface desc) }
 instance Show MethodDesc where { show desc = descToCode "" (DescMethod desc) }
+instance Show ParamDesc where { show desc = descToCode "" (DescParam desc) }
+instance Show AnnotationDesc where { show desc = descToCode "" (DescAnnotation desc) }

compiler/src/Token.hs

@@ -54,9 +54,11 @@ data Token = Identifier String
            | FalseKeyword
            | AtSign
            | Colon
+           | DollarSign
            | Period
            | EqualsSign
            | MinusSign
+           | Asterisk
            | ExclamationPoint
            | InKeyword
            | OfKeyword    -- We reserve some common, short English words for use as future keywords.
@@ -71,7 +73,7 @@ data Token = Identifier String
            | StructKeyword
            | UnionKeyword
            | InterfaceKeyword
-           | OptionKeyword
+           | AnnotationKeyword
            deriving (Data, Typeable, Show, Eq)
 
 data Statement = Line TokenSequence