diagnose 2.1.1 → 2.2.0

raw patch · 5 files changed

+106/−55 lines, 5 filesdep +arraydep +dlistPVP ok

version bump matches the API change (PVP)

Dependencies added: array, dlist

API changes (from Hackage documentation)

Files

• diagnose.cabal +14/−6
• src/Error/Diagnose/Compat/Parsec.hs +6/−5
• src/Error/Diagnose/Diagnostic/Internal.hs +15/−9
• src/Error/Diagnose/Report/Internal.hs +64/−35
• test/parsec/Spec.hs +7/−0

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.6.+-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack  name:           diagnose-version:        2.1.1+version:        2.2.0 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.@@ -65,8 +65,10 @@       BlockArguments   ghc-options: -Wall -Wextra   build-depends:-      base >=4.7 && <5+      array ==0.5.*+    , base >=4.7 && <5     , data-default >=0.7 && <1+    , dlist ==1.0.*     , hashable >=1.3 && <2     , prettyprinter >=1.7.0 && <2     , prettyprinter-ansi-terminal >=1.1.0 && <2@@ -108,9 +110,11 @@       BlockArguments   ghc-options: -Wall -Wextra -threaded -rtsopts -with-rtsopts=-N   build-depends:-      base >=4.7 && <5+      array ==0.5.*+    , base >=4.7 && <5     , data-default >=0.7 && <1     , diagnose+    , dlist ==1.0.*     , hashable >=1.3 && <2     , prettyprinter >=1.7.0 && <2     , prettyprinter-ansi-terminal >=1.1.0 && <2@@ -147,9 +151,11 @@       BlockArguments   ghc-options: -Wall -Wextra -threaded -rtsopts -with-rtsopts=-N   build-depends:-      base >=4.7 && <5+      array ==0.5.*+    , base >=4.7 && <5     , data-default >=0.7 && <1     , diagnose+    , dlist ==1.0.*     , hashable >=1.3 && <2     , prettyprinter >=1.7.0 && <2     , prettyprinter-ansi-terminal >=1.1.0 && <2@@ -185,9 +191,11 @@       BlockArguments   ghc-options: -Wall -Wextra -threaded -rtsopts -with-rtsopts=-N   build-depends:-      base >=4.7 && <5+      array ==0.5.*+    , base >=4.7 && <5     , data-default >=0.7 && <1     , diagnose+    , dlist ==1.0.*     , hashable >=1.3 && <2     , prettyprinter >=1.7.0 && <2     , prettyprinter-ansi-terminal >=1.1.0 && <2

@@ -66,11 +66,12 @@           putTogether (PE.Message thing : ms) = let (a, b, c, d) = putTogether ms in (a, b, c, thing : d)            (nub -> sysUnexpectedList, nub -> unexpectedList, nub -> expectedList, nub -> 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 ", " (filter (not . null) expectedList))]++          firstSysUnexpectedMessage = head sysUnexpectedList+          unexpectedMessage = "unexpected " <> if null unexpectedList then if null firstSysUnexpectedMessage then "end of line" else firstSysUnexpectedMessage else intercalate ", " (filter (not . null) unexpectedList)+       in [ (source, This $ fromString unexpectedMessage) ]+            <> [ (source, This $ fromString msg) | msg <- messages ]+            <> [ (source, Where $ fromString $ "expecting any of " <> intercalate ", " (filter (not . null) expectedList)) ]  -- | Generates an error diagnostic from a 'PE.ParseError'. errorDiagnosticFromParseError ::

