@@ -5,10 +5,15 @@ module Reporting.Report
55 , simple
66 , toString
77 , toJson
8+ , printError, printWarning
89 ) where
910
11+import Control.Applicative ((<|>))
12+import Control.Monad.Writer (Writer, execWriter, tell)
1013import Data.Aeson ((.=))
1114import qualified Data.Aeson.Types as Json
15+import System.Console.ANSI
16+import System.IO (hPutStr, stderr)
1217
1318import qualified Reporting.Region as R
1419
@@ -27,13 +32,33 @@ simple title pre post =
2732
2833
2934toString :: String -> R.Region -> Report -> String -> String
30−toString location region (Report title highlight pre post) source =
31− concat
32− [ messageBar title location
33− , pre ++ "\n\n"
34− , grabRegion highlight region source ++ "\n"
35− , if null post then "\n" else post ++ "\n\n\n"
36− ]
35+toString location region report source =
36+ execWriter (render plain location region report source)
37+
38+
39+printError :: String -> R.Region -> Report -> String -> IO ()
40+printError location region report source =
41+ render (ansi Error) location region report source
42+
43+
44+printWarning :: String -> R.Region -> Report -> String -> IO ()
45+printWarning location region report source =
46+ render (ansi Warning) location region report source
47+
48+
49+render
50+ :: (Monad m)
51+ => Renderer m
52+ -> String
53+ -> R.Region
54+ -> Report
55+ -> String
56+ -> m ()
57+render renderer location region (Report title highlight pre post) source =
58+ do messageBar renderer title location
59+ normal renderer (pre ++ "\n\n")
60+ grabRegion renderer highlight region source
61+ normal renderer ("\n" ++ if null post then "\n" else post ++ "\n\n\n")
3762
3863
3964toJson :: [Json.Pair] -> Report -> (Maybe R.Region, [Json.Pair])
@@ -48,12 +73,55 @@ toJson extraFields (Report title subregion pre post) =
4873 (subregion, fields ++ extraFields)
4974
5075
76+-- RENDERING
77+
78+data Renderer m = Renderer
79+ { normal :: String -> m ()
80+ , header :: String -> m ()
81+ , accent :: String -> m ()
82+ }
83+
84+
85+plain :: Renderer (Writer String)
86+plain =
87+ Renderer tell tell tell
88+
89+
90+data Type = Error | Warning
91+
92+
93+ansi :: Type -> Renderer IO
94+ansi tipe =
95+ let
96+ put =
97+ hPutStr stderr
98+
99+ put' intensity color string =
100+ do hSetSGR stderr [SetColor Foreground intensity color]
101+ put string
102+ hSetSGR stderr [Reset]
103+
104+ accentColor =
105+ case tipe of
106+ Error -> Red
107+ Warning -> Yellow
108+ in
109+ Renderer
110+ put
111+ (put' Dull Cyan)
112+ (put' Dull accentColor)
113+
114+
115+
116+
51117-- REPORT HEADER
52118
53−messageBar :: String -> String -> String
54−messageBar tag location =
55− let usedSpace = 4 + length tag + 1 + length location
119+messageBar :: Renderer m -> String -> String -> m ()
120+messageBar renderer tag location =
121+ let
122+ usedSpace = 4 + length tag + 1 + length location
56123 in
124+ header renderer $
57125 "-- " ++ tag ++ " "
58126 ++ replicate (max 1 (80 - usedSpace)) '-'
59127 ++ " " ++ location ++ "\n\n"
@@ -61,8 +129,14 @@ messageBar tag location =
61129
62130-- REGIONS
63131
64−grabRegion :: Maybe R.Region -> R.Region -> String -> String
65−grabRegion maybeSubRegion (R.Region start end) source =
132+grabRegion
133+ :: (Monad m)
134+ => Renderer m
135+ -> Maybe R.Region
136+ -> R.Region
137+ -> String
138+ -> m ()
139+grabRegion renderer maybeSubRegion region@(R.Region start end) source =
66140 let
67141 (R.Position startLine startColumn) = start
68142 (R.Position endLine endColumn) = end
@@ -76,10 +150,10 @@ grabRegion maybeSubRegion (R.Region start end) source =
76150 in
77151 case relevantLines of
78152 [] ->
79− ""
153+ normal renderer ""
80154
81155 [sourceLine] ->
82− singleLineRegion startLine sourceLine $
156+ singleLineRegion renderer startLine sourceLine $
83157 case maybeSubRegion of
84158 Nothing ->
85159 (0, startColumn, endColumn, length sourceLine)
@@ -100,44 +174,61 @@ grabRegion maybeSubRegion (R.Region start end) source =
100174 filteredFirstLine : init rest ++ [filteredLastLine]
101175
102176 lineNumbersWidth =
103− length (show (endLine + 1))
177+ length (show endLine)
178+
179+ subregion =
180+ maybeSubRegion <|> Just region
104181
105182 numberedLines =
106183 zipWith
107− (addLineNumber maybeSubRegion lineNumbersWidth)
108− [startLine - 1 .. endLine + 1]
109− ("" : focusedRelevantLines ++ [""])
184+ (addLineNumber renderer subregion lineNumbersWidth)
185+ [startLine .. endLine]
186+ focusedRelevantLines
110187 in
111− unlines numberedLines
112−
113−
114−addLineNumber :: Maybe R.Region -> Int -> Int -> String -> String
115−addLineNumber maybeSubRegion width n line =
188+ mapM_ (\line -> line >> normal renderer "\n") numberedLines
189+
190+
191+addLineNumber
192+ :: (Monad m)
193+ => Renderer m
194+ -> Maybe R.Region
195+ -> Int
196+ -> Int
197+ -> String
198+ -> m ()
199+addLineNumber renderer maybeSubRegion width n line =
116200 let
117201 number =
118− if n < 0 then " " else show n
202+ if n < 0 then " " else show n
203+
204+ lineNumber =
205+ replicate (width - length number) ' ' ++ number ++ "|"
119206
120207 spacer (R.Region start end) =
121− if R.line start <= n && n <= R.line end
122− then ">"
123− else " "
208+ if R.line start <= n && n <= R.line end
209+ then accent renderer ">"
210+ else normal renderer " "
124211 in
125− replicate (width - length number) ' ' ++ number
126− ++ "|" ++ maybe " " spacer maybeSubRegion
127− ++ line
128−
129−
130−singleLineRegion :: Int -> String -> (Int, Int, Int, Int) -> String
131−singleLineRegion lineNum sourceLine (start, innerStart, innerEnd, end) =
212+ do normal renderer lineNumber
213+ maybe (normal renderer " ") spacer maybeSubRegion
214+ normal renderer line
215+
216+
217+singleLineRegion
218+ :: (Monad m)
219+ => Renderer m
220+ -> Int
221+ -> String
222+ -> (Int, Int, Int, Int)
223+ -> m ()
224+singleLineRegion renderer lineNum sourceLine (start, innerStart, innerEnd, end) =
132225 let
133− w = length (show (lineNum + 1))
134−
135− number =
136− addLineNumber Nothing w
226+ width =
227+ length (show lineNum)
137228
138229 underline =
139− replicate (innerStart - 1) ' '
140− ++ replicate (max 1 (innerEnd - innerStart)) '^'
230+ replicate (innerStart + width + 1) ' '
231+ ++ replicate (max 1 (innerEnd - innerStart)) '^'
141232
142233 (|>) = flip ($)
143234
@@ -147,8 +238,5 @@ singleLineRegion lineNum sourceLine (start, innerStart, innerEnd, end) =
147238 |> take (end - start + 1)
148239 |> (++) (replicate (start - 1) ' ')
149240 in
150− unlines
151− [ number (lineNum-1) ""
152− , number lineNum trimmedSourceLine
153− , number (lineNum+1) underline
154− ]
241+ do addLineNumber renderer Nothing width lineNum trimmedSourceLine
242+ accent renderer $ "\n" ++ underline