Mdoc.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# OPTIONS_GHC -Wno-ambiguous-fields #-}

-- |
--
-- Module      : Autodocodec.Schema.Mdoc
-- Copyright   : (c) 2026 Patrick Brisbin
-- License     : AGPL-3
-- Maintainer  : pbrisbin@gmail.com
-- Stability   : experimental
-- Portability : POSIX
--
-- See "Mdoc.Examples.Person".
module Autodocodec.Schema.Mdoc
  ( getPage
  , getPageViaCodec

    -- * Re-used by "OptEnvConf.Mdoc"
  , getConfigs
  ) where

import Mdoc.Prelude

import Autodocodec (HasCodec)
import Autodocodec.Schema
  ( JSONSchema (..)
  , ObjectSchema (..)
  , jsonSchemaViaCodec
  )
import Autodocodec.Schema qualified as JSONSchema
import Data.Aeson (Value)
import Data.Aeson qualified as Aeson
import Mdoc.Data.Config
import Mdoc.Data.Described
import Mdoc.Data.Optionality
import Mdoc.Data.Page
import Mdoc.Optics
import Mdoc.Syntax (textToMdoc)

getPage :: JSONSchema -> Page
getPage js = foldr addConfig mempty $ getConfigs Nothing js

getPageViaCodec :: forall a. HasCodec a => Page
getPageViaCodec = getPage $ jsonSchemaViaCodec @a

getConfigs :: Maybe (NonEmpty String) -> JSONSchema -> [Described Config]
getConfigs mPrefix = getConfigs1 mPrefix . simplifyJSONSchema

getConfigs1 :: Maybe (NonEmpty String) -> Simplified -> [Described Config]
getConfigs1 mPrefix Simplified {comment, schema, members} =
  maybe id (:) mParent
    $ concatMap (describeObjectMember schema mPrefix) members
 where
  mParent = do
    -- This makes sure the no-prefix + complex case doesn't look like:
    --
    --   : object
    --
    --   bar : this
    --   baz : that
    --
    -- But instead is,
    --
    --   bar : this
    --   baz : that
    --
    guard $ isJust mPrefix || null members
    pure
      $ Described
        { item = Config {name = renderPrefix <$> mPrefix, schema}
        , optionality = Required
        , multiple = False
        , help = textToMdoc =<< comment
        , example = Nothing
        }

data Simplified = Simplified
  { comment :: Maybe Text
  , schema :: Schema
  , members :: [Described ObjectMember]
  }

setComment :: Text -> Simplified -> Simplified
setComment c s = s {comment = Just c}

mapSchema :: (Schema -> Schema) -> Simplified -> Simplified
mapSchema f s = s {schema = f s.schema}

data ObjectMember = ObjectMember
  { keys :: NonEmpty String
  , schema :: Schema
  , members :: [Described ObjectMember]
  }

describeObjectMember
  :: Schema
  -- ^ Parent schema
  -> Maybe (NonEmpty String)
  -> Described ObjectMember
  -> [Described Config]
describeObjectMember pschema mPrefix member =
  (config <$ member)
    : concatMap
      (describeObjectMember member.item.schema $ Just prefix)
      member.item.members
 where
  prefix = case (mPrefix, pschema) of
    (Nothing, ListOf {}) -> pure "[]" <> member.item.keys
    (Nothing, _) -> member.item.keys
    (Just p, ListOf {}) -> (p & last1 <>~ "[]") <> member.item.keys
    (Just p, _) -> p <> member.item.keys

  config =
    Config
      { name = Just $ renderPrefix prefix
      , schema = member.item.schema
      }

simplifyJSONSchema :: JSONSchema -> Simplified
simplifyJSONSchema = \case
  AnySchema -> primitive "any"
  NullSchema -> primitive "null"
  BoolSchema -> primitive "boolean"
  StringSchema {} -> primitive "string"
  IntegerSchema {} -> primitive "number"
  NumberSchema {} -> primitive "number"
  MapSchema s -> simplifyJSONSchema s
  ArraySchema s -> mapSchema ListOf $ simplifyJSONSchema s
  ObjectSchema ObjectAnySchema -> Simplified Nothing "any" []
  ObjectSchema os -> Simplified Nothing "object" $ simplifyObjectSchema os
  ValueSchema v -> primitive $ constSchema v
  AnyOfSchema ss -> anyOf ss
  OneOfSchema ss -> anyOf ss
  CommentSchema c s -> setComment c $ simplifyJSONSchema s
  RefSchema t -> primitive $ Simple t
  WithDefSchema _ s -> simplifyJSONSchema s

simplifyObjectSchema :: ObjectSchema -> [Described ObjectMember]
simplifyObjectSchema = \case
  ObjectKeySchema k reqd s mcomment ->
    let Simplified {schema, members} = simplifyJSONSchema s
    in  [ Described
            { item = ObjectMember {keys = pure $ unpack k, schema, members}
            , optionality = case reqd of
                JSONSchema.Required -> Required
                _ -> Optional
            , multiple = False
            , help = textToMdoc =<< mcomment
            , example = Nothing
            }
        ]
  ObjectAllOfSchema os -> concatMap simplifyObjectSchema $ toList os
  ObjectAnyOfSchema os -> concatMap simplifyObjectSchema $ toList os
  ObjectOneOfSchema os -> concatMap simplifyObjectSchema $ toList os
  ObjectAnySchema -> error "panic! we should not have hit this case"

-- Work around bug in opt-env-conf where all schemas are null|x
anyOf :: NonEmpty JSONSchema -> Simplified
anyOf (NullSchema :| [s]) = simplifyJSONSchema s
anyOf ss =
  Simplified
    { comment = Nothing
    , schema = AnyOf $ toList $ (.schema) <$> ne
    , members = concat $ toList $ (.members) <$> ne
    }
 where
  ne :: NonEmpty Simplified
  ne = simplifyJSONSchema <$> ss

primitive :: Schema -> Simplified
primitive schema = Simplified Nothing schema []

-- | 'ValueSchema' is only used for @const {value}@; i.e. it must match the
-- given @Value@ literally. We don't render complex values, but rendering simple
-- types is how an enum, defined as @[{const:error, const:warning}]@, is
-- correctly rendered as @error|warning@.
constSchema :: Value -> Schema
constSchema = \case
  Aeson.Object {} -> "json"
  Aeson.Array {} -> "json"
  Aeson.String t -> Simple t
  Aeson.Number n -> Simple $ pack $ show n
  Aeson.Bool b -> Simple $ pack $ show b
  Aeson.Null -> "null"

renderPrefix :: NonEmpty String -> String
renderPrefix = intercalate "." . toList