diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/gen/TestProto.hs b/gen/TestProto.hs --- a/gen/TestProto.hs +++ b/gen/TestProto.hs @@ -9,6 +9,7 @@ {-# OPTIONS_GHC -fno-warn-unused-matches #-} -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! + module TestProto where import qualified Prelude as Hs import qualified Proto3.Suite.Class as HsProtobuf diff --git a/gen/TestProtoImport.hs b/gen/TestProtoImport.hs --- a/gen/TestProtoImport.hs +++ b/gen/TestProtoImport.hs @@ -9,6 +9,7 @@ {-# OPTIONS_GHC -fno-warn-unused-matches #-} -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! + module TestProtoImport where import qualified Prelude as Hs import qualified Proto3.Suite.Class as HsProtobuf diff --git a/gen/TestProtoOneof.hs b/gen/TestProtoOneof.hs --- a/gen/TestProtoOneof.hs +++ b/gen/TestProtoOneof.hs @@ -9,6 +9,7 @@ {-# OPTIONS_GHC -fno-warn-unused-matches #-} -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! + module TestProtoOneof where import qualified Prelude as Hs import qualified Proto3.Suite.Class as HsProtobuf diff --git a/gen/TestProtoOneofImport.hs b/gen/TestProtoOneofImport.hs --- a/gen/TestProtoOneofImport.hs +++ b/gen/TestProtoOneofImport.hs @@ -9,6 +9,7 @@ {-# OPTIONS_GHC -fno-warn-unused-matches #-} -- | Generated by Haskell protocol buffer compiler. DO NOT EDIT! + module TestProtoOneofImport where import qualified Prelude as Hs import qualified Proto3.Suite.Class as HsProtobuf diff --git a/proto3-suite.cabal b/proto3-suite.cabal --- a/proto3-suite.cabal +++ b/proto3-suite.cabal @@ -1,5 +1,5 @@ name: proto3-suite -version: 0.4.0.2 +version: 0.4.1 synopsis: A low level library for writing out data in the Protocol Buffers wire format license: Apache-2.0 author: Awake Security @@ -7,7 +7,7 @@ copyright: 2017-2018 Awake Security category: Codec build-type: Simple -cabal-version: >=1.10 +cabal-version: 2.0 data-files: test-files/*.bin tests/encode.sh tests/decode.sh Flag dhall @@ -15,14 +15,23 @@ Default: False Manual: True +Flag swagger + Description: Turn on Swagger doc generation. + Default: True + Manual: True + library if flag(dhall) exposed-modules: Proto3.Suite.DhallPB build-depends: dhall >=1.13 && < 1.34 - cpp-options: -DDHALL + if flag(swagger) + exposed-modules: Proto3.Suite.DotProto.Generate.Swagger + build-depends: swagger2 >=2.1.6 && <2.7 + cpp-options: -DSWAGGER + exposed-modules: Proto3.Suite Proto3.Suite.Class Proto3.Suite.DotProto @@ -35,14 +44,14 @@ Proto3.Suite.Tutorial Proto3.Suite.Types - other-modules: Proto3.Suite.DotProto.Internal - Proto3.Suite.DotProto.Generate.Swagger + Proto3.Suite.DotProto.Internal Proto3.Suite.JSONPB.Class - build-depends: aeson >= 1.1.1.0 && < 1.5, + + build-depends: aeson >= 1.1.1.0 && < 1.6, aeson-pretty, attoparsec >= 0.13.0.1, base >=4.8 && <5.0, - base64-bytestring >= 1.0.0.1 && < 1.1, + base64-bytestring >= 1.0.0.1 && < 1.2, binary >=0.8.3, bytestring >=0.10.6.0 && <0.11.0, deepseq ==1.4.*, @@ -62,10 +71,9 @@ pretty ==1.1.*, pretty-show >= 1.6.12 && < 2.0, proto3-wire == 1.2.*, - QuickCheck >=2.10 && <2.14, + QuickCheck >=2.10 && <2.15, quickcheck-instances < 0.4, safe ==0.3.*, - swagger2 >=2.1.6 && <2.7, system-filepath, text >= 0.2 && <1.3, transformers >=0.4 && <0.6, @@ -86,9 +94,13 @@ build-depends: dhall >=1.13 && < 1.34 cpp-options: -DDHALL + if flag(swagger) + build-depends: swagger2 + cpp-options: -DSWAGGER + other-modules: ArbitraryGeneratedTestTypes - TestProto TestCodeGen + TestProto TestProtoImport TestProtoOneof TestProtoOneofImport @@ -96,11 +108,11 @@ hs-source-dirs: tests gen default-language: Haskell2010 build-depends: base >=4.8 && <5.0, - QuickCheck >=2.10 && <2.14, - aeson >= 1.1.1.0 && < 1.5, + QuickCheck >=2.10 && <2.15, + aeson >= 1.1.1.0 && < 1.6, attoparsec >= 0.13.0.1, base >=4.8 && <5.0, - base64-bytestring >= 1.0.0.1 && < 1.1, + base64-bytestring >= 1.0.0.1 && < 1.2, bytestring >=0.10.6.0 && <0.11.0, cereal >= 0.5.1 && <0.6, containers >=0.5 && < 0.7, @@ -111,7 +123,6 @@ pretty-show >= 1.6.12 && < 2.0, proto3-suite, proto3-wire == 1.2.*, - swagger2, tasty >= 0.11 && <1.3, tasty-hunit >= 0.9 && <0.11, tasty-quickcheck >= 0.8.4 && <0.11, diff --git a/src/Proto3/Suite/DotProto/Generate.hs b/src/Proto3/Suite/DotProto/Generate.hs --- a/src/Proto3/Suite/DotProto/Generate.hs +++ b/src/Proto3/Suite/DotProto/Generate.hs @@ -24,7 +24,6 @@ ( CompileError(..) , TypeContext , CompileArgs(..) - , UseLegacyTypes(..) , compileDotProtoFile , compileDotProtoFileOrDie , hsModuleForDotProto @@ -73,69 +72,8 @@ , extraInstanceFiles :: [FilePath] , inputProto :: FilePath , outputDir :: FilePath - , useLegacyTypes :: UseLegacyTypes } -{-| -Used as a compiler arg that determines whether or not to use the legacy -behavior for handling protocol buffer Wrapper messages. These Wrapper -messages can be found in @test-files/google/protobuf/wrappers.proto@ -(path is relative to root). - -Example @.proto@ file: -@ -syntax = "proto3"; -package example; -import "google/protobuf/wrappers.proto"; - -message Test { - google.protobuf.Int32Value x = 1; - google.protobuf.BytesValue y = 2; -} - -... -@ - -From the @.proto@ file above, the legacy behavior -generates the corresponding @Example.hs@ file: -@ -... - -module Example where - -... - -import qualified Google.Protobuf.Wrappers - -data Test = Test - { testX :: Maybe Google.Protobuf.Wrappers.Int32Value - , testY :: Maybe Google.Protobuf.Wrappers.BytesValue - } deriving (...) - -... -@ - -The new behavior generates: -@ -... - -module Example where - -... - -import qualified Google.Protobuf.Wrappers - -data Test = Test - { testX :: Maybe Int32 - , testY :: Maybe ByteString - } deriving (...) - -... -@ --} -data UseLegacyTypes = YesLegacy | NoLegacy - deriving (Eq, Show) - -- | Generate a Haskell module corresponding to a @.proto@ file compileDotProtoFile :: CompileArgs -> IO (Either CompileError ()) compileDotProtoFile CompileArgs{..} = runExceptT $ do @@ -150,7 +88,7 @@ extraInstances <- foldMapM getExtraInstances extraInstanceFiles - haskellModule <- renderHsModuleForDotProto useLegacyTypes extraInstances dotProto importTypeContext + haskellModule <- renderHsModuleForDotProto extraInstances dotProto importTypeContext liftIO (writeFile (FP.encodeString modulePath) haskellModule) @@ -174,10 +112,10 @@ -- messages and enums. renderHsModuleForDotProto :: MonadError CompileError m - => UseLegacyTypes -> ([HsImportDecl],[HsDecl]) -> DotProto -> TypeContext -> m String -renderHsModuleForDotProto useLegacyTypes extraInstanceFiles dotProto importCtxt = do - haskellModule <- hsModuleForDotProto useLegacyTypes extraInstanceFiles dotProto importCtxt - return (T.unpack header ++ prettyPrint haskellModule) + => ([HsImportDecl],[HsDecl]) -> DotProto -> TypeContext -> m String +renderHsModuleForDotProto extraInstanceFiles dotProto importCtxt = do + haskellModule <- hsModuleForDotProto extraInstanceFiles dotProto importCtxt + return (T.unpack header ++ "\n" ++ prettyPrint haskellModule) where header = [Neat.text| {-# LANGUAGE DeriveGeneric #-} @@ -197,8 +135,7 @@ -- Instances given in @eis@ override those otherwise generated. hsModuleForDotProto :: MonadError CompileError m - => UseLegacyTypes - -> ([HsImportDecl], [HsDecl]) + => ([HsImportDecl], [HsDecl]) -- ^ Extra user-define instances that override default generated instances -> DotProto -- ^ @@ -206,7 +143,6 @@ -- ^ -> m HsModule hsModuleForDotProto - useLegacyTypes (extraImports, extraInstances) dotProto@DotProto{ protoMeta = DotProtoMeta { metaModulePath = modulePath } , protoPackage @@ -226,7 +162,7 @@ typeContext <- dotProtoTypeContext dotProto let toDotProtoDeclaration = - dotProtoDefinitionD useLegacyTypes packageIdentifier (typeContext <> importTypeContext) + dotProtoDefinitionD packageIdentifier (typeContext <> importTypeContext) let extraInstances' = instancesForModule moduleName extraInstances @@ -285,6 +221,11 @@ let (uncustomized, customized) = partitionEithers (map (deriv tyn) insts) in HsDataDecl loc ctx tyn names def uncustomized : customized + -- instances listed in "deriving" clause of newtype definition: + mbReplace (HsNewTypeDecl loc ctx tyn names def insts) = + let (uncustomized, customized) = partitionEithers (map (deriv tyn) insts) + in HsNewTypeDecl loc ctx tyn names def uncustomized : customized + -- irrelevant declarations remain unchanged: mbReplace hid = [hid] @@ -439,15 +380,15 @@ coerceF | unsafe = HsVar (haskellName "unsafeCoerce") | otherwise = HsVar (haskellName "coerce") -wrapE :: MonadError CompileError m => UseLegacyTypes -> TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp -wrapE useLegacyTypes ctxt opts dpt e = maybe e (\f -> apply f [e]) <$> - (coerceE (isMap dpt) <$> dptToHsType useLegacyTypes ctxt dpt <*> dptToHsTypeWrapped useLegacyTypes opts ctxt dpt) +wrapE :: MonadError CompileError m => TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp +wrapE ctxt opts dpt e = maybe e (\f -> apply f [e]) <$> + (coerceE (isMap dpt) <$> dptToHsType ctxt dpt <*> dptToHsTypeWrapped opts ctxt dpt) -unwrapE :: MonadError CompileError m => UseLegacyTypes -> TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp -unwrapE useLegacyTypes ctxt opts dpt e = maybe e (\f -> apply f [e]) <$> +unwrapE :: MonadError CompileError m => TypeContext -> [DotProtoOption] -> DotProtoType -> HsExp -> m HsExp +unwrapE ctxt opts dpt e = maybe e (\f -> apply f [e]) <$> (coerceE (isMap dpt) <$> - overParser (dptToHsTypeWrapped useLegacyTypes opts ctxt dpt) <*> - overParser (dptToHsType useLegacyTypes ctxt dpt)) + overParser (dptToHsTypeWrapped opts ctxt dpt) <*> + overParser (dptToHsType ctxt dpt)) where overParser = fmap $ HsTyApp (HsTyVar (HsIdent "_")) @@ -458,21 +399,18 @@ -- -- | Convert a dot proto type to a Haskell type -dptToHsType :: MonadError CompileError m => UseLegacyTypes -> TypeContext -> DotProtoType -> m HsType -dptToHsType useLegacyTypes = foldDPT dptToHsContType $ dpptToHsType useLegacyTypes +dptToHsType :: MonadError CompileError m => TypeContext -> DotProtoType -> m HsType +dptToHsType = foldDPT dptToHsContType dpptToHsType -- | Convert a dot proto type to a wrapped Haskell type -dptToHsTypeWrapped :: MonadError CompileError m => UseLegacyTypes -> [DotProtoOption] -> TypeContext -> DotProtoType -> m HsType -dptToHsTypeWrapped useLegacyTypes opts = +dptToHsTypeWrapped :: MonadError CompileError m => [DotProtoOption] -> TypeContext -> DotProtoType -> m HsType +dptToHsTypeWrapped opts = foldDPT -- The wrapper for the collection type replaces the native haskell -- collection type, so try that first. (\ctxt ty -> maybe (dptToHsContType ctxt ty) id (dptToHsWrappedContType ctxt opts ty)) -- Always wrap the primitive type. - (\ctxt ty -> case useLegacyTypes of - YesLegacy -> dpptToHsTypeWrapper ty <$> (dpptToHsType useLegacyTypes) ctxt ty - NoLegacy -> dpptToHsTypeWrapper ty <$> dpptToHsType' ctxt ty - ) + (\ctxt ty -> dpptToHsTypeWrapper ty <$> dpptToHsType' ctxt ty) where dpptToHsType' :: MonadError CompileError m => TypeContext @@ -570,11 +508,10 @@ -- | Convert a dot proto prim type to an unwrapped Haskell type dpptToHsType :: MonadError CompileError m - => UseLegacyTypes - -> TypeContext + => TypeContext -> DotProtoPrimType -> m HsType -dpptToHsType useLegacyTypes ctxt = \case +dpptToHsType ctxt = \case Int32 -> pure $ primType_ "Int32" Int64 -> pure $ primType_ "Int64" SInt32 -> pure $ primType_ "Int32" @@ -591,15 +528,15 @@ Float -> pure $ primType_ "Float" Double -> pure $ primType_ "Double" Named (Dots (Path ("google" :| ["protobuf", x]))) - | x == "Int32Value" && useLegacyTypes == NoLegacy -> pure $ primType_ "Int32" - | x == "Int64Value" && useLegacyTypes == NoLegacy -> pure $ primType_ "Int64" - | x == "UInt32Value" && useLegacyTypes == NoLegacy -> pure $ primType_ "Word32" - | x == "UInt64Value" && useLegacyTypes == NoLegacy -> pure $ primType_ "Word64" - | x == "StringValue" && useLegacyTypes == NoLegacy -> pure $ primType_ "Text" - | x == "BytesValue" && useLegacyTypes == NoLegacy -> pure $ primType_ "ByteString" - | x == "BoolValue" && useLegacyTypes == NoLegacy -> pure $ primType_ "Bool" - | x == "FloatValue" && useLegacyTypes == NoLegacy -> pure $ primType_ "Float" - | x == "DoubleValue" && useLegacyTypes == NoLegacy -> pure $ primType_ "Double" + | x == "Int32Value" -> pure $ primType_ "Int32" + | x == "Int64Value" -> pure $ primType_ "Int64" + | x == "UInt32Value" -> pure $ primType_ "Word32" + | x == "UInt64Value" -> pure $ primType_ "Word64" + | x == "StringValue" -> pure $ primType_ "Text" + | x == "BytesValue" -> pure $ primType_ "ByteString" + | x == "BoolValue" -> pure $ primType_ "Bool" + | x == "FloatValue" -> pure $ primType_ "Float" + | x == "DoubleValue" -> pure $ primType_ "Double" Named msgName -> case M.lookup msgName ctxt of Just ty@(DotProtoTypeInfo { dotProtoTypeInfoKind = DotProtoKindEnum }) -> @@ -621,16 +558,16 @@ -- ** Generate instances for a 'DotProto' package dotProtoDefinitionD :: MonadError CompileError m - => UseLegacyTypes -> DotProtoIdentifier -> TypeContext -> DotProtoDefinition -> m [HsDecl] -dotProtoDefinitionD useLegacyTypes pkgIdent ctxt = \case + => DotProtoIdentifier -> TypeContext -> DotProtoDefinition -> m [HsDecl] +dotProtoDefinitionD pkgIdent ctxt = \case DotProtoMessage _ messageName messageParts -> - dotProtoMessageD useLegacyTypes ctxt Anonymous messageName messageParts + dotProtoMessageD ctxt Anonymous messageName messageParts DotProtoEnum _ enumName enumParts -> - dotProtoEnumD useLegacyTypes Anonymous enumName enumParts + dotProtoEnumD Anonymous enumName enumParts DotProtoService _ serviceName serviceParts -> - dotProtoServiceD useLegacyTypes pkgIdent ctxt serviceName serviceParts + dotProtoServiceD pkgIdent ctxt serviceName serviceParts -- | Generate 'Named' instance for a type in this package namedInstD :: String -> HsDecl @@ -657,17 +594,16 @@ dotProtoMessageD :: forall m . MonadError CompileError m - => UseLegacyTypes - -> TypeContext + => TypeContext -> DotProtoIdentifier -> DotProtoIdentifier -> [DotProtoMessagePart] -> m [HsDecl] -dotProtoMessageD useLegacyTypes ctxt parentIdent messageIdent messageParts = do +dotProtoMessageD ctxt parentIdent messageIdent messageParts = do messageName <- qualifiedMessageName parentIdent messageIdent let mkDataDecl flds = - (dataDecl_ useLegacyTypes) messageName + dataDecl_ messageName [ recDecl_ (HsIdent messageName) flds ] defaultMessageDeriving @@ -678,10 +614,10 @@ foldMapM id [ sequence - [ mkDataDecl <$> foldMapM (messagePartFieldD useLegacyTypes messageName) messageParts + [ mkDataDecl <$> foldMapM (messagePartFieldD messageName) messageParts , pure (namedInstD messageName) , pure (hasDefaultInstD messageName) - , messageInstD useLegacyTypes ctxt' parentIdent messageIdent messageParts + , messageInstD ctxt' parentIdent messageIdent messageParts , toJSONPBMessageInstD ctxt' parentIdent messageIdent messageParts , fromJSONPBMessageInstD ctxt' parentIdent messageIdent messageParts @@ -690,9 +626,11 @@ , pure (toJSONInstDecl messageName) , pure (fromJSONInstDecl messageName) +#ifdef SWAGGER -- And the Swagger ToSchema instance corresponding to JSONPB encodings , toSchemaInstanceDeclaration messageName Nothing =<< foldMapM (traverse dpIdentUnqualName . getName) messageParts +#endif #ifdef DHALL -- Generate Dhall instances @@ -703,11 +641,11 @@ -- Nested regular and oneof message decls , foldMapOfM (traverse . _DotProtoMessageDefinition) - (nestedDecls useLegacyTypes) + nestedDecls messageParts , foldMapOfM (traverse . _DotProtoMessageOneOf) - (uncurry $ nestedOneOfDecls useLegacyTypes messageName) + (uncurry $ nestedOneOfDecls messageName) messageParts ] @@ -716,43 +654,47 @@ ctxt' = maybe mempty dotProtoTypeChildContext (M.lookup messageIdent ctxt) <> ctxt - messagePartFieldD :: UseLegacyTypes -> String -> DotProtoMessagePart -> m [([HsName], HsBangType)] - messagePartFieldD useLegacyTypes' messageName (DotProtoMessageField DotProtoField{..}) = do + messagePartFieldD :: String -> DotProtoMessagePart -> m [([HsName], HsBangType)] + messagePartFieldD messageName (DotProtoMessageField DotProtoField{..}) = do fullName <- prefixedFieldName messageName =<< dpIdentUnqualName dotProtoFieldName - fullTy <- dptToHsType useLegacyTypes' ctxt' dotProtoFieldType + fullTy <- dptToHsType ctxt' dotProtoFieldType pure [ ([HsIdent fullName], HsUnBangedTy fullTy ) ] - messagePartFieldD _ messageName (DotProtoMessageOneOf fieldName _) = do + messagePartFieldD messageName (DotProtoMessageOneOf fieldName _) = do fullName <- prefixedFieldName messageName =<< dpIdentUnqualName fieldName qualTyName <- prefixedConName messageName =<< dpIdentUnqualName fieldName let fullTy = HsTyApp (HsTyCon (haskellName "Maybe")) . type_ $ qualTyName pure [ ([HsIdent fullName], HsUnBangedTy fullTy) ] - messagePartFieldD _ _ _ = pure [] + messagePartFieldD _ _ = pure [] - nestedDecls :: UseLegacyTypes -> DotProtoDefinition -> m [HsDecl] - nestedDecls useLegacyTypes' (DotProtoMessage _ subMsgName subMessageDef) = do + nestedDecls :: DotProtoDefinition -> m [HsDecl] + nestedDecls (DotProtoMessage _ subMsgName subMessageDef) = do parentIdent' <- concatDotProtoIdentifier parentIdent messageIdent - dotProtoMessageD useLegacyTypes' ctxt' parentIdent' subMsgName subMessageDef + dotProtoMessageD ctxt' parentIdent' subMsgName subMessageDef - nestedDecls useLegacyTypes' (DotProtoEnum _ subEnumName subEnumDef) = do + nestedDecls (DotProtoEnum _ subEnumName subEnumDef) = do parentIdent' <- concatDotProtoIdentifier parentIdent messageIdent - dotProtoEnumD useLegacyTypes' parentIdent' subEnumName subEnumDef + dotProtoEnumD parentIdent' subEnumName subEnumDef - nestedDecls _ _ = pure [] + nestedDecls _ = pure [] - nestedOneOfDecls :: UseLegacyTypes -> String -> DotProtoIdentifier -> [DotProtoField] -> m [HsDecl] - nestedOneOfDecls useLegacyTypes' messageName identifier fields = do + nestedOneOfDecls :: String -> DotProtoIdentifier -> [DotProtoField] -> m [HsDecl] + nestedOneOfDecls messageName identifier fields = do fullName <- prefixedConName messageName =<< dpIdentUnqualName identifier - (cons, idents) <- fmap unzip (mapM (oneOfCons useLegacyTypes' fullName) fields) + (cons, idents) <- fmap unzip (mapM (oneOfCons fullName) fields) +#ifdef SWAGGER toSchemaInstance <- toSchemaInstanceDeclaration fullName (Just idents) =<< mapM (dpIdentUnqualName . dotProtoFieldName) fields +#endif - pure [ (dataDecl_ useLegacyTypes') fullName cons defaultMessageDeriving + pure [ dataDecl_ fullName cons defaultMessageDeriving , namedInstD fullName +#ifdef SWAGGER , toSchemaInstance +#endif #ifdef DHALL , dhallInterpretInstDecl fullName @@ -760,37 +702,36 @@ #endif ] - oneOfCons :: UseLegacyTypes -> String -> DotProtoField -> m (HsConDecl, HsName) - oneOfCons useLegacyTypes' fullName DotProtoField{..} = do + oneOfCons :: String -> DotProtoField -> m (HsConDecl, HsName) + oneOfCons fullName DotProtoField{..} = do consTy <- case dotProtoFieldType of Prim msg@(Named msgName) | isMessage ctxt' msgName - -> (dpptToHsType useLegacyTypes') ctxt' msg - _ -> dptToHsType useLegacyTypes' ctxt' dotProtoFieldType + -> dpptToHsType ctxt' msg + _ -> dptToHsType ctxt' dotProtoFieldType consName <- prefixedConName fullName =<< dpIdentUnqualName dotProtoFieldName let ident = HsIdent consName pure (conDecl_ ident [HsUnBangedTy consTy], ident) - oneOfCons _ _ DotProtoEmptyField = internalError "field type : empty field" + oneOfCons _ DotProtoEmptyField = internalError "field type : empty field" -- *** Generate Protobuf 'Message' instances messageInstD :: forall m . MonadError CompileError m - => UseLegacyTypes - -> TypeContext + => TypeContext -> DotProtoIdentifier -> DotProtoIdentifier -> [DotProtoMessagePart] -> m HsDecl -messageInstD useLegacyTypes ctxt parentIdent msgIdent messageParts = do +messageInstD ctxt parentIdent msgIdent messageParts = do msgName <- qualifiedMessageName parentIdent msgIdent qualifiedFields <- getQualifiedFields msgName messageParts - encodedFields <- mapM (encodeMessageField useLegacyTypes) qualifiedFields - decodedFields <- mapM (decodeMessageField useLegacyTypes) qualifiedFields + encodedFields <- mapM encodeMessageField qualifiedFields + decodedFields <- mapM decodeMessageField qualifiedFields let encodeMessageDecl = match_ (HsIdent "encodeMessage") [HsPWildCard, HsPRec (unqual_ msgName) punnedFieldsP] @@ -830,12 +771,12 @@ , HsFunBind [ dotProtoDecl ] ] where - encodeMessageField :: UseLegacyTypes -> QualifiedField -> m HsExp - encodeMessageField useLegacyTypes' QualifiedField{recordFieldName, fieldInfo} = + encodeMessageField :: QualifiedField -> m HsExp + encodeMessageField QualifiedField{recordFieldName, fieldInfo} = let recordFieldName' = uvar_ (coerce recordFieldName) in case fieldInfo of FieldNormal _fieldName fieldNum dpType options -> do - fieldE <- wrapE useLegacyTypes' ctxt options dpType recordFieldName' + fieldE <- wrapE ctxt options dpType recordFieldName' pure $ apply encodeMessageFieldE [ fieldNumberE fieldNum, fieldE ] FieldOneOf OneofField{subfields} -> do @@ -862,7 +803,7 @@ let wrapJust = HsParen . HsApp (HsVar (haskellName "Just")) xE <- (if isMaybe then id else fmap forceEmitE) - . wrapE useLegacyTypes' ctxt options dpType + . wrapE ctxt options dpType . (if isMaybe then wrapJust else id) $ uvar_ "y" @@ -871,20 +812,20 @@ [] - decodeMessageField :: UseLegacyTypes -> QualifiedField -> m HsExp - decodeMessageField useLegacyTypes' QualifiedField{fieldInfo} = + decodeMessageField :: QualifiedField -> m HsExp + decodeMessageField QualifiedField{fieldInfo} = case fieldInfo of FieldNormal _fieldName fieldNum dpType options -> - unwrapE useLegacyTypes' ctxt options dpType $ apply atE [ decodeMessageFieldE, fieldNumberE fieldNum ] + unwrapE ctxt options dpType $ apply atE [ decodeMessageFieldE, fieldNumberE fieldNum ] FieldOneOf OneofField{subfields} -> do - parsers <- mapM (subfieldParserE useLegacyTypes') subfields + parsers <- mapM subfieldParserE subfields pure $ apply oneofE [ HsVar (haskellName "Nothing") , HsList parsers ] where -- create a list of (fieldNumber, Cons <$> parser) - subfieldParserE useLegacyTypes'' (OneofSubfield fieldNumber consName _ dpType options) = do + subfieldParserE (OneofSubfield fieldNumber consName _ dpType options) = do let fE | Prim (Named tyName) <- dpType, isMessage ctxt tyName = HsParen (HsApp fmapE (uvar_ consName)) | otherwise @@ -892,7 +833,7 @@ composeOp (uvar_ consName)) - alts <- unwrapE useLegacyTypes'' ctxt options dpType decodeMessageFieldE + alts <- unwrapE ctxt options dpType decodeMessageFieldE pure $ HsTuple [ fieldNumberE fieldNumber @@ -1142,6 +1083,7 @@ let _namedSchemaNameExpression = HsApp justC (str_ messageName) +#ifdef SWAGGER -- { _paramSchemaType = HsJSONPB.SwaggerObject -- } let paramSchemaUpdates = @@ -1155,6 +1097,9 @@ #else _paramSchemaTypeExpression = HsVar (jsonpbName "SwaggerObject") #endif +#else + let paramSchemaUpdates = [] +#endif let _schemaParamSchemaExpression = HsRecUpdate memptyE paramSchemaUpdates @@ -1320,12 +1265,11 @@ dotProtoEnumD :: MonadError CompileError m - => UseLegacyTypes - -> DotProtoIdentifier + => DotProtoIdentifier -> DotProtoIdentifier -> [DotProtoEnumPart] -> m [HsDecl] -dotProtoEnumD useLegacyTypes parentIdent enumIdent enumParts = do +dotProtoEnumD parentIdent enumIdent enumParts = do enumName <- qualifiedMessageName parentIdent enumIdent let enumeratorDecls = @@ -1433,7 +1377,7 @@ (uvar_ "x"))) [] - pure [ (dataDecl_ useLegacyTypes) enumName + pure [ dataDecl_ enumName [ conDecl_ (HsIdent con) [] | con <- enumConNames ] defaultEnumDeriving , namedInstD enumName @@ -1473,13 +1417,12 @@ dotProtoServiceD :: MonadError CompileError m - => UseLegacyTypes - -> DotProtoIdentifier + => DotProtoIdentifier -> TypeContext -> DotProtoIdentifier -> [DotProtoServicePart] -> m [HsDecl] -dotProtoServiceD useLegacyTypes pkgIdent ctxt serviceIdent service = do +dotProtoServiceD pkgIdent ctxt serviceIdent service = do serviceName <- typeLikeName =<< dpIdentUnqualName serviceIdent packageName <- dpIdentQualName pkgIdent @@ -1492,9 +1435,9 @@ Single nm -> pure nm _ -> invalidMethodNameError rpcMethodName - requestTy <- (dpptToHsType useLegacyTypes) ctxt (Named rpcMethodRequestType) + requestTy <- dpptToHsType ctxt (Named rpcMethodRequestType) - responseTy <- (dpptToHsType useLegacyTypes) ctxt (Named rpcMethodResponseType) + responseTy <- dpptToHsType ctxt (Named rpcMethodResponseType) let streamingType = case (rpcMethodRequestStreaming, rpcMethodResponseStreaming) of @@ -1550,6 +1493,7 @@ , patVar "initialMetadata" , patVar "sslConfig" , patVar "logger" + , patVar "serverMaxReceiveMessageLength" ] ] (HsUnGuardedRhs (apply serverLoopE [ serverOptsE ])) @@ -1593,9 +1537,9 @@ , update "optInitialMetadata" "initialMetadata" , update "optSSLConfig" "sslConfig" , update "optLogger" "logger" + , update "optMaxReceiveMessageLength" "serverMaxReceiveMessageLength" ] - let clientT = tyApp (HsTyCon (unqual_ serviceName)) [ clientRequestT, clientResultT ] let serviceClientTypeD = @@ -1906,10 +1850,10 @@ importDecl_ :: Module -> Bool -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl importDecl_ = HsImportDecl defaultSrcLoc -dataDecl_ :: UseLegacyTypes -> String -> [HsConDecl] -> [HsQName] -> HsDecl -dataDecl_ NoLegacy messageName [constructor@(HsRecDecl _ _ [_])] = +dataDecl_ :: String -> [HsConDecl] -> [HsQName] -> HsDecl +dataDecl_ messageName [constructor@(HsRecDecl _ _ [_])] = HsNewTypeDecl defaultSrcLoc [] (HsIdent messageName) [] constructor -dataDecl_ _ messageName constructors = +dataDecl_ messageName constructors = HsDataDecl defaultSrcLoc [] (HsIdent messageName) [] constructors recDecl_ :: HsName -> [([HsName], HsBangType)] -> HsConDecl diff --git a/src/Proto3/Suite/DotProto/Generate/Swagger.hs b/src/Proto3/Suite/DotProto/Generate/Swagger.hs --- a/src/Proto3/Suite/DotProto/Generate/Swagger.hs +++ b/src/Proto3/Suite/DotProto/Generate/Swagger.hs @@ -23,13 +23,16 @@ #else import Control.Lens ((&), (.~), (?~)) #endif -import Data.Aeson (Value (String)) +import Data.Aeson (Value (String), ToJSONKey, + ToJSONKeyFunction(..)) +import qualified Data.Aeson as Aeson import Data.Aeson.Encode.Pretty (encodePretty) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy.Char8 as LC8 import Data.Hashable (Hashable) import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import qualified Data.HashMap.Strict.InsOrd +import Data.Map (Map) import Data.Swagger import qualified Data.Text as T import Data.Proxy @@ -71,6 +74,17 @@ & type_ .~ SwaggerArray #endif & items ?~ SwaggerItemsObject (Inline byteSchema) + +instance {-# OVERLAPPING #-} (ToJSONKey k, ToSchema k) => ToSchema (OverrideToSchema (Map k ByteString)) where + declareNamedSchema _ = case Aeson.toJSONKey :: ToJSONKeyFunction k of + ToJSONKeyText _ _ -> do + return (NamedSchema Nothing schema_) + ToJSONKeyValue _ _ -> do + declareNamedSchema (Proxy :: Proxy [(k, (OverrideToSchema ByteString))]) + where + schema_ = mempty + & type_ ?~ SwaggerObject + & additionalProperties ?~ AdditionalPropertiesSchema (Inline byteSchema) {-| This is a convenience function that uses type inference to select the correct instance of `ToSchema` to use for fields of a message diff --git a/src/Proto3/Suite/JSONPB.hs b/src/Proto3/Suite/JSONPB.hs --- a/src/Proto3/Suite/JSONPB.hs +++ b/src/Proto3/Suite/JSONPB.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Proto3.Suite.JSONPB ( -- * Typeclasses FromJSONPB(..) @@ -30,6 +32,7 @@ , A.FromJSON(..) , A.typeMismatch , A.withObject +#ifdef SWAGGER -- * Swagger schema helpers , Swagger.ToSchema(..) , Swagger.NamedSchema(..) @@ -40,11 +43,14 @@ , Proto3.Suite.DotProto.Generate.Swagger.OverrideToSchema(..) , Proto3.Suite.DotProto.Generate.Swagger.asProxy , Proto3.Suite.DotProto.Generate.Swagger.insOrdFromList +#endif ) where import qualified Data.Aeson as A import qualified Data.Aeson.Types as A +#ifdef SWAGGER import qualified Data.Swagger as Swagger import Proto3.Suite.DotProto.Generate.Swagger +#endif import Proto3.Suite.JSONPB.Class diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -63,6 +63,12 @@ [ "-isrc" , "-itests" , "-igen" +#ifdef SWAGGER + , "-DSWAGGER" +#endif +#ifdef DHALL + , "-DDHALL" +#endif , "src/Proto3/Suite/DotProto/Internal.hs" , "src/Proto3/Suite/JSONPB/Class.hs" , "tests/TestCodeGen.hs" diff --git a/tests/TestCodeGen.hs b/tests/TestCodeGen.hs --- a/tests/TestCodeGen.hs +++ b/tests/TestCodeGen.hs @@ -130,11 +130,11 @@ -- * Helpers --- E.g. dumpAST NoLegacy ["test-files"] "test_proto.proto" -dumpAST :: UseLegacyTypes -> [FilePath] -> FilePath -> IO () -dumpAST useLegacyTypes incs fp = (either (error . show) putStrLn <=< runExceptT) $ do +-- E.g. dumpAST ["test-files"] "test_proto.proto" +dumpAST :: [FilePath] -> FilePath -> IO () +dumpAST incs fp = (either (error . show) putStrLn <=< runExceptT) $ do (dp, tc) <- readDotProtoWithContext incs fp - src <- renderHsModuleForDotProto useLegacyTypes mempty dp tc + src <- renderHsModuleForDotProto mempty dp tc pure src hsTmpDir, pyTmpDir :: IsString a => a @@ -158,7 +158,6 @@ , extraInstanceFiles = [] , outputDir = hsTmpDir , inputProto = protoFile - , useLegacyTypes = NoLegacy } let cmd = T.concat [ "protoc --python_out=" diff --git a/tools/compile-proto-file/Main.hs b/tools/compile-proto-file/Main.hs --- a/tools/compile-proto-file/Main.hs +++ b/tools/compile-proto-file/Main.hs @@ -16,7 +16,7 @@ parseArgs :: ParserInfo CompileArgs parseArgs = info (helper <*> parser) (fullDesc <> progDesc "Compiles a .proto file to a Haskell module") where - parser = CompileArgs <$> includes <*> extraInstances <*> proto <*> out <*> useLegacyTypes + parser = CompileArgs <$> includes <*> extraInstances <*> proto <*> out includes = many $ strOption $ long "includeDir" @@ -37,14 +37,6 @@ long "out" <> metavar "DIR" <> help "Output directory path where generated Haskell modules will be written (directory is created if it does not exist; note that files in the output directory may be overwritten!)" - - boolToUseLegacyTypes = \bool -> case bool of - True -> YesLegacy - False -> NoLegacy - - useLegacyTypes = boolToUseLegacyTypes <$> (switch $ - long "use-legacy-types" - <> help "If this flag is set, the program will use legacy behavior to wrap protobuf Wrapper types (e.g. Int32Value) with Maybe in the generated Haskell code (provided for backwards compatibility).") main :: IO () main = execParser parseArgs >>= compileDotProtoFileOrDie