packages feed

diagnose (empty) → 1.6.3

raw patch · 17 files changed

+2078/−0 lines, 17 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, data-default, diagnose, hashable, megaparsec, parsec, prettyprinter, prettyprinter-ansi-terminal, text, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Ghilain Bergeron (Mesabloo) (c) 2019-2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Ghilain Bergeron (Mesabloo) nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,105 @@+# Error reporting made easy++Diagnose is a small library used to report compiler/interpreter errors in a beautiful yet readable way.+It was in the beginning heavily inspired by [ariadne](https://github.com/zesterer/ariadne), but ended up quickly becoming its own thing.++As a great example, here's the output of the last test:++![first example](./assets/real-world-example-unicode.png)++If you do not like unicode characters, or choose to target platforms which cannot output them natively;+you may alternatively print the whole diagnostic with ASCII characters, like this:++![second example](./assets/real-world-example-ascii.png)++Colors are also optional, and you may choose not to print them.++## Features++- Show diagnostics with/without 8-bit colors, with/without Unicode characters+- Inline and multiline markers are nicely displayed+- The order of markers matters!+  If there are multiple markers on the same line, they are ordered according to how they were put in each report+- Reports spanning across multiple files are handled as well+- Generic over the type of message which can be displayed, meaning that you can output custom data types as well as they can be pretty-printed+- Diagnostics can be exported to JSON, if you don't quite like the rendering as it is, or if you need to transmit them to e.g. a website+- Plug and play (mega)parsec integration and it magically works with your parsers!++## Usage++You only need to `import Error.Diagnose`, and everything should be ready to go.+You don't even need to `import Prettyprinter`, as it is already provided to you by `Error.Diagnose`!++--------++A diagnostic can be viewed as a collection of reports, spanning on files.+This is what the `Diagnostic` type embodies.++It has a `Default` instance, which can be used to construct an empty diagnostic (contains no reports, and has no files).++The second step is to add some reports.+There are two kinds of reports:+- Error reports, created through `err`+- Warning reports, created by using `warn`++Both of these fonctions have the following type:+```haskell+  -- | The main message, which is output at the top right after `[error]` or `[warning]`+  msg ->+  -- | A list of markers, along with the positions they span on+  [(Position, Marker msg)] ->+  -- | Some hints to be output at the bottom of the report+  [msg] ->+  -- | The created report+  Report msg+```++Each report contains markers, which are what underlines the code in the screenshots above.+They come in three flavors:+- A `This` marker indicates the main reason of the error.+  It is highlighted in red (for errors) or yellow (for warnings).+  Ideally, there is only one per report, but this isn't strictly required.+- A `Where` marker adds additional context to the error by adding highlighted code to the error.+  This can be used to remind used that a variable was found of a given type earlier, or even where a previous declaration was found in another file.+  This is output in blue by default.+- A `Maybe` marker is probably the rarest one.+  It is basically a way of suggesting fixes (as when GCC tells you that you probably mistyped a variable name).+  These markers are highlighted in green.++The `Position` datatype is however required to be used with this library.+If you use another way of keeping track of position information, you will need to convert them to the `Position` datatype.++Once your reports are created, you will need to add them inside the diagnostic using `addReport`.+You will also need to put your files into the diagnostic with `addFile`, else lines won't be printed and you will get `<no-line>` in your reports.++After all of this is done, you may choose to either print the diagnostic onto a handle using `printDiagnostic`+or export it to JSON with `diagnosticToJson` or the `ToJSON` class of Aeson (the output format is documented under the `diagnosticToJson` function).++## Example++Here is how the above screenshot was generated:+```haskell+let beautifulExample =+      err+        "Could not deduce constraint 'Num(a)' from the current context"+        [ (Position (1, 25) (2, 6) "somefile.zc", This "While applying function '+'"),+          (Position (1, 11) (1, 16) "somefile.zc", Where "'x' is supposed to have type 'a'"),+          (Position (1, 8) (1, 9) "somefile.zc", Where "type 'a' is bound here without constraints")+        ]+        ["Adding 'Num(a)' to the list of constraints may solve this problem."]++-- Create the diagnostic +let diagnostic  = addFile def "somefile.zc" "let id<a>(x : a) : a := x\n  + 1"+let diagnostic' = addReport diagnostic beautifulExample++-- Print with unicode characters and colors+printDiagnostic stdout True True diagnostic'+```++More examples are given in the [`test/rendering`](./test/rendering) folder.++## License++This work is licensed under the BSD-3 clause license.++Copyright (c) 2021- Mesabloo, all rights reserved.
+ diagnose.cabal view
@@ -0,0 +1,201 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.6.+--+-- see: https://github.com/sol/hpack++name:           diagnose+version:        1.6.3+synopsis:       Beautiful error reporting done easily+description:    This package provides a simple way of getting beautiful compiler/interpreter errors+                using a very simple interface for the programmer.+                .+                A quick tutorial is available in the module "Error.Diagnose", which goes on most of the basis+                of how to use it.+category:       Error Reporting+homepage:       https://github.com/mesabloo/diagnose#readme+bug-reports:    https://github.com/mesabloo/diagnose/issues+author:         Ghilain Bergeron+maintainer:     Ghilain Bergeron+copyright:      2021- Ghilain Bergeron+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/mesabloo/diagnose++flag json+  description: Allows exporting diagnostics as JSON. This is disabled by default as this relies on the very heavy dependency Aeson.+  manual: True+  default: False++flag megaparsec-compat+  description: Includes a small compatibility layer (in the module `Error.Diagnose.Compat.Megaparsec`) to transform megaparsec errors into reports for this library.+  manual: True+  default: False++flag parsec-compat+  description: Includes a small compatibility layer (in the module `Error.Diagnose.Compat.Parsec`) to transform parsec errors into reports for this library.+  manual: True+  default: False++library+  exposed-modules:+      Error.Diagnose+      Error.Diagnose.Diagnostic+      Error.Diagnose.Position+      Error.Diagnose.Pretty+      Error.Diagnose.Report+  other-modules:+      Data.List.Safe+      Error.Diagnose.Compat.Hints+      Error.Diagnose.Diagnostic.Internal+      Error.Diagnose.Report.Internal+      Paths_diagnose+  hs-source-dirs:+      src+  default-extensions:+      OverloadedStrings+      LambdaCase+      BlockArguments+  ghc-options: -Wall -Wextra+  build-depends:+      base >=4.7 && <5+    , bytestring ==0.10.*+    , data-default ==0.7.*+    , hashable ==1.3.*+    , prettyprinter ==1.7.*+    , prettyprinter-ansi-terminal ==1.1.*+    , text ==1.2.*+    , unordered-containers ==0.2.*+  if flag(json)+    cpp-options: -DUSE_AESON+    build-depends:+        aeson ==1.5.*+  if flag(megaparsec-compat)+    build-depends:+        containers ==0.6.*+      , megaparsec >=9.0.0+  if flag(parsec-compat)+    build-depends:+        parsec >=3.1.14+  if flag(megaparsec-compat)+    exposed-modules:+        Error.Diagnose.Compat.Megaparsec+  if flag(parsec-compat)+    exposed-modules:+        Error.Diagnose.Compat.Parsec+  default-language: Haskell2010++test-suite diagnose-megaparsec-tests+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_diagnose+  hs-source-dirs:+      test/megaparsec+  default-extensions:+      OverloadedStrings+      LambdaCase+      BlockArguments+  ghc-options: -Wall -Wextra -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , bytestring ==0.10.*+    , data-default ==0.7.*+    , diagnose+    , hashable ==1.3.*+    , prettyprinter ==1.7.*+    , prettyprinter-ansi-terminal ==1.1.*+    , text ==1.2.*+    , unordered-containers ==0.2.*+  if flag(json)+    cpp-options: -DUSE_AESON+    build-depends:+        aeson ==1.5.*+  if flag(megaparsec-compat)+    build-depends:+        containers ==0.6.*+      , megaparsec >=9.0.0+  if flag(parsec-compat)+    build-depends:+        parsec >=3.1.14+  if !(flag(megaparsec-compat))+    buildable: False+  default-language: Haskell2010++test-suite diagnose-parsec-tests+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_diagnose+  hs-source-dirs:+      test/parsec+  default-extensions:+      OverloadedStrings+      LambdaCase+      BlockArguments+  ghc-options: -Wall -Wextra -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , bytestring ==0.10.*+    , data-default ==0.7.*+    , diagnose+    , hashable ==1.3.*+    , prettyprinter ==1.7.*+    , prettyprinter-ansi-terminal ==1.1.*+    , text ==1.2.*+    , unordered-containers ==0.2.*+  if flag(json)+    cpp-options: -DUSE_AESON+    build-depends:+        aeson ==1.5.*+  if flag(megaparsec-compat)+    build-depends:+        containers ==0.6.*+      , megaparsec >=9.0.0+  if flag(parsec-compat)+    build-depends:+        parsec >=3.1.14+  if !(flag(parsec-compat))+    buildable: False+  default-language: Haskell2010++test-suite diagnose-rendering-tests+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_diagnose+  hs-source-dirs:+      test/rendering+  default-extensions:+      OverloadedStrings+      LambdaCase+      BlockArguments+  ghc-options: -Wall -Wextra -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , bytestring ==0.10.*+    , data-default ==0.7.*+    , diagnose+    , hashable ==1.3.*+    , prettyprinter ==1.7.*+    , prettyprinter-ansi-terminal ==1.1.*+    , text ==1.2.*+    , unordered-containers ==0.2.*+  if flag(json)+    cpp-options: -DUSE_AESON+    build-depends:+        aeson ==1.5.*+  if flag(megaparsec-compat)+    build-depends:+        containers ==0.6.*+      , megaparsec >=9.0.0+  if flag(parsec-compat)+    build-depends:+        parsec >=3.1.14+  default-language: Haskell2010
+ src/Data/List/Safe.hs view
@@ -0,0 +1,35 @@+module Data.List.Safe where++import Data.Bifunctor (first)+++-- | Analogous to 'Data.List.last', but returns 'Nothing' on an empty list, instead of throwing an error.+safeLast :: [a] -> Maybe a+safeLast [] = Nothing+safeLast l  = Just $ last l++-- | Analogous to `Data.List.head`, but returns 'Nothing' in case of an empty list.+safeHead :: [a] -> Maybe a+safeHead []      = Nothing+safeHead (x : _) = Just x++-- | Analogous tu 'Data.List.!!', but does not throw an error on missing index.+safeIndex :: Int -> [a] -> Maybe a+safeIndex _ []       = Nothing+safeIndex 0 (x : _)  = Just x+safeIndex n (_ : xs)+  | n < 0            = Nothing+  | otherwise        = safeIndex (n - 1) xs++-- | Safely deconstructs a list from the end.+--+--   More efficient than @(init x, last x)@+safeUnsnoc :: [a] -> Maybe ([a], a)+safeUnsnoc []       = Nothing+safeUnsnoc [x]      = Just ([], x)+safeUnsnoc (x : xs) = first (x :) <$> safeUnsnoc xs++-- | Safely deconstructs a list from the beginning, returning 'Nothing' if the list is empty.+safeUncons :: [a] -> Maybe (a, [a])+safeUncons []       = Nothing+safeUncons (x : xs) = Just (x, xs)
+ src/Error/Diagnose.hs view
@@ -0,0 +1,289 @@+module Error.Diagnose+  ( -- $header++    -- * How to use this module+    -- $usage++    -- ** Generating a report+    -- $generate_report++    -- ** Creating diagnostics from reports+    -- $create_diagnostic++    -- *** Pretty-printing a diagnostic+    -- $diagnostic_pretty++    -- *** Exporting a diagnostic to JSON+    -- $diagnostic_json++    -- ** Compatibility layers for popular parsing libraries+    -- $compatibility_layers++    -- *** megaparsec >= 9.0.0 ("Error.Diagnose.Compat.Megaparsec")+    -- $compatibility_megaparsec+     +    -- *** parsec >= 3.1.14.0 ("Error.Diagnose.Compat.Parsec")+    -- $compatibility_parsec+    +    -- *** Common errors+    -- $compatibility_errors++    -- * Re-exports+    module Export ) where++import Error.Diagnose.Pretty as Export+import Error.Diagnose.Position as Export+import Error.Diagnose.Report as Export+import Error.Diagnose.Diagnostic as Export++{- $header++   This module exports all the needed data types to use this library.+   It should be sufficient to only @import "Error.Diagnose"@.+-}++{- $usage++   This library is intended to provide a very simple way of creating beautiful errors, by exposing+   a small yet simple API to the user.++   The basic idea is that a diagnostic is a collection of reports (which embody errors or warnings) along+   with the files which can be referenced in those reports.+-}++{- $generate_report++   A report contains:++   - A message, to be shown at the top++   - A list of located markers, used to underline parts of the source code and to emphasize it with a message++   - A list of hints, shown at the very bottom++   __Note__: The message type contained in a report is abstracted by a type variable.+             In order to render the report, the message must also be able to be rendered in some way+             (that we'll see later).++   This library allows defining two kinds of reports:++   - Errors, using 'err'++   - Warnings, using 'warn'++   Both take a message, a list of located markers and a list of hints.++   A very simple example is:++   > exampleReport :: Report String+   > exampleReport =+   >   err+   >     -- vv  ERROR MESSAGE+   >     "This is my first error report"+   >     -- vv  MARKERS+   >     [ (Position (1, 3) (1, 8) "some_test.txt", This "Some text under the marker") ]+   >     -- vv  HINTS+   >     []++   In general, 'Position's are returned by either a lexer or a parser, so that you never have to construct them+   directly in the code.++   __Note__: If using any parser library, you will have to convert from the internal positioning system to a 'Position'+             to be able to use this library.++   Markers put in the report can be one of (the colors specified are used only when pretty-printing):++   - A 'This' marker, which is the primary marker of the report.+     While it is allowed to have multiple of these inside one report, it is encouraged not to, because the position at the top of+     the report will only be the one of the /first/ 'This' marker, and because the resulting report may be harder to understand.++         This marker is output in red in an error report, and yellow in a warning report.++   - A 'Where' marker contains additional information/provides context to the error/warning report.+     For example, it may underline where a given variable @x@ is bound to emphasize it.++         This marker is output in blue.++   - A 'Error.Diagnose.Report.Maybe' marker may contain possible fixes (if the text is short, else hints are recommended for this use).++         This marker is output in magenta.+-}++{- $create_diagnostic++   To create a new diagnostic, you need to use its 'Data.Default.Default' instance (which exposes a 'def' function, returning a new empty 'Diagnostic').+   Once the 'Diagnostic' is created, you can use either 'addReport' (which takes a 'Diagnostic' and a 'Report', abstract by the same message type,+   and returns a 'Diagnostic') to insert a new report inside the diagnostic, or 'addFile' (which takes a 'Diagnostic', a 'FilePath' and a @['String']@,+   and returns a 'Diagnostic') to insert a new file reference in the diagnostic.++   You can then either pretty-print the diagnostic obtained (which requires all messages to be instances of the 'Text.PrettyPrint.ANSI.Leijen.Pretty')+   or export it to a lazy JSON 'Data.Bytestring.Lazy.ByteString' (e.g. in a LSP context).+-}++{- $diagnostic_pretty++   'Diagnostic's can be output to any 'System.IO.Handle' using the 'printDiagnostic' function.+   This function takes several parameters:++   - The 'System.IO.Handle' onto which to output the 'Diagnostic'.+     It __must__ be a 'System.IO.Handle' capable of outputting data.++   - A 'Bool' used to indicate whether you want to output the 'Diagnostic' with unicode characters, or simple ASCII characters.++         Here are two examples of the same diagnostic, the first output with unicode characters, and the second output with ASCII characters:++         > [error]: Error with one marker in bounds+         >      ╭─▶ test.zc@1:25-1:30+         >      │+         >    1 │ let id<a>(x : a) : a := x + 1+         >      •                         ┬────+         >      •                         ╰╸ Required here+         > ─────╯++         > [error]: Error with one marker in bounds+         >      +-> test.zc@1:25-1:30+         >      |+         >    1 | let id<a>(x : a) : a := x + 1+         >      :                         ^----+         >      :                         `- Required here+         > -----+++   - A 'Bool' set to 'False' if you don't want colors in the end result.++   - And finally the 'Diagnostic' to output.+-}++{- $diagnostic_json++   'Diagnostic's can be exported to a JSON record of the following type, using the 'diagnosticToJson' function:++   > { files:+   >     { name: string+   >     , content: string[]+   >     }[]+   > , reports:+   >     { kind: 'error' | 'warning'+   >     , message: string+   >     , markers:+   >         { kind: 'this' | 'where' | 'maybe'+   >         , position:+   >             { beginning: { line: int, column: int }+   >             , end: { line: int, column: int }+   >             , file: string+   >             }+   >         , message: string+   >         }[]+   >     , hints: string[]+   >     }[]+   > }++   This is particularly useful in the context of a LSP server, where outputting or parsing a raw error yields strange results or is unnecessarily complicated.++   Please note that this requires the flag @diagnose:json@ to be enabled (it is disabled by default in order not to include @aeson@, which is a heavy library).+-}++{- $compatibility_layers ++   There are many parsing libraries available in the Haskell ecosystem, each coming with its own way of handling errors.+   Eventually, one needs to be able to map errors from these libraries to 'Diagnostic's, without having to include additional code for doing so.+   This is where compatibility layers come in handy.++   As of now, there are compatibility layers for these libraries:+-}++{- $compatibility_megaparsec++   This needs the flag @diagnose:megaparsec-compat@ to be enabled.++   Using the compatibility layer is very easy, as it is designed to be as simple as possible.+   One simply needs to convert the 'Text.Megaparsec.ParseErrorBundle' which is returned by running a parser into a 'Diagnostic' by using 'Error.Diagnose.Compat.Megaparsec.diagnosticFromBundle'.+   Several wrappers are included for easy creation of kinds (error, warning) of diagnostics.++   __Note:__ the returned diagnostic does not include file contents, which needs to be added manually afterwards.++   As a quick example:++   > import qualified Text.Megaparsec as MP+   > import qualified Text.Megaparsec.Char as MP+   > import qualified Text.Megaparsec.Char.Lexer as MP+   >+   > let filename = "<interactive>"+   >     content  = "00000a2223266"+   >+   > let myParser = MP.some MP.decimal <* MP.eof+   >+   > let res      = MP.runParser myParser filename content+   >+   > case res of+   >   Left bundle ->+   >     let diag  = errorDiagnosticFromBundle "Parse error on input" Nothing bundle+   >            --   Creates a new diagnostic with no default hints from the bundle returned by megaparsec+   >         diag' = addFile diag filename content+   >            --   Add the file used when parsing with the same filename given to 'MP.runParser'+   >     in printDiagnostic stderr True True diag'+   >   Right res   -> print res++   This example will return the following error message (assuming default instances for @'Error.Diagnose.Compat.Megaparsec.HasHints' 'Data.Void.Void' msg@):++   > [error]: Parse error on input+   >      ╭─▶ <interactive>@1:6-1:7+   >      │+   >    1 │ 00000a2223266+   >      •      ┬ +   >      •      ├╸ unexpected 'a'+   >      •      ╰╸ expecting digit, end of input, or integer+   > ─────╯+-}++{- $compatibility_parsec++   This needs the flag @diagnose:parsec-compat@ to be enabled.++   This compatibility layer allows easily converting 'Text.Parsec.Error.ParseError's into a single-report diagnostic containing all available information such+   as unexpected/expected tokens or error messages.+   The function 'Error.Diagnose.Compat.Parsec.diagnosticFromParseError' is used to perform the conversion between a 'Text.Parsec.Error.ParseError' and a 'Diagnostic'.++   __Note:__ the returned diagnostic does not include file contents, which needs to be added manually afterwards.++   Quick example:++   > import qualified Text.Parsec as P+   >+   > let filename = "<interactive>"+   >     content  = "00000a2223266"+   >+   > let myParser = P.many1 P.digit <* P.eof+   >+   > let res      = P.parse myParser filename content+   >+   > case res of+   >   Left error ->+   >     let diag  = errorDiagnosticFromParseError "Parse error on input" Nothing error+   >            --   Creates a new diagnostic with no default hints from the bundle returned by megaparsec+   >         diag' = addFile diag filename content+   >            --   Add the file used when parsing with the same filename given to 'MP.runParser'+   >     in printDiagnostic stderr True True diag'+   >   Right res  -> print res++   This will output the following errr on @stderr@:++   > [error]: Parse error on input+   >      ╭─▶ <interactive>@1:6-1:7+   >      │+   >    1 │ 00000a2223266+   >      •      ┬ +   >      •      ├╸ unexpected 'a'+   >      •      ╰╸ expecting any of digit, end of input+   > ─────╯+-}++{- $compatibility_errors++   - @No instance for (HasHints ??? msg) arising from a use of ‘errorDiagnosticFromBundle’@ (@???@ is any type, depending on your parser's custom error type):++       The typeclass 'Error.Diagnose.Compat.Megaparsec.HasHints' does not have any default instances, because treatments of custom errors is highly dependent on who is using the library.+       As such, you will need to create orphan instances for your parser's error type.++       Note that the message type @msg@ can be left abstract if the implements of 'Error.Diagnose.Compat.Hints.hints' is @hints _ = mempty@.++-}
+ src/Error/Diagnose/Compat/Hints.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Error.Diagnose.Compat.Hints where+    +-- | A class mapping custom errors of type @e@ with messages of type @msg@.+class HasHints e msg where+  -- | Defines all the hints associated with a given custom error.+  hints :: e -> [msg]++-- this is a sane default for 'Void'+-- but this can be redefined+--+-- instance HasHints Void msg where+--   hints _ = mempty
+ src/Error/Diagnose/Compat/Megaparsec.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE BlockArguments #-}+{-# 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++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) =>+  -- | 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+    toLabeledPosition :: MP.ParseError s e -> Report msg+    toLabeledPosition error =+      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)]+                | [m1, m2] <- msgs -> [(source, This m1), (source, Where m2)]+                | otherwise -> [(source, This $ fromString "<<Unknown error>>")]++    fromSourcePos :: MP.SourcePos -> Position+    fromSourcePos MP.SourcePos {..} =+      let start = both (fromIntegral . MP.unPos) (sourceLine, sourceColumn)+          end = second (+ 1) start+       in Position start end sourceName++    errorHints :: MP.ParseError s e -> [msg]+    errorHints MP.TrivialError {} = trivialHints+    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) =>+  -- | 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) =>+  -- | 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 --------------+------------------------------------++-- | Applies a computation to both element of a tuple.+--+--   > both f = bimap @(,) f f+both :: (a -> b) -> (a, a) -> (b, b)+both f ~(x, y) = (f x, f y)
+ src/Error/Diagnose/Compat/Parsec.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++{-# 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++import Data.Bifunctor (second)+import Data.Function ((&))+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) =>+  -- | 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+      report = (msg & if isError error then err else warn) markers (defaultHints <> hints (undefined :: Void))+   in addReport def report+  where+    fromSourcePos :: PP.SourcePos -> Position+    fromSourcePos pos =+      let start = both fromIntegral (PP.sourceLine pos, PP.sourceColumn pos)+          end = second (+ 1) start+       in Position start end (PP.sourceName pos)++    toMarkers :: Position -> [PE.Message] -> [(Position, Marker msg)]+    toMarkers source [] = [(source, This $ fromString "<<unknown error>>")]+    toMarkers source msgs =+      let putTogether [] = ([], [], [], [])+          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.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)++          (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+               ]+            <> [(source, Where $ fromString $ "expecting any of " <> intercalate ", " expectedList)]++-- | Generates an error diagnostic from a 'PE.ParseError'.+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) =>+  -- | 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 --------------+------------------------------------++-- | Applies a computation to both element of a tuple.+--+--   > both f = bimap @(,) f f+both :: (a -> b) -> (a, a) -> (b, b)+both f ~(x, y) = (f x, f y)
+ src/Error/Diagnose/Diagnostic.hs view
@@ -0,0 +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+  ( -- * Re-exports+    module Export,+  )+where++import Error.Diagnose.Diagnostic.Internal as Export+  ( Diagnostic,+#ifdef USE_AESON+  diagnosticToJson,+#endif+    addFile,+    addReport,+    def,+    printDiagnostic,+  )+import System.IO as Export (stderr, stdout)
+ src/Error/Diagnose/Diagnostic/Internal.hs view
@@ -0,0 +1,144 @@+{-# 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 (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)++-- | 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.+      --+      --   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+  def = Diagnostic mempty mempty++instance Semigroup (Diagnostic msg) where+  Diagnostic rs1 file <> Diagnostic rs2 _ = Diagnostic (rs1 <> rs2) file++#ifdef USE_AESON+instance ToJSON msg => ToJSON (Diagnostic msg) where+  toJSON (Diagnostic reports files) =+    object [ "files" .= fmap toJSONFile (HashMap.toList files)+           , "reports" .= reports+           ]+    where+      toJSONFile (path, content) =+        object [ "name" .= path+               , "content" .= content+               ]+#endif++-- | 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 =>+  -- | 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) =>+  -- | 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+    unlessId cond app = if cond then id else app+    {-# INLINE unlessId #-}+{-# INLINE printDiagnostic #-}++-- | Inserts a new referenceable file within the diagnostic.+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 ->+  -- | The new report to add to the diagnostic.+  Report msg ->+  Diagnostic msg+addReport (Diagnostic reports files) report =+  Diagnostic (report : reports) files+{-# INLINE addReport #-}++#ifdef USE_AESON+-- | Creates a JSON object from a diagnostic, containing those fields (only types are indicated):+--+--   > { files:+--   >     { name: string+--   >     , content: string[]+--   >     }[]+--   > , reports:+--   >     { kind: 'error' | 'warning'+--   >     , message: string+--   >     , markers:+--   >         { kind: 'this' | 'where' | 'maybe'+--   >         , position:+--   >             { beginning: { line: int, column: int }+--   >             , end: { line: int, column: int }+--   >             , file: string+--   >             }+--   >         , message: string+--   >         }[]+--   >     , hints: string[]+--   >     }[]+--   > }+diagnosticToJson :: ToJSON msg => Diagnostic msg -> ByteString+diagnosticToJson = encode+#endif
+ src/Error/Diagnose/Position.hs view
@@ -0,0 +1,65 @@+{-# 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.Position (Position (..)) where++#ifdef USE_AESON+import Data.Aeson (ToJSON(..), object, (.=))+#endif+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 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),+    -- | The end line and column of the span.+    end :: (Int, Int),+    -- | The file this position spans in.+    file :: FilePath+  }+  deriving (Show, Eq, Generic)++instance Ord Position where+  Position b1 e1 _ `compare` Position b2 e2 _ = (b1, e1) `compare` (b2, e2)++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 "@"+      dash = pretty @Text "-"++instance Hashable Position++instance Default Position where+  def = Position (1, 1) (1, 1) "<no-file>"++#ifdef USE_AESON+instance ToJSON Position where+  toJSON (Position (bl, bc) (el, ec) file) =+    object [ "beginning" .= object [ "line" .= bl, "column" .= bc ]+           , "end" .= object [ "line" .= el, "column" .= ec ]+           , "file" .= file+           ]+#endif
+ src/Error/Diagnose/Pretty.hs view
@@ -0,0 +1,4 @@+module Error.Diagnose.Pretty (module Export) where++import qualified Prettyprinter as Export +import qualified Prettyprinter.Render.Terminal as Export
+ src/Error/Diagnose/Report.hs view
@@ -0,0 +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+  ( -- * Re-exports+    module Export,+  )+where++import Error.Diagnose.Report.Internal as Export (Marker (..), Report, err, warn)
+ src/Error/Diagnose/Report/Internal.hs view
@@ -0,0 +1,543 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS -Wno-name-shadowing #-}++-- |+-- Module      : Error.Diagnose.Report.Internal+-- Description : Internal workings for report 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.Report" module, which exports some of the useful functions defined here.+module Error.Diagnose.Report.Internal where++#ifdef USE_AESON+import Data.Aeson (ToJSON(..), object, (.=))+#endif+import Data.Bifunctor (bimap, first, second)+import Data.Default (def)+import Data.Foldable (fold)+import Data.Function (on)+import Data.Functor ((<&>))+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap+import qualified Data.List as List+import qualified Data.List.Safe as List+import Data.Ord (Down (..))+import Error.Diagnose.Position+import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, space, width, (<+>))+import Prettyprinter.Internal (Doc (..))+import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold, color, colorDull)++-- | The type of diagnostic reports with abstract message type.+data Report msg+  = Report+      Bool+      -- ^ Is the report a warning or an error?+      msg+      -- ^ The message associated with the error.+      [(Position, Marker msg)]+      -- ^ A map associating positions with marker to show under the source code.+      [msg]+      -- ^ A list of hints to add at the end of the report.++instance Semigroup msg => Semigroup (Report msg) where+  Report isError1 msg1 pos1 hints1 <> Report isError2 msg2 pos2 hints2 =+    Report (isError1 || isError2) (msg1 <> msg2) (pos1 <> pos2) (hints1 <> hints2)++instance Monoid msg => Monoid (Report msg) where+  mempty = Report False mempty mempty mempty++#ifdef USE_AESON+instance ToJSON msg => ToJSON (Report msg) where+  toJSON (Report isError msg markers hints) =+    object [ "kind" .= (if isError then "error" else "warning" :: String)+           , "message" .= msg+           , "markers" .= fmap showMarker markers+           , "hints" .= hints+           ]+    where+      showMarker (pos, marker) =+        object $ [ "position" .= pos ]+              <> case marker of+                   This m  -> [ "message" .= m+                              , "kind" .= ("this" :: String)+                              ]+                   Where m -> [ "message" .= m+                              , "kind" .= ("where" :: String)+                              ]+                   Maybe m -> [ "message" .= m+                              , "kind" .= ("maybe" :: String)+                              ]+#endif++-- | The type of markers with abstract message type, shown under code lines.+data Marker msg+  = -- | A red or yellow marker under source code, marking important parts of the code.+    This msg+  | -- | A blue marker symbolizing additional information.+    Where msg+  | -- | A magenta marker to report potential fixes.+    Maybe msg++instance Eq (Marker msg) where+  This _ == This _ = True+  Where _ == Where _ = True+  Maybe _ == Maybe _ = True+  _ == _ = False+  {-# INLINEABLE (==) #-}++instance Ord (Marker msg) where+  This _ < _ = False+  Where _ < This _ = True+  Where _ < _ = False+  Maybe _ < _ = True+  {-# INLINEABLE (<) #-}++  m1 <= m2 = m1 < m2 || m1 == m2+  {-# INLINEABLE (<=) #-}++-- | Constructs a warning or an error report.+warn,+  err ::+    -- | The report message, shown at the very top.+    msg ->+    -- | A list associating positions with markers.+    [(Position, Marker msg)] ->+    -- | A possibly mempty list of hints to add at the end of the report.+    [msg] ->+    Report msg+warn = Report False+{-# INLINE warn #-}+err = Report True+{-# INLINE err #-}++-- | Pretty prints a report to a 'Doc' handling colors.+prettyReport ::+  Pretty msg =>+  -- | The content of the file the reports are for+  HashMap FilePath [String] ->+  -- | Should we print paths in unicode?+  Bool ->+  -- | The whole report to output+  Report msg ->+  Doc AnsiStyle+prettyReport fileContent withUnicode (Report isError message markers hints) =+  let sortedMarkers = List.sortOn (fst . begin . fst) markers+      -- sort the markers so that the first lines of the reports are the first lines of the file++      groupedMarkers = groupMarkersPerFile sortedMarkers+      -- group markers by the file they appear in, and put `This` markers at the top of the report++      maxLineNumberLength = maybe 3 (max 3 . length . show . fst . end . fst) $ List.safeLast markers+      -- if there are no markers, then default to 3, else get the maximum between 3 and the length of the last marker++      header = annotate bold if isError then annotate (color Red) "[error]" else annotate (color Yellow) "[warning]"+   in {-+              A report is of the form:+              (1)    [error|warning]: <message>+              (2)           +-> <file>+              (3)           :+              (4)    <line> | <line of code>+                            : <marker lines>+                            : <marker messages>+              (5)           :+                            : <hints>+              (6)    -------++      -}++      {- (1) -} header <> colon <+> align (pretty message)+        <> {- (2), (3), (4) -} fold (uncurry (prettySubReport fileContent withUnicode isError maxLineNumberLength) <$> groupedMarkers)+        <> {- (5) -} ( if+                           | null hints && null markers -> mempty+                           | null hints -> mempty+                           | otherwise -> hardline <+> dotPrefix maxLineNumberLength withUnicode+                     )+        <> prettyAllHints hints maxLineNumberLength withUnicode+        <> hardline+        <> {- (6) -} ( if null markers && null hints+                         then mempty+                         else+                           annotate (bold <> color Black) (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty <> if withUnicode then "╯" else "+")+                             <> hardline+                     )++-------------------------------------------------------------------------------------+----- INTERNAL STUFF ----------------------------------------------------------------+-------------------------------------------------------------------------------------++-- | Inserts a given number of character after a 'Doc'ument.+pad :: Int -> Char -> Doc ann -> Doc ann+pad n c d = width d \w -> pretty $ replicate (n - w) c++-- | Creates a "dot"-prefix for a report line where there is no code.+--+--   Pretty printing yields those results:+--+--   [with unicode] "@␣␣␣␣␣•␣@"+--   [without unicode] "@␣␣␣␣␣:␣@"+dotPrefix ::+  -- | The length of the left space before the bullet.+  Int ->+  -- | Whether to print with unicode characters or not.+  Bool ->+  Doc AnsiStyle+dotPrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate (bold <> color Black) (if withUnicode then "•" else ":")+{-# INLINE dotPrefix #-}++-- | Creates a "pipe"-prefix for a report line where there is no code.+--+--   Pretty printing yields those results:+--+--   [with unicode] "@␣␣␣␣␣│␣@"+--   [without unicode] "@␣␣␣␣␣|␣@"+pipePrefix ::+  -- | The length of the left space before the pipe.+  Int ->+  -- | Whether to print with unicode characters or not.+  Bool ->+  Doc AnsiStyle+pipePrefix leftLen withUnicode = pad leftLen ' ' mempty <+> annotate (bold <> color Black) (if withUnicode then "│" else "|")+{-# INLINE pipePrefix #-}++-- | Creates a line-prefix for a report line containing source code+--+--   Pretty printing yields those results:+--+--   [with unicode] "@␣␣␣3␣│␣@"+--   [without unicode] "@␣␣␣3␣|␣@"+--+--   Results may be different, depending on the length of the line number.+linePrefix ::+  -- | The length of the amount of space to span before the vertical bar.+  Int ->+  -- | The line number to show.+  Int ->+  -- | Whether to use unicode characters or not.+  Bool ->+  Doc AnsiStyle+linePrefix leftLen lineNo withUnicode =+  let lineNoLen = length (show lineNo)+   in annotate (bold <> color Black) $ mempty <+> pad (leftLen - lineNoLen) ' ' mempty <> pretty lineNo <+> if withUnicode then "│" else "|"+{-# INLINE linePrefix #-}++groupMarkersPerFile ::+  Pretty msg =>+  [(Position, Marker msg)] ->+  [(Bool, [(Position, Marker msg)])]+groupMarkersPerFile [] = []+groupMarkersPerFile markers =+  let markersPerFile = List.foldl' (HashMap.unionWith (<>)) mempty $ markers <&> \tup@(p, _) -> HashMap.singleton (file p) [tup]+   in -- put all markers on the same file together+      -- NOTE: it's a shame that `HashMap.unionsWith f = foldl' (HashMap.unionWith f) mempty` does not exist++      onlyFirstToTrue $ putThisMarkersAtTop $ HashMap.elems markersPerFile+  where+    onlyFirstToTrue = go True []++    go _ acc [] = reverse acc+    go t acc (x : xs) = go False ((t, x) : acc) xs++    putThisMarkersAtTop = List.sortBy \ms1 ms2 ->+      if+          | any isThisMarker (snd <$> ms1) -> LT+          | any isThisMarker (snd <$> ms2) -> GT+          | otherwise -> EQ++-- | Prettyprint a sub-report, which is a part of the report spanning across a single file+prettySubReport ::+  Pretty msg =>+  -- | The content of files in the diagnostics+  HashMap FilePath [String] ->+  -- | Is the output done with Unicode characters?+  Bool ->+  -- | Is the current report an error report?+  Bool ->+  -- | The size of the biggest line number+  Int ->+  -- | Is this sub-report the first one in the list?+  Bool ->+  -- | The list of line-ordered markers appearing in a single file+  [(Position, Marker msg)] ->+  Doc AnsiStyle+prettySubReport fileContent withUnicode isError maxLineNumberLength isFirst markers =+  let (markersPerLine, multilineMarkers) = splitMarkersPerLine markers+      -- split the list on whether markers are multiline or not++      sortedMarkersPerLine = {- second (List.sortOn (first $ snd . begin)) <$> -} List.sortOn fst (HashMap.toList markersPerLine)++      reportFile = maybe (pretty @Position def) (pretty . fst) $ List.safeHead (List.sortOn snd markers)+      -- the reported file is the file of the first 'This' marker (only one must be present)++      allLineNumbers = List.sort $ List.nub $ (fst <$> sortedMarkersPerLine) <> (multilineMarkers >>= \(Position (bl, _) (el, _) _, _) -> [bl .. el])++      fileMarker =+        ( if isFirst+            then+              space <> pad maxLineNumberLength ' ' mempty+                <+> annotate (bold <> color Black) (if withUnicode then "╭──▶" else "+-->")+            else+              space <> dotPrefix maxLineNumberLength withUnicode <> hardline+                <> annotate (bold <> color Black) (pad (maxLineNumberLength + 2) (if withUnicode then '─' else '-') mempty)+                <> annotate (bold <> color Black) (if withUnicode then "┼──▶" else "+-->")+        )+          <+> annotate (bold <> colorDull Green) reportFile+   in {- (2) -} hardline <> fileMarker+        <> hardline+          <+> {- (3) -} pipePrefix maxLineNumberLength withUnicode+        <> {- (4) -} prettyAllLines fileContent withUnicode isError maxLineNumberLength sortedMarkersPerLine multilineMarkers allLineNumbers++isThisMarker :: Marker msg -> Bool+isThisMarker (This _) = True+isThisMarker _ = False++-- |+splitMarkersPerLine :: [(Position, Marker msg)] -> (HashMap Int [(Position, Marker msg)], [(Position, Marker msg)])+splitMarkersPerLine [] = (mempty, mempty)+splitMarkersPerLine (m@(Position {..}, _) : ms) =+  let (bl, _) = begin+      (el, _) = end+   in (if bl == el then first (HashMap.insertWith (<>) bl [m]) else second (m :))+        (splitMarkersPerLine ms)++-- |+prettyAllLines ::+  Pretty msg =>+  HashMap FilePath [String] ->+  Bool ->+  Bool ->+  Int ->+  [(Int, [(Position, Marker msg)])] ->+  [(Position, Marker msg)] ->+  [Int] ->+  Doc AnsiStyle+prettyAllLines _ _ _ _ _ [] [] = mempty+prettyAllLines _ withUnicode isError leftLen _ multiline [] =+  let colorOfLastMultilineMarker = maybe mempty (markerColor isError . snd) (List.safeLast multiline)+      -- take the color of the last multiline marker in case we need to add additional bars++      prefix = hardline <+> dotPrefix leftLen withUnicode <> space+      prefixWithBar color = prefix <> annotate color (if withUnicode then "│ " else "| ")++      showMultilineMarkerMessage (_, marker) isLast =+        annotate (markerColor isError marker) $+          ( if isLast+              then if withUnicode then "╰╸ " else "`- "+              else if withUnicode then "├╸ " else "|- "+          )+            <> replaceLinesWith (if isLast then prefix <> "   " else prefixWithBar (markerColor isError marker) <> space) (pretty $ markerMessage marker)++      showMultilineMarkerMessages [] = []+      showMultilineMarkerMessages [m] = [showMultilineMarkerMessage m True]+      showMultilineMarkerMessages (m : ms) = showMultilineMarkerMessage m False : showMultilineMarkerMessages ms+   in prefixWithBar colorOfLastMultilineMarker <> prefix <> fold (List.intersperse prefix $ showMultilineMarkerMessages $ reverse multiline)+prettyAllLines files withUnicode isError leftLen inline multiline (line : ls) =+  {-+      A line of code is composed of:+      (1)     <line> | <source code>+      (2)            : <markers>+      (3)            : <marker messages>++      Multline markers may also take additional space (2 characters) on the right of the bar+  -}+  let allInlineMarkersInLine = snd =<< filter ((==) line . fst) inline++      allMultilineMarkersInLine = flip filter multiline \(Position (bl, _) (el, _) _, _) -> bl == line || el == line++      allMultilineMarkersSpanningLine = flip filter multiline \(Position (bl, _) (el, _) _, _) -> bl < line && el > line++      inSpanOfMultiline = flip any multiline \(Position (bl, _) (el, _) _, _) -> bl <= line && el >= line++      colorOfFirstMultilineMarker = maybe id (annotate . markerColor isError . snd) (List.safeHead $ allMultilineMarkersInLine <> allMultilineMarkersSpanningLine)+      -- take the first multiline marker to color the entire line, if there is one++      !additionalPrefix = case allMultilineMarkersInLine of+        [] ->+          if not $ null multiline+            then+              if not $ null allMultilineMarkersSpanningLine+                then colorOfFirstMultilineMarker if withUnicode then "│  " else "|  "+                else "   "+            else mempty+        (p@(Position _ (el, _) _), marker) : _ ->+          let hasPredecessor = el == line || maybe False ((/=) p . fst . fst) (List.safeUncons multiline)+           in colorOfFirstMultilineMarker+                ( if+                      | hasPredecessor && withUnicode -> "├"+                      | hasPredecessor -> "|"+                      | withUnicode -> "╭"+                      | otherwise -> "+"+                )+                <> annotate (markerColor isError marker) (if withUnicode then "┤" else ">")+                <> space++      allMarkersInLine = {- List.sortOn fst $ -} allInlineMarkersInLine <> allMultilineMarkersInLine+   in hardline+        <> {- (1) -} linePrefix leftLen line withUnicode <+> additionalPrefix+        <> getLine_ files (allMarkersInLine <> allMultilineMarkersSpanningLine) line isError+        <> {- (2) -} showAllMarkersInLine (not $ null multiline) inSpanOfMultiline colorOfFirstMultilineMarker withUnicode isError leftLen allInlineMarkersInLine+        <> {- (3) -} prettyAllLines files withUnicode isError leftLen inline multiline ls++-- |+getLine_ :: HashMap FilePath [String] -> [(Position, Marker msg)] -> Int -> Bool -> Doc AnsiStyle+getLine_ files markers line isError = case List.safeIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of+  Nothing -> annotate (bold <> colorDull Magenta) "<no line>"+  Just code ->+    fold $+      indexed code <&> \(n, c) ->+        let colorizingMarkers = flip+              filter+              markers+              \(Position (bl, bc) (el, ec) _, _) ->+                if bl == el+                  then n >= bc && n < ec+                  else (bl == line && n >= bc) || (el == line && n < ec)+         in maybe id ((\m -> annotate (bold <> markerColor isError m)) . snd) (List.safeHead colorizingMarkers) (pretty c)+  where+    indexed :: [a] -> [(Int, a)]+    indexed = goIndexed 1++    goIndexed :: Int -> [a] -> [(Int, a)]+    goIndexed _ [] = []+    goIndexed n (x : xs) = (n, x) : goIndexed (n + 1) xs++-- |+showAllMarkersInLine :: Pretty msg => Bool -> Bool -> (Doc AnsiStyle -> Doc AnsiStyle) -> Bool -> Bool -> Int -> [(Position, Marker msg)] -> Doc AnsiStyle+showAllMarkersInLine _ _ _ _ _ _ [] = mempty+showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUnicode isError leftLen ms =+  let maxMarkerColumn = snd $ end $ fst $ List.last $ List.sortOn (snd . end . fst) ms+      specialPrefix =+        if inSpanOfMultiline+          then colorMultilinePrefix (if withUnicode then "│ " else "| ") <> space+          else+            if hasMultilines+              then colorMultilinePrefix "  " <> space+              else mempty+   in -- get the maximum end column, so that we know when to stop looking for other markers on the same line+      hardline <+> dotPrefix leftLen withUnicode <+> (if List.null ms then mempty else specialPrefix <> showMarkers 1 maxMarkerColumn <> showMessages specialPrefix ms maxMarkerColumn)+  where+    showMarkers n lineLen+      | n > lineLen = mempty -- reached the end of the line+      | otherwise =+        let allMarkers = flip filter ms \(Position (_, bc) (_, ec) _, _) -> n >= bc && n < ec+         in -- only consider markers which span onto the current column+            case allMarkers of+              [] -> space <> showMarkers (n + 1) lineLen+              (Position {..}, marker) : _ ->+                if snd begin == n+                  then annotate (markerColor isError marker) (if withUnicode then "┬" else "^") <> showMarkers (n + 1) lineLen+                  else annotate (markerColor isError marker) (if withUnicode then "─" else "-") <> showMarkers (n + 1) lineLen+    -- if the marker just started on this column, output a caret, else output a dash++    showMessages specialPrefix ms lineLen = case List.safeUncons ms of+      Nothing -> mempty -- no more messages to show+      Just ((Position b@(_, bc) _ _, msg), pipes) ->+        let filteredPipes = filter ((/= b) . begin . fst) pipes+            -- record only the pipes corresponding to markers on different starting positions+            nubbedPipes = List.nubBy ((==) `on` (begin . fst)) filteredPipes+            -- and then remove all duplicates++            allColumns _ [] = (1, [])+            allColumns n ms@((Position (_, bc) _ _, col) : ms')+              | n == bc = bimap (+ 1) (col :) (allColumns (n + 1) ms')+              | n < bc = bimap (+ 1) (space :) (allColumns (n + 1) ms)+              | otherwise = bimap (+ 1) (space :) (allColumns (n + 1) ms')+            -- transform the list of remaining markers into a single document line++            hasSuccessor = length filteredPipes /= length pipes++            lineStart pipes =+              let (n, docs) = allColumns 1 $ List.sortOn (snd . begin . fst) pipes+               in dotPrefix leftLen withUnicode <+> specialPrefix <> fold docs <> pretty (replicate (bc - n) ' ')+            -- the start of the line contains the "dot"-prefix as well as all the pipes for all the still not rendered marker messages++            prefix =+              let (pipesBefore, pipesAfter) = List.partition ((< bc) . snd . begin . fst) nubbedPipes+                  -- split the list so that all pipes before can have `|`s but pipes after won't++                  pipesBeforeRendered = pipesBefore <&> second \marker -> annotate (markerColor isError marker) (if withUnicode then "│" else "|")+                  -- pre-render pipes which are before because they will be shown++                  lastBeginPosition = snd . begin . fst <$> List.safeLast (List.sortOn (Down . snd . begin . fst) pipesAfter)++                  lineLen = case lastBeginPosition of+                    Nothing -> 0+                    Just col -> col - bc++                  currentPipe =+                    if+                        | withUnicode && hasSuccessor -> "├"+                        | withUnicode -> "╰"+                        | hasSuccessor -> "|"+                        | otherwise -> "`"++                  lineChar = if withUnicode then '─' else '-'+                  pointChar = if withUnicode then "╸" else "-"+               in lineStart pipesBeforeRendered+                    <> annotate (markerColor isError msg) (currentPipe <> pretty (replicate lineLen lineChar) <> pointChar)+                    <+> annotate (markerColor isError msg) (replaceLinesWith (hardline <+> lineStart pipesBeforeRendered <+> "  ") $ pretty $ markerMessage msg)+         in hardline <+> prefix <> showMessages specialPrefix pipes lineLen++-- WARN: uses the internal of the library+--+--       DO NOT use a wildcard here, in case the internal API exposes one more constructor++-- |+replaceLinesWith :: Doc ann -> Doc ann -> Doc ann+replaceLinesWith repl Line = repl+replaceLinesWith _ Fail = Fail+replaceLinesWith _ Empty = Empty+replaceLinesWith _ (Char c) = Char c+replaceLinesWith _ (Text n s) = Text n s+replaceLinesWith repl (FlatAlt f d) = FlatAlt (replaceLinesWith repl f) (replaceLinesWith repl d)+replaceLinesWith repl (Cat c d) = Cat (replaceLinesWith repl c) (replaceLinesWith repl d)+replaceLinesWith repl (Nest n d) = Nest n (replaceLinesWith repl d)+replaceLinesWith repl (Union c d) = Union (replaceLinesWith repl c) (replaceLinesWith repl d)+replaceLinesWith repl (Column f) = Column (replaceLinesWith repl . f)+replaceLinesWith repl (Nesting f) = Nesting (replaceLinesWith repl . f)+replaceLinesWith repl (Annotated ann doc) = Annotated ann (replaceLinesWith repl doc)+replaceLinesWith repl (WithPageWidth f) = WithPageWidth (replaceLinesWith repl . f)++-- | Extracts the color of a marker as a 'Doc' coloring function.+markerColor ::+  -- | Whether the marker is in an error context or not.+  --   This really makes a difference for a 'This' marker.+  Bool ->+  -- | The marker to extract the color from.+  Marker msg ->+  -- | A function used to color a 'Doc'.+  AnsiStyle+markerColor isError (This _) = if isError then color Red else color Yellow+markerColor _ (Where _) = colorDull Blue+markerColor _ (Maybe _) = color Magenta+{-# INLINE markerColor #-}++-- | Retrieves the message held by a marker.+markerMessage :: Marker msg -> msg+markerMessage (This m) = m+markerMessage (Where m) = m+markerMessage (Maybe m) = m+{-# INLINE markerMessage #-}++-- | Pretty prints all hints.+prettyAllHints :: Pretty msg => [msg] -> Int -> Bool -> Doc AnsiStyle+prettyAllHints [] _ _ = mempty+prettyAllHints (h : hs) leftLen withUnicode =+  {-+        A hint is composed of:+        (1)         : Hint: <hint message>+  -}+  let prefix = hardline <+> pipePrefix leftLen withUnicode+   in prefix <+> annotate (color Cyan) (annotate bold "Hint:" <+> replaceLinesWith (prefix <+> "      ") (pretty h))+        <> prettyAllHints hs leftLen withUnicode
+ test/megaparsec/Spec.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-# OPTIONS -Wno-orphans #-}++import Data.Bifunctor (first)+import Data.Text (Text)+import qualified Data.Text as Text (unpack)+import Data.Void (Void)++import Error.Diagnose+import Error.Diagnose.Compat.Megaparsec++import qualified Text.Megaparsec as MP+import qualified Text.Megaparsec.Char as MP+import qualified Text.Megaparsec.Char.Lexer as MP++instance HasHints Void msg where+  hints _ = mempty++main :: IO ()+main = do+  let filename :: FilePath = "<interactive>"+      content1 :: Text = "0000000123456"+      content2 :: Text = "00000a2223266"++  let res1 = first (errorDiagnosticFromBundle "Parse error on input" Nothing) $ MP.runParser @Void (MP.some MP.decimal <* MP.eof) filename content1+      res2 = first (errorDiagnosticFromBundle "Parse error on input" Nothing) $ MP.runParser @Void (MP.some MP.decimal <* MP.eof) filename content2++  case res1 of+    Left diag -> printDiagnostic stdout True True (addFile diag filename (Text.unpack content1) :: Diagnostic String)+    Right res -> print res+  case res2 of+    Left diag -> printDiagnostic stdout True True (addFile diag filename (Text.unpack content2) :: Diagnostic String)+    Right res -> print res
+ test/parsec/Spec.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-# OPTIONS -Wno-orphans #-}++import Data.Bifunctor (first)+import Data.Text (Text)+import qualified Data.Text as Text (unpack)+import Data.Void (Void)++import Error.Diagnose+import Error.Diagnose.Compat.Parsec++import qualified Text.Parsec as P++instance HasHints Void msg where+  hints _ = mempty++main :: IO ()+main = do+  let filename :: FilePath = "<interactive>"+      content1 :: Text = "0000000123456"+      content2 :: Text = "00000a2223266"++  let res1 = first (errorDiagnosticFromParseError "Parse error on input" Nothing) $ P.parse (P.many1 P.digit <* P.eof) filename content1+      res2 = first (errorDiagnosticFromParseError "Parse error on input" Nothing) $ P.parse (P.many1 P.digit <* P.eof) filename content2++  case res1 of+    Left diag -> printDiagnostic stdout True True (addFile diag filename (Text.unpack content1) :: Diagnostic String)+    Right res -> print res+  case res2 of+    Left diag -> printDiagnostic stdout True True (addFile diag filename (Text.unpack content2) :: Diagnostic String)+    Right res -> print res+
+ test/rendering/Spec.hs view
@@ -0,0 +1,312 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++#ifdef USE_AESON+      diagnosticToJson,+#endif++#ifdef USE_AESON+import qualified Data.ByteString.Lazy as BS+#endif+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap+import Error.Diagnose+  ( Marker (..),+    Position (..),+    Report,+    addFile,+    addReport,+    def,+    err,+    printDiagnostic,+    stdout,+    warn,+  )+import System.IO (hPutStrLn)++main :: IO ()+main = do+  let files :: HashMap FilePath String =+        HashMap.fromList+          [ ("test.zc", "let id<a>(x : a) : a := x + 1\nrec fix(f) := f(fix(f))\nlet const<a, b>(x : a, y : b) : a := x"),+            ("somefile.zc", "let id<a>(x : a) : a := x\n  + 1"),+            ("err.nst", "\n\n\n\n    = jmp g\n\n    g: forall(s: Ts, e: Tc).{ %r0: *s64 | s -> e }"),+            ("unsized.nst", "main: forall(a: Ta, s: Ts, e: Tc).{ %r5: forall().{| s -> e } | s -> %r5 }\n    = salloc a\n    ; sfree\n")+          ]++  let reports =+        [ errorNoMarkersNoHints,+          errorSingleMarkerNoHints,+          warningSingleMarkerNoHints,+          errorTwoMarkersSameLineNoOverlapNoHints,+          errorSingleMarkerOutOfBoundsNoHints,+          errorTwoMarkersSameLineOverlapNoHints,+          errorTwoMarkersSameLinePartialOverlapNoHints,+          errorTwoMarkersTwoLinesNoHints,+          realWorldExample,+          errorTwoMarkersSamePositionNoHints,+          errorThreeMarkersWithOverlapNoHints,+          errorWithMultilineErrorNoMarkerNoHints,+          errorSingleMultilineMarkerMessageNoHints,+          errorTwoMarkersSameOriginOverlapNoHints,+          errorNoMarkersSingleHint,+          errorNoMarkersSingleMultilineHint,+          errorNoMarkersTwoHints,+          errorSingleMultilineMarkerNoHints,+          errorTwoMarkersWithMultilineNoHints,+          errorTwoMultilineMarkersNoHints,+          errorSingleMultilineMarkerMultilineMessageNoHints,+          errorTwoMultilineMarkersFirstMultilineMessageNoHints,+          errorThreeMultilineMarkersTwoMultilineMessageNoHints,+          errorOrderSensitive,+          errorMultilineAfterSingleLine,+          errorOnEmptyLine,+          errorMultipleFiles,+          beautifulExample+        ]++  let diag = HashMap.foldlWithKey' addFile (foldr (flip addReport) def reports) files++  hPutStrLn stdout "\n\nWith unicode: ─────────────────────────\n"+  printDiagnostic stdout True True diag+  hPutStrLn stdout "\n\nWithout unicode: ----------------------\n"+  printDiagnostic stdout False True diag+#ifdef USE_AESON+  hPutStrLn stdout "\n\nAs JSON: ------------------------------\n"+  BS.hPutStr stdout (diagnosticToJson diag)+#endif+  hPutStrLn stdout "\n"++errorNoMarkersNoHints :: Report String+errorNoMarkersNoHints =+  err+    "Error with no marker"+    []+    []++errorSingleMarkerNoHints :: Report String+errorSingleMarkerNoHints =+  err+    "Error with one marker in bounds"+    [(Position (1, 25) (1, 30) "test.zc", This "Required here")]+    []++warningSingleMarkerNoHints :: Report String+warningSingleMarkerNoHints =+  warn+    "Warning with one marker in bounds"+    [(Position (1, 25) (1, 30) "test.zc", This "Required here")]+    []++errorTwoMarkersSameLineNoOverlapNoHints :: Report String+errorTwoMarkersSameLineNoOverlapNoHints =+  err+    "Error with two markers in bounds (no overlap) on the same line"+    [ (Position (1, 5) (1, 10) "test.zc", This "First"),+      (Position (1, 15) (1, 22) "test.zc", Where "Second")+    ]+    []++errorSingleMarkerOutOfBoundsNoHints :: Report String+errorSingleMarkerOutOfBoundsNoHints =+  err+    "Error with one marker out of bounds"+    [(Position (10, 5) (10, 15) "test2.zc", This "Out of bounds")]+    []++errorTwoMarkersSameLineOverlapNoHints :: Report String+errorTwoMarkersSameLineOverlapNoHints =+  err+    "Error with two overlapping markers in bounds"+    [ (Position (1, 6) (1, 13) "test.zc", This "First"),+      (Position (1, 10) (1, 15) "test.zc", Where "Second")+    ]+    []++errorTwoMarkersSameLinePartialOverlapNoHints :: Report String+errorTwoMarkersSameLinePartialOverlapNoHints =+  err+    "Error with two partially overlapping markers in bounds"+    [ (Position (1, 5) (1, 25) "test.zc", This "First"),+      (Position (1, 12) (1, 20) "test.zc", Where "Second")+    ]+    []++errorTwoMarkersTwoLinesNoHints :: Report String+errorTwoMarkersTwoLinesNoHints =+  err+    "Error with two markers on two lines in bounds"+    [ (Position (1, 5) (1, 12) "test.zc", This "First"),+      (Position (2, 3) (2, 4) "test.zc", Where "Second")+    ]+    []++realWorldExample :: Report String+realWorldExample =+  err+    "Could not deduce constraint 'Num(a)' from the current context"+    [ (Position (1, 25) (1, 30) "test.zc", This "While applying function '+'"),+      (Position (1, 11) (1, 16) "test.zc", Where "'x' is supposed to have type 'a'"),+      (Position (1, 8) (1, 9) "test.zc", Where "type 'a' is bound here without constraints")+    ]+    ["Adding 'Num(a)' to the list of constraints may solve this problem."]++errorTwoMarkersSamePositionNoHints :: Report String+errorTwoMarkersSamePositionNoHints =+  err+    "Error with two markers on the same exact position in bounds"+    [ (Position (1, 6) (1, 10) "test.zc", This "First"),+      (Position (1, 6) (1, 10) "test.zc", Maybe "Second")+    ]+    []++errorThreeMarkersWithOverlapNoHints :: Report String+errorThreeMarkersWithOverlapNoHints =+  err+    "Error with three markers with overlapping in bounds"+    [ (Position (1, 9) (1, 15) "test.zc", This "First"),+      (Position (1, 9) (1, 18) "test.zc", Maybe "Second"),+      (Position (1, 6) (1, 10) "test.zc", Where "Third")+    ]+    []++errorWithMultilineErrorNoMarkerNoHints :: Report String+errorWithMultilineErrorNoMarkerNoHints =+  err+    "Error with multi\nline message and no markers"+    []+    []++errorSingleMultilineMarkerMessageNoHints :: Report String+errorSingleMultilineMarkerMessageNoHints =+  err+    "Error with single marker with multiline message"+    [(Position (1, 9) (1, 15) "test.zc", This "First\nmultiline")]+    []++errorTwoMarkersSameOriginOverlapNoHints :: Report String+errorTwoMarkersSameOriginOverlapNoHints =+  err+    "Error with two markers with same origin but partial overlap in bounds"+    [ (Position (1, 9) (1, 15) "test.zc", This "First"),+      (Position (1, 9) (1, 20) "test.zc", Maybe "Second")+    ]+    []++errorNoMarkersSingleHint :: Report String+errorNoMarkersSingleHint =+  err+    "Error with no marker and one hint"+    []+    ["First hint"]++errorNoMarkersSingleMultilineHint :: Report String+errorNoMarkersSingleMultilineHint =+  err+    "Error with no marker and one multiline hint"+    []+    ["First multi\nline hint"]++errorNoMarkersTwoHints :: Report String+errorNoMarkersTwoHints =+  err+    "Error with no markers and two hints"+    []+    [ "First hint",+      "Second hint"+    ]++errorSingleMultilineMarkerNoHints :: Report String+errorSingleMultilineMarkerNoHints =+  err+    "Error with single marker spanning across multiple lines"+    [(Position (1, 15) (2, 6) "test.zc", This "First")]+    []++errorTwoMarkersWithMultilineNoHints :: Report String+errorTwoMarkersWithMultilineNoHints =+  err+    "Error with two markers, one single line and one multiline, in bounds"+    [ (Position (1, 9) (1, 13) "test.zc", This "First"),+      (Position (1, 14) (2, 6) "test.zc", Where "Second")+    ]+    []++errorTwoMultilineMarkersNoHints :: Report String+errorTwoMultilineMarkersNoHints =+  err+    "Error with two multiline markers in bounds"+    [ (Position (1, 9) (2, 5) "test.zc", This "First"),+      (Position (2, 1) (3, 10) "test.zc", Where "Second")+    ]+    []++errorSingleMultilineMarkerMultilineMessageNoHints :: Report String+errorSingleMultilineMarkerMultilineMessageNoHints =+  err+    "Error with one multiline marker with a multiline message in bounds"+    [(Position (1, 9) (2, 5) "test.zc", This "Multi\nline message")]+    []++errorTwoMultilineMarkersFirstMultilineMessageNoHints :: Report String+errorTwoMultilineMarkersFirstMultilineMessageNoHints =+  err+    "Error with two multiline markers with one multiline message in bounds"+    [ (Position (1, 9) (2, 5) "test.zc", This "First"),+      (Position (1, 9) (2, 6) "test.zc", Where "Multi\nline message")+    ]+    []++errorThreeMultilineMarkersTwoMultilineMessageNoHints :: Report String+errorThreeMultilineMarkersTwoMultilineMessageNoHints =+  err+    "Error with three multiline markers with two multiline messages in bounds"+    [ (Position (1, 9) (2, 5) "test.zc", This "First"),+      (Position (1, 9) (2, 6) "test.zc", Where "Multi\nline message"),+      (Position (1, 9) (2, 7) "test.zc", Maybe "Multi\nline message #2")+    ]+    []++errorOrderSensitive :: Report String+errorOrderSensitive =+  err+    "Order-sensitive labels with crossing"+    [ (Position (1, 1) (1, 7) "somefile.zc", This "Leftmost label"),+      (Position (1, 9) (1, 16) "somefile.zc", Where "Rightmost label")+    ]+    []++beautifulExample :: Report String+beautifulExample =+  err+    "Could not deduce constraint 'Num(a)' from the current context"+    [ (Position (1, 25) (2, 6) "somefile.zc", This "While applying function '+'"),+      (Position (1, 11) (1, 16) "somefile.zc", Where "'x' is supposed to have type 'a'"),+      (Position (1, 8) (1, 9) "somefile.zc", Where "type 'a' is bound here without constraints")+    ]+    ["Adding 'Num(a)' to the list of constraints may solve this problem."]++errorMultilineAfterSingleLine :: Report String+errorMultilineAfterSingleLine =+  err+    "Multiline after single line"+    [ (Position (1, 17) (1, 18) "unsized.nst", Where "Kind is infered from here"),+      (Position (2, 14) (3, 0) "unsized.nst", This "is an error")+    ]+    []++errorOnEmptyLine :: Report String+errorOnEmptyLine =+  err+    "Error on empty line"+    [(Position (1, 5) (3, 8) "err.nst", This "error on empty line")]+    []++errorMultipleFiles :: Report String+errorMultipleFiles =+  err+    "Error on multiple files"+    [ (Position (1, 5) (1, 7) "test.zc", Where "Function already declared here"),+      (Position (1, 5) (1, 7) "somefile.zc", This "Function `id` is already declared in another module")+    ]+    []