@@ -1,379 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Reporting.Progress.Terminal
3− ( create
4− , newPackageOverview
5− )
6− where
7−
8−
9−import Control.Concurrent (forkIO)
10−import Control.Concurrent.Chan (Chan, newChan, readChan)
11−import Control.Concurrent.MVar (newEmptyMVar, putMVar)
12−import qualified System.Info as Info
13−import System.IO (hFlush, hPutStr, stdout)
14−import qualified Elm.Package as Pkg
15−import qualified Elm.Version as V
16−
17−import qualified Deps.Diff as Diff
18−import Reporting.Doc ((<>), (<+>))
19−import qualified Reporting.Doc as D
20−import qualified Reporting.Exit as Exit
21−import qualified Reporting.Exit.Help as Help
22−import Reporting.Progress (Msg(..), Progress(..), Outcome(..), PublishPhase(..), BumpPhase(..))
23−import qualified Reporting.Progress as Progress
24−import qualified Reporting.Progress.Bar as Bar
25−
26−
27−
28−-- CREATE
29−
30−
31−create :: IO Progress.Reporter
32−create =
33− do chan <- newChan
34− mvar <- newEmptyMVar
35− _ <- forkIO (loop chan (State 0 0 0) >>= putMVar mvar)
36− return (Progress.makeReporter chan mvar)
37−
38−
39−
40−-- STATE
41−
42−
43−data State =
44− State
45− { _total :: !Int
46− , _good :: !Int
47− , _bad :: !Int
48− }
49−
50−
51−
52−-- LOOP
53−
54−
55−loop :: Chan Msg -> State -> IO ()
56−loop chan state =
57− do msg <- readChan chan
58− case msg of
59− End (Just exit) ->
60− Exit.toStderr exit
61−
62− End Nothing ->
63− return ()
64−
65− Ask doc mvar ->
66− do Help.toStdout doc
67− putMVar mvar =<< getApproval
68− loop chan state
69−
70− Progress progress ->
71− loopHelp chan progress state
72−
73−
74−getApproval :: IO Bool
75−getApproval =
76− do hFlush stdout
77− input <- getLine
78− case input of
79− "" -> return True
80− "Y" -> return True
81− "y" -> return True
82− "n" -> return False
83− _ ->
84− do putStr "Must type 'y' for yes or 'n' for no: "
85− getApproval
86−
87−
88−loopHelp :: Chan Msg -> Progress -> State -> IO ()
89−loopHelp chan progress state@(State total good bad) =
90− case progress of
91−
92−
93− -- DOWNLOADS
94−
95− DownloadSkip ->
96− do putStrLn "Dependencies loaded from local cache."
97− loop chan state
98−
99− DownloadStart [] ->
100− loop chan state
101−
102− DownloadStart _ ->
103− do putStrLn "Starting downloads...\n"
104− loop chan state
105−
106− DownloadPkgStart _name _version ->
107− loop chan state
108−
109− DownloadPkgEnd name version outcome ->
110− do Help.toStdout (makeBullet name version outcome)
111− loop chan state
112−
113− DownloadEnd Bad ->
114− do putStrLn ""
115− loop chan state
116−
117− DownloadEnd Good ->
118− do putStrLn ""
119− loop chan state
120−
121−
122− -- BUILD DEPS
123−
124− BuildDepsStart size ->
125− do hPutStr stdout "Verifying dependencies..."
126− hFlush stdout
127− loop chan (State size 0 0)
128−
129− BuildDepsProgress ->
130− do let n = good + 1
131− let msg = "\rBuilding dependencies (" ++ show n ++ "/" ++ show total ++ ")"
132− hPutStr stdout msg
133− hFlush stdout
134− loop chan (State total n 0)
135−
136− BuildDepsEnd ->
137− do putStrLn "\rDependencies ready! "
138− loop chan (State 0 0 0)
139−
140−
141− -- COMPILE
142−
143− CompileStart size ->
144− loop chan (State size 0 0)
145−
146− CompileFileStart _ ->
147− loop chan state
148−
149− CompileFileEnd _ Good ->
150− do hPutStr stdout $ Bar.render (good + 1) bad total
151− hFlush stdout
152− loop chan (State total (good + 1) bad)
153−
154− CompileFileEnd _ Bad ->
155− do hPutStr stdout $ Bar.render good (bad + 1) total
156− hFlush stdout
157− loop chan (State total good (bad + 1))
158−
159− CompileEnd ->
160− let
161− message =
162− case (bad, total) of
163− (0, 0) -> "Success!"
164− (0, 1) -> "Success! Compiled 1 module."
165− (0, n) -> "Success! Compiled " ++ show n ++ " modules."
166− (1, _) -> "Detected errors in 1 module."
167− (n, _) -> "Detected errors in " ++ show n ++ " modules."
168− in
169− do hPutStr stdout $ Bar.clear
170− putStrLn message
171− loop chan (State 0 0 0)
172−
173−
174− -- PUBLISH
175−
176− PublishStart name version maybePublishedVersions ->
177− case maybePublishedVersions of
178− Nothing ->
179− do putStrLn newPackageOverview
180− putStrLn "I will now verify that everything is in order..."
181− putStrLn ""
182− loop chan state
183−
184− Just _ ->
185− do putStrLn $ unwords [ "Verifying", Pkg.toChars name, V.toChars version, "..." ]
186− putStrLn ""
187− loop chan state
188−
189− PublishCheckBump version bumpPhase ->
190− do Help.toStdout $ bumpPhaseToChecklistDoc version bumpPhase
191− hFlush stdout
192− loop chan state
193−
194− PublishProgress phase status ->
195− do Help.toStdout $ toChecklistDoc status (toChecklistMessages phase)
196− hFlush stdout
197− loop chan state
198−
199− PublishEnd ->
200− do putStrLn "Success!"
201− loop chan state
202−
203−
204− -- SOLVER
205−
206− UnableToLoadLatestPackages ->
207− do putStrLn ""
208− Help.toStdout $ D.dullyellow "WARNING:" <+> "I normally check <https://package.elm-lang.org> for new packages\n"
209− putStrLn "here, but my request failed. Are you offline? I will try to continue anyway.\n"
210− loop chan state
211−
212−
213−
214−-- BULLETS
215−
216−
217−makeBullet :: Pkg.Name -> V.Version -> Outcome -> D.Doc
218−makeBullet name version outcome =
219− let
220− nm = D.fromUtf8 (Pkg.toString name)
221− vsn = D.fromUtf8 (V.toString version)
222−
223− bullet =
224− case outcome of
225− Good -> goodMark
226− Bad -> badMark
227− in
228− D.indent 2 $ bullet <+> nm <+> vsn <> "\n"
229−
230−
231−goodMark :: D.Doc
232−goodMark =
233− D.green $
234− if Info.os == "mingw32" then "+" else "●"
235−
236−
237−badMark :: D.Doc
238−badMark =
239− D.red $
240− if Info.os == "mingw32" then "X" else "✗"
241−
242−
243−waitingMark :: D.Doc
244−waitingMark =
245− D.dullyellow $
246− if Info.os == "mingw32" then "-" else "→"
247−
248−
249−
250−-- OVERVIEW OF VERSIONING
251−
252−
253−newPackageOverview :: String
254−newPackageOverview =
255− unlines
256− [ "This package has never been published before. Here's how things work:"
257− , ""
258− , " - Versions all have exactly three parts: MAJOR.MINOR.PATCH"
259− , ""
260− , " - All packages start with initial version " ++ V.toChars V.one
261− , ""
262− , " - Versions are incremented based on how the API changes:"
263− , ""
264− , " PATCH = the API is the same, no risk of breaking code"
265− , " MINOR = values have been added, existing values are unchanged"
266− , " MAJOR = existing values have been changed or removed"
267− , ""
268− , " - I will bump versions for you, automatically enforcing these rules"
269− , ""
270− ]
271−
272−
273−
274−-- CHECKLIST
275−
276−
277−toChecklistDoc :: Maybe Outcome -> ChecklistMessages -> D.Doc
278−toChecklistDoc status (ChecklistMessages waiting success failure) =
279− let
280− padded message =
281− message ++ replicate (length waiting - length message) ' '
282− in
283− case status of
284− Nothing ->
285− " " <> waitingMark <+> D.fromChars waiting
286−
287− Just Good ->
288− "\r " <> goodMark <+> D.fromChars (padded success ++ "\n")
289−
290− Just Bad ->
291− "\r " <> badMark <+> D.fromChars (padded failure ++ "\n\n")
292−
293−
294−data ChecklistMessages =
295− ChecklistMessages
296− { _waiting :: String
297− , _success :: String
298− , _failure :: String
299− }
300−
301−
302−toChecklistMessages :: PublishPhase -> ChecklistMessages
303−toChecklistMessages phase =
304− case phase of
305− CheckReadme ->
306− ChecklistMessages
307− "Looking for README.md"
308− "Found README.md"
309− "Problem with your README.md"
310−
311− CheckLicense ->
312− ChecklistMessages
313− "Looking for LICENSE"
314− "Found LICENSE"
315− "Problem with your LICENSE"
316−
317− CheckTag version ->
318− ChecklistMessages
319− ("Is version " ++ V.toChars version ++ " tagged on GitHub?")
320− ("Version " ++ V.toChars version ++ " is tagged on GitHub")
321− ("Version " ++ V.toChars version ++ " is not tagged on GitHub!")
322−
323− CheckDownload ->
324− ChecklistMessages
325− "Downloading code from GitHub..."
326− "Code downloaded successfully from GitHub"
327− "Could not download code from GitHub!"
328−
329− CheckBuild ->
330− ChecklistMessages
331− "Building downloaded code and generated docs..."
332− "Downloaded code compiles successfully / docs generated\n"
333− "Cannot compile downloaded code!"
334−
335− CheckChanges ->
336− ChecklistMessages
337− "Checking for uncommitted changes..."
338− "No uncommitted changes in local code"
339− "Your local code is different than the code tagged on GitHub"
340−
341−
342−
343−-- BUMP PHASE
344−
345−
346−bumpPhaseToChecklistDoc :: V.Version -> BumpPhase -> D.Doc
347−bumpPhaseToChecklistDoc version bumpPhase =
348− let
349− mkMsgs success =
350− ChecklistMessages
351− ("Checking semantic versioning rules. Is " ++ V.toChars version ++ " correct?")
352− success
353− ("Version " ++ V.toChars version ++ " is not correct!")
354− in
355−
356− case bumpPhase of
357− StatedVersion ->
358− toChecklistDoc Nothing $ mkMsgs ""
359−
360− GoodStart ->
361− toChecklistDoc (Just Good) $ mkMsgs $
362− "All packages start at version " ++ V.toChars V.one
363−
364− GoodBump old magnitude ->
365− toChecklistDoc (Just Good) $ mkMsgs $
366− toCheckVersionSuccessMessage old version magnitude
367−
368− BadBump ->
369− toChecklistDoc (Just Bad) $ mkMsgs ""
370−
371−
372−toCheckVersionSuccessMessage :: V.Version -> V.Version -> Diff.Magnitude -> String
373−toCheckVersionSuccessMessage oldVersion newVersion magnitude =
374− let
375− old = V.toChars oldVersion
376− new = V.toChars newVersion
377− mag = Diff.magnitudeToString magnitude
378− in
379− "Version number " ++ new ++ " verified (" ++ mag ++ " change, " ++ old ++ " => " ++ new ++ ")"