git.iko.soy/elk
on efe80bc help sign in
elk/builder/src/Reporting/Progress/Terminal.hs
379 lines 9.5 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 qualified Elm.Version as V
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 -- DOWNLOADS
95 DownloadSkip ->
96 do putStrLn "Dependencies loaded from local cache."
97 loop chan state
99 DownloadStart [] ->
100 loop chan state
102 DownloadStart _ ->
103 do putStrLn "Starting downloads...\n"
104 loop chan state
106 DownloadPkgStart _name _version ->
107 loop chan state
109 DownloadPkgEnd name version outcome ->
110 do Help.toStdout (makeBullet name version outcome)
111 loop chan state
113 DownloadEnd Bad ->
114 do putStrLn ""
115 loop chan state
117 DownloadEnd Good ->
118 do putStrLn ""
119 loop chan state
122 -- BUILD DEPS
124 BuildDepsStart size ->
125 do hPutStr stdout "Verifying dependencies..."
126 hFlush stdout
127 loop chan (State size 0 0)
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)
136 BuildDepsEnd ->
137 do putStrLn "\rDependencies ready! "
138 loop chan (State 0 0 0)
141 -- COMPILE
143 CompileStart size ->
144 loop chan (State size 0 0)
146 CompileFileStart _ ->
147 loop chan state
149 CompileFileEnd _ Good ->
150 do hPutStr stdout $ Bar.render (good + 1) bad total
151 hFlush stdout
152 loop chan (State total (good + 1) bad)
154 CompileFileEnd _ Bad ->
155 do hPutStr stdout $ Bar.render good (bad + 1) total
156 hFlush stdout
157 loop chan (State total good (bad + 1))
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)
174 -- PUBLISH
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
184 Just _ ->
185 do putStrLn $ unwords [ "Verifying", Pkg.toChars name, V.toChars version, "..." ]
186 putStrLn ""
187 loop chan state
189 PublishCheckBump version bumpPhase ->
190 do Help.toStdout $ bumpPhaseToChecklistDoc version bumpPhase
191 hFlush stdout
192 loop chan state
194 PublishProgress phase status ->
195 do Help.toStdout $ toChecklistDoc status (toChecklistMessages phase)
196 hFlush stdout
197 loop chan state
199 PublishEnd ->
200 do putStrLn "Success!"
201 loop chan state
204 -- SOLVER
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
214-- BULLETS
217makeBullet :: Pkg.Name -> V.Version -> Outcome -> D.Doc
218makeBullet name version outcome =
219 let
220 nm = D.fromUtf8 (Pkg.toString name)
221 vsn = D.fromUtf8 (V.toString version)
223 bullet =
224 case outcome of
225 Good -> goodMark
226 Bad -> badMark
227 in
228 D.indent 2 $ bullet <+> nm <+> vsn <> "\n"
231goodMark :: D.Doc
232goodMark =
233 D.green $
234 if Info.os == "mingw32" then "+" else "●"
237badMark :: D.Doc
238badMark =
239 D.red $
240 if Info.os == "mingw32" then "X" else "✗"
243waitingMark :: D.Doc
244waitingMark =
245 D.dullyellow $
246 if Info.os == "mingw32" then "-" else "→"
250-- OVERVIEW OF VERSIONING
253newPackageOverview :: String
254newPackageOverview =
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 ]
274-- CHECKLIST
277toChecklistDoc :: Maybe Outcome -> ChecklistMessages -> D.Doc
278toChecklistDoc 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
287 Just Good ->
288 "\r " <> goodMark <+> D.fromChars (padded success ++ "\n")
290 Just Bad ->
291 "\r " <> badMark <+> D.fromChars (padded failure ++ "\n\n")
294data ChecklistMessages =
295 ChecklistMessages
296 { _waiting :: String
297 , _success :: String
298 , _failure :: String
299 }
302toChecklistMessages :: PublishPhase -> ChecklistMessages
303toChecklistMessages phase =
304 case phase of
305 CheckReadme ->
306 ChecklistMessages
307 "Looking for README.md"
308 "Found README.md"
309 "Problem with your README.md"
311 CheckLicense ->
312 ChecklistMessages
313 "Looking for LICENSE"
314 "Found LICENSE"
315 "Problem with your LICENSE"
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!")
323 CheckDownload ->
324 ChecklistMessages
325 "Downloading code from GitHub..."
326 "Code downloaded successfully from GitHub"
327 "Could not download code from GitHub!"
329 CheckBuild ->
330 ChecklistMessages
331 "Building downloaded code and generated docs..."
332 "Downloaded code compiles successfully / docs generated\n"
333 "Cannot compile downloaded code!"
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"
343-- BUMP PHASE
346bumpPhaseToChecklistDoc :: V.Version -> BumpPhase -> D.Doc
347bumpPhaseToChecklistDoc 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
356 case bumpPhase of
357 StatedVersion ->
358 toChecklistDoc Nothing $ mkMsgs ""
360 GoodStart ->
361 toChecklistDoc (Just Good) $ mkMsgs $
362 "All packages start at version " ++ V.toChars V.one
364 GoodBump old magnitude ->
365 toChecklistDoc (Just Good) $ mkMsgs $
366 toCheckVersionSuccessMessage old version magnitude
368 BadBump ->
369 toChecklistDoc (Just Bad) $ mkMsgs ""
372toCheckVersionSuccessMessage :: V.Version -> V.Version -> Diff.Magnitude -> String
373toCheckVersionSuccessMessage 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 ++ ")"