{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveGeneric #-}
-- |
-- Module      : Error.Diagnose.Style
-- Description : Custom style definitions
-- Copyright   : (c) Mesabloo, 2021-2022
-- License     : BSD3
-- Stability   : experimental
-- Portability : Portable
module Error.Diagnose.Style
  ( -- * Defining new style
    Annotation (..),
    Style,
    -- $defining_new_styles

    -- * Styles
    defaultStyle,
    unadornedStyle,
  )
where

import GHC.Generics
import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold, color, colorDull)

-- $defining_new_styles
--
-- Defining new color styles (one may call them "themes") is actually rather easy.
--
-- A 'Style' is a function from an annotated 'Doc'ument to another annotated 'Doc'ument.
-- Note that only the annotation type changes, hence the need of only providing a unidirectional mapping between those.
--
-- 'Annotation's are used when creating a 'Doc'ument and are simply placeholders to specify custom colors.
-- 'AnsiStyle' is the concrete annotation to specify custom colors when rendering a 'Doc'ument.
--
-- One may define additional styles as follows:
--
-- > myNewCustomStyle :: Style
-- > myNewCustomStyle = reAnnotate \case
-- >   -- all cases for all annotations
--
-- For simplicity's sake, a default style is given as 'defaultStyle'.

-- | Some annotations as placeholders for colors in a 'Doc'.
data Annotation a
  = -- | The color of 'Error.Diagnose.Report.This' markers, depending on whether the report is an error
    --   report or a warning report.
    ThisColor
      Bool
  | -- | The color of 'Error.Diagnose.Report.Maybe' markers.
    MaybeColor
  | -- | The color of 'Error.Diagnose.Report.Where' markers.
    WhereColor
  | -- | The color for hints.
    --
    --   Note that the beginning @Hint:@ text will always be in bold.
    HintColor
  | -- | The color for file names.
    FileColor
  | -- | The color of the rule separating the code/markers from the line numbers.
    RuleColor
  | -- | The color of the @[error]@/@[warning]@ at the top, depending on whether
    --   this is an error or warning report.
    KindColor
      Bool
  | -- | The color in which to output the @<no line>@ information when the file was not found.
    NoLineColor
  | -- | Additional style to apply to marker rules (e.g. bold) on top of some
    --   already processed color annotation.
    MarkerStyle
      (Annotation a)
  | -- | The color of the code when no marker is present.
    CodeStyle
  | -- | Something else, could be provided by the user
    OtherStyle a
  deriving (Annotation a -> Annotation a -> Bool
forall a. Eq a => Annotation a -> Annotation a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Annotation a -> Annotation a -> Bool
$c/= :: forall a. Eq a => Annotation a -> Annotation a -> Bool
== :: Annotation a -> Annotation a -> Bool
$c== :: forall a. Eq a => Annotation a -> Annotation a -> Bool
Eq, Annotation a -> Annotation a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Annotation a)
forall a. Ord a => Annotation a -> Annotation a -> Bool
forall a. Ord a => Annotation a -> Annotation a -> Ordering
forall a. Ord a => Annotation a -> Annotation a -> Annotation a
min :: Annotation a -> Annotation a -> Annotation a
$cmin :: forall a. Ord a => Annotation a -> Annotation a -> Annotation a
max :: Annotation a -> Annotation a -> Annotation a
$cmax :: forall a. Ord a => Annotation a -> Annotation a -> Annotation a
>= :: Annotation a -> Annotation a -> Bool
$c>= :: forall a. Ord a => Annotation a -> Annotation a -> Bool
> :: Annotation a -> Annotation a -> Bool
$c> :: forall a. Ord a => Annotation a -> Annotation a -> Bool
<= :: Annotation a -> Annotation a -> Bool
$c<= :: forall a. Ord a => Annotation a -> Annotation a -> Bool
< :: Annotation a -> Annotation a -> Bool
$c< :: forall a. Ord a => Annotation a -> Annotation a -> Bool
compare :: Annotation a -> Annotation a -> Ordering
$ccompare :: forall a. Ord a => Annotation a -> Annotation a -> Ordering
Ord, Int -> Annotation a -> ShowS
forall a. Show a => Int -> Annotation a -> ShowS
forall a. Show a => [Annotation a] -> ShowS
forall a. Show a => Annotation a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Annotation a] -> ShowS
$cshowList :: forall a. Show a => [Annotation a] -> ShowS
show :: Annotation a -> String
$cshow :: forall a. Show a => Annotation a -> String
showsPrec :: Int -> Annotation a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Annotation a -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Annotation a) x -> Annotation a
forall a x. Annotation a -> Rep (Annotation a) x
$cto :: forall a x. Rep (Annotation a) x -> Annotation a
$cfrom :: forall a x. Annotation a -> Rep (Annotation a) x
Generic, forall a b. a -> Annotation b -> Annotation a
forall a b. (a -> b) -> Annotation a -> Annotation b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Annotation b -> Annotation a
$c<$ :: forall a b. a -> Annotation b -> Annotation a
fmap :: forall a b. (a -> b) -> Annotation a -> Annotation b
$cfmap :: forall a b. (a -> b) -> Annotation a -> Annotation b
Functor, forall a. Eq a => a -> Annotation a -> Bool
forall a. Num a => Annotation a -> a
forall a. Ord a => Annotation a -> a
forall m. Monoid m => Annotation m -> m
forall a. Annotation a -> Bool
forall a. Annotation a -> Int
forall a. Annotation a -> [a]
forall a. (a -> a -> a) -> Annotation a -> a
forall m a. Monoid m => (a -> m) -> Annotation a -> m
forall b a. (b -> a -> b) -> b -> Annotation a -> b
forall a b. (a -> b -> b) -> b -> Annotation a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Annotation a -> a
$cproduct :: forall a. Num a => Annotation a -> a
sum :: forall a. Num a => Annotation a -> a
$csum :: forall a. Num a => Annotation a -> a
minimum :: forall a. Ord a => Annotation a -> a
$cminimum :: forall a. Ord a => Annotation a -> a
maximum :: forall a. Ord a => Annotation a -> a
$cmaximum :: forall a. Ord a => Annotation a -> a
elem :: forall a. Eq a => a -> Annotation a -> Bool
$celem :: forall a. Eq a => a -> Annotation a -> Bool
length :: forall a. Annotation a -> Int
$clength :: forall a. Annotation a -> Int
null :: forall a. Annotation a -> Bool
$cnull :: forall a. Annotation a -> Bool
toList :: forall a. Annotation a -> [a]
$ctoList :: forall a. Annotation a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Annotation a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Annotation a -> a
foldr1 :: forall a. (a -> a -> a) -> Annotation a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Annotation a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Annotation a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Annotation a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Annotation a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Annotation a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Annotation a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Annotation a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Annotation a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Annotation a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Annotation a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Annotation a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Annotation a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Annotation a -> m
fold :: forall m. Monoid m => Annotation m -> m
$cfold :: forall m. Monoid m => Annotation m -> m
Foldable, Functor Annotation
Foldable Annotation
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
Annotation (m a) -> m (Annotation a)
forall (f :: * -> *) a.
Applicative f =>
Annotation (f a) -> f (Annotation a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Annotation a -> m (Annotation b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Annotation a -> f (Annotation b)
sequence :: forall (m :: * -> *) a.
Monad m =>
Annotation (m a) -> m (Annotation a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
Annotation (m a) -> m (Annotation a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Annotation a -> m (Annotation b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Annotation a -> m (Annotation b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Annotation (f a) -> f (Annotation a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Annotation (f a) -> f (Annotation a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Annotation a -> f (Annotation b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Annotation a -> f (Annotation b)
Traversable)

-- | A style is a function which can be applied using 'reAnnotate'.
--
--   It transforms a 'Doc'ument containing 'Annotation's into a 'Doc'ument containing
--   color information.
type Style a = Annotation a -> AnsiStyle

-------------------------------------------

-- | A style which disregards all annotations
unadornedStyle :: Style a
unadornedStyle :: forall a. Style a
unadornedStyle = forall a b. a -> b -> a
const forall a. Monoid a => a
mempty

-- | The default style for diagnostics, where:
--
--   * 'Error.Diagnose.Report.This' markers are colored in red for errors and yellow for warnings
--   * 'Error.Diagnose.Report.Where' markers are colored in dull blue
--   * 'Error.Diagnose.Report.Maybe' markers are colored in magenta
--   * Marker rules are of the same color of the marker, but also in bold
--   * Hints are output in cyan
--   * The left rules are colored in bold black
--   * File names are output in dull green
--   * The @[error]@/@[warning]@ at the top is colored in red for errors and yellow for warnings
--   * The code is output in normal white
defaultStyle :: Style AnsiStyle
defaultStyle :: Style AnsiStyle
defaultStyle = \case
    ThisColor Bool
isError -> Color -> AnsiStyle
color if Bool
isError then Color
Red else Color
Yellow
    Annotation AnsiStyle
MaybeColor -> Color -> AnsiStyle
color Color
Magenta
    Annotation AnsiStyle
WhereColor -> Color -> AnsiStyle
colorDull Color
Blue
    Annotation AnsiStyle
HintColor -> Color -> AnsiStyle
color Color
Cyan
    Annotation AnsiStyle
FileColor -> AnsiStyle
bold forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
colorDull Color
Green
    Annotation AnsiStyle
RuleColor -> AnsiStyle
bold forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
color Color
Black
    KindColor Bool
isError -> AnsiStyle
bold forall a. Semigroup a => a -> a -> a
<> Style AnsiStyle
defaultStyle (forall a. Bool -> Annotation a
ThisColor Bool
isError)
    Annotation AnsiStyle
NoLineColor -> AnsiStyle
bold forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
colorDull Color
Magenta
    MarkerStyle Annotation AnsiStyle
st ->
      let ann :: AnsiStyle
ann = Style AnsiStyle
defaultStyle Annotation AnsiStyle
st
       in if AnsiStyle
ann forall a. Eq a => a -> a -> Bool
== Style AnsiStyle
defaultStyle forall a. Annotation a
CodeStyle
            then AnsiStyle
ann
            else AnsiStyle
bold forall a. Semigroup a => a -> a -> a
<> AnsiStyle
ann
    Annotation AnsiStyle
CodeStyle -> Color -> AnsiStyle
color Color
White
    OtherStyle AnsiStyle
s -> AnsiStyle
s