From 0d971cd667dcc27e3011182717928e9861940210 Mon Sep 17 00:00:00 2001 From: Mesabloo <22964017+Mesabloo@users.noreply.github.com> Date: Fri, 21 Aug 2020 12:40:14 +0200 Subject: [PATCH] Import all from https://github.com/Mesabloo/nihil --- .gitignore | 5 + LICENSE | 30 ++++++ Setup.hs | 2 + diagnose.cabal | 41 ++++++++ package.yaml | 19 ++++ src/Text/Diagnose.hs | 11 +++ src/Text/Diagnose/Diagnostic.hs | 41 ++++++++ src/Text/Diagnose/Format.hs | 7 ++ src/Text/Diagnose/Format/JSON.hs | 7 ++ src/Text/Diagnose/Format/Text.hs | 22 +++++ src/Text/Diagnose/Position.hs | 25 +++++ src/Text/Diagnose/Report.hs | 158 +++++++++++++++++++++++++++++++ stack.yaml | 66 +++++++++++++ 13 files changed, 434 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100644 Setup.hs create mode 100644 diagnose.cabal create mode 100644 package.yaml create mode 100644 src/Text/Diagnose.hs create mode 100644 src/Text/Diagnose/Diagnostic.hs create mode 100644 src/Text/Diagnose/Format.hs create mode 100644 src/Text/Diagnose/Format/JSON.hs create mode 100644 src/Text/Diagnose/Format/Text.hs create mode 100644 src/Text/Diagnose/Position.hs create mode 100644 src/Text/Diagnose/Report.hs create mode 100644 stack.yaml diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..321a5b5 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +.stack-work/ +*~ + +*.lock +# This is a lib, we'd rather not commit the lock file... diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..4b44b21 --- /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. \ No newline at end of file diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/diagnose.cabal b/diagnose.cabal new file mode 100644 index 0000000..10f75b7 --- /dev/null +++ b/diagnose.cabal @@ -0,0 +1,41 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.2. +-- +-- see: https://github.com/sol/hpack + +name: diagnose +version: 1.0.0 +homepage: https://github.com/mesabloo/nihil#readme +bug-reports: https://github.com/mesabloo/nihil/issues +author: Mesabloo +maintainer: Mesabloo +copyright: 2020 Mesabloo +license: BSD3 +license-file: LICENSE +build-type: Simple + +source-repository head + type: git + location: https://github.com/mesabloo/nihil + +library + exposed-modules: + Lib + Text.Diagnose + Text.Diagnose.Diagnostic + Text.Diagnose.Format + Text.Diagnose.Format.JSON + Text.Diagnose.Format.Text + Text.Diagnose.Position + Text.Diagnose.Report + other-modules: + Paths_diagnose + hs-source-dirs: + src + default-extensions: OverloadedStrings LambdaCase BlockArguments + build-depends: + ansi-wl-pprint + , base >=4.7 && <5 + , containers + default-language: Haskell2010 diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..128b262 --- /dev/null +++ b/package.yaml @@ -0,0 +1,19 @@ +name: diagnose +version: 1.0.0 +github: "mesabloo/nihil" +license: BSD3 +author: "Mesabloo" +copyright: "2020 Mesabloo" + +dependencies: +- base >= 4.7 && < 5 +- ansi-wl-pprint +- containers + +default-extensions: +- OverloadedStrings +- LambdaCase +- BlockArguments + +library: + source-dirs: src diff --git a/src/Text/Diagnose.hs b/src/Text/Diagnose.hs new file mode 100644 index 0000000..af9dd5f --- /dev/null +++ b/src/Text/Diagnose.hs @@ -0,0 +1,11 @@ +module Text.Diagnose +( module Text.Diagnose.Diagnostic +, module Text.Diagnose.Report +, module Text.Diagnose.Format +, module Text.Diagnose.Position +) where + +import Text.Diagnose.Diagnostic +import Text.Diagnose.Report hiding (prettyReport, Files) +import Text.Diagnose.Position +import Text.Diagnose.Format diff --git a/src/Text/Diagnose/Diagnostic.hs b/src/Text/Diagnose/Diagnostic.hs new file mode 100644 index 0000000..465d6a1 --- /dev/null +++ b/src/Text/Diagnose/Diagnostic.hs @@ -0,0 +1,41 @@ +module Text.Diagnose.Diagnostic +( Diagnostic +, diagnostic, (<~<), (<++>) +, printDiagnostic +) where + +import Text.Diagnose.Report +import Text.Diagnose.Format +import Data.Map (Map) +import qualified Data.Map as Map +import Text.PrettyPrint.ANSI.Leijen +import System.IO (Handle) + +-- | A @'Diagnostic' s m a@ is a diagnostic whose stream is a @s a@ and whose message type is @m@. +data Diagnostic s m a + = Diagnostic (Files s a) [Report m] + + +-- | Creates an empty 'Diagnostic' with no files and no reports. +diagnostic :: Diagnostic s m a +diagnostic = Diagnostic mempty mempty + +-- | Appends a file along with its name to the map of files of the 'Diagnostic'. +(<~<) :: Diagnostic s m a -> (FilePath, [s a]) -> Diagnostic s m a +Diagnostic files reports <~< (path, content) = Diagnostic (Map.insert path content files) reports + +-- | Appends a report to the list of reports of the 'Diagnostic'. +(<++>) :: Diagnostic s m a -> Report m -> Diagnostic s m a +Diagnostic files reports <++> report = Diagnostic files (reports ++ [report]) + +infixl 5 <++> +infixl 4 <~< + + +instance (Foldable s, PrettyText (s a), PrettyText m) => PrettyText (Diagnostic s m a) where + prettyText (Diagnostic files reports) = indent 1 (sep (fmap (prettyReport files) reports)) <> line + + +-- | Prints a @'Diagnostic' s m a@ To the given @'Handle'@ +printDiagnostic :: (Foldable s, PrettyText (s a), PrettyText m) => Handle -> Diagnostic s m a -> IO () +printDiagnostic handle diag = displayIO handle (renderPretty 0.9 80 $ prettyText diag) diff --git a/src/Text/Diagnose/Format.hs b/src/Text/Diagnose/Format.hs new file mode 100644 index 0000000..13064c0 --- /dev/null +++ b/src/Text/Diagnose/Format.hs @@ -0,0 +1,7 @@ +module Text.Diagnose.Format +( module Text.Diagnose.Format.Text +, module Text.Diagnose.Format.JSON +) where + +import Text.Diagnose.Format.Text +import Text.Diagnose.Format.JSON diff --git a/src/Text/Diagnose/Format/JSON.hs b/src/Text/Diagnose/Format/JSON.hs new file mode 100644 index 0000000..bc8e89d --- /dev/null +++ b/src/Text/Diagnose/Format/JSON.hs @@ -0,0 +1,7 @@ +module Text.Diagnose.Format.JSON where + +import Text.PrettyPrint.ANSI.Leijen + +class PrettyJSON a where + -- | Prettifies a value into a JSON representation. + prettyJSON :: a -> Doc diff --git a/src/Text/Diagnose/Format/Text.hs b/src/Text/Diagnose/Format/Text.hs new file mode 100644 index 0000000..3a1a70e --- /dev/null +++ b/src/Text/Diagnose/Format/Text.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module Text.Diagnose.Format.Text where + +import Text.PrettyPrint.ANSI.Leijen + +class PrettyText a where + -- | Prettifies into a simple 'Doc'. + prettyText :: a -> Doc + +instance PrettyText String where + prettyText = pretty + +instance PrettyText Integer where + prettyText = integer + +instance PrettyText Int where + prettyText = int + +instance PrettyText Char where + prettyText = text . (: []) diff --git a/src/Text/Diagnose/Position.hs b/src/Text/Diagnose/Position.hs new file mode 100644 index 0000000..b886cfb --- /dev/null +++ b/src/Text/Diagnose/Position.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE RecordWildCards #-} + +module Text.Diagnose.Position where + +import Text.PrettyPrint.ANSI.Leijen + +-- | Offset in a stream used to determine where to put markers. +data Position + = Position + { beginning :: (Integer, Integer) -- ^ The beginning line and column + , end :: (Integer, Integer) -- ^ The end line and column + , file :: String -- ^ The name of the file (does not need to be an absolute path) + } + deriving (Show, Eq) + +instance Pretty Position where + pretty Position{..} = + let (bLine, bCol) = beginning + in angles (text file <> colon <> integer bLine <> colon <> integer bCol) + +instance Ord Position where + p1 <= p2 = + let (b1Line, b1Col) = beginning p1 + (b2Line, b2Col) = beginning p2 + in b1Line <= b2Line && b1Col <= b2Col diff --git a/src/Text/Diagnose/Report.hs b/src/Text/Diagnose/Report.hs new file mode 100644 index 0000000..82a1a21 --- /dev/null +++ b/src/Text/Diagnose/Report.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} + +module Text.Diagnose.Report +( Report, Marker(..), Files, Kind, Hint +, reportError, reportWarning +, hint + +, prettyReport +) where + +import Text.Diagnose.Position +import Text.Diagnose.Format +import Text.PrettyPrint.ANSI.Leijen +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as List +import Prelude hiding ((<$>)) +import Data.Functor ((<&>)) +import Data.Function (on) +import Data.List (sortBy) +import Data.Maybe (fromJust, maybeToList) + +type Files s a = Map FilePath [s a] +type Markers m = Map Position (NonEmpty (Marker m)) + +-- | A report holds a 'Kind' of report and a message along with the useful 'Marker's and 'Hint'. +-- +-- It basically holds either an error or a warning along with additional context such as code. +data Report m + = Report Kind m (Markers m) [Hint m] + +-- | The kind of a 'Report', either an error or a warning. +data Kind + = Error + | Warning + +-- | A simple polymorphic hint holder +data Hint m + = Hint m + +-- | A polymorphic marker, parameterized on the message type. +-- +-- A marker is either: +data Marker m + = This m -- ^ * a "this" marker (@^^^^^ \@) used to highlight where the error/warning is located at + | Where m -- ^ * a "where" marker (@----- \@) used to provide some useful information in the context + | Maybe m -- ^ * a "maybe" marker (@~~~~~ \@) used to provide ideas of potential fixes + | Empty -- ^ * an "empty" marker used to show a line in the error/warning without adding any sort of marker on it + +-- | Creates a new report. +reportError, reportWarning :: m -> [(Position, Marker m)] -> [Hint m] -> Report m +reportError = newReport Error +reportWarning = newReport Warning + +-- | Internal creation of a new report. +newReport :: Kind -> m -> [(Position, Marker m)] -> [Hint m] -> Report m +newReport sev msg markers hints = Report sev msg markMap hints + where markMap = foldl createMap mempty markers + -- | Extends a 'Map' with a marker at a given position. + -- + -- If the position is already in the 'Map', the marker is simply added to the list of markers + -- else it is added as a non-empty list directly in the 'Map'. + createMap m (p, mark) = Map.insertWith (flip (<>)) p (mark List.:| []) m + +-- | A simple alias on the constructor of 'Hint', used to avoid exporting the constructor. +hint :: m -> Hint m +hint = Hint + + + +-- | Prettifies a report, when given the files it may want to used. +prettyReport :: (Foldable s, PrettyText (s a), PrettyText m) => Files s a -> Report m -> Doc +prettyReport files (Report kind msg markers hints) = + let (color, margin, sev) = prettyKind kind + in color (bold sev) <> colon <+> prettyText msg <$> + mconcat (replicate (margin - 2) space) <> text "In" <> colon <+> + prettyCodeWithMarkers files markers color <$> line <> + prettyHints hints + +-- | Prettifies the kind of a report. +prettyKind :: Kind + -> (Doc -> Doc, Int, Doc) -- ^ Returns the color for "this" markers, the offset for the "In: " part and the label of the report +prettyKind Error = (red, 7, brackets $ text "error") +prettyKind Warning = (yellow, 9, brackets $ text "warning") + +-- | Prettifies the code along with the useful markers. +prettyCodeWithMarkers :: (Foldable s, PrettyText m, PrettyText (s a)) + => Files s a -- ^ The potential input files to use to show the code + -> Markers m -- ^ The markers to show + -> (Doc -> Doc) -- ^ The color for "this" markers + -> Doc +prettyCodeWithMarkers files markers color = + let sortedMarkers = sortBy (compare `on` fst) (Map.toList markers) + in case sortedMarkers of + [] -> green (text "???") + (Position{beginning=begin, ..}, _):_ -> + let (bLine, bCol) = begin + ((p, _):_) = reverse sortedMarkers + maxLineMarkLen = length (show (fst (beginning p))) + + showLine l = + space <> text (replicate (maxLineMarkLen - length (show l)) ' ') <> integer l <> text "|" + + fileContent = fromJust (Map.lookup file files) + + showMarkers = sortedMarkers <&> uncurry \ Position{..} markers -> + let (bLine, bCol) = beginning + (eLine, eCol) = end + + code = fileContent !! fromIntegral (bLine - 1) + + underlineLen = fromIntegral $ (if eLine == bLine then eCol else fromIntegral (length code)) - bCol + + marker m = prettyMarker underlineLen m color magenta dullgreen + renderMarker m = + marker m <&> \ x -> mconcat (replicate (maxLineMarkLen + 2 + fromIntegral bCol) space) <> x + + renderedMarkers = List.toList markers >>= maybeToList . renderMarker + in white $ bold (showLine bLine) <+> prettyText code <> + mconcat (applyIfNotNull (line :) $ punctuate line renderedMarkers) + in green (text file) <$> + empty <$> + mconcat (punctuate line showMarkers) + +-- | Prettifies a list of 'Hint's into a single 'Doc'ument. All 'Hint's are prettified and concatenated with a 'line' in between. +prettyHints :: (PrettyText m) => [Hint m] -> Doc +prettyHints [] = line +prettyHints hs = blue (fillSep $ punctuate line (fmap render hs)) <> line + where render (Hint msg) = smartPretty msg + +-- | Prettifies a marker. +prettyMarker :: (PrettyText m) + => Int -- ^ The length of the marker + -> Marker m -- ^ The marker to show + -> (Doc -> Doc) -- ^ The color if a "this" marker + -> (Doc -> Doc) -- ^ The color for a "where" marker + -> (Doc -> Doc) -- ^ The color for a "maybe" marker + -> Maybe Doc -- ^ 'Nothing' if it is the 'Empty' marker +prettyMarker underlineLen marker colorThis colorWhere colorMaybe = case marker of + Empty -> Nothing + This msg -> Just (colorThis $ under '^' <+> align (smartPretty msg)) + Where msg -> Just (colorWhere $ under '-' <+> align (smartPretty msg)) + Maybe msg -> Just (colorMaybe $ under '~' <+> align (smartPretty msg)) + where under = text . replicate underlineLen + +-- | A smarter pretty to keep long texts in between the bounds and correctly align them. +smartPretty :: (PrettyText d) => d -> Doc +smartPretty = fillSep . fmap text . words . show . prettyText + + +-- | Applies a function to the list if it isn't '[]', else returns it. +applyIfNotNull :: ([a] -> [a]) -> [a] -> [a] +applyIfNotNull _ [] = [] +applyIfNotNull f l = f l diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..38ed2ec --- /dev/null +++ b/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-16.10 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.3" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor