{-# LANGUAGE OverloadedStrings #-}

{- |
Module      : Errata.Styles
Copyright   : (c) 2020- comp
License     : MIT
Maintainer  : onecomputer00@gmail.com
Stability   : stable
Portability : portable

Premade styles for blocks and pointers.
-}
module Errata.Styles
    ( basicStyle
    , basicPointer
    , fancyStyle
    , fancyPointer
    , fancyRedStyle
    , fancyRedPointer
    , fancyYellowStyle
    , fancyYellowPointer
    , highlight
    ) where

import           Data.Bifunctor (bimap, second)
import qualified Data.Text as T
import           Errata.Types

{- | A basic style using only ASCII characters.

Errors should look like so (with 'basicPointer'):

> error header message
> --> file.ext:1:16
> block header message
>   |
> 1 |   line 1 foo bar do
>   |  ________________^^ start label
> 2 | | line 2
>   | |      ^ unconnected label
> 3 | | line 3
>   | |______^ middle label
> 4 | | line 4
> 5 | | line 5
> . | |
> 7 | | line 7
> 8 | | line 8 baz end
>   | |______^_____^^^ end label
>   |        |
>   |        | inner label
> block body message
> error body message
-}
basicStyle :: Style
basicStyle :: Style
basicStyle = Style
    { styleLocation :: (FilePath, Line, Line) -> Text
styleLocation = \(FilePath
fp, Line
l, Line
c) -> [Text] -> Text
T.concat [Text
"--> ", FilePath -> Text
T.pack FilePath
fp, Text
":", FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Line -> FilePath
forall a. Show a => a -> FilePath
show Line
l, Text
":", FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Line -> FilePath
forall a. Show a => a -> FilePath
show Line
c]
    , styleNumber :: Line -> Text
styleNumber = FilePath -> Text
T.pack (FilePath -> Text) -> (Line -> FilePath) -> Line -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> FilePath
forall a. Show a => a -> FilePath
show
    , styleLine :: [(PointerStyle, (Line, Line))] -> Text -> Text
styleLine = [(PointerStyle, (Line, Line))] -> Text -> Text
highlight
    , styleEllipsis :: Text
styleEllipsis = Text
"."
    , styleLinePrefix :: Text
styleLinePrefix = Text
"|"
    , styleVertical :: Text
styleVertical = Text
"|"
    , styleHorizontal :: Text
styleHorizontal = Text
"_"
    , styleDownRight :: Text
styleDownRight = Text
" "
    , styleUpRight :: Text
styleUpRight = Text
"|"
    , styleUpDownRight :: Text
styleUpDownRight = Text
"|"
    , styleTabWidth :: Line
styleTabWidth = Line
4
    , styleExtraLinesAfter :: Line
styleExtraLinesAfter = Line
2
    , styleExtraLinesBefore :: Line
styleExtraLinesBefore = Line
1
    , stylePaddingTop :: Bool
stylePaddingTop = Bool
True
    , stylePaddingBottom :: Bool
stylePaddingBottom = Bool
False
    , styleEnableDecorations :: Bool
styleEnableDecorations = Bool
True
    , styleEnableLinePrefix :: Bool
styleEnableLinePrefix = Bool
True
    }

-- | Pointers using only ASCII characters.
basicPointer :: PointerStyle
basicPointer :: PointerStyle
basicPointer = PointerStyle
    { styleHighlight :: Text -> Text
styleHighlight = Text -> Text
forall a. a -> a
id
    , styleUnderline :: Text
styleUnderline = Text
"^"
    , styleHook :: Text
styleHook = Text
"|"
    , styleConnector :: Text
styleConnector = Text
"|"
    , styleEnableHook :: Bool
styleEnableHook = Bool
True
    }

{- | A fancy style using Unicode characters.

Errors should look like so (with 'fancyPointer'):

> error header message
> → file.ext:1:16
> block header message
>   │
> 1 │   line 1 foo bar do
>   │ ┌────────────────^^ start label
> 2 │ │ line 2
>   │ │      ^ unconnected label
> 3 │ │ line 3
>   │ ├──────^ middle label
> 4 │ │ line 4
> 5 │ │ line 5
> . │ │
> 7 │ │ line 7
> 8 │ │ line 8 baz end
>   │ └──────^─────^^^ end label
>   │        │
>   │        └ inner label
-}
fancyStyle :: Style
fancyStyle :: Style
fancyStyle = Style
    { styleLocation :: (FilePath, Line, Line) -> Text
styleLocation = \(FilePath
fp, Line
l, Line
c) -> [Text] -> Text
T.concat
        [ Text
"→ ", FilePath -> Text
T.pack FilePath
fp, Text
":", FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Line -> FilePath
forall a. Show a => a -> FilePath
show Line
l, Text
":", FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Line -> FilePath
forall a. Show a => a -> FilePath
show Line
c
        ]
    , styleNumber :: Line -> Text
styleNumber = FilePath -> Text
T.pack (FilePath -> Text) -> (Line -> FilePath) -> Line -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> FilePath
forall a. Show a => a -> FilePath
show
    , styleLine :: [(PointerStyle, (Line, Line))] -> Text -> Text
styleLine = [(PointerStyle, (Line, Line))] -> Text -> Text
highlight
    , styleEllipsis :: Text
styleEllipsis = Text
"."
    , styleLinePrefix :: Text
styleLinePrefix = Text
"│"
    , styleHorizontal :: Text
styleHorizontal = Text
"─"
    , styleVertical :: Text
styleVertical = Text
"│"
    , styleDownRight :: Text
styleDownRight = Text
"┌"
    , styleUpDownRight :: Text
styleUpDownRight = Text
"├"
    , styleUpRight :: Text
styleUpRight = Text
"└"
    , styleTabWidth :: Line
styleTabWidth = Line
4
    , styleExtraLinesAfter :: Line
styleExtraLinesAfter = Line
2
    , styleExtraLinesBefore :: Line
styleExtraLinesBefore = Line
1
    , stylePaddingTop :: Bool
stylePaddingTop = Bool
True
    , stylePaddingBottom :: Bool
stylePaddingBottom = Bool
False
    , styleEnableDecorations :: Bool
styleEnableDecorations = Bool
True
    , styleEnableLinePrefix :: Bool
styleEnableLinePrefix = Bool
True
    }

-- | Pointers using Unicode characters and ANSI colors.
fancyPointer :: PointerStyle
fancyPointer :: PointerStyle
fancyPointer = PointerStyle
    { styleHighlight :: Text -> Text
styleHighlight = Text -> Text
forall a. a -> a
id
    , styleUnderline :: Text
styleUnderline = Text
"^"
    , styleHook :: Text
styleHook = Text
"└"
    , styleConnector :: Text
styleConnector = Text
"│"
    , styleEnableHook :: Bool
styleEnableHook = Bool
True
    }

-- | A fancy style using Unicode characters and ANSI colors, similar to 'fancyStyle'. Most things are colored red.
fancyRedStyle :: Style
fancyRedStyle :: Style
fancyRedStyle = Style
    { styleLocation :: (FilePath, Line, Line) -> Text
styleLocation = \(FilePath
fp, Line
l, Line
c) -> [Text] -> Text
T.concat
        [ Text
"\x1b[34m→\x1b[0m ", FilePath -> Text
T.pack FilePath
fp, Text
":", FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Line -> FilePath
forall a. Show a => a -> FilePath
show Line
l, Text
":", FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Line -> FilePath
forall a. Show a => a -> FilePath
show Line
c
        ]
    , styleNumber :: Line -> Text
styleNumber = FilePath -> Text
T.pack (FilePath -> Text) -> (Line -> FilePath) -> Line -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> FilePath
forall a. Show a => a -> FilePath
show
    , styleLine :: [(PointerStyle, (Line, Line))] -> Text -> Text
styleLine = [(PointerStyle, (Line, Line))] -> Text -> Text
highlight
    , styleEllipsis :: Text
styleEllipsis = Text
"."
    , styleLinePrefix :: Text
styleLinePrefix = Text
"\x1b[34m│\x1b[0m"
    , styleHorizontal :: Text
styleHorizontal = Text
"\x1b[31m─\x1b[0m"
    , styleVertical :: Text
styleVertical = Text
"\x1b[31m│\x1b[0m"
    , styleDownRight :: Text
styleDownRight = Text
"\x1b[31m┌\x1b[0m"
    , styleUpDownRight :: Text
styleUpDownRight = Text
"\x1b[31m├\x1b[0m"
    , styleUpRight :: Text
styleUpRight = Text
"\x1b[31m└\x1b[0m"
    , styleTabWidth :: Line
styleTabWidth = Line
4
    , styleExtraLinesAfter :: Line
styleExtraLinesAfter = Line
2
    , styleExtraLinesBefore :: Line
styleExtraLinesBefore = Line
1
    , stylePaddingTop :: Bool
stylePaddingTop = Bool
True
    , stylePaddingBottom :: Bool
stylePaddingBottom = Bool
False
    , styleEnableDecorations :: Bool
styleEnableDecorations = Bool
True
    , styleEnableLinePrefix :: Bool
styleEnableLinePrefix = Bool
True
    }

-- | Red pointers using Unicode characters and ANSI colors.
fancyRedPointer :: PointerStyle
fancyRedPointer :: PointerStyle
fancyRedPointer = PointerStyle
    { styleHighlight :: Text -> Text
styleHighlight = \Text
x -> Text
"\x1b[31m" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\x1b[0m"
    , styleUnderline :: Text
styleUnderline = Text
"\x1b[31m^\x1b[0m"
    , styleHook :: Text
styleHook = Text
"\x1b[31m└\x1b[0m"
    , styleConnector :: Text
styleConnector = Text
"\x1b[31m│\x1b[0m"
    , styleEnableHook :: Bool
styleEnableHook = Bool
True
    }

-- | A fancy style using Unicode characters and ANSI colors, similar to 'fancyStyle'. Most things are colored yellow.
fancyYellowStyle :: Style
fancyYellowStyle :: Style
fancyYellowStyle = Style
    { styleLocation :: (FilePath, Line, Line) -> Text
styleLocation = \(FilePath
fp, Line
l, Line
c) -> [Text] -> Text
T.concat
        [ Text
"\x1b[34m→\x1b[0m ", FilePath -> Text
T.pack FilePath
fp, Text
":", FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Line -> FilePath
forall a. Show a => a -> FilePath
show Line
l, Text
":", FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Line -> FilePath
forall a. Show a => a -> FilePath
show Line
c
        ]
    , styleNumber :: Line -> Text
styleNumber = FilePath -> Text
T.pack (FilePath -> Text) -> (Line -> FilePath) -> Line -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> FilePath
forall a. Show a => a -> FilePath
show
    , styleLine :: [(PointerStyle, (Line, Line))] -> Text -> Text
styleLine = [(PointerStyle, (Line, Line))] -> Text -> Text
highlight
    , styleEllipsis :: Text
styleEllipsis = Text
"."
    , styleLinePrefix :: Text
styleLinePrefix = Text
"\x1b[34m│\x1b[0m"
    , styleHorizontal :: Text
styleHorizontal = Text
"\x1b[33m─\x1b[0m"
    , styleVertical :: Text
styleVertical = Text
"\x1b[33m│\x1b[0m"
    , styleDownRight :: Text
styleDownRight = Text
"\x1b[33m┌\x1b[0m"
    , styleUpRight :: Text
styleUpRight = Text
"\x1b[33m└\x1b[0m"
    , styleUpDownRight :: Text
styleUpDownRight = Text
"\x1b[33m├\x1b[0m"
    , styleTabWidth :: Line
styleTabWidth = Line
4
    , styleExtraLinesAfter :: Line
styleExtraLinesAfter = Line
2
    , styleExtraLinesBefore :: Line
styleExtraLinesBefore = Line
1
    , stylePaddingTop :: Bool
stylePaddingTop = Bool
True
    , stylePaddingBottom :: Bool
stylePaddingBottom = Bool
False
    , styleEnableDecorations :: Bool
styleEnableDecorations = Bool
True
    , styleEnableLinePrefix :: Bool
styleEnableLinePrefix = Bool
True
    }

-- | Yellow pointers using Unicode characters and ANSI colors.
fancyYellowPointer :: PointerStyle
fancyYellowPointer :: PointerStyle
fancyYellowPointer = PointerStyle
    { styleHighlight :: Text -> Text
styleHighlight = \Text
x -> Text
"\x1b[33m" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\x1b[0m"
    , styleUnderline :: Text
styleUnderline = Text
"\x1b[33m^\x1b[0m"
    , styleHook :: Text
styleHook = Text
"\x1b[33m└\x1b[0m"
    , styleConnector :: Text
styleConnector = Text
"\x1b[33m│\x1b[0m"
    , styleEnableHook :: Bool
styleEnableHook = Bool
True
    }

-- | Adds highlighting to spans of text by modifying it with the given styles' highlights.
highlight
    :: [(PointerStyle, (Column, Column))] -- ^ Styles and columns to work on. These are sorted, starting at 1. They must not overlap.
    -> T.Text                             -- ^ Text to highlight.
    -> T.Text
highlight :: [(PointerStyle, (Line, Line))] -> Text -> Text
highlight [] Text
xs = Text
xs
highlight ((PointerStyle
p, (Line
s, Line
e)):[(PointerStyle, (Line, Line))]
ps) Text
xs =
    let (Text
pre, Text
xs') = Line -> Text -> (Text, Text)
T.splitAt (Line
s Line -> Line -> Line
forall a. Num a => a -> a -> a
- Line
1) Text
xs
        (Text
txt, Text
xs'') = Line -> Text -> (Text, Text)
T.splitAt (Line
e Line -> Line -> Line
forall a. Num a => a -> a -> a
- Line
s) Text
xs'
        hi :: Text -> Text
hi = PointerStyle -> Text -> Text
styleHighlight PointerStyle
p
        ps' :: [(PointerStyle, (Line, Line))]
ps' = ((Line, Line) -> (Line, Line))
-> (PointerStyle, (Line, Line)) -> (PointerStyle, (Line, Line))
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Line -> Line) -> (Line, Line) -> (Line, Line)
forall {p :: * -> * -> *} {c} {d}.
Bifunctor p =>
(c -> d) -> p c c -> p d d
both (\Line
i -> Line
i Line -> Line -> Line
forall a. Num a => a -> a -> a
- Line
e Line -> Line -> Line
forall a. Num a => a -> a -> a
+ Line
1)) ((PointerStyle, (Line, Line)) -> (PointerStyle, (Line, Line)))
-> [(PointerStyle, (Line, Line))] -> [(PointerStyle, (Line, Line))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PointerStyle, (Line, Line))]
ps
    in Text
pre Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
hi Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [(PointerStyle, (Line, Line))] -> Text -> Text
highlight [(PointerStyle, (Line, Line))]
ps' Text
xs''
    where
        both :: (c -> d) -> p c c -> p d d
both c -> d
f = (c -> d) -> (c -> d) -> p c c -> p d d
forall a b c d. (a -> b) -> (c -> d) -> p a c -> p b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap c -> d
f c -> d
f