Added default ToSchema instances for product types and custom instanc…

…es for sum types in auto-gen code
byteally · Nov 26, 2018 · f735d88 · f735d88
1 parent b5f9f95
commit f735d88
Showing 1 changed file with 76 additions and 7 deletions.
diff --git a/webapi-swagger/src/ContractGen.hs b/webapi-swagger/src/ContractGen.hs
@@ -18,7 +18,7 @@ import Data.Text as T
 import GHC.Generics
 import qualified Data.ByteString.Lazy as BSL
 import Data.HashMap.Strict.InsOrd as HMSIns
-import Language.Haskell.Exts hiding (OPTIONS)
+import Language.Haskell.Exts as LHE hiding (OPTIONS)
 import Data.Vector.Sized as SV hiding ((++), foldM, forM, mapM)
 import Safe
 import Data.Finite.Internal
@@ -65,11 +65,12 @@ runCodeGen swaggerJsonInputFilePath contractOutputFolderPath = do
                   case (DL.isInfixOf "FormParam" $ mName newData) of
                     True -> [defaultToParamInstance (mName newData) "FormParam"]
                     False -> []
-        accValue ++ [dataDeclaration (DataType noSrcSpan) (mName newData) (mRecordTypes newData) ["Eq", "Show", "Generic"] ] ++ (jsonInstances (mName newData) ) ++ toParamInstances
+        accValue ++ [dataDeclaration (DataType noSrcSpan) (mName newData) (mRecordTypes newData) ["Eq", "Show", "Generic"] ] ++ (jsonInstances (mName newData) ) ++ toParamInstances ++ [defaultToSchemaInstance (mName newData)]
       SumType tName tConstructors -> do
         let toParamEncodeParamQueryParamInstance = [toParamQueryParamInstance tName] ++ [encodeParamSumTypeInstance tName (DL.zip tConstructors ( (fmap . fmap) Char.toLower tConstructors) ) ]
         let fromParamDecodeParamQueryParamInstance = [fromParamQueryParamInstance tName] ++ [decodeParamSumTypeInstance tName (DL.zip ((fmap . fmap) Char.toLower tConstructors) tConstructors ) ]
-        accValue ++ ([sumTypeDeclaration tName tConstructors ["Eq", "Generic", "Ord"] ] ++ (instanceDeclForShow tName) ++ (instanceDeclForJSONForSumType tName) ++ toParamEncodeParamQueryParamInstance ++ fromParamDecodeParamQueryParamInstance )
+        let toSchemaInstance = [toSchemaInstanceForSumType tName (DL.zip ((fmap . fmap) Char.toLower tConstructors) tConstructors ) ]
+        accValue ++ ([sumTypeDeclaration tName tConstructors ["Eq", "Generic", "Ord"] ] ++ (instanceDeclForShow tName) ++ (instanceDeclForJSONForSumType tName) ++ toParamEncodeParamQueryParamInstance ++ fromParamDecodeParamQueryParamInstance ++ toSchemaInstance)
 
 
 
@@ -96,14 +97,14 @@ readSwaggerGenerateDefnModels swaggerJsonInputFilePath contractOutputFolderPath
             Module noSrcSpan 
                 (Just $ ModuleHead noSrcSpan (ModuleName noSrcSpan "Types") Nothing Nothing)
                 (fmap languageExtension ["TypeFamilies", "MultiParamTypeClasses", "DeriveGeneric", "TypeOperators", "DataKinds", "TypeSynonymInstances", "FlexibleInstances", "DuplicateRecordFields", "OverloadedStrings"])
-                (fmap (moduleImport) ( (DL.zip ["Data.Text","Data.Int","Data.Time.Clock", "GHC.Generics", "Data.Aeson", "WebApi.Param", "Data.Text.Encoding"] (cycle [(False, Nothing)]) ) ++ qualifiedImportsForTypes ) ) --"GHC.Generics", "Data.Time.Calendar"
+                (fmap (moduleImport) ( (DL.zip ["Data.Text","Data.Int","Data.Time.Clock", "GHC.Generics", "Data.Aeson", "WebApi.Param", "Data.Text.Encoding", "Data.Swagger.Schema"] (cycle [(False, Nothing)]) ) ++ qualifiedImportsForTypes ) ) --"GHC.Generics", "Data.Time.Calendar"
                 (createDataDeclarations newData)
       liftIO $ writeFile (contractOutputFolderPath ++ "Types.hs") $ prettyPrint hTypesModule ++ "\n\n"
 
  where 
   createDataDeclarations :: [NewData] -> [Decl SrcSpanInfo]
   createDataDeclarations newDataList = DL.foldl' (\accValue newDataInfo -> 
-      accValue ++ (dataDeclaration (DataType noSrcSpan) (mName newDataInfo) (mRecordTypes newDataInfo) ["Eq", "Show", "Generic"]):jsonInstances (mName newDataInfo) ) [] newDataList
+      accValue ++ [(dataDeclaration (DataType noSrcSpan) (mName newDataInfo) (mRecordTypes newDataInfo) ["Eq", "Show", "Generic"])] ++ jsonInstances (mName newDataInfo) ++ [defaultToSchemaInstance (mName newDataInfo)] ) [] newDataList
 
 -- TODO: This function assumes SwaggerObject to be the type and directly reads from schemaProperties. We need to also take additionalProperties into consideration.
 generateSwaggerDefinitionData :: InsOrdHashMap Text Schema -> StateT [CreateNewType] IO [NewData]
