{-# LANGUAGE OverloadedStrings #-}

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

This module is for creating pretty error messages. We assume very little about the format you want to use, so much of
this module is to allow you to customize your error messages.

To get started, see the documentation for 'prettyErrors'. When using this module, we recommend you turn on the
@OverloadedStrings@ extension and import "Data.Text" at the very least due to the use of 'Data.Text.Text' (strict).

The overall workflow to use the printer is to convert your error type to 'Errata', which entails filling in messages
and 'Block's. You can create 'Errata' and 'Block' from their constructors, or use the convenience functions for
common usecases, like 'errataSimple' and 'blockSimple'.

For easier reading, we define:

> type Line = Int
> type Column = Int
> type Header = Text
> type Body = Text
> type Label = Text
-}
module Errata
    ( -- * Error format data
      Errata (..)
    , errataSimple
      -- * Blocks and pointers
    , Block (..)
    , blockSimple
    , blockSimple'
    , blockConnected
    , blockConnected'
    , blockMerged
    , blockMerged'
    , Pointer (..)
      -- * Styling options
    , Style (..)
    , basicStyle
    , fancyStyle
    , fancyRedStyle
    , fancyYellowStyle
      -- * Pretty printer
    , prettyErrors
    ) where

import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB
import           Errata.Internal.Render
import           Errata.Source
import           Errata.Types

-- | Creates a simple error that has a single block, with an optional header or body.
errataSimple
    :: Maybe Header -- ^ The header.
    -> Block        -- ^ The block.
    -> Maybe Body   -- ^ The body.
    -> Errata
errataSimple :: Maybe Header -> Block -> Maybe Header -> Errata
errataSimple Maybe Header
header Block
block Maybe Header
body = Errata :: Maybe Header -> [Block] -> Maybe Header -> Errata
Errata
    { errataHeader :: Maybe Header
errataHeader = Maybe Header
header
    , errataBlocks :: [Block]
errataBlocks = [Block
block]
    , errataBody :: Maybe Header
errataBody = Maybe Header
body
    }

-- | A simple block that points to only one line and optionally has a label, header, or body message.
blockSimple
    :: Style                               -- ^ The style of the pointer.
    -> FilePath                            -- ^ The filepath.
    -> Maybe Header                        -- ^ The header message.
    -> (Line, Column, Column, Maybe Label) -- ^ The line number and column span, starting at 1, and a label.
    -> Maybe Body                          -- ^ The body message.
    -> Block
blockSimple :: Style
-> FilePath
-> Maybe Header
-> (Line, Line, Line, Maybe Header)
-> Maybe Header
-> Block
blockSimple Style
style FilePath
fp Maybe Header
hm (Line
l, Line
cs, Line
ce, Maybe Header
lbl) Maybe Header
bm = Block :: Style
-> (FilePath, Line, Line)
-> Maybe Header
-> [Pointer]
-> Maybe Header
-> Block
Block
    { blockStyle :: Style
blockStyle = Style
style
    , blockLocation :: (FilePath, Line, Line)
blockLocation = (FilePath
fp, Line
l, Line
cs)
    , blockHeader :: Maybe Header
blockHeader = Maybe Header
hm
    , blockPointers :: [Pointer]
blockPointers = [Line -> Line -> Line -> Bool -> Maybe Header -> Pointer
Pointer Line
l Line
cs Line
ce Bool
False Maybe Header
lbl]
    , blockBody :: Maybe Header
blockBody = Maybe Header
bm
    }

-- | A variant of 'blockSimple' that only points at one column.
blockSimple'
    :: Style                       -- ^ The style of the pointer.
    -> FilePath                    -- ^ The filepath.
    -> Maybe Header                -- ^ The header message.
    -> (Line, Column, Maybe Label) -- ^ The line number and column, starting at 1, and a label.
    -> Maybe Body                  -- ^ The body message.
    -> Block
