Merge pull request #22 from expipiplus1/instances

Remove suspicious instances + some new ones

README.md

@@ -39,7 +39,8 @@ You don't even need to `import Prettyprinter`, as it is already provided to you
 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).
+It is an instance of `Monoid`, 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:
@@ -99,7 +100,7 @@ let beautifulExample =
         -- ^^^^ This is a 'Note' not a 'Hint', as specified by its 'IsString' instance
 
 -- Create the diagnostic
-let diagnostic  = addFile def "somefile.zc" "let id<a>(x : a) : a := x\n  + 1"
+let diagnostic  = addFile mempty "somefile.zc" "let id<a>(x : a) : a := x\n  + 1"
 let diagnostic' = addReport diagnostic beautifulExample
 
 -- Print with unicode characters, and the default (colorful) style

src/Error/Diagnose/Diagnostic.hs

@@ -20,7 +20,6 @@ import Error.Diagnose.Diagnostic.Internal as Export
 #endif
     addFile,
     addReport,
-    def,
     errorsToWarnings,
     hasReports,
     reportsOf,

src/Error/Diagnose/Diagnostic/Internal.hs

@@ -14,7 +14,7 @@
 --            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, WithUnicode(..), TabSize(..)) where
+module Error.Diagnose.Diagnostic.Internal (module Error.Diagnose.Diagnostic.Internal, WithUnicode(..), TabSize(..)) where
 
 import Control.Monad.IO.Class (MonadIO, liftIO)
 #ifdef USE_AESON
@@ -25,7 +25,6 @@ import Data.ByteString.Lazy (ByteString)
 import Data.Array (listArray)
 import Data.DList (DList)
 import qualified Data.DList as DL
-import Data.Default (Default, def)
 import Data.Foldable (fold, toList)
 import qualified Data.HashMap.Lazy as HashMap
 import Data.List (intersperse)
@@ -38,8 +37,8 @@ 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.
+--   Users can use 'mempty' to create a new empty diagnostic, and 'addFile' and
+--   'addReport' to alter its internal state.
 data Diagnostic msg
   = Diagnostic
       (DList (Report msg))
@@ -50,11 +49,11 @@ data Diagnostic msg
       -- ^ A map associating files with their content as lists of lines.
   deriving (Functor, Foldable, Traversable)
 
-instance Default (Diagnostic msg) where
-  def = Diagnostic mempty mempty
+instance Monoid (Diagnostic msg) where
+  mempty = Diagnostic mempty mempty
 
 instance Semigroup (Diagnostic msg) where
-  Diagnostic rs1 file <> Diagnostic rs2 _ = Diagnostic (rs1 <> rs2) file
+  Diagnostic rs1 files1 <> Diagnostic rs2 files2 = Diagnostic (rs1 <> rs2) (files1 <> files2)
 
 #ifdef USE_AESON
 instance ToJSON msg => ToJSON (Diagnostic msg) where

src/Error/Diagnose/Position.hs

@@ -41,10 +41,7 @@ data Position = Position
     -- | 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)
+  deriving (Show, Eq, Ord, Generic)
 
 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

src/Error/Diagnose/Report/Internal.hs

@@ -39,15 +39,13 @@ import Data.Char.WCWidth (wcwidth)
 import Data.Default (def)
 import Data.Foldable (fold)
 import Data.Function (on)
-import Data.Functor ((<&>))
+import Data.Functor ((<&>), void)
 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.Maybe
-import Data.Ord (Down (Down))
 import Data.String (IsString (fromString))
-import qualified Data.Text as Text
 import Error.Diagnose.Position
 import Error.Diagnose.Style (Annotation (..))
 import Prettyprinter (Doc, Pretty (..), align, annotate, colon, hardline, lbracket, rbracket, space, width, (<+>), reAnnotate, SimpleDocStream (..), layoutCompact)
@@ -125,27 +123,12 @@ data Marker msg
     Maybe msg
   | -- | An empty marker, whose sole purpose is to include a line of code in the report without markers under.
     Blank
-  deriving (Functor, Foldable, Traversable)
+  deriving (Eq, Ord, Functor, Foldable, Traversable)
 
