git.iko.soy/elk
on a67b4dc help sign in
elk/src/Reporting/Report.hs
242 lines 5.6 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Report
4 ( Report(Report)
5 , simple
6 , toString
7 , toJson
8 , printError, printWarning
9 ) where
11import Control.Applicative ((<|>))
12import Control.Monad.Writer (Writer, execWriter, tell)
13import Data.Aeson ((.=))
14import qualified Data.Aeson.Types as Json
15import System.Console.ANSI
16import System.IO (hPutStr, stderr)
18import qualified Reporting.Region as R
21data Report = Report
22 { _title :: String
23 , _highlight :: Maybe R.Region
24 , _preHint :: String
25 , _postHint :: String
26 }
29simple :: String -> String -> String -> Report
30simple title pre post =
31 Report title Nothing pre post
34toString :: String -> R.Region -> Report -> String -> String
35toString location region report source =
36 execWriter (render plain location region report source)
39printError :: String -> R.Region -> Report -> String -> IO ()
40printError location region report source =
41 render (ansi Error) location region report source
44printWarning :: String -> R.Region -> Report -> String -> IO ()
45printWarning location region report source =
46 render (ansi Warning) location region report source
49render
50 :: (Monad m)
51 => Renderer m
52 -> String
53 -> R.Region
54 -> Report
55 -> String
56 -> m ()
57render 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")
64toJson :: [Json.Pair] -> Report -> (Maybe R.Region, [Json.Pair])
65toJson extraFields (Report title subregion pre post) =
66 let
67 fields =
68 [ "tag" .= title
69 , "overview" .= pre
70 , "details" .= post
71 ]
72 in
73 (subregion, fields ++ extraFields)
76-- RENDERING
78data Renderer m = Renderer
79 { normal :: String -> m ()
80 , header :: String -> m ()
81 , accent :: String -> m ()
82 }
85plain :: Renderer (Writer String)
86plain =
87 Renderer tell tell tell
90data Type = Error | Warning
93ansi :: Type -> Renderer IO
94ansi tipe =
95 let
96 put =
97 hPutStr stderr
99 put' intensity color string =
100 do hSetSGR stderr [SetColor Foreground intensity color]
101 put string
102 hSetSGR stderr [Reset]
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)
117-- REPORT HEADER
119messageBar :: Renderer m -> String -> String -> m ()
120messageBar renderer tag location =
121 let
122 usedSpace = 4 + length tag + 1 + length location
123 in
124 header renderer $
125 "-- " ++ tag ++ " "
126 ++ replicate (max 1 (80 - usedSpace)) '-'
127 ++ " " ++ location ++ "\n\n"
130-- REGIONS
132grabRegion
133 :: (Monad m)
134 => Renderer m
135 -> Maybe R.Region
136 -> R.Region
137 -> String
138 -> m ()
139grabRegion renderer maybeSubRegion region@(R.Region start end) source =
140 let
141 (R.Position startLine startColumn) = start
142 (R.Position endLine endColumn) = end
144 (|>) = flip ($)
146 relevantLines =
147 lines source
148 |> drop (startLine - 1)
149 |> take (endLine - startLine + 1)
150 in
151 case relevantLines of
152 [] ->
153 normal renderer ""
155 [sourceLine] ->
156 singleLineRegion renderer startLine sourceLine $
157 case maybeSubRegion of
158 Nothing ->
159 (0, startColumn, endColumn, length sourceLine)
161 Just (R.Region s e) ->
162 (startColumn, R.column s, R.column e, endColumn)
164 firstLine : rest ->
165 let
166 filteredFirstLine =
167 replicate (startColumn - 1) ' '
168 ++ drop (startColumn - 1) firstLine
170 filteredLastLine =
171 take (endColumn) (last rest)
173 focusedRelevantLines =
174 filteredFirstLine : init rest ++ [filteredLastLine]
176 lineNumbersWidth =
177 length (show endLine)
179 subregion =
180 maybeSubRegion <|> Just region
182 numberedLines =
183 zipWith
184 (addLineNumber renderer subregion lineNumbersWidth)
185 [startLine .. endLine]
186 focusedRelevantLines
187 in
188 mapM_ (\line -> line >> normal renderer "\n") numberedLines
191addLineNumber
192 :: (Monad m)
193 => Renderer m
194 -> Maybe R.Region
195 -> Int
196 -> Int
197 -> String
198 -> m ()
199addLineNumber renderer maybeSubRegion width n line =
200 let
201 number =
202 if n < 0 then " " else show n
204 lineNumber =
205 replicate (width - length number) ' ' ++ number ++ "|"
207 spacer (R.Region start end) =
208 if R.line start <= n && n <= R.line end
209 then accent renderer ">"
210 else normal renderer " "
211 in
212 do normal renderer lineNumber
213 maybe (normal renderer " ") spacer maybeSubRegion
214 normal renderer line
217singleLineRegion
218 :: (Monad m)
219 => Renderer m
220 -> Int
221 -> String
222 -> (Int, Int, Int, Int)
223 -> m ()
224singleLineRegion renderer lineNum sourceLine (start, innerStart, innerEnd, end) =
225 let
226 width =
227 length (show lineNum)
229 underline =
230 replicate (innerStart + width + 1) ' '
231 ++ replicate (max 1 (innerEnd - innerStart)) '^'
233 (|>) = flip ($)
235 trimmedSourceLine =
236 sourceLine
237 |> drop (start - 1)
238 |> take (end - start + 1)
239 |> (++) (replicate (start - 1) ' ')
240 in
241 do addLineNumber renderer Nothing width lineNum trimmedSourceLine
242 accent renderer $ "\n" ++ underline