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,40 +1,50 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# 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
( diagnosticFromBundle
, errorDiagnosticFromBundle
, warningDiagnosticFromBundle
, module Error.Diagnose.Compat.Hints
) where
( diagnosticFromBundle,
errorDiagnosticFromBundle,
warningDiagnosticFromBundle,
module Error.Diagnose.Compat.Hints,
)
where
import Data.Bifunctor (second)
import Data.Function ((&))
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set (toList)
import Data.String (IsString (..))
import Error.Diagnose
import Error.Diagnose.Compat.Hints (HasHints (..))
import qualified Text.Megaparsec as MP
-- | Transforms a megaparsec 'MP.ParseErrorBundle' into a well-formated 'Diagnostic' ready to be shown.
diagnosticFromBundle
:: forall msg s e.
(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
-> msg -- ^ The error message of the diagnostic
-> Maybe [msg] -- ^ Default hints when trivial errors are reported
-> MP.ParseErrorBundle s e -- ^ The bundle to create a diagnostic from
-> Diagnostic msg
diagnosticFromBundle ::
forall msg s e.
(IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s) =>
-- | How to decide whether this is an error or a warning diagnostic
(MP.ParseError s e -> Bool) ->
-- | The error message of the diagnostic
msg ->
-- | Default hints when trivial errors are reported
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)
where
@ -43,8 +53,11 @@ diagnosticFromBundle isError msg (fromMaybe [] -> trivialHints) MP.ParseErrorBun
let (_, pos) = MP.reachOffset (MP.errorOffset error) bundlePosState
source = fromSourcePos (MP.pstateSourcePos pos)
msgs = fromString @msg <$> lines (MP.parseErrorTextPretty error)
in flip (msg & if isError error then err else warn) (errorHints error)
if | [m] <- msgs -> [ (source, This m) ]
in flip
(msg & if isError error then err else warn)
(errorHints error)
if
| [m] <- msgs -> [(source, This m)]
| [m1, m2] <- msgs -> [(source, This m1), (source, Where m2)]
| otherwise -> [(source, This $ fromString "<<Unknown error>>")]
@ -56,31 +69,37 @@ diagnosticFromBundle isError msg (fromMaybe [] -> trivialHints) MP.ParseErrorBun
errorHints :: MP.ParseError s e -> [msg]
errorHints MP.TrivialError {} = trivialHints
errorHints (MP.FancyError _ errs) = Set.toList errs >>= \ case
errorHints (MP.FancyError _ errs) =
Set.toList errs >>= \case
MP.ErrorCustom e -> hints e
_ -> mempty
-- | Creates an error diagnostic from a megaparsec 'MP.ParseErrorBundle'.
errorDiagnosticFromBundle
:: forall msg s e.
(IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s)
=> msg -- ^ The error message of the diagnostic
-> Maybe [msg] -- ^ Default hints when trivial errors are reported
-> MP.ParseErrorBundle s e -- ^ The bundle to create a diagnostic from
-> Diagnostic msg
errorDiagnosticFromBundle ::
forall msg s e.
(IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s) =>
-- | The error message of the diagnostic
msg ->
-- | Default hints when trivial errors are reported
Maybe [msg] ->
-- | The bundle to create a diagnostic from
MP.ParseErrorBundle s e ->
Diagnostic msg
errorDiagnosticFromBundle = diagnosticFromBundle (const True)
-- | Creates a warning diagnostic from a megaparsec 'MP.ParseErrorBundle'.
warningDiagnosticFromBundle
:: forall msg s e.
(IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s)
=> msg -- ^ The error message of the diagnostic
-> Maybe [msg] -- ^ Default hints when trivial errors are reported
-> MP.ParseErrorBundle s e -- ^ The bundle to create a diagnostic from
-> Diagnostic msg
warningDiagnosticFromBundle ::
forall msg s e.
(IsString msg, MP.Stream s, HasHints e msg, MP.ShowErrorComponent e, MP.VisualStream s, MP.TraversableStream s) =>
-- | The error message of the diagnostic
msg ->
-- | Default hints when trivial errors are reported
Maybe [msg] ->
-- | The bundle to create a diagnostic from
MP.ParseErrorBundle s e ->
Diagnostic msg
warningDiagnosticFromBundle = diagnosticFromBundle (const False)
------------------------------------
------------ INTERNAL --------------
------------------------------------