-instance Eq (Marker msg) where
-  This _ == This _ = True
-  Where _ == Where _ = True
-  Maybe _ == Maybe _ = True
-  Blank == Blank = True
-  _ == _ = False
-  {-# INLINEABLE (==) #-}
-
-instance Ord (Marker msg) where
-  This _ < _ = False
-  Where _ < This _ = True
-  Where _ < _ = False
-  Maybe _ < _ = True
-  _ < Blank = True
-  Blank < _ = False
-  {-# INLINEABLE (<) #-}
-
-  m1 <= m2 = m1 < m2 || m1 == m2
-  {-# INLINEABLE (<=) #-}
+isBlank :: Marker msg -> Bool
+isBlank = \case
+  Blank -> True
+  _ -> False
 
 -- | A note is a piece of information that is found at the end of a report.
 data Note msg
@@ -378,7 +361,7 @@ prettySubReport fileContent withUnicode isError tabSize maxLineNumberLength isFi
 
       sortedMarkersPerLine = {- second (List.sortOn (first $ snd . begin)) <$> -} List.sortOn fst (HashMap.toList markersPerLine)
 
-      reportFile = maybe (pretty @Position def) (pretty . fst) $ List.safeHead (List.sortOn (Down . snd) markers)
+      reportFile = maybe (pretty @Position def) (pretty . fst) $ List.safeHead (List.sortOn (void . 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])
@@ -459,6 +442,8 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu
           -- take the first multiline marker to color the entire line, if there is one
 
           (multilineEndingOnLine, otherMultilines) = flip List.partition multiline \(Position _ (el, _) _, _) -> el == line
+          shouldShowMultiLine = isLastLine
+            || ((==) `on` fmap (fmap void)) (List.safeLast multilineEndingOnLine) (List.safeLast multiline)
 
           !additionalPrefix = case allMultilineMarkersInLine of
             [] ->
@@ -476,8 +461,8 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu
                     <> space
 
           -- we need to remove all blank markers because they are irrelevant to the display
-          allInlineMarkersInLine' = filter ((/=) Blank . snd) allInlineMarkersInLine
-          allMultilineMarkersSpanningLine' = filter ((/=) Blank . snd) allMultilineMarkersSpanningLine
+          allInlineMarkersInLine' = filter (not . isBlank . snd) allInlineMarkersInLine
+          allMultilineMarkersSpanningLine' = filter (not . isBlank . snd) allMultilineMarkersSpanningLine
 
           (widths, renderedCode) = getLine_ files (allInlineMarkersInLine <> allMultilineMarkersInLine <> allMultilineMarkersSpanningLine') line tabSize isError
        in ( otherMultilines,
@@ -485,7 +470,7 @@ prettyAllLines files withUnicode isError tabSize leftLen inline multiline lineNu
               <> {- (1) -} linePrefix leftLen line withUnicode <+>  additionalPrefix
               <> renderedCode
               <> {- (2) -} showAllMarkersInLine (not $ null multiline) inSpanOfMultiline colorOfFirstMultilineMarker withUnicode isError leftLen widths allInlineMarkersInLine'
-              <> showMultiline (isLastLine || List.safeLast multilineEndingOnLine == List.safeLast multiline) multilineEndingOnLine
+              <> showMultiline shouldShowMultiLine multilineEndingOnLine
           )
 
     showMultiline _ [] = mempty
@@ -570,7 +555,7 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn
     showMarkers n lineLen
       | n > lineLen = mempty -- reached the end of the line
       | otherwise =
-        let allMarkers = flip filter ms \(Position (_, bc) (_, ec) _, mark) -> mark /= Blank && n >= bc && n < ec
+        let allMarkers = flip filter ms \(Position (_, bc) (_, ec) _, mark) -> not (isBlank mark) && n >= bc && n < ec
          in -- only consider markers which span onto the current column
             case allMarkers of
               [] -> fold (replicate (widthAt n) space) <> showMarkers (n + 1) lineLen
@@ -586,7 +571,7 @@ showAllMarkersInLine hasMultilines inSpanOfMultiline colorMultilinePrefix withUn
     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 (uncurry (&&) . bimap ((/= b) . begin) (/= Blank)) pipes
+        let filteredPipes = filter (uncurry (&&) . bimap ((/= b) . begin) (not . isBlank)) pipes
             -- record only the pipes corresponding to markers on different starting positions
             nubbedPipes = List.nubBy ((==) `on` (begin . fst)) filteredPipes
             -- and then remove all duplicates

src/Error/Diagnose/Style.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE DeriveTraversable #-}
-
+{-# LANGUAGE DeriveGeneric #-}
 -- |
 -- Module      : Error.Diagnose.Style
 -- Description : Custom style definitions
@@ -19,6 +19,7 @@ module Error.Diagnose.Style
   )
 where
 
+import GHC.Generics
 import Prettyprinter.Render.Terminal (AnsiStyle, Color (..), bold, color, colorDull)
 
 -- $defining_new_styles
@@ -71,7 +72,7 @@ data Annotation a
     CodeStyle
   | -- | Something else, could be provided by the user
     OtherStyle a
-  deriving (Functor, Foldable, Traversable)
+  deriving (Eq, Ord, Show, Generic, Functor, Foldable, Traversable)
 
 -- | A style is a function which can be applied using 'reAnnotate'.
 --

test/rendering/Spec.hs

@@ -16,7 +16,6 @@ import Error.Diagnose
     Report(..),
     addFile,
     addReport,
-    def,
     defaultStyle,
     printDiagnostic,
     printDiagnostic',
@@ -90,8 +89,8 @@ main = do
           nestingReport
         ]
 
-  let diag = HashMap.foldlWithKey' addFile (foldl addReport def reports) files
-      customDiag = HashMap.foldlWithKey' addFile (foldl addReport def customAnnReports) files
+  let diag = HashMap.foldlWithKey' addFile (foldl addReport mempty reports) files
+      customDiag = HashMap.foldlWithKey' addFile (foldl addReport mempty customAnnReports) files
 
   hPutStrLn stdout "\n\nWith unicode: ─────────────────────────\n"
   printDiagnostic stdout WithUnicode (TabSize 4) defaultStyle diag