Commit 2c8595bc authored by Kenton Varda's avatar Kenton Varda

Redo IDs. They now look like ordinals, except that they are 64-bit unique integers.

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