From 312be3b73af9af5627daad9d8705503224761104 Mon Sep 17 00:00:00 2001 From: Alexander Vershilov Date: Tue, 17 Feb 2015 00:18:20 +0300 Subject: [PATCH] Fix warnings in the Bond compiler code --- compiler/Bond/Parser.hs | 40 +++++++++------ compiler/Bond/Schema.hs | 29 ++++++++--- compiler/Bond/Template/Cpp/Apply_cpp.hs | 7 +-- compiler/Bond/Template/Cpp/Apply_h.hs | 8 ++- compiler/Bond/Template/Cpp/Enum_h.hs | 5 +- compiler/Bond/Template/Cpp/Reflection_h.hs | 2 + compiler/Bond/Template/Cpp/Types_cpp.hs | 6 ++- compiler/Bond/Template/Cpp/Types_h.hs | 7 ++- compiler/Bond/Template/Cpp/Util.hs | 21 ++++++++ compiler/Bond/Template/Cs/Types_cs.hs | 5 +- compiler/Bond/Template/Cs/Util.hs | 16 +++++- compiler/Bond/Template/CustomMapping.hs | 19 ++++--- compiler/Bond/Template/TypeMapping.hs | 58 +++++++++++++--------- compiler/Bond/Template/Util.hs | 17 +++++-- compiler/Bond/Util.hs | 17 +++++-- compiler/Bond/Version.hs | 2 + compiler/Main.hs | 24 ++++++--- compiler/Options.hs | 5 +- 18 files changed, 208 insertions(+), 80 deletions(-) diff --git a/compiler/Bond/Parser.hs b/compiler/Bond/Parser.hs index 68fbdca7..6f5e6736 100644 --- a/compiler/Bond/Parser.hs +++ b/compiler/Bond/Parser.hs @@ -15,7 +15,6 @@ import Data.List import Data.Function import Control.Applicative import Control.Monad.Reader -import Control.Monad.Trans (liftIO) import Text.Parsec.Pos (initialPos) import Text.Parsec hiding (many, optional, (<|>)) import Bond.Lexer @@ -42,6 +41,8 @@ newEnvironment = Environment [] [] type Parser a = ParsecT String Symbols (ReaderT Environment IO) a +parseBond :: SourceName + -> String -> ReaderT Environment IO (Either ParseError Bond) parseBond = runParserT bond $ Symbols [] [] data Bond = Bond [Import] [Namespace] [Declaration] @@ -88,6 +89,7 @@ declaration = do updateSymbols decl "declaration" return decl +updateSymbols :: Declaration -> Parser () updateSymbols decl = do (previous, symbols) <- partition (duplicateDeclaration decl) <$> symbols <$> getState case reconcile previous decl of @@ -103,6 +105,7 @@ updateSymbols decl = do -- 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 } @@ -118,9 +121,9 @@ findSymbol name = doFind "qualified 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) + 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 @@ -131,10 +134,10 @@ findStruct :: QualifiedName -> Parser Declaration findStruct name = doFind "qualified struct name" where doFind = do - symbol <- findSymbol name - case symbol of - Struct {..} -> return symbol - _ -> fail $ "The " ++ show symbol ++ " is invalid in this context. Expected a struct." + symb <- findSymbol name + case symb of + Struct {..} -> return symb + _ -> fail $ "The " ++ show symb ++ " is invalid in this context. Expected a struct." -- namespace namespace :: Parser Namespace @@ -189,6 +192,7 @@ view = do 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 @@ -204,14 +208,17 @@ struct = do 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 + 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 @@ -237,8 +244,8 @@ enum :: Parser Declaration enum = Enum <$> asks currentNamespaces <*> attributes <*> name <*> consts <* optional semi "enum definition" where name = keyword "enum" *> (identifier "enum identifier") - consts = braces (semiOrCommaSepEnd1 const "enum constant") - const = Constant <$> identifier <*> optional value + consts = braces (semiOrCommaSepEnd1 constant "enum constant") + constant = Constant <$> identifier <*> optional value value = equal *> (fromIntegral <$> integer) -- basic types parser @@ -276,6 +283,7 @@ basicUserType = do BT_WString -> True _ -> scalarType t typeName (BT_UserDefined decl _) = declName decl + typeName _ = error "basicUserType/typeName: impossible happened." -- containers parser complexType :: Parser Type @@ -298,14 +306,14 @@ userType = do Nothing -> do decl <- findSymbol name args <- option [] (angles $ commaSep1 arg) - if length args /= length (params decl) + if length args /= length (params' decl) then fail $ declName decl ++ " requires " ++ (show.length $ declParams decl) ++ " type argument(s)" else return $ BT_UserDefined decl args where - params Enum{..} = [] - params d = declParams d + params' Enum{..} = [] + params' d = declParams d arg = type_ <|> BT_IntTypeArg <$> (fromIntegral <$> integer) where isParam [name] TypeParam {..} = name == paramName diff --git a/compiler/Bond/Schema.hs b/compiler/Bond/Schema.hs index 028e95c1..eaa14a28 100644 --- a/compiler/Bond/Schema.hs +++ b/compiler/Bond/Schema.hs @@ -17,7 +17,7 @@ module Bond.Schema , Language(..) , Namespace(..) , Attribute(..) - , QualifiedName(..) + , QualifiedName , takeName , takeNamespace , showQualifiedName @@ -43,9 +43,6 @@ import Data.Word import Data.List import Data.Foldable (foldMap) import Data.Monoid -import System.FilePath -import Data.Text.Lazy.Builder -import Text.Shakespeare.Text import Bond.Util type QualifiedName = [String] @@ -81,6 +78,7 @@ data Type = BT_UserDefined Declaration [Type] deriving Eq +scalarType :: Type -> Bool scalarType BT_Int8 = True scalarType BT_Int16 = True scalarType BT_Int32 = True @@ -96,31 +94,39 @@ scalarType (BT_TypeParam (TypeParam _ (Just Value))) = True scalarType (BT_UserDefined Enum {..} _) = True scalarType _ = False +metaType :: Type -> Bool metaType BT_MetaName = True metaType BT_MetaFullName = True metaType _ = False +stringType :: Type -> Bool stringType BT_String = True stringType BT_WString = True stringType _ = False +listType :: Type -> Bool listType (BT_List _) = True listType (BT_Vector _) = True listType _ = False +associativeType :: Type -> Bool associativeType (BT_Set _) = True associativeType (BT_Map _ _) = True associativeType _ = False +containerType :: Type -> Bool containerType f = listType f || associativeType f +structType :: Type -> Bool structType (BT_UserDefined Struct {} _) = True structType (BT_UserDefined a@Alias {} args) = structType $ resolveAlias a args structType _ = False +nullableType :: Type -> Bool nullableType (BT_Nullable _) = True nullableType _ = False +metaField :: Field -> Any metaField Field {..} = Any $ metaType fieldType data Default = @@ -150,6 +156,13 @@ data Field = } deriving Eq +makeField :: [Attribute] + -> Word16 + -> Modifier + -> Type + -> String + -> Maybe Default + -> Field 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 @@ -206,6 +219,7 @@ data Declaration = } deriving Eq +showTypeParams :: [TypeParam] -> String showTypeParams = angles . sepBy ", " show instance Show Declaration where @@ -226,14 +240,16 @@ mapType f x = f x foldMapFields :: (Monoid m) => (Field -> m) -> Type -> m foldMapFields f t = case t of - (BT_UserDefined s@Struct {..} _) -> optional (foldMapFields f) structBase <> foldMap f structFields + (BT_UserDefined Struct {..} _) -> optional (foldMapFields f) structBase <> foldMap f structFields (BT_UserDefined a@Alias {..} args) -> foldMapFields f $ resolveAlias a args _ -> mempty +foldMapStructFields :: Monoid m + => (Field -> m) -> Declaration -> m foldMapStructFields f s = foldMapFields f $ BT_UserDefined s [] foldMapType :: (Monoid m) => (Type -> m) -> Type -> m -foldMapType f t@(BT_UserDefined decl args) = f t <> foldMap (foldMapType f) args +foldMapType f t@(BT_UserDefined _decl args) = f t <> foldMap (foldMapType f) args 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 @@ -249,6 +265,7 @@ resolveAlias Alias {..} args = mapType resolveParam $ resolveParam aliasType resolveParam (BT_TypeParam param) = snd.fromJust $ find ((param ==).fst) paramsArgs resolveParam x = x paramsArgs = zip declParams args +resolveAlias _ _ = error "resolveAlias: impossible happened." duplicateDeclaration :: Declaration -> Declaration -> Bool duplicateDeclaration left right = diff --git a/compiler/Bond/Template/Cpp/Apply_cpp.hs b/compiler/Bond/Template/Cpp/Apply_cpp.hs index 3111cf6e..92ba3d3d 100644 --- a/compiler/Bond/Template/Cpp/Apply_cpp.hs +++ b/compiler/Bond/Template/Cpp/Apply_cpp.hs @@ -5,16 +5,17 @@ module Bond.Template.Cpp.Apply_cpp (apply_cpp) where -import System.FilePath -import Data.Monoid +import Data.Text.Lazy (Text) import Text.Shakespeare.Text import Bond.Schema +import Bond.Template.TypeMapping import Bond.Template.Util import Bond.Template.Cpp.Apply_h import qualified Bond.Template.Cpp.Util as CPP -- generate the *_apply.cpp file from parsed .bond file -apply_cpp protocols cpp file imports declarations = ("_apply.cpp", [lt| +apply_cpp :: [Protocol] -> MappingContext -> String -> [Import] -> [Declaration] -> (String, Text) +apply_cpp protocols cpp file _imports declarations = ("_apply.cpp", [lt| #include "#{file}_apply.h" #include "#{file}_reflection.h" diff --git a/compiler/Bond/Template/Cpp/Apply_h.hs b/compiler/Bond/Template/Cpp/Apply_h.hs index de080a81..77fe9194 100644 --- a/compiler/Bond/Template/Cpp/Apply_h.hs +++ b/compiler/Bond/Template/Cpp/Apply_h.hs @@ -7,10 +7,12 @@ module Bond.Template.Cpp.Apply_h (apply_h, Protocol(..), apply) where import System.FilePath import Data.Monoid +import Data.Text.Lazy (Text) import Text.Shakespeare.Text import Bond.Schema import Bond.Util import Bond.Template.Util +import Bond.Template.TypeMapping import qualified Bond.Template.Cpp.Util as CPP data Protocol = @@ -20,6 +22,7 @@ data Protocol = } -- generate the *_apply.h file from parsed .bond file +apply_h :: [Protocol] -> Maybe String -> MappingContext -> String -> [Import] -> [Declaration] -> (String, Text) apply_h protocols attribute cpp file imports declarations = ("_apply.h", [lt| #pragma once @@ -41,6 +44,7 @@ apply_h protocols attribute cpp file imports declarations = ("_apply.h", [lt| semi = [lt|;|] -- Apply overloads +apply :: [Protocol] -> Text -> Text -> Declaration -> Text apply protocols attr body Struct {..} | null declParams = [lt| // // Overloads of Apply function with common transforms for #{declName}. @@ -76,8 +80,8 @@ apply protocols attr body Struct {..} | null declParams = [lt| const bond::bonded<#{declName}>& value)#{body} #{newlineSep 1 (transcoding transform) protocols}|] where - transcoding transform Protocol {protocolReader = fromReader} = [lt| - #{attr}bool Apply(const bond::#{transform} >& transform, + transcoding transform' Protocol {protocolReader = fromReader} = [lt| + #{attr}bool Apply(const bond::#{transform'} >& transform, const bond::bonded<#{declName}, bond::#{fromReader}&>& value)#{body}|] apply _ _ _ _ = mempty diff --git a/compiler/Bond/Template/Cpp/Enum_h.hs b/compiler/Bond/Template/Cpp/Enum_h.hs index 1071710f..96d91a24 100644 --- a/compiler/Bond/Template/Cpp/Enum_h.hs +++ b/compiler/Bond/Template/Cpp/Enum_h.hs @@ -5,8 +5,8 @@ module Bond.Template.Cpp.Enum_h (enum_h) where -import System.FilePath import Data.Monoid +import Data.Text.Lazy (Text) import Text.Shakespeare.Text import Bond.Schema import Bond.Template.TypeMapping @@ -14,7 +14,8 @@ import Bond.Template.Util import qualified Bond.Template.Cpp.Util as CPP -- generate the *_types.h file from parsed .bond file -enum_h cpp file imports declarations = ("_enum.h", [lt| +enum_h :: MappingContext -> String -> [Import] -> [Declaration] -> (String, Text) +enum_h cpp _file _imports declarations = ("_enum.h", [lt| #pragma once #{CPP.openNamespace cpp} diff --git a/compiler/Bond/Template/Cpp/Reflection_h.hs b/compiler/Bond/Template/Cpp/Reflection_h.hs index 638e1028..4601c877 100644 --- a/compiler/Bond/Template/Cpp/Reflection_h.hs +++ b/compiler/Bond/Template/Cpp/Reflection_h.hs @@ -7,6 +7,7 @@ module Bond.Template.Cpp.Reflection_h (reflection_h) where import System.FilePath import Data.Monoid +import Data.Text.Lazy (Text) import Text.Shakespeare.Text import Bond.Schema import Bond.Template.TypeMapping @@ -14,6 +15,7 @@ import Bond.Template.Util import qualified Bond.Template.Cpp.Util as CPP -- generate the *_refection.h file from parsed .bond file +reflection_h :: MappingContext -> String -> [Import] -> [Declaration] -> (String, Text) reflection_h cpp file imports declarations = ("_reflection.h", [lt| #pragma once diff --git a/compiler/Bond/Template/Cpp/Types_cpp.hs b/compiler/Bond/Template/Cpp/Types_cpp.hs index 4f83d67a..6398aa36 100644 --- a/compiler/Bond/Template/Cpp/Types_cpp.hs +++ b/compiler/Bond/Template/Cpp/Types_cpp.hs @@ -6,6 +6,7 @@ module Bond.Template.Cpp.Types_cpp (types_cpp) where import Data.Monoid +import Data.Text.Lazy (Text) import Text.Shakespeare.Text import Bond.Schema import Bond.Template.TypeMapping @@ -13,7 +14,8 @@ import Bond.Template.Util import qualified Bond.Template.Cpp.Util as CPP -- generate the *_types_cpp file from parsed .bond file -types_cpp cpp file imports declarations = ("_types.cpp", [lt| +types_cpp :: MappingContext -> String -> [Import] -> [Declaration] -> (String, Text) +types_cpp cpp file _imports declarations = ("_types.cpp", [lt| #include "#{file}_reflection.h" #include @@ -27,7 +29,7 @@ types_cpp cpp file imports declarations = ("_types.cpp", [lt| if null declParams then CPP.schemaMetadata cpp s else mempty -- global variables for enum name/value conversions - statics e@Enum {..} = [lt| + statics Enum {..} = [lt| namespace _bond_enumerators { namespace #{declName} diff --git a/compiler/Bond/Template/Cpp/Types_h.hs b/compiler/Bond/Template/Cpp/Types_h.hs index 3f6e0cee..c8e42b75 100644 --- a/compiler/Bond/Template/Cpp/Types_h.hs +++ b/compiler/Bond/Template/Cpp/Types_h.hs @@ -21,6 +21,10 @@ import Bond.Template.Util import qualified Bond.Template.Cpp.Util as CPP -- generate the *_types.h file from parsed .bond file +types_h :: [String] + -> Bool + -> Maybe String + -> 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} @@ -181,7 +185,7 @@ namespace std | otherwise = Nothing -- constructor initializer list from 'base' and 'fields' initializers - initializeList base fields = between colon mempty $ commaLineSep 3 id [base, fields] + initializeList base' fields = between colon mempty $ commaLineSep 3 id [base', fields] where colon = [lt| : |] @@ -237,6 +241,7 @@ namespace std allocInitValue i f d = i f d keyType (BT_Set key) = cppType key keyType (BT_Map key _) = cppType key + keyType _ = error "allocatorCtor/keyType: impossible happened." allocParameterized = L.isInfixOf (L.pack alloc) . toLazyText . cppType -- copy constructor diff --git a/compiler/Bond/Template/Cpp/Util.hs b/compiler/Bond/Template/Cpp/Util.hs index 0955591e..07d6d8ef 100644 --- a/compiler/Bond/Template/Cpp/Util.hs +++ b/compiler/Bond/Template/Cpp/Util.hs @@ -2,6 +2,7 @@ -- Licensed under the MIT license. See LICENSE file in the project root for full license information. {-# LANGUAGE QuasiQuotes, OverloadedStrings, RecordWildCards #-} +{-# OPTIONS_GHC -Wwarn #-} module Bond.Template.Cpp.Util ( openNamespace @@ -21,32 +22,41 @@ module Bond.Template.Cpp.Util import Text.Shakespeare.Text import Data.Monoid +import Data.Text.Lazy (Text) import Bond.Schema import Bond.Util import Bond.Template.Util import Bond.Template.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 @@ -54,6 +64,7 @@ attributeInit xs = [lt|boost::assign::map_list_of#{new -- 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|] @@ -62,6 +73,7 @@ modifierTag Field {..} = [lt|bond::reflection::#{modifier fieldType fieldModifie 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|] @@ -75,11 +87,15 @@ defaultValue _ _ (DefaultBool False) = "false" defaultValue _ _ (DefaultInteger x) = [lt|#{x}|] defaultValue _ _ (DefaultFloat x) = [lt|#{x}|] defaultValue _ _ (DefaultNothing) = mempty +defaultValue _ _ _ = error "defaultValue: impossible happened." +enumValue :: ToText a => MappingContext -> Type -> a -> Text enumValue cpp (BT_UserDefined e@Enum {..} _) x = [lt|#{getGlobalQualifiedName cppTypeMapping $ 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}|] @@ -101,14 +117,18 @@ schemaMetadata cpp s@Struct {..} = [lt| 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} @@ -116,4 +136,5 @@ enumDefinition Enum {..} = [lt|enum #{declName} where constant Constant {..} = [lt|#{constantName}#{optional value constantValue}|] value x = [lt| = #{x}|] +enumDefinition _ = error "enumDefinition: impossible happened." diff --git a/compiler/Bond/Template/Cs/Types_cs.hs b/compiler/Bond/Template/Cs/Types_cs.hs index 01871b64..2b8e4114 100644 --- a/compiler/Bond/Template/Cs/Types_cs.hs +++ b/compiler/Bond/Template/Cs/Types_cs.hs @@ -5,9 +5,9 @@ module Bond.Template.Cs.Types_cs (types_cs) where -import System.FilePath import Data.Monoid import Data.Foldable (foldMap) +import Data.Text.Lazy (Text) import Text.Shakespeare.Text import Bond.Schema import Bond.Util @@ -16,7 +16,8 @@ import Bond.Template.Util import qualified Bond.Template.Cs.Util as CS -- generate the *_types.cs file from parsed .bond file -types_cs readOnly useFields cs file imports declarations = ("_types.cs", [lt| +types_cs :: Bool -> Bool -> MappingContext -> String -> [Import] -> [Declaration] -> (String, Text) +types_cs readOnly useFields cs _file _imports declarations = ("_types.cs", [lt| #{CS.disableReSharperWarnings} namespace #{csNamespace} { diff --git a/compiler/Bond/Template/Cs/Util.hs b/compiler/Bond/Template/Cs/Util.hs index 77e84660..cd9da7fa 100644 --- a/compiler/Bond/Template/Cs/Util.hs +++ b/compiler/Bond/Template/Cs/Util.hs @@ -12,13 +12,16 @@ module Bond.Template.Cs.Util , disableReSharperWarnings ) where +import Data.Int (Int64) import Data.Monoid +import Data.Text.Lazy (Text) import Text.Shakespeare.Text import Bond.Version import Bond.Schema import Bond.Template.TypeMapping import Bond.Template.Util +disableReSharperWarnings :: Text disableReSharperWarnings = [lt| #region ReSharper warnings // ReSharper disable PartialTypeWithSinglePart @@ -31,6 +34,7 @@ disableReSharperWarnings = [lt| |] -- C# field/property attributes +propertyAttributes :: MappingContext -> Field -> Text propertyAttributes cs Field {..} = schemaAttributes 2 fieldAttributes <> [lt|[global::Bond.Id(#{fieldOrdinal})#{typeAttribute}#{modifierAttribute fieldType fieldModifier}]|] @@ -48,6 +52,7 @@ propertyAttributes cs Field {..} = modifierAttribute _ _ = mempty -- C# class/struct/interface attributes +typeAttributes :: MappingContext -> Declaration -> Text typeAttributes cs s@Struct {..} = optionalTypeAttributes cs s <> [lt|[global::Bond.Schema] @@ -58,9 +63,12 @@ typeAttributes cs s@Struct {..} = typeAttributes cs e@Enum {..} = optionalTypeAttributes cs e <> generatedCodeAttr +typeAttributes _ _ = error "typeAttributes: impossible happened." +generatedCodeAttr :: Text generatedCodeAttr = [lt|[System.CodeDom.Compiler.GeneratedCode("gbc", "#{majorVersion}.#{minorVersion}")]|] +optionalTypeAttributes :: MappingContext -> Declaration -> Text optionalTypeAttributes cs decl = schemaAttributes 1 (declAttributes decl) <> namespaceAttribute @@ -71,18 +79,21 @@ optionalTypeAttributes cs 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("#{getIdlQualifiedName 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}()|] @@ -107,8 +118,9 @@ defaultValue cs Field {fieldDefault = (Just def), ..} = explicitDefault def explicitDefault (DefaultInteger x) = Just [lt|#{x}|] explicitDefault (DefaultFloat x) = Just $ floatLiteral fieldType x where - floatLiteral BT_Float x = [lt|#{x}F|] - floatLiteral BT_Double x = [lt|#{x}|] + 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}"|] diff --git a/compiler/Bond/Template/CustomMapping.hs b/compiler/Bond/Template/CustomMapping.hs index ac559d79..c4b7e6f2 100644 --- a/compiler/Bond/Template/CustomMapping.hs +++ b/compiler/Bond/Template/CustomMapping.hs @@ -4,8 +4,8 @@ {-# LANGUAGE OverloadedStrings #-} module Bond.Template.CustomMapping - ( parseAliasMapping - , parseNamespaceMapping + ( parseAliasMappings + , parseNamespaceMappings , AliasMapping(..) , Fragment(..) , NamespaceMapping(..) @@ -30,19 +30,26 @@ data NamespaceMapping = NamespaceMapping , toNamespace :: QualifiedName } + +whitespace :: Parsec SourceName u String whitespace = many (char ' ') "whitespace" +identifier :: Parsec SourceName u String identifier = many1 (alphaNum <|> char '_') "identifier" +qualifiedName :: Parsec SourceName u [String] qualifiedName = sepBy1 identifier (char '.') "qualified name" +symbol :: String -> Parsec SourceName u String symbol s = whitespace *> string s <* whitespace +equal :: Parsec SourceName u String equal = symbol "=" +integer :: Parsec SourceName u Integer integer = decimal <$> many1 digit "decimal number" where decimal = foldl (\x d -> 10 * x + toInteger (digitToInt d)) 0 -- parse alias mapping specification from the command line --using flags -- e.g.: --using="OrderedSet=SortedSet<{0}>" -parseAliasMapping :: [String] -> IO [AliasMapping] -parseAliasMapping = mapM parseAliasMapping +parseAliasMappings :: [String] -> IO [AliasMapping] +parseAliasMappings = mapM parseAliasMapping where parseAliasMapping s = case parse aliasMapping s s of Left err -> fail $ show err @@ -55,8 +62,8 @@ parseAliasMapping = mapM parseAliasMapping -- parse namespace mapping specification from the command line --namespace flags -- e.g.: --namespace="bond=" -parseNamespaceMapping :: [String] -> IO [NamespaceMapping] -parseNamespaceMapping = mapM parseNamespaceMapping +parseNamespaceMappings :: [String] -> IO [NamespaceMapping] +parseNamespaceMappings = mapM parseNamespaceMapping where parseNamespaceMapping s = case parse namespaceMapping s s of Left err -> fail $ show err diff --git a/compiler/Bond/Template/TypeMapping.hs b/compiler/Bond/Template/TypeMapping.hs index 7e1156a6..2365d659 100644 --- a/compiler/Bond/Template/TypeMapping.hs +++ b/compiler/Bond/Template/TypeMapping.hs @@ -4,8 +4,7 @@ {-# LANGUAGE OverloadedStrings, RecordWildCards #-} module Bond.Template.TypeMapping - ( newMappingContext - , findAliasMapping + ( findAliasMapping , setTypeMapping , setNamespaces , cppTypeMapping @@ -22,6 +21,7 @@ module Bond.Template.TypeMapping , getDeclQualifiedTypeName , getTypeName , getInstanceTypeName + , MappingContext(..) ) where import Data.List @@ -36,7 +36,7 @@ import Bond.Util import Bond.Template.Util import Bond.Template.CustomMapping -data Context = Context +data MappingContext = MappingContext { typeMapping :: TypeMapping , aliasMapping :: [AliasMapping] , namespaceMapping :: [NamespaceMapping] @@ -53,23 +53,21 @@ data TypeMapping = TypeMapping , elementMapping :: TypeMapping } -type TypeNameBuilder = Reader Context Builder +type TypeNameBuilder = Reader MappingContext Builder -newMappingContext = Context - -setTypeMapping :: Context -> TypeMapping -> Context +setTypeMapping :: MappingContext -> TypeMapping -> MappingContext setTypeMapping c m = c { typeMapping = m } -setNamespaces :: Context -> [Namespace] -> Context +setNamespaces :: MappingContext -> [Namespace] -> MappingContext setNamespaces c n = c { namespaces = n } -getNamespace :: Context -> QualifiedName -getNamespace c@Context {..} = resolveNamespace c namespaces +getNamespace :: MappingContext -> QualifiedName +getNamespace c@MappingContext {..} = resolveNamespace c namespaces -getIdlNamespace :: Context -> QualifiedName -getIdlNamespace c@Context {..} = findNamespace c namespaces +getIdlNamespace :: MappingContext -> QualifiedName +getIdlNamespace c@MappingContext {..} = findNamespace c namespaces -getDeclNamespace :: Context -> Declaration -> QualifiedName +getDeclNamespace :: MappingContext -> Declaration -> QualifiedName getDeclNamespace c = resolveNamespace c . declNamespaces getQualifiedName :: TypeMapping -> QualifiedName -> Builder @@ -81,18 +79,19 @@ getIdlQualifiedName = sep "." getGlobalQualifiedName :: TypeMapping -> QualifiedName -> Builder getGlobalQualifiedName m@TypeMapping {..} = (global <>) . getQualifiedName m -getDeclQualifiedTypeName :: Context -> Declaration -> Builder +getDeclQualifiedTypeName :: MappingContext -> Declaration -> Builder getDeclQualifiedTypeName c = getGlobalQualifiedName (typeMapping c) . declQualifiedName c -getTypeName :: Context -> Type -> Builder -getTypeName c t = fix $ runReader (typeName t) c +getTypeName :: MappingContext -> Type -> Builder +getTypeName c t = fix' $ runReader (typeName t) c where - fix = fixSyntax $ typeMapping c + fix' = fixSyntax $ typeMapping c -getInstanceTypeName :: Context -> Type -> Builder +getInstanceTypeName :: MappingContext -> Type -> Builder getInstanceTypeName c t = runReader (instanceTypeName t) c -- type mappings for different languages/variants +cppTypeMapping :: TypeMapping cppTypeMapping = TypeMapping Cpp "::" @@ -102,6 +101,7 @@ cppTypeMapping = TypeMapping cppTypeMapping cppTypeMapping +cppCustomAllocTypeMapping :: ToText a => a -> TypeMapping cppCustomAllocTypeMapping alloc = TypeMapping Cpp "::" @@ -111,6 +111,7 @@ cppCustomAllocTypeMapping alloc = TypeMapping (cppCustomAllocTypeMapping alloc) (cppCustomAllocTypeMapping alloc) +csTypeMapping :: TypeMapping csTypeMapping = TypeMapping Cs "global::" @@ -120,6 +121,7 @@ csTypeMapping = TypeMapping csTypeMapping csTypeMapping +csInterfaceTypeMapping :: TypeMapping csInterfaceTypeMapping = TypeMapping Cs "global::" @@ -129,8 +131,10 @@ csInterfaceTypeMapping = TypeMapping csInterfaceInstanceTypeMapping csInterfaceTypeMapping +csInterfaceInstanceTypeMapping :: TypeMapping csInterfaceInstanceTypeMapping = csInterfaceTypeMapping {mapType = csType} +csAnnotatedTypeMapping :: TypeMapping csAnnotatedTypeMapping = TypeMapping Cs "global::" @@ -158,6 +162,7 @@ infixr 6 <<> 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 @@ -176,16 +181,17 @@ elementTypeName = localWith elementMapping . typeName instanceTypeName :: Type -> TypeNameBuilder instanceTypeName = localWith instanceMapping . typeName -resolveNamespace :: Context -> [Namespace] -> QualifiedName -resolveNamespace c@Context {..} ns = maybe namespace toNamespace $ find ((namespace ==) . fromNamespace) namespaceMapping +resolveNamespace :: MappingContext -> [Namespace] -> QualifiedName +resolveNamespace c@MappingContext {..} ns = maybe namespace toNamespace $ find ((namespace ==) . fromNamespace) namespaceMapping where namespace = findNamespace c ns -- last namespace that is language-neutral or matches the language of the context's type mapping -findNamespace Context {..} ns = +findNamespace :: MappingContext -> [Namespace] -> QualifiedName +findNamespace MappingContext {..} ns = nsName . last . filter (maybe True (language typeMapping ==) . nsLanguage) $ ns -declQualifiedName :: Context -> Declaration -> QualifiedName +declQualifiedName :: MappingContext -> Declaration -> QualifiedName declQualifiedName c decl = getDeclNamespace c decl ++ [declName decl] declQualifiedTypeName :: Declaration -> TypeNameBuilder @@ -200,7 +206,7 @@ declTypeName decl = do then pureText $ declName decl else declQualifiedTypeName decl -findAliasMapping :: Context -> Declaration -> Maybe AliasMapping +findAliasMapping :: MappingContext -> Declaration -> Maybe AliasMapping findAliasMapping ctx a = find isSameAlias $ aliasMapping ctx where aliasDeclName = declQualifiedName ctx a @@ -248,23 +254,27 @@ 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) | structType element = "bond::nullable<" <>> elementTypeName element <<> ", " <> alloc <> ">" -cppTypeCustomAlloc alloc (BT_Nullable element) = "bond::nullable<" <>> elementTypeName element <<> ">" +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" diff --git a/compiler/Bond/Template/Util.hs b/compiler/Bond/Template/Util.hs index 98e93196..6c73aab7 100644 --- a/compiler/Bond/Template/Util.hs +++ b/compiler/Bond/Template/Util.hs @@ -2,6 +2,7 @@ -- Licensed under the MIT license. See LICENSE file in the project root for full license information. {-# LANGUAGE QuasiQuotes, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Bond.Template.Util ( toText @@ -21,16 +22,14 @@ module Bond.Template.Util , doubleLineSepEnd ) where -import System.FilePath +import Data.Int (Int64) import Data.Monoid import Data.Word -import Data.String -import Data.Text.Lazy (justifyRight) +import Data.Text.Lazy (Text, justifyRight) import Data.Text.Lazy.Builder import Text.Shakespeare.Text import Bond.Version import Bond.Util -import Bond.Schema instance ToText Word16 where toText = toText . show @@ -41,27 +40,36 @@ instance ToText Double where instance ToText Integer where toText = toText . show +mconcatMap :: Monoid b => (a -> b) -> [a] -> b mconcatMap f = foldr (mappend . f) mempty +mconcatFor :: Monoid b => [a] -> (a -> b) -> b mconcatFor m f = mconcatMap f m +sep :: ToText t => Builder -> [t] -> Builder sep s = sepBy s toText commaSep :: ToText t => [t] -> Builder commaSep = sepBy ", " toText +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 -> (t -> Text) -> [t] -> Text newlineSep = sepBy . newLine commaLineSep = sepBy . commaLine newlineSepEnd = sepEndBy . newLine @@ -69,6 +77,7 @@ newlineBeginSep = sepBeginBy . newLine doubleLineSep = sepBy . doubleLine doubleLineSepEnd = sepEndBy . doubleLine +commonHeader :: ToText a => a -> Text commonHeader file = [lt| //------------------------------------------------------------------------------ // This code was generated by a tool. diff --git a/compiler/Bond/Util.hs b/compiler/Bond/Util.hs index d48e4e24..bee51bc8 100644 --- a/compiler/Bond/Util.hs +++ b/compiler/Bond/Util.hs @@ -16,8 +16,11 @@ module Bond.Util ) where import Data.Monoid +import Data.String (IsString) -sepEndBy s f [] = mempty +sepEndBy :: (Monoid a, Eq a) + => a -> (t -> a) -> [t] -> a +sepEndBy _ _ [] = mempty sepEndBy s f (x:xs) | next == mempty = rest | otherwise = next <> s <> rest @@ -25,7 +28,9 @@ sepEndBy s f (x:xs) next = f x rest = sepEndBy s f xs -sepBeginBy s f [] = mempty +sepBeginBy :: (Monoid a, Eq a) + => a -> (t -> a) -> [t] -> a +sepBeginBy _ _ [] = mempty sepBeginBy s f (x:xs) | next == mempty = rest | otherwise = s <> next <> rest @@ -33,7 +38,9 @@ sepBeginBy s f (x:xs) next = f x rest = sepBeginBy s f xs -sepBy s f [] = mempty +sepBy :: (Monoid a, Eq a) + => a -> (t -> a) -> [t] -> a +sepBy _ _ [] = mempty sepBy s f (x:xs) | null xs = next | next == mempty = rest @@ -45,10 +52,14 @@ sepBy s f (x:xs) optional :: (Monoid m) => (a -> m) -> Maybe a -> m optional = maybe 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 angles m = between "<" ">" m brackets m = between "[" "]" m braces m = between "{" "}" m diff --git a/compiler/Bond/Version.hs b/compiler/Bond/Version.hs index ad28c9de..66afbf7a 100644 --- a/compiler/Bond/Version.hs +++ b/compiler/Bond/Version.hs @@ -6,5 +6,7 @@ module Bond.Version , minorVersion ) where +majorVersion :: String majorVersion = "3" +minorVersion :: String minorVersion = "02" diff --git a/compiler/Main.hs b/compiler/Main.hs index 1af33973..e926cb61 100644 --- a/compiler/Main.hs +++ b/compiler/Main.hs @@ -15,8 +15,10 @@ import Control.Monad.Reader import Control.Monad.Loops (firstM) import Control.Concurrent.Async import GHC.Conc (getNumProcessors, setNumCapabilities) +import Data.Text.Lazy (Text) import qualified Data.Text.Lazy.IO as L import Bond.Parser +import Bond.Schema (Declaration, Import) import Bond.Template.Util import Bond.Template.Cpp.Reflection_h import Bond.Template.Cpp.Types_h @@ -39,6 +41,7 @@ main = do Cs {..} -> csCodegen options _ -> print options +setJobs :: Maybe Int -> IO () setJobs Nothing = return () setJobs (Just n) | n > 0 = setNumCapabilities n @@ -46,16 +49,17 @@ setJobs (Just n) numProc <- getNumProcessors setNumCapabilities $ max 1 (numProc + n) +concurrentlyFor_ :: [a] -> (a -> IO b) -> IO () concurrentlyFor_ = (void .) . flip mapConcurrently cppCodegen :: Options -> IO() cppCodegen (Cpp {..}) = do - aliasMapping <- parseAliasMapping using - namespaceMapping <- parseNamespaceMapping namespace + aliasMapping <- parseAliasMappings using + namespaceMapping <- parseNamespaceMappings namespace let typeMapping = case allocator of Nothing -> cppTypeMapping Just a -> cppCustomAllocTypeMapping a - let mappingContext = newMappingContext typeMapping aliasMapping namespaceMapping [] + let mappingContext = MappingContext typeMapping aliasMapping namespaceMapping [] concurrentlyFor_ files $ codeGen output_dir import_dir mappingContext $ [ reflection_h , types_cpp @@ -72,19 +76,27 @@ cppCodegen (Cpp {..}) = do , (Fast, Protocol "FastBinaryReader" "FastBinaryWriter") , (Simple, Protocol "SimpleBinaryReader" "SimpleBinaryWriter") ] +cppCodegen _ = error "cppCodegen: impossible happened." csCodegen :: Options -> IO() csCodegen (Cs {..}) = do - aliasMapping <- parseAliasMapping using - namespaceMapping <- parseNamespaceMapping namespace + aliasMapping <- parseAliasMappings using + namespaceMapping <- parseNamespaceMappings namespace let typeMapping = if collection_interfaces then csInterfaceTypeMapping else csTypeMapping - let mappingContext = newMappingContext typeMapping aliasMapping namespaceMapping [] + let mappingContext = MappingContext typeMapping aliasMapping namespaceMapping [] concurrentlyFor_ files $ codeGen output_dir import_dir mappingContext [ types_cs readonly_properties fields ] +csCodegen _ = error "csCodegen: impossible happened." +codeGen :: FilePath + -> [FilePath] + -> MappingContext + -> [MappingContext -> String -> [Import] -> [Declaration] -> (String, Text)] + -> FilePath + -> IO () codeGen outputDir importDirs mappingContext templates file = do cwd <- getCurrentDirectory input <- readFileUtf8 file diff --git a/compiler/Options.hs b/compiler/Options.hs index 32715195..6e90d54e 100644 --- a/compiler/Options.hs +++ b/compiler/Options.hs @@ -9,7 +9,6 @@ module Options (getOptions, Options(..), ApplyOptions(..)) where import Bond.Version import System.Console.CmdArgs -import System.Console.CmdArgs.Explicit (Mode(..)) data ApplyOptions = Compact | @@ -45,6 +44,7 @@ data Options } deriving (Show, Data, Typeable) +cpp :: Options cpp = Cpp { files = def &= typFile &= args , import_dir = def &= typDir &= help "Add the directory to import search path" @@ -61,6 +61,7 @@ cpp = Cpp name "c++" &= help "Generate C++ code" +cs :: Options cs = Cs { collection_interfaces = def &= help "Use interfaces rather than concrete collection types" , readonly_properties = def &= help "Generate private property setters" @@ -69,9 +70,11 @@ cs = Cs name "c#" &= help "Generate C# code" +mode :: Mode (CmdArgs Options) mode = cmdArgsMode $ modes [cpp, cs] &= program "gbc" &= help "Compile Bond schema definition file and generate specified output" &= summary ("Bond Compiler " ++ majorVersion ++ "." ++ minorVersion ++ ", (C) Microsoft") +getOptions :: IO Options getOptions = cmdArgsRun mode