@@ -0,0 +1,379 @@
1+{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2+module Reporting
3+ ( Style
4+ , json
5+ , terminal
6+ --
7+ , attempt
8+ , exit
9+ --
10+ , Key
11+ , report
12+ --
13+ , DKey
14+ , DMsg(..)
15+ , trackDetails
16+ --
17+ , BKey
18+ , BMsg(..)
19+ , trackBuild
20+ --
21+ , reportGenerate
22+ )
23+ where
24+
25+
26+import Control.Concurrent
27+import Control.Monad (when)
28+import qualified Data.ByteString.Builder as B
29+import qualified Data.NonEmptyList as NE
30+import qualified System.Exit as Exit
31+import qualified System.Info as Info
32+import System.IO (hFlush, hPutStr, stderr, stdout)
33+
34+import qualified Elm.ModuleName as ModuleName
35+import qualified Elm.Package as Pkg
36+import qualified Elm.Version as V
37+import qualified Json.Encode as Encode
38+import Reporting.Doc ((<+>), (<>))
39+import qualified Reporting.Doc as D
40+import qualified Reporting.Exit as Exit
41+import qualified Reporting.Exit.Help as Help
42+
43+
44+
45+-- STYLE
46+
47+
48+data Style
49+ = Json
50+ | Terminal (MVar ())
51+
52+
53+json :: Style
54+json =
55+ Json
56+
57+
58+terminal :: IO Style
59+terminal =
60+ Terminal <$> newMVar ()
61+
62+
63+
64+-- ATTEMPT
65+
66+
67+attempt :: Style -> IO (Either Help.Report a) -> IO a
68+attempt style work =
69+ do result <- work
70+ case result of
71+ Right a -> return a
72+ Left ex -> exit style ex
73+
74+
75+exit :: Style -> Help.Report -> IO a
76+exit style rep =
77+ case style of
78+ Json ->
79+ do B.hPutBuilder stderr (Encode.encodeUgly (Exit.toJson rep))
80+ Exit.exitFailure
81+
82+ Terminal mvar ->
83+ do readMVar mvar
84+ Exit.toStderr rep
85+ Exit.exitFailure
86+
87+
88+
89+-- MARKS
90+
91+
92+goodMark :: D.Doc
93+goodMark =
94+ D.green $ if isWindows then "+" else "●"
95+
96+
97+badMark :: D.Doc
98+badMark =
99+ D.red $ if isWindows then "X" else "✗"
100+
101+
102+_waitingMark :: D.Doc
103+_waitingMark =
104+ D.dullyellow $ if isWindows then "-" else "→"
105+
106+
107+isWindows :: Bool
108+isWindows =
109+ Info.os == "mingw32"
110+
111+
112+
113+-- KEY
114+
115+
116+newtype Key msg = Key (msg -> IO ())
117+
118+
119+report :: Key msg -> msg -> IO ()
120+report (Key send) msg =
121+ send msg
122+
123+
124+
125+-- DETAILS
126+
127+
128+type DKey = Key DMsg
129+
130+
131+trackDetails :: Style -> (DKey -> IO a) -> IO a
132+trackDetails style callback =
133+ case style of
134+ Json ->
135+ callback (Key (\_ -> return ()))
136+
137+ Terminal mvar ->
138+ do chan <- newChan
139+
140+ _ <- forkIO $
141+ do takeMVar mvar
142+ detailsLoop chan (DState 0 0 0 0 0 0 0)
143+ putMVar mvar ()
144+
145+ answer <- callback (Key (writeChan chan . Just))
146+ writeChan chan Nothing
147+ return answer
148+
149+
150+detailsLoop :: Chan (Maybe DMsg) -> DState -> IO ()
151+detailsLoop chan state@(DState total _ _ _ _ built _) =
152+ do msg <- readChan chan
153+ case msg of
154+ Just dmsg ->
155+ detailsLoop chan =<< detailsStep dmsg state
156+
157+ Nothing ->
158+ putStrLn $ clear (toBuildProgress total total) $
159+ if built == total
160+ then "Dependencies ready!"
161+ else "Dependency problem!"
162+
163+
164+data DState =
165+ DState
166+ { _total :: !Int
167+ , _cached :: !Int
168+ , _requested :: !Int
169+ , _received :: !Int
170+ , _failed :: !Int
171+ , _built :: !Int
172+ , _broken :: !Int
173+ }
174+
175+
176+data DMsg
177+ = DStart Int
178+ | DCached
179+ | DRequested
180+ | DReceived Pkg.Name V.Version
181+ | DFailed Pkg.Name V.Version
182+ | DBuilt
183+ | DBroken
184+
185+
186+detailsStep :: DMsg -> DState -> IO DState
187+detailsStep msg (DState total cached rqst rcvd failed built broken) =
188+ case msg of
189+ DStart numDependencies ->
190+ return (DState numDependencies 0 0 0 0 0 0)
191+
192+ DCached ->
193+ putTransition (DState total (cached + 1) rqst rcvd failed built broken)
194+
195+ DRequested ->
196+ do when (rqst == 0) (putStrLn "Starting downloads...\n")
197+ return (DState total cached (rqst + 1) rcvd failed built broken)
198+
199+ DReceived pkg vsn ->
200+ do putDownload goodMark pkg vsn
201+ putTransition (DState total cached rqst (rcvd + 1) failed built broken)
202+
203+ DFailed pkg vsn ->
204+ do putDownload badMark pkg vsn
205+ putTransition (DState total cached rqst rcvd (failed + 1) built broken)
206+
207+ DBuilt ->
208+ putBuilt (DState total cached rqst rcvd failed (built + 1) broken)
209+
210+ DBroken ->
211+ putBuilt (DState total cached rqst rcvd failed built (broken + 1))
212+
213+
214+putDownload :: D.Doc -> Pkg.Name -> V.Version -> IO ()
215+putDownload mark pkg vsn =
216+ Help.toStdout $ D.indent 2 $
217+ mark
218+ <+> D.fromUtf8 (Pkg.toString pkg)
219+ <+> D.fromUtf8 (V.toString vsn)
220+ <> "\n"
221+
222+
223+putTransition :: DState -> IO DState
224+putTransition state@(DState total cached _ rcvd failed built broken) =
225+ if cached + rcvd + failed < total then
226+ return state
227+
228+ else
229+ do let char = if rcvd + failed == 0 then '\r' else '\n'
230+ putStrFlush (char : toBuildProgress (built + broken + failed) total)
231+ return state
232+
233+
234+putBuilt :: DState -> IO DState
235+putBuilt state@(DState total cached _ rcvd failed built broken) =
236+ do when (total == cached + rcvd + failed) $
237+ putStrFlush $ '\r' : toBuildProgress (built + broken + failed) total
238+ return state
239+
240+
241+toBuildProgress :: Int -> Int -> [Char]
242+toBuildProgress built total =
243+ "Verifying dependencies (" ++ show built ++ "/" ++ show total ++ ")"
244+
245+
246+clear :: [Char] -> [Char] -> [Char]
247+clear before after =
248+ '\r' : replicate (length before) ' ' ++ '\r' : after
249+
250+
251+
252+-- BUILD
253+
254+
255+type BKey = Key BMsg
256+
257+type BResult a = Either Exit.BuildProblem a
258+
259+
260+trackBuild :: Style -> (BKey -> IO (BResult a)) -> IO (BResult a)
261+trackBuild style callback =
262+ case style of
263+ Json ->
264+ callback (Key (\_ -> return ()))
265+
266+ Terminal mvar ->
267+ do chan <- newChan
268+
269+ _ <- forkIO $
270+ do takeMVar mvar
271+ putStrFlush "Compiling ..."
272+ buildLoop chan 0
273+ putMVar mvar ()
274+
275+ result <- callback (Key (writeChan chan . Left))
276+ writeChan chan (Right result)
277+ return result
278+
279+
280+data BMsg
281+ = BDone
282+
283+
284+buildLoop :: Chan (Either BMsg (BResult a)) -> Int -> IO ()
285+buildLoop chan done =
286+ do msg <- readChan chan
287+ case msg of
288+ Left BDone ->
289+ do let !done1 = done + 1
290+ putStrFlush $ "\rCompiling (" ++ show done1 ++ ")"
291+ buildLoop chan done1
292+
293+ Right result ->
294+ let
295+ !message = toFinalMessage done result
296+ !width = 12 + length (show done)
297+ in
298+ putStrLn $
299+ if length message < width
300+ then '\r' : replicate width ' ' ++ '\r' : message
301+ else '\r' : message
302+
303+
304+toFinalMessage :: Int -> BResult a -> [Char]
305+toFinalMessage done result =
306+ case result of
307+ Right _ ->
308+ case done of
309+ 0 -> "Success!"
310+ 1 -> "Success! Compiled 1 module."
311+ n -> "Success! Compiled " ++ show n ++ " modules."
312+
313+ Left problem ->
314+ case problem of
315+ Exit.BuildModuleProblems _ [] ->
316+ "Detected problems in 1 module."
317+
318+ Exit.BuildModuleProblems _ (_:ps) ->
319+ "Detected problems in " ++ show (2 + length ps) ++ " modules."
320+
321+ Exit.BuildProjectProblem _ ->
322+ "Detected a problem."
323+
324+
325+
326+-- GENERATE
327+
328+
329+reportGenerate :: Style -> NE.List ModuleName.Raw -> FilePath -> IO ()
330+reportGenerate style names output =
331+ case style of
332+ Json ->
333+ return ()
334+
335+ Terminal mvar ->
336+ do readMVar mvar
337+ let cnames = fmap ModuleName.toChars names
338+ putStrLn ('\n' : toGenDiagram cnames output)
339+
340+
341+toGenDiagram :: NE.List [Char] -> FilePath -> [Char]
342+toGenDiagram (NE.List name names) output =
343+ let
344+ width = 3 + foldr (max . length) (length name) names
345+ in
346+ case names of
347+ [] ->
348+ toGenLine width name ('>' : ' ' : output ++ "\n")
349+
350+ _:_ ->
351+ unlines $
352+ toGenLine width name (vtop : hbar : hbar : '>' : ' ' : output)
353+ : reverse (zipWith (toGenLine width) (reverse names) ([vbottom] : repeat [vmiddle]))
354+
355+
356+toGenLine :: Int -> [Char] -> [Char] -> [Char]
357+toGenLine width name end =
358+ " " ++ name ++ ' ' : replicate (width - length name) hbar ++ end
359+
360+
361+hbar :: Char
362+hbar = if isWindows then '-' else '─'
363+
364+vtop :: Char
365+vtop = if isWindows then '+' else '┬'
366+
367+vmiddle :: Char
368+vmiddle = if isWindows then '+' else '┤'
369+
370+vbottom :: Char
371+vbottom = if isWindows then '+' else '┘'
372+
373+
374+--
375+
376+
377+putStrFlush :: String -> IO ()
378+putStrFlush str =
379+ hPutStr stdout str >> hFlush stdout