View File

@ -1,37 +1,48 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# 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
( diagnosticFromParseError
, errorDiagnosticFromParseError
, warningDiagnosticFromParseError
, module Error.Diagnose.Compat.Hints
) where
( diagnosticFromParseError,
errorDiagnosticFromParseError,
warningDiagnosticFromParseError,
module Error.Diagnose.Compat.Hints,
)
where
import Data.Bifunctor (second)
import Data.Function ((&))
import Data.Maybe (fromMaybe)
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import Data.String (IsString (..))
import Data.Void (Void)
import Error.Diagnose
import Error.Diagnose.Compat.Hints (HasHints (..))
import qualified Text.Parsec.Error as PE
import qualified Text.Parsec.Pos as PP
-- | Generates a diagnostic from a 'PE.ParseError'.
diagnosticFromParseError
:: forall msg. (IsString msg, HasHints Void msg)
=> (PE.ParseError -> Bool) -- ^ Determine whether the diagnostic is an error or a warning
-> msg -- ^ The main error of the diagnostic
-> Maybe [msg] -- ^ Default hints
-> PE.ParseError -- ^ The 'PE.ParseError' to transform into a 'Diagnostic'
-> Diagnostic msg
diagnosticFromParseError ::
forall msg.
(IsString msg, HasHints Void msg) =>
-- | Determine whether the diagnostic is an error or a warning
(PE.ParseError -> Bool) ->
-- | The main error of the diagnostic
msg ->
-- | Default hints
Maybe [msg] ->
-- | The 'PE.ParseError' to transform into a 'Diagnostic'
PE.ParseError ->
Diagnostic msg
diagnosticFromParseError isError msg (fromMaybe [] -> defaultHints) error =
let pos = fromSourcePos $ PE.errorPos error
markers = toMarkers pos $ PE.errorMessages error
@ -54,32 +65,38 @@ diagnosticFromParseError isError msg (fromMaybe [] -> defaultHints) error =
putTogether (PE.Message thing : ms) = let (a, b, c, d) = putTogether ms in (a, b, c, thing : d)
(sysUnexpectedList, unexpectedList, expectedList, messages) = putTogether msgs
in [ (source, marker) | unexpected <- if null unexpectedList then sysUnexpectedList else unexpectedList
, let marker = This $ fromString $ "unexpected " <> unexpected ]
<> [ (source, marker) | msg <- messages
, let marker = This $ fromString msg ]
in [ (source, marker) | unexpected <- if null unexpectedList then sysUnexpectedList else unexpectedList, let marker = This $ fromString $ "unexpected " <> unexpected
]
<> [ (source, marker) | msg <- messages, let marker = This $ fromString msg
]
<> [(source, Where $ fromString $ "expecting any of " <> intercalate ", " expectedList)]
-- | Generates an error diagnostic from a 'PE.ParseError'.
errorDiagnosticFromParseError
:: forall msg. (IsString msg, HasHints Void msg)
=> msg -- ^ The main error message of the diagnostic
-> Maybe [msg] -- ^ Default hints
-> PE.ParseError -- ^ The 'PE.ParseError' to convert
-> Diagnostic msg
errorDiagnosticFromParseError ::
forall msg.
(IsString msg, HasHints Void msg) =>
-- | The main error message of the diagnostic
msg ->
-- | Default hints
Maybe [msg] ->
-- | The 'PE.ParseError' to convert
PE.ParseError ->
Diagnostic msg
errorDiagnosticFromParseError = diagnosticFromParseError (const True)
-- | Generates a warning diagnostic from a 'PE.ParseError'.
warningDiagnosticFromParseError
:: forall msg. (IsString msg, HasHints Void msg)
=> msg -- ^ The main error message of the diagnostic
-> Maybe [msg] -- ^ Default hints
-> PE.ParseError -- ^ The 'PE.ParseError' to convert
-> Diagnostic msg
warningDiagnosticFromParseError ::
forall msg.
(IsString msg, HasHints Void msg) =>
-- | The main error message of the diagnostic
msg ->
-- | Default hints
Maybe [msg] ->
-- | The 'PE.ParseError' to convert
PE.ParseError ->
Diagnostic msg
warningDiagnosticFromParseError = diagnosticFromParseError (const False)
------------------------------------
------------ INTERNAL --------------
------------------------------------
@ -89,4 +106,3 @@ warningDiagnosticFromParseError = diagnosticFromParseError (const False)
-- > both f = bimap @(,) f f
both :: (a -> b) -> (a, a) -> (b, b)
both f ~(x, y) = (f x, f y)

