Documentation.hs

{-# LANGUAGE OverloadedStrings #-}
{-|
Module      : HsLua.Packaging.Documentation
Copyright   : © 2020-2024 Albert Krewinkel
License     : MIT
Maintainer  : Albert Krewinkel <tarleb@hslua.org>

Provides a function to print documentation if available.
-}
module HsLua.Packaging.Documentation
  ( documentation
  , getdocumentation
  , registerDocumentation
  , pushModuleDoc
  , pushFunctionDoc
  , pushFieldDoc
  , docsField
  ) where

import Data.Version (showVersion)
import HsLua.Core as Lua
import HsLua.Marshalling
import HsLua.Packaging.Types
import HsLua.Typing (pushTypeSpec)

-- | Function that retrieves documentation.
documentation :: LuaError e => DocumentedFunction e
documentation =
  DocumentedFunction
  { callFunction = documentationHaskellFunction
  , functionName = "documentation"
  , functionDoc = FunctionDoc
    { functionDescription =
      "Retrieves the documentation of the given object."
    , parameterDocs =
      [ ParameterDoc
        { parameterName = "value"
        , parameterType = "any"
        , parameterDescription = "documented object"
        , parameterIsOptional = False
        }
      ]
    , functionResultsDocs =  ResultsDocList
      [ ResultValueDoc "string|nil" "docstring" ]
    , functionSince = Nothing
    }
  }

-- | Function that returns the documentation of a given object, or @nil@
-- if no documentation is available.
documentationHaskellFunction :: LuaError e => LuaE e NumResults
documentationHaskellFunction = isnoneornil (nthBottom 1) >>= \case
  True -> failLua "expected a non-nil value as argument 1"
  _ -> NumResults 1 <$ getdocumentation top

-- | Pushes the documentation for the element at the given stack index.
-- Returns the type of the documentation object.
getdocumentation :: LuaError e => StackIndex -> LuaE e Lua.Type
getdocumentation idx = do
  idx' <- absindex idx
  pushDocumentationTable
  pushvalue idx'
  rawget (nth 2) <* Lua.remove (nth 2)  -- remove documentation table

-- | Registers the object at the top of the stack as documentation for
-- the object at index @idx@. Pops the documentation of the stack.
registerDocumentation :: LuaError e
                      => StackIndex  -- ^ @idx@
                      -> LuaE e ()
registerDocumentation idx = do
  checkstack' 10 "registerDocumentation"  -- keep some buffer
  idx' <- absindex idx
  pushDocumentationTable
  pushvalue idx'    -- the documented object
  pushvalue (nth 3) -- documentation object
  rawset (nth 3)    -- add to docs table
  pop 2             -- docs table and documentation object

-- | Pushes the documentation table that's stored in the registry to the
-- top of the stack, creating it if necessary. The documentation table
-- is indexed by the documented objects, like module tables and
-- functions, and contains documentation strings as values.
--
-- The table is an ephemeron table, i.e., an entry gets garbage
-- collected if the key is no longer reachable.
pushDocumentationTable :: LuaError e => LuaE e ()
pushDocumentationTable = Lua.getfield registryindex docsField >>= \case
  Lua.TypeTable -> return () -- documentation table already initialized
  _ -> do
    pop 1            -- pop non-table value
    newtable         -- create documentation table
    pushstring "k"   -- Make it an "ephemeron table" and..
    setfield (nth 2) "__mode"  -- collect docs if documented object is GCed
    pushvalue top    -- add copy of table to registry
    setfield registryindex docsField

-- | Name of the registry field holding the documentation table. The
-- documentation table is indexed by the documented objects, like module
-- tables and functions, and contains documentation strings as values.
--
-- The table is an ephemeron table, i.e., an entry gets garbage
-- collected if the key is no longer reachable.
docsField :: Name
docsField = "HsLua docs"

-- | Pushes the documentation of a module as a table with string fields
-- @name@ and @description@.
pushModuleDoc :: LuaError e => Pusher e (Module e)
pushModuleDoc = pushAsTable
  [ ("name", pushName . moduleName)
  , ("description", pushText . moduleDescription)
  , ("fields", pushList pushFieldDoc . moduleFields)
  , ("functions", pushList pushFunctionDoc . moduleFunctions)
  ]

-- | Pushes the documentation of a field as a table with string fields
-- @name@ and @description@.
pushFieldDoc :: LuaError e => Pusher e (Field e)
pushFieldDoc = pushAsTable
  [ ("name", pushText . fieldName)
  , ("type", pushTypeSpec . fieldType)
  , ("description", pushText . fieldDescription)
  ]

-- | Pushes the documentation of a function as a table with string
-- fields, @name@, @description@, and @since@, sequence field
-- @parameters@, and sequence or string field @results@.
pushFunctionDoc :: LuaError e => Pusher e (DocumentedFunction e)
pushFunctionDoc fun = pushAsTable
  [ ("name", pushName . const (functionName fun))
  , ("description", pushText . functionDescription)
  , ("parameters", pushList pushParameterDoc . parameterDocs)
  , ("results", pushResultsDoc . functionResultsDocs)
  , ("since", maybe pushnil (pushString . showVersion) . functionSince)
  ] (functionDoc fun)

-- | Pushes the documentation of a parameter as a table with boolean
-- field @optional@ and string fields @name@, @type@, and @description@.
pushParameterDoc :: LuaError e => Pusher e ParameterDoc
pushParameterDoc = pushAsTable
  [ ("name", pushText . parameterName)
  , ("type", pushTypeSpec . parameterType)
  , ("description", pushText . parameterDescription)
  , ("optional", pushBool . parameterIsOptional)
  ]

-- | Pushes a the documentation for a function's return values as either
-- a simple string, or as a sequence of tables with @type@ and
-- @description@ fields.
pushResultsDoc :: LuaError e => Pusher e ResultsDoc
pushResultsDoc = \case
  ResultsDocMult desc -> pushText desc
  ResultsDocList resultDocs -> pushList pushResultValueDoc resultDocs

-- | Pushes the documentation of a single result value as a table with
-- fields @type@ and @description@.
pushResultValueDoc :: LuaError e => Pusher e ResultValueDoc
pushResultValueDoc = pushAsTable
  [ ("type", pushTypeSpec . resultValueType)
  , ("description", pushText . resultValueDescription)
  ]