reformat all files

This commit is contained in:
Mesabloo 2022-04-21 20:01:21 +02:00
parent ecdbed4a2d
commit 21a3c67660
6 changed files with 240 additions and 197 deletions

View File

@ -1,86 +1,105 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS -Wno-name-shadowing #-} {-# OPTIONS -Wno-name-shadowing #-}
-- |
-- Module : Error.Diagnose.Compat.Megaparsec
-- Description : Compatibility layer for megaparsec
-- Copyright : (c) Mesabloo, 2021
-- License : BSD3
-- Stability : experimental
-- Portability : Portable
module Error.Diagnose.Compat.Megaparsec module Error.Diagnose.Compat.Megaparsec
( diagnosticFromBundle ( diagnosticFromBundle,
, errorDiagnosticFromBundle errorDiagnosticFromBundle,
, warningDiagnosticFromBundle warningDiagnosticFromBundle,
, module Error.Diagnose.Compat.Hints module Error.Diagnose.Compat.Hints,
) where )
where
import Data.Bifunctor (second) import Data.Bifunctor (second)
import Data.Function ((&)) import Data.Function ((&))
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import qualified Data.Set as Set (toList) import qualified Data.Set as Set (toList)
import Data.String (IsString(..)) import Data.String (IsString (..))
import Error.Diagnose import Error.Diagnose
import Error.Diagnose.Compat.Hints (HasHints(..)) import Error.Diagnose.Compat.Hints (HasHints (..))
import qualified Text.Megaparsec as MP import qualified Text.Megaparsec as MP
-- | Transforms a megaparsec 'MP.ParseErrorBundle' into a well-formated 'Diagnostic' ready to be shown. -- | Transforms a megaparsec 'MP.ParseErrorBundle' into a well-formated 'Diagnostic' ready to be shown.
diagnosticFromBundle diagnosticFromBundle ::
:: forall msg s e. forall msg s e.
(IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s) (IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s) =>
=> (MP.ParseError s e -> Bool) -- ^ How to decide whether this is an error or a warning diagnostic -- | How to decide whether this is an error or a warning diagnostic
-> msg -- ^ The error message of the diagnostic (MP.ParseError s e -> Bool) ->
-> Maybe [msg] -- ^ Default hints when trivial errors are reported -- | The error message of the diagnostic
-> MP.ParseErrorBundle s e -- ^ The bundle to create a diagnostic from msg ->
-> Diagnostic msg -- | Default hints when trivial errors are reported
diagnosticFromBundle isError msg (fromMaybe [] -> trivialHints) MP.ParseErrorBundle{..} = Maybe [msg] ->
-- | The bundle to create a diagnostic from
MP.ParseErrorBundle s e ->
Diagnostic msg
diagnosticFromBundle isError msg (fromMaybe [] -> trivialHints) MP.ParseErrorBundle {..} =
foldl addReport def (toLabeledPosition <$> bundleErrors) foldl addReport def (toLabeledPosition <$> bundleErrors)
where where
toLabeledPosition :: MP.ParseError s e -> Report msg toLabeledPosition :: MP.ParseError s e -> Report msg
toLabeledPosition error = toLabeledPosition error =
let (_, pos) = MP.reachOffset (MP.errorOffset error) bundlePosState let (_, pos) = MP.reachOffset (MP.errorOffset error) bundlePosState
source = fromSourcePos (MP.pstateSourcePos pos) source = fromSourcePos (MP.pstateSourcePos pos)
msgs = fromString @msg <$> lines (MP.parseErrorTextPretty error) msgs = fromString @msg <$> lines (MP.parseErrorTextPretty error)
in flip (msg & if isError error then err else warn) (errorHints error) in flip
if | [m] <- msgs -> [ (source, This m) ] (msg & if isError error then err else warn)
| [m1, m2] <- msgs -> [ (source, This m1), (source, Where m2) ] (errorHints error)
| otherwise -> [ (source, This $ fromString "<<Unknown error>>") ] if
| [m] <- msgs -> [(source, This m)]
| [m1, m2] <- msgs -> [(source, This m1), (source, Where m2)]
| otherwise -> [(source, This $ fromString "<<Unknown error>>")]
fromSourcePos :: MP.SourcePos -> Position fromSourcePos :: MP.SourcePos -> Position
fromSourcePos MP.SourcePos{..} = fromSourcePos MP.SourcePos {..} =
let start = both (fromIntegral . MP.unPos) (sourceLine, sourceColumn) let start = both (fromIntegral . MP.unPos) (sourceLine, sourceColumn)
end = second (+ 1) start end = second (+ 1) start
in Position start end sourceName in Position start end sourceName
errorHints :: MP.ParseError s e -> [msg] errorHints :: MP.ParseError s e -> [msg]
errorHints MP.TrivialError{} = trivialHints errorHints MP.TrivialError {} = trivialHints
errorHints (MP.FancyError _ errs) = Set.toList errs >>= \ case errorHints (MP.FancyError _ errs) =
MP.ErrorCustom e -> hints e Set.toList errs >>= \case
_ -> mempty MP.ErrorCustom e -> hints e
_ -> mempty
-- | Creates an error diagnostic from a megaparsec 'MP.ParseErrorBundle'. -- | Creates an error diagnostic from a megaparsec 'MP.ParseErrorBundle'.
errorDiagnosticFromBundle errorDiagnosticFromBundle ::
:: forall msg s e. forall msg s e.
(IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s) (IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s) =>
=> msg -- ^ The error message of the diagnostic -- | The error message of the diagnostic
-> Maybe [msg] -- ^ Default hints when trivial errors are reported msg ->
-> MP.ParseErrorBundle s e -- ^ The bundle to create a diagnostic from -- | Default hints when trivial errors are reported
-> Diagnostic msg Maybe [msg] ->
-- | The bundle to create a diagnostic from
MP.ParseErrorBundle s e ->
Diagnostic msg
errorDiagnosticFromBundle = diagnosticFromBundle (const True) errorDiagnosticFromBundle = diagnosticFromBundle (const True)
-- | Creates a warning diagnostic from a megaparsec 'MP.ParseErrorBundle'. -- | Creates a warning diagnostic from a megaparsec 'MP.ParseErrorBundle'.
warningDiagnosticFromBundle warningDiagnosticFromBundle ::
:: forall msg s e. forall msg s e.
(IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s) (IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s) =>
=> msg -- ^ The error message of the diagnostic -- | The error message of the diagnostic
-> Maybe [msg] -- ^ Default hints when trivial errors are reported msg ->
-> MP.ParseErrorBundle s e -- ^ The bundle to create a diagnostic from -- | Default hints when trivial errors are reported
-> Diagnostic msg Maybe [msg] ->
-- | The bundle to create a diagnostic from
MP.ParseErrorBundle s e ->
Diagnostic msg
warningDiagnosticFromBundle = diagnosticFromBundle (const False) warningDiagnosticFromBundle = diagnosticFromBundle (const False)
------------------------------------ ------------------------------------
------------ INTERNAL -------------- ------------ INTERNAL --------------
------------------------------------ ------------------------------------

