{-# 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