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