Skip to content

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

Remove obsolete Haskell-based compiler.

parent ae33cf61
Show whitespace changes
Inline Side-by-side
Showing with 0 additions and 5000 deletions
compiler/LICENSE.txt deleted 120000 → 0
View file @ ae33cf61
../LICENSE
\ No newline at end of file
compiler/README.txt deleted 100644 → 0
View file @ ae33cf61
Cap'n Proto - Insanely Fast Data Serialization Format
Copyright 2013 Kenton Varda
http://kentonv.github.com/capnproto/
Cap'n Proto is an insanely fast data interchange format and capability-based
RPC system. Think JSON, except binary. Or think of Google's Protocol Buffers
(http://protobuf.googlecode.com), except faster. In fact, in benchmarks,
Cap'n Proto is INFINITY TIMES faster than Protocol Buffers.
This package is the executable tool which parses Cap'n Proto schema definitions
and generates corresponding source code in various target languages. To be
useful, you will also need to obtain a runtime library for your target
language. These are distributed separately.
Full installation and usage instructions and other documentation are maintained
on the Cap'n Proto web site:
http://kentonv.github.io/capnproto/install.html
To build and install, simply do:
cabal install capnproto-compiler.cabal
compiler/Setup.hs deleted 100644 → 0
View file @ ae33cf61
import Distribution.Simple
main = defaultMain
compiler/capnproto-compiler.cabal deleted 100644 → 0
View file @ ae33cf61
name: capnproto-compiler
version: 0.2-dev
cabal-version: >=1.2
build-type: Simple
author: Kenton Varda <temporal@gmail.com>
maintainer: capnproto@googlegroups.com
homepage: http://kentonv.github.io/capnproto/
-- actually BSD2, but that's not on the list for some reason
license: BSD3
license-file: LICENSE.txt
synopsis: Schema parser and code generator for Cap'n Proto serialization/RPC system.
category: Data
description:
Cap’n Proto is an insanely fast data interchange format and capability-based RPC system. Think
JSON, except binary. Or think Protocol Buffers, except faster. In fact, in benchmarks, Cap’n
Proto is INFINITY TIMES faster than Protocol Buffers.
This package is the executable tool which parses Cap'n Proto schema definitions and generates
corresponding source code in various target languages. To be useful, you will also need to
obtain a runtime library for your target language. These are distributed separately.
See the web site for full documentation: http://kentonv.github.io/capnproto/
-- How to get stack traces:
-- 1. Compile normally and do not clean.
-- 2. Add "-prof -fprof-auto -osuf .prof.o" to ghc-options and compile again.
-- (TODO: Figure out how to add these through "cabal configure" instead of by editing
-- this file. --enable-executable-profiling alone doesn't appear to get the job done.)
-- 3. Run with +RTS -xc -RTS on the command line.
extra-source-files:
README.txt,
src/c++-source.mustache,
src/c++-header.mustache
executable capnpc
hs-source-dirs: src
main-is: Main.hs
build-depends:
base >= 4,
parsec,
mtl,
containers,
file-embed,
bytestring,
Crypto,
utf8-string,
hastache,
array,
data-binary-ieee754,
filepath,
directory,
syb,
transformers,
entropy,
process
ghc-options: -Wall -fno-warn-missing-signatures
other-modules:
Lexer,
Token,
Grammar,
Parser,
Compiler,
Semantics,
Util,
CxxGenerator,
WireFormat
compiler/src/Compiler.hs deleted 100644 → 0
View file @ ae33cf61
-- 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.
module Compiler (Status(..), parseAndCompileFile) where
import Grammar
import Semantics
import Token(Located(Located), locatedValue)
import Parser(parseFile)
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, 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 qualified Data.Digest.MD5 as MD5
import qualified Codec.Binary.UTF8.String as UTF8
import Util(delimit, intToBytes)
import Data.Bits(setBit)
------------------------------------------------------------------------------------------
-- Error helpers
------------------------------------------------------------------------------------------
data Status a = Active a [ParseError]
| Failed [ParseError]
deriving(Show)
statusErrors (Active _ e) = e
statusErrors (Failed e) = e
statusAddErrors errs (Active x e) = Active x (e ++ errs)
statusAddErrors errs (Failed e) = Failed (e ++ errs)
instance Functor Status where
fmap f (Active x e) = Active (f x) e
fmap _ (Failed e) = Failed e
instance Monad Status where
(Active x e) >>= k = statusAddErrors e (k x)
(Failed e) >>= _ = Failed e
-- If the result is ignored, we can automatically recover.
(Active _ e) >> k = statusAddErrors e k
(Failed e) >> k = statusAddErrors e k
return x = Active x []
fail = makeError (newPos "?" 0 0)
-- Recovers from Failed status by using a fallback result, but keeps the errors.
--
-- This function is carefully written such that the runtime can see that it returns Active without
-- actually evaluating the parameters. The parameters are only evaluated when the returned value
-- or errors are examined.
recover :: a -> Status a -> Status a
recover fallback status = Active value errs where
(value, errs) = case status of
Active v e -> (v, e)
Failed e -> (fallback, e)
succeed :: a -> Status a
succeed x = Active x []
makeError pos message = Failed [ newErrorMessage (Message message) pos ]
makeExpectError pos message = Failed [ newErrorMessage (Expect message) pos ]
maybeError :: Maybe t -> SourcePos -> String -> Status t
maybeError (Just x) _ _ = succeed x
maybeError Nothing pos message = makeError pos message
declNamePos (AbsoluteName (Located pos _)) = pos
declNamePos (RelativeName (Located pos _)) = pos
declNamePos (ImportName (Located pos _)) = pos
declNamePos (MemberName _ (Located pos _)) = pos
declNameString (AbsoluteName (Located _ n)) = n
declNameString (RelativeName (Located _ n)) = n
declNameString (ImportName (Located _ n)) = n
declNameString (MemberName _ (Located _ n)) = n
-- Trick for feeding a function's own result back in as a parameter, taking advantage of
-- lazy evaluation. If the function returns a Failed status, then it must do so withous using
-- its parameter.
feedback :: (a -> Status a) -> Status a
feedback f = status where
status = f result
result = case status of
Active x _ -> x
Failed _ -> undefined
statusToMaybe (Active x _) = Just x
statusToMaybe (Failed _) = Nothing
doAll statuses = Active [x | (Active x _) <- statuses] (concatMap statusErrors statuses)
------------------------------------------------------------------------------------------
-- Symbol lookup
------------------------------------------------------------------------------------------
-- | Look up a direct member of a descriptor by name.
descMember name (DescFile d) = lookupMember name (fileMemberMap d)
descMember name (DescEnum d) = lookupMember name (enumMemberMap d)
descMember name (DescStruct d) = lookupMember name (structMemberMap d)
descMember name (DescInterface d) = lookupMember name (interfaceMemberMap d)
descMember name (DescUsing d) = descMember name (usingTarget d)
descMember _ _ = Nothing
-- | Lookup the given name in the scope of the given descriptor.
lookupDesc :: Desc -> DeclName -> Status Desc
-- For a member, look up the parent, then apply descMember.
lookupDesc scope (MemberName parentName (Located pos name)) = do
p <- lookupDesc scope parentName
maybeError (descMember name p) pos
(printf "'%s' is not defined in '%s'." name (declNameString parentName))
-- Implement absolute, relative, and import names on the file scope by just checking the appropriate
-- map. There is not parent scope to which to recurse.
lookupDesc (DescFile desc) (AbsoluteName (Located pos name)) =
maybeError (lookupMember name (fileMemberMap desc)) pos
(printf "'%s' is not defined." name)
lookupDesc (DescFile desc) (RelativeName (Located pos name)) = result where
maybeResult = case lookupMember name (fileMemberMap desc) of
Just x -> Just x
Nothing -> Map.lookup name builtinTypeMap
result = maybeError maybeResult pos
(printf "'%s' is not defined." name)
lookupDesc (DescFile desc) (ImportName (Located pos name)) =
maybeError (fmap DescFile (Map.lookup name (fileImportMap desc))) pos
(printf "'%s' was not in the import table." name)
-- Implement other relative names by first checking the current scope, then the parent.
lookupDesc scope (RelativeName (Located pos name)) =
case descMember name scope of
Just m -> succeed m
Nothing -> lookupDesc (descParent scope) (RelativeName (Located pos name))
-- For non-relative names on non-file scopes, just recurse out to parent scope.
lookupDesc scope name = lookupDesc (descParent scope) name
builtinTypeMap :: Map.Map String Desc
builtinTypeMap = Map.fromList
([(builtinTypeName t, DescBuiltinType t) | t <- builtinTypes] ++
[ ("List", DescBuiltinList)
{- Inlines have been disabled for now because they added too much complication.
, ("Inline", DescBuiltinInline)
, ("InlineList", DescBuiltinInlineList)
, ("InlineData", DescBuiltinInlineData)
-}
])
------------------------------------------------------------------------------------------
fromIntegerChecked :: Integral a => String -> SourcePos -> Integer -> Status a
fromIntegerChecked name pos x = result where
unchecked = fromInteger x
result = if toInteger unchecked == x
then succeed unchecked
else makeError pos (printf "Integer %d out of range for type %s." x name)
compileFieldAssignment :: StructDesc -> (Located String, Located FieldValue)
-> Status (FieldDesc, ValueDesc)
compileFieldAssignment desc (Located namePos name, Located valPos val) =
case lookupMember name (structMemberMap desc) of
Just (DescField field) ->
fmap (\x -> (field, x)) (compileValue valPos (fieldType field) val)
Just (DescUnion union) -> case val of
UnionFieldValue uName uVal ->
case lookupMember uName (unionMemberMap union) of
Just (DescField field) ->
fmap (\x -> (field, x)) (compileValue valPos (fieldType field) uVal)
_ -> makeError namePos (printf "Union %s has no member %s."
(unionName union) uName)
_ -> makeExpectError valPos "union value"
_ -> makeError namePos (printf "Struct %s has no field %s." (structName desc) name)
compileValue :: SourcePos -> TypeDesc -> FieldValue -> Status ValueDesc
compileValue _ (BuiltinType BuiltinVoid) VoidFieldValue = succeed VoidDesc
compileValue _ (BuiltinType BuiltinBool) (BoolFieldValue x) = succeed (BoolDesc x)
compileValue pos (BuiltinType BuiltinInt8 ) (IntegerFieldValue x) = fmap Int8Desc (fromIntegerChecked "Int8" pos x)
compileValue pos (BuiltinType BuiltinInt16 ) (IntegerFieldValue x) = fmap Int16Desc (fromIntegerChecked "Int16" pos x)
compileValue pos (BuiltinType BuiltinInt32 ) (IntegerFieldValue x) = fmap Int32Desc (fromIntegerChecked "Int32" pos x)
compileValue pos (BuiltinType BuiltinInt64 ) (IntegerFieldValue x) = fmap Int64Desc (fromIntegerChecked "Int64" pos x)
compileValue pos (BuiltinType BuiltinUInt8 ) (IntegerFieldValue x) = fmap UInt8Desc (fromIntegerChecked "UInt8" pos x)
compileValue pos (BuiltinType BuiltinUInt16) (IntegerFieldValue x) = fmap UInt16Desc (fromIntegerChecked "UInt16" pos x)
compileValue pos (BuiltinType BuiltinUInt32) (IntegerFieldValue x) = fmap UInt32Desc (fromIntegerChecked "UInt32" pos x)
compileValue pos (BuiltinType BuiltinUInt64) (IntegerFieldValue x) = fmap UInt64Desc (fromIntegerChecked "UInt64" pos x)
compileValue _ (BuiltinType BuiltinFloat32) (FloatFieldValue x) = succeed (Float32Desc (realToFrac x))
compileValue _ (BuiltinType BuiltinFloat64) (FloatFieldValue x) = succeed (Float64Desc x)
compileValue _ (BuiltinType BuiltinFloat32) (IntegerFieldValue x) = succeed (Float32Desc (realToFrac x))
compileValue _ (BuiltinType BuiltinFloat64) (IntegerFieldValue x) = succeed (Float64Desc (realToFrac x))
compileValue _ (BuiltinType BuiltinFloat32) (IdentifierFieldValue "inf") = succeed $ Float32Desc $ 1.0 / 0.0
compileValue _ (BuiltinType BuiltinFloat64) (IdentifierFieldValue "inf") = succeed $ Float64Desc $ 1.0 / 0.0
compileValue _ (BuiltinType BuiltinFloat32) (IdentifierFieldValue "nan") = succeed $ Float32Desc $ 0.0 / 0.0
compileValue _ (BuiltinType BuiltinFloat64) (IdentifierFieldValue "nan") = succeed $ Float64Desc $ 0.0 / 0.0
compileValue _ (BuiltinType BuiltinText) (StringFieldValue x) = succeed (TextDesc x)
compileValue _ (BuiltinType BuiltinData) (StringFieldValue x) =
succeed (DataDesc (map (fromIntegral . fromEnum) x))
compileValue pos (EnumType desc) (IdentifierFieldValue name) =
case lookupMember name (enumMemberMap desc) of
Just (DescEnumerant value) -> succeed (EnumerantValueDesc value)
_ -> makeError pos (printf "Enum type '%s' has no value '%s'." (enumName desc) name)
compileValue pos (StructType desc) (RecordFieldValue fields) = do
assignments <- doAll (map (compileFieldAssignment desc) fields)
-- Check for duplicate fields.
_ <- let
dupes = findDupesBy id [fieldName f | (f, _) <- assignments]
errors = map dupFieldError dupes
dupFieldError [] = error "empty group?"
dupFieldError (name:_) = makeError pos
(printf "Struct literal assigns field '%s' multiple times." name)
in doAll errors
-- Check for multiple assignments in the same union.
_ <- let
dupes = findDupesBy (\(_, u) -> unionName u)
[(f, u) | (f@(FieldDesc {fieldUnion = Just (u, _)}), _) <- assignments]
errors = map dupUnionError dupes
dupUnionError [] = error "empty group?"
dupUnionError dupFields@((_, u):_) = makeError pos (printf
"Struct literal assigns multiple fields belonging to the same union '%s': %s"
(unionName u) (delimit ", " (map (\(f, _) -> fieldName f) dupFields)))
in doAll errors
return (StructValueDesc assignments)
compileValue pos (InlineStructType desc) v = compileValue pos (StructType desc) v
compileValue _ (ListType t) (ListFieldValue l) =
fmap ListDesc (doAll [ compileValue vpos t v | Located vpos v <- l ])
compileValue pos (InlineListType t s) (ListFieldValue l) = do
elements <- doAll [ compileValue vpos t v | Located vpos v <- l ]
when (List.genericLength elements /= s) $
makeError pos $ printf "Fixed-size list must have exactly %d elements." s
return $ ListDesc elements
compileValue pos (InlineDataType s) (StringFieldValue x) = let
bytes = map (fromIntegral . fromEnum) x
in if List.genericLength bytes == s
then succeed $ DataDesc bytes
else makeError pos $ printf "Fixed-size data must have exactly %d bytes." s
compileValue pos (BuiltinType BuiltinVoid) _ = makeError pos "Void fields cannot have values."
compileValue pos (BuiltinType BuiltinBool) _ = makeExpectError pos "boolean"
compileValue pos (BuiltinType BuiltinInt8) _ = makeExpectError pos "integer"
compileValue pos (BuiltinType BuiltinInt16) _ = makeExpectError pos "integer"
compileValue pos (BuiltinType BuiltinInt32) _ = makeExpectError pos "integer"
compileValue pos (BuiltinType BuiltinInt64) _ = makeExpectError pos "integer"
compileValue pos (BuiltinType BuiltinUInt8) _ = makeExpectError pos "integer"
compileValue pos (BuiltinType BuiltinUInt16) _ = makeExpectError pos "integer"
compileValue pos (BuiltinType BuiltinUInt32) _ = makeExpectError pos "integer"
compileValue pos (BuiltinType BuiltinUInt64) _ = makeExpectError pos "integer"
compileValue pos (BuiltinType BuiltinFloat32) _ = makeExpectError pos "number"
compileValue pos (BuiltinType BuiltinFloat64) _ = makeExpectError pos "number"
compileValue pos (BuiltinType BuiltinText) _ = makeExpectError pos "string"
compileValue pos (BuiltinType BuiltinData) _ = makeExpectError pos "string"
compileValue pos (BuiltinType BuiltinObject) _ =
-- TODO(someday): We could arguably design a syntax where you specify the type followed by
-- the value, but it seems not worth the effort.
makeError pos "Can't specify literal value for 'Object'."
compileValue pos (EnumType _) _ = makeExpectError pos "enumerant name"
compileValue pos (StructType _) _ = makeExpectError pos "parenthesized list of field assignments"
compileValue pos (InterfaceType _) _ = makeError pos "Can't specify literal value for interface."
compileValue pos (ListType _) _ = makeExpectError pos "list"
compileValue pos (InlineListType _ _) _ = makeExpectError pos "list"
compileValue pos (InlineDataType _) _ = makeExpectError pos "string"
descAsType _ (DescEnum desc) = succeed (EnumType desc)
descAsType _ (DescStruct desc) = succeed (StructType desc)
descAsType _ (DescInterface desc) = succeed (InterfaceType desc)
descAsType _ (DescBuiltinType desc) = succeed (BuiltinType desc)
descAsType name (DescUsing desc) = descAsType name (usingTarget desc)
descAsType name DescBuiltinList = makeError (declNamePos name) message where
message = printf "'List' requires exactly one type parameter." (declNameString name)
descAsType name DescBuiltinInline = makeError (declNamePos name) message where
message = printf "'Inline' requires exactly one type parameter." (declNameString name)
descAsType name DescBuiltinInlineList = makeError (declNamePos name) message where
message = printf "'InlineList' requires exactly two type parameters." (declNameString name)
descAsType name DescBuiltinInlineData = makeError (declNamePos name) message where
message = printf "'InlineData' requires exactly one type parameter." (declNameString name)
descAsType name _ = makeError (declNamePos name) message where
message = printf "'%s' is not a type." (declNameString name)
compileType :: Desc -> TypeExpression -> Status TypeDesc
compileType scope (TypeExpression n params) = do
desc <- lookupDesc scope n
case desc of
DescBuiltinList -> case params of
[TypeParameterType param] -> do
inner <- compileType scope param
case inner of
InlineStructType _ -> makeError (declNamePos n)
"Don't declare list elements 'Inline'. The regular encoding for struct \
\lists already inlines the elements."
InlineListType (BuiltinType BuiltinBool) _ -> makeError (declNamePos n)
"List(InlineList(Bool, n)) not supported due to implementation difficulty."
BuiltinType BuiltinObject -> makeError (declNamePos n)
"List(Object) not supported. Just use Object, or create a struct with \
\one field of type 'Object' and use a List of that."
_ -> return (ListType inner)
_ -> makeError (declNamePos n) "'List' requires exactly one type parameter."
DescBuiltinInline -> case params of
[TypeParameterType param] -> do
inner <- compileType scope param
case inner of
StructType s -> if structIsFixedWidth s
then return (InlineStructType s)
else makeError (declNamePos n) $
printf "'%s' cannot be inlined because it is not fixed-width."
(structName s)
_ -> makeError (declNamePos n) "'Inline' parameter must be a struct type."
_ -> makeError (declNamePos n) "'Inline' requires exactly one type parameter."
DescBuiltinInlineList -> case params of
[TypeParameterType param, TypeParameterInteger size] -> do
inner <- compileType scope param
case inner of
InlineStructType _ -> makeError (declNamePos n)
"Don't declare list elements 'Inline'. The regular encoding for struct \
\lists already inlines the elements."
StructType s -> if structIsFixedWidth s
then return (InlineListType (InlineStructType s) size)
else makeError (declNamePos n) $
printf "'%s' cannot be inlined because it is not fixed-width."
(structName s)
InlineListType _ _ -> makeError (declNamePos n)
"InlineList of InlineList not currently supported."
InlineDataType _ -> makeError (declNamePos n)
"InlineList of InlineData not currently supported."
BuiltinType BuiltinObject -> makeError (declNamePos n)
"InlineList(Object) not supported."
_ -> return $ InlineListType inner size
_ -> makeError (declNamePos n)
"'InlineList' requires exactly two type parameters: a type and a size."
DescBuiltinInlineData -> case params of
[TypeParameterInteger size] -> return $ InlineDataType size
_ -> makeError (declNamePos n)
"'InlineData' requires exactly one type parameter: the byte size of the data."
_ -> case params of
[] -> descAsType n desc
_ -> makeError (declNamePos n) $
printf "'%s' doesn't take parameters." (declNameString n)
compileAnnotation :: Desc -> AnnotationTarget -> Annotation
-> Status (AnnotationDesc, ValueDesc)
compileAnnotation scope kind (Annotation name (Located pos value)) = do
nameDesc <- lookupDesc scope name
case nameDesc of
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)
_ -> makeError (declNamePos name)
$ printf "'%s' is not an annotation." (declNameString name)
compileAnnotations :: Desc -> AnnotationTarget -> [Annotation]
-> 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.
let locatedEntries = [ Located pos (annotationId desc, (desc, v))
| Located pos (desc, v) <- compiled ]
-- 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
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 flip setBit 63 $ foldl addByte 0 (take 8 hash)
------------------------------------------------------------------------------------------
findDupesBy :: Ord a => (b -> a) -> [b] -> [[b]]
findDupesBy getKey items = let
compareItems a b = compare (getKey a) (getKey b)
eqItems a b = getKey a == getKey b
grouped = List.groupBy eqItems $ List.sortBy compareItems items
in [ item | item@(_:_:_) <- grouped ]
requireSequentialNumbering :: String -> [Located Integer] -> Status ()
requireSequentialNumbering kind items = Active () (loop undefined (-1) sortedItems) where
sortedItems = List.sort items
loop _ _ [] = []
loop _ prev (Located pos num:rest) | num == prev + 1 = loop pos num rest
loop prevPos prev (Located pos num:rest) | num == prev = err1:err2:loop pos num rest where
err1 = newErrorMessage (Message message) prevPos
err2 = newErrorMessage (Message message) pos
message = printf "Duplicate number %d. %s must be numbered uniquely within their scope."
num kind
loop _ prev (Located pos num:rest) = err:loop pos num rest where
err = newErrorMessage (Message message) pos
message = printf "Skipped number %d. %s must be numbered sequentially starting \
\from zero." (prev + 1) kind
requireOrdinalsInRange ordinals =
Active () [ ordinalError num pos | Located pos num <- ordinals, num > maxOrdinal ] where
ordinalError num = newErrorMessage (Message
(printf "Ordinal %d too large; maximum is %d." num maxOrdinal))
requireNoDuplicateNames :: [Declaration] -> Status()
requireNoDuplicateNames decls = Active () (loop (List.sort locatedNames)) where
locatedNames = mapMaybe declarationName decls
loop (Located pos1 val1:Located pos2 val2:t) =
if val1 == val2
then dupError val1 pos1:dupError val2 pos2:loop2 val1 t
else loop t
loop _ = []
loop2 val1 l@(Located pos2 val2:t) =
if val1 == val2
then dupError val2 pos2:loop2 val1 t
else loop l
loop2 _ _ = []
dupError val = newErrorMessage (Message message) where
message = printf "Duplicate declaration \"%s\"." val
requireNoMoreThanOneFieldNumberLessThan name pos num fields = Active () errors where
retroFields = [fieldName f | f <- fields, fieldNumber f < num]
message = printf "No more than one field in a union may have a number less than the \
\union's number, as it is not possible to retroactively unionize fields that \
\had been separate. The following fields of union '%s' have lower numbers: %s"
name (delimit ", " retroFields)
errors = if length retroFields <= 1
then []
else [newErrorMessage (Message message) pos]
extractFieldNumbers :: [Declaration] -> [Located Integer]
extractFieldNumbers decls = concat
([ num | FieldDecl _ num _ _ _ <- decls ]
:[ num:extractFieldNumbers uDecls | UnionDecl _ num _ uDecls <- decls ])
------------------------------------------------------------------------------------------
data PackingState = PackingState
{ packingHoles :: Map.Map DataSize Integer
, packingDataSize :: Integer
, packingPointerCount :: Integer
}
initialPackingState = PackingState Map.empty 0 0
packValue :: FieldSize -> PackingState -> (FieldOffset, PackingState)
packValue SizeVoid s = (VoidOffset, s)
packValue SizePointer s@(PackingState { packingPointerCount = rc }) =
(PointerOffset rc, s { packingPointerCount = rc + 1 })
packValue (SizeInlineComposite (DataSectionWords inlineDs) inlineRc)
s@(PackingState { packingDataSize = ds, packingPointerCount = rc }) =
(InlineCompositeOffset ds rc (DataSectionWords inlineDs) inlineRc,
s { packingDataSize = ds + inlineDs
, packingPointerCount = rc + inlineRc })
packValue (SizeInlineComposite inlineDs inlineRc)
s@(PackingState { packingPointerCount = rc }) = let
size = (dataSectionAlignment inlineDs)
(offset, s2) = packData size s
in (InlineCompositeOffset offset rc inlineDs inlineRc,
s2 { packingPointerCount = rc + inlineRc })
packValue (SizeData size) s = let (o, s2) = packData size s in (DataOffset size o, s2)
packData :: DataSize -> PackingState -> (Integer, PackingState)
packData Size64 s@(PackingState { packingDataSize = ds }) =
(ds, s { packingDataSize = ds + 1 })
packData size s = let
-- updateLookupWithKey doesn't quite work here because it returns the new value if updated, or
-- the old value if not. We really always want the old value and have no way to distinguish.
-- There appears to be no function that does this, AFAICT.
hole = Map.lookup size $ packingHoles s
newHoles = Map.update splitHole size $ packingHoles s
splitHole off = case size of
Size1 -> if mod off 8 == 7 then Nothing else Just (off + 1)
_ -> Nothing
in case hole of
-- If there was a hole of the correct size, use it.
Just off -> (off, s { packingHoles = newHoles })
-- Otherwise, try to pack a value of the next size up, and then split it.
Nothing -> let
nextSize = succ size
(nextOff, s2) = packData nextSize s
off = demoteOffset nextSize nextOff
newHoles2 = Map.insert size (off + 1) $ packingHoles s2
in (off, s2 { packingHoles = newHoles2 })
-- Convert an offset of one data size to an offset of the next smaller size.
demoteOffset :: DataSize -> Integer -> Integer
demoteOffset Size1 _ = error "can't split bit"
demoteOffset Size8 i = i * 8
demoteOffset _ i = i * 2
data UnionSlot sizeType = UnionSlot sizeType Integer -- size, offset
data UnionPackingState = UnionPackingState
{ unionDataSlot :: UnionSlot DataSectionSize
, unionPointerSlot :: UnionSlot Integer }
initialUnionPackingState = UnionPackingState (UnionSlot (DataSectionWords 0) 0) (UnionSlot 0 0)
packUnionizedValue :: FieldSize -- Size of field to pack.
-> UnionPackingState -- Current layout of the union
-> PackingState -- Current layout of the struct.
-> (FieldOffset, UnionPackingState, PackingState)
packUnionizedValue SizeVoid u s = (VoidOffset, u, s)
-- Pack data when there is no existing slot.
packUnionizedValue (SizeData size) (UnionPackingState (UnionSlot (DataSectionWords 0) _) p) s =
let (offset, s2) = packData size s
in (DataOffset size offset,
UnionPackingState (UnionSlot (dataSizeToSectionSize size) offset) p, s2)
-- Pack data when there is a word-sized slot. All data fits in a word.
packUnionizedValue (SizeData size)
ups@(UnionPackingState (UnionSlot (DataSectionWords _) offset) _) s =
(DataOffset size (offset * div 64 (dataSizeInBits size)), ups, s)
-- Pack data when there is a non-word-sized slot.
packUnionizedValue (SizeData size) (UnionPackingState (UnionSlot slotSize slotOffset) p) s =
case tryExpandSubWordDataSlot (dataSectionAlignment slotSize, slotOffset) s size of
Just (offset, (newSlotSize, newSlotOffset), s2) ->
(DataOffset size offset,
UnionPackingState (UnionSlot (dataSizeToSectionSize newSlotSize) newSlotOffset) p, s2)
-- If the slot wasn't big enough, pack as if there were no slot.
Nothing -> packUnionizedValue (SizeData size)
(UnionPackingState (UnionSlot (DataSectionWords 0) 0) p) s
-- Pack pointer when we don't have a pointer slot.
packUnionizedValue SizePointer u@(UnionPackingState _ (UnionSlot 0 _)) s = let
(PointerOffset offset, s2) = packValue SizePointer s
u2 = u { unionPointerSlot = UnionSlot 1 offset }
in (PointerOffset offset, u2, s2)
-- Pack pointer when we already have a pointer slot allocated.
packUnionizedValue SizePointer u@(UnionPackingState _ (UnionSlot _ offset)) s =
(PointerOffset offset, u, s)
-- Pack inline composite.
packUnionizedValue (SizeInlineComposite dataSize pointerCount)
u@(UnionPackingState { unionDataSlot = UnionSlot dataSlotSize dataSlotOffset
, unionPointerSlot = UnionSlot pointerSlotSize pointerSlotOffset })
s = let
-- Pack the data section.
(dataOffset, u2, s2) = case dataSize of
DataSectionWords 0 -> (0, u, s)
DataSectionWords requestedWordSize -> let
maybeExpanded = case dataSlotSize of
-- Try to expand existing n-word slot to fit.
DataSectionWords existingWordSize ->
tryExpandUnionizedDataWords u s
dataSlotOffset existingWordSize requestedWordSize
-- Try to expand the existing sub-word slot into a word, then from there to a slot
-- of the size we need.
_ -> do
(expandedSlotOffset, _, expandedPackingState) <-
tryExpandSubWordDataSlot (dataSectionAlignment dataSlotSize, dataSlotOffset)
s Size64
let newU = u { unionDataSlot =
UnionSlot (DataSectionWords 1) expandedSlotOffset }
tryExpandUnionizedDataWords newU expandedPackingState
expandedSlotOffset 1 requestedWordSize
-- If expanding fails, fall back to appending the new words to the end of the struct.
atEnd = (packingDataSize s,
u { unionDataSlot = UnionSlot (DataSectionWords requestedWordSize)
(packingDataSize s) },
s { packingDataSize = packingDataSize s + requestedWordSize })
in fromMaybe atEnd maybeExpanded
_ -> let
(DataOffset _ result, newU, newS) =
packUnionizedValue (SizeData (dataSectionAlignment dataSize)) u s
in (result, newU, newS)
-- Pack the pointer section.
(pointerOffset, u3, s3)
| pointerCount <= pointerSlotSize = (pointerSlotOffset, u2, s2)
| pointerSlotOffset + pointerSlotSize == packingPointerCount s2 =
(pointerSlotOffset,
u2 { unionPointerSlot = UnionSlot pointerCount pointerSlotOffset },
s2 { packingPointerCount = pointerSlotOffset + pointerCount })
| otherwise =
(packingPointerCount s2,
u2 { unionPointerSlot = UnionSlot pointerCount (packingPointerCount s2) },
s2 { packingPointerCount = packingPointerCount s2 + pointerCount })
combinedOffset = InlineCompositeOffset
{ inlineCompositeDataOffset = dataOffset
, inlineCompositePointerOffset = pointerOffset
, inlineCompositeDataSize = dataSize
, inlineCompositePointerSize = pointerCount
}
in (combinedOffset, u3, s3)
tryExpandUnionizedDataWords unionState packingState existingOffset existingSize requestedSize
-- Is the existing multi-word slot big enough?
| requestedSize <= existingSize =
-- Yes, use it.
Just (existingOffset, unionState, packingState)
-- Is the slot at the end of the struct?
| existingOffset + existingSize == packingDataSize packingState =
-- Yes, expand it.
Just (existingOffset,
unionState { unionDataSlot = UnionSlot (DataSectionWords requestedSize)
existingOffset },
packingState { packingDataSize = packingDataSize packingState
+ requestedSize - existingSize })
| otherwise = Nothing
-- Try to expand an existing data slot to be big enough for a data field.
tryExpandSubWordDataSlot :: (DataSize, Integer) -- existing slot to expand
-> PackingState -- existing packing state
-> DataSize -- desired field size
-> Maybe (Integer, -- Offset of the new field.
(DataSize, Integer), -- New offset of the slot.
PackingState) -- New struct packing state.
-- If slot is bigger than desired size, no expansion is needed.
tryExpandSubWordDataSlot (slotSize, slotOffset) state desiredSize
| dataSizeInBits slotSize >= dataSizeInBits desiredSize =
Just (div (dataSizeInBits slotSize) (dataSizeInBits desiredSize) * slotOffset,
(slotSize, slotOffset), state)
-- Try expanding the slot by combining it with subsequent padding.
tryExpandSubWordDataSlot (slotSize, slotOffset) state desiredSize = let
nextSize = succ slotSize
ratio = div (dataSizeInBits nextSize) (dataSizeInBits slotSize)
isAligned = mod slotOffset ratio == 0
nextOffset = div slotOffset ratio
deleteHole _ _ = Nothing
(maybeHole, newHoles) = Map.updateLookupWithKey deleteHole slotSize $ packingHoles state
newState = state { packingHoles = newHoles }
in if not isAligned
then Nothing -- Existing slot is not aligned properly.
else case maybeHole of
Just holeOffset | holeOffset == slotOffset + 1 ->
tryExpandSubWordDataSlot (nextSize, nextOffset) newState desiredSize
_ -> Nothing
-- Determine the offset for the given field, and update the packing states to include the field.
packField :: FieldDesc -> PackingState -> Map.Map Integer UnionPackingState
-> (FieldOffset, PackingState, Map.Map Integer UnionPackingState)
packField fieldDesc state unionState =
case fieldUnion fieldDesc of
Nothing -> let
(offset, newState) = packValue (fieldSize $ fieldType fieldDesc) state
in (offset, newState, unionState)
Just (unionDesc, _) -> let
n = unionNumber unionDesc
oldUnionPacking = fromMaybe initialUnionPackingState (Map.lookup n unionState)
(offset, newUnionPacking, newState) =
packUnionizedValue (fieldSize $ fieldType fieldDesc) oldUnionPacking state
newUnionState = Map.insert n newUnionPacking unionState
in (offset, newState, newUnionState)
-- Determine the offset for the given union, and update the packing states to include the union.
-- Specifically, this packs the union tag, *not* the fields of the union.
packUnion :: UnionDesc -> PackingState -> Map.Map Integer UnionPackingState
-> (FieldOffset, PackingState, Map.Map Integer UnionPackingState)
packUnion _ state unionState = (DataOffset Size16 offset, newState, unionState) where
(offset, newState) = packData Size16 state
stripHolesFromFirstWord Size1 _ = Size1 -- Stop at a bit.
stripHolesFromFirstWord size holes = let
nextSize = pred size
in case Map.lookup nextSize holes of
Just 1 -> stripHolesFromFirstWord nextSize holes
_ -> size
packFields :: [FieldDesc] -> [UnionDesc] -> (DataSectionSize, Integer, Map.Map Integer FieldOffset)
packFields fields unions = let
items = concat (
[(fieldNumber d, packField d) | d <- fields]:
[(unionNumber d, packUnion d):[(fieldNumber d2, packField d2) | d2 <- unionFields d]
| d <- unions])
itemsByNumber = List.sortBy compareNumbers items
compareNumbers (a, _) (b, _) = compare a b
(finalState, _, packedItems) =
foldl packItem (initialPackingState, Map.empty, []) itemsByNumber
packItem (state, unionState, packed) (n, item) =
(newState, newUnionState, (n, offset):packed) where
(offset, newState, newUnionState) = item state unionState
dataSectionSize =
if packingDataSize finalState == 1
then dataSizeToSectionSize $ stripHolesFromFirstWord Size64 $ packingHoles finalState
else DataSectionWords $ packingDataSize finalState
in (dataSectionSize, packingPointerCount finalState, Map.fromList packedItems)
enforceFixed Nothing sizes = return sizes
enforceFixed (Just (Located pos (requestedDataSize, requestedPointerCount)))
(actualDataSize, actualPointerCount) = do
validatedRequestedDataSize <- case requestedDataSize of
1 -> return DataSection1
8 -> return DataSection8
16 -> return DataSection16
32 -> return DataSection32
s | mod s 64 == 0 -> return $ DataSectionWords $ div s 64
_ -> makeError pos $ printf "Struct data section size must be 0, 1, 2, 4, or a multiple of \
\8 bytes."
recover () $ when (dataSectionBits actualDataSize > dataSectionBits validatedRequestedDataSize) $
makeError pos $ printf "Struct data section size is %s which exceeds specified maximum of \
\%s. WARNING: Increasing the maximum will break backwards-compatibility."
(dataSectionSizeString actualDataSize)
(dataSectionSizeString validatedRequestedDataSize)
recover () $ when (actualPointerCount > requestedPointerCount) $
makeError pos $ printf "Struct pointer section size is %d pointers which exceeds specified \
\maximum of %d pointers. WARNING: Increasing the maximum will break \
\backwards-compatibility."
actualPointerCount requestedPointerCount
recover () $ when (dataSectionBits actualDataSize > maxStructDataWords * 64) $
makeError pos $ printf "Struct is too big. Maximum data section size is %d bytes."
(maxStructDataWords * 8)
recover () $ when (actualPointerCount > maxStructPointers) $
makeError pos $ printf "Struct is too big. Maximum pointer section size is %d."
maxStructPointers
return (validatedRequestedDataSize, requestedPointerCount)
------------------------------------------------------------------------------------------
data CompiledStatementStatus = CompiledStatementStatus String (Status Desc)
compiledErrors (CompiledStatementStatus _ status) = statusErrors status
compileChildDecls :: Desc -> [Declaration]
-> Status ([Desc], MemberMap)
compileChildDecls desc decls = Active (members, memberMap) errors where
compiledDecls = map (compileDecl desc) decls
memberMap = Map.fromList memberPairs
members = [member | (_, Just member) <- memberPairs]
memberPairs = [(name, statusToMaybe status)
| CompiledStatementStatus name status <- compiledDecls]
errors = concatMap compiledErrors compiledDecls
compileDecl scope (UsingDecl (Located _ name) target) =
CompiledStatementStatus name (do
targetDesc <- lookupDesc scope target
return (DescUsing UsingDesc
{ usingName = name
, usingParent = scope
, usingTarget = targetDesc
}))
compileDecl scope (ConstantDecl (Located _ name) t annotations (Located valuePos value)) =
CompiledStatementStatus name (do
typeDesc <- compileType scope t
valueDesc <- compileValue valuePos typeDesc value
compiledAnnotations <- compileAnnotations scope ConstantAnnotation annotations
return (DescConstant ConstantDesc
{ constantName = name
, constantId = childId name Nothing scope
, constantParent = scope
, constantType = typeDesc
, constantValue = valueDesc
, constantAnnotations = compiledAnnotations
}))
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
compiledAnnotations <- compileAnnotations scope EnumAnnotation annotations
return (DescEnum EnumDesc
{ enumName = name
, enumId = childId name maybeTypeId scope
, enumParent = scope
, enumerants = [d | DescEnumerant d <- members]
, enumAnnotations = compiledAnnotations
, enumMemberMap = memberMap
, enumMembers = members
})))
compileDecl scope@(DescEnum parent)
(EnumerantDecl (Located _ name) (Located _ number) annotations) =
CompiledStatementStatus name (do
compiledAnnotations <- compileAnnotations scope EnumerantAnnotation annotations
return (DescEnumerant EnumerantDesc
{ enumerantName = name
, enumerantParent = parent
, enumerantNumber = number
, enumerantAnnotations = compiledAnnotations
}))
compileDecl _ (EnumerantDecl (Located pos name) _ _) =
CompiledStatementStatus name (makeError pos "Enumerants can only appear inside enums.")
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
compiledAnnotations <- compileAnnotations scope StructAnnotation annotations
let (dataSize, pointerCount, fieldPackingMap) = packFields fields unions
fields = [d | DescField d <- members]
unions = [d | DescUnion d <- members]
(finalDataSize, finalPointerCount) <-
recover (dataSize, pointerCount) $ enforceFixed isFixed (dataSize, pointerCount)
let memberByNumber d@(DescField f) = Just (fieldNumber f, d)
memberByNumber d@(DescUnion u) = Just (unionNumber u, d)
memberByNumber _ = Nothing
return (let
in DescStruct StructDesc
{ structName = name
, structId = childId name maybeTypeId scope
, structParent = scope
, structDataSize = finalDataSize
, structPointerCount = finalPointerCount
, structIsFixedWidth = isJust isFixed
, structFields = fields
, structUnions = unions
, structAnnotations = compiledAnnotations
, structMemberMap = memberMap
, structMembersByNumber = Map.fromList $ mapMaybe memberByNumber members
, structMembers = members
, structFieldPackingMap = fieldPackingMap
})))
compileDecl scope@(DescStruct parent)
(UnionDecl (Located _ name) (Located numPos number) annotations decls) =
CompiledStatementStatus name (feedback (\desc -> do
(members, memberMap) <- compileChildDecls desc decls
let fields = [f | DescField f <- members]
orderedFieldNumbers = List.sort $ map fieldNumber fields
discriminantMap = Map.fromList $ zip orderedFieldNumbers [0..]
requireNoMoreThanOneFieldNumberLessThan name numPos number fields
compiledAnnotations <- compileAnnotations scope UnionAnnotation annotations
return (let
DataOffset Size16 tagOffset = structFieldPackingMap parent ! number
in DescUnion UnionDesc
{ unionName = name
, unionParent = parent
, unionNumber = number
, unionTagOffset = tagOffset
, unionFields = fields
, unionAnnotations = compiledAnnotations
, unionMemberMap = memberMap
, unionMembers = members
, unionFieldDiscriminantMap = discriminantMap
})))
compileDecl _ (UnionDecl (Located pos name) _ _ _) =
CompiledStatementStatus name (makeError pos "Unions can only appear inside structs.")
compileDecl scope
(FieldDecl (Located pos name) (Located _ number) typeExp annotations defaultValue) =
CompiledStatementStatus name (do
parent <- case scope of
DescStruct s -> return s
DescUnion u -> return (unionParent u)
_ -> makeError pos "Fields can only appear inside structs."
let unionDesc = case scope of
DescUnion u -> Just (u, unionFieldDiscriminantMap u ! number)
_ -> Nothing
typeDesc <- compileType scope typeExp
recover () $ when (fieldSizeInBits (fieldSize typeDesc) > maxInlineFieldBits) $
makeError pos $ printf "Inlined fields cannot exceed %d bytes."
(div maxInlineFieldBits 8)
defaultDesc <- case defaultValue of
Just (Located defaultPos value) -> do
result <- fmap Just (compileValue defaultPos typeDesc value)
recover () (case typeDesc of
InlineStructType _ ->
makeError defaultPos "Inline fields cannot have default values."
InlineListType _ _ ->
makeError defaultPos "Inline fields cannot have default values."
InlineDataType _ ->
makeError defaultPos "Inline fields cannot have default values."
_ -> return ())
return result
Nothing -> return Nothing
compiledAnnotations <- compileAnnotations scope FieldAnnotation annotations
return (let
in DescField FieldDesc
{ fieldName = name
, fieldParent = parent
, fieldNumber = number
, fieldOffset = structFieldPackingMap parent ! number
, fieldUnion = unionDesc
, fieldType = typeDesc
, fieldDefaultValue = defaultDesc
, fieldAnnotations = compiledAnnotations
}))
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
compiledAnnotations <- compileAnnotations scope InterfaceAnnotation annotations
return (DescInterface InterfaceDesc
{ interfaceName = name
, interfaceId = childId name maybeTypeId scope
, interfaceParent = scope
, interfaceMethods = [d | DescMethod d <- members]
, interfaceAnnotations = compiledAnnotations
, interfaceMemberMap = memberMap
, interfaceMembers = members
})))
compileDecl scope@(DescInterface parent)
(MethodDecl (Located _ name) (Located _ number) params returnType annotations) =
CompiledStatementStatus name (feedback (\desc -> do
paramDescs <- doAll (map (compileParam desc) (zip [0..] params))
returnTypeDesc <- compileType scope returnType
compiledAnnotations <- compileAnnotations scope MethodAnnotation annotations
return (DescMethod MethodDesc
{ methodName = name
, methodParent = parent
, methodNumber = number
, methodParams = paramDescs
, methodReturnType = returnTypeDesc
, methodAnnotations = compiledAnnotations
})))
compileDecl _ (MethodDecl (Located pos name) _ _ _ _) =
CompiledStatementStatus name (makeError pos "Methods can only appear inside interfaces.")
compileDecl scope (AnnotationDecl (Located _ name) maybeTypeId typeExp annotations targets) =
CompiledStatementStatus name (do
typeDesc <- compileType scope typeExp
compiledAnnotations <- compileAnnotations scope AnnotationAnnotation annotations
return (DescAnnotation AnnotationDesc
{ annotationName = name
, annotationId = childId name maybeTypeId scope
, annotationParent = scope
, annotationType = typeDesc
, annotationAnnotations = compiledAnnotations
, annotationTargets = Set.fromList targets
}))
compileParam scope@(DescMethod parent)
(ordinal, ParamDecl name typeExp annotations defaultValue) = do
typeDesc <- compileType scope typeExp
defaultDesc <- case defaultValue of
Just (Located pos value) -> fmap Just (compileValue pos typeDesc value)
Nothing -> return Nothing
compiledAnnotations <- compileAnnotations scope ParamAnnotation annotations
return ParamDesc
{ paramName = name
, paramParent = parent
, paramNumber = ordinal
, paramType = typeDesc
, paramDefaultValue = defaultDesc
, paramAnnotations = compiledAnnotations
}
compileParam _ _ = error "scope of parameter was not a method"
compileFile name theId decls annotations importMap =
feedback (\desc -> do
(members, memberMap) <- compileChildDecls (DescFile desc) decls
requireNoDuplicateNames decls
compiledAnnotations <- compileAnnotations (DescFile desc) FileAnnotation annotations
return FileDesc
{ fileName = name
, fileId = locatedValue theId
, fileImports = Map.elems importMap
, fileRuntimeImports =
Set.fromList $ map fileName $ concatMap descRuntimeImports members
, fileAnnotations = compiledAnnotations
, fileMemberMap = memberMap
, fileImportMap = importMap
, fileMembers = members
})
dedup :: Ord a => [a] -> [a]
dedup = Set.toList . Set.fromList
emptyFileDesc filename = FileDesc
{ fileName = filename
, fileId = 0x0
, fileImports = []
, fileRuntimeImports = Set.empty
, fileAnnotations = Map.empty
, fileMemberMap = Map.empty
, fileImportMap = Map.empty
, fileMembers = []
}
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 randomCallback = do
let (maybeFileId, decls, annotations, parseErrors) = parseFile filename text
importNames = dedup $ concatMap declImports decls
doImport (Located pos name) = do
result <- importCallback name
case result of
Left desc -> return (succeed (name, desc))
Right err -> return $ recover (name, emptyFileDesc name)
(makeError pos (printf "Couldn't import \"%s\": %s" name err))
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.
-- Report errors from parsing.
-- We do the compile step even if there were errors in parsing, and just combine all the
-- errors together. This may allow the user to fix more errors per compiler iteration, but
-- it might also be confusing if a parse error causes a subsequent compile error,
-- especially if the compile error ends up being on a line before the parse error (e.g.
-- there's a parse error in a type definition, causing a not-defined error on a field
-- trying to use that type).
-- TODO: Re-evaluate after getting some experience on whether this is annoing.
Active () parseErrors
-- Report errors from imports.
-- Similar to the above, we're continuing with compiling even if imports fail, but the
-- problem above probably doesn't occur in this case since global imports usually appear
-- at the top of the file anyway. The only annoyance is seeing a long error log because
-- 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 theFileId decls annotations $ Map.fromList imports)
compiler/src/CxxGenerator.hs deleted 100644 → 0
View file @ ae33cf61
-- 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.
{-# LANGUAGE TemplateHaskell #-}
module CxxGenerator(generateCxx) where
import qualified Data.ByteString.UTF8 as ByteStringUTF8
import Data.FileEmbed(embedFile)
import Data.Word(Word8)
import qualified Data.Digest.MD5 as MD5
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.List as List
import Data.Maybe(catMaybes, mapMaybe)
import Data.Binary.IEEE754(floatToWord, doubleToWord)
import Data.Map((!))
import Data.Function(on)
import Text.Printf(printf)
import Text.Hastache
import Text.Hastache.Context
import qualified Codec.Binary.UTF8.String as UTF8
import System.FilePath(takeBaseName)
import Semantics
import Util
import WireFormat
-- MuNothing isn't considered a false value for the purpose of {{#variable}} expansion. Use this
-- instead.
muNull = MuBool False;
-- There is no way to make a MuType from a singular MuContext, i.e. for optional sub-contexts.
-- Using a single-element list has the same effect, though.
muJust c = MuList [c]
namespaceAnnotationId = 0xb9c6f99ebf805f2c
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 desc) = maybe " " (" ::" ++) $ fileNamespace desc
globalName desc = globalName (descParent desc) ++ "::" ++ descName desc
-- Flatten the descriptor tree in pre-order, returning struct, union, and interface descriptors
-- only.
flattenTypes :: [Desc] -> [Desc]
flattenTypes [] = []
flattenTypes (d@(DescStruct s):rest) = d:(flattenTypes children ++ flattenTypes rest) where
children = structMembers s
flattenTypes (d@(DescUnion u):rest) = d:(flattenTypes children ++ flattenTypes rest) where
children = unionMembers u
flattenTypes (d@(DescInterface i):rest) = d:(flattenTypes children ++ flattenTypes rest) where
children = interfaceMembers i
flattenTypes (d@(DescEnum _):rest) = d:flattenTypes rest
flattenTypes (_:rest) = flattenTypes rest
hashString :: String -> String
hashString str =
concatMap (printf "%02x" . fromEnum) $
MD5.hash $
UTF8.encode str
isPrimitive (BuiltinType BuiltinObject) = False
isPrimitive t@(BuiltinType _) = not $ isBlob t
isPrimitive (EnumType _) = True
isPrimitive (StructType _) = False
isPrimitive (InlineStructType _) = False
isPrimitive (InterfaceType _) = False
isPrimitive (ListType _) = False
isPrimitive (InlineListType _ _) = False
isPrimitive (InlineDataType _) = False
isBlob (BuiltinType BuiltinText) = True
isBlob (BuiltinType BuiltinData) = True
isBlob (InlineDataType _) = True
isBlob _ = False
isInlineBlob (InlineDataType _) = True
isInlineBlob _ = False
isStruct (StructType _) = True
isStruct (InlineStructType _) = True
isStruct _ = False
isInlineStruct (InlineStructType _) = True
isInlineStruct _ = False
isList (ListType _) = True
isList (InlineListType _ _) = True
isList _ = False
isNonStructList (ListType t) = not $ isStruct t
isNonStructList (InlineListType t _) = not $ isStruct t
isNonStructList _ = False
isPrimitiveList (ListType t) = isPrimitive t
isPrimitiveList (InlineListType t _) = isPrimitive t
isPrimitiveList _ = False
isPointerElement (InlineDataType _) = False
isPointerElement t = not (isPrimitive t || isStruct t || isInlineList t)
isPointerList (ListType t) = isPointerElement t
isPointerList (InlineListType t _) = isPointerElement t
isPointerList _ = False
isInlineBlobList (ListType t) = isInlineBlob t
isInlineBlobList _ = False
isStructList (ListType t@(InlineListType _ _)) = isStructList t
isStructList (InlineListType t@(InlineListType _ _) _) = isStructList t
isStructList (ListType t) = isStruct t
isStructList (InlineListType t _) = isStruct t
isStructList _ = False
isInlineList (InlineListType _ _) = True
isInlineList _ = False
isGenericObject (BuiltinType BuiltinObject) = True
isGenericObject _ = False
blobTypeString (BuiltinType BuiltinText) = "Text"
blobTypeString (BuiltinType BuiltinData) = "Data"
blobTypeString (InlineDataType _) = "Data"
blobTypeString (ListType t) = blobTypeString t
blobTypeString (InlineListType t _) = blobTypeString t
blobTypeString _ = error "Not a blob."
inlineMultiplier (InlineListType t s) = s * inlineMultiplier t
inlineMultiplier (InlineDataType s) = s
inlineMultiplier _ = 1
listInlineMultiplierString (ListType t) = case inlineMultiplier t of
1 -> ""
s -> " * " ++ show s
listInlineMultiplierString _ = error "Not a list."
cxxTypeString (BuiltinType BuiltinVoid) = " ::capnp::Void"
cxxTypeString (BuiltinType BuiltinBool) = "bool"
cxxTypeString (BuiltinType BuiltinInt8) = " ::int8_t"
cxxTypeString (BuiltinType BuiltinInt16) = " ::int16_t"
cxxTypeString (BuiltinType BuiltinInt32) = " ::int32_t"
cxxTypeString (BuiltinType BuiltinInt64) = " ::int64_t"
cxxTypeString (BuiltinType BuiltinUInt8) = " ::uint8_t"
cxxTypeString (BuiltinType BuiltinUInt16) = " ::uint16_t"
cxxTypeString (BuiltinType BuiltinUInt32) = " ::uint32_t"
cxxTypeString (BuiltinType BuiltinUInt64) = " ::uint64_t"
cxxTypeString (BuiltinType BuiltinFloat32) = "float"
cxxTypeString (BuiltinType BuiltinFloat64) = "double"
cxxTypeString (BuiltinType BuiltinText) = " ::capnp::Text"
cxxTypeString (BuiltinType BuiltinData) = " ::capnp::Data"
cxxTypeString (BuiltinType BuiltinObject) = " ::capnp::Object"
cxxTypeString (EnumType desc) = globalName $ DescEnum desc
cxxTypeString (StructType desc) = globalName $ DescStruct desc
cxxTypeString (InlineStructType desc) = globalName $ DescStruct desc
cxxTypeString (InterfaceType desc) = globalName $ DescInterface desc
cxxTypeString (ListType t) = concat [" ::capnp::List<", cxxTypeString t, ">"]
cxxTypeString (InlineListType t s) =
concat [" ::capnp::InlineList<", cxxTypeString t, ", ", show s, ">"]
cxxTypeString (InlineDataType s) =
concat [" ::capnp::InlineData<", show s, ">"]
cxxFieldSizeString SizeVoid = "VOID";
cxxFieldSizeString (SizeData Size1) = "BIT";
cxxFieldSizeString (SizeData Size8) = "BYTE";
cxxFieldSizeString (SizeData Size16) = "TWO_BYTES";
cxxFieldSizeString (SizeData Size32) = "FOUR_BYTES";
cxxFieldSizeString (SizeData Size64) = "EIGHT_BYTES";
cxxFieldSizeString SizePointer = "POINTER";
cxxFieldSizeString (SizeInlineComposite _ _) = "INLINE_COMPOSITE";
fieldOffsetInteger VoidOffset = "0"
fieldOffsetInteger (DataOffset _ o) = show o
fieldOffsetInteger (PointerOffset o) = show o
fieldOffsetInteger (InlineCompositeOffset d p ds ps) = let
byteSize = div (dataSectionBits ds) 8
byteOffset = case ds of
DataSectionWords _ -> d * 8
_ -> d * byteSize
in printf "%d * ::capnp::BYTES, %d * ::capnp::BYTES, \
\%d * ::capnp::POINTERS, %d * ::capnp::POINTERS" byteOffset byteSize p ps
isDefaultZero VoidDesc = True
isDefaultZero (BoolDesc b) = not b
isDefaultZero (Int8Desc i) = i == 0
isDefaultZero (Int16Desc i) = i == 0
isDefaultZero (Int32Desc i) = i == 0
isDefaultZero (Int64Desc i) = i == 0
isDefaultZero (UInt8Desc i) = i == 0
isDefaultZero (UInt16Desc i) = i == 0
isDefaultZero (UInt32Desc i) = i == 0
isDefaultZero (UInt64Desc i) = i == 0
isDefaultZero (Float32Desc x) = x == 0
isDefaultZero (Float64Desc x) = x == 0
isDefaultZero (EnumerantValueDesc v) = enumerantNumber v == 0
isDefaultZero (TextDesc _) = error "Can't call isDefaultZero on aggregate types."
isDefaultZero (DataDesc _) = error "Can't call isDefaultZero on aggregate types."
isDefaultZero (StructValueDesc _) = error "Can't call isDefaultZero on aggregate types."
isDefaultZero (ListDesc _) = error "Can't call isDefaultZero on aggregate types."
defaultMask VoidDesc = "0"
defaultMask (BoolDesc b) = if b then "true" else "false"
defaultMask (Int8Desc i) = show i
defaultMask (Int16Desc i) = show i
defaultMask (Int32Desc i) = show i
defaultMask (Int64Desc i) = show i ++ "ll"
defaultMask (UInt8Desc i) = show i
defaultMask (UInt16Desc i) = show i
defaultMask (UInt32Desc i) = show i ++ "u"
defaultMask (UInt64Desc i) = show i ++ "llu"
defaultMask (Float32Desc x) = show (floatToWord x) ++ "u"
defaultMask (Float64Desc x) = show (doubleToWord x) ++ "ul"
defaultMask (EnumerantValueDesc v) = show (enumerantNumber v)
defaultMask (TextDesc _) = error "Can't call defaultMask on aggregate types."
defaultMask (DataDesc _) = error "Can't call defaultMask on aggregate types."
defaultMask (StructValueDesc _) = error "Can't call defaultMask on aggregate types."
defaultMask (ListDesc _) = error "Can't call defaultMask on aggregate types."
defaultValueBytes _ (TextDesc s) = Just (UTF8.encode s ++ [0])
defaultValueBytes _ (DataDesc d) = Just d
defaultValueBytes t v@(StructValueDesc _) = Just $ encodeMessage t v
defaultValueBytes t v@(ListDesc _) = Just $ encodeMessage t v
defaultValueBytes _ _ = Nothing
elementType (ListType t) = t
elementType (InlineListType t _) = t
elementType _ = error "Called elementType on non-list."
inlineElementType (ListType t@(InlineListType _ _)) = inlineElementType t
inlineElementType (InlineListType t@(InlineListType _ _) _) = inlineElementType t
inlineElementType t = elementType t
repeatedlyTake _ [] = []
repeatedlyTake n l = take n l : repeatedlyTake n (drop n l)
typeDependencies (StructType s) = [structId s]
typeDependencies (EnumType e) = [enumId e]
typeDependencies (InterfaceType i) = [interfaceId i]
typeDependencies (ListType t) = typeDependencies t
typeDependencies _ = []
paramDependencies d = typeDependencies $ paramType d
descDependencies (DescStruct d) = concatMap descDependencies $ structMembers d
descDependencies (DescUnion d) = concatMap descDependencies $ unionMembers d
descDependencies (DescField d) = typeDependencies $ fieldType d
descDependencies (DescInterface d) = concatMap descDependencies $ interfaceMembers d
descDependencies (DescMethod d) =
concat $ typeDependencies (methodReturnType d) : map paramDependencies (methodParams d)
descDependencies _ = []
memberIndexes :: Int -> [(Int, Int)]
memberIndexes unionIndex = zip (repeat unionIndex) [0..]
memberTable (DescStruct desc) = let
-- Fields and unions of the struct.
topMembers = zip (memberIndexes 0) $ mapMaybe memberName
$ List.sortBy (compare `on` ordinal) $ structMembers desc
-- Fields of each union.
innerMembers = catMaybes $ zipWith indexedUnionMembers [1..]
$ List.sortBy (compare `on` ordinal) $ structMembers desc
ordinal (DescField f) = fieldNumber f
ordinal (DescUnion u) = unionNumber u
ordinal _ = 65536 -- doesn't really matter what this is; will be filtered out later
memberName (DescField f) = Just $ fieldName f
memberName (DescUnion u) = Just $ unionName u
memberName _ = Nothing
indexedUnionMembers i (DescUnion u) =
Just $ zip (memberIndexes i) $ mapMaybe memberName $
List.sortBy (compare `on` ordinal) $ unionMembers u
indexedUnionMembers _ _ = Nothing
in concat $ topMembers : innerMembers
memberTable (DescEnum desc) = zip (memberIndexes 0) $ map enumerantName
$ List.sortBy (compare `on` enumerantNumber) $ enumerants desc
memberTable (DescInterface desc) = zip (memberIndexes 0) $ map methodName
$ List.sortBy (compare `on` methodNumber) $ interfaceMethods desc
memberTable _ = []
outerFileContext schemaNodes = fileContext where
schemaDepContext parent i = mkStrContext context where
context "dependencyId" = MuVariable (printf "%016x" i :: String)
context s = parent s
schemaMemberByNameContext parent (ui, mi) = mkStrContext context where
context "memberUnionIndex" = MuVariable ui
context "memberIndex" = MuVariable mi
context s = parent s
schemaContext parent desc = mkStrContext context where
node = schemaNodes ! descId desc
codeLines = map (delimit ", ") $ repeatedlyTake 8 $ map (printf "%3d") node
depIds = map head $ List.group $ List.sort $ descDependencies desc
membersByName = map fst $ List.sortBy (compare `on` memberByNameKey) $ memberTable desc
memberByNameKey ((unionIndex, _), name) = (unionIndex, name)
context "schemaWordCount" = MuVariable $ div (length node + 7) 8
context "schemaBytes" = MuVariable $ delimit ",\n " codeLines
context "schemaId" = MuVariable (printf "%016x" (descId desc) :: String)
context "schemaDependencyCount" = MuVariable $ length depIds
context "schemaDependencies" =
MuList $ map (schemaDepContext context) depIds
context "schemaMemberCount" = MuVariable $ length membersByName
context "schemaMembersByName" =
MuList $ map (schemaMemberByNameContext context) membersByName
context s = parent s
enumerantContext parent desc = mkStrContext context where
context "enumerantName" = MuVariable $ toUpperCaseWithUnderscores $ enumerantName desc
context "enumerantNumber" = MuVariable $ enumerantNumber desc
context s = parent s
enumContext parent desc = mkStrContext context where
context "enumName" = MuVariable $ enumName desc
context "enumId" = MuVariable (printf "%016x" (enumId desc) ::String)
context "enumerants" = MuList $ map (enumerantContext context) $ enumerants desc
context s = parent s
defaultBytesContext :: Monad m => (String -> MuType m) -> TypeDesc -> [Word8] -> MuContext m
defaultBytesContext parent t bytes = mkStrContext context where
codeLines = map (delimit ", ") $ repeatedlyTake 8 $ map (printf "%3d") bytes
context "defaultByteList" = MuVariable $ delimit ",\n " codeLines
context "defaultWordCount" = MuVariable $ div (length bytes + 7) 8
context "defaultBlobSize" = case t of
BuiltinType BuiltinText -> MuVariable (length bytes - 1) -- Don't include NUL terminator.
BuiltinType BuiltinData -> MuVariable (length bytes)
_ -> error "defaultBlobSize used on non-blob."
context s = parent s
descDecl desc = head $ lines $ descToCode "" desc
fieldContext parent desc = mkStrContext context where
context "fieldName" = MuVariable $ fieldName desc
context "fieldDecl" = MuVariable $ descDecl $ DescField desc
context "fieldTitleCase" = MuVariable $ toTitleCase $ fieldName desc
context "fieldUpperCase" = MuVariable $ toUpperCaseWithUnderscores $ fieldName desc
context "fieldIsPrimitive" = MuBool $ isPrimitive $ fieldType desc
context "fieldIsListOrBlob" = MuBool $ isBlob (fieldType desc) || isList (fieldType desc)
context "fieldIsBlob" = MuBool $ isBlob $ fieldType desc
context "fieldIsInlineBlob" = MuBool $ isInlineBlob $ fieldType desc
context "fieldIsStruct" = MuBool $ isStruct $ fieldType desc
context "fieldIsInlineStruct" = MuBool $ isInlineStruct $ fieldType desc
context "fieldIsList" = MuBool $ isList $ fieldType desc
context "fieldIsNonStructList" = MuBool $ isNonStructList $ fieldType desc
context "fieldIsPrimitiveList" = MuBool $ isPrimitiveList $ fieldType desc
context "fieldIsPointerList" = MuBool $ isPointerList $ fieldType desc
context "fieldIsInlineBlobList" = MuBool $ isInlineBlobList $ fieldType desc
context "fieldIsStructList" = MuBool $ isStructList $ fieldType desc
context "fieldIsInlineList" = MuBool $ isInlineList $ fieldType desc
context "fieldIsGenericObject" = MuBool $ isGenericObject $ fieldType desc
context "fieldDefaultBytes" =
case fieldDefaultValue desc >>= defaultValueBytes (fieldType desc) of
Just v -> muJust $ defaultBytesContext context (fieldType desc) v
Nothing -> muNull
context "fieldType" = MuVariable $ cxxTypeString $ fieldType desc
context "fieldBlobType" = MuVariable $ blobTypeString $ fieldType desc
context "fieldOffset" = MuVariable $ fieldOffsetInteger $ fieldOffset desc
context "fieldInlineListSize" = case fieldType desc of
InlineListType _ n -> MuVariable n
InlineDataType n -> MuVariable n
_ -> muNull
context "fieldInlineDataOffset" = case fieldOffset desc of
InlineCompositeOffset off _ size _ ->
MuVariable (off * div (dataSizeInBits (dataSectionAlignment size)) 8)
_ -> muNull
context "fieldInlineDataSize" = case fieldOffset desc of
InlineCompositeOffset _ _ size _ ->
MuVariable $ div (dataSectionBits size) 8
_ -> muNull
context "fieldInlinePointerOffset" = case fieldOffset desc of
InlineCompositeOffset _ off _ _ -> MuVariable off
_ -> muNull
context "fieldInlinePointerSize" = case fieldOffset desc of
InlineCompositeOffset _ _ _ size -> MuVariable size
_ -> muNull
context "fieldInlineMultiplier" = MuVariable $ listInlineMultiplierString $ fieldType desc
context "fieldDefaultMask" = case fieldDefaultValue desc of
Nothing -> MuVariable ""
Just v -> MuVariable (if isDefaultZero v then "" else ", " ++ defaultMask v)
context "fieldElementSize" =
MuVariable $ cxxFieldSizeString $ fieldSize $ inlineElementType $ fieldType desc
context "fieldElementType" =
MuVariable $ cxxTypeString $ elementType $ fieldType desc
context "fieldElementReaderType" = MuVariable readerString where
readerString = if isPrimitiveList $ fieldType desc
then tString
else tString ++ "::Reader"
tString = cxxTypeString $ elementType $ fieldType desc
context "fieldInlineElementType" =
MuVariable $ cxxTypeString $ inlineElementType $ fieldType desc
context "fieldUnion" = case fieldUnion desc of
Just (u, _) -> muJust $ unionContext context u
Nothing -> muNull
context "fieldUnionDiscriminant" = case fieldUnion desc of
Just (_, n) -> MuVariable n
Nothing -> muNull
context "fieldSetterDefault" = case fieldType desc of
BuiltinType BuiltinVoid -> MuVariable " = ::capnp::Void::VOID"
_ -> MuVariable ""
context s = parent s
unionContext parent desc = mkStrContext context where
titleCase = toTitleCase $ unionName desc
unionIndex = Map.findIndex (unionNumber desc) $ structMembersByNumber $ unionParent desc
context "typeStruct" = MuBool False
context "typeUnion" = MuBool True
context "typeName" = MuVariable titleCase
context "typeFullName" = context "unionFullName"
context "typeFields" = context "unionFields"
context "unionName" = MuVariable $ unionName desc
context "unionFullName" = MuVariable $ fullName (DescStruct $ unionParent desc) ++
"::" ++ titleCase
context "unionDecl" = MuVariable $ descDecl $ DescUnion desc
context "unionTitleCase" = MuVariable titleCase
context "unionTagOffset" = MuVariable $ unionTagOffset desc
context "unionFields" = MuList $ map (fieldContext context) $ unionFields desc
context "unionIndex" = MuVariable unionIndex
context s = parent s
childContext parent name = mkStrContext context where
context "nestedName" = MuVariable name
context s = parent s
structContext parent desc = mkStrContext context where
context "typeStruct" = MuBool True
context "typeUnion" = MuBool False
context "typeName" = context "structName"
context "typeFullName" = context "structFullName"
context "typeFields" = context "structFields"
context "structName" = MuVariable $ structName desc
context "structId" = MuVariable (printf "%016x" (structId desc) ::String)
context "structFullName" = MuVariable $ fullName (DescStruct desc)
context "structFields" = MuList $ map (fieldContext context) $ structFields desc
context "structUnions" = MuList $ map (unionContext context) $ structUnions desc
context "structDataSize" = MuVariable $ dataSectionWordSize $ structDataSize desc
context "structPointerCount" = MuVariable $ structPointerCount desc
context "structPreferredListEncoding" = case (structDataSize desc, structPointerCount desc) of
(DataSectionWords 0, 0) -> MuVariable "VOID"
(DataSection1, 0) -> MuVariable "BIT"
(DataSection8, 0) -> MuVariable "BYTE"
(DataSection16, 0) -> MuVariable "TWO_BYTES"
(DataSection32, 0) -> MuVariable "FOUR_BYTES"
(DataSectionWords 1, 0) -> MuVariable "EIGHT_BYTES"
(DataSectionWords 0, 1) -> MuVariable "POINTER"
_ -> MuVariable "INLINE_COMPOSITE"
context "structNestedEnums" =
MuList $ map (enumContext context) [m | DescEnum m <- structMembers desc]
context "structNestedStructs" =
MuList $ map (childContext context . structName) [m | DescStruct m <- structMembers desc]
context "structNestedInterfaces" =
MuList $ map (childContext context . interfaceName) [m | DescInterface m <- structMembers desc]
context s = parent s
typeContext parent desc = mkStrContext context where
context "typeStructOrUnion" = case desc of
DescStruct d -> muJust $ structContext context d
DescUnion u -> muJust $ unionContext context u
_ -> muNull
context "typeEnum" = case desc of
DescEnum d -> muJust $ enumContext context d
_ -> muNull
context "typeSchema" = case desc of
DescUnion _ -> muNull
_ -> muJust $ schemaContext context desc
context s = parent s
importContext parent ('/':filename) = mkStrContext context where
context "importFilename" = MuVariable filename
context "importIsSystem" = MuBool True
context s = parent s
importContext parent filename = mkStrContext context where
context "importFilename" = MuVariable filename
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 $ fileMembers desc
namespace = maybe [] (splitOn "::") $ fileNamespace desc
isImportUsed (_, dep) = Set.member (fileName dep) (fileRuntimeImports desc)
context "fileName" = MuVariable $ fileName desc
context "fileBasename" = MuVariable $ takeBaseName $ fileName desc
context "fileIncludeGuard" = MuVariable $
"CAPNP_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
context "fileImports" = MuList $ map (importContext context . fst)
$ filter isImportUsed $ Map.toList $ fileImportMap desc
context s = error ("Template variable not defined: " ++ s)
headerTemplate :: String
headerTemplate = ByteStringUTF8.toString $(embedFile "src/c++-header.mustache")
srcTemplate :: String
srcTemplate = ByteStringUTF8.toString $(embedFile "src/c++-source.mustache")
-- Sadly it appears that hashtache requires access to the IO monad, even when template inclusion
-- is disabled.
hastacheConfig :: MuConfig IO
hastacheConfig = MuConfig
{ muEscapeFunc = emptyEscape
, muTemplateFileDir = Nothing
, muTemplateFileExt = Nothing
, muTemplateRead = \_ -> return Nothing
}
generateCxxHeader file schemaNodes =
hastacheStr hastacheConfig (encodeStr headerTemplate) (outerFileContext schemaNodes file)
generateCxxSource file schemaNodes =
hastacheStr hastacheConfig (encodeStr srcTemplate) (outerFileContext schemaNodes file)
generateCxx files _ schemaNodes = do
let handleFile file = do
header <- generateCxxHeader file schemaNodes
source <- generateCxxSource file schemaNodes
return [(fileName file ++ ".h", header), (fileName file ++ ".c++", source)]
results <- mapM handleFile files
return $ concat results
compiler/src/Grammar.hs deleted 100644 → 0
View file @ ae33cf61
-- 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.
module Grammar where
import Token (Located)
import Data.Maybe (maybeToList)
import Data.Word (Word64)
data DeclName = AbsoluteName (Located String)
| RelativeName (Located String)
| ImportName (Located String)
| MemberName DeclName (Located String)
deriving (Show)
declNameImport :: DeclName -> Maybe (Located String)
declNameImport (AbsoluteName _) = Nothing
declNameImport (RelativeName _) = Nothing
declNameImport (ImportName s) = Just s
declNameImport (MemberName parent _) = declNameImport parent
data TypeParameter = TypeParameterType TypeExpression
| TypeParameterInteger Integer
deriving (Show)
data TypeExpression = TypeExpression DeclName [TypeParameter]
deriving (Show)
typeParameterImports :: TypeParameter -> [Located String]
typeParameterImports (TypeParameterType t) = typeImports t
typeParameterImports (TypeParameterInteger _) = []
typeImports :: TypeExpression -> [Located String]
typeImports (TypeExpression name params) =
maybeToList (declNameImport name) ++ concatMap typeParameterImports params
data Annotation = Annotation DeclName (Located FieldValue) deriving(Show)
annotationImports (Annotation name _) = maybeToList $ declNameImport name
data FieldValue = VoidFieldValue
| BoolFieldValue Bool
| IntegerFieldValue Integer
| FloatFieldValue Double
| StringFieldValue String
| IdentifierFieldValue String
| ListFieldValue [Located FieldValue]
| RecordFieldValue [(Located String, Located FieldValue)]
| UnionFieldValue String FieldValue
deriving (Show)
data ParamDecl = ParamDecl String TypeExpression [Annotation] (Maybe (Located FieldValue))
deriving (Show)
paramImports (ParamDecl _ t ann _) = typeImports t ++ concatMap annotationImports ann
data AnnotationTarget = FileAnnotation
| ConstantAnnotation
| EnumAnnotation
| EnumerantAnnotation
| StructAnnotation
| FieldAnnotation
| UnionAnnotation
| InterfaceAnnotation
| MethodAnnotation
| ParamAnnotation
| AnnotationAnnotation
deriving(Eq, Ord, Bounded, Enum)
instance Show AnnotationTarget where
show FileAnnotation = "file"
show ConstantAnnotation = "const"
show EnumAnnotation = "enum"
show EnumerantAnnotation = "enumerant"
show StructAnnotation = "struct"
show FieldAnnotation = "field"
show UnionAnnotation = "union"
show InterfaceAnnotation = "interface"
show MethodAnnotation = "method"
show ParamAnnotation = "param"
show AnnotationAnnotation = "annotation"
data Declaration = UsingDecl (Located String) DeclName
| ConstantDecl (Located String) TypeExpression [Annotation] (Located FieldValue)
| EnumDecl (Located String) (Maybe (Located Word64)) [Annotation] [Declaration]
| EnumerantDecl (Located String) (Located Integer) [Annotation]
| 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) (Maybe (Located Word64))
[Annotation] [Declaration]
| MethodDecl (Located String) (Located Integer) [ParamDecl]
TypeExpression [Annotation]
| 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 (EnumerantDecl n _ _) = Just n
declarationName (StructDecl n _ _ _ _) = Just n
declarationName (FieldDecl n _ _ _ _) = Just n
declarationName (UnionDecl n _ _ _) = Just n
declarationName (InterfaceDecl n _ _ _) = Just n
declarationName (MethodDecl n _ _ _ _) = Just n
declarationName (AnnotationDecl n _ _ _ _) = Just n
declImports :: Declaration -> [Located String]
declImports (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 (EnumerantDecl _ _ ann) = concatMap annotationImports ann
declImports (StructDecl _ _ _ ann decls) = concatMap annotationImports ann ++
concatMap declImports decls
declImports (FieldDecl _ _ t ann _) = typeImports t ++ concatMap annotationImports ann
declImports (UnionDecl _ _ ann decls) = concatMap annotationImports ann ++
concatMap declImports decls
declImports (InterfaceDecl _ _ ann decls) = concatMap annotationImports ann ++
concatMap declImports decls
declImports (MethodDecl _ _ params t ann) =
concat [concatMap paramImports params, typeImports t, concatMap annotationImports ann]
declImports (AnnotationDecl _ _ t ann _) = typeImports t ++ concatMap annotationImports ann
compiler/src/Lexer.hs deleted 100644 → 0
View file @ ae33cf61
-- 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.
module Lexer (lexer) where
import Text.Parsec hiding (token, tokens)
import Text.Parsec.String
import Control.Monad (liftM, when)
import qualified Text.Parsec.Token as T
import Text.Parsec.Language (emptyDef)
import Token
import Data.Char (isUpper, isLower)
keywords =
[ (VoidKeyword, "void")
, (TrueKeyword, "true")
, (FalseKeyword, "false")
, (InKeyword, "in")
, (OfKeyword, "of")
, (OnKeyword, "on")
, (AsKeyword, "as")
, (WithKeyword, "with")
, (FromKeyword, "from")
, (ImportKeyword, "import")
, (UsingKeyword, "using")
, (ConstKeyword, "const")
, (EnumKeyword, "enum")
, (StructKeyword, "struct")
, (UnionKeyword, "union")
, (InterfaceKeyword, "interface")
, (AnnotationKeyword, "annotation")
-- , (FixedKeyword, "fixed") -- Inlines have been disabled because they were too complicated.
]
languageDef :: T.LanguageDef st
languageDef = emptyDef
{ T.commentLine = "#"
, T.identStart = letter <|> char '_'
, T.identLetter = alphaNum <|> char '_'
, T.reservedNames = [name | (_, name) <- keywords]
, T.opStart = T.opLetter languageDef
, T.opLetter = fail "There are no operators."
}
tokenParser = T.makeTokenParser languageDef
rawIdentifier = T.identifier tokenParser
reserved = T.reserved tokenParser
symbol = T.symbol tokenParser
naturalOrFloat = T.naturalOrFloat tokenParser
braces = T.braces tokenParser
parens = T.parens tokenParser
brackets = T.brackets tokenParser
whiteSpace = T.whiteSpace tokenParser
stringLiteral = T.stringLiteral tokenParser
keyword :: Parser Token
keyword = foldl1 (<|>) [reserved name >> return t | (t, name) <- keywords]
toLiteral :: Either Integer Double -> Token
toLiteral (Left i) = LiteralInt i
toLiteral (Right d) = LiteralFloat d
located :: Parser t -> Parser (Located t)
located p = do
pos <- getPosition
t <- p
return (Located pos t)
isTypeName (c:_) = isUpper c
isTypeName _ = False
hasUppercaseAcronym (a:rest@(b:c:_)) =
(isUpper a && isUpper b && not (isLower c)) || hasUppercaseAcronym rest
hasUppercaseAcronym (a:b:[]) = isUpper a && isUpper b
hasUppercaseAcronym _ = False
identifier :: Parser Token
identifier = do
text <- rawIdentifier
when (elem '_' text) $
fail "Identifiers containing underscores are reserved for the implementation. Use \
\camelCase style for multi-word names."
when (hasUppercaseAcronym text) $
fail "Wrong style: Only the first letter of an acronym should be capitalized. \
\Consistent style is necessary to allow code generators to sanely translate \
\names into the target language's preferred style."
return (if isTypeName text then TypeIdentifier text else Identifier text)
tokenSequence = do
tokens <- many1 locatedToken
endPos <- getPosition
return (TokenSequence tokens endPos)
token :: Parser Token
token = keyword
<|> identifier
<|> liftM ParenthesizedList (parens (sepBy tokenSequence (symbol ",")))
<|> liftM BracketedList (brackets (sepBy tokenSequence (symbol ",")))
<|> liftM toLiteral naturalOrFloat
<|> liftM LiteralString stringLiteral
<|> liftM (const AtSign) (symbol "@")
<|> liftM (const Colon) (symbol ":")
<|> liftM (const DollarSign) (symbol "$")
<|> liftM (const Period) (symbol ".")
<|> liftM (const EqualsSign) (symbol "=")
<|> liftM (const MinusSign) (symbol "-")
<|> liftM (const Asterisk) (symbol "*")
<|> liftM (const ExclamationPoint) (symbol "!")
<?> "token"
locatedToken = located token
statementEnd :: Parser (Maybe [Located Statement])
statementEnd = (symbol ";" >>= \_ -> return Nothing)
<|> (braces (many locatedStatement) >>= \statements -> return (Just statements))
compileStatement :: TokenSequence -> Maybe [Located Statement] -> Statement
compileStatement tokens Nothing = Line tokens
compileStatement tokens (Just statements) = Block tokens statements
statement :: Parser Statement
statement = do
tokens <- tokenSequence
end <- statementEnd
return (compileStatement tokens end)
locatedStatement = located statement
lexer :: Parser [Located Statement]
lexer = do
whiteSpace
tokens <- many locatedStatement
eof
return tokens
compiler/src/Main.hs deleted 100644 → 0
View file @ ae33cf61
-- 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.
module Main ( main ) where
import System.Environment
import System.Console.GetOpt
import System.Exit(exitFailure, exitSuccess, ExitCode(..))
import System.IO(hPutStr, stderr, hSetBinaryMode, hClose)
import System.FilePath(takeDirectory)
import System.Directory(createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
import System.Entropy(getEntropy)
import System.Process(createProcess, proc, std_in, cwd, StdStream(CreatePipe), waitForProcess)
import Control.Monad
import Control.Monad.IO.Class(MonadIO, liftIO)
import Control.Exception(IOException, catch)
import Control.Monad.Trans.State(StateT, state, modify, evalStateT)
import qualified Control.Monad.Trans.State as State
import Prelude hiding (catch)
import Compiler
import Util(delimit)
import Text.Parsec.Pos
import Text.Parsec.Error
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, pack, hPut)
import Data.Word(Word64, Word8)
import Data.Maybe(fromMaybe, catMaybes, mapMaybe)
import Data.Function(on)
import Semantics
import WireFormat(encodeSchema)
import CxxGenerator(generateCxx)
import Paths_capnproto_compiler
import Data.Version(showVersion)
type GeneratorFn = [FileDesc] -> [Word8] -> Map.Map Word64 [Word8] -> IO [(FilePath, LZ.ByteString)]
generatorFns :: Map.Map String GeneratorFn
generatorFns = Map.fromList [ ("c++", generateCxx) ]
data Opt = SearchPathOpt FilePath
| OutputOpt String GeneratorFn FilePath
| SrcPrefixOpt String
| VerboseOpt
| HelpOpt
| VersionOpt
| GenIdOpt
main :: IO ()
main = do
let optionDescs =
[ Option "I" ["import-path"] (ReqArg SearchPathOpt "DIR")
"Search DIR for absolute imports."
, Option "" ["src-prefix"] (ReqArg SrcPrefixOpt "PREFIX")
"Prefix directory to strip off of source\n\
\file names before generating output file\n\
\names."
, Option "o" ["output"] (ReqArg parseOutputArg "LANG[:DIR]")
("Generate output for language LANG\n\
\to directory DIR (default: current\n\
\directory). LANG may be any of:\n\
\ " ++ unwords (Map.keys generatorFns) ++ "\n\
\or a plugin name.")
, 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 "" ["version"] (NoArg VersionOpt) "Print version number and exit."
]
let usage = usageInfo
"capnpc [OPTION]... [FILE]...\n\
\Generate source code based on Cap'n Proto definition FILEs.\n"
optionDescs
args <- getArgs
let (options, files, errs) = getOpt Permute optionDescs args
unless (null errs) (do
mapM_ (hPutStr stderr) errs
hPutStr stderr usage
exitFailure)
when (null options) (do
hPutStr stderr "Nothing to do.\n"
hPutStr stderr usage
exitFailure)
let isHelp = not $ null [opt | opt@HelpOpt <- options]
when isHelp (do
putStr usage
exitSuccess)
let isVersion = not $ null [opt | opt@VersionOpt <- options]
when isVersion (do
putStr ("Cap'n Proto Compiler " ++ showVersion Paths_capnproto_compiler.version ++ "\n")
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 _ fn dir <- options]
-- TODO(someday): We should perhaps determine the compiler binary's location and search its
-- ../include as well. Also, there should perhaps be a way to tell the compiler not to search
-- these hard-coded default paths.
let searchPath = [dir | SearchPathOpt dir <- options] ++
["/usr/local/include", "/usr/include"]
srcPrefixes = [addTrailingSlash prefix | SrcPrefixOpt prefix <- options]
addTrailingSlash path =
if not (null path) && last path /= '/'
then path ++ "/"
else path
let verifyDirectoryExists dir = do
exists <- doesDirectoryExist dir
unless exists (do
hPutStr stderr $ printf "no such directory: %s\n" dir
exitFailure)
mapM_ verifyDirectoryExists [dir | (_, dir) <- outputs]
(failed, requestedFiles, allFiles) <-
evalStateT (handleFiles isVerbose searchPath files)
(CompilerState False Map.empty)
let (schema, schemaNodes) = encodeSchema requestedFiles allFiles
toEntry ((i, _), node) = (i, node)
schemaMap = Map.fromList $ map toEntry schemaNodes
areDupes (i, _) (j, _) = i == j
dupes = filter (\x -> length x > 1) $ List.groupBy areDupes
$ List.sortBy (compare `on` fst) $ map fst schemaNodes
unless (null dupes) (do
hPutStr stderr $ concat
("Duplicate type / delcaration IDs detected:\n":
map (concatMap (uncurry $ printf " @0x%016x %s\n")) dupes)
hPutStr stderr
"IDs (16-digit hex strings prefixed with @0x) must be unique. Sorry I'm not\n\
\able to be more specific about where the duplicates were seen, but it should\n\
\be easy enough to grep, right?\n"
exitFailure)
mapM_ (doOutput requestedFiles srcPrefixes schema schemaMap) outputs
when failed exitFailure
handleFiles isVerbose searchPath files = do
requestedFiles <- liftM catMaybes $ mapM (handleFile isVerbose searchPath) files
CompilerState failed importMap <- State.get
return (failed, requestedFiles, [ file | (_, ImportSucceeded file) <- Map.toList importMap ])
parseOutputArg :: String -> Opt
parseOutputArg str = let
generatorFn lang wd = fromMaybe (callPlugin lang wd) $ Map.lookup lang generatorFns
in case List.elemIndex ':' str of
Just i -> let
(lang, _:dir) = splitAt i str
in OutputOpt lang (generatorFn lang (Just dir)) dir
Nothing -> OutputOpt str (generatorFn str Nothing) "."
pluginName lang = if '/' `elem` lang then lang else "capnpc-" ++ lang
callPlugin lang wd _ schema _ = do
(Just hin, _, _, p) <- createProcess (proc (pluginName lang) [])
{ std_in = CreatePipe, cwd = wd }
hSetBinaryMode hin True
hPut hin (pack schema)
hClose hin
exitCode <- waitForProcess p
case exitCode of
ExitFailure 126 -> do
_ <- printf "Plugin for language '%s' is not executable.\n" lang
exitFailure
ExitFailure 127 -> do
_ <- printf "No plugin found for language '%s'.\n" lang
exitFailure
ExitFailure i -> do
_ <- printf "Plugin for language '%s' failed with exit code: %d\n" lang i
exitFailure
ExitSuccess -> return []
-- As always, here I am, writing my own path manipulation routines, because the ones in the
-- standard lib don't do what I want.
canonicalizePath :: [String] -> [String]
-- An empty string anywhere other than the beginning must be caused by multiple consecutive /'s.
canonicalizePath (a:"":rest) = canonicalizePath (a:rest)
-- An empty string at the beginning means this is an absolute path.
canonicalizePath ("":rest) = "":canonicalizePath rest
-- "." is redundant.
canonicalizePath (".":rest) = canonicalizePath rest
-- ".." at the beginning of the path refers to the parent of the root directory. Arguably this
-- is illegal but let's at least make sure that "../../foo" doesn't canonicalize to "foo"!
canonicalizePath ("..":rest) = "..":canonicalizePath rest
-- ".." cancels out the previous path component. Technically this does NOT match what the OS would
-- do in the presence of symlinks: `foo/bar/..` is NOT `foo` if `bar` is a symlink. But, in
-- practice, the user almost certainly wants symlinks to behave exactly the same as if the
-- directory had been copied into place.
canonicalizePath (_:"..":rest) = canonicalizePath rest
-- In all other cases, just proceed on.
canonicalizePath (a:rest) = a:canonicalizePath rest
-- All done.
canonicalizePath [] = []
splitPath = loop [] where
loop part ('/':text) = List.reverse part : loop [] text
loop part (c:text) = loop (c:part) text
loop part [] = [List.reverse part]
relativePath from searchPath relative = let
splitFrom = canonicalizePath $ splitPath from
splitRelative = canonicalizePath $ splitPath relative
splitSearchPath = map splitPath searchPath
-- TODO: Should we explicitly disallow "/../foo"?
resultPath = if head splitRelative == ""
then map (++ tail splitRelative) splitSearchPath
else [canonicalizePath (init splitFrom ++ splitRelative)]
in map (List.intercalate "/") resultPath
firstExisting :: [FilePath] -> IO (Maybe FilePath)
firstExisting paths = do
bools <- mapM doesFileExist paths
let existing = [path | (True, path) <- zip bools paths]
return (if null existing then Nothing else Just (head existing))
data ImportState = ImportInProgress | ImportFailed | ImportSucceeded FileDesc
type ImportStateMap = Map.Map String ImportState
data CompilerState = CompilerState Bool ImportStateMap
type CompilerMonad a = StateT CompilerState IO a
importFile :: Bool -> [FilePath] -> FilePath -> CompilerMonad (Either FileDesc String)
importFile isVerbose searchPath filename = do
fileState <- state (\s@(CompilerState f m) -> case Map.lookup filename m of
d@Nothing -> (d, CompilerState f (Map.insert filename ImportInProgress m))
d -> (d, s))
case fileState of
Just ImportFailed -> return $ Right "File contained errors."
Just ImportInProgress -> return $ Right "File cyclically imports itself."
Just (ImportSucceeded d) -> return $ Left d
Nothing -> do
result <- readAndParseFile isVerbose searchPath filename
modify (\(CompilerState f m) -> case result of
Left desc -> CompilerState f (Map.insert filename (ImportSucceeded desc) m)
Right _ -> CompilerState True (Map.insert filename ImportFailed m))
return result
readAndParseFile isVerbose searchPath filename = do
textOrError <- liftIO $ catch (fmap Left $ readFile filename)
(\ex -> return $ Right $ show (ex :: IOException))
case textOrError of
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
maybePath <- liftIO $ firstExisting candidates
case maybePath of
Nothing -> return $ Right "File not found."
Just path -> importFile isVerbose searchPath path
status <- parseAndCompileFile filename text importCallback generateId
case status of
Active desc [] -> do
when isVerbose (liftIO $ print desc)
return $ Left desc
Active _ e -> do
liftIO $ mapM_ printError (List.sortBy compareErrors e)
return $ Right "File contained errors."
Failed e -> do
liftIO $ mapM_ printError (List.sortBy compareErrors e)
return $ Right "File contained errors."
handleFile :: Bool -> [FilePath] -> FilePath -> CompilerMonad (Maybe FileDesc)
handleFile isVerbose searchPath filename = do
result <- importFile isVerbose searchPath filename
case result of
Right e -> do
liftIO $ hPutStr stderr (e ++ "\n")
return Nothing
Left desc -> return $ Just desc
doOutput requestedFiles srcPrefixes schema schemaMap output = do
let write dir (name, content) = do
let strippedOptions = mapMaybe (flip List.stripPrefix name) srcPrefixes
stripped = if null strippedOptions then name else
List.minimumBy (compare `on` length) strippedOptions
outFilename = dir ++ "/" ++ stripped
createDirectoryIfMissing True $ takeDirectory outFilename
LZ.writeFile outFilename content
generate (generatorFn, dir) = do
files <- generatorFn requestedFiles schema schemaMap
mapM_ (write dir) files
liftIO $ generate output
compareErrors a b = compare (errorPos a) (errorPos b)
-- TODO: This is a fairly hacky way to make showErrorMessages' output not suck. We could do better
-- by interpreting the error structure ourselves.
printError e = hPutStr stderr $ printf "%s:%d:%d: error: %s\n" f l c m' where
pos = errorPos e
f = sourceName pos
l = sourceLine pos
c = sourceColumn pos
m = showErrorMessages "or" "Unknown parse error" "Expected" "Unexpected" "end of expression"
(errorMessages e)
m' = delimit "; " (List.filter (not . null) (lines m))
compiler/src/Parser.hs deleted 100644 → 0
View file @ ae33cf61
-- 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.
module Parser (parseFile) where
import Data.Generics
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)
import Control.Monad.Identity
tokenParser :: (Located Token -> Maybe a) -> Parsec [Located Token] u a
tokenParser = token (tokenErrorString . locatedValue) locatedPos
tokenErrorString (Identifier s) = "identifier \"" ++ s ++ "\""
tokenErrorString (TypeIdentifier s) = "type identifier \"" ++ s ++ "\""
tokenErrorString (ParenthesizedList _) = "parenthesized list"
tokenErrorString (BracketedList _) = "bracketed list"
tokenErrorString (LiteralInt i) = "integer literal " ++ show i
tokenErrorString (LiteralFloat f) = "float literal " ++ show f
tokenErrorString (LiteralString s) = "string literal " ++ show s
tokenErrorString AtSign = "\"@\""
tokenErrorString Colon = "\":\""
tokenErrorString DollarSign = "\"$\""
tokenErrorString Period = "\".\""
tokenErrorString EqualsSign = "\"=\""
tokenErrorString MinusSign = "\"-\""
tokenErrorString Asterisk = "\"*\""
tokenErrorString ExclamationPoint = "\"!\""
tokenErrorString VoidKeyword = "keyword \"void\""
tokenErrorString TrueKeyword = "keyword \"true\""
tokenErrorString FalseKeyword = "keyword \"false\""
tokenErrorString InKeyword = "keyword \"in\""
tokenErrorString OfKeyword = "keyword \"of\""
tokenErrorString OnKeyword = "keyword \"on\""
tokenErrorString AsKeyword = "keyword \"as\""
tokenErrorString WithKeyword = "keyword \"with\""
tokenErrorString FromKeyword = "keyword \"from\""
tokenErrorString ImportKeyword = "keyword \"import\""
tokenErrorString UsingKeyword = "keyword \"using\""
tokenErrorString ConstKeyword = "keyword \"const\""
tokenErrorString EnumKeyword = "keyword \"enum\""
tokenErrorString StructKeyword = "keyword \"struct\""
tokenErrorString UnionKeyword = "keyword \"union\""
tokenErrorString InterfaceKeyword = "keyword \"interface\""
tokenErrorString AnnotationKeyword = "keyword \"annotation\""
tokenErrorString FixedKeyword = "keyword \"fixed\""
type TokenParser = Parsec [Located Token] [ParseError]
located :: TokenParser t -> TokenParser (Located t)
located p = do
input <- getInput
t <- p
return (Located (locatedPos (head input)) t)
matchUnary :: (Data a, Data b) => (a -> b) -> Located b -> Maybe a
matchUnary c t = if toConstr (c undefined) == toConstr v
then Just $ gmapQi 0 (undefined `mkQ` id) v
else Nothing
where v = locatedValue t
matchIdentifier = matchUnary Identifier
matchTypeIdentifier = matchUnary TypeIdentifier
matchLiteralBool t = case locatedValue t of
TrueKeyword -> Just True
FalseKeyword -> Just False
_ -> 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.")
<?> "identifier"
typeIdentifier = tokenParser matchTypeIdentifier
<|> (tokenParser matchIdentifier >>=
fail "Type identifiers must start with upper-case letter.")
<?> "type identifier"
anyIdentifier = tokenParser matchIdentifier
<|> tokenParser matchTypeIdentifier
<?> "identifier"
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\""
atSign = tokenParser (matchSimpleToken AtSign) <?> "\"@\""
colon = tokenParser (matchSimpleToken Colon) <?> "\":\""
dollarSign = tokenParser (matchSimpleToken DollarSign) <?> "\"$\""
period = tokenParser (matchSimpleToken Period) <?> "\".\""
equalsSign = tokenParser (matchSimpleToken EqualsSign) <?> "\"=\""
minusSign = tokenParser (matchSimpleToken MinusSign) <?> "\"-\""
asterisk = tokenParser (matchSimpleToken Asterisk) <?> "\"*\""
importKeyword = tokenParser (matchSimpleToken ImportKeyword) <?> "\"import\""
usingKeyword = tokenParser (matchSimpleToken UsingKeyword) <?> "\"using\""
constKeyword = tokenParser (matchSimpleToken ConstKeyword) <?> "\"const\""
enumKeyword = tokenParser (matchSimpleToken EnumKeyword) <?> "\"enum\""
structKeyword = tokenParser (matchSimpleToken StructKeyword) <?> "\"struct\""
unionKeyword = tokenParser (matchSimpleToken UnionKeyword) <?> "\"union\""
interfaceKeyword = tokenParser (matchSimpleToken InterfaceKeyword) <?> "\"interface\""
annotationKeyword = tokenParser (matchSimpleToken AnnotationKeyword) <?> "\"annotation\""
fixedKeyword = tokenParser (matchSimpleToken FixedKeyword) <?> "\"fixed\""
exactIdentifier s = tokenParser (matchSimpleToken $ Identifier s) <?> "\"" ++ s ++ "\""
parenthesizedList parser = do
items <- tokenParser (matchUnary ParenthesizedList)
parseList parser items
parenthesized parser = do
items <- tokenParser (matchUnary ParenthesizedList)
unless (length items == 1) (fail "Expected exactly one item in parentheses.")
[result] <- parseList parser items
return result
bracketedList parser = do
items <- tokenParser (matchUnary BracketedList)
parseList parser items
declNameBase :: TokenParser DeclName
declNameBase = liftM ImportName (importKeyword >> located literalString)
<|> liftM AbsoluteName (period >> located anyIdentifier)
<|> liftM RelativeName (located anyIdentifier)
declName :: TokenParser DeclName
declName = do
base <- declNameBase
members <- many (period >> located anyIdentifier)
return (foldl MemberName base members :: DeclName)
typeParameter :: TokenParser TypeParameter
typeParameter = liftM TypeParameterInteger literalInt
<|> liftM TypeParameterType typeExpression
typeExpression :: TokenParser TypeExpression
typeExpression = do
name <- declName
suffixes <- option [] (parenthesizedList typeParameter)
return (TypeExpression name suffixes)
nameWithOrdinal :: TokenParser (Located String, Located Integer)
nameWithOrdinal = do
name <- located varIdentifier
atSign
ordinal <- located literalInt
return (name, ordinal)
declId = atSign >> literalId
annotation :: TokenParser Annotation
annotation = do
dollarSign
name <- declName
value <- located (try (parenthesized fieldValue)
<|> liftM RecordFieldValue (parenthesizedList fieldAssignment)
<|> return VoidFieldValue)
return (Annotation name value)
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
maybeName <- optionMaybe $ try (do
name <- located typeIdentifier
equalsSign
return name)
target <- declName
name <- let
inferredName = case target of
AbsoluteName s -> return s
RelativeName s -> return s
ImportName _ -> fail "When 'using' an 'import' you must specify a name, e.g.: \
\using Foo = import \"foo.capnp\";"
MemberName _ s -> return s
in maybe inferredName return maybeName
return (UsingDecl name target)
constantDecl = do
constKeyword
name <- located varIdentifier
colon
typeName <- typeExpression
equalsSign
value <- located fieldValue
annotations <- many annotation
return (ConstantDecl name typeName annotations value)
typeDecl statements = enumDecl statements
<|> structDecl statements
<|> interfaceDecl statements
enumDecl statements = do
enumKeyword
name <- located typeIdentifier
typeId <- optionMaybe $ located declId
annotations <- many annotation
children <- parseBlock enumLine statements
return (EnumDecl name typeId annotations children)
enumLine :: Maybe [Located Statement] -> TokenParser Declaration
enumLine Nothing = enumerantDecl
enumLine (Just _) = fail "Blocks not allowed here."
enumerantDecl = do
(name, value) <- nameWithOrdinal
annotations <- many annotation
return (EnumerantDecl name value annotations)
structDecl statements = do
structKeyword
name <- located typeIdentifier
typeId <- optionMaybe $ located declId
fixed <- optionMaybe fixedSpec
annotations <- many annotation
children <- parseBlock structLine statements
return (StructDecl name typeId fixed annotations children)
fixedSpec = do
fixedKeyword
Located pos sizes <- located $ parenthesizedList fixedSize
(dataSize, pointerSize) <- foldM combineFixedSizes (Nothing, Nothing) sizes
return $ Located pos (fromMaybe 0 dataSize, fromMaybe 0 pointerSize)
data FixedSize = FixedData Integer | FixedPointers Integer
combineFixedSizes :: (Maybe Integer, Maybe Integer) -> FixedSize
-> TokenParser (Maybe Integer, Maybe Integer)
combineFixedSizes (Nothing, p) (FixedData d) = return (Just d, p)
combineFixedSizes (Just _, _) (FixedData _) =
fail "Multiple data section size specifications."
combineFixedSizes (d, Nothing) (FixedPointers p) = return (d, Just p)
combineFixedSizes (_, Just _) (FixedPointers _) =
fail "Multiple pointer section size specifications."
fixedSize = do
size <- literalInt
-- We do not allow single-bit structs because most CPUs cannot address bits.
(exactIdentifier "bytes" >> return (FixedData (8 * size)))
<|> (exactIdentifier "pointers" >> return (FixedPointers size))
<?> "\"bytes\" or \"pointers\""
structLine :: Maybe [Located Statement] -> TokenParser Declaration
structLine Nothing = usingDecl <|> constantDecl <|> fieldDecl <|> annotationDecl
structLine (Just statements) = typeDecl statements <|> unionDecl statements <|> unionDecl statements
unionDecl statements = do
(name, ordinal) <- nameWithOrdinal
unionKeyword
annotations <- many annotation
children <- parseBlock unionLine statements
return (UnionDecl name ordinal annotations children)
unionLine :: Maybe [Located Statement] -> TokenParser Declaration
unionLine Nothing = fieldDecl
unionLine (Just _) = fail "Blocks not allowed here."
fieldDecl = do
(name, ordinal) <- nameWithOrdinal
colon
t <- typeExpression
value <- optionMaybe (equalsSign >> located fieldValue)
annotations <- many annotation
return (FieldDecl name ordinal t annotations value)
negativeFieldValue = liftM (IntegerFieldValue . negate) literalInt
<|> liftM (FloatFieldValue . negate) literalFloat
<|> (exactIdentifier "inf" >> return (FloatFieldValue (-1.0 / 0.0)))
fieldValue = (literalVoid >> return VoidFieldValue)
<|> liftM BoolFieldValue literalBool
<|> liftM IntegerFieldValue literalInt
<|> liftM FloatFieldValue literalFloat
<|> liftM StringFieldValue literalString
<|> enumOrUnionFieldValue
<|> liftM ListFieldValue (bracketedList (located fieldValue))
<|> liftM RecordFieldValue (parenthesizedList fieldAssignment)
<|> (minusSign >> negativeFieldValue)
<?> "default value"
enumOrUnionFieldValue = do
name <- varIdentifier
liftM (UnionFieldValue name) (try (parenthesized fieldValue))
<|> liftM (UnionFieldValue name . RecordFieldValue) (parenthesizedList fieldAssignment)
<|> return (IdentifierFieldValue name)
fieldAssignment = do
name <- located varIdentifier
equalsSign
value <- located fieldValue
return (name, value)
interfaceDecl statements = do
interfaceKeyword
name <- located typeIdentifier
typeId <- optionMaybe $ located declId
annotations <- many annotation
children <- parseBlock interfaceLine statements
return (InterfaceDecl name typeId annotations children)
interfaceLine :: Maybe [Located Statement] -> TokenParser Declaration
interfaceLine Nothing = usingDecl <|> constantDecl <|> methodDecl <|> annotationDecl
interfaceLine (Just statements) = typeDecl statements
methodDecl = do
(name, ordinal) <- nameWithOrdinal
params <- parenthesizedList paramDecl
colon
t <- typeExpression
annotations <- many annotation
return (MethodDecl name ordinal params t annotations)
paramDecl = do
name <- varIdentifier
colon
t <- typeExpression
value <- optionMaybe (equalsSign >> located fieldValue)
annotations <- many annotation
return (ParamDecl name t annotations value)
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 annId t annotations targets)
allAnnotationTargets = [minBound::AnnotationTarget .. maxBound::AnnotationTarget]
annotationTarget = (exactIdentifier "file" >> return FileAnnotation)
<|> (constKeyword >> return ConstantAnnotation)
<|> (enumKeyword >> return EnumAnnotation)
<|> (exactIdentifier "enumerant" >> return EnumerantAnnotation)
<|> (structKeyword >> return StructAnnotation)
<|> (exactIdentifier "field" >> return FieldAnnotation)
<|> (unionKeyword >> return UnionAnnotation)
<|> (interfaceKeyword >> return InterfaceAnnotation)
<|> (exactIdentifier "method" >> return MethodAnnotation)
<|> (exactIdentifier "parameter" >> return ParamAnnotation)
<|> (annotationKeyword >> return AnnotationAnnotation)
extractErrors :: Either ParseError (a, [ParseError]) -> [ParseError]
extractErrors (Left err) = [err]
extractErrors (Right (_, errors)) = errors
parseList parser items = do
let results = map (parseCollectingErrors parser) items
modifyState (\old -> concat (old:map extractErrors results))
return [ result | Right (result, _) <- results ]
parseBlock :: (Maybe [Located Statement] -> TokenParser Declaration)
-> [Located Statement] -> TokenParser [Declaration]
parseBlock parser statements = do
let results = map (parseStatement parser) statements
modifyState (\old -> concat (old:map extractErrors results))
return [ result | Right (result, _) <- results ]
parseCollectingErrors :: TokenParser a -> TokenSequence
-> Either ParseError (a, [ParseError])
parseCollectingErrors parser tokenSequence = runParser parser' [] "" tokens where
TokenSequence tokens endPos = tokenSequence
parser' = do
-- Work around Parsec bug: Text.Parsec.Print.token is supposed to produce a parser that
-- sets the position by using the provided function to extract it from each token. However,
-- it doesn't bother to call this function for the *first* token, only subsequent tokens.
-- The first token is always assumed to be at 1:1. To fix this, set it manually.
--
-- TODO: There's still a problem when a parse error occurs at end-of-input: Parsec will
-- report the error at the location of the previous token.
setPosition (case tokens of
Located pos2 _:_ -> pos2
[] -> endPos)
result <- parser
eof
errors <- getState
return (result, errors)
parseStatement :: (Maybe [Located Statement] -> TokenParser a)
-> Located Statement
-> Either ParseError (a, [ParseError])
parseStatement parser (Located _ (Line tokens)) =
parseCollectingErrors (parser Nothing) tokens
parseStatement parser (Located _ (Block tokens statements)) =
parseCollectingErrors (parser (Just statements)) tokens
parseFileTokens :: [Located Statement]
-> (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 ++ 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 -> (Nothing, [], [], [e])
Right statements -> parseFileTokens statements
compiler/src/Semantics.hs deleted 100644 → 0
View file @ ae33cf61
-- 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.
module Semantics where
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.List as List
import qualified Data.Maybe as Maybe
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Word (Word8, Word16, Word32, Word64)
import Data.Char (chr)
import Text.Printf(printf)
import Control.Monad(join)
import Util(delimit)
import Grammar(AnnotationTarget(..))
-- Field counts are 16-bit, therefore there cannot be more than 65535 fields, therefore the max
-- ordinal is 65534.
maxOrdinal = 65534 :: Integer
-- Inline fields can be 64 words. (This limit is relied upon by implementations which may need
-- to produce some sort of default value when an inlined field is not actually present in the
-- struct.)
maxInlineFieldBits = 64 * 64 :: Integer
maxStructDataWords = 65536 :: Integer
maxStructPointers = 65536 :: Integer
type ByteString = [Word8]
data Desc = DescFile FileDesc
| DescUsing UsingDesc
| DescConstant ConstantDesc
| DescEnum EnumDesc
| DescEnumerant EnumerantDesc
| DescStruct StructDesc
| DescUnion UnionDesc
| DescField FieldDesc
| DescInterface InterfaceDesc
| DescMethod MethodDesc
| DescParam ParamDesc
| DescAnnotation AnnotationDesc
| DescBuiltinType BuiltinType
| DescBuiltinList
| DescBuiltinInline
| DescBuiltinInlineList
| DescBuiltinInlineData
descName (DescFile _) = "(top-level)"
descName (DescUsing d) = usingName d
descName (DescConstant d) = constantName d
descName (DescEnum d) = enumName d
descName (DescEnumerant d) = enumerantName d
descName (DescStruct d) = structName d
descName (DescUnion d) = unionName d
descName (DescField d) = fieldName d
descName (DescInterface d) = interfaceName d
descName (DescMethod d) = methodName d
descName (DescParam d) = paramName d
descName (DescAnnotation d) = annotationName d
descName (DescBuiltinType d) = builtinTypeName d
descName DescBuiltinList = "List"
descName DescBuiltinInline = "Inline"
descName DescBuiltinInlineList = "InlineList"
descName DescBuiltinInlineData = "InlineData"
descId (DescFile d) = fileId d
descId (DescEnum d) = enumId d
descId (DescStruct d) = structId d
descId (DescInterface d) = interfaceId d
descId (DescConstant d) = constantId d
descId (DescAnnotation d) = annotationId d
descId _ = error "This construct does not have an ID."
descParent (DescFile _) = error "File descriptor has no parent."
descParent (DescUsing d) = usingParent d
descParent (DescConstant d) = constantParent d
descParent (DescEnum d) = enumParent d
descParent (DescEnumerant d) = DescEnum (enumerantParent d)
descParent (DescStruct d) = structParent d
descParent (DescUnion d) = DescStruct (unionParent d)
descParent (DescField d) = DescStruct (fieldParent d)
descParent (DescInterface d) = interfaceParent d
descParent (DescMethod d) = DescInterface (methodParent d)
descParent (DescParam d) = DescMethod (paramParent d)
descParent (DescAnnotation d) = annotationParent d
descParent (DescBuiltinType _) = error "Builtin type has no parent."
descParent DescBuiltinList = error "Builtin type has no parent."
descParent DescBuiltinInline = error "Builtin type has no parent."
descParent DescBuiltinInlineList = error "Builtin type has no parent."
descParent DescBuiltinInlineData = error "Builtin type has no parent."
descFile (DescFile d) = d
descFile desc = descFile $ descParent desc
descAnnotations (DescFile d) = fileAnnotations d
descAnnotations (DescUsing _) = Map.empty
descAnnotations (DescConstant d) = constantAnnotations d
descAnnotations (DescEnum d) = enumAnnotations d
descAnnotations (DescEnumerant d) = enumerantAnnotations 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 DescBuiltinInline = Map.empty
descAnnotations DescBuiltinInlineList = Map.empty
descAnnotations DescBuiltinInlineData = Map.empty
descRuntimeImports (DescFile _) = error "Not to be called on files."
descRuntimeImports (DescUsing d) = usingRuntimeImports d
descRuntimeImports (DescConstant d) = constantRuntimeImports d
descRuntimeImports (DescEnum d) = enumRuntimeImports d
descRuntimeImports (DescEnumerant d) = enumerantRuntimeImports d
descRuntimeImports (DescStruct d) = structRuntimeImports d
descRuntimeImports (DescUnion d) = unionRuntimeImports d
descRuntimeImports (DescField d) = fieldRuntimeImports d
descRuntimeImports (DescInterface d) = interfaceRuntimeImports d
descRuntimeImports (DescMethod d) = methodRuntimeImports d
descRuntimeImports (DescParam d) = paramRuntimeImports d
descRuntimeImports (DescAnnotation d) = annotationRuntimeImports d
descRuntimeImports (DescBuiltinType _) = []
descRuntimeImports DescBuiltinList = []
descRuntimeImports DescBuiltinInline = []
descRuntimeImports DescBuiltinInlineList = []
descRuntimeImports DescBuiltinInlineData = []
type MemberMap = Map.Map String (Maybe Desc)
lookupMember :: String -> MemberMap -> Maybe Desc
lookupMember name members = join (Map.lookup name members)
data BuiltinType = BuiltinVoid | BuiltinBool
| BuiltinInt8 | BuiltinInt16 | BuiltinInt32 | BuiltinInt64
| BuiltinUInt8 | BuiltinUInt16 | BuiltinUInt32 | BuiltinUInt64
| BuiltinFloat32 | BuiltinFloat64
| BuiltinText | BuiltinData
| BuiltinObject
deriving (Show, Enum, Bounded, Eq)
builtinTypes = [minBound::BuiltinType .. maxBound::BuiltinType]
-- Get in-language name of type.
builtinTypeName :: BuiltinType -> String
builtinTypeName = Maybe.fromJust . List.stripPrefix "Builtin" . show
data ValueDesc = VoidDesc
| BoolDesc Bool
| Int8Desc Int8
| Int16Desc Int16
| Int32Desc Int32
| Int64Desc Int64
| UInt8Desc Word8
| UInt16Desc Word16
| UInt32Desc Word32
| UInt64Desc Word64
| Float32Desc Float
| Float64Desc Double
| TextDesc String
| DataDesc ByteString
| EnumerantValueDesc EnumerantDesc
| StructValueDesc [(FieldDesc, ValueDesc)]
| ListDesc [ValueDesc]
deriving (Show)
valueString VoidDesc = "void"
valueString (BoolDesc b) = if b then "true" else "false"
valueString (Int8Desc i) = show i
valueString (Int16Desc i) = show i
valueString (Int32Desc i) = show i
valueString (Int64Desc i) = show i
valueString (UInt8Desc i) = show i
valueString (UInt16Desc i) = show i
valueString (UInt32Desc i) = show i
valueString (UInt64Desc i) = show i
valueString (Float32Desc x) = show x
valueString (Float64Desc x) = show x
valueString (TextDesc s) = show s
valueString (DataDesc s) = show (map (chr . fromIntegral) s)
valueString (EnumerantValueDesc v) = enumerantName v
valueString (StructValueDesc l) = "(" ++ delimit ", " (map assignmentString l) ++ ")" where
assignmentString (field, value) = case fieldUnion field of
Nothing -> fieldName field ++ " = " ++ valueString value
Just (u, _) -> unionName u ++ " = " ++ fieldName field ++
(case value of
StructValueDesc _ -> valueString value
_ -> "(" ++ valueString value ++ ")")
valueString (ListDesc l) = "[" ++ delimit ", " (map valueString l) ++ "]" where
data TypeDesc = BuiltinType BuiltinType
| EnumType EnumDesc
| StructType StructDesc
| InlineStructType StructDesc
| InterfaceType InterfaceDesc
| ListType TypeDesc
| InlineListType TypeDesc Integer
| InlineDataType Integer
typeRuntimeImports (BuiltinType _) = []
typeRuntimeImports (EnumType d) = [descFile (DescEnum d)]
typeRuntimeImports (StructType d) = [descFile (DescStruct d)]
typeRuntimeImports (InlineStructType d) = [descFile (DescStruct d)]
typeRuntimeImports (InterfaceType d) = [descFile (DescInterface d)]
typeRuntimeImports (ListType d) = typeRuntimeImports d
typeRuntimeImports (InlineListType d _) = typeRuntimeImports d
typeRuntimeImports (InlineDataType _) = []
data DataSectionSize = DataSection1 | DataSection8 | DataSection16 | DataSection32
| DataSectionWords Integer
dataSectionWordSize ds = case ds of
DataSectionWords w -> w
_ -> 1
dataSectionAlignment DataSection1 = Size1
dataSectionAlignment DataSection8 = Size8
dataSectionAlignment DataSection16 = Size16
dataSectionAlignment DataSection32 = Size32
dataSectionAlignment (DataSectionWords _) = Size64
dataSectionBits DataSection1 = 1
dataSectionBits DataSection8 = 8
dataSectionBits DataSection16 = 16
dataSectionBits DataSection32 = 32
dataSectionBits (DataSectionWords w) = w * 64
dataSizeToSectionSize Size1 = DataSection1
dataSizeToSectionSize Size8 = DataSection8
dataSizeToSectionSize Size16 = DataSection16
dataSizeToSectionSize Size32 = DataSection32
dataSizeToSectionSize Size64 = DataSectionWords 1
dataSectionSizeString DataSection1 = error "Data section for display can't be 1 bit."
dataSectionSizeString DataSection8 = "1 bytes"
dataSectionSizeString DataSection16 = "2 bytes"
dataSectionSizeString DataSection32 = "4 bytes"
dataSectionSizeString (DataSectionWords n) = show (n * 8) ++ " bytes"
data DataSize = Size1 | Size8 | Size16 | Size32 | Size64 deriving(Eq, Ord, Enum)
dataSizeInBits :: DataSize -> Integer
dataSizeInBits Size1 = 1
dataSizeInBits Size8 = 8
dataSizeInBits Size16 = 16
dataSizeInBits Size32 = 32
dataSizeInBits Size64 = 64
data FieldSize = SizeVoid
| SizeData DataSize
| SizePointer
| SizeInlineComposite DataSectionSize Integer
fieldSizeInBits SizeVoid = 0
fieldSizeInBits (SizeData d) = dataSizeInBits d
fieldSizeInBits SizePointer = 64
fieldSizeInBits (SizeInlineComposite ds pc) = dataSectionBits ds + pc * 64
data FieldOffset = VoidOffset
| DataOffset DataSize Integer
| PointerOffset Integer
| InlineCompositeOffset
{ inlineCompositeDataOffset :: Integer
, inlineCompositePointerOffset :: Integer
, inlineCompositeDataSize :: DataSectionSize
, inlineCompositePointerSize :: Integer
}
offsetToSize :: FieldOffset -> FieldSize
offsetToSize VoidOffset = SizeVoid
offsetToSize (DataOffset s _) = SizeData s
offsetToSize (PointerOffset _) = SizePointer
offsetToSize (InlineCompositeOffset _ _ d p) = SizeInlineComposite d p
fieldSize (BuiltinType BuiltinVoid) = SizeVoid
fieldSize (BuiltinType BuiltinBool) = SizeData Size1
fieldSize (BuiltinType BuiltinInt8) = SizeData Size8
fieldSize (BuiltinType BuiltinInt16) = SizeData Size16
fieldSize (BuiltinType BuiltinInt32) = SizeData Size32
fieldSize (BuiltinType BuiltinInt64) = SizeData Size64
fieldSize (BuiltinType BuiltinUInt8) = SizeData Size8
fieldSize (BuiltinType BuiltinUInt16) = SizeData Size16
fieldSize (BuiltinType BuiltinUInt32) = SizeData Size32
fieldSize (BuiltinType BuiltinUInt64) = SizeData Size64
fieldSize (BuiltinType BuiltinFloat32) = SizeData Size32
fieldSize (BuiltinType BuiltinFloat64) = SizeData Size64
fieldSize (BuiltinType BuiltinText) = SizePointer
fieldSize (BuiltinType BuiltinData) = SizePointer
fieldSize (BuiltinType BuiltinObject) = SizePointer
fieldSize (EnumType _) = SizeData Size16
fieldSize (StructType _) = SizePointer
fieldSize (InlineStructType StructDesc { structDataSize = ds, structPointerCount = ps }) =
SizeInlineComposite ds ps
fieldSize (InterfaceType _) = SizePointer
fieldSize (ListType _) = SizePointer
fieldSize (InlineListType element size) = let
minDataSectionForBits bits
| bits <= 0 = DataSectionWords 0
| bits <= 1 = DataSection1
| bits <= 8 = DataSection8
| bits <= 16 = DataSection16
| bits <= 32 = DataSection32
| otherwise = DataSectionWords $ div (bits + 63) 64
dataSection = case fieldSize element of
SizeVoid -> DataSectionWords 0
SizeData s -> minDataSectionForBits $ dataSizeInBits s * size
SizePointer -> DataSectionWords 0
SizeInlineComposite ds _ -> minDataSectionForBits $ dataSectionBits ds * size
pointerCount = case fieldSize element of
SizeVoid -> 0
SizeData _ -> 0
SizePointer -> size
SizeInlineComposite _ pc -> pc * size
in SizeInlineComposite dataSection pointerCount
fieldSize (InlineDataType size)
| size <= 0 = SizeInlineComposite (DataSectionWords 0) 0
| size <= 1 = SizeInlineComposite DataSection8 0
| size <= 2 = SizeInlineComposite DataSection16 0
| size <= 4 = SizeInlineComposite DataSection32 0
| otherwise = SizeInlineComposite (DataSectionWords (div (size + 7) 8)) 0
-- Render the type descriptor's name as a string, appropriate for use in the given scope.
typeName :: Desc -> TypeDesc -> String
typeName _ (BuiltinType t) = builtinTypeName t -- TODO: Check for shadowing.
typeName scope (EnumType desc) = descQualifiedName scope (DescEnum desc)
typeName scope (StructType desc) = descQualifiedName scope (DescStruct desc)
typeName scope (InlineStructType desc) = descQualifiedName scope (DescStruct desc)
typeName scope (InterfaceType desc) = descQualifiedName scope (DescInterface desc)
typeName scope (ListType t) = "List(" ++ typeName scope t ++ ")"
typeName scope (InlineListType t s) = printf "InlineList(%s, %d)" (typeName scope t) s
typeName _ (InlineDataType s) = printf "InlineData(%d)" s
-- Computes the qualified name for the given descriptor within the given scope.
-- At present the scope is only used to determine whether the target is in the same file. If
-- not, an "import" expression is used.
-- This could be made fancier in a couple ways:
-- 1) Drop the common prefix between scope and desc to form a minimal relative name. Note that
-- we'll need to check for shadowing.
-- 2) Examine `using`s visible in the current scope to see if they refer to a prefix of the target
-- symbol, and use them if so. A particularly important case of this is imports -- typically
-- the import will have a `using` in the file scope.
descQualifiedName :: Desc -> Desc -> String
-- Builtin descs can be aliased with "using", so we need to support them.
descQualifiedName _ (DescBuiltinType t) = builtinTypeName t
descQualifiedName _ DescBuiltinList = "List"
descQualifiedName _ DescBuiltinInline = "Inline"
descQualifiedName _ DescBuiltinInlineList = "InlineList"
descQualifiedName _ DescBuiltinInlineData = "InlineData"
descQualifiedName (DescFile scope) (DescFile desc) =
if fileName scope == fileName desc
then ""
else printf "import \"%s\"" (fileName desc)
descQualifiedName (DescFile scope) desc = printf "%s.%s" parent (descName desc) where
parent = descQualifiedName (DescFile scope) (descParent desc)
descQualifiedName scope desc = descQualifiedName (descParent scope) desc
data FileDesc = FileDesc
{ fileName :: 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.
, fileRuntimeImports :: Set.Set String
, fileAnnotations :: AnnotationMap
, fileMemberMap :: MemberMap
, fileImportMap :: Map.Map String FileDesc
, fileMembers :: [Desc]
}
data UsingDesc = UsingDesc
{ usingName :: String
, usingParent :: Desc
, usingTarget :: Desc
}
usingRuntimeImports _ = []
data ConstantDesc = ConstantDesc
{ constantName :: String
, constantId :: Word64
, constantParent :: Desc
, constantType :: TypeDesc
, constantAnnotations :: AnnotationMap
, constantValue :: ValueDesc
}
constantRuntimeImports desc = typeRuntimeImports $ constantType desc
data EnumDesc = EnumDesc
{ enumName :: String
, enumId :: Word64
, enumParent :: Desc
, enumerants :: [EnumerantDesc]
, enumAnnotations :: AnnotationMap
, enumMemberMap :: MemberMap
, enumMembers :: [Desc]
}
enumRuntimeImports desc = concatMap descRuntimeImports $ enumMembers desc
data EnumerantDesc = EnumerantDesc
{ enumerantName :: String
, enumerantParent :: EnumDesc
, enumerantNumber :: Integer
, enumerantAnnotations :: AnnotationMap
}
enumerantRuntimeImports _ = []
data StructDesc = StructDesc
{ structName :: String
, structId :: Word64
, structParent :: Desc
, structDataSize :: DataSectionSize
, structPointerCount :: Integer
, structIsFixedWidth :: Bool
, structFields :: [FieldDesc]
, structUnions :: [UnionDesc]
, structAnnotations :: AnnotationMap
, structMemberMap :: MemberMap
, structMembersByNumber :: Map.Map Integer Desc -- top-level members only
, structMembers :: [Desc]
-- Don't use this directly, use the members of FieldDesc and UnionDesc.
-- This field is exposed here only because I was too lazy to create a way to pass it on
-- the side when compiling members of a struct.
, structFieldPackingMap :: Map.Map Integer FieldOffset
}
structRuntimeImports desc = concatMap descRuntimeImports $ structMembers desc
data UnionDesc = UnionDesc
{ unionName :: String
, unionParent :: StructDesc
, unionNumber :: Integer
, unionTagOffset :: Integer
, unionFields :: [FieldDesc]
, unionAnnotations :: AnnotationMap
, unionMemberMap :: MemberMap
, unionMembers :: [Desc]
-- Maps field numbers to discriminants for all fields in the union.
, unionFieldDiscriminantMap :: Map.Map Integer Integer
}
unionRuntimeImports desc = concatMap descRuntimeImports $ unionMembers desc
data FieldDesc = FieldDesc
{ fieldName :: String
, fieldParent :: StructDesc
, fieldNumber :: Integer
, fieldOffset :: FieldOffset
, fieldUnion :: Maybe (UnionDesc, Integer) -- Integer is value of union discriminant.
, fieldType :: TypeDesc
, fieldDefaultValue :: Maybe ValueDesc
, fieldAnnotations :: AnnotationMap
}
fieldRuntimeImports desc = typeRuntimeImports $ fieldType desc
data InterfaceDesc = InterfaceDesc
{ interfaceName :: String
, interfaceId :: Word64
, interfaceParent :: Desc
, interfaceMethods :: [MethodDesc]
, interfaceAnnotations :: AnnotationMap
, interfaceMemberMap :: MemberMap
, interfaceMembers :: [Desc]
}
interfaceRuntimeImports desc = concatMap descRuntimeImports $ interfaceMembers desc
data MethodDesc = MethodDesc
{ methodName :: String
, methodParent :: InterfaceDesc
, methodNumber :: Integer
, methodParams :: [ParamDesc]
, methodReturnType :: TypeDesc
, methodAnnotations :: AnnotationMap
}
methodRuntimeImports desc = typeRuntimeImports (methodReturnType desc) ++
concatMap paramRuntimeImports (methodParams desc)
data ParamDesc = ParamDesc
{ paramName :: String
, paramParent :: MethodDesc
, paramNumber :: Integer
, paramType :: TypeDesc
, paramDefaultValue :: Maybe ValueDesc
, paramAnnotations :: AnnotationMap
}
paramRuntimeImports desc = typeRuntimeImports $ paramType desc
data AnnotationDesc = AnnotationDesc
{ annotationName :: String
, annotationParent :: Desc
, annotationType :: TypeDesc
, annotationAnnotations :: AnnotationMap
, annotationId :: Word64
, annotationTargets :: Set.Set AnnotationTarget
}
annotationRuntimeImports desc = typeRuntimeImports $ annotationType desc
type AnnotationMap = Map.Map Word64 (AnnotationDesc, ValueDesc)
descToCode :: String -> Desc -> String
descToCode indent self@(DescFile desc) = printf "# %s\n@0x%016x;\n%s%s"
(fileName desc)
(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
(usingName desc)
(descQualifiedName (usingParent desc) (usingTarget desc))
descToCode indent self@(DescConstant desc) = printf "%sconst %s: %s = %s%s;\n" indent
(constantName desc)
(typeName (descParent self) (constantType desc))
(valueString (constantValue desc))
(annotationsCode self)
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 @0x%016x%s%s { # %d bytes, %d pointers\n%s%s}\n" indent
(structName desc)
(structId desc)
(if structIsFixedWidth desc
then printf " fixed(%s, %d pointers) "
(dataSectionSizeString $ structDataSize desc)
(structPointerCount desc)
else "")
(annotationsCode self)
(div (dataSectionBits $ structDataSize desc) 8)
(structPointerCount desc)
(blockCode indent (structMembers desc))
indent
descToCode indent self@(DescField desc) = printf "%s%s@%d: %s%s%s; # %s%s\n" indent
(fieldName desc) (fieldNumber desc)
(typeName (descParent self) (fieldType desc))
(case fieldDefaultValue desc of { Nothing -> ""; Just v -> " = " ++ valueString v; })
(annotationsCode self)
(case fieldOffset desc of
PointerOffset o -> printf "ptr[%d]" o
InlineCompositeOffset dataOffset pointerOffset dataSize pointerSize ->
let dataBitOffset = dataOffset * dataSizeInBits (dataSectionAlignment dataSize)
in printf "bits[%d, %d), ptrs[%d, %d)"
dataBitOffset (dataBitOffset + dataSectionBits dataSize)
pointerOffset (pointerOffset + pointerSize)
VoidOffset -> "(none)"
DataOffset dataSize offset -> let
bits = dataSizeInBits dataSize
in printf "bits[%d, %d)" (offset * bits) ((offset + 1) * bits))
(case fieldUnion desc of { Nothing -> ""; Just (_, i) -> printf ", union tag = %d" i})
descToCode indent self@(DescUnion desc) = printf "%sunion %s@%d%s { # [%d, %d)\n%s%s}\n" indent
(unionName desc) (unionNumber desc)
(annotationsCode self)
(unionTagOffset desc * 16) (unionTagOffset desc * 16 + 16)
(blockCode indent $ unionMembers desc)
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
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 self)
descToCode _ self@(DescParam desc) = printf "%s: %s%s%s"
(paramName desc)
(typeName (descParent self) (paramType desc))
(case paramDefaultValue desc of
Just v -> printf " = %s" $ valueString v
Nothing -> "")
(annotationsCode self)
descToCode indent self@(DescAnnotation desc) = printf "%sannotation %s @0x%016x(%s): %s%s;\n" indent
(annotationName desc)
(annotationId desc)
(delimit ", " $ map show $ Set.toList $ annotationTargets desc)
(typeName (descParent self) (annotationType desc))
(annotationsCode self)
descToCode _ (DescBuiltinType _) = error "Can't print code for builtin type."
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."
maybeBlockCode :: String -> [Desc] -> String
maybeBlockCode _ [] = ";\n"
maybeBlockCode indent statements = printf " {\n%s%s}\n" (blockCode indent statements) indent
blockCode :: String -> [Desc] -> String
blockCode indent = concatMap (descToCode (" " ++ indent))
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 = concatMap ((' ':) . annotationCode (descParent desc)) $ Map.toList
$ descAnnotations desc
instance Show FileDesc where { show desc = descToCode "" (DescFile desc) }
instance Show UsingDesc where { show desc = descToCode "" (DescUsing desc) }
instance Show ConstantDesc where { show desc = descToCode "" (DescConstant desc) }
instance Show EnumDesc where { show desc = descToCode "" (DescEnum desc) }
instance Show EnumerantDesc where { show desc = descToCode "" (DescEnumerant desc) }
instance Show StructDesc where { show desc = descToCode "" (DescStruct desc) }
instance Show FieldDesc where { show desc = descToCode "" (DescField desc) }
instance Show InterfaceDesc where { show desc = descToCode "" (DescInterface desc) }
instance Show MethodDesc where { show desc = descToCode "" (DescMethod desc) }
instance Show ParamDesc where { show desc = descToCode "" (DescParam desc) }
instance Show AnnotationDesc where { show desc = descToCode "" (DescAnnotation desc) }
compiler/src/Token.hs deleted 100644 → 0
View file @ ae33cf61
-- 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.
{-# LANGUAGE DeriveDataTypeable #-}
module Token where
import Data.Generics
import Text.Parsec.Pos (SourcePos, sourceLine, sourceColumn)
import Text.Printf (printf)
data Located t = Located { locatedPos :: SourcePos, locatedValue :: t } deriving (Typeable, Data)
instance Show t => Show (Located t) where
show (Located pos x) = printf "%d:%d:%s" (sourceLine pos) (sourceColumn pos) (show x)
instance Eq a => Eq (Located a) where
Located _ a == Located _ b = a == b
instance Ord a => Ord (Located a) where
compare (Located _ a) (Located _ b) = compare a b
data TokenSequence = TokenSequence [Located Token] SourcePos deriving(Data, Typeable, Show, Eq)
data Token = Identifier String
| TypeIdentifier String
| ParenthesizedList [TokenSequence]
| BracketedList [TokenSequence]
| LiteralInt Integer
| LiteralFloat Double
| LiteralString String
| VoidKeyword
| TrueKeyword
| FalseKeyword
| AtSign
| Colon
| DollarSign
| Period
| EqualsSign
| MinusSign
| Asterisk
| ExclamationPoint
| InKeyword
| OfKeyword -- We reserve some common, short English words for use as future keywords.
| OnKeyword
| AsKeyword
| WithKeyword
| FromKeyword
| ImportKeyword
| UsingKeyword
| ConstKeyword
| EnumKeyword
| StructKeyword
| UnionKeyword
| InterfaceKeyword
| AnnotationKeyword
| FixedKeyword
deriving (Data, Typeable, Show, Eq)
data Statement = Line TokenSequence
| Block TokenSequence [Located Statement]
deriving (Show)
compiler/src/Util.hs deleted 100644 → 0
View file @ ae33cf61
-- 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.
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
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
firstWord:moreWords -> (a:firstWord):moreWords
[] -> [[a]]
splitName [] = []
toTitleCase :: String -> String
toTitleCase (a:rest) = toUpper a:rest
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 deleted 100644 → 0
View file @ ae33cf61
-- 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.
module WireFormat(encodeMessage, encodeSchema) where
import Data.List(sortBy, genericLength, genericReplicate)
import Data.Word
import Data.Bits(shiftL, Bits, setBit, xor)
import Data.Function(on)
import Data.Maybe(mapMaybe, listToMaybe, isNothing)
import Data.List(findIndices)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Semantics
import Data.Binary.IEEE754(floatToWord, doubleToWord)
import Text.Printf(printf)
import qualified Codec.Binary.UTF8.String as UTF8
import Util(intToBytes)
import Grammar(AnnotationTarget(..))
padToWord b = let
trailing = mod (length b) 8
in if trailing == 0
then b
else b ++ replicate (8 - trailing) 0
data EncodedData = EncodedBit Bool
| EncodedBytes [Word8]
deriving(Show)
xorData (EncodedBit a) (EncodedBit b) = EncodedBit (a /= b)
xorData (EncodedBytes a) (EncodedBytes b) = EncodedBytes (zipWith xor a b)
xorData _ _ = error "Value type mismatch when xor'ing."
encodeDataValue :: TypeDesc -> ValueDesc -> EncodedData
encodeDataValue _ VoidDesc = EncodedBytes []
encodeDataValue _ (BoolDesc v) = EncodedBit v
encodeDataValue _ (Int8Desc v) = EncodedBytes $ intToBytes v 1
encodeDataValue _ (Int16Desc v) = EncodedBytes $ intToBytes v 2
encodeDataValue _ (Int32Desc v) = EncodedBytes $ intToBytes v 4
encodeDataValue _ (Int64Desc v) = EncodedBytes $ intToBytes v 8
encodeDataValue _ (UInt8Desc v) = EncodedBytes $ intToBytes v 1
encodeDataValue _ (UInt16Desc v) = EncodedBytes $ intToBytes v 2
encodeDataValue _ (UInt32Desc v) = EncodedBytes $ intToBytes v 4
encodeDataValue _ (UInt64Desc v) = EncodedBytes $ intToBytes v 8
encodeDataValue _ (Float32Desc v) = EncodedBytes $ intToBytes (floatToWord v) 4
encodeDataValue _ (Float64Desc v) = EncodedBytes $ intToBytes (doubleToWord v) 8
encodeDataValue _ (TextDesc _) = error "Not fixed-width data."
encodeDataValue _ (DataDesc _) = error "Not fixed-width data."
encodeDataValue _ (EnumerantValueDesc v) = EncodedBytes $ intToBytes (enumerantNumber v) 2
encodeDataValue _ (StructValueDesc _) = error "Not fixed-width data."
encodeDataValue _ (ListDesc _) = error "Not fixed-width data."
encodeMaskedDataValue t v Nothing = encodeDataValue t v
encodeMaskedDataValue t v (Just d) = xorData (encodeDataValue t v) (encodeDataValue t d)
encodePointerValue :: TypeDesc -> ValueDesc -> (Integer -> [Word8], [Word8])
encodePointerValue _ (TextDesc text) = let
encoded = UTF8.encode text ++ [0]
in (encodeListPointer (SizeData Size8) (genericLength encoded), padToWord encoded)
encodePointerValue _ (DataDesc d) =
(encodeListPointer (SizeData Size8) (genericLength d), padToWord d)
encodePointerValue (StructType desc) (StructValueDesc assignments) = let
(dataBytes, ptrBytes, childBytes) = encodeStruct desc assignments 0
in (encodeStructPointer (structDataSize desc, structPointerCount desc),
concat [dataBytes, ptrBytes, childBytes])
encodePointerValue (InlineStructType _) _ =
error "Tried to encode inline struct as a pointer."
encodePointerValue (ListType elementType) (ListDesc items) = encodeList elementType items
encodePointerValue (InlineListType _ _) _ =
error "Tried to encode inline list as a pointer."
encodePointerValue (InlineDataType _) _ =
error "Tried to encode inline data as a pointer."
encodePointerValue _ _ = error "Unknown pointer type."
-- Given a sorted list of (bitOffset, data), pack into a byte array.
packBytes :: Integer -- Total size of array to pack, in bits.
-> [(Integer, EncodedData)] -- (offset, data) pairs to pack. Must be in order.
-> [Word8]
packBytes size items = padToWord $ loop 0 items where
loop :: Integer -> [(Integer, EncodedData)] -> [Word8]
loop bit [] | bit <= size = genericReplicate (div (size - bit + 7) 8) 0
loop bit [] | bit > size = error "Data values overran size."
loop bit values@((offset, _):_) | offset >= bit + 8 = 0:loop (bit + 8) values
loop bit ((offset, EncodedBit True):rest) = let
firstByte:restBytes = loop bit rest
in setBit firstByte (fromIntegral (offset - bit)) : restBytes
loop bit ((_, EncodedBit False):rest) = loop bit rest
loop bit ((offset, EncodedBytes encoded):rest) | offset == bit =
encoded ++ loop (bit + genericLength encoded * 8) rest
loop bit rest = error
(printf "Data values overlapped @%d: %s\n\n%s" bit (show rest) (show items))
bytesToWords i = if mod i 8 == 0 then div i 8
else error "Byte count did not divide evenly into words."
packPointers :: Integer -- Total number of pointers to pack.
-> [(Integer, (Integer -> [Word8], [Word8]))]
-> Integer -- Word offset from end of pointer array to child area.
-> ([Word8], [Word8])
packPointers size items o = loop 0 items (o + size - 1) where
loop :: Integer -> [(Integer, (Integer -> [Word8], [Word8]))] -> Integer -> ([Word8], [Word8])
loop idx ((pos, (mkptrs, child)):rest) childOff | idx == pos = let
ptrs = mkptrs childOff
ptrCount = bytesToWords (genericLength ptrs)
newChildOff = childOff - ptrCount + bytesToWords (genericLength child)
(restPtrs, restChildren) = loop (idx + ptrCount) rest newChildOff
in (ptrs ++ restPtrs, child ++ restChildren)
loop idx rest@((pos, _):_) childOff = let
padCount = pos - idx
(restPtrs, restChildren) = loop pos rest (childOff - padCount)
in (genericReplicate (padCount * 8) 0 ++ restPtrs, restChildren)
loop idx [] _ = (genericReplicate ((size - idx) * 8) 0, [])
encodeStructPointer (dataSize, pointerCount) offset =
intToBytes (offset * 4 + structTag) 4 ++
intToBytes (dataSectionWordSize dataSize) 2 ++
intToBytes pointerCount 2
encodeListPointer elemSize@(SizeInlineComposite ds rc) elementCount offset =
intToBytes (offset * 4 + listTag) 4 ++
intToBytes (fieldSizeEnum elemSize + shiftL (elementCount * (dataSectionWordSize ds + rc)) 3) 4
encodeListPointer elemSize elementCount offset =
intToBytes (offset * 4 + listTag) 4 ++
intToBytes (fieldSizeEnum elemSize + shiftL elementCount 3) 4
fieldSizeEnum SizeVoid = 0
fieldSizeEnum (SizeData Size1) = 1
fieldSizeEnum (SizeData Size8) = 2
fieldSizeEnum (SizeData Size16) = 3
fieldSizeEnum (SizeData Size32) = 4
fieldSizeEnum (SizeData Size64) = 5
fieldSizeEnum SizePointer = 6
fieldSizeEnum (SizeInlineComposite _ _) = 7
structTag = 0
listTag = 1
-- childOffset = number of words between the last pointer and the location where children will
-- be allocated.
encodeStruct desc assignments childOffset = let
dataSize = dataSectionBits $ structDataSize desc
dataSection = packBytes dataSize $ sortBy (compare `on` fst)
$ structDataSectionValues assignments
pointerCount = structPointerCount desc
(pointerSection, children) = packPointers pointerCount
(sortBy (compare `on` fst) $ structPointerSectionValues assignments)
childOffset
in (dataSection, pointerSection, children)
dataBitOffset (DataOffset size off) = dataSizeInBits size * off
dataBitOffset (InlineCompositeOffset off _ dataSectionSize _) =
off * dataSizeInBits (dataSectionAlignment dataSectionSize)
dataBitOffset _ = error "Not a data field."
structDataSectionValues assignments = let
simpleValues = [(dataBitOffset $ fieldOffset f,
encodeMaskedDataValue (fieldType f) v (fieldDefaultValue f))
| (f@FieldDesc { fieldOffset = DataOffset _ _ }, v) <- assignments]
inlineCompositeValues = do -- List monad!
(FieldDesc { fieldType = t
, fieldOffset = InlineCompositeOffset off _ sectionSize _ }, v) <- assignments
let bitOffset = off * dataSizeInBits (dataSectionAlignment sectionSize)
(pos, v2) <- case (t, v) of
(InlineStructType _, StructValueDesc v2) -> structDataSectionValues v2
(InlineListType t2 _, ListDesc v2) -> inlineListDataSectionValues t2 v2
(InlineDataType _, DataDesc v2) -> [(0, EncodedBytes v2)]
_ -> error "Non-inline-composite had inline-composite offset."
return (pos + bitOffset, v2)
unionTags = [(unionTagOffset u * 16,
encodeDataValue (BuiltinType BuiltinUInt16) (UInt16Desc $ fromIntegral n))
| (FieldDesc {fieldUnion = Just (u, n)}, _) <- assignments]
in simpleValues ++ inlineCompositeValues ++ unionTags
structPointerSectionValues :: [(FieldDesc, ValueDesc)] -> [(Integer, (Integer -> [Word8], [Word8]))]
structPointerSectionValues assignments = let
simpleValues = [(off, encodePointerValue (fieldType f) v)
| (f@FieldDesc { fieldOffset = PointerOffset off }, v) <- assignments]
inlineCompositeValues = do -- List monad!
(FieldDesc { fieldType = t
, fieldOffset = InlineCompositeOffset _ off _ _ }, v) <- assignments
(pos, v2) <- case (t, v) of
(InlineStructType _, StructValueDesc v2) -> structPointerSectionValues v2
(InlineListType t2 _, ListDesc v2) -> inlineListPointerSectionValues t2 v2
(InlineDataType _, DataDesc _) -> []
_ -> error "Non-inline-composite had inline-composite offset."
return (pos + off, v2)
in simpleValues ++ inlineCompositeValues
------------------------------------------------------------------------------------------
encodeList :: TypeDesc -- Type of each element.
-> [ValueDesc] -- Element values.
-> (Integer -> [Word8], -- Encodes the pointer, given the offset.
[Word8]) -- Body bytes.
-- Encode a list of empty structs as void.
encodeList (StructType StructDesc {
structDataSize = DataSectionWords 0, structPointerCount = 0 }) elements =
(encodeListPointer SizeVoid (genericLength elements), [])
-- Encode a list of sub-word data-only structs as a list of primitives.
encodeList (StructType desc@StructDesc { structDataSize = ds, structPointerCount = 0 }) elements
| dataSectionBits ds <= 64 = let
in (encodeListPointer (SizeData $ dataSectionAlignment ds) (genericLength elements),
inlineStructListDataSection desc elements)
-- Encode a list of single-pointer structs as a list of pointers.
encodeList (StructType desc@StructDesc {
structDataSize = DataSectionWords 0, structPointerCount = 1 }) elements = let
(ptrBytes, childBytes) = inlineStructListPointerSection desc elements
in (encodeListPointer SizePointer (genericLength elements), ptrBytes ++ childBytes)
-- Encode a list of any other sort of struct.
encodeList (StructType desc) elements = let
count = genericLength elements
tag = encodeStructPointer (structDataSize desc, structPointerCount desc) count
eSize = dataSectionWordSize (structDataSize desc) + structPointerCount desc
structElems = [v | StructValueDesc v <- elements]
(elemBytes, childBytes) = loop (eSize * genericLength structElems) structElems
loop _ [] = ([], [])
loop offset (element:rest) = let
offsetFromElementEnd = offset - eSize
(dataBytes, ptrBytes, childBytes2) = encodeStruct desc element offsetFromElementEnd
childLen = genericLength childBytes2
childWordLen = if mod childLen 8 == 0
then div childLen 8
else error "Child not word-aligned."
(restBytes, restChildren) = loop (offsetFromElementEnd + childWordLen) rest
in (dataBytes ++ ptrBytes ++ restBytes, childBytes2 ++ restChildren)
in (encodeListPointer (SizeInlineComposite (structDataSize desc) (structPointerCount desc))
(genericLength elements),
concat [tag, elemBytes, childBytes])
encodeList (InlineStructType _) _ = error "Not supported: List of inline structs."
-- Encode a list of inline lists by just concatenating all the elements. The number of inner
-- lists can be determined at runtime by dividing the total size by the fixed inline list size.
-- Note that this means if you have something like List(InlineList(UInt8, 3)) and the list has
-- two elements, the total size will be 6 bytes -- we don't round the individual sub-lists up
-- to power-of-two boundaries.
encodeList (InlineListType (InlineStructType t) _) elements =
encodeList (StructType t) (concat [l | ListDesc l <- elements])
encodeList (InlineListType t _) elements = encodeList t (concat [l | ListDesc l <- elements])
-- Encode a list of inline data. Similar deal to above.
encodeList (InlineDataType _) elements =
encodePointerValue (BuiltinType BuiltinData) (DataDesc $ concat [l | DataDesc l <- elements])
-- Encode primitive types.
encodeList elementType elements = let
eSize = fieldSize elementType
dataBytes = case eSize of
SizeVoid -> []
SizeInlineComposite _ _ -> error "All inline composites should have been handled above."
SizePointer -> ptrBytes ++ childBytes where
encodedElements = zip [0..] $ map (encodePointerValue elementType) elements
(ptrBytes, childBytes) = packPointers (genericLength elements) encodedElements 0
SizeData size -> let
bits = dataSizeInBits size
encodedElements = zip [0,bits..] $ map (encodeDataValue elementType) elements
in packBytes (genericLength elements * bits) encodedElements
in (encodeListPointer eSize (genericLength elements), dataBytes)
---------------------------------------------
inlineListDataSectionValues elementType elements = case fieldSize elementType of
SizeVoid -> []
(SizeInlineComposite _ _) -> case elementType of
InlineStructType desc -> inlineStructListDataSectionValues desc elements
InlineListType t _ -> inlineListDataSectionValues t (concat [l | ListDesc l <- elements])
InlineDataType _ -> [(0, EncodedBytes $ concat [l | DataDesc l <- elements])]
_ -> error "Unknown inline composite type."
SizePointer -> []
SizeData size -> let
bits = dataSizeInBits size
in zip [0,bits..] $ map (encodeDataValue elementType) elements
inlineListPointerSectionValues elementType elements = case fieldSize elementType of
SizeVoid -> []
(SizeInlineComposite _ _) -> case elementType of
InlineStructType desc -> inlineStructListPointerSectionValues desc elements
InlineListType t _ -> inlineListPointerSectionValues t (concat [l | ListDesc l <- elements])
InlineDataType _ -> []
_ -> error "Unknown inline composite type."
SizePointer -> zip [0..] $ map (encodePointerValue elementType) elements
SizeData _ -> []
inlineStructListDataSection elementDesc elements =
packBytes (genericLength elements * dataSectionBits (structDataSize elementDesc))
(sortBy (compare `on` fst) $ inlineStructListDataSectionValues elementDesc elements)
inlineStructListDataSectionValues elementDesc elements = do
let bits = dataSectionBits $ structDataSize elementDesc
(i, StructValueDesc e) <- zip [0..] elements
(off, v) <- structDataSectionValues e
return (off + bits * i, v)
inlineStructListPointerSection elementDesc elements =
packPointers
(genericLength elements * structPointerCount elementDesc)
(sortBy (compare `on` fst) $ inlineStructListPointerSectionValues elementDesc elements)
0
inlineStructListPointerSectionValues elementDesc elements = do
let ptrs = structPointerCount elementDesc
(i, StructValueDesc e) <- zip [0..] elements
(off, v) <- structPointerSectionValues e
return (off + ptrs * i, v)
------------------------------------------------------------------------------------------
encodeMessage (StructType desc) (StructValueDesc assignments) = let
(dataBytes, ptrBytes, childBytes) = encodeStruct desc assignments 0
in concat [encodeStructPointer (structDataSize desc, structPointerCount desc) (0::Integer),
dataBytes, ptrBytes, childBytes]
encodeMessage (ListType elementType) (ListDesc elements) = let
(ptr, listBytes) = encodeList elementType elements
in ptr (0::Integer) ++ listBytes
encodeMessage _ _ = error "Not a message."
------------------------------------------------------------------------------------------
type EncodedPtr = (Integer -> [Word8], [Word8])
-- Given the list of requested files and the list of all files including transitive imports,
-- returns a tuple containing the appropriate encoded CodeGeneratorRequest as well as a list
-- of ((typeId, displayName), encodedNode), where encodedNode is the encoded schema node
-- appropriate for reading as a "trusted message".
encodeSchema :: [FileDesc] -> [FileDesc] -> ([Word8], [((Word64, String), [Word8])])
encodeSchema requestedFiles allFiles = (encRoot, nodesForEmbedding) where
encUInt64 = EncodedBytes . flip intToBytes 8
encUInt32 = EncodedBytes . flip intToBytes 4
encUInt16 :: (Integral a, Bits a) => a -> EncodedData
encUInt16 = EncodedBytes . flip intToBytes 2
encText :: String -> EncodedPtr
encText v = encodePointerValue (BuiltinType BuiltinText) (TextDesc v)
encDataList :: DataSize -> [EncodedData] -> EncodedPtr
encDataList elementSize elements = let
elemBits = dataSizeInBits elementSize
bytes = packBytes (elemBits * genericLength elements)
$ zip [0,elemBits..] elements
in (encodeListPointer (SizeData elementSize) (genericLength elements), bytes)
-- Not used, but maybe useful in the future.
--encPtrList :: [EncodedPtr] -> EncodedPtr
--encPtrList elements = let
-- (ptrBytes, childBytes) = packPointers (genericLength elements) (zip [0..] elements) 0
-- in (encodeListPointer SizePointer (genericLength elements), ptrBytes ++ childBytes)
encStructList :: (DataSectionSize, Integer)
-> [([(Integer, EncodedData)], [(Integer, EncodedPtr)])]
-> EncodedPtr
encStructList elementSize@(dataSize, pointerCount) elements = let
count = genericLength elements
tag = encodeStructPointer elementSize count
eSize = dataSectionWordSize dataSize + pointerCount
(elemBytes, childBytes) = loop (eSize * genericLength elements) elements
loop _ [] = ([], [])
loop offset ((dataValues, ptrValues):rest) = let
offsetFromElementEnd = offset - eSize
(dataBytes, ptrBytes, childBytes2) =
encStructBody elementSize dataValues ptrValues offsetFromElementEnd
childLen = genericLength childBytes2
childWordLen = if mod childLen 8 == 0
then div childLen 8
else error "Child not word-aligned."
(restBytes, restChildren) = loop (offsetFromElementEnd + childWordLen) rest
in (concat [dataBytes, ptrBytes, restBytes], childBytes2 ++ restChildren)
in (encodeListPointer (SizeInlineComposite dataSize pointerCount) (genericLength elements),
concat [tag, elemBytes, childBytes])
encStructBody :: (DataSectionSize, Integer)
-> [(Integer, EncodedData)]
-> [(Integer, EncodedPtr)]
-> Integer
-> ([Word8], [Word8], [Word8])
encStructBody (dataSize, pointerCount) dataValues ptrValues offsetFromElementEnd = let
dataBytes = packBytes (dataSectionBits dataSize) dataValues
(ptrBytes, childBytes) = packPointers pointerCount ptrValues offsetFromElementEnd
in (dataBytes, ptrBytes, childBytes)
encStruct :: (DataSectionSize, Integer)
-> ([(Integer, EncodedData)], [(Integer, EncodedPtr)])
-> EncodedPtr
encStruct size (dataValues, ptrValues) = let
(dataBytes, ptrBytes, childBytes) = encStructBody size dataValues ptrValues 0
in (encodeStructPointer size, concat [dataBytes, ptrBytes, childBytes])
---------------------------------------------
isNodeDesc (DescFile _) = True
isNodeDesc (DescStruct _) = True
isNodeDesc (DescEnum _) = True
isNodeDesc (DescInterface _) = True
isNodeDesc (DescConstant _) = True
isNodeDesc (DescAnnotation _) = True
isNodeDesc _ = False
descNestedNodes (DescFile d) = filter isNodeDesc $ fileMembers d
descNestedNodes (DescStruct d) = filter isNodeDesc $ structMembers d
descNestedNodes (DescInterface d) = filter isNodeDesc $ interfaceMembers d
descNestedNodes _ = []
flattenDescs desc = desc : concatMap flattenDescs (descNestedNodes desc)
allDescs = concatMap flattenDescs $ map DescFile allFiles
allNodes = map encNode allDescs
nodesForEmbedding = map encodeNodeForEmbedding allNodes
---------------------------------------------
encRoot = let
ptrVal = encStruct codeGeneratorRequestSize encCodeGeneratorRequest
(ptrBytes, childBytes) = packPointers 1 [(0, ptrVal)] 0
segment = ptrBytes ++ childBytes
in concat [[0,0,0,0], intToBytes (div (length segment) 8) 4, segment]
encodeNodeForEmbedding ((typeId, name), node) = let
ptrVal = encStruct nodeSize node
(ptrBytes, childBytes) = packPointers 1 [(0, ptrVal)] 0
in ((typeId, name), ptrBytes ++ childBytes)
codeGeneratorRequestSize = (DataSectionWords 0, 2)
encCodeGeneratorRequest = (dataValues, ptrValues) where
dataValues = []
ptrValues = [ (0, encStructList nodeSize $ map snd allNodes)
, (1, encDataList Size64 $ map (encUInt64 . fileId) requestedFiles)
]
typeSize = (DataSectionWords 2, 1)
encType t = (dataValues, ptrValues) where
dataValues = [ (0, encUInt16 discrim)
, (64, encUInt64 typeId)
]
ptrValues = case listElementType of
Nothing -> []
Just et -> [ (0, encStruct typeSize $ encType et) ]
(discrim, typeId, listElementType) = case t of
BuiltinType BuiltinVoid -> (0::Word16, 0, Nothing)
BuiltinType BuiltinBool -> (1, 0, Nothing)
BuiltinType BuiltinInt8 -> (2, 0, Nothing)
BuiltinType BuiltinInt16 -> (3, 0, Nothing)
BuiltinType BuiltinInt32 -> (4, 0, Nothing)
BuiltinType BuiltinInt64 -> (5, 0, Nothing)
BuiltinType BuiltinUInt8 -> (6, 0, Nothing)
BuiltinType BuiltinUInt16 -> (7, 0, Nothing)
BuiltinType BuiltinUInt32 -> (8, 0, Nothing)
BuiltinType BuiltinUInt64 -> (9, 0, Nothing)
BuiltinType BuiltinFloat32 -> (10, 0, Nothing)
BuiltinType BuiltinFloat64 -> (11, 0, Nothing)
BuiltinType BuiltinText -> (12, 0, Nothing)
BuiltinType BuiltinData -> (13, 0, Nothing)
BuiltinType BuiltinObject -> (18, 0, Nothing)
ListType et -> (14, 0, Just et)
EnumType d -> (15, enumId d, Nothing)
StructType d -> (16, structId d, Nothing)
InterfaceType d -> (17, interfaceId d, Nothing)
InlineStructType _ -> error "Inline types not currently supported by codegen plugins."
InlineListType _ _ -> error "Inline types not currently supported by codegen plugins."
InlineDataType _ -> error "Inline types not currently supported by codegen plugins."
valueSize = (DataSectionWords 2, 1)
encValue t maybeValue = (dataValues, ptrValues) where
dataValues = (0, encUInt16 discrim) : (case (maybeValue, fieldSize t) of
(Nothing, _) -> []
(_, SizeVoid) -> []
(Just value, SizeData _) -> [ (64, encodeDataValue t value) ]
(_, SizePointer) -> []
(_, SizeInlineComposite _ _) ->
error "Inline types not currently supported by codegen plugins.")
ptrValues = case (maybeValue, fieldSize t) of
(Nothing, _) -> []
(_, SizeVoid) -> []
(_, SizeData _) -> []
(Just value, SizePointer) -> [ (0, encodePointerValue t value) ]
(_, SizeInlineComposite _ _) ->
error "Inline types not currently supported by codegen plugins."
discrim = case t of
BuiltinType BuiltinVoid -> 9::Word16
BuiltinType BuiltinBool -> 1
BuiltinType BuiltinInt8 -> 2
BuiltinType BuiltinInt16 -> 3
BuiltinType BuiltinInt32 -> 4
BuiltinType BuiltinInt64 -> 5
BuiltinType BuiltinUInt8 -> 6
BuiltinType BuiltinUInt16 -> 7
BuiltinType BuiltinUInt32 -> 8
BuiltinType BuiltinUInt64 -> 0
BuiltinType BuiltinFloat32 -> 10
BuiltinType BuiltinFloat64 -> 11
BuiltinType BuiltinText -> 12
BuiltinType BuiltinData -> 13
BuiltinType BuiltinObject -> 18
ListType _ -> 14
EnumType _ -> 15
StructType _ -> 16
InterfaceType _ -> 17
InlineStructType _ -> error "Inline types not currently supported by codegen plugins."
InlineListType _ _ -> error "Inline types not currently supported by codegen plugins."
InlineDataType _ -> error "Inline types not currently supported by codegen plugins."
annotationSize = (DataSectionWords 1, 1)
encAnnotation (annId, (desc, value)) = (dataValues, ptrValues) where
dataValues = [ (0, encUInt64 annId) ]
ptrValues = [ (0, encStruct valueSize $ encValue (annotationType desc) (Just value)) ]
encAnnotationList annotations =
encStructList annotationSize $ map encAnnotation $ Map.toList annotations
nodeSize = (DataSectionWords 3, 4)
encNode :: Desc -> ((Word64, String), ([(Integer, EncodedData)], [(Integer, EncodedPtr)]))
encNode desc = ((descId desc, dname), (dataValues, ptrValues)) where
dataValues = [ (0, encUInt64 $ descId desc)
, (64, encUInt64 $ scopedId desc)
, (128, encUInt16 discrim)
]
ptrValues = [ (0, encText dname)
, (1, encStructList nestedNodeSize $ map encNestedNode $ descNestedNodes desc)
, (2, encAnnotationList $ descAnnotations desc)
, (3, encStruct bodySize body)
]
dname = displayName desc
(discrim, bodySize, body) = case desc of
DescFile d -> (0::Word16, fileNodeSize, encFileNode d)
DescStruct d -> (1, structNodeSize, encStructNode d)
DescEnum d -> (2, enumNodeSize, encEnumNode d)
DescInterface d -> (3, interfaceNodeSize, encInterfaceNode d)
DescConstant d -> (4, constNodeSize, encConstNode d)
DescAnnotation d -> (5, annotationNodeSize, encAnnotationNode d)
_ -> error "Not a node type."
displayName (DescFile f) = fileName f
displayName desc = concat [fileName (descFile desc), ":", descName desc]
nestedNodeSize = (DataSectionWords 1, 1)
encNestedNode desc = (dataValues, ptrValues) where
dataValues = [ (0, encUInt64 $ descId desc) ]
ptrValues = [ (0, encText $ descName desc) ]
scopedId (DescFile _) = 0
scopedId desc = descId $ descParent desc
fileNodeSize = (DataSectionWords 0, 1)
encFileNode desc = (dataValues, ptrValues) where
dataValues = []
ptrValues = [ (0, encStructList importSize $ map encImport $ Map.toList $ fileImportMap desc) ]
importSize = (DataSectionWords 1, 1)
encImport (impName, impFile) = (dataValues2, ptrValues2) where
dataValues2 = [ (0, encUInt64 $ fileId impFile) ]
ptrValues2 = [ (0, encText impName) ]
structNodeSize = (DataSectionWords 1, 1)
encStructNode desc = (dataValues, ptrValues) where
dataValues = [ (0, encUInt16 $ dataSectionWordSize $ structDataSize desc)
, (16, encUInt16 $ structPointerCount desc)
, (32, encUInt16 (fieldSizeEnum preferredListEncoding::Word16))
]
ptrValues = [ (0, encStructList memberSize $ map encMember $
sortMembers $ structMembers desc) ]
preferredListEncoding = case (structDataSize desc, structPointerCount desc) of
(DataSectionWords 0, 0) -> SizeVoid
(DataSectionWords 0, 1) -> SizePointer
(DataSection1, 0) -> SizeData Size1
(DataSection8, 0) -> SizeData Size8
(DataSection16, 0) -> SizeData Size16
(DataSection32, 0) -> SizeData Size32
(DataSectionWords 1, 0) -> SizeData Size64
(ds, pc) -> SizeInlineComposite ds pc
-- Extract just the field and union members, annotate them with ordinals and code order,
-- and then sort by ordinal.
sortMembers members = sortBy (compare `on` (fst . snd)) $ zip [0::Word16 ..]
$ mapMaybe selectFieldOrUnion members
selectFieldOrUnion d@(DescField f) = Just (fieldNumber f, d)
selectFieldOrUnion d@(DescUnion u) = Just (unionNumber u, d)
selectFieldOrUnion _ = Nothing
memberSize = (DataSectionWords 1, 3)
encMember (codeOrder, (_, DescField field)) = (dataValues2, ptrValues2) where
dataValues2 = [ (0, encUInt16 $ fieldNumber field)
, (16, encUInt16 codeOrder)
, (32, encUInt16 (0::Word16)) -- discriminant
]
ptrValues2 = [ (0, encText $ fieldName field)
, (1, encAnnotationList $ fieldAnnotations field)
, (2, encStruct (DataSection32, 2) (dataValues3, ptrValues3))
]
-- StructNode.Field
dataValues3 = [ (0, encUInt32 $ offsetToInt $ fieldOffset field) ]
ptrValues3 = [ (0, encStruct typeSize $ encType $ fieldType field)
, (1, encStruct valueSize $ encValue (fieldType field) $
fieldDefaultValue field)
]
offsetToInt VoidOffset = 0
offsetToInt (DataOffset _ i) = i
offsetToInt (PointerOffset i) = i
offsetToInt (InlineCompositeOffset {}) =
error "Inline types not currently supported by codegen plugins."
encMember (codeOrder, (_, DescUnion union)) = (dataValues2, ptrValues2) where
dataValues2 = [ (0, encUInt16 $ unionNumber union)
, (16, encUInt16 codeOrder)
, (32, encUInt16 (1::Word16)) -- discriminant
]
ptrValues2 = [ (0, encText $ unionName union)
, (1, encAnnotationList $ unionAnnotations union)
, (2, encStruct (DataSection32, 1) (dataValues3, ptrValues3))
]
-- StructNode.Union
dataValues3 = [ (0, encUInt32 $ unionTagOffset union) ]
ptrValues3 = [ (0, encStructList memberSize $ map encMember $ sortMembers $
unionMembers union) ]
encMember _ = error "Not a field or union?"
enumNodeSize = (DataSectionWords 0, 1)
encEnumNode desc = (dataValues, ptrValues) where
dataValues = []
ptrValues = [ (0, encStructList enumerantSize $ map encEnumerant sortedEnumerants) ]
sortedEnumerants = sortBy (compare `on` (enumerantNumber . snd))
$ zip [0::Word16 ..] $ enumerants desc
enumerantSize = (DataSection16, 2)
encEnumerant (codeOrder, enumerant) = (dataValues2, ptrValues2) where
dataValues2 = [ (0, encUInt16 codeOrder) ]
ptrValues2 = [ (0, encText $ enumerantName enumerant)
, (1, encAnnotationList $ enumerantAnnotations enumerant)
]
interfaceNodeSize = (DataSectionWords 0, 1)
encInterfaceNode desc = (dataValues, ptrValues) where
dataValues = []
ptrValues = [ (0, encStructList methodSize $ map encMethod sortedMethods) ]
sortedMethods = sortBy (compare `on` (methodNumber . snd))
$ zip [0::Word16 ..] $ interfaceMethods desc
methodSize = (DataSection32, 4)
encMethod (codeOrder, method) = (dataValues2, ptrValues2) where
dataValues2 = [ (0, encUInt16 codeOrder)
, (16, encUInt16 requiredParamCount) ]
ptrValues2 = [ (0, encText $ methodName method)
, (1, encStructList paramSize $ map encParam $ methodParams method)
, (2, encStruct typeSize $ encType $ methodReturnType method)
, (3, encAnnotationList $ methodAnnotations method)
]
paramIndicesWithoutDefaults =
findIndices (isNothing . paramDefaultValue) $ methodParams method
requiredParamCount = maybe 0 (+1) $ listToMaybe
$ reverse paramIndicesWithoutDefaults
paramSize = (DataSectionWords 0, 4)
encParam param = (dataValues2, ptrValues2) where
dataValues2 = []
ptrValues2 = [ (0, encText $ paramName param)
, (1, encStruct typeSize $ encType $ paramType param)
, (2, encStruct valueSize $ encValue (paramType param) $
paramDefaultValue param)
, (3, encAnnotationList $ paramAnnotations param)
]
constNodeSize = (DataSectionWords 0, 2)
encConstNode desc = (dataValues, ptrValues) where
dataValues = []
ptrValues = [ (0, encStruct typeSize $ encType $ constantType desc)
, (1, encStruct valueSize $ encValue (constantType desc) $ Just $
constantValue desc)
]
annotationNodeSize = (DataSection16, 1)
encAnnotationNode desc = (dataValues, ptrValues) where
dataValues = [ (0, encTarget FileAnnotation)
, (1, encTarget ConstantAnnotation)
, (2, encTarget EnumAnnotation)
, (3, encTarget EnumerantAnnotation)
, (4, encTarget StructAnnotation)
, (5, encTarget FieldAnnotation)
, (6, encTarget UnionAnnotation)
, (7, encTarget InterfaceAnnotation)
, (8, encTarget MethodAnnotation)
, (9, encTarget ParamAnnotation)
, (10, encTarget AnnotationAnnotation)
]
ptrValues = [ (0, encStruct typeSize $ encType $ annotationType desc) ]
encTarget t = EncodedBit $ Set.member t $ annotationTargets desc
compiler/src/c++-header.mustache deleted 100644 → 0
View file @ ae33cf61
{{!
| 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.
Template for generated C++ header files.
}}// Generated code, DO NOT EDIT
#ifndef {{fileIncludeGuard}}
#define {{fileIncludeGuard}}
#include <capnp/generated-header-support.h>
{{#fileImports}}
{{#importIsSystem}}
#include <{{importFilename}}.h>
{{/importIsSystem}}
{{^importIsSystem}}
#include "{{importFilename}}.h"
{{/importIsSystem}}
{{/fileImports}}
{{#fileNamespaces}}
namespace {{namespaceName}} {
{{/fileNamespaces}}
{{! =========================================================================================== }}
{{#fileTypes}}
{{#typeStructOrUnion}}
struct {{typeFullName}} {
{{typeName}}() = delete;
class Reader;
class Builder;
{{#typeStruct}}
{{#structNestedStructs}}
struct {{nestedName}};
{{/structNestedStructs}}
{{#structUnions}}
struct {{unionTitleCase}};
{{/structUnions}}
{{#structNestedInterfaces}}
struct {{nestedName}};
{{/structNestedInterfaces}}
{{#structNestedEnums}}
enum class {{enumName}}: uint16_t {
{{#enumerants}}
{{enumerantName}} = {{enumerantNumber}},
{{/enumerants}}
};
{{/structNestedEnums}}
{{/typeStruct}}
{{#typeUnion}}
enum Which: uint16_t {
{{#unionFields}}
{{fieldUpperCase}} = {{fieldUnionDiscriminant}},
{{/unionFields}}
};
{{/typeUnion}}
private:
{{#typeFields}}
{{#fieldDefaultBytes}}
static const ::capnp::_::AlignedData<{{defaultWordCount}}> DEFAULT_{{fieldUpperCase}};
{{/fieldDefaultBytes}}
{{/typeFields}}
};
{{/typeStructOrUnion}}
{{/fileTypes}}
{{! ------------------------------------------------------------------------------------------- }}
{{#fileEnums}}
enum class {{enumName}}: uint16_t {
{{#enumerants}}
{{enumerantName}} = {{enumerantNumber}},
{{/enumerants}}
};
{{/fileEnums}}
{{! =========================================================================================== }}
{{#fileNamespaces}}
} // namespace
{{/fileNamespaces}}
namespace capnp {
namespace schemas {
{{#fileTypes}}
{{#typeSchema}}
extern const ::capnp::_::RawSchema s_{{schemaId}};
{{/typeSchema}}
{{/fileTypes}}
} // namespace schemas
namespace _ { // private
{{#fileTypes}}
{{#typeStructOrUnion}}
{{#typeStruct}}
CAPNP_DECLARE_STRUCT(
::{{#fileNamespaces}}{{namespaceName}}::{{/fileNamespaces}}{{typeFullName}}, {{structId}},
{{structDataSize}}, {{structPointerCount}}, {{structPreferredListEncoding}});
{{#structNestedEnums}}
CAPNP_DECLARE_ENUM(
::{{#fileNamespaces}}{{namespaceName}}::{{/fileNamespaces}}{{typeFullName}}::{{enumName}}, {{enumId}});
{{/structNestedEnums}}
{{#structUnions}}
CAPNP_DECLARE_UNION(
::{{#fileNamespaces}}{{namespaceName}}::{{/fileNamespaces}}{{structFullName}}::{{unionTitleCase}},
::{{#fileNamespaces}}{{namespaceName}}::{{/fileNamespaces}}{{structFullName}}, {{unionIndex}});
{{/structUnions}}
{{/typeStruct}}
{{/typeStructOrUnion}}
{{/fileTypes}}
{{#fileEnums}}
CAPNP_DECLARE_ENUM(
::{{#fileNamespaces}}{{namespaceName}}::{{/fileNamespaces}}{{enumName}}, {{enumId}});
{{/fileEnums}}
} // namespace capnp
} // namespace _ (private)
{{#fileNamespaces}}
namespace {{namespaceName}} {
{{/fileNamespaces}}
{{! =========================================================================================== }}
{{#fileTypes}}
{{#typeStructOrUnion}}
class {{typeFullName}}::Reader {
public:
typedef {{typeName}} Reads;
Reader() = default;
inline explicit Reader(::capnp::_::StructReader base): _reader(base) {}
{{#typeStruct}}
inline size_t totalSizeInWords() const {
return _reader.totalSize() / ::capnp::WORDS;
}
{{#structUnions}}
// {{unionDecl}}
inline {{unionTitleCase}}::Reader get{{unionTitleCase}}() const;
{{/structUnions}}
{{/typeStruct}}
{{#typeUnion}}
inline Which which() const;
{{/typeUnion}}
{{#typeFields}}
// {{fieldDecl}}
{{#fieldIsPrimitive}}
inline {{fieldType}} get{{fieldTitleCase}}() const;
{{/fieldIsPrimitive}}
{{^fieldIsPrimitive}}
inline bool has{{fieldTitleCase}}() const;
{{^fieldIsGenericObject}}
inline {{fieldType}}::Reader get{{fieldTitleCase}}() const;
{{/fieldIsGenericObject}}
{{/fieldIsPrimitive}}
{{#fieldIsGenericObject}}
template <typename T> inline typename T::Reader get{{fieldTitleCase}}() const;
template <typename T, typename Param> inline typename T::Reader
get{{fieldTitleCase}}(Param&& param) const;
{{/fieldIsGenericObject}}
{{/typeFields}}
private:
::capnp::_::StructReader _reader;
template <typename T, ::capnp::Kind k>
friend struct ::capnp::ToDynamic_;
template <typename T, ::capnp::Kind k>
friend struct ::capnp::_::PointerHelpers;
template <typename T, ::capnp::Kind k>
friend struct ::capnp::List;
friend class ::capnp::MessageBuilder;
friend class ::capnp::Orphanage;
friend ::kj::StringTree KJ_STRINGIFY({{typeFullName}}::Reader reader);
};
inline ::kj::StringTree KJ_STRINGIFY({{typeFullName}}::Reader reader) {
{{#typeStruct}}
return ::capnp::_::structString<{{typeFullName}}>(reader._reader);
{{/typeStruct}}
{{#typeUnion}}
return ::capnp::_::unionString<{{typeFullName}}>(reader._reader);
{{/typeUnion}}
}
{{! ------------------------------------------------------------------------------------------- }}
class {{typeFullName}}::Builder {
public:
typedef {{typeName}} Builds;
Builder() = default;
inline explicit Builder(::capnp::_::StructBuilder base): _builder(base) {}
inline operator Reader() const { return Reader(_builder.asReader()); }
inline Reader asReader() const { return *this; }
{{#typeStruct}}
inline size_t totalSizeInWords() { return asReader().totalSizeInWords(); }
{{#structUnions}}
// {{unionDecl}}
inline {{unionTitleCase}}::Builder get{{unionTitleCase}}();
{{/structUnions}}
{{/typeStruct}}
{{#typeUnion}}
inline Which which();
{{/typeUnion}}
{{#typeFields}}
// {{fieldDecl}}
{{#fieldIsPrimitive}}
inline {{fieldType}} get{{fieldTitleCase}}();
inline void set{{fieldTitleCase}}({{fieldType}} value);
{{/fieldIsPrimitive}}
{{^fieldIsPrimitive}}
inline bool has{{fieldTitleCase}}();
{{^fieldIsGenericObject}}
inline {{fieldType}}::Builder get{{fieldTitleCase}}();
inline void set{{fieldTitleCase}}({{fieldType}}::Reader other);
{{#fieldIsNonStructList}}
inline void set{{fieldTitleCase}}(
std::initializer_list<{{fieldElementReaderType}}> other);
{{/fieldIsNonStructList}}
{{#fieldIsListOrBlob}}
inline {{fieldType}}::Builder init{{fieldTitleCase}}(unsigned int size);
{{/fieldIsListOrBlob}}
{{#fieldIsStruct}}
inline {{fieldType}}::Builder init{{fieldTitleCase}}();
{{/fieldIsStruct}}
inline void adopt{{fieldTitleCase}}(::capnp::Orphan<{{fieldType}}>&& value);
inline ::capnp::Orphan<{{fieldType}}> disown{{fieldTitleCase}}();
{{/fieldIsGenericObject}}
{{/fieldIsPrimitive}}
{{#fieldIsGenericObject}}
template <typename T> inline typename T::Builder get{{fieldTitleCase}}();
template <typename T, typename Param> inline typename T::Builder
get{{fieldTitleCase}}(Param&& param);
template <typename T> inline void set{{fieldTitleCase}}(typename T::Reader value);
template <typename T, typename U> inline void
set{{fieldTitleCase}}(std::initializer_list<U> value);
template <typename T, typename... Params> inline typename T::Builder
init{{fieldTitleCase}}(Params&&... params);
template <typename T> void adopt{{fieldTitleCase}}(::capnp::Orphan<T>&& value);
template <typename T, typename... Params> ::capnp::Orphan<T>
disown{{fieldTitleCase}}(Params&&... params);
{{/fieldIsGenericObject}}
{{/typeFields}}
private:
::capnp::_::StructBuilder _builder;
template <typename T, ::capnp::Kind k>
friend struct ::capnp::ToDynamic_;
friend class ::capnp::Orphanage;
friend ::kj::StringTree KJ_STRINGIFY({{typeFullName}}::Builder builder);
};
inline ::kj::StringTree KJ_STRINGIFY({{typeFullName}}::Builder builder) {
{{#typeStruct}}
return ::capnp::_::structString<{{typeFullName}}>(builder._builder.asReader());
{{/typeStruct}}
{{#typeUnion}}
return ::capnp::_::unionString<{{typeFullName}}>(builder._builder.asReader());
{{/typeUnion}}
}
{{/typeStructOrUnion}}
{{/fileTypes}}
{{! =========================================================================================== }}
{{#fileTypes}}
{{#typeStructOrUnion}}
{{#typeStruct}}
{{#structUnions}}
inline {{unionFullName}}::Reader {{structFullName}}::Reader::get{{unionTitleCase}}() const {
return {{unionFullName}}::Reader(_reader);
}
inline {{unionFullName}}::Builder {{structFullName}}::Builder::get{{unionTitleCase}}() {
return {{unionFullName}}::Builder(_builder);
}
{{/structUnions}}
{{/typeStruct}}
{{#typeUnion}}
// {{unionFullName}}
inline {{unionFullName}}::Which {{unionFullName}}::Reader::which() const {
return _reader.getDataField<Which>({{unionTagOffset}} * ::capnp::ELEMENTS);
}
inline {{unionFullName}}::Which {{unionFullName}}::Builder::which() {
return _builder.getDataField<Which>({{unionTagOffset}} * ::capnp::ELEMENTS);
}
{{/typeUnion}}
{{! ------------------------------------------------------------------------------------------- }}
{{#typeFields}}
// {{typeFullName}}::{{fieldDecl}}
{{! ------------------------------------------------------------------------------------------- }}
{{#fieldIsPrimitive}}
inline {{fieldType}} {{typeFullName}}::Reader::get{{fieldTitleCase}}() const {
{{#fieldUnion}}
KJ_IREQUIRE(which() == {{unionTitleCase}}::{{fieldUpperCase}},
"Must check which() before get()ing a union member.");
{{/fieldUnion}}
return _reader.getDataField<{{fieldType}}>(
{{fieldOffset}} * ::capnp::ELEMENTS{{fieldDefaultMask}});
}
inline {{fieldType}} {{typeFullName}}::Builder::get{{fieldTitleCase}}() {
{{#fieldUnion}}
KJ_IREQUIRE(which() == {{unionTitleCase}}::{{fieldUpperCase}},
"Must check which() before get()ing a union member.");
{{/fieldUnion}}
return _builder.getDataField<{{fieldType}}>(
{{fieldOffset}} * ::capnp::ELEMENTS{{fieldDefaultMask}});
}
inline void {{typeFullName}}::Builder::set{{fieldTitleCase}}({{fieldType}} value{{fieldSetterDefault}}) {
{{#fieldUnion}}
_builder.setDataField<{{unionTitleCase}}::Which>(
{{unionTagOffset}} * ::capnp::ELEMENTS, {{unionTitleCase}}::{{fieldUpperCase}});
{{/fieldUnion}}
_builder.setDataField<{{fieldType}}>(
{{fieldOffset}} * ::capnp::ELEMENTS, value{{fieldDefaultMask}});
}
{{/fieldIsPrimitive}}
{{! ------------------------------------------------------------------------------------------- }}
{{^fieldIsPrimitive}}
inline bool {{typeFullName}}::Reader::has{{fieldTitleCase}}() const {
return !_reader.isPointerFieldNull({{fieldOffset}} * ::capnp::POINTERS);
}
inline bool {{typeFullName}}::Builder::has{{fieldTitleCase}}() {
return !_builder.isPointerFieldNull({{fieldOffset}} * ::capnp::POINTERS);
}
{{^fieldIsGenericObject}}
inline {{fieldType}}::Reader {{typeFullName}}::Reader::get{{fieldTitleCase}}() const {
{{#fieldUnion}}
KJ_IREQUIRE(which() == {{unionTitleCase}}::{{fieldUpperCase}},
"Must check which() before get()ing a union member.");
{{/fieldUnion}}
return ::capnp::_::PointerHelpers<{{fieldType}}>::get(
_reader, {{fieldOffset}} * ::capnp::POINTERS{{#fieldDefaultBytes}},
DEFAULT_{{fieldUpperCase}}.words{{#fieldIsBlob}}, {{defaultBlobSize}}{{/fieldIsBlob}}{{/fieldDefaultBytes}});
}
inline {{fieldType}}::Builder {{typeFullName}}::Builder::get{{fieldTitleCase}}() {
{{#fieldUnion}}
KJ_IREQUIRE(which() == {{unionTitleCase}}::{{fieldUpperCase}},
"Must check which() before get()ing a union member.");
{{/fieldUnion}}
return ::capnp::_::PointerHelpers<{{fieldType}}>::get(
_builder, {{fieldOffset}} * ::capnp::POINTERS{{#fieldDefaultBytes}},
DEFAULT_{{fieldUpperCase}}.words{{#fieldIsBlob}}, {{defaultBlobSize}}{{/fieldIsBlob}}{{/fieldDefaultBytes}});
}
inline void {{typeFullName}}::Builder::set{{fieldTitleCase}}({{fieldType}}::Reader value) {
{{#fieldUnion}}
_builder.setDataField<{{unionTitleCase}}::Which>(
{{unionTagOffset}} * ::capnp::ELEMENTS, {{unionTitleCase}}::{{fieldUpperCase}});
{{/fieldUnion}}
::capnp::_::PointerHelpers<{{fieldType}}>::set(
_builder, {{fieldOffset}} * ::capnp::POINTERS, value);
}
{{#fieldIsNonStructList}}
inline void {{typeFullName}}::Builder::set{{fieldTitleCase}}(
std::initializer_list<{{fieldElementReaderType}}> value) {
{{#fieldUnion}}
_builder.setDataField<{{unionTitleCase}}::Which>(
{{unionTagOffset}} * ::capnp::ELEMENTS, {{unionTitleCase}}::{{fieldUpperCase}});
{{/fieldUnion}}
::capnp::_::PointerHelpers<{{fieldType}}>::set(
_builder, {{fieldOffset}} * ::capnp::POINTERS, value);
}
{{/fieldIsNonStructList}}
{{#fieldIsListOrBlob}}
inline {{fieldType}}::Builder {{typeFullName}}::Builder::init{{fieldTitleCase}}(unsigned int size) {
{{#fieldUnion}}
_builder.setDataField<{{unionTitleCase}}::Which>(
{{unionTagOffset}} * ::capnp::ELEMENTS, {{unionTitleCase}}::{{fieldUpperCase}});
{{/fieldUnion}}
return ::capnp::_::PointerHelpers<{{fieldType}}>::init(
_builder, {{fieldOffset}} * ::capnp::POINTERS, size);
}
{{/fieldIsListOrBlob}}
{{#fieldIsStruct}}
inline {{fieldType}}::Builder {{typeFullName}}::Builder::init{{fieldTitleCase}}() {
{{#fieldUnion}}
_builder.setDataField<{{unionTitleCase}}::Which>(
{{unionTagOffset}} * ::capnp::ELEMENTS, {{unionTitleCase}}::{{fieldUpperCase}});
{{/fieldUnion}}
return ::capnp::_::PointerHelpers<{{fieldType}}>::init(
_builder, {{fieldOffset}} * ::capnp::POINTERS);
}
{{/fieldIsStruct}}
inline void {{typeFullName}}::Builder::adopt{{fieldTitleCase}}(
::capnp::Orphan<{{fieldType}}>&& value) {
{{#fieldUnion}}
_builder.setDataField<{{unionTitleCase}}::Which>(
{{unionTagOffset}} * ::capnp::ELEMENTS, {{unionTitleCase}}::{{fieldUpperCase}});
{{/fieldUnion}}
::capnp::_::PointerHelpers<{{fieldType}}>::adopt(
_builder, {{fieldOffset}} * ::capnp::POINTERS, kj::mv(value));
}
inline ::capnp::Orphan<{{fieldType}}> {{typeFullName}}::Builder::disown{{fieldTitleCase}}() {
{{#fieldUnion}}
KJ_IREQUIRE(which() == {{unionTitleCase}}::{{fieldUpperCase}},
"Must check which() before get()ing a union member.");
{{/fieldUnion}}
return ::capnp::_::PointerHelpers<{{fieldType}}>::disown(
_builder, {{fieldOffset}} * ::capnp::POINTERS);
}
{{/fieldIsGenericObject}}
{{! ------------------------------------------------------------------------------------------- }}
{{#fieldIsGenericObject}}
template <typename T>
inline typename T::Reader {{typeFullName}}::Reader::get{{fieldTitleCase}}() const {
{{#fieldUnion}}
KJ_IREQUIRE(which() == {{unionTitleCase}}::{{fieldUpperCase}},
"Must check which() before get()ing a union member.");
{{/fieldUnion}}
return ::capnp::_::PointerHelpers<T>::get(
_reader, {{fieldOffset}} * ::capnp::POINTERS);
}
template <typename T>
inline typename T::Builder {{typeFullName}}::Builder::get{{fieldTitleCase}}() {
{{#fieldUnion}}
KJ_IREQUIRE(which() == {{unionTitleCase}}::{{fieldUpperCase}},
"Must check which() before get()ing a union member.");
{{/fieldUnion}}
return ::capnp::_::PointerHelpers<T>::get(
_builder, {{fieldOffset}} * ::capnp::POINTERS);
}
template <typename T, typename Param>
inline typename T::Reader {{typeFullName}}::Reader::get{{fieldTitleCase}}(Param&& param) const {
{{#fieldUnion}}
KJ_IREQUIRE(which() == {{unionTitleCase}}::{{fieldUpperCase}},
"Must check which() before get()ing a union member.");
{{/fieldUnion}}
return ::capnp::_::PointerHelpers<T>::getDynamic(
_reader, {{fieldOffset}} * ::capnp::POINTERS, ::kj::fwd<Param>(param));
}
template <typename T, typename Param>
inline typename T::Builder {{typeFullName}}::Builder::get{{fieldTitleCase}}(Param&& param) {
{{#fieldUnion}}
KJ_IREQUIRE(which() == {{unionTitleCase}}::{{fieldUpperCase}},
"Must check which() before get()ing a union member.");
{{/fieldUnion}}
return ::capnp::_::PointerHelpers<T>::getDynamic(
_builder, {{fieldOffset}} * ::capnp::POINTERS, ::kj::fwd<Param>(param));
}
template <typename T>
inline void {{typeFullName}}::Builder::set{{fieldTitleCase}}(typename T::Reader value) {
{{#fieldUnion}}
_builder.setDataField<{{unionTitleCase}}::Which>(
{{unionTagOffset}} * ::capnp::ELEMENTS, {{unionTitleCase}}::{{fieldUpperCase}});
{{/fieldUnion}}
::capnp::_::PointerHelpers<T>::set(
_builder, {{fieldOffset}} * ::capnp::POINTERS, value);
}
template <typename T, typename U>
inline void {{typeFullName}}::Builder::set{{fieldTitleCase}}(std::initializer_list<U> value) {
{{#fieldUnion}}
_builder.setDataField<{{unionTitleCase}}::Which>(
{{unionTagOffset}} * ::capnp::ELEMENTS, {{unionTitleCase}}::{{fieldUpperCase}});
{{/fieldUnion}}
::capnp::_::PointerHelpers<T>::set(
_builder, {{fieldOffset}} * ::capnp::POINTERS, value);
}
template <typename T, typename... Params>
inline typename T::Builder {{typeFullName}}::Builder::init{{fieldTitleCase}}(Params&&... params) {
{{#fieldUnion}}
_builder.setDataField<{{unionTitleCase}}::Which>(
{{unionTagOffset}} * ::capnp::ELEMENTS, {{unionTitleCase}}::{{fieldUpperCase}});
{{/fieldUnion}}
return ::capnp::_::PointerHelpers<T>::init(
_builder, {{fieldOffset}} * ::capnp::POINTERS, ::kj::fwd<Params>(params)...);
}
template <typename T>
void {{typeFullName}}::Builder::adopt{{fieldTitleCase}}(::capnp::Orphan<T>&& value) {
{{#fieldUnion}}
_builder.setDataField<{{unionTitleCase}}::Which>(
{{unionTagOffset}} * ::capnp::ELEMENTS, {{unionTitleCase}}::{{fieldUpperCase}});
{{/fieldUnion}}
::capnp::_::PointerHelpers<T>::adopt(
_builder, {{fieldOffset}} * ::capnp::POINTERS, kj::mv(value));
}
template <typename T, typename... Params>
::capnp::Orphan<T> {{typeFullName}}::Builder::disown{{fieldTitleCase}}(Params&&... params) {
{{#fieldUnion}}
KJ_IREQUIRE(which() == {{unionTitleCase}}::{{fieldUpperCase}},
"Must check which() before get()ing a union member.");
{{/fieldUnion}}
return ::capnp::_::PointerHelpers<T>::disown(
_builder, {{fieldOffset}} * ::capnp::POINTERS, ::kj::fwd<Params>(params)...);
}
{{/fieldIsGenericObject}}
{{/fieldIsPrimitive}}
{{/typeFields}}
{{/typeStructOrUnion}}
{{/fileTypes}}
{{! =========================================================================================== }}
{{#fileNamespaces}}
} // namespace
{{/fileNamespaces}}
#endif // {{fileIncludeGuard}}
compiler/src/c++-source.mustache deleted 100644 → 0
View file @ ae33cf61
{{!
| 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.
Template for generated C++ source files.
}}// Generated code, DO NOT EDIT
#include "{{fileName}}.h"
{{#fileNamespaces}}
namespace {{namespaceName}} {
{{/fileNamespaces}}
{{#fileTypes}}
{{#typeStructOrUnion}}
{{#typeStruct}}
{{#structFields}}
{{#fieldDefaultBytes}}
const ::capnp::_::AlignedData<{{defaultWordCount}}>
{{structFullName}}::DEFAULT_{{fieldUpperCase}} = {
{ {{defaultByteList}} }
};
{{/fieldDefaultBytes}}
{{/structFields}}
{{/typeStruct}}
{{/typeStructOrUnion}}
{{/fileTypes}}
{{#fileNamespaces}}
} // namespace
{{/fileNamespaces}}
namespace capnp {
namespace schemas {
{{#fileTypes}}
{{#typeSchema}}
static const ::capnp::_::AlignedData<{{schemaWordCount}}> b_{{schemaId}} = {
{ {{schemaBytes}} }
};
static const ::capnp::_::RawSchema* const d_{{schemaId}}[] = {
{{#schemaDependencies}}
&s_{{dependencyId}},
{{/schemaDependencies}}
};
static const ::capnp::_::RawSchema::MemberInfo m_{{schemaId}}[] = {
{{#schemaMembersByName}}
{ {{memberUnionIndex}}, {{memberIndex}} },
{{/schemaMembersByName}}
};
const ::capnp::_::RawSchema s_{{schemaId}} = {
0x{{schemaId}}, b_{{schemaId}}.words, {{schemaWordCount}}, d_{{schemaId}}, m_{{schemaId}},
{{schemaDependencyCount}}, {{schemaMemberCount}}, nullptr, nullptr
};
{{/typeSchema}}
{{/fileTypes}}
} // namespace schemas
namespace _ { // private
{{#fileTypes}}
{{#typeStructOrUnion}}
{{#typeStruct}}
CAPNP_DEFINE_STRUCT(
::{{#fileNamespaces}}{{namespaceName}}::{{/fileNamespaces}}{{typeFullName}});
{{#structNestedEnums}}
CAPNP_DEFINE_ENUM(
::{{#fileNamespaces}}{{namespaceName}}::{{/fileNamespaces}}{{typeFullName}}::{{enumName}});
{{/structNestedEnums}}
{{#structUnions}}
CAPNP_DEFINE_UNION(
::{{#fileNamespaces}}{{namespaceName}}::{{/fileNamespaces}}{{structFullName}}::{{unionTitleCase}});
{{/structUnions}}
{{/typeStruct}}
{{/typeStructOrUnion}}
{{/fileTypes}}
{{#fileEnums}}
CAPNP_DEFINE_ENUM(
::{{#fileNamespaces}}{{namespaceName}}::{{/fileNamespaces}}{{enumName}});
{{/fileEnums}}
} // namespace _ (private)
} // namespace capnp
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