errata (empty) → 0.1.0.0
raw patch · 9 files changed
+1088/−0 lines, 9 filesdep +basedep +containersdep +errata
Dependencies added: base, containers, errata, text
Files
- CHANGELOG.md +7/−0
- LICENSE +21/−0
- README.md +17/−0
- errata.cabal +65/−0
- example/Main.hs +135/−0
- src/Errata.hs +329/−0
- src/Errata/Internal/Render.hs +318/−0
- src/Errata/Source.hs +41/−0
- src/Errata/Types.hs +155/−0
+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# Changelog++**Errata** uses [PVP Versioning](https://pvp.haskell.org).++## 0.1.0.0++* Initial release.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2020 comp++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,17 @@+# Errata++[](./LICENSE)+[](https://hackage.haskell.org/package/errata)+[](https://github.com/1Computer1/errata/actions?query=workflow%3ACI)++**Errata** is an extremely customizable error pretty printer that can handle many kinds of error formatting. For example, it can handle errors that are all over the source or errors that are connected to each other spanning multiple lines. You can be as simple or as fancy as you like! ++You can also customize the format of the printer in several ways: ++- Custom messages and labels+- Custom character sets for symbols+- Highlighting the source, messages, and symbols++Here is an example of a pretty error message from **Errata**: ++
+ errata.cabal view
@@ -0,0 +1,65 @@+cabal-version: 2.4+name: errata+version: 0.1.0.0+synopsis: Source code error pretty printing+description:+ An extremely customizable error pretty printer that can handle many kinds of error formatting.+ It can handle errors that are connected, disconnected, and those spanning multiple lines.+ .+ You can get started by importing the "Errata" module.+homepage: https://github.com/1Computer1/errata+bug-reports: https://github.com/1Computer1/errata/issues+license: MIT+license-file: LICENSE+author: comp+maintainer: onecomputer00@gmail.com+copyright: (c) 2020 comp+category: Pretty Printer+build-type: Simple+extra-doc-files:+ README.md+ CHANGELOG.md+tested-with:+ GHC == 8.10.1+ , GHC == 8.8.3+ , GHC == 8.6.5++source-repository head+ type: git+ location: https://github.com/1Computer1/errata.git++common common-options+ build-depends:+ base >= 4.12 && < 4.15+ , containers >= 0.6.0.1 && < 0.7+ , text >= 1.2.3.1 && < 1.3+ ghc-options:+ -Wall+ -Wcompat+ -Widentities+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wredundant-constraints+ -Wpartial-fields+ -Wno-unused-do-bind+ default-language: Haskell2010++library+ import: common-options+ hs-source-dirs: src+ exposed-modules:+ Errata+ Errata.Internal.Render+ Errata.Source+ Errata.Types++executable errata-example+ import: common-options+ hs-source-dirs: example+ main-is: Main.hs+ build-depends:+ errata+ ghc-options:+ -threaded+ -rtsopts+ -with-rtsopts=-N
+ example/Main.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import qualified Data.Text as T+import qualified Data.Text.Lazy.IO as TL+import Errata++-------------------------------------------------------------+-- Definitions from the Haddock example for 'prettyErrors' --+-------------------------------------------------------------++data ParseError = ParseError+ { peFile :: FilePath+ , peLine :: Int+ , peCol :: Int+ , peUnexpected :: T.Text+ , peExpected :: [T.Text]+ }++toErrata :: ParseError -> Errata+toErrata (ParseError fp l c unexpected expected) =+ errataSimple+ (Just "error: invalid syntax")+ (blockSimple basicStyle fp l (c, c + T.length unexpected) Nothing+ (Just $ "unexpected " <> unexpected <> "\nexpected " <> T.intercalate ", " expected))+ Nothing++printErrors :: T.Text -> [ParseError] -> IO ()+printErrors source es = TL.putStrLn $ prettyErrors source (toErrata <$> es)++--------------+-- Examples --+--------------++-- An ad-hoc errata.+adhoc :: [Pointer] -> Errata+adhoc ps = errataSimple (Just "an error") (Block fancyRedStyle ("here", 1, 1) ps (Just "pbody")) Nothing++main :: IO ()+main = do+ putStrLn "Simple single pointer:"+ putStrLn ""+ TL.putStrLn $ prettyErrors @String+ "abcdefghijk\nlmnopqrstuv\nwxyzfoobar"+ [ adhoc [Pointer 1 2 4 False (Just "x")]+ ]+ putStrLn ""++ putStrLn "Nothing is connected, some inner labels:"+ putStrLn ""+ TL.putStrLn $ prettyErrors @String+ "abcdefghijk\nlmnopqrstuv\nwxyzfoobar"+ [ adhoc+ [ Pointer 1 2 4 False (Just "x")+ , Pointer 1 6 8 False (Just "y")+ , Pointer 1 10 12 False (Just "z")+ , Pointer 2 5 8 False (Just "w")+ ]+ ]+ putStrLn ""++ putStrLn "Everything is connected."+ putStrLn ""+ TL.putStrLn $ prettyErrors @String+ "abcdefghijk\nlmnopqrstuv\nwxyzfoobar"+ [ adhoc+ [ Pointer 1 2 4 True (Just "x")+ , Pointer 1 6 8 True (Just "y")+ , Pointer 1 10 12 True (Just "z")+ , Pointer 2 5 8 True (Just "w")+ ]+ ]+ putStrLn ""++ putStrLn "Only one line is connected, and one of them is skewered through:"+ putStrLn ""+ TL.putStrLn $ prettyErrors @String+ "abcdefghijk\nlmnopqrstuv\nwxyzfoobar"+ [ adhoc+ [ Pointer 1 2 4 True (Just "x")+ , Pointer 1 6 8 False (Just "y")+ , Pointer 1 10 12 True (Just "z")+ , Pointer 2 5 8 False (Just "w")+ ]+ ]+ putStrLn ""++ putStrLn "Everything is connected except for 2. One of them does not have a label:"+ putStrLn ""+ TL.putStrLn $ prettyErrors @String+ "abcdefghijk\nlmnopqrstuv\nwxyzfoobar"+ [ adhoc+ [ Pointer 1 2 4 True (Just "x")+ , Pointer 1 6 8 True Nothing+ , Pointer 1 10 12 False (Just "z")+ , Pointer 2 5 8 False (Just "w")+ , Pointer 3 1 3 True (Just "v")+ ]+ ]+ putStrLn ""++ putStrLn "Example from the Haddock example for `prettyErrors`:"+ putStrLn ""+ printErrors+ "{\n \"bad\": [1, 2,]\n }"+ (pure (ParseError "./comma.json" 2 18 "]" ["null", "true", "false", "\"", "-", "digit", "[", "{"]))+ putStrLn ""++ putStrLn "Example from the readme:"+ putStrLn ""+ TL.putStrLn $ prettyErrors @String+ "foo = if 1 > 2\n then 100\n else \"uh oh\""+ [ Errata+ (Just "\x1b[31merror[E001]: mismatching types in `if` expression\x1b[0m")+ (Block+ fancyRedStyle+ ("file.hs", 3, 10)+ [ Pointer 2 10 13 False (Just "\x1b[31mthis has type `Int`\x1b[0m")+ , Pointer 3 10 17 False (Just "\x1b[31mbut this has type `String`\x1b[0m")+ ]+ Nothing)+ [ Block+ fancyYellowStyle+ ("file.hs", 1, 7)+ [ Pointer 1 7 9 True Nothing+ , Pointer 2 5 9 True Nothing+ , Pointer 3 5 9 True (Just "\x1b[33min this `if` expression\x1b[0m")+ ]+ Nothing+ ]+ (Just "\x1b[33mnote: use --explain E001 to learn more\x1b[0m")+ ]+ putStrLn ""
+ src/Errata.hs view
@@ -0,0 +1,329 @@+{-# LANGUAGE OverloadedStrings #-}++{-|+Module : Errata+Copyright : (c) 2020 comp+License : MIT+Maintainer : onecomputer00@gmail.com+Stability : stable+Portability : portable++This module is for creating pretty error messages. We assume very little about the format you want to use, so much of+this module is to allow you to customize your error messages.++To get started, see the documentation for 'prettyErrors'. When using this module, we recommend you turn on the+@OverloadedStrings@ extension and import "Data.Text" at the very least due to the use of 'Data.Text.Text' (strict).++The overall workflow to use the printer is to convert your error type to 'Errata', which entails converting your errors+to 'Errata' by filling in messages and 'Block's. You can create 'Errata' and 'Block' from their constructors, or use+the convenience functions for common usecases, like 'errataSimple' and 'blockSimple'.+-}+module Errata+ ( -- * Error format data+ Errata(..)+ , errataSimple+ -- * Blocks and pointers+ , Block(..)+ , blockSimple+ , blockSimple'+ , blockConnected+ , blockConnected'+ , blockMerged+ , blockMerged'+ , Pointer(..)+ -- * Styling options+ , Style(..)+ , basicStyle+ , fancyStyle+ , fancyRedStyle+ , fancyYellowStyle+ -- * Pretty printer+ , prettyErrors+ , prettyErrorsNE+ ) where++import qualified Data.List.NonEmpty as N+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TB+import Errata.Internal.Render+import Errata.Source+import Errata.Types++-- | Creates a simple error that has a single block, with an optional header or body.+errataSimple+ :: Maybe T.Text -- ^ The header.+ -> Block -- ^ The block.+ -> Maybe T.Text -- ^ The body.+ -> Errata+errataSimple header block body = Errata+ { errataHeader = header+ , errataBlock = block+ , errataBlocks = []+ , errataBody = body+ }++-- | A simple block that points to only one line and optionally has a label or a body message.+blockSimple+ :: Style -- ^ The style of the pointer.+ -> FilePath -- ^ The filepath.+ -> Int -- ^ The line number starting at 1.+ -> (Int, Int) -- ^ The column span. These start at 1.+ -> Maybe T.Text -- ^ The label.+ -> Maybe T.Text -- ^ The body message.+ -> Block+blockSimple style fp l (cs, ce) lbl m = Block+ { blockStyle = style+ , blockLocation = (fp, l, cs)+ , blockPointers = [Pointer l cs ce False lbl]+ , blockBody = m+ }++-- | A variant of 'blockSimple' that only points at one column.+blockSimple'+ :: Style -- ^ The style of the pointer.+ -> FilePath -- ^ The filepath.+ -> Int -- ^ The line number starting at 1.+ -> Int -- ^ The column number starting at 1.+ -> Maybe T.Text -- ^ The label.+ -> Maybe T.Text -- ^ The body message.+ -> Block+blockSimple' style fp l c lbl m = Block+ { blockStyle = style+ , blockLocation = (fp, l, c)+ , blockPointers = [Pointer l c (c + 1) False lbl]+ , blockBody = m+ }++-- | A block that points to two parts of the source that are visually connected together.+blockConnected+ :: Style -- ^ The style of the pointer.+ -> FilePath -- ^ The filepath.+ -> (Int, Int, Int, Maybe T.Text) -- ^ The first line number and column span, starting at 1, as well as a label.+ -> (Int, Int, Int, Maybe T.Text) -- ^ The second line number and column span, starting at 1, as well as a label.+ -> Maybe T.Text -- ^ The body message.+ -> Block+blockConnected style fp (l1, cs1, ce1, lbl1) (l2, cs2, ce2, lbl2) m = Block+ { blockStyle = style+ , blockLocation = (fp, l1, cs1)+ , blockPointers = [Pointer l1 cs1 ce1 True lbl1, Pointer l2 cs2 ce2 True lbl2]+ , blockBody = m+ }++-- | A variant of 'blockConnected' where the pointers point at only one column.+blockConnected'+ :: Style -- ^ The style of the pointer.+ -> FilePath -- ^ The filepath.+ -> (Int, Int, Maybe T.Text) -- ^ The first line number and column, starting at 1, as well as a label.+ -> (Int, Int, Maybe T.Text) -- ^ The second line number and column, starting at 1, as well as a label.+ -> Maybe T.Text -- ^ The body message.+ -> Block+blockConnected' style fp (l1, c1, lbl1) (l2, c2, lbl2) m = Block+ { blockStyle = style+ , blockLocation = (fp, l1, c1)+ , blockPointers = [Pointer l1 c1 (c1 + 1) True lbl1, Pointer l2 c2 (c2 + 1) True lbl2]+ , blockBody = m+ }++{-|+A block that points to two parts of the source that are visually connected together.++If the two parts of the source happen to be on the same line, the pointers are merged into one.+-}+blockMerged+ :: Style -- ^ The style of the pointer.+ -> FilePath -- ^ The filepath.+ -> (Int, Int, Int, Maybe T.Text) -- ^ The first line number and column span, starting at 1, as well as a label.+ -> (Int, Int, Int, Maybe T.Text) -- ^ The second line number and column span, starting at 1, as well as a label.+ -> Maybe T.Text -- ^ The label for when the two pointers are merged into one.+ -> Maybe T.Text -- ^ The body message.+ -> Block+blockMerged style fp (l1, cs1, ce1, lbl1) (l2, cs2, ce2, lbl2) lbl m = Block+ { blockStyle = style+ , blockLocation = (fp, l1, cs1)+ , blockPointers = if l1 == l2+ then [Pointer l1 cs1 ce2 False lbl]+ else [Pointer l1 cs1 ce1 True lbl1, Pointer l2 cs2 ce2 True lbl2]+ , blockBody = m+ }++-- | A variant of 'blockMerged' where the pointers point at only one column.+blockMerged'+ :: Style -- ^ The style of the pointer.+ -> FilePath -- ^ The filepath.+ -> (Int, Int, Maybe T.Text) -- ^ The first line number and column, starting at 1, as well as a label.+ -> (Int, Int, Maybe T.Text) -- ^ The second line number and column, starting at 1, as well as a label.+ -> Maybe T.Text -- ^ The label for when the two pointers are merged into one.+ -> Maybe T.Text -- ^ The body message.+ -> Block+blockMerged' style fp (l1, c1, lbl1) (l2, c2, lbl2) lbl m = Block+ { blockStyle = style+ , blockLocation = (fp, l1, c1)+ , blockPointers = if l1 == l2+ then [Pointer l1 c1 (c2 + 1) False lbl]+ else [Pointer l1 c1 (c1 + 1) True lbl1, Pointer l2 c2 (c2 + 1) True lbl2]+ , blockBody = m+ }++{-|+A basic style using only ASCII characters.++Errors should look like so:++> error header message+> --> file.ext:1:16+> |+> 1 | line 1 foo bar do+> | ________________^^ start label+> 2 | | line 2+> | | ^ unconnected label+> 3 | | line 3+> . | |______^ middle label+> 6 | | line 6+> 7 | | line 7 baz end+> | |______^_____^^^ end label+> | |+> | | inner label+> block body message+> error body message+-}+basicStyle :: Style+basicStyle = Style+ { styleLocation = \(fp, l, c) -> T.concat ["--> ", T.pack fp, ":", T.pack $ show l, ":", T.pack $ show c]+ , styleNumber = T.pack . show+ , styleLine = const id+ , styleEllipsis = "."+ , styleLinePrefix = "|"+ , styleUnderline = "^"+ , styleVertical = "|"+ , styleHorizontal = "_"+ , styleDownRight = " "+ , styleUpRight = "|"+ , styleUpDownRight = "|"+ }++{-|+A fancy style using Unicode characters.++Errors should look like so:++> error header message+> → file.ext:1:16+> │+> 1 │ line 1 foo bar do+> │ ┌────────────────^^ start label+> 2 │ │ line 2+> │ │ ^ unconnected label+> 3 │ │ line 3+> . │ ├──────^ middle label+> 6 │ │ line 6+> 7 │ │ line 7 baz end+> │ └──────^─────^^^ end label+> │ │+> │ └ inner label+> block body message+> error body message+-}+fancyStyle :: Style+fancyStyle = Style+ { styleLocation = \(fp, l, c) -> T.concat+ [ "→ ", T.pack fp, ":", T.pack $ show l, ":", T.pack $ show c+ ]+ , styleNumber = T.pack . show+ , styleLine = const id+ , styleEllipsis = "."+ , styleLinePrefix = "│"+ , styleUnderline = "^"+ , styleHorizontal = "─"+ , styleVertical = "│"+ , styleDownRight = "┌"+ , styleUpDownRight = "├"+ , styleUpRight = "└"+ }++-- | A fancy style using Unicode characters and ANSI colors, similar to 'fancyStyle'. Most things are colored red.+fancyRedStyle :: Style+fancyRedStyle = Style+ { styleLocation = \(fp, l, c) -> T.concat+ [ "\x1b[34m→\x1b[0m ", T.pack fp, ":", T.pack $ show l, ":", T.pack $ show c+ ]+ , styleNumber = T.pack . show+ , styleLine = highlight "\x1b[31m" "\x1b[0m"+ , styleEllipsis = "."+ , styleLinePrefix = "\x1b[34m│\x1b[0m"+ , styleUnderline = "\x1b[31m^\x1b[0m"+ , styleHorizontal = "\x1b[31m─\x1b[0m"+ , styleVertical = "\x1b[31m│\x1b[0m"+ , styleDownRight = "\x1b[31m┌\x1b[0m"+ , styleUpDownRight = "\x1b[31m├\x1b[0m"+ , styleUpRight = "\x1b[31m└\x1b[0m"+ }++-- | A fancy style using Unicode characters and ANSI colors, similar to 'fancyStyle'. Most things are colored yellow.+fancyYellowStyle :: Style+fancyYellowStyle = Style+ { styleLocation = \(fp, l, c) -> T.concat+ [ "\x1b[34m→\x1b[0m ", T.pack fp, ":", T.pack $ show l, ":", T.pack $ show c+ ]+ , styleNumber = T.pack . show+ , styleLine = highlight "\x1b[33m" "\x1b[0m"+ , styleEllipsis = "."+ , styleLinePrefix = "\x1b[34m│\x1b[0m"+ , styleUnderline = "\x1b[33m^\x1b[0m"+ , styleHorizontal = "\x1b[33m─\x1b[0m"+ , styleVertical = "\x1b[33m│\x1b[0m"+ , styleDownRight = "\x1b[33m┌\x1b[0m"+ , styleUpRight = "\x1b[33m└\x1b[0m"+ , styleUpDownRight = "\x1b[33m├\x1b[0m"+ }++{-|+Pretty prints errors. The original source is required. Returns 'Data.Text.Lazy.Text' (lazy). If the list is empty,+an empty string is returned.++Suppose we had an error of this type:++> data ParseError = ParseError+> { peFile :: FilePath+> , peLine :: Int+> , peCol :: Int+> , peUnexpected :: T.Text+> , peExpected :: [T.Text]+> }++Then we can create a simple pretty printer like so:++> import qualified Data.List.NonEmpty as N+> import qualified Data.Text as T+> import qualified Data.Text.Lazy.IO as TL+> import Errata+>+> toErrata :: ParseError -> Errata+> toErrata (ParseError fp l c unexpected expected) =+> errataSimple+> (Just "error: invalid syntax")+> (blockSimple basicStyle fp l (c, c + T.length unexpected) Nothing+> (Just $ "unexpected " <> unexpected <> "\nexpected " <> T.intercalate ", " expected))+> Nothing+>+> printErrors :: T.Text -> [ParseError] -> IO ()+> printErrors source es = TL.putStrLn $ prettyErrors source (toErrata <$> es)++Note that in the above example, we have @OverloadedStrings@ enabled to reduce uses of 'Data.Text.pack'.++An example error message from this might be:++> error: invalid syntax+> --> ./comma.json:2:18+> |+> 2 | "bad": [1, 2,]+> | ^+> unexpected ]+> expected null, true, false, ", -, digit, [, {+-}+prettyErrors :: Source source => source -> [Errata] -> TL.Text+prettyErrors source errs = TB.toLazyText $ renderErrors source errs++-- | A variant of 'prettyErrors' for non-empty lists. You can ensure the output is never an empty string.+prettyErrorsNE :: Source source => source -> N.NonEmpty Errata -> TL.Text+prettyErrorsNE source errs = prettyErrors source (N.toList errs)
+ src/Errata/Internal/Render.hs view
@@ -0,0 +1,318 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{-|+Module : Errata.Internal.Render+Copyright : (c) 2020 comp+License : MIT+Maintainer : onecomputer00@gmail.com+Stability : stable+Portability : portable++Functions for rendering the errors. You should not need to import this, as these functions are lower-level.++This module is internal, and may break across non-breaking versions.+-}+module Errata.Internal.Render+ ( renderErrors+ , renderErrata+ , renderBlock+ , renderSourceLines+ ) where++import Data.List+import qualified Data.List.NonEmpty as N+import qualified Data.Sequence as S+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.String (IsString)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as TB+import Errata.Source+import Errata.Types++-- | Renders errors.+renderErrors :: Source source => source -> [Errata] -> TB.Builder+renderErrors source errs = unsplit "\n\n" prettified+ where+ sortedErrata = sortOn (\(Errata {..}) -> blockLocation errataBlock) $ errs++ -- We may arbitrarily index the source lines a lot, so a Seq is appropriate.+ -- If push comes to shove, this could be replaced with an 'Array' or a 'Vec'.+ slines = S.fromList (sourceToLines source)+ prettified = map (renderErrata slines) sortedErrata++-- | A single pretty error from metadata and source lines.+renderErrata :: Source source => S.Seq source -> Errata -> TB.Builder+renderErrata slines (Errata {..}) = errorMessage+ where+ errorMessage = mconcat+ [ TB.fromText $ maybe "" (<> "\n") errataHeader+ , unsplit "\n\n" (map (renderBlock slines) (errataBlock : errataBlocks))+ , TB.fromText $ maybe "" ("\n\n" <>) errataBody+ ]++-- | A single pretty block from block data and source lines.+renderBlock :: Source source => S.Seq source -> Block -> TB.Builder+renderBlock slines block@(Block {..}) = blockMessage+ where+ blockMessage = mconcat+ [ TB.fromText $ styleLocation blockStyle blockLocation+ , maybe "" ("\n" <>) (renderSourceLines slines block <$> N.nonEmpty blockPointers)+ , TB.fromText $ maybe "" ("\n" <>) blockBody+ ]++-- | The source lines for a block.+renderSourceLines+ :: Source source+ => S.Seq source+ -> Block+ -> N.NonEmpty Pointer+ -> TB.Builder+renderSourceLines slines (Block {..}) lspans = unsplit "\n" sourceLines+ where+ Style {..} = blockStyle++ -- Min and max line numbers, as well padding size before the line prefix.+ minLine = fst (M.findMin pointersGrouped)+ maxLine = fst (M.findMax pointersGrouped)+ padding = length (show maxLine)++ -- Shows a line in accordance to the style.+ -- We might get a line that's out-of-bounds, usually the EOF line, so we can default to empty.+ showLine :: [(Int, Int)] -> Int -> TB.Builder+ showLine hs n = TB.fromText . maybe "" id . fmap (styleLine hs . sourceToText) $ S.lookup (n - 1) slines++ -- Generic prefix without line number.+ prefix = mconcat+ [ replicateB padding " ", " ", TB.fromText styleLinePrefix, " "+ ]++ -- Prefix for omitting lines when spanning many lines.+ omitPrefix = mconcat+ [ TB.fromText styleEllipsis, replicateB (padding - 1) " ", " ", TB.fromText styleLinePrefix, " "+ ]++ -- Prefix with a line number.+ linePrefix :: Int -> TB.Builder+ linePrefix n = mconcat+ [ TB.fromText (styleNumber n), replicateB (padding - length (show n)) " ", " "+ , TB.fromText styleLinePrefix, " "+ ]++ -- The pointers grouped by line.+ pointersGrouped = M.fromListWith (<>) $ map (\x -> (pointerLine x, pure x)) (N.toList lspans)++ -- The resulting source lines.+ -- Extra prefix for padding.+ sourceLines = mconcat [replicateB padding " ", " ", TB.fromText styleLinePrefix]+ : makeSourceLines 0 [minLine .. maxLine]++ -- Whether there will be a multiline span.+ hasConnMulti = M.size (M.filter (any pointerConnect) pointersGrouped) > 1++ -- Whether line /n/ has a connection to somewhere else (including the same line).+ hasConn :: Int -> Bool+ hasConn n = maybe False (any pointerConnect) $ M.lookup n pointersGrouped++ -- Whether line /n/ has a connection to a line before or after it (but not including).+ connAround :: Int -> (Bool, Bool)+ connAround n =+ let (a, b) = M.split n pointersGrouped+ in ((any . any) pointerConnect a, (any . any) pointerConnect b)++ -- Makes the source lines.+ -- We have an @extra@ parameter to keep track of extra lines when spanning multiple lines.+ makeSourceLines :: Int -> [Int] -> [TB.Builder]++ -- No lines left.+ makeSourceLines _ [] = []++ -- The next line is a line we have to decorate with pointers.+ makeSourceLines _ (n:ns)+ | Just p <- M.lookup n pointersGrouped = makeDecoratedLines p <> makeSourceLines 0 ns++ -- The next line is an extra line, within a limit (currently 2, may be configurable later).+ makeSourceLines extra (n:ns)+ | extra < 2 =+ let mid = if+ | snd (connAround n) -> TB.fromText styleVertical <> " "+ | hasConnMulti -> " "+ | otherwise -> ""+ in (linePrefix n <> mid <> showLine [] n) : makeSourceLines (extra + 1) ns++ -- We reached the extra line limit, so now there's some logic to figure out what's next.+ makeSourceLines _ ns =+ let (es, ns') = break (`M.member` pointersGrouped) ns+ in case (es, ns') of+ -- There were no lines left to decorate anyways.+ (_, []) -> []++ -- There are lines left to decorate, and it came right after.+ ([], _) -> makeSourceLines 0 ns'++ -- There is a single extra line, so we can use that as the before-line.+ -- No need for omission, because it came right before.+ ([n], _) ->+ let mid = if+ | snd (connAround n) -> TB.fromText styleVertical <> " "+ | hasConnMulti -> " "+ | otherwise -> ""+ in (linePrefix n <> mid <> showLine [] n) : makeSourceLines 0 ns'++ -- There are more than one line in between, so we omit all but the last.+ -- We use the last one as the before-line.+ (_, _) ->+ let n = last es+ mid = if+ | snd (connAround n) -> TB.fromText styleVertical <> " "+ | hasConnMulti -> " "+ | otherwise -> ""+ in (omitPrefix <> mid) : (linePrefix n <> mid <> showLine [] n) : makeSourceLines 0 ns'++ -- Decorate a line that has pointers.+ -- The pointers we get are assumed to be all on the same line.+ makeDecoratedLines :: N.NonEmpty Pointer -> [TB.Builder]+ makeDecoratedLines pointers = (linePrefix line <> TB.fromText lineConnector <> sline) : decorationLines+ where+ lineConnector = if+ | hasConnBefore && hasConnUnder -> styleVertical <> " "+ | hasConnMulti -> " "+ | otherwise -> ""++ -- Shortcuts to where this line connects to.+ hasConnHere = hasConn line+ (hasConnBefore, hasConnAfter) = connAround line+ hasConnAround = hasConnBefore || hasConnAfter+ hasConnOver = hasConnHere || hasConnBefore+ hasConnUnder = hasConnHere || hasConnAfter++ -- The sorted pointers by column.+ -- There's a reverse for when we create decorations.+ pointersSorted = N.fromList . sortOn pointerColumns $ N.toList pointers+ pointersSorted' = N.reverse pointersSorted++ -- The line we're on.+ line = pointerLine $ N.head pointers+ sline = showLine (map pointerColumns (N.toList pointersSorted)) line++ -- The resulting decoration lines.+ decorationLines = if+ -- There's only one pointer, so no need for more than just an underline and label.+ | N.length pointersSorted' == 1 -> [underline pointersSorted']++ -- There's no labels at all, so we just need the underline.+ | all (isNothing . pointerLabel) (N.tail pointersSorted') -> [underline pointersSorted']++ -- Otherwise, we have three steps to do:+ -- The underline directly underneath.+ -- An extra connector for the labels other than the rightmost one.+ -- The remaining connectors and the labels.+ | otherwise ->+ let hasLabels = filter (isJust . pointerLabel) $ N.tail pointersSorted'+ in underline pointersSorted'+ : connectors hasLabels+ : parar (\a (rest, xs) -> connectorAndLabel rest a : xs) [] hasLabels++ -- Create an underline directly under the source.+ underline :: N.NonEmpty Pointer -> TB.Builder+ underline ps =+ let (decor, _) = foldDecorations+ (\n isFirst rest -> if+ | isFirst && any pointerConnect rest && hasConnAround -> replicateB n styleHorizontal+ | isFirst -> replicateB n " "+ | any pointerConnect rest -> replicateB n styleHorizontal+ | otherwise -> replicateB n " "+ )+ ""+ (\n -> replicateB n styleUnderline)+ (N.toList ps)+ lbl = maybe "" (" " <>) . pointerLabel $ N.head ps+ mid = if+ | hasConnHere && hasConnBefore && hasConnAfter -> styleUpDownRight <> styleHorizontal+ | hasConnHere && hasConnBefore -> styleUpRight <> styleHorizontal+ | hasConnHere && hasConnAfter -> styleDownRight <> styleHorizontal+ | hasConnBefore && hasConnAfter -> styleVertical <> " "+ | hasConnMulti -> " "+ | otherwise -> ""+ in prefix <> TB.fromText mid <> decor <> TB.fromText lbl++ -- Create connectors underneath.+ -- It's assumed all these pointers have labels.+ connectors :: [Pointer] -> TB.Builder+ connectors ps =+ let (decor, _) = foldDecorations+ (\n _ _ -> replicateB n " ")+ (TB.fromText styleVertical)+ (\n -> replicateB (n - 1) " ")+ ps+ mid = if+ | hasConnOver && hasConnAfter -> styleVertical <> " "+ | hasConnMulti -> " "+ | otherwise -> ""+ in prefix <> TB.fromText mid <> decor++ -- Create connectors and labels underneath.+ -- It's assumed all these pointers have labels.+ -- The single pointer passed in is the label to make at the end of the decorations.+ connectorAndLabel :: [Pointer] -> Pointer -> TB.Builder+ connectorAndLabel ps p =+ let (decor, finalCol) = foldDecorations+ (\n _ _ -> replicateB n " ")+ (TB.fromText styleVertical)+ (\n -> replicateB (n - 1) " ")+ ps+ lbl = maybe ""+ (\x -> mconcat+ [ replicateB (pointerColStart p - finalCol) " "+ , TB.fromText styleUpRight+ , " "+ , TB.fromText x+ ]+ )+ (pointerLabel p)+ mid = if+ | hasConnOver && hasConnAfter -> styleVertical <> " "+ | hasConnMulti -> " "+ | otherwise -> ""+ in prefix <> TB.fromText mid <> decor <> lbl++-- | Makes a line of decorations below the source.+foldDecorations+ :: (Int -> Bool -> [Pointer] -> TB.Builder) -- ^ Catch up from the previous pointer to this pointer.+ -> TB.Builder -- ^ Something in the middle.+ -> (Int -> TB.Builder) -- ^ Reach the next pointer.+ -> [Pointer]+ -> (TB.Builder, Int)+foldDecorations catchUp something reachAfter ps =+ let (decor, finalCol, _, _) = foldr+ (\(Pointer {..}) (xs, c, rest, isFirst) ->+ ( mconcat+ [ xs+ , catchUp (pointerColStart - c) isFirst rest+ , something+ , reachAfter (pointerColEnd - pointerColStart)+ ]+ , pointerColEnd+ , tail rest+ , False+ )+ )+ ("", 1, reverse ps, True)+ ps+ in (decor, finalCol)++-- | Paramorphism on lists (lazily, from the right).+parar :: (a -> ([a], b) -> b) -> b -> [a] -> b+parar _ b [] = b+parar f b (a:as) = f a (as, parar f b as)++-- | Puts text between each item.+unsplit :: (Semigroup a, IsString a) => a -> [a] -> a+unsplit _ [] = ""+unsplit a (x:xs) = foldl' (\acc y -> acc <> a <> y) x xs++-- | Replicates text into a builder.+replicateB :: Int -> T.Text -> TB.Builder+replicateB n = TB.fromText . T.replicate n
+ src/Errata/Source.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE FlexibleInstances #-}+{-|+Module : Errata.Source+Copyright : (c) 2020 comp+License : MIT+Maintainer : onecomputer00@gmail.com+Stability : stable+Portability : portable++A class for source text types. You should not need to use this, except to add new source types.+-}+module Errata.Source+ ( Source(..)+ ) where++import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++{-|+A class for manipulating and converting source text.++For @ByteString@ source types, you should convert it to one of the built-in instances with your encoding of choice.+-}+class Source s where+ -- | Splits the source into lines.+ sourceToLines :: s -> [s]++ -- | Converts the source text to 'Data.Text.Text' (strict). The given source text is a single line of the source.+ sourceToText :: s -> T.Text++instance Source String where+ sourceToLines = lines+ sourceToText = T.pack++instance Source T.Text where+ sourceToLines = T.lines+ sourceToText = id++instance Source TL.Text where+ sourceToLines = TL.lines+ sourceToText = TL.toStrict
+ src/Errata/Types.hs view
@@ -0,0 +1,155 @@+{-|+Module : Errata.Types+Copyright : (c) 2020 comp+License : MIT+Maintainer : onecomputer00@gmail.com+Stability : stable+Portability : portable++Type definitions. Most of these are re-exported in "Errata", so you should not need to import this module, unless you+need some of the helper functions for making new functionality on top of Errata.+-}+module Errata.Types+ ( -- * Error format data+ Errata(..)+ -- * Blocks and pointers+ , Block(..)+ , Pointer(..)+ , pointerColumns+ -- * Styling options+ , Style(..)+ , highlight+ ) where++import qualified Data.Text as T++-- | A collection of information for pretty printing an error.+data Errata = Errata+ { errataHeader :: Maybe T.Text -- ^ The message that appears above all the blocks.+ , errataBlock :: Block -- ^ The main error block, which will be used for sorting errors.+ , errataBlocks :: [Block] -- ^ Extra blocks in the source code to display. Blocks themselves are not sorted.+ , errataBody :: Maybe T.Text -- ^ The message that appears below all the blocks.+ }++{-|+Information about a block in the source code, such as pointers and messages.++Each block has a style associated with it.+-}+data Block = Block+ { -- | The style of the block.+ blockStyle :: Style++ {-|+ The filepath, line, and column of the block. These start at 1.++ This is used for sorting errors, as well as to create the text that details the location.+ -}+ , blockLocation :: (FilePath, Int, Int)++ {-|+ The block's pointers. These are used to "point out" parts of the source code in this block.++ The locations of each of these pointers must be non-overlapping. If the pointers are touching at a boundary+ however, that is allowed.+ -}+ , blockPointers :: [Pointer]++ -- | The message for the block. This will appear below the source lines.+ , blockBody :: Maybe T.Text+ }++{-|+A pointer is the span of the source code at a line, from one column to another. Each of the positions start at 1.++A pointer may also have a label that will display inline.++A pointer may also be connected to all the other pointers within the same block.+-}+data Pointer = Pointer+ { pointerLine :: Int -- ^ The line of the pointer.+ , pointerColStart :: Int -- ^ The starting column of the pointer.+ , pointerColEnd :: Int -- ^ The ending column of the pointer.+ , pointerConnect :: Bool -- ^ Whether this pointer connects with other pointers.+ , pointerLabel :: Maybe T.Text -- ^ An optional label for the pointer.+ }++-- | Gets the column span for a 'Pointer'.+pointerColumns :: Pointer -> (Int, Int)+pointerColumns p = (pointerColStart p, pointerColEnd p)++-- | Stylization options for a block, e.g. characters to use.+data Style = Style+ { -- | Shows the location of a block at a file, line, and column.+ styleLocation :: (FilePath, Int, Int) -> T.Text++ -- | Shows the line number /n/ for a source line. The result should visually be the same length as just @show n@.+ , styleNumber :: Int -> T.Text++ {-|+ Stylize a source line.++ Column pointers of the text that are being underlined are given for highlighting purposes. The result of this+ should visually take up the same space as the original line.+ -}+ , styleLine :: [(Int, Int)] -> T.Text -> T.Text++ {-|+ The text to use as an ellipsis in the position of line numbers for when lines are omitted. This should visually+ be one character.+ -}+ , styleEllipsis :: T.Text++ -- | The prefix before the source lines.+ , styleLinePrefix :: T.Text++ {-|+ The text to underline a character in a pointer. This should visually be one character.+ -}+ , styleUnderline :: T.Text++ {-|+ The text to use as a vertical bar when connecting pointers. This should visually be one character.+ -}+ , styleVertical :: T.Text++ {-|+ The text to use as a horizontal bar when connecting pointers. This should visually be one character.+ -}+ , styleHorizontal :: T.Text++ {-|+ The text to use as a connector downwards and rightwards when connecting pointers. This should visually+ be one character.+ -}+ , styleDownRight :: T.Text++ {-|+ The text to use as a connector upwards and rightwards when connecting pointers. This should visually+ be one character.+ -}+ , styleUpRight :: T.Text++ {-|+ The text to use as a connector upwards, downwards, and rightwards when connecting pointers. This should visually+ be one character.+ -}+ , styleUpDownRight :: T.Text+ }++-- | Adds highlighting to spans of text by enclosing it with some text e.g ANSI escape codes.+highlight+ :: T.Text -- ^ Text to add before.+ -> T.Text -- ^ Text to add after.+ -> [(Int, Int)] -- ^ Indices to enclose. These are column spans, starting at 1. They must not overlap.+ -> T.Text -- ^ Text to highlight.+ -> T.Text+highlight open close = go False . concatMap (\(a, b) -> [a, b])+ where+ go _ [] xs = xs+ go False (i:is) xs =+ let (a, ys) = T.splitAt (i - 1) xs+ in a <> open <> go True (map (\x -> x - i + 1) is) ys+ go True (i:is) xs =+ let (a, ys) = T.splitAt (i - 1) xs+ in a <> close <> go False (map (\x -> x - i + 1) is) ys