blockSimple' :: Style
-> FilePath
-> Maybe Header
-> (Line, Line, Maybe Header)
-> Maybe Header
-> Block
blockSimple' Style
style FilePath
fp Maybe Header
hm (Line
l, Line
c, Maybe Header
lbl) Maybe Header
bm =
    Style
-> FilePath
-> Maybe Header
-> (Line, Line, Line, Maybe Header)
-> Maybe Header
-> Block
blockSimple Style
style FilePath
fp Maybe Header
hm (Line
l, Line
c, Line
c Line -> Line -> Line
forall a. Num a => a -> a -> a
+ Line
1, Maybe Header
lbl) Maybe Header
bm

-- | A block that points to two parts of the source that are visually connected together.
blockConnected
    :: Style                               -- ^ The style of the pointer.
    -> FilePath                            -- ^ The filepath.
    -> Maybe Header                        -- ^ The header message.
    -> (Line, Column, Column, Maybe Label) -- ^ The first line number and column span, starting at 1, and a label.
    -> (Line, Column, Column, Maybe Label) -- ^ The second line number and column span, starting at 1, and a label.
    -> Maybe Body                          -- ^ The body message.
    -> Block
blockConnected :: Style
-> FilePath
-> Maybe Header
-> (Line, Line, Line, Maybe Header)
-> (Line, Line, Line, Maybe Header)
-> Maybe Header
-> Block
blockConnected Style
style FilePath
fp Maybe Header
hm (Line
l1, Line
cs1, Line
ce1, Maybe Header
lbl1) (Line
l2, Line
cs2, Line
ce2, Maybe Header
lbl2) Maybe Header
bm = Block :: Style
-> (FilePath, Line, Line)
-> Maybe Header
-> [Pointer]
-> Maybe Header
-> Block
Block
    { blockStyle :: Style
blockStyle = Style
style
    , blockLocation :: (FilePath, Line, Line)
blockLocation = (FilePath
fp, Line
l1, Line
cs1)
    , blockHeader :: Maybe Header
blockHeader = Maybe Header
hm
    , blockPointers :: [Pointer]
blockPointers = [Line -> Line -> Line -> Bool -> Maybe Header -> Pointer
Pointer Line
l1 Line
cs1 Line
ce1 Bool
True Maybe Header
lbl1, Line -> Line -> Line -> Bool -> Maybe Header -> Pointer
Pointer Line
l2 Line
cs2 Line
ce2 Bool
True Maybe Header
lbl2]
    , blockBody :: Maybe Header
blockBody = Maybe Header
bm
    }

-- | A variant of 'blockConnected' where the pointers point at only one column.
blockConnected'
    :: Style                       -- ^ The style of the pointer.
    -> FilePath                    -- ^ The filepath.
    -> Maybe Header                -- ^ The header message.
    -> (Line, Column, Maybe Label) -- ^ The first line number and column, starting at 1, and a label.
    -> (Line, Column, Maybe Label) -- ^ The second line number and column, starting at 1, and a label.
    -> Maybe Body                  -- ^ The body message.
    -> Block
blockConnected' :: Style
-> FilePath
-> Maybe Header
-> (Line, Line, Maybe Header)
-> (Line, Line, Maybe Header)
-> Maybe Header
-> Block
blockConnected' Style
style FilePath
fp Maybe Header
hm (Line
l1, Line
c1, Maybe Header
lbl1) (Line
l2, Line
c2, Maybe Header
lbl2) Maybe Header
bm =
    Style
-> FilePath
-> Maybe Header
-> (Line, Line, Line, Maybe Header)
-> (Line, Line, Line, Maybe Header)
-> Maybe Header
-> Block
blockConnected Style
style FilePath
fp Maybe Header
hm (Line
l1, Line
c1, Line
c1 Line -> Line -> Line
forall a. Num a => a -> a -> a
+ Line
1, Maybe Header
lbl1) (Line
l2, Line
c2, Line
c2 Line -> Line -> Line
forall a. Num a => a -> a -> a
+ Line
1, Maybe Header
lbl2) Maybe Header
bm

