diff --git a/IO.hs b/IO.hs new file mode 100644 --- /dev/null +++ b/IO.hs @@ -0,0 +1,83 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +module IO + ( parseFile + , parseBondFile + , parseASTFile + , parseNamespaceMappings + , parseAliasMappings + ) + where + +import System.Exit +import System.FilePath +import System.Directory +import System.IO +import Control.Applicative +import Prelude +import Data.Aeson (eitherDecode) +import Control.Monad.Loops (firstM) +import qualified Data.ByteString.Lazy as BL +import Language.Bond.Syntax.Types (Bond(..)) +import Language.Bond.Syntax.JSON() +import Language.Bond.Parser +import Language.Bond.Codegen.TypeMapping + + +parseFile :: [FilePath] -> FilePath -> IO(Bond) +parseFile importDirs file = + if takeExtension file == ".json" then + parseASTFile file else + parseBondFile importDirs file + + +parseBondFile :: [FilePath] -> FilePath -> IO(Bond) +parseBondFile importDirs file = do + cwd <- getCurrentDirectory + input <- readFileUtf8 file + result <- parseBond file input (cwd file) readImportFile + case result of + Left err -> do + putStrLn $ "Error parsing " ++ file ++ ": " ++ show err + exitFailure + Right bond -> return bond + where + readImportFile parentFile importFile = do + path <- findFilePath (takeDirectory parentFile:importDirs) + case path of + Just path' -> do + content <- readFileUtf8 path' + return (path', content) + Nothing -> fail $ "Can't find import file " ++ importFile + where + findFilePath dirs = fmap ( importFile) <$> firstM (doesFileExist . ( importFile)) dirs + + readFileUtf8 name = do + h <- openFile name ReadMode + hSetEncoding h utf8_bom + hGetContents h + + +parseASTFile :: FilePath -> IO(Bond) +parseASTFile file = do + input <- BL.readFile file + case eitherDecode input of + Left err -> do + putStrLn $ "Error parsing " ++ file ++ ": " ++ show err + exitFailure + Right bond -> return bond + + +parseAliasMappings :: [String] -> IO [AliasMapping] +parseAliasMappings = mapM $ + \ s -> case parseAliasMapping s of + Left err -> fail $ show err + Right m -> return m + + +parseNamespaceMappings :: [String] -> IO [NamespaceMapping] +parseNamespaceMappings = mapM $ + \ s -> case parseNamespaceMapping s of + Left err -> fail $ show err + Right m -> return m diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +The MIT License (MIT) + +Copyright (c) 2014 Microsoft + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,120 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE RecordWildCards #-} + +import System.Environment (getArgs, withArgs) +import System.Directory +import System.FilePath +import Data.Monoid +import Control.Monad +import Prelude +import Control.Concurrent.Async +import GHC.Conc (getNumProcessors, setNumCapabilities) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy.IO as L +import Data.Aeson (encode) +import qualified Data.ByteString.Lazy as BL +import Language.Bond.Syntax.Types (Bond(..), Declaration(..), Import, Type(..)) +import Language.Bond.Syntax.JSON() +import Language.Bond.Syntax.SchemaDef +import Language.Bond.Codegen.Util +import Language.Bond.Codegen.Templates +import Language.Bond.Codegen.TypeMapping +import Options +import IO + +type Template = MappingContext -> String -> [Import] -> [Declaration] -> (String, Text) + +main :: IO() +main = do + args <- getArgs + options <- (if null args then withArgs ["--help"] else id) getOptions + setJobs $ jobs options + case options of + Cpp {..} -> cppCodegen options + Cs {..} -> csCodegen options + Schema {..} -> writeSchema options + _ -> print options + +setJobs :: Maybe Int -> IO () +setJobs Nothing = return () +setJobs (Just n) + | n > 0 = setNumCapabilities n + | otherwise = do + numProc <- getNumProcessors + -- if n is less than 0 use that many fewer jobs than processors + setNumCapabilities $ max 1 (numProc + n) + +concurrentlyFor_ :: [a] -> (a -> IO b) -> IO () +concurrentlyFor_ = (void .) . flip mapConcurrently + + +writeSchema :: Options -> IO() +writeSchema Schema {..} = + concurrentlyFor_ files $ \file -> do + let fileName = takeBaseName file + bond <- parseFile import_dir file + if runtime_schema then + forM_ (bondDeclarations bond) (writeSchemaDef fileName) + else + BL.writeFile (output_dir fileName <.> "json") $ encode bond + where + writeSchemaDef fileName s@Struct{..} | null declParams = + BL.writeFile (output_dir fileName <.> declName <.> "json") $ encodeSchemaDef $ BT_UserDefined s [] + writeSchemaDef _ _ = return () + +writeSchema _ = error "writeSchema: impossible happened." + +cppCodegen :: Options -> IO() +cppCodegen options@Cpp {..} = do + let typeMapping = maybe cppTypeMapping cppCustomAllocTypeMapping allocator + concurrentlyFor_ files $ codeGen options typeMapping $ + [ reflection_h + , types_cpp + , types_h header enum_header allocator + , apply_h applyProto apply_attribute + , apply_cpp applyProto + ] <> + [ enum_h | enum_header] + where + applyProto = map snd $ filter (enabled apply) protocols + enabled a p = null a || fst p `elem` a + protocols = + [ (Compact, Protocol "bond::CompactBinaryReader" + "bond::CompactBinaryWriter") + , (Fast, Protocol "bond::FastBinaryReader" + "bond::FastBinaryWriter") + , (Simple, Protocol "bond::SimpleBinaryReader" + "bond::SimpleBinaryWriter") + ] +cppCodegen _ = error "cppCodegen: impossible happened." + + +csCodegen :: Options -> IO() +csCodegen options@Cs {..} = do + let fieldMapping = if readonly_properties + then ReadOnlyProperties + else if fields + then PublicFields + else Properties + let typeMapping = if collection_interfaces then csCollectionInterfacesTypeMapping else csTypeMapping + let templates = [ types_cs Class fieldMapping ] + concurrentlyFor_ files $ codeGen options typeMapping templates +csCodegen _ = error "csCodegen: impossible happened." + +codeGen :: Options -> TypeMapping -> [Template] -> FilePath -> IO () +codeGen options typeMapping templates file = do + let outputDir = output_dir options + let baseName = takeBaseName file + aliasMapping <- parseAliasMappings $ using options + namespaceMapping <- parseNamespaceMappings $ namespace options + (Bond imports namespaces declarations) <- parseFile (import_dir options) file + let mappingContext = MappingContext typeMapping aliasMapping namespaceMapping namespaces + forM_ templates $ \template -> do + let (suffix, code) = template mappingContext baseName imports declarations + let fileName = baseName ++ suffix + createDirectoryIfMissing True outputDir + let content = if (no_banner options) then code else (commonHeader "//" fileName <> code) + L.writeFile (outputDir fileName) content + diff --git a/Options.hs b/Options.hs new file mode 100644 --- /dev/null +++ b/Options.hs @@ -0,0 +1,108 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +{-# OPTIONS_GHC -fno-cse #-} + +module Options + ( getOptions + , processOptions + , Options(..) + , ApplyOptions(..) + ) where + +import Paths_bond (version) +import Data.Version (showVersion) +import System.Console.CmdArgs +import System.Console.CmdArgs.Explicit (processValue) + +data ApplyOptions = + Compact | + Fast | + Simple + deriving (Show, Data, Typeable, Eq) + +data Options + = Options + | Cpp + { files :: [FilePath] + , import_dir :: [FilePath] + , output_dir :: FilePath + , using :: [String] + , namespace :: [String] + , header :: [String] + , enum_header :: Bool + , allocator :: Maybe String + , apply :: [ApplyOptions] + , apply_attribute :: Maybe String + , jobs :: Maybe Int + , no_banner :: Bool + } + | Cs + { files :: [FilePath] + , import_dir :: [FilePath] + , output_dir :: FilePath + , using :: [String] + , namespace :: [String] + , collection_interfaces :: Bool + , readonly_properties :: Bool + , fields :: Bool + , jobs :: Maybe Int + , no_banner :: Bool + } + | Schema + { files :: [FilePath] + , import_dir :: [FilePath] + , output_dir :: FilePath + , jobs :: Maybe Int + , runtime_schema :: Bool + } + deriving (Show, Data, Typeable) + +cpp :: Options +cpp = Cpp + { files = def &= typFile &= args + , import_dir = def &= typDir &= name "i" &= help "Add the directory to import search path" + , output_dir = "." &= typDir &= name "o" &= help "Output generated files into the specified directory" + , using = def &= typ "MAPPING" &= name "u" &= help "Custom type alias mapping in the form alias=type" + , namespace = def &= typ "MAPPING" &= name "n" &= help "Custom namespace mapping in the form bond_namespace=language_namespace" + , header = def &= typ "HEADER" &= name "h" &= help "Emit #include HEADER into the generated files" + , enum_header = def &= name "e" &= help "Generate enums into a separate header file" + , allocator = def &= typ "ALLOCATOR" &= help "Generate types using the specified allocator" + , apply = def &= typ "PROTOCOL" &= help "Generate Apply function overloads for the specified protocol only; supported protocols: compact, fast and simple" + , apply_attribute = def &= typ "ATTRIBUTE" &= help "Prefix the declarations of Apply functions with the specified C++ attribute/declspec" + , jobs = def &= opt "0" &= typ "NUM" &= name "j" &= help "Run NUM jobs simultaneously (or '$ncpus' if no NUM is not given)" + , no_banner = def &= help "Omit the banner at the top of generated files" + } &= + name "c++" &= + help "Generate C++ code" + +cs :: Options +cs = Cs + { collection_interfaces = def &= name "c" &= help "Use interfaces rather than concrete collection types" + , readonly_properties = def &= name "r" &= help "Generate private property setters" + , fields = def &= name "f" &= help "Generate public fields rather than properties" + } &= + name "c#" &= + help "Generate C# code" + +schema :: Options +schema = Schema + { runtime_schema = def &= help "Generate Simple JSON representation of runtime schema, aka SchemaDef" + } &= + name "schema" &= + help "Output the JSON representation of the schema" + + +mode :: Mode (CmdArgs Options) +mode = cmdArgsMode $ modes [cpp, cs, schema] &= + program "gbc" &= + help "Compile Bond schema file(s) and generate specified output. The schema file(s) can be in one of two formats: Bond IDL or JSON representation of the schema abstract syntax tree as produced by `gbc schema`. Multiple schema files can be specified either directly on the command line or by listing them in a text file passed to gbc via @listfile syntax." &= + summary ("Bond Compiler " ++ showVersion version ++ ", (C) Microsoft") + +getOptions :: IO Options +getOptions = cmdArgsRun mode + +processOptions :: [String] -> Options +processOptions = cmdArgsValue . processValue mode diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/bond.cabal b/bond.cabal new file mode 100644 --- /dev/null +++ b/bond.cabal @@ -0,0 +1,113 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +name: bond +version: 0.4.0.1 +cabal-version: >= 1.8 +synopsis: Bond schema compiler and code generator +description: Bond is a cross-platform framework for handling schematized + data. It supports cross-language de/serialization and + powerful generic mechanisms for efficiently manipulating + data. + . + This package contains a library for parsing the Bond + schema definition language and performing template-based + code generation. The library includes built-in templates + for generating standard Bond C++ and C# code, as well as + utilities for writing custom codegen templates. + . + The package also contains a command-line compiler/codegen + tool, named gbc, which is primarily used to generate code + for C++ and C# programs using Bond. + +homepage: https://github.com/Microsoft/bond +license: MIT +license-file: LICENSE +author: Adam Sapek +maintainer: Adam Sapek +bug-reports: https://github.com/Microsoft/bond/issues +copyright: Copyright (c) Microsoft. All rights reserved. +category: Language +build-type: Simple + +source-repository head + type: git + location: git@github.com:Microsoft/bond.git + +library + hs-source-dirs: src + build-depends: aeson >= 0.7.0.6 && < 0.10.0.0, + base >= 4.5 && < 5, + bytestring >= 0.10, + filepath >= 1.0, + mtl >= 2.1, + parsec >= 3.1, + shakespeare >= 2.0, + text >= 0.11 + ghc-options: -Wall + exposed-modules: Language.Bond.Parser + Language.Bond.Util + Language.Bond.Syntax.Types + Language.Bond.Syntax.JSON + Language.Bond.Syntax.Util + Language.Bond.Syntax.SchemaDef + Language.Bond.Codegen.Util + Language.Bond.Codegen.TypeMapping + Language.Bond.Codegen.Templates + other-modules: Language.Bond.Codegen.CustomMapping + Language.Bond.Codegen.Cpp.Apply_cpp + Language.Bond.Codegen.Cpp.Apply_h + Language.Bond.Codegen.Cpp.Enum_h + Language.Bond.Codegen.Cpp.Reflection_h + Language.Bond.Codegen.Cpp.Types_cpp + Language.Bond.Codegen.Cpp.Types_h + Language.Bond.Codegen.Cs.Types_cs + Language.Bond.Codegen.Cpp.ApplyOverloads + Language.Bond.Codegen.Cpp.Util + Language.Bond.Codegen.Cs.Util + Language.Bond.Lexer + Language.Bond.Syntax.Internal + Paths_bond + +test-suite gbc-tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests, . + main-is: Main.hs + other-modules: Tests.Codegen + Tests.Syntax + ghc-options: -threaded -Wall + build-depends: bond, + aeson >= 0.7.0.6 && < 0.10.0.0, + base >= 4.5 && < 5, + bytestring >= 0.10, + cmdargs >= 0.10.10, + directory >= 1.1, + filepath >= 1.0, + monad-loops >= 0.4, + text >= 0.11, + derive, + HUnit, + QuickCheck, + Diff >= 0.2 && < 0.4, + pretty, + tasty, + tasty-golden, + tasty-hunit, + tasty-quickcheck + +executable gbc + main-is: Main.hs + other-modules: IO + Options + ghc-options: -threaded -Wall + build-depends: bond, + aeson >= 0.7.0.6 && < 0.10.0.0, + async >= 2.0.1.0, + base >= 4.5 && < 5, + bytestring >= 0.10, + cmdargs >= 0.10.10, + process < 1.4, + directory >= 1.1, + filepath >= 1.0, + monad-loops >= 0.4, + text >= 0.11 diff --git a/src/Language/Bond/Codegen/Cpp/ApplyOverloads.hs b/src/Language/Bond/Codegen/Cpp/ApplyOverloads.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/Cpp/ApplyOverloads.hs @@ -0,0 +1,65 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE QuasiQuotes, OverloadedStrings, RecordWildCards #-} + +module Language.Bond.Codegen.Cpp.ApplyOverloads (applyOverloads, Protocol(..)) where + +import Data.Monoid +import Prelude +import Data.Text.Lazy (Text) +import Text.Shakespeare.Text +import Language.Bond.Syntax.Types +import Language.Bond.Codegen.Util + +-- | Protocol data type is used to specify what protocols the @Apply@ function +-- overloads should be generated for. +data Protocol = + Protocol + { protocolReader :: String -- ^ Name of the class implementing the protocol reader. + , protocolWriter :: String -- ^ Name of the class implementing the protocol writer. + } + + +-- Apply overloads +applyOverloads :: [Protocol] -> Text -> Text -> Declaration -> Text +applyOverloads protocols attr body Struct {..} | null declParams = [lt| + // + // Overloads of Apply function with common transforms for #{declName}. + // These overloads will be selected using argument dependent lookup + // before bond::Apply function templates. + // + #{attr}bool Apply(const bond::To<#{declName}>& transform, + const bond::bonded<#{declName}>& value)#{body} + + #{attr}bool Apply(const bond::InitSchemaDef& transform, + const #{declName}& value)#{body} + #{newlineSep 1 applyOverloads' protocols}|] + where + applyOverloads' p = [lt|#{deserialization p} + #{serialization serializer p} + #{serialization marshaler p}|] + + serializer = "Serializer" :: String + marshaler = "Marshaler" :: String + + deserialization Protocol {..} = [lt| + #{attr}bool Apply(const bond::To<#{declName}>& transform, + const bond::bonded<#{declName}, #{protocolReader}&>& value)#{body} + + #{attr}bool Apply(const bond::To<#{declName}>& transform, + const bond::bonded& value)#{body}|] + + serialization transform Protocol {..} = [lt| + #{attr}bool Apply(const bond::#{transform}<#{protocolWriter} >& transform, + const #{declName}& value)#{body} + + #{attr}bool Apply(const bond::#{transform}<#{protocolWriter} >& transform, + const bond::bonded<#{declName}>& value)#{body} + #{newlineSep 1 (transcoding transform) protocols}|] + where + transcoding transform' Protocol {protocolReader = fromReader} = [lt| + #{attr}bool Apply(const bond::#{transform'}<#{protocolWriter} >& transform, + const bond::bonded<#{declName}, #{fromReader}&>& value)#{body}|] + +applyOverloads _ _ _ _ = mempty diff --git a/src/Language/Bond/Codegen/Cpp/Apply_cpp.hs b/src/Language/Bond/Codegen/Cpp/Apply_cpp.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/Cpp/Apply_cpp.hs @@ -0,0 +1,35 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE QuasiQuotes, OverloadedStrings #-} + +module Language.Bond.Codegen.Cpp.Apply_cpp (apply_cpp) where + +import Data.Text.Lazy (Text) +import Text.Shakespeare.Text +import Language.Bond.Syntax.Types +import Language.Bond.Codegen.TypeMapping +import Language.Bond.Codegen.Util +import Language.Bond.Codegen.Cpp.ApplyOverloads +import qualified Language.Bond.Codegen.Cpp.Util as CPP + +-- | Codegen template for generating /base_name/_apply.cpp containing +-- definitions of the @Apply@ function overloads for the specified protocols. +apply_cpp :: [Protocol] -- ^ List of protocols for which @Apply@ overloads should be generated + -> MappingContext -> String -> [Import] -> [Declaration] -> (String, Text) +apply_cpp protocols cpp file _imports declarations = ("_apply.cpp", [lt| +#include "#{file}_apply.h" +#include "#{file}_reflection.h" + +#{CPP.openNamespace cpp} + #{newlineSepEnd 1 (applyOverloads protocols attr body) declarations} +#{CPP.closeNamespace cpp} +|]) + where + body = [lt| + { + return bond::Apply<>(transform, value); + }|] + + attr = [lt||] + diff --git a/src/Language/Bond/Codegen/Cpp/Apply_h.hs b/src/Language/Bond/Codegen/Cpp/Apply_h.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/Cpp/Apply_h.hs @@ -0,0 +1,44 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE QuasiQuotes, OverloadedStrings, RecordWildCards #-} + +module Language.Bond.Codegen.Cpp.Apply_h (apply_h) where + +import System.FilePath +import Prelude +import Data.Text.Lazy (Text) +import Text.Shakespeare.Text +import Language.Bond.Syntax.Types +import Language.Bond.Util +import Language.Bond.Codegen.Util +import Language.Bond.Codegen.TypeMapping +import Language.Bond.Codegen.Cpp.ApplyOverloads +import qualified Language.Bond.Codegen.Cpp.Util as CPP + +-- | Codegen template for generating /base_name/_apply.h containing declarations of +-- +-- function overloads for the specified protocols. +apply_h :: [Protocol] -- ^ List of protocols for which @Apply@ overloads should be generated + -> Maybe String -- ^ Optional attribute to decorate the @Apply@ function declarations + -> MappingContext -> String -> [Import] -> [Declaration] -> (String, Text) +apply_h protocols attribute cpp file imports declarations = ("_apply.h", [lt| +#pragma once + +#include "#{file}_types.h" +#include +#include +#{newlineSep 0 includeImport imports} + +#{CPP.openNamespace cpp} + #{newlineSepEnd 1 (applyOverloads protocols attr semi) declarations} +#{CPP.closeNamespace cpp} +|]) + where + includeImport (Import path) = [lt|#include "#{dropExtension path}_apply.h"|] + + attr = optional (\a -> [lt|#{a} + |]) attribute + + semi = [lt|;|] + diff --git a/src/Language/Bond/Codegen/Cpp/Enum_h.hs b/src/Language/Bond/Codegen/Cpp/Enum_h.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/Cpp/Enum_h.hs @@ -0,0 +1,43 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE QuasiQuotes, OverloadedStrings, RecordWildCards #-} + +module Language.Bond.Codegen.Cpp.Enum_h (enum_h) where + +import Data.Monoid +import Prelude +import Data.Text.Lazy (Text) +import Text.Shakespeare.Text +import Language.Bond.Syntax.Types +import Language.Bond.Codegen.TypeMapping +import Language.Bond.Codegen.Util +import qualified Language.Bond.Codegen.Cpp.Util as CPP + +-- | Codegen template for generating /base_name/_enum.h containing definitions +-- of enums. Generated by with @--enum-header@ flag. +enum_h :: MappingContext -> String -> [Import] -> [Declaration] -> (String, Text) +enum_h cpp _file _imports declarations = ("_enum.h", [lt| +#pragma once + +#{CPP.openNamespace cpp} +namespace _bond_enumerators +{ + #{newlineSep 1 typeDeclaration declarations} +} // namespace _bond_enumerators + +#{newlineSep 0 usingDeclaration declarations} +#{CPP.closeNamespace cpp} +|]) + where + -- enum definition + typeDeclaration e@Enum {..} = [lt| + namespace #{declName} + { + #{CPP.enumDefinition e} + } // namespace #{declName} +|] + typeDeclaration _ = mempty + + usingDeclaration Enum {..} = [lt|using namespace _bond_enumerators::#{declName};|] + usingDeclaration _ = mempty diff --git a/src/Language/Bond/Codegen/Cpp/Reflection_h.hs b/src/Language/Bond/Codegen/Cpp/Reflection_h.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/Cpp/Reflection_h.hs @@ -0,0 +1,118 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE QuasiQuotes, OverloadedStrings, RecordWildCards #-} + +module Language.Bond.Codegen.Cpp.Reflection_h (reflection_h) where + +import System.FilePath +import Data.Monoid +import Prelude +import Data.Text.Lazy (Text) +import qualified Data.Foldable as F +import Text.Shakespeare.Text +import Language.Bond.Syntax.Types +import Language.Bond.Codegen.TypeMapping +import Language.Bond.Codegen.Util +import qualified Language.Bond.Codegen.Cpp.Util as CPP + +-- | Codegen template for generating /base_name/_reflection.h containing schema +-- metadata definitions. +reflection_h :: MappingContext -> String -> [Import] -> [Declaration] -> (String, Text) +reflection_h cpp file imports declarations = ("_reflection.h", [lt| +#pragma once + +#include "#{file}_types.h" +#include +#{newlineSepEnd 0 include imports} +#{CPP.openNamespace cpp} + #{doubleLineSepEnd 1 schema declarations} +#{CPP.closeNamespace cpp} +|]) + where + idl = MappingContext idlTypeMapping [] [] [] + + -- C++ type + cppType = getTypeName cpp + + -- template for generating #include statement from import + include (Import path) = [lt|#include "#{dropExtension path}_reflection.h"|] + + -- template for generating struct schema + schema s@Struct {..} = [lt|// + // #{declName} + // + #{CPP.template s}struct #{structName}::Schema + { + typedef #{baseType structBase} base; + + static const bond::Metadata metadata; + #{newlineBeginSep 2 fieldMetadata structFields} + + public: struct var + {#{fieldTemplates structFields}}; + + private: typedef boost::mpl::list<> fields0; + #{newlineSep 2 pushField indexedFields} + + public: typedef #{typename}fields#{length structFields}::type fields; + #{constructor} + + static bond::Metadata GetMetadata() + { + return bond::reflection::MetadataInit#{metadataInitArgs}("#{declName}", "#{getDeclTypeName idl s}", + #{CPP.attributeInit declAttributes} + ); + } + }; + #{onlyTemplate $ CPP.schemaMetadata cpp s}|] + where + structParams = CPP.structParams s + + structName = CPP.structName s + + onlyTemplate x = if null declParams then mempty else x + + metadataInitArgs = onlyTemplate [lt||] + + typename = onlyTemplate [lt|typename |] + + -- constructor, generated only for struct templates + constructor = onlyTemplate [lt| + Schema() + { + // Force instantiation of template statics + (void)metadata; + #{newlineSep 3 static structFields} + }|] + where + static Field {..} = [lt|(void)s_#{fieldName}_metadata;|] + + -- reversed list of field names zipped with indexes + indexedFields :: [(String, Int)] + indexedFields = zipWith ((,) . fieldName) (reverse structFields) [0..] + + baseType (Just base) = cppType base + baseType Nothing = "bond::no_base" + + pushField (field, i) = + [lt|private: typedef #{typename}boost::mpl::push_front::type fields#{i + 1};|] + + fieldMetadata Field {..} = + [lt|private: static const bond::Metadata s_#{fieldName}_metadata;|] + + fieldTemplates = F.foldMap $ \ f@Field {..} -> [lt| + // #{fieldName} + typedef bond::reflection::FieldTemplate< + #{fieldOrdinal}, + #{CPP.modifierTag f}, + #{structName}, + #{cppType fieldType}, + &#{structName}::#{fieldName}, + &s_#{fieldName}_metadata + > #{fieldName}; + |] + + + -- nothing to generate for enums + schema _ = mempty diff --git a/src/Language/Bond/Codegen/Cpp/Types_cpp.hs b/src/Language/Bond/Codegen/Cpp/Types_cpp.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/Cpp/Types_cpp.hs @@ -0,0 +1,75 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE QuasiQuotes, OverloadedStrings, RecordWildCards #-} + +module Language.Bond.Codegen.Cpp.Types_cpp (types_cpp) where + +import Data.Monoid +import Prelude +import Data.Text.Lazy (Text) +import Text.Shakespeare.Text +import Language.Bond.Syntax.Types +import Language.Bond.Codegen.TypeMapping +import Language.Bond.Codegen.Util +import qualified Language.Bond.Codegen.Cpp.Util as CPP + +-- | Codegen template for generating /base_name/_type.cpp containing +-- definitions of helper functions and schema metadata static variables. +types_cpp :: MappingContext -> String -> [Import] -> [Declaration] -> (String, Text) +types_cpp cpp file _imports declarations = ("_types.cpp", [lt| +#include "#{file}_reflection.h" +#include + +#{CPP.openNamespace cpp} + #{doubleLineSepEnd 1 statics declarations} +#{CPP.closeNamespace cpp} +|]) + where + -- definitions of Schema statics for non-generic structs + statics s@Struct {..} = + if null declParams then CPP.schemaMetadata cpp s else mempty + + -- global variables for enum name/value conversions + statics Enum {..} = [lt| + namespace _bond_enumerators + { + namespace #{declName} + { + const + std::map _name_to_value_#{declName} = + boost::assign::map_list_of + #{newlineSep 4 constant enumConstants}; + + const + std::map _value_to_name_#{declName} = + bond::reverse_map(_name_to_value_#{declName}); + + const std::string& ToString(enum #{declName} value) + { + std::map::const_iterator it = + GetValueToNameMap(value).find(value); + + if (GetValueToNameMap(value).end() == it) + bond::InvalidEnumValueException(value, "#{declName}"); + + return it->second; + } + + void FromString(const std::string& name, enum #{declName}& value) + { + std::map::const_iterator it = + _name_to_value_#{declName}.find(name); + + if (_name_to_value_#{declName}.end() == it) + bond::InvalidEnumValueException(name.c_str(), "#{declName}"); + + value = it->second; + } + + } // namespace #{declName} + } // namespace _bond_enumerators|] + where + constant Constant {..} = [lt|("#{constantName}", #{constantName})|] + + statics _ = mempty diff --git a/src/Language/Bond/Codegen/Cpp/Types_h.hs b/src/Language/Bond/Codegen/Cpp/Types_h.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/Cpp/Types_h.hs @@ -0,0 +1,370 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE QuasiQuotes, OverloadedStrings, RecordWildCards #-} + +module Language.Bond.Codegen.Cpp.Types_h (types_h) where + +import System.FilePath +import Data.Maybe +import Data.Monoid +import Prelude +import Numeric +import Data.Text.Lazy.Builder +import qualified Data.Text.Lazy as L +import qualified Data.Foldable as F +import Text.Shakespeare.Text +import Paths_bond (version) +import Data.Version +import Language.Bond.Syntax.Types +import Language.Bond.Syntax.Util +import Language.Bond.Syntax.Internal +import Language.Bond.Util +import Language.Bond.Codegen.TypeMapping +import Language.Bond.Codegen.Util +import qualified Language.Bond.Codegen.Cpp.Util as CPP + +-- | Codegen template for generating /base_name/_type.h containing definitions +-- of C++ types representing the schema. +types_h :: [String] -- ^ list of optional header files to be @#include@'ed by the generated code + -> Bool -- ^ 'True' to generate enum definitions into a separate file /base_name/_enum.h + -> Maybe String -- ^ optional custom allocator to be used in the generated code + -> MappingContext -> String -> [Import] -> [Declaration] -> (String, L.Text) +types_h userHeaders enumHeader allocator cpp file imports declarations = ("_types.h", [lt| +#pragma once +#{newlineBeginSep 0 includeHeader userHeaders} +#include + +#if BOND_VERSION < 0x302 +#error This file was generated by a newer version of Bond compiler +#error and is incompatible with your version Bond library. +#endif + +#if BOND_MIN_CODEGEN_VERSION > 0x#{hexVersion version} +#error This file was generated by an older version of Bond compiler +#error and is incompatible with your version Bond library. +#endif + +#include +#include +#{newlineSep 0 optionalHeader bondHeaders} +#{includeEnum} +#{newlineSepEnd 0 includeImport imports} +#{CPP.openNamespace cpp} + #{doubleLineSep 1 typeDeclaration declarations} +#{CPP.closeNamespace cpp} +#{optional usesAllocatorSpecialization allocator} +|]) + where + hexVersion (Version xs _) = foldr showHex "" xs + cppType = getTypeName cpp + + idl = MappingContext idlTypeMapping [] [] [] + + cppDefaultValue = CPP.defaultValue cpp + + includeImport (Import path) = [lt|#include "#{dropExtension path}_types.h"|] + + optionalHeader (False, _) = mempty + optionalHeader (True, header) = includeHeader header + + includeHeader header = [lt|#include #{header}|] + + includeEnum = if enumHeader then [lt|#include "#{file}_enum.h"|] else mempty + + -- True if declarations have any type satisfying f + have f = getAny $ F.foldMap g declarations + where + g Struct{..} = F.foldMap (foldMapType f . fieldType) structFields + <> optional (foldMapType f) structBase + g _ = mempty + + anyBonded (BT_Bonded _) = Any True + anyBonded _ = Any False + + anyBlob BT_Blob = Any True + anyBlob _ = Any False + + anyNullable = Any . isNullable + + bondHeaders :: [(Bool, String)] + bondHeaders = [ + (have anyNullable, ""), + (have anyBonded, ""), + (have anyBlob, "")] + + usesAllocatorSpecialization alloc = [lt| +#if !defined(BOND_NO_CXX11_ALLOCATOR) +namespace std +{ + #{doubleLineSep 1 usesAllocator declarations} +} +#endif +|] + where + usesAllocator s@Struct {..} = [lt|template + struct uses_allocator<#{typename} #{getDeclTypeName cpp s}#{CPP.structParams s}, _Alloc> + : is_convertible<_Alloc, #{allocParam}> + {};|] + where + typename = if null declParams then mempty else [lt|typename|] + allocParam = if last alloc == '>' then alloc ++ " " else alloc + usesAllocator _ = mempty + + -- forward declaration + typeDeclaration f@Forward {..} = [lt|#{CPP.template f}struct #{declName};|] + + -- struct definition + typeDeclaration s@Struct {..} = [lt| + #{template}struct #{declName}#{optional base structBase} + { + #{newlineSepEnd 2 field structFields}#{defaultCtor} + + #{copyCtor} + #{moveCtor} + #{optional allocatorCtor allocator} + #{assignmentOp} + + bool operator==(const #{declName}&#{otherParam}) const + { + return true#{optional baseEqual structBase}#{newlineBeginSep 4 fieldEqual structFields}; + } + + bool operator!=(const #{declName}& other) const + { + return !(*this == other); + } + + void swap(#{declName}&#{otherParam}) + { + using std::swap;#{optional swapBase structBase}#{newlineBeginSep 3 swapField structFields} + } + + struct Schema; + + protected: + #{initMetadata} + }; + + #{template}inline void swap(#{structName}& left, #{structName}& right) + { + left.swap(right); + }|] + where + template = CPP.template s + structName = CPP.structName s + + otherParam = if hasOnlyMetaFields then mempty else [lt| other|] + hasOnlyMetaFields = not (any (not . getAny . metaField) structFields) && isNothing structBase + hasMetaFields = getAny $ foldMapStructFields metaField s + + base x = [lt| + : #{cppType x}|] + + field Field {..} = [lt|#{cppType fieldType} #{fieldName};|] + + notMeta Field {fieldType = BT_MetaName, ..} _ = [lt|/* skip bond_meta::name field '#{fieldName}' */|] + notMeta Field {fieldType = BT_MetaFullName, ..} _ = [lt|/* skip bond_meta::full_name field '#{fieldName}' */|] + notMeta _ f = f + + fieldEqual f@Field {..} = notMeta f [lt|&& (#{fieldName} ==#{otherParam}.#{fieldName})|] + + baseEqual b = [lt| + && (static_cast(*this) == static_cast(#{otherParam}))|] + + swapField f@Field {..} = notMeta f [lt|swap(#{fieldName},#{otherParam}.#{fieldName});|] + + swapBase b = [lt| + #{cppType b}::swap(#{otherParam});|] + + -- value to pass to field initializer in ctor initialize list + -- or Nothing if field doesn't need explicit initialization + initValue (BT_Maybe _) _ = Nothing + initValue t (Just d) = Just $ cppDefaultValue t d + initValue (BT_TypeParam _) _ = Just mempty + initValue (BT_UserDefined a@Alias {} args) d + | customAliasMapping cpp a = Just mempty + | otherwise = initValue (resolveAlias a args) d + initValue t _ + | isScalar t = Just mempty + | otherwise = Nothing + + -- constructor initializer list from 'base' and 'fields' initializers + initializeList base' fields = between colon mempty $ commaLineSep 3 id [base', fields] + where + colon = [lt| + : |] + + -- constructor body + ctorBody = if hasMetaFields then [lt| + { + InitMetadata("#{declName}", "#{getDeclTypeName idl s}"); + }|] + else [lt| + { + }|] + + -- default constructor + defaultCtor = [lt| + #{declName}()#{initList}#{ctorBody}|] + where + initList = initializeList mempty + $ commaLineSep 3 fieldInit structFields + fieldInit Field {..} = optional (\x -> [lt|#{fieldName}(#{x})|]) + $ initValue fieldType fieldDefault + + allocatorCtor alloc = [lt| + explicit + #{declName}(const #{alloc}&#{allocParam})#{initList}#{ctorBody} + |] + where + allocParam = if needAlloc then [lt| allocator|] else mempty + where + needAlloc = isJust structBase || any (allocParameterized . fieldType) structFields + initList = initializeList + (optional baseInit structBase) + (commaLineSep 3 fieldInit structFields) + baseInit b = [lt|#{cppType b}(allocator)|] + fieldInit Field {..} = optional (\x -> [lt|#{fieldName}(#{x})|]) + $ allocInitValue fieldType fieldDefault + allocInitValue t@(BT_UserDefined a@Alias {} args) d + | allocParameterized t = allocInitValue (resolveAlias a args) d + | otherwise = initValue t d + allocInitValue (BT_Nullable t) _ = allocInitValue t Nothing + allocInitValue (BT_Maybe t) _ = allocInitValue t Nothing + allocInitValue t (Just d) + | isString t = Just [lt|#{cppDefaultValue t d}, allocator|] + allocInitValue t Nothing + | isList t || isMetaName t || isString t || isStruct t = Just "allocator" + | isAssociative t = Just [lt|std::less<#{keyType t}>(), allocator|] + allocInitValue t d = initValue t d + keyType (BT_Set key) = cppType key + keyType (BT_Map key _) = cppType key + keyType (BT_UserDefined a@Alias {} args) = keyType $ resolveAlias a args + keyType _ = error "allocatorCtor/keyType: impossible happened." + allocParameterized t = (isStruct t) || (L.isInfixOf (L.pack alloc) . toLazyText $ cppType t) + + -- copy constructor + copyCtor = if hasMetaFields then define else implicitlyDeclared + where + -- default OK when there are no meta fields + implicitlyDeclared = CPP.ifndef CPP.defaultedFunctions [lt| + // Compiler generated copy ctor OK + #{declName}(const #{declName}& other) = default;|] + + -- define ctor to initialize meta fields + define = [lt|#{declName}(const #{declName}& other)#{initList}#{ctorBody}|] + where + initList = initializeList + (optional baseCopy structBase) + (commaLineSep 3 fieldCopy structFields) + baseCopy b = [lt|#{cppType b}(other)|] + fieldCopy Field {..} = [lt|#{fieldName}(other.#{fieldName}#{getAllocator fieldType})|] + getAllocator BT_MetaName = [lt|.get_allocator()|] + getAllocator BT_MetaFullName = [lt|.get_allocator()|] + getAllocator _ = mempty + + -- move constructor + moveCtor = CPP.ifndef CPP.rvalueReferences [lt| + #{declName}(#{declName}&&#{param})#{initList}#{ctorBody}|] + where + initList = initializeList + (optional baseMove structBase) + (commaLineSep 3 fieldMove structFields) + baseMove b = [lt|#{cppType b}(std::move(other))|] + fieldMove Field {..} = [lt|#{fieldName}(std::move(other.#{fieldName}))|] + param = if initList == mempty then mempty else [lt| other|] + + -- operator= + assignmentOp = if hasMetaFields then define else implicitlyDeclared + where + -- default OK when there are no meta fields + implicitlyDeclared = CPP.ifndef CPP.defaultedFunctions [lt| + // Compiler generated operator= OK + #{declName}& operator=(const #{declName}& other) = default;|] + + -- define operator= using swap + define = [lt|#{declName}& operator=(const #{declName}& other) + { + #{declName}(other).swap(*this); + return *this; + }|] + + initMetadata = [lt|void InitMetadata(const char*#{nameParam}, const char*#{qualifiedNameParam}) + {#{newlineBeginSep 3 id [baseInit, nameInit, qualifiedInit]} + }|] + where + nameParam = if baseInit == mempty && nameInit == mempty then mempty else [lt| name|] + qualifiedNameParam = if baseInit == mempty && qualifiedInit == mempty then mempty else [lt| qualified_name|] + baseInit = optional (\b -> [lt|#{cppType b}::InitMetadata(name, qualified_name);|]) structBase + nameInit = newlineSep 3 init' structFields + where + init' Field {fieldType = BT_MetaName, ..} = [lt|this->#{fieldName} = name;|] + init' _ = mempty + qualifiedInit = newlineSep 3 init' structFields + where + init' Field {fieldType = BT_MetaFullName, ..} = [lt|this->#{fieldName} = qualified_name;|] + init' _ = mempty + + -- enum definition and helpers + typeDeclaration e@Enum {..} = [lt| + namespace _bond_enumerators + { + namespace #{declName} + { + #{enumDefinition} + extern const std::map _value_to_name_#{declName}; + extern const std::map _name_to_value_#{declName}; + + inline + const char* GetTypeName(enum #{declName}) + { + return "#{declName}"; + } + + inline + const char* GetTypeName(enum #{declName}, const bond::qualified_name_tag&) + { + return "#{getDeclTypeName idl e}"; + } + + inline + const std::map& GetValueToNameMap(enum #{declName}) + { + return _value_to_name_#{declName}; + } + + inline + const std::map& GetNameToValueMap(enum #{declName}) + { + return _name_to_value_#{declName}; + } + + const std::string& ToString(enum #{declName} value); + + void FromString(const std::string& name, enum #{declName}& value); + + inline + bool ToEnum(enum #{declName}& value, const std::string& name) + { + std::map::const_iterator it = + _name_to_value_#{declName}.find(name); + + if (_name_to_value_#{declName}.end() == it) + return false; + + value = it->second; + + return true; + } + } // namespace #{declName} + } // namespace _bond_enumerators + + #{enumUsing}|] + where + enumDefinition = if enumHeader then mempty else [lt|#{CPP.enumDefinition e} + |] + enumUsing = if enumHeader then mempty else [lt|using namespace _bond_enumerators::#{declName}; + |] + + typeDeclaration _ = mempty diff --git a/src/Language/Bond/Codegen/Cpp/Util.hs b/src/Language/Bond/Codegen/Cpp/Util.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/Cpp/Util.hs @@ -0,0 +1,145 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE QuasiQuotes, OverloadedStrings, RecordWildCards #-} +{-# OPTIONS_GHC -Wwarn #-} + +module Language.Bond.Codegen.Cpp.Util + ( openNamespace + , closeNamespace + , structName + , structParams + , template + , modifierTag + , defaultValue + , attributeInit + , schemaMetadata + , ifndef + , defaultedFunctions + , rvalueReferences + , enumDefinition + ) where + +import Data.Monoid +import Prelude +import Data.Text.Lazy (Text) +import Text.Shakespeare.Text +import Language.Bond.Syntax.Types +import Language.Bond.Syntax.Util +import Language.Bond.Util +import Language.Bond.Codegen.Util +import Language.Bond.Codegen.TypeMapping + +-- open namespaces +openNamespace :: MappingContext -> Text +openNamespace cpp = newlineSep 0 open $ getNamespace cpp + where + open n = [lt|namespace #{n} +{|] + +-- close namespaces in reverse order +closeNamespace :: MappingContext -> Text +closeNamespace cpp = newlineSep 0 close (reverse $ getNamespace cpp) + where + close n = [lt|} // namespace #{n}|] + +structName :: Declaration -> String +structName s@Struct {..} = declName <> structParams s +structName _ = error "structName: impossible happened." + +structParams :: Declaration -> String +structParams Struct {..} = angles $ sepBy ", " paramName declParams +structParams _ = error "structName: impossible happened." + +template :: Declaration -> Text +template d = if null $ declParams d then mempty else [lt|template + |] + where + params = sepBy ", typename " paramName $ declParams d + +-- attribute initializer +attributeInit :: [Attribute] -> Text +attributeInit [] = "bond::reflection::Attributes()" +attributeInit xs = [lt|boost::assign::map_list_of#{newlineBeginSep 5 attrNameValue xs}|] + where + idl = MappingContext idlTypeMapping [] [] [] + attrNameValue Attribute {..} = [lt|("#{getQualifiedName idl attrName}", "#{attrValue}")|] + + +-- modifier tag type for a field +modifierTag :: Field -> Text +modifierTag Field {..} = [lt|bond::reflection::#{modifier fieldType fieldModifier}_field_modifier|] + where + modifier BT_MetaName _ = [lt|required_optional|] + modifier BT_MetaFullName _ = [lt|required_optional|] + modifier _ RequiredOptional = [lt|required_optional|] + modifier _ Required = [lt|required|] + modifier _ _ = [lt|optional|] + +defaultValue :: MappingContext -> Type -> Default -> Text +defaultValue _ BT_WString (DefaultString x) = [lt|L"#{x}"|] +defaultValue _ BT_String (DefaultString x) = [lt|"#{x}"|] +defaultValue _ BT_Float (DefaultFloat x) = [lt|#{x}f|] +defaultValue _ BT_Int64 (DefaultInteger (-9223372036854775808)) = [lt|-9223372036854775807LL-1|] +defaultValue _ BT_Int64 (DefaultInteger x) = [lt|#{x}LL|] +defaultValue _ BT_UInt64 (DefaultInteger x) = [lt|#{x}ULL|] +defaultValue _ BT_Int32 (DefaultInteger (-2147483648)) = [lt|-2147483647-1|] +defaultValue m t (DefaultEnum x) = enumValue m t x +defaultValue _ _ (DefaultBool True) = "true" +defaultValue _ _ (DefaultBool False) = "false" +defaultValue _ _ (DefaultInteger x) = [lt|#{x}|] +defaultValue _ _ (DefaultFloat x) = [lt|#{x}|] +defaultValue _ _ (DefaultNothing) = mempty +defaultValue m (BT_UserDefined a@Alias {..} args) d = defaultValue m (resolveAlias a args) d +defaultValue _ _ _ = error "defaultValue: impossible happened." + +enumValue :: ToText a => MappingContext -> Type -> a -> Text +enumValue cpp (BT_UserDefined e@Enum {..} _) x = + [lt|#{getQualifiedName cpp $ getDeclNamespace cpp e}::_bond_enumerators::#{declName}::#{x}|] +enumValue _ _ _ = error "enumValue: impossible happened." + +-- schema metadata static member definitions +schemaMetadata :: MappingContext -> Declaration -> Text +schemaMetadata cpp s@Struct {..} = [lt| + #{template s}const bond::Metadata #{structName s}::Schema::metadata + = #{structName s}::Schema::GetMetadata();#{newlineBeginSep 1 staticDef structFields}|] + where + -- static member definition for field metadata + staticDef f@Field {..} + | fieldModifier == Optional && null fieldAttributes = [lt| + #{template s}const bond::Metadata #{structName s}::Schema::s_#{fieldName}_metadata + = bond::reflection::MetadataInit(#{defaultInit f}"#{fieldName}");|] + | otherwise = [lt| + #{template s}const bond::Metadata #{structName s}::Schema::s_#{fieldName}_metadata + = bond::reflection::MetadataInit(#{defaultInit f}"#{fieldName}", #{modifierTag f}::value, + #{attributeInit fieldAttributes});|] + where + defaultInit Field {fieldDefault = (Just def)} = [lt|#{explicitDefault def}, |] + defaultInit _ = mempty + explicitDefault (DefaultNothing) = "bond::nothing" + explicitDefault d@(DefaultInteger _) = staticCast d + explicitDefault d@(DefaultFloat _) = staticCast d + explicitDefault d = defaultValue cpp fieldType d + staticCast d = [lt|static_cast<#{getTypeName cpp fieldType}>(#{defaultValue cpp fieldType d})|] +schemaMetadata _ _ = error "schemaMetadata: impossible happened." + +defaultedFunctions, rvalueReferences :: Text +defaultedFunctions = [lt|BOND_NO_CXX11_DEFAULTED_FUNCTIONS|] +rvalueReferences = [lt|BOND_NO_CXX11_RVALUE_REFERENCES|] + +ifndef :: ToText a => a -> Text -> Text +ifndef m = between [lt| +#ifndef #{m}|] [lt| +#endif|] + +enumDefinition :: Declaration -> Text +enumDefinition Enum {..} = [lt|enum #{declName} + { + #{commaLineSep 3 constant enumConstants} + };|] + where + constant Constant {..} = [lt|#{constantName}#{optional value constantValue}|] + value (-2147483648) = [lt| = -2147483647-1|] + value x = [lt| = #{x}|] +enumDefinition _ = error "enumDefinition: impossible happened." + diff --git a/src/Language/Bond/Codegen/Cs/Types_cs.hs b/src/Language/Bond/Codegen/Cs/Types_cs.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/Cs/Types_cs.hs @@ -0,0 +1,145 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE QuasiQuotes, OverloadedStrings, RecordWildCards #-} + +module Language.Bond.Codegen.Cs.Types_cs + ( types_cs + , FieldMapping(..) + , StructMapping(..) + ) where + +import Data.Monoid +import qualified Data.Foldable as F +import Prelude +import Data.Text.Lazy (Text) +import Text.Shakespeare.Text +import Language.Bond.Syntax.Types +import Language.Bond.Syntax.Util +import Language.Bond.Syntax.Internal +import Language.Bond.Util +import Language.Bond.Codegen.TypeMapping +import Language.Bond.Codegen.Util +import qualified Language.Bond.Codegen.Cs.Util as CS + +-- | C# representation of schema structs +data StructMapping = + Class -- ^ public partial class + deriving Eq + +-- | Representation of schema fields in the generated C# types +data FieldMapping = + PublicFields | -- ^ public fields + Properties | -- ^ auto-properties + ReadOnlyProperties -- ^ auto-properties with private setter + deriving Eq + +-- | Codegen template for generating definitions of C# types representing the schema. +types_cs + :: StructMapping -- ^ Specifies how to represent schema structs + -> FieldMapping -- ^ Specifies how to represent schema fields + -> MappingContext -> String -> [Import] -> [Declaration] -> (String, Text) +types_cs structMapping fieldMapping cs _ _ declarations = (fileSuffix, [lt| +#{CS.disableReSharperWarnings} +namespace #{csNamespace} +{ + using System.Collections.Generic; + + #{doubleLineSep 1 typeDefinition declarations} +} // #{csNamespace} +|]) + where + idl = MappingContext idlTypeMapping [] [] [] + + -- C# type + csType = getTypeName cs + csNamespace = sepBy "." toText $ getNamespace cs + + access = case structMapping of + _ -> [lt|public |] + + fileSuffix = case structMapping of + _ -> "_types.cs" + + struct = case structMapping of + _ -> [lt|public partial class |] + + typeAttributes s = case structMapping of + _ -> CS.typeAttributes cs s + + propertyAttributes f = case structMapping of + Class -> CS.propertyAttributes cs f + + -- C# type definition for schema struct + typeDefinition s@Struct {..} = [lt|#{typeAttributes s}#{struct}#{declName}#{params}#{maybe interface baseClass structBase}#{constraints} + { + #{doubleLineSep 2 property structFields}#{constructors} + }|] + where + interface = case structMapping of + _ -> mempty + + -- type parameters + params = angles $ sepBy ", " paramName declParams + + -- constraints + constraints = CS.paramConstraints declParams + + -- base + callBaseCtor = getAny $ optional (foldMapFields metaField) structBase + + baseClass x = [lt| + : #{csType x}|] + + baseCtor = if not callBaseCtor then mempty else [lt| + : base(fullName, name)|] + + -- default value + csDefault = CS.defaultValue cs + + -- constructors + constructors = if noCtor then mempty else [lt| + + public #{declName}() + : this("#{getDeclTypeName idl s}", "#{declName}") + {} + + protected #{declName}(string fullName, string name)#{baseCtor} + { + #{newlineSep 3 initializer structFields} + }|] + where + noCtor = not callBaseCtor && (fieldMapping == PublicFields && noMetaFields || null structFields) + noMetaFields = not $ getAny $ F.foldMap metaField structFields + + -- property or field + property f@Field {..} = + [lt|#{propertyAttributes f}#{new}#{access}#{csType fieldType} #{fieldName}#{autoPropertyOrField}|] + where + autoPropertyOrField = case fieldMapping of + PublicFields -> [lt|#{optional fieldInitializer $ csDefault f};|] + Properties -> [lt| { get; set; }|] + ReadOnlyProperties -> [lt| { get; private set; }|] + fieldInitializer x = [lt| = #{x}|] + new = if isBaseField fieldName structBase then "new " else "" :: String + + -- initializers in constructor + initializer f@Field {..} = optional fieldInit $ def f + where + fieldInit x = [lt|#{this fieldName} = #{x};|] + this = if fieldName == "name" || fieldName == "fullName" then ("this." ++) else id + def Field {fieldType = BT_MetaName} = Just "name" + def Field {fieldType = BT_MetaFullName} = Just "fullName" + def x = if fieldMapping == PublicFields then Nothing else csDefault x + + -- C# enum definition for schema enum + typeDefinition e@Enum {..} = [lt|#{CS.typeAttributes cs e}public enum #{declName} + { + #{newlineSep 2 constant enumConstants} + }|] + where + -- constant + constant Constant {..} = let value x = [lt| = #{x}|] in + [lt|#{constantName}#{optional value constantValue},|] + + typeDefinition _ = mempty diff --git a/src/Language/Bond/Codegen/Cs/Util.hs b/src/Language/Bond/Codegen/Cs/Util.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/Cs/Util.hs @@ -0,0 +1,130 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE QuasiQuotes, OverloadedStrings, RecordWildCards #-} + +module Language.Bond.Codegen.Cs.Util + ( typeAttributes + , propertyAttributes + , schemaAttributes + , paramConstraints + , defaultValue + , disableReSharperWarnings + ) where + +import Data.Int (Int64) +import Data.Monoid +import Prelude +import Data.Text.Lazy (Text) +import Text.Shakespeare.Text +import Paths_bond (version) +import Data.Version (showVersion) +import Language.Bond.Syntax.Types +import Language.Bond.Syntax.Util +import Language.Bond.Codegen.TypeMapping +import Language.Bond.Codegen.Util + +disableReSharperWarnings :: Text +disableReSharperWarnings = [lt| +#region ReSharper warnings +// ReSharper disable PartialTypeWithSinglePart +// ReSharper disable RedundantNameQualifier +// ReSharper disable InconsistentNaming +// ReSharper disable CheckNamespace +// ReSharper disable UnusedParameter.Local +// ReSharper disable RedundantUsingDirective +#endregion +|] + +-- C# field/property attributes +propertyAttributes :: MappingContext -> Field -> Text +propertyAttributes cs Field {..} = + schemaAttributes 2 fieldAttributes + <> [lt|[global::Bond.Id(#{fieldOrdinal})#{typeAttribute}#{modifierAttribute fieldType fieldModifier}] + |] + where + annotatedType = getAnnotatedTypeName cs fieldType + propertyType = getTypeName cs fieldType + typeAttribute = if annotatedType /= propertyType + then [lt|, global::Bond.Type(typeof(#{annotatedType}))|] + else mempty + modifierAttribute BT_MetaName _ = [lt|, global::Bond.RequiredOptional|] + modifierAttribute BT_MetaFullName _ = [lt|, global::Bond.RequiredOptional|] + modifierAttribute _ Required = [lt|, global::Bond.Required|] + modifierAttribute _ RequiredOptional = [lt|, global::Bond.RequiredOptional|] + modifierAttribute _ _ = mempty + +-- C# class/struct/interface attributes +typeAttributes :: MappingContext -> Declaration -> Text +typeAttributes cs s@Struct {..} = + optionalTypeAttributes cs s + <> [lt|[global::Bond.Schema] + |] + <> generatedCodeAttr + +-- C# enum attributes +typeAttributes cs e@Enum {..} = + optionalTypeAttributes cs e + <> generatedCodeAttr +typeAttributes _ _ = error "typeAttributes: impossible happened." + +generatedCodeAttr :: Text +generatedCodeAttr = [lt|[System.CodeDom.Compiler.GeneratedCode("gbc", "#{showVersion version}")] + |] + +idl :: MappingContext +idl = MappingContext idlTypeMapping [] [] [] + +optionalTypeAttributes :: MappingContext -> Declaration -> Text +optionalTypeAttributes cs decl = + schemaAttributes 1 (declAttributes decl) + <> namespaceAttribute + where + namespaceAttribute = if getDeclNamespace idl decl == getDeclNamespace cs decl + then mempty + else [lt|[global::Bond.Namespace("#{getQualifiedName idl $ getDeclNamespace idl decl}")] + |] + +-- Attributes defined by the user in the schema +schemaAttributes :: Int64 -> [Attribute] -> Text +schemaAttributes indent = newlineSepEnd indent schemaAttribute + where + schemaAttribute Attribute {..} = + [lt|[global::Bond.Attribute("#{getQualifiedName idl attrName}", "#{attrValue}")]|] + +-- generic type parameter constraints +paramConstraints :: [TypeParam] -> Text +paramConstraints = newlineBeginSep 2 constraint + where + constraint (TypeParam _ Nothing) = mempty + constraint (TypeParam name (Just Value)) = [lt|where #{name} : struct|] + +-- Initial value for C# field/property or Nothing if C# implicit default is OK +defaultValue :: MappingContext -> Field -> Maybe Text +defaultValue cs Field {fieldDefault = Nothing, ..} = implicitDefault fieldType + where + newInstance t = Just [lt|new #{getInstanceTypeName cs t}()|] + implicitDefault (BT_Bonded t) = Just [lt|global::Bond.Bonded<#{getTypeName cs t}>.Empty|] + implicitDefault t@(BT_TypeParam _) = Just [lt|global::Bond.GenericFactory.Create<#{getInstanceTypeName cs t}>()|] + implicitDefault t@BT_Blob = newInstance t + implicitDefault t@(BT_UserDefined a@Alias {..} args) + | customAliasMapping cs a = newInstance t + | otherwise = implicitDefault $ resolveAlias a args + implicitDefault t + | isString t = Just [lt|""|] + | isContainer t || isStruct t = newInstance t + implicitDefault _ = Nothing + +defaultValue cs Field {fieldDefault = (Just def), ..} = explicitDefault def + where + explicitDefault (DefaultInteger x) = Just [lt|#{x}|] + explicitDefault (DefaultFloat x) = Just $ floatLiteral fieldType x + where + floatLiteral BT_Float y = [lt|#{y}F|] + floatLiteral BT_Double y = [lt|#{y}|] + floatLiteral _ _ = error "defaultValue/floatLiteral: impossible happened." + explicitDefault (DefaultBool True) = Just "true" + explicitDefault (DefaultBool False) = Just "false" + explicitDefault (DefaultString x) = Just [lt|"#{x}"|] + explicitDefault (DefaultEnum x) = Just [lt|#{getTypeName cs fieldType}.#{x}|] + explicitDefault _ = Nothing diff --git a/src/Language/Bond/Codegen/CustomMapping.hs b/src/Language/Bond/Codegen/CustomMapping.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/CustomMapping.hs @@ -0,0 +1,79 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE OverloadedStrings #-} + +module Language.Bond.Codegen.CustomMapping + ( AliasMapping(..) + , Fragment(..) + , NamespaceMapping(..) + , parseAliasMapping + , parseNamespaceMapping + ) where + +import Data.Char +import Control.Applicative +import Prelude +import Text.Parsec hiding (many, optional, (<|>)) +import Language.Bond.Syntax.Types + +-- | Specification of a fragment of type alias mappings. +data Fragment = + Fragment String | -- ^ hardcoded string fragment + Placeholder Int -- ^ placeholder for the n-th type argument of the type alias, applicable only to generic aliases + +-- | Specification of a type alias mapping. +data AliasMapping = AliasMapping + { aliasName :: QualifiedName -- ^ qualified name of a type alias + , aliasTemplate :: [Fragment] -- ^ list of fragments comprising custom mapping for the alias + } + +-- | Specification of namespace mapping. +data NamespaceMapping = NamespaceMapping + { fromNamespace :: QualifiedName -- ^ schema namespace + , toNamespace :: QualifiedName -- ^ namespace in the generated code + } + +type Parser a = Parsec SourceName () a + +whitespace :: Parser String +whitespace = many (char ' ') "whitespace" +identifier :: Parser String +identifier = many1 (alphaNum <|> char '_') "identifier" +qualifiedName :: Parser [String] +qualifiedName = sepBy1 identifier (char '.') "qualified name" +symbol :: String -> Parser String +symbol s = whitespace *> string s <* whitespace +equal :: Parser String +equal = symbol "=" +integer :: Parser Integer +integer = decimal <$> many1 digit "decimal number" + where + decimal = foldl (\x d -> 10 * x + toInteger (digitToInt d)) 0 + +-- | Parse a type alias mapping specification used in command-line arguments of +-- . +-- +-- ==== __Examples__ +-- +-- > > parseAliasMapping "Example.OrderedSet=SortedSet<{0}>" +-- > Right (AliasMapping {aliasName = ["Example","OrderedSet"], aliasTemplate = [Fragment "SortedSet<",Placeholder 0,Fragment ">"]}) +parseAliasMapping :: String -> Either ParseError AliasMapping +parseAliasMapping s = parse aliasMapping s s + where + aliasMapping = AliasMapping <$> qualifiedName <* equal <*> many1 (placeholder <|> fragment) <* eof + placeholder = Placeholder <$> fromIntegral <$> between (char '{') (char '}') integer + fragment = Fragment <$> many1 (noneOf "{") + +-- | Parse a namespace mapping specification used in command-line arguments of +-- . +-- +-- ==== __Examples__ +-- +-- > > parseNamespaceMapping "bond=Microsoft.Bond" +-- > Right (NamespaceMapping {fromNamespace = ["bond"], toNamespace = ["Microsoft","Bond"]}) +parseNamespaceMapping :: String -> Either ParseError NamespaceMapping +parseNamespaceMapping s = parse namespaceMapping s s + where + namespaceMapping = NamespaceMapping <$> qualifiedName <* equal <*> qualifiedName + diff --git a/src/Language/Bond/Codegen/Templates.hs b/src/Language/Bond/Codegen/Templates.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/Templates.hs @@ -0,0 +1,62 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +{-| +Copyright : (c) Microsoft +License : MIT +Maintainer : adamsap@microsoft.com +Stability : provisional +Portability : portable + +The module exports the built-in code generation templates. +-} + +module Language.Bond.Codegen.Templates + ( -- * Templates + -- | All codegen templates take at least the following arguments: + -- + -- * 'MappingContext' which determines mapping of Bond types to types in + -- the target language + -- + -- * base file name, typically the name of the schema definition file + -- without the extension + -- + -- * list of 'Import's from the parsed schema definition + -- + -- * list of 'Declaration's from the parsed schema definition + -- + -- Some templates are parameterized with additional options for + -- customizing the generated code. + -- + -- The templates return the name suffix for the target file and lazy + -- 'Text' with the generated code. + + -- ** C++ + types_h + , types_cpp + , reflection_h + , enum_h + , apply_h + , apply_cpp + , Protocol(..) + -- ** C# + , FieldMapping(..) + , StructMapping(..) + , types_cs + ) + where + +import Language.Bond.Codegen.Cpp.Apply_cpp +import Language.Bond.Codegen.Cpp.Apply_h +import Language.Bond.Codegen.Cpp.ApplyOverloads +import Language.Bond.Codegen.Cpp.Enum_h +import Language.Bond.Codegen.Cpp.Reflection_h +import Language.Bond.Codegen.Cpp.Types_cpp +import Language.Bond.Codegen.Cpp.Types_h +import Language.Bond.Codegen.Cs.Types_cs +-- redundant imports for haddock +import Language.Bond.Codegen.TypeMapping +import Language.Bond.Syntax.Types +import Data.Text.Lazy diff --git a/src/Language/Bond/Codegen/TypeMapping.hs b/src/Language/Bond/Codegen/TypeMapping.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/TypeMapping.hs @@ -0,0 +1,439 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} + +{-| +Copyright : (c) Microsoft +License : MIT +Maintainer : adamsap@microsoft.com +Stability : provisional +Portability : portable + +The module defines abstractions for mapping from the Bond type system into the +type systems of a target programming language. +-} + +module Language.Bond.Codegen.TypeMapping + ( -- * Mapping context + MappingContext(..) + , TypeMapping + -- * Type mappings + , idlTypeMapping + , cppTypeMapping + , cppCustomAllocTypeMapping + , csTypeMapping + , csCollectionInterfacesTypeMapping + -- * Alias mapping + -- + -- | + -- defined in a schema can optionally be mapped to user specified types. + , AliasMapping(..) + , Fragment(..) + , parseAliasMapping + -- #namespace-mapping# + -- * Namespace mapping + -- + -- | Schema namespaces can be mapped into languange-specific namespaces in the + -- generated code. + , NamespaceMapping(..) + , parseNamespaceMapping + -- * Name builders + , getTypeName + , getInstanceTypeName + , getAnnotatedTypeName + , getDeclTypeName + , getQualifiedName + -- * Helper functions + , getNamespace + , getDeclNamespace + , customAliasMapping + ) where + +import Data.List +import Data.Monoid +import Data.Maybe +import Control.Applicative +import Control.Monad.Reader +import Prelude +import qualified Data.Text.Lazy as L +import Data.Text.Lazy.Builder +import Text.Shakespeare.Text +import Language.Bond.Syntax.Types +import Language.Bond.Syntax.Util +import Language.Bond.Util +import Language.Bond.Codegen.CustomMapping + +-- | The 'MappingContext' encapsulates information about mapping Bond types +-- into types of code generation target language. A context instance is passed +-- to code generation templates. +data MappingContext = MappingContext + { typeMapping :: TypeMapping + , aliasMapping :: [AliasMapping] + , namespaceMapping :: [NamespaceMapping] + , namespaces :: [Namespace] + } + +-- | An opaque type representing type mapping. +data TypeMapping = TypeMapping + { language :: Maybe Language + , global :: Builder + , separator :: Builder + , mapType :: Type -> TypeNameBuilder + , fixSyntax :: Builder -> Builder + , instanceMapping :: TypeMapping + , elementMapping :: TypeMapping + , annotatedMapping :: TypeMapping + } + +type TypeNameBuilder = Reader MappingContext Builder + +-- | Returns the namespace for the 'MappingContext'. The namespace may be +-- different than specified in schema definition file due to +-- <#namespace-mapping namespace mapping>. +getNamespace :: MappingContext -> QualifiedName +getNamespace c@MappingContext {..} = resolveNamespace c namespaces + +-- | Returns the namespace for a 'Declaration' in the specified 'MappingContext'. +getDeclNamespace :: MappingContext -> Declaration -> QualifiedName +getDeclNamespace c = resolveNamespace c . declNamespaces + +-- | Builds a qualified name in the specified 'MappingContext'. +getQualifiedName :: MappingContext -> QualifiedName -> Builder +getQualifiedName MappingContext { typeMapping = m } = (global m <>) . sepBy (separator m) toText + +-- | Builds the qualified name for a 'Declaration' in the specified +-- 'MappingContext'. +getDeclTypeName :: MappingContext -> Declaration -> Builder +getDeclTypeName c = getQualifiedName c . declQualifiedName c + +-- | Builds the name of a 'Type' in the specified 'MappingContext'. +getTypeName :: MappingContext -> Type -> Builder +getTypeName c t = fix' $ runReader (typeName t) c + where + fix' = fixSyntax $ typeMapping c + +-- | Builds the name to be used when instantiating a 'Type'. The instance type +-- name may be different than the type name returned by 'getTypeName' when the +-- latter is an interface. +getInstanceTypeName :: MappingContext -> Type -> Builder +getInstanceTypeName c t = runReader (instanceTypeName t) c + +-- | Builds the annotated name of a 'Type'. The type annotations are used to +-- express type information about a Bond type that doesn't directly map to +-- the target language type system (e.g. distinction between a nullable and +-- non-nullable string in C# type system). +getAnnotatedTypeName :: MappingContext -> Type -> Builder +getAnnotatedTypeName c t = runReader (annotatedTypeName t) c + +-- | Returns 'True' if the alias has a custom mapping in the given +-- 'MappingContext'. +customAliasMapping :: MappingContext -> Declaration -> Bool +customAliasMapping = (maybe False (const True) .) . findAliasMapping + +-- | The Bond IDL type name mapping. +idlTypeMapping :: TypeMapping +idlTypeMapping = TypeMapping + Nothing + "" + "." + idlType + id + idlTypeMapping + idlTypeMapping + idlTypeMapping + +-- | The default C++ type name mapping. +cppTypeMapping :: TypeMapping +cppTypeMapping = TypeMapping + (Just Cpp) + "::" + "::" + cppType + cppSyntaxFix + cppTypeMapping + cppTypeMapping + cppTypeMapping + +-- | C++ type name mapping using a custom allocator. +cppCustomAllocTypeMapping :: ToText a => a -> TypeMapping +cppCustomAllocTypeMapping alloc = TypeMapping + (Just Cpp) + "::" + "::" + (cppTypeCustomAlloc $ toText alloc) + cppSyntaxFix + (cppCustomAllocTypeMapping alloc) + (cppCustomAllocTypeMapping alloc) + (cppCustomAllocTypeMapping alloc) + +-- | The default C# type name mapping. +csTypeMapping :: TypeMapping +csTypeMapping = TypeMapping + (Just Cs) + "global::" + "." + csType + id + csTypeMapping + csTypeMapping + csAnnotatedTypeMapping + +-- | C# type name mapping using interfaces rather than concrete types to +-- represent collections. +csCollectionInterfacesTypeMapping :: TypeMapping +csCollectionInterfacesTypeMapping = TypeMapping + (Just Cs) + "global::" + "." + csInterfaceType + id + csCollectionInstancesTypeMapping + csCollectionInterfacesTypeMapping + csAnnotatedTypeMapping + +csCollectionInstancesTypeMapping :: TypeMapping +csCollectionInstancesTypeMapping = csCollectionInterfacesTypeMapping {mapType = csType} + +csAnnotatedTypeMapping :: TypeMapping +csAnnotatedTypeMapping = TypeMapping + (Just Cs) + "global::" + "." + (csTypeAnnotation csType) + id + csAnnotatedTypeMapping + csAnnotatedTypeMapping + csAnnotatedTypeMapping + +infixr 6 <<>> + +(<<>>) :: (Monoid r, Monad m) => m r -> m r -> m r +(<<>>) = liftM2 (<>) + +infixr 6 <>> + +(<>>) :: (Monoid r, Monad m) => r -> m r -> m r +(<>>) x = liftM (x <>) + +infixr 6 <<> + +(<<>) :: (Monoid r, Monad m) => m r -> r -> m r +(<<>) x y = liftM (<> y) x + +pureText :: ToText a => a -> TypeNameBuilder +pureText = pure . toText + +commaSepTypeNames :: [Type] -> TypeNameBuilder +commaSepTypeNames [] = return mempty +commaSepTypeNames [x] = typeName x +commaSepTypeNames (x:xs) = typeName x <<>> ", " <>> commaSepTypeNames xs + +typeName :: Type -> TypeNameBuilder +typeName t = do + m <- asks $ mapType . typeMapping + m t + +localWith :: (TypeMapping -> TypeMapping) -> TypeNameBuilder -> TypeNameBuilder +localWith f = local $ \c -> c { typeMapping = f $ typeMapping c } + +elementTypeName :: Type -> TypeNameBuilder +elementTypeName = localWith elementMapping . typeName + +instanceTypeName :: Type -> TypeNameBuilder +instanceTypeName = localWith instanceMapping . typeName + +annotatedTypeName :: Type -> TypeNameBuilder +annotatedTypeName = localWith annotatedMapping . typeName + +resolveNamespace :: MappingContext -> [Namespace] -> QualifiedName +resolveNamespace MappingContext {..} ns = + maybe namespaceName toNamespace $ find ((namespaceName ==) . fromNamespace) namespaceMapping + where + namespaceName = nsName . fromJust $ mappingNamespace <|> neutralNamespace <|> fallbackNamespace + mappingNamespace = find ((language typeMapping ==) . nsLanguage) ns + neutralNamespace = find (isNothing . nsLanguage) ns + fallbackNamespace = case (language typeMapping) of + Nothing -> Just $ last ns + Just l -> error $ "No namespace declared for " ++ show l + +declQualifiedName :: MappingContext -> Declaration -> QualifiedName +declQualifiedName c decl = getDeclNamespace c decl ++ [declName decl] + +declQualifiedTypeName :: Declaration -> TypeNameBuilder +declQualifiedTypeName decl = do + ctx <- ask + return $ getDeclTypeName ctx decl + +declTypeName :: Declaration -> TypeNameBuilder +declTypeName decl = do + ctx <- ask + if namespaces ctx == declNamespaces decl + then pureText $ declName decl + else declQualifiedTypeName decl + +findAliasMapping :: MappingContext -> Declaration -> Maybe AliasMapping +findAliasMapping ctx a = find isSameAlias $ aliasMapping ctx + where + aliasDeclName = declQualifiedName ctx a + isSameNs = namespaces ctx == declNamespaces a + isSameAlias m = aliasDeclName == aliasName m || isSameNs && [declName a] == aliasName m + +aliasTypeName :: Declaration -> [Type] -> TypeNameBuilder +aliasTypeName a args = do + ctx <- ask + case findAliasMapping ctx a of + Just AliasMapping {..} -> foldr ((<<>>) . fragment) (pure mempty) aliasTemplate + Nothing -> typeName $ resolveAlias a args + where + fragment (Fragment s) = pureText s + fragment (Placeholder i) = typeName $ args !! i + +-- IDL type mapping +idlType :: Type -> TypeNameBuilder +idlType BT_Int8 = pure "int8" +idlType BT_Int16 = pure "int16" +idlType BT_Int32 = pure "int32" +idlType BT_Int64 = pure "int64" +idlType BT_UInt8 = pure "uint8" +idlType BT_UInt16 = pure "uint16" +idlType BT_UInt32 = pure "uint32" +idlType BT_UInt64 = pure "uint64" +idlType BT_Float = pure "float" +idlType BT_Double = pure "double" +idlType BT_Bool = pure "bool" +idlType BT_String = pure "string" +idlType BT_WString = pure "wstring" +idlType BT_MetaName = pure "bond_meta::name" +idlType BT_MetaFullName = pure "bond_meta::full_name" +idlType BT_Blob = pure "blob" +idlType (BT_IntTypeArg x) = pureText x +idlType (BT_Maybe type_) = elementTypeName type_ +idlType (BT_List element) = "list<" <>> elementTypeName element <<> ">" +idlType (BT_Nullable element) = "nullable<" <>> elementTypeName element <<> ">" +idlType (BT_Vector element) = "vector<" <>> elementTypeName element <<> ">" +idlType (BT_Set element) = "set<" <>> elementTypeName element <<> ">" +idlType (BT_Map key value) = "map<" <>> elementTypeName key <<>> ", " <>> elementTypeName value <<> ">" +idlType (BT_Bonded type_) = "bonded<" <>> elementTypeName type_ <<> ">" +idlType (BT_TypeParam param) = pureText $ paramName param +idlType (BT_UserDefined a@Alias {..} args) = aliasTypeName a args +idlType (BT_UserDefined decl args) = declQualifiedTypeName decl <<>> (angles <$> commaSepTypeNames args) + +-- C++ type mapping +cppType :: Type -> TypeNameBuilder +cppType BT_Int8 = pure "int8_t" +cppType BT_Int16 = pure "int16_t" +cppType BT_Int32 = pure "int32_t" +cppType BT_Int64 = pure "int64_t" +cppType BT_UInt8 = pure "uint8_t" +cppType BT_UInt16 = pure "uint16_t" +cppType BT_UInt32 = pure "uint32_t" +cppType BT_UInt64 = pure "uint64_t" +cppType BT_Float = pure "float" +cppType BT_Double = pure "double" +cppType BT_Bool = pure "bool" +cppType BT_String = pure "std::string" +cppType BT_WString = pure "std::wstring" +cppType BT_MetaName = pure "std::string" +cppType BT_MetaFullName = pure "std::string" +cppType BT_Blob = pure "bond::blob" +cppType (BT_IntTypeArg x) = pureText x +cppType (BT_Maybe type_) = "bond::maybe<" <>> elementTypeName type_ <<> ">" +cppType (BT_List element) = "std::list<" <>> elementTypeName element <<> ">" +cppType (BT_Nullable element) = "bond::nullable<" <>> elementTypeName element <<> ">" +cppType (BT_Vector element) = "std::vector<" <>> elementTypeName element <<> ">" +cppType (BT_Set element) = "std::set<" <>> elementTypeName element <<> ">" +cppType (BT_Map key value) = "std::map<" <>> elementTypeName key <<>> ", " <>> elementTypeName value <<> ">" +cppType (BT_Bonded type_) = "bond::bonded<" <>> elementTypeName type_ <<> ">" +cppType (BT_TypeParam param) = pureText $ paramName param +cppType (BT_UserDefined a@Alias {..} args) = aliasTypeName a args +cppType (BT_UserDefined decl args) = declQualifiedTypeName decl <<>> (angles <$> commaSepTypeNames args) + +-- C++ type mapping with custom allocator +cppTypeCustomAlloc :: Builder -> Type -> TypeNameBuilder +cppTypeCustomAlloc alloc BT_String = pure $ "std::basic_string, typename " <> alloc <> "::rebind::other>" +cppTypeCustomAlloc alloc BT_WString = pure $ "std::basic_string, typename " <> alloc <> "::rebind::other>" +cppTypeCustomAlloc alloc BT_MetaName = cppTypeCustomAlloc alloc BT_String +cppTypeCustomAlloc alloc BT_MetaFullName = cppTypeCustomAlloc alloc BT_String +cppTypeCustomAlloc alloc (BT_List element) = "std::list<" <>> elementTypeName element <<>> ", " <>> allocator alloc element <<> ">" +cppTypeCustomAlloc alloc (BT_Nullable element) | isStruct element = "bond::nullable<" <>> elementTypeName element <<> ", " <> alloc <> ">" +cppTypeCustomAlloc _lloc (BT_Nullable element) = "bond::nullable<" <>> elementTypeName element <<> ">" +cppTypeCustomAlloc alloc (BT_Vector element) = "std::vector<" <>> elementTypeName element <<>> ", " <>> allocator alloc element <<> ">" +cppTypeCustomAlloc alloc (BT_Set element) = "std::set<" <>> elementTypeName element <<>> comparer element <<>> allocator alloc element <<> ">" +cppTypeCustomAlloc alloc (BT_Map key value) = "std::map<" <>> elementTypeName key <<>> ", " <>> elementTypeName value <<>> comparer key <<>> pairAllocator alloc key value <<> ">" +cppTypeCustomAlloc _ t = cppType t + +comparer :: Type -> TypeNameBuilder +comparer t = ", std::less<" <>> elementTypeName t <<> ">, " + +allocator :: Builder -> Type -> TypeNameBuilder +allocator alloc element = + "typename " <>> alloc <>> "::rebind<" <>> elementTypeName element <<> ">::other" + +pairAllocator :: Builder -> Type -> Type -> TypeNameBuilder +pairAllocator alloc key value = + "typename " <>> alloc <>> "::rebind<" <>> "std::pair> elementTypeName key <<>> ", " <>> elementTypeName value <<> "> >::other" + +cppSyntaxFix :: Builder -> Builder +cppSyntaxFix = fromLazyText . snd . L.foldr fixInvalid (' ', mempty) . toLazyText + where + fixInvalid c r + -- C++98 requires space between consecutive angle brackets + | c == '>' && fst r == '>' = (c, L.cons c (L.cons ' ' $ snd r)) + -- <: is digraph for [ + | c == '<' && fst r == ':' = (c, L.cons c (L.cons ' ' $ snd r)) + | otherwise = (c, L.cons c (snd r)) + + +-- C# type mapping +csType :: Type -> TypeNameBuilder +csType BT_Int8 = pure "sbyte" +csType BT_Int16 = pure "short" +csType BT_Int32 = pure "int" +csType BT_Int64 = pure "long" +csType BT_UInt8 = pure "byte" +csType BT_UInt16 = pure "ushort" +csType BT_UInt32 = pure "uint" +csType BT_UInt64 = pure "ulong" +csType BT_Float = pure "float" +csType BT_Double = pure "double" +csType BT_Bool = pure "bool" +csType BT_String = pure "string" +csType BT_WString = pure "string" +csType BT_MetaName = pure "string" +csType BT_MetaFullName = pure "string" +csType BT_Blob = pure "System.ArraySegment" +csType (BT_IntTypeArg x) = pureText x +csType (BT_Maybe type_) = csType (BT_Nullable type_) +csType (BT_Nullable element) = typeName element <<> if isScalar element then "?" else mempty +csType (BT_List element) = "LinkedList<" <>> elementTypeName element <<> ">" +csType (BT_Vector element) = "List<" <>> elementTypeName element <<> ">" +csType (BT_Set element) = "HashSet<" <>> elementTypeName element <<> ">" +csType (BT_Map key value) = "Dictionary<" <>> elementTypeName key <<>> ", " <>> elementTypeName value <<> ">" +csType (BT_Bonded type_) = "global::Bond.IBonded<" <>> typeName type_ <<> ">" +csType (BT_TypeParam param) = pureText $ paramName param +csType (BT_UserDefined a@Alias {} args) = aliasTypeName a args +csType (BT_UserDefined decl args) = declTypeName decl <<>> (angles <$> localWith (const csTypeMapping) (commaSepTypeNames args)) + +-- C# type mapping with collection interfaces +csInterfaceType :: Type -> TypeNameBuilder +csInterfaceType (BT_List element) = "ICollection<" <>> elementTypeName element <<> ">" +csInterfaceType (BT_Vector element) = "IList<" <>> elementTypeName element <<> ">" +csInterfaceType (BT_Set element) = "ISet<" <>> elementTypeName element <<> ">" +csInterfaceType (BT_Map key value) = "IDictionary<" <>> elementTypeName key <<>> ", " <>> elementTypeName value <<> ">" +csInterfaceType t = csType t + +-- C# type annotation mapping +csTypeAnnotation :: (Type -> TypeNameBuilder) -> Type -> TypeNameBuilder +csTypeAnnotation _ BT_WString = pure "global::Bond.Tag.wstring" +csTypeAnnotation _ (BT_Nullable element) = "global::Bond.Tag.nullable<" <>> typeName element <<> ">" +csTypeAnnotation _ (BT_Maybe a@(BT_UserDefined Alias{} _)) = typeName a +csTypeAnnotation _ (BT_TypeParam (TypeParam _ Nothing)) = pure "global::Bond.Tag.classT" +csTypeAnnotation _ (BT_TypeParam (TypeParam _ (Just Value))) = pure "global::Bond.Tag.structT" +csTypeAnnotation _ (BT_UserDefined Alias {aliasType = BT_Blob} _) = pure "global::Bond.Tag.blob" +csTypeAnnotation m t@(BT_UserDefined a@Alias {..} args) + | isContainer t = m t + | otherwise = typeName $ resolveAlias a args +csTypeAnnotation _ (BT_UserDefined decl args) = declTypeName decl <<>> (angles <$> commaSepTypeNames args) +csTypeAnnotation m t = m t + diff --git a/src/Language/Bond/Codegen/Util.hs b/src/Language/Bond/Codegen/Util.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Codegen/Util.hs @@ -0,0 +1,104 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE QuasiQuotes, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-| +Copyright : (c) Microsoft +License : MIT +Maintainer : adamsap@microsoft.com +Stability : provisional +Portability : portable + +Helper functions for creating common text structures useful in code generation. +These functions operate on 'Text' objects. +-} + +module Language.Bond.Codegen.Util + ( commonHeader + , newlineSep + , commaLineSep + , newlineSepEnd + , newlineBeginSep + , doubleLineSep + , doubleLineSepEnd + ) where + +import Data.Int (Int64) +import Data.Word +import Prelude +import Data.Text.Lazy (Text, justifyRight) +import Text.Shakespeare.Text +import Paths_bond (version) +import Data.Version (showVersion) +import Language.Bond.Util + +instance ToText Word16 where + toText = toText . show + +instance ToText Double where + toText = toText . show + +instance ToText Integer where + toText = toText . show + +indent :: Int64 -> Text +indent n = justifyRight (4 * n) ' ' "" + +commaLine :: Int64 -> Text +commaLine n = [lt|, +#{indent n}|] + +newLine :: Int64 -> Text +newLine n = [lt| +#{indent n}|] + +doubleLine :: Int64 -> Text +doubleLine n = [lt| + +#{indent n}|] + +newlineSep, commaLineSep, newlineSepEnd, newlineBeginSep, doubleLineSep, doubleLineSepEnd + :: Int64 -> (a -> Text) -> [a] -> Text + +-- | Separates elements of a list with new lines. Starts new lines at the +-- specified indentation level. +newlineSep = sepBy . newLine + +-- | Separates elements of a list with comma followed by a new line. Starts +-- new lines at the specified indentation level. +commaLineSep = sepBy . commaLine + +-- | Separates elements of a list with new lines, ending with a new line. +-- Starts new lines at the specified indentation level. +newlineSepEnd = sepEndBy . newLine + +-- | Separates elements of a list with new lines, beginning with a new line. +-- Starts new lines at the specified indentation level. +newlineBeginSep = sepBeginBy . newLine + +-- | Separates elements of a list with two new lines. Starts new lines at +-- the specified indentation level. +doubleLineSep = sepBy . doubleLine + +-- | Separates elements of a list with two new lines, ending with two new +-- lines. Starts new lines at the specified indentation level. +doubleLineSepEnd = sepEndBy . doubleLine + +-- | Returns common header for generated files using specified single-line +-- comment lead character(s) and a file name. +commonHeader :: ToText a => a -> a -> Text +commonHeader c file = [lt| +#{c}------------------------------------------------------------------------------ +#{c} This code was generated by a tool. +#{c} +#{c} Tool : Bond Compiler #{showVersion version} +#{c} File : #{file} +#{c} +#{c} Changes to this file may cause incorrect behavior and will be lost when +#{c} the code is regenerated. +#{c} +#{c}------------------------------------------------------------------------------ +|] + diff --git a/src/Language/Bond/Lexer.hs b/src/Language/Bond/Lexer.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Lexer.hs @@ -0,0 +1,153 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Language.Bond.Lexer + ( angles + , braces + , brackets + , colon + , comma + , commaEnd + , commaEnd1 + , commaSep1 + , decimal + , equal + , float + , identifier + , namespaceIdentifier + , integer + , keyword + , lexeme + , natural + , parens + , unescapedStringLiteral + , semi + , semiEnd + , semiOrCommaEnd + , semiOrCommaSep + , semiOrCommaSep1 + , semiOrCommaSepEnd + , semiOrCommaSepEnd1 + , semiSep + , stringLiteral + , symbol + , whiteSpace + ) where + +import Data.List +import Control.Monad.Reader +import Text.ParserCombinators.Parsec +import qualified Text.Parsec.Token as P + +type LanguageDef st env = P.GenLanguageDef String st (ReaderT env IO) + +bondIdl :: LanguageDef st env +bondIdl = P.LanguageDef + { P.commentStart = "/*" + , P.commentEnd = "*/" + , P.commentLine = "//" + , P.nestedComments = True + , P.identStart = letter <|> char '_' + , P.identLetter = alphaNum <|> char '_' + , P.opStart = mzero + , P.opLetter = mzero + , P.reservedNames = + [ "blob" + , "bond_meta" + , "bonded" + , "bool" + , "class" + , "double" + , "enum" + , "false" + , "float" + , "import" + , "int16" + , "int32" + , "int64" + , "int8" + , "list" + , "map" + , "namespace" + , "nullable" + , "optional" + , "required" + , "required_optional" + , "Schema" + , "sealed" + , "service" + , "set" + , "string" + , "struct" + , "true" + , "uint16" + , "uint32" + , "uint64" + , "uint8" + , "using" + , "var" + , "vector" + , "view_of" + , "void" + , "wstring" + ] + , P.reservedOpNames = [] + , P.caseSensitive = True + } + +lexer = P.makeTokenParser bondIdl + +angles = P.angles lexer +braces = P.braces lexer +brackets = P.brackets lexer +colon = P.colon lexer +comma = P.comma lexer +commaSep1 = P.commaSep1 lexer +decimal = P.decimal lexer +identifier = P.identifier lexer +integer = P.integer lexer +keyword = P.reserved lexer +lexeme = P.lexeme lexer +natural = P.natural lexer +parens = P.parens lexer +semi = P.semi lexer +semiSep = P.semiSep lexer +symbol = P.symbol lexer +whiteSpace = P.whiteSpace lexer + +namespaceLexer = P.makeTokenParser bondIdl { P.reservedNames = delete "Schema" (P.reservedNames bondIdl) } +namespaceIdentifier = P.identifier namespaceLexer + +equal = symbol "=" +semiEnd p = endBy p semi +commaEnd p = endBy p comma +commaEnd1 p = endBy1 p comma + +semiOrComma = semi <|> comma + +semiOrCommaSep p = sepBy p semiOrComma +semiOrCommaSep1 p = sepBy1 p semiOrComma +semiOrCommaEnd p = endBy p semiOrComma +semiOrCommaSepEnd p = sepEndBy p semiOrComma +semiOrCommaSepEnd1 p = sepEndBy1 p semiOrComma + +quote = symbol "\"" +quotes = between quote quote + +stringLiteral = P.stringLiteral lexer + +unescapedStringLiteral = quotes $ many $ satisfy (/= '"') + +-- Can't use float from Text.Parsec.Token because it doesn't handle numbers +-- starting with +/- sign. +float = do + s <- sign + f <- P.float lexer + return $ s f + where + sign = (char '-' >> return negate) + <|> (char '+' >> return id) + <|> return id + diff --git a/src/Language/Bond/Parser.hs b/src/Language/Bond/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Parser.hs @@ -0,0 +1,353 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE RecordWildCards #-} + +{-| +Copyright : (c) Microsoft +License : MIT +Maintainer : adamsap@microsoft.com +Stability : provisional +Portability : portable + +This module provides functionality necessary to parse Bond +. +-} + +module Language.Bond.Parser + ( -- * Parser + parseBond + , ImportResolver + ) + where + +import Data.Ord +import Data.List +import Data.Function +import Control.Applicative +import Control.Monad.Reader +import Prelude +import Text.Parsec.Pos (initialPos) +import Text.Parsec hiding (many, optional, (<|>)) +import Language.Bond.Lexer +import Language.Bond.Syntax.Types +import Language.Bond.Syntax.Util +import Language.Bond.Syntax.Internal + +-- parser state, mutable and global +data Symbols = + Symbols + { symbols :: [Declaration] -- list of structs, enums and aliases declared in the current and all imported files + , imports :: [FilePath] -- list of imported files + } + +type ImportResolver = + FilePath -- ^ path of the file containing the + -> FilePath -- ^ (usually relative) path of the imported file + -> IO (FilePath, String) -- ^ the resolver function returns the resolved path of the imported file and its content + +-- parser environment, immutable but contextual +data Environment = + Environment + { currentNamespaces :: [Namespace] -- namespace(s) in current context + , currentParams :: [TypeParam] -- type parameter(s) for current type (struct or alias) + , currentFile :: FilePath -- path of the current file + , resolveImport :: ImportResolver -- imports resolver + } + +type Parser a = ParsecT String Symbols (ReaderT Environment IO) a + +-- | Parses content of a schema definition file. +parseBond :: + SourceName -- ^ source name, used only for error messages + -> String -- ^ content of a schema file to parse + -> FilePath -- ^ path of the file being parsed, used to resolve relative import paths + -> ImportResolver -- ^ function to resolve and load imported files + -> IO (Either ParseError Bond) -- ^ function returns 'Bond' which represents the parsed abstract syntax tree + -- or 'ParserError' if parsing failed +parseBond s c f r = runReaderT (runParserT bond (Symbols [] []) s c) (Environment [] [] f r) + +-- parser for .bond files +bond :: Parser Bond +bond = do + whiteSpace + imports <- many import_ + namespaces <- many1 namespace + local (with namespaces) $ Bond imports namespaces <$> many declaration <* eof + where + with namespaces e = e { currentNamespaces = namespaces } + +import_ :: Parser Import +import_ = do + i <- Import <$ keyword "import" <*> unescapedStringLiteral "import statement" + input <- getInput + pos <- getPosition + processImport i + setInput input + setPosition pos + return i + +processImport :: Import -> Parser() +processImport (Import file) = do + Environment { currentFile = currentFile, resolveImport = resolveImport } <- ask + (path, content) <- liftIO $ resolveImport currentFile file + Symbols { imports = imports } <- getState + if path `elem` imports then return () else do + modifyState (\u -> u { imports = path:imports } ) + setInput content + setPosition $ initialPos path + void $ local (\e -> e { currentFile = path }) bond + +-- parser for struct, enum or type alias declaration/definition +declaration :: Parser Declaration +declaration = do + decl <- try forward + <|> try struct + <|> try view + <|> try enum + <|> try alias + updateSymbols decl "declaration" + return decl + +updateSymbols :: Declaration -> Parser () +updateSymbols decl = do + (previous, symbols) <- partition (duplicateDeclaration decl) <$> symbols <$> getState + case reconcile previous decl of + (False, _) -> fail $ "The " ++ showPretty decl ++ " has been previously defined as " ++ showPretty (head previous) + (True, f) -> modifyState (f symbols) + where + reconcile [x@Forward {}] y@Struct {} = (paramsMatch x y, add y) + reconcile [x@Forward {}] y@Forward {} = (paramsMatch x y, const id) + reconcile [x@Struct {}] y@Forward {} = (paramsMatch x y, add y) + reconcile [] x = (True, add x) + -- This allows identical duplicate definitions, which is how parsing the + -- same import multiple times is handled. Ideally we would avoid parsing + -- imports multiple times but that would have to depend on canonical file + -- paths which are unreliable. + reconcile [x] y = (x == y, const id) + reconcile _ _ = error "updateSymbols/reconcile: impossible happened." + paramsMatch = (==) `on` (map paramConstraint . declParams) + add x xs u = u { symbols = x:xs } + duplicateDeclaration left right = + (declName left == declName right) + && not (null $ intersect (declNamespaces left) (declNamespaces right)) + + +findSymbol :: QualifiedName -> Parser Declaration +findSymbol name = doFind "qualified name" + where + doFind = do + namespaces <- asks currentNamespaces + Symbols { symbols = symbols } <- getState + case find (delcMatching namespaces name) symbols of + Just decl -> return decl + Nothing -> fail $ "Unknown symbol: " ++ showQualifiedName name + delcMatching namespaces [unqualifiedName] decl = + unqualifiedName == declName decl + && (not $ null $ intersectBy nsMatching namespaces (declNamespaces decl)) + delcMatching _ qualifiedName' decl = + takeName qualifiedName' == declName decl + && any ((takeNamespace qualifiedName' ==) . nsName) (declNamespaces decl) + nsMatching ns1 ns2 = + nsName ns1 == nsName ns2 && (lang1 == lang2 || lang1 == Nothing || lang2 == Nothing) + where + lang1 = nsLanguage ns1 + lang2 = nsLanguage ns2 + +findStruct :: QualifiedName -> Parser Declaration +findStruct name = doFind "qualified struct name" + where + doFind = do + symb <- findSymbol name + case symb of + Struct {..} -> return symb + _ -> fail $ "The " ++ showPretty symb ++ " is invalid in this context. Expected a struct." + +-- namespace +namespace :: Parser Namespace +namespace = Namespace <$ keyword "namespace" <*> language <*> qualifiedName <* optional semi "namespace declaration" + where + language = optional (keyword "cpp" *> pure Cpp + <|> keyword "cs" *> pure Cs + <|> keyword "java" *> pure Java + <|> keyword "csharp" *> pure Cs) + +-- identifier optionally qualified with namespace +qualifiedName :: Parser QualifiedName +qualifiedName = sepBy1 namespaceIdentifier (char '.') "qualified name" + +-- type parameters +parameters :: Parser [TypeParam] +parameters = option [] (angles $ commaSep1 param) "type parameters" + where + param = TypeParam <$> identifier <*> constraint + constraint = optional (colon *> keyword "value" *> pure Value) + +-- type alias +alias :: Parser Declaration +alias = do + name <- keyword "using" *> identifier "alias definition" + params <- parameters + namespaces <- asks currentNamespaces + local (with params) $ Alias namespaces name params <$ equal <*> type_ <* semi + where + with params e = e { currentParams = params } + +-- forward declaration +forward :: Parser Declaration +forward = Forward <$> asks currentNamespaces <*> name <*> parameters <* semi "forward declaration" + where + name = keyword "struct" *> identifier + +-- attributes parser +attributes :: Parser [Attribute] +attributes = many attribute "attributes" + where + attribute = brackets (Attribute <$> qualifiedName <*> parens stringLiteral "attribute") + +-- struct view parser +view :: Parser Declaration +view = do + attr <- attributes + name <- keyword "struct" *> identifier + decl <- keyword "view_of" *> qualifiedName >>= findStruct + fields <- braces $ semiOrCommaSepEnd1 identifier + namespaces <- asks currentNamespaces + Struct namespaces attr name (declParams decl) (structBase decl) (viewFields decl fields) <$ optional semi + where + viewFields Struct {..} fields = filter ((`elem` fields) . fieldName) structFields + viewFields _ _ = error "view/viewFields: impossible happened." + +-- struct definition parser +struct :: Parser Declaration +struct = do + attr <- attributes + name <- keyword "struct" *> identifier "struct definition" + params <- parameters + namespaces <- asks currentNamespaces + updateSymbols $ Forward namespaces name params + local (with params) $ Struct namespaces attr name params <$> base <*> fields <* optional semi + where + base = optional (colon *> userType "base struct") + fields = unique $ braces $ manySortedBy (comparing fieldOrdinal) (field <* semi) + with params e = e { currentParams = params } + unique p = do + fields' <- p + case findDuplicates fields' of + [] -> return fields' + Field {..}:_ -> fail $ "Duplicate definition of the field with ordinal " ++ show fieldOrdinal + where + findDuplicates xs = deleteFirstsBy ordinal xs (nubBy ordinal xs) + ordinal = (==) `on` fieldOrdinal + +manySortedBy :: (a -> a -> Ordering) -> ParsecT s u m a -> ParsecT s u m [a] +manySortedBy = manyAccum . insertBy + +-- field definition parser +field :: Parser Field +field = makeField <$> attributes <*> ordinal <*> modifier <*> ftype <*> identifier <*> optional default_ + where + ordinal = (fromIntegral <$> integer) <* colon "field ordinal" + modifier = option Optional + (keyword "optional" *> pure Optional + <|> keyword "required" *> pure Required + <|> keyword "required_optional" *> pure RequiredOptional) + default_ = equal *> + (keyword "true" *> pure (DefaultBool True) + <|> keyword "false" *> pure (DefaultBool False) + <|> keyword "nothing" *> pure DefaultNothing + <|> DefaultString <$> try (optional (char 'L') *> stringLiteral) + <|> DefaultEnum <$> identifier + <|> DefaultFloat <$> try float + <|> DefaultInteger <$> fromIntegral <$> integer) + makeField a o m t n d@(Just DefaultNothing) = Field a o m (BT_Maybe t) n d + makeField a o m t n d = Field a o m t n d + +-- enum definition parser +enum :: Parser Declaration +enum = Enum <$> asks currentNamespaces <*> attributes <*> name <*> consts <* optional semi "enum definition" + where + name = keyword "enum" *> (identifier "enum identifier") + consts = braces (semiOrCommaSepEnd1 constant "enum constant") + constant = Constant <$> identifier <*> optional value + value = equal *> (fromIntegral <$> integer) + +-- basic types parser +basicType :: Parser Type +basicType = + keyword "int8" *> pure BT_Int8 + <|> keyword "int16" *> pure BT_Int16 + <|> keyword "int32" *> pure BT_Int32 + <|> keyword "int64" *> pure BT_Int64 + <|> keyword "uint8" *> pure BT_UInt8 + <|> keyword "uint16" *> pure BT_UInt16 + <|> keyword "uint32" *> pure BT_UInt32 + <|> keyword "uint64" *> pure BT_UInt64 + <|> keyword "float" *> pure BT_Float + <|> keyword "double" *> pure BT_Double + <|> keyword "wstring" *> pure BT_WString + <|> keyword "string" *> pure BT_String + <|> keyword "bool" *> pure BT_Bool + + +-- containers parser +complexType :: Parser Type +complexType = + keyword "list" *> angles (BT_List <$> type_) + <|> keyword "blob" *> pure BT_Blob + <|> keyword "vector" *> angles (BT_Vector <$> type_) + <|> keyword "nullable" *> angles (BT_Nullable <$> type_) + <|> keyword "set" *> angles (BT_Set <$> keyType) + <|> keyword "map" *> angles (BT_Map <$> keyType <* comma <*> type_) + <|> keyword "bonded" *> angles (BT_Bonded <$> userStruct) + where + keyType = try (basicType <|> checkUserType validKeyType) "scalar, string or enum" + userStruct = try (checkUserType validBondedType) "user defined struct" + checkUserType valid = do + t <- userType + if valid t then return t else unexpected "type" + validKeyType t = case t of + BT_TypeParam _ -> True + _ -> isScalar t || isString t + validBondedType t = case t of + BT_TypeParam _ -> True + _ -> isStruct t + + +-- parser for user defined type (struct, enum, alias or type parameter) +userType :: Parser Type +userType = do + name <- qualifiedName + params <- asks currentParams + case find (isParam name) params of + Just param -> return $ BT_TypeParam param + Nothing -> do + decl <- findSymbol name + args <- option [] (angles $ commaSep1 arg) + if length args /= paramsCount decl then + fail $ declName decl ++ + if paramsCount decl /= 0 then + " requires " ++ show (paramsCount decl) ++ " type argument(s)" + else + " is not a generic type" + else + return $ BT_UserDefined decl args + where + paramsCount Enum{} = 0 + paramsCount decl = length $ declParams decl + arg = type_ <|> BT_IntTypeArg <$> (fromIntegral <$> integer) + where + isParam [name] = (name ==) . paramName + isParam _ = const False + + +-- type parser +type_ :: Parser Type +type_ = basicType <|> complexType <|> userType + +-- field type parser +ftype :: Parser Type +ftype = keyword "bond_meta::name" *> pure BT_MetaName + <|> keyword "bond_meta::full_name" *> pure BT_MetaFullName + <|> type_ + diff --git a/src/Language/Bond/Syntax/Internal.hs b/src/Language/Bond/Syntax/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Syntax/Internal.hs @@ -0,0 +1,52 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} + +module Language.Bond.Syntax.Internal + ( showPretty + , showQualifiedName + , takeName + , takeNamespace + , isBaseField + , metaField + ) where + +import Data.Monoid +import Language.Bond.Util +import Language.Bond.Syntax.Util +import Language.Bond.Syntax.Types + +takeName :: QualifiedName -> String +takeName = last + +takeNamespace :: QualifiedName -> QualifiedName +takeNamespace = subtract 1 . length >>= take + +showQualifiedName :: QualifiedName -> String +showQualifiedName = sepBy "." id + +showTypeParams :: [TypeParam] -> String +showTypeParams = angles . sepBy ", " showPretty + +class ShowPretty a where + showPretty :: a -> String + +instance ShowPretty Constraint where + showPretty Value = ": value" + +instance ShowPretty TypeParam where + showPretty TypeParam {..} = paramName ++ optional showPretty paramConstraint + +instance ShowPretty Declaration where + showPretty Struct {..} = "struct " ++ declName ++ showTypeParams declParams + showPretty Enum {..} = "enum " ++ declName + showPretty Forward {..} = "struct declaration " ++ declName ++ showTypeParams declParams + showPretty Alias {..} = "alias " ++ declName ++ showTypeParams declParams + +metaField :: Field -> Any +metaField Field {..} = Any $ isMetaName fieldType + +isBaseField :: String -> Maybe Type -> Bool +isBaseField name = getAny . optional (foldMapFields (Any.(name==).fieldName)) + diff --git a/src/Language/Bond/Syntax/JSON.hs b/src/Language/Bond/Syntax/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Syntax/JSON.hs @@ -0,0 +1,270 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE OverloadedStrings, RecordWildCards, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-| +Copyright : (c) Microsoft +License : MIT +Maintainer : adamsap@microsoft.com +Stability : provisional +Portability : portable +-} + +module Language.Bond.Syntax.JSON + ( -- * FromJSON and ToJSON instances + -- $aeson + ) + where + +import Data.Aeson +import Data.Aeson.Types +import Data.Aeson.TH +import Control.Applicative +import Prelude +import Language.Bond.Syntax.Types + +-- $aeson +-- +-- This module defines 'FromJSON' and 'ToJSON' instances for Bond abstract +-- syntax tree. They allow using the +-- library to encode Bond AST types to : +-- +-- > > encode (Bond [] [Namespace Nothing ["example"]] []) +-- > "{\"namespaces\":[{\"name\":[\"example\"]}],\"imports\":[],\"declarations\":[]}" +-- +-- and decode Bond data types from JSON: +-- +-- > > decode "{\"namespaces\":[{\"name\":[\"example\"]}],\"imports\":[],\"declarations\":[]}" :: Maybe Bond +-- > Just (Bond {bondImports = [], bondNamespaces = [Namespace {nsLanguage = Nothing, nsName = ["example"]}], bondDeclarations = []}) + +instance FromJSON Type where + parseJSON (String "int8") = pure BT_Int8 + parseJSON (String "int16") = pure BT_Int16 + parseJSON (String "int32") = pure BT_Int32 + parseJSON (String "int64") = pure BT_Int64 + parseJSON (String "uint8") = pure BT_UInt8 + parseJSON (String "uint16") = pure BT_UInt16 + parseJSON (String "uint32") = pure BT_UInt32 + parseJSON (String "uint64") = pure BT_UInt64 + parseJSON (String "float") = pure BT_Float + parseJSON (String "double") = pure BT_Double + parseJSON (String "bool") = pure BT_Bool + parseJSON (String "string") = pure BT_String + parseJSON (String "wstring") = pure BT_WString + parseJSON (String "bond_meta::name") = pure BT_MetaName + parseJSON (String "bond_meta::full_name") = pure BT_MetaFullName + parseJSON (String "blob") = pure BT_Blob + parseJSON (Object o) = do + type_ <- o .: "type" + case type_ of + String "maybe" -> BT_Maybe <$> + o .: "element" + String "list" -> BT_List <$> + o .: "element" + String "vector" -> BT_Vector <$> + o .: "element" + String "nullable" -> BT_Nullable <$> + o .: "element" + String "set" -> BT_Set <$> + o .: "element" + String "map" -> BT_Map <$> + o .: "key" <*> + o .: "element" + String "bonded" -> BT_Bonded <$> + o .: "element" + String "constant" -> BT_IntTypeArg <$> + o .: "value" + String "parameter" -> BT_TypeParam <$> + o .: "value" + String "user" -> BT_UserDefined <$> + o .: "declaration" <*> + o .:? "arguments" .!= [] + _ -> modifyFailure + (const $ "Invalid value `" ++ show type_ ++ "` for the `type` key.") + empty + parseJSON x = modifyFailure + (const $ "Expected a representation of Type but found: " ++ show x) + empty + +instance ToJSON Type where + toJSON BT_Int8 = "int8" + toJSON BT_Int16 = "int16" + toJSON BT_Int32 = "int32" + toJSON BT_Int64 = "int64" + toJSON BT_UInt8 = "uint8" + toJSON BT_UInt16 = "uint16" + toJSON BT_UInt32 = "uint32" + toJSON BT_UInt64 = "uint64" + toJSON BT_Float = "float" + toJSON BT_Double = "double" + toJSON BT_Bool = "bool" + toJSON BT_String = "string" + toJSON BT_WString = "wstring" + toJSON BT_MetaName = "bond_meta::name" + toJSON BT_MetaFullName = "bond_meta::full_name" + toJSON BT_Blob = "blob" + toJSON (BT_Maybe t) = object + [ "type" .= String "maybe" + , "element" .= t + ] + toJSON (BT_List t) = object + [ "type" .= String "list" + , "element" .= t + ] + toJSON (BT_Vector t) = object + [ "type" .= String "vector" + , "element" .= t + ] + toJSON (BT_Nullable t) = object + [ "type" .= String "nullable" + , "element" .= t + ] + toJSON (BT_Set t) = object + [ "type" .= String "set" + , "element" .= t + ] + toJSON (BT_Map k t) = object + [ "type" .= String "map" + , "key" .= k + , "element" .= t + ] + toJSON (BT_Bonded t) = object + [ "type" .= String "bonded" + , "element" .= t + ] + toJSON (BT_IntTypeArg n) = object + [ "type" .= String "constant" + , "value" .= n + ] + toJSON (BT_TypeParam p) = object + [ "type" .= String "parameter" + , "value" .= p + ] + toJSON (BT_UserDefined decl []) = object + [ "type" .= String "user" + , "declaration" .= decl + ] + toJSON (BT_UserDefined decl args) = object + [ "type" .= String "user" + , "declaration" .= decl + , "arguments" .= args + ] + +instance FromJSON Default where + parseJSON (Object o) = do + type_ <- o .: "type" + case type_ of + String "bool" -> DefaultBool <$> o .: "value" + String "integer" -> DefaultInteger <$> o .: "value" + String "float" -> DefaultFloat <$> o .: "value" + String "string" -> DefaultString <$> o .: "value" + String "enum" -> DefaultEnum <$> o .: "value" + String "nothing" -> pure DefaultNothing + _ -> modifyFailure + (const $ "Invalid value `" ++ show type_ ++ "` for the `type` key.") + empty + parseJSON x = modifyFailure + (const $ "Expected a representation of Default but found: " ++ show x) + empty + +instance ToJSON Default where + toJSON (DefaultBool x) = object + [ "type" .= String "bool" + , "value" .= x + ] + toJSON (DefaultInteger x) = object + [ "type" .= String "integer" + , "value" .= x + ] + toJSON (DefaultFloat x) = object + [ "type" .= String "float" + , "value" .= x + ] + toJSON (DefaultString x) = object + [ "type" .= String "string" + , "value" .= x + ] + toJSON (DefaultEnum x) = object + [ "type" .= String "enum" + , "value" .= x + ] + toJSON DefaultNothing = object + [ "type" .= String "nothing" + ] + +instance FromJSON Field where + parseJSON (Object o) = Field <$> + o .:? "fieldAttributes" .!= [] <*> + o .: "fieldOrdinal" <*> + o .:? "fieldModifier" .!= Optional <*> + o .: "fieldType" <*> + o .: "fieldName" <*> + o .:? "fieldDefault" .!= Nothing + parseJSON x = modifyFailure + (const $ "Expected a representation of Field but found: " ++ show x) + empty + +instance ToJSON Field where + toJSON f = object + [ "fieldAttributes" .= fieldAttributes f + , "fieldOrdinal" .= fieldOrdinal f + , "fieldModifier" .= fieldModifier f + , "fieldType" .= fieldType f + , "fieldName" .= fieldName f + , "fieldDefault" .= fieldDefault f + ] + +instance FromJSON Constraint where + parseJSON (String "value") = pure Value + parseJSON x = modifyFailure + (const $ "Expected a representation of Constraint but found: " ++ show x) + empty + +instance ToJSON Constraint where + toJSON Value = "value" + +instance FromJSON Namespace where + parseJSON (Object v) = + Namespace <$> + v .:? "language" <*> + v .: "name" + parseJSON x = modifyFailure + (const $ "Expected an object but found: " ++ show x) + empty + +instance ToJSON Namespace where + toJSON (Namespace Nothing name) = object + [ "name" .= name + ] + toJSON Namespace {..} = object + [ "language" .= nsLanguage + , "name" .= nsName + ] + +instance FromJSON Bond where + parseJSON (Object v) = + Bond <$> + v .: "imports" <*> + v .: "namespaces" <*> + v .: "declarations" + parseJSON x = modifyFailure + (const $ "Expected an object but found: " ++ show x) + empty + +instance ToJSON Bond where + toJSON Bond {..} = object + [ "imports" .= bondImports + , "namespaces" .= bondNamespaces + , "declarations" .= bondDeclarations + ] + +$(deriveJSON defaultOptions ''Modifier) +$(deriveJSON defaultOptions ''Attribute) +$(deriveJSON defaultOptions ''Constant) +$(deriveJSON defaultOptions ''TypeParam) +$(deriveJSON defaultOptions ''Declaration) +$(deriveJSON defaultOptions ''Import) +$(deriveJSON defaultOptions ''Language) + diff --git a/src/Language/Bond/Syntax/SchemaDef.hs b/src/Language/Bond/Syntax/SchemaDef.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Syntax/SchemaDef.hs @@ -0,0 +1,209 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-| +Copyright : (c) Microsoft +License : MIT +Maintainer : adamsap@microsoft.com +Stability : provisional +Portability : portable +-} + +{-# LANGUAGE OverloadedStrings, RecordWildCards, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} + +module Language.Bond.Syntax.SchemaDef + ( -- * Runtime schema (aka SchemaDef) support + encodeSchemaDef + ) where + +import Data.Word +import Data.List +import Data.Maybe +import Data.Function +import Data.Text.Lazy.Builder +import qualified Data.Foldable as F +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text.Lazy as L +import Data.Monoid +import Control.Applicative hiding (optional) +import Prelude +import Data.Aeson +import Data.Aeson.TH +import Language.Bond.Util +import Language.Bond.Syntax.Types +import Language.Bond.Syntax.Util +import Language.Bond.Codegen.TypeMapping + +-- | Returns an instance of +-- for the specified type. The SchemaDef is encoded using Bond Simple JSON +-- protocol and returned as a lazy 'BL.ByteString'. +encodeSchemaDef :: Type -> BL.ByteString +encodeSchemaDef = encode . makeSchemaDef + +data SchemaDef = + SchemaDef + { structs :: [StructDef] + } + +data StructDef = + StructDef + { metadata :: Metadata + , base_def :: Maybe [TypeDef] + , fields :: [FieldDef] + } + +data FieldDef = + FieldDef + { _metadata :: Metadata + , _id :: Word16 + , _type :: TypeDef + } + +data TypeDef = + TypeDef + { id :: Maybe Int + , struct_def :: Maybe Int + , element :: Maybe [TypeDef] + , key :: Maybe [TypeDef] + , bonded_type :: Maybe Bool + } + +data Metadata = + Metadata + { name :: String + , qualified_name :: Maybe String + , attributes :: Maybe [String] + , modifier :: Maybe Int + , default_value :: Maybe Variant + } + +data Variant = + Variant + { uint_value :: Maybe Integer + , int_value :: Maybe Integer + , double_value :: Maybe Double + , string_value :: Maybe String + , wstring_value :: Maybe String + , nothing :: Maybe Bool + } + +-- Returns BondDataType enum value for a 'Type'. Applies only to scalars/strings +typeId :: Type -> Int +typeId t = case t of + BT_Bool -> 2 + BT_UInt8 -> 3 + BT_UInt16 -> 4 + BT_UInt32 -> 5 + BT_UInt64 -> 6 + BT_Float -> 7 + BT_Double -> 8 + BT_String -> 9 + BT_Int8 -> 14 + BT_Int16 -> 15 + BT_Int32 -> 16 + BT_Int64 -> 17 + BT_WString -> 18 + BT_MetaName -> typeId BT_String + BT_MetaFullName -> typeId BT_String + (BT_UserDefined Enum {} _) -> typeId BT_Int32 + _ -> error "typeId: unexpected type" + + +makeSchemaDef :: Type -> SchemaDef +makeSchemaDef root = SchemaDef $ map structDef structs + where + ctx = MappingContext idlTypeMapping [] [] [] + -- list of structs in the schema + structs = nub $ f root + where + f t@(BT_UserDefined Struct{..} declArgs) = [t] + <|> optional ((foldMapType f) . resolve) structBase + <|> F.foldMap ((foldMapType f) . resolve . fieldType) structFields + where + resolve = resolveType declParams declArgs + f _ = mempty + -- index of a struct in the schema + structIdx typ@(BT_UserDefined f fArgs) = case findIndex matchingStruct structs of + Nothing -> error $ "makeSchemaDef.structIdx: struct not found " ++ show typ + Just n -> n + where + matchingStruct (BT_UserDefined s@Struct{} sArgs) = + declName s == declName f + && not (null $ intersect (declNamespaces s) (declNamespaces f)) + && sArgs == fArgs + matchingStruct t = typ == t + structIdx typ = error $ "makeSchemaDef.structIdx: undefined struct: " ++ show typ + -- StructDef for the specified struct type + structDef typ@(BT_UserDefined s@Struct{..} declArgs) = StructDef metadata base fields + where + resolve = resolveType declParams declArgs + structQualifiedName = L.unpack $ toLazyText $ getTypeName ctx typ + structName = drop (1 + (length $ qualifiedName $ getDeclNamespace ctx s)) structQualifiedName + metadata = Metadata structName (Just structQualifiedName) (attr declAttributes) Nothing Nothing + base = pure . typeDef . resolve <$> structBase + fields = map fieldDef structFields + fieldDef Field {..} = FieldDef fieldMetadata fieldOrdinal (typeDef schemaFieldType) + where + schemaFieldType = resolve fieldType + fieldMetadata = Metadata fieldName Nothing (attr fieldAttributes) modifier + (defaultValue schemaFieldType <$> fieldDefault) + modifier = case fieldModifier of + Optional -> Nothing + Required -> Just 1 + RequiredOptional -> Just 2 + defaultValue BT_WString (DefaultString x) = variant {wstring_value = Just x} + defaultValue BT_String (DefaultString x) = variant {string_value = Just x} + defaultValue t (DefaultFloat x) + | isFloat t = variant {double_value = Just x} + defaultValue t (DefaultInteger x) + | isSigned t = variant {int_value = Just x} + | isUnsigned t = variant {uint_value = Just x} + | isFloat t = variant {double_value = Just $ fromInteger x} + defaultValue BT_Maybe{} (DefaultNothing) = variant {nothing = Just True} + defaultValue BT_Bool (DefaultBool x) = variant {uint_value = Just $ if x then 1 else 0} + defaultValue (BT_UserDefined e _) (DefaultEnum x) = variant {int_value = Just $ resolveEnum e x} + defaultValue _ _ = error $ "makeSchemaDef.defaultValue: invalid default value for field " + ++ structName ++ "." ++ fieldName + structDef _ = error "makeSchemaDef.structDef: Not a struct type" + -- TypeDef for specified type + typeDef typ + | isScalar typ || isString typ || isMetaName typ + = TypeDef (Just $ typeId typ) Nothing Nothing Nothing Nothing + | otherwise = case typ of + BT_Blob -> listDef BT_Int8 + (BT_List t) -> listDef t + (BT_Vector t) -> listDef t + (BT_Nullable t) -> listDef t + (BT_Set t) -> TypeDef (Just 12) Nothing (Just [typeDef t]) Nothing Nothing + (BT_Map k t) -> TypeDef (Just 13) Nothing (Just [typeDef t]) (Just [typeDef k]) Nothing + (BT_Bonded t) -> (typeDef t) {bonded_type = Just True} + (BT_Maybe t) -> typeDef t + t -> TypeDef Nothing (Just (structIdx t)) Nothing Nothing Nothing + where + listDef t = TypeDef (Just 11) Nothing (Just [typeDef t]) Nothing Nothing + variant = Variant Nothing Nothing Nothing Nothing Nothing Nothing + attr [] = Nothing + attr xs = Just $ concatMap (\a -> [qualifiedName $ attrName a, attrValue a]) xs + qualifiedName = L.unpack . toLazyText . getQualifiedName ctx + -- resolve type parameters into type arguments and aliases into aliased types + resolveType typeParams typeArgs = fmapType resolve + where + resolve (BT_TypeParam p) = snd . fromJust $ find ((p ==) . fst) $ zip typeParams typeArgs + resolve (BT_UserDefined a@Alias{} args) = resolve $ resolveAlias a args + resolve t = t + -- resolve value of an enum constant + resolveEnum Enum{..} n = fromIntegral . snd . fromJust $ find ((n ==) . fst) $ nameValues 0 enumConstants + where + -- fill in values for constants w/o explicitly specified value + nameValues _ [] = [] + nameValues _ ((Constant name (Just value)):xs) = (name, value) : nameValues (value + 1) xs + nameValues next ((Constant name Nothing):xs) = (name, next) : nameValues (next + 1) xs + resolveEnum _ _ = error "makeSchemaDef.resolveEnum: not a enum" + +$(deriveToJSON defaultOptions {omitNothingFields = True} ''SchemaDef) +$(deriveToJSON defaultOptions {omitNothingFields = True} ''StructDef) +$(deriveToJSON defaultOptions {omitNothingFields = True, fieldLabelModifier = dropWhile ('_' ==)} ''FieldDef) +$(deriveToJSON defaultOptions {omitNothingFields = True} ''TypeDef) +$(deriveToJSON defaultOptions {omitNothingFields = True} ''Metadata) +$(deriveToJSON defaultOptions {omitNothingFields = True} ''Variant) diff --git a/src/Language/Bond/Syntax/Types.hs b/src/Language/Bond/Syntax/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Syntax/Types.hs @@ -0,0 +1,180 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveGeneric #-} + +{-| +Copyright : (c) Microsoft +License : MIT +Maintainer : adamsap@microsoft.com +Stability : provisional +Portability : portable + +A suite of types describing the abstract syntax tree of the Bond +. +-} + +module Language.Bond.Syntax.Types + ( -- * Schema definition file + Bond(..) + , QualifiedName + , Import(..) + , Namespace(..) + -- ** Declarations + , Declaration(..) + , Field(..) + , Default(..) + , Modifier(..) + , Constant(..) + -- ** Types + , Type(..) + , TypeParam(..) + , Constraint(..) + -- ** Metadata + , Attribute(..) + -- ** Deprecated + , Language(..) + ) where + +import Data.Word + +-- | Represents fully qualified name +type QualifiedName = [String] + +-- | Specifies whether a field is required or optional. +data Modifier = + Optional | -- ^ field is optional and may be omitted during serialization + Required | -- ^ field is required, deserialization will fail if it is missing + RequiredOptional -- ^ deserialization will not fail if the field is missing but it can't be omitted during serialization + deriving (Eq, Show) + +-- | Type in the Bond type system +data Type = + BT_Int8 | BT_Int16 | BT_Int32 | BT_Int64 | + BT_UInt8 | BT_UInt16 | BT_UInt32 | BT_UInt64 | + BT_Float | BT_Double | + BT_Bool | + BT_String | BT_WString | + BT_MetaName | BT_MetaFullName | + BT_Blob | + BT_Maybe Type | -- ^ type for fields with the default value of @nothing@ + BT_List Type | + BT_Vector Type | + BT_Nullable Type | + BT_Set Type | + BT_Map Type Type | + BT_Bonded Type | + BT_IntTypeArg Int | -- ^ an integer argument in an instance of a generic type 'Alias' + BT_TypeParam TypeParam | -- ^ type parameter of a generic 'Struct' or 'Alias' declaration + BT_UserDefined Declaration [Type] -- ^ user defined type or an instance of a generic type with the specified type arguments + deriving (Eq, Show) + +-- | Default value of a field. +data Default = + DefaultBool Bool | + DefaultInteger Integer | + DefaultFloat Double | + DefaultString String | + DefaultEnum String | -- ^ name of an enum 'Constant' + DefaultNothing -- ^ explicitly specified default value of @nothing@ + deriving (Eq, Show) + +-- | for attaching user defined metadata to a 'Declaration' or a 'Field' +data Attribute = + Attribute + { attrName :: QualifiedName -- attribute name + , attrValue :: String -- value + } + deriving (Eq, Show) + +-- | Definition of a 'Struct' field. +data Field = + Field + { fieldAttributes :: [Attribute] -- zero or more attributes + , fieldOrdinal :: Word16 -- ordinal + , fieldModifier :: Modifier -- field modifier + , fieldType :: Type -- type + , fieldName :: String -- field name + , fieldDefault :: Maybe Default -- optional default value + } + deriving (Eq, Show) + +-- | Definition of an 'Enum' constant. +data Constant = + Constant + { constantName :: String -- enum constant name + , constantValue :: Maybe Int -- optional constant value + } + deriving (Eq, Show) + +-- | Constraint on a 'TypeParam'. +data Constraint = Value -- ^ the type parameter allows only value types + deriving (Eq, Show) + +-- | Type parameter of a 'Struct' or type 'Alias' +data TypeParam = + TypeParam + { paramName :: String + , paramConstraint :: Maybe Constraint + } + deriving (Eq, Show) + +-- | A declaration of a schema type. +data Declaration = + Struct + { declNamespaces :: [Namespace] -- namespace(s) in which the struct is declared + , declAttributes :: [Attribute] -- zero or more attributes + , declName :: String -- struct identifier + , declParams :: [TypeParam] -- list of type parameters for generics + , structBase :: Maybe Type -- optional base struct + , structFields :: [Field] -- zero or more fields + } + | -- ^ + Enum + { declNamespaces :: [Namespace] -- namespace(s) in which the enum is declared + , declAttributes :: [Attribute] -- zero or more attributes + , declName :: String -- enum identifier + , enumConstants :: [Constant] -- one or more enum constant values + } + | -- ^ + Forward + { declNamespaces :: [Namespace] -- namespace(s) in which the struct is declared + , declName :: String -- struct identifier + , declParams :: [TypeParam] -- type parameters for generics + } + | -- ^ + Alias + { declNamespaces :: [Namespace] -- namespace(s) in which the type alias is declared + , declName :: String -- alias identifier + , declParams :: [TypeParam] -- type parameters for generics + , aliasType :: Type -- aliased type + } -- ^ + deriving (Eq, Show) + +-- | declaration. +data Import = Import FilePath + deriving (Eq, Show) + +-- | Language annotation for namespaces. Note that language-specific +-- namespaces are only supported for backward compatibility and are not +-- recommended. +data Language = Cpp | Cs | Java + deriving (Eq, Show) + +-- | declaration. +data Namespace = + Namespace + { nsLanguage :: Maybe Language + , nsName :: QualifiedName + } + deriving (Eq, Show) + +-- | The top level type representing the Bond schema definition abstract syntax tree. +data Bond = + Bond + { bondImports :: [Import] + , bondNamespaces :: [Namespace] + , bondDeclarations :: [Declaration] + } + deriving (Eq, Show) + diff --git a/src/Language/Bond/Syntax/Util.hs b/src/Language/Bond/Syntax/Util.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Syntax/Util.hs @@ -0,0 +1,226 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-| +Copyright : (c) Microsoft +License : MIT +Maintainer : adamsap@microsoft.com +Stability : provisional +Portability : portable +-} + +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} + +module Language.Bond.Syntax.Util + ( -- * Type classification + -- | Functions that test if a type belongs to a particular category. These + -- functions will resolve type aliases and return answer based on the type + -- the alias resolves to. + isScalar + , isUnsigned + , isSigned + , isFloat + , isString + , isContainer + , isList + , isAssociative + , isNullable + , isStruct + , isMetaName + -- * Type mapping + , fmapType + -- * Folds + , foldMapFields + , foldMapStructFields + , foldMapType + -- * Helper functions + , resolveAlias + ) where + +import Data.Maybe +import Data.List +import qualified Data.Foldable as F +import Data.Monoid +import Prelude +import Language.Bond.Util +import Language.Bond.Syntax.Types + +-- | Returns 'True' if the type represents a scalar. +isScalar :: Type -> Bool +isScalar BT_Int8 = True +isScalar BT_Int16 = True +isScalar BT_Int32 = True +isScalar BT_Int64 = True +isScalar BT_UInt8 = True +isScalar BT_UInt16 = True +isScalar BT_UInt32 = True +isScalar BT_UInt64 = True +isScalar BT_Float = True +isScalar BT_Double = True +isScalar BT_Bool = True +isScalar (BT_TypeParam (TypeParam _ (Just Value))) = True +isScalar (BT_UserDefined Enum {..} _) = True +isScalar (BT_UserDefined a@Alias {} args) = isScalar $ resolveAlias a args +isScalar _ = False + +-- | Returns 'True' if the type represents unsigned integer. +isUnsigned :: Type -> Bool +isUnsigned BT_UInt8 = True +isUnsigned BT_UInt16 = True +isUnsigned BT_UInt32 = True +isUnsigned BT_UInt64 = True +isUnsigned (BT_UserDefined a@Alias {} args) = isUnsigned $ resolveAlias a args +isUnsigned _ = False + +-- | Returns 'True' if the type represents signed integer. +isSigned :: Type -> Bool +isSigned BT_Int8 = True +isSigned BT_Int16 = True +isSigned BT_Int32 = True +isSigned BT_Int64 = True +isSigned (BT_UserDefined a@Alias {} args) = isSigned $ resolveAlias a args +isSigned _ = False + +-- | Returns 'True' if the type represents floating point number. +isFloat :: Type -> Bool +isFloat BT_Float = True +isFloat BT_Double = True +isFloat (BT_UserDefined a@Alias {} args) = isFloat $ resolveAlias a args +isFloat _ = False + +-- | Returns 'True' if the type represents a meta-name type. +isMetaName :: Type -> Bool +isMetaName BT_MetaName = True +isMetaName BT_MetaFullName = True +isMetaName (BT_UserDefined a@Alias {} args) = isMetaName $ resolveAlias a args +isMetaName _ = False + +-- | Returns 'True' if the type represents a string. +isString :: Type -> Bool +isString BT_String = True +isString BT_WString = True +isString (BT_UserDefined a@Alias {} args) = isString $ resolveAlias a args +isString _ = False + +-- | Returns 'True' if the type represents a list or a vector. +isList :: Type -> Bool +isList (BT_List _) = True +isList (BT_Vector _) = True +isList (BT_UserDefined a@Alias {} args) = isList $ resolveAlias a args +isList _ = False + +-- | Returns 'True' if the type represents a map or a set. +isAssociative :: Type -> Bool +isAssociative (BT_Set _) = True +isAssociative (BT_Map _ _) = True +isAssociative (BT_UserDefined a@Alias {} args) = isAssociative $ resolveAlias a args +isAssociative _ = False + +-- | Returns 'True' if the type represents a container (i.e. list, vector, set or map). +isContainer :: Type -> Bool +isContainer f = isList f || isAssociative f + +-- | Returns 'True' if the type represents a struct or a struct forward declaration. +isStruct :: Type -> Bool +isStruct (BT_UserDefined Struct {} _) = True +isStruct (BT_UserDefined Forward {} _) = True +isStruct (BT_UserDefined a@Alias {} args) = isStruct $ resolveAlias a args +isStruct _ = False + +-- | Returns 'True' if the type represents a nullable type. +isNullable :: Type -> Bool +isNullable (BT_Nullable _) = True +isNullable (BT_UserDefined a@Alias {} args) = isNullable $ resolveAlias a args +isNullable _ = False + +-- | Recursively map a 'Type' into another 'Type'. +-- +-- ==== __Examples__ +-- +-- Change lists into vectors: +-- +-- > listToVector = fmapType f +-- > where +-- > f (BT_List x) = BT_Vector x +-- > f x = x +fmapType :: (Type -> Type) -> Type -> Type +fmapType f (BT_UserDefined decl args) = f $ BT_UserDefined decl $ map (fmapType f) args +fmapType f (BT_Maybe element) = f $ BT_Maybe $ fmapType f element +fmapType f (BT_Map key value) = f $ BT_Map (fmapType f key) (fmapType f value) +fmapType f (BT_List element) = f $ BT_List $ fmapType f element +fmapType f (BT_Vector element) = f $ BT_Vector $ fmapType f element +fmapType f (BT_Set element) = f $ BT_Set $ fmapType f element +fmapType f (BT_Nullable element) = f $ BT_Nullable $ fmapType f element +fmapType f (BT_Bonded struct) = f $ BT_Bonded $ fmapType f struct +fmapType f x = f x + +-- | Maps all fields, including fields of the base, to a 'Monoid', and combines +-- the results. Returns 'mempty' if type is not a struct. +-- +-- ==== __Examples__ +-- +-- Check if there are any container fields: +-- +-- > anyContainerFields :: Type -> Bool +-- > anyContainerFields = getAny . foldMapFields (Any . isContainer . fieldType) +foldMapFields :: (Monoid m) => (Field -> m) -> Type -> m +foldMapFields f t = case t of + (BT_UserDefined Struct {..} _) -> optional (foldMapFields f) structBase <> F.foldMap f structFields + (BT_UserDefined a@Alias {..} args) -> foldMapFields f $ resolveAlias a args + _ -> mempty + +-- | Like 'foldMapFields' but takes a 'Declaration' as an argument instead of 'Type'. +foldMapStructFields :: Monoid m => (Field -> m) -> Declaration -> m +foldMapStructFields f s = foldMapFields f $ BT_UserDefined s [] + +-- | Maps all parts of a 'Type' to a 'Monoid' and combines the results. +-- +-- ==== __Examples__ +-- +-- For a type: +-- +-- > list> +-- +-- the result is: +-- +-- > f (BT_List (BT_Nullable BT_Int32)) +-- > <> f (BT_Nullable BT_Int32) +-- > <> f BT_Int32 +-- +-- 'foldMapType' resolves type aliases. E.g. given the following type alias +-- declaration (Bond IDL syntax): +-- +-- > using Array = vector; +-- +-- the result for the following type: +-- +-- > Array +-- +-- is: +-- +-- > f (BT_UserDefined Alias{..} [BT_Int32, BT_IntTypeArg 10]) +-- > <> f (BT_Vector BT_Int32) +-- > <> f BT_Int32 +foldMapType :: (Monoid m) => (Type -> m) -> Type -> m +foldMapType f t@(BT_UserDefined a@Alias {} args) = f t <> foldMapType f (resolveAlias a args) +foldMapType f t@(BT_UserDefined _ args) = f t <> F.foldMap (foldMapType f) args +foldMapType f t@(BT_Maybe element) = f t <> foldMapType f element +foldMapType f t@(BT_Map key value) = f t <> foldMapType f key <> foldMapType f value +foldMapType f t@(BT_List element) = f t <> foldMapType f element +foldMapType f t@(BT_Vector element) = f t <> foldMapType f element +foldMapType f t@(BT_Set element) = f t <> foldMapType f element +foldMapType f t@(BT_Nullable element) = f t <> foldMapType f element +foldMapType f t@(BT_Bonded struct) = f t <> foldMapType f struct +foldMapType f x = f x + + +-- | Resolves a type alias declaration with given type arguments. Note that the +-- function resolves one level of aliasing and thus may return a type alias. +resolveAlias :: Declaration -> [Type] -> Type +resolveAlias Alias {..} args = fmapType resolveParam aliasType + where + resolveParam (BT_TypeParam param) = snd.fromJust $ find ((param ==).fst) paramsArgs + resolveParam x = x + paramsArgs = zip declParams args +resolveAlias _ _ = error "resolveAlias: impossible happened." + diff --git a/src/Language/Bond/Util.hs b/src/Language/Bond/Util.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bond/Util.hs @@ -0,0 +1,96 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE OverloadedStrings #-} + +{-| +Copyright : (c) Microsoft +License : MIT +Maintainer : adamsap@microsoft.com +Stability : provisional +Portability : portable + +Helper functions for combining elements into common constructs. These functions +can be used in code generation to lazily combine 'Text' elements but they are +more generic and work for any 'Monoid'. +-} + +module Language.Bond.Util + ( sepBy + , sepEndBy + , sepBeginBy + , optional + , angles + , brackets + , braces + , parens + , between + ) where + +import Data.Monoid +import Data.String (IsString) +import Prelude + +sepEndBy, sepBeginBy, sepBy :: (Monoid a, Eq a) => a -> (b -> a) -> [b] -> a + +-- | Maps elements of a list and combines them with 'mappend' using given +-- separator, ending with a separator. +sepEndBy _ _ [] = mempty +sepEndBy s f (x:xs) + | next == mempty = rest + | otherwise = next <> s <> rest + where + next = f x + rest = sepEndBy s f xs + +-- | Maps elements of a list and combines them with 'mappend' using given +-- separator, starting with a separator. +sepBeginBy _ _ [] = mempty +sepBeginBy s f (x:xs) + | next == mempty = rest + | otherwise = s <> next <> rest + where + next = f x + rest = sepBeginBy s f xs + +-- | Maps elements of a list and combines them with 'mappend' using given +-- separator. +sepBy _ _ [] = mempty +sepBy s f (x:xs) + | null xs = next + | next == mempty = rest + | otherwise = next <> sepBeginBy s f xs + where + next = f x + rest = sepBy s f xs + +-- | The function takes a function and a Maybe value. If the Maybe value is +-- Nothing, the function returns 'mempty', otherwise, it applies the function +-- to the value inside 'Just' and returns the result. +optional :: (Monoid m) => (a -> m) -> Maybe a -> m +optional = maybe mempty + +-- | If the 3rd argument is not 'mempty' the function wraps it between the +-- first and second argument using 'mappend', otherwise it return 'mempty'. +between :: (Monoid a, Eq a) => a -> a -> a -> a +between l r m + | m == mempty = mempty + | otherwise = l <> m <> r + +angles, brackets, braces, parens :: (Monoid a, IsString a, Eq a) => a -> a +-- | Wraps the string argument between @<@ and @>@, unless the argument is +-- 'mempty' in which case the function returns 'mempty'. +angles m = between "<" ">" m + +-- | Wraps the string argument between @[@ and @]@, unless the argument is +-- 'mempty' in which case the function returns 'mempty'. +brackets m = between "[" "]" m + +-- | Wraps the string argument between @{@ and @}@, unless the argument is +-- 'mempty' in which case the function returns 'mempty'. +braces m = between "{" "}" m + +-- | Wraps the string argument between @(@ and @)@, unless the argument is +-- 'mempty' in which case the function returns 'mempty'. +parens m = between "(" ")" m + diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,109 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Tasty.HUnit (testCase) +import Tests.Syntax +import Tests.Codegen + +tests :: TestTree +tests = testGroup "Compiler tests" + [ testGroup "AST" + [ localOption (QuickCheckMaxSize 15) $ + testProperty "roundtrip" roundtripAST + , testGroup "Compare .bond and .json" + [ testCase "attributes" $ compareAST "attributes" + , testCase "basic types" $ compareAST "basic_types" + , testCase "complex types" $ compareAST "complex_types" + , testCase "default values" $ compareAST "defaults" + , testCase "empty" $ compareAST "empty" + , testCase "field modifiers" $ compareAST "field_modifiers" + , testCase "generics" $ compareAST "generics" + , testCase "inheritance" $ compareAST "inheritance" + , testCase "type aliases" $ compareAST "aliases" + , testCase "documentation example" $ compareAST "example" + ] + ] + , testGroup "SchemaDef" + [ verifySchemaDef "attributes" "Foo" + , verifySchemaDef "basic_types" "BasicTypes" + , verifySchemaDef "defaults" "Foo" + , verifySchemaDef "field_modifiers" "Foo" + , verifySchemaDef "inheritance" "Foo" + , verifySchemaDef "alias_key" "foo" + , verifySchemaDef "maybe_blob" "Foo" + , verifySchemaDef "nullable_alias" "foo" + , verifySchemaDef "schemadef" "AliasBase" + , verifySchemaDef "schemadef" "EnumDefault" + , verifySchemaDef "schemadef" "StringTree" + , verifySchemaDef "example" "SomeStruct" + ] + , testGroup "Types" + [ testCase "type alias resolution" aliasResolution + ] + , testGroup "Codegen" + [ testGroup "C++" + [ verifyCppCodegen "attributes" + , verifyCppCodegen "basic_types" + , verifyCppCodegen "complex_types" + , verifyCppCodegen "defaults" + , verifyCppCodegen "empty" + , verifyCppCodegen "field_modifiers" + , verifyCppCodegen "generics" + , verifyCppCodegen "inheritance" + , verifyCppCodegen "aliases" + , verifyCppCodegen "alias_key" + , verifyCppCodegen "maybe_blob" + , verifyCodegen + [ "c++" + , "--allocator=arena" + ] + "alias_with_allocator" + , verifyCodegen + [ "c++" + , "--allocator=arena" + , "--using=List=my::list<{0}, arena>" + , "--using=Vector=my::vector<{0}, arena>" + , "--using=Set=my::set<{0}, arena>" + , "--using=Map=my::map<{0}, {1}, arena>" + , "--using=String=my::string" + ] + "custom_alias_with_allocator" + , verifyCodegen + [ "c++" + , "--allocator=arena" + , "--using=List=my::list<{0}>" + , "--using=Vector=my::vector<{0}>" + , "--using=Set=my::set<{0}>" + , "--using=Map=my::map<{0}, {1}>" + , "--using=String=my::string" + ] + "custom_alias_without_allocator" + , verifyApplyCodegen + [ "c++" + , "--apply-attribute=DllExport" + ] + "basic_types" + ] + , testGroup "C#" + [ verifyCsCodegen "attributes" + , verifyCsCodegen "basic_types" + , verifyCsCodegen "complex_types" + , verifyCsCodegen "defaults" + , verifyCsCodegen "empty" + , verifyCsCodegen "field_modifiers" + , verifyCsCodegen "generics" + , verifyCsCodegen "inheritance" + , verifyCsCodegen "aliases" + , verifyCodegen + [ "c#" + , "--using=time=System.DateTime" + ] + "nullable_alias" + ] + ] + ] + +main :: IO () +main = defaultMain tests diff --git a/tests/Tests/Codegen.hs b/tests/Tests/Codegen.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Codegen.hs @@ -0,0 +1,118 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +module Tests.Codegen + ( verifyCodegen + , verifyCppCodegen + , verifyApplyCodegen + , verifyCsCodegen + ) where + +import System.FilePath +import Control.Monad +import Data.Monoid +import Data.Maybe +import Prelude +import Data.Algorithm.DiffContext +import Data.Text.Lazy (Text, unpack) +import qualified Data.ByteString.Char8 as BS +import Text.PrettyPrint (render, text) +import Test.Tasty +import Test.Tasty.Golden.Advanced +import Language.Bond.Codegen.Templates +import Language.Bond.Codegen.TypeMapping +import Language.Bond.Syntax.Types (Bond(..), Import, Declaration) +import Options +import IO + +type Template = MappingContext -> String -> [Import] -> [Declaration] -> (String, Text) + +verifyCppCodegen :: FilePath -> TestTree +verifyCppCodegen = verifyCodegen ["c++"] + +verifyCsCodegen :: FilePath -> TestTree +verifyCsCodegen = verifyCodegen ["c#"] + +verifyCodegen :: [String] -> FilePath -> TestTree +verifyCodegen args baseName = + testGroup baseName $ + verifyFiles (processOptions args) baseName + +verifyApplyCodegen :: [String] -> FilePath -> TestTree +verifyApplyCodegen args baseName = + testGroup baseName $ + map (verifyFile options baseName cppTypeMapping "apply") templates + where + options = processOptions args + templates = + [ apply_h protocols (apply_attribute options) + , apply_cpp protocols + ] + protocols = + [ Protocol "bond::CompactBinaryReader" + "bond::CompactBinaryWriter" + , Protocol "bond::FastBinaryReader" + "bond::FastBinaryWriter" + , Protocol "bond::SimpleBinaryReader" + "bond::SimpleBinaryWriter" + ] + + +verifyFiles :: Options -> FilePath -> [TestTree] +verifyFiles options baseName = + map (verify (typeMapping options) "") (templates options) + <> + extra options + where + verify = verifyFile options baseName + fieldMapping Cs {..} = if readonly_properties + then ReadOnlyProperties + else if fields + then PublicFields + else Properties + typeMapping Cpp {..} = maybe cppTypeMapping cppCustomAllocTypeMapping allocator + typeMapping Cs {} = csTypeMapping + templates Cpp {..} = + [ reflection_h + , types_cpp + , types_h header enum_header allocator + ] + templates Cs {..} = + [ types_cs Class $ fieldMapping options + ] + extra Cs {} = + [ testGroup "collection interfaces" $ + map (verify csCollectionInterfacesTypeMapping "collection-interfaces") (templates options) + ] + extra Cpp {..} = + [ testGroup "custom allocator" $ + map (verify (cppCustomAllocTypeMapping "arena") "allocator") + (templates $ options { allocator = Just "arena" }) + | isNothing allocator + ] + +verifyFile :: Options -> FilePath -> TypeMapping -> FilePath -> Template -> TestTree +verifyFile options baseName typeMapping subfolder template = + goldenTest suffix readGolden codegen cmp updateGolden + where + (suffix, _) = template (MappingContext typeMapping [] [] []) "" [] [] + golden = "tests" "generated" subfolder baseName ++ suffix + readGolden = BS.readFile golden + updateGolden = BS.writeFile golden + codegen = do + aliasMapping <- parseAliasMappings $ using options + namespaceMapping <- parseNamespaceMappings $ namespace options + (Bond imports namespaces declarations) <- parseBondFile [] $ "tests" "schema" baseName <.> "bond" + let mappingContext = MappingContext typeMapping aliasMapping namespaceMapping namespaces + let (_, code) = template mappingContext baseName imports declarations + return $ BS.pack $ unpack code + cmp x y = return $ if x == y then Nothing else Just $ diff x y + diff x y = render $ prettyContextDiff + (text golden) + (text "test output") + (text . BS.unpack) + (getContextDiff 3 (BS.lines x) (BS.lines y)) + diff --git a/tests/Tests/Syntax.hs b/tests/Tests/Syntax.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Syntax.hs @@ -0,0 +1,114 @@ +-- Copyright (c) Microsoft. All rights reserved. +-- Licensed under the MIT license. See LICENSE file in the project root for full license information. + +{-# LANGUAGE OverloadedStrings, RecordWildCards, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Tests.Syntax + ( roundtripAST + , compareAST + , aliasResolution + , verifySchemaDef + ) where + +import Data.Maybe +import Data.List +import Data.Aeson (encode, decode) +import Data.DeriveTH +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import System.FilePath +import Test.QuickCheck +import Test.HUnit +import Test.Tasty +import Test.Tasty.Golden +import Language.Bond.Syntax.Types +import Language.Bond.Syntax.Util +import Language.Bond.Syntax.SchemaDef +import IO + +derive makeArbitrary ''Attribute +derive makeArbitrary ''Bond +derive makeArbitrary ''Constant +derive makeArbitrary ''Constraint +derive makeArbitrary ''Declaration +derive makeArbitrary ''Default +derive makeArbitrary ''Field +derive makeArbitrary ''Import +derive makeArbitrary ''Language +derive makeArbitrary ''Modifier +derive makeArbitrary ''Namespace +derive makeArbitrary ''Type +derive makeArbitrary ''TypeParam + +roundtripAST :: Bond -> Bool +roundtripAST x = (decode . encode) x == Just x + +compareAST :: FilePath -> Assertion +compareAST file = do + bond <- parseBondFile [] $ "tests" "schema" file <.> "bond" + json <- parseASTFile $ "tests" "schema" file <.> "json" + assertEqual "" bond json + +aliasResolution :: Assertion +aliasResolution = do + let p1 = TypeParam "T" Nothing + let p2 = TypeParam "U" Nothing + let a1 = Alias [] "" [] BT_Bool + let a2 = Alias [] "" [p1] $ BT_TypeParam p1 + let a3 = Alias [] "" [p1] $ BT_List $ BT_TypeParam p1 + let a4 = Alias [] "" [p1, p2] $ BT_Nullable $ BT_Map (BT_TypeParam p2) (BT_Nullable $ BT_TypeParam p1) + let a5 = Alias [] "" [p1] $ BT_List $ BT_UserDefined a3 [BT_TypeParam p1] + let a6 = Alias [] "" [p1, p2] $ BT_Vector $ BT_Vector $ BT_TypeParam p2 + + assertEqual "" BT_Bool $ + resolveAlias a1 [] + + assertEqual "" BT_Int32 $ + resolveAlias a2 [BT_Int32] + + assertEqual "" (BT_Set BT_Int32) $ + resolveAlias a2 [BT_Set BT_Int32] + + assertEqual "" (BT_TypeParam p2) $ + resolveAlias a2 [BT_TypeParam p2] + + assertEqual "" (BT_TypeParam p1) $ + resolveAlias a2 [BT_TypeParam p1] + + assertEqual "" (BT_List BT_Int32) $ + resolveAlias a3 [BT_Int32] + + assertEqual "" (BT_List $ BT_UserDefined a1 []) $ + resolveAlias a3 [BT_UserDefined a1 []] + + assertEqual "" (BT_Nullable $ BT_Map BT_Bool $ BT_Nullable BT_String) $ + resolveAlias a4 [BT_String, BT_Bool] + + assertEqual "" (BT_List $ BT_UserDefined a3 [BT_Set BT_Bool]) $ + resolveAlias a5 [BT_Set BT_Bool] + + assertEqual "" (BT_Vector $ BT_Vector $ BT_List BT_Double) $ + resolveAlias a6 [BT_IntTypeArg 10, BT_List BT_Double] + +verifySchemaDef :: FilePath -> String -> TestTree +verifySchemaDef baseName schemaName = + goldenVsString + schemaName + ("tests" "generated" "schemadef" baseName <.> schemaName <.> "json") + schemaDef + where + schemaDef = do + (Bond _ _ declarations) <- parseBondFile [] $ "tests" "schema" baseName <.> "bond" + let schema = fromJust $ find ((schemaName ==) . declName) declarations + return $ + -- some versions aeson encode angle brackets + BL.fromStrict $ + replace "\\u003c" "<" $ + replace "\\u003e" ">" $ + BL.toStrict $ encodeSchemaDef $ BT_UserDefined schema [] + where + replace s r bs = if B.null t then h else + B.append h (B.append r $ replace s r (B.drop (B.length s) t)) + where + (h, t) = B.breakSubstring s bs