View File

@ -1,85 +1,102 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS -Wno-name-shadowing #-} {-# OPTIONS -Wno-name-shadowing #-}
-- |
-- Module : Error.Diagnose.Compat.Parsec
-- Description : Compatibility layer for parsec
-- Copyright : (c) Mesabloo, 2021
-- License : BSD3
-- Stability : experimental
-- Portability : Portable
module Error.Diagnose.Compat.Parsec module Error.Diagnose.Compat.Parsec
( diagnosticFromParseError ( diagnosticFromParseError,
, errorDiagnosticFromParseError errorDiagnosticFromParseError,
, warningDiagnosticFromParseError warningDiagnosticFromParseError,
, module Error.Diagnose.Compat.Hints module Error.Diagnose.Compat.Hints,
) where )
where
import Data.Bifunctor (second) import Data.Bifunctor (second)
import Data.Function ((&)) import Data.Function ((&))
import Data.Maybe (fromMaybe)
import Data.List (intercalate) import Data.List (intercalate)
import Data.String (IsString(..)) import Data.Maybe (fromMaybe)
import Data.String (IsString (..))
import Data.Void (Void) import Data.Void (Void)
import Error.Diagnose import Error.Diagnose
import Error.Diagnose.Compat.Hints (HasHints(..)) import Error.Diagnose.Compat.Hints (HasHints (..))
import qualified Text.Parsec.Error as PE import qualified Text.Parsec.Error as PE
import qualified Text.Parsec.Pos as PP import qualified Text.Parsec.Pos as PP
-- | Generates a diagnostic from a 'PE.ParseError'. -- | Generates a diagnostic from a 'PE.ParseError'.
diagnosticFromParseError diagnosticFromParseError ::
:: forall msg. (IsString msg, HasHints Void msg) forall msg.
=> (PE.ParseError -> Bool) -- ^ Determine whether the diagnostic is an error or a warning (IsString msg, HasHints Void msg) =>
-> msg -- ^ The main error of the diagnostic -- | Determine whether the diagnostic is an error or a warning
-> Maybe [msg] -- ^ Default hints (PE.ParseError -> Bool) ->
-> PE.ParseError -- ^ The 'PE.ParseError' to transform into a 'Diagnostic' -- | The main error of the diagnostic
-> Diagnostic msg msg ->
-- | Default hints
Maybe [msg] ->
-- | The 'PE.ParseError' to transform into a 'Diagnostic'
PE.ParseError ->
Diagnostic msg
diagnosticFromParseError isError msg (fromMaybe [] -> defaultHints) error = diagnosticFromParseError isError msg (fromMaybe [] -> defaultHints) error =
let pos = fromSourcePos $ PE.errorPos error let pos = fromSourcePos $ PE.errorPos error
markers = toMarkers pos $ PE.errorMessages error markers = toMarkers pos $ PE.errorMessages error
report = (msg & if isError error then err else warn) markers (defaultHints <> hints (undefined :: Void)) report = (msg & if isError error then err else warn) markers (defaultHints <> hints (undefined :: Void))
in addReport def report in addReport def report
where where
fromSourcePos :: PP.SourcePos -> Position fromSourcePos :: PP.SourcePos -> Position
fromSourcePos pos = fromSourcePos pos =
let start = both fromIntegral (PP.sourceLine pos, PP.sourceColumn pos) let start = both fromIntegral (PP.sourceLine pos, PP.sourceColumn pos)
end = second (+ 1) start end = second (+ 1) start
in Position start end (PP.sourceName pos) in Position start end (PP.sourceName pos)
toMarkers :: Position -> [PE.Message] -> [(Position, Marker msg)] toMarkers :: Position -> [PE.Message] -> [(Position, Marker msg)]
toMarkers source [] = [ (source, This $ fromString "<<unknown error>>") ] toMarkers source [] = [(source, This $ fromString "<<unknown error>>")]
toMarkers source msgs = toMarkers source msgs =
let putTogether [] = ([], [], [], []) let putTogether [] = ([], [], [], [])
putTogether (PE.SysUnExpect thing:ms) = let (a, b, c, d) = putTogether ms in (thing:a, b, c, d) putTogether (PE.SysUnExpect thing : ms) = let (a, b, c, d) = putTogether ms in (thing : a, b, c, d)
putTogether (PE.UnExpect thing:ms) = let (a, b, c, d) = putTogether ms in (a, thing:b, c, d) putTogether (PE.UnExpect thing : ms) = let (a, b, c, d) = putTogether ms in (a, thing : b, c, d)
putTogether (PE.Expect thing:ms) = let (a, b, c, d) = putTogether ms in (a, b, thing:c, d) putTogether (PE.Expect thing : ms) = let (a, b, c, d) = putTogether ms in (a, b, thing : c, d)
putTogether (PE.Message thing:ms) = let (a, b, c, d) = putTogether ms in (a, b, c, thing:d) putTogether (PE.Message thing : ms) = let (a, b, c, d) = putTogether ms in (a, b, c, thing : d)
(sysUnexpectedList, unexpectedList, expectedList, messages) = putTogether msgs (sysUnexpectedList, unexpectedList, expectedList, messages) = putTogether msgs
in [ (source, marker) | unexpected <- if null unexpectedList then sysUnexpectedList else unexpectedList in [ (source, marker) | unexpected <- if null unexpectedList then sysUnexpectedList else unexpectedList, let marker = This $ fromString $ "unexpected " <> unexpected
, let marker = This $ fromString $ "unexpected " <> unexpected ] ]
<> [ (source, marker) | msg <- messages <> [ (source, marker) | msg <- messages, let marker = This $ fromString msg
, let marker = This $ fromString msg ] ]
<> [ (source, Where $ fromString $ "expecting any of " <> intercalate ", " expectedList) ] <> [(source, Where $ fromString $ "expecting any of " <> intercalate ", " expectedList)]
-- | Generates an error diagnostic from a 'PE.ParseError'. -- | Generates an error diagnostic from a 'PE.ParseError'.
errorDiagnosticFromParseError errorDiagnosticFromParseError ::
:: forall msg. (IsString msg, HasHints Void msg) forall msg.
=> msg -- ^ The main error message of the diagnostic (IsString msg, HasHints Void msg) =>
-> Maybe [msg] -- ^ Default hints -- | The main error message of the diagnostic
-> PE.ParseError -- ^ The 'PE.ParseError' to convert msg ->
-> Diagnostic msg -- | Default hints
Maybe [msg] ->
-- | The 'PE.ParseError' to convert
PE.ParseError ->
Diagnostic msg
errorDiagnosticFromParseError = diagnosticFromParseError (const True) errorDiagnosticFromParseError = diagnosticFromParseError (const True)
-- | Generates a warning diagnostic from a 'PE.ParseError'. -- | Generates a warning diagnostic from a 'PE.ParseError'.
warningDiagnosticFromParseError warningDiagnosticFromParseError ::
:: forall msg. (IsString msg, HasHints Void msg) forall msg.
=> msg -- ^ The main error message of the diagnostic (IsString msg, HasHints Void msg) =>
-> Maybe [msg] -- ^ Default hints -- | The main error message of the diagnostic
-> PE.ParseError -- ^ The 'PE.ParseError' to convert msg ->
-> Diagnostic msg -- | Default hints
Maybe [msg] ->
-- | The 'PE.ParseError' to convert
PE.ParseError ->
Diagnostic msg
warningDiagnosticFromParseError = diagnosticFromParseError (const False) warningDiagnosticFromParseError = diagnosticFromParseError (const False)
------------------------------------ ------------------------------------
------------ INTERNAL -------------- ------------ INTERNAL --------------
------------------------------------ ------------------------------------
@ -89,4 +106,3 @@ warningDiagnosticFromParseError = diagnosticFromParseError (const False)
-- > both f = bimap @(,) f f -- > both f = bimap @(,) f f
both :: (a -> b) -> (a, a) -> (b, b) both :: (a -> b) -> (a, a) -> (b, b)
both f ~(x, y) = (f x, f y) both f ~(x, y) = (f x, f y)