{- | A block that points to two parts of the source that are visually connected together.

If the two parts of the source happen to be on the same line, the pointers are merged into one.
-}
blockMerged
    :: Style                               -- ^ The style of the pointer.
    -> FilePath                            -- ^ The filepath.
    -> Maybe Header                        -- ^ The header message.
    -> (Line, Column, Column, Maybe Label) -- ^ The first line number and column span, starting at 1, and a label.
    -> (Line, Column, Column, Maybe Label) -- ^ The second line number and column span, starting at 1, and a label.
    -> Maybe Label                         -- ^ The label for when the two pointers are merged into one.
    -> Maybe Body                          -- ^ The body message.
    -> Block
blockMerged :: Style
-> FilePath
-> Maybe Header
-> (Line, Line, Line, Maybe Header)
-> (Line, Line, Line, Maybe Header)
-> Maybe Header
-> Maybe Header
-> Block
blockMerged Style
style FilePath
fp Maybe Header
hm (Line
l1, Line
cs1, Line
ce1, Maybe Header
lbl1) (Line
l2, Line
cs2, Line
ce2, Maybe Header
lbl2) Maybe Header
lbl Maybe Header
bm = Block :: Style
-> (FilePath, Line, Line)
-> Maybe Header
-> [Pointer]
-> Maybe Header
-> Block
Block
    { blockStyle :: Style
blockStyle = Style
style
    , blockLocation :: (FilePath, Line, Line)
blockLocation = (FilePath
fp, Line
l1, Line
cs1)
    , blockHeader :: Maybe Header
blockHeader = Maybe Header
hm
    , blockPointers :: [Pointer]
blockPointers = if Line
l1 Line -> Line -> Bool
forall a. Eq a => a -> a -> Bool
== Line
l2
        then [Line -> Line -> Line -> Bool -> Maybe Header -> Pointer
Pointer Line
l1 Line
cs1 Line
ce2 Bool
False Maybe Header
lbl]
        else [Line -> Line -> Line -> Bool -> Maybe Header -> Pointer
Pointer Line
l1 Line
cs1 Line
ce1 Bool
True Maybe Header
lbl1, Line -> Line -> Line -> Bool -> Maybe Header -> Pointer
Pointer Line
l2 Line
cs2 Line
ce2 Bool
True Maybe Header
lbl2]
    , blockBody :: Maybe Header
blockBody = Maybe Header
bm
    }

-- | A variant of 'blockMerged' where the pointers point at only one column.
blockMerged'
    :: Style                       -- ^ The style of the pointer.
    -> FilePath                    -- ^ The filepath.
    -> Maybe Header                -- ^ The header message.
    -> (Line, Column, Maybe Label) -- ^ The first line number and column, starting at 1, and a label.
    -> (Line, Column, Maybe Label) -- ^ The second line number and column, starting at 1, and a label.
    -> Maybe Label                 -- ^ The label for when the two pointers are merged into one.
    -> Maybe Body                  -- ^ The body message.
    -> Block
blockMerged' :: Style
-> FilePath
-> Maybe Header
-> (Line, Line, Maybe Header)
-> (Line, Line, Maybe Header)
-> Maybe Header
-> Maybe Header
-> Block
blockMerged' Style
style FilePath
fp Maybe Header
hm (Line
l1, Line
c1, Maybe Header
lbl1) (Line
l2, Line
c2, Maybe Header
lbl2) Maybe Header
lbl Maybe Header
bm =
    Style
-> FilePath
-> Maybe Header
-> (Line, Line, Line, Maybe Header)
-> (Line, Line, Line, Maybe Header)
-> Maybe Header
-> Maybe Header
-> Block
blockMerged Style
style FilePath
fp Maybe Header
hm (Line
l1, Line
c1, Line
c1 Line -> Line -> Line
forall a. Num a => a -> a -> a
+ Line
1, Maybe Header
lbl1) (Line
l2, Line
c2, Line
c2 Line -> Line -> Line
forall a. Num a => a -> a -> a
+ Line
1, Maybe Header
lbl2) Maybe Header
lbl Maybe Header
bm

