{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}

-- |
-- Module      : Error.Diagnose.Diagnostic.Internal
-- Description : Internal workings for diagnostic definitions and pretty printing.
-- Copyright   : (c) Mesabloo, 2021-2022
-- License     : BSD3
-- Stability   : experimental
-- Portability : Portable
--
-- /Warning/: The API of this module can break between two releases, therefore you should not rely on it.
--            It is also highly undocumented.
--
--            Please limit yourself to the "Error.Diagnose.Diagnostic" module, which exports some of the useful functions defined here.
module Error.Diagnose.Diagnostic.Internal (module Error.Diagnose.Diagnostic.Internal, def) where

import Control.Monad.IO.Class (MonadIO, liftIO)
#ifdef USE_AESON
import Data.Aeson (ToJSON(..), encode, object, (.=))
import Data.ByteString.Lazy (ByteString)
#endif

import Data.Array (listArray)
import Data.DList (DList)
import qualified Data.DList as DL
import Data.Default (Default, def)
import Data.Foldable (fold, toList)
import qualified Data.HashMap.Lazy as HashMap
import Data.List (intersperse)
import Error.Diagnose.Report (Report)
import Error.Diagnose.Report.Internal (FileMap, errorToWarning, prettyReport, warningToError)
import Error.Diagnose.Style (Annotation, Style)
import Prettyprinter (Doc, Pretty, hardline, unAnnotate)
import Prettyprinter.Render.Terminal (hPutDoc)
import System.IO (Handle)

-- | The data type for diagnostic containing messages of an abstract type.
--
--   The constructors are private, but users can use 'def' from the 'Default' typeclass
--   to create a new empty diagnostic, and 'addFile' and 'addReport' to alter its internal state.
data Diagnostic msg
  = Diagnostic
      (DList (Report msg))
      -- ^ All the reports contained in a diagnostic.
      --
      --   Reports are output one by one, without connections in between.
      !FileMap
      -- ^ A map associating files with their content as lists of lines.

instance Default (Diagnostic msg) where
  def :: Diagnostic msg
def = DList (Report msg) -> FileMap -> Diagnostic msg
forall msg. DList (Report msg) -> FileMap -> Diagnostic msg
Diagnostic DList (Report msg)
forall a. Monoid a => a
mempty FileMap
forall a. Monoid a => a
mempty

instance Semigroup (Diagnostic msg) where
  Diagnostic DList (Report msg)
rs1 FileMap
file <> :: Diagnostic msg -> Diagnostic msg -> Diagnostic msg
<> Diagnostic DList (Report msg)
rs2 FileMap
_ = DList (Report msg) -> FileMap -> Diagnostic msg
forall msg. DList (Report msg) -> FileMap -> Diagnostic msg
Diagnostic (DList (Report msg)
rs1 DList (Report msg) -> DList (Report msg) -> DList (Report msg)
forall a. Semigroup a => a -> a -> a
<> DList (Report msg)
rs2) FileMap
file

#ifdef USE_AESON
instance ToJSON msg => ToJSON (Diagnostic msg) where
  toJSON :: Diagnostic msg -> Value
toJSON (Diagnostic DList (Report msg)
reports FileMap
files) =
    [Pair] -> Value
