Mdoc.hs

{-# LANGUAGE AllowAmbiguousTypes #-}

-- |
--
-- Module      : Autodocodec.Schema.Mdoc
-- Copyright   : (c) 2026 Patrick Brisbin
-- License     : AGPL-3
-- Maintainer  : pbrisbin@gmail.com
-- Stability   : experimental
-- Portability : POSIX
--
-- A small, semi-representative, not type-checked example:
--
-- @
-- data Person = Person
--   { name :: Text
--   , age :: Int
--   }
--
-- instance HasCodec Person where
--   codec = object "Person" $ Person
--     <$> requiredField "name" "Their name" .= (.name)
--     <*> requiredField "age" "Their age" .= (.age)
--
-- schema :: JSONSchema
-- schema = jsonSchemaViaCodec @Person
-- @
--
-- @
-- .\" Generates this mandoc source
-- .Sh DESCIPTION
-- .Bl ...
-- .It Cm name : string
-- Their name
-- .It Cm age : number
-- Their age
-- .El
-- @
--
-- Which renders something like:
--
-- @
-- DESCRIPTION
--   name : string      Their name
--
--   age : object      Their age
--
-- @
module Autodocodec.Schema.Mdoc
  ( addToMan5
  , addToMan5ViaCodec
  , 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 Data.List (intercalate)
import Data.Text qualified as T
import Mdoc.Gen.Config
import Mdoc.Gen.Described
import Mdoc.Gen.Man5
import Mdoc.Gen.Optionality
import Mdoc.Optics

-- |
--
-- This uses 'getConfigs' without prefix, resulting in output like:
--
-- @
-- foo : string
-- A foo field that is string
--
-- bar : number
-- A bar field that is a number
-- @
--
-- for an object, or
--
-- @
-- : string
-- @
--
-- for a primitive
addToMan5 :: JSONSchema -> Man5 -> Man5
addToMan5 js m =
  m
    & field @"name" % field @"description" %~ getComment js
    & field @"configs" <>~ getConfigs Nothing js

addToMan5ViaCodec :: forall a. HasCodec a => Man5 -> Man5
addToMan5ViaCodec = addToMan5 $ jsonSchemaViaCodec @a

getComment :: JSONSchema -> String -> String
getComment js existing = case js of
  CommentSchema comment _
    | null existing
    , not $ T.null comment ->
        unpack comment
  _ -> existing

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
            , exampleLines = Nothing
            }

    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 {}) -> onLast (<> "[]") p <> member.item.keys
    (Just p, _) -> p <> member.item.keys

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

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
            , helpLines = nonEmpty . lines . unpack =<< 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}@; e.g. it must match the
-- @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