{- | A basic style using only ASCII characters.

Errors should look like so:

> 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
> 6 | | line 6
> 7 | | line 7 baz end
>   | |______^_____^^^ end label
>   |        |
>   |        | inner label
> block body message
> error body message
-}
basicStyle :: Style
basicStyle :: Style
basicStyle = Style :: ((FilePath, Line, Line) -> Header)
-> (Line -> Header)
-> ([(Line, Line)] -> Header -> Header)
-> Header
-> Header
-> Header
-> Header
-> Header
-> Header
-> Header
-> Header
-> Style
Style
    { styleLocation :: (FilePath, Line, Line) -> Header
styleLocation = \(FilePath
fp, Line
l, Line
c) -> [Header] -> Header
T.concat [Header
"--> ", FilePath -> Header
T.pack FilePath
fp, Header
":", FilePath -> Header
T.pack (FilePath -> Header) -> FilePath -> Header
forall a b. (a -> b) -> a -> b
$ Line -> FilePath
forall a. Show a => a -> FilePath
show Line
l, Header
":", FilePath -> Header
T.pack (FilePath -> Header) -> FilePath -> Header
forall a b. (a -> b) -> a -> b
$ Line -> FilePath
forall a. Show a => a -> FilePath
show Line
c]
    , styleNumber :: Line -> Header
styleNumber = FilePath -> Header
T.pack (FilePath -> Header) -> (Line -> FilePath) -> Line -> Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> FilePath
forall a. Show a => a -> FilePath
show
    , styleLine :: [(Line, Line)] -> Header -> Header
styleLine = (Header -> Header) -> [(Line, Line)] -> Header -> Header
forall a b. a -> b -> a
const Header -> Header
forall a. a -> a
id
    , styleEllipsis :: Header
styleEllipsis = Header
"."
    , styleLinePrefix :: Header
styleLinePrefix = Header
"|"
    , styleUnderline :: Header
styleUnderline = Header
"^"
    , styleVertical :: Header
styleVertical = Header
"|"
    , styleHorizontal :: Header
styleHorizontal = Header
"_"
    , styleDownRight :: Header
styleDownRight = Header
" "
    , styleUpRight :: Header
styleUpRight = Header
"|"
    , styleUpDownRight :: Header
styleUpDownRight = Header
"|"
    }

{- | A fancy style using Unicode characters.

Errors should look like so:

> 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
> 6 │ │ line 6
> 7 │ │ line 7 baz end
>   │ └──────^─────^^^ end label
>   │        │
>   │        └ inner label
> block body message
> error body message
-}
fancyStyle :: Style
fancyStyle :: Style
fancyStyle = Style :: ((FilePath, Line, Line) -> Header)
-> (Line -> Header)
-> ([(Line, Line)] -> Header -> Header)
-> Header
-> Header
-> Header
-> Header
-> Header
-> Header
-> Header
-> Header
-> Style
Style
    { styleLocation :: (FilePath, Line, Line) -> Header
styleLocation = \(FilePath
fp, Line
l, Line
c) -> [Header] -> Header
T.concat
        [ Header
"→ ", FilePath -> Header
T.pack FilePath
fp, Header
":", FilePath -> Header
T.pack (FilePath -> Header) -> FilePath -> Header
forall a b. (a -> b) -> a -> b
$ Line -> FilePath
forall a. Show a => a -> FilePath
show Line
l, Header
":", FilePath -> Header
T.pack (FilePath -> Header) -> FilePath -> Header
forall a b. (a -> b) -> a -> b
$ Line -> FilePath
forall a. Show a => a -> FilePath
show Line
c
        ]
    , styleNumber :: Line -> Header
styleNumber = FilePath -> Header
T.pack (FilePath -> Header) -> (Line -> FilePath) -> Line -> Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> FilePath
forall a. Show a => a -> FilePath
show
    , styleLine :: [(Line, Line)] -> Header -> Header
styleLine = (Header -> Header) -> [(Line, Line)] -> Header -> Header
forall a b. a -> b -> a
const Header -> Header
forall a. a -> a
id
    , styleEllipsis :: Header
styleEllipsis = Header
"."
    , styleLinePrefix :: Header
styleLinePrefix = Header
"│"
    , styleUnderline :: Header
styleUnderline = Header
"^"
    , styleHorizontal :: Header
styleHorizontal = Header
"─"
    , styleVertical :: Header
styleVertical = Header
"│"
    , styleDownRight :: Header
styleDownRight = Header
"┌"
    , styleUpDownRight :: Header
styleUpDownRight = Header
"├"
    , styleUpRight :: Header
styleUpRight = Header
"└"
    }

