git.iko.soy/elk
on master help sign in
promote dependencies properly with `elm install`
3d190f1Evan Czaplicki
builder/src/Elm/Bump.hs+2−3
compare with master
unifiedsplit
@@ -123,11 +123,10 @@ suggestVersion summary@(Summary.Summary root _ _ _ _) info@(Project.PkgInfo name
123
123
124changeVersion :: FilePath -> Project.PkgInfo -> Pkg.Version -> D.Doc -> Task.Task ()
124changeVersion :: FilePath -> Project.PkgInfo -> Pkg.Version -> D.Doc -> Task.Task ()
125changeVersion root info targetVersion explanation =
125changeVersion root info targetVersion explanation =
126− do liftIO $ Help.toStdout explanation
127− approved <- Task.getApproval
126+ do approved <- Task.getApproval explanation
128 if not approved
127 if not approved
129 then
128 then
130− liftIO $ putStrLn "Okay, no changes were made."
129+ liftIO $ putStrLn "Okay, I did not change anything!"
131
130
132 else
131 else
133 do liftIO $ Project.write root $ Project.Pkg $
132 do liftIO $ Project.write root $ Project.Pkg $
builder/src/Elm/Install.hs+128−84
@@ -7,13 +7,11 @@ module Elm.Install
7
7
8import Control.Monad (filterM, forM, msum, void)
8import Control.Monad (filterM, forM, msum, void)
9import Control.Monad.Except (catchError, lift, liftIO)
9import Control.Monad.Except (catchError, lift, liftIO)
10−import Data.Map (Map, (!))
10+import Data.Map ((!))
11import qualified Data.Map as Map
11import qualified Data.Map as Map
12import qualified Data.Map.Merge.Lazy as Map
12import qualified Data.Map.Merge.Lazy as Map
13−import System.IO (stdout)
14
13
15import qualified Elm.Package as Pkg
14import qualified Elm.Package as Pkg
16−import Elm.Package (Name, Version)
17
15
18import qualified Deps.Cache as Cache
16import qualified Deps.Cache as Cache
19import Deps.Explorer (Explorer)
17import Deps.Explorer (Explorer)
@@ -35,57 +33,133 @@ import qualified Reporting.Task as Task
35-- INSTALL
33-- INSTALL
36
34
37
35
38−install :: Name -> Task.Task ()
36+install :: Pkg.Name -> Task.Task ()
39install pkg =
37install pkg =
40 do (root, oldProject) <- Root.unsafeGet
38 do (root, oldProject) <- Root.unsafeGet
41− makePlan pkg oldProject $ \newProject ->
42− let
43− upgrade =
44− do liftIO $ Project.write root newProject
45− void $ Verify.verify root newProject
46
39
47− revert err =
40+ case oldProject of
48− do liftIO $ Project.write root oldProject
41+ Project.App info ->
49− Task.throw err
42+ do changes <- makeAppPlan pkg info
50− in
43+ attemptElmJsonChange root oldProject Pkg.versionToString changes
51− upgrade `catchError` revert
52
44
45+ Project.Pkg info ->
46+ do changes <- makePkgPlan pkg info
47+ attemptElmJsonChange root oldProject Con.toString changes
53
48
54
49
50+attemptElmJsonChange :: FilePath -> Project.Project -> (a -> String) -> Changes a -> Task.Task ()
51+attemptElmJsonChange root oldProject toString changes =
52+ let
53+ attempt newProject question =
54+ do approved <- Task.getApproval question
55+ if approved
56+ then upgrade newProject `catchError` revert
57+ else liftIO $ putStrLn "Okay, I did not change anything!"
58+
59+ upgrade newProject =
60+ do liftIO $ Project.write root newProject
61+ void $ Verify.verify root newProject
62+
63+ revert err =
64+ do liftIO $ Project.write root oldProject
65+ Task.throw err
66+ in
67+ case changes of
68+ AlreadyInstalled ->
69+ do liftIO $ putStrLn "It is already installed!"
70+
71+ PromoteTest newProject ->
72+ attempt newProject $ D.vcat $
73+ [ "I found it in your elm.json file!"
74+ , "In \"test-dependencies\" though."
75+ , "Should I move it into \"dependencies\" for more general use? [Y/n]: "
76+ ]
77+
78+ PromoteTrans newProject ->
79+ attempt newProject $ D.vcat $
80+ [ "I found it in your elm.json file!"
81+ , "In \"transitive-dependencies\" though."
82+ , "Should I move it into \"dependencies\" for more general use? [Y/n]: "
83+ ]
84+
85+ Changes changeDict newProject ->
86+ let
87+ widths = Map.foldrWithKey (widen toString) (Widths 0 0 0) changeDict
88+ changeDocs = Map.foldrWithKey (addChange toString widths) (Docs [] [] []) changeDict
89+ in
90+ attempt newProject $ D.vcat $
91+ [ "Here is my plan:"
92+ , viewChangeDocs changeDocs
93+ , ""
94+ , "Would you like me to update your elm.json accordingly? [Y/n]: "
95+ ]
96+
97+
98+
55−-- MAKE PLAN
99+-- MAKE PLANS
56−
100+
57−
101+
58−makePlan :: Name -> Project.Project -> (Project.Project -> Task.Task ()) -> Task.Task ()
102+data Changes vsn
59−makePlan pkg project attemptInstall =
103+ = AlreadyInstalled
60− case project of
104+ | PromoteTest Project.Project
105+ | PromoteTrans Project.Project
106+ | Changes (Map.Map Pkg.Name (Change vsn)) Project.Project
107+
108+
109+makeAppPlan :: Pkg.Name -> Project.AppInfo -> Task.Task (Changes Pkg.Version)
61− Project.App info@(Project.AppInfo elm srcDirs deps test trans) ->
110+makeAppPlan pkg info@(Project.AppInfo elm srcDirs deps test trans) =
62− do registry <- Cache.optionalUpdate
111+ if Map.member pkg deps then
63− changes <- addToApp registry pkg info
112+ return AlreadyInstalled
64−
113+ else
65− let news = Map.mapMaybe keepNew changes
114+ case Map.lookup pkg test of
66− let newDeps = addNews (Just pkg) news deps
115+ Just vsn ->
67− let newTest = addNews Nothing news test
116+ return $ PromoteTest $ Project.App $
68− let newTrans = Map.union (Map.difference news (Map.union newDeps newTest)) trans
117+ Project.AppInfo elm srcDirs (Map.insert pkg vsn deps) (Map.delete pkg test) trans
69− let newInfo = Project.AppInfo elm srcDirs newDeps newTest newTrans
70− let newProject = Project.App newInfo
71
118
72− withApproval Pkg.versionToString changes (attemptInstall newProject)
119+ Nothing ->
120+ case Map.lookup pkg trans of
121+ Just vsn ->
122+ return $ PromoteTrans $ Project.App $
123+ Project.AppInfo elm srcDirs (Map.insert pkg vsn deps) test (Map.delete pkg trans)
73
124
74− Project.Pkg info@(Project.PkgInfo _ _ _ _ _ deps test _) ->
125+ Nothing ->
75− do registry <- Cache.optionalUpdate
126+ do registry <- Cache.optionalUpdate
76− changes <- addToPkg registry pkg info
127+ changes <- addToApp registry pkg info
77
128
78− let news = Map.mapMaybe keepNew changes
129+ let news = Map.mapMaybe keepNew changes
79− let newProject = Project.Pkg $
80− info
81− { Project._pkg_deps = addNews (Just pkg) news deps
130+ let newDeps = addNews (Just pkg) news deps
82− , Project._pkg_test_deps = addNews Nothing news test
131+ let newTest = addNews Nothing news test
83− }
132+ let newTrans = Map.union (Map.difference news (Map.union newDeps newTest)) trans
84
133
85− withApproval (show . Con.toString) changes (attemptInstall newProject)
134+ return $ Changes changes $ Project.App $
135+ Project.AppInfo elm srcDirs newDeps newTest newTrans
86
136
87
137
138+makePkgPlan :: Pkg.Name -> Project.PkgInfo -> Task.Task (Changes Constraint)
139+makePkgPlan pkg info@(Project.PkgInfo _ _ _ _ _ deps test _) =
140+ if Map.member pkg deps then
141+ return AlreadyInstalled
142+ else
143+ case Map.lookup pkg test of
144+ Just con ->
145+ return $ PromoteTest $ Project.Pkg $
146+ info
147+ { Project._pkg_deps = Map.insert pkg con deps
148+ , Project._pkg_test_deps = Map.delete pkg test
149+ }
150+
151+ Nothing ->
152+ do registry <- Cache.optionalUpdate
153+ changes <- addToPkg registry pkg info
154+ let news = Map.mapMaybe keepNew changes
155+ return $ Changes changes $ Project.Pkg $
156+ info
157+ { Project._pkg_deps = addNews (Just pkg) news deps
158+ , Project._pkg_test_deps = addNews Nothing news test
159+ }
160+
161+
88−addNews :: Maybe Name -> Map Name a -> Map Name a -> Map Name a
162+addNews :: Maybe Pkg.Name -> Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Map.Map Pkg.Name a
89addNews pkg new old =
163addNews pkg new old =
90 Map.merge
164 Map.merge
91 Map.preserveMissing
165 Map.preserveMissing
@@ -105,7 +179,7 @@ data Change a
105 | Remove a
179 | Remove a
106
180
107
181
108−detectChanges :: (Eq a) => Map Name a -> Map Name a -> Map Name (Change a)
182+detectChanges :: (Eq a) => Map.Map Pkg.Name a -> Map.Map Pkg.Name a -> Map.Map Pkg.Name (Change a)
109detectChanges old new =
183detectChanges old new =
110 Map.merge
184 Map.merge
111 (Map.mapMissing (\_ v -> Remove v))
185 (Map.mapMissing (\_ v -> Remove v))
@@ -140,7 +214,7 @@ keepNew change =
140-- ADD TO APP
214-- ADD TO APP
141
215
142
216
143−addToApp :: Cache.PackageRegistry -> Name -> Project.AppInfo -> Task.Task (Map Name (Change Version))
217+addToApp :: Cache.PackageRegistry -> Pkg.Name -> Project.AppInfo -> Task.Task (Map.Map Pkg.Name (Change Pkg.Version))
144addToApp registry pkg info@(Project.AppInfo _ _ deps tests trans) =
218addToApp registry pkg info@(Project.AppInfo _ _ deps tests trans) =
145 Explorer.run registry $
219 Explorer.run registry $
146 do Explorer.exists pkg
220 do Explorer.exists pkg
@@ -155,7 +229,7 @@ addToApp registry pkg info@(Project.AppInfo _ _ deps tests trans) =
155 lift $ Task.throw (Exit.Install (E.NoSolution badNames))
229 lift $ Task.throw (Exit.Install (E.NoSolution badNames))
156
230
157
231
158−addToAppHelp :: Name -> Project.AppInfo -> Solver.Solver (Map Name Version)
232+addToAppHelp :: Pkg.Name -> Project.AppInfo -> Solver.Solver (Map.Map Pkg.Name Pkg.Version)
159addToAppHelp pkg (Project.AppInfo _ _ deps tests trans) =
233addToAppHelp pkg (Project.AppInfo _ _ deps tests trans) =
160 let
234 let
161 directs =
235 directs =
@@ -180,7 +254,7 @@ addToAppHelp pkg (Project.AppInfo _ _ deps tests trans) =
180-- ADD TO PKG
254-- ADD TO PKG
181
255
182
256
183−addToPkg :: Cache.PackageRegistry -> Name -> Project.PkgInfo -> Task.Task (Map Name (Change Constraint))
257+addToPkg :: Cache.PackageRegistry -> Pkg.Name -> Project.PkgInfo -> Task.Task (Map.Map Pkg.Name (Change Constraint))
184addToPkg registry pkg info@(Project.PkgInfo _ _ _ _ _ deps tests _) =
258addToPkg registry pkg info@(Project.PkgInfo _ _ _ _ _ deps tests _) =
185 Explorer.run registry $
259 Explorer.run registry $
186 do Explorer.exists pkg
260 do Explorer.exists pkg
@@ -196,7 +270,7 @@ addToPkg registry pkg info@(Project.PkgInfo _ _ _ _ _ deps tests _) =
196 lift $ Task.throw (Exit.Install (E.NoSolution badNames))
270 lift $ Task.throw (Exit.Install (E.NoSolution badNames))
197
271
198
272
199−addToPkgHelp :: Name -> Project.PkgInfo -> Solver.Solver (Map Name Constraint)
273+addToPkgHelp :: Pkg.Name -> Project.PkgInfo -> Solver.Solver (Map.Map Pkg.Name Constraint)
200addToPkgHelp pkg (Project.PkgInfo _ _ _ _ _ deps tests _) =
274addToPkgHelp pkg (Project.PkgInfo _ _ _ _ _ deps tests _) =
201 do let directs = Map.union deps tests
275 do let directs = Map.union deps tests
202 let newCons = Map.insert pkg Con.anything directs
276 let newCons = Map.insert pkg Con.anything directs
@@ -209,7 +283,7 @@ addToPkgHelp pkg (Project.PkgInfo _ _ _ _ _ deps tests _) =
209-- FAILURE HINTS
283-- FAILURE HINTS
210
284
211
285
212−isBadElm :: Name -> Explorer Bool
286+isBadElm :: Pkg.Name -> Explorer Bool
213isBadElm name =
287isBadElm name =
214 do versions <- Explorer.getVersions name
288 do versions <- Explorer.getVersions name
215
289
@@ -220,36 +294,6 @@ isBadElm name =
220
294
221
295
222
296
223−-- VIEW
224−
225−
226−withApproval :: (a -> String) -> Map Name (Change a) -> Task.Task () -> Task.Task ()
227−withApproval toString changes attemptInstall =
228− let
229− widths =
230− Map.foldrWithKey (widen toString) (Widths 0 0 0) changes
231−
232− changeDocs =
233− Map.foldrWithKey (addChange toString widths) (Docs [] [] []) changes
234− in
235− case changeDocs of
236− Docs [] [] [] ->
237− do liftIO $ putStrLn "Already installed. No changes necessary!"
238−
239− Docs inserts [] [] ->
240− do liftIO $ putStrLn "Adding the following dependencies:\n"
241− liftIO $ D.toAnsi stdout $ D.indent 2 (D.vcat (reverse inserts))
242− liftIO $ putStrLn "\n"
243− attemptInstall
244−
245− Docs _ _ _ ->
246− do liftIO $ putStrLn "Here is my plan:"
247− liftIO $ D.toAnsi stdout $ viewChangeDocs changeDocs
248− liftIO $ putStrLn "\nDo you approve? [Y/n]: "
249− Task.withApproval attemptInstall
250−
251−
252−
253-- VIEW CHANGE DOCS
297-- VIEW CHANGE DOCS
254
298
255
299
@@ -285,7 +329,7 @@ viewNonZero title entries =
285-- VIEW CHANGE
329-- VIEW CHANGE
286
330
287
331
288−addChange :: (a -> String) -> Widths -> Name -> Change a -> ChangeDocs -> ChangeDocs
332+addChange :: (a -> String) -> Widths -> Pkg.Name -> Change a -> ChangeDocs -> ChangeDocs
289addChange toString widths name change (Docs inserts changes removes) =
333addChange toString widths name change (Docs inserts changes removes) =
290 case change of
334 case change of
291 Insert new ->
335 Insert new ->
@@ -298,12 +342,12 @@ addChange toString widths name change (Docs inserts changes removes) =
298 Docs inserts changes (viewRemove toString widths name old : removes)
342 Docs inserts changes (viewRemove toString widths name old : removes)
299
343
300
344
301−viewInsert :: (a -> String) -> Widths -> Name -> a -> D.Doc
345+viewInsert :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc
302viewInsert toString (Widths nameWidth leftWidth _) name new =
346viewInsert toString (Widths nameWidth leftWidth _) name new =
303 viewName nameWidth name <+> pad leftWidth (toString new)
347 viewName nameWidth name <+> pad leftWidth (toString new)
304
348
305
349
306−viewChange :: (a -> String) -> Widths -> Name -> a -> a -> D.Doc
350+viewChange :: (a -> String) -> Widths -> Pkg.Name -> a -> a -> D.Doc
307viewChange toString (Widths nameWidth leftWidth rightWidth) name old new =
351viewChange toString (Widths nameWidth leftWidth rightWidth) name old new =
308 D.hsep
352 D.hsep
309 [ viewName nameWidth name
353 [ viewName nameWidth name
@@ -313,12 +357,12 @@ viewChange toString (Widths nameWidth leftWidth rightWidth) name old new =
313 ]
357 ]
314
358
315
359
316−viewRemove :: (a -> String) -> Widths -> Name -> a -> D.Doc
360+viewRemove :: (a -> String) -> Widths -> Pkg.Name -> a -> D.Doc
317viewRemove toString (Widths nameWidth leftWidth _) name old =
361viewRemove toString (Widths nameWidth leftWidth _) name old =
318 viewName nameWidth name <+> pad leftWidth (toString old)
362 viewName nameWidth name <+> pad leftWidth (toString old)
319
363
320
364
321−viewName :: Int -> Name -> D.Doc
365+viewName :: Int -> Pkg.Name -> D.Doc
322viewName width name =
366viewName width name =
323 D.fill (width + 3) (D.fromText (Pkg.toText name))
367 D.fill (width + 3) (D.fromText (Pkg.toText name))
324
368
@@ -340,7 +384,7 @@ data Widths =
340 }
384 }
341
385
342
386
343−widen :: (a -> String) -> Name -> Change a -> Widths -> Widths
387+widen :: (a -> String) -> Pkg.Name -> Change a -> Widths -> Widths
344widen toString pkg change (Widths name left right) =
388widen toString pkg change (Widths name left right) =
345 let
389 let
346 toLength a =
390 toLength a =
builder/src/Reporting/Progress.hs+14−3
@@ -13,10 +13,11 @@ module Reporting.Progress
13
13
14
14
15import Control.Concurrent.Chan (Chan, writeChan)
15import Control.Concurrent.Chan (Chan, writeChan)
16−import Control.Concurrent.MVar (MVar, readMVar)
16+import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar)
17import qualified Elm.Compiler.Module as Module
17import qualified Elm.Compiler.Module as Module
18import Deps.Diff (Magnitude)
18import Deps.Diff (Magnitude)
19import Elm.Package (Name, Version)
19import Elm.Package (Name, Version)
20+import qualified Reporting.Doc as D
20import Reporting.Exit (Exit)
21import Reporting.Exit (Exit)
21
22
22
23
@@ -27,6 +28,7 @@ import Reporting.Exit (Exit)
27data Reporter =
28data Reporter =
28 Reporter
29 Reporter
29 { _tell :: Progress -> IO ()
30 { _tell :: Progress -> IO ()
31+ , _ask :: D.Doc -> IO Bool
30 , _end :: Maybe Exit -> IO ()
32 , _end :: Maybe Exit -> IO ()
31 }
33 }
32
34
@@ -37,17 +39,23 @@ makeReporter chan mvar =
37 tell progress =
39 tell progress =
38 writeChan chan (Progress progress)
40 writeChan chan (Progress progress)
39
41
42+ ask doc =
43+ do var <- newEmptyMVar
44+ writeChan chan (Ask doc var)
45+ readMVar var
46+
40 end maybeError =
47 end maybeError =
41 do writeChan chan (End maybeError)
48 do writeChan chan (End maybeError)
42 readMVar mvar
49 readMVar mvar
43 in
50 in
44− Reporter tell end
51+ Reporter tell ask end
45
52
46
53
47silentReporter :: Reporter
54silentReporter :: Reporter
48silentReporter =
55silentReporter =
49 Reporter
56 Reporter
50 (\_ -> return ())
57 (\_ -> return ())
58+ (\_ -> return True)
51 (\_ -> return ())
59 (\_ -> return ())
52
60
53
61
@@ -55,7 +63,10 @@ silentReporter =
55-- MESSAGES
63-- MESSAGES
56
64
57
65
66+data Msg
58−data Msg = Progress Progress | End (Maybe Exit)
67+ = Progress Progress
68+ | Ask D.Doc (MVar Bool)
69+ | End (Maybe Exit)
59
70
60
71
61data Progress
72data Progress
builder/src/Reporting/Progress/Json.hs+4−1
@@ -18,7 +18,10 @@ import qualified Json.Encode as Encode
18
18
19reporter :: Progress.Reporter
19reporter :: Progress.Reporter
20reporter =
20reporter =
21− Progress.Reporter (\_ -> return ()) end
21+ Progress.Reporter
22+ (\_ -> return ())
23+ (\_ -> return True)
24+ end
22
25
23
26
24end :: Maybe Exit.Exit -> IO ()
27end :: Maybe Exit.Exit -> IO ()
builder/src/Reporting/Progress/Repl.hs+4−1
@@ -14,7 +14,10 @@ import qualified Reporting.Progress as Progress
14
14
15reporter :: Progress.Reporter
15reporter :: Progress.Reporter
16reporter =
16reporter =
17− Progress.Reporter (\_ -> return ()) end
17+ Progress.Reporter
18+ (\_ -> return ())
19+ (\_ -> return True)
20+ end
18
21
19
22
20end :: Maybe Exit.Exit -> IO ()
23end :: Maybe Exit.Exit -> IO ()
builder/src/Reporting/Progress/Terminal.hs+19
@@ -62,10 +62,29 @@ loop chan state =
62 End Nothing ->
62 End Nothing ->
63 return ()
63 return ()
64
64
65+ Ask doc mvar ->
66+ do Help.toStdout doc
67+ putMVar mvar =<< getApproval
68+ loop chan state
69+
65 Progress progress ->
70 Progress progress ->
66 loopHelp chan progress state
71 loopHelp chan progress state
67
72
68
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+
69loopHelp :: Chan Msg -> Progress -> State -> IO ()
88loopHelp :: Chan Msg -> Progress -> State -> IO ()
70loopHelp chan progress state@(State total good bad) =
89loopHelp chan progress state@(State total good bad) =
71 case progress of
90 case progress of
builder/src/Reporting/Task.hs+19−33
@@ -10,7 +10,6 @@ module Reporting.Task
10 , getPackageCacheDirFor
10 , getPackageCacheDirFor
11 , report
11 , report
12 , getReporter
12 , getReporter
13− , withApproval
14 , getApproval
13 , getApproval
15 , silently
14 , silently
16 , getSilentRunner
15 , getSilentRunner
@@ -23,18 +22,18 @@ import Control.Concurrent (forkIO)
23import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
22import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
24import Control.Monad (forever, join, replicateM_)
23import Control.Monad (forever, join, replicateM_)
25import Control.Monad.Except (ExceptT, runExceptT, throwError, withExceptT)
24import Control.Monad.Except (ExceptT, runExceptT, throwError, withExceptT)
26−import Control.Monad.Reader (ReaderT, runReaderT, ask, asks)
25+import qualified Control.Monad.Reader as R
27import Control.Monad.Trans (liftIO)
26import Control.Monad.Trans (liftIO)
28import qualified Network.HTTP.Client as Http
27import qualified Network.HTTP.Client as Http
29import qualified Network.HTTP.Client.TLS as Http
28import qualified Network.HTTP.Client.TLS as Http
30import qualified System.Directory as Dir
29import qualified System.Directory as Dir
31import qualified System.Exit as Exit
30import qualified System.Exit as Exit
32import System.FilePath ((</>))
31import System.FilePath ((</>))
33−import qualified System.IO as IO
34
32
35import Elm.Package (Name, Version)
33import Elm.Package (Name, Version)
36import qualified Elm.Package as Pkg
34import qualified Elm.Package as Pkg
37import qualified Elm.PerUserCache as PerUserCache
35import qualified Elm.PerUserCache as PerUserCache
36+import qualified Reporting.Doc as D
38import qualified Reporting.Exit as Exit
37import qualified Reporting.Exit as Exit
39import qualified Reporting.Progress as Progress
38import qualified Reporting.Progress as Progress
40
39
@@ -48,7 +47,7 @@ type Task =
48
47
49
48
50type Task_ e =
49type Task_ e =
51− ExceptT e (ReaderT Env IO)
50+ ExceptT e (R.ReaderT Env IO)
52
51
53
52
54data Env =
53data Env =
@@ -57,16 +56,17 @@ data Env =
57 , _worker :: IO () -> IO ()
56 , _worker :: IO () -> IO ()
58 , _httpManager :: Http.Manager
57 , _httpManager :: Http.Manager
59 , _tell :: Progress.Progress -> IO ()
58 , _tell :: Progress.Progress -> IO ()
59+ , _ask :: D.Doc -> IO Bool
60 }
60 }
61
61
62
62
63try :: Progress.Reporter -> Task a -> IO (Maybe a)
63try :: Progress.Reporter -> Task a -> IO (Maybe a)
64−try (Progress.Reporter tell end) task =
64+try (Progress.Reporter tell ask end) task =
65 do root <- PerUserCache.getPackageRoot
65 do root <- PerUserCache.getPackageRoot
66 pool <- initPool 4
66 pool <- initPool 4
67 httpManager <- Http.newManager Http.tlsManagerSettings
67 httpManager <- Http.newManager Http.tlsManagerSettings
68− let env = Env root pool httpManager tell
68+ let env = Env root pool httpManager tell ask
69− result <- runReaderT (runExceptT task) env
69+ result <- R.runReaderT (runExceptT task) env
70 case result of
70 case result of
71 Left err ->
71 Left err ->
72 do end (Just err)
72 do end (Just err)
@@ -101,7 +101,7 @@ mapError =
101
101
102getPackageCacheDir :: Task_ e FilePath
102getPackageCacheDir :: Task_ e FilePath
103getPackageCacheDir =
103getPackageCacheDir =
104− asks _cacheDir
104+ R.asks _cacheDir
105
105
106
106
107getPackageCacheDirFor :: Name -> Version -> Task_ e FilePath
107getPackageCacheDirFor :: Name -> Version -> Task_ e FilePath
@@ -118,37 +118,23 @@ getPackageCacheDirFor name version =
118
118
119report :: Progress.Progress -> Task_ e ()
119report :: Progress.Progress -> Task_ e ()
120report progress =
120report progress =
121− do tell <- asks _tell
121+ do tell <- R.asks _tell
122 liftIO (tell progress)
122 liftIO (tell progress)
123
123
124
124
125getReporter :: Task (Progress.Progress -> IO ())
125getReporter :: Task (Progress.Progress -> IO ())
126getReporter =
126getReporter =
127− asks _tell
127+ R.asks _tell
128
128
129
129
130
130
131-- APPROVAL
131-- APPROVAL
132
132
133
133
134−withApproval :: Task_ e () -> Task_ e ()
135−withApproval task =
136− do approval <- getApproval
137− if approval then task else return ()
138−
139−
140−getApproval :: Task_ e Bool
134+getApproval :: D.Doc -> Task_ e Bool
141−getApproval =
135+getApproval doc =
142− do liftIO $ IO.hFlush IO.stdout
136+ do ask <- R.asks _ask
143− input <- liftIO getLine
137+ liftIO (ask doc)
144− case input of
145− "" -> return True
146− "Y" -> return True
147− "y" -> return True
148− "n" -> return False
149− _ ->
150− do liftIO $ putStr "Must type 'y' for yes or 'n' for no: "
151− getApproval
152
138
153
139
154
140
@@ -164,9 +150,9 @@ silently task =
164
150
165getSilentRunner :: Task_ x (Task_ e a -> IO (Either e a))
151getSilentRunner :: Task_ x (Task_ e a -> IO (Either e a))
166getSilentRunner =
152getSilentRunner =
167− do env <- ask
153+ do env <- R.ask
168 let silentEnv = env { _tell = \_ -> return () }
154 let silentEnv = env { _tell = \_ -> return () }
169− return $ \task -> runReaderT (runExceptT task) silentEnv
155+ return $ \task -> R.runReaderT (runExceptT task) silentEnv
170
156
171
157
172
158
@@ -175,10 +161,10 @@ getSilentRunner =
175
161
176workerChan :: Chan (Either e a) -> Task_ e a -> Task_ x ()
162workerChan :: Chan (Either e a) -> Task_ e a -> Task_ x ()
177workerChan chan task =
163workerChan chan task =
178− do env <- ask
164+ do env <- R.ask
179
165
180 liftIO $ _worker env $
166 liftIO $ _worker env $
181− do result <- runReaderT (runExceptT task) env
167+ do result <- R.runReaderT (runExceptT task) env
182 writeChan chan result
168 writeChan chan result
183
169
184
170
@@ -198,6 +184,6 @@ initPool size =
198
184
199runHttp :: (Http.Manager -> (Progress.Progress -> IO ()) -> IO (Either Exit.Exit a)) -> Task a
185runHttp :: (Http.Manager -> (Progress.Progress -> IO ()) -> IO (Either Exit.Exit a)) -> Task a
200runHttp fetcher =
186runHttp fetcher =
201− do (Env _ _ manager tell) <- ask
187+ do (Env _ _ manager tell _) <- R.ask
202 result <- liftIO $ fetcher manager tell
188 result <- liftIO $ fetcher manager tell
203 either throwError return result
189 either throwError return result
ui/terminal/src/Develop.hs+1−1
@@ -163,7 +163,7 @@ compileToHtmlBuilder file =
163 do mvar1 <- newEmptyMVar
163 do mvar1 <- newEmptyMVar
164 mvar2 <- newEmptyMVar
164 mvar2 <- newEmptyMVar
165
165
166− let reporter = Progress.Reporter (\_ -> return ()) (putMVar mvar1)
166+ let reporter = Progress.Reporter (\_ -> return ()) (\_ -> return True) (putMVar mvar1)
167 let output = Just (Output.HtmlBuilder mvar2)
167 let output = Just (Output.HtmlBuilder mvar2)
168
168
169 void $ Task.try reporter $
169 void $ Task.try reporter $