Mdoc.hs

{-# LANGUAGE AllowAmbiguousTypes #-}

-- |
--
-- 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

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 = uncurry (getConfigs1 mPrefix) . simplifyJSONSchema

getConfigs1
  :: Maybe (NonEmpty String)
  -> Described Schema
  -> [Described ObjectMember]
  -> [Described Config]
getConfigs1 mPrefix schema members =
  maybe id (:) mParent
    $ concatMap (describeObjectMember schema.item 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

    let config =
          Config
            { name = renderPrefix <$> mPrefix
            , schema = schema.item
            }

    pure $ config <$ 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 -> (Described Schema, [Described ObjectMember])
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 -> first (fmap ListOf) $ simplifyJSONSchema s
  ObjectSchema ObjectAnySchema -> (required "any", [])
  ObjectSchema os -> (required "object", simplifyObjectSchema os)
  ValueSchema v -> primitive $ constSchema v
  AnyOfSchema ss -> anyOf ss
  OneOfSchema ss -> anyOf ss
  CommentSchema c s -> first (setHelpText c) $ simplifyJSONSchema s
  RefSchema t -> primitive $ Simple t
  WithDefSchema _ s -> simplifyJSONSchema s

simplifyObjectSchema :: ObjectSchema -> [Described ObjectMember]
simplifyObjectSchema = \case
  ObjectKeySchema k reqd s mcomment ->
    let (Described {item = 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
            }
        ]
  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 configs are null|x
anyOf :: NonEmpty JSONSchema -> (Described Schema, [Described ObjectMember])
anyOf (NullSchema :| [s]) = simplifyJSONSchema s
anyOf ss = bimap (redescribe AnyOf) concat $ unzip $ map simplifyJSONSchema $ toList ss

primitive :: Schema -> (Described Schema, [a])
primitive schema = (required 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