git.iko.soy/elk
on 1238607 help sign in
elk/builder/src/Reporting.hs
453 lines 11 kB history raw
1{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2module Reporting
3 ( Style
4 , json
5 , terminal
6 --
7 , attempt
8 , attemptWithStyle
9 --
10 , Key
11 , report
12 , ignorer
13 , ask
14 --
15 , DKey
16 , DMsg(..)
17 , trackDetails
18 --
19 , BKey
20 , BMsg(..)
21 , trackBuild
22 --
23 , reportGenerate
24 )
25 where
28import Control.Concurrent
29import Control.Exception (SomeException, AsyncException(UserInterrupt), catch, fromException, throw)
30import Control.Monad (when)
31import qualified Data.ByteString.Builder as B
32import qualified Data.NonEmptyList as NE
33import qualified System.Exit as Exit
34import qualified System.Info as Info
35import System.IO (hFlush, hPutStr, stderr, stdout)
37import qualified Elm.ModuleName as ModuleName
38import qualified Elm.Package as Pkg
39import qualified Elm.Version as V
40import qualified Json.Encode as Encode
41import Reporting.Doc ((<+>), (<>))
42import qualified Reporting.Doc as D
43import qualified Reporting.Exit as Exit
44import qualified Reporting.Exit.Help as Help
48-- STYLE
51data Style
52 = Json
53 | Terminal (MVar ())
56json :: Style
57json =
58 Json
61terminal :: IO Style
62terminal =
63 Terminal <$> newMVar ()
67-- ATTEMPT
70attempt :: (x -> Help.Report) -> IO (Either x a) -> IO a
71attempt toReport work =
72 do result <- work `catch` reportExceptionsNicely
73 case result of
74 Right a -> return a
75 Left x ->
76 do Exit.toStderr (toReport x)
77 Exit.exitFailure
80attemptWithStyle :: Style -> (x -> Help.Report) -> IO (Either x a) -> IO a
81attemptWithStyle style toReport work =
82 do result <- work `catch` reportExceptionsNicely
83 case result of
84 Right a -> return a
85 Left x ->
86 case style of
87 Json ->
88 do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson (toReport x)))
89 Exit.exitFailure
91 Terminal mvar ->
92 do readMVar mvar
93 Exit.toStderr (toReport x)
94 Exit.exitFailure
98-- MARKS
101goodMark :: D.Doc
102goodMark =
103 D.green $ if isWindows then "+" else "●"
106badMark :: D.Doc
107badMark =
108 D.red $ if isWindows then "X" else "✗"
111_waitingMark :: D.Doc
112_waitingMark =
113 D.dullyellow $ if isWindows then "-" else "→"
116isWindows :: Bool
117isWindows =
118 Info.os == "mingw32"
122-- KEY
125newtype Key msg = Key (msg -> IO ())
128report :: Key msg -> msg -> IO ()
129report (Key send) msg =
130 send msg
133ignorer :: Key msg
134ignorer =
135 Key (\_ -> return ())
139-- ASK
142ask :: D.Doc -> IO Bool
143ask doc =
144 do Help.toStdout doc
145 askHelp
148askHelp :: IO Bool
149askHelp =
150 do hFlush stdout
151 input <- getLine
152 case input of
153 "" -> return True
154 "Y" -> return True
155 "y" -> return True
156 "n" -> return False
157 _ ->
158 do putStr "Must type 'y' for yes or 'n' for no: "
159 askHelp
162-- DETAILS
165type DKey = Key DMsg
168trackDetails :: Style -> (DKey -> IO a) -> IO a
169trackDetails style callback =
170 case style of
171 Json ->
172 callback (Key (\_ -> return ()))
174 Terminal mvar ->
175 do chan <- newChan
177 _ <- forkIO $
178 do takeMVar mvar
179 detailsLoop chan (DState 0 0 0 0 0 0 0)
180 putMVar mvar ()
182 answer <- callback (Key (writeChan chan . Just))
183 writeChan chan Nothing
184 return answer
187detailsLoop :: Chan (Maybe DMsg) -> DState -> IO ()
188detailsLoop chan state@(DState total _ _ _ _ built _) =
189 do msg <- readChan chan
190 case msg of
191 Just dmsg ->
192 detailsLoop chan =<< detailsStep dmsg state
194 Nothing ->
195 putStrLn $ clear (toBuildProgress total total) $
196 if built == total
197 then "Dependencies ready!"
198 else "Dependency problem!"
201data DState =
202 DState
203 { _total :: !Int
204 , _cached :: !Int
205 , _requested :: !Int
206 , _received :: !Int
207 , _failed :: !Int
208 , _built :: !Int
209 , _broken :: !Int
210 }
213data DMsg
214 = DStart Int
215 | DCached
216 | DRequested
217 | DReceived Pkg.Name V.Version
218 | DFailed Pkg.Name V.Version
219 | DBuilt
220 | DBroken
223detailsStep :: DMsg -> DState -> IO DState
224detailsStep msg (DState total cached rqst rcvd failed built broken) =
225 case msg of
226 DStart numDependencies ->
227 return (DState numDependencies 0 0 0 0 0 0)
229 DCached ->
230 putTransition (DState total (cached + 1) rqst rcvd failed built broken)
232 DRequested ->
233 do when (rqst == 0) (putStrLn "Starting downloads...\n")
234 return (DState total cached (rqst + 1) rcvd failed built broken)
236 DReceived pkg vsn ->
237 do putDownload goodMark pkg vsn
238 putTransition (DState total cached rqst (rcvd + 1) failed built broken)
240 DFailed pkg vsn ->
241 do putDownload badMark pkg vsn
242 putTransition (DState total cached rqst rcvd (failed + 1) built broken)
244 DBuilt ->
245 putBuilt (DState total cached rqst rcvd failed (built + 1) broken)
247 DBroken ->
248 putBuilt (DState total cached rqst rcvd failed built (broken + 1))
251putDownload :: D.Doc -> Pkg.Name -> V.Version -> IO ()
252putDownload mark pkg vsn =
253 Help.toStdout $ D.indent 2 $
254 mark
255 <+> D.fromUtf8 (Pkg.toString pkg)
256 <+> D.fromUtf8 (V.toString vsn)
257 <> "\n"
260putTransition :: DState -> IO DState
261putTransition state@(DState total cached _ rcvd failed built broken) =
262 if cached + rcvd + failed < total then
263 return state
265 else
266 do let char = if rcvd + failed == 0 then '\r' else '\n'
267 putStrFlush (char : toBuildProgress (built + broken + failed) total)
268 return state
271putBuilt :: DState -> IO DState
272putBuilt state@(DState total cached _ rcvd failed built broken) =
273 do when (total == cached + rcvd + failed) $
274 putStrFlush $ '\r' : toBuildProgress (built + broken + failed) total
275 return state
278toBuildProgress :: Int -> Int -> [Char]
279toBuildProgress built total =
280 "Verifying dependencies (" ++ show built ++ "/" ++ show total ++ ")"
283clear :: [Char] -> [Char] -> [Char]
284clear before after =
285 '\r' : replicate (length before) ' ' ++ '\r' : after
289-- BUILD
292type BKey = Key BMsg
294type BResult a = Either Exit.BuildProblem a
297trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)
298trackBuild style callback =
299 case style of
300 Json ->
301 callback (Key (\_ -> return ()))
303 Terminal mvar ->
304 do chan <- newChan
306 _ <- forkIO $
307 do takeMVar mvar
308 putStrFlush "Compiling ..."
309 buildLoop chan 0
310 putMVar mvar ()
312 result <- callback (Key (writeChan chan . Left))
313 writeChan chan (Right result)
314 return result
317data BMsg
318 = BDone
321buildLoop :: Chan (Either BMsg (BResult a)) -> Int -> IO ()
322buildLoop chan done =
323 do msg <- readChan chan
324 case msg of
325 Left BDone ->
326 do let !done1 = done + 1
327 putStrFlush $ "\rCompiling (" ++ show done1 ++ ")"
328 buildLoop chan done1
330 Right result ->
331 let
332 !message = toFinalMessage done result
333 !width = 12 + length (show done)
334 in
335 putStrLn $
336 if length message < width
337 then '\r' : replicate width ' ' ++ '\r' : message
338 else '\r' : message
341toFinalMessage :: Int -> BResult a -> [Char]
342toFinalMessage done result =
343 case result of
344 Right _ ->
345 case done of
346 0 -> "Success!"
347 1 -> "Success! Compiled 1 module."
348 n -> "Success! Compiled " ++ show n ++ " modules."
350 Left problem ->
351 case problem of
352 Exit.BuildModuleProblems _ [] ->
353 "Detected problems in 1 module."
355 Exit.BuildModuleProblems _ (_:ps) ->
356 "Detected problems in " ++ show (2 + length ps) ++ " modules."
358 Exit.BuildProjectProblem _ ->
359 "Detected a problem."
363-- GENERATE
366reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO ()
367reportGenerate style names output =
368 case style of
369 Json ->
370 return ()
372 Terminal mvar ->
373 do readMVar mvar
374 let cnames = fmap ModuleName.toChars names
375 putStrLn ('\n' : toGenDiagram cnames output)
378toGenDiagram :: NE.List [Char] -> FilePath -> [Char]
379toGenDiagram (NE.List name names) output =
380 let
381 width = 3 + foldr (max . length) (length name) names
382 in
383 case names of
384 [] ->
385 toGenLine width name ('>' : ' ' : output ++ "\n")
387 _:_ ->
388 unlines $
389 toGenLine width name (vtop : hbar : hbar : '>' : ' ' : output)
390 : reverse (zipWith (toGenLine width) (reverse names) ([vbottom] : repeat [vmiddle]))
393toGenLine :: Int -> [Char] -> [Char] -> [Char]
394toGenLine width name end =
395 " " ++ name ++ ' ' : replicate (width - length name) hbar ++ end
398hbar :: Char
399hbar = if isWindows then '-' else '─'
401vtop :: Char
402vtop = if isWindows then '+' else '┬'
404vmiddle :: Char
405vmiddle = if isWindows then '+' else '┤'
407vbottom :: Char
408vbottom = if isWindows then '+' else '┘'
411--
414putStrFlush :: String -> IO ()
415putStrFlush str =
416 hPutStr stdout str >> hFlush stdout
420-- REPORT EXCEPTIONS NICELY
423reportExceptionsNicely :: SomeException -> IO a
424reportExceptionsNicely e =
425 case fromException e of
426 Just UserInterrupt -> throw e
427 _ -> putException e >> throw e
430putException :: SomeException -> IO ()
431putException e =
432 Help.toStderr $ D.stack $
433 [ D.reflow $
434 "Oh no! I ran into something that bypassed the normal error reporting process!\
435 \ I extracted whatever information I could from the internal error:"
436 , D.vcat $ map (\line -> D.red ">" <> " " <> D.fromChars line) (lines (show e))
437 , D.reflow $
438 "These errors are usually pretty confusing, so start by asking around on Slack\
439 \ or Discourse to see if anyone can get you unstuck quickly."
440 , "------------------------------------------------------------"
441 , D.reflow $
442 "From there, if you are feeling up to it, please try to get your code down to the\
443 \ smallest version that still triggers this message. Ideally in a single Main.elm\
444 \ and elm.json file."
445 , D.reflow $
446 "From there open a NEW issue at https://github.com/elm/compiler/issues with\
447 \ your reduced example pasted in directly. (Not a link to a repo or gist!) Do not\
448 \ worry about if someone else saw something similar. More examples is better!"
449 , D.reflow $
450 "This kind of error is usually tied up in larger architectural choices that are\
451 \ hard to change, so even when we have a couple good examples, it can take some\
452 \ time to resolve in a solid way."
453 ]