Pretty.hs

{-# LANGUAGE CPP #-}
module Options.Applicative.Help.Pretty
  ( module Prettyprinter
  , module Prettyprinter.Render.Terminal
  , Doc
  , SimpleDoc

  , (.$.)
  , (</>)

  , groupOrNestLine
  , altSep
  , hangAtIfOver

  , prettyString
  ) where

#if !MIN_VERSION_base(4,11,0)
import           Data.Semigroup ((<>), mempty)
#endif
import qualified Data.Text.Lazy as Lazy

import           Prettyprinter hiding (Doc)
import qualified Prettyprinter as PP
import           Prettyprinter.Render.Terminal

import           Prelude

type Doc = PP.Doc AnsiStyle
type SimpleDoc = SimpleDocStream AnsiStyle

linebreak :: Doc
linebreak = flatAlt line mempty

(.$.) :: Doc -> Doc -> Doc
x .$. y = x <> line <> y
(</>) :: Doc -> Doc -> Doc
x </> y = x <> softline <> y

-- | Apply the function if we're not at the
--   start of our nesting level.
ifNotAtRoot :: (Doc -> Doc) -> Doc -> Doc
ifNotAtRoot =
  ifElseAtRoot id

-- | Apply the function if we're not at the
--   start of our nesting level.
ifAtRoot :: (Doc -> Doc) -> Doc -> Doc
ifAtRoot =
  flip ifElseAtRoot id

-- | Apply the function if we're not at the
--   start of our nesting level.
ifElseAtRoot :: (Doc -> Doc) -> (Doc -> Doc) -> Doc -> Doc
ifElseAtRoot f g doc =
  nesting $ \i ->
    column $ \j ->
      if i == j
        then f doc
        else g doc

-- | Render flattened text on this line, or start
--   a new line before rendering any text.
--
--   This will also nest subsequent lines in the
--   group.
groupOrNestLine :: Doc -> Doc
groupOrNestLine =
  group . ifNotAtRoot (linebreak <>) . nest 2


-- | Separate items in an alternative with a pipe.
--
--   If the first document and the pipe don't fit
--   on the line, then mandatorily flow the next entry
--   onto the following line.
--
--   The (<//>) softbreak ensures that if the document
--   does fit on the line, there is at least a space,
--   but it's possible for y to still appear on the
--   next line.
altSep :: Doc -> Doc -> Doc
altSep x y =
  group (x <+> pretty '|' <> line) <> group linebreak <>  y


-- | Printer hacks to get nice indentation for long commands
--   and subcommands.
--
--   If we're starting this section over the desired width
--   (usually 1/3 of the ribbon), then we will make a line
--   break, indent all of the usage, and go.
--
--   The ifAtRoot is an interesting clause. If this whole
--   operation is put under a `group` then the linebreak
--   will disappear; then item d will therefore not be at
--   the starting column, and it won't be indented more.
hangAtIfOver :: Int -> Int -> Doc -> Doc
hangAtIfOver i j d =
  column $ \k ->
    if k <= j then
      align d
    else
      linebreak <> ifAtRoot (indent i) d


renderPretty :: Double -> Int -> Doc -> SimpleDocStream AnsiStyle
renderPretty ribbonFraction lineWidth
  = layoutPretty LayoutOptions
      { layoutPageWidth = AvailablePerLine lineWidth ribbonFraction }

prettyString :: Double -> Int -> Doc -> String
prettyString ribbonFraction lineWidth
  = streamToString
  . renderPretty ribbonFraction lineWidth

streamToString :: SimpleDocStream AnsiStyle -> String
streamToString sdoc =
  let
    rendered =
      Prettyprinter.Render.Terminal.renderLazy sdoc
  in
    Lazy.unpack rendered