structs forms

README.md

@@ -50,21 +50,6 @@ $ git clone https://github.com/scarf-sh/tie.git
 $ cd tie
 ```
 
-Then, you need to build it using cabal:
-
-```bash
-$ cabal build exe:tie
-```
-
-Finally, you can copy the resulting executable to your desired location:
-
-```bash
-$ cp $(cabal exec -- which tie) ~/.local/bin/tie
-```
-
-Alternatively, instead of manually copying the executable you can install with
-cabal:
-
 ```bash
 $ cabal install .
 ```

Request.template.hs

@@ -146,10 +146,11 @@ requiredQueryParameters style name withParam =
 optionalQueryParameters ::
   (FromHttpApiData a) =>
   Style ->
+  Bool ->
   ByteString ->
   (Maybe (NonEmpty.NonEmpty a) -> Wai.Application) ->
   Wai.Application
-optionalQueryParameters style name withParam =
+optionalQueryParameters style allowEmpty name withParam =
   case style of
     FormStyle -> \request respond ->
       case urlDecodeForm (LBS.fromStrict (ByteString.drop 1 (Wai.rawQueryString request))) of
@@ -166,21 +167,21 @@ optionalQueryParameters style name withParam =
     SpaceDelimitedStyle ->
       optionalQueryParameter
         name
-        False
+        allowEmpty
         ( \xs ->
             withParam (xs >>= NonEmpty.nonEmpty . unSpaceDelimitedValue)
         )
     PipeDelimitedStyle ->
       optionalQueryParameter
         name
-        False
+        allowEmpty
         ( \xs ->
             withParam (xs >>= NonEmpty.nonEmpty . unPipeDelimitedValue)
         )
     CommaDelimitedStyle ->
       optionalQueryParameter
         name
-        False
+        allowEmpty
         ( \xs ->
             withParam (xs >>= NonEmpty.nonEmpty . unCommaDelimitedValue)
         )

example/generated/Petstore/API/Untitled-1.hs

@@ -0,0 +1,6 @@
+data CreatePackageRequest where
+  CreatePackageRequest_application_json :: CreatePackage1 -> CreatePackageRequest
+  CreatePackageRequest_text_xml :: CreatePackage1 -> CreatePackageRequest
+
+data CreatePackageResponse (status :: Natural) body where
+  CreatePackageResponse_200_application_json :: CreatePackageResponse 200

src/Tie/Codegen/Imports.hs

@@ -161,6 +161,10 @@ codegenModuleHeader moduleName =
       <> "import"
     <+> "qualified"
     <+> "Web.HttpApiData"
+      <> PP.line
+      <> "import"
+    <+> "qualified"
+    <+> "Web.FormUrlEncoded"
 
 codegenExtraApiModuleDependencies :: ApiName -> Doc ann
 codegenExtraApiModuleDependencies apiName =

src/Tie/Codegen/Operation.hs

@@ -363,7 +363,7 @@ codegenQueryParamStyle explode style = case (explode, style) of
   (False, StyleForm) -> Just "CommaDelimitedStyle"
 
 codegenQueryParamGuard :: Param -> PP.Doc ann -> PP.Doc ann
-codegenQueryParamGuard Param {name, required, style, explode, schema} continuation
+codegenQueryParamGuard Param {name, required, style, explode, schema, allowEmpty} continuation
   | Just _ <- isArrayType (namedType schema),
     Just style <- style,
     Just style <- codegenQueryParamStyle explode style =
@@ -394,7 +394,7 @@ codegenQueryParamGuard Param {name, required, style, explode, schema} continuati
   | otherwise =
       "optionalQueryParameter"
         <+> "\"" <> toParamName name <> "\""
-        <+> "False"
+        <+> if allowEmpty then "True" else "False"
         <+> "(" <> "\\" <> toParamBinder name
         <+> "request"
         <+> "respond"

src/Tie/Codegen/Schema.hs

@@ -48,6 +48,7 @@ import Tie.Type
     isOneOfType,
     namedType,
     normalizeType,
+    isFitForFromFormInstance,
   )
 import Prelude hiding (Type)
 
@@ -264,7 +265,7 @@ codegenOneOfType getDiscriminator typName variants = do
   pure (PP.vsep $ intersperse mempty [decl, toJson, fromJson])
 
 codegenObjectType :: (Monad m) => Name -> ObjectType (Named Type) -> m (Doc ann)
-codegenObjectType typName ObjectType {..}
+codegenObjectType typName objectType@ObjectType {..}
   -- for empty, free form objects, just generate a type synonym for Value.
   | Just FreeForm <- additionalProperties,
     null properties =
@@ -508,7 +509,53 @@ codegenObjectType typName ObjectType {..}
                                 )
                           )
                   )
-       in pure (PP.vsep $ intersperse mempty [decl, toJson, fromJson])
+
+          parseFormForm form fieldName fieldType
+            | Just {} <- isArrayType (namedType fieldType) =
+                if is_required then
+                  "Web.FormUrlEncoded.parseAll" <+> "\"" <> toJsonFieldName fieldName <> "\"" <+> form
+                else
+                  "(" <> "either" <+> "(" <> "const" <+> "(" <> "Right" <+> "Nothing" <> ")" <> ")" <+> "(" <> "Right" <+> "." <+> "Just" <> ")" <+> "(" <> "Web.FormUrlEncoded.parseAll" <+> "\"" <> toJsonFieldName fieldName <> "\"" <+> form <> ")" <> ")"
+            | Just {} <- isObjectType (namedType fieldType) = 
+                if is_required then 
+                  "Web.FormUrlEncoded.fromForm" <+> form
+                else 
+                  "(" <> "either" <+> "(" <> "const" <+> "(" <> "Right" <+> "Nothing" <> ")" <> ")" <+> "(" <> "Right" <+> "." <+> "Just" <> ")" <+> "(" <> "Web.FormUrlEncoded.fromForm" <+> form <> ")" <> ")"
+            | is_required =
+                "Web.FormUrlEncoded.parseUnique" <+> "\"" <> toJsonFieldName fieldName <> "\"" <+> form
+            | otherwise =
+                "Web.FormUrlEncoded.parseMaybe" <+> "\"" <> toJsonFieldName fieldName <> "\"" <+> form
+            where 
+              is_required = HashSet.member fieldName requiredProperties        
+
+          fromForm
+            | isFitForFromFormInstance (Object objectType) =
+                "instance"
+                  <+> "Web.FormUrlEncoded.FromForm"
+                  <+> toDataTypeName typName
+                  <+> "where"
+                    <> PP.line
+                    <> PP.indent
+                      4
+                      ( "fromForm" <+> "x" <+> "=" 
+                            <> PP.line
+                            <> PP.indent
+                              4
+                              ( toConstructorName typName
+                                  <> PP.line
+                                  <> PP.indent
+                                    4
+                                    ( PP.vsep
+                                        [ op <+> parseFormForm "x" fieldName fieldType
+                                          | (op, (fieldName, fieldType)) <- zip ("<$>" : repeat "<*>") orderedProperties
+                                        ]
+                                    )
+                              )
+                      )
+            | otherwise = 
+                mempty
+
+       in pure (PP.vsep $ intersperse mempty [decl, toJson, fromJson, fromForm])
 
 codegenRequiredOptionalFieldType :: Bool -> Doc ann -> Doc ann
 codegenRequiredOptionalFieldType True doc = doc

src/Tie/Operation.hs

@@ -122,7 +122,8 @@ data Param = Param
     schema :: Named Type,
     required :: Bool,
     explode :: Bool,
-    style :: Maybe Style
+    style :: Maybe Style,
+    allowEmpty :: Bool
   }
   deriving (Eq, Ord, Show)
 
@@ -423,7 +424,8 @@ paramToParam resolver Errors {..} OpenApi.Param {..} = do
             | OpenApi.ParamQuery <- _paramIn ->
                 Just StyleForm
             | otherwise -> Nothing,
-        schema = typ
+        schema = typ,
+        allowEmpty = fromMaybe False _paramAllowEmptyValue
       }
 
 headerToHeader ::

src/Tie/Type.hs

@@ -31,6 +31,7 @@ module Tie.Type
     isArrayType,
     isObjectType,
     isOneOfType,
+    isFitForFromFormInstance,
 
     -- * Normalize types
     normalizeType,
@@ -518,6 +519,24 @@ isArrayType ty = case ty of
   Array elem -> Just elem
   _ -> Nothing
 
+-- | Due to techinical reasons we only generate the fromFrom code for certain data types.
+-- It's a matter of the instances that http-api-data providers but nothing structural that 
+-- would prevent us from doing all types.
+isFitForFromFormInstance :: Type -> Bool
+isFitForFromFormInstance ty 
+  | Just {} <- isOneOfType ty =
+      False
+  | Just ty <- isArrayType ty =
+    isJust (isBasicType (namedType ty))
+  | Just objectTy <- isObjectType ty =
+    isJust (traverse (isBasicType . namedType) objectTy)
+  | Just {} <- isEnumType ty =
+      True
+  | Just {} <- isBasicType ty =
+      True
+  | otherwise = 
+      False
+
 -- | Casting a 'Type' to an 'ObjectType', if possible. `isObjectType` looks through
 -- allOf, oneOf, anyOf to ensure
 isObjectType :: Type -> Maybe (ObjectType (Named Type))