Render.hs

-- | Render algebra for PluginSchema
module Synapse.Algebra.Render
  ( -- * Rendering Functions
    renderSchema
  , renderSchemaWith
  , renderMethod
  , renderMethodFull
  , renderChild
  , renderParams

    -- * Configuration
  , RenderStyle(..)
  , defaultStyle
  , compactStyle

    -- * Deprecation Rendering (IR-6)
  , deprecationMarker
  , formatDeprecationLine
  ) where

import Data.Text (Text)
import qualified Data.Text as T
import Data.Aeson (Value(..))
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import Data.List (intersperse, sortOn)
import Prettyprinter
import Prettyprinter.Render.Text (renderStrict)

import Synapse.Schema.Types
import Plexus.Schema.Recursive (DeprecationInfo(..), ParamSchema(..))

-- | Rendering style configuration
data RenderStyle = RenderStyle
  { rsIndent    :: !Int   -- ^ Spaces per indent level
  , rsShowHash  :: !Bool  -- ^ Show plugin/method hashes
  , rsShowTypes :: !Bool  -- ^ Show parameter types
  , rsCompact   :: !Bool  -- ^ Compact single-line format
  }
  deriving stock (Show, Eq)

-- | Default style: readable multi-line output
defaultStyle :: RenderStyle
defaultStyle = RenderStyle
  { rsIndent    = 2
  , rsShowHash  = False
  , rsShowTypes = True
  , rsCompact   = False
  }

-- | Compact style: single-line descriptions
compactStyle :: RenderStyle
compactStyle = defaultStyle { rsCompact = True }

-- | Render a PluginSchema
renderSchema :: PluginSchema -> Text
renderSchema = renderSchemaWith defaultStyle

-- | Render with custom style
renderSchemaWith :: RenderStyle -> PluginSchema -> Text
renderSchemaWith _style PluginSchema{..}
  | null psMethods && maybe True null psChildren = deprecationBanner <> headerText
  | otherwise = renderStrict $ layoutPretty layoutOpts doc
  where
    layoutOpts = LayoutOptions (AvailablePerLine 80 1.0)

    -- Activation-level deprecation banner (plain-text, rendered ahead
    -- of the compact header variant used for trivial schemas).
    deprecationBanner = case psDeprecation of
      Just di -> deprecationMarker <> " " <> formatDeprecationLine di <> "\n"
      Nothing -> ""

    headerText = psNamespace <> " v" <> psVersion <> "\n" <> psDescription <> "\n"

    -- Name line; decorated with the warning marker when the activation
    -- carries Just DeprecationInfo.
    namespaceHeading = case psDeprecation of
      Just _  -> pretty (deprecationMarker <> " " <> psNamespace)
                   <+> pretty ("v" <> psVersion)
      Nothing -> pretty psNamespace <+> pretty ("v" <> psVersion)

    -- Full deprecation notice rendered immediately below the heading
    -- when relevant, before the description block.
    deprecationNoticeDoc = case psDeprecation of
      Just di -> vsep
        [ emptyDoc
        , indent 2 $ pretty (formatDeprecationLine di)
        ]
      Nothing -> emptyDoc

    doc :: Doc ann
    doc = vsep
      [ namespaceHeading
      , deprecationNoticeDoc
      , emptyDoc
      , indent 2 $ align $ fillSep $ map pretty $ T.words psDescription
      , emptyDoc
      , childrenDoc
      , methodsDoc
      ]

    childrenDoc = case psChildren of
      Nothing -> emptyDoc
      Just [] -> emptyDoc
      Just children -> vsep
        [ pretty ("activations" :: Text)
        , emptyDoc
        , indent 2 $ vsep $ map renderChildDoc (sortOn csNamespace children)
        , emptyDoc
        ]

    methodsDoc
      | null psMethods = emptyDoc
      | otherwise = vsep
        [ pretty ("methods" :: Text)
        , emptyDoc
        , indent 2 $ vsep $ intersperse emptyDoc $ map renderMethodDoc (sortOn methodName psMethods)
        ]

    renderChildDoc child = fillBreak 12 (pretty $ csNamespace child)
      <+> align (fillSep $ map pretty $ T.words $ csDescription child)

    renderMethodDoc method =
      let nameText = case methodDeprecation method of
            Just _  -> deprecationMarker <> " " <> methodName method
            Nothing -> methodName method
          nameLine = fillBreak 12 (pretty nameText)
                       <+> align (fillSep $ map pretty $ T.words $ methodDescription method)
          depLines = case methodDeprecation method of
            Just di -> [indent 12 $ pretty (formatDeprecationLine di)]
            Nothing -> []
      in vsep $ [nameLine] ++ depLines ++ paramsDocs (methodParams method)

    paramsDocs Nothing = []
    paramsDocs (Just (Object o)) = case KM.lookup "properties" o of
      Just (Object props) ->
        let reqList = case KM.lookup "required" o of
              Just (Array arr) -> [t | String t <- foldr (:) [] arr]
              _ -> []
            propList = KM.toList props
            sorted = sortOn (\(k, _) -> (K.toText k `notElem` reqList, K.toText k)) propList
        in [indent 12 $ vsep $ map (renderParamDoc reqList) sorted]
      _ -> []
    paramsDocs _ = []

    renderParamDoc :: [Text] -> (K.Key, Value) -> Doc ann
    renderParamDoc required (name, propSchema) =
      let nameText = K.toText name
          isReq = nameText `elem` required
          (typ, desc) = extractTypeDesc propSchema
          flag = "--" <> T.replace "_" "-" nameText
          typStr = " <" <> typ <> ">" <> if isReq then "" else "?"
          descWords = if T.null desc then [] else map pretty (T.words desc)
      in fillBreak 20 (pretty flag <> pretty typStr)
         <+> align (fillSep descWords)