-- | A fancy style using Unicode characters and ANSI colors, similar to 'fancyStyle'. Most things are colored red.
fancyRedStyle :: Style
fancyRedStyle :: Style
fancyRedStyle = Style :: ((FilePath, Line, Line) -> Header)
-> (Line -> Header)
-> ([(Line, Line)] -> Header -> Header)
-> Header
-> Header
-> Header
-> Header
-> Header
-> Header
-> Header
-> Header
-> Style
Style
    { styleLocation :: (FilePath, Line, Line) -> Header
styleLocation = \(FilePath
fp, Line
l, Line
c) -> [Header] -> Header
T.concat
        [ Header
"\x1b[34m→\x1b[0m ", FilePath -> Header
T.pack FilePath
fp, Header
":", FilePath -> Header
T.pack (FilePath -> Header) -> FilePath -> Header
forall a b. (a -> b) -> a -> b
$ Line -> FilePath
forall a. Show a => a -> FilePath
show Line
l, Header
":", FilePath -> Header
T.pack (FilePath -> Header) -> FilePath -> Header
forall a b. (a -> b) -> a -> b
$ Line -> FilePath
forall a. Show a => a -> FilePath
show Line
c
        ]
    , styleNumber :: Line -> Header
styleNumber = FilePath -> Header
T.pack (FilePath -> Header) -> (Line -> FilePath) -> Line -> Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> FilePath
forall a. Show a => a -> FilePath
show
    , styleLine :: [(Line, Line)] -> Header -> Header
styleLine = Header -> Header -> [(Line, Line)] -> Header -> Header
highlight Header
"\x1b[31m" Header
"\x1b[0m"
    , styleEllipsis :: Header
styleEllipsis = Header
"."
    , styleLinePrefix :: Header
styleLinePrefix = Header
"\x1b[34m│\x1b[0m"
    , styleUnderline :: Header
styleUnderline = Header
"\x1b[31m^\x1b[0m"
    , styleHorizontal :: Header
styleHorizontal = Header
"\x1b[31m─\x1b[0m"
    , styleVertical :: Header
styleVertical = Header
"\x1b[31m│\x1b[0m"
    , styleDownRight :: Header
styleDownRight = Header
"\x1b[31m┌\x1b[0m"
    , styleUpDownRight :: Header
styleUpDownRight = Header
"\x1b[31m├\x1b[0m"
    , styleUpRight :: Header
styleUpRight = Header
"\x1b[31m└\x1b[0m"
    }

