diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index 714edf2f6..e56548072 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -55,22 +55,22 @@ renderTypeError :: (Var v, Annotated a, Eq a, Show a) => Env -> TypeError v a -> String - -> AT.AnnotatedDocument Color.Color + -> AT.AnnotatedDocument Color.Style renderTypeError env e src = case e of Mismatch {..} -> AT.AnnotatedDocument . Seq.fromList $ [ (fromString . annotatedToEnglish) mismatchSite - , " has a type mismatch (colored in ", AT.Text $ Color.color1 "red", " below):\n\n" + , " has a type mismatch (colored in ", AT.Text $ Color.errorSite "red", " below):\n\n" , AT.Blockquote $ AT.markup (fromString src) (Set.fromList $ catMaybes - [ (,Color.Color1) <$> rangeForAnnotated mismatchSite - , (,Color.Color2) <$> rangeForType overallType1 - , (,Color.Color3) <$> rangeForType overallType2 + [ (,Color.ErrorSite) <$> rangeForAnnotated mismatchSite + , (,Color.Type1) <$> rangeForType overallType1 + , (,Color.Type2) <$> rangeForType overallType2 ]) , "\n" , "The two types involved are:\n\n" - , AT.Text $ styleInOverallType env overallType1 leaf1 Color.Color2 + , AT.Text $ styleInOverallType env overallType1 leaf1 Color.Type1 , " (", fromString (annotatedToEnglish overallType1), ")\n and\n" - , AT.Text $ styleInOverallType env overallType2 leaf2 Color.Color3 + , AT.Text $ styleInOverallType env overallType2 leaf2 Color.Type2 , " (from " , fromString (Char.toLower <$> annotatedToEnglish overallType2) , ")\n\n" ] @@ -130,11 +130,11 @@ styleInOverallType :: (Var v, Annotated a, Eq a) => Env -> C.Type v a -> C.Type v a - -> Color.Color + -> Color.Style -> StyledText styleInOverallType e overallType leafType c = renderType e f overallType - where f loc s = if loc == ABT.annotation leafType then Color.color c s else s + where f loc s = if loc == ABT.annotation leafType then Color.style c s else s posToEnglish :: L.Pos -> String posToEnglish (L.Pos l c) = "Line " ++ show l ++ ", Column " ++ show c @@ -239,7 +239,7 @@ prettyTypecheckError :: (Var v, Eq loc, Show loc, Parser.Annotated loc) -> String -> C.Note v loc -> String prettyTypecheckError env input n = - show . Color.renderDocInColor $ + show . Color.renderDocANSI 3 $ (renderTypeError env (typeErrorFromNote n) input) -- case cause of -- C.TypeMismatch _ -> case path of diff --git a/parser-typechecker/src/Unison/Util/AnnotatedText.hs b/parser-typechecker/src/Unison/Util/AnnotatedText.hs index 5be78018e..1e12ce12e 100644 --- a/parser-typechecker/src/Unison/Util/AnnotatedText.hs +++ b/parser-typechecker/src/Unison/Util/AnnotatedText.hs @@ -1,16 +1,20 @@ -{-# LANGUAGE FlexibleInstances, TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} module Unison.Util.AnnotatedText where -import Control.Arrow (second) -import Data.Sequence (Seq) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Sequence (Seq((:|>))) -import Safe (lastMay) -import Data.String (IsString(..)) -import Unison.Lexer (Line) -import Unison.Util.Range (Range) +import Control.Arrow (second) +import Data.Foldable (asum, foldl') +import Data.Sequence (Seq) +import Data.Sequence (Seq ((:|>))) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String (IsString (..)) +import Safe (lastMay) +import Unison.Lexer (Line, Pos (..)) +import Unison.Util.Monoid (intercalateMap) +import Unison.Util.Range (Range (..)) newtype AnnotatedDocument a = AnnotatedDocument (Seq (Section a)) @@ -27,17 +31,75 @@ data AnnotatedExcerpt a = AnnotatedExcerpt , annotations :: Set (Range, a) } deriving (Eq, Ord, Show) +newtype Rendered a = Rendered (Seq String) + +excerptToDoc :: AnnotatedExcerpt a -> AnnotatedDocument a +excerptToDoc = AnnotatedDocument . pure . Blockquote + trailingNewLine :: AnnotatedText a -> Bool trailingNewLine (AnnotatedText (init :|> (s,_))) = case lastMay s of Just '\n' -> True - Just _ -> False - _ -> trailingNewLine (AnnotatedText init) + Just _ -> False + _ -> trailingNewLine (AnnotatedText init) trailingNewLine _ = False markup :: Ord a => AnnotatedExcerpt a -> Set (Range, a) -> AnnotatedExcerpt a markup a r = a { annotations = r `Set.union` annotations a } +splitAndRender :: Ord a + => Int + -> (AnnotatedExcerpt a -> Rendered b) + -> AnnotatedExcerpt a -> Rendered b +splitAndRender n f e = intercalateMap " .\n" f $ snipWithContext n e + +_deoffsetRange :: Line -> Range -> Range +_deoffsetRange lineOffset (Range (Pos startLine startCol) (Pos endLine endCol)) = + Range (Pos (startLine - lineOffset + 1) startCol) + (Pos (endLine - lineOffset + 1) endCol) + +-- | drops lines and replaces with "." if there are more than `n` unannotated +-- | lines in a row. +snipWithContext :: Ord a => Int -> AnnotatedExcerpt a -> [AnnotatedExcerpt a] +snipWithContext margin source = + case foldl' whileWithinMargin + (Nothing, mempty, mempty) + (Set.toList $ annotations source) of + (Nothing, _, _) -> [] + (Just (Range (Pos startLine' _) (Pos endLine' _)), group', rest') -> + let dropLineCount = startLine' - lineOffset source + takeLineCount = endLine' - startLine' + 1 + text', text2' :: [String] + (text', text2') = + splitAt takeLineCount (drop dropLineCount (lines (text source))) + in AnnotatedExcerpt startLine' (unlines text') group' + : snipWithContext + margin (AnnotatedExcerpt (endLine' + 1) (unlines text2') rest') + where + withinMargin :: Range -> Range -> Bool + withinMargin (Range _start1 (Pos end1 _)) (Range (Pos start2 _) _end2) = + end1 + margin >= start2 + + whileWithinMargin :: Ord a + => (Maybe Range, Set (Range, a), Set (Range, a)) + -> (Range, a) + -> (Maybe Range, Set (Range, a), Set (Range, a)) + whileWithinMargin (r0, taken, rest) a@(r1,_) = + case r0 of + Nothing -> -- haven't processed any annotations yet + (Just r1, Set.singleton a, mempty) + Just r0 -> + -- if all annotations so far can be joined without .. separations + if null rest + -- if this one can be joined to the new region without .. separation + then if withinMargin r0 r1 + -- add it to the first set and grow the compare region + then (Just $ r0 <> r1, Set.insert a taken, mempty) + -- otherwise add it to the second set + else (Just r0, taken, Set.singleton a) + -- once we've added to the second set, anything more goes there too + else (Just r0, taken, Set.insert a rest) + instance IsString (AnnotatedDocument a) where fromString = AnnotatedDocument . pure . fromString @@ -68,3 +130,16 @@ instance Monoid (AnnotatedText a) where instance Functor AnnotatedText where fmap f (AnnotatedText chunks) = AnnotatedText (second f <$> chunks) + +instance Show (Rendered a) where + show (Rendered chunks) = asum chunks + +instance Semigroup (Rendered a) where + (<>) = mappend + +instance Monoid (Rendered a) where + mempty = Rendered mempty + mappend (Rendered chunks) (Rendered chunks') = Rendered (chunks <> chunks') + +instance IsString (Rendered a) where + fromString s = Rendered (pure s) diff --git a/parser-typechecker/src/Unison/Util/ColorText.hs b/parser-typechecker/src/Unison/Util/ColorText.hs index 308a607ee..f5acc6cbd 100644 --- a/parser-typechecker/src/Unison/Util/ColorText.hs +++ b/parser-typechecker/src/Unison/Util/ColorText.hs @@ -1,12 +1,10 @@ +{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} module Unison.Util.ColorText where -import Data.Foldable (asum, foldl', toList) -import qualified Data.List as List -import Data.Sequence (Seq) -import Data.Set (Set) +import Data.Foldable (foldl', toList) import qualified Data.Set as Set import Data.String (IsString (..)) import Safe (headMay) @@ -18,184 +16,106 @@ import System.Console.ANSI (pattern Blue, pattern BoldIntensity, pattern SetUnderlining, pattern SingleUnderline, pattern Vivid, setSGRCode) -import Unison.Lexer (Line, Pos (..)) -import Unison.Util.AnnotatedText +import Unison.Lexer (Pos (..)) +import Unison.Util.AnnotatedText (AnnotatedDocument (..), + AnnotatedExcerpt, + AnnotatedText (..), Rendered (..), + Section (..), annotations, + lineOffset, splitAndRender, text, + trailingNewLine) import Unison.Util.Range (Range (..), inRange) -data Color = Color1 | Color2 | Color3 deriving (Eq, Ord, Show) -type StyledText = AnnotatedText (Maybe Color) -type StyledBlockquote = AnnotatedExcerpt Color +data ANSI +data ASCII +data Style = Type1 | Type2 | ErrorSite deriving (Eq, Ord, Show) +type StyledText = AnnotatedText (Maybe Style) +type StyledBlockquote = AnnotatedExcerpt Style -toANSI :: Color -> Rendered -toANSI c = Rendered . pure . setSGRCode $ case c of - Color1 -> SetColor Foreground Vivid Red : [bold, underline] - Color2 -> SetColor Foreground Vivid Blue : [bold, underline] - Color3 -> SetColor Foreground Vivid Green : [bold, underline] - where bold = SetConsoleIntensity BoldIntensity - underline = SetUnderlining SingleUnderline +unhighlighted :: StyledText -> StyledText +unhighlighted s = const Nothing <$> s -resetANSI :: Rendered -resetANSI = Rendered . pure . setSGRCode $ [Reset] +style :: Style -> StyledText -> StyledText +style c s = const (Just c) <$> s -newtype Rendered = Rendered (Seq String) +type1 :: StyledText -> StyledText +type1 s = const (Just Type1) <$> s -deoffsetRange :: Line -> Range -> Range -deoffsetRange lineOffset (Range (Pos startLine startCol) (Pos endLine endCol)) = - Range (Pos (startLine - lineOffset + 1) startCol) - (Pos (endLine - lineOffset + 1) endCol) +type2 :: StyledText -> StyledText +type2 s = const (Just Type2) <$> s --- | drops lines and replaces with "." if there are more than `n` unannotated --- | lines in a row. -splitAndRenderWithColor :: Int -> StyledBlockquote -> Rendered -splitAndRenderWithColor n e = - mconcat $ List.intersperse - " .\n" - (renderExcerptWithColor <$> snipWithContext n e) +errorSite :: StyledText -> StyledText +errorSite s = const (Just ErrorSite) <$> s -renderExcerptWithColor :: StyledBlockquote -> Rendered -renderExcerptWithColor e = - track (Pos line1 1) [] (Set.toList $ annotations e) - (Rendered . pure $ renderLineNumber line1) (text e) +renderDocANSI :: Int -> AnnotatedDocument Style -> Rendered ANSI +renderDocANSI excerptCollapseWidth (AnnotatedDocument chunks) = + go $ toList chunks where - line1 :: Int - line1 = lineOffset e - renderLineNumber n = " " ++ replicate (lineNumberWidth - length sn) ' ' ++ sn ++ " | " where sn = show n - lineNumberWidth = 4 --length (show maxLineIndex) - -- where maxLineIndex = line1 - 1 + length (lines (text e)) - setupNewLine :: Rendered -> Pos -> Char -> (Rendered, Pos) - setupNewLine openColor (Pos line col) c = case c of - '\n' -> let r = Rendered . pure $ renderLineNumber (line + 1) - in (r <> openColor, Pos (line + 1) 1) - _ -> (mempty, Pos line (col + 1)) - track :: Pos -> [(Color, Pos)] -> [(Range, Color)] -> Rendered -> String -> Rendered - track _pos stack _annotations rendered "" = - rendered <> if null stack then mempty else resetANSI - track pos stack annotations rendered _input@(c:rest) = - let -- get whichever annotations may now be open - (poppedAnnotations, remainingAnnotations) = span (inRange pos . fst) annotations - -- drop any stack entries that will be closed after this char - stack0 = dropWhile ((<=pos) . snd) stack - -- and add new stack entries - stack' = foldl' pushColor stack0 poppedAnnotations - where pushColor s (Range _ end, color) = (color, end) : s - resetColor = -- stack is newly null, and there are no newly opened annotations - if null poppedAnnotations && null stack' && not (null stack) - then resetANSI else mempty - maybeColor = fst <$> headMay stack' - openColor = maybe mempty toANSI maybeColor - (lineHeader, pos') = setupNewLine openColor pos c - lineHeader' = if null rest then mempty else lineHeader - newChar = - if c == '\n' - then (Rendered . pure) [c] <> resetANSI <> lineHeader' - else openColor <> (Rendered . pure) [c] - in track pos' stack' remainingAnnotations - (rendered <> newChar <> resetColor) rest - -snipWithContext :: Ord a => Int -> AnnotatedExcerpt a -> [AnnotatedExcerpt a] -snipWithContext margin source = - case foldl' whileWithinMargin - (Nothing, mempty, mempty) - (Set.toList $ annotations source) of - (Nothing, _, _) -> [] - (Just (Range (Pos startLine' _) (Pos endLine' _)), group', rest') -> - let dropLineCount = startLine' - lineOffset source - takeLineCount = endLine' - startLine' + 1 - text', text2' :: [String] - (text', text2') = - splitAt takeLineCount (drop dropLineCount (lines (text source))) - in AnnotatedExcerpt startLine' (unlines text') group' - : snipWithContext - margin (AnnotatedExcerpt (endLine' + 1) (unlines text2') rest') - where - withinMargin :: Range -> Range -> Bool - withinMargin (Range _start1 (Pos end1 _)) (Range (Pos start2 _) _end2) = - end1 + margin >= start2 - - whileWithinMargin :: Ord a - => (Maybe Range, Set (Range, a), Set (Range, a)) - -> (Range, a) - -> (Maybe Range, Set (Range, a), Set (Range, a)) - whileWithinMargin (r0, taken, rest) a@(r1,_) = - case r0 of - Nothing -> -- haven't processed any annotations yet - (Just r1, Set.singleton a, mempty) - Just r0 -> - if null rest -- if all annotations so far can be joined without .. separations - then if withinMargin r0 r1 -- if this one can be joined to the compare region without .. separation - then (Just $ r0 <> r1, Set.insert a taken, mempty) -- add it to the first set and grow the compare region - else (Just r0, taken, Set.singleton a) -- otherwise add it to the second set - else (Just r0, taken, Set.insert a rest) -- once we've added to the second set, anything more goes there too - -renderStyleTextWithColor :: StyledText -> Rendered -renderStyleTextWithColor (AnnotatedText chunks) = foldl' go mempty chunks - where go :: Rendered -> (String, Maybe Color) -> Rendered - go r (text, Nothing) = r <> resetANSI <> fromString text - go r (text, Just color) = r <> toANSI color <> fromString text - -renderDocInColor :: AnnotatedDocument Color -> Rendered -renderDocInColor (AnnotatedDocument chunks) = go $ toList chunks where go [] = mempty - go (Blockquote exc : rest) = splitAndRenderWithColor 3 exc <> go rest + go (Blockquote exc : rest) = + splitAndRender excerptCollapseWidth renderExcerptWithColor exc <> go rest go (Text t : rest@(Blockquote _ : _)) = renderStyleTextWithColor t <> (if trailingNewLine t then mempty else "\n") <> go rest go (Text t : rest) = renderStyleTextWithColor t <> go rest -{- + toANSI :: Style -> Rendered ANSI + toANSI c = Rendered . pure . setSGRCode $ case c of + ErrorSite -> SetColor Foreground Vivid Red : [bold, underline] + Type1 -> SetColor Foreground Vivid Blue : [bold, underline] + Type2 -> SetColor Foreground Vivid Green : [bold, underline] + where bold = SetConsoleIntensity BoldIntensity + underline = SetUnderlining SingleUnderline - 1 | foo : Int - 2 | foo = 42 -❌ 3:80 | -> Hello, world! - ^^^^^ -> Goodbye, world! - ^^^^^^^ + resetANSI :: Rendered ANSI + resetANSI = Rendered . pure . setSGRCode $ [Reset] -Highlight: Line 1, Cols 1-5 -Highlight: Line 2, Cols 1-7 --} + renderStyleTextWithColor :: StyledText -> Rendered ANSI + renderStyleTextWithColor (AnnotatedText chunks) = foldl' go mempty chunks + where go :: Rendered ANSI -> (String, Maybe Style) -> Rendered ANSI + go r (text, Nothing) = r <> resetANSI <> fromString text + go r (text, Just style) = r <> toANSI style <> fromString text -unhighlighted :: StyledText -> StyledText -unhighlighted s = const Nothing <$> s + renderExcerptWithColor :: StyledBlockquote -> Rendered ANSI + renderExcerptWithColor e = + track (Pos line1 1) [] (Set.toList $ annotations e) + (Rendered . pure $ renderLineNumber line1) (text e) + where + line1 :: Int + line1 = lineOffset e -color :: Color -> StyledText -> StyledText -color c s = const (Just c) <$> s + renderLineNumber n = + " " ++ replicate (lineNumberWidth - length sn) ' ' ++ sn ++ " | " + where sn = show n + lineNumberWidth = 4 -color1 :: StyledText -> StyledText -color1 s = const (Just Color1) <$> s + setupNewLine :: Rendered ANSI -> Pos -> Char -> (Rendered ANSI, Pos) + setupNewLine openColor (Pos line col) c = case c of + '\n' -> let r = Rendered . pure $ renderLineNumber (line + 1) + in (r <> openColor, Pos (line + 1) 1) + _ -> (mempty, Pos line (col + 1)) -color2 :: StyledText -> StyledText -color2 s = const (Just Color2) <$> s - -color3 :: StyledText -> StyledText -color3 s = const (Just Color3) <$> s - --- data AnnotatedText --- = Line { line :: String -- cannot contain newlines --- , overline :: Maybe String --- , underline :: Maybe String --- , colorRegions :: Map (Column) } --- -- , colorline :: String - --- * Don't print out source that isn't related to the error --- * Color regions that are related to the error --- * Insert lines with carets in place of using colors in some cases - - -- vvvvv - -- Foo - -- - -instance Show Rendered where - show (Rendered chunks) = asum chunks - -instance Semigroup Rendered where - (<>) = mappend - -instance Monoid Rendered where - mempty = Rendered mempty - mappend (Rendered chunks) (Rendered chunks') = Rendered (chunks <> chunks') - -instance IsString Rendered where - fromString s = Rendered (pure s) + track :: Pos -> [(Style, Pos)] -> [(Range, Style)] -> Rendered ANSI -> String -> Rendered ANSI + track _pos stack _annotations rendered _input@"" = + rendered <> if null stack then mempty else resetANSI + track pos stack annotations rendered _input@(c:rest) = + let -- get whichever annotations may now be open + (poppedAnnotations, remainingAnnotations) = span (inRange pos . fst) annotations + -- drop any stack entries that will be closed after this char + stack0 = dropWhile ((<=pos) . snd) stack + -- and add new stack entries + stack' = foldl' pushColor stack0 poppedAnnotations + where pushColor s (Range _ end, style) = (style, end) : s + resetColor = -- stack is newly null, and there are no newly opened annotations + if null poppedAnnotations && null stack' && not (null stack) + then resetANSI else mempty + maybeColor = fst <$> headMay stack' + openColor = maybe mempty toANSI maybeColor + (lineHeader, pos') = setupNewLine openColor pos c + lineHeader' = if null rest then mempty else lineHeader + newChar = + if c == '\n' + then (Rendered . pure) [c] <> resetANSI <> lineHeader' + else openColor <> (Rendered . pure) [c] + in track pos' stack' remainingAnnotations + (rendered <> newChar <> resetColor) rest diff --git a/parser-typechecker/tests/Unison/Test/ColorText.hs b/parser-typechecker/tests/Unison/Test/ColorText.hs index 6b0249e6a..8c82acd6e 100644 --- a/parser-typechecker/tests/Unison/Test/ColorText.hs +++ b/parser-typechecker/tests/Unison/Test/ColorText.hs @@ -3,34 +3,35 @@ module Unison.Test.ColorText where -- import EasyTest -import qualified Data.Set as Set +import qualified Data.Set as Set import Text.RawString.QQ -import Unison.Lexer (Pos (..)) -import Unison.Util.AnnotatedText (AnnotatedExcerpt (..), markup) -import Unison.Util.ColorText (Color (..), Rendered, - renderExcerptWithColor) -import Unison.Util.Range (Range (..)) +import Unison.Lexer (Pos (..)) +import Unison.Util.AnnotatedText (AnnotatedExcerpt (..), Rendered, + excerptToDoc, markup) +import Unison.Util.ColorText (ANSI, Style (..), renderDocANSI) +import Unison.Util.Range (Range (..)) -ex2 :: AnnotatedExcerpt Color +ex2 :: AnnotatedExcerpt Style ex2 = markup ex (Set.fromList - [ (Range (Pos 3 1) (Pos 3 5), Color2) -- SCENE - , (Range (Pos 5 1) (Pos 5 5), Color1) -- Enter - , (Range (Pos 25 1) (Pos 25 6), Color2) -- ALONSO - , (Range (Pos 12 1) (Pos 13 44), Color1) -- Good, ... bestir. + [ (Range (Pos 3 1) (Pos 3 5), ErrorSite) -- SCENE + , (Range (Pos 5 9) (Pos 5 14), Type1) -- Master + , (Range (Pos 5 22) (Pos 5 30), Type1) -- Boatswain + , (Range (Pos 25 1) (Pos 25 6), ErrorSite) -- ALONSO + , (Range (Pos 12 30) (Pos 13 27), Type2) -- fall ... aground. ]) -renderEx2 :: Rendered -renderEx2 = renderExcerptWithColor ex2 +renderEx2 :: Rendered ANSI +renderEx2 = renderDocANSI 3 . excerptToDoc $ ex2 -ex3 :: AnnotatedExcerpt Color +ex3 :: AnnotatedExcerpt Style ex3 = markup "Hello, world!" $ Set.fromList - [ (Range (Pos 1 8) (Pos 1 12), Color1) - , (Range (Pos 1 1) (Pos 1 5), Color2) ] + [ (Range (Pos 1 8) (Pos 1 12), Type1) + , (Range (Pos 1 1) (Pos 1 5), Type2) ] -ex4 :: AnnotatedExcerpt Color +ex4 :: AnnotatedExcerpt Style ex4 = markup "Hello,\nworld!" $ Set.fromList - [ (Range (Pos 2 1) (Pos 2 5), Color1) - , (Range (Pos 1 1) (Pos 1 5), Color2) ] + [ (Range (Pos 2 1) (Pos 2 5), Type1) + , (Range (Pos 1 1) (Pos 1 5), Type2) ] ex :: Ord a => AnnotatedExcerpt a ex = [r|The Tempest | Act 1, Scene 1