-- | Render a method (short form)
renderMethod :: MethodSchema -> Text
renderMethod = renderMethodWith defaultStyle

-- | Render a method with style
renderMethodWith :: RenderStyle -> MethodSchema -> Text
renderMethodWith RenderStyle{..} m =
  "  " <> padRight 16 (methodName m) <> methodDescription m
    <> if rsShowTypes then renderParams (methodParams m) else ""

-- | Render a method (full form with all params).
--
-- IR-14: per-parameter deprecation info carried on @methodParamSchemas@
-- is threaded into the param rendering so each deprecated parameter
-- receives the ⚠ marker and the formatted @DEPRECATED since …@ line.
-- Non-deprecated parameters render exactly as before.
renderMethodFull :: MethodSchema -> Text
renderMethodFull m = T.unlines $
  [ methodName m <> " - " <> methodDescription m
  , ""
  ] <> paramLines
  where
    paramLines = case methodParams m of
      Nothing -> ["  (no parameters)"]
      Just schema -> renderParamsFull (methodParamSchemas m) schema

-- | Render a child summary
renderChild :: ChildSummary -> Text
renderChild child =
  "  " <> padRight 16 (csNamespace child) <> csDescription child

-- | Render parameters inline
renderParams :: Maybe Value -> Text
renderParams Nothing = ""
renderParams (Just (Object o)) = case KM.lookup "properties" o of
  Just (Object props) ->
    let reqList = case KM.lookup "required" o of
          Just (Array arr) -> [t | String t <- foldr (:) [] arr]
          _ -> []
        propList = KM.toList props
        sorted = sortOn (\(k, _) -> (K.toText k `notElem` reqList, K.toText k)) propList
        rendered = map (renderParam reqList) sorted
    in if null rendered then "" else "\n" <> T.intercalate "\n" rendered
  _ -> ""
renderParams _ = ""