@@ -632,7 +633,7 @@ constructorDeclaration constructorName innerRecords =
 
 
 stringLiteral :: String -> Exp SrcSpanInfo
-stringLiteral str = (Lit noSrcSpan (Language.Haskell.Exts.String noSrcSpan str str))
+stringLiteral str = (Lit noSrcSpan (LHE.String noSrcSpan str str))
 
 variableName :: String -> Exp SrcSpanInfo
 variableName name = (Var noSrcSpan (UnQual noSrcSpan (nameDecl name) ) )
@@ -905,6 +906,8 @@ jsonInstances dataTypeName = [jsonInstance "ToJSON", jsonInstance "FromJSON"]
         )
       ) Nothing
 
+
+
 queryParamInstanceIRule :: String -> String -> InstRule SrcSpanInfo
 queryParamInstanceIRule paramDirection sumTypeName = 
   IRule noSrcSpan Nothing Nothing 
@@ -959,7 +962,7 @@ encodeCaseStatementOption (caseMatchOn, caseResult) =
 decodeCaseStatementOption :: (String, String) -> Alt SrcSpanInfo
 decodeCaseStatementOption (caseMatchOnStr, resultOfCaseMatch) = 
   Alt noSrcSpan 
-    (PLit noSrcSpan (Signless noSrcSpan) (Language.Haskell.Exts.String noSrcSpan caseMatchOnStr caseMatchOnStr ) ) 
+    (PLit noSrcSpan (Signless noSrcSpan) (LHE.String noSrcSpan caseMatchOnStr caseMatchOnStr ) ) 
     (UnGuardedRhs noSrcSpan (App noSrcSpan (dataConstructor "Just") (dataConstructor resultOfCaseMatch) )) 
     Nothing
 
@@ -1179,6 +1182,72 @@ defaultToParamInstance dataTypeName paramType =
         (typeConstructor dataTypeName) )) 
     Nothing
 
+defaultToSchemaInstance :: String -> Decl SrcSpanInfo
+defaultToSchemaInstance dataTypeName =
+  InstDecl noSrcSpan Nothing 
+    (IRule noSrcSpan Nothing Nothing 
+      (IHApp noSrcSpan 
+        (instanceHead "ToSchema") 
+        (typeConstructor dataTypeName)
+      )
+    ) Nothing
+
+toSchemaInstanceForSumType :: String -> [(String, String)] -> Decl SrcSpanInfo
+toSchemaInstanceForSumType typeName constructorValues = 
+  InstDecl noSrcSpan Nothing 
+    (IRule noSrcSpan Nothing Nothing 
+      (IHApp noSrcSpan 
+        (instanceHead "ToSchema") 
+        (typeConstructor typeName)
+      )
+    ) 
+  (Just [InsDecl noSrcSpan 
+  (PatBind noSrcSpan 
+    (PVar noSrcSpan 
+      (nameDecl "declareNamedSchema")
+    ) 
+    (UnGuardedRhs noSrcSpan 
+      (App noSrcSpan 
+        (Var noSrcSpan (UnQual noSrcSpan (nameDecl "genericDeclareNamedSchema"))) 
+        (Paren noSrcSpan 
+          (App noSrcSpan 
+            (App noSrcSpan 
+              (App noSrcSpan 
+                (App noSrcSpan 
+                  (App noSrcSpan 
+                    (dataConstructor "SchemaOptions")
+                    (Var noSrcSpan (Qual noSrcSpan (ModuleName noSrcSpan "Prelude") (nameDecl "id")))) 
+                    (Paren noSrcSpan 
+                      (Lambda noSrcSpan [PVar noSrcSpan (nameDecl "inputConst")] 
+                        (Case noSrcSpan 
+                          (Var noSrcSpan (UnQual noSrcSpan (nameDecl "inputConst"))) 
+                          (fmap caseMatchStatement constructorValues)
+                        )
+                      )
+                    )
+                ) 
+                (Var noSrcSpan (Qual noSrcSpan (ModuleName noSrcSpan "Prelude") (nameDecl "id")))
+              ) 
+              (dataConstructor "True")
+          ) 
+          (dataConstructor "False")
+        )
+      )
+    )
+  ) 
+  Nothing)])
+ where
+  caseMatchStatement (lowerCaseCons, typeConstructor) = 
+    (Alt noSrcSpan 
+      (PLit noSrcSpan (Signless noSrcSpan) (LHE.String noSrcSpan typeConstructor typeConstructor)) 
+      (UnGuardedRhs noSrcSpan (stringLiteral lowerCaseCons) ) Nothing)
+    -- Alt noSrcSpan 
+    --   (PLit noSrcSpan (Signless noSrcSpan) (LHE.String noSrcSpan "Pending" "Pending")) 
+    --   (UnGuardedRhs noSrcSpan (stringLiteral "pending") ) Nothing,
+    -- Alt noSrcSpan 
+    --   (PLit noSrcSpan (Signless noSrcSpan) (LHE.String noSrcSpan "Sold" "Sold")) 
+    --   (UnGuardedRhs noSrcSpan (stringLiteral "sold") ) Nothing
+    -- ]
 ---------------------------------------------------------------------------------------
 -- Support multiple versions of GHC (Use ifndef )
 -- for LTS 9.0 -> 1.18.2