Add required field to generated ToSchema instances

src/Proto3/Suite/DotProto/Generate.hs

@@ -560,8 +560,10 @@ validMapKey = (`elem` [ Int32, Int64, SInt32, SInt64, UInt32, UInt64
 dotProtoDefinitionD :: MonadError CompileError m
                     => DotProtoIdentifier -> TypeContext -> DotProtoDefinition -> m [HsDecl]
 dotProtoDefinitionD pkgIdent ctxt = \case
-  DotProtoMessage _ messageName messageParts ->
-    dotProtoMessageD ctxt Anonymous messageName messageParts
+  DotProtoMessage _ messageName messageParts -> do
+    let ctxt' = maybe mempty dotProtoTypeChildContext (M.lookup pkgIdent ctxt) <> ctxt
+
+    dotProtoMessageD ctxt' Anonymous messageName messageParts
 
   DotProtoEnum _ enumName enumParts ->
     dotProtoEnumD Anonymous enumName enumParts
@@ -607,10 +609,27 @@ dotProtoMessageD ctxt parentIdent messageIdent messageParts = do
             [ recDecl_ (HsIdent messageName) flds ]
             defaultMessageDeriving
 
-    let getName = \case
-          DotProtoMessageField fld     -> [dotProtoFieldName fld]
-          DotProtoMessageOneOf ident _ -> [ident]
-          _                            -> []
+    let isRequired :: DotProtoField -> Bool = \case
+          DotProtoField _ (Prim (Named ident)) _ _ _ -> case M.lookup ident ctxt of
+            Nothing -> False
+            Just protoType -> case dotProtoTypeInfoKind protoType of
+              DotProtoKindEnum -> True
+              _ -> False
+          DotProtoField _ _ _ _ _ -> True
+          DotProtoEmptyField -> False
+
+    let getEither :: DotProtoMessagePart -> m [(String, Bool)] = \case
+          DotProtoMessageField fld     -> do
+            name <- dpIdentUnqualName (dotProtoFieldName fld)
+            pure [(name, isRequired fld)]
+          DotProtoMessageOneOf ident _ -> do
+            name <- dpIdentUnqualName ident
+            pure [(name, False)]
+          _                            -> do pure []
+
+    fieldss <- traverse getEither messageParts
+
+    let fields = concat fieldss
 
     foldMapM id
       [ sequence
@@ -626,10 +645,7 @@ dotProtoMessageD ctxt parentIdent messageIdent messageParts = do
           , pure (toJSONInstDecl messageName)
           , pure (fromJSONInstDecl messageName)
 
-          -- And the Swagger ToSchema instance corresponding to JSONPB encodings
-          , toSchemaInstanceDeclaration messageName Nothing
-              =<< foldMapM (traverse dpIdentUnqualName . getName) messageParts
-
+          , toSchemaInstanceDeclaration messageName Nothing fields
 #ifdef DHALL
           -- Generate Dhall instances
           , pure (dhallInterpretInstDecl messageName)
@@ -678,13 +694,13 @@ dotProtoMessageD ctxt parentIdent messageIdent messageParts = do
     nestedDecls _ = pure []
 
     nestedOneOfDecls :: String -> DotProtoIdentifier -> [DotProtoField] -> m [HsDecl]
-    nestedOneOfDecls messageName identifier fields = do
+    nestedOneOfDecls messageName identifier dotProtoFields = do
+      fields <- traverse (dpIdentUnqualName . dotProtoFieldName) dotProtoFields
       fullName <- prefixedConName messageName =<< dpIdentUnqualName identifier
 
-      (cons, idents) <- fmap unzip (mapM (oneOfCons fullName) fields)
+      (cons, idents) <- fmap unzip (mapM (oneOfCons fullName) dotProtoFields)
 
-      toSchemaInstance <- toSchemaInstanceDeclaration fullName (Just idents)
-                            =<< mapM (dpIdentUnqualName . dotProtoFieldName) fields
+      toSchemaInstance <- toSchemaInstanceDeclaration fullName (Just idents) (zip fields $ repeat False)
 
       pure [ dataDecl_ fullName cons defaultMessageDeriving
            , namedInstD fullName
@@ -1067,10 +1083,12 @@ toSchemaInstanceDeclaration
     -- ^ Name of the message type to create an instance for
     -> Maybe [HsName]
     -- ^ Oneof constructors
-    -> [String]
-    -- ^ Field names
+    -> [(String, Bool)]
+    -- ^ Field and if it is nested oneof field
     -> m HsDecl
-toSchemaInstanceDeclaration messageName maybeConstructors fieldNames = do
+toSchemaInstanceDeclaration messageName maybeConstructors fieldsWithIsRequired = do
+  let fieldNames = map fst fieldsWithIsRequired
+
   qualifiedFieldNames <- mapM (prefixedFieldName messageName) fieldNames
 
   let messageConstructor = HsCon (UnQual (HsIdent messageName))
@@ -1104,15 +1122,23 @@ toSchemaInstanceDeclaration messageName maybeConstructors fieldNames = do
   let _schemaPropertiesExpression =
         HsApp (HsVar (jsonpbName "insOrdFromList")) properties
 
+  let requiredFieldNames = map fst $ filter snd fieldsWithIsRequired
+
+  let requiredList = HsList $ map str_ requiredFieldNames
+
+  let _schemaRequiredExpression = requiredList
+
       -- { _schemaParamSchema = ...
       -- , _schemaProperties  = ...
+      -- , _schemaRequired    = ...
       -- , ...
       -- }
   let schemaUpdates = normalUpdates ++ extraUpdates
         where
           normalUpdates =
             [ HsFieldUpdate _schemaParamSchema _schemaParamSchemaExpression
             , HsFieldUpdate _schemaProperties  _schemaPropertiesExpression
+            , HsFieldUpdate _schemaRequired  _schemaRequiredExpression
             ]
 
           extraUpdates =
@@ -1126,6 +1152,7 @@ toSchemaInstanceDeclaration messageName maybeConstructors fieldNames = do
 
           _schemaParamSchema    = jsonpbName "_schemaParamSchema"
           _schemaProperties     = jsonpbName "_schemaProperties"
+          _schemaRequired       = jsonpbName "_schemaRequired"
           _schemaMinProperties  = jsonpbName "_schemaMinProperties"
           _schemaMaxProperties  = jsonpbName "_schemaMaxProperties"
 
@@ -1250,7 +1277,6 @@ toSchemaInstanceDeclaration messageName maybeConstructors fieldNames = do
 
   return instanceDeclaration
 
-
 -- ** Generate types and instances for .proto enums
 
 dotProtoEnumD

src/Proto3/Suite/DotProto/Internal.hs

@@ -288,19 +288,54 @@ dotProtoTypeContext :: MonadError CompileError m => DotProto -> m TypeContext
 dotProtoTypeContext DotProto{..} =
   foldMapM (definitionTypeContext (metaModulePath protoMeta)) protoDefinitions
 
+fieldTypeContext :: MonadError CompileError m => Path -> DotProtoField -> m TypeContext
+fieldTypeContext modulePath (DotProtoField _ fieldType fieldName _ _) =
+  case fieldType of
+    Prim (Named _) -> do
+    -- Not a good pattern match here. I want to pattern match specifically on enum fields,
+    -- but that's not possible. All enums are named, but not all named types are enums
+
+      let tyInfo = DotProtoTypeInfo { dotProtoTypeInfoPackage = DotProtoNoPackage
+                                    , dotProtoTypeInfoParent = Anonymous
+                                    , dotProtoTypeChildContext = mempty
+                                    , dotProtoTypeInfoKind = DotProtoKindEnum
+                                    , dotProtoTypeInfoModulePath = modulePath
+                                    }
+
+      pure $ M.singleton fieldName tyInfo
+
+    _ -> do
+      pure mempty
+
+fieldTypeContext modulePath DotProtoEmptyField = do
+  pure $ mempty
+
 definitionTypeContext :: MonadError CompileError m
                       => Path -> DotProtoDefinition -> m TypeContext
 definitionTypeContext modulePath (DotProtoMessage _ msgIdent parts) = do
   let updateParent = tiParent (concatDotProtoIdentifier msgIdent)
 
+  let getQualifiedTypeContext definition = do
+        typeContext <- definitionTypeContext modulePath definition
+        traverse updateParent typeContext
+  -- (definitionTypeContext modulePath >=> traverse updateParent)
+
+  let getQualifiedTypeContext' field = do
+        typeContext <- fieldTypeContext modulePath field
+	traverse updateParent typeContext
+
   childTyContext <- foldMapOfM (traverse . _DotProtoMessageDefinition)
-                               (definitionTypeContext modulePath >=> traverse updateParent)
+                               getQualifiedTypeContext
                                parts
 
-  qualifiedChildTyContext <- mapKeysM (concatDotProtoIdentifier msgIdent) childTyContext
+  childTyContext' <- foldMapOfM (traverse . _DotProtoMessageField)
+                                getQualifiedTypeContext'
+                                parts
+
+  qualifiedChildTyContext <- mapKeysM (concatDotProtoIdentifier msgIdent) (childTyContext <> childTyContext')
 
   let tyInfo = DotProtoTypeInfo { dotProtoTypeInfoPackage = DotProtoNoPackage
-                                , dotProtoTypeInfoParent =  Anonymous
+                                , dotProtoTypeInfoParent = Anonymous
                                 , dotProtoTypeChildContext = childTyContext
                                 , dotProtoTypeInfoKind = DotProtoKindMessage
                                 , dotProtoTypeInfoModulePath = modulePath
@@ -310,7 +345,7 @@ definitionTypeContext modulePath (DotProtoMessage _ msgIdent parts) = do
 
 definitionTypeContext modulePath (DotProtoEnum _ enumIdent _) = do
   let tyInfo = DotProtoTypeInfo { dotProtoTypeInfoPackage = DotProtoNoPackage
-                                , dotProtoTypeInfoParent =  Anonymous
+                                , dotProtoTypeInfoParent = Anonymous
                                 , dotProtoTypeChildContext = mempty
                                 , dotProtoTypeInfoKind = DotProtoKindEnum
                                 , dotProtoTypeInfoModulePath = modulePath
@@ -319,9 +354,11 @@ definitionTypeContext modulePath (DotProtoEnum _ enumIdent _) = do
 
 definitionTypeContext _ _ = pure mempty
 
+isEnum :: TypeContext -> DotProtoIdentifier -> Bool
+isEnum typeContext identifier = Just DotProtoKindEnum == (dotProtoTypeInfoKind <$> M.lookup identifier typeContext)
 
 isMessage :: TypeContext -> DotProtoIdentifier -> Bool
-isMessage ctxt n = Just DotProtoKindMessage == (dotProtoTypeInfoKind <$> M.lookup n ctxt)
+isMessage typeContext identifier = Just DotProtoKindMessage == (dotProtoTypeInfoKind <$> M.lookup identifier typeContext)
 
 isPacked :: [DotProtoOption] -> Bool
 isPacked opts =

tests/TestCodeGen.hs

@@ -252,13 +252,15 @@ compileTestDotProtos = do
 -- Swagger
 --
 -- >>> schemaOf @Something
--- {"properties":{"value":{"maximum":9223372036854775807,"format":"int64","minimum":-9223372036854775808,"type":"integer"},"another":{"maximum":2147483647,"format":"int32","minimum":-2147483648,"type":"integer"},"pickOne":{"$ref":"#/definitions/SomethingPickOne"}},"type":"object"}
+-- {"required":["value","another"],"properties":{"value":{"maximum":9223372036854775807,"format":"int64","minimum":-9223372036854775808,"type":"integer"},"another":{"maximum":2147483647,"format":"int32","minimum":-2147483648,"type":"integer"},"pickOne":{"$ref":"#/definitions/SomethingPickOne"}},"type":"object"}
 -- >>> schemaOf @SomethingPickOne
 -- {"properties":{"name":{"type":"string"},"someid":{"maximum":2147483647,"format":"int32","minimum":-2147483648,"type":"integer"},"dummyMsg1":{"$ref":"#/definitions/DummyMsg"},"dummyMsg2":{"$ref":"#/definitions/DummyMsg"},"dummyEnum":{"$ref":"#/definitions/DummyEnum"}},"maxProperties":1,"minProperties":1,"type":"object"}
 -- >>> schemaOf @DummyMsg
--- {"properties":{"dummy":{"maximum":2147483647,"format":"int32","minimum":-2147483648,"type":"integer"}},"type":"object"}
+-- {"required":["dummy"],"properties":{"dummy":{"maximum":2147483647,"format":"int32","minimum":-2147483648,"type":"integer"}},"type":"object"}
 -- >>> schemaOf @(Enumerated DummyEnum)
 -- {"type":"string","enum":["DUMMY0","DUMMY1"]}
+-- >>> schemaOf @WithEnum
+-- {"required": ["enumField"],"properties":{"enumField":{"$ref":"#/definitions/WithEnum_TestEnum"}},"type":"object"}
 --
 -- Generic HasDefault
 --