Support x-tie-haskell-name to override field names

scarf-sh · Apr 7, 2023 · e877363 · e877363
1 parent 4e9764f
commit e877363
Show file tree

Hide file tree

Showing 26 changed files with 385 additions and 319 deletions.
diff --git a/Request.template.hs b/Request.template.hs
@@ -52,7 +52,7 @@ import Web.HttpApiData
   )
 
 pathVariable ::
-  FromHttpApiData a =>
+  (FromHttpApiData a) =>
   -- | Path variable value
   Text ->
   (a -> Wai.Application) ->
@@ -73,27 +73,27 @@ data Style
 
 newtype CommaDelimitedValue a = CommaDelimitedValue {unCommaDelimitedValue :: [a]}
 
-instance FromHttpApiData a => FromHttpApiData (CommaDelimitedValue a) where
+instance (FromHttpApiData a) => FromHttpApiData (CommaDelimitedValue a) where
   parseUrlPiece input = do
     xs <- parseUrlPieces (Text.splitOn "," input)
     pure (CommaDelimitedValue xs)
 
 newtype SpaceDelimitedValue a = SpaceDelimitedValue {unSpaceDelimitedValue :: [a]}
 
-instance FromHttpApiData a => FromHttpApiData (SpaceDelimitedValue a) where
+instance (FromHttpApiData a) => FromHttpApiData (SpaceDelimitedValue a) where
   parseUrlPiece input = do
     xs <- parseUrlPieces (Text.splitOn " " input)
     pure (SpaceDelimitedValue xs)
 
 newtype PipeDelimitedValue a = PipeDelimitedValue {unPipeDelimitedValue :: [a]}
 
-instance FromHttpApiData a => FromHttpApiData (PipeDelimitedValue a) where
+instance (FromHttpApiData a) => FromHttpApiData (PipeDelimitedValue a) where
   parseUrlPiece input = do
     xs <- parseUrlPieces (Text.splitOn "|" input)
     pure (PipeDelimitedValue xs)
 
 requiredQueryParameters ::
-  FromHttpApiData a =>
+  (FromHttpApiData a) =>
   Style ->
   ByteString ->
   (NonEmpty.NonEmpty a -> Wai.Application) ->
@@ -144,7 +144,7 @@ requiredQueryParameters style name withParam =
         )
 
 optionalQueryParameters ::
-  FromHttpApiData a =>
+  (FromHttpApiData a) =>
   Style ->
   ByteString ->
   (Maybe (NonEmpty.NonEmpty a) -> Wai.Application) ->
@@ -186,7 +186,7 @@ optionalQueryParameters style name withParam =
         )
 
 requiredQueryParameter ::
-  FromHttpApiData a =>
+  (FromHttpApiData a) =>
   ByteString ->
   (a -> Wai.Application) ->
   Wai.Application
