Skip to content
Projects
Groups
Snippets
Help
Loading...
Sign in / Register
Toggle navigation
C
capnproto
Project
Project
Details
Activity
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
0
Issues
0
List
Board
Labels
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Packages
Packages
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
submodule
capnproto
Commits
2c8595bc
Commit
2c8595bc
authored
Apr 30, 2013
by
Kenton Varda
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Redo IDs. They now look like ordinals, except that they are 64-bit unique integers.
parent
567c2de2
Show whitespace changes
Inline
Side-by-side
Showing
12 changed files
with
205 additions
and
179 deletions
+205
-179
c++.capnp
c++/src/capnproto/c++.capnp
+1
-1
test-import.capnp
c++/src/capnproto/test-import.capnp
+2
-0
test.capnp
c++/src/capnproto/test.capnp
+2
-0
capnproto-compiler.cabal
compiler/capnproto-compiler.cabal
+2
-1
Compiler.hs
compiler/src/Compiler.hs
+60
-59
CxxGenerator.hs
compiler/src/CxxGenerator.hs
+3
-3
Grammar.hs
compiler/src/Grammar.hs
+16
-13
Main.hs
compiler/src/Main.hs
+23
-3
Parser.hs
compiler/src/Parser.hs
+47
-18
Semantics.hs
compiler/src/Semantics.hs
+19
-53
Util.hs
compiler/src/Util.hs
+7
-0
WireFormat.hs
compiler/src/WireFormat.hs
+23
-28
No files found.
c++/src/capnproto/c++.capnp
View file @
2c8595bc
...
...
@@ -21,7 +21,7 @@
# (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")
;
@0xbdf87d7bb8304e81
;
$namespace("capnproto::annotations");
annotation namespace(file): Text;
c++/src/capnproto/test-import.capnp
View file @
2c8595bc
...
...
@@ -21,6 +21,8 @@
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
@0xf36d7b330303c66e;
using Test = import "test.capnp";
struct TestImport {
...
...
c++/src/capnproto/test.capnp
View file @
2c8595bc
...
...
@@ -21,6 +21,8 @@
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
@0xd508eebdc2dc42b8;
using Cxx = import "c++.capnp";
# Use a namespace likely to cause trouble if the generated code doesn't use fully-qualified
...
...
compiler/capnproto-compiler.cabal
View file @
2c8595bc
...
...
@@ -29,7 +29,8 @@ executable capnpc
filepath,
directory,
syb,
transformers
transformers,
entropy
ghc-options: -Wall -fno-warn-missing-signatures
other-modules:
Lexer,
...
...
compiler/src/Compiler.hs
View file @
2c8595bc
...
...
@@ -25,18 +25,21 @@ module Compiler (Status(..), parseAndCompileFile) where
import
Grammar
import
Semantics
import
Token
(
Located
(
Located
),
located
Pos
,
located
Value
)
import
Token
(
Located
(
Located
),
locatedValue
)
import
Parser
(
parseFile
)
import
Control.Monad
(
when
,
unless
)
import
Control.Monad
(
when
,
unless
,
liftM
)
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
,
listToMaybe
,
catMaybes
,
isJust
)
import
Data.Maybe
(
mapMaybe
,
fromMaybe
,
isJust
,
isNothing
)
import
Data.Word
(
Word64
,
Word8
)
import
Text.Parsec.Pos
(
SourcePos
,
newPos
)
import
Text.Parsec.Error
(
ParseError
,
newErrorMessage
,
Message
(
Message
,
Expect
))
import
Text.Printf
(
printf
)
import
Util
(
delimit
)
import
qualified
Data.Digest.MD5
as
MD5
import
qualified
Codec.Binary.UTF8.String
as
UTF8
import
Util
(
delimit
,
intToBytes
)
------------------------------------------------------------------------------------------
-- Error helpers
...
...
@@ -164,8 +167,7 @@ builtinTypeMap = Map.fromList
[(
"List"
,
DescBuiltinList
),
(
"Inline"
,
DescBuiltinInline
),
(
"InlineList"
,
DescBuiltinInlineList
),
(
"InlineData"
,
DescBuiltinInlineData
),
(
"id"
,
DescBuiltinId
)])
(
"InlineData"
,
DescBuiltinInlineData
)])
------------------------------------------------------------------------------------------
...
...
@@ -364,43 +366,30 @@ compileType scope (TypeExpression n params) = do
printf
"'%s' doesn't take parameters."
(
declNameString
n
)
compileAnnotation
::
Desc
->
AnnotationTarget
->
Annotation
->
Status
(
Maybe
AnnotationDesc
,
ValueDesc
)
->
Status
(
AnnotationDesc
,
ValueDesc
)
compileAnnotation
scope
kind
(
Annotation
name
(
Located
pos
value
))
=
do
nameDesc
<-
lookupDesc
scope
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
(
Just
annDesc
,
compiledValue
)
return
(
annDesc
,
compiledValue
)
_
->
makeError
(
declNamePos
name
)
$
printf
"'%s' is not an annotation."
(
declNameString
name
)
compileAnnotations
::
Desc
->
AnnotationTarget
->
[
Annotation
]
->
Status
(
Maybe
String
,
AnnotationMap
)
-- (id, other annotations)
->
Status
AnnotationMap
compileAnnotations
scope
kind
annotations
=
do
let
compileLocated
ann
@
(
Annotation
name
_
)
=
fmap
(
Located
$
declNamePos
name
)
$
compileAnnotation
scope
kind
ann
compiled
<-
doAll
$
map
compileLocated
annotations
-- 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
-- Makes a map entry for the annotation keyed by ID.
let
locatedEntries
=
[
Located
pos
(
annotationId
desc
,
(
desc
,
v
))
|
Located
pos
(
desc
,
v
)
<-
compiled
]
-- TODO(cleanup): Generalize duplicate detection.
sortedLocatedEntries
=
detectDup
$
List
.
sortBy
compareIds
locatedEntries
...
...
@@ -411,9 +400,16 @@ compileAnnotations scope kind annotations = do
detectDup
[]
=
[]
finalEntries
<-
doAll
sortedLocatedEntries
_
<-
doAll
dupIds
return
(
theId
,
Map
.
fromList
finalEntries
)
return
$
Map
.
fromList
finalEntries
childId
::
String
->
Maybe
(
Located
Word64
)
->
Desc
->
Word64
childId
_
(
Just
(
Located
_
myId
))
_
=
myId
childId
name
Nothing
parent
=
let
hash
=
MD5
.
hash
(
intToBytes
(
descId
parent
)
8
++
UTF8
.
encode
name
)
addByte
::
Word64
->
Word8
->
Word64
addByte
b
v
=
b
*
256
+
fromIntegral
v
in
foldl
addByte
0
(
take
8
hash
)
------------------------------------------------------------------------------------------
...
...
@@ -801,27 +797,26 @@ compileDecl scope (ConstantDecl (Located _ name) t annotations (Located valuePos
CompiledStatementStatus
name
(
do
typeDesc
<-
compileType
scope
t
valueDesc
<-
compileValue
valuePos
typeDesc
value
(
theId
,
compiledAnnotations
)
<-
compileAnnotations
scope
ConstantAnnotation
annotations
compiledAnnotations
<-
compileAnnotations
scope
ConstantAnnotation
annotations
return
(
DescConstant
ConstantDesc
{
constantName
=
name
,
constantId
=
theId
,
constantParent
=
scope
,
constantType
=
typeDesc
,
constantValue
=
valueDesc
,
constantAnnotations
=
compiledAnnotations
}))
compileDecl
scope
(
EnumDecl
(
Located
_
name
)
annotations
decls
)
=
compileDecl
scope
(
EnumDecl
(
Located
_
name
)
maybeTypeId
annotations
decls
)
=
CompiledStatementStatus
name
(
feedback
(
\
desc
->
do
(
members
,
memberMap
)
<-
compileChildDecls
desc
decls
requireNoDuplicateNames
decls
let
numbers
=
[
num
|
EnumerantDecl
_
num
_
<-
decls
]
requireSequentialNumbering
"Enumerants"
numbers
requireOrdinalsInRange
numbers
(
theId
,
compiledAnnotations
)
<-
compileAnnotations
scope
EnumAnnotation
annotations
compiledAnnotations
<-
compileAnnotations
scope
EnumAnnotation
annotations
return
(
DescEnum
EnumDesc
{
enumName
=
name
,
enumId
=
theId
,
enumId
=
childId
name
maybeTypeId
scope
,
enumParent
=
scope
,
enumerants
=
[
d
|
DescEnumerant
d
<-
members
]
,
enumAnnotations
=
compiledAnnotations
...
...
@@ -832,10 +827,9 @@ compileDecl scope (EnumDecl (Located _ name) annotations decls) =
compileDecl
scope
@
(
DescEnum
parent
)
(
EnumerantDecl
(
Located
_
name
)
(
Located
_
number
)
annotations
)
=
CompiledStatementStatus
name
(
do
(
theId
,
compiledAnnotations
)
<-
compileAnnotations
scope
EnumerantAnnotation
annotations
compiledAnnotations
<-
compileAnnotations
scope
EnumerantAnnotation
annotations
return
(
DescEnumerant
EnumerantDesc
{
enumerantName
=
name
,
enumerantId
=
theId
,
enumerantParent
=
parent
,
enumerantNumber
=
number
,
enumerantAnnotations
=
compiledAnnotations
...
...
@@ -843,14 +837,14 @@ compileDecl scope@(DescEnum parent)
compileDecl
_
(
EnumerantDecl
(
Located
pos
name
)
_
_
)
=
CompiledStatementStatus
name
(
makeError
pos
"Enumerants can only appear inside enums."
)
compileDecl
scope
(
StructDecl
(
Located
_
name
)
isFixed
annotations
decls
)
=
compileDecl
scope
(
StructDecl
(
Located
_
name
)
maybeTypeId
isFixed
annotations
decls
)
=
CompiledStatementStatus
name
(
feedback
(
\
desc
->
do
(
members
,
memberMap
)
<-
compileChildDecls
desc
decls
requireNoDuplicateNames
decls
let
fieldNums
=
extractFieldNumbers
decls
requireSequentialNumbering
"Fields"
fieldNums
requireOrdinalsInRange
fieldNums
(
theId
,
compiledAnnotations
)
<-
compileAnnotations
scope
StructAnnotation
annotations
compiledAnnotations
<-
compileAnnotations
scope
StructAnnotation
annotations
let
(
dataSize
,
pointerCount
,
fieldPackingMap
)
=
packFields
fields
unions
fields
=
[
d
|
DescField
d
<-
members
]
unions
=
[
d
|
DescUnion
d
<-
members
]
...
...
@@ -859,7 +853,7 @@ compileDecl scope (StructDecl (Located _ name) isFixed annotations decls) =
return
(
let
in
DescStruct
StructDesc
{
structName
=
name
,
structId
=
theId
,
structId
=
childId
name
maybeTypeId
scope
,
structParent
=
scope
,
structDataSize
=
finalDataSize
,
structPointerCount
=
finalPointerCount
...
...
@@ -880,12 +874,11 @@ compileDecl scope@(DescStruct parent)
orderedFieldNumbers
=
List
.
sort
$
map
fieldNumber
fields
discriminantMap
=
Map
.
fromList
$
zip
orderedFieldNumbers
[
0
..
]
requireNoMoreThanOneFieldNumberLessThan
name
numPos
number
fields
(
theId
,
compiledAnnotations
)
<-
compileAnnotations
scope
UnionAnnotation
annotations
compiledAnnotations
<-
compileAnnotations
scope
UnionAnnotation
annotations
return
(
let
DataOffset
Size16
tagOffset
=
structFieldPackingMap
parent
!
number
in
DescUnion
UnionDesc
{
unionName
=
name
,
unionId
=
theId
,
unionParent
=
parent
,
unionNumber
=
number
,
unionTagOffset
=
tagOffset
...
...
@@ -925,11 +918,10 @@ compileDecl scope
_
->
return
()
)
return
result
Nothing
->
return
Nothing
(
theId
,
compiledAnnotations
)
<-
compileAnnotations
scope
FieldAnnotation
annotations
compiledAnnotations
<-
compileAnnotations
scope
FieldAnnotation
annotations
return
(
let
in
DescField
FieldDesc
{
fieldName
=
name
,
fieldId
=
theId
,
fieldParent
=
parent
,
fieldNumber
=
number
,
fieldOffset
=
structFieldPackingMap
parent
!
number
...
...
@@ -939,17 +931,17 @@ compileDecl scope
,
fieldAnnotations
=
compiledAnnotations
}))
compileDecl
scope
(
InterfaceDecl
(
Located
_
name
)
annotations
decls
)
=
compileDecl
scope
(
InterfaceDecl
(
Located
_
name
)
maybeTypeId
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
(
theId
,
compiledAnnotations
)
<-
compileAnnotations
scope
InterfaceAnnotation
annotations
compiledAnnotations
<-
compileAnnotations
scope
InterfaceAnnotation
annotations
return
(
DescInterface
InterfaceDesc
{
interfaceName
=
name
,
interfaceId
=
theId
,
interfaceId
=
childId
name
maybeTypeId
scope
,
interfaceParent
=
scope
,
interfaceMethods
=
[
d
|
DescMethod
d
<-
members
]
,
interfaceAnnotations
=
compiledAnnotations
...
...
@@ -962,10 +954,9 @@ compileDecl scope@(DescInterface parent)
CompiledStatementStatus
name
(
feedback
(
\
desc
->
do
paramDescs
<-
doAll
(
map
(
compileParam
desc
)
(
zip
[
0
..
]
params
))
returnTypeDesc
<-
compileType
scope
returnType
(
theId
,
compiledAnnotations
)
<-
compileAnnotations
scope
MethodAnnotation
annotations
compiledAnnotations
<-
compileAnnotations
scope
MethodAnnotation
annotations
return
(
DescMethod
MethodDesc
{
methodName
=
name
,
methodId
=
theId
,
methodParent
=
parent
,
methodNumber
=
number
,
methodParams
=
paramDescs
...
...
@@ -975,13 +966,13 @@ compileDecl scope@(DescInterface parent)
compileDecl
_
(
MethodDecl
(
Located
pos
name
)
_
_
_
_
)
=
CompiledStatementStatus
name
(
makeError
pos
"Methods can only appear inside interfaces."
)
compileDecl
scope
(
AnnotationDecl
(
Located
_
name
)
typeExp
annotations
targets
)
=
compileDecl
scope
(
AnnotationDecl
(
Located
_
name
)
maybeTypeId
typeExp
annotations
targets
)
=
CompiledStatementStatus
name
(
do
typeDesc
<-
compileType
scope
typeExp
(
theId
,
compiledAnnotations
)
<-
compileAnnotations
scope
AnnotationAnnotation
annotations
compiledAnnotations
<-
compileAnnotations
scope
AnnotationAnnotation
annotations
return
(
DescAnnotation
AnnotationDesc
{
annotationName
=
name
,
annotationId
=
theId
,
annotationId
=
childId
name
maybeTypeId
scope
,
annotationParent
=
scope
,
annotationType
=
typeDesc
,
annotationAnnotations
=
compiledAnnotations
...
...
@@ -994,10 +985,9 @@ compileParam scope@(DescMethod parent)
defaultDesc
<-
case
defaultValue
of
Just
(
Located
pos
value
)
->
fmap
Just
(
compileValue
pos
typeDesc
value
)
Nothing
->
return
Nothing
(
theId
,
compiledAnnotations
)
<-
compileAnnotations
scope
ParamAnnotation
annotations
compiledAnnotations
<-
compileAnnotations
scope
ParamAnnotation
annotations
return
ParamDesc
{
paramName
=
name
,
paramId
=
theId
,
paramParent
=
parent
,
paramNumber
=
ordinal
,
paramType
=
typeDesc
...
...
@@ -1006,15 +996,14 @@ compileParam scope@(DescMethod parent)
}
compileParam
_
_
=
error
"scope of parameter was not a method"
compileFile
name
decls
annotations
importMap
=
compileFile
name
theId
decls
annotations
importMap
=
feedback
(
\
desc
->
do
(
members
,
memberMap
)
<-
compileChildDecls
(
DescFile
desc
)
decls
requireNoDuplicateNames
decls
(
theId
,
compiledAnnotations
)
<-
compileAnnotations
(
DescFile
desc
)
FileAnnotation
annotations
compiledAnnotations
<-
compileAnnotations
(
DescFile
desc
)
FileAnnotation
annotations
return
FileDesc
{
fileName
=
name
,
fileId
=
theId
,
fileId
=
locatedValue
theId
,
fileImports
=
Map
.
elems
importMap
,
fileRuntimeImports
=
Set
.
fromList
$
map
fileName
$
concatMap
descRuntimeImports
members
...
...
@@ -1029,7 +1018,7 @@ dedup = Set.toList . Set.fromList
emptyFileDesc
filename
=
FileDesc
{
fileName
=
filename
,
fileId
=
Nothing
,
fileId
=
0x0
,
fileImports
=
[]
,
fileRuntimeImports
=
Set
.
empty
,
fileAnnotations
=
Map
.
empty
...
...
@@ -1042,9 +1031,10 @@ parseAndCompileFile :: Monad m
=>
FilePath
-- Name of this file.
->
String
-- Content of this file.
->
(
String
->
m
(
Either
FileDesc
String
))
-- Callback to import other files.
->
m
Word64
-- Callback to generate a random id.
->
m
(
Status
FileDesc
)
-- Compiled file and/or errors.
parseAndCompileFile
filename
text
importCallback
=
do
let
(
decls
,
annotations
,
parseErrors
)
=
parseFile
filename
text
parseAndCompileFile
filename
text
importCallback
randomCallback
=
do
let
(
maybeFileId
,
decls
,
annotations
,
parseErrors
)
=
parseFile
filename
text
importNames
=
dedup
$
concatMap
declImports
decls
doImport
(
Located
pos
name
)
=
do
result
<-
importCallback
name
...
...
@@ -1055,6 +1045,11 @@ parseAndCompileFile filename text importCallback = do
importStatuses
<-
mapM
doImport
importNames
let
dummyPos
=
newPos
filename
1
1
theFileId
<-
case
maybeFileId
of
Nothing
->
liftM
(
Located
dummyPos
)
randomCallback
Just
i
->
return
i
return
(
do
-- We are now in the Status monad.
...
...
@@ -1075,5 +1070,11 @@ parseAndCompileFile filename text importCallback = do
-- of one bad import.
imports
<-
doAll
importStatuses
-- Report lack of an id.
when
(
isNothing
maybeFileId
)
$
makeError
dummyPos
$
printf
"File does not declare an ID. I've generated one for you. Add this line
\
\
to your file: @0x%016x;"
(
locatedValue
theFileId
)
-- Compile the file!
compileFile
filename
decls
annotations
$
Map
.
fromList
imports
)
compileFile
filename
theFileId
decls
annotations
$
Map
.
fromList
imports
)
compiler/src/CxxGenerator.hs
View file @
2c8595bc
...
...
@@ -31,7 +31,7 @@ import Data.Word(Word8)
import
qualified
Data.Digest.MD5
as
MD5
import
qualified
Data.Map
as
Map
import
qualified
Data.Set
as
Set
import
Data.Maybe
(
catMaybes
,
fromMaybe
)
import
Data.Maybe
(
catMaybes
)
import
Data.Binary.IEEE754
(
floatToWord
,
doubleToWord
)
import
Text.Printf
(
printf
)
import
Text.Hastache
...
...
@@ -51,7 +51,7 @@ muNull = MuBool False;
-- Using a single-element list has the same effect, though.
muJust
c
=
MuList
[
c
]
namespaceAnnotationId
=
"v3JF2GP4Supe9JSSJ3pnSdUqhJI.namespace"
namespaceAnnotationId
=
0xb9c6f99ebf805f2c
fileNamespace
desc
=
fmap
testAnnotation
$
Map
.
lookup
namespaceAnnotationId
$
fileAnnotations
desc
...
...
@@ -422,7 +422,7 @@ fileContext desc = mkStrContext context where
context
"fileName"
=
MuVariable
$
fileName
desc
context
"fileBasename"
=
MuVariable
$
takeBaseName
$
fileName
desc
context
"fileIncludeGuard"
=
MuVariable
$
"CAPNPROTO_INCLUDED_"
++
hashString
(
fileName
desc
++
':'
:
fromMaybe
""
(
fileId
desc
))
"CAPNPROTO_INCLUDED_"
++
hashString
(
fileName
desc
++
':'
:
show
(
fileId
desc
))
context
"fileNamespaces"
=
MuList
$
map
(
namespaceContext
context
)
namespace
context
"fileEnums"
=
MuList
$
map
(
enumContext
context
)
[
e
|
DescEnum
e
<-
fileMembers
desc
]
context
"fileTypes"
=
MuList
$
map
(
typeContext
context
)
flattenedMembers
...
...
compiler/src/Grammar.hs
View file @
2c8595bc
...
...
@@ -25,6 +25,7 @@ module Grammar where
import
Token
(
Located
)
import
Data.Maybe
(
maybeToList
)
import
Data.Word
(
Word64
)
data
DeclName
=
AbsoluteName
(
Located
String
)
|
RelativeName
(
Located
String
)
...
...
@@ -100,43 +101,45 @@ instance Show AnnotationTarget where
data
Declaration
=
UsingDecl
(
Located
String
)
DeclName
|
ConstantDecl
(
Located
String
)
TypeExpression
[
Annotation
]
(
Located
FieldValue
)
|
EnumDecl
(
Located
String
)
[
Annotation
]
[
Declaration
]
|
EnumDecl
(
Located
String
)
(
Maybe
(
Located
Word64
))
[
Annotation
]
[
Declaration
]
|
EnumerantDecl
(
Located
String
)
(
Located
Integer
)
[
Annotation
]
|
StructDecl
(
Located
String
)
(
Maybe
(
Located
(
Integer
,
Integer
)
))
[
Annotation
]
[
Declaration
]
|
StructDecl
(
Located
String
)
(
Maybe
(
Located
Word64
))
(
Maybe
(
Located
(
Integer
,
Integer
)))
[
Annotation
]
[
Declaration
]
|
FieldDecl
(
Located
String
)
(
Located
Integer
)
TypeExpression
[
Annotation
]
(
Maybe
(
Located
FieldValue
))
|
UnionDecl
(
Located
String
)
(
Located
Integer
)
[
Annotation
]
[
Declaration
]
|
InterfaceDecl
(
Located
String
)
[
Annotation
]
[
Declaration
]
|
InterfaceDecl
(
Located
String
)
(
Maybe
(
Located
Word64
))
[
Annotation
]
[
Declaration
]
|
MethodDecl
(
Located
String
)
(
Located
Integer
)
[
ParamDecl
]
TypeExpression
[
Annotation
]
|
AnnotationDecl
(
Located
String
)
TypeExpression
[
Annotation
]
[
AnnotationTarget
]
|
AnnotationDecl
(
Located
String
)
(
Maybe
(
Located
Word64
))
TypeExpression
[
Annotation
]
[
AnnotationTarget
]
deriving
(
Show
)
declarationName
::
Declaration
->
Maybe
(
Located
String
)
declarationName
(
UsingDecl
n
_
)
=
Just
n
declarationName
(
ConstantDecl
n
_
_
_
)
=
Just
n
declarationName
(
EnumDecl
n
_
_
)
=
Just
n
declarationName
(
EnumDecl
n
_
_
_
)
=
Just
n
declarationName
(
EnumerantDecl
n
_
_
)
=
Just
n
declarationName
(
StructDecl
n
_
_
_
)
=
Just
n
declarationName
(
StructDecl
n
_
_
_
_
)
=
Just
n
declarationName
(
FieldDecl
n
_
_
_
_
)
=
Just
n
declarationName
(
UnionDecl
n
_
_
_
)
=
Just
n
declarationName
(
InterfaceDecl
n
_
_
)
=
Just
n
declarationName
(
InterfaceDecl
n
_
_
_
)
=
Just
n
declarationName
(
MethodDecl
n
_
_
_
_
)
=
Just
n
declarationName
(
AnnotationDecl
n
_
_
_
)
=
Just
n
declarationName
(
AnnotationDecl
n
_
_
_
_
)
=
Just
n
declImports
::
Declaration
->
[
Located
String
]
declImports
(
UsingDecl
_
name
)
=
maybeToList
(
declNameImport
name
)
declImports
(
ConstantDecl
_
t
ann
_
)
=
typeImports
t
++
concatMap
annotationImports
ann
declImports
(
EnumDecl
_
ann
decls
)
=
concatMap
annotationImports
ann
++
concatMap
declImports
decls
declImports
(
EnumDecl
_
_
ann
decls
)
=
concatMap
annotationImports
ann
++
concatMap
declImports
decls
declImports
(
EnumerantDecl
_
_
ann
)
=
concatMap
annotationImports
ann
declImports
(
StructDecl
_
_
ann
decls
)
=
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
++
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
declImports
(
AnnotationDecl
_
_
t
ann
_
)
=
typeImports
t
++
concatMap
annotationImports
ann
compiler/src/Main.hs
View file @
2c8595bc
...
...
@@ -29,8 +29,9 @@ import System.Exit(exitFailure, exitSuccess)
import
System.IO
(
hPutStr
,
stderr
)
import
System.FilePath
(
takeDirectory
)
import
System.Directory
(
createDirectoryIfMissing
,
doesDirectoryExist
,
doesFileExist
)
import
System.Entropy
(
getEntropy
)
import
Control.Monad
import
Control.Monad.IO.Class
(
liftIO
)
import
Control.Monad.IO.Class
(
MonadIO
,
liftIO
)
import
Control.Exception
(
IOException
,
catch
)
import
Control.Monad.Trans.State
(
StateT
,
state
,
modify
,
execStateT
)
import
Prelude
hiding
(
catch
)
...
...
@@ -42,6 +43,8 @@ import Text.Printf(printf)
import
qualified
Data.List
as
List
import
qualified
Data.Map
as
Map
import
qualified
Data.ByteString.Lazy.Char8
as
LZ
import
Data.ByteString
(
unpack
)
import
Data.Word
(
Word64
,
Word8
)
import
Semantics
import
CxxGenerator
(
generateCxx
)
...
...
@@ -54,6 +57,7 @@ data Opt = SearchPathOpt FilePath
|
OutputOpt
String
(
Maybe
GeneratorFn
)
FilePath
|
VerboseOpt
|
HelpOpt
|
GenIdOpt
main
::
IO
()
main
=
do
...
...
@@ -66,6 +70,7 @@ main = do
\
directory). LANG may be any of:
\n\
\
"
++
unwords
(
Map
.
keys
generatorFns
))
,
Option
"v"
[
"verbose"
]
(
NoArg
VerboseOpt
)
"Write information about parsed files."
,
Option
"i"
[
"generate-id"
]
(
NoArg
GenIdOpt
)
"Generate a new unique ID."
,
Option
"h"
[
"help"
]
(
NoArg
HelpOpt
)
"Print usage info and exit."
]
let
usage
=
usageInfo
...
...
@@ -88,11 +93,16 @@ main = do
exitFailure
)
let
isHelp
=
not
$
null
[
opt
|
opt
@
HelpOpt
<-
options
]
when
isHelp
(
do
putStr
usage
exitSuccess
)
let
isGenId
=
not
$
null
[
opt
|
opt
@
GenIdOpt
<-
options
]
when
isGenId
(
do
i
<-
generateId
_
<-
printf
"@0x%016x
\n
"
i
exitSuccess
)
let
isVerbose
=
not
$
null
[
opt
|
opt
@
VerboseOpt
<-
options
]
let
outputs
=
[(
fn
,
dir
)
|
OutputOpt
_
(
Just
fn
)
dir
<-
options
]
let
searchPath
=
[
dir
|
SearchPathOpt
dir
<-
options
]
...
...
@@ -187,6 +197,16 @@ readAndParseFile isVerbose searchPath filename = do
Right
err
->
return
$
Right
err
Left
text
->
parseFile
isVerbose
searchPath
filename
text
generateId
::
MonadIO
m
=>
m
Word64
generateId
=
do
byteString
<-
liftIO
$
getEntropy
8
let
i
|
ix
<
2
^
(
63
::
Integer
)
=
ix
+
2
^
(
63
::
Integer
)
|
otherwise
=
ix
ix
=
foldl
addByte
0
(
unpack
byteString
)
addByte
::
Word64
->
Word8
->
Word64
addByte
b
v
=
b
*
256
+
fromIntegral
v
return
i
parseFile
isVerbose
searchPath
filename
text
=
do
let
importCallback
name
=
do
let
candidates
=
relativePath
filename
searchPath
name
...
...
@@ -195,7 +215,7 @@ parseFile isVerbose searchPath filename text = do
Nothing
->
return
$
Right
"File not found."
Just
path
->
importFile
isVerbose
searchPath
path
status
<-
parseAndCompileFile
filename
text
importCallback
status
<-
parseAndCompileFile
filename
text
importCallback
generateId
case
status
of
Active
desc
[]
->
do
when
isVerbose
(
liftIO
$
print
desc
)
...
...
compiler/src/Parser.hs
View file @
2c8595bc
...
...
@@ -24,8 +24,10 @@
module
Parser
(
parseFile
)
where
import
Data.Generics
import
Data.Maybe
(
fromMaybe
)
import
Data.Maybe
(
fromMaybe
,
listToMaybe
)
import
Data.Word
(
Word64
)
import
Text.Parsec
hiding
(
tokens
)
import
Text.Parsec.Error
(
newErrorMessage
,
Message
(
Message
))
import
Token
import
Grammar
import
Lexer
(
lexer
)
...
...
@@ -89,6 +91,13 @@ matchLiteralBool t = case locatedValue t of
_
->
Nothing
matchSimpleToken
expected
t
=
if
locatedValue
t
==
expected
then
Just
()
else
Nothing
matchLiteralId
::
Located
Token
->
Maybe
Word64
matchLiteralId
(
Located
_
(
LiteralInt
i
))
|
i
>=
(
2
^
(
63
::
Integer
))
&&
i
<
(
2
^
(
64
::
Integer
))
=
Just
(
fromIntegral
i
)
matchLiteralId
_
=
Nothing
varIdentifier
=
tokenParser
matchIdentifier
<|>
(
tokenParser
matchTypeIdentifier
>>=
fail
"Non-type identifiers must start with lower-case letter."
)
...
...
@@ -104,6 +113,7 @@ anyIdentifier = tokenParser matchIdentifier
literalInt
=
tokenParser
(
matchUnary
LiteralInt
)
<?>
"integer"
literalFloat
=
tokenParser
(
matchUnary
LiteralFloat
)
<?>
"floating-point number"
literalString
=
tokenParser
(
matchUnary
LiteralString
)
<?>
"string"
literalId
=
tokenParser
matchLiteralId
<?>
"id (generate using capnpc -i)"
literalBool
=
tokenParser
matchLiteralBool
<?>
"boolean"
literalVoid
=
tokenParser
(
matchSimpleToken
VoidKeyword
)
<?>
"
\"
void
\"
"
...
...
@@ -166,6 +176,8 @@ nameWithOrdinal = do
ordinal
<-
located
literalInt
return
(
name
,
ordinal
)
declId
=
atSign
>>
literalId
annotation
::
TokenParser
Annotation
annotation
=
do
dollarSign
...
...
@@ -175,10 +187,15 @@ annotation = do
<|>
return
VoidFieldValue
)
return
(
Annotation
name
value
)
topLine
::
Maybe
[
Located
Statement
]
->
TokenParser
(
Either
Declaration
Annotation
)
topLine
Nothing
=
liftM
Left
(
usingDecl
<|>
constantDecl
<|>
annotationDecl
)
<|>
liftM
Right
annotation
topLine
(
Just
statements
)
=
liftM
Left
$
typeDecl
statements
data
TopLevelDecl
=
TopLevelDecl
Declaration
|
TopLevelAnnotation
Annotation
|
TopLevelId
(
Located
Word64
)
topLine
::
Maybe
[
Located
Statement
]
->
TokenParser
TopLevelDecl
topLine
Nothing
=
liftM
TopLevelId
(
located
declId
)
<|>
liftM
TopLevelDecl
(
usingDecl
<|>
constantDecl
<|>
annotationDecl
)
<|>
liftM
TopLevelAnnotation
annotation
topLine
(
Just
statements
)
=
liftM
TopLevelDecl
$
typeDecl
statements
usingDecl
=
do
usingKeyword
...
...
@@ -214,9 +231,10 @@ typeDecl statements = enumDecl statements
enumDecl
statements
=
do
enumKeyword
name
<-
located
typeIdentifier
typeId
<-
optionMaybe
$
located
declId
annotations
<-
many
annotation
children
<-
parseBlock
enumLine
statements
return
(
EnumDecl
name
annotations
children
)
return
(
EnumDecl
name
typeId
annotations
children
)
enumLine
::
Maybe
[
Located
Statement
]
->
TokenParser
Declaration
enumLine
Nothing
=
enumerantDecl
...
...
@@ -230,10 +248,11 @@ enumerantDecl = do
structDecl
statements
=
do
structKeyword
name
<-
located
typeIdentifier
typeId
<-
optionMaybe
$
located
declId
fixed
<-
optionMaybe
fixedSpec
annotations
<-
many
annotation
children
<-
parseBlock
structLine
statements
return
(
StructDecl
name
fixed
annotations
children
)
return
(
StructDecl
name
typeId
fixed
annotations
children
)
fixedSpec
=
do
fixedKeyword
...
...
@@ -312,9 +331,10 @@ fieldAssignment = do
interfaceDecl
statements
=
do
interfaceKeyword
name
<-
located
typeIdentifier
typeId
<-
optionMaybe
$
located
declId
annotations
<-
many
annotation
children
<-
parseBlock
interfaceLine
statements
return
(
InterfaceDecl
name
annotations
children
)
return
(
InterfaceDecl
name
typeId
annotations
children
)
interfaceLine
::
Maybe
[
Located
Statement
]
->
TokenParser
Declaration
interfaceLine
Nothing
=
usingDecl
<|>
constantDecl
<|>
methodDecl
<|>
annotationDecl
...
...
@@ -339,12 +359,13 @@ paramDecl = do
annotationDecl
=
do
annotationKeyword
name
<-
located
varIdentifier
annId
<-
optionMaybe
$
located
declId
targets
<-
try
(
parenthesized
asterisk
>>
return
allAnnotationTargets
)
<|>
parenthesizedList
annotationTarget
colon
t
<-
typeExpression
annotations
<-
many
annotation
return
(
AnnotationDecl
name
t
annotations
targets
)
return
(
AnnotationDecl
name
annId
t
annotations
targets
)
allAnnotationTargets
=
[
minBound
::
AnnotationTarget
..
maxBound
::
AnnotationTarget
]
annotationTarget
=
(
exactIdentifier
"file"
>>
return
FileAnnotation
)
...
...
@@ -404,15 +425,23 @@ parseStatement parser (Located _ (Line tokens)) =
parseStatement
parser
(
Located
_
(
Block
tokens
statements
))
=
parseCollectingErrors
(
parser
(
Just
statements
))
tokens
parseFileTokens
::
[
Located
Statement
]
->
([
Declaration
],
[
Annotation
],
[
ParseError
])
parseFileTokens
statements
=
(
decls
,
annotations
,
errors
)
where
results
::
[
Either
ParseError
(
Either
Declaration
Annotation
,
[
ParseError
])]
parseFileTokens
::
[
Located
Statement
]
->
(
Maybe
(
Located
Word64
),
[
Declaration
],
[
Annotation
],
[
ParseError
])
parseFileTokens
statements
=
(
fileId
,
decls
,
annotations
,
errors
)
where
results
::
[
Either
ParseError
(
TopLevelDecl
,
[
ParseError
])]
results
=
map
(
parseStatement
topLine
)
statements
errors
=
concatMap
extractErrors
results
decls
=
[
decl
|
Right
(
Left
decl
,
_
)
<-
results
]
annotations
=
[
ann
|
Right
(
Right
ann
,
_
)
<-
results
]
parseFile
::
String
->
String
->
([
Declaration
],
[
Annotation
],
[
ParseError
])
errors
=
concatMap
extractErrors
results
++
idErrors
decls
=
[
decl
|
Right
(
TopLevelDecl
decl
,
_
)
<-
results
]
annotations
=
[
ann
|
Right
(
TopLevelAnnotation
ann
,
_
)
<-
results
]
ids
=
[
i
|
Right
(
TopLevelId
i
,
_
)
<-
results
]
fileId
=
listToMaybe
ids
idErrors
|
length
ids
<=
1
=
[]
|
otherwise
=
map
makeDupeIdError
ids
makeDupeIdError
(
Located
pos
_
)
=
newErrorMessage
(
Message
"File declares multiple ids."
)
pos
parseFile
::
String
->
String
->
(
Maybe
(
Located
Word64
),
[
Declaration
],
[
Annotation
],
[
ParseError
])
parseFile
filename
text
=
case
parse
lexer
filename
text
of
Left
e
->
(
[]
,
[]
,
[
e
])
Left
e
->
(
Nothing
,
[]
,
[]
,
[
e
])
Right
statements
->
parseFileTokens
statements
compiler/src/Semantics.hs
View file @
2c8595bc
...
...
@@ -66,7 +66,6 @@ data Desc = DescFile FileDesc
|
DescBuiltinInline
|
DescBuiltinInlineList
|
DescBuiltinInlineData
|
DescBuiltinId
descName
(
DescFile
_
)
=
"(top-level)"
descName
(
DescUsing
d
)
=
usingName
d
...
...
@@ -85,34 +84,13 @@ descName DescBuiltinList = "List"
descName
DescBuiltinInline
=
"Inline"
descName
DescBuiltinInlineList
=
"InlineList"
descName
DescBuiltinInlineData
=
"InlineData"
descName
DescBuiltinId
=
"id"
descId
(
DescFile
d
)
=
fileId
d
descId
(
DescUsing
_
)
=
Nothing
descId
(
DescConstant
d
)
=
constantId
d
descId
(
DescEnum
d
)
=
enumId
d
descId
(
DescEnumerant
d
)
=
enumerantId
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
DescBuiltinInline
=
Nothing
descId
DescBuiltinInlineList
=
Nothing
descId
DescBuiltinInlineData
=
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
descId
_
=
error
"This construct does not have an ID."
descParent
(
DescFile
_
)
=
error
"File descriptor has no parent."
descParent
(
DescUsing
d
)
=
usingParent
d
...
...
@@ -131,7 +109,6 @@ descParent DescBuiltinList = error "Builtin type has no parent."
descParent
DescBuiltinInline
=
error
"Builtin type has no parent."
descParent
DescBuiltinInlineList
=
error
"Builtin type has no parent."
descParent
DescBuiltinInlineData
=
error
"Builtin type has no parent."
descParent
DescBuiltinId
=
error
"Builtin annotation has no parent."
descFile
(
DescFile
d
)
=
d
descFile
desc
=
descFile
$
descParent
desc
...
...
@@ -153,7 +130,6 @@ descAnnotations DescBuiltinList = Map.empty
descAnnotations
DescBuiltinInline
=
Map
.
empty
descAnnotations
DescBuiltinInlineList
=
Map
.
empty
descAnnotations
DescBuiltinInlineData
=
Map
.
empty
descAnnotations
DescBuiltinId
=
Map
.
empty
descRuntimeImports
(
DescFile
_
)
=
error
"Not to be called on files."
descRuntimeImports
(
DescUsing
d
)
=
usingRuntimeImports
d
...
...
@@ -172,7 +148,6 @@ descRuntimeImports DescBuiltinList = []
descRuntimeImports
DescBuiltinInline
=
[]
descRuntimeImports
DescBuiltinInlineList
=
[]
descRuntimeImports
DescBuiltinInlineData
=
[]
descRuntimeImports
DescBuiltinId
=
[]
type
MemberMap
=
Map
.
Map
String
(
Maybe
Desc
)
...
...
@@ -398,7 +373,7 @@ descQualifiedName scope desc = descQualifiedName (descParent scope) desc
data
FileDesc
=
FileDesc
{
fileName
::
String
,
fileId
::
Maybe
String
,
fileId
::
Word64
,
fileImports
::
[
FileDesc
]
-- Set of imports which are used at runtime, i.e. not just for annotations.
-- The set contains file names matching files in fileImports.
...
...
@@ -419,7 +394,6 @@ usingRuntimeImports _ = []
data
ConstantDesc
=
ConstantDesc
{
constantName
::
String
,
constantId
::
Maybe
String
,
constantParent
::
Desc
,
constantType
::
TypeDesc
,
constantAnnotations
::
AnnotationMap
...
...
@@ -430,7 +404,7 @@ constantRuntimeImports desc = typeRuntimeImports $ constantType desc
data
EnumDesc
=
EnumDesc
{
enumName
::
String
,
enumId
::
Maybe
String
,
enumId
::
Word64
,
enumParent
::
Desc
,
enumerants
::
[
EnumerantDesc
]
,
enumAnnotations
::
AnnotationMap
...
...
@@ -442,7 +416,6 @@ enumRuntimeImports desc = concatMap descRuntimeImports $ enumMembers desc
data
EnumerantDesc
=
EnumerantDesc
{
enumerantName
::
String
,
enumerantId
::
Maybe
String
,
enumerantParent
::
EnumDesc
,
enumerantNumber
::
Integer
,
enumerantAnnotations
::
AnnotationMap
...
...
@@ -452,7 +425,7 @@ enumerantRuntimeImports _ = []
data
StructDesc
=
StructDesc
{
structName
::
String
,
structId
::
Maybe
String
,
structId
::
Word64
,
structParent
::
Desc
,
structDataSize
::
DataSectionSize
,
structPointerCount
::
Integer
...
...
@@ -473,7 +446,6 @@ structRuntimeImports desc = concatMap descRuntimeImports $ structMembers desc
data
UnionDesc
=
UnionDesc
{
unionName
::
String
,
unionId
::
Maybe
String
,
unionParent
::
StructDesc
,
unionNumber
::
Integer
,
unionTagOffset
::
Integer
...
...
@@ -490,7 +462,6 @@ unionRuntimeImports desc = concatMap descRuntimeImports $ unionMembers desc
data
FieldDesc
=
FieldDesc
{
fieldName
::
String
,
fieldId
::
Maybe
String
,
fieldParent
::
StructDesc
,
fieldNumber
::
Integer
,
fieldOffset
::
FieldOffset
...
...
@@ -504,7 +475,7 @@ fieldRuntimeImports desc = typeRuntimeImports $ fieldType desc
data
InterfaceDesc
=
InterfaceDesc
{
interfaceName
::
String
,
interfaceId
::
Maybe
String
,
interfaceId
::
Word64
,
interfaceParent
::
Desc
,
interfaceMethods
::
[
MethodDesc
]
,
interfaceAnnotations
::
AnnotationMap
...
...
@@ -516,7 +487,6 @@ interfaceRuntimeImports desc = concatMap descRuntimeImports $ interfaceMembers d
data
MethodDesc
=
MethodDesc
{
methodName
::
String
,
methodId
::
Maybe
String
,
methodParent
::
InterfaceDesc
,
methodNumber
::
Integer
,
methodParams
::
[
ParamDesc
]
...
...
@@ -529,7 +499,6 @@ methodRuntimeImports desc = typeRuntimeImports (methodReturnType desc) ++
data
ParamDesc
=
ParamDesc
{
paramName
::
String
,
paramId
::
Maybe
String
,
paramParent
::
MethodDesc
,
paramNumber
::
Integer
,
paramType
::
TypeDesc
...
...
@@ -544,20 +513,18 @@ data AnnotationDesc = AnnotationDesc
,
annotationParent
::
Desc
,
annotationType
::
TypeDesc
,
annotationAnnotations
::
AnnotationMap
,
annotationId
::
Maybe
String
,
annotationId
::
Word64
,
annotationTargets
::
Set
.
Set
AnnotationTarget
}
annotationRuntimeImports
desc
=
typeRuntimeImports
$
annotationType
desc
type
AnnotationMap
=
Map
.
Map
String
(
AnnotationDesc
,
ValueDesc
)
type
AnnotationMap
=
Map
.
Map
Word64
(
AnnotationDesc
,
ValueDesc
)
descToCode
::
String
->
Desc
->
String
descToCode
indent
self
@
(
DescFile
desc
)
=
printf
"# %s
\n
%s
%s%s"
descToCode
indent
self
@
(
DescFile
desc
)
=
printf
"# %s
\n
@0x%016x;
\n
%s%s"
(
fileName
desc
)
(
case
fileId
desc
of
Just
i
->
printf
"$id(%s);
\n
"
$
show
i
Nothing
->
""
)
(
fileId
desc
)
(
concatMap
((
++
";
\n
"
)
.
annotationCode
self
)
$
Map
.
toList
$
fileAnnotations
desc
)
(
concatMap
(
descToCode
indent
)
(
fileMembers
desc
))
descToCode
indent
(
DescUsing
desc
)
=
printf
"%susing %s = %s;
\n
"
indent
...
...
@@ -568,16 +535,18 @@ descToCode indent self@(DescConstant desc) = printf "%sconst %s: %s = %s%s;\n" i
(
typeName
(
descParent
self
)
(
constantType
desc
))
(
valueString
(
constantValue
desc
))
(
annotationsCode
self
)
descToCode
indent
self
@
(
DescEnum
desc
)
=
printf
"%senum %s%s {
\n
%s%s}
\n
"
indent
descToCode
indent
self
@
(
DescEnum
desc
)
=
printf
"%senum %s
@0x%016x
%s {
\n
%s%s}
\n
"
indent
(
enumName
desc
)
(
enumId
desc
)
(
annotationsCode
self
)
(
blockCode
indent
(
enumMembers
desc
))
indent
descToCode
indent
self
@
(
DescEnumerant
desc
)
=
printf
"%s%s @%d%s;
\n
"
indent
(
enumerantName
desc
)
(
enumerantNumber
desc
)
(
annotationsCode
self
)
descToCode
indent
self
@
(
DescStruct
desc
)
=
printf
"%sstruct %s%s%s {
\n
%s%s}
\n
"
indent
descToCode
indent
self
@
(
DescStruct
desc
)
=
printf
"%sstruct %s
@0x%016x
%s%s {
\n
%s%s}
\n
"
indent
(
structName
desc
)
(
structId
desc
)
(
if
structIsFixedWidth
desc
then
printf
" fixed(%s, %d pointers) "
(
dataSectionSizeString
$
structDataSize
desc
)
...
...
@@ -609,8 +578,9 @@ descToCode indent self@(DescUnion desc) = printf "%sunion %s@%d%s { # [%d, %d)\
(
unionTagOffset
desc
*
16
)
(
unionTagOffset
desc
*
16
+
16
)
(
blockCode
indent
$
unionMembers
desc
)
indent
descToCode
indent
self
@
(
DescInterface
desc
)
=
printf
"%sinterface %s%s {
\n
%s%s}
\n
"
indent
descToCode
indent
self
@
(
DescInterface
desc
)
=
printf
"%sinterface %s
@0x%016x
%s {
\n
%s%s}
\n
"
indent
(
interfaceName
desc
)
(
interfaceId
desc
)
(
annotationsCode
self
)
(
blockCode
indent
(
interfaceMembers
desc
))
indent
...
...
@@ -626,8 +596,9 @@ descToCode _ self@(DescParam desc) = printf "%s: %s%s%s"
Just
v
->
printf
" = %s"
$
valueString
v
Nothing
->
""
)
(
annotationsCode
self
)
descToCode
indent
self
@
(
DescAnnotation
desc
)
=
printf
"%sannotation %s: %s on(%s)%s;
\n
"
indent
descToCode
indent
self
@
(
DescAnnotation
desc
)
=
printf
"%sannotation %s
@0x%016x
: %s on(%s)%s;
\n
"
indent
(
annotationName
desc
)
(
annotationId
desc
)
(
typeName
(
descParent
self
)
(
annotationType
desc
))
(
delimit
", "
$
map
show
$
Set
.
toList
$
annotationTargets
desc
)
(
annotationsCode
self
)
...
...
@@ -636,7 +607,6 @@ descToCode _ DescBuiltinList = error "Can't print code for builtin type."
descToCode
_
DescBuiltinInline
=
error
"Can't print code for builtin type."
descToCode
_
DescBuiltinInlineList
=
error
"Can't print code for builtin type."
descToCode
_
DescBuiltinInlineData
=
error
"Can't print code for builtin type."
descToCode
_
DescBuiltinId
=
error
"Can't print code for builtin annotation."
maybeBlockCode
::
String
->
[
Desc
]
->
String
maybeBlockCode
_
[]
=
";
\n
"
...
...
@@ -645,18 +615,14 @@ maybeBlockCode indent statements = printf " {\n%s%s}\n" (blockCode indent statem
blockCode
::
String
->
[
Desc
]
->
String
blockCode
indent
=
concatMap
(
descToCode
(
" "
++
indent
))
annotationCode
::
Desc
->
(
String
,
(
AnnotationDesc
,
ValueDesc
))
->
String
annotationCode
::
Desc
->
(
Word64
,
(
AnnotationDesc
,
ValueDesc
))
->
String
annotationCode
scope
(
_
,
(
desc
,
VoidDesc
))
=
printf
"$%s"
(
descQualifiedName
scope
(
DescAnnotation
desc
))
annotationCode
scope
(
_
,
(
desc
,
val
))
=
printf
"$%s(%s)"
(
descQualifiedName
scope
(
DescAnnotation
desc
))
(
valueString
val
)
annotationsCode
desc
=
let
nonIds
=
concatMap
((
' '
:
)
.
annotationCode
(
descParent
desc
))
$
Map
.
toList
annotationsCode
desc
=
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
UsingDesc
where
{
show
desc
=
descToCode
""
(
DescUsing
desc
)
}
...
...
compiler/src/Util.hs
View file @
2c8595bc
...
...
@@ -25,6 +25,8 @@ module Util where
import
Data.Char
(
isUpper
,
toUpper
)
import
Data.List
(
intercalate
,
isPrefixOf
)
import
Data.Bits
(
shiftR
,
Bits
)
import
Data.Word
(
Word8
)
--delimit _ [] = ""
--delimit delimiter (h:t) = h ++ concatMap (delimiter ++) t
...
...
@@ -50,3 +52,8 @@ toTitleCase [] = []
toUpperCaseWithUnderscores
::
String
->
String
toUpperCaseWithUnderscores
name
=
delimit
"_"
$
map
(
map
toUpper
)
$
splitName
name
intToBytes
::
(
Integral
a
,
Bits
a
)
=>
a
->
Int
->
[
Word8
]
intToBytes
i
count
=
map
(
byte
i
)
[
0
..
(
count
-
1
)]
where
byte
::
(
Integral
a
,
Bits
a
)
=>
a
->
Int
->
Word8
byte
i2
amount
=
fromIntegral
(
shiftR
i2
(
amount
*
8
))
compiler/src/WireFormat.hs
View file @
2c8595bc
...
...
@@ -25,18 +25,13 @@ module WireFormat(encodeMessage) where
import
Data.List
(
sortBy
,
genericLength
,
genericReplicate
)
import
Data.Word
import
Data.Bits
(
shiftL
,
shiftR
,
Bits
,
setBit
,
xor
)
import
Data.Bits
(
shiftL
,
Bits
,
setBit
,
xor
)
import
Data.Function
(
on
)
import
Semantics
import
Data.Binary.IEEE754
(
floatToWord
,
doubleToWord
)
import
Text.Printf
(
printf
)
import
qualified
Codec.Binary.UTF8.String
as
UTF8
byte
::
(
Integral
a
,
Bits
a
)
=>
a
->
Int
->
Word8
byte
i
amount
=
fromIntegral
(
shiftR
i
(
amount
*
8
))
bytes
::
(
Integral
a
,
Bits
a
)
=>
a
->
Int
->
[
Word8
]
bytes
i
count
=
map
(
byte
i
)
[
0
..
(
count
-
1
)]
import
Util
(
intToBytes
)
padToWord
b
=
let
trailing
=
mod
(
length
b
)
8
...
...
@@ -55,19 +50,19 @@ xorData _ _ = error "Value type mismatch when xor'ing."
encodeDataValue
::
TypeDesc
->
ValueDesc
->
EncodedData
encodeDataValue
_
VoidDesc
=
EncodedBytes
[]
encodeDataValue
_
(
BoolDesc
v
)
=
EncodedBit
v
encodeDataValue
_
(
Int8Desc
v
)
=
EncodedBytes
$
b
ytes
v
1
encodeDataValue
_
(
Int16Desc
v
)
=
EncodedBytes
$
b
ytes
v
2
encodeDataValue
_
(
Int32Desc
v
)
=
EncodedBytes
$
b
ytes
v
4
encodeDataValue
_
(
Int64Desc
v
)
=
EncodedBytes
$
b
ytes
v
8
encodeDataValue
_
(
UInt8Desc
v
)
=
EncodedBytes
$
b
ytes
v
1
encodeDataValue
_
(
UInt16Desc
v
)
=
EncodedBytes
$
b
ytes
v
2
encodeDataValue
_
(
UInt32Desc
v
)
=
EncodedBytes
$
b
ytes
v
4
encodeDataValue
_
(
UInt64Desc
v
)
=
EncodedBytes
$
b
ytes
v
8
encodeDataValue
_
(
Float32Desc
v
)
=
EncodedBytes
$
b
ytes
(
floatToWord
v
)
4
encodeDataValue
_
(
Float64Desc
v
)
=
EncodedBytes
$
b
ytes
(
doubleToWord
v
)
8
encodeDataValue
_
(
Int8Desc
v
)
=
EncodedBytes
$
intToB
ytes
v
1
encodeDataValue
_
(
Int16Desc
v
)
=
EncodedBytes
$
intToB
ytes
v
2
encodeDataValue
_
(
Int32Desc
v
)
=
EncodedBytes
$
intToB
ytes
v
4
encodeDataValue
_
(
Int64Desc
v
)
=
EncodedBytes
$
intToB
ytes
v
8
encodeDataValue
_
(
UInt8Desc
v
)
=
EncodedBytes
$
intToB
ytes
v
1
encodeDataValue
_
(
UInt16Desc
v
)
=
EncodedBytes
$
intToB
ytes
v
2
encodeDataValue
_
(
UInt32Desc
v
)
=
EncodedBytes
$
intToB
ytes
v
4
encodeDataValue
_
(
UInt64Desc
v
)
=
EncodedBytes
$
intToB
ytes
v
8
encodeDataValue
_
(
Float32Desc
v
)
=
EncodedBytes
$
intToB
ytes
(
floatToWord
v
)
4
encodeDataValue
_
(
Float64Desc
v
)
=
EncodedBytes
$
intToB
ytes
(
doubleToWord
v
)
8
encodeDataValue
_
(
TextDesc
_
)
=
error
"Not fixed-width data."
encodeDataValue
_
(
DataDesc
_
)
=
error
"Not fixed-width data."
encodeDataValue
_
(
EnumerantValueDesc
v
)
=
EncodedBytes
$
b
ytes
(
enumerantNumber
v
)
2
encodeDataValue
_
(
EnumerantValueDesc
v
)
=
EncodedBytes
$
intToB
ytes
(
enumerantNumber
v
)
2
encodeDataValue
_
(
StructValueDesc
_
)
=
error
"Not fixed-width data."
encodeDataValue
_
(
ListDesc
_
)
=
error
"Not fixed-width data."
...
...
@@ -132,23 +127,23 @@ packPointers size items o = loop 0 items (o + size - 1) where
loop
idx
[]
_
=
(
genericReplicate
((
size
-
idx
)
*
8
)
0
,
[]
)
encodeStructReference
desc
offset
=
b
ytes
(
offset
*
4
+
structTag
)
4
++
b
ytes
(
dataSectionWordSize
$
structDataSize
desc
)
2
++
b
ytes
(
structPointerCount
desc
)
2
intToB
ytes
(
offset
*
4
+
structTag
)
4
++
intToB
ytes
(
dataSectionWordSize
$
structDataSize
desc
)
2
++
intToB
ytes
(
structPointerCount
desc
)
2
encodeInlineStructListReference
elementDataSize
elementPointerCount
elementCount
offset
=
let
dataBits
=
dataSectionBits
elementDataSize
*
elementCount
dataWords
=
div
(
dataBits
+
63
)
64
in
b
ytes
(
offset
*
4
+
structTag
)
4
++
b
ytes
dataWords
2
++
b
ytes
(
elementPointerCount
*
elementCount
)
2
in
intToB
ytes
(
offset
*
4
+
structTag
)
4
++
intToB
ytes
dataWords
2
++
intToB
ytes
(
elementPointerCount
*
elementCount
)
2
encodeListReference
elemSize
@
(
SizeInlineComposite
ds
rc
)
elementCount
offset
=
b
ytes
(
offset
*
4
+
listTag
)
4
++
b
ytes
(
fieldSizeEnum
elemSize
+
shiftL
(
elementCount
*
(
dataSectionWordSize
ds
+
rc
))
3
)
4
intToB
ytes
(
offset
*
4
+
listTag
)
4
++
intToB
ytes
(
fieldSizeEnum
elemSize
+
shiftL
(
elementCount
*
(
dataSectionWordSize
ds
+
rc
))
3
)
4
encodeListReference
elemSize
elementCount
offset
=
b
ytes
(
offset
*
4
+
listTag
)
4
++
b
ytes
(
fieldSizeEnum
elemSize
+
shiftL
elementCount
3
)
4
intToB
ytes
(
offset
*
4
+
listTag
)
4
++
intToB
ytes
(
fieldSizeEnum
elemSize
+
shiftL
elementCount
3
)
4
fieldSizeEnum
SizeVoid
=
0
fieldSizeEnum
(
SizeData
Size1
)
=
1
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment