List.hs

-- |
--
-- Module      : Mdoc.Data.List
-- Copyright   : (c) 2026 Patrick Brisbin
-- License     : AGPL-3
-- Maintainer  : pbrisbin@gmail.com
-- Stability   : experimental
-- Portability : POSIX
module Mdoc.Data.List
  ( List
  , fromNonEmpty
  , singleton

    -- * Width
  , Width (..)
  , Indent
  , ByItem
  ) where

import Mdoc.Prelude

import Data.Aeson (Value (..), object, (.=))
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Kind (Constraint, Type)
import Data.List.NonEmpty qualified as NE
import Data.Text qualified as T
import Mdoc.Syntax

type List :: forall {k}. k -> Type -> Type
newtype List t a = List
  { items :: NonEmpty a
  }
  deriving stock (Eq, Generic, Show)
  deriving (Semigroup) via Generically (List t a)

instance (Ord a, ToJSON a, Width t a) => ToJSON (List t a) where
  toJSON l =
    object
      [ "width" .= renderedWidth (Proxy @t) items
      , "items" .= items
      ]
   where
    items :: NonEmpty a
    items = NE.sort $ NE.nub l.items

fromNonEmpty :: NonEmpty a -> List t a
fromNonEmpty = foldMap1 singleton

singleton :: a -> List t a
singleton a = List {items = pure a}

data Indent

data ByItem

type Width :: forall {k}. k -> Type -> Constraint
class Width t a where
  renderedWidth :: Proxy t -> NonEmpty a -> MacroArg

instance Width Indent a where
  renderedWidth _ _ = "indent"

instance ToJSON a => Width ByItem a where
  renderedWidth _ =
    Quoted
      . esc
      . maximumBy (comparing T.length)
      . fmap headWidth

headWidth :: ToJSON a => a -> Text
headWidth = go . T.words . getHead . toJSON
 where
  getHead :: Value -> Text
  getHead v = fromMaybe "" $ do
    Object km <- pure v
    String t <- KeyMap.lookup "head" km
    pure t

  go :: [Text] -> Text
  go = \case
    [] -> ""
    ("Ev" : rest) -> go rest
    ("Ns" : rest) -> go rest
    ("Ar" : rest) -> go rest
    ("Op" : rest) -> "[" <> go rest <> "]"
    ("Fl" : rest) -> "-" <> go rest
    ("|" : rest) -> "|" <> go rest -- assume Ns-wrapped
    ("," : rest) -> " , " <> go rest -- assume not Ns-wrapped
    (x : rest) -> x <> go rest