@@ -205,7 +205,7 @@ requiredQueryParameter name withParam = \request respond ->
 {-# INLINEABLE requiredQueryParameter #-}
 
 optionalQueryParameter ::
-  FromHttpApiData a =>
+  (FromHttpApiData a) =>
   ByteString ->
   -- | Allow empty, e.g. "x="
   Bool ->
@@ -229,7 +229,7 @@ optionalQueryParameter name allowEmpty withParam = \request respond ->
 {-# INLINEABLE optionalQueryParameter #-}
 
 optionalHeader ::
-  FromHttpApiData a =>
+  (FromHttpApiData a) =>
   HeaderName ->
   (Maybe a -> Wai.Application) ->
   Wai.Application
@@ -246,7 +246,7 @@ optionalHeader name withHeader = \request respond ->
 {-# INLINEABLE optionalHeader #-}
 
 requiredHeader ::
-  FromHttpApiData a =>
+  (FromHttpApiData a) =>
   HeaderName ->
   (a -> Wai.Application) ->
   Wai.Application
@@ -267,11 +267,11 @@ data BodyParser a
       Network.HTTP.Media.MediaType
       ((a -> Wai.Application) -> Wai.Application)
 
-jsonBodyParser :: FromJSON a => BodyParser a
+jsonBodyParser :: (FromJSON a) => BodyParser a
 jsonBodyParser = BodyParser "application/json" parseRequestBodyJSON
 {-# INLINE jsonBodyParser #-}
 
-formBodyParser :: FromForm a => BodyParser a
+formBodyParser :: (FromForm a) => BodyParser a
 formBodyParser = BodyParser "application/xxx-form-urlencoded" parseRequestBodyForm
 {-# INLINE formBodyParser #-}
 
@@ -294,7 +294,7 @@ parseRequestBody parsers withBody = \request respond -> do
       respond (Wai.responseBuilder (toEnum 415) [] mempty)
 {-# INLINE parseRequestBody #-}
 
-parseRequestBodyJSON :: FromJSON a => (a -> Wai.Application) -> Wai.Application
+parseRequestBodyJSON :: (FromJSON a) => (a -> Wai.Application) -> Wai.Application
 parseRequestBodyJSON withBody = \request respond -> do
   result <- parseWith (Wai.getRequestBodyChunk request) Data.Aeson.Parser.json' mempty
   case eitherResult result of
@@ -308,7 +308,7 @@ parseRequestBodyJSON withBody = \request respond -> do
           withBody body request respond
 {-# INLINEABLE parseRequestBodyJSON #-}
 
-parseRequestBodyForm :: FromForm a => (a -> Wai.Application) -> Wai.Application
+parseRequestBodyForm :: (FromForm a) => (a -> Wai.Application) -> Wai.Application
 parseRequestBodyForm withBody = \request respond -> do
   -- Reads the body using lazy IO. Not great but it gets us
   -- going and is pretty local.

diff --git a/Response.template.hs b/Response.template.hs
@@ -15,7 +15,7 @@ import qualified Network.Wai
 
 type NDJSON element = ((element -> IO ()) -> IO () -> IO ())
 
-responseNDJSON :: Data.Aeson.ToJSON element => Network.HTTP.Types.Status -> Network.HTTP.Types.ResponseHeaders -> NDJSON element -> Network.Wai.Response
+responseNDJSON :: (Data.Aeson.ToJSON element) => Network.HTTP.Types.Status -> Network.HTTP.Types.ResponseHeaders -> NDJSON element -> Network.Wai.Response
 responseNDJSON status responseHeaders stream =
   Network.Wai.responseStream status responseHeaders $ \emit flush ->
     stream

diff --git a/bin/Main.hs b/bin/Main.hs
@@ -3,6 +3,7 @@
 
 module Main (main) where
 
+import Data.Version (showVersion)
 import Options.Applicative
   ( Parser,
     auto,
@@ -26,11 +27,10 @@ import Options.Applicative
     switch,
     value,
   )
+import Paths_tie (version)
 import System.Environment (getArgs)
 import Tie (fileWriter, generate)
 import Prelude hiding (Option)
-import Data.Version (showVersion)
-import Paths_tie (version)
 
 data Input = Input
   { outputDirectory :: FilePath,
@@ -82,10 +82,12 @@ options =
       )
 
 versioner :: Parser (a -> a)
-versioner = infoOption ("tie " <> showVersion version)
-  ( long "version"
-  <> help "Print Tie version"
-  )
+versioner =
+  infoOption
+    ("tie " <> showVersion version)
+    ( long "version"
+        <> help "Print Tie version"
+    )
 
 main :: IO ()
 main = do

diff --git a/src/Tie.hs b/src/Tie.hs
@@ -77,13 +77,13 @@ import Tie.Writer (Writer, fileWriter, withTestWriter)
 import Prelude hiding (Type)
 
 -- | Our own version of nubOrd that both nubs and sorts
-nubOrd :: Ord a => [a] -> [a]
+nubOrd :: (Ord a) => [a] -> [a]
 nubOrd = Set.toList . Set.fromList
 
 -- | Read an OpenAPI spec. Throws in case it can not
 -- be read or deserialized.
 readOpenApiSpec ::
-  MonadIO m =>
+  (MonadIO m) =>
   FilePath ->
   m OpenApi.OpenApi
 readOpenApiSpec filePath =
@@ -104,7 +104,7 @@ specComponents =
 
 -- | Normalizes a 'Type' by extracting the contained inline type
 -- definitions.
-normalize :: Monad m => Name -> Type -> m (Type, [(Name, Type)])
+normalize :: (Monad m) => Name -> Type -> m (Type, [(Name, Type)])
 normalize =
   normalizeType
     ( \enclosingType fieldName ->
@@ -125,7 +125,7 @@ normalize =
 -- unnamed types left:
 --   forall x. normalize x == []
 --  where x is an element of the result of normalizedTypes
-normalizeTypes :: Monad m => [(Name, Type)] -> m [(Name, Type)]
+normalizeTypes :: (Monad m) => [(Name, Type)] -> m [(Name, Type)]
 normalizeTypes types =
   concat
     <$> traverse
@@ -137,7 +137,7 @@ normalizeTypes types =
       types
 
 generate ::
-  MonadIO m =>
+  (MonadIO m) =>
   Writer m ->
   -- | Package name
   Text ->

diff --git a/src/Tie/Codegen/Operation.hs b/src/Tie/Codegen/Operation.hs
@@ -32,7 +32,7 @@ import Tie.Operation
 import Tie.Resolve (Resolver)
 import Tie.Type (isArrayType, namedType)
 
-codegenOperations :: Monad m => Resolver m -> [Operation] -> m (PP.Doc ann)
+codegenOperations :: (Monad m) => Resolver m -> [Operation] -> m (PP.Doc ann)
 codegenOperations resolver operations = do
   let groupedOperations :: Map.Map Path [Operation]
       groupedOperations =
@@ -121,7 +121,7 @@ codegenOperations resolver operations = do
 
   pure (dataApiDecl <> PP.line <> PP.line <> apiDecl <> PP.line <> inlineablePragma)
 
-codegenApiType :: Monad m => Resolver m -> [Operation] -> m (PP.Doc ann)
+codegenApiType :: (Monad m) => Resolver m -> [Operation] -> m (PP.Doc ann)
 codegenApiType resolver operations = do
   operationsFieldsCode <- traverse (codegenApiTypeOperation resolver) operations
   let fieldsCode =
@@ -140,7 +140,7 @@ codegenApiType resolver operations = do
             <> "}"
   pure dataDecl
 
-codegenApiTypeOperation :: Monad m => Resolver m -> Operation -> m (PP.Doc ann)
+codegenApiTypeOperation :: (Monad m) => Resolver m -> Operation -> m (PP.Doc ann)
 codegenApiTypeOperation resolver Operation {..} = do
   paramsCode <-
     sequence $
@@ -164,7 +164,7 @@ codegenApiTypeOperation resolver Operation {..} = do
               (\x y -> x <+> "->" <> PP.line <> y)
               ( paramsCode
                   ++ [ codegenRequestBodyComment body <> codegenRequestBodyType body
-                       | Just body<- [requestBody]
+                       | Just body <- [requestBody]
                      ]
                   ++ ["m" <+> toApiResponseTypeName name]
               )
@@ -194,7 +194,7 @@ codegenApiTypeOperation resolver Operation {..} = do
       code <- codegenParamSchema param
       pure (codegenParamComment param <> code)
 
-codegenOperation :: Monad m => Resolver m -> [Operation] -> m (PP.Doc ann)
+codegenOperation :: (Monad m) => Resolver m -> [Operation] -> m (PP.Doc ann)
 codegenOperation resolver operations@(Operation {path} : _) =
   pure $
     codegenPathGuard path $
@@ -297,8 +297,14 @@ codegenRequestBodyGuard requestBody continuation = case requestBody of
   Nothing ->
     continuation
   Just RequestBody {provideRequestBodyAsStream = True} ->
-    "let" <+> "body" <+> "=" <+> "Network.Wai.getRequestBodyChunk" <+> "request" <+> "in" <> PP.line <>
-      PP.indent 4 ("(" <> continuation <> ")")
+    "let"
+      <+> "body"
+      <+> "="
+      <+> "Network.Wai.getRequestBodyChunk"
+      <+> "request"
+      <+> "in"
+        <> PP.line
+        <> PP.indent 4 ("(" <> continuation <> ")")
   Just RequestBody {jsonRequestBodyContent} ->
     let parsers =
           -- TODO support forms

diff --git a/src/Tie/Codegen/Response.hs b/src/Tie/Codegen/Response.hs
@@ -45,7 +45,7 @@ import Tie.Resolve (Resolver)
 
 -- | Generate code for the responses of an 'Operation'.
 codegenResponses ::
-  Monad m =>
+  (Monad m) =>
   Resolver m ->
   -- | Aux. Response module name TODO make this a proper type
   Text ->

diff --git a/src/Tie/Codegen/Schema.hs b/src/Tie/Codegen/Schema.hs
@@ -52,7 +52,7 @@ import Tie.Type
 import Prelude hiding (Type)
 
 -- | Generate code for a parameter type.
-codegenParamSchema :: Monad m => Param -> m (Doc ann)
+codegenParamSchema :: (Monad m) => Param -> m (Doc ann)
 codegenParamSchema Param {schema, required} =
   fmap (codegenRequiredOptionalFieldType required) $
     case schema of
@@ -93,7 +93,7 @@ codegenHeaderSchema Header {schema, required} =
         error "Header without schema"
 
 -- | Generate code for a schema.
-codegenSchema :: Monad m => Name -> Type -> m (Doc ann)
+codegenSchema :: (Monad m) => Name -> Type -> m (Doc ann)
 codegenSchema typName typ
   | Just Enumeration {alternatives, includeNull} <- isEnumType typ =
       pure (codegenEnumeration typName alternatives includeNull)
@@ -126,7 +126,7 @@ codegenArrayType typeName elemType =
   "type" <+> toDataTypeName typeName <+> "=" <+> "[" <+> codegenFieldType elemType <+> "]"
 
 codegenOneOfType ::
-  Monad m =>
+  (Monad m) =>
   -- | Given a variant type name, returns the discrimintor property
   -- and value, if any
   (Name -> Maybe (Text, Text)) ->
@@ -263,7 +263,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 :: (Monad m) => Name -> ObjectType (Named Type) -> m (Doc ann)
 codegenObjectType typName ObjectType {..}
   -- for empty, free form objects, just generate a type synonym for Value.
   | Just FreeForm <- additionalProperties,
@@ -366,12 +366,14 @@ codegenObjectType typName ObjectType {..}
                         4
                         ( PP.concatWith
                             (\x y -> x <> "," <> PP.line <> y)
-                            [ toFieldName field
+                            [ toFieldName haskellField
                                 <+> "::"
                                 <+> codegenRequiredOptionalFieldType
                                   (HashSet.member field requiredProperties)
                                   (codegenFieldType fieldType)
-                              | (field, fieldType) <- orderedProperties
+                              | (field, fieldType) <- orderedProperties,
+                                let haskellField =
+                                      HashMap.lookupDefault field field haskellFieldNames
                             ]
                         )
                       <> PP.line
@@ -403,9 +405,11 @@ codegenObjectType typName ObjectType {..}
                               <+> PP.align
                                 ( PP.concatWith
                                     (\x y -> x <> "," <> PP.line <> y)
-                                    [ "\"" <> toJsonFieldName field <> "\"" <+> "Data.Aeson..=" <+> toFieldName field
+                                    [ "\"" <> toJsonFieldName field <> "\"" <+> "Data.Aeson..=" <+> toFieldName haskellField
                                       | (field, _) <- orderedProperties,
-                                        HashSet.member field requiredProperties
+                                        HashSet.member field requiredProperties,
+                                        let haskellField =
+                                              HashMap.lookupDefault field field haskellFieldNames
                                     ]
                                 )
                                 <> PP.line
@@ -417,16 +421,18 @@ codegenObjectType typName ObjectType {..}
                                         <+> "["
                                         <+> "\"" <> toJsonFieldName field <> "\""
                                         <+> "Data.Aeson..="
-                                        <+> toFieldName field
+                                        <+> toFieldName haskellField
                                         <+> "|"
                                         <+> "Just"
-                                        <+> toFieldName field
+                                        <+> toFieldName haskellField
                                         <+> "<-"
-                                        <+> "[" <> toFieldName field <> "]"
+                                        <+> "[" <> toFieldName haskellField <> "]"
                                         <+> "]"
                                     )
                                     | (field, _) <- orderedProperties,
-                                      not (HashSet.member field requiredProperties)
+                                      not (HashSet.member field requiredProperties),
+                                      let haskellField =
+                                            HashMap.lookupDefault field field haskellFieldNames
                                   ]
                                 <> ")"
                           )
@@ -449,7 +455,7 @@ codegenObjectType typName ObjectType {..}
                                           "Data.Aeson.Encoding.pair"
                                             <+> "\"" <> toJsonFieldName field <> "\""
                                             <+> "(" <> "Data.Aeson.toEncoding"
-                                            <+> toFieldName field <> ")"
+                                            <+> toFieldName haskellField <> ")"
                                         else
                                           "maybe"
                                             <+> "mempty"
@@ -458,8 +464,10 @@ codegenObjectType typName ObjectType {..}
                                             <+> "\"" <> toJsonFieldName field <> "\""
                                             <+> "."
                                             <+> "Data.Aeson.toEncoding" <> ")"
-                                            <+> toFieldName field
-                                      | (field, _) <- orderedProperties
+                                            <+> toFieldName haskellField
+                                      | (field, _) <- orderedProperties,
+                                        let haskellField =
+                                              HashMap.lookupDefault field field haskellFieldNames
                                     ]
                                 )
                                 <> PP.line