Skip to content

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

Fix bugs in annotations, implement ability to set C++ namespace via annotations.

parent 4d121574
Show whitespace changes
Inline Side-by-side
Showing with 228 additions and 85 deletions
c++/Makefile.am
View file @ d3e5540c
......@@ -84,10 +84,13 @@ libcapnproto_a_SOURCES= \
# Tests ==============================================================
capnpc_inputs = \
src/capnproto/c++.capnp \
src/capnproto/test.capnp \
src/capnproto/test-import.capnp
capnpc_outputs = \
src/capnproto/c++.capnp.c++ \
src/capnproto/c++.capnp.h \
src/capnproto/test.capnp.c++ \
src/capnproto/test.capnp.h \
src/capnproto/test-import.capnp.c++ \
......
c++/src/capnproto/c++.capnp 0 → 100644
View file @ d3e5540c
# Copyright (c) 2013, Kenton Varda <temporal@gmail.com>
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
# 1. Redistributions of source code must retain the above copyright notice, this
# list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright notice,
# this list of conditions and the following disclaimer in the documentation
# and/or other materials provided with the distribution.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
# DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
# ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
$id("v3JF2GP4Supe9JSSJ3pnSdUqhJI");
$namespace("capnproto::annotations");
annotation namespace: Text on(file);
c++/src/capnproto/test-util.h
View file @ d3e5540c
......@@ -48,17 +48,26 @@ inline std::ostream& operator<<(std::ostream& os, Void) {
namespace internal {
void initTestMessage(TestAllTypes::Builder builder);
void initTestMessage(TestDefaults::Builder builder);
// Explicitly import each of these to make sure they're really located in capnproto::test and not,
// say, the global namespace.
using ::capnproto::test::TestAllTypes;
using ::capnproto::test::TestDefaults;
using ::capnproto::test::TestEnum;
using ::capnproto::test::TestUnion;
using ::capnproto::test::TestUnionDefaults;
using ::capnproto::test::TestNestedTypes;
void checkTestMessage(TestAllTypes::Builder builder);
void checkTestMessage(TestDefaults::Builder builder);
void initTestMessage(test::TestAllTypes::Builder builder);
void initTestMessage(test::TestDefaults::Builder builder);
void checkTestMessage(TestAllTypes::Reader reader);
void checkTestMessage(TestDefaults::Reader reader);
void checkTestMessage(test::TestAllTypes::Builder builder);
void checkTestMessage(test::TestDefaults::Builder builder);
void checkTestMessageAllZero(TestAllTypes::Builder builder);
void checkTestMessageAllZero(TestAllTypes::Reader reader);
void checkTestMessage(test::TestAllTypes::Reader reader);
void checkTestMessage(test::TestDefaults::Reader reader);
void checkTestMessageAllZero(test::TestAllTypes::Builder builder);
void checkTestMessageAllZero(test::TestAllTypes::Reader reader);
} // namespace internal
} // namespace capnproto
......
c++/src/capnproto/test.capnp
View file @ d3e5540c
......@@ -21,6 +21,10 @@
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
using Cxx = import "c++.capnp";
$Cxx.namespace("capnproto::test");
enum TestEnum {
foo @0;
bar @1;
......
compiler/src/Compiler.hs
View file @ d3e5540c
......@@ -25,14 +25,14 @@ module Compiler where
import Grammar
import Semantics
import Token(Located(Located))
import Token(Located(Located), locatedPos, locatedValue)
import Parser(parseFile)
import Control.Monad(unless)
import qualified Data.Map as Map
import Data.Map((!))
import qualified Data.Set as Set
import qualified Data.List as List
import Data.Maybe(mapMaybe, fromMaybe)
import Data.Maybe(mapMaybe, fromMaybe, listToMaybe, catMaybes)
import Text.Parsec.Pos(SourcePos, newPos)
import Text.Parsec.Error(ParseError, newErrorMessage, Message(Message, Expect))
import Text.Printf(printf)
......@@ -154,27 +154,7 @@ lookupDesc scope name = lookupDesc (descParent scope) name
builtinTypeMap :: Map.Map String Desc
builtinTypeMap = Map.fromList
([(builtinTypeName t, DescBuiltinType t) | t <- builtinTypes] ++
[("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]
}
[("List", DescBuiltinList), ("id", DescBuiltinId)])
------------------------------------------------------------------------------------------
......@@ -304,30 +284,57 @@ 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 :: Desc -> AnnotationTarget -> Annotation
-> Status (Maybe 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)
case nameDesc of
DescBuiltinId -> do
compiledValue <- compileValue pos (BuiltinType BuiltinText) value
return (Nothing, compiledValue)
DescAnnotation annDesc -> do
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)
return (Just annDesc, compiledValue)
_ -> makeError (declNamePos name)
$ printf "'%s' is not an annotation." (declNameString name)
compileAnnotationMap :: Desc -> AnnotationTarget -> [Annotation] -> Status AnnotationMap
compileAnnotationMap scope kind annotations = do
compiled <- doAll $ map (compileAnnotation scope kind) annotations
compileAnnotations :: Desc -> AnnotationTarget -> [Annotation]
-> Status (Maybe String, AnnotationMap) -- (id, other annotations)
compileAnnotations scope kind annotations = do
let compileLocated ann@(Annotation name _) =
fmap (Located $ declNamePos name) $ compileAnnotation scope kind ann
-- 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
compiled <- doAll $ map compileLocated annotations
return $ Map.fromList $ mapMaybe makeMapEntry compiled
-- Makes a map entry for the annotation keyed by ID. Throws out annotations with no ID.
let ids = [ Located pos i | Located pos (Nothing, TextDesc i) <- compiled ]
theId = fmap locatedValue $ listToMaybe ids
dupIds = map (flip makeError "Duplicate annotation 'id'." . locatedPos) $ List.drop 1 ids
-- For the annotations other than "id", we want to build a map keyed by annotation ID.
-- We drop any annotation that doesn't have an ID.
locatedEntries = catMaybes
[ annotationById pos (desc, v) | Located pos (Just desc, v) <- compiled ]
annotationById pos ann@(desc, _) =
case descAutoId (DescAnnotation desc) of
Just globalId -> Just (Located pos (globalId, ann))
Nothing -> Nothing
-- TODO(cleanup): Generalize duplicate detection.
sortedLocatedEntries = detectDup $ List.sortBy compareIds locatedEntries
compareIds (Located _ (a, _)) (Located _ (b, _)) = compare a b
detectDup (Located _ x@(id1, _):Located pos (id2, _):rest)
| id1 == id2 = succeed x:makeError pos "Duplicate annotation.":detectDup rest
detectDup (Located _ x:rest) = succeed x:detectDup rest
detectDup [] = []
finalEntries <- doAll sortedLocatedEntries
_ <- doAll dupIds
return (theId, Map.fromList finalEntries)
------------------------------------------------------------------------------------------
......@@ -559,9 +566,10 @@ compileDecl scope (ConstantDecl (Located _ name) t annotations (Located valuePos
CompiledStatementStatus name (do
typeDesc <- compileType scope t
valueDesc <- compileValue valuePos typeDesc value
compiledAnnotations <- compileAnnotationMap scope ConstantAnnotation annotations
(theId, compiledAnnotations) <- compileAnnotations scope ConstantAnnotation annotations
return (DescConstant ConstantDesc
{ constantName = name
, constantId = theId
, constantParent = scope
, constantType = typeDesc
, constantValue = valueDesc
......@@ -575,9 +583,10 @@ compileDecl scope (EnumDecl (Located _ name) annotations decls) =
let numbers = [ num | EnumValueDecl _ num _ <- decls ]
requireSequentialNumbering "Enum values" numbers
requireOrdinalsInRange numbers
compiledAnnotations <- compileAnnotationMap scope EnumAnnotation annotations
(theId, compiledAnnotations) <- compileAnnotations scope EnumAnnotation annotations
return (DescEnum EnumDesc
{ enumName = name
, enumId = theId
, enumParent = scope
, enumValues = [d | DescEnumValue d <- members]
, enumAnnotations = compiledAnnotations
......@@ -588,9 +597,10 @@ compileDecl scope (EnumDecl (Located _ name) annotations decls) =
compileDecl scope@(DescEnum parent)
(EnumValueDecl (Located _ name) (Located _ number) annotations) =
CompiledStatementStatus name (do
compiledAnnotations <- compileAnnotationMap scope EnumValueAnnotation annotations
(theId, compiledAnnotations) <- compileAnnotations scope EnumValueAnnotation annotations
return (DescEnumValue EnumValueDesc
{ enumValueName = name
, enumValueId = theId
, enumValueParent = parent
, enumValueNumber = number
, enumValueAnnotations = compiledAnnotations
......@@ -605,13 +615,14 @@ compileDecl scope (StructDecl (Located _ name) annotations decls) =
let fieldNums = extractFieldNumbers decls
requireSequentialNumbering "Fields" fieldNums
requireOrdinalsInRange fieldNums
compiledAnnotations <- compileAnnotationMap scope StructAnnotation annotations
(theId, compiledAnnotations) <- compileAnnotations scope StructAnnotation annotations
return (let
fields = [d | DescField d <- members]
unions = [d | DescUnion d <- members]
(packing, _, fieldPackingMap) = packFields fields unions
in DescStruct StructDesc
{ structName = name
, structId = theId
, structParent = scope
, structPacking = packing
, structFields = fields
......@@ -635,11 +646,12 @@ compileDecl scope@(DescStruct parent)
orderedFieldNumbers = List.sort $ map fieldNumber fields
discriminantMap = Map.fromList $ zip orderedFieldNumbers [0..]
requireNoMoreThanOneFieldNumberLessThan name numPos number fields
compiledAnnotations <- compileAnnotationMap scope UnionAnnotation annotations
(theId, compiledAnnotations) <- compileAnnotations scope UnionAnnotation annotations
return (let
(tagOffset, tagPacking) = structFieldPackingMap parent ! number
in DescUnion UnionDesc
{ unionName = name
, unionId = theId
, unionParent = parent
, unionNumber = number
, unionTagOffset = tagOffset
......@@ -667,11 +679,12 @@ compileDecl scope
defaultDesc <- case defaultValue of
Just (Located defaultPos value) -> fmap Just (compileValue defaultPos typeDesc value)
Nothing -> return Nothing
compiledAnnotations <- compileAnnotationMap scope FieldAnnotation annotations
(theId, compiledAnnotations) <- compileAnnotations scope FieldAnnotation annotations
return (let
(offset, packing) = structFieldPackingMap parent ! number
in DescField FieldDesc
{ fieldName = name
, fieldId = theId
, fieldParent = parent
, fieldNumber = number
, fieldOffset = offset
......@@ -689,9 +702,10 @@ compileDecl scope (InterfaceDecl (Located _ name) annotations decls) =
let numbers = [ num | MethodDecl _ num _ _ _ <- decls ]
requireSequentialNumbering "Methods" numbers
requireOrdinalsInRange numbers
compiledAnnotations <- compileAnnotationMap scope InterfaceAnnotation annotations
(theId, compiledAnnotations) <- compileAnnotations scope InterfaceAnnotation annotations
return (DescInterface InterfaceDesc
{ interfaceName = name
, interfaceId = theId
, interfaceParent = scope
, interfaceMethods = [d | DescMethod d <- members]
, interfaceNestedAliases = [d | DescAlias d <- members]
......@@ -709,9 +723,10 @@ compileDecl scope@(DescInterface parent)
CompiledStatementStatus name (feedback (\desc -> do
paramDescs <- doAll (map (compileParam desc) (zip [0..] params))
returnTypeDesc <- compileType scope returnType
compiledAnnotations <- compileAnnotationMap scope MethodAnnotation annotations
(theId, compiledAnnotations) <- compileAnnotations scope MethodAnnotation annotations
return (DescMethod MethodDesc
{ methodName = name
, methodId = theId
, methodParent = parent
, methodNumber = number
, methodParams = paramDescs
......@@ -724,9 +739,10 @@ compileDecl _ (MethodDecl (Located pos name) _ _ _ _) =
compileDecl scope (AnnotationDecl (Located _ name) typeExp annotations targets) =
CompiledStatementStatus name (do
typeDesc <- compileType scope typeExp
compiledAnnotations <- compileAnnotationMap scope AnnotationAnnotation annotations
(theId, compiledAnnotations) <- compileAnnotations scope AnnotationAnnotation annotations
return (DescAnnotation AnnotationDesc
{ annotationName = name
, annotationId = theId
, annotationParent = scope
, annotationType = typeDesc
, annotationAnnotations = compiledAnnotations
......@@ -739,9 +755,10 @@ compileParam scope@(DescMethod parent)
defaultDesc <- case defaultValue of
Just (Located pos value) -> fmap Just (compileValue pos typeDesc value)
Nothing -> return Nothing
compiledAnnotations <- compileAnnotationMap scope ParamAnnotation annotations
(theId, compiledAnnotations) <- compileAnnotations scope ParamAnnotation annotations
return ParamDesc
{ paramName = name
, paramId = theId
, paramParent = parent
, paramNumber = ordinal
, paramType = typeDesc
......@@ -754,9 +771,11 @@ compileFile name decls annotations importMap =
feedback (\desc -> do
(members, memberMap) <- compileChildDecls (DescFile desc) decls
requireNoDuplicateNames decls
compiledAnnotations <- compileAnnotationMap (DescFile desc) FileAnnotation annotations
(theId, compiledAnnotations)
<- compileAnnotations (DescFile desc) FileAnnotation annotations
return FileDesc
{ fileName = name
, fileId = theId
, fileImports = Map.elems importMap
, fileAliases = [d | DescAlias d <- members]
, fileConstants = [d | DescConstant d <- members]
......@@ -774,6 +793,7 @@ dedup = Set.toList . Set.fromList
emptyFileDesc filename = FileDesc
{ fileName = filename
, fileId = Nothing
, fileImports = []
, fileAliases = []
, fileConstants = []
......
compiler/src/CxxGenerator.hs
View file @ d3e5540c
......@@ -30,7 +30,7 @@ import Data.FileEmbed(embedFile)
import Data.Word(Word8)
import qualified Data.Digest.MD5 as MD5
import qualified Data.Map as Map
import Data.Maybe(catMaybes)
import Data.Maybe(catMaybes, fromMaybe)
import Data.Binary.IEEE754(floatToWord, doubleToWord)
import Text.Printf(printf)
import Text.Hastache
......@@ -50,12 +50,20 @@ muNull = MuBool False;
-- Using a single-element list has the same effect, though.
muJust c = MuList [c]
namespaceAnnotationId = "v3JF2GP4Supe9JSSJ3pnSdUqhJI.namespace"
fileNamespace desc = fmap testAnnotation $ Map.lookup namespaceAnnotationId $ fileAnnotations desc
testAnnotation (_, TextDesc x) = x
testAnnotation (desc, _) =
error "Annotation was supposed to be text, but wasn't: " ++ annotationName desc
fullName desc = scopePrefix (descParent desc) ++ descName desc
scopePrefix (DescFile _) = ""
scopePrefix desc = fullName desc ++ "::"
globalName (DescFile _) = " " -- TODO: namespaces
globalName (DescFile desc) = maybe " " (" ::" ++) $ fileNamespace desc
globalName desc = globalName (descParent desc) ++ "::" ++ descName desc
-- Flatten the descriptor tree in pre-order, returning struct, union, and interface descriptors
......@@ -303,14 +311,20 @@ importContext parent filename = mkStrContext context where
context "importIsSystem" = MuBool False
context s = parent s
namespaceContext parent part = mkStrContext context where
context "namespaceName" = MuVariable part
context s = parent s
fileContext desc = mkStrContext context where
flattenedMembers = flattenTypes $ catMaybes $ Map.elems $ fileMemberMap desc
namespace = maybe [] (splitOn "::") $ fileNamespace desc
context "fileName" = MuVariable $ fileName desc
context "fileBasename" = MuVariable $ takeBaseName $ fileName desc
context "fileIncludeGuard" = MuVariable $
"CAPNPROTO_INCLUDED_" ++ hashString (fileName desc)
context "fileNamespaces" = MuList [] -- TODO
"CAPNPROTO_INCLUDED_" ++ hashString (fileName desc ++ ':':fromMaybe "" (fileId desc))
context "fileNamespaces" = MuList $ map (namespaceContext context) namespace
context "fileEnums" = MuList $ map (enumContext context) $ fileEnums desc
context "fileTypes" = MuList $ map (typeContext context) flattenedMembers
context "fileImports" = MuList $ map (importContext context) $ Map.keys $ fileImportMap desc
......
compiler/src/Parser.hs
View file @ d3e5540c
......@@ -184,9 +184,9 @@ constantDecl = do
name <- located varIdentifier
colon
typeName <- typeExpression
annotations <- many annotation
equalsSign
value <- located fieldValue
annotations <- many annotation
return (ConstantDecl name typeName annotations value)
typeDecl statements = enumDecl statements
......@@ -235,8 +235,8 @@ fieldDecl = do
(name, ordinal) <- nameWithOrdinal
colon
t <- typeExpression
annotations <- many annotation
value <- optionMaybe (equalsSign >> located fieldValue)
annotations <- many annotation
return (FieldDecl name ordinal t annotations value)
negativeFieldValue = liftM (IntegerFieldValue . negate) literalInt
......@@ -288,8 +288,8 @@ paramDecl = do
name <- varIdentifier
colon
t <- typeExpression
annotations <- many annotation
value <- optionMaybe (equalsSign >> located fieldValue)
annotations <- many annotation
return (ParamDecl name t annotations value)
annotationDecl = do
......@@ -297,10 +297,10 @@ annotationDecl = do
name <- located varIdentifier
colon
t <- typeExpression
annotations <- many annotation
onKeyword
targets <- try (parenthesized asterisk >> return allAnnotationTargets)
<|> parenthesizedList annotationTarget
annotations <- many annotation
return (AnnotationDecl name t annotations targets)
allAnnotationTargets = [minBound::AnnotationTarget .. maxBound::AnnotationTarget]
......
compiler/src/Semantics.hs
View file @ d3e5540c
......@@ -39,8 +39,6 @@ import Grammar(AnnotationTarget(..))
-- ordinal is 65534.
maxOrdinal = 65534 :: Integer
idId = "com.capnproto.compiler.builtin.id"
type ByteString = [Word8]
data Desc = DescFile FileDesc
......@@ -57,6 +55,7 @@ data Desc = DescFile FileDesc
| DescAnnotation AnnotationDesc
| DescBuiltinType BuiltinType
| DescBuiltinList
| DescBuiltinId
descName (DescFile _) = "(top-level)"
descName (DescAlias d) = aliasName d
......@@ -72,6 +71,31 @@ descName (DescParam d) = paramName d
descName (DescAnnotation d) = annotationName d
descName (DescBuiltinType d) = builtinTypeName d
descName DescBuiltinList = "List"
descName DescBuiltinId = "id"
descId (DescFile d) = fileId d
descId (DescAlias _) = Nothing
descId (DescConstant d) = constantId d
descId (DescEnum d) = enumId d
descId (DescEnumValue d) = enumValueId d
descId (DescStruct d) = structId d
descId (DescUnion d) = unionId d
descId (DescField d) = fieldId d
descId (DescInterface d) = interfaceId d
descId (DescMethod d) = methodId d
descId (DescParam d) = paramId d
descId (DescAnnotation d) = annotationId d
descId (DescBuiltinType _) = Nothing
descId DescBuiltinList = Nothing
descId DescBuiltinId = Just "0U0T3e_SnatEfk6UcH2tcjTt1E0"
-- Gets the ID if explicitly defined, or generates it by appending ".name" to the parent's ID.
-- If no ancestor has an ID, still returns Nothing.
descAutoId d = case descId d of
Just i -> Just i
Nothing -> case d of
DescFile _ -> Nothing
_ -> fmap (++ '.':descName d) $ descAutoId $ descParent d
descParent (DescFile _) = error "File descriptor has no parent."
descParent (DescAlias d) = aliasParent d
......@@ -87,6 +111,23 @@ 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."
descParent DescBuiltinId = error "Builtin annotation has no parent."
descAnnotations (DescFile d) = fileAnnotations d
descAnnotations (DescAlias _) = Map.empty
descAnnotations (DescConstant d) = constantAnnotations d
descAnnotations (DescEnum d) = enumAnnotations d
descAnnotations (DescEnumValue d) = enumValueAnnotations d
descAnnotations (DescStruct d) = structAnnotations d
descAnnotations (DescUnion d) = unionAnnotations d
descAnnotations (DescField d) = fieldAnnotations d
descAnnotations (DescInterface d) = interfaceAnnotations d
descAnnotations (DescMethod d) = methodAnnotations d
descAnnotations (DescParam d) = paramAnnotations d
descAnnotations (DescAnnotation d) = annotationAnnotations d
descAnnotations (DescBuiltinType _) = Map.empty
descAnnotations DescBuiltinList = Map.empty
descAnnotations DescBuiltinId = Map.empty
type MemberMap = Map.Map String (Maybe Desc)
......@@ -264,6 +305,7 @@ descQualifiedName scope desc = descQualifiedName (descParent scope) desc
data FileDesc = FileDesc
{ fileName :: String
, fileId :: Maybe String
, fileImports :: [FileDesc]
, fileAliases :: [AliasDesc]
, fileConstants :: [ConstantDesc]
......@@ -284,6 +326,7 @@ data AliasDesc = AliasDesc
data ConstantDesc = ConstantDesc
{ constantName :: String
, constantId :: Maybe String
, constantParent :: Desc
, constantType :: TypeDesc
, constantAnnotations :: AnnotationMap
......@@ -292,6 +335,7 @@ data ConstantDesc = ConstantDesc
data EnumDesc = EnumDesc
{ enumName :: String
, enumId :: Maybe String
, enumParent :: Desc
, enumValues :: [EnumValueDesc]
, enumAnnotations :: AnnotationMap
......@@ -301,6 +345,7 @@ data EnumDesc = EnumDesc
data EnumValueDesc = EnumValueDesc
{ enumValueName :: String
, enumValueId :: Maybe String
, enumValueParent :: EnumDesc
, enumValueNumber :: Integer
, enumValueAnnotations :: AnnotationMap
......@@ -308,6 +353,7 @@ data EnumValueDesc = EnumValueDesc
data StructDesc = StructDesc
{ structName :: String
, structId :: Maybe String
, structParent :: Desc
, structPacking :: PackingState
, structFields :: [FieldDesc]
......@@ -329,6 +375,7 @@ data StructDesc = StructDesc
data UnionDesc = UnionDesc
{ unionName :: String
, unionId :: Maybe String
, unionParent :: StructDesc
, unionNumber :: Integer
, unionTagOffset :: Integer
......@@ -344,6 +391,7 @@ data UnionDesc = UnionDesc
data FieldDesc = FieldDesc
{ fieldName :: String
, fieldId :: Maybe String
, fieldParent :: StructDesc
, fieldNumber :: Integer
, fieldOffset :: Integer
......@@ -356,6 +404,7 @@ data FieldDesc = FieldDesc
data InterfaceDesc = InterfaceDesc
{ interfaceName :: String
, interfaceId :: Maybe String
, interfaceParent :: Desc
, interfaceMethods :: [MethodDesc]
, interfaceNestedAliases :: [AliasDesc]
......@@ -370,6 +419,7 @@ data InterfaceDesc = InterfaceDesc
data MethodDesc = MethodDesc
{ methodName :: String
, methodId :: Maybe String
, methodParent :: InterfaceDesc
, methodNumber :: Integer
, methodParams :: [ParamDesc]
......@@ -379,6 +429,7 @@ data MethodDesc = MethodDesc
data ParamDesc = ParamDesc
{ paramName :: String
, paramId :: Maybe String
, paramParent :: MethodDesc
, paramNumber :: Integer
, paramType :: TypeDesc
......@@ -391,43 +442,47 @@ data AnnotationDesc = AnnotationDesc
, annotationParent :: Desc
, annotationType :: TypeDesc
, annotationAnnotations :: AnnotationMap
, annotationId :: Maybe String
, annotationTargets :: Set.Set AnnotationTarget
}
type AnnotationMap = Map.Map String (AnnotationDesc, ValueDesc)
descToCode :: String -> Desc -> String
descToCode indent self@(DescFile desc) = printf "# %s\n%s%s"
descToCode indent self@(DescFile desc) = printf "# %s\n%s%s%s"
(fileName desc)
(concatMap ((++ ";\n") . annotationCode (descParent self)) $ Map.toList $ fileAnnotations desc)
(case fileId desc of
Just i -> printf "$id(%s);\n" $ show i
Nothing -> "")
(concatMap ((++ ";\n") . annotationCode 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 self@(DescConstant desc) = printf "%sconst %s: %s%s = %s;\n" indent
descToCode indent self@(DescConstant desc) = printf "%sconst %s: %s = %s%s;\n" indent
(constantName desc)
(typeName (descParent self) (constantType desc))
(annotationsCode (descParent self) $ constantAnnotations desc)
(valueString (constantValue desc))
(annotationsCode self)
descToCode indent self@(DescEnum desc) = printf "%senum %s%s {\n%s%s}\n" indent
(enumName desc)
(annotationsCode (descParent self) $ enumAnnotations desc)
(annotationsCode self)
(blockCode indent (enumStatements desc))
indent
descToCode indent self@(DescEnumValue desc) = printf "%s%s @%d%s;\n" indent
(enumValueName desc) (enumValueNumber desc)
(annotationsCode (descParent self) $ enumValueAnnotations desc)
(annotationsCode self)
descToCode indent self@(DescStruct desc) = printf "%sstruct %s%s {\n%s%s}\n" indent
(structName desc)
(annotationsCode (descParent self) $ structAnnotations desc)
(annotationsCode self)
(blockCode indent (structStatements desc))
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 (descParent self) (fieldType desc))
(annotationsCode (descParent self) $ fieldAnnotations desc)
(case fieldDefaultValue desc of { Nothing -> ""; Just v -> " = " ++ valueString v; })
(annotationsCode self)
(case fieldSize $ fieldType desc of
SizeReference -> printf "ref[%d]" $ fieldOffset desc
SizeInlineComposite _ _ -> "??"
......@@ -437,34 +492,35 @@ descToCode indent self@(DescField desc) = printf "%s%s@%d%s: %s%s%s; # %s\n" in
in printf "bits[%d, %d)" (offset * bits) ((offset + 1) * bits))
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)
(annotationsCode self)
(unionTagOffset desc * 16) (unionTagOffset desc * 16 + 16)
(blockCode indent $ unionStatements desc)
indent
descToCode indent self@(DescInterface desc) = printf "%sinterface %s%s {\n%s%s}\n" indent
(interfaceName desc)
(annotationsCode (descParent self) $ interfaceAnnotations desc)
(annotationsCode self)
(blockCode indent (interfaceStatements desc))
indent
descToCode indent self@(DescMethod desc) = printf "%s%s@%d(%s): %s%s" indent
(methodName desc) (methodNumber desc)
(delimit ", " (map (descToCode indent . DescParam) (methodParams desc)))
(typeName (descParent self) (methodReturnType desc))
(annotationsCode (descParent self) $ methodAnnotations desc)
(annotationsCode self)
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
(annotationsCode self)
descToCode indent self@(DescAnnotation desc) = printf "%sannotation %s: %s on(%s)%s;\n" indent
(annotationName desc)
(typeName (descParent self) (annotationType desc))
(annotationsCode (descParent self) $ annotationAnnotations desc)
(delimit ", " $ map show $ Set.toList $ annotationTargets desc)
(annotationsCode self)
descToCode _ (DescBuiltinType _) = error "Can't print code for builtin type."
descToCode _ DescBuiltinList = error "Can't print code for builtin type."
descToCode _ DescBuiltinId = error "Can't print code for builtin annotation."
maybeBlockCode :: String -> [Desc] -> String
maybeBlockCode _ [] = ";\n"
......@@ -476,12 +532,15 @@ 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
annotationsCode desc = let
nonIds = concatMap ((' ':) . annotationCode (descParent desc)) $ Map.toList
$ descAnnotations desc
in case descId desc of
Just i -> printf " $id(%s)%s" (show i) nonIds
Nothing -> nonIds
instance Show FileDesc where { show desc = descToCode "" (DescFile desc) }
instance Show AliasDesc where { show desc = descToCode "" (DescAlias desc) }
......
compiler/src/Util.hs
View file @ d3e5540c
......@@ -24,12 +24,19 @@
module Util where
import Data.Char (isUpper, toUpper)
import Data.List (intercalate)
import Data.List (intercalate, isPrefixOf)
--delimit _ [] = ""
--delimit delimiter (h:t) = h ++ concatMap (delimiter ++) t
delimit = intercalate
splitOn :: String -> String -> [String]
splitOn _ "" = [""]
splitOn delimiter text | delimiter `isPrefixOf` text =
[]:splitOn delimiter (drop (length delimiter) text)
splitOn delimiter (c:rest) = let (first:more) = splitOn delimiter rest in (c:first):more
-- Splits "camelCase" into ["camel", "Case"]
splitName :: String -> [String]
splitName (a:rest@(b:_)) | isUpper b = [a]:splitName rest
splitName (a:rest) = case splitName rest of
......
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