Skip to content

C
capnproto
Commit 4d121574 authored by Kenton Varda's avatar Kenton Varda
Browse files
Options

Implement annotations.

parent 7a7e0b64
Hide whitespace changes
Inline Side-by-side
Showing with 398 additions and 241 deletions
compiler/src/Compiler.hs
View file @ 4d121574
......@@ -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
View file @ 4d121574
......@@ -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
View file @ 4d121574
......@@ -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
View file @ 4d121574
......@@ -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
View file @ 4d121574
......@@ -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
View file @ 4d121574
......@@ -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
......
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