git.iko.soy/elk
on master help sign in
elk/builder/src/Reporting.hs
474 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, hPutStrLn, 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 ->
82 return a
84 Left x ->
85 do Exit.toStderr (toReport x)
86 Exit.exitFailure
89attemptWithStyle :: Style -> (x -> Help.Report) -> IO (Either x a) -> IO a
90attemptWithStyle style toReport work =
91 do result <- work `catch` reportExceptionsNicely
92 case result of
93 Right a ->
94 return a
96 Left x ->
97 case style of
98 Silent ->
99 do Exit.exitFailure
101 Json ->
102 do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson (toReport x)))
103 Exit.exitFailure
105 Terminal mvar ->
106 do readMVar mvar
107 Exit.toStderr (toReport x)
108 Exit.exitFailure
112-- MARKS
115goodMark :: D.Doc
116goodMark =
117 D.green $ if isWindows then "+" else "●"
120badMark :: D.Doc
121badMark =
122 D.red $ if isWindows then "X" else "✗"
125isWindows :: Bool
126isWindows =
127 Info.os == "mingw32"
131-- KEY
134newtype Key msg = Key (msg -> IO ())
137report :: Key msg -> msg -> IO ()
138report (Key send) msg =
139 send msg
142ignorer :: Key msg
143ignorer =
144 Key (\_ -> return ())
148-- ASK
151ask :: D.Doc -> IO Bool
152ask doc =
153 do Help.toStdout doc
154 askHelp
157askHelp :: IO Bool
158askHelp =
159 do hFlush stdout
160 input <- getLine
161 case input of
162 "" -> return True
163 "Y" -> return True
164 "y" -> return True
165 "n" -> return False
166 _ ->
167 do putStr "Must type 'y' for yes or 'n' for no: "
168 askHelp
171-- DETAILS
174type DKey = Key DMsg
177trackDetails :: Style -> (DKey -> IO a) -> IO a
178trackDetails style callback =
179 case style of
180 Silent ->
181 callback (Key (\_ -> return ()))
183 Json ->
184 callback (Key (\_ -> return ()))
186 Terminal mvar ->
187 do chan <- newChan
189 _ <- forkIO $
190 do takeMVar mvar
191 detailsLoop chan (DState 0 0 0 0 0 0 0)
192 putMVar mvar ()
194 answer <- callback (Key (writeChan chan . Just))
195 writeChan chan Nothing
196 return answer
199detailsLoop :: Chan (Maybe DMsg) -> DState -> IO ()
200detailsLoop chan state@(DState total _ _ _ _ built _) =
201 do msg <- readChan chan
202 case msg of
203 Just dmsg ->
204 detailsLoop chan =<< detailsStep dmsg state
206 Nothing ->
207 putStrLn $ clear (toBuildProgress total total) $
208 if built == total
209 then "Dependencies ready!"
210 else "Dependency problem!"
213data DState =
214 DState
215 { _total :: !Int
216 , _cached :: !Int
217 , _requested :: !Int
218 , _received :: !Int
219 , _failed :: !Int
220 , _built :: !Int
221 , _broken :: !Int
222 }
225data DMsg
226 = DStart Int
227 | DCached
228 | DRequested
229 | DReceived Pkg.Name V.Version
230 | DFailed Pkg.Name V.Version
231 | DBuilt
232 | DBroken
235detailsStep :: DMsg -> DState -> IO DState
236detailsStep msg (DState total cached rqst rcvd failed built broken) =
237 case msg of
238 DStart numDependencies ->
239 return (DState numDependencies 0 0 0 0 0 0)
241 DCached ->
242 putTransition (DState total (cached + 1) rqst rcvd failed built broken)
244 DRequested ->
245 do when (rqst == 0) (putStrLn "Starting downloads...\n")
246 return (DState total cached (rqst + 1) rcvd failed built broken)
248 DReceived pkg vsn ->
249 do putDownload goodMark pkg vsn
250 putTransition (DState total cached rqst (rcvd + 1) failed built broken)
252 DFailed pkg vsn ->
253 do putDownload badMark pkg vsn
254 putTransition (DState total cached rqst rcvd (failed + 1) built broken)
256 DBuilt ->
257 putBuilt (DState total cached rqst rcvd failed (built + 1) broken)
259 DBroken ->
260 putBuilt (DState total cached rqst rcvd failed built (broken + 1))
263putDownload :: D.Doc -> Pkg.Name -> V.Version -> IO ()
264putDownload mark pkg vsn =
265 Help.toStdout $ D.indent 2 $
266 mark
267 <+> D.fromPackage pkg
268 <+> D.fromVersion vsn
269 <> "\n"
272putTransition :: DState -> IO DState
273putTransition state@(DState total cached _ rcvd failed built broken) =
274 if cached + rcvd + failed < total then
275 return state
277 else
278 do let char = if rcvd + failed == 0 then '\r' else '\n'
279 putStrFlush (char : toBuildProgress (built + broken + failed) total)
280 return state
283putBuilt :: DState -> IO DState
284putBuilt state@(DState total cached _ rcvd failed built broken) =
285 do when (total == cached + rcvd + failed) $
286 putStrFlush $ '\r' : toBuildProgress (built + broken + failed) total
287 return state
290toBuildProgress :: Int -> Int -> [Char]
291toBuildProgress built total =
292 "Verifying dependencies (" ++ show built ++ "/" ++ show total ++ ")"
295clear :: [Char] -> [Char] -> [Char]
296clear before after =
297 '\r' : replicate (length before) ' ' ++ '\r' : after
301-- BUILD
304type BKey = Key BMsg
306type BResult a = Either Exit.BuildProblem a
309trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)
310trackBuild style callback =
311 case style of
312 Silent ->
313 callback (Key (\_ -> return ()))
315 Json ->
316 callback (Key (\_ -> return ()))
318 Terminal mvar ->
319 do chan <- newChan
321 _ <- forkIO $
322 do takeMVar mvar
323 putStrFlush "Compiling ..."
324 buildLoop chan 0
325 putMVar mvar ()
327 result <- callback (Key (writeChan chan . Left))
328 writeChan chan (Right result)
329 return result
332data BMsg
333 = BDone
336buildLoop :: Chan (Either BMsg (BResult a)) -> Int -> IO ()
337buildLoop chan done =
338 do msg <- readChan chan
339 case msg of
340 Left BDone ->
341 do let !done1 = done + 1
342 putStrFlush $ "\rCompiling (" ++ show done1 ++ ")"
343 buildLoop chan done1
345 Right result ->
346 let
347 !message = toFinalMessage done result
348 !width = 12 + length (show done)
349 in
350 putStrLn $
351 if length message < width
352 then '\r' : replicate width ' ' ++ '\r' : message
353 else '\r' : message
356toFinalMessage :: Int -> BResult a -> [Char]
357toFinalMessage done result =
358 case result of
359 Right _ ->
360 case done of
361 0 -> "Success!"
362 1 -> "Success! Compiled 1 module."
363 n -> "Success! Compiled " ++ show n ++ " modules."
365 Left problem ->
366 case problem of
367 Exit.BuildBadModules _ _ [] ->
368 "Detected problems in 1 module."
370 Exit.BuildBadModules _ _ (_:ps) ->
371 "Detected problems in " ++ show (2 + length ps) ++ " modules."
373 Exit.BuildProjectProblem _ ->
374 "Detected a problem."
378-- GENERATE
381reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO ()
382reportGenerate style names output =
383 case style of
384 Silent ->
385 return ()
387 Json ->
388 return ()
390 Terminal mvar ->
391 do readMVar mvar
392 let cnames = fmap ModuleName.toChars names
393 putStrLn ('\n' : toGenDiagram cnames output)
396toGenDiagram :: NE.List [Char] -> FilePath -> [Char]
397toGenDiagram (NE.List name names) output =
398 let
399 width = 3 + foldr (max . length) (length name) names
400 in
401 case names of
402 [] ->
403 toGenLine width name ('>' : ' ' : output ++ "\n")
405 _:_ ->
406 unlines $
407 toGenLine width name (vtop : hbar : hbar : '>' : ' ' : output)
408 : reverse (zipWith (toGenLine width) (reverse names) ([vbottom] : repeat [vmiddle]))
411toGenLine :: Int -> [Char] -> [Char] -> [Char]
412toGenLine width name end =
413 " " ++ name ++ ' ' : replicate (width - length name) hbar ++ end
416hbar :: Char
417hbar = if isWindows then '-' else '─'
419vtop :: Char
420vtop = if isWindows then '+' else '┬'
422vmiddle :: Char
423vmiddle = if isWindows then '+' else '┤'
425vbottom :: Char
426vbottom = if isWindows then '+' else '┘'
429--
432putStrFlush :: String -> IO ()
433putStrFlush str =
434 hPutStr stdout str >> hFlush stdout
438-- REPORT EXCEPTIONS NICELY
441reportExceptionsNicely :: SomeException -> IO a
442reportExceptionsNicely e =
443 case fromException e of
444 Just UserInterrupt -> throw e
445 _ -> putException e >> throw e
448putException :: SomeException -> IO ()
449putException e = do
450 hPutStrLn stderr ""
451 Help.toStderr $ D.stack $
452 [ D.dullyellow "-- ERROR -----------------------------------------------------------------------"
453 , D.reflow $
454 "I ran into something that bypassed the normal error reporting process!\
455 \ I extracted whatever information I could from the internal error:"
456 , D.vcat $ map (\line -> D.red ">" <> " " <> D.fromChars line) (lines (show e))
457 , D.reflow $
458 "These errors are usually pretty confusing, so start by asking around on one of\
459 \ forums listed at https://elm-lang.org/community to see if anyone can get you\
460 \ unstuck quickly."
461 , D.dullyellow "-- REQUEST ---------------------------------------------------------------------"
462 , D.reflow $
463 "If you are feeling up to it, please try to get your code down to the smallest\
464 \ version that still triggers this message. Ideally in a single Main.elm and\
465 \ elm.json file."
466 , D.reflow $
467 "From there open a NEW issue at https://github.com/elm/compiler/issues with\
468 \ your reduced example pasted in directly. (Not a link to a repo or gist!) Do not\
469 \ worry about if someone else saw something similar. More examples is better!"
470 , D.reflow $
471 "This kind of error is usually tied up in larger architectural choices that are\
472 \ hard to change, so even when we have a couple good examples, it can take some\
473 \ time to resolve in a solid way."
474 ]