Printer.hs

{-# LANGUAGE TypeFamilies #-}
module Control.Monad.Terminal.Printer where

import           Data.Text
import           Data.Text.Prettyprint.Doc

import           Prelude                   hiding (putChar)

-- | This class describes an environment that Unicode text can be printed to.
--   This might either be file or a terminal.
--
--    * Instances shall implement the concept of lines and line width.
--    * Instances shall implement the concept of a carriage that can be
--      set to the beginning of the next line.
--    * It is assumed that the carriage automatically moves to the beginning
--      of the next line if the end of the current line is reached.
--    * Instances shall be Unicode aware or must at least be able to print
--      a replacement character.
--    * Implementations must be aware of infinite lazy `Prelude.String`s and
--      long `Data.Text.Text`s. `String`s should be printed character wise as
--      evaluating them might trigger exceptions at any point. Long text should
--      be printed chunk wise in order to stay interruptible.
--    * Implementations must not use an unbounded output buffer. Print operations
--      shall block and be interruptible when the output buffer is full.
--    * Instances shall not interpret any control characters but
--      \\n (new line, as generated by `putLn`, and \\t (horizontal tabulator).
--    * Especially escape sequences shall be filtered or at least defused
--      by removing the leading \\ESC. Text formatting shall be done with the
--      designated classes like `MonadPrettyPrinter`, `MonadFormatPrinter`
--      and `MonadColorPrinter`. Allowing control sequences would cause a
--      dependency on certain terminal types, but might also be an underrated
--      security risk as modern terminals are highly programmable and should
--      not be fed with untrusted input.
class Monad m => MonadPrinter m where
  -- | Move the carriage to the beginning of the next line.
  putLn              :: m ()
  putLn               = putChar '\n'
  -- | Print a single printable character or one of the allowed control characters.
  putChar            :: Char -> m ()
  -- | Print a `String`.
  putString          :: String -> m ()
  putString           = mapM_ putChar
  -- | Print a `String` and an additional newline.
  putStringLn        :: String -> m ()
  putStringLn s       = putString s >> putLn
  -- | Print a `Text`.
  putText            :: Text -> m ()
  putText             = putString . Data.Text.unpack
  -- | Print a `Text` and an additional newline.
  putTextLn          :: Text -> m ()
  putTextLn           = putStringLn . Data.Text.unpack
  -- | Flush the output buffer and make the all previous output actually
  --   visible after a reasonably short amount of time.
  --
  --    * The operation may return before the buffer has actually been flushed.
  flush              :: m ()
  flush               = pure ()
  -- | Get the current line width.
  --
  --    * The operation may return the last known line width and may not be
  --      completely precise when I/O is asynchronous.
  --    * This operations shall not block too long and rather be called more
  --      often in order to adapt to changes in line width.
  getLineWidth       :: m Int
  {-# MINIMAL putChar, getLineWidth #-}

-- | This class is the foundation for all environments that allow
--   annotated text and `Doc`uments to be printed to.
--
--    * Prefer using the `Data.Text.Prettyprint.Doc` module and the
--      `putDoc` operation whenever trying to print structured or
--      formatted text as it automatically deals with nested annotations
--      and the current line width.
class MonadPrinter m => MonadPrettyPrinter m where
  -- | This associated type represents all possible annotations that are available
  --   in the current environment.
  --
  --   When writing polymorphic code against these monadic interfaces
  --   the concrete instantiation of this type is usually unknown and class
  --   instances are generally advised to not expose value constructors for
  --   this type.
  --
  --   Instead, subclasses like `MonadFormatPrinter` and `MonadColorPrinter`
  --   offer abstract value constructors like `bold`, `underlined`, `inverted`
  --   which are then given meaning by the concrete class instance. The
  --   environment `Control.Monad.Terminal.Ansi.AnsiTerminalT` for example
  --   implements all of these classes.
  data Annotation m
  -- | Print an annotated `Doc`.
  --
  --   * This operation performs `resetAnnotations` on entry and on exit.
  --   * This operation can deal with nested annotations (see example).
  --
  -- Example:
  --
  -- @
  -- {-# LANGUAGE OverloadedStrings #-}
  -- import Control.Monad.Terminal
  -- import Data.Text.Prettyprint.Doc
  --
  -- printer :: (`MonadFormatPrinter` m, `MonadColorPrinter` m) => m ()
  -- printer = `putDoc` $ `annotate` (foreground $ `bright` `Blue`) "This is blue!" <> `line`
  --                 <> `annotate` `bold` ("Just bold!" <> otherDoc <> "..just bold again")
  --
  -- otherDoc :: (`MonadColorPrinter` m, `Annotation` m ~ ann) => `Doc` ann
  -- otherDoc = `annotate` (`background` $ `dull` `Red`) " BOLD ON RED BACKGROUND "
  -- @
  --
  -- Note the necessary unification of `Annotation` `m` and `ann` in the definition of `otherDoc`!
  putDoc           :: Doc (Annotation m) -> m ()
  -- | Like `putDoc` but adds an additional newline.
  putDocLn         :: Doc (Annotation m) -> m ()
  putDocLn doc      = putDoc doc >> putLn
  -- | Set an annotation so that it affects subsequent output.
  setAnnotation    :: Annotation m -> m ()
  setAnnotation _   = pure ()
  -- | Reset an annotation so that it does no longer affect subsequent output.
  --
  -- * Binary attributes like `bold` or `underlined` shall just be reset to their opposite.
  --
  -- * For non-binary attributes like colors all of their possible values shall be treated
  --   as equal, so that
  --
  --   @
  --   `setAnnotation` (`foreground` $ `bright` `Blue`) >> `resetAnnotation` (`foreground` $ `dull` `Red`)
  --   @
  --
  --   results in the foreground color attribute reset afterwards whereas after
  --
  --   @
  --   `setAnnotation` (`foreground` $ `bright` `Blue`) >> `resetAnnotation` (`background` $ `dull` `Red`)
  --   @
  --
  --   the foreground color is still set as `bright` `Blue`.
  --
  resetAnnotation  :: Annotation m -> m ()
  resetAnnotation _ = pure ()
  -- | Reset all annotations to their default.
  resetAnnotations :: m ()
  resetAnnotations  = pure ()
  {-# MINIMAL putDoc, setAnnotation, resetAnnotation, resetAnnotations #-}

pprint :: (MonadPrettyPrinter m, Pretty a) => a -> m ()
pprint  = putDocLn . pretty

-- | This class offers abstract constructors for text formatting
--   annotations.
class MonadPrettyPrinter m => MonadFormatPrinter m where
  -- | This annotation makes text appear __bold__.
  bold            :: Annotation m
  -- | This annotation makes text appear /italic/.
  italic          :: Annotation m
  -- | This annotation makes text appear underlined.
  underlined      :: Annotation m

-- | This class offers abstract value constructors for
--   foreground and background coloring.
class MonadPrettyPrinter m => MonadColorPrinter m where
  -- | This annotation swaps foreground and background color.
  --
  --   * This operation is idempotent: Applying the annotation a second time
  --     won't swap it back. Use `resetAnnotation` instead.
  inverted        :: Annotation m
  -- | This annotation sets the __foreground__ color (the text color).
  foreground      :: Color -> Annotation m
  -- | This annotation sets the __background__ color.
  background      :: Color -> Annotation m

data Color = Color ColorMode BasicColor
  deriving (Eq, Ord, Show)

data ColorMode
  = Dull
  | Bright
  deriving (Eq, Ord, Show)

data BasicColor
  = Black
  | Red
  | Green
  | Yellow
  | Blue
  | Magenta
  | Cyan
  | White
  deriving (Eq, Ord, Show)

dull :: BasicColor -> Color
dull = Color Dull

bright :: BasicColor -> Color
bright = Color Bright