git.iko.soy/elk
on 3973751 help sign in
elk/builder/src/Reporting.hs
472 lines 11 kB history raw
1{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2module Reporting
3 ( Style
4 , silent
5 , json
6 , terminal
7 --
8 , attempt
9 , attemptWithStyle
10 --
11 , Key
12 , report
13 , ignorer
14 , ask
15 --
16 , DKey
17 , DMsg(..)
18 , trackDetails
19 --
20 , BKey
21 , BMsg(..)
22 , trackBuild
23 --
24 , reportGenerate
25 )
26 where
29import Control.Concurrent
30import Control.Exception (SomeException, AsyncException(UserInterrupt), catch, fromException, throw)
31import Control.Monad (when)
32import qualified Data.ByteString.Builder as B
33import qualified Data.NonEmptyList as NE
34import qualified System.Exit as Exit
35import qualified System.Info as Info
36import System.IO (hFlush, hPutStr, stderr, stdout)
38import qualified Elm.ModuleName as ModuleName
39import qualified Elm.Package as Pkg
40import qualified Elm.Version as V
41import qualified Json.Encode as Encode
42import Reporting.Doc ((<+>), (<>))
43import qualified Reporting.Doc as D
44import qualified Reporting.Exit as Exit
45import qualified Reporting.Exit.Help as Help
49-- STYLE
52data Style
53 = Silent
54 | Json
55 | Terminal (MVar ())
58silent :: Style
59silent =
60 Silent
63json :: Style
64json =
65 Json
68terminal :: IO Style
69terminal =
70 Terminal <$> newMVar ()
74-- ATTEMPT
77attempt :: (x -> Help.Report) -> IO (Either x a) -> IO a
78attempt toReport work =
79 do result <- work `catch` reportExceptionsNicely
80 case result of
81 Right a -> return a
82 Left x ->
83 do Exit.toStderr (toReport x)
84 Exit.exitFailure
87attemptWithStyle :: Style -> (x -> Help.Report) -> IO (Either x a) -> IO a
88attemptWithStyle style toReport work =
89 do result <- work `catch` reportExceptionsNicely
90 case result of
91 Right a -> return a
92 Left x ->
93 case style of
94 Silent ->
95 do Exit.exitFailure
97 Json ->
98 do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson (toReport x)))
99 Exit.exitFailure
101 Terminal mvar ->
102 do readMVar mvar
103 Exit.toStderr (toReport x)
104 Exit.exitFailure
108-- MARKS
111goodMark :: D.Doc
112goodMark =
113 D.green $ if isWindows then "+" else "●"
116badMark :: D.Doc
117badMark =
118 D.red $ if isWindows then "X" else "✗"
121_waitingMark :: D.Doc
122_waitingMark =
123 D.dullyellow $ if isWindows then "-" else "→"
126isWindows :: Bool
127isWindows =
128 Info.os == "mingw32"
132-- KEY
135newtype Key msg = Key (msg -> IO ())
138report :: Key msg -> msg -> IO ()
139report (Key send) msg =
140 send msg
143ignorer :: Key msg
144ignorer =
145 Key (\_ -> return ())
149-- ASK
152ask :: D.Doc -> IO Bool
153ask doc =
154 do Help.toStdout doc
155 askHelp
158askHelp :: IO Bool
159askHelp =
160 do hFlush stdout
161 input <- getLine
162 case input of
163 "" -> return True
164 "Y" -> return True
165 "y" -> return True
166 "n" -> return False
167 _ ->
168 do putStr "Must type 'y' for yes or 'n' for no: "
169 askHelp
172-- DETAILS
175type DKey = Key DMsg
178trackDetails :: Style -> (DKey -> IO a) -> IO a
179trackDetails style callback =
180 case style of
181 Silent ->
182 callback (Key (\_ -> return ()))
184 Json ->
185 callback (Key (\_ -> return ()))
187 Terminal mvar ->
188 do chan <- newChan
190 _ <- forkIO $
191 do takeMVar mvar
192 detailsLoop chan (DState 0 0 0 0 0 0 0)
193 putMVar mvar ()
195 answer <- callback (Key (writeChan chan . Just))
196 writeChan chan Nothing
197 return answer
200detailsLoop :: Chan (Maybe DMsg) -> DState -> IO ()
201detailsLoop chan state@(DState total _ _ _ _ built _) =
202 do msg <- readChan chan
203 case msg of
204 Just dmsg ->
205 detailsLoop chan =<< detailsStep dmsg state
207 Nothing ->
208 putStrLn $ clear (toBuildProgress total total) $
209 if built == total
210 then "Dependencies ready!"
211 else "Dependency problem!"
214data DState =
215 DState
216 { _total :: !Int
217 , _cached :: !Int
218 , _requested :: !Int
219 , _received :: !Int
220 , _failed :: !Int
221 , _built :: !Int
222 , _broken :: !Int
223 }
226data DMsg
227 = DStart Int
228 | DCached
229 | DRequested
230 | DReceived Pkg.Name V.Version
231 | DFailed Pkg.Name V.Version
232 | DBuilt
233 | DBroken
236detailsStep :: DMsg -> DState -> IO DState
237detailsStep msg (DState total cached rqst rcvd failed built broken) =
238 case msg of
239 DStart numDependencies ->
240 return (DState numDependencies 0 0 0 0 0 0)
242 DCached ->
243 putTransition (DState total (cached + 1) rqst rcvd failed built broken)
245 DRequested ->
246 do when (rqst == 0) (putStrLn "Starting downloads...\n")
247 return (DState total cached (rqst + 1) rcvd failed built broken)
249 DReceived pkg vsn ->
250 do putDownload goodMark pkg vsn
251 putTransition (DState total cached rqst (rcvd + 1) failed built broken)
253 DFailed pkg vsn ->
254 do putDownload badMark pkg vsn
255 putTransition (DState total cached rqst rcvd (failed + 1) built broken)
257 DBuilt ->
258 putBuilt (DState total cached rqst rcvd failed (built + 1) broken)
260 DBroken ->
261 putBuilt (DState total cached rqst rcvd failed built (broken + 1))
264putDownload :: D.Doc -> Pkg.Name -> V.Version -> IO ()
265putDownload mark pkg vsn =
266 Help.toStdout $ D.indent 2 $
267 mark
268 <+> D.fromPackage pkg
269 <+> D.fromVersion vsn
270 <> "\n"
273putTransition :: DState -> IO DState
274putTransition state@(DState total cached _ rcvd failed built broken) =
275 if cached + rcvd + failed < total then
276 return state
278 else
279 do let char = if rcvd + failed == 0 then '\r' else '\n'
280 putStrFlush (char : toBuildProgress (built + broken + failed) total)
281 return state
284putBuilt :: DState -> IO DState
285putBuilt state@(DState total cached _ rcvd failed built broken) =
286 do when (total == cached + rcvd + failed) $
287 putStrFlush $ '\r' : toBuildProgress (built + broken + failed) total
288 return state
291toBuildProgress :: Int -> Int -> [Char]
292toBuildProgress built total =
293 "Verifying dependencies (" ++ show built ++ "/" ++ show total ++ ")"
296clear :: [Char] -> [Char] -> [Char]
297clear before after =
298 '\r' : replicate (length before) ' ' ++ '\r' : after
302-- BUILD
305type BKey = Key BMsg
307type BResult a = Either Exit.BuildProblem a
310trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)
311trackBuild style callback =
312 case style of
313 Silent ->
314 callback (Key (\_ -> return ()))
316 Json ->
317 callback (Key (\_ -> return ()))
319 Terminal mvar ->
320 do chan <- newChan
322 _ <- forkIO $
323 do takeMVar mvar
324 putStrFlush "Compiling ..."
325 buildLoop chan 0
326 putMVar mvar ()
328 result <- callback (Key (writeChan chan . Left))
329 writeChan chan (Right result)
330 return result
333data BMsg
334 = BDone
337buildLoop :: Chan (Either BMsg (BResult a)) -> Int -> IO ()
338buildLoop chan done =
339 do msg <- readChan chan
340 case msg of
341 Left BDone ->
342 do let !done1 = done + 1
343 putStrFlush $ "\rCompiling (" ++ show done1 ++ ")"
344 buildLoop chan done1
346 Right result ->
347 let
348 !message = toFinalMessage done result
349 !width = 12 + length (show done)
350 in
351 putStrLn $
352 if length message < width
353 then '\r' : replicate width ' ' ++ '\r' : message
354 else '\r' : message
357toFinalMessage :: Int -> BResult a -> [Char]
358toFinalMessage done result =
359 case result of
360 Right _ ->
361 case done of
362 0 -> "Success!"
363 1 -> "Success! Compiled 1 module."
364 n -> "Success! Compiled " ++ show n ++ " modules."
366 Left problem ->
367 case problem of
368 Exit.BuildModuleProblems _ [] ->
369 "Detected problems in 1 module."
371 Exit.BuildModuleProblems _ (_:ps) ->
372 "Detected problems in " ++ show (2 + length ps) ++ " modules."
374 Exit.BuildProjectProblem _ ->
375 "Detected a problem."
379-- GENERATE
382reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO ()
383reportGenerate style names output =
384 case style of
385 Silent ->
386 return ()
388 Json ->
389 return ()
391 Terminal mvar ->
392 do readMVar mvar
393 let cnames = fmap ModuleName.toChars names
394 putStrLn ('\n' : toGenDiagram cnames output)
397toGenDiagram :: NE.List [Char] -> FilePath -> [Char]
398toGenDiagram (NE.List name names) output =
399 let
400 width = 3 + foldr (max . length) (length name) names
401 in
402 case names of
403 [] ->
404 toGenLine width name ('>' : ' ' : output ++ "\n")
406 _:_ ->
407 unlines $
408 toGenLine width name (vtop : hbar : hbar : '>' : ' ' : output)
409 : reverse (zipWith (toGenLine width) (reverse names) ([vbottom] : repeat [vmiddle]))
412toGenLine :: Int -> [Char] -> [Char] -> [Char]
413toGenLine width name end =
414 " " ++ name ++ ' ' : replicate (width - length name) hbar ++ end
417hbar :: Char
418hbar = if isWindows then '-' else '─'
420vtop :: Char
421vtop = if isWindows then '+' else '┬'
423vmiddle :: Char
424vmiddle = if isWindows then '+' else '┤'
426vbottom :: Char
427vbottom = if isWindows then '+' else '┘'
430--
433putStrFlush :: String -> IO ()
434putStrFlush str =
435 hPutStr stdout str >> hFlush stdout
439-- REPORT EXCEPTIONS NICELY
442reportExceptionsNicely :: SomeException -> IO a
443reportExceptionsNicely e =
444 case fromException e of
445 Just UserInterrupt -> throw e
446 _ -> putException e >> throw e
449putException :: SomeException -> IO ()
450putException e =
451 Help.toStderr $ D.stack $
452 [ D.reflow $
453 "Oh no! I ran into something that bypassed the normal error reporting process!\
454 \ I extracted whatever information I could from the internal error:"
455 , D.vcat $ map (\line -> D.red ">" <> " " <> D.fromChars line) (lines (show e))
456 , D.reflow $
457 "These errors are usually pretty confusing, so start by asking around on Slack\
458 \ or Discourse to see if anyone can get you unstuck quickly."
459 , "------------------------------------------------------------"
460 , D.reflow $
461 "From there, if you are feeling up to it, please try to get your code down to the\
462 \ smallest version that still triggers this message. Ideally in a single Main.elm\
463 \ and elm.json file."
464 , D.reflow $
465 "From there open a NEW issue at https://github.com/elm/compiler/issues with\
466 \ your reduced example pasted in directly. (Not a link to a repo or gist!) Do not\
467 \ worry about if someone else saw something similar. More examples is better!"
468 , D.reflow $
469 "This kind of error is usually tied up in larger architectural choices that are\
470 \ hard to change, so even when we have a couple good examples, it can take some\
471 \ time to resolve in a solid way."
472 ]