-- | Render a single parameter
renderParam :: [Text] -> (K.Key, Value) -> Text
renderParam required (name, propSchema) =
  let nameText = K.toText name
      isReq = nameText `elem` required
      flagName = T.replace "_" "-" nameText
      (typ, desc) = extractTypeDesc propSchema
      reqMarker = if isReq then "" else "?"
  in "      --" <> flagName <> " <" <> typ <> ">" <> reqMarker <> "  " <> desc

-- | Render parameters in full (for method help).
--
-- IR-14: the first argument carries optional per-parameter metadata
-- ('ParamSchema') advertised by IR-5 producers. Any parameter whose
-- 'paramDeprecation' is @Just@ is decorated with the ⚠ marker and a
-- trailing @DEPRECATED since … removed in … — …@ line. Parameters
-- without a matching entry render identically to pre-ticket output.
renderParamsFull :: Maybe [ParamSchema] -> Value -> [Text]
renderParamsFull paramSchemas (Object o) = case KM.lookup "properties" o of
  Just (Object props) ->
    let reqList = case KM.lookup "required" o of
          Just (Array arr) -> [t | String t <- foldr (:) [] arr]
          _ -> []
        propList = KM.toList props
        sorted = sortOn (\(k, _) -> (K.toText k `notElem` reqList, K.toText k)) propList
    in map (renderParamFull paramSchemas reqList) sorted
  _ -> []
renderParamsFull _ _ = []

-- | Look up per-parameter deprecation info by name, scanning the
--   optional ParamSchema list attached to the method.
lookupParamDeprecation :: Maybe [ParamSchema] -> Text -> Maybe DeprecationInfo
lookupParamDeprecation Nothing     _     = Nothing
lookupParamDeprecation (Just pss) pname =
  case filter ((== pname) . paramName) pss of
    (ps:_) -> paramDeprecation ps
    []     -> Nothing

renderParamFull :: Maybe [ParamSchema] -> [Text] -> (K.Key, Value) -> Text
renderParamFull paramSchemas required (name, propSchema) =
  let nameText = K.toText name
      isReq = nameText `elem` required
      (typ, desc) = extractTypeDesc propSchema
      reqText = if isReq then " (required)" else " (optional)"
      -- IR-14: deprecation decoration.  Marker prepended to the flag
      -- name, detail line appended after the description.  Pre-ticket
      -- non-deprecated output is preserved exactly when depInfo is
      -- Nothing.
      depInfo = lookupParamDeprecation paramSchemas nameText
      decoratedName = case depInfo of
        Just _  -> deprecationMarker <> " --" <> nameText
        Nothing -> "--" <> nameText
      depLine = case depInfo of
        Just di -> "\n      " <> formatDeprecationLine di
        Nothing -> ""
  in "  " <> decoratedName <> " <" <> typ <> ">" <> reqText
     <> "\n      " <> desc <> depLine

-- | Extract type and description from property schema
extractTypeDesc :: Value -> (Text, Text)
extractTypeDesc (Object po) =
  ( case KM.lookup "type" po of { Just (String t) -> t; _ -> "any" }
  , case KM.lookup "description" po of { Just (String d) -> d; _ -> "" }
  )
extractTypeDesc _ = ("any", "")

-- | Pad text to a minimum width
padRight :: Int -> Text -> Text
padRight n t
  | T.length t >= n = t <> " "
  | otherwise = t <> T.replicate (n - T.length t) " "

-- ============================================================================
-- Deprecation Rendering (IR-6)
-- ============================================================================

-- | Visible marker for deprecated surfaces.
--
--   Plain UTF-8 — a TTY/color-aware renderer lives at the CLI boundary;
--   this module only emits text markers.
deprecationMarker :: Text
deprecationMarker = "\x26A0"  -- ⚠

-- | Format the one-line deprecation detail, e.g.
--   @DEPRECATED since 0.5, removed in 0.7 — use move_doc@.
formatDeprecationLine :: DeprecationInfo -> Text
formatDeprecationLine di =
  "DEPRECATED since " <> depSince di
    <> ", removed in " <> depRemovedIn di
    <> " \x2014 " <> depMessage di   -- em-dash