{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveTraversable #-}
{-# 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, WithUnicode(..), TabSize(..)) 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.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, WithUnicode(..), TabSize(..))
import Error.Diagnose.Style (Annotation, Style)
import Prettyprinter (Doc, Pretty, hardline, pretty, defaultLayoutOptions, reAnnotateS, layoutPretty)
import Prettyprinter.Render.Terminal (renderIO)
import System.IO (Handle)

-- | The data type for diagnostic containing messages of an abstract type.
--
--   Users can use 'mempty' 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.
  deriving (forall a b. a -> Diagnostic b -> Diagnostic a
forall a b. (a -> b) -> Diagnostic a -> Diagnostic 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 -> Diagnostic b -> Diagnostic a
$c<$ :: forall a b. a -> Diagnostic b -> Diagnostic a
fmap :: forall a b. (a -> b) -> Diagnostic a -> Diagnostic b
$cfmap :: forall a b. (a -> b) -> Diagnostic a -> Diagnostic b
Functor, forall a. Eq a => a -> Diagnostic a -> Bool
forall a. Num a => Diagnostic a -> a
forall a. Ord a => Diagnostic a -> a
forall m. Monoid m => Diagnostic m -> m
forall a. Diagnostic a -> Bool
forall a. Diagnostic a -> Int
forall a. Diagnostic a -> [a]
forall a. (a -> a -> a) -> Diagnostic a -> a
forall m a. Monoid m => (a -> m) -> Diagnostic a -> m
forall b a. (b -> a -> b) -> b -> Diagnostic a -> b
forall a b. (a -> b -> b) -> b -> Diagnostic 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 => Diagnostic a -> a
$cproduct :: forall a. Num a => Diagnostic a -> a
sum :: forall a. Num a => Diagnostic a -> a
$csum :: forall a. Num a => Diagnostic a -> a
minimum :: forall a. Ord a => Diagnostic a -> a
$cminimum :: forall a. Ord a => Diagnostic a -> a
maximum :: forall a. Ord a => Diagnostic a -> a
$cmaximum :: forall a. Ord a => Diagnostic a -> a
elem :: forall a. Eq a => a -> Diagnostic a -> Bool
$celem :: forall a. Eq a => a -> Diagnostic a -> Bool
length :: forall a. Diagnostic a -> Int
$clength :: forall a. Diagnostic a -> Int
null :: forall a. Diagnostic a -> Bool
$cnull :: forall a. Diagnostic a -> Bool
toList :: forall a. Diagnostic a -> [a]
$ctoList :: forall a. Diagnostic a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Diagnostic a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Diagnostic a -> a
foldr1 :: forall a. (a -> a -> a) -> Diagnostic a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Diagnostic a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Diagnostic a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Diagnostic a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Diagnostic a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Diagnostic a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Diagnostic a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Diagnostic a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Diagnostic a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Diagnostic a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Diagnostic a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Diagnostic a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Diagnostic a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Diagnostic a -> m
fold :: forall m. Monoid m => Diagnostic m -> m
$cfold :: forall m. Monoid m => Diagnostic m -> m
Foldable, Functor Diagnostic
Foldable Diagnostic
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 =>
Diagnostic (m a) -> m (Diagnostic a)
forall (f :: * -> *) a.
Applicative f =>
Diagnostic (f a) -> f (Diagnostic a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Diagnostic a -> m (Diagnostic b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Diagnostic a -> f (Diagnostic b)
sequence :: forall (m :: * -> *) a.
Monad m =>
Diagnostic (m a) -> m (Diagnostic a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
Diagnostic (m a) -> m (Diagnostic a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Diagnostic a -> m (Diagnostic b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Diagnostic a -> m (Diagnostic b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Diagnostic (f a) -> f (Diagnostic a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Diagnostic (f a) -> f (Diagnostic a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Diagnostic a -> f (Diagnostic b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Diagnostic a -> f (Diagnostic b)
Traversable)

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

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

#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 [ Key
"files" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {v} {v}. (ToJSON v, ToJSON v) => (v, v) -> Value
toJSONFile (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall k v. HashMap k v -> [(k, v)]
HashMap.toList FileMap
files))
           , Key
"reports" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DList (Report msg)
reports
           ]
    where
      toJSONFile :: (v, v) -> Value
toJSONFile (v
path, v
content) =
        [Pair] -> Value
object [ Key
"name" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= v
path
               , Key
"content" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> 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 a. Diagnostic a -> 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
_) = 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) = forall msg. DList (Report msg) -> FileMap -> Diagnostic msg
Diagnostic (forall msg. Report msg -> Report msg
warningToError 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) = forall msg. DList (Report msg) -> FileMap -> Diagnostic msg
Diagnostic (forall msg. Report msg -> Report msg
errorToWarning 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?
  WithUnicode ->
  -- | The number of spaces each TAB character will span.
  TabSize ->
  -- | The diagnostic to print.
  Diagnostic msg ->
  Doc (Annotation ann)
prettyDiagnostic :: forall msg ann.
Pretty msg =>
WithUnicode -> TabSize -> Diagnostic msg -> Doc (Annotation ann)
prettyDiagnostic WithUnicode
withUnicode TabSize
tabSize =
  forall ann.
WithUnicode
-> TabSize -> Diagnostic (Doc ann) -> Doc (Annotation ann)
prettyDiagnostic' WithUnicode
withUnicode TabSize
tabSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a ann. Pretty a => a -> Doc ann
pretty
{-# INLINE prettyDiagnostic #-}

-- | Like 'prettyDiagnostic' except that instead of requiring a 'pretty'
-- instance for messages, this allows passing in your own 'Doc'. Custom
-- annotations are retained in 'OtherStyle'
prettyDiagnostic' ::
  -- | Should we use unicode when printing paths?
  WithUnicode ->
  -- | The number of spaces each TAB character will span.
  TabSize ->
  -- | The diagnostic to print.
  Diagnostic (Doc ann) ->
  Doc (Annotation ann)
prettyDiagnostic' :: forall ann.
WithUnicode
-> TabSize -> Diagnostic (Doc ann) -> Doc (Annotation ann)
prettyDiagnostic' WithUnicode
withUnicode TabSize
tabSize (Diagnostic DList (Report (Doc ann))
reports FileMap
file) =
  forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse forall ann. Doc ann
hardline forall a b. (a -> b) -> a -> b
$ forall ann.
FileMap
-> WithUnicode
-> TabSize
-> Report (Doc ann)
-> Doc (Annotation ann)
prettyReport FileMap
file WithUnicode
withUnicode TabSize
tabSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList DList (Report (Doc ann))
reports

-- | 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?
  WithUnicode ->
  -- | The number of spaces each TAB character will span.
  TabSize ->
  -- | The style in which to output the diagnostic.
  Style ann ->
  -- | The diagnostic to output.
  Diagnostic msg ->
  m ()
printDiagnostic :: forall (m :: * -> *) msg ann.
(MonadIO m, Pretty msg) =>
Handle
-> WithUnicode -> TabSize -> Style ann -> Diagnostic msg -> m ()
printDiagnostic Handle
handle WithUnicode
withUnicode TabSize
tabSize Style ann
style =
  forall (m :: * -> *) ann.
MonadIO m =>
Handle
-> WithUnicode
-> TabSize
-> Style ann
-> Diagnostic (Doc ann)
-> m ()
printDiagnostic' Handle
handle WithUnicode
withUnicode TabSize
tabSize Style ann
style forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a ann. Pretty a => a -> Doc ann
pretty
{-# INLINE printDiagnostic #-}

-- | Like 'printDiagnostic' except that instead of requiring a 'pretty'
-- instance for messages, this allows passing in your own 'Doc'.
printDiagnostic' ::
  MonadIO m =>
  -- | The handle onto which to output the diagnostic.
  Handle ->
  -- | Should we print with unicode characters?
  WithUnicode ->
  -- | The number of spaces each TAB character will span.
  TabSize ->
  -- | The style in which to output the diagnostic.
  Style ann ->
  -- | The diagnostic to output.
  Diagnostic (Doc ann) ->
  m ()
printDiagnostic' :: forall (m :: * -> *) ann.
MonadIO m =>
Handle
-> WithUnicode
-> TabSize
-> Style ann
-> Diagnostic (Doc ann)
-> m ()
printDiagnostic' Handle
handle WithUnicode
withUnicode TabSize
tabSize Style ann
style =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> SimpleDocStream AnsiStyle -> IO ()
renderIO Handle
handle
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann ann'.
(ann -> ann') -> SimpleDocStream ann -> SimpleDocStream ann'
reAnnotateS Style ann
style
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann.
WithUnicode
-> TabSize -> Diagnostic (Doc ann) -> Doc (Annotation ann)
prettyDiagnostic' WithUnicode
withUnicode TabSize
tabSize

-- | 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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
fileLines
      lineArray :: Array Int [Char]
lineArray = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, Int
lineCount forall a. Num a => a -> a -> a
- Int
1) [[Char]]
fileLines
   in forall msg. DList (Report msg) -> FileMap -> Diagnostic msg
Diagnostic DList (Report msg)
reports (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 =
  forall msg. DList (Report msg) -> FileMap -> Diagnostic msg
Diagnostic (DList (Report msg)
reports 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 = forall a. ToJSON a => a -> ByteString
encode
#endif