-- | A fancy style using Unicode characters and ANSI colors, similar to 'fancyStyle'. Most things are colored yellow.
fancyYellowStyle :: Style
fancyYellowStyle :: Style
fancyYellowStyle = Style :: ((FilePath, Line, Line) -> Header)
-> (Line -> Header)
-> ([(Line, Line)] -> Header -> Header)
-> Header
-> Header
-> Header
-> Header
-> Header
-> Header
-> Header
-> Header
-> Style
Style
    { styleLocation :: (FilePath, Line, Line) -> Header
styleLocation = \(FilePath
fp, Line
l, Line
c) -> [Header] -> Header
T.concat
        [ Header
"\x1b[34m→\x1b[0m ", FilePath -> Header
T.pack FilePath
fp, Header
":", FilePath -> Header
T.pack (FilePath -> Header) -> FilePath -> Header
forall a b. (a -> b) -> a -> b
$ Line -> FilePath
forall a. Show a => a -> FilePath
show Line
l, Header
":", FilePath -> Header
T.pack (FilePath -> Header) -> FilePath -> Header
forall a b. (a -> b) -> a -> b
$ Line -> FilePath
forall a. Show a => a -> FilePath
show Line
c
        ]
    , styleNumber :: Line -> Header
styleNumber = FilePath -> Header
T.pack (FilePath -> Header) -> (Line -> FilePath) -> Line -> Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> FilePath
forall a. Show a => a -> FilePath
show
    , styleLine :: [(Line, Line)] -> Header -> Header
styleLine = Header -> Header -> [(Line, Line)] -> Header -> Header
highlight Header
"\x1b[33m" Header
"\x1b[0m"
    , styleEllipsis :: Header
styleEllipsis = Header
"."
    , styleLinePrefix :: Header
styleLinePrefix = Header
"\x1b[34m│\x1b[0m"
    , styleUnderline :: Header
styleUnderline = Header
"\x1b[33m^\x1b[0m"
    , styleHorizontal :: Header
styleHorizontal = Header
"\x1b[33m─\x1b[0m"
    , styleVertical :: Header
styleVertical = Header
"\x1b[33m│\x1b[0m"
    , styleDownRight :: Header
styleDownRight = Header
"\x1b[33m┌\x1b[0m"
    , styleUpRight :: Header
styleUpRight = Header
"\x1b[33m└\x1b[0m"
    , styleUpDownRight :: Header
styleUpDownRight = Header
"\x1b[33m├\x1b[0m"
    }

{- | Pretty prints errors. The original source is required. Returns 'Data.Text.Lazy.Text' (lazy). If the list is empty,
an empty string is returned.

Suppose we had an error of this type:

> data ParseError = ParseError
>     { peFile       :: FilePath
>     , peLine       :: Int
>     , peCol        :: Int
>     , peUnexpected :: T.Text
>     , peExpected   :: [T.Text]
>     }

Then we can create a simple pretty printer like so:

@
import qualified Data.Text as T
import qualified Data.Text.Lazy.IO as TL
import           "Errata"

toErrata :: ParseError -> 'Errata'
toErrata (ParseError fp l c unexpected expected) =
    'errataSimple'
        (Just \"an error occured!\")
        ('blockSimple' 'basicStyle' fp
            (Just \"error: invalid syntax\")
            (l, c, c + T.length unexpected, Just \"this one\")
            (Just $ \"unexpected \" \<> unexpected \<> \"\\nexpected \" \<> T.intercalate \", \" expected))
        Nothing

printErrors :: T.Text -> [ParseError] -> IO ()
printErrors source es = TL.putStrLn $ 'prettyErrors' source (map toErrata es)
@

Note that in the above example, we have @OverloadedStrings@ enabled to reduce uses of 'Data.Text.pack'.

An example error message from this might be:

> an error occured!
> --> ./comma.json:2:18
> error: invalid syntax
>   |
> 2 |     "bad": [1, 2,]
>   |                  ^ this one
> unexpected ]
> expected null, true, false, ", -, digit, [, {
-}
prettyErrors :: Source source => source -> [Errata] -> TL.Text
prettyErrors :: source -> [Errata] -> Text
prettyErrors source
source [Errata]
errs = Builder -> Text
TB.toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ source -> [Errata] -> Builder
forall source. Source source => source -> [Errata] -> Builder
renderErrors source
source [Errata]
errs