git.iko.soy/elk
on 233cfc8 help sign in
elk/builder/src/Reporting/Progress/Terminal.hs
402 lines 10 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Reporting.Progress.Terminal
3 ( create
4 , newPackageOverview
5 )
6 where
9import Control.Concurrent (forkIO)
10import Control.Concurrent.Chan (Chan, newChan, readChan)
11import Control.Concurrent.MVar (newEmptyMVar, putMVar)
12import qualified System.Info as Info
13import System.IO (hFlush, hPutStr, stdout)
14import qualified Elm.Package as Pkg
15import Elm.Package (Name, Version)
17import qualified Deps.Diff as Diff
18import Reporting.Doc ((<>), (<+>))
19import qualified Reporting.Doc as D
20import qualified Reporting.Exit as Exit
21import qualified Reporting.Exit.Help as Help
22import Reporting.Progress (Msg(..), Progress(..), Outcome(..), PublishPhase(..), BumpPhase(..))
23import qualified Reporting.Progress as Progress
24import qualified Reporting.Progress.Bar as Bar
28-- CREATE
31create :: IO Progress.Reporter
32create =
33 do chan <- newChan
34 mvar <- newEmptyMVar
35 _ <- forkIO (loop chan (State 0 0 0) >>= putMVar mvar)
36 return (Progress.makeReporter chan mvar)
40-- STATE
43data State =
44 State
45 { _total :: !Int
46 , _good :: !Int
47 , _bad :: !Int
48 }
52-- LOOP
55loop :: Chan Msg -> State -> IO ()
56loop chan state =
57 do msg <- readChan chan
58 case msg of
59 End (Just exit) ->
60 Exit.toStderr exit
62 End Nothing ->
63 return ()
65 Ask doc mvar ->
66 do Help.toStdout doc
67 putMVar mvar =<< getApproval
68 loop chan state
70 Progress progress ->
71 loopHelp chan progress state
74getApproval :: IO Bool
75getApproval =
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
88loopHelp :: Chan Msg -> Progress -> State -> IO ()
89loopHelp chan progress state@(State total good bad) =
90 case progress of
93 -- ELM.JSON
95 ElmJsonApproved ->
96 do putStrLn ""
97 Help.toStdout $ D.fillSep $
98 [ "Done!","And","check","out"
99 ,D.green "<https://guide.elm-lang.org>"
100 ,"to","learn","what","to","do","next!"
101 ]
102 putStrLn "\n"
103 Help.toStdout $ D.black $ D.vcat $
104 [ "--------------------------------------------------------------------------------"
105 , "-------------------- Now back to what you were doing before --------------------"
106 , "--------------------------------------------------------------------------------"
107 ]
108 putStrLn "\n"
109 loop chan state
111 ElmJsonRejected ->
112 do putStrLn "\nOkay, I did not create anything.\n"
113 loop chan state
116 -- DOWNLOADS
118 DownloadSkip ->
119 do putStrLn "Dependencies loaded from local cache."
120 loop chan state
122 DownloadStart [] ->
123 loop chan state
125 DownloadStart _ ->
126 do putStrLn "Starting downloads...\n"
127 loop chan state
129 DownloadPkgStart _name _version ->
130 loop chan state
132 DownloadPkgEnd name version outcome ->
133 do Help.toStdout (makeBullet name version outcome)
134 loop chan state
136 DownloadEnd Bad ->
137 do putStrLn ""
138 loop chan state
140 DownloadEnd Good ->
141 do putStrLn ""
142 loop chan state
145 -- BUILD DEPS
147 BuildDepsStart size ->
148 do hPutStr stdout "Verifying dependencies..."
149 hFlush stdout
150 loop chan (State size 0 0)
152 BuildDepsProgress ->
153 do let n = good + 1
154 let msg = "\rBuilding dependencies (" ++ show n ++ "/" ++ show total ++ ")"
155 hPutStr stdout msg
156 hFlush stdout
157 loop chan (State total n 0)
159 BuildDepsEnd ->
160 do putStrLn "\rDependencies ready! "
161 loop chan (State 0 0 0)
164 -- COMPILE
166 CompileStart size ->
167 loop chan (State size 0 0)
169 CompileFileStart _ ->
170 loop chan state
172 CompileFileEnd _ Good ->
173 do hPutStr stdout $ Bar.render (good + 1) bad total
174 hFlush stdout
175 loop chan (State total (good + 1) bad)
177 CompileFileEnd _ Bad ->
178 do hPutStr stdout $ Bar.render good (bad + 1) total
179 hFlush stdout
180 loop chan (State total good (bad + 1))
182 CompileEnd ->
183 let
184 message =
185 case (bad, total) of
186 (0, 0) -> "Success!"
187 (0, 1) -> "Success! Compiled 1 module."
188 (0, n) -> "Success! Compiled " ++ show n ++ " modules."
189 (1, _) -> "Detected errors in 1 module."
190 (n, _) -> "Detected errors in " ++ show n ++ " modules."
191 in
192 do hPutStr stdout $ Bar.clear
193 putStrLn message
194 loop chan (State 0 0 0)
197 -- PUBLISH
199 PublishStart name version maybePublishedVersions ->
200 case maybePublishedVersions of
201 Nothing ->
202 do putStrLn newPackageOverview
203 putStrLn "I will now verify that everything is in order..."
204 putStrLn ""
205 loop chan state
207 Just _ ->
208 do putStrLn $ unwords [ "Verifying", Pkg.toString name, Pkg.versionToString version, "..." ]
209 putStrLn ""
210 loop chan state
212 PublishCheckBump version bumpPhase ->
213 do Help.toStdout $ bumpPhaseToChecklistDoc version bumpPhase
214 hFlush stdout
215 loop chan state
217 PublishProgress phase status ->
218 do Help.toStdout $ toChecklistDoc status (toChecklistMessages phase)
219 hFlush stdout
220 loop chan state
222 PublishEnd ->
223 do putStrLn "Success!"
224 loop chan state
227 -- SOLVER
229 UnableToLoadLatestPackages ->
230 do putStrLn ""
231 Help.toStdout $ D.dullyellow "WARNING:" <+> "I normally check <https://package.elm-lang.org> for new packages\n"
232 putStrLn "here, but my request failed. Are you offline? I will try to continue anyway.\n"
233 loop chan state
237-- BULLETS
240makeBullet :: Name -> Version -> Outcome -> D.Doc
241makeBullet name version outcome =
242 let
243 nm = D.fromText (Pkg.toText name)
244 vsn = D.fromText (Pkg.versionToText version)
246 bullet =
247 case outcome of
248 Good -> goodMark
249 Bad -> badMark
250 in
251 D.indent 2 $ bullet <+> nm <+> vsn <> "\n"
254goodMark :: D.Doc
255goodMark =
256 D.green $
257 if Info.os == "mingw32" then "+" else "●"
260badMark :: D.Doc
261badMark =
262 D.red $
263 if Info.os == "mingw32" then "X" else "✗"
266waitingMark :: D.Doc
267waitingMark =
268 D.dullyellow $
269 if Info.os == "mingw32" then "-" else "→"
273-- OVERVIEW OF VERSIONING
276newPackageOverview :: String
277newPackageOverview =
278 unlines
279 [ "This package has never been published before. Here's how things work:"
280 , ""
281 , " - Versions all have exactly three parts: MAJOR.MINOR.PATCH"
282 , ""
283 , " - All packages start with initial version " ++ Pkg.versionToString Pkg.initialVersion
284 , ""
285 , " - Versions are incremented based on how the API changes:"
286 , ""
287 , " PATCH = the API is the same, no risk of breaking code"
288 , " MINOR = values have been added, existing values are unchanged"
289 , " MAJOR = existing values have been changed or removed"
290 , ""
291 , " - I will bump versions for you, automatically enforcing these rules"
292 , ""
293 ]
297-- CHECKLIST
300toChecklistDoc :: Maybe Outcome -> ChecklistMessages -> D.Doc
301toChecklistDoc status (ChecklistMessages waiting success failure) =
302 let
303 padded message =
304 message ++ replicate (length waiting - length message) ' '
305 in
306 case status of
307 Nothing ->
308 " " <> waitingMark <+> D.fromString waiting
310 Just Good ->
311 "\r " <> goodMark <+> D.fromString (padded success ++ "\n")
313 Just Bad ->
314 "\r " <> badMark <+> D.fromString (padded failure ++ "\n\n")
317data ChecklistMessages =
318 ChecklistMessages
319 { _waiting :: String
320 , _success :: String
321 , _failure :: String
322 }
325toChecklistMessages :: PublishPhase -> ChecklistMessages
326toChecklistMessages phase =
327 case phase of
328 CheckReadme ->
329 ChecklistMessages
330 "Looking for README.md"
331 "Found README.md"
332 "Problem with your README.md"
334 CheckLicense ->
335 ChecklistMessages
336 "Looking for LICENSE"
337 "Found LICENSE"
338 "Problem with your LICENSE"
340 CheckTag version ->
341 ChecklistMessages
342 ("Is version " ++ Pkg.versionToString version ++ " tagged on GitHub?")
343 ("Version " ++ Pkg.versionToString version ++ " is tagged on GitHub")
344 ("Version " ++ Pkg.versionToString version ++ " is not tagged on GitHub!")
346 CheckDownload ->
347 ChecklistMessages
348 "Downloading code from GitHub..."
349 "Code downloaded successfully from GitHub"
350 "Could not download code from GitHub!"
352 CheckBuild ->
353 ChecklistMessages
354 "Building downloaded code and generated docs..."
355 "Downloaded code compiles successfully / docs generated\n"
356 "Cannot compile downloaded code!"
358 CheckChanges ->
359 ChecklistMessages
360 "Checking for uncommitted changes..."
361 "No uncommitted changes in local code"
362 "Your local code is different than the code tagged on GitHub"
366-- BUMP PHASE
369bumpPhaseToChecklistDoc :: Pkg.Version -> BumpPhase -> D.Doc
370bumpPhaseToChecklistDoc version bumpPhase =
371 let
372 mkMsgs success =
373 ChecklistMessages
374 ("Checking semantic versioning rules. Is " ++ Pkg.versionToString version ++ " correct?")
375 success
376 ("Version " ++ Pkg.versionToString version ++ " is not correct!")
377 in
379 case bumpPhase of
380 StatedVersion ->
381 toChecklistDoc Nothing $ mkMsgs ""
383 GoodStart ->
384 toChecklistDoc (Just Good) $ mkMsgs $
385 "All packages start at version " ++ Pkg.versionToString Pkg.initialVersion
387 GoodBump old magnitude ->
388 toChecklistDoc (Just Good) $ mkMsgs $
389 toCheckVersionSuccessMessage old version magnitude
391 BadBump ->
392 toChecklistDoc (Just Bad) $ mkMsgs ""
395toCheckVersionSuccessMessage :: Pkg.Version -> Pkg.Version -> Diff.Magnitude -> String
396toCheckVersionSuccessMessage oldVersion newVersion magnitude =
397 let
398 old = Pkg.versionToString oldVersion
399 new = Pkg.versionToString newVersion
400 mag = Diff.magnitudeToString magnitude
401 in
402 "Version number " ++ new ++ " verified (" ++ mag ++ " change, " ++ old ++ " => " ++ new ++ ")"