@@ -20,13 +20,16 @@ import Data.Aeson (ToJSON(..), encode, object, (.=)) import Data.ByteString.Lazy (ByteString) #endif++import Data.Array (listArray)+import Data.DList (DList)+import qualified Data.DList as DL import Data.Default (Default, def)-import Data.Foldable (fold)-import Data.HashMap.Lazy (HashMap)+import Data.Foldable (fold, toList) import qualified Data.HashMap.Lazy as HashMap import Data.List (intersperse) import Error.Diagnose.Report (Report)-import Error.Diagnose.Report.Internal (prettyReport)+import Error.Diagnose.Report.Internal (FileMap, prettyReport) import Error.Diagnose.Style (Annotation, Style) import Prettyprinter (Doc, Pretty, hardline, unAnnotate) import Prettyprinter.Render.Terminal (hPutDoc)@@ -38,11 +41,11 @@ --   to create a new empty diagnostic, and 'addFile' and 'addReport' to alter its internal state. data Diagnostic msg   = Diagnostic-      [Report msg]+      (DList (Report msg))       -- ^ All the reports contained in a diagnostic.       --       --   Reports are output one by one, without connections in between.-      (HashMap FilePath [String])+      !FileMap       -- ^ A map associating files with their content as lists of lines.  instance Default (Diagnostic msg) where@@ -54,7 +57,7 @@ #ifdef USE_AESON instance ToJSON msg => ToJSON (Diagnostic msg) where   toJSON (Diagnostic reports files) =-    object [ "files" .= fmap toJSONFile (HashMap.toList files)+    object [ "files" .= fmap toJSONFile (fmap toList <$> (HashMap.toList files))            , "reports" .= reports            ]     where@@ -85,7 +88,7 @@   Diagnostic msg ->   Doc Annotation prettyDiagnostic withUnicode tabSize (Diagnostic reports file) =-  fold . intersperse hardline $ prettyReport file withUnicode tabSize <$> reports+  fold . intersperse hardline $ prettyReport file withUnicode tabSize <$> toList reports {-# INLINE prettyDiagnostic #-}  -- | Prints a 'Diagnostic' onto a specific 'Handle'.@@ -117,7 +120,10 @@   String ->   Diagnostic msg addFile (Diagnostic reports files) path content =-  Diagnostic reports (HashMap.insert path (lines content) files)+  let fileLines = lines content+      lineCount = length fileLines+      lineArray = listArray (0, lineCount - 1) fileLines+   in Diagnostic reports (HashMap.insert path lineArray files) {-# INLINE addFile #-}  -- | Inserts a new report into a diagnostic.@@ -127,7 +133,7 @@   Report msg ->   Diagnostic msg addReport (Diagnostic reports files) report =-  Diagnostic (reports <> [report]) files+  Diagnostic (reports `DL.snoc` report) files {-# INLINE addReport #-}  #ifdef USE_AESON

