{-# 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, prettyReport)
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 reports files) =
object [ "files" .= fmap toJSONFile (fmap toList <$> (HashMap.toList files))
, "reports" .= reports
]
where
toJSONFile (path, content) =
object [ "name" .= path
, "content" .= content
]
#endif
prettyDiagnostic ::
Pretty msg =>
Bool ->
Int ->
Diagnostic msg ->
Doc Annotation
prettyDiagnostic :: 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 :: 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 :: Diagnostic msg -> FilePath -> FilePath -> Diagnostic msg
addFile (Diagnostic DList (Report msg)
reports FileMap
files) FilePath
path FilePath
content =
let fileLines :: [FilePath]
fileLines = FilePath -> [FilePath]
lines FilePath
content
lineCount :: Int
lineCount = [FilePath] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
fileLines
lineArray :: Array Int FilePath
lineArray = (Int, Int) -> [FilePath] -> Array Int FilePath
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) [FilePath]
fileLines
in DList (Report msg) -> FileMap -> Diagnostic msg
forall msg. DList (Report msg) -> FileMap -> Diagnostic msg
Diagnostic DList (Report msg)
reports (FilePath -> Array Int FilePath -> FileMap -> FileMap
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert FilePath
path Array Int FilePath
lineArray FileMap
files)
{-# INLINE addFile #-}
addReport ::
Diagnostic msg ->
Report msg ->
Diagnostic msg
addReport :: 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 = encode
#endif