{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
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)
data Diagnostic msg
= Diagnostic
(DList (Report msg))
!FileMap
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
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
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
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
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
prettyDiagnostic ::
Pretty msg =>
Bool ->
Int ->
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 #-}
printDiagnostic ::
(MonadIO m, Pretty msg) =>
Handle ->
Bool ->
Bool ->
Int ->
Style ->
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 #-}
addFile ::
Diagnostic msg ->
FilePath ->
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 #-}
addReport ::
Diagnostic msg ->
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
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