@@ -25,6 +25,8 @@ import Data.Aeson (ToJSON(..), object, (.=)) #endif import Control.Applicative ((<|>))+import qualified Data.Array.IArray as Array+import Data.Array.Unboxed (Array, IArray, Ix, UArray, listArray, (!)) import Data.Bifunctor (bimap, first, second) import Data.Char.WCWidth (wcwidth) import Data.Default (def)@@ -33,9 +35,9 @@ import Data.Functor ((<&>)) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap-import qualified Data.HashMap.Lazy as IntMap import qualified Data.List as List import qualified Data.List.Safe as List+import Data.Maybe import Data.Ord (Down (Down)) import Data.String (IsString (fromString)) import qualified Data.Text as Text@@ -44,6 +46,10 @@ import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>)) import Prettyprinter.Internal (Doc (..)) +type FileMap = HashMap FilePath (Array Int String)++type WidthTable = UArray Int Int+ -- | The type of diagnostic reports with abstract message type. data Report msg   = Report@@ -153,7 +159,7 @@ prettyReport ::   Pretty msg =>   -- | The content of the file the reports are for-  HashMap FilePath [String] ->+  FileMap ->   -- | Should we print paths in unicode?   Bool ->   -- | The number of spaces each TAB character will span@@ -310,7 +316,7 @@ prettySubReport ::   Pretty msg =>   -- | The content of files in the diagnostics-  HashMap FilePath [String] ->+  FileMap ->   -- | Is the output done with Unicode characters?   Bool ->   -- | Is the current report an error report?@@ -367,7 +373,7 @@ -- | prettyAllLines ::   Pretty msg =>-  HashMap FilePath [String] ->+  FileMap ->   Bool ->   Bool ->   -- | The number of spaces each TAB character will span@@ -467,34 +473,48 @@        in prefixWithBar colorOfFirstMultilineMarker <> prefix <> fold (List.intersperse prefix $ showMultilineMarkerMessages multiline)  -- |-getLine_ :: HashMap FilePath [String] -> [(Position, Marker msg)] -> Int -> Int -> Bool -> (IntMap.HashMap Int Int, Doc Annotation)-getLine_ files markers line tabSize isError = case List.safeIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of-  Nothing -> (mempty, annotate NoLineColor "<no line>")-  Just code ->-    let (tabs, code') = indexedWithTabsReplaced code-     in ( tabs,-          fold $-            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) || (bl < line && el > line)-               in maybe id ((\m -> annotate (MarkerStyle $ markerColor isError m)) . snd) (List.safeHead colorizingMarkers) (pretty c)-        )+getLine_ ::+  FileMap ->+  [(Position, Marker msg)] ->+  Int ->+  Int ->+  Bool ->+  (WidthTable, Doc Annotation)+getLine_ files markers line tabSize isError =+  case safeArrayIndex (line - 1) =<< (HashMap.!?) files . file . fst =<< List.safeHead markers of+    Nothing ->+      ( mkWidthTable "",+        annotate NoLineColor "<no line>"+      )+    Just code ->+      ( mkWidthTable code,+        flip foldMap (zip [1 ..] code) \(n, c) ->+          let cdoc =+                ifTab (pretty (replicate tabSize ' ')) pretty c+              colorizingMarkers = flip filter markers \case+                (Position (bl, bc) (el, ec) _, _)+                  | bl == el ->+                    n >= bc && n < ec+                  | otherwise ->+                    (bl == line && n >= bc)+                      || (el == line && n < ec)+                      || (bl < line && el > line)+           in maybe+                id+                ((\m -> annotate (MarkerStyle $ markerColor isError m)) . snd)+                (List.safeHead colorizingMarkers)+                cdoc+      )   where-    indexedWithTabsReplaced :: String -> (IntMap.HashMap Int Int, [(Int, Char)])-    indexedWithTabsReplaced = goIndexed 1+    ifTab :: a -> (Char -> a) -> Char -> a+    ifTab a _ '\t' = a+    ifTab _ f c = f c -    goIndexed :: Int -> String -> (IntMap.HashMap Int Int, [(Int, Char)])-    goIndexed _ [] = (mempty, [])-    goIndexed n ('\t' : xs) = bimap (IntMap.insert n tabSize) (replicate tabSize (n, ' ') <>) (goIndexed (n + 1) xs)-    goIndexed n (x : xs) = bimap (IntMap.insert n (wcwidth x)) ((n, x) :) (goIndexed (n + 1) xs)+    mkWidthTable :: String -> WidthTable+    mkWidthTable s = listArray (1, length s) (ifTab tabSize wcwidth <$> s)  -- |-showAllMarkersInLine :: Pretty msg => Bool -> Bool -> (Doc Annotation -> Doc Annotation) -> Bool -> Bool -> Int -> IntMap.HashMap Int Int -> [(Position, Marker msg)] -> Doc Annotation+showAllMarkersInLine :: Pretty msg => Bool -> Bool -> (Doc Annotation -> Doc Annotation) -> Bool -> Bool -> Int -> WidthTable -> [(Position, Marker msg)] -> Doc Annotation showAllMarkersInLine _ _ _ _ _ _ _ [] = mempty showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUnicode isError leftLen widths ms =   let maxMarkerColumn = snd $ end $ fst $ List.last $ List.sortOn (snd . end . fst) ms@@ -505,19 +525,23 @@    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+    widthAt i = 0 `fromMaybe` safeArrayIndex i widths+    widthsBetween start end =+      sum $ take (end - start) $ drop (start - 1) $ Array.elems widths+     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-              [] -> fold (replicate (IntMap.lookupDefault 0 n widths) space) <> showMarkers (n + 1) lineLen+              [] -> fold (replicate (widthAt n) space) <> showMarkers (n + 1) lineLen               (Position {..}, marker) : _ ->                 annotate                   (markerColor isError marker)                   ( if snd begin == n-                      then (if withUnicode then "┬" else "^") <> fold (replicate (IntMap.lookupDefault 0 n widths - 1) if withUnicode then "─" else "-")-                      else fold (replicate (IntMap.lookupDefault 0 n widths) if withUnicode then "─" else "-")+                      then (if withUnicode then "┬" else "^") <> fold (replicate (widthAt n - 1) if withUnicode then "─" else "-")+                      else fold (replicate (widthAt n) if withUnicode then "─" else "-")                   )                   <> showMarkers (n + 1) lineLen @@ -532,15 +556,15 @@             allColumns _ [] = (1, [])             allColumns n ms@((Position (_, bc) _ _, col) : ms')               | n == bc = bimap (+ 1) (col :) (allColumns (n + 1) ms')-              | n < bc = bimap (+ 1) (replicate (IntMap.lookupDefault 0 n widths) space <>) (allColumns (n + 1) ms)-              | otherwise = bimap (+ 1) (replicate (IntMap.lookupDefault 0 n widths) space <>) (allColumns (n + 1) ms')+              | n < bc = bimap (+ 1) (replicate (widthAt n) space <>) (allColumns (n + 1) ms)+              | otherwise = bimap (+ 1) (replicate (widthAt n) 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-                  numberOfSpaces = sum [IntMap.lookupDefault 0 x widths | x <- [n .. bc - 1]] -- bc - n+                  numberOfSpaces = widthsBetween n bc                in dotPrefix leftLen withUnicode <+> specialPrefix <> fold docs <> pretty (replicate numberOfSpaces ' ')             -- the start of the line contains the "dot"-prefix as well as all the pipes for all the still not rendered marker messages @@ -555,7 +579,7 @@                    lineLen = case lastBeginPosition of                     Nothing -> 0-                    Just col -> sum [IntMap.lookupDefault 0 x widths | x <- [bc .. col - 1]]+                    Just col -> widthsBetween bc col                    currentPipe =                     if@@ -639,3 +663,8 @@      noteMessage (Note msg) = msg     noteMessage (Hint msg) = msg++safeArrayIndex :: (Ix i, IArray a e) => i -> a i e -> Maybe e+safeArrayIndex i a+  | Array.inRange (Array.bounds a) i = Just (a ! i)+  | otherwise = Nothing

