Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add required field to generated ToSchema instances #137

Open
wants to merge 13 commits into
base: master
Choose a base branch
from
Open

Add required field to generated ToSchema instances #137

Show file tree
Hide file tree
Changes from 4 commits
Commits
Show all changes
13 commits
Select commit Hold shift + click to select a range
42d4791
Add required field to genrated ToSchema instances
rashadg1030 Aug 4, 2020
05189b7
For testing
rashadg1030 Aug 4, 2020
4021408
Fix wrong argument
rashadg1030 Aug 5, 2020
a227574
Fix doctests for ToSchema instance generator
rashadg1030 Aug 5, 2020
627a522
Get doctests passing
rashadg1030 Aug 6, 2020
1eb688b
Fix doctests; get doctests to pass
rashadg1030 Aug 6, 2020
52a8b88
Make fields that are enum types required
rashadg1030 Aug 11, 2020
84245ad
Revert "Make fields that are enum types required"
rashadg1030 Aug 11, 2020
5c79a90
Make enum type fields required
rashadg1030 Aug 11, 2020
5ebed4b
Merge remote-tracking branch 'origin' into rashad/to-schema-instances
rashadg1030 Aug 11, 2020
49cab30
Merge remote-tracking branch 'origin' into rashad/to-schema-instances
rashadg1030 Aug 12, 2020
364657a
Try to add enum fields to the TypeContext of messages so they can be …
rashadg1030 Aug 18, 2020
c4c904e
Make enum fields not required
rashadg1030 Aug 24, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
221 changes: 215 additions & 6 deletions src/Proto3/Suite/DotProto/Generate.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -627,9 +627,10 @@ dotProtoMessageD ctxt parentIdent messageIdent messageParts = do
, pure (fromJSONInstDecl messageName)

-- And the Swagger ToSchema instance corresponding to JSONPB encodings
, toSchemaInstanceDeclaration messageName Nothing
=<< foldMapM (traverse dpIdentUnqualName . getName) messageParts

, toSchemaInstanceDeclarationNew messageName Nothing
=<< do
dotProtoUnqualifiedName <- foldMapM (traverse dpIdentUnqualName . getName) messageParts
pure $ zip dotProtoUnqualifiedName messageParts
#ifdef DHALL
-- Generate Dhall instances
, pure (dhallInterpretInstDecl messageName)
Expand Down Expand Up @@ -683,7 +684,7 @@ dotProtoMessageD ctxt parentIdent messageIdent messageParts = do

(cons, idents) <- fmap unzip (mapM (oneOfCons fullName) fields)

toSchemaInstance <- toSchemaInstanceDeclaration fullName (Just idents)
toSchemaInstance <- toSchemaInstanceDeclarationOld fullName (Just idents)
=<< mapM (dpIdentUnqualName . dotProtoFieldName) fields

