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
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
12 changed files
with
135 additions
and
76 deletions
+135
-76
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
+0
-0
CxxGenerator.hs
compiler/src/CxxGenerator.hs
+3
-3
Grammar.hs
compiler/src/Grammar.hs
+24
-21
Main.hs
compiler/src/Main.hs
+23
-3
Parser.hs
compiler/src/Parser.hs
+48
-19
Semantics.hs
compiler/src/Semantics.hs
+0
-0
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 @@
...
@@ -21,7 +21,7 @@
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
$id("v3JF2GP4Supe9JSSJ3pnSdUqhJI")
;
@0xbdf87d7bb8304e81
;
$namespace("capnproto::annotations");
$namespace("capnproto::annotations");
annotation namespace(file): Text;
annotation namespace(file): Text;
c++/src/capnproto/test-import.capnp
View file @
2c8595bc
...
@@ -21,6 +21,8 @@
...
@@ -21,6 +21,8 @@
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
@0xf36d7b330303c66e;
using Test = import "test.capnp";
using Test = import "test.capnp";
struct TestImport {
struct TestImport {
...
...
c++/src/capnproto/test.capnp
View file @
2c8595bc
...
@@ -21,6 +21,8 @@
...
@@ -21,6 +21,8 @@
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
@0xd508eebdc2dc42b8;
using Cxx = import "c++.capnp";
using Cxx = import "c++.capnp";
# Use a namespace likely to cause trouble if the generated code doesn't use fully-qualified
# 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
...
@@ -29,7 +29,8 @@ executable capnpc
filepath,
filepath,
directory,
directory,
syb,
syb,
transformers
transformers,
entropy
ghc-options: -Wall -fno-warn-missing-signatures
ghc-options: -Wall -fno-warn-missing-signatures
other-modules:
other-modules:
Lexer,
Lexer,
...
...
compiler/src/Compiler.hs
View file @
2c8595bc
This diff is collapsed.
Click to expand it.
compiler/src/CxxGenerator.hs
View file @
2c8595bc
...
@@ -31,7 +31,7 @@ import Data.Word(Word8)
...
@@ -31,7 +31,7 @@ import Data.Word(Word8)
import
qualified
Data.Digest.MD5
as
MD5
import
qualified
Data.Digest.MD5
as
MD5
import
qualified
Data.Map
as
Map
import
qualified
Data.Map
as
Map
import
qualified
Data.Set
as
Set
import
qualified
Data.Set
as
Set
import
Data.Maybe
(
catMaybes
,
fromMaybe
)
import
Data.Maybe
(
catMaybes
)
import
Data.Binary.IEEE754
(
floatToWord
,
doubleToWord
)
import
Data.Binary.IEEE754
(
floatToWord
,
doubleToWord
)
import
Text.Printf
(
printf
)
import
Text.Printf
(
printf
)
import
Text.Hastache
import
Text.Hastache
...
@@ -51,7 +51,7 @@ muNull = MuBool False;
...
@@ -51,7 +51,7 @@ muNull = MuBool False;
-- Using a single-element list has the same effect, though.
-- Using a single-element list has the same effect, though.
muJust
c
=
MuList
[
c
]
muJust
c
=
MuList
[
c
]
namespaceAnnotationId
=
"v3JF2GP4Supe9JSSJ3pnSdUqhJI.namespace"
namespaceAnnotationId
=
0xb9c6f99ebf805f2c
fileNamespace
desc
=
fmap
testAnnotation
$
Map
.
lookup
namespaceAnnotationId
$
fileAnnotations
desc
fileNamespace
desc
=
fmap
testAnnotation
$
Map
.
lookup
namespaceAnnotationId
$
fileAnnotations
desc
...
@@ -422,7 +422,7 @@ fileContext desc = mkStrContext context where
...
@@ -422,7 +422,7 @@ fileContext desc = mkStrContext context where
context
"fileName"
=
MuVariable
$
fileName
desc
context
"fileName"
=
MuVariable
$
fileName
desc
context
"fileBasename"
=
MuVariable
$
takeBaseName
$
fileName
desc
context
"fileBasename"
=
MuVariable
$
takeBaseName
$
fileName
desc
context
"fileIncludeGuard"
=
MuVariable
$
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
"fileNamespaces"
=
MuList
$
map
(
namespaceContext
context
)
namespace
context
"fileEnums"
=
MuList
$
map
(
enumContext
context
)
[
e
|
DescEnum
e
<-
fileMembers
desc
]
context
"fileEnums"
=
MuList
$
map
(
enumContext
context
)
[
e
|
DescEnum
e
<-
fileMembers
desc
]
context
"fileTypes"
=
MuList
$
map
(
typeContext
context
)
flattenedMembers
context
"fileTypes"
=
MuList
$
map
(
typeContext
context
)
flattenedMembers
...
...
compiler/src/Grammar.hs
View file @
2c8595bc
...
@@ -25,6 +25,7 @@ module Grammar where
...
@@ -25,6 +25,7 @@ module Grammar where
import
Token
(
Located
)
import
Token
(
Located
)
import
Data.Maybe
(
maybeToList
)
import
Data.Maybe
(
maybeToList
)
import
Data.Word
(
Word64
)
data
DeclName
=
AbsoluteName
(
Located
String
)
data
DeclName
=
AbsoluteName
(
Located
String
)
|
RelativeName
(
Located
String
)
|
RelativeName
(
Located
String
)
...
@@ -100,43 +101,45 @@ instance Show AnnotationTarget where
...
@@ -100,43 +101,45 @@ instance Show AnnotationTarget where
data
Declaration
=
UsingDecl
(
Located
String
)
DeclName
data
Declaration
=
UsingDecl
(
Located
String
)
DeclName
|
ConstantDecl
(
Located
String
)
TypeExpression
[
Annotation
]
(
Located
FieldValue
)
|
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
]
|
EnumerantDecl
(
Located
String
)
(
Located
Integer
)
[
Annotation
]
|
StructDecl
(
Located
String
)
(
Maybe
(
Located
(
Integer
,
Integer
)
))
|
StructDecl
(
Located
String
)
(
Maybe
(
Located
Word64
))
[
Annotation
]
[
Declaration
]
(
Maybe
(
Located
(
Integer
,
Integer
)))
[
Annotation
]
[
Declaration
]
|
FieldDecl
(
Located
String
)
(
Located
Integer
)
|
FieldDecl
(
Located
String
)
(
Located
Integer
)
TypeExpression
[
Annotation
]
(
Maybe
(
Located
FieldValue
))
TypeExpression
[
Annotation
]
(
Maybe
(
Located
FieldValue
))
|
UnionDecl
(
Located
String
)
(
Located
Integer
)
[
Annotation
]
[
Declaration
]
|
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
]
|
MethodDecl
(
Located
String
)
(
Located
Integer
)
[
ParamDecl
]
TypeExpression
[
Annotation
]
TypeExpression
[
Annotation
]
|
AnnotationDecl
(
Located
String
)
TypeExpression
[
Annotation
]
[
AnnotationTarget
]
|
AnnotationDecl
(
Located
String
)
(
Maybe
(
Located
Word64
))
TypeExpression
[
Annotation
]
[
AnnotationTarget
]
deriving
(
Show
)
deriving
(
Show
)
declarationName
::
Declaration
->
Maybe
(
Located
String
)
declarationName
::
Declaration
->
Maybe
(
Located
String
)
declarationName
(
UsingDecl
n
_
)
=
Just
n
declarationName
(
UsingDecl
n
_
)
=
Just
n
declarationName
(
ConstantDecl
n
_
_
_
)
=
Just
n
declarationName
(
ConstantDecl
n
_
_
_
)
=
Just
n
declarationName
(
EnumDecl
n
_
_
)
=
Just
n
declarationName
(
EnumDecl
n
_
_
_
)
=
Just
n
declarationName
(
EnumerantDecl
n
_
_
)
=
Just
n
declarationName
(
EnumerantDecl
n
_
_
)
=
Just
n
declarationName
(
StructDecl
n
_
_
_
)
=
Just
n
declarationName
(
StructDecl
n
_
_
_
_
)
=
Just
n
declarationName
(
FieldDecl
n
_
_
_
_
)
=
Just
n
declarationName
(
FieldDecl
n
_
_
_
_
)
=
Just
n
declarationName
(
UnionDecl
n
_
_
_
)
=
Just
n
declarationName
(
UnionDecl
n
_
_
_
)
=
Just
n
declarationName
(
InterfaceDecl
n
_
_
)
=
Just
n
declarationName
(
InterfaceDecl
n
_
_
_
)
=
Just
n
declarationName
(
MethodDecl
n
_
_
_
_
)
=
Just
n
declarationName
(
MethodDecl
n
_
_
_
_
)
=
Just
n
declarationName
(
AnnotationDecl
n
_
_
_
)
=
Just
n
declarationName
(
AnnotationDecl
n
_
_
_
_
)
=
Just
n
declImports
::
Declaration
->
[
Located
String
]
declImports
::
Declaration
->
[
Located
String
]
declImports
(
UsingDecl
_
name
)
=
maybeToList
(
declNameImport
name
)
declImports
(
UsingDecl
_
name
)
=
maybeToList
(
declNameImport
name
)
declImports
(
ConstantDecl
_
t
ann
_
)
=
typeImports
t
++
concatMap
annotationImports
ann
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
(
EnumerantDecl
_
_
ann
)
=
concatMap
annotationImports
ann
declImports
(
StructDecl
_
_
ann
decls
)
=
concatMap
annotationImports
ann
++
declImports
(
StructDecl
_
_
_
ann
decls
)
=
concatMap
annotationImports
ann
++
concatMap
declImports
decls
concatMap
declImports
decls
declImports
(
FieldDecl
_
_
t
ann
_
)
=
typeImports
t
++
concatMap
annotationImports
ann
declImports
(
FieldDecl
_
_
t
ann
_
)
=
typeImports
t
++
concatMap
annotationImports
ann
declImports
(
UnionDecl
_
_
ann
decls
)
=
concatMap
annotationImports
ann
++
declImports
(
UnionDecl
_
_
ann
decls
)
=
concatMap
annotationImports
ann
++
concatMap
declImports
decls
concatMap
declImports
decls
declImports
(
InterfaceDecl
_
ann
decls
)
=
concatMap
annotationImports
ann
++
declImports
(
InterfaceDecl
_
_
ann
decls
)
=
concatMap
annotationImports
ann
++
concatMap
declImports
decls
concatMap
declImports
decls
declImports
(
MethodDecl
_
_
params
t
ann
)
=
declImports
(
MethodDecl
_
_
params
t
ann
)
=
concat
[
concatMap
paramImports
params
,
typeImports
t
,
concatMap
annotationImports
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)
...
@@ -29,8 +29,9 @@ import System.Exit(exitFailure, exitSuccess)
import
System.IO
(
hPutStr
,
stderr
)
import
System.IO
(
hPutStr
,
stderr
)
import
System.FilePath
(
takeDirectory
)
import
System.FilePath
(
takeDirectory
)
import
System.Directory
(
createDirectoryIfMissing
,
doesDirectoryExist
,
doesFileExist
)
import
System.Directory
(
createDirectoryIfMissing
,
doesDirectoryExist
,
doesFileExist
)
import
System.Entropy
(
getEntropy
)
import
Control.Monad
import
Control.Monad
import
Control.Monad.IO.Class
(
liftIO
)
import
Control.Monad.IO.Class
(
MonadIO
,
liftIO
)
import
Control.Exception
(
IOException
,
catch
)
import
Control.Exception
(
IOException
,
catch
)
import
Control.Monad.Trans.State
(
StateT
,
state
,
modify
,
execStateT
)
import
Control.Monad.Trans.State
(
StateT
,
state
,
modify
,
execStateT
)
import
Prelude
hiding
(
catch
)
import
Prelude
hiding
(
catch
)
...
@@ -42,6 +43,8 @@ import Text.Printf(printf)
...
@@ -42,6 +43,8 @@ import Text.Printf(printf)
import
qualified
Data.List
as
List
import
qualified
Data.List
as
List
import
qualified
Data.Map
as
Map
import
qualified
Data.Map
as
Map
import
qualified
Data.ByteString.Lazy.Char8
as
LZ
import
qualified
Data.ByteString.Lazy.Char8
as
LZ
import
Data.ByteString
(
unpack
)
import
Data.Word
(
Word64
,
Word8
)
import
Semantics
import
Semantics
import
CxxGenerator
(
generateCxx
)
import
CxxGenerator
(
generateCxx
)
...
@@ -54,6 +57,7 @@ data Opt = SearchPathOpt FilePath
...
@@ -54,6 +57,7 @@ data Opt = SearchPathOpt FilePath
|
OutputOpt
String
(
Maybe
GeneratorFn
)
FilePath
|
OutputOpt
String
(
Maybe
GeneratorFn
)
FilePath
|
VerboseOpt
|
VerboseOpt
|
HelpOpt
|
HelpOpt
|
GenIdOpt
main
::
IO
()
main
::
IO
()
main
=
do
main
=
do
...
@@ -66,6 +70,7 @@ main = do
...
@@ -66,6 +70,7 @@ main = do
\
directory). LANG may be any of:
\n\
\
directory). LANG may be any of:
\n\
\
"
++
unwords
(
Map
.
keys
generatorFns
))
\
"
++
unwords
(
Map
.
keys
generatorFns
))
,
Option
"v"
[
"verbose"
]
(
NoArg
VerboseOpt
)
"Write information about parsed files."
,
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."
,
Option
"h"
[
"help"
]
(
NoArg
HelpOpt
)
"Print usage info and exit."
]
]
let
usage
=
usageInfo
let
usage
=
usageInfo
...
@@ -88,11 +93,16 @@ main = do
...
@@ -88,11 +93,16 @@ main = do
exitFailure
)
exitFailure
)
let
isHelp
=
not
$
null
[
opt
|
opt
@
HelpOpt
<-
options
]
let
isHelp
=
not
$
null
[
opt
|
opt
@
HelpOpt
<-
options
]
when
isHelp
(
do
when
isHelp
(
do
putStr
usage
putStr
usage
exitSuccess
)
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
isVerbose
=
not
$
null
[
opt
|
opt
@
VerboseOpt
<-
options
]
let
outputs
=
[(
fn
,
dir
)
|
OutputOpt
_
(
Just
fn
)
dir
<-
options
]
let
outputs
=
[(
fn
,
dir
)
|
OutputOpt
_
(
Just
fn
)
dir
<-
options
]
let
searchPath
=
[
dir
|
SearchPathOpt
dir
<-
options
]
let
searchPath
=
[
dir
|
SearchPathOpt
dir
<-
options
]
...
@@ -187,6 +197,16 @@ readAndParseFile isVerbose searchPath filename = do
...
@@ -187,6 +197,16 @@ readAndParseFile isVerbose searchPath filename = do
Right
err
->
return
$
Right
err
Right
err
->
return
$
Right
err
Left
text
->
parseFile
isVerbose
searchPath
filename
text
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
parseFile
isVerbose
searchPath
filename
text
=
do
let
importCallback
name
=
do
let
importCallback
name
=
do
let
candidates
=
relativePath
filename
searchPath
name
let
candidates
=
relativePath
filename
searchPath
name
...
@@ -195,7 +215,7 @@ parseFile isVerbose searchPath filename text = do
...
@@ -195,7 +215,7 @@ parseFile isVerbose searchPath filename text = do
Nothing
->
return
$
Right
"File not found."
Nothing
->
return
$
Right
"File not found."
Just
path
->
importFile
isVerbose
searchPath
path
Just
path
->
importFile
isVerbose
searchPath
path
status
<-
parseAndCompileFile
filename
text
importCallback
status
<-
parseAndCompileFile
filename
text
importCallback
generateId
case
status
of
case
status
of
Active
desc
[]
->
do
Active
desc
[]
->
do
when
isVerbose
(
liftIO
$
print
desc
)
when
isVerbose
(
liftIO
$
print
desc
)
...
...
compiler/src/Parser.hs
View file @
2c8595bc
...
@@ -24,8 +24,10 @@
...
@@ -24,8 +24,10 @@
module
Parser
(
parseFile
)
where
module
Parser
(
parseFile
)
where
import
Data.Generics
import
Data.Generics
import
Data.Maybe
(
fromMaybe
)
import
Data.Maybe
(
fromMaybe
,
listToMaybe
)
import
Data.Word
(
Word64
)
import
Text.Parsec
hiding
(
tokens
)
import
Text.Parsec
hiding
(
tokens
)
import
Text.Parsec.Error
(
newErrorMessage
,
Message
(
Message
))
import
Token
import
Token
import
Grammar
import
Grammar
import
Lexer
(
lexer
)
import
Lexer
(
lexer
)
...
@@ -40,7 +42,7 @@ tokenErrorString (ParenthesizedList _) = "parenthesized list"
...
@@ -40,7 +42,7 @@ tokenErrorString (ParenthesizedList _) = "parenthesized list"
tokenErrorString
(
BracketedList
_
)
=
"bracketed list"
tokenErrorString
(
BracketedList
_
)
=
"bracketed list"
tokenErrorString
(
LiteralInt
i
)
=
"integer literal "
++
show
i
tokenErrorString
(
LiteralInt
i
)
=
"integer literal "
++
show
i
tokenErrorString
(
LiteralFloat
f
)
=
"float literal "
++
show
f
tokenErrorString
(
LiteralFloat
f
)
=
"float literal "
++
show
f
tokenErrorString
(
LiteralString
s
)
=
"string literal "
++
show
s
tokenErrorString
(
LiteralString
s
)
=
"string literal "
++
show
s
tokenErrorString
AtSign
=
"
\"
@
\"
"
tokenErrorString
AtSign
=
"
\"
@
\"
"
tokenErrorString
Colon
=
"
\"
:
\"
"
tokenErrorString
Colon
=
"
\"
:
\"
"
tokenErrorString
DollarSign
=
"
\"
$
\"
"
tokenErrorString
DollarSign
=
"
\"
$
\"
"
...
@@ -89,6 +91,13 @@ matchLiteralBool t = case locatedValue t of
...
@@ -89,6 +91,13 @@ matchLiteralBool t = case locatedValue t of
_
->
Nothing
_
->
Nothing
matchSimpleToken
expected
t
=
if
locatedValue
t
==
expected
then
Just
()
else
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
varIdentifier
=
tokenParser
matchIdentifier
<|>
(
tokenParser
matchTypeIdentifier
>>=
<|>
(
tokenParser
matchTypeIdentifier
>>=
fail
"Non-type identifiers must start with lower-case letter."
)
fail
"Non-type identifiers must start with lower-case letter."
)
...
@@ -104,6 +113,7 @@ anyIdentifier = tokenParser matchIdentifier
...
@@ -104,6 +113,7 @@ anyIdentifier = tokenParser matchIdentifier
literalInt
=
tokenParser
(
matchUnary
LiteralInt
)
<?>
"integer"
literalInt
=
tokenParser
(
matchUnary
LiteralInt
)
<?>
"integer"
literalFloat
=
tokenParser
(
matchUnary
LiteralFloat
)
<?>
"floating-point number"
literalFloat
=
tokenParser
(
matchUnary
LiteralFloat
)
<?>
"floating-point number"
literalString
=
tokenParser
(
matchUnary
LiteralString
)
<?>
"string"
literalString
=
tokenParser
(
matchUnary
LiteralString
)
<?>
"string"
literalId
=
tokenParser
matchLiteralId
<?>
"id (generate using capnpc -i)"
literalBool
=
tokenParser
matchLiteralBool
<?>
"boolean"
literalBool
=
tokenParser
matchLiteralBool
<?>
"boolean"
literalVoid
=
tokenParser
(
matchSimpleToken
VoidKeyword
)
<?>
"
\"
void
\"
"
literalVoid
=
tokenParser
(
matchSimpleToken
VoidKeyword
)
<?>
"
\"
void
\"
"
...
@@ -166,6 +176,8 @@ nameWithOrdinal = do
...
@@ -166,6 +176,8 @@ nameWithOrdinal = do
ordinal
<-
located
literalInt
ordinal
<-
located
literalInt
return
(
name
,
ordinal
)
return
(
name
,
ordinal
)
declId
=
atSign
>>
literalId
annotation
::
TokenParser
Annotation
annotation
::
TokenParser
Annotation
annotation
=
do
annotation
=
do
dollarSign
dollarSign
...
@@ -175,10 +187,15 @@ annotation = do
...
@@ -175,10 +187,15 @@ annotation = do
<|>
return
VoidFieldValue
)
<|>
return
VoidFieldValue
)
return
(
Annotation
name
value
)
return
(
Annotation
name
value
)
topLine
::
Maybe
[
Located
Statement
]
->
TokenParser
(
Either
Declaration
Annotation
)
data
TopLevelDecl
=
TopLevelDecl
Declaration
topLine
Nothing
=
liftM
Left
(
usingDecl
<|>
constantDecl
<|>
annotationDecl
)
|
TopLevelAnnotation
Annotation
<|>
liftM
Right
annotation
|
TopLevelId
(
Located
Word64
)
topLine
(
Just
statements
)
=
liftM
Left
$
typeDecl
statements
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
usingDecl
=
do
usingKeyword
usingKeyword
...
@@ -214,9 +231,10 @@ typeDecl statements = enumDecl statements
...
@@ -214,9 +231,10 @@ typeDecl statements = enumDecl statements
enumDecl
statements
=
do
enumDecl
statements
=
do
enumKeyword
enumKeyword
name
<-
located
typeIdentifier
name
<-
located
typeIdentifier
typeId
<-
optionMaybe
$
located
declId
annotations
<-
many
annotation
annotations
<-
many
annotation
children
<-
parseBlock
enumLine
statements
children
<-
parseBlock
enumLine
statements
return
(
EnumDecl
name
annotations
children
)
return
(
EnumDecl
name
typeId
annotations
children
)
enumLine
::
Maybe
[
Located
Statement
]
->
TokenParser
Declaration
enumLine
::
Maybe
[
Located
Statement
]
->
TokenParser
Declaration
enumLine
Nothing
=
enumerantDecl
enumLine
Nothing
=
enumerantDecl
...
@@ -230,10 +248,11 @@ enumerantDecl = do
...
@@ -230,10 +248,11 @@ enumerantDecl = do
structDecl
statements
=
do
structDecl
statements
=
do
structKeyword
structKeyword
name
<-
located
typeIdentifier
name
<-
located
typeIdentifier
typeId
<-
optionMaybe
$
located
declId
fixed
<-
optionMaybe
fixedSpec
fixed
<-
optionMaybe
fixedSpec
annotations
<-
many
annotation
annotations
<-
many
annotation
children
<-
parseBlock
structLine
statements
children
<-
parseBlock
structLine
statements
return
(
StructDecl
name
fixed
annotations
children
)
return
(
StructDecl
name
typeId
fixed
annotations
children
)
fixedSpec
=
do
fixedSpec
=
do
fixedKeyword
fixedKeyword
...
@@ -312,9 +331,10 @@ fieldAssignment = do
...
@@ -312,9 +331,10 @@ fieldAssignment = do
interfaceDecl
statements
=
do
interfaceDecl
statements
=
do
interfaceKeyword
interfaceKeyword
name
<-
located
typeIdentifier
name
<-
located
typeIdentifier
typeId
<-
optionMaybe
$
located
declId
annotations
<-
many
annotation
annotations
<-
many
annotation
children
<-
parseBlock
interfaceLine
statements
children
<-
parseBlock
interfaceLine
statements
return
(
InterfaceDecl
name
annotations
children
)
return
(
InterfaceDecl
name
typeId
annotations
children
)
interfaceLine
::
Maybe
[
Located
Statement
]
->
TokenParser
Declaration
interfaceLine
::
Maybe
[
Located
Statement
]
->
TokenParser
Declaration
interfaceLine
Nothing
=
usingDecl
<|>
constantDecl
<|>
methodDecl
<|>
annotationDecl
interfaceLine
Nothing
=
usingDecl
<|>
constantDecl
<|>
methodDecl
<|>
annotationDecl
...
@@ -339,12 +359,13 @@ paramDecl = do
...
@@ -339,12 +359,13 @@ paramDecl = do
annotationDecl
=
do
annotationDecl
=
do
annotationKeyword
annotationKeyword
name
<-
located
varIdentifier
name
<-
located
varIdentifier
annId
<-
optionMaybe
$
located
declId
targets
<-
try
(
parenthesized
asterisk
>>
return
allAnnotationTargets
)
targets
<-
try
(
parenthesized
asterisk
>>
return
allAnnotationTargets
)
<|>
parenthesizedList
annotationTarget
<|>
parenthesizedList
annotationTarget
colon
colon
t
<-
typeExpression
t
<-
typeExpression
annotations
<-
many
annotation
annotations
<-
many
annotation
return
(
AnnotationDecl
name
t
annotations
targets
)
return
(
AnnotationDecl
name
annId
t
annotations
targets
)
allAnnotationTargets
=
[
minBound
::
AnnotationTarget
..
maxBound
::
AnnotationTarget
]
allAnnotationTargets
=
[
minBound
::
AnnotationTarget
..
maxBound
::
AnnotationTarget
]
annotationTarget
=
(
exactIdentifier
"file"
>>
return
FileAnnotation
)
annotationTarget
=
(
exactIdentifier
"file"
>>
return
FileAnnotation
)
...
@@ -404,15 +425,23 @@ parseStatement parser (Located _ (Line tokens)) =
...
@@ -404,15 +425,23 @@ parseStatement parser (Located _ (Line tokens)) =
parseStatement
parser
(
Located
_
(
Block
tokens
statements
))
=
parseStatement
parser
(
Located
_
(
Block
tokens
statements
))
=
parseCollectingErrors
(
parser
(
Just
statements
))
tokens
parseCollectingErrors
(
parser
(
Just
statements
))
tokens
parseFileTokens
::
[
Located
Statement
]
->
([
Declaration
],
[
Annotation
],
[
ParseError
])
parseFileTokens
::
[
Located
Statement
]
parseFileTokens
statements
=
(
decls
,
annotations
,
errors
)
where
->
(
Maybe
(
Located
Word64
),
[
Declaration
],
[
Annotation
],
[
ParseError
])
results
::
[
Either
ParseError
(
Either
Declaration
Annotation
,
[
ParseError
])]
parseFileTokens
statements
=
(
fileId
,
decls
,
annotations
,
errors
)
where
results
::
[
Either
ParseError
(
TopLevelDecl
,
[
ParseError
])]
results
=
map
(
parseStatement
topLine
)
statements
results
=
map
(
parseStatement
topLine
)
statements
errors
=
concatMap
extractErrors
results
errors
=
concatMap
extractErrors
results
++
idErrors
decls
=
[
decl
|
Right
(
Left
decl
,
_
)
<-
results
]
decls
=
[
decl
|
Right
(
TopLevelDecl
decl
,
_
)
<-
results
]
annotations
=
[
ann
|
Right
(
Right
ann
,
_
)
<-
results
]
annotations
=
[
ann
|
Right
(
TopLevelAnnotation
ann
,
_
)
<-
results
]
ids
=
[
i
|
Right
(
TopLevelId
i
,
_
)
<-
results
]
parseFile
::
String
->
String
->
([
Declaration
],
[
Annotation
],
[
ParseError
])
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
parseFile
filename
text
=
case
parse
lexer
filename
text
of
Left
e
->
(
[]
,
[]
,
[
e
])
Left
e
->
(
Nothing
,
[]
,
[]
,
[
e
])
Right
statements
->
parseFileTokens
statements
Right
statements
->
parseFileTokens
statements
compiler/src/Semantics.hs
View file @
2c8595bc
This diff is collapsed.
Click to expand it.
compiler/src/Util.hs
View file @
2c8595bc
...
@@ -25,6 +25,8 @@ module Util where
...
@@ -25,6 +25,8 @@ module Util where
import
Data.Char
(
isUpper
,
toUpper
)
import
Data.Char
(
isUpper
,
toUpper
)
import
Data.List
(
intercalate
,
isPrefixOf
)
import
Data.List
(
intercalate
,
isPrefixOf
)
import
Data.Bits
(
shiftR
,
Bits
)
import
Data.Word
(
Word8
)
--delimit _ [] = ""
--delimit _ [] = ""
--delimit delimiter (h:t) = h ++ concatMap (delimiter ++) t
--delimit delimiter (h:t) = h ++ concatMap (delimiter ++) t
...
@@ -50,3 +52,8 @@ toTitleCase [] = []
...
@@ -50,3 +52,8 @@ toTitleCase [] = []
toUpperCaseWithUnderscores
::
String
->
String
toUpperCaseWithUnderscores
::
String
->
String
toUpperCaseWithUnderscores
name
=
delimit
"_"
$
map
(
map
toUpper
)
$
splitName
name
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
...
@@ -25,18 +25,13 @@ module WireFormat(encodeMessage) where
import
Data.List
(
sortBy
,
genericLength
,
genericReplicate
)
import
Data.List
(
sortBy
,
genericLength
,
genericReplicate
)
import
Data.Word
import
Data.Word
import
Data.Bits
(
shiftL
,
shiftR
,
Bits
,
setBit
,
xor
)
import
Data.Bits
(
shiftL
,
Bits
,
setBit
,
xor
)
import
Data.Function
(
on
)
import
Data.Function
(
on
)
import
Semantics
import
Semantics
import
Data.Binary.IEEE754
(
floatToWord
,
doubleToWord
)
import
Data.Binary.IEEE754
(
floatToWord
,
doubleToWord
)
import
Text.Printf
(
printf
)
import
Text.Printf
(
printf
)
import
qualified
Codec.Binary.UTF8.String
as
UTF8
import
qualified
Codec.Binary.UTF8.String
as
UTF8
import
Util
(
intToBytes
)
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
)]
padToWord
b
=
let
padToWord
b
=
let
trailing
=
mod
(
length
b
)
8
trailing
=
mod
(
length
b
)
8
...
@@ -55,19 +50,19 @@ xorData _ _ = error "Value type mismatch when xor'ing."
...
@@ -55,19 +50,19 @@ xorData _ _ = error "Value type mismatch when xor'ing."
encodeDataValue
::
TypeDesc
->
ValueDesc
->
EncodedData
encodeDataValue
::
TypeDesc
->
ValueDesc
->
EncodedData
encodeDataValue
_
VoidDesc
=
EncodedBytes
[]
encodeDataValue
_
VoidDesc
=
EncodedBytes
[]
encodeDataValue
_
(
BoolDesc
v
)
=
EncodedBit
v
encodeDataValue
_
(
BoolDesc
v
)
=
EncodedBit
v
encodeDataValue
_
(
Int8Desc
v
)
=
EncodedBytes
$
b
ytes
v
1
encodeDataValue
_
(
Int8Desc
v
)
=
EncodedBytes
$
intToB
ytes
v
1
encodeDataValue
_
(
Int16Desc
v
)
=
EncodedBytes
$
b
ytes
v
2
encodeDataValue
_
(
Int16Desc
v
)
=
EncodedBytes
$
intToB
ytes
v
2
encodeDataValue
_
(
Int32Desc
v
)
=
EncodedBytes
$
b
ytes
v
4
encodeDataValue
_
(
Int32Desc
v
)
=
EncodedBytes
$
intToB
ytes
v
4
encodeDataValue
_
(
Int64Desc
v
)
=
EncodedBytes
$
b
ytes
v
8
encodeDataValue
_
(
Int64Desc
v
)
=
EncodedBytes
$
intToB
ytes
v
8
encodeDataValue
_
(
UInt8Desc
v
)
=
EncodedBytes
$
b
ytes
v
1
encodeDataValue
_
(
UInt8Desc
v
)
=
EncodedBytes
$
intToB
ytes
v
1
encodeDataValue
_
(
UInt16Desc
v
)
=
EncodedBytes
$
b
ytes
v
2
encodeDataValue
_
(
UInt16Desc
v
)
=
EncodedBytes
$
intToB
ytes
v
2
encodeDataValue
_
(
UInt32Desc
v
)
=
EncodedBytes
$
b
ytes
v
4
encodeDataValue
_
(
UInt32Desc
v
)
=
EncodedBytes
$
intToB
ytes
v
4
encodeDataValue
_
(
UInt64Desc
v
)
=
EncodedBytes
$
b
ytes
v
8
encodeDataValue
_
(
UInt64Desc
v
)
=
EncodedBytes
$
intToB
ytes
v
8
encodeDataValue
_
(
Float32Desc
v
)
=
EncodedBytes
$
b
ytes
(
floatToWord
v
)
4
encodeDataValue
_
(
Float32Desc
v
)
=
EncodedBytes
$
intToB
ytes
(
floatToWord
v
)
4
encodeDataValue
_
(
Float64Desc
v
)
=
EncodedBytes
$
b
ytes
(
doubleToWord
v
)
8
encodeDataValue
_
(
Float64Desc
v
)
=
EncodedBytes
$
intToB
ytes
(
doubleToWord
v
)
8
encodeDataValue
_
(
TextDesc
_
)
=
error
"Not fixed-width data."
encodeDataValue
_
(
TextDesc
_
)
=
error
"Not fixed-width data."
encodeDataValue
_
(
DataDesc
_
)
=
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
_
(
StructValueDesc
_
)
=
error
"Not fixed-width data."
encodeDataValue
_
(
ListDesc
_
)
=
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
...
@@ -132,23 +127,23 @@ packPointers size items o = loop 0 items (o + size - 1) where
loop
idx
[]
_
=
(
genericReplicate
((
size
-
idx
)
*
8
)
0
,
[]
)
loop
idx
[]
_
=
(
genericReplicate
((
size
-
idx
)
*
8
)
0
,
[]
)
encodeStructReference
desc
offset
=
encodeStructReference
desc
offset
=
b
ytes
(
offset
*
4
+
structTag
)
4
++
intToB
ytes
(
offset
*
4
+
structTag
)
4
++
b
ytes
(
dataSectionWordSize
$
structDataSize
desc
)
2
++
intToB
ytes
(
dataSectionWordSize
$
structDataSize
desc
)
2
++
b
ytes
(
structPointerCount
desc
)
2
intToB
ytes
(
structPointerCount
desc
)
2
encodeInlineStructListReference
elementDataSize
elementPointerCount
elementCount
offset
=
let
encodeInlineStructListReference
elementDataSize
elementPointerCount
elementCount
offset
=
let
dataBits
=
dataSectionBits
elementDataSize
*
elementCount
dataBits
=
dataSectionBits
elementDataSize
*
elementCount
dataWords
=
div
(
dataBits
+
63
)
64
dataWords
=
div
(
dataBits
+
63
)
64
in
b
ytes
(
offset
*
4
+
structTag
)
4
++
in
intToB
ytes
(
offset
*
4
+
structTag
)
4
++
b
ytes
dataWords
2
++
intToB
ytes
dataWords
2
++
b
ytes
(
elementPointerCount
*
elementCount
)
2
intToB
ytes
(
elementPointerCount
*
elementCount
)
2
encodeListReference
elemSize
@
(
SizeInlineComposite
ds
rc
)
elementCount
offset
=
encodeListReference
elemSize
@
(
SizeInlineComposite
ds
rc
)
elementCount
offset
=
b
ytes
(
offset
*
4
+
listTag
)
4
++
intToB
ytes
(
offset
*
4
+
listTag
)
4
++
b
ytes
(
fieldSizeEnum
elemSize
+
shiftL
(
elementCount
*
(
dataSectionWordSize
ds
+
rc
))
3
)
4
intToB
ytes
(
fieldSizeEnum
elemSize
+
shiftL
(
elementCount
*
(
dataSectionWordSize
ds
+
rc
))
3
)
4
encodeListReference
elemSize
elementCount
offset
=
encodeListReference
elemSize
elementCount
offset
=
b
ytes
(
offset
*
4
+
listTag
)
4
++
intToB
ytes
(
offset
*
4
+
listTag
)
4
++
b
ytes
(
fieldSizeEnum
elemSize
+
shiftL
elementCount
3
)
4
intToB
ytes
(
fieldSizeEnum
elemSize
+
shiftL
elementCount
3
)
4
fieldSizeEnum
SizeVoid
=
0
fieldSizeEnum
SizeVoid
=
0
fieldSizeEnum
(
SizeData
Size1
)
=
1
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