@@ -25,9 +25,11 @@   let filename :: FilePath = "<interactive>"       content1 :: Text = "0000000123456"       content2 :: Text = "00000a2223266"+      content3 :: Text = "aab"    let res1 = first (errorDiagnosticFromParseError Nothing "Parse error on input" Nothing) $ P.parse (P.many1 P.digit <* P.eof) filename content1       res2 = first (errorDiagnosticFromParseError Nothing "Parse error on input" Nothing) $ P.parse (P.many1 P.digit <* P.eof) filename content2+      res3 = first (errorDiagnosticFromParseError Nothing "Parse error on input" Nothing) $ P.parse (test1 <* P.eof) filename content3    case res1 of     Left diag -> printDiagnostic stdout True True 4 defaultStyle (addFile diag filename (Text.unpack content1) :: Diagnostic String)@@ -35,6 +37,11 @@   case res2 of     Left diag -> printDiagnostic stdout True True 4 defaultStyle (addFile diag filename (Text.unpack content2) :: Diagnostic String)     Right res -> print res+  case res3 of+    Left diag -> printDiagnostic stdout True True 4 defaultStyle (addFile diag filename (Text.unpack content3) :: Diagnostic String)+    Right res -> print res    -- all issue reproduction   Issue2.main++test1 = P.many (P.string "a") *> P.string "b" *> P.many1 (P.string "c")