pure [ dataDecl_ fullName cons defaultMessageDeriving
Expand Down Expand Up @@ -1061,7 +1062,215 @@ fromJSONInstDecl typeName =

-- *** Generate `ToSchema` instance

toSchemaInstanceDeclaration
toSchemaInstanceDeclarationNew
:: MonadError CompileError m
=> String
-- ^ Name of the message type to create an instance for
-> Maybe [HsName]
-- ^ Oneof constructors
-> [(String, DotProtoMessagePart)]
rashadg1030 marked this conversation as resolved.
Show resolved Hide resolved
-- ^ Field names and message parts
-> m HsDecl
toSchemaInstanceDeclarationNew messageName maybeConstructors fieldNamesAndMessageParts = do
let fieldNames = map fst fieldNamesAndMessageParts

qualifiedFieldNames <- mapM (prefixedFieldName messageName) fieldNames

let messageConstructor = HsCon (UnQual (HsIdent messageName))

let _namedSchemaNameExpression = HsApp justC (str_ messageName)

-- { _paramSchemaType = HsJSONPB.SwaggerObject
-- }
let paramSchemaUpdates =
[ HsFieldUpdate _paramSchemaType _paramSchemaTypeExpression
]
where
_paramSchemaType = jsonpbName "_paramSchemaType"

#if MIN_VERSION_swagger2(2,4,0)
_paramSchemaTypeExpression = HsApp justC (HsVar (jsonpbName "SwaggerObject"))
#else
_paramSchemaTypeExpression = HsVar (jsonpbName "SwaggerObject")
#endif

let _schemaParamSchemaExpression = HsRecUpdate memptyE paramSchemaUpdates

-- [ ("fieldName0", qualifiedFieldName0)
-- , ("fieldName1", qualifiedFieldName1)
-- ...
-- ]
let properties = HsList $ do
(fieldName, qualifiedFieldName) <- zip fieldNames qualifiedFieldNames
return (HsTuple [ str_ fieldName, uvar_ qualifiedFieldName ])

let _schemaPropertiesExpression =
HsApp (HsVar (jsonpbName "insOrdFromList")) properties

let isRequired :: DotProtoMessagePart -> Bool = \case
DotProtoMessageField _ -> True
DotProtoMessageOneOf _ _ -> False
DotProtoMessageDefinition _ -> False
DotProtoMessageReserved _ -> True

let requiredList = HsList $ do
requiredFieldNameAndMessagePart <- filter (isRequired . snd) fieldNamesAndMessageParts
let requiredFieldName = fst requiredFieldNameAndMessagePart
return $ str_ requiredFieldName

let _schemaRequiredExpression = requiredList

-- { _schemaParamSchema = ...
-- , _schemaProperties = ...
-- , _schemaRequired = ...
-- , ...
-- }
let schemaUpdates = normalUpdates ++ extraUpdates
where
normalUpdates =
[ HsFieldUpdate _schemaParamSchema _schemaParamSchemaExpression
, HsFieldUpdate _schemaProperties _schemaPropertiesExpression
, HsFieldUpdate _schemaRequired _schemaRequiredExpression
]

extraUpdates =
case maybeConstructors of
Just _ ->
[ HsFieldUpdate _schemaMinProperties justOne
, HsFieldUpdate _schemaMaxProperties justOne
]
Nothing ->
[]

_schemaParamSchema = jsonpbName "_schemaParamSchema"
_schemaProperties = jsonpbName "_schemaProperties"
_schemaRequired = jsonpbName "_schemaRequired"
_schemaMinProperties = jsonpbName "_schemaMinProperties"
_schemaMaxProperties = jsonpbName "_schemaMaxProperties"

justOne = HsApp justC (HsLit (HsInt 1))

let _namedSchemaSchemaExpression = HsRecUpdate memptyE schemaUpdates

-- { _namedSchemaName = ...
-- , _namedSchemaSchema = ...
-- }
let namedSchemaUpdates =
[ HsFieldUpdate _namedSchemaName _namedSchemaNameExpression
, HsFieldUpdate _namedSchemaSchema _namedSchemaSchemaExpression
]
where
_namedSchemaName = jsonpbName "_namedSchemaName"
_namedSchemaSchema = jsonpbName "_namedSchemaSchema"

let namedSchema = HsRecConstr (jsonpbName "NamedSchema") namedSchemaUpdates

let toDeclareName fieldName = "declare_" ++ fieldName

let toArgument fieldName = HsApp asProxy declare
where
declare = uvar_ (toDeclareName fieldName)

asProxy = HsVar (jsonpbName "asProxy")

-- do let declare_fieldName0 = HsJSONPB.declareSchemaRef
-- qualifiedFieldName0 <- declare_fieldName0 Proxy.Proxy
-- let declare_fieldName1 = HsJSONPB.declareSchemaRef
-- qualifiedFieldName1 <- declare_fieldName1 Proxy.Proxy
-- ...
-- let _ = pure MessageName <*> HsJSONPB.asProxy declare_fieldName0 <*> HsJSONPB.asProxy declare_fieldName1 <*> ...
-- return (...)
let expressionForMessage =
HsDo (bindingStatements ++ inferenceStatement ++ [ returnStatement ])
where
bindingStatements = do
(fieldName, qualifiedFieldName) <- zip fieldNames qualifiedFieldNames

let declareIdentifier = HsIdent (toDeclareName fieldName)

let stmt0 = HsLetStmt [ HsFunBind
[ HsMatch defaultSrcLoc declareIdentifier []
(HsUnGuardedRhs (HsVar (jsonpbName "declareSchemaRef"))) []
]
]

let stmt1 = HsGenerator defaultSrcLoc (HsPVar (HsIdent qualifiedFieldName))
(HsApp (HsVar (UnQual declareIdentifier))
(HsCon (proxyName "Proxy")))
[ stmt0, stmt1]


inferenceStatement =
if null fieldNames then [] else [ HsLetStmt [ patternBind ] ]
where
arguments = map toArgument fieldNames

patternBind = HsPatBind defaultSrcLoc HsPWildCard
(HsUnGuardedRhs (applicativeApply messageConstructor arguments)) []

returnStatement = HsQualifier (HsApp returnE (HsParen namedSchema))

-- do let declare_fieldName0 = HsJSONPB.declareSchemaRef
-- let _ = pure ConstructorName0 <*> HsJSONPB.asProxy declare_fieldName0
-- qualifiedFieldName0 <- declare_fieldName0 Proxy.Proxy
-- let declare_fieldName1 = HsJSONPB.declareSchemaRef
-- let _ = pure ConstructorName1 <*> HsJSONPB.asProxy declare_fieldName1
-- qualifiedFieldName1 <- declare_fieldName1 Proxy.Proxy
-- ...
-- return (...)
let expressionForOneOf constructors =
HsDo (bindingStatements ++ [ returnStatement ])
where
bindingStatements = do
(fieldName, qualifiedFieldName, constructor)
<- zip3 fieldNames qualifiedFieldNames constructors

let declareIdentifier = HsIdent (toDeclareName fieldName)

let stmt0 = HsLetStmt [ HsFunBind
[ HsMatch defaultSrcLoc declareIdentifier []
(HsUnGuardedRhs (HsVar (jsonpbName "declareSchemaRef"))) []
]
]
let stmt1 = HsGenerator defaultSrcLoc (HsPVar (HsIdent qualifiedFieldName))
(HsApp (HsVar (UnQual declareIdentifier))
(HsCon (proxyName "Proxy")))
let inferenceStatement =
if null fieldNames then [] else [ HsLetStmt [ patternBind ] ]
where
arguments = [ toArgument fieldName ]

patternBind = HsPatBind defaultSrcLoc HsPWildCard
(HsUnGuardedRhs (applicativeApply (HsCon (UnQual constructor)) arguments)) []

[stmt0, stmt1] ++ inferenceStatement


returnStatement = HsQualifier (HsApp returnE (HsParen namedSchema))

let instanceDeclaration =
instDecl_ className [ classArgument ] [ classDeclaration ]
where
className = jsonpbName "ToSchema"

classArgument = HsTyCon (UnQual (HsIdent messageName))

classDeclaration = HsFunBind [ match ]
where
match = match_ matchName [ HsPWildCard ] rightHandSide []
where
expression = case maybeConstructors of
Nothing -> expressionForMessage
Just constructors -> expressionForOneOf constructors

rightHandSide = HsUnGuardedRhs expression

matchName = HsIdent "declareNamedSchema"

return instanceDeclaration


toSchemaInstanceDeclarationOld
:: MonadError CompileError m
=> String
-- ^ Name of the message type to create an instance for
Expand All @@ -1070,7 +1279,7 @@ toSchemaInstanceDeclaration
-> [String]
-- ^ Field names
-> m HsDecl
toSchemaInstanceDeclaration messageName maybeConstructors fieldNames = do
toSchemaInstanceDeclarationOld messageName maybeConstructors fieldNames = do
qualifiedFieldNames <- mapM (prefixedFieldName messageName) fieldNames

let messageConstructor = HsCon (UnQual (HsIdent messageName))
Expand Down
6 changes: 3 additions & 3 deletions tests/TestCodeGen.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -252,11 +252,11 @@ 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"}
-- {"required":["name","someid"],"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"}
rashadg1030 marked this conversation as resolved.
Show resolved Hide resolved
-- >>> 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"]}
--
Expand Down