records-edsl-deriving-openapi3-0.1.0: Records/EDSL/Deriving/ToSchema.hs

module Records.EDSL.Deriving.ToSchema (deriveToSchema) where

import Data.OpenApi qualified as O
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Syntax qualified as TH
import Optics
import Records.EDSL.Deriving.Type
import Records.EDSL.Description
import Relude

deriveToSchema :: Deriver
deriveToSchema = deriver #openapi3_ToSchema \RecordDesc {typeNameText, typeName, fields, description} ->
  [d|
    instance O.ToSchema $(TH.conT typeName) where
      declareNamedSchema _ =
        O.NamedSchema (Just $(TH.lift typeNameText)) <$> $(qToSchemaBody fields description)
    |]

qToSchemaBody :: [FieldDesc TH.Name] -> Maybe Description -> TH.ExpQ
qToSchemaBody fields tydescription =
  [|
    do
      properties <- sequence $(TH.listE (map qProperty fields))
      pure $
        (mempty :: O.Schema)
          & #type ?~ O.OpenApiObject
          & #description
            ?~ $( TH.lift case tydescription of
                    Just Description {text} -> text
                    Nothing -> mempty :: Text
                )
          & #properties .~ fromList properties
          & #required .~ $(TH.listE [TH.lift nameText | FieldDesc {nameText, isOptional} <- fields, not isOptional])
    |]
  where
    qProperty :: FieldDesc TH.Name -> TH.ExpQ
    qProperty fld@FieldDesc {nameText, type_} =
      [|
        O.declareSchemaRef (Proxy :: Proxy $(pure (qFieldJSONTypeDesc type_).type_))
          <&> \prop -> ($(TH.lift nameText), $(setFieldDescription fld) prop)
        |]

    setFieldDescription :: FieldDesc TH.Name -> TH.ExpQ
    setFieldDescription FieldDesc {description, type_} = case description of
      Nothing -> [|identity|]
      Just Description {isExtra = False, text} ->
        [|
          \case
            O.Ref ref -> refWithDescription ref $(TH.lift text)
            O.Inline i ->
              O.Inline $
                i
                  & #description %~ \mdesc -> Just $(TH.lift text) `appendDescription` mdesc
          |]
      Just Description {isExtra = True, text} ->
        [|
          let baseDesc = O.toSchema (Proxy :: Proxy $(pure (qFieldJSONTypeDesc type_).type_)) ^. #description
          in \case
               O.Ref ref -> refWithDescription ref $(TH.lift text)
               O.Inline i ->
                 O.Inline $
                   i
                     & #description %~ \mdesc -> Just $(TH.lift text) `appendDescription` mdesc `appendDescription` baseDesc
          |]

refWithDescription :: O.Reference -> Text -> O.Referenced O.Schema
refWithDescription ref description =
  O.Inline $
    mempty
      & #description ?~ description
      & #allOf ?~ [O.Ref ref]

appendDescription :: Maybe Text -> Maybe Text -> Maybe Text
appendDescription (Just a) (Just b) = Just (a <> "\n" <> b)
appendDescription a b = a <> b