Pretty.hs

-- |
--
-- Module      : Mdoc.Pretty
-- Copyright   : (c) 2026 Patrick Brisbin
-- License     : AGPL-3
-- Maintainer  : pbrisbin@gmail.com
-- Stability   : experimental
-- Portability : POSIX
module Mdoc.Pretty
  ( -- * @--color@ option
    Color (..)
  , readColor
  , showColor

    -- * Annotations used in this project
  , Ann (..)
  , annToAnsi

    -- * Re-exports
  , module Prettyprinter
  , module Prettyprinter.Util

    -- * Rendering 'ToJSON' via 'Pretty'
  , Rendered (..)

    -- * Rendering 'Doc a' to 'Text'
  , putDoc
  , renderDoc
  , renderColor
  , renderPlain
  ) where

import Mdoc.Prelude

import Data.Aeson (Value)
import Data.Text.IO qualified as T
import Prettyprinter
import Prettyprinter.Render.Terminal (AnsiStyle, bold, color, colorDull)
import Prettyprinter.Render.Terminal qualified as Ansi
import Prettyprinter.Render.Text qualified as Text
import Prettyprinter.Util
import System.IO (Handle, hIsTerminalDevice)

data Ann
  = AnnComment
  | AnnCommand
  | AnnKeyword
  | AnnSymbol
  | AnnArgument
  | AnnQuote
  | AnnQuoted
  | AnnSpecial
  | AnnFile
  | AnnDiffAddition
  | AnnDiffDeletion
  | AnnDiffContext

data Color
  = -- | Behaves like 'ColorAuto' but is an identity under 'Semigroup'
    --
    -- This means you can give parsers this as a default, and still do (e.g.):
    --
    -- @
    -- color :: Color
    -- color = env.color <> opt.color
    -- @
    --
    -- Without finding that the @opt@ default clobbers an explicit @env@.
    ColorDefault
  | ColorAuto
  | ColorAlways
  | ColorNever

instance Semigroup Color where
  ColorDefault <> a = a
  a <> ColorDefault = a
  _ <> a = a

readColor :: String -> Either String Color
readColor = \case
  "auto" -> Right ColorAuto
  "always" -> Right ColorAlways
  "never" -> Right ColorNever
  other -> Left $ "Unknown color: " <> other <> ", expected auto|always|never"

showColor :: Color -> String
showColor = \case
  ColorDefault -> "auto"
  ColorAuto -> "auto"
  ColorAlways -> "always"
  ColorNever -> "never"

putDoc :: MonadIO m => Color -> Handle -> Doc Ann -> m ()
putDoc c h doc = do
  useColor <- case c of
    ColorDefault -> liftIO $ hIsTerminalDevice h
    ColorAuto -> liftIO $ hIsTerminalDevice h
    ColorAlways -> pure True
    ColorNever -> pure False

  liftIO $ T.hPutStrLn h $ renderDoc useColor doc

renderDoc :: Bool -> Doc Ann -> Text
renderDoc useColor doc
  | useColor = renderColor doc
  | otherwise = renderPlain doc

renderColor :: Doc Ann -> Text
renderColor =
  Ansi.renderStrict
    . layoutPretty defaultLayoutOptions
    . reAnnotate annToAnsi

renderPlain :: Doc Ann -> Text
renderPlain =
  Text.renderStrict
    . layoutPretty defaultLayoutOptions

annToAnsi :: Ann -> AnsiStyle
annToAnsi = \case
  AnnComment -> colorDull Ansi.White
  AnnCommand -> colorDull Ansi.Blue
  AnnKeyword -> color Ansi.Black
  AnnSymbol -> colorDull Ansi.White
  AnnArgument -> colorDull Ansi.Green
  AnnQuote -> colorDull Ansi.White
  AnnQuoted -> colorDull Ansi.Green
  AnnSpecial -> colorDull Ansi.Magenta
  AnnFile -> bold
  AnnDiffAddition -> colorDull Ansi.Green
  AnnDiffDeletion -> colorDull Ansi.Red
  AnnDiffContext -> colorDull Ansi.White

-- | Newtype for rendering to a JSON 'String' via 'Pretty'
--
-- @
-- data SomethingWithPretty
--   deriving 'ToJSON' via ('Rendered' SomethingWithPretty)
-- @
newtype Rendered a = Rendered
  { unwrap :: a
  }
  deriving stock (Eq, Functor, Show)
  deriving newtype (Monoid, Pretty, Semigroup)

instance Pretty a => ToJSON (Rendered a) where
  toJSON = toJSON . renderJSON . (.unwrap)
  toEncoding = toEncoding . renderJSON . (.unwrap)

renderJSON :: Pretty a => a -> Value
renderJSON = toJSON . renderPlain . pretty