View File

@ -1,22 +1,26 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-| -- |
Module : Error.Diagnose.Diagnostic -- Module : Error.Diagnose.Diagnostic
Description : Diagnostic definition and pretty printing -- Description : Diagnostic definition and pretty printing
Copyright : (c) Mesabloo, 2021 -- Copyright : (c) Mesabloo, 2021
License : BSD3 -- License : BSD3
Stability : experimental -- Stability : experimental
Portability : Portable -- Portability : Portable
-}
module Error.Diagnose.Diagnostic module Error.Diagnose.Diagnostic
( -- * Re-exports ( -- * Re-exports
module Export ) where module Export,
)
where
import Error.Diagnose.Diagnostic.Internal as Export import Error.Diagnose.Diagnostic.Internal as Export
(Diagnostic, def, printDiagnostic, ( Diagnostic,
#ifdef USE_AESON #ifdef USE_AESON
diagnosticToJson, diagnosticToJson,
#endif #endif
addFile, addReport) addFile,
addReport,
import System.IO as Export (stdout, stderr) def,
printDiagnostic,
)
import System.IO as Export (stderr, stdout)

View File

@ -1,23 +1,21 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-| -- |
Module : Error.Diagnose.Diagnostic.Internal -- Module : Error.Diagnose.Diagnostic.Internal
Description : Internal workings for diagnostic definitions and pretty printing. -- Description : Internal workings for diagnostic definitions and pretty printing.
Copyright : (c) Mesabloo, 2021 -- Copyright : (c) Mesabloo, 2021
License : BSD3 -- License : BSD3
Stability : experimental -- Stability : experimental
Portability : Portable -- Portability : Portable
--
/Warning/: The API of this module can break between two releases, therefore you should not rely on it. -- /Warning/: The API of this module can break between two releases, therefore you should not rely on it.
It is also highly undocumented. -- It is also highly undocumented.
--
Please limit yourself to the "Error.Diagnose.Diagnostic" module, which exports some of the useful functions defined here. -- 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 module Error.Diagnose.Diagnostic.Internal (module Error.Diagnose.Diagnostic.Internal, def) where
import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Class (MonadIO, liftIO)
#ifdef USE_AESON #ifdef USE_AESON
import Data.Aeson (ToJSON(..), encode, object, (.=)) import Data.Aeson (ToJSON(..), encode, object, (.=))
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
@ -27,26 +25,24 @@ import Data.Foldable (fold)
import Data.HashMap.Lazy (HashMap) import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HashMap import qualified Data.HashMap.Lazy as HashMap
import Data.List (intersperse) import Data.List (intersperse)
import Error.Diagnose.Report (Report) import Error.Diagnose.Report (Report)
import Error.Diagnose.Report.Internal (prettyReport) import Error.Diagnose.Report.Internal (prettyReport)
import Prettyprinter (Doc, Pretty, hardline, unAnnotate)
import Prettyprinter.Render.Terminal (AnsiStyle, hPutDoc)
import System.IO (Handle) import System.IO (Handle)
import Prettyprinter (Pretty, Doc, unAnnotate, hardline)
import Prettyprinter.Render.Terminal (hPutDoc, AnsiStyle)
-- | The data type for diagnostic containing messages of an abstract type. -- | The data type for diagnostic containing messages of an abstract type.
-- --
-- The constructors are private, but users can use 'def' from the 'Default' typeclass -- 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. -- to create a new empty diagnostic, and 'addFile' and 'addReport' to alter its internal state.
data Diagnostic msg data Diagnostic msg
= Diagnostic = Diagnostic
[Report msg] -- ^ All the reports contained in a diagnostic. [Report msg]
-- -- ^ All the reports contained in a diagnostic.
-- Reports are output one by one, without connections in between. --
(HashMap FilePath [String]) -- ^ A map associating files with their content as lists of lines. -- Reports are output one by one, without connections in between.
(HashMap FilePath [String])
-- ^ A map associating files with their content as lists of lines.
instance Default (Diagnostic msg) where instance Default (Diagnostic msg) where
def = Diagnostic mempty mempty def = Diagnostic mempty mempty
@ -69,21 +65,29 @@ instance ToJSON msg => ToJSON (Diagnostic msg) where
-- | Pretty prints a diagnostic into a 'Doc'ument that can be output using -- | Pretty prints a diagnostic into a 'Doc'ument that can be output using
-- 'Text.PrettyPrint.ANSI.Leijen.hPutDoc' or 'Text.PrettyPrint.ANSI.Leijen.displayIO'. -- 'Text.PrettyPrint.ANSI.Leijen.hPutDoc' or 'Text.PrettyPrint.ANSI.Leijen.displayIO'.
prettyDiagnostic :: Pretty msg prettyDiagnostic ::
=> Bool -- ^ Should we use unicode when printing paths? Pretty msg =>
-> Diagnostic msg -- ^ The diagnostic to print -- | Should we use unicode when printing paths?
-> Doc AnsiStyle Bool ->
-- | The diagnostic to print
Diagnostic msg ->
Doc AnsiStyle
prettyDiagnostic withUnicode (Diagnostic reports file) = prettyDiagnostic withUnicode (Diagnostic reports file) =
fold . intersperse hardline $ prettyReport file withUnicode <$> reports fold . intersperse hardline $ prettyReport file withUnicode <$> reports
{-# INLINE prettyDiagnostic #-} {-# INLINE prettyDiagnostic #-}
-- | Prints a 'Diagnostic' onto a specific 'Handle'. -- | Prints a 'Diagnostic' onto a specific 'Handle'.
printDiagnostic :: (MonadIO m, Pretty msg) printDiagnostic ::
=> Handle -- ^ The handle onto which to output the diagnostic. (MonadIO m, Pretty msg) =>
-> Bool -- ^ Should we print with unicode characters? -- | The handle onto which to output the diagnostic.
-> Bool -- ^ 'False' to disable colors. Handle ->
-> Diagnostic msg -- ^ The diagnostic to output. -- | Should we print with unicode characters?
-> m () Bool ->
-- | 'False' to disable colors.
Bool ->
-- | The diagnostic to output.
Diagnostic msg ->
m ()
printDiagnostic handle withUnicode withColors diag = printDiagnostic handle withUnicode withColors diag =
liftIO $ hPutDoc handle (unlessId withColors unAnnotate $ prettyDiagnostic withUnicode diag) liftIO $ hPutDoc handle (unlessId withColors unAnnotate $ prettyDiagnostic withUnicode diag)
where where
@ -92,18 +96,23 @@ printDiagnostic handle withUnicode withColors diag =
{-# INLINE printDiagnostic #-} {-# INLINE printDiagnostic #-}
-- | Inserts a new referenceable file within the diagnostic. -- | Inserts a new referenceable file within the diagnostic.
addFile :: Diagnostic msg addFile ::
-> FilePath -- ^ The path to the file. Diagnostic msg ->
-> String -- ^ The content of the file as a single string, where lines are ended by @\n@. -- | The path to the file.
-> Diagnostic msg FilePath ->
-- | The content of the file as a single string, where lines are ended by @\n@.
String ->
Diagnostic msg
addFile (Diagnostic reports files) path content = addFile (Diagnostic reports files) path content =
Diagnostic reports (HashMap.insert path (lines content) files) Diagnostic reports (HashMap.insert path (lines content) files)
{-# INLINE addFile #-} {-# INLINE addFile #-}
-- | Inserts a new report into a diagnostic. -- | Inserts a new report into a diagnostic.
addReport :: Diagnostic msg addReport ::
-> Report msg -- ^ The new report to add to the diagnostic. Diagnostic msg ->
-> Diagnostic msg -- | The new report to add to the diagnostic.
Report msg ->
Diagnostic msg
addReport (Diagnostic reports files) report = addReport (Diagnostic reports files) report =
Diagnostic (report : reports) files Diagnostic (report : reports) files
{-# INLINE addReport #-} {-# INLINE addReport #-}

View File

@ -1,18 +1,17 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-| -- |
Module : Error.Diagnose.Diagnostic -- Module : Error.Diagnose.Diagnostic
Description : Defines location information as a simple record. -- Description : Defines location information as a simple record.
Copyright : (c) Mesabloo, 2021 -- Copyright : (c) Mesabloo, 2021
License : BSD3 -- License : BSD3
Stability : experimental -- Stability : experimental
Portability : Portable -- Portability : Portable
-} module Error.Diagnose.Position (Position (..)) where
module Error.Diagnose.Position (Position(..)) where
#ifdef USE_AESON #ifdef USE_AESON
import Data.Aeson (ToJSON(..), object, (.=)) import Data.Aeson (ToJSON(..), object, (.=))
@ -20,31 +19,25 @@ import Data.Aeson (ToJSON(..), object, (.=))
import Data.Default (Default, def) import Data.Default (Default, def)
import Data.Hashable (Hashable) import Data.Hashable (Hashable)
import Data.Text (Text) import Data.Text (Text)
import GHC.Generics (Generic (..))
import Prettyprinter (Pretty (..), colon)
import GHC.Generics (Generic(..))
import Prettyprinter (Pretty(..), colon)
-- import Text.PrettyPrint.ANSI.Leijen (Pretty(..), text, colon, int) -- import Text.PrettyPrint.ANSI.Leijen (Pretty(..), text, colon, int)
-- | Contains information about the location of something.
-- | Contains information about the location about something.
-- --
-- It is best used in a datatype like: -- It is best used in a datatype like:
-- --
-- > data Located a -- > data Located a
-- > = a :@ Position -- > = a :@ Position
-- > deriving (Show, Eq, Ord, Functor, Traversable) -- > deriving (Show, Eq, Ord, Functor, Traversable)
data Position data Position = Position
= Position { -- | The beginning line and column of the span.
{ begin :: (Int, Int),
-- | The beginning line and column of the span. -- | The end line and column of the span.
begin :: (Int, Int) end :: (Int, Int),
, -- | The file this position spans in.
-- | The end line and column of the span. file :: FilePath
end :: (Int, Int)
,
-- | The file this position spans in.
file :: FilePath
} }
deriving (Show, Eq, Generic) deriving (Show, Eq, Generic)
@ -53,10 +46,11 @@ instance Ord Position where
instance Pretty Position where instance Pretty Position where
pretty (Position (bl, bc) (el, ec) f) = pretty f <> at <> pretty bl <> colon <> pretty bc <> dash <> pretty el <> colon <> pretty ec pretty (Position (bl, bc) (el, ec) f) = pretty f <> at <> pretty bl <> colon <> pretty bc <> dash <> pretty el <> colon <> pretty ec
where at = pretty @Text "@" where
dash = pretty @Text "-" at = pretty @Text "@"
dash = pretty @Text "-"
instance Hashable Position where instance Hashable Position
instance Default Position where instance Default Position where
def = Position (1, 1) (1, 1) "<no-file>" def = Position (1, 1) (1, 1) "<no-file>"

View File

@ -1,13 +1,14 @@
{-| -- |
Module : Error.Diagnose.Report -- Module : Error.Diagnose.Report
Description : Report definition and pretty printing -- Description : Report definition and pretty printing
Copyright : (c) Mesabloo, 2021 -- Copyright : (c) Mesabloo, 2021
License : BSD3 -- License : BSD3
Stability : experimental -- Stability : experimental
Portability : Portable -- Portability : Portable
-}
module Error.Diagnose.Report module Error.Diagnose.Report
( -- * Re-exports ( -- * Re-exports
module Export ) where module Export,
)
where
import Error.Diagnose.Report.Internal as Export (Report, warn, err, Marker(..)) import Error.Diagnose.Report.Internal as Export (Marker (..), Report, err, warn)