{-# 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.Default (Default, def)
import Data.Foldable (fold)
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HashMap
import Data.List (intersperse)
import Error.Diagnose.Report (Report)
import Error.Diagnose.Report.Internal (prettyReport)
import Prettyprinter (Doc, Pretty, hardline, unAnnotate)
import Prettyprinter.Render.Terminal (AnsiStyle, hPutDoc)
import System.IO (Handle)
data Diagnostic msg
= Diagnostic
[Report msg]
(HashMap FilePath [String])
instance Default (Diagnostic msg) where
def :: Diagnostic msg
def = [Report msg] -> HashMap FilePath [FilePath] -> Diagnostic msg
forall msg.
[Report msg] -> HashMap FilePath [FilePath] -> Diagnostic msg
Diagnostic [Report msg]
forall a. Monoid a => a
mempty HashMap FilePath [FilePath]
forall a. Monoid a => a
mempty
instance Semigroup (Diagnostic msg) where
Diagnostic [Report msg]
rs1 HashMap FilePath [FilePath]
file <> :: Diagnostic msg -> Diagnostic msg -> Diagnostic msg
<> Diagnostic [Report msg]
rs2 HashMap FilePath [FilePath]
_ = [Report msg] -> HashMap FilePath [FilePath] -> Diagnostic msg
forall msg.
[Report msg] -> HashMap FilePath [FilePath] -> Diagnostic msg
Diagnostic ([Report msg]
rs1 [Report msg] -> [Report msg] -> [Report msg]
forall a. Semigroup a => a -> a -> a
<> [Report msg]
rs2) HashMap FilePath [FilePath]
file
#ifdef USE_AESON
instance ToJSON msg => ToJSON (Diagnostic msg) where
toJSON :: Diagnostic msg -> Value
toJSON (Diagnostic [Report msg]
reports HashMap FilePath [FilePath]
files) =
[Pair] -> Value
object [ Text
"files" Text -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ((FilePath, [FilePath]) -> Value)
-> [(FilePath, [FilePath])] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath, [FilePath]) -> Value
forall v v. (ToJSON v, ToJSON v) => (v, v) -> Value
toJSONFile (HashMap FilePath [FilePath] -> [(FilePath, [FilePath])]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap FilePath [FilePath]
files)
, Text
"reports" Text -> [Report msg] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [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
prettyDiagnostic ::
Pretty msg =>
Bool ->
Int ->
Diagnostic msg ->
Doc AnsiStyle
prettyDiagnostic :: Bool -> Int -> Diagnostic msg -> Doc AnsiStyle
prettyDiagnostic Bool
withUnicode Int
tabSize (Diagnostic [Report msg]
reports HashMap FilePath [FilePath]
file) =
[Doc AnsiStyle] -> Doc AnsiStyle
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Doc AnsiStyle] -> Doc AnsiStyle)
-> ([Doc AnsiStyle] -> [Doc AnsiStyle])
-> [Doc AnsiStyle]
-> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. a -> [a] -> [a]
intersperse Doc AnsiStyle
forall ann. Doc ann
hardline ([Doc AnsiStyle] -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ HashMap FilePath [FilePath]
-> Bool -> Int -> Report msg -> Doc AnsiStyle
forall msg.
Pretty msg =>
HashMap FilePath [FilePath]
-> Bool -> Int -> Report msg -> Doc AnsiStyle
prettyReport HashMap FilePath [FilePath]
file Bool
withUnicode Int
tabSize (Report msg -> Doc AnsiStyle) -> [Report msg] -> [Doc AnsiStyle]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Report msg]
reports
{-# INLINE prettyDiagnostic #-}
printDiagnostic ::
(MonadIO m, Pretty msg) =>
Handle ->
Bool ->
Bool ->
Int ->
Diagnostic msg ->
m ()
printDiagnostic :: Handle -> Bool -> Bool -> Int -> Diagnostic msg -> m ()
printDiagnostic Handle
handle Bool
withUnicode Bool
withColors Int
tabSize 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 (Bool
-> (Doc AnsiStyle -> Doc AnsiStyle)
-> Doc AnsiStyle
-> Doc AnsiStyle
forall a. Bool -> (a -> a) -> a -> a
unlessId Bool
withColors Doc AnsiStyle -> Doc AnsiStyle
forall ann xxx. Doc ann -> Doc xxx
unAnnotate (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Bool -> Int -> Diagnostic msg -> Doc AnsiStyle
forall msg.
Pretty msg =>
Bool -> Int -> Diagnostic msg -> Doc AnsiStyle
prettyDiagnostic Bool
withUnicode Int
tabSize Diagnostic msg
diag)
where
unlessId :: Bool -> (a -> a) -> a -> a
unlessId Bool
cond a -> a
app = if Bool
cond then a -> a
forall a. a -> a
id else a -> a
app
{-# INLINE unlessId #-}
{-# INLINE printDiagnostic #-}
addFile ::
Diagnostic msg ->
FilePath ->
String ->
Diagnostic msg
addFile :: Diagnostic msg -> FilePath -> FilePath -> Diagnostic msg
addFile (Diagnostic [Report msg]
reports HashMap FilePath [FilePath]
files) FilePath
path FilePath
content =
[Report msg] -> HashMap FilePath [FilePath] -> Diagnostic msg
forall msg.
[Report msg] -> HashMap FilePath [FilePath] -> Diagnostic msg
Diagnostic [Report msg]
reports (FilePath
-> [FilePath]
-> HashMap FilePath [FilePath]
-> HashMap FilePath [FilePath]
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert FilePath
path (FilePath -> [FilePath]
lines FilePath
content) HashMap FilePath [FilePath]
files)
{-# INLINE addFile #-}
addReport ::
Diagnostic msg ->
Report msg ->
Diagnostic msg
addReport :: Diagnostic msg -> Report msg -> Diagnostic msg
addReport (Diagnostic [Report msg]
reports HashMap FilePath [FilePath]
files) Report msg
report =
[Report msg] -> HashMap FilePath [FilePath] -> Diagnostic msg
forall msg.
[Report msg] -> HashMap FilePath [FilePath] -> Diagnostic msg
Diagnostic (Report msg
report Report msg -> [Report msg] -> [Report msg]
forall a. a -> [a] -> [a]
: [Report msg]
reports) HashMap FilePath [FilePath]
files
{-# INLINE addReport #-}
#ifdef USE_AESON
diagnosticToJson :: ToJSON msg => Diagnostic msg -> ByteString
diagnosticToJson :: Diagnostic msg -> ByteString
diagnosticToJson = Diagnostic msg -> ByteString
forall a. ToJSON a => a -> ByteString
encode
#endif