diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 `` 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(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. diff --git a/diagnose.cabal b/diagnose.cabal new file mode 100644 --- /dev/null +++ b/diagnose.cabal @@ -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 diff --git a/src/Data/List/Safe.hs b/src/Data/List/Safe.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Safe.hs @@ -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) diff --git a/src/Error/Diagnose.hs b/src/Error/Diagnose.hs new file mode 100644 --- /dev/null +++ b/src/Error/Diagnose.hs @@ -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(x : a) : a := x + 1 + > • ┬──── + > • ╰╸ Required here + > ─────╯ + + > [error]: Error with one marker in bounds + > +-> test.zc@1:25-1:30 + > | + > 1 | let id(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 = "" + > 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 + > ╭─▶ @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 = "" + > 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 + > ╭─▶ @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@. + +-} diff --git a/src/Error/Diagnose/Compat/Hints.hs b/src/Error/Diagnose/Compat/Hints.hs new file mode 100644 --- /dev/null +++ b/src/Error/Diagnose/Compat/Hints.hs @@ -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 diff --git a/src/Error/Diagnose/Compat/Megaparsec.hs b/src/Error/Diagnose/Compat/Megaparsec.hs new file mode 100644 --- /dev/null +++ b/src/Error/Diagnose/Compat/Megaparsec.hs @@ -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 "<>")] + + 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) diff --git a/src/Error/Diagnose/Compat/Parsec.hs b/src/Error/Diagnose/Compat/Parsec.hs new file mode 100644 --- /dev/null +++ b/src/Error/Diagnose/Compat/Parsec.hs @@ -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 "<>")] + 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) diff --git a/src/Error/Diagnose/Diagnostic.hs b/src/Error/Diagnose/Diagnostic.hs new file mode 100644 --- /dev/null +++ b/src/Error/Diagnose/Diagnostic.hs @@ -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) diff --git a/src/Error/Diagnose/Diagnostic/Internal.hs b/src/Error/Diagnose/Diagnostic/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Error/Diagnose/Diagnostic/Internal.hs @@ -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 diff --git a/src/Error/Diagnose/Position.hs b/src/Error/Diagnose/Position.hs new file mode 100644 --- /dev/null +++ b/src/Error/Diagnose/Position.hs @@ -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) "" + +#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 diff --git a/src/Error/Diagnose/Pretty.hs b/src/Error/Diagnose/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Error/Diagnose/Pretty.hs @@ -0,0 +1,4 @@ +module Error.Diagnose.Pretty (module Export) where + +import qualified Prettyprinter as Export +import qualified Prettyprinter.Render.Terminal as Export diff --git a/src/Error/Diagnose/Report.hs b/src/Error/Diagnose/Report.hs new file mode 100644 --- /dev/null +++ b/src/Error/Diagnose/Report.hs @@ -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) diff --git a/src/Error/Diagnose/Report/Internal.hs b/src/Error/Diagnose/Report/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Error/Diagnose/Report/Internal.hs @@ -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]: + (2) +-> + (3) : + (4) | + : + : + (5) : + : + (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) | + (2) : + (3) : + + 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) "" + 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: + -} + let prefix = hardline <+> pipePrefix leftLen withUnicode + in prefix <+> annotate (color Cyan) (annotate bold "Hint:" <+> replaceLinesWith (prefix <+> " ") (pretty h)) + <> prettyAllHints hs leftLen withUnicode diff --git a/test/megaparsec/Spec.hs b/test/megaparsec/Spec.hs new file mode 100644 --- /dev/null +++ b/test/megaparsec/Spec.hs @@ -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 = "" + 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 diff --git a/test/parsec/Spec.hs b/test/parsec/Spec.hs new file mode 100644 --- /dev/null +++ b/test/parsec/Spec.hs @@ -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 = "" + 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 + diff --git a/test/rendering/Spec.hs b/test/rendering/Spec.hs new file mode 100644 --- /dev/null +++ b/test/rendering/Spec.hs @@ -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(x : a) : a := x + 1\nrec fix(f) := f(fix(f))\nlet const(x : a, y : b) : a := x"), + ("somefile.zc", "let id(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") + ] + []