diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +# CHANGELOG + +## v0.0.1.0 – +* Release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,11 @@ +Copyright 2022 The Chapelure Development Team + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + +2. 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. + +3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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,104 @@ +# Chapelure [![CI-badge][CI-badge]][CI-url] ![simple-haskell][simple-haskell] + +⚠ The 0.0.\* series is experimental. + +## Description + +`chapelure` is a diagnostic library for Haskell, based on the [`miette`][miette] library by [Kat Marchán][kat's twitter] + +## Build + +```bash +$ cabal build +``` + + +## Examples + +You can provide snippets to be annotated and highlighted: + +``` +[L342]: Error: + ╭[Code.hs:3:1] + │ +3│ add :: Int + │ ╰┬╯ + │ ╰ Return type is an “Int” +4│ add = 1 + True + │ ╰┬─╯ + │ ╰ You tried to pass a “Bool” + │ Did you check all the types of your arguments? + │ https://localhost:8888/help/code/L342 + ╯ +``` + +And you can even put multiple highlights per line: + +``` +[L342]: Error: + ╭[Code.hs:3:1] + │ +3│ add :: Int + │ ╰┬╯ + │ ╰ Return type is “Int” +4│ add = 1 + True + │ ┬ + │ ╰ This takes an “Int” + │ ╰┬─╯ + │ ╰ But you passed a “Bool” + │ Did you check all the types of your arguments? + │ https://localhost:8888/help/code/L342 + ╯ +``` + +To generate such a diagnostic, build the appropriate structures and pass it to the renderer: + +```haskell +import Data.Vector.NonEmpty as NEVec +import Chapelure.Types + + +let helpMessage = "Did you check all the types of your arguments?" +let highlights = NEVec.fromList [ + Source{ label = Just "Return type is “Int”" + , line = Line 3 + , startColumn = Column 8 + , endColumn = Column 10 + } + , Source{ label = Just "This takes an “Int”" + , line = Line 4 + , startColumn = Column 9 + , endColumn = Column 9 + } + , Source{ label = Just "But you passed a “Bool”" + , line = Line 4 + , startColumn = Column 11 + , endColumn = Column 14 + } + ] +let snip = Snippet { location = ("Code.hs", Line 3, Column 1) + , highlights = highlights + , content = Vec.fromList $ T.lines $ T.pack "add :: Int\nadd = 1 + True" + } +let diagnostic = Diagnostic { code = Just "L342" + , severity = Error + , link = Just "https://localhost:8888/help/code/L342" + , help = Just helpMessage + , snippets = Just . NEVec.singleton $ snip + } +``` + +It even outputs in colour! + +![Colourful terminal output](./screenshots/chapelureprogress8.png) + +## Acknowledgements + +* Kat Marchán +* Geoffroy Couprie + +[simple-haskell]: https://img.shields.io/badge/Simple-Haskell-purple?style=flat-square +[miette]: https://github.com/zkat/miette +[kat's twitter]: https://twitter.com/zkat__ +[CI-badge]: https://img.shields.io/github/workflow/status/haskell-chapelure/chapelure/CI?style=flat-square +[CI-url]: https://github.com/haskell-chapelure/chapelure/actions diff --git a/chapelure.cabal b/chapelure.cabal new file mode 100644 --- /dev/null +++ b/chapelure.cabal @@ -0,0 +1,102 @@ +cabal-version: 3.0 +name: chapelure +version: 0.0.1.0 +homepage: https://github.com/haskell-chapelure/chapelure#readme +bug-reports: https://github.com/haskell-chapelure/chapelure/issues +author: Hécate Moonlight +maintainer: Hécate Moonlight +category: Pretty Printer +synopsis: A diagnostics library for Haskell +description: Chapelure is a diagnostics library for Haskell. +license: MIT +build-type: Simple +extra-source-files: + CHANGELOG.md + LICENSE + README.md + +source-repository head + type: git + location: https://github.com/haskell-chapelure/chapelure + +common common-extensions + default-extensions: + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DerivingVia + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + MultiParamTypeClasses + NamedFieldPuns + OverloadedLabels + OverloadedStrings + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + StrictData + TypeApplications + TypeOperators + + default-language: Haskell2010 + +common common-ghc-options + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + -fhide-source-paths -Wno-unused-do-bind -fwrite-ide-info + -hiedir=.hie -haddock + +common common-rts-options + ghc-options: -rtsopts -threaded -with-rtsopts=-N + +library + import: common-extensions + import: common-ghc-options + hs-source-dirs: src + exposed-modules: + Chapelure + --Chapelure.Errors + Chapelure.Handler.Colourful + Chapelure.Types + Chapelure.Style + + build-depends: + , base >=4.14 && <4.18 + , containers ^>=0.6 + , nonempty-vector ^>=0.2 + , optics-core ^>=0.4 + , prettyprinter ^>=1.7 + , text ^>=1.2 + , text-display ^>=0.0 + , vector ^>=0.12 + , hsluv-haskell ^>=0.1 + , colour ^>= 2.3 + , ansi-terminal ^>= 0.11 + + +test-suite chapelure-test + import: common-extensions + import: common-ghc-options + import: common-rts-options + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: + , base + , chapelure + , hspec + , nonempty-vector + , prettyprinter + , string-qq + , text + , vector + + other-modules: diff --git a/src/Chapelure.hs b/src/Chapelure.hs new file mode 100644 --- /dev/null +++ b/src/Chapelure.hs @@ -0,0 +1,19 @@ +module Chapelure + ( Diagnostic(..) + , displayDiagnostic + , displayDiagnosticAsString + ) where + +import Chapelure.Handler.Colourful (Config, layoutOptions, render) +import Chapelure.Style (putDocText, renderDoc) +import Chapelure.Types (Diagnostic(..)) +import Data.Text (Text) +import Prettyprinter (layoutPretty) + +-- | Helper for displaying a diagnostic to standard out, using default layout options +displayDiagnostic :: Config -> Diagnostic -> IO () +displayDiagnostic config diagnostic = putDocText $ layoutPretty (layoutOptions config) $ render config diagnostic + +-- | Helper for rendering a diagnostic to text, using default layout options +displayDiagnosticAsString :: Config -> Diagnostic -> Text +displayDiagnosticAsString config diagnostic = renderDoc $ layoutPretty (layoutOptions config) $ render config diagnostic diff --git a/src/Chapelure/Handler/Colourful.hs b/src/Chapelure/Handler/Colourful.hs new file mode 100644 --- /dev/null +++ b/src/Chapelure/Handler/Colourful.hs @@ -0,0 +1,608 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +-- | A pretty renderer for 'Diagnostic's. Can optionally render in color +module Chapelure.Handler.Colourful + ( render + , Config (..) + , prettyConfig + , asciiColorConfig + , asciiPlainConfig + ) where + +import Chapelure.Style + ( DocText, + Style, + StyleColor (Color16, Color256, ColorRGB), + styleFG, + styleUnderline, + ) +import Chapelure.Types + ( Column (..), + Diagnostic (Diagnostic), + Highlight (Highlight, spans), + Line (..), + Severity (Error, Info, Warning), + Snippet (Snippet), + ) +import Data.Bifunctor (Bifunctor (first)) +import Data.Colour (Colour, colourConvert) +import Data.Fixed (mod') +import Data.Foldable (Foldable (fold), toList) +import Data.List (mapAccumL) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Semigroup (Semigroup (stimes)) +import Data.Sequence (Seq (..)) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Display (display) +import Data.Vector (Vector) +import qualified Data.Vector as V +import qualified Data.Vector.NonEmpty as DVNE +import HSLuv + ( HSLuv (HSLuv), + HSLuvHue (HSLuvHue), + HSLuvLightness (HSLuvLightness), + HSLuvSaturation (HSLuvSaturation), + hsluvToColour, + ) +import Optics.Core ((<&>)) +import Prettyprinter (LayoutOptions (LayoutOptions, layoutPageWidth), PageWidth (AvailablePerLine, Unbounded), Pretty (pretty), SimpleDocStream (..), annotate, brackets, hardline, indent, layoutPretty, space) +import System.Console.ANSI (Color (Blue, Red, Yellow), ColorIntensity (Vivid), Underlining (SingleUnderline), xterm24LevelGray) + +-- Color generation +-- https://martin.ankerl.com/2009/12/09/how-to-create-random-colors-programmatically/ +-- lightness between 0 and 100 +spacedColors :: Double -> [Colour Double] +spacedColors lightness = map (\hue -> hsluvToColour $ HSLuv (HSLuvHue $ hue * 360.0) (HSLuvSaturation 100.0) (HSLuvLightness lightness)) hues + where + goldenRatioConjugate :: Double + goldenRatioConjugate = 0.618033988749895 + + hues = map (\x -> (x * goldenRatioConjugate) `mod'` 1.0) [1 ..] + +headMempty :: Monoid a => [a] -> a +headMempty [] = mempty +headMempty (a : _as) = a + +-- | Configuration for rendering +data Config = Config + { tabWidth :: !Word, + layoutOptions :: !LayoutOptions, + infoStyle :: !Style, + warningStyle :: !Style, + errorStyle :: !Style, + gutterStyle :: !Style, + linkStyle :: !Style, + colourizeHighlights :: !Bool, + gutterVLine :: !Char, + gutterVBreak :: !Char, + gutterHLineHead :: !Char, + gutterHLineFoot :: !Char, + gutterCornerHead :: !Char, + gutterCornerFoot :: !Char, + locationLeftBracket :: !Text, + locationRightBracket :: !Text, + locationSeparator :: !Text, + highlightUnderLeft :: !Char, + highlightUnderRight :: !Char, + highlightUnder :: !Char, + highlightUnderDown :: !Char, + highlightTwospan :: !Char, + highlightConnector :: !Char, + highlightConnectionLeft :: !Char, + highlightConnectionRight :: !Char, + highlightHConnector :: !Char, + highlightHTee :: !Char, + highlightLabelTee :: !Char, + highlightCornerTop :: !Char, + highlightCornerBottom :: !Char + } + +prettyConfig, asciiColorConfig, asciiPlainConfig :: Config +-- | A pretty rendering configuration, making use of color and Unicode box-drawing characters +prettyConfig = + Config + { tabWidth = 4, + layoutOptions = LayoutOptions (AvailablePerLine 80 1.0), + infoStyle = styleFG $ Color16 Vivid Blue, + warningStyle = styleFG $ Color16 Vivid Yellow, + errorStyle = styleFG $ Color16 Vivid Red, + gutterStyle = styleFG (Color256 $ xterm24LevelGray 12), + linkStyle = styleUnderline SingleUnderline, + colourizeHighlights = True, + gutterVLine = '│', + gutterVBreak = '┆', + gutterHLineHead = ' ', + gutterHLineFoot = ' ', + gutterCornerHead = '╭', + gutterCornerFoot = '╯', + locationLeftBracket = "[", + locationRightBracket = "]", + locationSeparator = ":", + highlightUnderLeft = '╰', + highlightUnderRight = '╯', + highlightUnder = '─', + highlightUnderDown = '┬', + highlightTwospan = '├', + highlightConnector = '│', + highlightConnectionLeft = '╯', + highlightConnectionRight = '╰', + highlightHConnector = '─', + highlightHTee = '├', + highlightLabelTee = '┴', + highlightCornerTop = '╭', + highlightCornerBottom = '╰' + } +-- | A colorful ASCII rendering configuration +asciiColorConfig = + prettyConfig + { gutterVLine = '|', + gutterVBreak = ':', + gutterCornerHead = '/', + gutterCornerFoot = '/', + highlightUnderLeft = '^', + highlightUnderRight = '^', + highlightUnder = '^', + highlightUnderDown = '^', + highlightTwospan = '^', + highlightConnector = '|', + highlightConnectionLeft = '/', + highlightConnectionRight = '\\', + highlightHConnector = '-', + highlightHTee = '|', + highlightLabelTee = '*', + highlightCornerTop = '/', + highlightCornerBottom = '\\' + } +-- | A plain ASCII rendering configuration. Useful if the terminal supports neither colour nor box-drawing characters +asciiPlainConfig = + asciiColorConfig + { infoStyle = mempty, + warningStyle = mempty, + errorStyle = mempty, + gutterStyle = mempty, + linkStyle = mempty, + colourizeHighlights = False + } + +-- | What to render at the left of the line +data Gutter + = -- ╭[source:line:column] + Header (Maybe Text) Line Column + | -- | + HeaderSpace + | -- line | + Numbered Line + | -- | + Unnumbered (Maybe Semantic) + | -- ┆ + Break + | -- ╯ + Footer + +-- | The meaning of an unnumbered line: used to connect up multi-line highlights +data Semantic + = -- | Extra information in the footer + FooterInfo + | -- | Line contains the first connnector for highlight #[Int] + FirstConnectorFor Int + | -- | Line contains a connnector for highlight #[Int] + MidConnectorFor Int + | -- | Line contains the last connnector for highlight #[Int] + LastConnectorFor Int + +-- | What kind of multi-span label to render in a column +data MultiSpan + = -- | No multi-span label here + NoMulti + | -- | A vertical connection + Vee Style + | -- | A vertical-right connection + Tee Style TeeLocation + +-- | Where a tee-junction of a multi-span is within the multi-span +data TeeLocation + = TeeTop + | TeeMid + | TeeBottom + +-- | A connector to labels and/or multi-spans +data Connector + = -- | ╯ Connect to a label on the left + LeftConnector + | -- | ╰ Connect to a label on the right + RightConnector + | -- | ╯ Connect to a multi-span + MultiConnector + | -- | ┴ Connect to a multi-span and a label on the right + MultiEndConnector + +-- | How to render a particular line, and the line's semantics +data RenderLine = RenderLine + { gutter :: Gutter, + multispans :: [MultiSpan], + contentOffset :: Word, + renderedContent :: [(Text, Style)], + connector :: Maybe (Style, Connector) + } + +renderLine :: Config -> Word -> RenderLine -> DocText +renderLine config pad (RenderLine g ms co rc conn) = + goGutter g + <> goMulti ms co + <> case conn of + Just (connSt, RightConnector) -> annotate connSt $ pretty (highlightConnectionRight config) + Just (connSt, MultiConnector) -> annotate connSt $ pretty (highlightConnectionLeft config) + Just (connSt, MultiEndConnector) -> annotate connSt $ pretty (highlightLabelTee config) + _ -> mempty + <> space + <> goContent rc + <> case conn of + Just (connSt, LeftConnector) -> space <> annotate connSt (pretty (highlightConnectionLeft config)) + _ -> mempty + <> hardline + where + goGutter :: Gutter -> DocText + goGutter = + annotate (gutterStyle config) + . \case + Header source l c' -> + stimes pad (pretty $ gutterHLineHead config) + <> pretty (gutterCornerHead config) + <> pretty (locationLeftBracket config) + <> maybe mempty (\s -> pretty s <> pretty (locationSeparator config)) source + <> pretty l + <> pretty (locationSeparator config) + <> pretty c' + <> pretty (locationRightBracket config) + HeaderSpace -> + indent (fromIntegral pad) (pretty $ gutterVLine config) + Numbered li -> + let s = display li + in indent (fromIntegral pad - T.length s) $ pretty s <> pretty (gutterVLine config) + Unnumbered _ -> indent (fromIntegral pad) $ pretty (gutterVLine config) + Break -> indent (fromIntegral pad) $ pretty (gutterVBreak config) + Footer -> + stimes pad (pretty $ gutterHLineFoot config) + <> pretty (gutterCornerFoot config) + + goMulti :: [MultiSpan] -> Word -> DocText + goMulti ms' co' = + let (hl, docs) = + mapAccumL + ( \hl' -> \case + NoMulti -> (hl', maybe space (\st -> annotate st $ pretty (highlightHConnector config)) hl') + Vee st -> (hl', annotate st $ pretty (highlightConnector config)) + Tee st TeeTop -> (Just st, annotate st $ pretty (highlightCornerTop config)) + Tee st TeeMid -> (Just st, annotate st $ pretty (highlightHTee config)) + Tee st TeeBottom -> (Just st, annotate st $ pretty (highlightCornerBottom config)) + ) + Nothing + ms' + in fold docs <> stimes co' (maybe space (\st -> annotate st $ pretty (highlightHConnector config)) hl) + + goContent :: [(Text, Style)] -> DocText + goContent = foldMap (\(t, s) -> annotate s (pretty t)) + +buildDoc :: LayoutOptions -> DocText -> Seq [(Text, Style)] +buildDoc lo = go [] [] . layoutPretty lo + where + go :: [Style] -> [(Text, Style)] -> SimpleDocStream Style -> Seq [(Text, Style)] + go st line = \case + SFail -> [reverse line] + SEmpty -> [reverse line] + SChar c sds -> go st ((T.singleton c, headMempty st) : line) sds + SText _n txt sds -> go st ((txt, headMempty st) : line) sds + SLine n sds -> reverse line :<| go st [(T.replicate n " ", headMempty st)] sds + SAnnPush st' sds -> case st of + [] -> go [st'] line sds + (s : ss) -> go (s <> st' : s : ss) line sds + SAnnPop sds -> go (drop 1 st) line sds + +buildGutter :: LayoutOptions -> Line -> Line -> Vector DocText -> (Word, Seq RenderLine) +buildGutter lo s e lines' = (fromIntegral pad, body) + where + pad = T.length (display e) + padded = LayoutOptions $ case layoutPageWidth lo of + AvailablePerLine n x -> AvailablePerLine (n - pad) x + Unbounded -> Unbounded + + body = + Seq.zip [s .. e] (Seq.fromList $ toList lines') >>= \(i, line) -> + fmap (\r -> RenderLine (Numbered i) [] 0 r Nothing) (buildDoc padded line) + +buildGutter' :: Bool -> Style -> LayoutOptions -> Maybe Text -> Line -> Column -> Line -> Vector DocText -> Maybe DocText -> Maybe Text -> (Word, Seq RenderLine) +buildGutter' isFinal linkStyle lo source s sc e lines' me li = + ( pad, + go (Header source s sc) :<| go HeaderSpace + :<| ( bg + <> if not isFinal then mempty else ((\l -> RenderLine (Unnumbered (Just FooterInfo)) [] 0 l Nothing) <$> buildDoc lo (fromMaybe mempty me)) + <> if not isFinal then mempty else maybe mempty (\link -> [RenderLine (Unnumbered (Just FooterInfo)) [] 0 [(link, linkStyle)] Nothing]) li :|> go Footer + ) + ) + where + go g = RenderLine g [] 0 [] Nothing + (pad, bg) = buildGutter lo s e lines' + +highlightSpans :: [(Column, Column, Style)] -> [(Text, Style)] -> [(Text, Style)] +highlightSpans hls = go 1 + where + go :: Word -> [(Text, Style)] -> [(Text, Style)] + go _col [] = [] + go col ((t, st) : rest) = + let cs = zipWith go' [col ..] (map (,st) (T.unpack t)) + in coalesce (map (first T.singleton) cs) ++ go (col + fromIntegral (T.length t)) rest + + coalesce :: [(Text, Style)] -> [(Text, Style)] + coalesce ((t, st) : (t', st') : rest) | st == st' = coalesce ((t <> t', st') : rest) + coalesce (a : as) = a : coalesce as + coalesce [] = [] + + go' :: Word -> (Char, Style) -> (Char, Style) + go' col (c, s) = + ( c, + s + <> fold + ( mapMaybe + (\(s', e, st) -> if s' <= Column col && Column col <= e then Just st else Nothing) + hls + ) + ) + +data MultiKind + = Single (Maybe DocText) + | Multi + | MultiEnd (Maybe DocText) + +data RenderHighlight = RenderHighlight + { hiStart :: Column, + hiEnd :: Column, + hiStyle :: Style, + multiKind :: MultiKind, + hiSem :: Maybe Semantic + } + +underlineHighlight :: Config -> [RenderHighlight] -> Seq RenderLine +underlineHighlight config highlights = Seq.fromList $ highlights >>= go + where + go (RenderHighlight (Column cs') (Column ce') st mk sem) = + let mid = (cs' + ce') `div` 2 + underline = + if + | ce' == cs' -> T.singleton $ highlightUnderDown config + | ce' == cs' + 1 -> T.singleton (highlightTwospan config) <> T.singleton (highlightUnderRight config) + | otherwise -> + T.singleton (highlightUnderLeft config) + <> T.replicate (fromIntegral $ mid - cs' - 1) (T.singleton $ highlightUnder config) + <> T.singleton (highlightUnderDown config) + <> T.replicate (fromIntegral $ ce' - mid - 1) (T.singleton $ highlightUnder config) + <> T.singleton (highlightUnderRight config) + connector + | Multi <- mk = MultiConnector + | MultiEnd _ <- mk = MultiEndConnector + | Unbounded <- layoutPageWidth (layoutOptions config) = RightConnector + | AvailablePerLine n _x <- layoutPageWidth $ layoutOptions config, + n `div` 2 > fromIntegral mid = + RightConnector + | otherwise = LeftConnector + t = case mk of + Single d -> d + Multi -> Nothing + MultiEnd d -> d + z = zip (Just connector : repeat Nothing) (toList (buildDoc (layoutOptions config) (annotate st $ fromMaybe mempty t))) + in RenderLine (Unnumbered Nothing) [] (cs' - 1) [(underline, st)] Nothing : + (z <&> \(conn, l) -> RenderLine (if isJust conn then Unnumbered sem else Unnumbered Nothing) [] mid l ((st,) <$> conn)) + +-- | Renders a 'Diagnostic' using the provided 'Config' into a 'DocText'. +render :: Config -> Diagnostic -> DocText +render config (Diagnostic co se me he li snip) = + let sgr = case se of + Info -> infoStyle config + Warning -> warningStyle config + Error -> errorStyle config + + code = + co <&> \co' -> + annotate sgr $ + brackets (pretty co') <> ": " + label' = annotate sgr $ pretty (show se) <> ": " + mess = fromMaybe mempty me <> hardline + snips :: Vector Snippet + snips = maybe mempty DVNE.toVector snip + body = foldMap go (zip [0..] (toList snips)) + inCaseNoSnippets = maybe showFooter (const mempty) snip + in fromMaybe mempty code <> label' <> mess <> body <> inCaseNoSnippets + where + showFooter = foldMap (foldMap (\(t, s) -> annotate s (pretty t) <> hardline)) $ + buildDoc (layoutOptions config) (fromMaybe mempty he) + <> maybe mempty (\link -> [[(link, linkStyle config)]]) li + + go (i, Snippet (source, ln@(Line ln'), col) highlights' lines') = + foldMap + (renderLine config pad) + ( renderMulti $ + fullGutter >>= \rl -> + case gutter rl of + Numbered li' -> rl :<| maybe mempty (underlineHighlight config) (Map.lookup li' highlights) + _ -> [rl] + ) + where + hls = + zip + (if colourizeHighlights config then map (styleFG . ColorRGB . colourConvert) (spacedColors 75.0) else repeat mempty) + (maybe mempty toList highlights') + + fromList' :: Ord k => [(k, v)] -> Map k [v] + fromList' = foldr (\(k, v) m -> Map.insertWith (<>) k [v] m) mempty + + highlights = + fromList' $ + concatMap + ( \(name, (style, Highlight label' spans)) -> + ( \(j :: Integer, (l, cs, ce)) -> + ( l, + RenderHighlight + cs + ce + style + if + | DVNE.length spans >= 2, j == fromIntegral (DVNE.length spans - 1) -> MultiEnd label' + | DVNE.length spans >= 2 -> Multi + | otherwise -> Single label' + if + | j == 0 -> Just $ FirstConnectorFor name + | j == fromIntegral (DVNE.length spans - 1) -> Just $ LastConnectorFor name + | otherwise -> Just $ MidConnectorFor name + ) + ) + <$> zip [0 ..] (toList spans) + ) + (zip [0 ..] hls) + + multilineHighlights :: [((Int, Style), [(Line, Column, Column)])] + multilineHighlights = mapMaybe (\(k, (st, hi)) -> if DVNE.length (spans hi) >= 2 then Just ((k, st), toList (spans hi)) else Nothing) (zip [0 ..] hls) + multilineHighlights' :: [Map Line [(Column, Column)]] + multilineHighlights' = fmap (fromList' . fmap (\(l, cs, ce) -> (l, (cs, ce))) . snd) multilineHighlights + multilineHighlights'' :: [Set Line] + multilineHighlights'' = + fmap + ( \m -> case (Map.lookupMin m, Map.lookupMax m) of + (Just (mini, _), Just (maxi, _)) -> Set.fromList [mini .. maxi] + _ -> mempty + ) + multilineHighlights' + multilineHighlights''' :: [((Int, Style), Set Line)] + multilineHighlights''' = zip (fmap fst multilineHighlights) multilineHighlights'' + + (pad, gutter') = buildGutter' (i == maybe 0 DVNE.length snip - 1) (linkStyle config) (layoutOptions config) source ln col (Line $ ln' + fromIntegral (V.length lines')) lines' he li + + forget = fmap (\(RenderHighlight cs ce st _ _) -> (cs, ce, st)) + hlGutter = + gutter' <&> \rl -> case gutter rl of + Numbered li' -> rl {renderedContent = maybe id highlightSpans (forget <$> Map.lookup li' highlights) $ renderedContent rl} + _ -> rl + fullGutter = if colourizeHighlights config then hlGutter else gutter' + + renderMulti :: Seq RenderLine -> Seq RenderLine + renderMulti s = + foldr + ( \((i', st), _ls) ls' -> + snd $ + mapAccumL + ( \isStyled rl -> + let (isStyled', c) = case gutter rl of + Unnumbered (Just (FirstConnectorFor j)) | i' == j -> (True, Tee st TeeTop) + Unnumbered (Just (MidConnectorFor j)) | i' == j -> (True, Tee st TeeMid) + Unnumbered (Just (LastConnectorFor j)) | i' == j -> (False, Tee st TeeBottom) + Unnumbered (Just FooterInfo) -> (False, NoMulti) + Footer -> (False, NoMulti) + _ -> (isStyled, if isStyled then Vee st else NoMulti) + in (isStyled', rl {multispans = c : multispans rl}) + ) + False + ls' + ) + s + multilineHighlights''' + +-- ──────────────────────────────── Testing ──────────────────────────────── -- +-- colourTest :: IO () +-- colourTest = go (zip (spacedColors 75.0) (words "This is a colour test! Fugiat excepturi illo nihil porro voluptatem. Repellendus velit quibusdam aut dolorem. Quis non ipsa qui molestiae explicabo quos. Sed dolorum laborum expedita exercitationem sit quaerat veniam culpa. Voluptas quas molestiae earum delectus veniam officia ut ut. Cupiditate tenetur libero quibusdam maiores ea. Est consequuntur perferendis est optio officia aliquid ratione. Velit hic eaque qui voluptatibus ipsam. Rem facilis temporibus corporis quia perferendis. Commodi vero laborum esse voluptas est numquam. Laudantium fuga aliquam repudiandae explicabo ut dolores beatae. Pariatur et provident consequatur optio neque asperiores voluptatem necessitatibus. Iusto nam sint et. Non qui cupiditate porro corporis qui. Dignissimos voluptates iusto dolor. Itaque minus et sed qui non quidem. Perspiciatis omnis id eaque. Quis rerum architecto magni qui iure nisi voluptatum. Omnis esse pariatur pariatur non. Fugiat provident voluptate maxime cupiditate unde consequatur at id. Praesentium molestiae consectetur sequi dolor qui nulla vel fuga. Enim aut assumenda recusandae. Et quisquam architecto quasi aut nihil unde et dolores. Delectus qui esse sapiente ut. Eum ut quis expedita reprehenderit et nihil odio sint. Molestias quidem iusto delectus est consequatur voluptas possimus. Neque reiciendis maiores cumque a non nihil.")) +-- where +-- go :: [(Colour Double, String)] -> IO () +-- go [] = putStrLn "" >> setSGR [] +-- go ((c, s) : rest) = do +-- setSGR [SetRGBColor Foreground (colourConvert c)] +-- putStr s +-- putStr " " +-- go rest + +-- displayDiag :: Diagnostic -> IO () +-- displayDiag = render asciiColorConfig >>> layoutPretty defaultLayoutOptions >>> putDocText + +-- testDiag :: Diagnostic +-- testDiag = +-- Diagnostic +-- (Just "E0001") +-- Error +-- (Just "Found a bug!") +-- (Just "Note: your code is broken!") +-- (Just "https://sofia.sofia") +-- ( DVNE.fromVector +-- [ Snippet +-- (Just "sofia.ð", Line 99, Column 1) +-- ( DVNE.fromVector +-- [ Highlight (Just "unrecognized type 'imt'") (DVNE.singleton (Line 99, Column 13, Column 15)), +-- Highlight +-- (Just "note: maybe you mean 'int' to match with y?") +-- ( DVNE.singleton (Line 100, Column 9, Column 13) <> DVNE.singleton (Line 101, Column 9, Column 9) +-- ) +-- ] +-- ) +-- [ "def blah(x: imt): int", +-- " y = x", +-- " y" +-- ] +-- ] +-- ) + +-- testDiag2 :: Diagnostic +-- testDiag2 = +-- Diagnostic +-- (Just "E0002") +-- Info +-- (Just $ "Edge case " <> annotate (styleItalicized True) "testing!") +-- (Just ("Note: we can have " <> annotate (styleFG (Color16 Vivid Cyan)) "colors!")) +-- (Just "https://sofia.sofia") +-- ( DVNE.fromVector +-- [ Snippet +-- (Just "sofia.ð", Line 99999, Column 1) +-- ( DVNE.fromVector +-- [ Highlight (Just "small label") (DVNE.singleton (Line 99999, Column 1, Column 2)), +-- Highlight +-- (Just "overlap") +-- ( DVNE.singleton (Line 100000, Column 1, Column 4) <> DVNE.singleton (Line 100000, Column 3, Column 7) +-- ) +-- ] +-- ) +-- [ "tiny", +-- "overlap" +-- ] +-- ] +-- ) + +-- testDiag3 :: Diagnostic +-- testDiag3 = +-- Diagnostic +-- (Just "E0003") +-- Info +-- Nothing +-- Nothing +-- Nothing +-- ( DVNE.fromVector +-- [ Snippet +-- (Nothing, Line 9, Column 1) +-- ( DVNE.fromVector +-- [ Highlight (Just "overlapping 1") (DVNE.singleton (Line 9, Column 1, Column 4) <> DVNE.singleton (Line 10, Column 1, Column 4)), +-- Highlight (Just "overlapping 2") (DVNE.singleton (Line 10, Column 1, Column 4) <> DVNE.singleton (Line 11, Column 1, Column 4)), +-- Highlight (Just "overlapping 3") (DVNE.singleton (Line 9, Column 1, Column 4) <> DVNE.singleton (Line 12, Column 1, Column 4) <> DVNE.singleton (Line 13, Column 1, Column 4)) +-- ] +-- ) +-- [ "blah", +-- "blaz", +-- "sofi", +-- "bing", +-- "cute" +-- ] +-- ] +-- ) diff --git a/src/Chapelure/Style.hs b/src/Chapelure/Style.hs new file mode 100644 --- /dev/null +++ b/src/Chapelure/Style.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} + +-- | Utilities for styling text for terminal output +module Chapelure.Style where + +import Control.Applicative ((<|>)) +import Data.Colour (Colour) +import Data.Maybe (catMaybes, listToMaybe, fromMaybe) +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Data.Word (Word8) +import Prettyprinter (Doc, SimpleDocStream (..)) +import System.Console.ANSI (Color, ColorIntensity, ConsoleIntensity, ConsoleLayer (Background, Foreground), SGR (SetColor, SetConsoleIntensity, SetDefaultColor, SetItalicized, SetPaletteColor, SetRGBColor, SetSwapForegroundBackground, SetUnderlining), Underlining, hSetSGR, setSGR, setSGRCode) +import System.IO (Handle) + +-- | A collection of style information. Implements 'Monoid' +data Style = Style + { _intensity :: !(Maybe ConsoleIntensity), + _italicize :: !(Maybe Bool), + _underline :: !(Maybe Underlining), + _negative :: !(Maybe Bool), + _colorFG :: !(Maybe StyleColor), + _colorBG :: !(Maybe StyleColor) + } + deriving (Show, Eq) + +-- | Set the intensity of a style +styleIntensity :: ConsoleIntensity -> Style +styleIntensity si = Style (Just si) Nothing Nothing Nothing Nothing Nothing + +-- | Set whether or not a style is italicized +styleItalicized :: Bool -> Style +styleItalicized it = Style Nothing (Just it) Nothing Nothing Nothing Nothing + +-- | Set the type of underling for a style +styleUnderline :: Underlining -> Style +styleUnderline ul = Style Nothing Nothing (Just ul) Nothing Nothing Nothing + +-- | Sets negative mode for a style; this inverts the foreground and background colours +styleNegative :: Bool -> Style +styleNegative sn = Style Nothing Nothing Nothing (Just sn) Nothing Nothing + +-- | Set the foreground color of a style +styleFG :: StyleColor -> Style +styleFG c = Style Nothing Nothing Nothing Nothing (Just c) Nothing + +-- | Set the background color of a style +styleBG :: StyleColor -> Style +styleBG c = Style Nothing Nothing Nothing Nothing Nothing (Just c) + +instance Semigroup Style where + Style is it un ne fg bg <> Style is2 it2 un2 ne2 fg2 bg2 = + Style (is <|> is2) (it <|> it2) (un <|> un2) (ne <|> ne2) (fg <|> fg2) (bg <|> bg2) + +instance Monoid Style where + mempty = Style Nothing Nothing Nothing Nothing Nothing Nothing + +-- | Various kinds of colors that can be used in a terminal +data StyleColor + = ColorDefault + -- | A 16-colour palette: 8 hues and 2 intensities. The most commonly supported form of terminal colouring + | Color16 !ColorIntensity !Color + -- | A fixed 256-color palette + | Color256 !Word8 + -- | Full 24-bit true colors + | ColorRGB !(Colour Float) + deriving (Show, Eq) + +-- | Styled, pretty-printed 'Doc'uments +type DocText = Doc Style + +-- | Converts a 'Style' to a list of Set Graphics Rendition 'SGR' codes +toSGR :: Style -> [SGR] +toSGR (Style is it un ne fg bg) = + catMaybes + [ SetConsoleIntensity <$> is, + SetItalicized <$> it, + SetUnderlining <$> un, + SetSwapForegroundBackground <$> ne, + go Foreground <$> fg, + go Background <$> bg + ] + where + go :: ConsoleLayer -> StyleColor -> SGR + go l = \case + ColorDefault -> SetDefaultColor l + Color16 ci co -> SetColor l ci co + Color256 wo -> SetPaletteColor l wo + ColorRGB co -> SetRGBColor l co + +-- | Converts a style to a string containing the escape codes to set that style +setStyleCode :: Style -> String +setStyleCode = setSGRCode . toSGR + +-- | Sets the graphics rendition mode of standard out to a style +setStyle :: Style -> IO () +setStyle = setSGR . toSGR + +-- | Sets the graphics rendition mode of a handle to a style +hSetStyle :: Handle -> Style -> IO () +hSetStyle h = hSetSGR h . toSGR + +-- | Render a styled document stream to text, including ANSI escape codes to set the style +renderDoc :: SimpleDocStream Style -> T.Text +renderDoc = go [] + where + go :: [Maybe Style] -> SimpleDocStream Style -> T.Text + go st = \case + SFail -> error "SFail left in pretty-printed output" + SEmpty -> mempty + SChar c sds -> T.singleton c <> go st sds + SText _n txt sds -> txt <> go st sds + SLine n sds -> T.singleton '\n' <> T.replicate n (T.singleton ' ') <> go st sds + SAnnPush st' sds -> if st' == mempty + then go (Nothing : st) sds + else T.pack (setStyleCode (fromMaybe mempty (fromMaybe mempty (listToMaybe st)) <> st')) <> go (Just st' : st) sds + SAnnPop sds -> case st of + [] -> go [] sds + [Nothing] -> go [] sds + (Nothing : t : ss) -> go (t : ss) sds + [Just _s] -> T.pack (setStyleCode mempty) <> go [] sds + (Just _s : t : ss) -> maybe mempty (T.pack . setStyleCode) t <> go (t : ss) sds + +-- | Output a styled document stream to standard out +putDocText :: SimpleDocStream Style -> IO () +putDocText = go [] + where + go :: [Maybe Style] -> SimpleDocStream Style -> IO () + go st = \case + SFail -> error "SFail left in pretty-printed output" + SEmpty -> pure () + SChar c sds -> putChar c >> go st sds + SText _n txt sds -> T.putStr txt >> go st sds + SLine n sds -> putChar '\n' >> T.putStr (T.replicate n (T.singleton ' ')) >> go st sds + SAnnPush st' sds -> if st' == mempty + then go (Nothing : st) sds + else do + setStyle (fromMaybe mempty (fromMaybe mempty (listToMaybe st)) <> st') + go (Just st' : st) sds + SAnnPop sds -> case st of + [] -> go [] sds + [Nothing] -> go [] sds + (Nothing : t : ss) -> go (t : ss) sds + [Just _s] -> setStyle mempty >> go [] sds + (Just _s : t : ss) -> maybe (pure ()) setStyle t >> go (t : ss) sds diff --git a/src/Chapelure/Types.hs b/src/Chapelure/Types.hs new file mode 100644 --- /dev/null +++ b/src/Chapelure/Types.hs @@ -0,0 +1,88 @@ +module Chapelure.Types where + +import Chapelure.Style (DocText) +import Data.Text (Text) +import Data.Text.Display (Display (displayBuilder), ShowInstance (..)) +import Data.Vector (Vector) +import Data.Vector.NonEmpty (NonEmptyVector) +import GHC.Generics (Generic) +import Prettyprinter (Pretty) + +data Diagnostic = Diagnostic + { -- | Unique diagnostic code that be used to look up more information. + -- Should be globally unique, and documented for easy searching. + code :: Maybe Text, + -- | Diagnostic severity, this may be used by the Report Handler + -- to adapt the formatting of the diagnostic. + severity :: Severity, + -- | A short description of the diagnostic. Rendered at the top. + message :: Maybe DocText, + -- | Additional free-form text for the poor bastard at the end of it all. Rendered at the bottom + help :: Maybe DocText, + -- | Link to visit for a more detailed explanation. + -- Can make use of the 'code' component. + link :: Maybe Text, + -- | Contextual snippet to provide relevant source data. + snippets :: Maybe (NonEmptyVector Snippet) + } + deriving stock (Show, Generic) + +-- | Enum used to indicate the severity of a diagnostic. +-- The Report Handlers will use this to adapt the formatting of the diagnostic. +data Severity + = Info + | Warning + | Error + deriving stock (Show, Eq, Enum, Bounded) + deriving + (Display) + via (ShowInstance Severity) + +-- | Wrapper to mark an offset from the beginning of a 'Highlight'. +newtype Offset = Offset Word + deriving stock (Eq, Show, Generic) + deriving newtype (Ord, Enum, Pretty) + +-- | Wrapper that represents a line in a Diagnostic report +newtype Line = Line Word + deriving stock (Eq, Show, Generic) + deriving newtype (Ord, Enum, Pretty) + +instance Display Line where + displayBuilder (Line line) = displayBuilder line + +incrementLine :: Line -> Line +incrementLine (Line i) = Line (i + 1) + +-- | Wrapper that represents a column in a Diagnostic report +newtype Column = Column Word + deriving stock (Eq, Show, Generic) + deriving newtype (Ord, Enum, Pretty) + +instance Display Column where + displayBuilder (Column column) = displayBuilder column + +incrementColumn :: Column -> Column +incrementColumn (Column i) = Column (i + 1) + +-- | A datatype holding a message, some source data and a span to highlight. +data Snippet = Snippet + { -- | A location name (filename or other), and the line and columns + -- at which the snippet starts. + location :: (Maybe Text, Line, Column), + -- | Highlights of the source that are of interest + highlights :: Maybe (NonEmptyVector Highlight), + -- | Subject that is being reported. Each member is a line. + content :: Vector DocText + } + deriving stock (Show, Generic) + +-- | A piece of source data that is shown when reporting an error. +-- Pointers on a source are always on a single line. +data Highlight = Highlight + { -- | An optional label for the highlight + label :: Maybe DocText, + -- | Where the highlight is + spans :: NonEmptyVector (Line, Column, Column) + } + deriving stock (Show, Generic) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE QuasiQuotes #-} +module Main where + +import Test.Hspec +import Data.String.QQ +import Data.Vector as Vec +import Data.Vector.NonEmpty as NEVec +import Data.Text as T +import Prettyprinter (pretty) + +import Chapelure.Types +import qualified Chapelure.Handler.Colourful as PT +import Chapelure + +main :: IO () +main = hspec spec + +testForScreenshot :: IO () +testForScreenshot = let helpMessage = "Did you check all the types of your arguments?" in + let highlights = NEVec.fromList [ + Highlight{ label = Just "Return type is “Int”" + , spans = NEVec.singleton (Line 3, Column 8, Column 10) + } + , Highlight{ label = Just "This takes an “Int”" + , spans = NEVec.singleton (Line 4, Column 9, Column 9) + } + , Highlight{ label = Just "But you passed a “Bool”" + , spans = NEVec.singleton (Line 4, Column 11, Column 14) + } + ] in + let snip = Snippet { location = (Just "Code.hs", Line 3, Column 1) + , highlights = highlights + , content = Vec.fromList $ fmap pretty $ T.lines $ T.pack "add :: Int\nadd = 1 + True" + } in + let diagnostic = Diagnostic { code = Just "L342" + , severity = Error + , link = Just "https://localhost:8888/help/code/L342" + , message = Nothing + , help = Just helpMessage + , snippets = Just . NEVec.singleton $ snip + } in + displayDiagnostic PT.prettyConfig diagnostic + +spec :: Spec +spec = do + describe "PlainText Renderer" $ do + it "Simple reporting" $ do + let helpMessage = "Did you check all the types of your arguments?" + let diagnostic = Diagnostic { code = Just "L342" + , severity = Error + , link = Just "https://localhost:8888/help/code/L342" + , message = Nothing + , help = Just helpMessage + , snippets = Nothing + } + let rendered = [s| +[L342]: Error: +Did you check all the types of your arguments? +https://localhost:8888/help/code/L342 +|] + displayDiagnosticAsString PT.asciiPlainConfig diagnostic `shouldBe` rendered + + it "Simple snippet rendering" $ do + let helpMessage = "Did you check all the types of your arguments?" + let snip = Snippet { location = (Just "Code.hs", Line 1, Column 10) + , highlights = Nothing + , content = Vec.fromList $ fmap pretty $ T.lines $ T.pack "add :: Int\nadd = 1 + True" + } + let diagnostic = Diagnostic { code = Just "L342" + , severity = Error + , link = Just "https://localhost:8888/help/code/L342" + , message = Nothing + , help = Just helpMessage + , snippets = Just . NEVec.singleton $ snip + } + let rendered = [s| +[L342]: Error: + /[Code.hs:1:10] + | +1| add :: Int +2| add = 1 + True + | Did you check all the types of your arguments? + | https://localhost:8888/help/code/L342 + / +|] + displayDiagnosticAsString PT.asciiPlainConfig diagnostic `shouldBe` rendered + + it "Highlighted snippet rendering with one highlight per line" $ do + let helpMessage = "Did you check all the types of your arguments?" + let highlights = NEVec.fromList [ + Highlight{ label = Just "Return type is an “Int”" + , spans = NEVec.singleton (Line 3, Column 8, Column 10) + } + , Highlight{ label = Just "You tried to pass a “Bool”" + , spans = NEVec.singleton (Line 4, Column 11, Column 14) + } + ] + let snip = Snippet { location = (Just "Code.hs", Line 3, Column 1) + , highlights = highlights + , content = Vec.fromList $ fmap pretty $ T.lines $ T.pack "add :: Int\nadd = 1 + True" + } + let diagnostic = Diagnostic { code = Just "L342" + , severity = Error + , link = Just "https://localhost:8888/help/code/L342" + , message = Nothing + , help = Just helpMessage + , snippets = Just . NEVec.singleton $ snip + } + let rendered = [s| +[L342]: Error: + /[Code.hs:3:1] + | +3| add :: Int + | ^^^ + | \ Return type is an “Int” +4| add = 1 + True + | ^^^^ + | \ You tried to pass a “Bool” + | Did you check all the types of your arguments? + | https://localhost:8888/help/code/L342 + / +|] + displayDiagnosticAsString PT.asciiPlainConfig diagnostic `shouldBe` rendered + + it "Highlighted snippet rendering with two highlights on one line" $ do + let helpMessage = "Did you check all the types of your arguments?" + let highlights = NEVec.fromList [ + Highlight{ label = Just "Return type is “Int”" + , spans = NEVec.singleton (Line 3, Column 8, Column 10) + } + , Highlight{ label = Just "This takes an “Int”" + , spans = NEVec.singleton (Line 4, Column 9, Column 9) + } + , Highlight{ label = Just "But you passed a “Bool”" + , spans = NEVec.singleton (Line 4, Column 11, Column 14) + } + ] + let snip = Snippet { location = (Just "Code.hs", Line 3, Column 1) + , highlights = highlights + , content = Vec.fromList $ fmap pretty $ T.lines $ T.pack "add :: Int\nadd = 1 + True" + } + let diagnostic = Diagnostic { code = Just "L342" + , severity = Error + , link = Just "https://localhost:8888/help/code/L342" + , message = Nothing + , help = Just helpMessage + , snippets = Just . NEVec.singleton $ snip + } + let rendered = [s| +[L342]: Error: + /[Code.hs:3:1] + | +3| add :: Int + | ^^^ + | \ Return type is “Int” +4| add = 1 + True + | ^ + | \ This takes an “Int” + | ^^^^ + | \ But you passed a “Bool” + | Did you check all the types of your arguments? + | https://localhost:8888/help/code/L342 + / +|] + displayDiagnosticAsString PT.asciiPlainConfig diagnostic `shouldBe` rendered