object [ Text
"files" Text -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (([Char], [[Char]]) -> Value) -> [([Char], [[Char]])] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char], [[Char]]) -> Value
forall {v} {v}. (ToJSON v, ToJSON v) => (v, v) -> Value
toJSONFile ((Array Int [Char] -> [[Char]])
-> ([Char], Array Int [Char]) -> ([Char], [[Char]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Array Int [Char] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (([Char], Array Int [Char]) -> ([Char], [[Char]]))
-> [([Char], Array Int [Char])] -> [([Char], [[Char]])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FileMap -> [([Char], Array Int [Char])]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList FileMap
files))
           , Text
"reports" Text -> DList (Report msg) -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= DList (Report msg)
reports
           ]
    where
      toJSONFile :: (v, v) -> Value
toJSONFile (v
path, v
content) =
        [Pair] -> Value
object [ Text
"name" Text -> v -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= v
path
               , Text
"content" Text -> v -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= v
content
               ]
#endif

-- | Checks whether the given diagnostic has any report or not (if it is effectively empty).
hasReports :: Diagnostic msg -> Bool
hasReports :: forall msg. Diagnostic msg -> Bool
hasReports (Diagnostic DList (Report msg)
DL.Nil FileMap
_) = Bool
False
hasReports Diagnostic msg
_ = Bool
True

-- | Retrieves the reports for this diagnostic.
reportsOf :: Diagnostic msg -> [Report msg]
reportsOf :: forall msg. Diagnostic msg -> [Report msg]
reportsOf (Diagnostic DList (Report msg)
reports FileMap
_) = DList (Report msg) -> [Report msg]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList DList (Report msg)
reports

-- | Transforms every warning report in this diagnostic into an error report.
warningsToErrors :: Diagnostic msg -> Diagnostic msg
warningsToErrors :: forall msg. Diagnostic msg -> Diagnostic msg
warningsToErrors (Diagnostic DList (Report msg)
reports FileMap
files) = DList (Report msg) -> FileMap -> Diagnostic msg
forall msg. DList (Report msg) -> FileMap -> Diagnostic msg
Diagnostic (Report msg -> Report msg
forall msg. Report msg -> Report msg
warningToError (Report msg -> Report msg)
-> DList (Report msg) -> DList (Report msg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DList (Report msg)
reports) FileMap
files

-- | Transforms every error report in this diagnostic into a warning report.
errorsToWarnings :: Diagnostic msg -> Diagnostic msg
errorsToWarnings :: forall msg. Diagnostic msg -> Diagnostic msg
errorsToWarnings (Diagnostic DList (Report msg)
reports FileMap
files) = DList (Report msg) -> FileMap -> Diagnostic msg
forall msg. DList (Report msg) -> FileMap -> Diagnostic msg
Diagnostic (Report msg -> Report msg
forall msg. Report msg -> Report msg
errorToWarning (Report msg -> Report msg)
-> DList (Report msg) -> DList (Report msg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DList (Report msg)
reports) FileMap
files

-- | Pretty prints a 'Diagnostic' into a 'Doc'ument that can be output using 'hPutDoc'.
--
--   Colors are put by default.
--   If you do not want these, just 'unAnnotate' the resulting document like so:
--
--   >>> let doc = unAnnotate (prettyDiagnostic withUnicode tabSize diagnostic)
--
--   Changing the style is also rather easy:
--
--   >>> let myCustomStyle :: Style = _
--   >>> let doc = myCustomStyle (prettyDiagnostic withUnicode tabSize diagnostic)
prettyDiagnostic ::
  Pretty msg =>
  -- | Should we use unicode when printing paths?
  Bool ->
  -- | The number of spaces each TAB character will span.
  Int ->
  -- | The diagnostic to print.
  Diagnostic msg ->
  Doc Annotation
prettyDiagnostic :: forall msg.
Pretty msg =>
Bool -> Int -> Diagnostic msg -> Doc Annotation
prettyDiagnostic Bool
withUnicode Int
tabSize (Diagnostic DList (Report msg)
reports FileMap
file) =
  [Doc Annotation] -> Doc Annotation
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Doc Annotation] -> Doc Annotation)
-> ([Doc Annotation] -> [Doc Annotation])
-> [Doc Annotation]
-> Doc Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Annotation -> [Doc Annotation] -> [Doc Annotation]
forall a. a -> [a] -> [a]
intersperse Doc Annotation
forall ann. Doc ann
hardline ([Doc Annotation] -> Doc Annotation)
-> [Doc Annotation] -> Doc Annotation
forall a b. (a -> b) -> a -> b
$ FileMap -> Bool -> Int -> Report msg -> Doc Annotation
forall msg.
Pretty msg =>
FileMap -> Bool -> Int -> Report msg -> Doc Annotation
prettyReport FileMap
file Bool
withUnicode Int
tabSize (Report msg -> Doc Annotation) -> [Report msg] -> [Doc Annotation]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DList (Report msg) -> [Report msg]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList DList (Report msg)
reports
{-# INLINE prettyDiagnostic #-}

-- | Prints a 'Diagnostic' onto a specific 'Handle'.
printDiagnostic ::
  (MonadIO m, Pretty msg) =>
  -- | The handle onto which to output the diagnostic.
  Handle ->
  -- | Should we print with unicode characters?
  Bool ->
  -- | 'False' to disable colors.
  Bool ->
  -- | The number of spaces each TAB character will span.
  Int ->
  -- | The style in which to output the diagnostic.
  Style ->
  -- | The diagnostic to output.
  Diagnostic msg ->
  m ()
printDiagnostic :: forall (m :: * -> *) msg.
(MonadIO m, Pretty msg) =>
Handle -> Bool -> Bool -> Int -> Style -> Diagnostic msg -> m ()
printDiagnostic Handle
handle Bool
withUnicode Bool
withColors Int
tabSize Style
style Diagnostic msg
diag =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
handle ((if Bool
withColors then Style
style else Style
forall ann xxx. Doc ann -> Doc xxx
unAnnotate) Style -> Style
forall a b. (a -> b) -> a -> b
$ Bool -> Int -> Diagnostic msg -> Doc Annotation
forall msg.
Pretty msg =>
Bool -> Int -> Diagnostic msg -> Doc Annotation
prettyDiagnostic Bool
withUnicode Int
tabSize Diagnostic msg
diag)
{-# INLINE printDiagnostic #-}

-- | Inserts a new referenceable file within the diagnostic.
addFile ::
  Diagnostic msg ->
  -- | The path to the file.
  FilePath ->
  -- | The content of the file as a single string, where lines are ended by @\\n@.
  String ->
  Diagnostic msg
addFile :: forall msg. Diagnostic msg -> [Char] -> [Char] -> Diagnostic msg
addFile (Diagnostic DList (Report msg)
reports FileMap
files) [Char]
path [Char]
content =
  let fileLines :: [[Char]]
fileLines = [Char] -> [[Char]]
lines [Char]
content
      lineCount :: Int
lineCount = [[Char]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
fileLines
      lineArray :: Array Int [Char]
lineArray = (Int, Int) -> [[Char]] -> Array Int [Char]
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
lineCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [[Char]]
fileLines
   in DList (Report msg) -> FileMap -> Diagnostic msg
forall msg. DList (Report msg) -> FileMap -> Diagnostic msg
Diagnostic DList (Report msg)
reports ([Char] -> Array Int [Char] -> FileMap -> FileMap
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert [Char]
path Array Int [Char]
lineArray FileMap
files)
{-# INLINE addFile #-}

-- | Inserts a new report into a diagnostic.
addReport ::
  Diagnostic msg ->
  -- | The new report to add to the diagnostic.
  Report msg ->
  Diagnostic msg
addReport :: forall msg. Diagnostic msg -> Report msg -> Diagnostic msg
addReport (Diagnostic DList (Report msg)
reports FileMap
files) Report msg
report =
  DList (Report msg) -> FileMap -> Diagnostic msg
forall msg. DList (Report msg) -> FileMap -> Diagnostic msg
Diagnostic (DList (Report msg)
reports DList (Report msg) -> Report msg -> DList (Report msg)
forall a. DList a -> a -> DList a
`DL.snoc` Report msg
report) FileMap
files
{-# INLINE addReport #-}

#ifdef USE_AESON
-- | Creates a JSON object from a diagnostic, containing those fields (only types are indicated):
--
--   > { files:
--   >     { name: string
--   >     , content: string[]
--   >     }[]
--   > , reports:
--   >     { kind: 'error' | 'warning'
--   >     , code: T?
--   >     , message: T
--   >     , markers:
--   >         { kind: 'this' | 'where' | 'maybe'
--   >         , position:
--   >             { beginning: { line: int, column: int }
--   >             , end: { line: int, column: int }
--   >             , file: string
--   >             }
--   >         , message: T
--   >         }[]
--   >     , hints: ({ note: T } | { hint: T })[]
--   >     }[]
--   > }
--
--   where @T@ is the type of the JSON representation for the @msg@ type variable.
diagnosticToJson :: ToJSON msg => Diagnostic msg -> ByteString
diagnosticToJson :: forall msg. ToJSON msg => Diagnostic msg -> ByteString
diagnosticToJson = Diagnostic msg -> ByteString
forall a. ToJSON a => a -> ByteString
encode
#endif