View File

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

View File

@ -1,23 +1,21 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-|
Module : Error.Diagnose.Diagnostic.Internal
Description : Internal workings for diagnostic definitions and pretty printing.
Copyright : (c) Mesabloo, 2021
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
-- Description : Internal workings for diagnostic definitions and pretty printing.
-- Copyright : (c) Mesabloo, 2021
-- 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, def) where
import Control.Monad.IO.Class (MonadIO, liftIO)
#ifdef USE_AESON
import Data.Aeson (ToJSON(..), encode, object, (.=))
import Data.ByteString.Lazy (ByteString)
@ -27,26 +25,24 @@ 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)
import Prettyprinter (Pretty, Doc, unAnnotate, hardline)
import Prettyprinter.Render.Terminal (hPutDoc, AnsiStyle)
-- | The data type for diagnostic containing messages of an abstract type.
--
-- 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.
data Diagnostic msg
= 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.
(HashMap FilePath [String])
-- ^ A map associating files with their content as lists of lines.
instance Default (Diagnostic msg) where
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
-- 'Text.PrettyPrint.ANSI.Leijen.hPutDoc' or 'Text.PrettyPrint.ANSI.Leijen.displayIO'.
prettyDiagnostic :: Pretty msg
=> Bool -- ^ Should we use unicode when printing paths?
-> Diagnostic msg -- ^ The diagnostic to print
-> Doc AnsiStyle
prettyDiagnostic ::
Pretty msg =>
-- | Should we use unicode when printing paths?
Bool ->
-- | The diagnostic to print
Diagnostic msg ->
Doc AnsiStyle
prettyDiagnostic withUnicode (Diagnostic reports file) =
fold . intersperse hardline $ prettyReport file withUnicode <$> reports
{-# INLINE prettyDiagnostic #-}
-- | Prints a 'Diagnostic' onto a specific 'Handle'.
printDiagnostic :: (MonadIO m, Pretty msg)
=> Handle -- ^ The handle onto which to output the diagnostic.
-> Bool -- ^ Should we print with unicode characters?
-> Bool -- ^ 'False' to disable colors.
-> Diagnostic msg -- ^ The diagnostic to output.
-> m ()
printDiagnostic ::
(MonadIO m, Pretty msg) =>
-- | The handle onto which to output the diagnostic.
Handle ->
-- | Should we print with unicode characters?
Bool ->
-- | 'False' to disable colors.
Bool ->
-- | The diagnostic to output.
Diagnostic msg ->
m ()
printDiagnostic handle withUnicode withColors diag =
liftIO $ hPutDoc handle (unlessId withColors unAnnotate $ prettyDiagnostic withUnicode diag)
where
@ -92,18 +96,23 @@ printDiagnostic handle withUnicode withColors diag =
{-# INLINE printDiagnostic #-}
-- | Inserts a new referenceable file within the diagnostic.
addFile :: Diagnostic msg
-> FilePath -- ^ The path to the file.
-> String -- ^ The content of the file as a single string, where lines are ended by @\n@.
-> Diagnostic msg
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 (Diagnostic reports files) path content =
Diagnostic reports (HashMap.insert path (lines content) files)
{-# INLINE addFile #-}
-- | Inserts a new report into a diagnostic.
addReport :: Diagnostic msg
-> Report msg -- ^ The new report to add to the diagnostic.
-> Diagnostic msg
addReport ::
Diagnostic msg ->
-- | The new report to add to the diagnostic.
Report msg ->
Diagnostic msg
addReport (Diagnostic reports files) report =
Diagnostic (report : reports) files
{-# INLINE addReport #-}

View File

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

View File

@ -1,13 +1,14 @@
{-|
Module : Error.Diagnose.Report
Description : Report definition and pretty printing
Copyright : (c) Mesabloo, 2021
License : BSD3
Stability : experimental
Portability : Portable
-}
-- |
-- Module : Error.Diagnose.Report
-- Description : Report definition and pretty printing
-- Copyright : (c) Mesabloo, 2021
-- License : BSD3
-- Stability : experimental
-- Portability : Portable
module Error.Diagnose.Report
( -- * 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)